# HG changeset patch
# User Michael Pavone <pavone@retrodev.com>
# Date 1426360251 25200
# Node ID f987bb2a1911bf08a523732de366a49dc5c000a5
# Parent  d4df33596e7dcaf47c781191278c150cef0da04e
WIP native compiler work

diff -r d4df33596e7d -r f987bb2a1911 modules/il.tp
--- a/modules/il.tp	Sat Mar 14 12:10:40 2015 -0700
+++ b/modules/il.tp	Sat Mar 14 12:10:51 2015 -0700
@@ -4,31 +4,36 @@
 	_and    <- 1
 	_or     <- 2
 	_xor    <- 3
-	_mul    <- 4
+	_muls   <- 4
+	_mulu   <- 5
 	//non-commutative ops
-	_div    <- 5
-	_sub    <- 6
-	_cmp    <- 7
-	_not    <- 8
-	_sl     <- 9
-	_asr    <- 10
-	_lsr    <- 11
-	_rol    <- 12
-	_ror    <- 13
-	_mov    <- 14
-	_call   <- 15
-	_ret    <- 16
-	_skipif <- 17
-	_save   <- 18
-	_bool   <- 19
+	_divs   <- 6
+	_divu   <- 7
+	_sub    <- 8
+	_cmp    <- 9
+	_not    <- 10
+	_sl     <- 11
+	_asr    <- 12
+	_lsr    <- 13
+	_rol    <- 14
+	_ror    <- 15
+	_mov    <- 16
+	_call   <- 17
+	_ret    <- 18
+	_skipif <- 19
+	_skipifelse <- 20
+	_save   <- 21
+	_bool   <- 22
 
 	_names <- #[
 		"add"
 		"and"
 		"or"
 		"xor"
-		"mul"
-		"div"
+		"muls"
+		"mulu"
+		"divs"
+		"divu"
 		"sub"
 		"cmp"
 		"not"
@@ -41,6 +46,7 @@
 		"call"
 		"ret"
 		"skipIf"
+		"skipIf:else"
 		"save"
 		"bool"
 	]
@@ -50,7 +56,7 @@
 			opcode <- { _opcode }
 			ina <- { _ina }
 			inb <- { _inb }
-			commutative? <- { _opcode < _sub }
+			commutative? <- { _opcode < _divs }
 			out <- { _out }
 			size <- { _size }
 			numops <- { 3 }
@@ -289,28 +295,36 @@
 			op3: _sub a: ina b: inb out: out size: size
 		}
 
