Mul/Div by constant transformation

4 files changed, 135 insertions, 42 deletions

diff --git a/emit.fun b/emit.fun
index 6b8ceb2..90cbaa2 100644
--- a/emit.fun
+++ b/emit.fun
@@ -200,12 +200,12 @@ functor Emit(I: IL) = struct
             val p = SpOrd (ord c)
             val l = collectStr cs []
           in
-            if null acc then l else SpStr (implode $ rev acc) :: p :: l
+            if null acc then p :: l else SpStr (implode $ rev acc) :: p :: l
           end
         | collectStr [] acc =
             if null acc then [] else [SpStr (implode $ rev acc)]
 
-     fun printPart (SpStr s) out = Printf out `"'" `s `"'" %
+     fun printPart (SpStr s) out = Printf out `"\"" `s `"\"" %
        | printPart (SpOrd v) out = Printf out I v %
 
      fun printStr [] = ()
@@ -1496,19 +1496,19 @@ functor Emit(I: IL) = struct
 
     val () = assertSize is81 is82 is83
 
-    val (first, second) =
-      case (t2, t3) of
-        (VtReg _ | VtStack _, _) => (t3, t2)
-      | (_, VtReg _ | VtStack _) => (t2, t3)
-      | (_, _) => raise Unreachable
+    val (pre, right) =
+      case t3 of
+        VtReg _ | VtStack _ => ([], t3)
+      | VtConst c => ([movRV is81 Rcx c], VtReg Rcx)
+      | VtUnk => raise Unreachable
   in
-    [
+    pre @ [
+      mov is81 (VtReg Rax) t2,
       if signExtend then
         if is81 then "cqo" else "cdq"
       else
         "xor edx, edx",
-      mov is81 (VtReg Rax) first,
-      sprintf `op' `" " A2 prm is81 second %,
+      sprintf `op' `" " A2 prm is81 right %,
       mov is81 t1 (VtReg resInReg)
     ]
   end
diff --git a/il.fun b/il.fun
index 0d45676..2db885b 100644
--- a/il.fun
+++ b/il.fun
@@ -72,6 +72,8 @@ functor IL(P: PARSER) = struct
     canFold: bool
   }
 
+  datatype funcType = FtLeaf | FtNonLeaf
+
   datatype scopeInfo =
     SiLoop of { breakL: label, contL: label, startL: label, endL: label } |
     SiIf
@@ -80,6 +82,7 @@ functor IL(P: PARSER) = struct
     fname: int,
     localVars: { onStack: bool, t: P.ctype, name: int } vector,
     paramNum: int,
+    ft: funcType ref,
 
     vregs: regInfo D.t,
     ops: (irIns option * (label * label) option) D.t,
@@ -92,6 +95,7 @@ functor IL(P: PARSER) = struct
     name: int,
     paramNum: int,
     localBound: int,
+    t: funcType,
     vregs: regInfo D.t,
     ops: (irIns option * (label * label) option) D.t,
     labels: int option D.t
@@ -126,12 +130,12 @@ functor IL(P: PARSER) = struct
 
   fun updateLctx (Lctx ctx) = fn z =>
   let
-    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
+    fun from fname localVars paramNum ft vregs ops scopes labels =
+      { fname, localVars, paramNum, ft, vregs, ops, scopes, labels }
+    fun to f { fname, localVars, paramNum, ft, vregs, ops, scopes, labels } =
+      f fname localVars paramNum ft vregs ops scopes labels
   in
-    FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f))
+    FRU.makeUpdate7 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f))
   end
 
   fun isLocal (Lctx { localVars, ... }) id = id < Vector.length localVars
@@ -337,7 +341,7 @@ functor IL(P: PARSER) = struct
 
     val ctx = Lctx {
       fname,
-      localVars, paramNum,
+      localVars, paramNum, ft = ref FtLeaf,
       vregs, ops = D.create0 (),
       scopes = ref [], labels
     }
