rbp register utilization by register allocator

1 files changed, 173 insertions, 113 deletions

diff --git a/emit.fun b/emit.fun
index 90cbaa2..709aaa9 100644
--- a/emit.fun
+++ b/emit.fun
@@ -30,19 +30,19 @@ functor Emit(I: IL) = struct
     (R13, 6),
     (R14, 7),
     (R15, 8),
+    (Rbp, 9),
 
-    (Rdi, 9),
-    (Rsi, 10),
-    (Rdx, 11),
-    (Rcx, 12),
+    (Rdi, 10),
+    (Rsi, 11),
+    (Rdx, 12),
+    (Rcx, 13),
 
-    (Rax, 13),
-    (Rsp, 14),
-    (Rbp, 15)
+    (Rax, 14),
+    (Rsp, 15)
   ]
 
   val callerSavedRegs = 4
-  val usedRegNum = 9
+  val usedRegNum = 10
 
   val usedOverallRegNum = 13
 
@@ -558,9 +558,19 @@ functor Emit(I: IL) = struct
 
   fun returnToPool pool reg =
   let
-    val idx = reg2idx reg
+    fun isCalleeSaved r = reg2idx r >= callerSavedRegs
+
+    fun skipCalleeSaved [] reg = [reg]
+      | skipCalleeSaved (r :: rs) reg =
+        if isCalleeSaved r then
+          r :: skipCalleeSaved rs reg
+        else
+          reg :: r :: rs
   in
-    Array.update (pool, idx, NONE)
+    if isCalleeSaved reg then
+      pool := reg :: !pool
+    else
+      pool := skipCalleeSaved (!pool) reg
   end
 
   fun expireOne { rinfo, active, pool, ... } (_, start, _) =
@@ -609,46 +619,15 @@ functor Emit(I: IL) = struct
     Array.update (arr, idx, (aff, reg))
   end
 
-  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
-    fun loop idx =
-      if idx = Array.length pool then
-        raise Unreachable
-      else
-        let
-          val user = Array.sub (pool, idx)
-        in
-          case user of
-            SOME _ => loop (idx + 1)
-          | NONE =>
-            let
-              val reg = idx2reg idx
-              val () = setUser pool vr reg
+    val reg = hd $ !pool
+    val () = dprintf R poff
+      `"assigned (first) reg " Preg reg `" to %" ip vr `"\n" %
 
-              val () = dprintf R poff
-                `"assigned (first) reg " Preg reg `" to %" ip vr `"\n" %
-            in
-              updReg rinfo vr (VtReg reg)
-            end
-        end
   in
-    loop 0
-  end
-
-  fun freeRegList pool =
-  let
-    fun loop idx acc =
-      if idx = Array.length pool then
-        rev acc
-      else
-        case Array.sub (pool, idx) of
-          NONE => loop (idx + 1) (idx2reg idx :: acc)
-        | SOME _ => loop (idx + 1) acc
-  in
-    loop 0 []
+    pool := tl (!pool);
+    updReg rinfo vr (VtReg reg)
   end
 
   fun getAffRegList rinfo affs =
@@ -682,17 +661,24 @@ functor Emit(I: IL) = struct
     intersection l1 l2
   end
 
+  fun removeReg [] _ = raise Unreachable
+    | removeReg (r :: rs) reg =
+      if r = reg then
+        rs
+      else
+        r :: removeReg rs reg
+
   fun assignSoftReg poff affs (I as { rinfo, pool, ... }) vr =
   let
     val () = dprintf R poff
       `"trying to assign register (by affinity) to %" ip vr `"\n" %
 
-    val regs = freeRegList pool
+    val freeRegs = !pool
     val affRegs = getAffRegList rinfo affs
-    val common = findCommonRegs regs affRegs
+    val common = findCommonRegs freeRegs affRegs
 
     val () = dprintf R (poff + 1)
-      `"free registers: " Plist preg regs (", ", true, 0) `"\n" %
+      `"free registers: " Plist preg freeRegs (", ", true, 0) `"\n" %
     val () = dprintf R (poff + 1)
       `"affinity registers: " Plist preg affRegs (", ", true, 0) `"\n" %
   in
@@ -703,18 +689,15 @@ functor Emit(I: IL) = struct
       in
         assignFirstReg (poff + 2) I vr
       end
