Removal of register reassignment in allocator

1 files changed, 158 insertions, 206 deletions

diff --git a/emit.fun b/emit.fun
index ccdb6ce..d42a085 100644
--- a/emit.fun
+++ b/emit.fun
@@ -20,29 +20,31 @@ functor Emit(I: IL) = struct
   datatype affinity = AfHard of reg | AfSoft of int list | AfUnk
 
   val regs = [
-    (Rcx, 0),
-    (Rsi, 1),
-    (Rdi, 2),
-    (R8, 3),
-    (R9, 4),
-    (R10, 5),
-    (R11, 6),
-
-    (Rbx, 7),
-    (R12, 8),
-    (R13, 9),
-    (R14, 10),
-    (R15, 11),
-
-    (Rdx, 12),
+    (R8, 0),
+    (R9, 1),
+    (R10, 2),
+    (R11, 3),
+
+    (Rbx, 4),
+    (R12, 5),
+    (R13, 6),
+    (R14, 7),
+    (R15, 8),
+
+    (Rdi, 9),
+    (Rsi, 10),
+    (Rdx, 11),
+    (Rcx, 12),
 
     (Rax, 13),
     (Rsp, 14),
     (Rbp, 15)
   ]
 
-  val callerSavedRegs = 7
-  val usedRegNum = 12 (* rdx is not counted *)
+  val callerSavedRegs = 4
+  val usedRegNum = 9
+
+  val usedOverallRegNum = 13
 
   fun reg2idx reg =
     case List.find (fn (r, _) => r = reg) regs of
@@ -54,6 +56,24 @@ functor Emit(I: IL) = struct
       NONE => raise Unreachable
     | SOME (r, _) => r
 
+  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
+
   local
     fun output s =
     let
@@ -294,10 +314,11 @@ functor Emit(I: IL) = struct
 
   fun printInts ints =
   let
-    val () = printfn `"\nsorted intervals:\n" %
-    fun p (id, s, e) = printfn `"id: %" I id `" {" I s `", " I e `"}" %
+    val () = dprintf `"\nsorted intervals:\n" %
+    fun p (id, s, e) = dprintf `"id: %" I id `" {" I s `", " I e `"}\n" %
   in
-    List.app p ints
+    List.app p ints;
+    dprintf `"\n" %
   end
 
   fun updAff arr idx aff =
@@ -451,25 +472,33 @@ functor Emit(I: IL) = struct
   let
     val rinfo = Array.array (D.length vregs, (AfUnk, VtUnk))
 
+    val () = compAffinity rinfo ops paramNum;
+
     fun transfer idx acc =
       if idx = D.length vregs then
         rev acc
       else
       let
+        val (aff, _) = Array.sub (rinfo, idx)
+
         val (vt, cand) =
           case #t $ D.get vregs idx of
             I.RtRem => (VtUnk, NONE)
           | I.RtConst w => (VtConst (VConst w), NONE)
-          | I.RtAddrConst (id, w) => (VtConst (VAddrConst (id, w)), NONE)
-          | I.RtReg => (VtUnk, SOME idx)
+          | I.RtAddrConst (id, w) =>
+              (VtConst (VAddrConst (id, w)), NONE)
+          | I.RtReg => (
+            case aff of
+              AfHard reg => (VtReg reg, NONE)
+            | _ => (VtUnk, SOME idx)
+          )
       in
-        Array.update (rinfo, idx, (AfUnk, vt));
+        Array.update (rinfo, idx, (aff, vt));
         transfer (idx + 1) (if isSome cand then valOf cand :: acc else acc)
       end
 
     val toAlloc = transfer 0 []
   in
-    compAffinity rinfo ops paramNum;
     (toAlloc, rinfo)
   end
 
@@ -505,12 +534,12 @@ functor Emit(I: IL) = struct
 
     fun p (idx, (aff, _)) =
     let
-      val () = printf `"%" I idx %
+      val () = dprintf `"%" I idx %
     in
       case aff of
-       AfUnk => printfn `" = unk" %
-     | AfHard reg => printfn `" <- " Preg reg %
-     | AfSoft rss => printfn `" <- " Plist pv rss (", ", true, 1) %
+       AfUnk => dprintf `" = unk\n" %
+     | AfHard reg => dprintf `" <- " Preg reg `"\n" %
+     | AfSoft rss => dprintf `" <- " Plist pv rss (", ", true, 1) `"\n" %
     end
   in
     Array.appi p rinfo
@@ -526,12 +555,11 @@ functor Emit(I: IL) = struct
     FRU.makeUpdate5 (from, from, to) i
   end z
 
-  fun returnToPool (_, rdxRef) Rdx = rdxRef := NONE
-    | returnToPool (arr, _) reg =
+  fun returnToPool pool reg =
   let
     val idx = reg2idx reg
   in
-    Array.update (arr, idx, NONE)
+    Array.update (pool, idx, NONE)
   end
 
   fun expireOne { rinfo, active, pool, ... } (_, start, _) =
@@ -545,9 +573,9 @@ functor Emit(I: IL) = struct
           val (_, vt) = Array.sub (rinfo, j)
           val reg = case vt of VtReg reg => reg | _ => raise Unreachable
 
-          val () = printfn `"III!!! interval %"
+          val () = dprintf `"III!!! interval %"
               ip j `"(" ip startp `", " ip endp `") "