@@ -362,12 +366,14 @@ functor IL(P: PARSER) = struct
   val getNew4 = getNewVReg VR4
   val getNew8 = getNewVReg VR8
 
-  fun newConst ctx class w =
+  fun newConst (Lctx { vregs, ... }) class w =
   let
-    val v = getNewVReg class ctx
-    val () = ctxPutOp ctx (IrSet (v, SaConst w))
+    val w = P.extz w (if class = VR4 then 0w4 else 0w8)
+
+    val id = D.pushAndGetId vregs { class, defs = [], use = [],
+      t = RtConst w, canFold = true }
   in
-    v
+    id
   end
 
   fun getClass (Lctx { vregs, ... }) id = #class $ D.get vregs id
@@ -694,7 +700,10 @@ functor IL(P: PARSER) = struct
         case convCast ctx (Reg vRight, rightT, P.ulong_t) of
           Reg v => v
         | Addr _ => raise Unreachable
-      val multiplier = newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT))
+
+      val mulVal = P.sizeOfType $ P.pointsTo leftT
+      val multiplier = newConst ctx VR8 mulVal
+
       val vm = getNew8 ctx
       val vRes = getNew8 ctx
     in
@@ -868,6 +877,7 @@ functor IL(P: PARSER) = struct
     val vLeft = genLogPart ctx left
 
     val (elseLabel, endLabel) = getLabelPair ctx
+
     val vRes = getNew4 ctx
     val () = ctxPutOp ctx (IrJz (vLeft, elseLabel))
     val () = ctxPutOp ctx (IrSet (vRes, SaConst 0w1))
@@ -877,6 +887,7 @@ functor IL(P: PARSER) = struct
     val vRight = genLogPart ctx right
     val vC = newConst ctx (getClass ctx vRight) 0w0
     val () = ctxPutOp ctx (IrCmp (Cmpneq, vRes, vRight, vC))
+    val () = ctxPutOp ctx (IrNopLabel endLabel);
   in
     Reg vRes
   end
@@ -889,6 +900,8 @@ functor IL(P: PARSER) = struct
     val vRight = genLogPart ctx right
     val vRes = getNew4 ctx
     val vC = newConst ctx (getClass ctx vRight) 0w0
+
+    val () = printf `"&& labels: " I falseLabel `", " I endLabel %
   in
     ctxPutOp ctx (IrCmp (Cmpneq, vRes, vRight, vC));
     ctxPutOp ctx (IrJmp endLabel);
@@ -1034,7 +1047,9 @@ functor IL(P: PARSER) = struct
           in
             vRes
           end
+    val Lctx { ft, ... } = ctx
   in
+    ft := FtNonLeaf;
     ctxPutOp ctx (IrFcall (vRes, vFunc, args));
     Reg vRes
   end
@@ -1333,7 +1348,7 @@ functor IL(P: PARSER) = struct
           IrNopLabel _ => dprintf `"\n" %
         | _ => dprintf `" ; (l" I startL `", l" I endL `")\n" %
 
-    val () = dprintf I idx `":" %
+    val () = dprintf Ip 4 idx `":" %
     val () =
       case op' of
         IrNopLabel _ => ()
@@ -1454,7 +1469,7 @@ functor IL(P: PARSER) = struct
   let
     val c = if class = VR4 then "w4" else "w8"
 
