diff modules/llcompile.tp @ 315:f987bb2a1911

WIP native compiler work
author Michael Pavone <pavone@retrodev.com>
date Sat, 14 Mar 2015 12:10:51 -0700
parents 2308336790d4
children f74ce841fd1e
line wrap: on
line diff
--- a/modules/llcompile.tp	Sat Mar 14 12:10:40 2015 -0700
+++ b/modules/llcompile.tp	Sat Mar 14 12:10:51 2015 -0700
@@ -8,16 +8,19 @@
 	}
 
 	_notError <- :vals ifnoterr {
-		maybeErr <- vals find: :val {
-			(object does: val understand?: "isError?") && val isError?
-		}
-		maybErr value: :err {
-			err
-		} none: 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 }
@@ -27,10 +30,21 @@
 				_nextReg <- _nextReg + 1
 				r
 			}
+			startBlock <- {
+				_blockStack <- _buff | _blockStack
+				_buff <- #[]
+			}
+			popBlock <- {
+				res <- _buff
+				_buff <- _blockStack value
+				_blockStack <- _blockStack tail
+				res
+			}
+			buffer <- { _buff }
 		}
 	}
 
-	_exprHandlers <- dict hash
+	_exprHandlers <- false
 	_compileExpr:syms:ilfun:dest <- :expr :syms :ilf :dst {
 		_exprHandlers ifget: (expr nodeType) :handler {
 			handler: expr syms ilf dst
@@ -38,27 +52,9 @@
 			_compileError: "Expression with node type " . (expr nodeType) . " not implemented yet"
 		}
 	}
-	_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" and
-	mapOp: "or" or
-	mapOp: "xor" xor
+	_opMap <- false
 
-	_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 } }
+	_compOps <- false
 
 	_compileBinary <- :expr syms ilf assignTo {
 		_assignSize? <- false
@@ -113,9 +109,92 @@
 			_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
+			}
+		}
+	}
 
-	_exprHandlers set: binary _compileBinary
-	_exprHandlers set: stringlit _compileString
+	_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
@@ -128,8 +207,160 @@
 			assignment
 			lambda
 		] from: ast
-		llFun <- :{
+		_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
+			}
 		}
 	}
 }