Initial import of l5c

diff --git a/Makefile b/Makefile
index 2cb435220eec662f6c700d874462a3dda53b69bc..2ae3db6938a19abcaf41c14cba4be0e72ba0d06b 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,14 +1,14 @@
 # the following are SML-NJ specific defines
 SML = sml
 
 # 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.*
 
 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}
 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
 
 
 TAGS: clean

diff --git a/README b/README
index ccc758154db0789c17f38c99c62f86cafa06ca7b..3c068e38cb2c17c4a7665ddfc14d2812bfe38308 100644 (file)
--- a/README
+++ b/README
@@ -1,64 +1,69 @@
 README
 ------
 
 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.
 
 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 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 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.
 
 
   * 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
 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 $*

diff --git a/codegen/codegen.sml b/codegen/codegen.sml
index 6ee8c2f38a373503ab8b0e5bf74192b7194268aa..18ac4af84e7a7f859412ae9f9acba524b895809d 100644 (file)
--- a/codegen/codegen.sml
+++ b/codegen/codegen.sml
@@ -12,22 +12,12 @@ end
 structure Codegen :> CODEGEN = 
 struct
   structure T = Tree
 structure Codegen :> CODEGEN = 
 struct
   structure T = Tree

+  structure TU = TreeUtils

   structure X = x86
   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
 
   (* 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
    *)
   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.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
 
     | 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)
    *)
   (* 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)
         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 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
 
           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
             (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)
             (fn (t,(exp,_)) => munch_exp (X.TEMP t) exp)

-            (ListPair.zip (temps, l_hf))
+            (ListPair.zip (temps, l_hf)))

           val argpushes = List.map
           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))
             (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
         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
         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
     | 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
         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
         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
         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
         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
         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
         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
         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
         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
         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
         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
         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
         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
         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
         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
     | 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
           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
         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
           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
         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
     | 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
         end

-    | munch_exp d (T.MEMORY e1) =
+    | munch_exp d (T.ALLOC(exp)) =
+        

         let
         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
         in

-          munch_exp a e1 @ [X.MOV (d, X.REL (a, X.CONST 0w0))]
+          (einsn @ insns, Tm.Quad)

         end
         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
 
   (* 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
         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
     | 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
           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) @
           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)
                 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
         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
           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) @
           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)
                 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
         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
       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.
    *)
       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
       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
       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 *)
       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
         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
         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
         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
         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
         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.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
 
   fun codegen nil = nil
     | codegen (stm::stms) = munch_stm stm @ codegen stms

diff --git a/codegen/coloring.sml b/codegen/coloring.sml
index 1e08e1d7d6863fb9359eb60cd5126cb60c309610..fc5fdf7b40c155fb4ea77b514f931ffecd4a2459 100644 (file)
--- a/codegen/coloring.sml
+++ b/codegen/coloring.sml
@@ -8,7 +8,7 @@
 signature COLORIZER =
 sig
   structure OperSet : ORD_SET
 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
   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
           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 =
           fixeds)
       (* Greedy-colorize -- pick the lowest number that isn't used by a neighbor *)
       fun greedy i l =

diff --git a/codegen/colororder.sml b/codegen/colororder.sml
index 0f25863957933eeeace36c2d402fa82c31ef656e..16dd163067d0c600a8d8c0e544e3c27ee097c01d 100644 (file)
--- a/codegen/colororder.sml
+++ b/codegen/colororder.sml
@@ -7,7 +7,7 @@
 signature COLORORDER =
 sig
   structure OperSet : ORD_SET
 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
   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
       
     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
       (* 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))))
           val neighbors =                      (* Grab all the neighbors for some given temp. *)
             (OperSet.listItems
               (valOf (TempMap.find (graph, chosen))))

