view modules/llcompile.tp @ 347:ff7ea11b4b60

Add length method to executable bytearrays
author Michael Pavone <pavone@retrodev.com>
date Fri, 10 Apr 2015 00:48:12 -0700
parents f987bb2a1911
children f74ce841fd1e
line wrap: on
line source
{
	_compileError <- :_msg _line {
		#{
			isError? <- { true }
			msg <- { _msg }
			line <- { _line }
		}
	}

	_notError <- :vals ifnoterr {
		if: (object does: vals understand?: "find") {
			maybeErr <- vals find: :val {
				(object does: val understand?: "isError?") && val isError?
			}
			maybeErr value: :err {
				err
			} none: ifnoterr
		} else: ifnoterr
	}

	_ilFun <- :_name {
		_buff <- #[]
		_blockStack <- []
		_nextReg <- 0
		#{
			name <- { _name }
			add <- :inst { _buff append: inst }
			getReg <- {
				r <- il reg: _nextReg
				_nextReg <- _nextReg + 1
				r
			}
			startBlock <- {
				_blockStack <- _buff | _blockStack
				_buff <- #[]
			}
			popBlock <- {
				res <- _buff
				_buff <- _blockStack value
				_blockStack <- _blockStack tail
				res
			}
			buffer <- { _buff }
		}
	}

	_exprHandlers <- false
	_compileExpr:syms:ilfun:dest <- :expr :syms :ilf :dst {
		_exprHandlers ifget: (expr nodeType) :handler {
			handler: expr syms ilf dst
		} else: {
			_compileError: "Expression with node type " . (expr nodeType) . " not implemented yet"
		}
	}
	_opMap <- false

	_compOps <- false

	_compileBinary <- :expr syms ilf assignTo {
		_assignSize? <- false
		_asize <- 0
		dest <- option value: assignTo :asn {
			_assignSize? <- true
			_asize <- asn size
			asn
		} none: {
			ilf getReg
		}
		l <- _compileExpr: (expr left) syms: syms ilfun: ilf assign: (option value: dest)
		r <- _compileExpr: (expr right) syms: syms ilfun: ilf assign: (option none)
		_notError: [(l) (r)] {
			lv <- l val
			ls <- l size
			rv <- r val
			rs <- r size
			_size <- if: ls > rs { ls } else: { rs }
			_signed <- (ls signed?) || (rs signed?)
			_opMap ifget: (expr op) :ingen {
				ilf add: (ingen: lv rv (dest val) _size)
				#{
					val <- dest
					size <- _size
					signed? <- _signed
				}
			} else: {
				_compOps ifget: (expr op) :cond {
					ilf add: (il bool: cond dest)
					#{
						val <- dest
						size <- il b
						signed? <- false
					}
				} else: {
					_compileError: "Operator " . (expr op) . " is not supported yet\n" 0
				}
			}
		}
	}
	_compileString <- :expr syms ilf assignTo {

	}
	_compileInt <- :expr syms ilf assignTo {
		expr
	}
	_compileSym <- :expr syms ilf assignTo {
		syms ifDefined: (expr name) :def {
			def
		} else: {
			_compileError: "Symbol " . (expr name) . " is not defined in " . (ilf name)
		}
	}
	_compileIf <- :expr syms ilf assignTo {
		if: ((expr args) length) != 2 {
			_compileError: "if takes exactly 2 arguments" 0
		} else: {
			condArg <- (expr args) value
			blockArg <- ((expr args) tail) value
			cond <- _compileExpr: condArg syms: syms ilfun: ilf dest: (option none)
			_notError: [cond] {
				if: (blockArg nodeType) != (ast lambda) {
					_compileError: "second argument to if must be a lambda"
				} else: {
					ilf add: (il cmp: condArg 0 (condArg size))
					//TODO: Deal with if in return position
					ilf startBlock
					foreach: (blockArg expressions) :idx expr{
						_compileExpr: expr syms: syms ilfun: ilf dest: (option none)
					}
					block <- ilf popBlock
					ilf add: (il skipIf: (il neq) block)
				}
			}
		}
	}
	_compileIfElse <- :expr syms ilf assignTo {
		if: ((expr args) length) != 2 {
			_compileError: "if takes exactly 2 arguments" 0
		} else: {
			condArg <- (expr args) value
			blockArg <- ((expr args) tail) value
			elseArg <- (((expr args) tail) tail) value
			cond <- _compileExpr: condArg syms: syms ilfun: ilf dest: (option none)
			_notError: [cond] {
				if: (blockArg nodeType) != (ast lambda) {
					_compileError: "second argument to if:else must be a lambda"
				} else: {
					if: (elseArg nodeType) != (ast lambda) {
						_compileError: "third argument to if:else must be a lambda"
					} else: {
						ilf add: (il cmp: condArg 0 (condArg size))
						//TODO: Deal with if:else in return position
						ilf startBlock
						foreach: (blockArg expressions) :idx expr {
							_compileExpr: expr syms: syms ilfun: ilf dest: (option none)
						}
						block <- ilf popBlock
						ilf startBlock
						foreach: (elseArg expressions) :idx expr {
							_compileExpr: expr syms: syms ilfun: ilf dest: (option none)
						}
						elseblock <- ilf popBlock
						ilf add: (il skipIf: (il neq) block else: elseblock)
					}
				}
			}
		}
	}
	_funMap <- false
	_compileCall <- :expr syms ilf assignTo {
		if: ((expr tocall) nodeType) = (ast sym) && (_funMap contains?: ((expr tocall) name)) {
			handler <- _funMap get: ((expr tocall) name) else: { false }
			handler: expr syms ilf assignTo
		} else: {
			ctocall <- _compileExpr: (expr tocall) syms: syms ilfuN: ilf dest: (option none)
			cargs <- (expr args) map: :arg {
				_compileExpr: arg syms: syms ilfun: ilf dest: (option none)
			}
			_notError: ctocall | cargs {
				ilf add: (il call: ctocall withArgs: cargs)
				il retr
			}
		}
	}

	_compileAssign <- :expr syms ilf assignTo {
		dest <- _compileExpr: (expr to) syms: syms ilfun: ilf dest: (option none)
		_notError: [dest] {
			value <- _compileExpr: (expr assign) syms: syms ilfun: ilf dest: dest
			_notError: [value] {
				//TODO: adjust size of value if necessary
				ilf add: (il mov: (value val) (dest val) (dest size))
				value
			}
		}
	}

	_initDone? <- false
	#{
		import: [
			binary
			stringlit
			intlit
			sym
			call
			obj
			sequence
			assignment
			lambda
		] from: ast
		_initHandlers <- {
			if: (not: _initDone?) {
				_exprHandlers <- dict hash
				_exprHandlers set: binary _compileBinary
				_exprHandlers set: stringlit _compileString
				_exprHandlers set: intlit _compileInt
				_exprHandlers set: sym _compileSym
				_exprHandlers set: assignment _compileAssign
				_exprHandlers set: call _compileCall

				_opMap <- dict hash
				mapOp <- macro: :op ilfun {
					quote: (_opMap set: op :ina inb out size {
						il ilfun: ina inb out size
					})
				}
				mapOp: "+" add
				mapOp: "-" sub
				mapOp: "*" mul
				mapOp: "/" div
				mapOp: "and" band
				mapOp: "or" bor
				mapOp: "xor" bxor

				_compOps <- dict hash
				_compOps set: "=" :signed? { il eq }
				_compOps set: "!=" :signed? { il ne }
				_compOps set: ">" :signed? { if: signed? { il gr } else: { il ugr } }
				_compOps set: "<" :signed? { if: signed? { il ls } else: { il uls } }
				_compOps set: ">=" :signed? { if: signed? { il ge } else: { il uge } }
				_compOps set: "<=" :signed? { if: signed? { il le } else: { il ule } }

				_funMap <- dict hash
				_funMap set: "if" _compileIf
				_funMap set: "if:else" _compileIfElse
				//_funMap set: "while:do" _compileWhileDo
			}
		}

		llFun:syms:vars:code <- :name :syms :vars :code{
			_initHandlers:
			syms <- symbols tableWithParent: syms
			argnames <- dict hash
			foreach: (code args) :idx arg {
				if: (arg startsWith?: ":") {
					arg <- arg from: 1
				}
				argnames set: arg true
			}
			ilf <- _ilFun: name
			_nextReg <- 0
			foreach: vars :idx var {
				type <- _parseType: (var assign)
				varname <- ((var to) name)
				v <- argnames ifget: varname :argnum {
					il arg: argnum
				} else: {
					ilf getReg
				}
				syms define: varname #{
					val <- v
					size <- (type size)
				}
			}
			last <- option none
			numexprs <- code length
			foreach: code :idx expr {
				asn <- option none
				if: idx = numexprs - 1 {
					option value: (il retr)
				}
				last <- option value: (_compileExpr: expr syms: syms ilfun: ilf dest: asn)
			}
			last value: :v {
				ilf add: (il return: (v val) (v size))
			} none: {
				ilf add: (il return: 0 (il l))
			}
			ilf
		}

		compileText <- :text {
			res <- parser top: text
			if: res {
				tree <- res yield
				if: (tree nodeType) = obj {
					errors <- []
					syms <- symbols table
					functions <- tree messages fold: [] :curfuncs msg {
						if: (msg nodeType) = call {
							if: ((msg tocall) name) = "llFun:withVars:andCode" {
								if: ((msg args) length) = 3 {
									fname <- ((msg args) get: 0) name
									syms define: fname #{
										type <- "topfun"
									}
									#{
										name <- fname
										vars <- (msg args) get: 1
										body <- (msg args) get: 2
									} | curfuncs
								} else: {
									errors <- (
										_compileError: "llFun:withVars:andCode takes exactly 3 arguments" 0
									) | errors
									curfuncs
								}
							} else: {
								errors <- (
									_compileError: "Only llFun:withVars:andCode expressions are allowed in top level object" 0
								) | errors
								curfuncs
							}
						} else: {
							errors <- (
								_compileError: "Only call expresions are allowed in top level object" 0
							) | errors
							curfuncs
						}
					}
					if: (errors empty?) {
						fmap <- functions fold: (dict hash) with: :acc func {
							_notError: acc {
								ilf <- llFun: (func name) syms: syms vars: (func vars) code: (func body)
								_notError: ilf {
									acc set: (func name) (ilf buffer)
								}
							}
						}
						fmap toBackend: x86
					} else: {
						errors
					}
				} else: {
					[(_compileError: "Top level must be an object in llcompile dialect" 1)]
				}
			} else: {
				[(_compileError: "Failed to parse file" 0)]
			}
		}

		main <- :args {
			if: (length: args) > 1 {
				text <- (file open: (args get: 1)) readAll
				mcode <- compileText: text
				_notError: mcode {
					ba <- bytearray executableFromBytes: mcode
					arg <- if: (length: args) > 2 { int32: (args get: 2) } else: {0}
					ba runWithArg: (arg i64)
				}
			} else: {
				(file stderr) write: "Usage: llcompile FILE\n"
				1
			}
		}
	}
}