Removal of register reassignment in allocator

1 files changed, 80 insertions, 64 deletions

diff --git a/il.fun b/il.fun
index 0e2240c..286cd32 100644
--- a/il.fun
+++ b/il.fun
@@ -105,6 +105,24 @@ functor IL(P: PARSER) = struct
     strlits: int list
   }
 
+  val debugFile = ref NONE
+
+  local
+    fun output s =
+    let
+      val outstream = !debugFile
+    in
+      case outstream of
+        NONE => ()
+      | SOME outstream => TextIO.output (outstream, s)
+    end
+
+    val ctx = ((false, makePrintfBase output),
+      fn (_: bool * ((string -> unit) * (unit -> unit))) => ())
+  in
+    fun dprintf g = Fold.fold ctx g
+  end
+
   fun updateLctx (Lctx ctx) = fn z =>
   let
     fun from fname localVars paramNum vregs ops scopes labels =
@@ -164,7 +182,7 @@ functor IL(P: PARSER) = struct
     val len = lvlen + paramNum
     val vregs = D.create len
 
-    val () = printfn `"local + copies: " I len %
+    val () = dprintf `"local + copies: " I len `"\n" %
 
     fun loop idx =
       if idx = len then
@@ -421,7 +439,6 @@ functor IL(P: PARSER) = struct
   let
     val v = convExpr ctx ea
 
-    val () = printfn `"TYPE: " P.Pctype (P.getT ea) %
     val offset = getOffset (P.pointsTo $ P.getT ea)field
   in
     case v of
@@ -1271,78 +1288,77 @@ functor IL(P: PARSER) = struct
     case rt of
       RtReg => Printf out `"%" I id %
     | RtRem => raise Unreachable
-    | RtConst w => printf Pwc (getClass C id) w %
-    | RtAddrConst (id, w) => printf `"$" PP.? id Pwc VR8 w %
+    | RtConst w => Printf out Pwc (getClass C id) w %
+    | RtAddrConst (id, w) => Printf out `"$" PP.? id Pwc VR8 w %
   end
   val Preg = fn z => bind A2 preg z
 
   fun printOpSet ctx reg arg =
   let
-    val () = printf `"\t" Preg ctx reg `" " Pt ctx reg `" = " %
+    val () = dprintf `"\t" Preg ctx reg `" " Pt ctx reg `" = " %
   in
     case arg of
-      SaVReg reg => printf Preg ctx reg %
-    | SaConst w => printf Pwc (getClass ctx reg) w %
-    | SaAddr (id, w) => printf PP.? id Pwc VR8 w %
+      SaVReg reg => dprintf Preg ctx reg %
+    | SaConst w => dprintf Pwc (getClass ctx reg) w %
+    | SaAddr (id, w) => dprintf PP.? id Pwc VR8 w %
   end
 
   fun printOp ctx (idx, (SOME op', li)) =
   let
-
-    fun printTail NONE = printf `"\n" %
+    fun printTail NONE = dprintf `"\n" %
       | printTail (SOME (startL, endL)) =
         case op' of
-          IrNopLabel _ => printf `"\n" %
-        | _ => printf `" ; (l" I startL `", l" I endL `")\n" %
+          IrNopLabel _ => dprintf `"\n" %
+        | _ => dprintf `" ; (l" I startL `", l" I endL `")\n" %
 
-    val () = printf I idx `":" %
+    val () = dprintf I idx `":" %
     val () =
       case op' of
         IrNopLabel _ => ()
-      | _ => printf `"\t" %
+      | _ => dprintf `"\t" %
     fun pt (reg1, reg2, reg3) op' =
-      printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
+      dprintf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
           `op' `" " Preg ctx reg2 `", " Preg ctx reg3 %
 
     fun pe (reg1, reg2, aClass) op' =