diff --git a/codegen/igraph.sml b/codegen/igraph.sml
index 30b17eee61acdde8942671491542182cb7e17200..7e71043bd27adeb2369f7f79ee58bcd3875fde06 100644 (file)
--- a/codegen/igraph.sml
+++ b/codegen/igraph.sml
@@ -7,7 +7,7 @@
 signature IGRAPH =
 sig
   structure OperSet : ORD_SET
 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
   structure LiveMap : ORD_MAP
     where type Key.ord_key = int
   structure TempMap : ORD_MAP

diff --git a/codegen/liveness.sml b/codegen/liveness.sml
index 4c8e4ad3fa868b45d00fc179e076b25198be7de7..b030f9426e98a8c2ad6353a6a908fb458c0418c9 100644 (file)
--- a/codegen/liveness.sml
+++ b/codegen/liveness.sml
@@ -7,22 +7,22 @@
 signature LIVENESS =
 sig
   structure OperSet : ORD_SET
 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;
   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
   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
 
   
   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 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
   val ismove : pred list -> bool
 
   val liveness : pseudoasm -> predicates * livenesses


@@ -37,6 +37,10 @@ struct
   
   structure OperSet = x86.OperSet
   structure LiveMap = x86.LiveMap
   
   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
 
   type live = int * OperSet.set
   type pseudoasm = X.insn list


@@ -44,8 +48,8 @@ struct
   type livenesses = OperSet.set LiveMap.map
 
   type ident = int
   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
   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
    *)
   (* val defusesucc : numasm -> (ident * pred list) list
    * generates def/use/succ predicates according to rules
    *)

-

   fun defusesucc l =
     let
   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 *)
       (* 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
     
         | 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
         | 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.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)])
         | 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.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)),
         | 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)])
         | 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
       (* 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
 
         | isndef x (a::l') = isndef x l'
         | isndef x nil = true
 


@@ -241,8 +246,8 @@ struct
       else liveiter newl preds
     end
 
       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"
 
     | dustostring (SUCC(a)) = "SUCC(" ^ Int.toString a ^ ")"
     | dustostring ISMOVE = "ISMOVE"
 


@@ -269,7 +274,7 @@ struct
   
   fun prettyprint (set) =
     OperSet.foldr
   
   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
       
       "-\n"
       set
       

diff --git a/codegen/peephole.sml b/codegen/peephole.sml
deleted file mode 100644 (file)
index 7bf55a1..0000000
--- a/codegen/peephole.sml
+++ /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

diff --git a/codegen/solidify.sml b/codegen/solidify.sml
index 21b37bceccae003162161409f75a1bfa92fc1646..07ae420b950703bc33226a307bcc46a6f09ff9f4 100644 (file)
--- a/codegen/solidify.sml
+++ b/codegen/solidify.sml
@@ -22,7 +22,13 @@ struct
   type asm = x86.insn list
   
   exception Spilled
   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 *)
   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
 
           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!")
       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. *)
 
       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
         | isspilled _ = false

+

       val stacksz = (nspilled + nsave) * 8
       fun stackpos (reg: int) = stacksz - (reg - maxreg + nsave) * 8    (* Stack position of some register number *)
 
       val prologue =
       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) =>
         (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) =>
           (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)) @
           (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()
 
       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
 
         | 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
               ([],
             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]
         | 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
         | 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
             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
               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
             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
               else
                 insns1 @ insns2 @ [X.LEA (realop1, realop2)]
             end


@@ -163,30 +187,30 @@ struct
             let
               val (insns, realop) = ophit dest
             in
             let
               val (insns, realop) = ophit dest
             in

-              unspill X.Long (src, spillreg2) @ insns @
+              unspill (src, spillreg2) @ insns @

               [ X.SUB(realop,
               [ 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)) =
             end
         | transform (X.IMUL (dest, src)) =

-            unspill X.Long (dest, spillreg1) @
+            unspill (dest, spillreg1) @

             [ X.IMUL(
             [ 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)] @
                 realoper src handle Spilled => stackoper src)] @

-            spill X.Long (dest, spillreg1)
+            spill (dest, spillreg1)

         | transform (X.IMUL3 (dest, src, const)) =
         | transform (X.IMUL3 (dest, src, const)) =

-            unspill X.Long ((X.stripsize src), spillreg2) @
+            unspill (src, spillreg2) @

             [ X.IMUL3(
             [ 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)] @
                 const)] @

