Initial import of l5c
authorJoshua Wise <joshua@h2so4.joshuawise.com>
Thu, 14 May 2009 02:23:00 +0000 (22:23 -0400)
committerJoshua Wise <joshua@h2so4.joshuawise.com>
Thu, 14 May 2009 02:23:00 +0000 (22:23 -0400)
39 files changed:
Makefile
README
bin/l4c [deleted file]
bin/l5c [new file with mode: 0755]
codegen/codegen.sml
codegen/coloring.sml
codegen/colororder.sml
codegen/igraph.sml
codegen/liveness.sml
codegen/peephole.sml [deleted file]
codegen/solidify.sml
codegen/stringifier.sml
codegen/x86.sml
compile-l5c.sml [moved from compile-l4c.sml with 72% similarity]
optimize/constfold.sml [new file with mode: 0644]
optimize/feckful.sml [new file with mode: 0644]
optimize/labelcoalescing.sml [new file with mode: 0644]
optimize/optimizer.sml [new file with mode: 0644]
optimize/peephole.sml [new file with mode: 0644]
optimize/stupidfunc.sml [new file with mode: 0644]
parse/ast.sml
parse/astutils.sml
parse/l5.grm [moved from parse/l4.grm with 88% similarity]
parse/l5.lex [moved from parse/l4.lex with 86% similarity]
parse/parse.sml
sources.cm
sources.mlb
top/flags.sml [new file with mode: 0644]
top/mlton-specific.sml [new file with mode: 0644]
top/smlnj-specific.sml [new file with mode: 0644]
top/top.sml
trans/temp.sml
trans/trans.sml
trans/tree.sml
trans/treeutils.sml [new file with mode: 0644]
type/type.sml [new file with mode: 0644]
type/typechecker.sml
util/graph.sml [deleted file]
util/word32.sml

index 2cb4352..2ae3db6 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,14 +1,14 @@
 # the following are SML-NJ specific defines
 SML = sml
 
-l4c: FORCE
-       echo 'use "compile-l4c.sml";' | ${SML}
+l5c: FORCE
+       echo 'use "compile-l5c.sml";' | ${SML}
 
