view code/gqc.tp @ 70:5f44ac1bcbd6

Add support for a special notFirst? variable so that globals can be initialized on startup only. This allows for state that persists between turns
author Michael Pavone <pavone@retrodev.com>
date Sun, 27 Jul 2014 23:43:37 -0700
parents 8a0f1447c034
children a2a5d80abaa0
line wrap: on
line source

{
	reg? <- :val {
		(object does: val understand?: "isReg?") && (val isReg?)
	}
	mem? <- :val {
		(object does: val understand?: "isMem?") && (val isMem?)
	}
	
	mem <- :_addr {
		#{
			addr <- { _addr }
			string <- { "[" . _addr . "]" }
			isReg? <- { false }
			!= <- :other { (not: (mem?: other)) || _addr != (other addr) }
			= <- :other { (mem?: other) && _addr = (other addr) }
		}
	}
	reg <- :_num {
		#{
			num <- { _num }
			string <- { (#["a" "b" "c" "d" "e" "f" "g" "h" "pc"]) get: _num }
			isReg? <- { true }
			!= <- :other { (not: (reg?: other)) || _num != (other num) }
			= <- :other { (reg?: other) && _num = (other num) }
		}
	}
	inst <- :_name _args {
		#{
			name <- _name
			args <- _args
			translateLabels <- :labelDict {
				missing <- #[]
				args <- args map: :arg {
					if: (object does: arg understand?: "isString?") && (arg isString?) {
						labelDict get: arg else: {
							missing append: arg
							arg
						}
					} else: {
						arg
					}
				}
				missing
			}
			label <- ""
			comment <- ""
			string <- {
				(if: label != "" { ";" . label . "\n  " } else: { "  " }
				) . name . " " . (args join: ", ") . (
				if: comment = "" { "" } else: { " ;" . comment})
			}
		}
	}
	_nextLabel <- 0
	_setLabel <- :inst {
		inst
	}
	prog <- #{
		instructions <- #[]
		add <- :inst {
			instructions append: (_setLabel: inst)
		}
		makeLabel <- :suffix {
			num <- _nextLabel
			_nextLabel <- _nextLabel + 1
			"" . num . "_" . suffix
		}
		labels <- dict hash
		setLabel <- :name {
			labels set: name pc
			_setLabel <- :inst {
				_setLabel <- :i { i }
				inst label!: name
			}
		}
		pc <- { instructions length }
		print <- {
			foreach: instructions :idx i {
				missing <- i translateLabels: labels
				if: (missing length) > 0 {
					error: "Undefined labels " . (missing join: ", ") . " at address " . idx
				}
				print: (string: i) . "\n"
			}
			
		}
	}
	error <- :msg {
		(file stderr) write: "Error - " . msg . "\n"
	}
	//0 is used for the special notFirst? variable
	_nextVar <- 1
	//a and b are reserved for int/return values
	//h is reserved as a stack pointer
	_allTemp <- [
		reg: 2
		reg: 3
		reg: 4
		reg: 5
		reg: 6
	]
	_tempRegs <- _allTemp
	
	getTemp <- {
		if: (_tempRegs empty?) {
			//out of regs, use memory
			loc <- _nextVar
			_nextVar <- _nextVar + 1
			mem: loc
		} else: {
			r <- _tempRegs value
			_tempRegs <- _tempRegs tail
			r
		}
	}
	
	preserveTemps <- :fun {
		saveTempRegs <- _tempRegs
		res <- fun:
		_tempRegs <- saveTempRegs
		res
	}
	
	_exprHandlers <- dict hash
	
	compileExpr:syms <- :expr :syms {
		_exprHandlers ifget: (expr nodeType) :handler {
			handler: expr syms
		} else: {
			error: "Unhandled node type " . (expr nodeType)
		}
	}
	
	_exprHandlers set: (ast intlit) :expr syms {
		expr val
	}
	
	_opNames <- dict hash
	_opNames set: "+" "ADD"
	_opNames set: "-" "SUB"
	_opNames set: "*" "MUL"
	_opNames set: "/" "DIV"
	_opNames set: "and" "AND"
	_opNames set: "or" "OR"
	_opNames set: "xor" "XOR"
	
	_exprHandlers set: (ast binary) :expr syms {
		l <- 0
		r <- preserveTemps: {
			l <- compileExpr: (expr left) syms: syms
			compileExpr: (expr right) syms: syms
		}
		dest <- l
		if: (reg?: l) {
			//reallocate temp register used by l
			//not always safe, needs work
			_tempRegs <- _tempRegs filter: :r { r != l }
		} else: {		
			dest <- getTemp:
			prog add: (inst: "MOV" #[
				dest
				l
			])
		}
		_opNames ifget: (expr op) :i {
			prog add: (inst: i #[
				dest
				r
			])
			dest
		} else: {
			error: "operator " . (expr op) . " is not supported"
		}
	}
	
	_exprHandlers set: (ast sym) :expr syms {
		syms ifDefined: (expr name) :info {
			info def
		} else: {
			error: "symbol " . (expr name) . " is not defined"
		}
	}
	
	_exprHandlers set: (ast assignment) :expr syms {
		sym <- expr to
		syms ifDefined: (sym name) :info {
		} else: {
			syms define: (sym name) (mem: _nextVar)
			_nextVar <- _nextVar + 1
		}
		info <- syms find: (sym name) else: {
			error: "this should never happen!"
		}
		v <- preserveTemps: {
			compileExpr: (expr assign) syms: syms
		}
		dest <- info def
		if: dest != v {
			prog add: (inst: "MOV" #[
				dest
				v
			])
		}
		dest
	}
	
	_funHandlers <- dict hash
	//provide symbolic names for all the interupt routines
	_funHandlers set: "debug" :args syms {
		prog add: (inst: "INT" #[8])
		0
	}
	_funHandlers set: "direction!" :args syms {
		dir <- args value
		v <- preserveTemps: {
			compileExpr: dir syms: syms
		}
		if: (reg: 0) != v {	
			prog add: (inst: "MOV" #[
				reg: 0
				v
			])
		}
		prog add: (inst: "INT" #[0])
		0
	}
	_funHandlers set: "lambdamanPos" :args syms {
		prog add: (inst: "INT" #[1])
		reg: 0
	}
	_funHandlers set: "lambdaman2Pos" :args syms {
		prog add: (inst: "INT" #[2])
		reg: 0
	}
	_funHandlers set: "me" :args syms {
		prog add: (inst: "INT" #[3])
		reg: 0
	}
	foreach: #["ghostStartPos" "ghostPos" "ghostStatus"] :idx name {
		intNum <- idx + 4
		_funHandlers set: name :args syms {
			ghostIdx <- args value
			v <- preserveTemps: {
				compileExpr: ghostIdx syms: syms
			}
			if: (reg: 0) != v {	
				prog add: (inst: "MOV" #[
					reg: 0
					v
				])
			}
			prog add: (inst: "INT" #[intNum])
			reg: 0
		}
	}
	_funHandlers set: "mapContentsAt" :args syms {
		x <- args value
		y <- (args tail) value
		preserveTemps: {
			x <- compileExpr: x syms: syms
			y <- compileExpr: y syms: syms
		}
		if: (reg: 0) != x {
			prog add: (inst: "MOV" #[	
				reg: 0
				x
			])
		}
		if: (reg: 1) != y {
			prog add: (inst: "MOV" #[	
				reg: 1
				y
			])
		}
		prog add: (inst: "INT" #[7])
		reg: 0
	}
	
	//allow access to raw instructions
	foreach: #["MOV" "INC" "DEC" "ADD" "SUB" "MUL" "DIV" "AND" "OR" "XOR" "JLT" "JEQ" "JGT" "HLT"] :idx instName {
		_funHandlers set: instName :args syms {
			preserveTemps: {
				args <- args map: :arg { compileExpr: arg syms: syms }
			}
			prog add: (inst: instName args)
		}
	}
	
	_funHandlers set: "while:do" :args syms {
		cond <- ((args value) expressions) value
		body <- ((args tail) value) expressions
		
		if: (cond nodeType) = (ast binary) {
			top <- prog makeLabel: "loop_top"
			end <- prog makeLabel: "loop_end"
			prog setLabel: top
			
			l <- 0
			r <- preserveTemps: {
				l <- compileExpr: (cond left) syms: syms
				compileExpr: (cond right) syms: syms
			}
			
			ok <- true
			//we need the inverse check in the instruction since a true condition
			//means continue the loop, whereas we need a jump instruction that jumps
			//only when it is time to exit
			if: (cond op) = ">=" {
				prog add: (inst: "JLT" #[
					end
					l
					r
				])
			} else: {
				if: (cond op) = "<=" {
					prog add: (inst: "JGT" #[
						end
						l
						r
					])
				} else: {
					if: (cond op) = "!=" {
						prog add: (inst: "JEQ" #[
							end
							l
							r
						])
					} else: {
						if: (cond op) = ">" {
							bodyLbl <- prog makeLabel: "loop_body"
							prog add: (inst: "JGT" #[
								bodyLbl
								l
								r
							])
							prog add: (inst: "MOV" #[
								reg: 8
								end
							])
							prog setLabel: bodyLbl
						} else: {
							if: (cond op) = "<" {
								bodyLbl <- prog makeLabel: "loop_body"
								prog add: (inst: "JLT" #[
									bodyLbl
									l
									r
								])
								prog add: (inst: "MOV" #[
									reg: 8
									end
								])
								prog setLabel: bodyLbl
							}  else: {
								bodyLbl <- prog makeLabel: "loop_body"
								if: (cond op) = "=" {
									prog add: (inst: "JEQ" #[
										bodyLbl
										l
										r
									])
									prog add: (inst: "MOV" #[
										reg: 8
										end
									])
									prog setLabel: bodyLbl
								} else: {
									ok <- false
								}
							}
						}
					}
				}
			}
			if: ok {
				//TODO: do 2 passes for labels to allow forward references
				foreach: body :idx expr {
					if: (expr nodeType) = (ast sym) {
						//allow using bare symbols to define labels
						lbl <- prog makeLabel: (expr name)
						prog setLabel: lbl
						syms define: (expr name) lbl
					} else: {
						v <- preserveTemps: {
							compileExpr: expr syms: syms
						}
					}
				}
				prog add: (inst: "MOV" #[
					reg: 8
					top
				])
				prog setLabel: end
			} else: {
				error: "Condition parameter to while:do must be a comparison operator expression"
			}
		} else: {
			error: "Condition parameter to while:do must be a comparison operator expression"
		}
	}
	
	_funHandlers set: "if:else" :args syms {
		cond <- (args value)
		trueBody <- ((args tail) value) expressions
		falseBody <- (((args tail) tail) value) expressions
		
		if: (cond nodeType) = (ast binary) {
			trueLbl <- prog makeLabel: "true"
			falseLbl <- prog makeLabel: "false"
			endLbl <- prog makeLabel: "end"
			
			l <- 0
			r <- preserveTemps: {
				l <- compileExpr: (cond left) syms: syms
				compileExpr: (cond right) syms: syms
			}
			
			ok <- true
			
			if: (cond op) = ">=" {
				prog add: (inst: "JLT" #[
					falseLbl
					l
					r
				])
			} else: {
				if: (cond op) = "<=" {
					prog add: (inst: "JGT" #[
						falseLbl
						l
						r
					])
				} else: {
					if: (cond op) = "!=" {
						prog add: (inst: "JEQ" #[
							falseLbl
							l
							r
						])
					} else: {
						if: (cond op) = ">" {
							prog add: (inst: "JGT" #[
								trueLbl
								l
								r
							])
							prog add: (inst: "MOV" #[
								reg: 8
								falseLbl
							])
						} else: {
							if: (cond op) = "<" {
								prog add: (inst: "JLT" #[
									trueLbl
									l
									r
								])
								prog add: (inst: "MOV" #[
									reg: 8
									falseLbl
								])
							}  else: {
								bodyLbl <- prog makeLabel: "loop_body"
								if: (cond op) = "=" {
									prog add: (inst: "JEQ" #[
										trueLbl
										l
										r
									])
									prog add: (inst: "MOV" #[
										reg: 8
										falseLbl
									])
								} else: {
									ok <- false
								}
							}
						}
					}
				}
			}
			if: ok {
				prog setLabel: trueLbl
				//TODO: do 2 passes for labels to allow forward references
				foreach: trueBody :idx expr {
					if: (expr nodeType) = (ast sym) {
						//allow using bare symbols to define labels
						lbl <- prog makeLabel: (expr name)
						prog setLabel: lbl
						syms define: (expr name) lbl
					} else: {
						v <- preserveTemps: {
							compileExpr: expr syms: syms
						}
					}
				}
				prog add: (inst: "MOV" #[
					reg: 8
					endLbl
				])
				prog setLabel: falseLbl
				//TODO: do 2 passes for labels to allow forward references
				foreach: falseBody :idx expr {
					if: (expr nodeType) = (ast sym) {
						//allow using bare symbols to define labels
						lbl <- prog makeLabel: (expr name)
						prog setLabel: lbl
						syms define: (expr name) lbl
					} else: {
						v <- preserveTemps: {
							compileExpr: expr syms: syms
						}
					}
				}
				prog setLabel: endLbl
			} else: {
				error: "Condition parameter to if:else must be a comparison operator expression"
			}
		} else: {
			error: "Condition parameter to if:else must be a comparison operator expression"
		}
	}
	
	_funHandlers set: "if" :args syms {
		cond <- (args value)
		trueBody <- ((args tail) value) expressions
		
		if: (cond nodeType) = (ast binary) {
			trueLbl <- prog makeLabel: "true"
			endLbl <- prog makeLabel: "end"
			
			l <- 0
			r <- preserveTemps: {
				l <- compileExpr: (cond left) syms: syms
				compileExpr: (cond right) syms: syms
			}
			
			ok <- true
			
			if: (cond op) = ">=" {
				prog add: (inst: "JLT" #[
					endLbl
					l
					r
				])
			} else: {
				if: (cond op) = "<=" {
					prog add: (inst: "JGT" #[
						endLbl
						l
						r
					])
				} else: {
					if: (cond op) = "!=" {
						prog add: (inst: "JEQ" #[
							endLbl
							l
							r
						])
					} else: {
						if: (cond op) = ">" {
							prog add: (inst: "JGT" #[
								trueLbl
								l
								r
							])
							prog add: (inst: "MOV" #[
								reg: 8
								endLbl
							])
						} else: {
							if: (cond op) = "<" {
								prog add: (inst: "JLT" #[
									trueLbl
									l
									r
								])
								prog add: (inst: "MOV" #[
									reg: 8
									endLbl
								])
							}  else: {
								bodyLbl <- prog makeLabel: "loop_body"
								if: (cond op) = "=" {
									prog add: (inst: "JEQ" #[
										trueLbl
										l
										r
									])
									prog add: (inst: "MOV" #[
										reg: 8
										endLbl
									])
								} else: {
									ok <- false
								}
							}
						}
					}
				}
			}
			if: ok {
				prog setLabel: trueLbl
				//TODO: do 2 passes for labels to allow forward references
				foreach: trueBody :idx expr {
					if: (expr nodeType) = (ast sym) {
						//allow using bare symbols to define labels
						lbl <- prog makeLabel: (expr name)
						prog setLabel: lbl
						syms define: (expr name) lbl
					} else: {
						v <- preserveTemps: {
							compileExpr: expr syms: syms
						}
					}
				}
				prog setLabel: endLbl
			} else: {
				error: "Condition parameter to if must be a comparison operator expression"
			}
		} else: {
			error: "Condition parameter to if must be a comparison operator expression"
		}
	}
	
	_exprHandlers set: (ast call) :expr syms {
		tc <- (expr tocall)
		if: (tc nodeType) = (ast sym) {
			_funHandlers ifget: (tc name) :handler {
				handler: (expr args) syms
			} else: {
				syms ifDefined: (tc name) :info {
					funArgs <- preserveTemps: {
						(expr args) map: :arg { compileExpr: arg syms: syms}
					}
				
					//save registers that need it
					needSave <- _allTemp filter: :r {
						not: (_tempRegs contains?: r)
					}
					foreach: needSave :idx r {
						prog add: (inst: "DEC" #[(reg: 7)])
						prog add: (inst: "MOV" #[
							mem: (reg: 7)
							r
						])
					}
					after <- prog makeLabel: "after_call"
					//save PC value after call
					prog add: (inst: "DEC" #[(reg: 7)])
					prog add: (inst: "MOV" #[
						mem: (reg: 7)
						after
					])
					//put arguments into the appropriate registers
					passregs <- _allTemp
					foreach: funArgs :idx arg {
						passreg <- passregs value
						passregs <- passregs tail
						if: passreg != arg {
							//there's a potential for clobbering argument temp regs
							//but there's no time to figure out a good solution
							prog add: (inst: "MOV" #[
								passreg
								arg
							])
						} else: {
							print: "Skipping MOV for argument: " . arg . "\n"
						}
					}
					//jump to function
					prog add: (inst: "MOV" #[	
						reg: 8
						info def
					])
					prog setLabel: after
					//adjust PC
					prog add: (inst: "INC" #[(reg: 7)])
					
					//restore registers that were saved earlier
					foreach: (reverse: needSave) :idx r {
						prog add: (inst: "MOV" #[
							r
							mem: (reg: 7)
						])
						prog add: (inst: "INC" #[(reg: 7)])
					}
					reg: 0
				} else: {
					error: "Function " . (tc name) . " is not defined"
				}
			}
		} else: {
			error: "Calling expressions is not supported in"
		}
	}
	
	
	_compileFun <- :fName fun globsyms {
		syms <- symbols tableWithParent: globsyms
		
		preserveTemps: {
			foreach: (fun args) :idx arg {
				argname <- (if: (arg startsWith?: ":") { arg from: 1 } else: { arg })
				r <- getTemp:
				syms define: argname r
			}
			
			lastexpr <- ((fun expressions) length) - 1
			
			//TODO: do 2 passes for labels to allow forward references
			foreach: (fun expressions) :idx expr {
				if: idx != lastexpr && (expr nodeType) = (ast sym) {
					//allow using bare symbols to define labels
					prog setLabel: (expr name)
					syms define: (expr name) (expr name)
				} else: {
					v <- preserveTemps: {
						compileExpr: expr syms: syms
					}
					if: idx = lastexpr && (fName != "main") {
						//move result to a register
						prog add: (inst: "MOV" #[
							reg: 0
							v
						])
						//return instruction
						prog add: (inst: "MOV" #[
							reg: 8
							mem: (reg: 7)
						])
					}
				}
			}
		}
	}
	
	#{
		compile <- :code {
			res <- parser top: code
			if: res {
				outer <- res yield
				functions <- dict hash
				syms <- symbols table
				
				//define symbols for the special notFirst? variable
				syms define: "notFirst?" (mem: 0)
				//use it to skip global init on subsequent runthroughs
				prog add: (inst: "JEQ" #[
					"main"
					(mem: 0)
					1
				])
				prog add: (inst: "MOV" #[
					(mem: 0)
					1
				])
				
				//define symbols for all registers
				//for low level shenanigans
				i <- 0
				while: { i < 9 } do: {
					r <- reg: i
					syms define: (string: r) r
					i <- i + 1
				}
				//define symbols for interrupt return values
				syms define: "xCoord" (reg: 0)
				syms define: "yCoord" (reg: 1)
				syms define: "vitality" (reg: 0)
				syms define: "direction" (reg: 1)
				
				//process top level assignments
				foreach: (outer messages) :idx msg {
					if: (msg nodeType) = (ast assignment) {
						def <- msg assign
						sym <- (msg to) name
						
						if: (def nodeType) = (ast lambda) {
							functions set: sym def
							syms define: sym sym
						} else: {
							compileExpr: msg syms: syms
						}
					} else: {
						error: "Only assignments are allowed at the top level"
					}
				}
				
				functions ifget: "main" :def {
					prog setLabel: "main"
					_compileFun: "main" def syms
				} else: {
					error: "Program must have a main function!"
				}
				prog add: (inst: "HLT" #[])
				
				foreach: functions :name def {
					if: name != "main" {
						prog setLabel: name
						_compileFun: name def syms
					}
				}
				print: prog
			}
		}
		
		compileFile <- :filename {
			f <- file open: filename
			compile: (f readAll)
		}
		
		main <- :args {
			if: (args length) > 1 {
				compileFile: (args get: 1)
			} else: {
				print: "Usage lmc FILE\n"
			}
		}
	}
}