Mercurial > repos > icfp2014
view code/gqc.tp @ 84:23d74104e515
merge
author | William Morgan <billjunk@mrgn.org> |
---|---|
date | Mon, 28 Jul 2014 04:41:30 -0700 |
parents | a2a5d80abaa0 |
children |
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 } //new Quiche parser doesn't support and/or/xor operators yet :( _funHandlers set: "and" :args syms { l <- 0 r <- preserveTemps: { l <- compileExpr: (args value) syms: syms compileExpr: ((args tail) value) syms: syms } dest <- getTemp: if: dest != l { prog add: (inst: "MOV" #[ dest l ]) } prog add: (inst: "AND" #[ dest r ]) dest } //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: { if: (def nodeType) != (ast intlit) || (def val) != 0{ preserveTemps: { compileExpr: msg syms: syms } } else: { syms define: sym (mem: _nextVar) _nextVar <- _nextVar + 1 } } } 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" } } } }