-    val () = dprintf `"%" Ip 4 idx `" " `c
+    val () = dprintf `"%" I idx `" " `c `"\t"
           `": defs = " Plist i defs (", ", true, 0)
           `", uses = " Plist i use (", ", true, 0) %
   in
@@ -1492,7 +1507,7 @@ functor IL(P: PARSER) = struct
         in
           RtConst w
         end
-      | RtAddrConst (id, w) => RtAddrConst (id, w)
+      | RtAddrConst p => RtAddrConst p
       | RtReg | RtRem => raise Unreachable
     val () = D.set vregs vid { class, defs, use, t = v, canFold = true }
 
@@ -1511,9 +1526,9 @@ functor IL(P: PARSER) = struct
         rev acc
       else
         let
-          val { defs, ... } = D.get vregs vid
+          val { defs, t, ... } = D.get vregs vid
 
-          fun addConst arg def =
+          fun addConstFromSet arg def =
           let
             val v =
               case arg of
@@ -1524,21 +1539,23 @@ functor IL(P: PARSER) = struct
             constAdd vregs ops vid v def
           end
         in
-          case defs of
-            [def] =>
+          case (t, defs) of
+            (RtReg, [def]) =>
             let
-              val ins = valOf o #1 $  D.get ops def
+              val ins = valOf o #1 $ D.get ops def
             in
               case ins of
                 IrSet(_, arg as SaConst _ | arg as SaAddr _) =>
                 let
-                  val () = addConst arg def
+                  val () = addConstFromSet arg def
                 in
                   loop (vid + 1) (vid :: acc)
                 end
               | _ => loop (vid + 1) acc
             end
-            | _ => loop (vid + 1) acc
+          | (RtReg, _) => loop (vid + 1) acc
+          | (RtConst _, _) => loop (vid + 1) (vid :: acc)
+          | _ => raise Unreachable
         end
   in
     loop (Vector.length localVars + paramNum) []
@@ -1893,7 +1910,7 @@ functor IL(P: PARSER) = struct
         if d = idx - 1 andalso rs >= Vector.length localVars + paramNum
         then
           let
-            val () = dprintf `"fusing instruction " I d `" with " I idx %
+            val () = dprintf `"fusing instruction " I d `" with " I idx `"\n" %
             val () = removeVR vregs rs
 
             val ins = valOf o #1 $ D.get ops (idx - 1)
@@ -1949,12 +1966,80 @@ functor IL(P: PARSER) = struct
     | SOME (IrJz (rs, lid)) => fuseJmpCommon C idx rs lid true
     | _ => ()
 
-  fun lowerMul C (idx, (ins, _)) = raise Unimplemented
+  fun log2 0w0 = NONE
+    | log2 w =
+    let
+      open Word
+
+      fun log 0w0 = raise Unreachable
+        | log 0w1 = 0w0
+        | log w = 0w1 + log (>> (w, 0w1))
+
+    in
+      if andb (w, w - 0w1) = 0w0 then
+        SOME $ log w
+      else
+        NONE
+    end
+
+  fun lowerMul' (C as Lctx { vregs, ops, ... }) idx (rd, rs1, rs2) =
+  let
+    val { class, ... } = D.get vregs rd
+    val { t = t1, ... } = D.get vregs rs1
+    val { t = t2, ... } = D.get vregs rs2
+
+    fun tryLower rs v =
+      case log2 v of
+        SOME 0w0 => changeIns ops idx (SOME $ IrSet (rd, SaVReg rs))
+      | SOME log =>
+          let
+            val log = newConst C class log
+          in
+            changeIns ops idx (SOME (IrShl (rd, rs, log)))
+          end
+      | NONE => ()
+  in
+    case (t1, t2) of
+      (RtConst v, _) => tryLower rs2 v
+    | (_, RtConst v) => tryLower rs1 v
+    | _ => ()
+  end
+
+  fun lowerMul C (idx, (ins, _)) =
+    case ins of
+      SOME (IrMul t) => lowerMul' C idx t
+    | SOME (IrIMul t) => lowerMul' C idx t
+    | _ => ()
+
+  fun lowerDiv (C as Lctx { vregs, ops, ... })
+    (idx, (SOME (IrDiv (rd, rs1, rs2)), _))
+  =
+  let
+    val { class, ... } = D.get vregs rd
+    val { t = t1, ... } = D.get vregs rs1
+    val { t = t2, ... } = D.get vregs rs2
+  in
+    case (t1, t2) of
+      (_, RtConst c) => (
+        case log2 c of
+          NONE => ()
+        | SOME 0w0 => changeIns ops idx (SOME $ IrSet (rd, SaVReg rs1))
+        | SOME log =>
+          let
+            val log = newConst C class log
+          in
+            changeIns ops idx (SOME $ IrShr (rd, rs1, log))
+          end
+      )
+    | _ => ()
+  end
+    | lowerDiv _ _ = ()
 
   fun peephole (C as Lctx { ops, ... }) = (
     D.appi (fuseSet C) ops;
     D.appi (fuseJmpc C) ops;
-    D.appi (lowerMul C) ops
+    D.appi (lowerMul C) ops;
+    D.appi (lowerDiv C) ops
   )
 
   fun removeUnusedLabels (Lctx { ops, labels, ... }) =