-    | (reg :: _) =>
-      let
-      in
-        updReg rinfo vr (VtReg reg);
-        setUser pool vr reg;
-
-        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
+    | (reg :: _) => (
+      pool := removeReg (!pool) reg;
+      updReg rinfo vr (VtReg reg);
+
+      dprintf R (poff + 1)
+        `"assigned (by affinity) reg " Preg reg `" to %" ip vr `"\n" %;
+      dprintf R (poff + 1)
+        `"free registers: " Plist preg (!pool) (", ", true, 0) `"\n" %
+    )
   end
 
   fun putToStack poff { rinfo, stackOff, ... } vr =
@@ -723,7 +706,7 @@ functor Emit(I: IL) = struct
     val () = dprintf R poff
       `"puting %" ip vr `" to stack: " ip newStackOff `"\n" %
   in
-    updReg rinfo vr (VtStack newStackOff);
+    updReg rinfo vr (VtStack (newStackOff));
     stackOff := newStackOff
   end
 
@@ -737,7 +720,10 @@ functor Emit(I: IL) = struct
     | AfHard _ => raise Unreachable
   end
 
-  fun getPool () = Array.array (usedRegNum, NONE)
+  fun getPool I.FtLeaf =
+      [R8, R9, R10, R11, Rbx, R12, R13, R14, R15, Rbp]
+    | getPool I.FtNonLeaf =
+      [R8, Rbx, R9, R12, R13, Rbp, R10, R14, R11, R15]
 
   fun changeInActive active newInt oldVr =
   let
@@ -772,24 +758,28 @@ functor Emit(I: IL) = struct
 
     val () = dprintf `"SpillAtInt\n" %
     val () = dprintf R 0
-      `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) `"\n" %
+      `"free registers: " Plist preg (!pool) (", ", true, 0) `"\n" %
   in
     if #3 spill > #3 int then
       let
-        val () = dprintf `"spilling!!!\n" %
-        val idx = userIdx pool (#1 spill)
-        val reg = idx2reg idx
+        val spillVr = #1 spill
+        val () = dprintf `"spilling (taking from" ip spillVr `")\n" %
+
+        val (_, vt) = Array.sub (rinfo, spillVr)
+        val reg =
+          case vt of
+            VtReg r => r
+          | _ => raise Unreachable
       in
-        setUser pool vr reg;
         updReg rinfo vr (VtReg reg);
-        putToStack 1 I (#1 spill);
-        changeInActive active int (#1 spill)
+        putToStack 1 I spillVr;
+        changeInActive active int spillVr
       end
     else
       putToStack 0 I vr
   end
 
-  fun linearscan rinfo ints stackOff =
+  fun linearscan rinfo ints stackOff ft =
   let
     fun incStart ((_, start1, _), (_, start2, _)) = start1 <= start2
     val ints = sort incStart ints
@@ -817,7 +807,7 @@ functor Emit(I: IL) = struct
         loop I ints
       end
   in
-    loop { active = ref [], pool = getPool (), rinfo,
+    loop { active = ref [], pool = ref $ getPool ft, rinfo,
       stackOff = ref stackOff } ints
   end
 
@@ -996,8 +986,9 @@ functor Emit(I: IL) = struct
     Array.appi printRow map
   end
 
-  fun resolveAlloc ops =
+  fun assignAlloc ops =
   let
+
     fun loop idx stackOffset =
       if idx = D.length ops then
         stackOffset
@@ -1012,8 +1003,8 @@ functor Emit(I: IL) = struct
                 ()
 
             val stackOffset = stackOffset - Word.toInt size
-            val negOffset = ~stackOffset
-            val ins = (SOME $ I.IrAlloc (v, size, SOME negOffset), li)
+
+            val ins = (SOME $ I.IrAlloc (v, size, SOME stackOffset), li)
           in
             D.set ops idx ins;
             loop (idx + 1) stackOffset
@@ -1023,27 +1014,79 @@ functor Emit(I: IL) = struct
     loop 0 0
   end
 
-  fun regAlloc (F as I.Fi { vregs, ops, paramNum, ... }) =
+  fun translateStackAddr rinfo ops stackOffset =
+  let
+    fun resolveAlloc () =
+    let
+      fun loop idx =
+        if idx = D.length ops then
+          ()
+        else
+          let
+            val (ins, li) = D.get ops idx
+          in
+            case ins of
+              SOME (I.IrAlloc (rd, size, SOME off)) =>
+              let
+                val ins = I.IrAlloc (rd, size, SOME $ off - stackOffset)
+              in
+                D.set ops idx (SOME ins, li)
+              end
+            | _ => ();
+            loop (idx + 1)
+          end
+    in
+      loop 0
+    end
+
+    fun resolveRegInfo () =
+    let
+      fun loop idx =
+        if idx = Array.length rinfo then
+          ()
+        else
+          let
+            val (aff, vt) = Array.sub (rinfo, idx)
+          in
+            case vt of
+              VtStack off =>
+                Array.update (rinfo, idx, (aff, VtStack (off - stackOffset)))
+            | _ => ();
+            loop $ idx + 1
+          end
+    in
+      loop 0
+    end
+  in
+    resolveAlloc ();
+    resolveRegInfo ()
+  end
+
+  fun regAlloc (F as I.Fi { name, vregs, ops, paramNum, t, ... }) =
   let
-    val stackOffset = resolveAlloc ops
+    val stackOffset = assignAlloc ops
     val (toAlloc, regInfo) = prepareRegInfo paramNum ops vregs
+    val () = dprintf `"function " PP.? name `"\n\n" %
     val () = dprintf `"for alloc: " Plist i toAlloc (", ", true, 0) `"\n" %
 
     val () = affPrint regInfo
 
     val intervals = computeInts F toAlloc
 
-    val stackOffset = linearscan regInfo intervals stackOffset
+    val stackOffset = linearscan regInfo intervals stackOffset t
     val () = printAlloced regInfo toAlloc
 
     val regsToSave = getRegsToSave regInfo
     val () = dprintf
       `"registers to save: " Plist preg regsToSave (", ", true, 0) `"\n" %
+    val () = translateStackAddr regInfo ops $ !stackOffset
 
     val regMap = computeMap (D.length ops) intervals regInfo
     val () = printMap regMap
   in
-    { regsToSave, stackOffset = !stackOffset, regMap, ops,
+    { regsToSave,
+      stackOffset = !stackOffset - 8 * (length regsToSave),
+      regMap, ops,
       rinfo = regInfo, vregs }
   end
 
@@ -1052,29 +1095,36 @@ functor Emit(I: IL) = struct
   fun emitPrologue ({ stackOffset, regsToSave, ... }) name =
   let
     val () = fprint PP.? name `":\n" %
+    val stackOffset = ~stackOffset - 8 * (length regsToSave)
   in
     List.app (emitPushPopReg "push") regsToSave;
-    if stackOffset <> 0 then (
-      fprinttn `"push rbp" %;
-      fprinttn `"mov rbp, rsp" %;
-      fprinttn `"sub rsp, " I (~ stackOffset) %
-    ) else
+    if stackOffset <> 0 then
+      fprinttn `"sub rsp, " I stackOffset %
+    else
       ()
   end
 
-  fun emitEpilogue { regsToSave, stackOffset, ... } = (
-    if stackOffset <> 0 then (
-      fprinttn `"mov rsp, rbp" %;
-      fprinttn `"pop rbp" %
-    ) else
+  fun emitEpilogue { regsToSave, stackOffset, ... } =
+  let
+    val stackOffset = ~stackOffset - 8 * (length regsToSave)
+  in
+    if stackOffset <> 0 then
+      fprinttn `"add rsp, " I stackOffset %
+    else
       ();
     List.app (emitPushPopReg "pop") (rev regsToSave);
     fprinttn `"ret" %
-  )
+  end
 
+  fun pAddr off out =
+  let
+    val () = if off < 0 then raise Unreachable else ()
+  in
+    Printf out `"[rsp+" I off `"]" %
+  end
 
   fun pm is8 off out =
-    Printf out `(if is8 then "qword" else "dword") `" [rbp-" I off `"]"%
+    Printf out `(if is8 then "qword" else "dword") A1 pAddr off %
 
   fun getType { rinfo, vregs, ... } vr =
   let
@@ -1312,7 +1362,9 @@ functor Emit(I: IL) = struct
     | MRR (off, r1, r2) => [ movMR off r1, opMR off r2 ]
     | RMM (r, off1, off2) => [ movRM r off1, opRM r off2 ]
     | RRV (r1, r2, c) | RVR (r1, c, r2) =>
-      if fitsInNsx 32 c then
+      if isZeroConst c andalso op' = "add" then
+        [ movRR r1 r2 ]
+      else if fitsInNsx 32 c then
         [ movRR r1 r2, opRV r1 c ]
       else
         [ movRV r1 c, opRR r1 r2 ]
@@ -1324,14 +1376,18 @@ functor Emit(I: IL) = struct
     | MM (off1, off2) => [ movRM Rax off2, opMR off1 Rax ]
     | MR (off, r) => [ opMR off r ]
     | MV (off, c) =>
-        if fitsInNsx 32 c then
+        if isZeroConst c andalso op' = "add" then
+          []
+        else if fitsInNsx 32 c then
           [ opMV off c ]
         else
           [ movRV Rax c, opMR off Rax ]
     | RR (r1, r2) => [ opRR r1 r2 ]
     | RM (r, off) => [ opRM r off ]
     | RV (r, c) =>
-      if fitsInNsx 32 c then
+      if isZeroConst c andalso op' = "add" then
+        []
+      else if fitsInNsx 32 c then
         [ opRV r c ]
       else
         [ movRV Rax c, opRR r Rax ]
@@ -1389,13 +1445,13 @@ functor Emit(I: IL) = struct
     | MV (off, v) => [opMV off (t v)]
   end
 
+  datatype cbv = CbvTrue | CbvFalse | CbvUnsure of int * word
+
   fun wordIsZero w =
     case Word.compare (w, 0w0) of
        EQUAL => true
      | _ => false
 
-  datatype cbv = CbvTrue | CbvFalse | CbvUnsure of int * word
-
   fun constBoolVal (VConst w) = if wordIsZero w then CbvFalse else CbvTrue
    | constBoolVal (VAddrConst (id, off)) =
     if wordIsZero off then
@@ -1413,7 +1469,9 @@ functor Emit(I: IL) = struct
       RRR (r1, r2, r3) => [movRR r1 r2, opRR r1 r3]
     | RRM (r1, r2, off) => [movRR r1 r2, opRM r1 off]
     | RRV (r1, r2, c) =>
-      if fitsInNsx 32 c then
+      if isZeroConst c then
+        [movRR r1 r2]
+      else if fitsInNsx 32 c then
         [movRR r1 r2, opRV r1 c]
       else
         [movRR r1 r2, movRV Rax c, opRR r1 Rax]
@@ -1455,14 +1513,18 @@ functor Emit(I: IL) = struct
     | RR (r1, r2) => [opRR r1 r2]
     | RM (r, off) => [opRM r off]
     | RV (r, v) =>
-        if fitsInNsx 32 v then
+        if isZeroConst v then
+          []
+        else if fitsInNsx 32 v then
           [opRV r v]
         else
           [movRV Rax v, opRR r Rax]
     | MR (off, r) => [opMR off r]
     | MM (off1, off2) => [movRM Rax off2, opMR off1 Rax]
     | MV (off, v) =>
-        if fitsInNsx 32 v then
+        if isZeroConst v then
+          []
+        else if fitsInNsx 32 v then
           [opMV off v]
         else
           [movRV Rax v, opMR off Rax]
@@ -1619,7 +1681,12 @@ functor Emit(I: IL) = struct
   fun pByAc ac vt out =
     case vt of
       VtReg r => Printf out `(regByAc ac r) %
-    | VtStack off => Printf out I.Pac ac `" [rbp-" I off `"]" %
+    | VtStack off =>
+        let
+          val () = if off > 0 then raise Unreachable else ()
+        in
+          Printf out I.Pac ac A1 pAddr off %
+        end
     | _ => raise Unreachable
 
   fun emitLoad I (vd, vs, ac) =
@@ -1827,14 +1894,14 @@ functor Emit(I: IL) = struct
      | VtUnk | VtConst _ => raise Unreachable
    end
 
-  fun emitAlloc E (vrd, _, SOME stackOffset) =
+  fun emitAlloc E (vrd, _, SOME offset) =
   let
     val (is8, t1) = getType E vrd
     val () = if not is8 then raise Unreachable else ()
   in
     case t1 of
       VtReg r =>
-      [ sprintf `"lea " A2 pr true r `", [rbp-" I stackOffset `"]" % ]
+      [ sprintf `"lea " A2 pr true r `", " A1 pAddr offset % ]
     | _ => raise Unreachable
   end
     | emitAlloc _ (_, _, NONE) = raise Unreachable
@@ -1925,21 +1992,14 @@ functor Emit(I: IL) = struct
     loop 0 []
   end
 
-  fun prepFuncPrologue ({ stackOffset, regsToSave, regMap, ... }) idx =
+  fun prepFuncPrologue ({ stackOffset, regMap, ... }) idx =
   let
-    val offFromCall = 8 + 8 * length regsToSave
-    val offFromCall =
-      if (stackOffset <> 0) then
-        offFromCall + 8 (* push rbp *)
-      else
-        offFromCall
-    val offFromCall = offFromCall + ~ stackOffset
-
     fun pushRegs regs = map (fn r => sprintf `"push " A2 pr true r %) regs
     val regsWeSave = getRegsWeSave regMap idx
 
-    val registerPush: string list = pushRegs regsWeSave
-    val offFromCall = offFromCall + 8 * length regsWeSave
+    val registerPush = pushRegs regsWeSave
+    val offFromCall =
+      stackOffset - 8 * length regsWeSave - 8 (* for addr put by call *)
 
     val tail =
       if offFromCall mod 16 <> 0 then