-            spill X.Long (dest, spillreg1)
+            spill (dest, spillreg1)

         | transform (X.ADD (dest, src)) =
             let
               val (insns, realop) = ophit dest
             in
         | 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,
               [ 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)]
             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)) =
                 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,
             [ 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)) =
         | transform (X.OR (dest, src)) =

-            unspill X.Long (src, spillreg1) @
+            unspill (src, spillreg1) @

             [ X.OR(
                 realoper dest handle Spilled => stackoper dest,
             [ 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)) =
         | transform (X.XOR (dest, src)) =

-            unspill X.Long (src, spillreg1) @
+            unspill (src, spillreg1) @

             [ X.XOR(
                 realoper dest handle Spilled => stackoper dest,
             [ 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)) =
         | 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)) =
         | transform (X.TEST (op1, op2)) =

-            unspill X.Long (op2, spillreg1) @
+            unspill (op2, spillreg1) @

             [ X.TEST(
                 realoper op1 handle Spilled => stackoper op1,
             [ 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.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(
         | 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)]
                 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 (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))
     in
       if (nsave < 2) then
         List.concat (prologue :: (map transform instrs))

diff --git a/codegen/stringifier.sml b/codegen/stringifier.sml
index 5010d7bc048d0b806491b2bec9dafb2092f79047..7ab1e896067557c65a0a10c6eee3b76955fe0a03 100644 (file)
--- a/codegen/stringifier.sml
+++ b/codegen/stringifier.sml
@@ -18,10 +18,10 @@ struct
   (* val stringify : asm -> string
    * turns a x86 instruction list into a string of assembly code for these instructions *)
 
   (* 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 *)
 
   (* 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
 
 end

diff --git a/codegen/x86.sml b/codegen/x86.sml
index e54d4beb2b0ec77085398cf5368e31670df14413..c0ff0b8a9ec8fdbafa692d5127c3d203b2fe7c1f 100644 (file)
--- a/codegen/x86.sml
+++ b/codegen/x86.sml
@@ -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 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 |
   (* 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 |
     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 |
     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 |
     JMP of Label.label |
     Jcc of cc * Label.label |
     CALL of Symbol.symbol * int |


@@ -42,41 +48,48 @@ sig
     CLTD |
     LIVEIGN of insn |
     RET
     CLTD |
     LIVEIGN of insn |
     RET

-  
+

   structure OperSet : ORD_SET
   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;
   
   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 cmpoper : oper * oper -> order

+  val cmpbasic : basicop * basicop -> order

   val opereq : oper * oper -> bool
   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 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
 
 end
 
 structure x86 :> X86 =
 struct
 

-

   datatype reg =
     EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D
   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 |
   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 |
     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 |
     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 |
     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
       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"
     end
 
   fun ccname E  = "e"


@@ -139,6 +153,10 @@ struct
     | ccname LE = "le"
     | ccname G  = "g"
     | ccname L  = "l"
     | 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
 
   (* 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 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) *)
     | regtonum RSP = 15
 
   (* gives reg associated with number (color) *)


@@ -169,45 +187,54 @@ struct
     | numtoreg 7 = R10D
     | numtoreg 8 = R11D
     | numtoreg 9 = EBX
     | 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)
 
   (* 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)
    *)
 
   (* 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
         in

-          if (order1 = EQUAL) then order2
-          else order1
+          if (o1 = EQUAL) then orderm
+          else o1

         end
         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
   structure OperSet = ListSetFn (
     struct

-      type ord_key = oper
-      val compare = cmpoper
+      type ord_key = basicop
+      val compare = cmpbasic

     end)
   
   structure LiveMap = SplayMapFn(struct
     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 ((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 ((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)
 
     | 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
 end

diff --git a/compile-l4c.sml b/compile-l5c.sml
similarity index 72%
rename from compile-l4c.sml
rename to compile-l5c.sml
index 7299ee821db62b075a9b082a3613a2a3cdd58de7..f5af6ede4772097d874cb63f7350243caf6846f4 100644 (file)
--- a/compile-l4c.sml
+++ b/compile-l5c.sml
@@ -4,4 +4,4 @@
  *)
 
 CM.make "sources.cm";
  *)
 
 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
+++ b/optimize/constfold.sml
@@ -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
+++ b/optimize/feckful.sml
@@ -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
+++ b/optimize/labelcoalescing.sml
@@ -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
+++ b/optimize/optimizer.sml
@@ -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
+++ b/optimize/peephole.sml
@@ -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
+++ b/optimize/stupidfunc.sml
@@ -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

diff --git a/parse/ast.sml b/parse/ast.sml
index 84b2356b74c146f728a598769b02264092c17176..75f704243da867828b4a8ab0e70baec7336d3356 100644 (file)
--- a/parse/ast.sml
+++ b/parse/ast.sml
@@ -13,13 +13,6 @@ signature AST =
 sig
   type ident = Symbol.symbol
   
 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
   datatype oper = 
      PLUS
    | MINUS


@@ -53,9 +46,10 @@ sig
    | DerefMember of exp * ident
    | Dereference of exp
    | ArrIndex of exp * exp
    | 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
    | Null

+   | Conditional of exp * exp * exp

   and stm =
      Assign of exp * exp
    | AsnOp of oper * 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 =
    | 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
   
    | 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
 
   (* 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
     val pp_stm : stm -> string
     val pp_program : program -> string
   end


@@ -90,20 +83,6 @@ structure Ast :> AST =
 struct
   type ident = Symbol.symbol
 
 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
   datatype oper = 
      PLUS
    | MINUS


@@ -137,9 +116,10 @@ struct
    | DerefMember of exp * ident
    | Dereference of exp
    | ArrIndex of exp * exp
    | 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
    | Null

+   | Conditional of exp * exp * exp

   and stm =
      Assign of exp * exp
    | AsnOp of oper * 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 =
    | 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
   
    | 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
 
   (* 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 (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 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))
     
     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_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 = ""
     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 = ""
     
     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)
       | 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
   end
 end

diff --git a/parse/astutils.sml b/parse/astutils.sml
index 72bdaeb71b2d68e0875477a4b0c3894e7241feae..7031e67593face5fe3cb5d9a8571b38eed25defd 100644 (file)
--- a/parse/astutils.sml
+++ b/parse/astutils.sml
@@ -2,33 +2,22 @@ signature ASTUTILS =
 sig    
   structure Program :
   sig
 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
     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
   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
   end
 end
 
 structure AstUtils :> ASTUTILS =
 struct

+  structure T = Type

   structure A = Ast
 
   structure Program =
   structure A = Ast
 
   structure Program =


@@ -36,10 +25,10 @@ struct
     fun append_typedef (tds, fns) (i, td) =
       let
         val mark = case td
     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)
                     | _ => 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) ;
                                                 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
        (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)
   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
       | 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
 end

diff --git a/parse/l4.grm b/parse/l5.grm
similarity index 88%
rename from parse/l4.grm
rename to parse/l5.grm
index 3f14c331a0c69ea61e14bf378c47e1e0590724a9..7195271967c36fc6e62d3c8e700402ba9966bdc8 100644 (file)
--- a/parse/l4.grm
+++ b/parse/l5.grm
@@ -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>
  * 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 A = Ast

+structure T = Type

 structure AU = AstUtils
 structure AUP = AstUtils.Program
 
 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 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 *)
 
 (* 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 )
 
 %%
                        Symbol.bogus )
 
 %%