-              `"with " Preg reg `" has expired" %
+              `"with " Preg reg `" has expired\n" %
         in
           returnToPool pool reg;
           active := acts;
@@ -558,12 +586,12 @@ functor Emit(I: IL) = struct
     let
       fun loop I =
         case expireOne I int of
-          false => ()
+          false => dprintf `"\n" %
         | true => loop I
     in
       case !active of
         [] => ()
-      | _ => loop I
+      | _ => (dprintf `"\n" %; loop I)
     end
 
   fun addToActive int [] = [int]
@@ -580,22 +608,17 @@ functor Emit(I: IL) = struct
     Array.update (arr, idx, (aff, reg))
   end
 
-  fun getUser (_, rdxRef) Rdx = !rdxRef
-    | getUser (arr, _) r = Array.sub (arr, reg2idx r)
-
-  fun setUser (_, rdxRef) u Rdx: unit = rdxRef := SOME u
-    | setUser (arr, _) u r = Array.update(arr, reg2idx r, SOME u)
+  fun getUser pool r = Array.sub (pool, reg2idx r)
+  fun setUser pool u r = Array.update(pool, reg2idx r, SOME u)
 
   fun assignFirstReg poff { rinfo, pool, ... } vr =
   let
-    val regArr = #1 pool
-
     fun loop idx =
-      if idx = Array.length regArr then
+      if idx = Array.length pool then
         raise Unreachable
       else
         let
-          val user = Array.sub (regArr, idx)
+          val user = Array.sub (pool, idx)
         in
           case user of
             SOME _ => loop (idx + 1)
@@ -604,8 +627,8 @@ functor Emit(I: IL) = struct
               val reg = idx2reg idx
               val () = setUser pool vr reg
 
-              val () = printfn R poff
-                `"assigned (first) reg " Preg reg `" to %" ip vr %
+              val () = dprintf R poff
+                `"assigned (first) reg " Preg reg `" to %" ip vr `"\n" %
             in
               updReg rinfo vr (VtReg reg)
             end
@@ -614,7 +637,7 @@ functor Emit(I: IL) = struct
     loop 0
   end
 
-  fun freeRegList (pool, _) =
+  fun freeRegList pool =
   let
     fun loop idx acc =
       if idx = Array.length pool then
@@ -660,22 +683,22 @@ functor Emit(I: IL) = struct
 
   fun assignSoftReg poff affs (I as { rinfo, pool, ... }) vr =
   let
-    val () = printfn R poff
-      `"trying to assign register (by affinity) to %" ip vr %
+    val () = dprintf R poff
+      `"trying to assign register (by affinity) to %" ip vr `"\n" %
 
     val regs = freeRegList pool
     val affRegs = getAffRegList rinfo affs
     val common = findCommonRegs regs affRegs
 
-    val () = printfn R (poff + 1)
-      `"free registers: " Plist preg regs (", ", true, 0) %
-    val () = printfn R (poff + 1)
-      `"affinity registers: " Plist preg affRegs (", ", true, 0) %
+    val () = dprintf R (poff + 1)
+      `"free registers: " Plist preg regs (", ", true, 0) `"\n" %
+    val () = dprintf R (poff + 1)
+      `"affinity registers: " Plist preg affRegs (", ", true, 0) `"\n" %
   in
     case common of
       [] =>
       let
