view modules/llcompile.tp @ 354:a6cdcc1b1c02

Fix il and llcompile modules enough that it actually attempts to run the compiled program
author Michael Pavone <pavone@retrodev.com>
date Wed, 15 Apr 2015 20:08:38 -0700
parents 95bc24c729e6
children 3b023e5a0b42
line wrap: on
line source

{
	_compileError <- :_msg _line {
		#{
			isError? <- { true }
			msg <- { _msg }
			line <- { _line }
		}
	}

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

	_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 }
		}
	}
	
	_sizeMap <- dict hash
	_sizeMap set: "8" (il b)
	_sizeMap set: "16" (il w)
	_sizeMap set: "32" (il l)
	_sizeMap set: "64" (il q)
	
	_parseType <- :expr {
		if: (expr nodeType) = (ast sym) {
			name <- expr name
			_signed? <- true
			if: (name startsWith?: "u") {
				_signed? <- false
				name <- name from: 1
			}
			if: (name startsWith?: "int") &&  ((name length) <= 5) {
				size <- name from: 3
				_sizeMap ifget: size :llsize {
					#{
						size <- llsize
						signed? <- _signed?
					}
				} else: {
					_compileError: "LL integer type " . (expr name) . " has an invalid size"
				}
			} else: {
				_compileError: "LL Type " . (expr name) . " not implemented yet"
			}
		} else: {
			_compileError: "LL Type with node type " . (expr nodeType) . " not implemented yet"
		}
	}

	_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 <- il b
		dest <- assignTo value: :asn {
			_assignSize? <- true
			_asize <- asn size
			asn
		} none: {
			#{
				val <- ilf getReg
				signed? <- true
				size <- _asize
			}
		}
		l <- _compileExpr: (expr left) syms: syms ilfun: ilf dest: (option value: dest)
		r <- _compileExpr: (expr right) syms: syms ilfun: ilf dest: (option none)
		_notError: [(l) (r)] {
			lv <- l val
			ls <- l size
			rv <- r val
			rs <- r size
			_size <- if: ls > rs { 
				ls
				//TODO: sign/zero extend rv
			} else: {
				rs
				//TODO: sign/zero extend lv if rs > ls
			}
			if: _assignSize? && _asize > _size {
				_size <- _asize
				//TODO: sign/zero extend result
			}
			_signed <- (l signed?) || (r signed?)
			_opMap ifget: (expr op) :ingen {
				if: (lv isInteger?) {
					tmp <- lv
					lv <- ilf getReg
					ilf add: (il mov: tmp lv ls)
				}
				ilf add: (ingen: rv lv (dest val) _size)
				#{
					val <- dest val
					size <- _size
					signed? <- _signed
				}
			} else: {
				_compOps ifget: (expr op) :condFun {
					if: (lv isInteger?) {
						tmp <- lv
						lv <- ilf getReg
						ilf add: (il mov: tmp lv ls)
					}
					ilf add: (il cmp: rv lv _size)
					cond <- condFun: _signed
					ilf add: (il bool: cond (dest val))
					#{
						val <- dest val
						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 {
		sz <- il sizeFromBytes: (expr size)
		assignTo value: :asn {
			ilf add: (il mov: (expr val) (asn val) sz)
			#{
				val <- asn val
				signed? <- expr signed?
				size <- sz
			}
		} none: {
			#{
				val <- expr val
				signed? <- expr signed?
				size <- sz
			}
		}
	}
	_compileSym <- :expr syms ilf assignTo {
		syms ifDefined: (expr name) :syminfo {
			if: (syminfo isLocal?) {
				syminfo def
			} else: {
				print: "Symbol " . (expr name) . " is not local and other types are not yet supported in LL dialect\n"
			}
		} 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: 0 (cond val) (cond size))
					dest <- if: (assignTo none?) {
						option value: #{
							val <- ilf reg
							//TODO: FIXME
							size <- il q
							signed? <- true
						}
					} else: {
						assignTo
					}
					ilf startBlock
					foreach: (blockArg expressions) :idx expr{
						asn <- if: idx = ((blockArg expressions) length) - 1 {
							dest
						} else: {
							option none
						}
						_compileExpr: expr syms: syms ilfun: ilf dest: asn
					}
					block <- ilf popBlock
					ilf add: (il skipIf: (il neq) block)
					dest value: :d { d } none: { _compileError: "Something went wrong" }
				}
			}
		}
	}
	_compileIfElse <- :expr syms ilf assignTo {
		if: ((expr args) length) != 3 {
			_compileError: "if:else takes exactly 3 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: 0 (cond val) (cond size))
						dest <- if: (assignTo none?) {
							option value: #{
								val <- ilf reg
								//TODO: FIXME
								size <- il q
								signed? <- true
							}
						} else: {
							assignTo
						}
						ilf startBlock
						foreach: (blockArg expressions) :idx expr {
							asn <- if: idx = ((blockArg expressions) length) - 1 {
								dest
							} else: {
								option none
							}
							_compileExpr: expr syms: syms ilfun: ilf dest: asn
						}
						block <- ilf popBlock
						ilf startBlock
						foreach: (elseArg expressions) :idx expr {
							asn <- if: idx = ((elseArg expressions) length) - 1 {
								dest
							} else: {
								option none
							}
							_compileExpr: expr syms: syms ilfun: ilf dest: (option none)
						}
						elseblock <- ilf popBlock
						ilf add: (il skipIf: (il neq) block else: elseblock)
						dest value: :d { d } none: { _compileError: "Something went wrong" }
					}
				}
			}
		}
	}
	_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 <- if: ((expr tocall) nodeType) = (ast sym) {
				ctocall <- (expr tocall) name
			} else: {
				_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 map: :arg { arg val } ))
				
				retval <- assignTo value: :asn {
					ilf add: (il mov: (il retr) (asn val) (asn size))
					asn
				} none: {
					#{
						val <- il retr
						//TODO: Use correct values based on return type
						size <- il q
						signed? <- true
					}
				}
				retval
			}
		}
	}

	_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 idx
			}
			ilf <- _ilFun: name
			_nextReg <- 0
			varErrors <- (vars expressions) fold: [] with: :acc var {
				type <- _parseType: (var assign)
				_notError: [type] {
					varname <- ((var to) name)
					v <- argnames ifget: varname :argnum {
						il arg: argnum
					} else: {
						ilf getReg
					}
					syms define: varname #{
						val <- v
						size <- (type size)
						signed? <- (type signed?)
					}
					acc
				} else: :err {
					err | acc
				}
			}
			if: (varErrors empty?) {
				last <- option none
				numexprs <- (code expressions) length
				foreach: (code expressions) :idx expr {
					asn <- if: idx = numexprs - 1 {
						option value: #{
							val <- ilf getReg
							//TODO: FIxme
							size <- il q
							signed? <- true
						}
					} else: {
						option none
					}
					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
			} else: {
				varErrors
			}
		}

		compileText <- :text {
			res <- parser top: text
			if: res {
				tree <- res yield
				if: (tree nodeType) = obj {
					errors <- []
					syms <- symbols table
					functions <- (tree messages) fold: [] with: :curfuncs msg {
						if: (msg nodeType) = call {
							if: ((msg tocall) name) = "llFun:withVars:andCode" {
								if: ((msg args) length) = 3 {
									fname <- ((msg args) value) name
									syms define: fname #{
										type <- "topfun"
									}
									rest <- (msg args) tail
									#{
										name <- fname
										vars <- rest value
										body <- (rest tail) value
									} | 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?) {
						errors <- []
						fmap <- functions fold: (dict hash) with: :acc func {
							ilf <- llFun: (func name) syms: syms vars: (func vars) code: (func body)
							_notError: ilf {
								acc set: (func name) (ilf buffer)
							} else: {
								errors <- ilf . errors
							}
							acc
						}
						if: (errors empty?) {
							foreach: fmap :name instarr {
								print: "Function: " . name . "\n"
								foreach: instarr :_ inst {
									print: "\t" . inst . "\n"
								}
							}
							print: "Translating IL to x86\n"
							il toBackend: fmap x86
						} else: {
							errors
						}
					} 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}
					res <- ba runWithArg: (arg int64)
					print: (string: res) . "\n"
				} else: :err {
					(file stderr) write: (err msg) . "\n"
				}
			} else: {
				(file stderr) write: "Usage: llcompile FILE\n"
				1
			}
		}
	}
}