-%header (functor L4LrValsFn (structure Token : TOKEN))
+%header (functor L5LrValsFn (structure Token : TOKEN))

 
 %term 
    EOF
 
 %term 
    EOF


@@ -42,7 +43,8 @@ fun make_lval (A.Var(id)) ext = id
  | LBRACE | RBRACE
  | LPAREN | RPAREN
  | UNARY | ASNOP (* dummy *)
  | 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
 
 %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
  | 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
  | 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
  | 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 *)
 
 %verbose                                (* print summary of errors *)
 %pos int                                (* positions *)


@@ -77,8 +79,9 @@ fun make_lval (A.Var(id)) ext = id
 %eop EOF
 %noshift EOF
 
 %eop EOF
 %noshift EOF
 

-%name L4
+%name L5

 
 

+%right QUESTION COLON

 %left LOGOR
 %left LOGAND
 %left BITOR
 %left LOGOR
 %left LOGAND
 %left BITOR


@@ -99,11 +102,11 @@ program    : programx               (programx)
 programx   : decls                  (decls)
            | programx function      (AUP.append_function programx function)
 
 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
            | vtype LBRACKET RBRACKET

-                                    (A.Array vtype)
+                                    (T.Array vtype)

 
 decls      :                        (Symbol.empty, Symbol.empty)
            | typedecl decls         (AUP.append_typedef decls typedecl)
 
 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
 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
            | 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])
 
 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))
                                     (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
            | 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)))
            | 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)
 
 explist    : exp                    ([exp])
            | exp COMMA explist      (exp :: explist)