-        val () = printfn R (poff + 1) `"affinity was not satisfied" %
+        val () = dprintf R (poff + 1) `"affinity was not satisfied\n" %
       in
         assignFirstReg (poff + 2) I vr
       end
@@ -685,56 +708,24 @@ functor Emit(I: IL) = struct
         updReg rinfo vr (VtReg reg);
         setUser pool vr reg;
 
-        printfn R (poff + 1)
-          `"assigned (by affinity) reg " Preg reg `" to %" ip vr %;
-        printfn R (poff + 1)
-          `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) %
+        dprintf R (poff + 1)
+          `"assigned (by affinity) reg " Preg reg `" to %" ip vr `"\n" %;
+        dprintf R (poff + 1)
+          `"free registers: " Plist preg (freeRegList pool) (", ", true, 0)
+          `"\n" %
       end
   end
 
   fun putToStack poff { rinfo, stackOff, ... } vr =
   let
     val newStackOff = !stackOff - 8
-    val () = printfn R poff
-      `"puting %" ip vr `" to stack: " ip newStackOff %
+    val () = dprintf R poff
+      `"puting %" ip vr `" to stack: " ip newStackOff `"\n" %
   in
     updReg rinfo vr (VtStack newStackOff);
     stackOff := newStackOff
   end
 
-  fun assignHardReg poff (I as { rinfo,  pool, ... }) vr reg =
-  let
-    val () = printfn R poff
-      `"trying to assign hard reg " A1 preg reg `" to %" ip vr %
-
-    val user = getUser pool reg
-
-    fun setOurReg () =
-    let
-      val () = printfn R (poff + 1) `"reg assigned" %
-    in
-      setUser pool vr reg;
-      updReg rinfo vr (VtReg reg)
-    end
-  in
-    case user of
-      NONE => setOurReg ()
-    | SOME u =>
-      let
-        val () = if reg = Rdx then raise Unreachable else ()
-
-        val () = printfn R (poff + 1) `"reg is taken by %" ip u %
-        val (aff, _) = Array.sub (rinfo, u)
-      in
-        case aff of
-          AfHard _ => raise Unreachable
-        | AfSoft affs => assignSoftReg poff affs I u
-        | AfUnk => assignFirstReg poff I u
-        ;
-        setOurReg ()
-      end
-  end
-
   fun assignReg (I as { rinfo, ... }) (vr, _, _) =
   let
     val (aff, _) = Array.sub (rinfo, vr)
@@ -742,11 +733,10 @@ functor Emit(I: IL) = struct
     case aff of
       AfUnk => assignFirstReg 0 I vr
     | AfSoft affs => assignSoftReg 0 affs I vr
-    | AfHard reg => assignHardReg 0 I vr reg
+    | AfHard _ => raise Unreachable
   end
 
-  (* Ref is for Rdx *)
-  fun getPool () = (Array.array (usedRegNum, NONE), ref NONE)
+  fun getPool () = Array.array (usedRegNum, NONE)
 
   fun changeInActive active newInt oldVr =
   let
@@ -756,42 +746,13 @@ functor Emit(I: IL) = struct
     active := addToActive newInt a
   end
 
-  fun expropriateReg (I as { rinfo, pool = (pool, _), active, ... })
-    int reg =
+  fun userIdx pool vr =
   let
-    val vr = #1 int
-
-    val () = if reg = Rdx then raise Unreachable else ()
-
-    val regIdx = reg2idx reg
-    val u = valOf $ Array.sub (pool, regIdx)
-
-    val (uAff, _) = Array.sub (rinfo, u)
-    val () =
-      case uAff of
-        AfHard _ => raise Unreachable
-      | _ => ()
-
-    val () = putToStack 1 I u
-    val () = Array.update (pool, regIdx, SOME vr)
-    val () = updReg rinfo vr (VtReg reg)
-  in
-    changeInActive active int u
-  end
-
-  fun userIdx (arr, rdxRef) vr =
-  let
-    val () =
-      if !rdxRef = SOME vr then
-        raise Unreachable
-      else
-        ()
-
     fun loop idx =
-      if idx = Array.length arr then
+      if idx = Array.length pool then
         raise Unreachable
       else
-        case Array.sub (arr, idx) of
+        case Array.sub (pool, idx) of
           SOME u =>
             if u = vr then
               idx
@@ -807,51 +768,25 @@ functor Emit(I: IL) = struct
     val spill = List.last (!active)
 
     val vr = #1 int
-    val (ourAff, _) = Array.sub (rinfo, vr)
-
-    fun isNotHard vr =
-      case #1 $ Array.sub (rinfo, vr) of
-        AfHard _ => false
-      | _ => true
 
-    val () = printfn `"SpilAtInt" %
-    val () = printfn R 0
-      `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) %
+    val () = dprintf `"SpillAtInt\n" %
+    val () = dprintf R 0
+      `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) `"\n" %
   in
