Register allocation

1 files changed, 158 insertions, 67 deletions

diff --git a/il.fun b/il.fun
index 13855ba..55f97de 100644
--- a/il.fun
+++ b/il.fun
@@ -75,22 +75,28 @@ functor IL(P: PARSER) = struct
     t: regType
   }
 
+  datatype scopeInfo =
+    SiLoop of { breakL: label, contL: label, startL: label, endL: label } |
+    SiIf
+
   datatype localCtx = Lctx of {
-    localVars: { onStack: bool, t: P.ctype } vector,
+    fname: int,
+    localVars: { onStack: bool, t: P.ctype, name: int } vector,
     paramNum: int,
 
     vregs: regInfo D.t,
-    ops: (irIns option) D.t,
+    ops: (irIns option * (label * label) option) D.t,
 
-    loopLabels: { break: label, continue: label } D.t,
+    scopes: scopeInfo list ref,
     labels: (int option * int) D.t
   }
 
   datatype funcInfo = Fi of {
     name: int,
+    paramNum: int,
     localBound: int,
     vregs: regInfo D.t,
-    ops: (irIns option) D.t,
+    ops: (irIns option * (label * label) option) D.t,
     labels: int option D.t
   }
 
@@ -105,10 +111,10 @@ functor IL(P: PARSER) = struct
 
   fun updateLctx (Lctx ctx) = fn z =>
   let
-    fun from localVars paramNum vregs ops loopLabels labels =
-      { localVars, paramNum, vregs, ops, loopLabels, labels }
-    fun to f { localVars, paramNum, vregs, ops, loopLabels, labels } =
-      f localVars paramNum vregs ops loopLabels labels
+    fun from fname localVars paramNum vregs ops scopes labels =
+      { fname, localVars, paramNum, vregs, ops, scopes, labels }
+    fun to f { fname, localVars, paramNum, vregs, ops, scopes, labels } =
+      f fname localVars paramNum vregs ops scopes labels
   in
     FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f))
   end
@@ -139,9 +145,9 @@ functor IL(P: PARSER) = struct
         Vector.fromList (rev acc)
       else
         let
-          val { onStack: bool, t: P.ctype, ... } = Vector.sub (localVars, idx)
+          val { onStack, t, name, ... } = Vector.sub (localVars, idx)
         in
-          setup (idx + 1) ({ onStack, t } :: acc)
+          setup (idx + 1) ({ onStack, t, name } :: acc)
         end
   in
     setup 0 []
@@ -172,7 +178,7 @@ functor IL(P: PARSER) = struct
           let
             val { t, onStack, ... } = Vector.sub (localVars, idx)
             val class = if onStack then VR8 else getClassForType t
-            val defs = if idx < paramNum then [~1] else []
+            val defs = if idx < paramNum then [0] else []
           in
             D.push vregs ({ class, defs, use = [], t = RtReg });
             loop (idx + 1)
@@ -260,12 +266,30 @@ functor IL(P: PARSER) = struct
     List.app updateUse use
   end
 
-  fun ctxPutOp (C as Lctx { ops, labels, ... }) op' =
+  fun getOutermostLoopIfNeeded scopes =
+  let
+    fun skipToIf [] = NONE
+      | skipToIf (SiLoop _ :: tail) = skipToIf tail
+      | skipToIf (SiIf :: tail) = SOME tail
+
+    fun tryGetFirstLoop (SiIf :: tail) = tryGetFirstLoop tail
+      | tryGetFirstLoop (SiLoop { startL, endL, ... } :: _) =
+        SOME (startL, endL)
+      | tryGetFirstLoop [] = NONE
+  in
+    case skipToIf scopes of
+      NONE => NONE
+    | SOME tail => tryGetFirstLoop (rev tail)
+  end
+
+  fun ctxPutOp (C as Lctx { ops, labels, scopes, ... }) op' =
   let
     val { defs, use } = getInsInfo op'
     val insPos = D.length ops
     val () = updateDefsUse C defs use insPos