diff --git a/parse/l4.lex b/parse/l5.lex
similarity index 86%
rename from parse/l4.lex
rename to parse/l5.lex
index b988c3548851c533e6bb2215a7380305a961e7ca..e10f8b7da384d198bb047cce7e2c8f06a21fb1c4 100644 (file)
--- a/parse/l4.lex
+++ b/parse/l5.lex
@@ -1,4 +1,4 @@
-(* L4 Compiler
+(* L5 Compiler

  * Lexer
  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
  * 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
                       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)
 
   fun eof () = 
       ( if (!commentLevel > 0)


@@ -51,12 +67,13 @@ in
 end
 
 %%
 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]*;
 %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];
 
 
 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.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));
 <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.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));
 
 <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> {decnum}    => (number (yytext, yypos));

+<INITIAL> {hexnum}    => (hexnumber (yytext, yypos));

 
 <INITIAL> {id}        => (let
                             val id = Symbol.symbol yytext
 
 <INITIAL> {id}        => (let
                             val id = Symbol.symbol yytext

diff --git a/parse/parse.sml b/parse/parse.sml
index 3786421ef2388a9f3e6b9c1e1c52fa7d548651e1..a2cc2fee41e34ceddffaacd961cc4af14fd7d75b 100644 (file)
--- a/parse/parse.sml
+++ b/parse/parse.sml
@@ -1,4 +1,4 @@
-(* L4 Compiler
+(* L5 Compiler

  * Parsing
  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
  * 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 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 *)
                             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
          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 *)
          (* 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)
           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 )
 
            | e as IO.Io _ => ( ErrorMsg.error NONE (exnMessage e);
                                raise ErrorMsg.Error )
 

diff --git a/sources.cm b/sources.cm
index 351df5f4f65b4a35b7bb4543b056840df11d024d..5fdb4c7cb0cd924a01153fa1fbf46ee72a203f62 100644 (file)
--- a/sources.cm
+++ b/sources.cm
@@ -3,6 +3,8 @@ Group is
        $/smlnj-lib.cm
        $/ml-yacc-lib.cm
 
        $/smlnj-lib.cm
        $/ml-yacc-lib.cm
 

+       top/smlnj-specific.sml
+

        util/mark.sml
        util/flag.sml
        util/symbol.sml
        util/mark.sml
        util/flag.sml
        util/symbol.sml


@@ -10,29 +12,38 @@ Group is
         util/safe-io.sml
         util/word32.sml
 
         util/safe-io.sml
         util/word32.sml
 

+       top/flags.sml
+
+       type/type.sml

        parse/ast.sml
        parse/astutils.sml
        parse/parsestate.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
        parse/parse.sml
 
        type/typechecker.sml
 
        trans/temp.sml

-

         trans/label.sml
        trans/tree.sml
         trans/label.sml
        trans/tree.sml

+       trans/treeutils.sml

        trans/trans.sml
 
        codegen/x86.sml
        codegen/codegen.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/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
 
        top/top.sml

diff --git a/sources.mlb b/sources.mlb
index 0f45274624517d5501567f0a5a45ac3d1bb28c0d..63f9acffa3b6454da112c81c9b814c641d9f621a 100644 (file)
--- a/sources.mlb
+++ b/sources.mlb
@@ -2,6 +2,8 @@ $(SML_LIB)/basis/basis.mlb
 $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb
 $(SML_LIB)/mlyacc-lib/mlyacc-lib.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
        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
 
         util/safe-io.sml
         util/word32.sml
 

+       top/flags.sml
+
+       type/type.sml

        parse/ast.sml
        parse/astutils.sml
        parse/parsestate.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
        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/temp.sml
         trans/label.sml
        trans/tree.sml

+       trans/treeutils.sml

        trans/trans.sml
 
        codegen/x86.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/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
+++ b/top/flags.sml
@@ -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
+++ b/top/mlton-specific.sml
@@ -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
+++ b/top/smlnj-specific.sml
@@ -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

diff --git a/top/top.sml b/top/top.sml
index c350c094c898d4002af110839f7415a77bd94251..4b58d00cb08d8fbb9cab41e7ba2c6e0ec842f355 100644 (file)
--- a/top/top.sml
+++ b/top/top.sml
@@ -27,38 +27,61 @@ struct
   fun newline () = TextIO.output (TextIO.stdErr, "\n")
 
   exception EXIT
   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"], 
 
   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"],
                   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"],
                   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"],
                   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"],
                   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"],
                   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 =
 
 
   fun stem s =


@@ -73,27 +96,30 @@ struct
   
   fun processir externs (Tree.FUNCTION (id, ir)) =
       let
   
   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
         
         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 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 (preds, liveness) = Liveness.liveness assem;

-        val _ = Flag.guard flag_liveness
+        val _ = Flag.guard Flags.liveness

                   (fn () => List.app
                     (fn (asm, liv) =>
                       TextIO.print (
                         let
                   (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
                           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))) ()
 
                         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 (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 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)
                   (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) ()
 
                         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
         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 *)
         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)
 
         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"
 
                | [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 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
                   (fn () => say (Ast.Print.pp_program ast)) ()
 
         val externs = Symbol.mapPartiali


@@ -175,18 +203,23 @@ struct
                                        | _ => NONE
                         ) funcs
 
                                        | _ => NONE
                         ) funcs
 

-        val _ = Flag.guard flag_verbose say "Checking..."
+        val _ = Flag.guard Flags.verbose say "Checking..."

         val ast = TypeChecker.typecheck ast
 
         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 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) 
         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 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
         val _ = SafeIO.withOpenOut afname (fn afstream =>
                    TextIO.output (afstream, output))
       in

diff --git a/trans/temp.sml b/trans/temp.sml
index 1092dfcc3e64099cc0e47d733da709897f632d43..bd311c4a08176cb88b0b8175029a31d1d078e549 100644 (file)
--- a/trans/temp.sml
+++ b/trans/temp.sml
@@ -8,18 +8,23 @@
 signature TEMP = 
 sig
   type temp
 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 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
 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
 
   local
     val counter = ref 1


@@ -29,9 +34,32 @@ struct
     fun new str size = (!counter, str, size) before ( counter := !counter + 1 )
   end
 
     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 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
 end

diff --git a/trans/trans.sml b/trans/trans.sml
index 6148ce82454349bb725d3f90267d49013e7a8486..7c70af19d941e14c304d3073ac0a437818225fa6 100644 (file)
--- a/trans/trans.sml
+++ b/trans/trans.sml
@@ -10,14 +10,13 @@
 signature TRANS =
 sig
   (* translate abstract syntax tree to IR tree *)
 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
 end
 
 structure Trans :> TRANS = 
 struct
 
   structure A = Ast