@@ -2055,10 +2140,14 @@ functor IL(P: PARSER) = struct
     val () = printVars ctx
     *)
 
-    val Lctx { vregs, ops, labels, ... } = ctx
+    val Lctx { vregs, ops, labels, ft, ... } = ctx
   in
-    Fi { name, localBound = Vector.length localVars + paramNum,
-        paramNum, vregs, ops, labels = D.copy labels (fn (v, _) => v) }
+    Fi {
+      name, localBound = Vector.length localVars + paramNum,
+      t = !ft,
+      paramNum, vregs, ops,
+      labels = D.copy labels (fn (v, _) => v)
+    }
   end
 
   fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) debugFileName =
diff --git a/il.sig b/il.sig
index 4c9e3a6..9e994a3 100644
--- a/il.sig
+++ b/il.sig
@@ -78,10 +78,13 @@ signature IL = sig
 
   val wrapTo8: word -> word
 
+  datatype funcType = FtLeaf | FtNonLeaf
+
   datatype funcInfo = Fi of {
     name: int,
     paramNum: int,
     localBound: int,
+    t: funcType,
     vregs: regInfo D.t,
     ops: (irIns option * (label * label) option) D.t,
     labels: int option D.t
diff --git a/parser.fun b/parser.fun
index a954a8e..a229425 100644
--- a/parser.fun
+++ b/parser.fun
@@ -235,6 +235,9 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   in
     case t of
       remote_t id => resolve id
+    | array_t (n, elT) => array_t (n, resolveType elT)
+    | function_t (rt, args, variadic) =>
+        function_t (resolveType rt, map resolveType args, variadic)
     | t => t
   end
 
@@ -1511,7 +1514,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   end
 
   and isLvalue (EA (_, _, lvalue, _)) = lvalue
-  and getT (EA (_, _, _, t)) = t
+  and getT (EA (_, _, _, t)) = resolveType t
   and getPos (EA (_, pos, _, _)) = pos
   and setT (EA (binop, pos, lvalue, _)) t = EA (binop, pos, lvalue, t)
 
@@ -1703,7 +1706,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         else
           P.error (getPos right)
             `"expression has a type incompatible with its sibling: "
-             `"(" Pctype leftT `", >" Pctype rightT `")" %
+             `"(" Pctype leftT `", >>" Pctype rightT `")" %
       else
         P.error (getPos left)
           `"expected value of an arithmetic type or a pointer" %
@@ -2235,9 +2238,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   and eval' (EA (e, pos, _, t)) =
     case e of
       Eid _ => P.error pos `"variable in constant expression" %
-    | Econst (_, Ninteger w) =>
-        (printf `"eval num: " W w `": " Pctype t `"\n" %;
-            ER (w, t))
+    | Econst (_, Ninteger w) => ER (w, t)
     | Econst _ => raise Unreachable
     | Estrlit _ => P.error pos `"string literal in constant expression" %
     | EmemberByV _ | EmemberByP _ =>