-    val () = D.push ops (SOME op')
+
+    val li = getOutermostLoopIfNeeded (!scopes)
+    val () = D.push ops (SOME op', li)
 
     fun setPos (NONE, use) = (SOME insPos, use)
       | setPos (SOME _, _) = raise Unreachable
@@ -297,17 +321,19 @@ functor IL(P: PARSER) = struct
 
   fun getLabel (Lctx { labels, ... }) = D.pushAndGetId labels (NONE, 0)
 
-  fun createLocalCtx localVars paramNum =
+  fun createLocalCtx fname localVars paramNum =
   let
     val localVars = setupLocalVars localVars
     val vregs = setupVregs localVars paramNum
     val labels = D.create0 ()
 
     val ctx = Lctx {
+      fname,
       localVars, paramNum,
       vregs, ops = D.create0 (),
-      loopLabels = D.create0 (), labels
+      scopes = ref [], labels
     }
+    val () = ctxPutOp ctx (IrNop "")
     val _ = getLabel ctx (* label before ret *)
     val () = copyArgs ctx
   in
@@ -929,7 +955,6 @@ functor IL(P: PARSER) = struct
 
     fun genArgs [] acc =
       let
-
         fun loop _ [] acc2 = rev acc2
           | loop idx (vArg :: acc) acc2 =
           let
@@ -941,7 +966,7 @@ functor IL(P: PARSER) = struct
 
         val () = ctxPutOp ctx (IrNop "here")
       in
-        loop 0 acc []
+        loop 0 (rev acc) []
       end
       | genArgs (arg :: args) acc =
       let
@@ -1022,8 +1047,15 @@ functor IL(P: PARSER) = struct
       end
    | NONE => ctxPutOp ctx (IrRet NONE)
 
+  fun beginIfScope (Lctx { scopes, ... }) = scopes := SiIf :: !scopes
+  fun endIfScope (Lctx { scopes, ... }) =
+    case hd (!scopes) of
+      SiLoop _ => raise Unreachable
+    | SiIf => scopes := tl (!scopes)
+
   fun convIf ctx (cond, thenPart, elsePart) =
   let
+    val () = beginIfScope ctx
     val v = genLogPart ctx cond
     val (elseL, endL) = getLabelPair ctx
   in
@@ -1037,63 +1069,94 @@ functor IL(P: PARSER) = struct
         convStmt ctx elsePart;
         ctxPutOp ctx (IrNopLabel endL)
       )
-    | NONE => ()
+    | NONE => ();
+    endIfScope ctx
   end
 
-  and ctxGetLoopLabels (C as Lctx { loopLabels, ... }) =
+  and getLabelsWhile (C as Lctx { scopes, ... }) =
   let
-    val (l1, l2) = getLabelPair C
-
-    val () = D.push loopLabels { break = l1, continue = l2 }
+    val (startL, endL) = getLabelPair C
+    val scope = SiLoop { startL, endL, contL = startL, breakL = endL }
   in
-    (l1, l2)
+    scopes := scope :: !scopes;
+    { startL, endL }
   end
 
-  and ctxLoopExit (Lctx { loopLabels, ... }) = ignore $ D.pop loopLabels
+  and ctxLoopExit (Lctx { scopes, ... }) =
+  let
+    val top = hd $ !scopes
+  in
+    case top of
+      SiLoop _ => scopes := tl (!scopes)
+    | _ => raise Unreachable
+  end
 
   and convWhile ctx (cond, body) =
   let
-    val (breakL, contL) = ctxGetLoopLabels ctx
-    val () = ctxPutOp ctx (IrNopLabel contL)
+    val { startL, endL } = getLabelsWhile ctx
+    val () = ctxPutOp ctx (IrNopLabel startL)
     val cond = genLogPart ctx cond
   in
-    ctxPutOp ctx (IrJz (cond, breakL));
+    ctxPutOp ctx (IrJz (cond, endL));
     convStmt ctx body;
-    ctxPutOp ctx (IrJmp contL);
-    ctxPutOp ctx (IrNopLabel breakL);
+    ctxPutOp ctx (IrJmp startL);
+    ctxPutOp ctx (IrNopLabel endL);
     ctxLoopExit ctx
   end
 
+  and getLabelsDoWhile (C as Lctx { scopes, ... }) =
+  let
+    val startL = getLabel C
+    val (contL, endL) = getLabelPair C
+    val scope = SiLoop { startL, endL, contL, breakL = endL }
+  in
+    scopes := scope :: !scopes;
+    { startL, contL, endL }
+  end
+
   and convDoWhile ctx (body, cond) =
   let
-    val (breakL, contL) = ctxGetLoopLabels ctx
-    val startL = getLabel ctx
+    val { startL, contL, endL } = getLabelsDoWhile ctx
     val () = ctxPutOp ctx (IrNopLabel startL)
     val () = convStmt ctx body
     val () = ctxPutOp ctx (IrNopLabel contL)
     val cond = genLogPart ctx cond
   in
     ctxPutOp ctx (IrJnz (cond, startL));
-    ctxPutOp ctx (IrNopLabel breakL);
+    ctxPutOp ctx (IrNopLabel endL);
     ctxLoopExit ctx
   end
 
-  and convBreakOrCont isBreak (C as Lctx { loopLabels, ... }) =
+  and convBreakOrCont isBreak (C as Lctx { scopes, ... }) =
   let
-    val { break, continue } = D.last loopLabels
+    fun getFirstLoopInfo [] = raise Unreachable
+      | getFirstLoopInfo (SiLoop { breakL, contL, ... } :: _) =
+       (breakL, contL)
+      | getFirstLoopInfo (SiIf :: tail) = getFirstLoopInfo tail
+
+    val (break, continue) = getFirstLoopInfo $ !scopes
     val label = if isBreak then break else continue
   in
     ctxPutOp C (IrJmp label)
   end
 
+  and getLabelsFor (C as Lctx { scopes, ... }) =
+  let
+    val startL = getLabel C
+    val (endL, contL) = getLabelPair C
+    val scope = SiLoop { startL, endL, contL, breakL = endL }
+  in
+    scopes := scope :: !scopes;
+    { startL, contL, endL }
+  end
+
   and convFor ctx (pre, cond, post, stmt) =
   let
     val () =
       case pre of
         NONE => ()
       | SOME ea => ignore $ convExpr ctx ea
-    val startL = getLabel ctx
-    val (breakL, contL) = ctxGetLoopLabels ctx
+    val { startL, contL, endL } = getLabelsFor ctx
 
     val () = ctxPutOp ctx (IrNopLabel startL)
     val () =
@@ -1103,7 +1166,7 @@ functor IL(P: PARSER) = struct
         let
           val cond = genLogPart ctx cond
         in
-          ctxPutOp ctx (IrJz (cond, breakL))
+          ctxPutOp ctx (IrJz (cond, endL))
         end
     val () = convStmt ctx stmt
     val () = ctxPutOp ctx (IrNopLabel contL)
@@ -1112,9 +1175,9 @@ functor IL(P: PARSER) = struct
         NONE => ()
       | SOME post => ignore $ convExpr ctx post
     val () = ctxPutOp ctx (IrJmp startL)
-    val () = ctxPutOp ctx (IrNopLabel breakL)
+    val () = ctxPutOp ctx (IrNopLabel endL)
   in
-    ()
+    ctxLoopExit ctx
   end
 
   and convStmt ctx stmt: unit =
@@ -1131,6 +1194,7 @@ functor IL(P: PARSER) = struct
     | P.StmtDoWhile pair => convDoWhile ctx pair
     | P.StmtBreak => convBreakOrCont true ctx
     | P.StmtContinue => convBreakOrCont false ctx
+    | P.StmtNone => raise Unreachable
 
   val Pl = fn z =>
   let
@@ -1185,12 +1249,6 @@ functor IL(P: PARSER) = struct
   fun preg (C as Lctx { vregs, ... }) id out =
   let
     val rt = getRegType vregs id
-
-    val () =
-      if id = 10 then
-        printfn `"printing 10" %
-      else
-        ()
   in
     case rt of
       RtReg => Printf out `"%" I id %
@@ -1210,10 +1268,20 @@ functor IL(P: PARSER) = struct
     | SaAddr (id, w) => (printf PP.? id %; printConst VR8 w)
   end
 
-  fun printOp ctx (idx, SOME op') =
+  fun printOp ctx (idx, (SOME op', li)) =
   let
 
+    fun printTail NONE = printf `"\n" %
+      | printTail (SOME (startL, endL)) =
+        case op' of
+          IrNopLabel _ => printf `"\n" %
+        | _ => printf `" ; (l" I startL `", l" I endL `")\n" %
+
     val () = printf I idx `":" %
+    val () =
+      case op' of
+        IrNopLabel _ => ()
+      | _ => printf `"\t" %
     fun pt (reg1, reg2, reg3) op' =
       printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
           `op' `" " Preg ctx reg2 `", " Preg ctx reg3 %
@@ -1224,7 +1292,6 @@ functor IL(P: PARSER) = struct
 
     fun pj (r, l) op' = printf `"\t" `op' `" " Preg ctx r `", " Pl l %
 
-
     fun printRet NONE = printf `"\tret" %
       | printRet (SOME reg) =
         printf `"\tret " Pt ctx reg `" " Preg ctx reg %
@@ -1296,9 +1363,9 @@ functor IL(P: PARSER) = struct
     | IrCopy t => printCopy t
     | IrFcall t => printFcall t
     ;
-    printf `"\n" %
+    printTail li
   end
-   | printOp _ (_, NONE) = ()
+   | printOp _ (_, (NONE, _)) = ()
 
   fun printIns (C as Lctx { ops, ... }) =
     D.appi (printOp C) ops
@@ -1351,8 +1418,11 @@ functor IL(P: PARSER) = struct
       | RtAddrConst (id, w) => RtAddrConst (id, w)
       | RtReg | RtRem => raise Unreachable
     val () = D.set vregs vid { class, defs, use, t = v }
+
+    fun f (SOME _, li) = (NONE, li)
+      | f (NONE, _) = raise Unreachable
   in
-    D.set ops insId NONE
+    D.update ops f insId
   end
 
   fun getFirstConstants
@@ -1379,7 +1449,7 @@ functor IL(P: PARSER) = struct
           case defs of
             [def] =>
             let
-              val ins = valOf $ D.get ops def
+              val ins = valOf o #1 $  D.get ops def
             in
               case ins of
                 IrSet(_, arg as SaConst _ | arg as SaAddr _) =>
@@ -1595,7 +1665,7 @@ functor IL(P: PARSER) = struct
 
       fun loop (insId :: tail) acc =
       let
-        val ins = D.get ops insId
+        val (ins, li) = D.get ops insId
 
         (*
         val () = printfn `"v: " I v `", Ins: " I insId %
@@ -1620,7 +1690,7 @@ functor IL(P: PARSER) = struct
                   | _ => raise Unreachable
                 val ins = IrSet (vd, vl)
               in
-                D.set ops insId (SOME ins);
+                D.set ops insId (SOME ins, li);
                 NONE
               end
         in
@@ -1685,12 +1755,19 @@ functor IL(P: PARSER) = struct
   let
     val () = printfn `"removing %" I rs %
 
+
     val { class, ... } = D.get vregs rs
     val () = D.set vregs rs { defs = [], use = [], class, t = RtRem }
-    val ins = valOf $ D.get ops (idx - 1)
+    val ins = valOf o #1 $ D.get ops (idx - 1)
     val ir = changeDest rd ins
-    val () = D.set ops (idx - 1) (SOME ir)
-    val () = D.set ops idx NONE
+
+    fun f1 (SOME _, v) = (SOME ir, v)
+      | f1 (NONE, _) = raise Unreachable
+    fun f2 (SOME _, v) = (NONE, v)
+      | f2 (NONE, _) = raise Unreachable
+
+    val () = D.update ops f1 (idx - 1)
+    val () = D.update ops f2 idx
 
     val { defs, use, class, t } = D.get vregs rd
 
@@ -1703,7 +1780,7 @@ functor IL(P: PARSER) = struct
   end
 
   fun optSet (C as Lctx { vregs, localVars, paramNum, ... })
-    (idx, SOME (IrSet (rd, SaVReg rs)))
+    (idx, (SOME (IrSet (rd, SaVReg rs)), _))
   =
     if getCS vregs rd <> getCS vregs rs then
       ()
@@ -1731,15 +1808,16 @@ functor IL(P: PARSER) = struct
 
   fun removeUnusedLabels (Lctx { ops, labels, ... }) =
   let
-    fun f (insId, op') =
+    fun rem (insId, (op', _)) =
       case op' of
         SOME (IrNopLabel lid) =>
         let
           val (_, usage) = D.get labels lid
         in
-          if usage = 0 then
-            (printfn `"removing label: " I lid %; D.set ops insId NONE)
-          else
+          if usage = 0 then (
+            printfn `"removing label: " I lid %;
+            D.set ops insId (NONE, NONE)
+          ) else
             ()
         end
       | _ => ()
@@ -1748,15 +1826,22 @@ functor IL(P: PARSER) = struct
       if idx = D.length ops then
         ()
       else (
-        f (idx, D.get ops idx);
+        rem (idx, D.get ops idx);
         loop (idx + 1)
       )
   in
     loop 0
   end
 
-  fun removeUnusedVars (Lctx { vregs, ... }) =
+  fun removeUnusedVars (Lctx { fname, vregs, localVars, ... }) =
   let
+    fun die' idx =
+    let
+      val varName = #name $ Vector.sub (localVars, idx)
+    in
+      die 1 PP.? fname `": " PP.? varName
+        `": variable is used uninitialized" %
+    end
     fun loop idx =
       if idx = D.length vregs then
         ()
@@ -1764,8 +1849,14 @@ functor IL(P: PARSER) = struct
         let
           val { defs, use, t, class } = D.get vregs idx
           val t =
-            if t = RtReg andalso defs = [] andalso use = [] then
-              RtRem
+            if t = RtReg andalso defs = [] then
+              case use of
+                [] => RtRem
+              | _ =>
+                if idx < Vector.length localVars then
+                  die' idx
+                else
+                  raise Unreachable
             else
               t
         in
@@ -1779,7 +1870,7 @@ functor IL(P: PARSER) = struct
   fun translateFn (F as { localVars, stmt, paramNum, name, ... }) =
   let
     val () = P.printDef (P.Definition F)
-    val ctx = createLocalCtx localVars paramNum
+    val ctx = createLocalCtx name localVars paramNum
     val () = convStmt ctx stmt
 
     val () = ctxPutOp ctx (IrNopLabel 0)
@@ -1807,7 +1898,7 @@ functor IL(P: PARSER) = struct
     val Lctx { vregs, ops, labels, ... } = ctx
   in
     Fi { name, localBound = Vector.length localVars + paramNum,
-        vregs, ops, labels = D.copy labels (fn (v, _) => v) }
+        paramNum, vregs, ops, labels = D.copy labels (fn (v, _) => v) }
   end
 
   fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) =