-l4c-mlton: FORCE
-       mllex parse/l4.lex
-       mlyacc parse/l4.grm
-       mlton -output bin/l4c-mlton sources.mlb
-       ${RM} parse/l4.lex.sml
+l5c-mlton: FORCE
+       mllex parse/l5.lex
+       mlyacc parse/l5.grm
+       mlton -profile time -profile-branch true -output bin/l5c-mlton sources.mlb
+       ${RM} parse/l5.lex.sml
 
 reallyclean: clean
        ${RM} parse/*.lex.* parse/*.grm.*
@@ -17,8 +17,8 @@ reallyclean: clean
 clean:
        find . -type d -name .cm | xargs rm -rf
        find . -type f | grep '~$$' | xargs ${RM}
-       ${RM} bin/l4c.heap.*
-       ${RM} bin/l4c-mlton
+       ${RM} bin/l5c.heap.*
+       ${RM} bin/l5c-mlton
 
 
 TAGS: clean
diff --git a/README b/README
index ccc7581..3c068e3 100644 (file)
--- a/README
+++ b/README
@@ -1,64 +1,69 @@
 README
 ------
 
-This compiler is a big long chain of modules that transform l4 code into
+This compiler is a big long chain of modules that transform L5 code into
 x86_64 assembly.
 
-Here is a breakdown of the modules and changes from l3:
+Here is a breakdown of the modules and changes from L5:
 
-  * The parser.  The parser was mainly brought in from lab 3, and mainly
-    just a straight-forward extension of the l3 parser.  We changed asops,
-    since they now side-effect and need special properties.  We also added
-    dereferences, arrays, other nice things.
+  * The parser.  The parser was mainly brought in from lab 4, and mainly
+    just a straight-forward extension of the L4 parser to have increments,
+    decrements, conditionals, and hex constants.
     
-  * AST utilities.  Some of those now exist to make common operations on raw
-    AST structures less painful.
-
-  * The typechecker.  The typechecker was significantly revamped.  A
-    'typeof' function was added that did most of the typechecking work;
-    the rest was relatively trivial compared to typeof.  There were many
-    annoying things other than typeof, but typeof was the most interesting
-    to comment on.
-
-  * The translator was extended with support for sizing up structs.  It now
-    is smarter about translating asops.  A MEMORY thingo was added to the
-    Tree, as was ALLOC.
-
-  * The x86/munch modules were extended with support for multiple operand
-    sizes.  This was done in a fashion of extreme type A, and needs to be
-    blasted before the next lab, for it is worthless, terrible, awful, ... A
-    major falling-down of this compiler is that it passes size information
-    around in no less than 235784 different fashions, and the translation
-    between each has caused us no end of grief.  If we had time to rewrite
-    it instead of firefighting broken tests, uh... we would.  Many of our
-    optimizations from last lab needed to be commented out because of this
-    temporary sizing sadness.
-
-  * The liveness analyzer was mainly unchanged, but for a few rules.
+  * AST utilities were updated to use the new temp typing system.
+
+  * Temporaries now are the only source of sizing information until we hit
+    the stage at which point instructions are generated.  At that point,
+    instructions get sizing info, too, but really, that's about it.
+
+  * The typechecker was mostly unchanged.
+
+  * The translator was changed to use the new sizing system.  Of interest,
+    the 'safe' alloc routine and the 'safe' dereference routines have been
+    moved into the IR stage, as opposed to having custom instructions
+    generated for them at the munch stage.  This was done with the addition
+    of the 'stmvar' IR function, which is equivalent to the GCC C extension:
+      ({ stm; stm; ... expr })
+    in that it evaluates the statements first, then returns the evaluation
+    of the expression.
+
+  * The munch modules were updated to remove a lot of their suck and make
+    them correct again. Specifically, they were updated to use the new
+    typing system and perform type inference of sorts (i.e. adding a
+    quadword base pointer and a long offset yields a quad, etc.). This is
+    far superior to the previous sizing method, in which we gave some loose
+    (and disgusting) annotations of size and left the final sizing decisions
+    to the stringifier (O.o).
+
+  * The liveness analyzer was mainly unchanged.
 
   * The grapher was fully unchanged.  Nice.
 
-  * The color orderer was fully unchanged.  Nice.
+  * The color orderer was optimized a bit.
 
   * The coloring module was fully unchanged.  Nice.
 
-  * The solidifier was modified to deal with the fact that certain things
-    could not be accessed directly.  It, too, has become an unmitigated
-    disaster.  It must deal with all 875847384 of the sizes, and I am sad
-    about this.
+  * The solidifier was similarly ripped out and hit by the diqing beam, sent
+    on a flight to Diqing airport, which is in Diqing which is in
+    the Diqing province in China, and subsequently it was diqed.  It is now
+    much happier.
+
+  * The peepholer has been moved into the optimization framework.
 
-  * The peepholer lost one form of fail and loss sizing.
+  * An optimization framework was added, allowing optimizers to be
+    individually turned off from the command line with approximately no work
+    on our part.  I'm particularly proud of the simplicity with which it
+    allows one to write optimizations; see optimize/feckful.sml.  They need
+    only be hooked in one place (in particular, in a list at the top of
+    top.sml).  Individual optimizations will be discussed in the paper to be
+    handed in tomorrow.
 
   * The stringifier is of no interest to you, for it does real things that
     interact with the real world, and that is not of interest to people who
     write in ML.
 
-  * Our internal representation of x86 assembly was changed. In particular,
-    conditional sets and jumps are now SETcc of cc * oper and Jcc of cc *
-    oper, instead of a separate SET or J for each condition code. This
-    simplifies other parts of the code as well.
-
 We believe that it is fully functional. We generate correct code whenever we
 are supposed to, and we pass every test that we can lay our hands on
-(including all of l2, and one of ours that killed the reference compiler).
-Of course, our last bug was caught by only one failing test, so...
\ No newline at end of file
+(including all of the regression suite). There are a number of optimizations
+that we wish to do, especially various interprocedural ones, but we ran out
+of time.
diff --git a/bin/l4c b/bin/l4c
deleted file mode 100755 (executable)
index 0259f69..0000000
--- a/bin/l4c
+++ /dev/null
@@ -1 +0,0 @@
-sml @SMLcmdname=$0 @SMLload=bin/l4c.heap.x86-linux $*
diff --git a/bin/l5c b/bin/l5c
new file mode 100755 (executable)
index 0000000..d883d20
--- /dev/null
+++ b/bin/l5c
@@ -0,0 +1 @@
+sml @SMLcmdname=$0 @SMLload=bin/l5c.heap.x86-linux $*
index 6ee8c2f..18ac4af 100644 (file)
@@ -12,22 +12,12 @@ end
 structure Codegen :> CODEGEN = 
 struct
   structure T = Tree
+  structure TU = TreeUtils
   structure X = x86
-
-  (* effect : T.exp -> bool
-   * true iff the given expression has an effect.
-   *)
-  fun effect (T.BINOP(T.DIV, _, _)) = true
-    | effect (T.BINOP(T.MOD, _, _)) = true
-    | effect (T.CALL _) = true
-    | effect (T.BINOP(_, a, b)) = (effect a) orelse (effect b)
-    | effect (T.UNOP (_, a)) = effect a
-    | effect (T.MEMORY m) = true
-    | effect (T.ALLOC(_)) = true
-    | effect _ = false
+  structure Tm = Temp
 
   (* hasfixed : T.exp -> bool
-   * true iff the given expression has an hasfixed. Somewhat like effect, hmm?
+   * true iff the given expression has an hasfixed.
    *)
   fun hasfixed (T.BINOP(T.DIV, _, _)) = true
     | hasfixed (T.BINOP(T.MOD, _, _)) = true
@@ -37,24 +27,52 @@ struct
     | hasfixed (T.BINOP(_, a, b)) = (hasfixed a) orelse (hasfixed b)
     | hasfixed (T.UNOP (_, a)) = hasfixed a
     | hasfixed (T.ALLOC(_)) = true
-    | hasfixed (T.MEMORY m) = hasfixed m
+    | hasfixed (T.MEMORY (m,s)) = hasfixed m
+    | hasfixed (T.STMVAR _) = true
     | hasfixed _ = false
 
+  fun offshit a b 0w4 d = [X.LEA(d, (X.REL((a, Tm.Quad), (b, Tm.Quad), 0w4), Tm.Quad))]
+    | offshit a b 0w8 d = [X.LEA(d, (X.REL((a, Tm.Quad), (b, Tm.Quad), 0w8), Tm.Quad))]
+    | offshit a b n d   = [X.IMUL((b, Tm.Long), (X.CONST n, Tm.Long)), X.MOV(d, (a, Tm.Quad)), X.ADD(d, (b, Tm.Quad))]
+
+  fun binophit_c d oper e c = let val (i, s) = munch_exp d e in (i @ [oper ((d,s), (X.CONST c, s))], s) end
+  and binophit_t d oper e t =
+    let
+      val (i, s) = munch_exp d e
+      val ts = Tm.size t
+      val rs = if Tm.cmpsize (s, ts) = GREATER then s else ts
+    in
+      (i @ [oper ((d, rs), (X.TEMP t, rs))], rs)
+    end
+  and binophit d oper e1 e2 =
+    let
+      val t = X.TEMP (Tm.new "add" Tm.Long)
+      val (i1, s1) = munch_exp d e1
+      val (i2, s2) = munch_exp t e2
+(*      val _ = print ("s1 = " ^ Tm.sfx s1 ^ ", s2 = " ^ Tm.sfx s2 ^ ", ") *)
+      val rs = if Tm.cmpsize (s1, s2) = GREATER then s1 else s2
+(*      val _ = print ("rs = " ^ Tm.sfx rs ^ " from " ^ TU.Print.pp_exp e1 ^ " and " ^ TU.Print.pp_exp e2 ^ "\n") *)
+    in
+      (i1 @ i2 @ [oper ((d,rs), (t,rs))], rs)
+    end
+  and cmphit d a = let val (insns, pos, neg) = munch_cond a in (insns @ [X.SETcc (pos, (d, Tm.Byte)), X.MOVZB((d, Tm.Long), (d, Tm.Byte))], Tm.Long) end
+
   (* munch_exp : prex86oper -> T.exp -> prex86insn list *)
   (* munch_exp d e
    * generates instructions to achieve d <- e
    * d must be TEMP(t) or REG(r)
    *)
-  and munch_exp d (T.CONST(n)) = [X.MOV(d, X.CONST n)]
-    | munch_exp d (T.TEMP(t)) = [X.MOV(d, X.TEMP t)]
-    | munch_exp d (T.ARG(0, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.EDI))]
-    | munch_exp d (T.ARG(1, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.ESI))]
-    | munch_exp d (T.ARG(2, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.EDX))]
-    | munch_exp d (T.ARG(3, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.ECX))]
-    | munch_exp d (T.ARG(4, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.R8D))]
-    | munch_exp d (T.ARG(5, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.R9D))]
-    | munch_exp d (T.ARG(t, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.STACKARG (t - 6)))]
-    | munch_exp d (T.CALL(name, l, rsz)) =     (* Scary demons live here. *)
+  and munch_exp d (T.CONST n) = ([X.MOV((d, Tm.Long), (X.CONST n, Tm.Long))], Tm.Long)
+    | munch_exp d (T.NULLPTR) = ([X.MOV((d, Tm.Quad), (X.CONST 0w0, Tm.Quad))], Tm.Quad)
+    | munch_exp d (T.TEMP(t)) = ([X.MOV((d, Tm.size t), (X.TEMP t, Tm.size t))], Tm.size t)
+    | munch_exp d (T.ARG(0, sz)) = ([X.MOV((d, sz), (X.REG X.EDI, sz))], sz)
+    | munch_exp d (T.ARG(1, sz)) = ([X.MOV((d, sz), (X.REG X.ESI, sz))], sz)
+    | munch_exp d (T.ARG(2, sz)) = ([X.MOV((d, sz), (X.REG X.EDX, sz))], sz)
+    | munch_exp d (T.ARG(3, sz)) = ([X.MOV((d, sz), (X.REG X.ECX, sz))], sz)
+    | munch_exp d (T.ARG(4, sz)) = ([X.MOV((d, sz), (X.REG X.R8D, sz))], sz)
+    | munch_exp d (T.ARG(5, sz)) = ([X.MOV((d, sz), (X.REG X.R9D, sz))], sz)
+    | munch_exp d (T.ARG(t, sz)) = ([X.MOV((d, sz), (X.STACKARG (t - 6), sz))], sz)
+    | munch_exp d (T.CALL(name, l, rsz)) = (* Scary demons live here. *)
         let
           val nargs = length l
           val nstack = if (nargs <= 6)
@@ -67,7 +85,7 @@ struct
             | argdest 4 = X.REG X.ECX
             | argdest 5 = X.REG X.R8D
             | argdest 6 = X.REG X.R9D
-            | argdest n = X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (~(stackb - 8 * (n - 7)))) )
+            | argdest n = X.REL ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt (~(stackb - 8 * (n - 7)))), Tm.Quad), 0w1)
 
           val dests = List.tabulate (nargs, fn x => argdest (x+1))
           val (exps,_) = ListPair.unzip l
@@ -83,180 +101,205 @@ struct
             (ListPair.zip (dests,l), hf)
           )
           val temps = List.map (fn (_, sz) => Temp.new ("arg") sz (* xxx? *)) l_hf
-          val argevals_hf = List.map
+          val (argevals_hf,_) = ListPair.unzip (List.map
             (fn (t,(exp,_)) => munch_exp (X.TEMP t) exp)
-            (ListPair.zip (temps, l_hf))
+            (ListPair.zip (temps, l_hf)))
           val argpushes = List.map
-            (fn (dest, t) => [(X.MOV (X.OSIZE(X.sts (Temp.size t), dest), X.TEMP t))])
+            (fn (dest, t) => [X.MOV ((dest, Tm.size t), (X.TEMP t, Tm.size t))])
             (ListPair.zip (d_hf, temps))
-          val argevals_nohf = List.map
-            (fn (d,(exp,sz)) => munch_exp (X.OSIZE (X.sts sz, d)) exp)
-            (ListPair.zip (d_nohf, l_nohf))
+          val (argevals_nohf,_) = ListPair.unzip (List.map
+            (fn (d,(exp,sz)) => munch_exp d exp)
+            (ListPair.zip (d_nohf, l_nohf)))
         in
-          List.concat argevals_hf @ 
-          List.concat argpushes @
-          List.concat argevals_nohf @
-          [ X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stackb)),
-            X.CALL (name, nargs),
-            X.ADD (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stackb)),
-            X.MOV (d, X.OSIZE (X.sts rsz, X.REG X.EAX)) ]      (* Finally! *)
-        end
-(*    | munch_exp d (T.BINOP(T.ADD, e1, T.CONST 0w0)) = munch_exp d e1
-    | munch_exp d (T.BINOP(T.ADD, T.CONST 0w0, e1)) = munch_exp d e1
-    | munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = (munch_exp d e1) @ [X.ADD(d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = (munch_exp d e1) @ [X.ADD(d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = (munch_exp d e1) @ [X.ADD(d, X.TEMP t)]
-    | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e2)) = (munch_exp d e2) @ [X.ADD(d, X.TEMP t)] *)
-    | munch_exp d (T.BINOP(T.ADD, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("add") 4)
-        in
-          (munch_exp d e1) @ (munch_exp t1 e2) @ [X.ADD(d, t1)]
-        end
-(*    | munch_exp d (T.BINOP(T.SUB, T.CONST 0w0, e1)) = (munch_exp d e1) @ [X.NEG d]
-    | munch_exp d (T.BINOP(T.SUB, e1, T.CONST 0w0)) = munch_exp d e1
-    | munch_exp d (T.BINOP(T.SUB, e1, T.CONST(n))) = (munch_exp d e1) @ [X.SUB(d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = (munch_exp d e1) @ [X.SUB(d, X.TEMP t)] *)
-    | munch_exp d (T.BINOP(T.SUB, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("sub") 4)
-        in
-          (munch_exp d e1) @ (munch_exp t1 e2) @ [X.SUB(d, t1)]
-        end
-    | munch_exp d (T.BINOP(T.MUL, T.TEMP t, T.CONST n)) = [X.IMUL3(d, X.TEMP t, n)]
-    | munch_exp d (T.BINOP(T.MUL, T.CONST n, T.TEMP t)) = [X.IMUL3(d, X.TEMP t, n)]
-(*
-    | munch_exp d (T.BINOP(T.MUL, e1, T.CONST 0w1)) = munch_exp d e1
-    | munch_exp d (T.BINOP(T.MUL, T.CONST 0w1, e1)) = munch_exp d e1
-    | munch_exp d (T.BINOP(T.MUL, e1, T.CONST n)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.MUL, T.CONST n, e1)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] *)
-    | munch_exp d (T.BINOP(T.MUL, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("mul") 4)
-        in
-          (munch_exp d e1) @ (munch_exp t1 e2) @ [X.IMUL(d, t1)]
+          (List.concat argevals_hf @ 
+           List.concat argpushes @
+           List.concat argevals_nohf @
+           [ X.SUB ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stackb), Tm.Quad)),
+             X.CALL (name, nargs),
+             X.ADD ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stackb), Tm.Quad)),
+             X.MOV ((d, rsz), (X.REG X.EAX, rsz))], rsz)      (* Finally! *)
         end
+    | munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = binophit_c d X.ADD e1 n
+    | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = binophit_c d X.ADD e1 n
+    | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = binophit_t d X.ADD e1 t
+    | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e1)) = binophit_t d X.ADD e1 t
+    | munch_exp d (T.BINOP(T.ADD, e1, e2)) = binophit d X.ADD e1 e2
+
+    | munch_exp d (T.BINOP(T.SUB, e1, T.CONST n)) = binophit_c d X.SUB e1 n
+    | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = binophit_t d X.SUB e1 t
+    | munch_exp d (T.BINOP(T.SUB, e1, e2)) = binophit d X.SUB e1 e2
+    | munch_exp d (T.BINOP(T.MUL, T.TEMP t, T.CONST n)) = let val s = Tm.size t in ([X.IMUL3((d,s), (X.TEMP t,s), n)], Tm.size t) end
+    | munch_exp d (T.BINOP(T.MUL, T.CONST n, T.TEMP t)) = let val s = Tm.size t in ([X.IMUL3((d,s), (X.TEMP t,s), n)], Tm.size t) end
+    | munch_exp d (T.BINOP(T.MUL, e1, T.CONST n)) = binophit_c d X.IMUL e1 n
+    | munch_exp d (T.BINOP(T.MUL, T.CONST n, e1)) = binophit_c d X.IMUL e1 n
+    | munch_exp d (T.BINOP(T.MUL, e1, e2)) = binophit d X.IMUL e1 e2
     | munch_exp d (T.BINOP(T.DIV, e1, e2)) =
         let
-          val t1 = X.TEMP (Temp.new ("div") 4)
+          val t1 = X.TEMP (Temp.new ("div") Tm.Long)
+          val (i1, s1) = munch_exp t1 e1
+          val (i2, s2) = munch_exp d e2
         in
-          (munch_exp t1 e1) @ (munch_exp d e2) @
-          [X.MOV (X.REG X.EAX, t1), X.CLTD, X.IDIV d, X.MOV (d, X.REG X.EAX)]
+          (i1 @ i2 @ [X.MOV ((X.REG X.EAX, s1), (t1, s1)), X.CLTD, X.IDIV (d, s2), X.MOV ((d, s2), (X.REG X.EAX, s2))], Tm.Long)
         end
     | munch_exp d (T.BINOP(T.MOD, e1, e2)) =
         let
-          val t1 = X.TEMP (Temp.new ("mod") 4)
+          val t1 = X.TEMP (Temp.new ("div") Tm.Long)
+          val (i1, s1) = munch_exp t1 e1
+          val (i2, s2) = munch_exp d e2
         in
-          (munch_exp t1 e1) @ (munch_exp d e2) @
-          [X.MOV (X.REG X.EAX, t1), X.CLTD, X.IDIV d, X.MOV (d, X.REG X.EDX)]
+          (i1 @ i2 @ [X.MOV ((X.REG X.EAX, s1), (t1, s1)), X.CLTD, X.IDIV (d, s2), X.MOV ((d, s2), (X.REG X.EDX, s2))], Tm.Long)
         end
-    | munch_exp d (T.BINOP(T.LSH, e1, T.CONST n)) = (munch_exp d e1) @ [X.SAL (d, X.CONST (n mod 0w32))]
-    | munch_exp d (T.BINOP(T.LSH, e1, T.TEMP t)) = (munch_exp d e1) @ [X.MOV (X.REG X.ECX, X.TEMP t), X.SAL (d, X.REG X.ECX)]
-    | munch_exp d (T.BINOP(T.LSH, e1, e2)) =
+    | munch_exp d (T.BINOP(T.LSH, e1, T.CONST n)) = let val (i,s) = munch_exp d e1 in (i @ [X.SAL ((d,s), (X.CONST (n mod 0w32),s))],s) end
+    | munch_exp d (T.BINOP(T.LSH, e1, T.TEMP t)) =
         let
-          val t = X.TEMP (Temp.new ("lsh") 4)
-        in
-          (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAL (d, X.REG X.ECX)]
+          val (i,s) = munch_exp d e1
+        in 
+          (i @ [X.MOV ((X.REG X.ECX, s), (X.TEMP t, s)), X.SAL ((d,s), (X.REG X.ECX, Tm.Byte))], s)
         end
-    | munch_exp d (T.BINOP(T.RSH, e1, T.CONST n)) = (munch_exp d e1) @ [X.SAR (d, X.CONST (n mod 0w32))]
-    | munch_exp d (T.BINOP(T.RSH, e1, T.TEMP t)) = (munch_exp d e1) @ [X.MOV (X.REG X.ECX, X.TEMP t), X.SAR (d, X.REG X.ECX)]
-    | munch_exp d (T.BINOP(T.RSH, e1, e2)) =
-        let
-          val t = X.TEMP (Temp.new ("rsh") 4)
-        in
-          (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAR (d, X.REG X.ECX)]
-        end
-    | munch_exp d (T.BINOP(T.BITAND, T.CONST n, e1)) = (munch_exp d e1) @ [X.AND (d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.BITAND, e1, T.CONST n)) = (munch_exp d e1) @ [X.AND (d, X.CONST n)] 
-    | munch_exp d (T.BINOP(T.BITAND, T.TEMP t, e1)) = (munch_exp d e1) @ [X.AND (d, X.TEMP t)]
-    | munch_exp d (T.BINOP(T.BITAND, e1, T.TEMP t)) = (munch_exp d e1) @ [X.AND (d, X.TEMP t)] 
-    | munch_exp d (T.BINOP(T.BITAND, e1, e2)) =
+    | munch_exp d (T.BINOP(T.LSH, e1, e2)) =
         let
-          val t1 = X.TEMP (Temp.new ("bitand") 4)
+          val t = X.TEMP (Temp.new ("lsh") Tm.Long)
+          val (i1, s1) = munch_exp d e1
+          val (i2, s2) = munch_exp t e2
         in
-          (munch_exp d e1) @ (munch_exp t1 e2) @ [X.AND(d, t1)]
+          (i1 @ i2 @ [X.MOV ((X.REG X.ECX, s1), (t, s1)), X.SAL ((d, s2), (X.REG X.ECX, Tm.Byte))], s2)
         end
-    | munch_exp d (T.BINOP(T.BITOR, T.CONST n, e1)) = (munch_exp d e1) @ [X.OR (d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.BITOR, e1, T.CONST n)) = (munch_exp d e1) @ [X.OR (d, X.CONST n)] 
-    | munch_exp d (T.BINOP(T.BITOR, T.TEMP t, e1)) = (munch_exp d e1) @ [X.OR (d, X.TEMP t)]
-    | munch_exp d (T.BINOP(T.BITOR, e1, T.TEMP t)) = (munch_exp d e1) @ [X.OR (d, X.TEMP t)] 
-    | munch_exp d (T.BINOP(T.BITOR, e1, e2)) =
+    | munch_exp d (T.BINOP(T.RSH, e1, T.CONST n)) = let val (i,s) = munch_exp d e1 in (i @ [X.SAR ((d,s), (X.CONST (n mod 0w32),s))],s) end
+    | munch_exp d (T.BINOP(T.RSH, e1, T.TEMP t)) =
         let
-          val t1 = X.TEMP (Temp.new ("bitor") 4)
-        in
-          (munch_exp d e1) @ (munch_exp t1 e2) @ [X.OR(d, t1)]
+          val (i,s) = munch_exp d e1
+        in 
+          (i @ [X.MOV ((X.REG X.ECX, s), (X.TEMP t, s)), X.SAR ((d,s), (X.REG X.ECX, Tm.Byte))], s)
         end
-    | munch_exp d (T.BINOP(T.BITXOR, T.CONST n, e1)) = (munch_exp d e1) @ [X.XOR (d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.BITXOR, e1, T.CONST n)) = (munch_exp d e1) @ [X.XOR (d, X.CONST n)]
-    | munch_exp d (T.BINOP(T.BITXOR, T.TEMP t, e1)) = (munch_exp d e1) @ [X.XOR (d, X.TEMP t)]
-    | munch_exp d (T.BINOP(T.BITXOR, e1, T.TEMP t)) = (munch_exp d e1) @ [X.XOR (d, X.TEMP t)]
-    | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) =
+    | munch_exp d (T.BINOP(T.RSH, e1, e2)) =
         let
-          val t1 = X.TEMP (Temp.new ("bitxor") 4)
+          val t = X.TEMP (Temp.new ("lsh") Tm.Long)
+          val (i1, s1) = munch_exp d e1
+          val (i2, s2) = munch_exp t e2
         in
-          (munch_exp d e1) @ (munch_exp t1 e2) @ [X.XOR(d, t1)]
+          (i1 @ i2 @ [X.MOV ((X.REG X.ECX, s1), (t, s1)), X.SAR ((d, s2), (X.REG X.ECX, Tm.Byte))], s2)
         end
+    | munch_exp d (T.BINOP(T.BITAND, T.CONST n, e1)) = binophit_c d X.AND e1 n
+    | munch_exp d (T.BINOP(T.BITAND, e1, T.CONST n)) = binophit_c d X.AND e1 n
+    | munch_exp d (T.BINOP(T.BITAND, T.TEMP t, e1)) = binophit_t d X.AND e1 t
+    | munch_exp d (T.BINOP(T.BITAND, e1, T.TEMP t)) = binophit_t d X.AND e1 t
+    | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = binophit d X.AND e1 e2
+
+    | munch_exp d (T.BINOP(T.BITOR, T.CONST n, e1)) = binophit_c d X.OR e1 n
+    | munch_exp d (T.BINOP(T.BITOR, e1, T.CONST n)) = binophit_c d X.OR e1 n
+    | munch_exp d (T.BINOP(T.BITOR, T.TEMP t, e1)) = binophit_t d X.OR e1 t
+    | munch_exp d (T.BINOP(T.BITOR, e1, T.TEMP t)) = binophit_t d X.OR e1 t
+    | munch_exp d (T.BINOP(T.BITOR, e1, e2)) = binophit d X.OR e1 e2
+
+    | munch_exp d (T.BINOP(T.BITXOR, T.CONST n, e1)) = binophit_c d X.XOR e1 n
+    | munch_exp d (T.BINOP(T.BITXOR, e1, T.CONST n)) = binophit_c d X.XOR e1 n
+    | munch_exp d (T.BINOP(T.BITXOR, T.TEMP t, e1)) = binophit_t d X.XOR e1 t
+    | munch_exp d (T.BINOP(T.BITXOR, e1, T.TEMP t)) = binophit_t d X.XOR e1 t
+    | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) = binophit d X.XOR e1 e2
+
     | munch_exp d (a as T.BINOP(T.LOGAND, e1, e2)) =
         let
           val (insn1, pos1, neg1) = munch_cond e1
           val (insn2, pos2, neg2) = munch_cond e2
-          val t1 = X.TEMP (Temp.new("logand 1") 4)
-          val t2 = X.TEMP (Temp.new("logand 2") 4)
+          val t1 = (X.TEMP (Tm.new "logand 1" Tm.Byte), Tm.Byte)
+          val t2 = (X.TEMP (Tm.new "logand 2" Tm.Byte), Tm.Byte)
           val l = Label.new ()
         in
-          if (effect e2 orelse (length insn2 > 10))
-          then (insn1) @
-               [X.SETcc(pos1, t1), X.Jcc (neg1, l)] @
-               (insn2) @
-               [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)]
-          else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2)), X.MOVZB(d, t1)]
+          if (TU.effect e2 orelse (length insn2 > 10))
+          then ((insn1) @
+                [X.SETcc(pos1, t1), X.Jcc (neg1, l)] @
+                (insn2) @
+                [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB((d, Tm.Long), t1)], Tm.Long)
+          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(t1,t2), X.MOVZB((d, Tm.Long), t1)], Tm.Long)
         end
     | munch_exp d (a as T.BINOP(T.LOGOR, e1, e2)) =
         let
           val (insn1, pos1, neg1) = munch_cond e1
           val (insn2, pos2, neg2) = munch_cond e2
-          val t1 = X.TEMP (Temp.new("logor 1") 4)
-          val t2 = X.TEMP (Temp.new("logor 2") 4)
+          val t1 = (X.TEMP (Tm.new "logand 1" Tm.Byte), Tm.Byte)
+          val t2 = (X.TEMP (Tm.new "logand 2" Tm.Byte), Tm.Byte)
           val l = Label.new ()
         in
-          if (effect e2 orelse (length insn2 > 10))
-          then (insn1) @
-               [X.SETcc(pos1, t1), X.Jcc (pos1, l)] @
-               (insn2) @
-               [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)]
-          else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2)), X.MOVZB(d, t1)]
+          if (TU.effect e2 orelse (length insn2 > 10))
+          then ((insn1) @
+                [X.SETcc(pos1, t1), X.Jcc (pos1, l)] @
+                (insn2) @
+                [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB((d, Tm.Long), t1)], Tm.Long)
+          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(t1,t2), X.MOVZB((d, Tm.Long), t1)], Tm.Long)
         end
-    | munch_exp d (a as T.BINOP(T.EQ, _, _)) =
-        let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end
-    | munch_exp d (a as T.BINOP(T.NEQ, _, _)) =
-        let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end
-    | munch_exp d (a as T.BINOP(T.LE, _, _)) =
-        let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end
-    | munch_exp d (a as T.BINOP(T.LT, _, _)) =
-        let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end
-    | munch_exp d (a as T.BINOP(T.GE, _, _)) =
-        let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end
-    | munch_exp d (a as T.BINOP(T.GT, _, _)) =
-        let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end
-    | munch_exp d (T.UNOP(T.NEG, T.CONST n)) = [X.MOV (d, X.CONST (~n))]
-    | munch_exp d (T.UNOP(T.NEG, e1)) = (munch_exp d e1) @ [X.NEG d]
-    | munch_exp d (T.UNOP(T.BITNOT, T.CONST n)) = [X.MOV (d, X.CONST (Word32.notb n))]
-    | munch_exp d (T.UNOP(T.BITNOT, e1)) = (munch_exp d e1) @ [X.NOT d]
-    | munch_exp d (T.UNOP(T.BANG, T.CONST n)) = if (n = 0w0) then [X.MOV (d, X.CONST 0w1)] else [X.MOV (d, X.CONST 0w0)]
+    | munch_exp d (a as T.BINOP(T.EQ, _, _)) = cmphit d a
+    | munch_exp d (a as T.BINOP(T.NEQ, _, _)) = cmphit d a
+    | munch_exp d (a as T.BINOP(T.LE, _, _)) = cmphit d a
+    | munch_exp d (a as T.BINOP(T.LT, _, _)) = cmphit d a
+    | munch_exp d (a as T.BINOP(T.GE, _, _)) = cmphit d a
+    | munch_exp d (a as T.BINOP(T.GT, _, _)) = cmphit d a
+    | munch_exp d (a as T.BINOP(T.BE, _, _)) = cmphit d a
+
+    | munch_exp d (T.UNOP(T.NEG, e1)) = let val (i, s) = munch_exp d e1 in (i @ [X.NEG (d, Tm.Long)], s) end
+    | munch_exp d (T.UNOP(T.BITNOT, e1)) = let val (i, s) = munch_exp d e1 in (i @ [X.NOT (d, Tm.Long)], s) end
     | munch_exp d (T.UNOP(T.BANG, e)) = 
         let
           val (insns, pos, neg) = munch_cond e
         in
-          insns @ [X.SETcc (neg, d), X.MOVZB(d, d)]
+          (insns @ [X.SETcc (neg, (d, Tm.Byte)), X.MOVZB((d, Tm.Long), (d, Tm.Byte))], Tm.Long)
+        end
+    | munch_exp d (T.MEMORY (e1,s)) =
+        let
+          val a = X.TEMP (Temp.new "addr" Tm.Quad)
+          val (i, s') = munch_exp a e1
+          val _ = if s' = Tm.Quad then () else raise ErrorMsg.InternalError "memory fuxed."
+        in
+          (i @ [X.MOV ((d,s), (X.REL ((a, Tm.Quad), (X.CONST 0w0, Tm.Quad), 0w1), s))], s)
         end
-    | munch_exp d (T.MEMORY e1) =
+    | munch_exp d (T.ALLOC(exp)) =
+        
         let
-          val a = X.TEMP (Temp.new "addr" 8)
+          val t1 = Temp.new "alloc" Tm.Long
+          val l1 = Label.new()
+          val (einsn, _) = munch_exp (X.TEMP t1) exp
+          val (insns, _) = munch_exp d (T.CALL (Symbol.symbol "calloc", [(T.TEMP t1, Tm.Long), (T.CONST 0w1, Tm.Long)], Tm.Quad))
+          val rd = (d, Tm.Quad)
         in
-          munch_exp a e1 @ [X.MOV (d, X.REL (a, X.CONST 0w0))]
+          (einsn @ insns, Tm.Quad)
         end
-    | munch_exp d (T.ALLOC(exp)) = (munch_exp d (T.CALL (Symbol.symbol "calloc", [(exp, 4), (T.CONST 0w1, 4)], 8)))
-                                   @ [X.MOV (X.REL (d, X.CONST 0w0), X.CONST 0w0)]
+(*    | munch_exp d (T.COND(c, T.CONST n1, T.CONST n2)) = let val (i,p,n) = munch_cond c in ((X.MOV (d, X.CONST n1))::i) @ [X.CMOVcc (p, d, X.CONST n2)] end *)
+    | munch_exp d (T.COND(c,e1,e2)) =
+        let
+          val (insns, pos, neg) = munch_cond c
+          val l1 = Label.new()
+          val l2 = Label.new()
+          val (i1, s1) = munch_exp d e1
+          val (i2, s2) = munch_exp d e2
+(*          val _ = print ("cond: size " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp e1 ^ ", " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ "\n") *)
+        in
+          (insns @ [X.Jcc(neg, l1)] @ i1 @ [X.JMP l2, X.LABEL l1] @ i2 @ [X.LABEL l2], if s1 = s2 then s1 else raise ErrorMsg.InternalError "condfuxed.")
+        end
+    | munch_exp d (T.STMVAR (sl, e)) = let val (i, s) = munch_exp d e in (List.concat (map munch_stm sl) @ i, s) end
+
+  and condhit_tc t c (pos, neg) = ([X.CMP((X.TEMP t, Tm.size t), (X.CONST c, Tm.size t))], pos, neg)
+  and condhit_c e c (pos, neg) =
+    let
+      val t = X.TEMP (Temp.new "consthit" Tm.Long)
+      val (i,s) = munch_exp t e
+    in
+      (i @ [X.CMP ((t,s), (X.CONST c,s))], pos, neg)
+    end
+  and condhit_t e t (pos, neg) =
+    let
+      val t' = X.TEMP (Temp.new "consthit" Tm.Long)
+      val (i,s) = munch_exp t' e
+    in
+      (i @ [X.CMP ((t',s), (X.TEMP t,s))], pos, neg)
+    end
+  and condhit e1 e2 (pos, neg) =
+    let
+      val t1 = X.TEMP (Temp.new ("var neq 1") Tm.Long)
+      val t2 = X.TEMP (Temp.new ("var neq 2") Tm.Long)
+      val (i1, s1) = munch_exp t1 e1
+      val (i2, s2) = munch_exp t2 e2
+    in
+      (i1 @ i2 @ [X.CMP((t1,s1),(t2,s2))], pos, neg)
+    end
 
   (* munch_cond : T.exp -> X.insn list * X.cond * X.cond
    * munch_cond stm generates code to set flags, and then returns a conditional
@@ -268,195 +311,156 @@ struct
         in
           (insns, neg, pos)
         end
-    | munch_cond (T.BINOP(T.NEQ, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.NE, X.E)
-    | munch_cond (T.BINOP(T.NEQ, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.NE, X.E)
-    | munch_cond (T.BINOP(T.NEQ, T.CONST n, e1)) =
-        let val t = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end
-    | munch_cond (T.BINOP(T.NEQ, e1, T.CONST n)) =
-        let val t = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end
-    | munch_cond (T.BINOP(T.NEQ, T.TEMP t, e1)) =
-        let val t1 = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end
-    | munch_cond (T.BINOP(T.NEQ, e1, T.TEMP t)) =
-        let val t1 = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end
-    | munch_cond (T.BINOP(T.NEQ, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("var neq 1") 4)
-          val t2 = X.TEMP (Temp.new ("var neq 2") 4)
-        in
-          (munch_exp t1 e1 @ munch_exp t2 e2 @
-           [X.CMP(t1, t2)], X.NE, X.E)
-        end
-    | munch_cond (T.BINOP(T.EQ, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.E, X.NE)
-    | munch_cond (T.BINOP(T.EQ, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.E, X.NE)
-    | munch_cond (T.BINOP(T.EQ, T.CONST n, e1)) =
-        let val t = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end
-    | munch_cond (T.BINOP(T.EQ, e1, T.CONST n)) =
-        let val t = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end
-    | munch_cond (T.BINOP(T.EQ, T.TEMP t, e1)) =
-        let val t1 = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end
-    | munch_cond (T.BINOP(T.EQ, e1, T.TEMP t)) =
-        let val t1 = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end
-    | munch_cond (T.BINOP(T.EQ, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("var eq 1") 4)
-          val t2 = X.TEMP (Temp.new ("var eq 2") 4)
-        in
-          (munch_exp t1 e1 @ munch_exp t2 e2 @
-           [X.CMP(t1, t2)], X.E, X.NE)
-        end
-    | munch_cond (T.BINOP(T.LE, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.LE, X.G)
-    | munch_cond (T.BINOP(T.LE, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.GE, X.L)
-    | munch_cond (T.BINOP(T.LE, T.CONST n, e1)) =
-        let val t = X.TEMP (Temp.new ("const le") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end
-    | munch_cond (T.BINOP(T.LE, e1, T.CONST n)) =
-        let val t = X.TEMP (Temp.new ("const le") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end
-    | munch_cond (T.BINOP(T.LE, T.TEMP t, e1)) =
-        let val t1 = X.TEMP (Temp.new ("const le") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end
-    | munch_cond (T.BINOP(T.LE, e1, T.TEMP t)) =
-        let val t1 = X.TEMP (Temp.new ("const le") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end
-    | munch_cond (T.BINOP(T.LE, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("var le 1") 4)
-          val t2 = X.TEMP (Temp.new ("var le 2") 4)
-        in
-          (munch_exp t1 e1 @ munch_exp t2 e2 @
-           [X.CMP(t1, t2)], X.LE, X.G)
-        end
-    | munch_cond (T.BINOP(T.LT, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.L, X.GE)
-    | munch_cond (T.BINOP(T.LT, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.G, X.LE)
-    | munch_cond (T.BINOP(T.LT, T.CONST n, e1)) =
-        let val t = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end
-    | munch_cond (T.BINOP(T.LT, e1, T.CONST n)) =
-        let val t = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end
-    | munch_cond (T.BINOP(T.LT, T.TEMP t, e1)) =
-        let val t1 = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end
-    | munch_cond (T.BINOP(T.LT, e1, T.TEMP t)) =
-        let val t1 = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end
-    | munch_cond (T.BINOP(T.LT, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("var lt 1") 4)
-          val t2 = X.TEMP (Temp.new ("var lt 2") 4)
-        in
-          (munch_exp t1 e1 @ munch_exp t2 e2 @
-           [X.CMP(t1, t2)], X.L, X.GE)
-        end
-    | munch_cond (T.BINOP(T.GT, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.G, X.LE)
-    | munch_cond (T.BINOP(T.GT, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.L, X.GE)
-    | munch_cond (T.BINOP(T.GT, e1, T.CONST n)) =
-        let val t = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end
-    | munch_cond (T.BINOP(T.GT, T.CONST n, e1)) =
-        let val t = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end
-    | munch_cond (T.BINOP(T.GT, e1, T.TEMP t)) =
-        let val t1 = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end
-    | munch_cond (T.BINOP(T.GT, T.TEMP t, e1)) =
-        let val t1 = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end
-    | munch_cond (T.BINOP(T.GT, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("var gt 1") 4)
-          val t2 = X.TEMP (Temp.new ("var gt 2") 4)
-        in
-          (munch_exp t1 e1 @ munch_exp t2 e2 @
-           [X.CMP(t1, t2)], X.G, X.LE)
-        end
-    | munch_cond (T.BINOP(T.GE, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.GE, X.L)
-    | munch_cond (T.BINOP(T.GE, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.LE, X.G)
-    | munch_cond (T.BINOP(T.GE, e1, T.CONST n)) =
-        let val t = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end
-    | munch_cond (T.BINOP(T.GE, T.CONST n, e1)) =
-        let val t = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end
-    | munch_cond (T.BINOP(T.GE, e1, T.TEMP t)) =
-        let val t1 = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end
-    | munch_cond (T.BINOP(T.GE, T.TEMP t, e1)) =
-        let val t1 = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end
-    | munch_cond (T.BINOP(T.GE, e1, e2)) =
-        let
-          val t1 = X.TEMP (Temp.new ("var ge 1") 4)
-          val t2 = X.TEMP (Temp.new ("var ge 2") 4)
-        in
-          (munch_exp t1 e1 @ munch_exp t2 e2 @
-           [X.CMP(t1, t2)], X.GE, X.L)
-        end
+    | munch_cond (T.BINOP(T.NEQ, T.TEMP t, T.CONST n)) = condhit_tc t n (X.NE, X.E)
+    | munch_cond (T.BINOP(T.NEQ, T.CONST n, T.TEMP t)) = condhit_tc t n (X.NE, X.E)
+    | munch_cond (T.BINOP(T.NEQ, T.CONST n, e1)) = condhit_c e1 n (X.NE, X.E)
+    | munch_cond (T.BINOP(T.NEQ, e1, T.CONST n)) = condhit_c e1 n (X.NE, X.E)
+    | munch_cond (T.BINOP(T.NEQ, T.TEMP t, e1)) = condhit_t e1 t (X.NE, X.E)
+    | munch_cond (T.BINOP(T.NEQ, e1, T.TEMP t)) = condhit_t e1 t (X.NE, X.E)
+    | munch_cond (T.BINOP(T.NEQ, e1, e2)) = condhit e1 e2 (X.NE, X.E)
+
+    | munch_cond (T.BINOP(T.EQ, T.TEMP t, T.CONST n)) = condhit_tc t n (X.E, X.NE)
+    | munch_cond (T.BINOP(T.EQ, T.CONST n, T.TEMP t)) = condhit_tc t n (X.E, X.NE)
+    | munch_cond (T.BINOP(T.EQ, T.CONST n, e1)) = condhit_c e1 n (X.E, X.NE)
+    | munch_cond (T.BINOP(T.EQ, e1, T.CONST n)) = condhit_c e1 n (X.E, X.NE)
+    | munch_cond (T.BINOP(T.EQ, T.TEMP t, e1)) = condhit_t e1 t (X.E, X.NE)
+    | munch_cond (T.BINOP(T.EQ, e1, T.TEMP t)) = condhit_t e1 t (X.E, X.NE)
+    | munch_cond (T.BINOP(T.EQ, e1, e2)) = condhit e1 e2 (X.E, X.NE)
+
+    | munch_cond (T.BINOP(T.LE, T.TEMP t, T.CONST n)) = condhit_tc t n (X.LE, X.G)
+    | munch_cond (T.BINOP(T.LE, T.CONST n, T.TEMP t)) = condhit_tc t n (X.GE, X.L)
+    | munch_cond (T.BINOP(T.LE, T.CONST n, e1)) = condhit_c e1 n (X.GE, X.L)
+    | munch_cond (T.BINOP(T.LE, e1, T.CONST n)) = condhit_c e1 n (X.LE, X.G)
+    | munch_cond (T.BINOP(T.LE, T.TEMP t, e1)) = condhit_t e1 t (X.GE, X.L)
+    | munch_cond (T.BINOP(T.LE, e1, T.TEMP t)) = condhit_t e1 t (X.LE, X.G)
+    | munch_cond (T.BINOP(T.LE, e1, e2)) = condhit e1 e2 (X.LE, X.G)
+
+    | munch_cond (T.BINOP(T.LT, T.TEMP t, T.CONST n)) = condhit_tc t n (X.L, X.GE)
+    | munch_cond (T.BINOP(T.LT, T.CONST n, T.TEMP t)) = condhit_tc t n (X.G, X.LE)
+    | munch_cond (T.BINOP(T.LT, T.CONST n, e1)) = condhit_c e1 n (X.G, X.LE)
+    | munch_cond (T.BINOP(T.LT, e1, T.CONST n)) = condhit_c e1 n (X.L, X.GE)
+    | munch_cond (T.BINOP(T.LT, T.TEMP t, e1)) = condhit_t e1 t (X.G, X.LE)
+    | munch_cond (T.BINOP(T.LT, e1, T.TEMP t)) = condhit_t e1 t (X.L, X.GE)
+    | munch_cond (T.BINOP(T.LT, e1, e2)) = condhit e1 e2 (X.L, X.GE)
+
+    | munch_cond (T.BINOP(T.GT, T.TEMP t, T.CONST n)) = condhit_tc t n (X.G, X.LE)
+    | munch_cond (T.BINOP(T.GT, T.CONST n, T.TEMP t)) = condhit_tc t n (X.L, X.GE)
+    | munch_cond (T.BINOP(T.GT, T.CONST n, e1)) = condhit_c e1 n (X.L, X.GE)
+    | munch_cond (T.BINOP(T.GT, e1, T.CONST n)) = condhit_c e1 n (X.G, X.LE)
+    | munch_cond (T.BINOP(T.GT, T.TEMP t, e1)) = condhit_t e1 t (X.L, X.GE)
+    | munch_cond (T.BINOP(T.GT, e1, T.TEMP t)) = condhit_t e1 t (X.G, X.LE)
+    | munch_cond (T.BINOP(T.GT, e1, e2)) = condhit e1 e2 (X.G, X.LE)
+
+    | munch_cond (T.BINOP(T.GE, T.TEMP t, T.CONST n)) = condhit_tc t n (X.GE, X.L)
+    | munch_cond (T.BINOP(T.GE, T.CONST n, T.TEMP t)) = condhit_tc t n (X.LE, X.G)
+    | munch_cond (T.BINOP(T.GE, T.CONST n, e1)) = condhit_c e1 n (X.LE, X.G)
+    | munch_cond (T.BINOP(T.GE, e1, T.CONST n)) = condhit_c e1 n (X.GE, X.L)
+    | munch_cond (T.BINOP(T.GE, T.TEMP t, e1)) = condhit_t e1 t (X.LE, X.G)
+    | munch_cond (T.BINOP(T.GE, e1, T.TEMP t)) = condhit_t e1 t (X.GE, X.L)
+    | munch_cond (T.BINOP(T.GE, e1, e2)) = condhit e1 e2 (X.GE, X.L)
+
+    | munch_cond (T.BINOP(T.BE, T.TEMP t, T.CONST n)) = condhit_tc t n (X.BE, X.A)
+    | munch_cond (T.BINOP(T.BE, T.CONST n, T.TEMP t)) = condhit_tc t n (X.AE, X.B)
+    | munch_cond (T.BINOP(T.BE, T.CONST n, e1)) = condhit_c e1 n (X.AE, X.B)
+    | munch_cond (T.BINOP(T.BE, e1, T.CONST n)) = condhit_c e1 n (X.BE, X.A)
+    | munch_cond (T.BINOP(T.BE, T.TEMP t, e1)) = condhit_t e1 t (X.AE, X.B)
+    | munch_cond (T.BINOP(T.BE, e1, T.TEMP t)) = condhit_t e1 t (X.BE, X.A)
+    | munch_cond (T.BINOP(T.BE, e1, e2)) = condhit e1 e2 (X.BE, X.A)
+
     | munch_cond (T.BINOP(T.LOGOR, e1, e2)) =
         let
           val (insn1, pos1, neg1) = munch_cond e1
           val (insn2, pos2, neg2) = munch_cond e2
-          val t1 = X.TEMP (Temp.new("logor c 1") 4)
-          val t2 = X.TEMP (Temp.new("logor c 2") 4)
+          val t1 = (X.TEMP (Temp.new("logor c 1") Tm.Byte), Tm.Byte)
+          val t2 = (X.TEMP (Temp.new("logor c 2") Tm.Byte), Tm.Byte)
           val l = Label.new ()
         in
-          if (effect e2 orelse (length insn2 > 10))
+          if (TU.effect e2 orelse (length insn2 > 10))
           then ((insn1) @
                 [X.SETcc (pos1, t1), X.Jcc (pos1, l)] @
                 (insn2) @
-                [X.SETcc (pos2, t1), X.LABEL l, X.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))],
+                [X.SETcc (pos2, t1), X.LABEL l, X.TEST(t1, t1)],
                 X.NE, X.E)
-          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2))], X.NE, X.E)
+          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(t1, t2)], X.NE, X.E)
         end
     | munch_cond (T.BINOP(T.LOGAND, e1, e2)) =
         let
           val (insn1, pos1, neg1) = munch_cond e1
           val (insn2, pos2, neg2) = munch_cond e2
-          val t1 = X.TEMP (Temp.new("logand c 1") 4)
-          val t2 = X.TEMP (Temp.new("logand c 2") 4)
+          val t1 = (X.TEMP (Temp.new("logand c 1") Tm.Byte), Tm.Byte)
+          val t2 = (X.TEMP (Temp.new("logand c 2") Tm.Byte), Tm.Byte)
           val l = Label.new ()
         in
-          if (effect e2 orelse (length insn2 > 10))
+          if (TU.effect e2 orelse (length insn2 > 10))
           then ((insn1) @
                 [X.SETcc (pos1, t1), X.Jcc (neg1, l)] @
                 (insn2) @
-                [X.SETcc (pos2, t1), X.LABEL l, X.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))],
+                [X.SETcc (pos2, t1), X.LABEL l, X.TEST(t1, t1)],
                 X.NE, X.E)
-          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2))], X.NE, X.E)
+          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(t1, t2)], X.NE, X.E)
         end
     | munch_cond e =
       let
-        val t = X.TEMP (Temp.new ("munch c") 4)
+        val t = X.TEMP (Temp.new ("munch c") Tm.Long)
+        val (i, s) = munch_exp t e
       in
-        (munch_exp t e @ [ X.TEST (t,t) ], X.NE, X.E)
+        (i @ [ X.TEST ((t,s),(t,s)) ], X.NE, X.E)
       end
 
   (* munch_lval : T.exp -> (X.insn list * X.operand)
    * Takes an expression that has been typechecked as being a valid lvalue, and then returns an instruction list and an operand to store your shit in.
    *)
-  fun munch_lval (T.TEMP t) = ([], X.TEMP t)
-    | munch_lval (T.MEMORY m) = 
+  and munch_lval (T.TEMP t) = ([], (X.TEMP t, Tm.size t))
+    | munch_lval (T.MEMORY (m,s)) = 
       let
-        val t = Temp.new "lv addr" 8
+        val t = X.TEMP (Tm.new "lv addr" Tm.Quad)
+        val (i,s') = munch_exp t m
       in
-        (munch_exp (X.TEMP t) m, X.REL (X.TEMP t, X.CONST 0w0))
+        (i, (X.REL ((t, Tm.Quad), (X.CONST 0w0, Tm.Quad), 0w1), s))
       end
     | munch_lval _ = raise ErrorMsg.InternalError "That wasn't really a valid lvalue..."
 
   (* munch_stm : T.stm -> X.insn list *)
   (* munch_stm stm generates code to execute stm *)
-  fun munch_stm (T.MOVE (T.TEMP t, a as T.TEMP _, _)) = munch_exp (X.TEMP t) a
-    | munch_stm (T.MOVE (T.TEMP t, a as T.CONST _, _)) = munch_exp (X.TEMP t) a
-    | munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an, sz), _)) = munch_exp (X.TEMP t) a
-    | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _, _)) = munch_exp (X.TEMP t) a
-    | munch_stm (T.MOVE (a, e2, sz)) =
+  and munch_stm (T.MOVE (T.TEMP t1, T.TEMP t2)) = if Tm.size t1 = Tm.size t2 then [X.MOV((X.TEMP t1, Tm.size t1), (X.TEMP t2, Tm.size t2))]
+                                                                             else raise ErrorMsg.InternalError "temp to temp move fuxed."
+    | munch_stm (T.MOVE (T.TEMP t, T.CONST n)) = if Tm.size t = Tm.Long then [X.MOV((X.TEMP t, Tm.size t), (X.CONST n, Tm.size t))]
+                                                                        else raise ErrorMsg.InternalError "const to temp move fuxed."
+    | munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an, sz))) =
+        let
+          val (i, s) = munch_exp (X.TEMP t) a
+        in
+          if s = Tm.size t
+          then i
+          else raise ErrorMsg.InternalError "arg to tmp fuxed."
+        end
+    | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _)) = let val (i, _) = munch_exp (X.TEMP t) a in i end
+    | munch_stm (T.MOVE (a, e2)) =
         let
-          val t = Temp.new ("assign") sz
-          val (m, r) = munch_lval a
+          val t = X.TEMP (Temp.new ("assign") Tm.Long)
+          val (m, (r,s1)) = munch_lval a
+          val (i, s2) = munch_exp t e2
+(*          val _ = print ("move: size " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ ", " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp a ^ "\n") *)
+          val _ = if s1 = s2 then () else raise ErrorMsg.InternalError "move generic fuxed."
         in
-          m @ munch_exp (X.TEMP t) e2
-          @ [X.MOV(X.OSIZE (X.sts sz, r), X.TEMP t)]
+          m @ i @ [X.MOV((r,s1), (t,s2))]
         end
     | munch_stm (T.RETURN(e, sz)) =
         let
-          val t = Temp.new ("retval") sz
+          val t = X.TEMP (Temp.new ("retval") sz)
+          val (i, s) = munch_exp t e
         in
-          munch_exp (X.TEMP t) e
-          @ [X.MOV(X.OSIZE (X.sts sz, X.REG X.EAX), X.TEMP t), X.RET]
+          i @ [X.MOV((X.REG X.EAX, sz), (t, if sz = s then sz else raise ErrorMsg.InternalError "retfuxed.")), X.RET]
         end
-    | munch_stm (T.LABEL(l)) = [X.LABEL l]
-    | munch_stm (T.JUMP(l)) = [X.JMP l]
+    | munch_stm (T.LABEL l) = [X.LABEL l]
+    | munch_stm (T.JUMP l) = [X.JMP l]
     | munch_stm (T.JUMPIFN(e, l)) =
        let
          val (insns, pos, neg) = munch_cond e 
        in
          insns @ [X.Jcc (neg, l)]
        end
-    | munch_stm (T.EFFECT(exp, sz)) = let val t = X.TEMP (Temp.new "throwaway" sz) in munch_exp t exp end
+    | munch_stm (T.EFFECT exp) = let val t = X.TEMP (Temp.new "throwaway" Tm.Quad) val (i, _) = munch_exp t exp in i end
 
   fun codegen nil = nil
     | codegen (stm::stms) = munch_stm stm @ codegen stms
index 1e08e1d..fc5fdf7 100644 (file)
@@ -8,7 +8,7 @@
 signature COLORIZER =
 sig
   structure OperSet : ORD_SET
-    where type Key.ord_key = x86.oper
+    where type Key.ord_key = x86.basicop
   structure LiveMap : ORD_MAP
     where type Key.ord_key = int
   structure TempMap : ORD_MAP
@@ -70,7 +70,7 @@ struct
           colorized)
         @ (List.map
              (fn X.REG a => X.regtonum a
-               | loss => raise ErrorMsg.InternalError ("Bad kind of specreg " ^ (X.prettyprint_oper X.Long loss )))
+               | loss => raise ErrorMsg.InternalError ("Bad kind of specreg " ^ (X.pp_oper (loss, Temp.Long))))
           fixeds)
       (* Greedy-colorize -- pick the lowest number that isn't used by a neighbor *)
       fun greedy i l =
index 0f25863..16dd163 100644 (file)
@@ -7,7 +7,7 @@
 signature COLORORDER =
 sig
   structure OperSet : ORD_SET
-    where type Key.ord_key = x86.oper
+    where type Key.ord_key = x86.basicop
   structure LiveMap : ORD_MAP
     where type Key.ord_key = int
   structure TempMap : ORD_MAP
@@ -35,15 +35,25 @@ struct
     let
       val initialWeights = TempMap.mapi (fn (t, _) => (t, 0)) graph
       
-      fun sortWeights weights =        (* Sort the weights such that the largest is at left, ready to be grabbed. *)
-        ListMergeSort.sort (fn ((_, a), (_, b)) => a < b) weights
-
       (* Chooses one temporary to pick, and updates the weights. *)
       fun orderOne (weights : (Temp.temp * int) list) : Temp.temp * (Temp.temp * int) list =
         let
-          val sorted = sortWeights weights
-          val (chosen, w) = List.hd sorted     (* Grab the temp with the highest weight. *)
-          val remaining = List.tl sorted
+          val (chosen, w) =
+            foldr
+              (fn ((t1, w1), (t2, w2)) =>
+                if (w2 > w1)
+                then (t2, w2)
+                else (t1, w1))
+              (Temp.new "emarnus" Temp.Word, ~9999)
+              weights
+              
+          fun ditchOne f nil = nil     (* Special case of filter, which bails out after it removes one. *)
+            | ditchOne f (h::l) =
+              if f h
+              then l
+              else h::(ditchOne f l)
+          val remaining = ditchOne (fn (t, w) => Temp.eq (t, chosen)) weights
+          
           val neighbors =                      (* Grab all the neighbors for some given temp. *)
             (OperSet.listItems
               (valOf (TempMap.find (graph, chosen))))
index 30b17ee..7e71043 100644 (file)
@@ -7,7 +7,7 @@
 signature IGRAPH =
 sig
   structure OperSet : ORD_SET
-    where type Key.ord_key = x86.oper
+    where type Key.ord_key = x86.basicop
   structure LiveMap : ORD_MAP
     where type Key.ord_key = int
   structure TempMap : ORD_MAP
index 4c8e4ad..b030f94 100644 (file)
@@ -7,22 +7,22 @@
 signature LIVENESS =
 sig
   structure OperSet : ORD_SET
-    where type Key.ord_key = x86.oper;
+    where type Key.ord_key = x86.basicop;
   structure LiveMap : ORD_MAP
     where type Key.ord_key = int;
-  
+
   type live = int * OperSet.set
   type pseudoasm = x86.insn list
   type livenesses = OperSet.set LiveMap.map
   
   type ident = int
-  datatype pred = DEF of x86.oper | USE of x86.oper | SUCC of ident | ISMOVE
+  datatype pred = DEF of x86.basicop | USE of x86.basicop | SUCC of ident | ISMOVE
   
   type predicates = pred list LiveMap.map
 
-  val uses : pred list -> x86.oper list
+  val uses : pred list -> x86.basicop list
   val succs : pred list -> ident list
-  val defs : pred list -> x86.oper list
+  val defs : pred list -> x86.basicop list
   val ismove : pred list -> bool
 
   val liveness : pseudoasm -> predicates * livenesses
@@ -37,6 +37,10 @@ struct
   
   structure OperSet = x86.OperSet
   structure LiveMap = x86.LiveMap
+  structure LabelMap = SplayMapFn(struct
+                                    type ord_key = Label.label
+                                    val compare = Label.compare
+                                  end)
 
   type live = int * OperSet.set
   type pseudoasm = X.insn list
@@ -44,8 +48,8 @@ struct
   type livenesses = OperSet.set LiveMap.map
 
   type ident = int
-  datatype pred = DEF of X.oper | USE of X.oper | SUCC of ident | ISMOVE
-  
+  datatype pred = DEF of X.basicop | USE of X.basicop | SUCC of ident | ISMOVE
+
   type predicates = pred list LiveMap.map
 
   (* val number : pseudoasm -> numasm
@@ -65,26 +69,25 @@ struct
   (* val defusesucc : numasm -> (ident * pred list) list
    * generates def/use/succ predicates according to rules
    *)
-
   fun defusesucc l =
     let
-      fun findlabel (lb) =
-            Option.valOf
-              (LiveMap.foldri (fn (n, X.LABEL lb', NONE) => if (Label.compare (lb, lb') = EQUAL) then SOME n else NONE
-                                | (_, _, old) => old) NONE l)
-      
+      val labelmap = LiveMap.foldri
+        (fn (n, a, b) => LabelMap.insert(b, a, n))
+        (LabelMap.empty)
+        (LiveMap.mapPartial (fn (X.LABEL lb) => SOME(lb) | _ => NONE) l)
+
+      fun findlabel (lb) = valOf (LabelMap.find (labelmap, lb))
+
       (* val defhit/usehit : X.oper -> pred list
        * helper functions to discard constant operands *)
-      fun defhit (X.REG a) = [DEF(X.REG a)]
-        | defhit (X.TEMP a) = [DEF(X.TEMP a)]
-        | defhit (X.REL(o1, o2)) = usehit o1 @ usehit o2
-        | defhit (X.OSIZE(s, oo)) = defhit oo
+      fun defhit (X.REG a,_) = [DEF(X.REG a)]
+        | defhit (X.TEMP a,_) = [DEF(X.TEMP a)]
+        | defhit (X.REL(o1, o2, _),_) = usehit o1 @ usehit o2
         | defhit (_) = nil
     
-      and usehit (X.REG a) = [USE(X.REG a)]
-        | usehit (X.TEMP a) = [USE(X.TEMP a)]
-        | usehit (X.REL(o1, o2)) = usehit o1 @ usehit o2
-        | usehit (X.OSIZE(s, oo)) = usehit oo
+      and usehit (X.REG a,_) = [USE(X.REG a)]
+        | usehit (X.TEMP a,_) = [USE(X.TEMP a)]
+        | usehit (X.REL(o1, o2, _),_) = usehit o1 @ usehit o2
         | usehit (_) = nil
 
       fun callhit 0 = nil
@@ -103,6 +106,7 @@ struct
         | gendef (n, X.COMMENT(_))             = (nil)
         | gendef (n, X.LIVEIGN (_))            = ([SUCC (n+1)])
         | gendef (n, X.MOV(dest, src))         = (defhit dest @ usehit src @ [SUCC(n+1), ISMOVE])
+        | gendef (n, X.MOVSC(dest, src))       = (defhit dest @ usehit src @ [SUCC(n+1)])
         | gendef (n, X.LEA(dest, src))         = (defhit dest @ usehit src @ [SUCC(n+1)])
         | gendef (n, X.SUB(dest, src))         = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)])
         | gendef (n, X.IMUL(dest, src))        = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)])
@@ -122,9 +126,10 @@ struct
         | gendef (n, X.CMP(dest, src))         = (usehit dest @ usehit src @ [SUCC(n+1)])
         | gendef (n, X.TEST(dest, src))        = (usehit dest @ usehit src @ [SUCC(n+1)])
         | gendef (n, X.SETcc(_,dest))          = (defhit dest @ [SUCC(n+1)])
+        | gendef (n, X.CMOVcc(_,src, dest))    = (defhit dest @ usehit src @ [SUCC(n+1)])
         | gendef (n, X.CALL(_, a))             = (callhit a @ [DEF(X.REG(X.EAX)), DEF(X.REG(X.ECX)), DEF(X.REG(X.EDX)),
-                                                                  DEF(X.REG(X.EDI)), DEF(X.REG(X.ESI)), DEF(X.REG(X.R8D)),
-                                                                  DEF(X.REG(X.R9D)), DEF(X.REG(X.R10D)), DEF(X.REG(X.R11D)), SUCC(n+1)])
+                                                               DEF(X.REG(X.EDI)), DEF(X.REG(X.ESI)), DEF(X.REG(X.R8D)),
+                                                               DEF(X.REG(X.R9D)), DEF(X.REG(X.R10D)), DEF(X.REG(X.R11D)), SUCC(n+1)])
         | gendef (n, X.MOVZB(dest, src))       = (defhit dest @ usehit src @ [SUCC(n+1)])
         | gendef (n, X.RET)                    = ([USE (X.REG X.EAX)])
         | gendef (n, X.LABEL l)                = ([SUCC (n+1)])
@@ -211,7 +216,7 @@ struct
       (* val isndef : X.oper -> pred list -> bool
        * checks to see if x is defined in a predicate list *)
       fun isndef (X.STACKARG(_)) _ = false
-        | isndef x (DEF(y)::l') = not (X.opereq (x,y)) andalso isndef x l'
+        | isndef x (DEF(y)::l') = not (X.basiceq (x,y)) andalso isndef x l'
         | isndef x (a::l') = isndef x l'
         | isndef x nil = true
 
@@ -241,8 +246,8 @@ struct
       else liveiter newl preds
     end
 
-  fun dustostring (DEF(a)) = "DEF(" ^ X.prettyprint_oper X.Long a ^ ")"
-    | dustostring (USE(a)) = "USE(" ^ X.prettyprint_oper X.Long a ^ ")"
+  fun dustostring (DEF(a)) = "DEF(" ^ X.pp_oper (a,Temp.Quad) ^ ")"
+    | dustostring (USE(a)) = "USE(" ^ X.pp_oper (a,Temp.Quad) ^ ")"
     | dustostring (SUCC(a)) = "SUCC(" ^ Int.toString a ^ ")"
     | dustostring ISMOVE = "ISMOVE"
 
@@ -269,7 +274,7 @@ struct
   
   fun prettyprint (set) =
     OperSet.foldr
-      (fn (oper, s) => (X.prettyprint_oper X.Long oper) ^ ", " ^ s)
+      (fn (oper, s) => (X.pp_oper (oper,Temp.Quad)) ^ ", " ^ s)
       "-\n"
       set
       
diff --git a/codegen/peephole.sml b/codegen/peephole.sml
deleted file mode 100644 (file)
index 7bf55a1..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
-(* L3 compiler
- * peephole optimizer
- * optimizes away redundant insns such as:
-     mov a, b
-     mov a, b
-
-     mov a, b
-     mov b, a
-
-     mov a, a
-     
-     neg a
-     neg a
- * Author: Chris Lu <czl@andrew.cmu.edu>
- *)
-
-signature PEEPHOLE =
-sig
-  val peephole : x86.insn list -> x86.insn list
-end
-
-structure Peephole :> PEEPHOLE =
-struct
-  structure X = x86
-
-  (* val peephole : x86.insn list -> x86.insn list *)
-
-  fun peephole ((insn1 as X.MOV(a1,b1))::(insn2 as X.MOV(a2,b2))::l) =
-        if(x86.opereq(a1, b1) orelse (x86.opereq(a1, a2) andalso x86.opereq(b1, b2))) then
-          peephole (insn2::l)
-        else if(x86.opereq(a2, b2) orelse (x86.opereq(a1, b2) andalso x86.opereq(b1, a2))) then
-          peephole (insn1::l)
-        else
-          insn1::(peephole (insn2::l))
-    | peephole (X.MOV (X.REG r, X.CONST 0w0)::l) = (X.XOR (X.REG r, X.REG r))::(peephole l)
-    | peephole ((insn as X.MOV(a,b))::l) = if x86.opereq(a, b) then peephole l else insn::(peephole l)
-    | peephole ((insn1 as X.NEG(a))::(insn2 as X.NEG(b))::l) = if x86.opereq(a, b) then peephole l else insn1::(peephole (insn2::l))
-    | peephole (X.ADD (_, X.CONST 0w0)::l) = peephole l
-    | peephole (X.SUB (_, X.CONST 0w0)::l) = peephole l
-    | peephole (X.CMP (X.REG r, X.CONST 0w0)::l) = (X.TEST (X.REG r, X.REG r))::(peephole l)
-    | peephole ((X.JMP a)::(X.JMP b)::l) = peephole ((X.JMP a)::l) (* What the cock? Yes, we actually generate this. *)
-    | peephole ((X.JMP l1)::(X.LABEL l2)::l) = if (Label.compare (l1,l2) = EQUAL) then (X.LABEL l2)::(peephole l) else (X.JMP l1)::(X.LABEL l2)::(peephole l)
-    | peephole (a::l) = a::(peephole l)
-    | peephole nil = nil
-
-end
index 21b37bc..07ae420 100644 (file)
@@ -22,7 +22,13 @@ struct
   type asm = x86.insn list
   
   exception Spilled
-  
+
+  structure TempMap = SplayMapFn(struct
+                                   type ord_key = Temp.temp
+                                   val compare = Temp.compare
+                                 end)
+  structure Tm = Temp
+
   fun solidify (regmap : colorings) (instrs : asm) : asm =
     let
       (* r14d and r15d is reserved for spilling *)
@@ -32,11 +38,9 @@ struct
           then raise Spilled
           else X.numtoreg n
 
-      fun temptonum (t: T.temp) : int =
-        (List.hd
-          (List.map (fn (_, n) => n)
-            (List.filter (fn (a, _) => (Temp.eq (a, t))) regmap)))
-      
+      val tempnums = List.foldr (fn ((t,n),b) => TempMap.insert(b,t,n)) (TempMap.empty) regmap
+      fun temptonum (t: T.temp) : int = valOf (TempMap.find (tempnums, t))
+
       fun temptoreg (t: T.temp) : x86.reg =
         numtoreg (temptonum t)          
         handle Empty => raise ErrorMsg.InternalError ("Uncolored temp "^(Temp.name t)^", agh!")
@@ -61,79 +65,99 @@ struct
 
       val numreg = foldr (Int.max) 0 (map (fn (_, n) => n) regmap)    (* Number of registers used. *)
       val nspilled = Int.max (numreg - maxreg, 0)    (* Number of spilled registers. *)
-      fun isspilled (X.TEMP temp) = (temptonum temp) > maxreg    (* Whether a register is spilled *)
-        | isspilled (X.STACKARG _) = true
-        | isspilled (X.REL _) = true
-        | isspilled (X.OSIZE (_, oo)) = isspilled oo
+      fun isspilled (X.TEMP temp, _) = (temptonum temp) > maxreg    (* Whether a register is spilled *)
+        | isspilled (X.STACKARG _, _) = true
+        | isspilled (X.REL _, _) = true
         | isspilled _ = false
+
       val stacksz = (nspilled + nsave) * 8
       fun stackpos (reg: int) = stacksz - (reg - maxreg + nsave) * 8    (* Stack position of some register number *)
 
       val prologue =
-        (X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))) ::
+        (X.SUB ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stacksz), Tm.Quad))) ::
         (ListPair.map
           (fn (num, reg) =>
-            X.MOV (X.OSIZE (X.Qword, X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz - 8*(num+1))))), X.OSIZE (X.Qword, reg)))
+            X.MOV ((X.REL ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt (stacksz - 8*(num+1))), Tm.Quad), 0w1), Tm.Quad), (reg, Tm.Quad)))
           (List.tabulate (nsave, fn x => x), savelist))
       val epilogue =
         (ListPair.map
           (fn (num, reg) =>
-            X.MOV (X.OSIZE (X.Qword, reg), X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz - 8*(num+1))))))
+            X.MOV ((reg, Tm.Quad), (X.REL ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt (stacksz - 8*(num+1))), Tm.Quad), 0w1), Tm.Quad)))
           (List.tabulate (nsave, fn x => x), savelist)) @
-        [X.ADD (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))]
+        [X.ADD ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stacksz), Tm.Quad))]
       val endlbl = Label.new()
 
-      fun spill s (X.TEMP temp, xreg: x86.reg) =    (* Spill a register if need be. *)
-        if (isspilled (X.TEMP temp))
-          then [X.MOV (X.OSIZE(s, X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp)), X.REG xreg)]
-          else nil
-        | spill s (X.STACKARG _, _) = raise ErrorMsg.InternalError "Cannot spill to a stack arg"
-        | spill s (a as X.REL _, xreg) = [X.MOV (X.OSIZE(s,a), X.REG xreg)]
-        | spill s (X.OSIZE (s', oo), xreg) = spill s' (X.stripsize oo, xreg)
-        | spill _ _ = nil        (* Nothing else can be spilled. *)
-      fun unspill s (X.TEMP temp, xreg: x86.reg) =    (* Unspill a register if need be. *)
-        if (isspilled (X.TEMP temp))
-          then [X.MOV (X.OSIZE(s, X.REG xreg), X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp))]
-          else nil
-        | unspill s (X.STACKARG arg, xreg) = [X.MOV (X.OSIZE(s, X.REG xreg), X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz + 8 + (arg * 8)))))]
-        | unspill s (a as X.REL _, xreg) = [X.MOV (X.OSIZE(s, X.REG xreg), a)]
-        | unspill s (X.OSIZE (s', oo), xreg) = unspill s' (X.stripsize oo, xreg)
-        | unspill _ _ = nil
-      
-      fun realoper (X.TEMP temp) = X.OSIZE (X.sts (Temp.size temp), X.REG (temptoreg temp))  (* Makes a operand 'real'. *)
-        | realoper (X.STACKARG arg) = raise Spilled
-        | realoper (X.REL _) = raise Spilled
-        | realoper (X.OSIZE (s, oo)) = X.OSIZE (s, realoper (X.stripsize oo))
+      fun spill ((X.TEMP temp, s), xreg: x86.reg) =    (* Spill a register if need be. *)
+            let
+              val base = (X.REG X.RSP, Tm.Quad)
+              val offs = (X.CONST (Word32.fromInt (stackpos (temptonum temp))), Tm.Quad)
+            in
+              if (isspilled (X.TEMP temp, s))
+                then [X.MOV ((X.REL (base, offs, 0w1), Tm.Quad), (X.REG xreg, Tm.Quad))]
+                else nil
+            end
+        | spill ((X.STACKARG _, s), _) = raise ErrorMsg.InternalError "Cannot spill to a stack arg"
+        | spill ((a as X.REL _, s), xreg) = [X.MOV ((a,s), (X.REG xreg,s))]
+        | spill _ = nil        (* Nothing else can be spilled. *)
+      fun unspill ((X.TEMP temp, s), xreg: x86.reg) =    (* Unspill a register if need be. *)
+            let
+              val base = (X.REG X.RSP, Tm.Quad)
+              val offs = (X.CONST (Word32.fromInt (stackpos (temptonum temp))), Tm.Quad)
+            in
+              if (isspilled (X.TEMP temp, s))
+                then [X.MOV ((X.REG xreg, Tm.Quad), (X.REL (base, offs, 0w1), Tm.Quad))]
+                else nil
+            end
+        | unspill ((X.STACKARG arg, s), xreg) =
+            let
+              val base = (X.REG X.RSP, Tm.Quad)
+              val offs = (X.CONST (Word32.fromInt (stacksz + 8 + (arg * 8))), Tm.Quad)
+            in
+              [X.MOV ((X.REG xreg, s), (X.REL (base, offs, 0w1), s))]
+            end
+        | unspill ((a as X.REL _, s), xreg) = [X.MOV ((X.REG xreg, s), (a,s))]
+        | unspill _ = nil
+
+      fun realoper (X.TEMP temp, s) = (X.REG (temptoreg temp), s) (* makes an operand 'real' *)
+        | realoper (X.STACKARG arg, _) = raise Spilled
+        | realoper (X.REL _, _) = raise Spilled
         | realoper r = r
 
-      fun stackoper (X.TEMP temp) =
-            if not (isspilled (X.TEMP temp)) then raise ErrorMsg.InternalError "stackoper on unspilled temp?"
-            else X.OSIZE (X.sts (Temp.size temp), X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp))
-        | stackoper (X.STACKARG arg) = X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt) (stacksz + 8 + (arg * 8)))
-        | stackoper (a as X.REL _) = a
-        | stackoper (X.OSIZE (s, oo)) = X.OSIZE (s, stackoper (X.stripsize oo))
-        | stackoper _ = raise ErrorMsg.InternalError "stackoper on not temp?"
-
-      fun ophit (X.OSIZE (s, oo)) = let val (insns, p) = ophit (X.stripsize oo) in (insns, X.OSIZE (s, p)) end
-        | ophit (X.REL(op1, op2)) =
-          let
-            val t1 = X.stripsize op1
-            val (s, t2) = X.sizeoper op2
-          in
-            if (isspilled t1 andalso isspilled t2) then
-              ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2),
-                X.ADD (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)],
-                X.REL (X.REG spillreg1, X.CONST 0w0))
-            else if(isspilled t1) then
-              ([X.MOV (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)],
-                X.REL (X.REG spillreg1, realoper t2))
-            else if(isspilled t2) then
-              ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2)],
-                X.REL (realoper t1, X.REG spillreg1))
+      fun stackoper (X.TEMP temp, s) =
+            let
+              val base = (X.REG X.RSP, Tm.Quad)
+              val offs = (X.CONST (Word32.fromInt (stackpos (temptonum temp))), Tm.Quad)
+            in
+              if (isspilled (X.TEMP temp, s)) 
+                then (X.REL (base, offs, 0w1), s)
+                else raise ErrorMsg.InternalError "stackoper on unspilled temp?"
+            end
+        | stackoper (X.STACKARG arg, s) =
+            let
+              val base = (X.REG X.RSP, Tm.Quad)
+              val offs = (X.CONST (Word32.fromInt (stacksz + 8 + (arg * 8))), Tm.Quad)
+            in
+              (X.REL (base, offs, 0w1), s)
+            end
+        | stackoper (a as (X.REL _, s)) = a
+        | stackoper (a as (X.CONST _, s)) = a
+        | stackoper anous = raise ErrorMsg.InternalError ("stackoper on not temp " ^ X.pp_oper anous)
+
+      fun ophit (X.REL(op1, op2, m), s) =
+            if (isspilled op1 andalso isspilled op2) then
+              ([X.MOV ((X.REG spillreg1, Tm.Long), stackoper op2),
+                X.IMUL((X.REG spillreg1, Tm.Quad), (X.CONST m, Tm.Quad)), 
+                X.ADD ((X.REG spillreg1, Tm.Quad), stackoper op1)],
+                (X.REL ((X.REG spillreg1, Tm.Quad), (X.CONST 0w0, Tm.Quad), 0w1), s))
+            else if(isspilled op1) then
+              ([X.MOV ((X.REG spillreg1, Tm.Quad), stackoper op1)],
+                (X.REL ((X.REG spillreg1, Tm.Quad), realoper op2, m), s))
+            else if(isspilled op2) then
+              ([X.MOV ((X.REG spillreg1, Tm.Long), stackoper op2)],
+                (X.REL (realoper op1, (X.REG spillreg1, Tm.Quad), m), s))
             else
               ([],
-                X.REL (realoper t1, realoper t2))
-          end
+                (X.REL (realoper op1, realoper op2, m), s))
         | ophit a = (nil, realoper a handle Spilled => stackoper a)
 
       fun transform (X.DIRECTIVE s) = [X.DIRECTIVE s]
@@ -141,21 +165,21 @@ struct
         | transform (X.LIVEIGN a) = transform a
         | transform (X.MOV (dest, src)) =
             let
-              val (insns1, realop1) = ophit dest
-              val (insns2, realop2) = ophit src
+              val (insns1, realop1 as (_,s1)) = ophit dest
+              val (insns2, realop2 as (_,s2)) = ophit src
             in
               if(isspilled dest andalso isspilled src) then
-                insns2 @ [X.MOV (X.REG spillreg2, realop2)] @ insns1 @ [X.MOV (realop1, X.REG spillreg2)]
+                insns2 @ [X.MOV ((X.REG spillreg2, s2), realop2)] @ insns1 @ [X.MOV (realop1, (X.REG spillreg2, s1))]
               else
                 insns1 @ insns2 @ [X.MOV (realop1, realop2)]
             end
         | transform (X.LEA (dest, src)) =
             let
-              val (insns1, realop1) = ophit dest
-              val (insns2, realop2) = ophit src
+              val (insns1, realop1 as (_,s1)) = ophit dest
+              val (insns2, realop2 as (_,s2)) = ophit src
             in
               if(isspilled dest andalso isspilled src) then
-                insns2 @ [X.MOV (X.REG spillreg2, realop2)] @ insns1 @ [X.LEA (realop1, X.REG spillreg2)]
+                insns2 @ [X.LEA ((X.REG spillreg2, s2), realop2)] @ insns1 @ [X.MOV (realop1, (X.REG spillreg2, s1))]
               else
                 insns1 @ insns2 @ [X.LEA (realop1, realop2)]
             end
@@ -163,30 +187,30 @@ struct
             let
               val (insns, realop) = ophit dest
             in
-              unspill X.Long (src, spillreg2) @ insns @
+              unspill (src, spillreg2) @ insns @
               [ X.SUB(realop,
-                  realoper src handle Spilled => X.REG spillreg2)]
+                  realoper src handle Spilled => (X.REG spillreg2, X.osize realop))]
             end
         | transform (X.IMUL (dest, src)) =
-            unspill X.Long (dest, spillreg1) @
+            unspill (dest, spillreg1) @
             [ X.IMUL(
-                realoper dest handle Spilled => X.REG spillreg1,
+                realoper dest handle Spilled => (X.REG spillreg1, X.osize dest),
                 realoper src handle Spilled => stackoper src)] @
-            spill X.Long (dest, spillreg1)
+            spill (dest, spillreg1)
         | transform (X.IMUL3 (dest, src, const)) =
-            unspill X.Long ((X.stripsize src), spillreg2) @
+            unspill (src, spillreg2) @
             [ X.IMUL3(
-                realoper dest handle Spilled => X.REG spillreg1,
-                realoper src handle Spilled => X.REG spillreg2,
+                realoper dest handle Spilled => (X.REG spillreg1, X.osize dest),
+                realoper src handle Spilled => (X.REG spillreg2, X.osize src),
                 const)] @
-            spill X.Long (dest, spillreg1)
+            spill (dest, spillreg1)
         | transform (X.ADD (dest, src)) =
             let
               val (insns, realop) = ophit dest
             in
-              unspill X.Long (src, spillreg2) @ insns @
+              unspill (src, spillreg2) @ insns @
               [ X.ADD(realop,
-                  realoper src handle Spilled => X.REG spillreg2)]
+                  realoper src handle Spilled => (X.REG spillreg2, X.osize realop))]
             end
         | transform (X.IDIV (src)) = [ X.IDIV(realoper src handle Spilled => stackoper src)]
         | transform (X.NEG (src)) = [ X.NEG(realoper src handle Spilled => stackoper src)]
@@ -201,41 +225,56 @@ struct
                 shft)]
         | transform (X.CLTD) = [ X.CLTD ]
         | transform (X.AND (dest, src)) =
-            unspill X.Long (src, spillreg1) @
+            unspill (src, spillreg1) @
             [ X.AND(
                 realoper dest handle Spilled => stackoper dest,
-                realoper src handle Spilled => X.REG spillreg1)]
+                realoper src handle Spilled => (X.REG spillreg1, X.osize src))]
         | transform (X.OR (dest, src)) =
-            unspill X.Long (src, spillreg1) @
+            unspill (src, spillreg1) @
             [ X.OR(
                 realoper dest handle Spilled => stackoper dest,
-                realoper src handle Spilled => X.REG spillreg1)]
+                realoper src handle Spilled => (X.REG spillreg1, X.osize src))]
         | transform (X.XOR (dest, src)) =
-            unspill X.Long (src, spillreg1) @
+            unspill (src, spillreg1) @
             [ X.XOR(
                 realoper dest handle Spilled => stackoper dest,
-                realoper src handle Spilled => X.REG spillreg1)]
+                realoper src handle Spilled => (X.REG spillreg1, X.osize src))]
         | transform (X.CMP (op1, op2)) =
-            unspill X.Long (op2, spillreg1) @
-            [ X.CMP(
-                realoper op1 handle Spilled => stackoper op1,
-                realoper op2 handle Spilled => X.REG spillreg1)]
+            let
+              val (insns1, realop1) = ophit op1
+            in
+              if(isspilled realop1 andalso isspilled op2) then
+                unspill (op2, spillreg2) @ insns1 @ [X.CMP (realop1, (X.REG spillreg2, X.osize realop1))]
+              else
+                insns1 @ [X.CMP (realop1, realoper op2 handle Spilled => stackoper op2)]
+            end
         | transform (X.TEST (op1, op2)) =
-            unspill X.Long (op2, spillreg1) @
+            unspill (op2, spillreg1) @
             [ X.TEST(
                 realoper op1 handle Spilled => stackoper op1,
-                realoper op2 handle Spilled => X.REG spillreg1)]
+                realoper op2 handle Spilled => (X.REG spillreg1, X.osize op2))]
         | transform (X.SETcc (c,src)) = [ X.SETcc(c, realoper src handle Spilled => stackoper src)]
+        | transform (X.CMOVcc (c, dest, src)) =
+            let
+              val (insns1, realop1) = ophit dest
+              val (insns2, realop2) = ophit src
+            in
+              if(isspilled dest andalso isspilled src) then
+                insns2 @ [X.MOV ((X.REG spillreg2, X.osize src), realop2)] @ insns1 @ [X.CMOVcc (c, realop1, (X.REG spillreg2, X.osize src))]
+              else
+                insns1 @ insns2 @ [X.CMOVcc (c, realop1, realop2)]
+            end
         | transform (X.CALL l) = [ X.CALL l ]
         | transform (X.MOVZB (dest, src)) =
             [ X.MOVZB(
-                realoper dest handle Spilled => X.REG spillreg1,
+                realoper dest handle Spilled => (X.REG spillreg1, X.osize dest),
                 realoper src handle Spilled => stackoper src)]
-            @ spill X.Long (dest, spillreg1)
+            @ spill (dest, spillreg1)
         | transform (X.RET) = if nsave < 2 then (epilogue @ [X.RET]) else [X.JMP endlbl]
         | transform (X.LABEL l) = [ X.LABEL l ]
         | transform (X.JMP l) = [ X.JMP l ]
         | transform (X.Jcc (c,l)) = [X.Jcc (c,l)]
+        | transform _ = raise ErrorMsg.InternalError "probably movsc: unimplemented"
     in
       if (nsave < 2) then
         List.concat (prologue :: (map transform instrs))
index 5010d7b..7ab1e89 100644 (file)
@@ -18,10 +18,10 @@ struct
   (* val stringify : asm -> string
    * turns a x86 instruction list into a string of assembly code for these instructions *)
 
-  fun stringify' rn (X.CALL (l, n)) = X.prettyprint (X.CALL ((Symbol.symbol (rn (Symbol.name l))), n))
-    | stringify' rn x = X.prettyprint x
+  fun stringify' rn (X.CALL (l, n)) = X.print (X.CALL ((Symbol.symbol (rn (Symbol.name l))), n))
+    | stringify' rn x = X.print x
 
   (* val stringify : asm -> string *)
-  fun stringify realname l = foldr (fn (a,b) => (stringify' realname a) ^ b) ("") l
+  fun stringify realname l = String.concat (List.map (stringify' realname) l)
 
 end
index e54d4be..c0ff0b8 100644 (file)
@@ -10,15 +10,20 @@ sig
   datatype reg =
     EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D
   (* operands to instructions *)
-  datatype size = Byte | Word | Long | Qword
-  datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (oper * oper) | STACKARG of int | OSIZE of (size * oper)
-  datatype cc = E | NE | GE | LE | L | G
+  datatype basicop = REG of reg |
+                     TEMP of Temp.temp |
+                     CONST of Word32.word |
+                     REL of ((basicop * Temp.size) * (basicop * Temp.size) * Word32.word) |
+                     STACKARG of int
+  type oper = basicop * Temp.size
+  datatype cc = E | NE | GE | LE | L | G | B | BE | A | AE
   (* instructions *)
   datatype insn =
     DIRECTIVE of string |
     COMMENT of string |
     LABEL of Label.label |
     MOV of oper * oper |
+    MOVSC of oper * oper |
     LEA of oper * oper |
     SUB of oper * oper |
     IMUL of oper * oper |
@@ -35,6 +40,7 @@ sig
     CMP of oper * oper |
     TEST of oper * oper |
     SETcc of cc * oper |
+    CMOVcc of cc * oper * oper |
     JMP of Label.label |
     Jcc of cc * Label.label |
     CALL of Symbol.symbol * int |
@@ -42,41 +48,48 @@ sig
     CLTD |
     LIVEIGN of insn |
     RET
-  
+
   structure OperSet : ORD_SET
-    where type Key.ord_key = oper;
+    where type Key.ord_key = basicop;
   structure LiveMap : ORD_MAP
     where type Key.ord_key = int;
   
-  val sts : int -> size
-  val sizeoper : oper -> size * oper
-  val stripsize : oper -> oper
-  val osize : oper -> size
+  val resize : Temp.size -> oper -> oper
+  val regcmp : reg * reg -> order
+  val getop : oper -> basicop
+  val osize : oper -> Temp.size
   val cmpoper : oper * oper -> order
+  val cmpbasic : basicop * basicop -> order
   val opereq : oper * oper -> bool
-  val regname : size -> reg -> string
+  val basiceq : basicop * basicop -> bool
+  val regname : Temp.size -> reg -> string
   val regtonum : reg -> int
   val numtoreg : int -> reg
   val ccname : cc -> string
   val opsused : insn list -> OperSet.set
-  val prettyprint_oper : size -> oper -> string
-  val prettyprint : insn -> string
+  val pp_oper : oper -> string
+  val print : insn -> string
 end
 
 structure x86 :> X86 =
 struct
 
-
   datatype reg =
     EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D
-  datatype size = Byte | Word | Long | Qword
-  datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (oper * oper) | STACKARG of int | OSIZE of (size * oper)
-  datatype cc = E | NE | GE | LE | L | G
+  (* operands to instructions *)
+  datatype basicop = REG of reg |
+                     TEMP of Temp.temp |
+                     CONST of Word32.word |
+                     REL of ((basicop * Temp.size) * (basicop * Temp.size) * Word32.word) |
+                     STACKARG of int
+  datatype cc = E | NE | GE | LE | L | G | B | BE | A | AE
+  type oper = basicop * Temp.size
   datatype insn =
     DIRECTIVE of string |
     COMMENT of string |
     LABEL of Label.label |
     MOV of oper * oper |
+    MOVSC of oper * oper |
     LEA of oper * oper |
     SUB of oper * oper |
     IMUL of oper * oper |
@@ -93,6 +106,7 @@ struct
     CMP of oper * oper |
     TEST of oper * oper |
     SETcc of cc * oper |
+    CMOVcc of cc * oper * oper |
     JMP of Label.label |
     Jcc of cc * Label.label |
     CALL of Symbol.symbol * int |
@@ -127,10 +141,10 @@ struct
       val (n, (b, w, l, q)) = valOf (List.find (fn (r, _) => r = reg) regnames)
     in
       case sz
-      of Byte => b
-       | Word => w
-       | Long => l
-       | Qword => q
+      of Temp.Byte => b
+       | Temp.Word => w
+       | Temp.Long => l
+       | Temp.Quad => q
     end
 
   fun ccname E  = "e"
@@ -139,6 +153,10 @@ struct
     | ccname LE = "le"
     | ccname G  = "g"
     | ccname L  = "l"
+    | ccname B  = "b"
+    | ccname A  = "a"
+    | ccname AE  = "ae"
+    | ccname BE  = "be"
 
   (* gives number (color) associated with reg *)
   fun regtonum EAX = 0
@@ -151,11 +169,11 @@ struct
     | regtonum R10D = 7
     | regtonum R11D = 8
     | regtonum EBX = 9
-    | regtonum R12D = 10
-    | regtonum R13D = 11
-    | regtonum R14D = 12
-    | regtonum R15D = 13
-    | regtonum EBP = 14                (* Dummy numbers -- not permitted for allocation, but there so that we can compare *)
+    | regtonum EBP = 10
+    | regtonum R12D = 11
+    | regtonum R13D = 12
+    | regtonum R14D = 13
+    | regtonum R15D = 14
     | regtonum RSP = 15
 
   (* gives reg associated with number (color) *)
@@ -169,45 +187,54 @@ struct
     | numtoreg 7 = R10D
     | numtoreg 8 = R11D
     | numtoreg 9 = EBX
-    | numtoreg 10 = R12D
-    | numtoreg 11 = R13D
-    | numtoreg 12 = R14D
-    | numtoreg 13 = R15D
-    | numtoreg n = raise ErrorMsg.InternalError ("numtoreg: Unknown register "^(Int.toString n))
+    | numtoreg 10 = EBP
+    | numtoreg 11 = R12D
+    | numtoreg 12 = R13D
+    | numtoreg 13 = R14D
+    | numtoreg 14 = R15D
+    | numtoreg n = raise ErrorMsg.InternalError ("numtoreg: Invalid register "^(Int.toString n))
 
   (* register compare *)
   fun regcmp (r1, r2) = Int.compare (regtonum r1, regtonum r2)
+  fun osize (_,s) = s
+  fun resize ss (a,_) = (a,ss)
+  fun getop (a,_) = a
 
   (* operand compare; arbitrary order imposed to make
    * various things easier (e.g. liveness, for sorting)
    *)
-  fun cmpoper (REG(reg1), REG(reg2)) = regcmp (reg1, reg2)
-    | cmpoper (TEMP(temp1), TEMP(temp2)) = Temp.compare (temp1,temp2)
-    | cmpoper (CONST(const1), CONST(const2)) = Word32.compare (const1, const2)
-    | cmpoper (REL (r1, i1), REL (r2, i2)) =
-        let 
-          val order1 = cmpoper (r1, r2)
-          val order2 = cmpoper (i1, i2)
+  fun cmpbasic (REG reg1, REG reg2) = regcmp (reg1, reg2)
+    | cmpbasic (TEMP temp1, TEMP temp2) = Temp.compare (temp1,temp2)
+    | cmpbasic (CONST(const1), CONST(const2)) = Word32.compare (const1, const2)
+    | cmpbasic (REL (r1, i1, m1), REL (r2, i2, m2)) =
+        let
+          val orderm = Word32.compare (m1,m2)
+          val order1 = cmpbasic (getop r1, getop r2)
+          val order2 = cmpbasic (getop i1, getop i2)
+          val o1 = if(order1 = EQUAL) then order2 else order1
         in
-          if (order1 = EQUAL) then order2
-          else order1
+          if (o1 = EQUAL) then orderm
+          else o1
         end
-    | cmpoper (CONST _, _) = LESS
-    | cmpoper (REG _, _) = LESS
-    | cmpoper (REL _, _) = LESS
-    | cmpoper (_, _) = GREATER
+    | cmpbasic (CONST _, _) = LESS
+    | cmpbasic (REG _, _) = LESS
+    | cmpbasic (REL _, _) = LESS
+    | cmpbasic (_, _) = GREATER
+
+  fun cmpoper ((o1,s1),(o2,s2)) = (case (cmpbasic (o1,o2)) of EQUAL => Temp.cmpsize (s1,s2) | a => a)
+
+  fun basiceq (REG a, REG b) = a = b
+    | basiceq (TEMP a, TEMP b) = Temp.eq (a, b)
+    | basiceq (CONST a, CONST b) = a = b
+    | basiceq (REL (a1, b1, m1), REL (a2, b2, m2)) = m1 = m2 andalso basiceq (getop a1, getop a2) andalso basiceq (getop b1, getop b2)
+    | basiceq (_, _) = false
+
+  fun opereq ((o1,s1),(o2,s2)) = basiceq (o1,o2) andalso s1 = s2
 
-  fun opereq (REG a, REG b) = a = b
-    | opereq (TEMP a, TEMP b) = Temp.eq (a, b)
-    | opereq (CONST a, CONST b) = a = b
-    | opereq (REL (a1, b1), REL (a2, b2)) = opereq (a1,a2) andalso opereq (b1,b2)
-(*    | opereq (OSIZE (s1, o1), OSIZE (s2, o2)) = (s1 = s2) andalso opereq (o1, o2)*) (* This breaks the peepholer, shit *)
-    | opereq (_, _) = false
-    
   structure OperSet = ListSetFn (
     struct
-      type ord_key = oper
-      val compare = cmpoper
+      type ord_key = basicop
+      val compare = cmpbasic
     end)
   
   structure LiveMap = SplayMapFn(struct
@@ -219,87 +246,73 @@ struct
     | opsused ((DIRECTIVE _)::l) = opsused l
     | opsused ((COMMENT _)::l) = opsused l
     | opsused ((LABEL _)::l) = opsused l
-    | opsused ((MOV (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((LEA (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((SUB (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((IMUL (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((IMUL3 (dst, src, _))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((ADD (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((IDIV (src))::l) = OperSet.addList (opsused l, [src, REG EDX, REG EAX])
-    | opsused ((NEG (dst))::l) = OperSet.addList (opsused l, [dst])
-    | opsused ((NOT (dst))::l) = OperSet.addList (opsused l, [dst])
-    | opsused ((SAL (dst, shft))::l) = OperSet.addList (opsused l, [dst, shft])
-    | opsused ((SAR (dst, shft))::l) = OperSet.addList (opsused l, [dst, shft])
-    | opsused ((AND (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((OR (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((XOR (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((CMP (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((TEST (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
-    | opsused ((SETcc (c, dst))::l) = OperSet.addList (opsused l, [dst])
+    | opsused ((MOV ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((MOVSC((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((LEA ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((SUB ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((IMUL ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((IMUL3 ((dst,_), (src,_), _))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((ADD ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((IDIV (src,_))::l) = OperSet.addList (opsused l, [src, REG EDX, REG EAX])
+    | opsused ((NEG (dst,_))::l) = OperSet.addList (opsused l, [dst])
+    | opsused ((NOT (dst,_))::l) = OperSet.addList (opsused l, [dst])
+    | opsused ((SAL ((dst,_), (shft,_)))::l) = OperSet.addList (opsused l, [dst, shft])
+    | opsused ((SAR ((dst,_), (shft,_)))::l) = OperSet.addList (opsused l, [dst, shft])
+    | opsused ((AND ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((OR ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((XOR ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((CMP ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((TEST ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((SETcc (c, (dst,_)))::l) = OperSet.addList (opsused l, [dst])
+    | opsused ((CMOVcc (c, (dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
     | opsused ((JMP _)::l) = opsused l
     | opsused ((Jcc _)::l) = opsused l
     | opsused ((CALL _)::l) = opsused l
-    | opsused ((MOVZB (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
+    | opsused ((MOVZB ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src])
     | opsused ((CLTD)::l) = opsused l
     | opsused ((RET)::l) = opsused l
     | opsused ((LIVEIGN i)::l) = opsused (i::l)
 
-  fun sts 8 = Qword
-    | sts 4 = Long
-    | sts 2 = Word
-    | sts 1 = Byte
-    | sts _ = raise ErrorMsg.InternalError "invalid size"
-
-  (* pretty prints an operand *)  
-  fun sfx Byte = "b"
-    | sfx Word = "w"
-    | sfx Long = "l"
-    | sfx Qword = "q"
-
-  fun osize (OSIZE (s, _)) = s
-    | osize _ = Long
-
-  fun stripsize (OSIZE (_, oo)) = stripsize oo
-    | stripsize oo = oo
-
-  fun sizeoper (OSIZE (s, oo)) = (s, stripsize oo)
-    | sizeoper oo = (Long, oo)
 
-  fun prettyprint_oper s (REG r) = "%" ^ (regname s r)
-    | prettyprint_oper _ (TEMP t) = (Temp.name t) ^ (sfx (sts (Temp.size t)))
-    | prettyprint_oper _ (CONST c) = "$0x" ^ (Word32.toString c)
-    | prettyprint_oper _ (REL (r, CONST n)) = (Word32Signed.toString n) ^ "(" ^ (prettyprint_oper Qword r) ^ ")"
-    | prettyprint_oper s (REL (r1, r2)) = "(" ^ (prettyprint_oper Qword (stripsize r1)) ^ "," ^ (prettyprint_oper Qword (stripsize r2)) ^ ")"
-    | prettyprint_oper _ (STACKARG i) = "arg#"^Int.toString i
-    | prettyprint_oper _ (OSIZE (s, oo)) = prettyprint_oper s (stripsize oo)
+  fun pp_oper (REG r, s) = "%" ^ (regname s r)
+    | pp_oper (TEMP t, _) = (Temp.name t) ^ (Temp.sfx (Temp.size t))
+    | pp_oper (CONST c, _) = "$" ^ Word32Signed.toString c
+    | pp_oper (REL ((CONST n, _), _, _), _) = Word32Signed.toString n
+    | pp_oper (REL (r, (CONST n, _), _), _) = (Word32Signed.toString n) ^ "(" ^ (pp_oper r) ^ ")"
+    | pp_oper (REL (r1, r2, m), _) = "(" ^ (pp_oper r1) ^ "," ^ (pp_oper r2) ^ "," ^
+                                           (Word32.toString m) ^ ")"
+    | pp_oper (STACKARG i, _) = "arg#"^Int.toString i
 
-  (* pretty prints (no...) *)
-  fun prettyprint (DIRECTIVE(str)) = str ^ "\n"
-    | prettyprint (COMMENT(str)) = "// " ^ str ^ "\n"
-    | prettyprint (LABEL(l)) = Label.name l ^ ":\n"
-    | prettyprint (LEA(dst, src)) = "\tlea" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (MOV(dst, src)) = "\tmov" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (SUB(dst, src)) = "\tsub" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (IMUL(dst, src)) = "\timul" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (IMUL3(dst, tmp, const)) = "\timul" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (CONST const)) ^ ", " ^ (prettyprint_oper (osize dst) (stripsize tmp)) ^ ", " ^ (prettyprint_oper (osize dst) dst) ^ "\n"
-    | prettyprint (ADD(dst, src)) = "\tadd" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (IDIV(src)) = "\tidiv" ^ (sfx (osize src)) ^ "\t" ^ (prettyprint_oper (osize src) src) ^ "\n"
-    | prettyprint (NEG (dst)) = "\tneg" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (NOT (dst)) = "\tnot" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (SAL (dst, shft)) = "\tsal" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (SAR (dst, shft)) = "\tsar" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (AND (dst, src)) = "\tand" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (OR (dst, src)) = "\tor" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (XOR (dst, src)) = "\txor" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (CMP (dst, src)) = "\tcmp" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (TEST (dst, src)) = "\ttest" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (prettyprint_oper Byte (stripsize dst)) ^ "\n"
-    | prettyprint (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n"
-    | prettyprint (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n"
-    | prettyprint (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n"
-    | prettyprint (MOVZB (dst, src)) = "\tmovzb" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
-    | prettyprint (CLTD) = "\tcltd\n"
-    | prettyprint (RET) = "\tret\n"
-    | prettyprint (LIVEIGN i) = prettyprint i
-(*    | prettyprint _ = raise ErrorMsg.InternalError ("prettyprint: Type A? Hatchar de coneccion?")*)
+  (* pretty prints the asm *)
+  fun print (DIRECTIVE(str)) = str ^ "\n"
+    | print (COMMENT(str)) = "// " ^ str ^ "\n"
+    | print (LABEL(l)) = Label.name l ^ ":\n"
+    | print (LEA(dst, src)) = "\tlea" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (MOV(dst, src)) = "\tmov" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (MOVSC((d,Temp.Long), (s,Temp.Quad))) = "\tmov" ^ (Temp.sfx Temp.Long) ^ "\t" ^ (pp_oper (s,Temp.Long)) ^ ", " ^ (pp_oper (d,Temp.Long)) ^ " // sex change\n"
+    | print (MOVSC((d,Temp.Quad), (s,Temp.Long))) = "\tmov" ^ (Temp.sfx Temp.Long) ^ "\t" ^ (pp_oper (s,Temp.Long)) ^ ", " ^ (pp_oper (d,Temp.Long)) ^ " // sex change\n"
+    | print (MOVSC(_,_)) = raise ErrorMsg.InternalError "invalid size change"
+    | print (SUB(dst, src)) = "\tsub" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (IMUL(dst, src)) = "\timul" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (IMUL3(dst, tmp, const)) = "\timul" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper (CONST const, Temp.Long)) ^ ", " ^ (pp_oper tmp) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (ADD(dst, src)) = "\tadd" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (IDIV(src)) = "\tidiv" ^ (Temp.sfx (osize src)) ^ "\t" ^ (pp_oper src) ^ "\n"
+    | print (NEG (dst)) = "\tneg" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper dst) ^ "\n"
+    | print (NOT (dst)) = "\tnot" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper dst) ^ "\n"
+    | print (SAL (dst, shft)) = "\tsal" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper shft) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (SAR (dst, shft)) = "\tsar" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper shft) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (AND (dst, src)) = "\tand" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (OR (dst, src)) = "\tor" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (XOR (dst, src)) = "\txor" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (CMP (dst, src)) = "\tcmp" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (TEST (dst, src)) = "\ttest" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (pp_oper dst) ^ "\n"
+    | print (CMOVcc (c, dst, src)) = "\tcmov" ^ (ccname c) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n"
+    | print (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n"
+    | print (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n"
+    | print (MOVZB (dst, src)) = "\tmovzb" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n"
+    | print (CLTD) = "\tcltd\n"
+    | print (RET) = "\tret\n"
+    | print (LIVEIGN i) = print i
 end
similarity index 72%
rename from compile-l4c.sml
rename to compile-l5c.sml
index 7299ee8..f5af6ed 100644 (file)
@@ -4,4 +4,4 @@
  *)
 
 CM.make "sources.cm";
-SMLofNJ.exportFn ("bin/l4c.heap", Top.main);
+SMLofNJ.exportFn ("bin/l5c.heap", Top.main);
diff --git a/optimize/constfold.sml b/optimize/constfold.sml
new file mode 100644 (file)
index 0000000..43e9d38
--- /dev/null
@@ -0,0 +1,69 @@
+structure ConstantFold :> OPTIMIZATION =
+struct
+  structure T = Tree
+
+(*  fun isconstret (T.FUNCTION (id, stml)) = foldr (fn (l,(b)) => noeffect l andalso ) true stml *)
+
+  fun operate (T.ADD)    a b = a + b
+    | operate (T.SUB)    a b = a - b
+    | operate (T.MUL)    a b = a * b
+    | operate (T.DIV)    a b = Word32Signed.adiv (a,b)
+    | operate (T.MOD)    a b = Word32Signed.amod (a,b)
+    | operate (T.LSH)    a b = Suq.Word32_lsh (a, Word32.mod (b, 0w32))
+    | operate (T.RSH)    a b = Suq.Word32_rsh (a, Word32.mod (b, 0w32))
+    | operate (T.BITOR)  a b = Word32.orb (a,b)
+    | operate (T.BITAND) a b = Word32.andb (a,b)
+    | operate (T.BITXOR) a b = Word32.xorb (a,b)
+    | operate (T.LOGOR)  a b = if (a <> 0w0 orelse b <> 0w0) then 0w1 else 0w0
+    | operate (T.LOGAND) a b = if (a <> 0w0 andalso b <> 0w0) then 0w1 else 0w0
+    | operate (T.NEQ)    a b = if (a <> b) then 0w1 else 0w0
+    | operate (T.EQ)     a b = if (a = b) then 0w1 else 0w0
+    | operate (T.LT)     a b = if (Word32Signed.lt (a,b)) then 0w1 else 0w0
+    | operate (T.GT)     a b = if (Word32Signed.gt (a,b)) then 0w1 else 0w0
+    | operate (T.LE)     a b = if (Word32Signed.le (a,b)) then 0w1 else 0w0
+    | operate (T.GE)     a b = if (Word32Signed.ge (a,b)) then 0w1 else 0w0
+    | operate (T.BE)     a b = if (Word32.>= (a,b)) then 0w1 else 0w0
+
+  fun operate_unop (T.NEG)    a = 0w0 - a
+    | operate_unop (T.BITNOT) a = Word32.notb a
+    | operate_unop (T.BANG)   a = if (a = 0w0) then 0w1 else 0w0
+
+  fun foldexp (T.BINOP(oper, e1, e2)) =
+        let
+          val f1 = foldexp e1
+          val f2 = foldexp e2
+        in
+          case f1
+          of T.CONST n1 => (case f2
+                            of T.CONST n2 => (T.CONST (operate oper n1 n2) handle _ (* Might be either 'div' on smlnj or 'overflow' on mlton *) => T.BINOP(oper, T.CONST n1, T.CONST n2))
+                             | _ => T.BINOP(oper, T.CONST n1, f2))
+           | _ => T.BINOP (oper, f1, f2)
+        end
+    | foldexp (T.UNOP(oper, e)) = (case foldexp e of T.CONST n => T.CONST (operate_unop oper n) | a => T.UNOP(oper, a))
+    | foldexp (T.CONST(n)) = T.CONST n
+    | foldexp (T.TEMP(t)) = T.TEMP t
+    | foldexp (T.ARG(n)) = T.ARG n
+    | foldexp (T.CALL(id, l, n)) = T.CALL (id, List.map (fn (a,n) => (foldexp a, n)) l, n)
+    | foldexp (T.MEMORY (e, s)) = T.MEMORY (foldexp e, s)
+    | foldexp (T.ALLOC (e)) = T.ALLOC (foldexp e)
+    | foldexp (T.STMVAR (sl, e)) = T.STMVAR (List.map foldstm sl, foldexp e)
+    | foldexp (T.COND (c, e1, e2)) =
+        let
+          val f1 = foldexp e1
+          val f2 = foldexp e2
+        in
+          case foldexp c
+          of T.CONST n => if n <> 0w0 then f1 else f2
+           | a => T.COND (a, f1, f2)
+        end
+    | foldexp (T.NULLPTR) = T.NULLPTR
+
+  and foldstm (T.MOVE (e1, e2)) = T.MOVE (foldexp e1, foldexp e2)
+    | foldstm (T.RETURN (e, s)) = T.RETURN (foldexp e, s)
+    | foldstm (T.EFFECT e) = T.EFFECT (foldexp e)
+    | foldstm (a as T.LABEL _) = a
+    | foldstm (T.JUMPIFN (e, l)) = T.JUMPIFN (foldexp e, l)
+    | foldstm (a as T.JUMP _) = a
+
+  val optimizer = { shortname = "constant-fold", description = "Folds constant expressions into constants", func = Optimizer.IREXP foldexp }
+end
diff --git a/optimize/feckful.sml b/optimize/feckful.sml
new file mode 100644 (file)
index 0000000..ec6bdc5
--- /dev/null
@@ -0,0 +1,13 @@
+structure FeckfulnessAnalysis :> OPTIMIZATION =
+struct
+  structure T = Tree
+  structure TU = TreeUtils
+  
+  fun feckstm (a as T.EFFECT e) =
+        if (TU.effect e)
+        then [a]
+        else []
+    | feckstm a = [a]
+  
+  val optimizer = { shortname = "feckfulness", description = "Removes simple side effect statements that have no effect", func = Optimizer.IRSTM feckstm }
+end
diff --git a/optimize/labelcoalescing.sml b/optimize/labelcoalescing.sml
new file mode 100644 (file)
index 0000000..5188e95
--- /dev/null
@@ -0,0 +1,28 @@
+structure LabelCoalescing :> OPTIMIZATION =
+struct
+  structure X = x86
+  
+  structure LabelMap = SplayMapFn(struct
+                                    type ord_key = Label.label
+                                    val compare = Label.compare
+                                  end)
+  
+  fun coalesce insns =
+    let
+      fun lmap (SOME(a)) ((X.LABEL l)::is) = let val (m, il) = lmap (SOME(a)) is in (LabelMap.insert(m, l, a), il) end
+        | lmap (NONE) ((X.LABEL l)::is) = let val (m, il) = lmap (SOME(l)) is in  (LabelMap.insert(m, l, l), (X.LABEL l)::il) end
+        | lmap _ (i::is) = let val (m, il) = lmap NONE is in (m, i::il) end
+        | lmap _ nil = (LabelMap.empty, nil)
+
+      val (labelmap, insns') = lmap NONE insns
+
+      fun convert ((X.Jcc(c,l))::is) = (X.Jcc(c, valOf(LabelMap.find(labelmap,l))))::(convert is)
+        | convert ((X.JMP(l))::is) = (X.JMP(valOf(LabelMap.find(labelmap,l))))::(convert is)
+        | convert (i::is) = i::(convert is)
+        | convert nil = nil
+    in
+      convert insns'
+    end  
+  
+  val optimizer = { shortname = "labelcoalescing", description = "Coalesces adjacent labels", func = Optimizer.PRELIVENESS coalesce }
+end
diff --git a/optimize/optimizer.sml b/optimize/optimizer.sml
new file mode 100644 (file)
index 0000000..fba6485
--- /dev/null
@@ -0,0 +1,76 @@
+signature OPTIMIZER =
+sig
+  datatype optfunc =
+    IRPROG of (Tree.program -> Tree.program) |
+    IRFUNC of (Tree.func -> Tree.func) |
+    IRSTM of (Tree.stm -> Tree.stm list) |
+    IREXP of (Tree.exp -> Tree.exp) |
+    PRELIVENESS of (x86.insn list -> x86.insn list) |
+    FINAL of (x86.insn list -> x86.insn list)
+  
+  type optimization = {
+    shortname : string,
+    description : string,
+    func : optfunc
+    }
+  
+  val optimize_ir : optimization list -> Tree.program -> Tree.program
+  val optimize_preliveness : optimization list -> x86.insn list -> x86.insn list
+  val optimize_final : optimization list -> x86.insn list -> x86.insn list
+end
+
+structure Optimizer :> OPTIMIZER =
+struct
+  structure T = Tree
+  
+  datatype optfunc =
+    IRPROG of (Tree.program -> Tree.program) |
+    IRFUNC of (Tree.func -> Tree.func) |
+    IRSTM of (Tree.stm -> Tree.stm list) |
+    IREXP of (Tree.exp -> Tree.exp) |
+    PRELIVENESS of (x86.insn list -> x86.insn list) |
+    FINAL of (x86.insn list -> x86.insn list)
+  
+  type optimization = {
+    shortname : string,
+    description : string,
+    func : optfunc
+    }
+  
+  fun foldfunc f (T.FUNCTION (id, stml)) = T.FUNCTION (id, List.concat (List.map f stml))
+  fun expfunc f (T.MOVE (e1, e2)) = [T.MOVE (f e1, f e2)]
+    | expfunc f (T.RETURN (e, s)) = [T.RETURN (f e, s)]
+    | expfunc f (T.EFFECT e) = [T.EFFECT (f e)]
+    | expfunc f (a as T.LABEL _) = [a]
+    | expfunc f (T.JUMPIFN (e, l)) = [T.JUMPIFN (f e, l)]
+    | expfunc f (a as T.JUMP _) = [a]
+  
+  fun optimize_ir ol prog =
+    foldr (
+      fn (IRPROG f, prog) => f prog
+       | (IRFUNC f, prog) => List.map f prog
+       | (IRSTM  f, prog) => List.map (foldfunc (f)) prog
+       | (IREXP  f, prog) => List.map (foldfunc (expfunc f)) prog
+       | (_, prog) => prog)
+      prog
+      (map (fn (x : optimization) => #func x) ol)
+  
+  fun optimize_preliveness ol assem =
+    foldr (
+      fn (PRELIVENESS f, assem) => f assem
+       | (_, assem) => assem)
+      assem
+      (map (fn (x : optimization) => #func x) ol)
+  
+  fun optimize_final ol assem =
+    foldr (
+      fn (FINAL f, assem) => f assem
+       | (_, assem) => assem)
+      assem
+      (map (fn (x : optimization) => #func x) ol)
+end
+
+signature OPTIMIZATION =
+sig
+  val optimizer : Optimizer.optimization
+end
diff --git a/optimize/peephole.sml b/optimize/peephole.sml
new file mode 100644 (file)
index 0000000..2c8ef5d
--- /dev/null
@@ -0,0 +1,48 @@
+(* L3 compiler
+ * peephole optimizer
+ * optimizes away redundant insns such as:
+     mov a, b
+     mov a, b
+
+     mov a, b
+     mov b, a
+
+     mov a, a
+     
+     neg a
+     neg a
+ * Author: Chris Lu <czl@andrew.cmu.edu>
+ *)
+
+structure Peephole :> OPTIMIZATION =
+struct
+  structure X = x86
+
+  (* val peephole : x86.insn list -> x86.insn list *)
+  fun peephole ((insn1 as X.MOV(d1, s1 as (X.REL a,_)))::(insn2 as X.MOV(d2, s2 as (X.REL(a2,b2,m),_)))::l) =
+        if(X.opereq(a2,d1) orelse X.opereq(b2,d1)) then
+          insn1::(peephole (insn2::l))
+        else if(X.opereq(s1,s2) andalso X.opereq (d1,d2)) then
+          peephole (insn2::l)
+        else
+          insn1::(peephole (insn2::l))
+    | peephole ((insn1 as X.MOV(a1,b1))::(insn2 as X.MOV(a2,b2))::l) =
+        if(X.opereq(a1, b1) orelse (X.opereq(a1, a2) andalso X.opereq(b1, b2))) then
+          peephole (insn2::l)
+        else if(X.opereq(a2, b2) orelse (X.opereq(a1, b2) andalso X.opereq(b1, a2))) then
+          peephole (insn1::l)
+        else
+          insn1::(peephole (insn2::l))
+    | peephole (X.MOV (a as (X.REG r,s), (X.CONST 0w0,_))::l) = (X.XOR (a, a))::(peephole l)
+    | peephole ((insn as X.MOV(a,b))::l) = if X.opereq(a, b) then peephole l else insn::(peephole l)
+    | peephole ((insn1 as X.NEG(a))::(insn2 as X.NEG(b))::l) = if X.opereq(a, b) then peephole l else insn1::(peephole (insn2::l))
+    | peephole (X.ADD (_, (X.CONST 0w0,_))::l) = peephole l
+    | peephole (X.SUB (_, (X.CONST 0w0,_))::l) = peephole l
+(*    | peephole (X.CMP ((X.REG r,s), (X.CONST 0w0,_))::l) = (X.TEST ((X.REG r,s), (X.REG r,s)))::(peephole l) *)
+    | peephole ((X.JMP a)::(X.JMP b)::l) = peephole ((X.JMP a)::l) (* What the cock? Yes, we actually generate this. *)
+    | peephole ((X.JMP l1)::(X.LABEL l2)::l) = if (Label.compare (l1,l2) = EQUAL) then (X.LABEL l2)::(peephole l) else (X.JMP l1)::(X.LABEL l2)::(peephole l)
+    | peephole (a::l) = a::(peephole l)
+    | peephole nil = nil
+  
+  val optimizer = { shortname = "peephole", description = "Peephole analysis", func = Optimizer.FINAL peephole }
+end
diff --git a/optimize/stupidfunc.sml b/optimize/stupidfunc.sml
new file mode 100644 (file)
index 0000000..99bd6b0
--- /dev/null
@@ -0,0 +1,58 @@
+structure StupidFunctionElim :> OPTIMIZATION =
+struct
+  structure T = Tree
+  structure TU = TreeUtils
+
+  datatype rval = Any | Const of Word32.word
+
+  fun stmhit NONE _ = NONE
+    | stmhit _ (T.JUMPIFN _) = NONE
+    | stmhit (SOME(Any)) (T.RETURN (T.CONST n, s)) = SOME(Const(n))
+    | stmhit (SOME(Const(n))) (T.RETURN (T.CONST n',s)) = if n' = n then SOME(Const(n)) else NONE
+    | stmhit _ (T.RETURN _) = NONE
+    | stmhit opt s = if TU.effect_stm s then NONE else opt
+
+  fun stupid (T.FUNCTION (id, fl)) = (foldr (fn (a,b) => stmhit b a) (SOME(Any)) fl, id)
+
+  fun findstupids prog = foldr (fn ((SOME(Const(n)),id),b) => Symbol.bind b (id, SOME(n))
+                                 | ((SOME(Any), id),b) => raise ErrorMsg.InternalError "wtf, this function no return"
+                                 | ((NONE, id),b) => Symbol.bind b (id, NONE))
+                               Symbol.empty
+                               (List.map stupid prog)
+
+  fun ds_exp t (T.CALL(id, l, s)) =
+        let
+          val effecting = List.mapPartial (fn (a,_) => if TU.effect a then SOME(ds_exp t a) else NONE) l
+        in
+          (case Symbol.look' t id
+            of SOME(n) => T.STMVAR(List.map T.EFFECT effecting, T.CONST n)
+            |  NONE => T.CALL(id, List.map (fn (a,i) => (ds_exp t a, i)) l, s))
+          handle Option => T.CALL(id, List.map (fn (a,i) => (ds_exp t a, i)) l, s)
+        end
+    | ds_exp t (T.BINOP(oper, e1, e2)) = T.BINOP(oper, ds_exp t e1, ds_exp t e2)
+    | ds_exp t (T.UNOP(oper, e)) = T.UNOP(oper, ds_exp t e)
+    | ds_exp t (T.MEMORY (e,s)) = T.MEMORY (ds_exp t e, s)
+    | ds_exp t (T.COND (c, e1, e2)) = T.COND (ds_exp t c, ds_exp t e1, ds_exp t e2)
+    | ds_exp t (T.ALLOC e) = T.ALLOC (ds_exp t e)
+    | ds_exp t (T.STMVAR (sl, e)) = T.STMVAR (List.map (ds_stm t) sl, ds_exp t e)
+    | ds_exp t a = a
+
+  and ds_stm t (T.MOVE (e1, e2)) = T.MOVE (ds_exp t e1, ds_exp t e2)
+    | ds_stm t (T.RETURN (e, s)) = T.RETURN (ds_exp t e, s)
+    | ds_stm t (T.EFFECT e) = T.EFFECT (ds_exp t e)
+    | ds_stm t (a as T.LABEL _) = a
+    | ds_stm t (T.JUMPIFN (e, l)) = T.JUMPIFN (ds_exp t e, l)
+    | ds_stm t (a as T.JUMP _) = a
+
+  fun diestupids prog =
+    let
+      val stupids = findstupids prog
+      fun kill (T.FUNCTION (id, sl)) = T.FUNCTION (id, List.map (ds_stm stupids) sl)
+    in
+      List.map kill prog
+    end
+
+  val optimizer = { shortname = "stupidfn",
+                    description = "Turns stupid functions with constant return and no side effect into constant",
+                    func = Optimizer.IRPROG diestupids }
+end
index 84b2356..75f7042 100644 (file)
@@ -13,13 +13,6 @@ signature AST =
 sig
   type ident = Symbol.symbol
   
-  datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull
-  val typeeq : vtype * vtype -> bool
-  val castable : vtype * vtype -> bool (* true if the second type can be casted to the first implicitly *)
-  type variable = ident * vtype
-  datatype typedef = Struct of variable list
-                   | MarkedTypedef of typedef Mark.marked
-
   datatype oper = 
      PLUS
    | MINUS
@@ -53,9 +46,10 @@ sig
    | DerefMember of exp * ident
    | Dereference of exp
    | ArrIndex of exp * exp
-   | New of vtype
-   | NewArr of vtype * exp
+   | New of Type.vtype
+   | NewArr of Type.vtype * exp
    | Null
+   | Conditional of exp * exp * exp
   and stm =
      Assign of exp * exp
    | AsnOp of oper * exp * exp
@@ -70,17 +64,16 @@ sig
    | MarkedStm of stm Mark.marked
 
   datatype function =
-     Extern of vtype * (variable list)
-   | Function of vtype * (variable list) * (variable list) * stm list
+     Extern of Type.vtype * (Type.variable list)
+   | Function of Type.vtype * (Type.variable list) * (Type.variable list) * stm list
    | MarkedFunction of function Mark.marked
   
-  type program = typedef Symbol.table * function Symbol.table
+  type program = Type.typedef Symbol.table * function Symbol.table
 
   (* print as source, with redundant parentheses *)
   structure Print :
   sig
     val pp_exp : exp -> string
-    val pp_type : vtype -> string
     val pp_stm : stm -> string
     val pp_program : program -> string
   end
@@ -90,20 +83,6 @@ structure Ast :> AST =
 struct
   type ident = Symbol.symbol
 
-  datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull
-  fun typeeq (Int, Int) = true
-    | typeeq (Typedef a, Typedef b) = (Symbol.name a) = (Symbol.name b)
-    | typeeq (Pointer a, Pointer b) = typeeq (a, b)
-    | typeeq (Array a, Array b) = typeeq (a, b)
-    | typeeq (TNull, TNull) = true
-    | typeeq _ = false
-  fun castable (Pointer _, TNull) = true
-    | castable (Array _, TNull) = true
-    | castable (a, b) = typeeq (a, b)
-  type variable = ident * vtype
-  datatype typedef = Struct of variable list
-                   | MarkedTypedef of typedef Mark.marked
-
   datatype oper = 
      PLUS
    | MINUS
@@ -137,9 +116,10 @@ struct
    | DerefMember of exp * ident
    | Dereference of exp
    | ArrIndex of exp * exp
-   | New of vtype
-   | NewArr of vtype * exp
+   | New of Type.vtype
+   | NewArr of Type.vtype * exp
    | Null
+   | Conditional of exp * exp * exp
   and stm =
      Assign of exp * exp
    | AsnOp of oper * exp * exp
@@ -154,11 +134,11 @@ struct
    | MarkedStm of stm Mark.marked
 
   datatype function =
-     Extern of vtype * (variable list)
-   | Function of vtype * (variable list) * (variable list) * stm list
+     Extern of Type.vtype * (Type.variable list)
+   | Function of Type.vtype * (Type.variable list) * (Type.variable list) * stm list
    | MarkedFunction of function Mark.marked
   
-  type program = typedef Symbol.table * function Symbol.table
+  type program = Type.typedef Symbol.table * function Symbol.table
 
   (* print programs and expressions in source form
    * using redundant parentheses to clarify precedence
@@ -205,9 +185,10 @@ struct
       | pp_exp (DerefMember(e, i)) = pp_exp e ^ "->" ^ pp_ident i
       | pp_exp (Dereference(e)) = "*(" ^ pp_exp e ^ ")"
       | pp_exp (ArrIndex(e1, e2)) = pp_exp e1 ^ "[" ^pp_exp e2 ^ "]"
-      | pp_exp (New t) = "new(" ^ pp_type t ^ ")"
-      | pp_exp (NewArr (t, s)) = "new(" ^ pp_type t ^ "[" ^ pp_exp s ^ "])"
+      | pp_exp (New t) = "new(" ^ Type.Print.pp_type t ^ ")"
+      | pp_exp (NewArr (t, s)) = "new(" ^ Type.Print.pp_type t ^ "[" ^ pp_exp s ^ "])"
       | pp_exp Null = "NULL"
+      | pp_exp (Conditional (q, e1, e2)) = "("^(pp_exp q)^"?"^(pp_exp e1)^":"^(pp_exp e2)^")"
     
     and pp_expl nil = ""
       | pp_expl (e::a::l) = (pp_exp e) ^ ", " ^ (pp_expl (a::l))
@@ -240,27 +221,18 @@ struct
 
     and pp_stms nil = ""
       | pp_stms (s::ss) = pp_stm s ^ "\n" ^ pp_stms ss
-    
-    and pp_type Int = "int"
-      | pp_type (Typedef i) = pp_ident i
-      | pp_type (Pointer t) = pp_type t ^ "*"
-      | pp_type (Array t) = pp_type t ^ "[]"
-      | pp_type TNull = "{NULL type}"
-    
+
     and pp_params nil = ""
-      | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ ", " ^ (pp_params (a::l))
-      | pp_params ((i, t)::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ (pp_params l)
+      | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (Type.Print.pp_type t) ^ ", " ^ (pp_params (a::l))
+      | pp_params ((i, t)::l) = (pp_ident i) ^ " : " ^ (Type.Print.pp_type t) ^ (pp_params l)
     
     and pp_vars nil = ""
-      | pp_vars ((i, t)::l) = "var " ^ (pp_ident i) ^ " : " ^ (pp_type t) ^ ";\n" ^ (pp_vars l)
+      | pp_vars ((i, t)::l) = "var " ^ (pp_ident i) ^ " : " ^ (Type.Print.pp_type t) ^ ";\n" ^ (pp_vars l)
 
-    and pp_function (n, Extern(t, pl)) = "extern " ^ (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ");\n"
-      | pp_function (n, Function(t, pl, vl, stms)) = (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ")\n{\n" ^ (pp_vars vl) ^ (String.concat (map pp_stm stms)) ^ "\n}\n"
+    and pp_function (n, Extern(t, pl)) = "extern " ^ (Type.Print.pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ");\n"
+      | pp_function (n, Function(t, pl, vl, stms)) = (Type.Print.pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ")\n{\n" ^ (pp_vars vl) ^ (String.concat (map pp_stm stms)) ^ "\n}\n"
       | pp_function (n, MarkedFunction d) = pp_function (n, Mark.data d)
-    
-    and pp_typedef (i, Struct (v)) = "struct " ^ (pp_ident i) ^ " {\n" ^ (String.concat (map (fn (i', t) => "  " ^ (pp_ident i') ^ " : " ^ (pp_type t) ^ ";\n") v)) ^ "}\n"
-      | pp_typedef (i, MarkedTypedef d) = pp_typedef (i, Mark.data d)
-    
-    and pp_program (types, funs) = String.concat ((map pp_typedef (Symbol.elemsi types)) @ (map pp_function (Symbol.elemsi funs)))
+
+    and pp_program (types, funs) = String.concat ((map Type.Print.pp_typedef (Symbol.elemsi types)) @ (map pp_function (Symbol.elemsi funs)))
   end
 end
index 72bdaeb..7031e67 100644 (file)
@@ -2,33 +2,22 @@ signature ASTUTILS =
 sig    
   structure Program :
   sig
-    val append_typedef : Ast.program -> (Ast.ident * Ast.typedef) -> Ast.program
+    val append_typedef : Ast.program -> (Ast.ident * Type.typedef) -> Ast.program
     val append_function : Ast.program -> (Ast.ident * Ast.function) -> Ast.program
   end
-  
-  structure Typedef :
-  sig
-    val data : Ast.typedef -> Ast.typedef
-    val mark : Ast.typedef -> Mark.ext option
-  end
-  
+
   structure Function :
   sig
     val data : Ast.function -> Ast.function
     val mark : Ast.function -> Mark.ext option
-    val returntype : Ast.function -> Ast.vtype
-    val params : Ast.function -> Ast.variable list
-  end
-  
-  structure Type :
-  sig
-    val size : Ast.vtype -> int
-    val issmall : Ast.vtype -> bool
+    val returntype : Ast.function -> Type.vtype
+    val params : Ast.function -> Type.variable list
   end
 end
 
 structure AstUtils :> ASTUTILS =
 struct
+  structure T = Type
   structure A = Ast
 
   structure Program =
@@ -36,10 +25,10 @@ struct
     fun append_typedef (tds, fns) (i, td) =
       let
         val mark = case td
-                   of A.MarkedTypedef m => Mark.ext m
+                   of T.MarkedTypedef m => Mark.ext m
                     | _ => NONE
         val _ = case (Symbol.look tds i)
-                of SOME (A.MarkedTypedef m) => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ;
+                of SOME (T.MarkedTypedef m) => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ;
                                                 ErrorMsg.error (Mark.ext m) "(was originally defined here)" ;
                                                 raise ErrorMsg.Error)
                  | SOME _ => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ;
@@ -64,16 +53,7 @@ struct
        (tds, Symbol.bind fns (i, func))
      end
   end
-  
-  structure Typedef =
-  struct
-    fun data (A.MarkedTypedef m) = data (Mark.data m)
-      | data m = m
-    
-    fun mark (A.MarkedTypedef m) = Mark.ext m
-      | mark _ = NONE
-  end
-  
+
   structure Function =
   struct
     fun data (A.MarkedFunction m) = data (Mark.data m)
@@ -90,18 +70,5 @@ struct
       | params (A.Function (_, pl, _, _)) = pl
       | params (A.Extern (_, pl)) = pl
   end
-  
-  structure Type =
-  struct
-    fun size A.Int = 4
-      | size (A.Typedef _) = raise ErrorMsg.InternalError "AU.Type.size on non-small type?"
-      | size (A.Pointer _) = 8
-      | size (A.Array _) = 8
-      | size A.TNull = 8
-    
-    fun issmall A.Int = true
-      | issmall (A.Pointer _) = true
-      | issmall (A.Array _) = true
-      | issmall _ = false
-  end
+
 end
similarity index 88%
rename from parse/l4.grm
rename to parse/l5.grm
index 3f14c33..7195271 100644 (file)
@@ -1,5 +1,5 @@
-(* L4 Compiler
- * L4 grammar
+(* L5 Compiler
+ * L5 grammar
  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
  * Modified: Joshua Wise <jwise@andrew.cmu.edu>
@@ -7,6 +7,7 @@
  *)
 
 structure A = Ast
+structure T = Type
 structure AU = AstUtils
 structure AUP = AstUtils.Program
 
@@ -16,7 +17,7 @@ structure AUP = AstUtils.Program
 fun mark (e, (left, right)) = A.Marked (Mark.mark' (e, ParseState.ext (left, right)))
 fun markstm (e, (left, right)) = A.MarkedStm (Mark.mark' (e, ParseState.ext (left, right)))
 fun markfunction (e, (left, right)) = A.MarkedFunction (Mark.mark' (e, ParseState.ext (left, right)))
-fun marktypedef (e, (left, right)) = A.MarkedTypedef (Mark.mark' (e, ParseState.ext (left, right)))
+fun marktypedef (e, (left, right)) = T.MarkedTypedef (Mark.mark' (e, ParseState.ext (left, right)))
 
 (* create lval from expression; here just an id *)
 (* generates error if not an identifier *)
@@ -27,7 +28,7 @@ fun make_lval (A.Var(id)) ext = id
                        Symbol.bogus )
 
 %%
-%header (functor L4LrValsFn (structure Token : TOKEN))
+%header (functor L5LrValsFn (structure Token : TOKEN))
 
 %term 
    EOF
@@ -42,7 +43,8 @@ fun make_lval (A.Var(id)) ext = id
  | LBRACE | RBRACE
  | LPAREN | RPAREN
  | UNARY | ASNOP (* dummy *)
- | EXTERN | VAR | INT | COLON | COMMA | STRUCT | NULL | LBRACKET | RBRACKET | ARROW | DOT | NEW
+ | EXTERN | VAR | INT | QUESTION | COLON | COMMA | STRUCT | NULL | LBRACKET | RBRACKET | ARROW | DOT | NEW
+ | PLUSPLUS | MINUSMINUS
 
 %nonterm 
    program of A.program
@@ -59,17 +61,17 @@ fun make_lval (A.Var(id)) ext = id
  | simpoption of A.stm option
  | elseoption of A.stm list option
  | idents of A.ident list
- | vtype of A.vtype
+ | vtype of T.vtype
  | decls of A.program
  | extdecl of A.ident * A.function
- | paramlist of A.variable list
- | param of A.variable
- | typedecl of A.ident * A.typedef
- | memberlist of (A.ident * A.vtype) list
- | member of (A.ident * A.vtype)
+ | paramlist of T.variable list
+ | param of T.variable
+ | typedecl of T.ident * T.typedef
+ | memberlist of (T.ident * T.vtype) list
+ | member of (T.ident * T.vtype)
  | function of A.ident * A.function
- | vardecl of A.variable list
- | vardecls of A.variable list
+ | vardecl of T.variable list
+ | vardecls of T.variable list
 
 %verbose                                (* print summary of errors *)
 %pos int                                (* positions *)
@@ -77,8 +79,9 @@ fun make_lval (A.Var(id)) ext = id
 %eop EOF
 %noshift EOF
 
-%name L4
+%name L5
 
+%right QUESTION COLON
 %left LOGOR
 %left LOGAND
 %left BITOR
@@ -99,11 +102,11 @@ program    : programx               (programx)
 programx   : decls                  (decls)
            | programx function      (AUP.append_function programx function)
 
-vtype      : INT                    (A.Int)
-           | IDENT                  (A.Typedef IDENT)
-           | vtype STAR             (A.Pointer vtype)
+vtype      : INT                    (T.Int)
+           | IDENT                  (T.Typedef IDENT)
+           | vtype STAR             (T.Pointer vtype)
            | vtype LBRACKET RBRACKET
-                                    (A.Array vtype)
+                                    (T.Array vtype)
 
 decls      :                        (Symbol.empty, Symbol.empty)
            | typedecl decls         (AUP.append_typedef decls typedecl)
@@ -120,9 +123,9 @@ paramlist  : param COMMA paramlist  (param :: paramlist)
 param      : IDENT COLON vtype      (IDENT, vtype)
 
 typedecl   : STRUCT IDENT LBRACE RBRACE SEMI
-                                    (IDENT, marktypedef (A.Struct ([]), (STRUCTleft, SEMIright)))
+                                    (IDENT, marktypedef (T.Struct ([]), (STRUCTleft, SEMIright)))
            | STRUCT IDENT LBRACE memberlist RBRACE SEMI
-                                    (IDENT, marktypedef (A.Struct (memberlist), (STRUCTleft, SEMIright)))
+                                    (IDENT, marktypedef (T.Struct (memberlist), (STRUCTleft, SEMIright)))
 
 memberlist : member memberlist      (member :: memberlist)
            | member                 ([member])
@@ -154,6 +157,10 @@ simp       : exp ASSIGN exp %prec ASNOP
                                     (A.Assign(exp1, exp2))
            | exp asnop exp %prec ASNOP
                                     (A.AsnOp(asnop, exp1, exp2))
+           | exp PLUSPLUS %prec ASNOP
+                                    (A.AsnOp(A.PLUS, exp, A.ConstExp(0w1)))
+           | exp MINUSMINUS %prec ASNOP
+                                    (A.AsnOp(A.MINUS, exp, A.ConstExp(0w1)))
            | exp                    (markstm (A.Effect (exp), (expleft, expright)))
 
 control    : IF LPAREN exp RPAREN block elseoption
@@ -212,6 +219,8 @@ exp        : LPAREN exp RPAREN      (exp)
            | MINUS exp %prec UNARY  (mark (A.OpExp (A.NEGATIVE, [exp]), (MINUSleft,expright)))
            | BITNOT exp %prec UNARY (mark (A.OpExp (A.BITNOT, [exp]), (BITNOTleft,expright)))
            | BANG exp %prec UNARY   (mark (A.OpExp (A.BANG, [exp]), (BANGleft,expright)))
+           | exp QUESTION exp COLON exp
+                                    (mark (A.Conditional (exp1, exp2, exp3), (exp1left, exp3right)))
 
 explist    : exp                    ([exp])
            | exp COMMA explist      (exp :: explist)
similarity index 86%
rename from parse/l4.lex
rename to parse/l5.lex
index b988c35..e10f8b7 100644 (file)
@@ -1,4 +1,4 @@
-(* L4 Compiler
+(* L5 Compiler
  * Lexer
  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
@@ -41,6 +41,22 @@ in
                       Tokens.INTNUM (Word32Signed.ZERO, yyp, yyp + size yyt) )
           | SOME n => Tokens.INTNUM (n,yyp,yyp + size yyt)
       end
+  fun hexnumber (yyt, yyp) =
+      let
+        val t = String.extract (yyt, 2, NONE)
+        val ext = ParseState.ext (yyp, yyp + size yyt)
+       val numOpt = StringCvt.scanString (Word32.scan StringCvt.HEX) t
+                     handle Overflow =>
+                           ( ErrorMsg.error ext
+                                ("integral constant `" ^ yyt ^ "' too large") ;
+                             NONE )
+      in
+       case numOpt
+         of NONE => ( ErrorMsg.error ext
+                         ("cannot parse integral constant `" ^ yyt ^ "'");
+                      Tokens.INTNUM (Word32Signed.ZERO, yyp, yyp + size yyt) )
+          | SOME n => Tokens.INTNUM (n,yyp,yyp + size yyt)
+      end
 
   fun eof () = 
       ( if (!commentLevel > 0)
@@ -51,12 +67,13 @@ in
 end
 
 %%
-%header (functor L4LexFn(structure Tokens : L4_TOKENS));
+%header (functor L5LexFn(structure Tokens : L5_TOKENS));
 %full
 %s COMMENT COMMENT_LINE;
 
 id = [A-Za-z_][A-Za-z0-9_]*;
 decnum = [0-9][0-9]*;
+hexnum = 0x[0-9a-fA-F][0-9a-fA-F]*;
 
 ws = [\ \t\012];
 
@@ -84,6 +101,9 @@ ws = [\ \t\012];
 <INITIAL> "^="        => (Tokens.BITXOREQ (yypos, yypos + size yytext));
 <INITIAL> "|="        => (Tokens.BITOREQ (yypos, yypos + size yytext));
 
+<INITIAL> "++"         => (Tokens.PLUSPLUS (yypos, yypos + size yytext));
+<INITIAL> "--"         => (Tokens.MINUSMINUS (yypos, yypos + size yytext));
+
 <INITIAL> "+"         => (Tokens.PLUS (yypos, yypos + size yytext));
 <INITIAL> "-"         => (Tokens.MINUS (yypos, yypos + size yytext));
 <INITIAL> "!"         => (Tokens.BANG (yypos, yypos + size yytext));
@@ -105,6 +125,7 @@ ws = [\ \t\012];
 <INITIAL> ">="        => (Tokens.GE (yypos, yypos + size yytext));
 <INITIAL> ">"         => (Tokens.GT (yypos, yypos + size yytext));
 
+<INITIAL> "?"         => (Tokens.QUESTION (yypos, yypos + size yytext));
 <INITIAL> ":"         => (Tokens.COLON (yypos, yypos + size yytext));
 <INITIAL> ","         => (Tokens.COMMA (yypos, yypos + size yytext));
 
@@ -129,6 +150,7 @@ ws = [\ \t\012];
 
 
 <INITIAL> {decnum}    => (number (yytext, yypos));
+<INITIAL> {hexnum}    => (hexnumber (yytext, yypos));
 
 <INITIAL> {id}        => (let
                             val id = Symbol.symbol yytext
index 3786421..a2cc2fe 100644 (file)
@@ -1,4 +1,4 @@
-(* L4 Compiler
+(* L5 Compiler
  * Parsing
  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
@@ -17,10 +17,10 @@ end
 structure Parse :> PARSE =
 struct 
 
-  structure L4LrVals = L4LrValsFn (structure Token = LrParser.Token)
-  structure L4Lex = L4LexFn (structure Tokens = L4LrVals.Tokens)
-  structure L4Parse = Join (structure ParserData = L4LrVals.ParserData
-                            structure Lex = L4Lex
+  structure L5LrVals = L5LrValsFn (structure Token = LrParser.Token)
+  structure L5Lex = L5LexFn (structure Tokens = L5LrVals.Tokens)
+  structure L5Parse = Join (structure ParserData = L5LrVals.ParserData
+                            structure Lex = L5Lex
                             structure LrParser = LrParser)
 
   (* Main parsing function *)
@@ -31,18 +31,18 @@ struct
          val _ = ParseState.setfile filename (* start at position 0 in filename *)
          fun parseerror (s, p1, p2) = ErrorMsg.error (ParseState.ext (p1,p2)) s
          val lexer = LrParser.Stream.streamify
-                         (L4Lex.makeLexer (fn _ => TextIO.input instream))
+                         (L5Lex.makeLexer (fn _ => TextIO.input instream))
          (* 0 = no error correction, 15 = reasonable lookahead for correction *)
-         val (absyn, _) = L4Parse.parse(0, lexer, parseerror, ())
+         val (absyn, _) = L5Parse.parse(0, lexer, parseerror, ())
           val _ = if !ErrorMsg.anyErrors
                  then raise ErrorMsg.Error
                  else ()
        in
          absyn
        end)
-      handle Fail s => ( ErrorMsg.error NONE ("lexer error: "^s) ;
-                        raise ErrorMsg.Error )
-          | LrParser.ParseError => raise ErrorMsg.Error (* always preceded by msg *)
+      handle (*L5Lex.LexError => ( ErrorMsg.error NONE "lexer error" ;
+                              raise ErrorMsg.Error )
+          |*) LrParser.ParseError => raise ErrorMsg.Error (* always preceded by msg *)
            | e as IO.Io _ => ( ErrorMsg.error NONE (exnMessage e);
                                raise ErrorMsg.Error )
 
index 351df5f..5fdb4c7 100644 (file)
@@ -3,6 +3,8 @@ Group is
        $/smlnj-lib.cm
        $/ml-yacc-lib.cm
 
+       top/smlnj-specific.sml
+
        util/mark.sml
        util/flag.sml
        util/symbol.sml
@@ -10,29 +12,38 @@ Group is
         util/safe-io.sml
         util/word32.sml
 
+       top/flags.sml
+
+       type/type.sml
        parse/ast.sml
        parse/astutils.sml
        parse/parsestate.sml
-       parse/l4.lex
-       parse/l4.grm
+       parse/l5.lex
+       parse/l5.grm
        parse/parse.sml
 
        type/typechecker.sml
 
        trans/temp.sml
-
         trans/label.sml
        trans/tree.sml
+       trans/treeutils.sml
        trans/trans.sml
 
        codegen/x86.sml
        codegen/codegen.sml
+       codegen/liveness.sml
        codegen/igraph.sml
        codegen/colororder.sml
        codegen/solidify.sml
        codegen/coloring.sml
        codegen/stringifier.sml
-       codegen/peephole.sml
-       codegen/liveness.sml
+
+        optimize/optimizer.sml
+       optimize/constfold.sml
+       optimize/feckful.sml
+       optimize/labelcoalescing.sml
+       optimize/peephole.sml
+       optimize/stupidfunc.sml
 
        top/top.sml
index 0f45274..63f9acf 100644 (file)
@@ -2,6 +2,8 @@ $(SML_LIB)/basis/basis.mlb
 $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb
 $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
 
+       top/mlton-specific.sml
+
        util/mark.sml
        util/flag.sml
        util/symbol.sml
@@ -9,12 +11,15 @@ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
         util/safe-io.sml
         util/word32.sml
 
+       top/flags.sml
+
+       type/type.sml
        parse/ast.sml
        parse/astutils.sml
        parse/parsestate.sml
-       parse/l4.grm.sig
-       parse/l4.grm.sml
-       parse/l4.lex.sml
+       parse/l5.grm.sig
+       parse/l5.grm.sml
+       parse/l5.lex.sml
        parse/parse.sml
 
        type/typechecker.sml
@@ -22,18 +27,24 @@ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
        trans/temp.sml
         trans/label.sml
        trans/tree.sml
+       trans/treeutils.sml
        trans/trans.sml
 
        codegen/x86.sml
+       codegen/codegen.sml
        codegen/liveness.sml
        codegen/igraph.sml
        codegen/colororder.sml
        codegen/solidify.sml
        codegen/coloring.sml
        codegen/stringifier.sml
-       codegen/peephole.sml
-       codegen/codegen.sml
 
-       top/top.sml
+        optimize/optimizer.sml
+       optimize/constfold.sml
+       optimize/feckful.sml
+       optimize/labelcoalescing.sml
+       optimize/peephole.sml
+       optimize/stupidfunc.sml
 
-       top/top_mlton.sml
\ No newline at end of file
+       top/top.sml
+       top/top_mlton.sml
diff --git a/top/flags.sml b/top/flags.sml
new file mode 100644 (file)
index 0000000..2017230
--- /dev/null
@@ -0,0 +1,28 @@
+signature FLAGS =
+sig
+  val verbose : Flag.flag
+  val liveness : Flag.flag
+  val ast : Flag.flag
+  val ir : Flag.flag
+  val assem : Flag.flag
+  val color : Flag.flag
+  val safe : Flag.flag
+  
+  val reset : unit -> unit     (* Anus... *)
+end
+
+structure Flags :> FLAGS =
+struct
+  val verbose = Flag.flag "verbose"
+  val liveness = Flag.flag "liveness"
+  val ast = Flag.flag "ast"
+  val ir = Flag.flag "ir"
+  val assem = Flag.flag "assem"
+  val color = Flag.flag "color"
+  val safe = Flag.flag "safe"
+  
+  fun reset () =
+    (List.app Flag.unset [verbose, ast,
+                          ir, assem, liveness, safe])
+end
+  
\ No newline at end of file
diff --git a/top/mlton-specific.sml b/top/mlton-specific.sml
new file mode 100644 (file)
index 0000000..e37b093
--- /dev/null
@@ -0,0 +1,11 @@
+signature SUQ =
+sig
+  val Word32_lsh : Word32.word * Word32.word -> Word32.word
+  val Word32_rsh : Word32.word * Word32.word -> Word32.word
+end
+
+structure Suq :> SUQ =
+struct
+  fun Word32_lsh (a, b) = Word32.<< (a, b)
+  fun Word32_rsh (a, b) = Word32.~>> (a, b)
+end
\ No newline at end of file
diff --git a/top/smlnj-specific.sml b/top/smlnj-specific.sml
new file mode 100644 (file)
index 0000000..e57cae6
--- /dev/null
@@ -0,0 +1,12 @@
+signature SUQ =
+sig
+  val Word32_lsh : Word32.word * Word32.word -> Word32.word
+  val Word32_rsh : Word32.word * Word32.word -> Word32.word
+end
+
+structure Suq :> SUQ =
+struct
+  fun loseBit (x: Word32.word) : word = Word31.fromInt (Word32.toInt x)
+  fun Word32_lsh (a, b) = Word32.<< (a, loseBit b)
+  fun Word32_rsh (a, b) = Word32.~>> (a, loseBit b)
+end
index c350c09..4b58d00 100644 (file)
@@ -27,38 +27,61 @@ struct
   fun newline () = TextIO.output (TextIO.stdErr, "\n")
 
   exception EXIT
+  
+  val alloptimizations =
+    [ConstantFold.optimizer,
+     StupidFunctionElim.optimizer,
+     FeckfulnessAnalysis.optimizer,
+     ConstantFold.optimizer,
+     LabelCoalescing.optimizer,
+     Peephole.optimizer]
+  
+  val uniqopts =
+    foldr
+      (fn (opt : Optimizer.optimization, l) =>
+        if (List.exists (fn (x : Optimizer.optimization) => (#shortname opt) = (#shortname x)) l)
+        then l
+        else opt :: l)
+      []
+      alloptimizations
 
-  (* see flag explanations below *)
-  val flag_verbose = Flag.flag "verbose"
-  val flag_liveness = Flag.flag "liveness"
-  val flag_ast = Flag.flag "ast"
-  val flag_ir = Flag.flag "ir"
-  val flag_assem = Flag.flag "assem"
-  val flag_color = Flag.flag "color"
-
-  fun reset_flags () =
-      List.app Flag.unset [flag_verbose, flag_ast,
-                           flag_ir, flag_assem, flag_liveness];
+  val enabledopts = ref alloptimizations
 
   val options = [{short = "v", long=["verbose"], 
-                  desc=G.NoArg (fn () => Flag.set flag_verbose),
+                  desc=G.NoArg (fn () => Flag.set Flags.verbose),
                   help="verbose messages"},
                  {short = "a", long=["dump-ast"],
-                  desc=G.NoArg (fn () => Flag.set flag_ast),
+                  desc=G.NoArg (fn () => Flag.set Flags.ast),
                   help="pretty print the AST"},
                  {short = "i", long=["dump-ir"],
-                  desc=G.NoArg (fn () => Flag.set flag_ir),
+                  desc=G.NoArg (fn () => Flag.set Flags.ir),
                   help="pretty print the IR"},
                  {short = "l", long=["dump-liveness"],
-                  desc=G.NoArg (fn () => Flag.set flag_liveness),
+                  desc=G.NoArg (fn () => Flag.set Flags.liveness),
                   help="pretty print the liveness results"},
                  {short = "s", long=["dump-assem"],
-                  desc=G.NoArg (fn () => Flag.set flag_assem),
+                  desc=G.NoArg (fn () => Flag.set Flags.assem),
                   help="pretty print the assembly before register allocaction"},
                  {short = "c", long=["dump-color"],
-                  desc=G.NoArg (fn () => Flag.set flag_color),
-                  help="pretty print the allocated regs"}
-                ]
+                  desc=G.NoArg (fn () => Flag.set Flags.color),
+                  help="pretty print the allocated regs"},
+                 {short = "", long=["safe"],
+                  desc=G.NoArg (fn () => Flag.set Flags.safe),
+                  help="enable memory-safety"},
+                 {short = "", long=["unsafe"],
+                  desc=G.NoArg (fn () => Flag.unset Flags.safe),
+                  help="disable memory-safety"}, 
+                 {short = "", long = ["disable-all"],
+                  desc=G.NoArg (fn () => enabledopts := nil),
+                  help="disable all optimizations"}
+                ] @
+                map
+                  (fn (opt : Optimizer.optimization) =>
+                    { short = "", long=["disable-" ^ (#shortname opt)],
+                      desc = G.NoArg (* This is nasty. *)
+                        (fn () => enabledopts := List.filter (fn x => (#shortname x) <> (#shortname opt)) (!enabledopts)),
+                      help = "disable optimization: " ^ (#description opt) })
+                  uniqopts
 
 
   fun stem s =
@@ -73,27 +96,30 @@ struct
   
   fun processir externs (Tree.FUNCTION (id, ir)) =
       let
-        val name = "_l4_" ^ (Symbol.name id)
+        val name = "_l5_" ^ (Symbol.name id)
         
         fun realname s = if (List.exists (fn n => s = n) externs)
                          then s
-                         else "_l4_" ^ s
+                         else "_l5_" ^ s
       
-        val _ = Flag.guard flag_verbose say ("Processing function: " ^ name)
+        val _ = Flag.guard Flags.verbose say ("Processing function: " ^ name)
 
-        val _ = Flag.guard flag_verbose say "  Generating proto-x86_64 code..."
+        val _ = Flag.guard Flags.verbose say "  Generating proto-x86_64 code..."
         val assem = Codegen.codegen ir
-        val _ = Flag.guard flag_assem
-                  (fn () => List.app (TextIO.print o (x86.prettyprint)) assem) ()
+        val _ = Flag.guard Flags.assem
+                  (fn () => List.app (TextIO.print o (x86.print)) assem) ()
 
-        val _ = Flag.guard flag_verbose say "  Analyzing liveness..."
+        val _ = Flag.guard Flags.verbose say "  Optimizing pre-liveness..."
+        val assem = Optimizer.optimize_preliveness (!enabledopts) assem
+        
+        val _ = Flag.guard Flags.verbose say "  Analyzing liveness..."
         val (preds, liveness) = Liveness.liveness assem;
-        val _ = Flag.guard flag_liveness
+        val _ = Flag.guard Flags.liveness
                   (fn () => List.app
                     (fn (asm, liv) =>
                       TextIO.print (
                         let
-                          val xpp = x86.prettyprint asm
+                          val xpp = x86.print asm
                           val xpp = String.extract (xpp, 0, SOME (size xpp - 1))
                           val spaces = implode (List.tabulate (40 - size xpp, fn _ => #" ")) handle size => ""
                           val lpp = Liveness.prettyprint liv
@@ -104,32 +130,32 @@ struct
                         end))
                     (ListPair.zip (assem, Liveness.listify liveness))) ()
 
-        val _ = Flag.guard flag_verbose say "  Graphing..."
+        val _ = Flag.guard Flags.verbose say "  Graphing..."
         val (igraph,temps) = Igraph.gengraph (preds, liveness)
 
-        val _ = Flag.guard flag_verbose say "  Ordering..."
+        val _ = Flag.guard Flags.verbose say "  Ordering..."
         val order = ColorOrder.colororder (igraph,temps)
         
-        val _ = Flag.guard flag_verbose say "  Coloring..."
-        val colors = Colorizer.colorize order igraph;
-        val _ = Flag.guard flag_color
+        val _ = Flag.guard Flags.verbose say "  Coloring..."
+        val colors = Colorizer.colorize order igraph
+        val _ = Flag.guard Flags.color
                   (fn () => List.app (TextIO.print o
                     (fn (t, i) =>
                       (Temp.name t) ^ " => " ^ (
                         if (i <= x86.regtonum x86.R13D)
-                          then (x86.prettyprint_oper x86.Long (x86.REG (x86.numtoreg i)))
+                          then (x86.pp_oper (x86.REG (x86.numtoreg i), Temp.Long))
                         else
                           "spill[" ^ Int.toString (i - x86.regtonum x86.R13D) ^ "]")
                         ^ "--"^ Int.toString i ^ "\n"))
                     colors) ()
 
-        val _ = Flag.guard flag_verbose say "  Solidifying x86_64 code..."
-        val x86 = Solidify.solidify colors assem;
+        val _ = Flag.guard Flags.verbose say "  Solidifying x86_64 code..."
+        val x86 = Solidify.solidify colors assem
 
-        val _ = Flag.guard flag_verbose say "  Peepholing..."
-        val x86p = Peephole.peephole x86;
+        val _ = Flag.guard Flags.verbose say "  Optimizing final assembly..."
+        val x86p = Optimizer.optimize_final (!enabledopts) x86
 
-        val _ = Flag.guard flag_verbose say "  Stringifying..."
+        val _ = Flag.guard Flags.verbose say "  Stringifying..."
         val x86d = [x86.DIRECTIVE(".globl " ^ name),
                     x86.DIRECTIVE(name ^ ":")]
                     @ x86p
@@ -145,7 +171,7 @@ struct
         fun errfn msg = (say (msg ^ "\n" ^ usageinfo) ; raise EXIT)
 
         val _ = Temp.reset (); (* reset temp variable counter *)
-        val _ = reset_flags (); (* return all flags to default value *)
+        val _ = Flags.reset (); (* return all flags to default value *)
 
         val _ = if List.length args = 0 then
                     (say usageinfo; raise EXIT)
@@ -163,10 +189,12 @@ struct
                | [filename] => filename
                | _ => errfn "Error: more than one input file"
 
-        val _ = Flag.guard flag_verbose say ("Parsing... " ^ source)
+        val _ = Flag.guard Flags.verbose say ("Enabled optimizations: " ^ String.concat (map (fn x => (#shortname x) ^ " ") (!enabledopts)))
+
+        val _ = Flag.guard Flags.verbose say ("Parsing... " ^ source)
         val ast = Parse.parse source
         val (_, funcs) = ast
-        val _ = Flag.guard flag_ast
+        val _ = Flag.guard Flags.ast
                   (fn () => say (Ast.Print.pp_program ast)) ()
 
         val externs = Symbol.mapPartiali
@@ -175,18 +203,23 @@ struct
                                        | _ => NONE
                         ) funcs
 
-        val _ = Flag.guard flag_verbose say "Checking..."
+        val _ = Flag.guard Flags.verbose say "Checking..."
         val ast = TypeChecker.typecheck ast
 
-        val _ = Flag.guard flag_verbose say "Translating..."
+        val _ = Flag.guard Flags.verbose say "Translating..."
         val ir = Trans.translate ast
-        val _ = Flag.guard flag_ir (fn () => say (Tree.Print.pp_program ir)) ()
-        
+        val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) ()
+
+        val _ = Flag.guard Flags.verbose say "Optimizing whole-program IR..."
+        val ir = Optimizer.optimize_ir (!enabledopts) ir
+        val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) ()
+
         val output = foldr (fn (func, code) => (processir ("calloc" (* lololololol *) :: (Symbol.elems externs)) func) ^ code) 
-          (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 L4 compiler by czl@ and jwise@\"\n") ir
+          (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 ASS compiler by czl@ and jwise@\"\n" ^
+           ".ident \"Optimizations enabled: " ^ String.concat (map (fn x => (#shortname x) ^ " ") (!enabledopts)) ^ "\"\n") ir
 
         val afname = stem source ^ ".s"
-        val _ = Flag.guard flag_verbose say ("Writing assembly to " ^ afname ^ " ...")
+        val _ = Flag.guard Flags.verbose say ("Writing assembly to " ^ afname ^ " ...")
         val _ = SafeIO.withOpenOut afname (fn afstream =>
                    TextIO.output (afstream, output))
       in
index 1092dfc..bd311c4 100644 (file)
@@ -8,18 +8,23 @@
 signature TEMP = 
 sig
   type temp
+  datatype size = Byte | Word | Long | Quad
 
-  val reset : unit -> unit     (* resets temp numbering *)
-  val new : string -> int -> temp      (* returns a unique new temp *)
-  val name : temp -> string    (* returns the name of a temp *)
-  val size : temp -> int       (* returns the size of a temp *)
+  val reset : unit -> unit           (* resets temp numbering *)
+  val new : string -> size -> temp   (* returns a unique new temp *)
+  val name : temp -> string          (* returns the name of a temp *)
+  val size : temp -> size            (* returns the size of a temp *)
   val compare : temp * temp -> order (* comparison function *)
   val eq : temp * temp -> bool
+  val cmpsize : size * size -> order
+  val sfx : size -> string
+  val sts : int -> size
 end
 
 structure Temp :> TEMP = 
 struct
-  type temp = int * string * int
+  datatype size = Byte | Word | Long | Quad
+  type temp = int * string * size
 
   local
     val counter = ref 1
@@ -29,9 +34,32 @@ struct
     fun new str size = (!counter, str, size) before ( counter := !counter + 1 )
   end
 
-  fun name (t,s, sz) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]"
+  fun sfx Byte = "b"
+    | sfx Word = "w"
+    | sfx Long = "l"
+    | sfx Quad = "q"
+
+  fun name (t,s, sz) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]" ^ sfx sz
   fun size (t, s, sz) = sz
   fun compare ((t1,_,_),(t2,_,_)) = Int.compare (t1,t2)
 
   fun eq ((t1,_,_), (t2,_,_)) = t1 = t2
+
+  fun cmpsize (Quad,Quad) = EQUAL
+    | cmpsize (Quad,_) = GREATER
+    | cmpsize (_,Quad) = LESS
+    | cmpsize (Long,Long) = EQUAL
+    | cmpsize (Long,_) = GREATER
+    | cmpsize (_,Long) = LESS
+    | cmpsize (Word,Word) = EQUAL
+    | cmpsize (Word,_) = GREATER
+    | cmpsize (_,Word) = LESS
+    | cmpsize (Byte,Byte) = EQUAL
+
+  fun sts 8 = Quad
+    | sts 4 = Long
+    | sts 2 = Word
+    | sts 1 = Byte
+    | sts _ = raise ErrorMsg.InternalError "Temp.sts: invalid size"
+
 end
index 6148ce8..7c70af1 100644 (file)
 signature TRANS =
 sig
   (* translate abstract syntax tree to IR tree *)
-  val translate : Ast.program -> Tree.func list
+  val translate : Ast.program -> Tree.program
 end
 
 structure Trans :> TRANS = 
 struct
 
   structure A = Ast
-  structure AU = AstUtils
   structure T = Tree
   
   fun trans_oper A.PLUS = T.ADD
@@ -43,72 +42,24 @@ struct
   fun translate (defs, funcs) =
     let
       val funclist = Symbol.elemsi funcs
+      val _ = Type.alignment_reset()
+      val _ = Type.sizeof_reset()
+      fun sizeof a = Type.sizeof defs a
+      fun alignment a = Type.alignment defs a
+      fun align t curpos = Type.align defs t curpos
 
-      val alignments = ref Symbol.empty  (* Ref for memoization. *)
-      fun alignment A.Int = 4
-        | alignment (A.Typedef(id)) =
-         (case Symbol.look (!alignments) id
-            of NONE =>
-              let
-                val r = alignment_s (Symbol.look' defs id)
-                val _ = (alignments := (Symbol.bind (!alignments) (id, r)))
-              in
-                r
-              end
-             | SOME r => r)
-        | alignment (A.Pointer(_)) = 8
-        | alignment (A.Array(_)) = 8
-        | alignment (A.TNull) = raise ErrorMsg.InternalError "alignmentof TNull?"
-      and alignment_s (A.Struct(members)) =
-            foldl
-              (fn ((_,t),al) => Int.max (al, alignment t))
-              1
-              members
-        | alignment_s (A.MarkedTypedef(a)) = alignment_s (Mark.data a)
-
-      fun align t curpos =
-        let
-          val al = alignment t
-        in
-          if (curpos mod al) = 0
-          then curpos
-          else curpos + al - (curpos mod al)
-        end
-
-      val sizes = ref Symbol.empty
-      fun sizeof_v A.Int = 4
-        | sizeof_v (A.Typedef(id)) =
-         (case Symbol.look (!sizes) id
-            of NONE =>
-              let
-                val r = sizeof_s (Symbol.look' defs id)
-                val _ = (sizes := (Symbol.bind (!sizes) (id, r)))
-              in
-                r
-              end
-             | SOME r => r)
-        | sizeof_v (A.Pointer(_)) = 8
-        | sizeof_v (A.Array(_)) = 8
-        | sizeof_v (A.TNull) = raise ErrorMsg.InternalError "sizeof TNull?"
-      and sizeof_s (A.Struct(l)) =
-          foldl
-            (fn ((_,t),curpos) => align t curpos + sizeof_v t)
-            0
-            l
-        | sizeof_s (A.MarkedTypedef(a)) = sizeof_s (Mark.data a)
-
-      fun offset_s id (A.Typedef(id')) =
+      fun offset_s id (Type.Typedef(id')) =
         let
           val shit = Symbol.look' defs id'
-          fun eat (A.Struct(l)) = l
-            | eat (A.MarkedTypedef(a)) = eat (Mark.data a)
+          fun eat (Type.Struct(l)) = l
+            | eat (Type.MarkedTypedef(a)) = eat (Mark.data a)
           fun offset_s' ((id1,t)::l') curofs =
             let
               val a = align t curofs
             in
               if Symbol.compare(id,id1) = EQUAL
                 then a
-              else offset_s' l' (a + sizeof_v t)
+              else offset_s' l' (a + sizeof t)
             end
             | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"
         in
@@ -116,11 +67,11 @@ struct
         end
         | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
       
-      fun type_s id (A.Typedef id') =
+      fun type_s id (Type.Typedef id') =
         let
           val td = 
-            case AU.Typedef.data (Symbol.look' defs id')
-            of A.Struct d => d
+            case Type.defdata (Symbol.look' defs id')
+            of Type.Struct d => d
              | _ => raise ErrorMsg.InternalError "data didn't return struct"
           fun type_s' ((id',t)::l) =
             if (Symbol.compare (id, id') = EQUAL)
@@ -132,8 +83,8 @@ struct
         end
         | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
       
-      fun deref (A.Pointer i) = i
-        | deref (A.Array i) = i
+      fun deref (Type.Pointer i) = i
+        | deref (Type.Array i) = i
         | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer"
 
       fun trans_unop A.NEGATIVE = T.NEG
@@ -158,38 +109,80 @@ struct
         | trans_exp env vartypes (A.FuncCall(func, stms)) =
             T.CALL(func,
               List.map
-                (fn exp => (trans_exp env vartypes exp, AU.Type.size (typeof' vartypes exp)))
+                (fn exp => (trans_exp env vartypes exp, Temp.sts (Type.size (typeof' vartypes exp))))
                 stms,
-              AU.Type.size (AU.Function.returntype (Symbol.look' funcs func)) )
+              Temp.sts (Type.size (AstUtils.Function.returntype (Symbol.look' funcs func))))
         | trans_exp env vartypes (A.Member (exp, id)) =
             let
               val apk = T.BINOP (T.ADD, trans_exp env vartypes exp, T.CONST (Word32.fromInt (offset_s id (typeof' vartypes exp))))
+              val tipo = type_s id (typeof' vartypes exp)
             in
-             if (AU.Type.issmall (type_s id (typeof' vartypes exp)))
-             then T.MEMORY(apk)
+             if Type.issmall tipo
+             then T.MEMORY(apk, Temp.sts (Type.size tipo))
              else apk
            end
         | trans_exp env vartypes (A.DerefMember (exp, id)) =
             trans_exp env vartypes (A.Member (A.Dereference (exp), id))
         | trans_exp env vartypes (A.Dereference(exp)) =
-            if (AU.Type.issmall (deref (typeof' vartypes exp)))
-            then T.MEMORY(trans_exp env vartypes exp)
+            if (Type.issmall (deref (typeof' vartypes exp)))
+            then T.MEMORY(trans_exp env vartypes exp, Temp.sts (Type.size (deref (typeof' vartypes exp))))
             else trans_exp env vartypes exp
         | trans_exp env vartypes (A.ArrIndex(exp1, exp2)) =
             let
               val asubk = T.BINOP(T.ADD, trans_exp env vartypes exp1, 
                                   T.BINOP(T.MUL, trans_exp env vartypes exp2,
-                                          T.CONST(Word32.fromInt(sizeof_v (deref (typeof' vartypes exp1))))))
+                                          T.CONST(Word32.fromInt(sizeof (deref (typeof' vartypes exp1))))))
+              val tipo = deref (typeof' vartypes exp1)
+              val d =
+                if not (Flag.isset Flags.safe)
+                then asubk
+                else T.COND (T.BINOP
+                              (T.BE,
+                               T.MEMORY (T.BINOP (
+                                 T.SUB,
+                                 trans_exp env vartypes exp1, 
+                                 T.CONST 0w8), Temp.Long),
+                               trans_exp env vartypes exp2),
+                             T.NULLPTR,
+                             asubk)
             in
-              if (AU.Type.issmall (deref (typeof' vartypes exp1)))
-              then T.MEMORY(asubk)
-              else asubk
+              if Type.issmall tipo
+              then T.MEMORY(d, Temp.sts (Type.size tipo))
+              else d
             end
         | trans_exp env vartypes (A.New(tipo)) =
-            T.ALLOC(T.CONST (Word32.fromInt(sizeof_v tipo)))
+            let
+              val t1 = T.TEMP (Temp.new "result" Temp.Quad)
+            in
+              T.STMVAR (
+                [T.MOVE (t1, T.ALLOC (T.CONST (Word32.fromInt(sizeof tipo)))),
+                 T.EFFECT (T.MEMORY (t1, Temp.Long))],
+                t1)
+            end
         | trans_exp env vartypes (A.NewArr(tipo, exp)) =
-            T.ALLOC(T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof_v tipo))))
-        | trans_exp env vartypes (A.Null) = T.CONST(0w0)
+            let
+              val size = T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof tipo)))
+              val t1 = T.TEMP (Temp.new "allocated address" Temp.Quad)
+              val ts = T.TEMP (Temp.new "size" Temp.Long)
+            in
+              if not (Flag.isset Flags.safe)
+              then T.STMVAR ([T.MOVE (t1, T.ALLOC size),
+                              T.EFFECT (T.COND (T.BINOP (T.EQ, trans_exp env vartypes exp, T.CONST 0w0), T.CONST 0w0, T.MEMORY (t1, Temp.Long)))],
+                             t1)
+              else T.COND (T.BINOP(T.EQ, size, T.CONST 0w0),
+                           T.NULLPTR,
+                           T.STMVAR (
+                             [T.MOVE(t1,
+                                T.COND(
+                                  T.BINOP(T.LT, size, T.CONST 0w0),
+                                  T.NULLPTR,
+                                  T.ALLOC (T.BINOP (T.ADD, size, T.CONST 0w8)))
+                                ),
+                              T.MOVE(T.MEMORY (t1, Temp.Long), trans_exp env vartypes exp)],
+                             T.BINOP(T.ADD, t1, T.CONST 0w8)))
+            end
+        | trans_exp env vartypes (A.Null) = T.NULLPTR
+        | trans_exp env vartypes (A.Conditional(c,e1,e2)) = T.COND(trans_exp env vartypes c, trans_exp env vartypes e1, trans_exp env vartypes e2)
 
         (* anything else should be impossible *)
 
@@ -198,23 +191,22 @@ struct
        * we pass around the environment and the current loop context, if any
        * (usually called ls, which contains a continue label and a break label)
        *)
-      fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2, AU.Type.size (typeof' vartypes e2))::(trans_stms vars vartypes ls stms)
+      fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2)::(trans_stms vars vartypes ls stms)
         | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) =
           let
             val te1 = trans_exp vars vartypes e1
             val te2 = trans_exp vars vartypes e2
-            val t1 = T.TEMP (Temp.new "memory deref cache" 8)
-            val size = AU.Type.size (typeof' vartypes e2)
+            val t1 = T.TEMP (Temp.new "memory deref cache" Temp.Quad)
           in
             case te1
-            of T.MEMORY(m) => T.MOVE(t1, m, 8) :: T.MOVE (T.MEMORY(t1), T.BINOP(trans_oper oop, T.MEMORY(t1), te2), size) :: (trans_stms vars vartypes ls stms)
-             | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2), size) :: (trans_stms vars vartypes ls stms)
+            of T.MEMORY(m,s) => T.MOVE(t1, m) :: T.MOVE (T.MEMORY(t1,s), T.BINOP(trans_oper oop, T.MEMORY(t1,s), te2)) :: (trans_stms vars vartypes ls stms)
+             | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2)) :: (trans_stms vars vartypes ls stms)
           end
         | trans_stms vars vartypes ls (A.Return e::stms) =
           let
             val remainder = trans_stms vars vartypes ls stms
           in 
-            T.RETURN (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))
+            T.RETURN (trans_exp vars vartypes e, Temp.sts (Type.size (typeof' vartypes e)))
             :: remainder
           end
         | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) =
@@ -274,7 +266,7 @@ struct
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end
-        | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))) :: (trans_stms vars vartypes ls stms)
+        | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e)) :: (trans_stms vars vartypes ls stms)
         | trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) =
           let
             val remainder = trans_stms vars vartypes (SOME(b,e)) stms
@@ -299,7 +291,7 @@ struct
             let
               val allvars = foldr
                               (fn ((name, t),b) =>
-                                Symbol.bind b (name, Temp.new (Symbol.name(name)) (AU.Type.size t)))
+                                Symbol.bind b (name, Temp.new (Symbol.name(name)) (Temp.sts (Type.size t))))
                               Symbol.empty
                               (args @ vars)
               val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars)
@@ -307,7 +299,7 @@ struct
               val (argn,_) = ListPair.unzip args
               val numberedargs = ListPair.zip (List.tabulate (length argn, fn x => x), argn)
               val argmv = map
-                (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n, Temp.size (Symbol.look' allvars argname)), Temp.size (Symbol.look' allvars argname)))
+                (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n, Temp.size (Symbol.look' allvars argname))))
                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
index d3e8c0d..dbd0efc 100644 (file)
@@ -9,8 +9,7 @@
 
 signature TREE =
 sig
-
-  datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE
+  datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE | BE
   datatype unop = NEG | BITNOT | BANG
 
   type Blarg = int
@@ -18,16 +17,19 @@ sig
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp
-    | ARG of Blarg * int (* I am j4cbo *)
+    | ARG of Blarg * Temp.size (* I am j4cbo *)
     | BINOP of binop * exp * exp
     | UNOP of unop * exp
-    | CALL of Ast.ident * (exp * int) list * int
-    | MEMORY of exp
+    | CALL of Ast.ident * (exp * Temp.size) list * Temp.size
+    | MEMORY of exp * Temp.size
     | ALLOC of exp
+    | COND of exp * exp * exp
+    | STMVAR of stm list * exp
+    | NULLPTR
   and stm =
-      MOVE of exp * exp * int
-    | RETURN of exp * int
-    | EFFECT of exp * int
+      MOVE of exp * exp
+    | RETURN of exp * Temp.size
+    | EFFECT of exp
     | LABEL of Label.label
     | JUMPIFN of exp * Label.label
     | JUMP of Label.label
@@ -35,19 +37,11 @@ sig
       FUNCTION of Ast.ident * stm list
 
   type program = func list
-
-  structure Print :
-  sig
-    val pp_exp : exp -> string
-    val pp_stm : stm -> string
-    val pp_program : program -> string
-  end
 end
 
 structure Tree :> TREE =
 struct
-
-  datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE
+  datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE | BE
   datatype unop = NEG | BITNOT | BANG
 
   type Blarg = int
@@ -55,16 +49,19 @@ struct
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp
-    | ARG of Blarg * int
+    | ARG of Blarg * Temp.size (* I am j4cbo *)
     | BINOP of binop * exp * exp
     | UNOP of unop * exp
-    | CALL of Ast.ident * (exp * int) list * int
-    | MEMORY of exp
+    | CALL of Ast.ident * (exp * Temp.size) list * Temp.size
+    | MEMORY of exp * Temp.size
     | ALLOC of exp
+    | COND of exp * exp * exp
+    | STMVAR of stm list * exp
+    | NULLPTR
   and stm =
-      MOVE of exp * exp * int
-    | RETURN of exp * int
-    | EFFECT of exp * int
+      MOVE of exp * exp
+    | RETURN of exp * Temp.size
+    | EFFECT of exp
     | LABEL of Label.label
     | JUMPIFN of exp * Label.label
     | JUMP of Label.label
@@ -72,65 +69,4 @@ struct
       FUNCTION of Ast.ident * stm list
 
   type program = func list
-
-  structure Print = 
-  struct
-
-    exception Aaaasssssss
-
-    fun pp_binop ADD = "+"
-      | pp_binop SUB = "-"
-      | pp_binop MUL = "*"
-      | pp_binop DIV = "/"
-      | pp_binop MOD = "%"
-      | pp_binop LSH = "<<"
-      | pp_binop RSH = ">>"
-      | pp_binop LOGOR = "||"
-      | pp_binop LOGAND = "&&"
-      | pp_binop BITOR = "|"
-      | pp_binop BITAND = "&"
-      | pp_binop BITXOR = "^"
-      | pp_binop NEQ = "!="
-      | pp_binop EQ = "=="
-      | pp_binop LE = "<="
-      | pp_binop LT = "<"
-      | pp_binop GE = ">="
-      | pp_binop GT = ">"
-    
-    fun pp_unop NEG = "-"
-      | pp_unop BITNOT = "~"
-      | pp_unop BANG = "!"
-
-    fun pp_exp (CONST(x)) = Word32Signed.toString x
-      | pp_exp (TEMP(t)) = Temp.name t
-      | pp_exp (ARG(n, sz)) = "arg#"^Int.toString n
-      | pp_exp (BINOP (binop, e1, e2)) =
-         "(" ^ pp_exp e1 ^ " " ^ pp_binop binop ^ " " ^ pp_exp e2 ^ ")"
-      | pp_exp (UNOP (unop, e1)) =
-          pp_unop unop ^ "(" ^ pp_exp e1 ^ ")"
-      | pp_exp (CALL (f, l, sz)) =
-          Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map (fn (e, _) => pp_exp e) l)) ^ ")"
-      | pp_exp (MEMORY exp) = "M[" ^ pp_exp exp ^ "]"
-      | pp_exp (ALLOC(e)) = "NEW(" ^ pp_exp e ^ ")"
-
-    fun pp_stm (MOVE (e1,e2, sz)) =
-         pp_exp e1 ^ "  <--  " ^ pp_exp e2
-      | pp_stm (RETURN (e, sz)) =
-         "return " ^ pp_exp e
-      | pp_stm (EFFECT (e, sz)) = pp_exp e
-      | pp_stm (LABEL l) =
-          Label.name l ^ ":"
-      | pp_stm (JUMP l) = 
-          "jump "^Label.name l
-      | pp_stm (JUMPIFN (e, l)) =
-          "jump "^Label.name l^" if! "^pp_exp e
-
-    fun pp_program (nil) = ""
-      | pp_program (FUNCTION(id, stms)::funcs) =
-          (Symbol.name id) ^
-          "\n{\n" ^
-          (foldr (fn (a,b) => (pp_stm a) ^ "\n" ^ b) "" stms) ^
-          "}\n" ^
-          pp_program funcs
-  end
 end
diff --git a/trans/treeutils.sml b/trans/treeutils.sml
new file mode 100644 (file)
index 0000000..b5217b0
--- /dev/null
@@ -0,0 +1,104 @@
+signature TREEUTILS =
+sig
+  val effect : Tree.exp -> bool
+  val effect_stm : Tree.stm -> bool
+
+  structure Print :
+  sig
+    val pp_exp : Tree.exp -> string
+    val pp_stm : Tree.stm -> string
+    val pp_program : Tree.program -> string
+  end
+end
+
+structure TreeUtils :> TREEUTILS =
+struct
+  structure T = Tree
+
+  (* effect : T.exp -> bool
+   * true iff the given expression has an effect.
+   *)
+  fun effect (T.CONST _) = false
+    | effect (T.TEMP _) = false
+    | effect (T.ARG _) = false
+    | effect (T.BINOP(T.DIV, _, _)) = true
+    | effect (T.BINOP(T.MOD, _, _)) = true
+    | effect (T.CALL _) = true
+    | effect (T.BINOP(_, a, b)) = (effect a) orelse (effect b)
+    | effect (T.UNOP (_, a)) = effect a
+    | effect (T.MEMORY _) = true
+    | effect (T.ALLOC _) = true
+    | effect (T.COND (a, b, c)) = (effect a) orelse (effect b) orelse (effect c)
+    | effect (T.STMVAR (sl, e)) = true (* Has to be, to be safe <--- jwise is an assclown, he was too lazy to write a effect_stm *)
+    | effect (T.NULLPTR) = false
+
+  fun effect_stm (T.MOVE (e1,e2)) = effect e1 orelse effect e2
+    | effect_stm (T.RETURN (e1,e2)) = effect e1 orelse effect e1
+    | effect_stm (T.EFFECT e) = effect e
+    | effect_stm (T.JUMPIFN (e,_)) = effect e
+    | effect_stm _ = false
+
+  structure Print = 
+  struct
+    exception Aaaasssssss
+
+    fun pp_binop T.ADD = "+"
+      | pp_binop T.SUB = "-"
+      | pp_binop T.MUL = "*"
+      | pp_binop T.DIV = "/"
+      | pp_binop T.MOD = "%"
+      | pp_binop T.LSH = "<<"
+      | pp_binop T.RSH = ">>"
+      | pp_binop T.LOGOR = "||"
+      | pp_binop T.LOGAND = "&&"
+      | pp_binop T.BITOR = "|"
+      | pp_binop T.BITAND = "&"
+      | pp_binop T.BITXOR = "^"
+      | pp_binop T.NEQ = "!="
+      | pp_binop T.EQ = "=="
+      | pp_binop T.LE = "<="
+      | pp_binop T.LT = "<"
+      | pp_binop T.GE = ">="
+      | pp_binop T.GT = ">"
+      | pp_binop T.BE = "[BE]"
+    
+    fun pp_unop T.NEG = "-"
+      | pp_unop T.BITNOT = "~"
+      | pp_unop T.BANG = "!"
+
+    fun pp_exp (T.CONST(x)) = Word32Signed.toString x
+      | pp_exp (T.TEMP(t)) = Temp.name t
+      | pp_exp (T.ARG(n, sz)) = "arg#"^Int.toString n
+      | pp_exp (T.BINOP (binop, e1, e2)) =
+         "(" ^ pp_exp e1 ^ " " ^ pp_binop binop ^ " " ^ pp_exp e2 ^ ")"
+      | pp_exp (T.UNOP (unop, e1)) =
+          pp_unop unop ^ "(" ^ pp_exp e1 ^ ")"
+      | pp_exp (T.CALL (f, l, sz)) =
+          Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map (fn (e, _) => pp_exp e) l)) ^ ")"
+      | pp_exp (T.MEMORY (exp, sz)) = "M(" ^ Temp.sfx sz ^ ")[" ^ pp_exp exp ^ "]"
+      | pp_exp (T.ALLOC(e)) = "NEW(" ^ pp_exp e ^ ")"
+      | pp_exp (T.COND(c,e1,e2)) = "(" ^ pp_exp c ^ ") ? (" ^ pp_exp e1 ^ ") : (" ^ pp_exp e2 ^ ")"
+      | pp_exp (T.STMVAR(sl,v)) = "({" ^ (foldr (fn (st,s) => (pp_stm st) ^ "; " ^ s) "" sl) ^ (pp_exp v) ^ "})"
+      | pp_exp (T.NULLPTR) = "NULL"
+
+    and pp_stm (T.MOVE (e1,e2)) =
+         pp_exp e1 ^ "  <--  " ^ pp_exp e2
+      | pp_stm (T.RETURN (e, sz)) =
+         "return " ^ pp_exp e
+      | pp_stm (T.EFFECT e) = pp_exp e
+      | pp_stm (T.LABEL l) =
+          Label.name l ^ ":"
+      | pp_stm (T.JUMP l) = 
+          "jump "^Label.name l
+      | pp_stm (T.JUMPIFN (e, l)) =
+          "jump "^Label.name l^" if! "^pp_exp e
+
+    fun pp_program (nil) = ""
+      | pp_program (T.FUNCTION(id, stms)::funcs) =
+          (Symbol.name id) ^
+          "\n{\n" ^
+          (foldr (fn (a,b) => (pp_stm a) ^ "\n" ^ b) "" stms) ^
+          "}\n" ^
+          pp_program funcs
+  end
+end
diff --git a/type/type.sml b/type/type.sml
new file mode 100644 (file)
index 0000000..69f35f8
--- /dev/null
@@ -0,0 +1,143 @@
+signature TYPE =
+sig
+  type ident = Symbol.symbol
+  datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull
+  type variable = ident * vtype
+  datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list
+
+  val typeeq : vtype * vtype -> bool
+  val castable : vtype * vtype -> bool
+  val size : vtype -> int
+  val sizeof : typedef Symbol.table -> vtype -> int
+  val sizeof_reset : unit -> unit
+  val alignment : typedef Symbol.table -> vtype -> int
+  val alignment_reset : unit -> unit
+  val align : typedef Symbol.table -> vtype -> int -> int
+  val issmall : vtype -> bool
+  val defdata : typedef -> typedef
+  val defmark : typedef -> Mark.ext option
+
+  structure Print :
+  sig
+    val pp_type : vtype -> string
+    val pp_typedef : (ident * typedef) -> string
+  end
+
+end
+
+structure Type :> TYPE =
+struct
+  type ident = Symbol.symbol
+  datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull
+  type variable = ident * vtype
+  datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list
+
+  fun size (Int) = 4
+    | size (Pointer _) = 8
+    | size (Array _) = 8
+    | size (TNull) = 8
+    | size _ = raise ErrorMsg.InternalError "Type.size on non-small type..."
+
+  (************************************************)
+  (* this is full of shit *************************)
+  (************************************************)
+  local
+    val size_memotable = ref Symbol.empty
+    val align_memotable = ref Symbol.empty
+  in
+    (* determine size of items *)
+    fun sizeof_reset () = ( size_memotable := Symbol.empty )
+    fun alignment_reset () = ( align_memotable := Symbol.empty )
+    fun sizeof _ (Int) = 4
+      | sizeof _ (Pointer _) = 8
+      | sizeof _ (Array _) = 8
+      | sizeof _ (TNull) = raise ErrorMsg.InternalError "Type.sizeof on TNull?"
+      | sizeof d (Typedef id) =
+          (case (Symbol.look (!size_memotable) id)
+          of SOME(r) => r
+           | NONE =>
+             let
+               val r = sizeof_s d (Symbol.look' d id)
+               val _ = (size_memotable := (Symbol.bind (!size_memotable) (id, r)))
+             in
+               r
+             end)
+    and sizeof_s d (Struct(l)) =
+          foldl
+            (fn ((_,t),curpos) => align d t curpos + sizeof d t)
+            0
+            l
+      | sizeof_s d (MarkedTypedef(a)) = sizeof_s d (Mark.data a)
+
+    (* determine alignment of items *)
+    and alignment _ (Int) = 4
+      | alignment _ (Pointer _) = 8
+      | alignment _ (Array _) = 8
+      | alignment d (Typedef id) =
+          (case Symbol.look (!align_memotable) id
+          of SOME(r) => r
+           | NONE =>
+             let
+               val r = alignment_s d (Symbol.look' d id)
+               val _ = (align_memotable := (Symbol.bind (!align_memotable) (id,r)))
+             in
+               r
+             end)
+      | alignment _ (TNull) = raise ErrorMsg.InternalError "Type.alignment on TNull?"
+    and alignment_s d (Struct(members)) =
+          foldl
+            (fn ((_,t),al) => Int.max (al, alignment d t))
+            1
+            members
+      | alignment_s d (MarkedTypedef(a)) = alignment_s d (Mark.data a)
+    and align d t curpos = 
+      let
+        val al = alignment d t
+      in
+        if(curpos mod al) = 0 then curpos
+        else curpos + al - (curpos mod al)
+      end
+  end
+  (************************************************)
+  (* end of shit **********************************)
+  (************************************************)
+
+
+  fun issmall (Int) = true
+    | issmall (Pointer _) = true
+    | issmall (Array _) = true
+    | issmall (TNull) = true
+    | issmall _ = false
+
+  fun typeeq (Int, Int) = true
+    | typeeq (Typedef a, Typedef b) = (Symbol.name a) = (Symbol.name b)
+    | typeeq (Pointer a, Pointer b) = typeeq (a, b)
+    | typeeq (Array a, Array b) = typeeq (a, b)
+    | typeeq (TNull, TNull) = true
+    | typeeq _ = false
+
+  fun castable (Pointer _, TNull) = true
+    | castable (Array _, TNull) = true
+    | castable (a, b) = typeeq (a, b)
+
+  fun defdata (MarkedTypedef m) = defdata (Mark.data m)
+    | defdata m = m
+
+  fun defmark (MarkedTypedef m) = Mark.ext m
+    | defmark _ = NONE
+
+  structure Print =
+  struct
+    fun pp_ident i = Symbol.name i
+
+    fun pp_type (Int) = "int"
+      | pp_type (Pointer t) = pp_type t ^ "*"
+      | pp_type (Array t) = pp_type t ^ "[]"
+      | pp_type (TNull) = "{NULL type}"
+      | pp_type (Typedef id) = pp_ident id
+
+    and pp_typedef (i, Struct (v)) = "struct " ^ (pp_ident i) ^ " {\n" ^ (String.concat (map (fn (i', t) => "  " ^ (pp_ident i') ^ " : " ^ (pp_type t) ^ ";\n") v)) ^ "}\n"
+      | pp_typedef (i, MarkedTypedef d) = pp_typedef (i, Mark.data d)
+  end
+
+end
index 35d2859..06c6d89 100644 (file)
@@ -10,36 +10,37 @@ signature TYPE_CHECK =
 sig
   (* prints error message and raises ErrorMsg.error if error found *)
   val typecheck : Ast.program -> Ast.program
-  val typeof : Ast.program -> Ast.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Ast.vtype
+  val typeof : Ast.program -> Type.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Type.vtype
 end;
 
 structure TypeChecker :> TYPE_CHECK = 
 struct
   structure A = Ast
   structure AU = AstUtils
+  structure T = Type
   
   fun typeof (tds, funcs) vars mark e =
     ( case e
       of A.Var a => (case Symbol.look vars a
                      of NONE => (ErrorMsg.error mark ("variable `"^(Symbol.name a)^"' not declared here") ; raise ErrorMsg.Error)
                       | SOME t => t)
-       | A.ConstExp _ => A.Int
+       | A.ConstExp _ => T.Int
        | A.OpExp (A.EQ, [a, b]) =>
            (case (typeof (tds, funcs) vars mark a, typeof (tds, funcs) vars mark b)
-            of (A.Int, A.Int) => A.Int (* You shall pass! *)
+            of (T.Int, T.Int) => T.Int (* You shall pass! *)
              | (a', b') =>
-                 if (A.typeeq (a', A.TNull) andalso A.castable (b', A.TNull)) orelse
-                    (A.typeeq (b', A.TNull) andalso A.castable (a', A.TNull)) orelse
-                    (A.typeeq (a', b'))
-                 then A.Int
-                 else (ErrorMsg.error mark ("incorrect types for equality opexp: " ^ A.Print.pp_type a' ^ ", " ^ A.Print.pp_type b') ; raise ErrorMsg.Error ))
+                 if (T.typeeq (a', T.TNull) andalso T.castable (b', T.TNull)) orelse
+                    (T.typeeq (b', T.TNull) andalso T.castable (a', T.TNull)) orelse
+                    (T.typeeq (a', b'))
+                 then T.Int
+                 else (ErrorMsg.error mark ("incorrect types for equality opexp:" ^ T.Print.pp_type a' ^ ", " ^ T.Print.pp_type b') ; raise ErrorMsg.Error ))
        | A.OpExp (A.NEQ, el) => typeof (tds, funcs) vars mark (A.OpExp (A.EQ, el))
        | A.OpExp (_, el) => (List.app
                               (fn e =>
                                 (case (typeof (tds, funcs) vars mark e)
-                                 of A.Int => ()
+                                 of T.Int => ()
                                   | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error)))
-                              el ; A.Int)
+                              el ; T.Int)
        | A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e)
        | A.FuncCall (i, exps) =>
          let
@@ -53,7 +54,7 @@ struct
                     else (ErrorMsg.error mark ("call to function `"^(Symbol.name i)^"' has incorrect parameter count [you must construct additional tycons]") ; raise ErrorMsg.Error)
            val () = List.app
                       (fn (t, (i, t')) =>
-                        if not (A.castable (t', t))
+                        if not (T.castable (t', t))
                         then (ErrorMsg.error mark ("parameter `"^(Symbol.name i)^"' in function call has wrong type [you must construct additional tycons]") ; raise ErrorMsg.Error)
                         else ())
                       (ListPair.zip (exptypes, fparams))
@@ -64,14 +65,14 @@ struct
          let
            val t = typeof (tds, funcs) vars mark e
            val name = case t
-                      of (A.Typedef i) => i
+                      of (T.Typedef i) => i
                        | _ => (ErrorMsg.error mark ("member operation only exists for struct types") ; raise ErrorMsg.Error)
            val s = case Symbol.look tds name
                    of SOME s => s
                     | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
-           val (s, smark) = (AU.Typedef.data s, AU.Typedef.mark s)
+           val (s, smark) = (T.defdata s, T.defmark s)
            val vl = case s
-                    of A.Struct vl => vl
+                    of T.Struct vl => vl
                      | _ => raise ErrorMsg.InternalError "mark of marked typedef?"
            val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl)
                    of SOME (_, t) => t
@@ -83,16 +84,16 @@ struct
          let
            val t = typeof (tds, funcs) vars mark e
            val name = case t
-                      of (A.Pointer (A.Typedef i)) => i
+                      of (T.Pointer (T.Typedef i)) => i
                        | _ => (ErrorMsg.error mark ("dereference and member operation only exists for struct pointer types") ; raise ErrorMsg.Error)
            val s = case Symbol.look tds name
                    of SOME s => s
                     | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
            val (s, smark) = case s
-                            of A.Struct vl => (s, NONE)
-                             | A.MarkedTypedef m => (Mark.data m, Mark.ext m)
+                            of T.Struct vl => (s, NONE)
+                             | T.MarkedTypedef m => (Mark.data m, Mark.ext m)
            val vl = case s
-                    of A.Struct vl => vl
+                    of T.Struct vl => vl
                      | _ => raise ErrorMsg.InternalError "mark of marked typedef?"
            val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl)
                    of SOME (_, t) => t
@@ -102,19 +103,33 @@ struct
          end
        | A.Dereference e =>
          (case typeof (tds, funcs) vars mark e
-          of (A.Pointer e') => e'
+          of (T.Pointer e') => e'
            | _ => (ErrorMsg.error mark ("cannot deference non-pointer type") ; raise ErrorMsg.Error))
        | A.ArrIndex (e, i) =>
          (case (typeof (tds, funcs) vars mark e, typeof (tds, funcs) vars mark i)
-          of (A.Array e', A.Int) => e'
-           | (_, A.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error)
+          of (T.Array e', T.Int) => e'
+           | (_, T.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error)
            | _ => (ErrorMsg.error mark ("cannot index using non-int type") ; raise ErrorMsg.Error))
-       | A.New (t) => A.Pointer t
+       | A.New (t) => T.Pointer t
        | A.NewArr (t, s) =>
          (case typeof (tds, funcs) vars mark s
-          of A.Int => (A.Array t)
+          of T.Int => (T.Array t)
            | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error))
-       | A.Null => A.TNull
+       | A.Null => T.TNull
+       | A.Conditional (q, e1, e2) =>
+         let
+           val _ = case typeof (tds, funcs) vars mark q
+                   of T.Int => ()
+                    | _ => (ErrorMsg.error mark ("ternary condition not of Int type") ; raise ErrorMsg.Error)
+           val t1 = typeof (tds, funcs) vars mark e1
+           val t2 = typeof (tds, funcs) vars mark e2
+         in
+           if (T.typeeq (t1, t2) orelse T.castable (t1, t2))
+           then t1
+           else if (T.castable (t2, t1))
+           then t2
+           else (ErrorMsg.error mark ("ternary types do not agree [you must construct additional tycons]") ; raise ErrorMsg.Error)
+         end
     )
   
   datatype asn = ASSIGNED | UNASSIGNED
@@ -131,7 +146,7 @@ struct
         | returns' (A.AsnOp _ :: stms) = returns' stms
         | returns' (A.Effect _ :: stms) = returns' stms
         | returns' (A.Return e :: stms) =
-            if (A.castable (t, typeof prog vars mark e))
+            if (T.castable (t, typeof prog vars mark e))
             then true
             else (ErrorMsg.error mark ("return value of incorrect type for function") ; raise ErrorMsg.Error)
         | returns' (A.Nop :: stms) = returns' stms
@@ -202,6 +217,7 @@ struct
     | varcheck_exp env (A.New _) mark = ()
     | varcheck_exp env (A.NewArr (_, e)) mark = varcheck_exp env e mark
     | varcheck_exp env (A.Null) mark = ()
+    | varcheck_exp env (A.Conditional (q, e1, e2)) mark = (varcheck_exp env q mark ; varcheck_exp env e1 mark ; varcheck_exp env e2 mark)
   
   (* computeassigns env exp
    * Computes the assigned variables after expression exp has been executed with a starting context of env.
@@ -285,7 +301,7 @@ struct
          varcheck_exp env e mark ;
          a :: varcheck env stms mark)
     | varcheck env ((A.Assign _) :: stms) mark = raise ErrorMsg.InternalError "assign to non lvalue"
-    | varcheck env ((a as A.AsnOp (oper, e1, e2)) :: stms) mark = ( varcheck env [(A.Assign (e1, A.OpExp (oper, [e1, e2])))] ; a :: varcheck env stms mark)
+    | varcheck env ((a as A.AsnOp (oper, e1, e2)) :: stms) mark = ( varcheck_exp env e1 mark ; varcheck_exp env e2 mark ; a :: varcheck env stms mark )
     | varcheck env ((a as A.Effect e) :: stms) mark = (varcheck_exp env e mark ; a :: varcheck env stms mark)
     | varcheck env (A.Return (e) :: stms) mark =
         ( varcheck_exp env e mark;
@@ -320,7 +336,7 @@ struct
           val env' = case sbegin
                      of SOME(s) => computeassigns env [s]
                       | NONE => env
-          val _ = varcheck_exp env' e
+          val _ = varcheck_exp env' e mark
           val inner = varcheck env' inner mark
           val env'' = computeassigns env' inner
           val sloop = case sloop
@@ -358,14 +374,14 @@ struct
   fun typecheck_stm prog vars mark stm =
     case stm
     of A.Assign (e1, e2) =>
-         if not (A.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2))
+         if not (T.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2))
          then (ErrorMsg.error mark "incompatible types in assignment" ; raise ErrorMsg.Error )
-         else if not (AU.Type.issmall (check_lvalue prog vars mark e1))
+         else if not (T.issmall (check_lvalue prog vars mark e1))
          then (ErrorMsg.error mark "lvalue is not small" ; raise ErrorMsg.Error)
          else ()
      | A.AsnOp (oper, e1, e2) => typecheck_stm prog vars mark (A.Assign (e1, A.OpExp (oper, [e1, e2])))
      | A.Effect e => 
-         if not (AU.Type.issmall (typeof prog vars mark e))
+         if not (T.issmall (typeof prog vars mark e))
          then (ErrorMsg.error mark "simple statement's value not small" ; raise ErrorMsg.Error )
          else ()
      | A.Return e => (typeof prog vars mark e ; ())
@@ -373,36 +389,36 @@ struct
      | A.Break => ()
      | A.Continue => ()
      | A.If (e, s, NONE) =>
-         if A.castable (A.Int, typeof prog vars mark e)
+         if T.castable (T.Int, typeof prog vars mark e)
          then (List.app (typecheck_stm prog vars mark) s)
          else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error )
      | A.If (e, s1, SOME s2) =>
-         if A.castable (A.Int, typeof prog vars mark e)
+         if T.castable (T.Int, typeof prog vars mark e)
          then (List.app (typecheck_stm prog vars mark) s1 ; List.app (typecheck_stm prog vars mark) s2)
          else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error )
      | A.For (sbegin, e, sloop, s) =>
-         if A.castable (A.Int, typeof prog vars mark e)
+         if T.castable (T.Int, typeof prog vars mark e)
          then (List.app (typecheck_stm prog vars mark) ((case sbegin of SOME l => [l] | NONE => nil) @ (case sloop of SOME l => [l] | NONE => nil) @ s))
          else (ErrorMsg.error mark "conditional in for statement is not of int type" ; raise ErrorMsg.Error )
      | A.While (e, s) =>
-         if A.castable (A.Int, typeof prog vars mark e)
+         if T.castable (T.Int, typeof prog vars mark e)
          then (List.app (typecheck_stm prog vars mark) s)
          else (ErrorMsg.error mark "conditional in while statement is not of int type" ; raise ErrorMsg.Error )
      | A.MarkedStm (m) => typecheck_stm prog vars (Mark.ext m) (Mark.data m)
         
   (* XXX does not check big vs. small types *)
-  fun typecheck_type (tds, funcs) mark A.Int = ()
-    | typecheck_type (tds, funcs) mark A.TNull = ()
-    | typecheck_type (tds, funcs) mark (A.Pointer t) = typecheck_type (tds, funcs) mark t
-    | typecheck_type (tds, funcs) mark (A.Array t) = typecheck_type (tds, funcs) mark t
-    | typecheck_type (tds, funcs) mark (A.Typedef t) =
+  fun typecheck_type (tds, funcs) mark T.Int = ()
+    | typecheck_type (tds, funcs) mark T.TNull = ()
+    | typecheck_type (tds, funcs) mark (T.Pointer t) = typecheck_type (tds, funcs) mark t
+    | typecheck_type (tds, funcs) mark (T.Array t) = typecheck_type (tds, funcs) mark t
+    | typecheck_type (tds, funcs) mark (T.Typedef t) =
         case (Symbol.look tds t)
         of SOME _ => ()
          | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name t)^"' does not exist") ; raise ErrorMsg.Error)
 
   fun typecheck_fn prog _ (id, A.MarkedFunction m) = typecheck_fn prog (Mark.ext m) (id, Mark.data m)
     | typecheck_fn (prog as (tds, funcs)) mark (id, A.Extern (t, al)) =
-      (if (String.isPrefix "_l4_" (Symbol.name id))
+      (if (String.isPrefix "_l5_" (Symbol.name id))
        then
          let
            val n = String.extract (Symbol.name id, 4, NONE)
@@ -432,7 +448,7 @@ struct
                  else ()
         val () = List.app (
                   fn (n, t) =>
-                    if (AU.Type.issmall t)
+                    if (T.issmall t)
                     then ()
                     else ( ErrorMsg.error mark ("variable `"^(Symbol.name n)^"' in function `"^(Symbol.name id)^"' not small") ; raise ErrorMsg.Error))
                  (al @ vl)
@@ -458,11 +474,11 @@ struct
           val s = case Symbol.look tds sym
                   of SOME a => a
                    | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name sym)^"' does not exist") ; raise ErrorMsg.Error)
-          val vl = case AU.Typedef.data s
-                   of A.Struct vl => vl
-                    | A.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type"
+          val vl = case T.defdata s
+                   of T.Struct vl => vl
+                    | T.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type"
         in
-          (vl, AU.Typedef.mark s)
+          (vl, T.defmark s)
         end
       fun checksym mark sym stack k remaining =
         if not (SymbolSet.member (remaining, sym))
@@ -477,7 +493,7 @@ struct
             fun remove k remaining' = k (SymbolSet.delete (remaining', sym))
             val newk = (* OH GOD D: *)
               foldr
-                (fn ((_, A.Typedef s), k') => checksym mark' s stack' k'
+                (fn ((_, T.Typedef s), k') => checksym mark' s stack' k'
                   | (_, k') => k')
                 (remove k)
                 vl
@@ -502,8 +518,8 @@ struct
         val () = case main
                  of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern");
                                     raise ErrorMsg.Error )
-                  | A.Function (A.Int, nil, _, _) => ()
-                  | A.Function (A.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters");
+                  | A.Function (T.Int, nil, _, _) => ()
+                  | A.Function (T.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters");
                                                         raise ErrorMsg.Error )
                   | A.Function (_, _, _, _) => ( ErrorMsg.error mainp ("main has incorrect return type");
                                                  raise ErrorMsg.Error )
diff --git a/util/graph.sml b/util/graph.sml
deleted file mode 100644 (file)
index 502cd7c..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-signature GRAPH =
-sig
-  type node
-  type graph
-  val addnode : graph -> node -> node list -> graph
-  val addedge : graph -> node -> node -> graph
-  val isdag : graph -> node -> bool
-end
-
-functor Graph (structure Node : ORD_KEY) :> GRAPH where type node = Node.key =
-struct
-  structure Map = SplayMapFn(Node)
-  structure Set = HashSetFn(Node)
-  type node = Node.key
-  type graph = (Set.set) Map.map
-
-  (* val addnode : graph -> node -> node list -> graph
-   * adds a node given its links (directed)
-   *)
-  fun addnode g n nl =
-    case Map.find (g,n)
-      of SOME(ns) => Map.insert (g, n, Set.addList (ns, nl))
-       | NONE => Map.insert (g, n, Set.addList (Set.empty, nl))
-
-  fun addedge g n1 n2 =
-    let
-      val set1 = case Map.find (g,n1) of SOME(a) => a | NONE => Set.empty
-      val set2 = case Map.find (g,n2) of SOME(a) => a | NONE => Set.empty
-    in
-      Map.insert (Map.insert (g, n2, set2), n1, Set.add (set1, n2))
-    end
-
-  fun isdag g n =
-    let
-      val nn = Set.numItems (case Map.find (g,n) of SOME(a) => a | NONE => Set.empty)
-      
-    in
-    end
-
-end
index d830c9d..c25c285 100644 (file)
 
 signature WORD32_SIGNED =
 sig
+
   val TMAX : Word32.word       (* largest signed positive word, 2^31-1  *)
   val TMIN : Word32.word       (* smallest signed negative word -2^31 *)
   val ZERO : Word32.word       (* 0 *)
   val fromString : string -> Word32.word option        (* parse from string, no sign *)
                                (* raises Overflow if not 0 <= n < 2^32 *)
   val toString : Word32.word -> string (* print to string, with sign *)
+  val abs : Word32.word -> Word32.word
+  val adiv : Word32.word * Word32.word -> Word32.word
+  val amod : Word32.word * Word32.word -> Word32.word
+  val lt : Word32.word * Word32.word -> bool
+  val gt : Word32.word * Word32.word -> bool
+  val le : Word32.word * Word32.word -> bool
+  val ge : Word32.word * Word32.word -> bool
 end
 
 structure Word32Signed :> WORD32_SIGNED =
 struct
+
   val TMIN = Word32.<<(Word32.fromInt(1), Word.fromInt(Word32.wordSize-1))
   val TMAX = Word32.-(TMIN, Word32.fromInt(1))
   val ZERO = Word32.fromInt(0)
@@ -36,6 +45,22 @@ struct
 
   fun toString (w) =
       if neg w
-        then "-" ^ Word32.fmt StringCvt.DEC (Word32.~(w))
-      else Word32.fmt StringCvt.DEC w
+        then "-0x" ^ Word32.fmt StringCvt.HEX (Word32.~(w))
+      else "0x" ^ Word32.fmt StringCvt.HEX w
+
+  fun toInt32 w = Int32.fromLarge (Word32.toLargeInt w)
+  fun fromInt32 i = Word32.fromLargeInt (Int32.toLarge i)
+
+  fun abs w = if neg w then Word32.~ (w) else w
+  fun adiv (a,b) = fromInt32 (Int32.div (toInt32 a, toInt32 b))
+  fun amod (a,b) = fromInt32 (Int32.mod (toInt32 a, if neg a andalso neg b then toInt32 b
+                                                    else if neg b then toInt32 (abs b)
+                                                    else if neg a then toInt32 (Word32.~ b)
+                                                    else toInt32 b))
+
+  fun lt (a,b) = Int32.compare (toInt32 a, toInt32 b) = LESS
+  fun gt (a,b) = Int32.compare (toInt32 a, toInt32 b) = GREATER
+  fun le (a,b) = case Int32.compare (toInt32 a, toInt32 b) of LESS => true | EQUAL => true | _ => false
+  fun ge (a,b) = case Int32.compare (toInt32 a, toInt32 b) of GREATER => true | EQUAL => true | _ => false
+
 end
This page took 0.670884 seconds and 4 git commands to generate.