-  structure AU = AstUtils

   structure T = Tree
   
   fun trans_oper A.PLUS = T.ADD
   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
   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'
         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
           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
             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"
       
         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 = 
         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)
              | _ => 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"
       
         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
         | 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
         | 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,
                 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))))
         | 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
             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)) =
              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,
             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
             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)) =
             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)) =
         | 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 *)
 
 
         (* 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)
        *)
        * 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
         | 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
           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 
           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) =
             :: 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
             @ [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
         | 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) =>
             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)
                               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
               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)
                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)

diff --git a/trans/tree.sml b/trans/tree.sml
index d3e8c0d1ecc4f5869c0a3b5cdcb57dbceed20cc3..dbd0efc335dbd8b57deafab808daac8f536700b2 100644 (file)
--- a/trans/tree.sml
+++ b/trans/tree.sml
@@ -9,8 +9,7 @@
 
 signature TREE =
 sig
 
 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
   datatype unop = NEG | BITNOT | BANG
 
   type Blarg = int


@@ -18,16 +17,19 @@ sig
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp
   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
     | 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
     | ALLOC of exp

+    | COND of exp * exp * exp
+    | STMVAR of stm list * exp
+    | NULLPTR

   and stm =
   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
     | 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
       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
 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
   datatype unop = NEG | BITNOT | BANG
 
   type Blarg = int


@@ -55,16 +49,19 @@ struct
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp
   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
     | 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
     | ALLOC of exp

+    | COND of exp * exp * exp
+    | STMVAR of stm list * exp
+    | NULLPTR

   and stm =
   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
     | 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
       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
 end

diff --git a/trans/treeutils.sml b/trans/treeutils.sml
new file mode 100644 (file)
index 0000000..b5217b0
--- /dev/null
+++ b/trans/treeutils.sml
@@ -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
+++ b/type/type.sml
@@ -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

diff --git a/type/typechecker.sml b/type/typechecker.sml
index 35d2859e214068d1597be973148db5a31541830d..06c6d89dce342aafdb9abc4ce88c3196b2573b6b 100644 (file)
--- a/type/typechecker.sml
+++ b/type/typechecker.sml
@@ -10,36 +10,37 @@ signature TYPE_CHECK =
 sig
   (* prints error message and raises ErrorMsg.error if error found *)
   val typecheck : Ast.program -> Ast.program
 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
 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)
   
   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)
        | 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') =>
              | (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)
        | 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)))
                                   | _ => (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
        | 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')) =>
                     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))
                         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
          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)
                        | _ => (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
            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
                      | _ => 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
          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
                        | _ => (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
            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
                      | _ => 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
          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)
            | _ => (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))
            | _ => (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
        | 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))
            | _ => (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
     )
   
   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) =
         | 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
             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.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.
   
   (* 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_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;
     | 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 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
           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) =>
   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 )
          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 => 
          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 ; ())
          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) =>
      | 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) =>
          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) =>
          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) =>
          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 *)
          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)) =
         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)
        then
          let
            val n = String.extract (Symbol.name id, 4, NONE)


@@ -432,7 +448,7 @@ struct
                  else ()
         val () = List.app (
                   fn (n, t) =>
                  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)
                     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 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
         in

-          (vl, AU.Typedef.mark s)
+          (vl, T.defmark s)

         end
       fun checksym mark sym stack k remaining =
         if not (SymbolSet.member (remaining, sym))
         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
             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
                   | (_, 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 )
         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 )
                                                         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
--- a/util/graph.sml
+++ /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

diff --git a/util/word32.sml b/util/word32.sml
index d830c9da5b17df00002616f63db22cf994865b1b..c25c2855c224dc37647bf0c7b64b666a910d876a 100644 (file)
--- a/util/word32.sml
+++ b/util/word32.sml
@@ -14,16 +14,25 @@
 
 signature WORD32_SIGNED =
 sig
 
 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 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
 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)
   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
 
   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
 end