-      printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
+      dprintf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
           `op' `" " Pac aClass `" " Preg ctx reg2 %
 
-    fun pj (r, l) op' = printf `"\t" `op' `" " Preg ctx r `", " Pl l %
+    fun pj (r, l) op' = dprintf `"\t" `op' `" " Preg ctx r `", " Pl l %
 
-    fun printRet NONE = printf `"\tret" %
+    fun printRet NONE = dprintf `"\tret" %
       | printRet (SOME reg) =
-        printf `"\tret " Pt ctx reg `" " Preg ctx reg %
+        dprintf `"\tret " Pt ctx reg `" " Preg ctx reg %
 
     fun printAlloc (r, size, off) =
     let
-      val () = printf `"\t" Preg ctx r `" = alloc " W size  %
+      val () = dprintf `"\t" Preg ctx r `" = alloc " W size  %
     in
       case off of
-        SOME off => printf `" [rbp-" I off `"]" %
+        SOME off => dprintf `" [rbp-" I off `"]" %
       | NONE => ()
     end
 
     fun printCopy (to, from, size) =
-      printf `"\tcopy " Preg ctx to `", .I" I from `", " W size %
+      dprintf `"\tcopy " Preg ctx to `", .I" I from `", " W size %
 
     fun printFcall (ret, f, args) =
     let
-      val () = printf `"\t" %
+      val () = dprintf `"\t" %
       val () =
         if ret <> ~1 then
-          printf Preg ctx ret `" " Pt ctx ret `" = " %
+          dprintf Preg ctx ret `" " Pt ctx ret `" = " %
         else
           ()
     in
-      printf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) %
+      dprintf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) %
     end
     fun printLabel (Lctx { labels, ... }) lid =
     let
       val (labelPos, use) = D.get labels lid
       val () = if valOf labelPos <> idx then raise Unreachable else ()
     in
-        printf `"@" Pl lid `"(" I use `"):" %
+        dprintf `"@" Pl lid `"(" I use `"):" %
     end
 
     fun cmpOpStr cmpop =
@@ -1381,14 +1397,14 @@ functor IL(P: PARSER) = struct
     | IrExtSign t => pe t "exts"
 
     | IrLoad (r1, r2, ac) =>
-      printf `"\t" Preg ctx r1 `" = " Pac ac `" [" Preg ctx r2 `"]" %
+      dprintf `"\t" Preg ctx r1 `" = " Pac ac `" [" Preg ctx r2 `"]" %
     | IrStore (r1, r2, ac) =>
-      printf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 %
-    | IrJmp l => printf `"\tjmp " Pl l %
+      dprintf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 %
+    | IrJmp l => dprintf `"\tjmp " Pl l %
     | IrJz p => pj p "jz"
     | IrJnz p => pj p "jnz"
     | IrNopLabel l => printLabel ctx l
-    | IrNop s => printf `"\t; " `s %
+    | IrNop s => dprintf `"\t; " `s %
     | IrRet v => printRet v
     | IrAlloc p => printAlloc p
     | IrCopy t => printCopy t
@@ -1405,18 +1421,18 @@ functor IL(P: PARSER) = struct
   let
     val c = if class = VR4 then "w4" else "w8"
 
-    val () = printf `"%" Ip 4 idx `" " `c
+    val () = dprintf `"%" Ip 4 idx `" " `c
           `": defs = " Plist i defs (", ", true, 0)
           `", uses = " Plist i use (", ", true, 0) %
   in
     case t of
-     RtReg => printf `" regular" %
-   | RtRem => printf `" removed" %
-   | RtConst w => printf `" const " Pwc class w %
+     RtReg => dprintf `" regular" %
+   | RtRem => dprintf `" removed" %
+   | RtConst w => dprintf `" const " Pwc class w %
    | RtAddrConst (id, w) =>
-       printf `" addr const " PP.? id Pwc class w %
+       dprintf `" addr const " PP.? id Pwc class w %
    ;
-   printf `"\n" %
+   dprintf `"\n" %
   end
 
   fun printVars (Lctx { vregs, ... }) =
@@ -1434,10 +1450,7 @@ functor IL(P: PARSER) = struct
 
   fun constAdd vregs ops vid v insId =
   let
-    val () = printfn `"new constant: %" I vid %
-
     val { class, defs, use, ... } = D.get vregs vid
-
     val v =
       case v of
         RtConst w =>
@@ -1453,6 +1466,7 @@ functor IL(P: PARSER) = struct
     fun f (SOME _, li) = (NONE, li)
       | f (NONE, _) = raise Unreachable
   in
+    dprintf `"%" I vid `", " %;
     D.update ops f insId
   end
 
@@ -1564,8 +1578,6 @@ functor IL(P: PARSER) = struct
   let
     val rt = getRegType vregs rs
     val ext = if ext = ExtZero then P.extz else P.exts