-    case ourAff of
-      AfHard reg => expropriateReg I int reg
-    | _ =>
-      if #3 spill > #3 int andalso isNotHard (#1 spill) then
-        let
-          val idx = userIdx pool (#1 spill)
-          val () = printfn `"spilling!!!" %
-          val reg = idx2reg idx
-        in
-          setUser pool vr reg;
-          updReg rinfo vr (VtReg reg);
-          putToStack 1 I (#1 spill);
-          changeInActive active int (#1 spill)
-        end
-      else
-        putToStack 0 I vr
-  end
-
-  fun haveRoomForVR { rinfo, active, pool = (_, rdxRef), ... } vr =
-    if length (!active) < usedRegNum then
-      true
-    else
+    if #3 spill > #3 int then
       let
-        val (aff, _) = Array.sub (rinfo, vr)
+        val () = dprintf `"spilling!!!\n" %
+        val idx = userIdx pool (#1 spill)
+        val reg = idx2reg idx
       in
-        case aff of
-          AfHard Rdx =>
-            if isSome (!rdxRef) then
-              raise Unreachable
-            else
-              true
-        | _ => false
+        setUser pool vr reg;
+        updReg rinfo vr (VtReg reg);
+        putToStack 1 I (#1 spill);
+        changeInActive active int (#1 spill)
       end
-
+    else
+      putToStack 0 I vr
+  end
 
   fun linearscan rinfo ints stackOff =
   let
@@ -863,13 +798,13 @@ functor Emit(I: IL) = struct
     fun loop { stackOff, ... } [] = stackOff
       | loop (I as { active, ... }) (int :: ints) =
       let
-        val () = printfn `"\n\ninspectiing interval "
-            ip (#1 int) `": (" ip (#2 int) `", " ip (#3 int) `")" %
-
         val () = expireOld I int
 
+        val () = dprintf `"inspecting interval %"
+            ip (#1 int) `": (" ip (#2 int) `", " ip (#3 int) `")\n" %
+
         val () =
-          if haveRoomForVR I (#1 int) then
+          if length (!active) < usedRegNum then
             let
               val () = assignReg I int
             in
@@ -885,17 +820,6 @@ functor Emit(I: IL) = struct
       stackOff = ref stackOff } ints
   end
 
-  fun printAllocVar rinfo v =
-  let
-    val () = printf `"%" I v `": " %
-    val (_, vt) = Array.sub (rinfo, v)
-  in
-    case vt of
-      VtStack off => printfn `"stack " I off %
-    | VtReg reg => printfn `"reg " A1 preg reg %
-    | VtConst _ | VtUnk => raise Unreachable
-  end
-
   fun pr is8 reg out =
   let
     fun old s =
@@ -927,16 +851,28 @@ functor Emit(I: IL) = struct
     | Rsp => old "rsp"
     | Rbp => old "rbp"
   end
+
+  fun printAllocVar rinfo v =
+  let
+    val () = dprintf `"%" I v `": " %
+    val (_, vt) = Array.sub (rinfo, v)
+  in
+    case vt of
+      VtStack off => dprintf `"stack " I off `"\n" %
+    | VtReg reg => dprintf `"reg " A1 preg reg `"\n" %
+    | VtConst _ | VtUnk => raise Unreachable
+  end
+
   fun printAlloced rinfo toAlloc =
   let
-    val () = printfn `"\nallocated:\n" %
+    val () = dprintf `"\nallocated:\n\n" %
   in
     List.app (printAllocVar rinfo) toAlloc
   end
 
   fun getUsedRegs rinfo =
   let
-    val regs = Array.array (usedRegNum + 1, false)
+    val regs = Array.array (usedOverallRegNum, false)
 
     fun loop idx =
       if idx = Array.length rinfo then
@@ -946,10 +882,7 @@ functor Emit(I: IL) = struct
           val (_, vt) = Array.sub (rinfo, idx)
         in
           case vt of
-            VtReg reg => (
-            printfn `"reg: " A2 pr true reg %;
-            Array.update (regs, reg2idx reg, true)
-          )
+            VtReg reg => Array.update (regs, reg2idx reg, true)
           | _ => ();
           loop (idx + 1)
         end
@@ -1016,30 +949,43 @@ functor Emit(I: IL) = struct
 
   fun printMap map =
   let
-    val () = printfn `"Register map\n" %
+    val () = dprintf `"Register map\n\n" %
 
     fun printHeader idx =
       if idx = callerSavedRegs then
-        printf `"\n" %
-      else (
-        printfp 5 `" " Preg (idx2reg idx) `" " %;
-        printHeader (idx + 1)
-      )
-
-    val () = printf `"      " %
+        dprintf `"\n" %
+      else
+        let
+          val reg = sprintf Preg (idx2reg idx) %
+          val reg = if size reg = 3 then reg else " " ^ reg
+        in
+          dprintf `" " `reg `" " %;
+          printHeader (idx + 1)
+        end
+    val () = dprintf `"      " %
     val () = printHeader 0
 
     fun printRow (idx, row) =
     let
-      val () = printf Ip 4 idx `": " %
+      val () = dprintf Ip 4 idx `": " %
 
       fun loop idx =
         if idx = callerSavedRegs then
-          printf `"\n" %
+          dprintf `"\n" %
         else (
           case Array.sub (row, idx) of
-            NONE => printf `"     " %
-          | SOME vr => printfp 5 `"%" I vr `" " %;
+            NONE => dprintf `"     " %
+          | SOME vr =>
+            let
+              val n: string = sprintf I vr %
+              val n =
+                if size n < 3 then
+                  implode (List.tabulate (3 - size n, fn _ => #" ")) ^ n
+                else
+                  n
+            in
+              dprintf `" " `n `" " %
+            end;
           loop (idx + 1)
         )
     in
@@ -1058,7 +1004,6 @@ functor Emit(I: IL) = struct
         case D.get ops idx of
           (SOME (I.IrAlloc (v, size, _)), li) =>
           let
-            val () = printfn `"alloca size: " W size %
             val () =
               if Word.mod (size, 0w8) <> 0w0 then
                 raise Unreachable
@@ -1081,7 +1026,7 @@ functor Emit(I: IL) = struct
   let
     val stackOffset = resolveAlloc ops
     val (toAlloc, regInfo) = prepareRegInfo paramNum ops vregs
-    val () = printfn `"for alloc: " Plist i toAlloc (", ", true, 0) %
+    val () = dprintf `"for alloc: " Plist i toAlloc (", ", true, 0) `"\n" %
 
     val () = affPrint regInfo
 
@@ -1091,8 +1036,8 @@ functor Emit(I: IL) = struct
     val () = printAlloced regInfo toAlloc
 
     val regsToSave = getRegsToSave regInfo
-    val () = printfn
-      `"registers to save: " Plist preg regsToSave (", ", true, 0) %
+    val () = dprintf
+      `"registers to save: " Plist preg regsToSave (", ", true, 0) `"\n" %
 
     val regMap = computeMap (D.length ops) intervals regInfo
     val () = printMap regMap
@@ -2115,8 +2060,15 @@ functor Emit(I: IL) = struct
   fun openFile fname = file := SOME (TextIO.openOut fname)
 
   fun emit fname
-    (I.Ctx { globSyms, extSyms, objsZI, objs, strlits, funcInfos, ... }) =
+    (I.Ctx { globSyms, extSyms, objsZI, objs, strlits, funcInfos, ... })
+    debugFileName
+  =
   let
+
+    val () =
+      case debugFileName of
+        NONE => ()
+      | SOME fname => debugFile := SOME (TextIO.openOut fname)
     val () = openFile fname
 
     val () = List.app (fn gs => fprint `"global " PP.? gs `"\n" %) globSyms