-		cmp <- :ina inb out size {
-			op3: _cmp a: ina b: inb out: out size: size
+		cmp <- :ina inb size {
+			op2: _cmp a: ina out: inb size: size
 		}
 
-		and <- :ina inb out size {
+		band <- :ina inb out size {
 			op3: _and a: ina b: inb out: out size: size
 		}
 
-		or <- :ina inb out size {
+		bor <- :ina inb out size {
 			op3: _or a: ina b: inb out: out size: size
 		}
 
-		xor <- :ina inb out size {
+		bxor <- :ina inb out size {
 			op3: _xor a: ina b: inb out: out size: size
 		}
 
-		mul <- :ina inb out size {
-			op3: _mul a: ina b: inb out: out size: size
+		muls <- :ina inb out size {
+			op3: _muls a: ina b: inb out: out size: size
 		}
 
-		div <- :ina inb out size {
-			op3: _div a: ina b: inb out: out size: size
+		mulu <- :ina inb out size {
+			op3: _mulu a: ina b: inb out: out size: size
+		}
+
+		divs <- :ina inb out size {
+			op3: _divs a: ina b: inb out: out size: size
+		}
+
+		divu <- :ina inb out size {
+			op3: _divu a: ina b: inb out: out size: size
 		}
 
 		bnot <- :in out size {
@@ -426,6 +440,49 @@
 				}
 			}
 		}
+		skipIf:else <- :_cond _toskip :_else {
+			#{
+				opcode <- { _skipif }
+				toskip <- { _toskip }
+				else <- { _else }
+				cond <- { _cond }
+				numops <- { 0 }
+				name <- { _names get: _skipifelse }
+				string <- {
+					block <- (_toskip map: :el { string: el }) join: "\n\t"
+					if: (_toskip length) > 0 {
+						block <- "\n\t" . block . "\n"
+					}
+					elseblock <- (_else map: :el { string: el }) join: "\n\t"
+					if: (_else length) > 0 {
+						elseblock <- "\n\t" . elseblock . "\n"
+					}
+					name . " " . (string: _cond) . " {" . block .  "} {" . elseblock . "}"
+				}
+				recordUsage:at <- :tracker :address {
+					foreach: _toskip :idx inst {
+						inst recordUsage: tracker at: idx | address
+					}
+					foreach: _else :idx inst {
+						inst recordUsage: tracker at: idx | address
+					}
+				}
+				assignRegs:at:withSource:andUsage <- :assignments :address :regSrc :usage {
+					newskip <- #[]
+					foreach: _toskip :idx inst {
+						newskip append: (inst assignRegs: assignments at: idx | address  withSource: regSrc andUsage: usage)
+					}
+					newelse <- #[]
+					foreach: _else :idx inst {
+						newelse append: (inst assignRegs: assignments at: idx | address  withSource: regSrc andUsage: usage)
+					}
+					skipIf: _cond newskip else: newelse
+				}
+				to2OpInst <- {
+					skipIf: _cond (to2Op: _toskip) (to2Op: _else)
+				}
+			}
+		}
 		save <- :regs :_scope{
 			#{
 				opcode <- { _save }
@@ -451,7 +508,7 @@
 			#{
 				opcode <- { _bool }
 				cond <- { _cond }
-				out <- { _code }
+				out <- { _out }
 				name <- { _names get: _save }
 				numops <- { 0 }
 
diff -r d4df33596e7d -r f987bb2a1911 modules/llcompile.tp
--- 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
+			}
 		}
 	}
 }
diff -r d4df33596e7d -r f987bb2a1911 modules/os.tp
--- a/modules/os.tp	Sat Mar 14 12:10:40 2015 -0700
+++ b/modules/os.tp	Sat Mar 14 12:10:51 2015 -0700
@@ -121,5 +121,118 @@
 			intret num!: (sleep: (secs num))
 			intret
 		}
