diff options
Diffstat (limited to 'CodeGen.sml')
| -rw-r--r-- | CodeGen.sml | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/CodeGen.sml b/CodeGen.sml new file mode 100644 index 0000000..0bd86be --- /dev/null +++ b/CodeGen.sml @@ -0,0 +1,181 @@ +structure CodeGen = +struct + fun enumerate l = ListPair.zip (List.tabulate (length l, (fn x => x)), l) + + (* There are 256 registers *) + val tempReg = 255 + + structure VarMap = Map (type k = Syntax.var + val cmp = Int.compare) + + fun cycle (outputs : Syntax.var VarMap.map) (output : Syntax.var) : Syntax.opcode list = + case VarMap.lookup output outputs of + NONE => Syntax.OShuf (output, Syntax.VVar tempReg) :: cycles outputs + | SOME input => + Syntax.OShuf (output, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input + + and cycles (outputs : Syntax.var VarMap.map) : Syntax.opcode list = + case VarMap.lookupMin outputs of + NONE => [] + | SOME (output, input) => + Syntax.OShuf (tempReg, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input + + fun shuffle' (inputs : unit VarMap.map) (outputs : Syntax.var VarMap.map) : Syntax.opcode list = + case VarMap.lookupMin (VarMap.difference outputs inputs) of + NONE => cycles outputs + | SOME (output, input) => + Syntax.OShuf (output, Syntax.VVar input) :: shuffle' (VarMap.delete input inputs) (VarMap.delete output outputs) + + fun shuffle (args : Syntax.value list) : Syntax.opcode list = + let + val outputMap = + VarMap.fromList + (List.mapPartial + (fn (i, Syntax.VVar v) => + if i = v + then NONE + else SOME (i, v) + | _ => NONE) + (enumerate args)) + val inputMap = + VarMap.fromList + (map + (fn (_, input) => (input, ())) + (VarMap.toList outputMap)) + val constants = + List.mapPartial + (fn (_, Syntax.VVar _) => NONE + | (i, constArg) => SOME (Syntax.OShuf (i, constArg))) + (enumerate args) + in + shuffle' inputMap outputMap @ constants + end + + fun buildVarMap (first : int) (expr : Syntax.cexp) : Syntax.var VarMap.map = + let + val next = ref first + fun insert v m = + let val this = !next + in + next := this + 1; + VarMap.insert v this m + end + fun go expr = + case expr of + Syntax.CRecord (records, k) => + foldl + (fn ((_, res), acc) => insert res acc) + (go k) + records + | Syntax.CSelect (_, _, res, k) => insert res (go k) + | Syntax.CApp _ => VarMap.empty + | Syntax.CFix (funcs, body) => + let + val funcsVars = + foldl + (fn ((_, args, body), acc) => + let + val argsVars = + foldl + (fn ((i, arg), acc) => VarMap.insert arg i acc) + VarMap.empty + (ListPair.zip + (List.tabulate (length args, fn x => x + 1), + args)) + val bodyVars = buildVarMap (length args + 1) body + in VarMap.union (VarMap.union acc argsVars) bodyVars + end) + VarMap.empty + funcs + val bodyVars = go body + in VarMap.union funcsVars bodyVars + end + | Syntax.CPrimop (_, _, res, k) => + let + val resVars = + foldl + (fn (v, acc) => insert v acc) + VarMap.empty + res + val kVars = + foldl + (fn (expr, acc) => VarMap.union acc (go expr)) + VarMap.empty + k + in + VarMap.union resVars kVars + end + in go expr + end + + fun toASM (expr : Syntax.cexp) : Syntax.opcode list = + let + val varMap = buildVarMap 0 expr + fun translate v = + case VarMap.lookup v varMap of + NONE => raise Fail ("unable to translate var " ^ Int.toString v) + | SOME x => x + fun translateVal (Syntax.VVar v) = Syntax.VVar (translate v) + | translateVal x = x + fun go expr = + case expr of + Syntax.CRecord (records, k) => + map (fn (args, res) => Syntax.OAlloc (translate res, Syntax.VInt (length args))) + records + @ List.concat + (map + (fn (args, res) => + List.concat + (map + (fn (i, (arg, path)) => + let val (temp, ops) = + foldl + (fn (off, (arg, ops)) => + (Syntax.VVar tempReg, Syntax.OPeek (tempReg, off, arg) :: ops)) + (translateVal arg, []) + path + in rev (Syntax.OPoke (i, translate res, temp) :: ops) + end) + (enumerate args))) + records) + @ go k + | Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: go k + | Syntax.CApp (func, args) => shuffle (map translateVal (func :: args)) @ [Syntax.OCall] + | Syntax.CFix (funcs, body) => + let + val bodyASM = go body + val funcsASM = + foldl + (fn ((name, _, body), acc) => + Syntax.OLabel name :: go body @ acc) + [] + funcs + in + bodyASM @ funcsASM + end + | Syntax.CPrimop (Syntax.PExit, [arg], _, _) => [Syntax.OExit (translateVal arg)] + | Syntax.CPrimop (Syntax.PAdd, [x, y], [res], [k]) => Syntax.OAdd (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PSub, [x, y], [res], [k]) => Syntax.OSub (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PMul, [x, y], [res], [k]) => Syntax.OMul (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PDiv, [x, y], [res], [k]) => Syntax.ODiv (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PLess, [x, y], [res], [k]) => Syntax.OLess (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PEq, [x, y], [res], [k]) => Syntax.OEq (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PIf, [b], [], [k1, k2]) => + let + val trueLabel = GenSym.new () + in + Syntax.OIf (translateVal b, trueLabel) + :: go k2 + @ Syntax.OLabel trueLabel + :: go k1 + end + | Syntax.CPrimop (Syntax.PRead, [Syntax.VVar ptr, off, len], [res], [k]) => + Syntax.ORead (translate res, translate ptr, translateVal off, translateVal len) :: go k + | Syntax.CPrimop (Syntax.PWrite, [Syntax.VVar ptr, off, len], _, [k]) => + Syntax.OWrite (translate ptr, translateVal off, translateVal len) :: go k + | Syntax.CPrimop (Syntax.PWriteErr, [Syntax.VVar ptr, off, len], _, [k]) => + Syntax.OWriteErr (translate ptr, translateVal off, translateVal len) :: go k + | _ => raise Fail ("malformed CPS:\n" ^ Syntax.cexpToString expr) + in go expr + end +end |