-
-    val () = printfn `"eval EXT" %
   in
     case rt of
       RtConst w => RtConst $ ext w (ac2word aClass)
@@ -1751,9 +1763,11 @@ functor IL(P: PARSER) = struct
 
   fun constPropagate (C as Lctx { vregs, ops, ... }) =
   let
+    val () = dprintf `"constants: " %
     val worklist = getFirstConstants C
   in
-    propagate worklist vregs ops
+    propagate worklist vregs ops;
+    dprintf `"\n" %
   end
 
   fun changeDest rd ins =
@@ -1791,7 +1805,7 @@ functor IL(P: PARSER) = struct
 
   fun mergeIns (Lctx { vregs, ops, ... }) idx rd rs =
   let
-    val () = printfn `"removing %" I rs %
+    val () = dprintf `"removing %" I rs `"\n" %
 
     val { class, ... } = D.get vregs rs
     val () = D.set vregs rs
@@ -1846,6 +1860,7 @@ functor IL(P: PARSER) = struct
 
   fun removeUnusedLabels (Lctx { ops, labels, ... }) =
   let
+    val () = dprintf `"removing labels: " %
     fun rem (insId, (op', _)) =
       case op' of
         SOME (IrNopLabel lid) =>
@@ -1853,7 +1868,7 @@ functor IL(P: PARSER) = struct
           val (_, usage) = D.get labels lid
         in
           if usage = 0 andalso lid <> 0 then (
-            printfn `"removing label: " I lid %;
+            dprintf `"L" I lid `", " %;
             D.set ops insId (NONE, NONE)
           ) else
             ()
@@ -1868,7 +1883,8 @@ functor IL(P: PARSER) = struct
         loop (idx + 1)
       )
   in
-    loop 0
+    loop 0;
+    dprintf `"\n" %
   end
 
   fun removeUnusedVars (Lctx { fname, vregs, localVars, ... }) =
@@ -1905,23 +1921,28 @@ functor IL(P: PARSER) = struct
     loop 0
   end
 
-  fun translateFn (F as { localVars, stmt, paramNum, name, ... }) =
+  fun translateFn ({ localVars, stmt, paramNum, name, ... }: P.funcInfo) =
   let
-    val () = P.printDef (P.Definition F)
+    val () = dprintf `"\n\nfunction " PP.? name `"\n\n" %
+
     val ctx = createLocalCtx name localVars paramNum
     val () = convStmt ctx stmt
 
     val () = ctxPutOp ctx (IrNopLabel 0)
 
-    val () = printVars ctx
     val () = printIns ctx
+    (*
+    val () = printVars ctx
+    *)
 
-    val () = printf `"\nconstant propagation\n\n" %
+    val () = dprintf `"\nconstant propagation\n\n" %
     val () = constPropagate ctx
+    (*
     val () = printVars ctx
     val () = printIns ctx
+    *)
 
-    val () = printf `"\nmisc il optimizations\n\n" %
+    val () = dprintf `"\nmisc il optimizations\n\n" %
 
     val () = removeUnusedLabels ctx
     val () = removeUnusedVars ctx
@@ -1930,8 +1951,10 @@ functor IL(P: PARSER) = struct
     val () = printVars ctx
     val () = printIns ctx
 
-    val () = printf `"\nvariables\n\n" %
+    (*
+    val () = dprintf `"\nvariables\n\n" %
     val () = printVars ctx
+    *)
 
     val Lctx { vregs, ops, labels, ... } = ctx
   in
@@ -1939,23 +1962,16 @@ functor IL(P: PARSER) = struct
         paramNum, vregs, ops, labels = D.copy labels (fn (v, _) => v) }
   end
 
-  fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) =
+  fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) debugFileName =
   let
+    val () =
+      case debugFileName of
+        NONE => ()
+      | SOME fname => debugFile := SOME (TextIO.openOut fname)
+
     val fis = List.map (fn func => translateFn func) funcs
   in
     Ctx { objs, objsZI, extSyms = ext, globSyms = glob,
       funcInfos = fis, strlits }
   end
-
-  (*
-  fun updateCtx (Ctx ctx) = fn z =>
-  let
-    fun from objs objsZI extSyms globSyms funcInfos strlits =
-      { objs, objsZI, extSyms, globSyms, funcs, strlits }
-    fun to f { objs, objsZI, extSyms, globSyms, funcs, strlits } =
-      f objs objsZI extSyms globSyms funcs strlits
-  in
-    FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f))
-  end
-  *)
 end