+
+		llMessage: execv withVars: {
+			opath <- object ptr
+			path <- string ptr
+			eargs <- object ptr
+			oarglen <- object ptr
+			arglen <- obj_int32 ptr
+			i <- int32_t
+			oi <- obj_int32 ptr
+			oarg <- object ptr
+			arg <- string ptr
+			cargs <- (char ptr) ptr
+		} andCode: :opath eargs {
+			path <- (mcall: string 1 opath) castTo: (string ptr)
+			oarglen <- mcall: length 1 eargs
+			arglen <- (mcall: int32 1 oarglen) castTo: (obj_int32 ptr)
+			cargs <- GC_MALLOC_ATOMIC: (sizeof: (char ptr)) * ((arglen num) + 1)
+			i <- 0
+			while: { i < (arglen num) } do: {
+				oi <- make_object: (addr_of: obj_int32_meta) NULL 0
+				oi num!: i
+				oarg <- mcall: get 2 eargs oi
+				arg <- (mcall: string 1 oarg) castTo: (string ptr)
+				cargs set: i (arg data)
+				i <- i + 1
+			}
+			cargs set: i NULL
+			i <- execv: (path data) cargs
+			oi <- make_object: (addr_of: obj_int32_meta) NULL 0
+			oi num!: i
+			oi
+		}
+
+		llMessage: execvp withVars: {
+			opath <- object ptr
+			path <- string ptr
+			eargs <- object ptr
+			oarglen <- object ptr
+			arglen <- obj_int32 ptr
+			i <- int32_t
+			oi <- obj_int32 ptr
+			oarg <- object ptr
+			arg <- string ptr
+			cargs <- (char ptr) ptr
+		} andCode: :opath eargs {
+			path <- (mcall: string 1 opath) castTo: (string ptr)
+			oarglen <- mcall: length 1 eargs
+			arglen <- (mcall: int32 1 oarglen) castTo: (obj_int32 ptr)
+			cargs <- GC_MALLOC_ATOMIC: (sizeof: (char ptr)) * ((arglen num) + 1)
+			i <- 0
+			while: { i < (arglen num) } do: {
+				oi <- make_object: (addr_of: obj_int32_meta) NULL 0
+				oi num!: i
+				oarg <- mcall: get 2 eargs oi
+				arg <- (mcall: string 1 oarg) castTo: (string ptr)
+				cargs set: i (arg data)
+				i <- i + 1
+			}
+			cargs set: i NULL
+			i <- execvp: (path data) cargs
+			oi <- make_object: (addr_of: obj_int32_meta) NULL 0
+			oi num!: i
+			oi
+		}
+
+		llMessage: execve withVars: {
+			opath <- object ptr
+			path <- string ptr
+			eargs <- object ptr
+			env <- object ptr
+			oarglen <- object ptr
+			arglen <- obj_int32 ptr
+			i <- int32_t
+			oi <- obj_int32 ptr
+			oarg <- object ptr
+			arg <- string ptr
+			cargs <- (char ptr) ptr
+			cenv <- (char ptr) ptr
+		} andCode: :opath eargs env {
+			path <- (mcall: string 1 opath) castTo: (string ptr)
+			oarglen <- mcall: length 1 eargs
+			arglen <- (mcall: int32 1 oarglen) castTo: (obj_int32 ptr)
+			cargs <- GC_MALLOC_ATOMIC: (sizeof: (char ptr)) * ((arglen num) + 1)
+			i <- 0
+			while: { i < (arglen num) } do: {
+				oi <- make_object: (addr_of: obj_int32_meta) NULL 0
+				oi num!: i
+				oarg <- mcall: get 2 eargs oi
+				arg <- (mcall: string 1 oarg) castTo: (string ptr)
+				cargs set: i (arg data)
+				i <- i + 1
+			}
+			cargs set: i NULL
+
+			oarglen <- mcall: length 1 eargs
+			arglen <- (mcall: int32 1 oarglen) castTo: (obj_int32 ptr)
+			cenv <- GC_MALLOC_ATOMIC: (sizeof: (char ptr)) * ((arglen num) + 1)
+			i <- 0
+			while: { i < (arglen num) } do: {
+				oi <- make_object: (addr_of: obj_int32_meta) NULL 0
+				oi num!: i
+				oarg <- mcall: get 2 env oi
+				arg <- (mcall: string 1 oarg) castTo: (string ptr)
+				cenv set: i (arg data)
+				i <- i + 1
+			}
+			cenv set: i NULL
+
+			i <- execve: (path data) cargs cenv
+			oi <- make_object: (addr_of: obj_int32_meta) NULL 0
+			oi num!: i
+			oi
+		}
 	}
 }
diff -r d4df33596e7d -r f987bb2a1911 modules/x86.tp
--- a/modules/x86.tp	Sat Mar 14 12:10:40 2015 -0700
+++ b/modules/x86.tp	Sat Mar 14 12:10:51 2015 -0700
@@ -732,6 +732,8 @@
 				{ outarr append: (and: (inst in) (inst out) (mapSize: (inst size))) }
 				{ outarr append: (or: (inst in) (inst out) (mapSize: (inst size))) }
 				{ outarr append: (xor: (inst in) (inst out) (mapSize: (inst size))) }
+				//mul
+				//div
 				{ outarr append: (sub: (inst in) (inst out) (mapSize: (inst size))) }
 				{ outarr append: (cmp: (inst in) (inst out) (mapSize: (inst size))) }
 				{ outarr append: (bnot: (inst arg) (mapSize: (inst size))) }
@@ -786,6 +788,7 @@
 					}
 					outarr append: endlab
 				}
+				//skipIf:else
 				{
 					//save
 					newsave <- []
@@ -802,6 +805,7 @@
 						}
 					}
 				}
+				//bool
 			]
 			fun <- opmap get: (inst opcode)
 			fun: