Fix spelling of file names

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