Initial import of l4c

diff --git a/Makefile b/Makefile
index 88508a2cb4ec18fed6ed7ca0edb327040557f991..2cb435220eec662f6c700d874462a3dda53b69bc 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,23 +1,24 @@
 # the following are SML-NJ specific defines
 SML = sml
 
 # the following are SML-NJ specific defines
 SML = sml
 

-l3c: FORCE
-       echo 'use "compile-l3c.sml";' | ${SML}
+l4c: FORCE
+       echo 'use "compile-l4c.sml";' | ${SML}

 
 

-l3c-mlton: FORCE
-       mllex parse/l3.lex
-       mlyacc parse/l3.grm
-       mlton -output bin/l3c-mlton sources.mlb
-       ${RM} parse/l3.lex.sml
+l4c-mlton: FORCE
+       mllex parse/l4.lex
+       mlyacc parse/l4.grm
+       mlton -output bin/l4c-mlton sources.mlb
+       ${RM} parse/l4.lex.sml

 
 reallyclean: clean
        ${RM} parse/*.lex.* parse/*.grm.*
 
 reallyclean: clean
        ${RM} parse/*.lex.* parse/*.grm.*

+       find . -type f -name '*~' | xargs rm -rf

 
 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/l3c.heap.*
-       ${RM} bin/l3c-mlton
+       ${RM} bin/l4c.heap.*
+       ${RM} bin/l4c-mlton

 
 
 TAGS: clean
 
 
 TAGS: clean

diff --git a/README b/README
index 4c6899bfe8efecada5501aa1411581720543f4be..ccc758154db0789c17f38c99c62f86cafa06ca7b 100644 (file)
--- a/README
+++ b/README
@@ -1,58 +1,53 @@
 README
 ------
 
 README
 ------
 

-This compiler is a big long chain of modules that transform l3 code into
+This compiler is a big long chain of modules that transform l4 code into

 x86_64 assembly.
 
 x86_64 assembly.
 

-Here is a breakdown of the modules and changes from l2:
+Here is a breakdown of the modules and changes from l3:

 
 

-  * The parser.  The parser was mainly brought in from lab 2, and mainly
-    just a straight-forward extension of the l2 parser.  We added the
-    ability to parse functions, function calls, and variable declarations.
+  * 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.
+    
+  * AST utilities.  Some of those now exist to make common operations on raw
+    AST structures less painful.

 
 

-  * The typechecker.  This module is mostly the same as that from l2. It
-    performs function-related typechecking as well now, such as ensuring
-    that the correct number of arguments is supplied in a function call,
-    that there are no multiple definitions of functions, and that there is a
-    main function that takes only one argument.
+  * 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 a CALL.
+  * 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 munch module was also extended with the ability to munch CALL; a
-    major improvement was made when we realized we could determine what
-    expressions had effects and what had fixed registers. Any expressions
-    that use no fixed registers and have no effects can be reordered during
-    evaluation of a function call's arguments. This enabled us to save a
-    bunch of register-register moves. Saving the caller save registers is
-    left to the liveness analyzer, which we believe results in substantially
-    better code than saving and restoring all caller saves.
+  * 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 remains in more or less the same form, but with
-    substantial performance and cleanliness improvements by replacing lists
-    with maps (via BinaryMapFn) and sets (via ListSetFn). Also, a bug of
-    incredible type A was discovered through much pain and suffering, and
-    promptly fixed; it involved not realizing that a def on one line led to
-    an interference on any succeeding lines. Somehow we got away with this
-    for lab 2. Otherwise, we just explicitly state rules to generate
-    def/use/succ predicates which we then iterate over to find a fixed point
-    for livenesses using the standard rules.
+  * The liveness analyzer was mainly unchanged, but for a few rules.

 
 

-  * The grapher was changed to use the binary map and list set for
-    performance boosts (needed to pass certain large tests, like
-    pine-tree_print.l3). It generates an interference graph from a list of
-    livenesses at each source line.
+  * The grapher was fully unchanged.  Nice.

 
 

-  * The color orderer had no changes.
+  * The color orderer was fully unchanged.  Nice.

 
 

-  * The coloring module was slightly updated to recognize more fixed-color
-    registers. It implements a greedy coloring algorithm.
+  * The coloring module was fully unchanged.  Nice.

 
 

-  * The solidifier was modified to change the callee save system. Now we
-    only save the registers we need to. This improvement was pushed by
-    excessively slow execution time on one of the tests.
+  * 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 peepholer is upgraded somewhat; it now eliminates more redundant
-    instructions (such as adding/subtracting 0).
+  * The peepholer lost one form of fail and loss sizing.

 
   * 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
 
   * 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

diff --git a/bin/l3c b/bin/l3c
deleted file mode 100755 (executable)
index 6350d67..0000000
--- a/bin/l3c
+++ /dev/null
@@ -1 +0,0 @@
-sml @SMLcmdname=$0 @SMLload=bin/l3c.heap.x86-linux $*

diff --git a/bin/l4c b/bin/l4c
new file mode 100755 (executable)
index 0000000..0259f69
--- /dev/null
+++ b/bin/l4c
@@ -0,0 +1 @@
+sml @SMLcmdname=$0 @SMLload=bin/l4c.heap.x86-linux $*

diff --git a/codegen/codegen.sml b/codegen/codegen.sml
index 8a5afe27965b552b3c6e7c4dcdc81abfe1f1a128..6ee8c2f38a373503ab8b0e5bf74192b7194268aa 100644 (file)
--- a/codegen/codegen.sml
+++ b/codegen/codegen.sml
@@ -22,6 +22,8 @@ struct
     | effect (T.CALL _) = true
     | effect (T.BINOP(_, a, b)) = (effect a) orelse (effect b)
     | effect (T.UNOP (_, a)) = effect a
     | 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
 
   (* hasfixed : T.exp -> bool
     | effect _ = false
 
   (* hasfixed : T.exp -> bool


@@ -34,6 +36,8 @@ struct
     | hasfixed (T.CALL _) = true
     | hasfixed (T.BINOP(_, a, b)) = (hasfixed a) orelse (hasfixed b)
     | hasfixed (T.UNOP (_, a)) = hasfixed a
     | hasfixed (T.CALL _) = 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 _ = false
 
   (* munch_exp : prex86oper -> T.exp -> prex86insn list *)
     | hasfixed _ = false
 
   (* munch_exp : prex86oper -> T.exp -> prex86insn list *)


@@ -41,16 +45,16 @@ struct
    * generates instructions to achieve d <- e
    * d must be TEMP(t) or REG(r)
    *)
    * generates instructions to achieve d <- e
    * d must be TEMP(t) or REG(r)
    *)

-  fun munch_exp d (T.CONST(n)) = [X.MOV(d, X.CONST n)]
+  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.TEMP(t)) = [X.MOV(d, X.TEMP t)]

-    | munch_exp d (T.ARG(0)) = [X.MOV(d, X.REG X.EDI)]
-    | munch_exp d (T.ARG(1)) = [X.MOV(d, X.REG X.ESI)]
-    | munch_exp d (T.ARG(2)) = [X.MOV(d, X.REG X.EDX)]
-    | munch_exp d (T.ARG(3)) = [X.MOV(d, X.REG X.ECX)]
-    | munch_exp d (T.ARG(4)) = [X.MOV(d, X.REG X.R8D)]
-    | munch_exp d (T.ARG(5)) = [X.MOV(d, X.REG X.R9D)]
-    | munch_exp d (T.ARG(t)) = [X.MOV(d, X.STACKARG (t - 6))]
-    | munch_exp d (T.CALL(name, l)) =  (* Scary demons live here. *)
+    | 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. *)

         let
           val nargs = length l
           val nstack = if (nargs <= 6)
         let
           val nargs = length l
           val nstack = if (nargs <= 6)


@@ -63,83 +67,85 @@ 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.RSP, (~(stackb - 8 * (n - 7))))
+            | argdest n = X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (~(stackb - 8 * (n - 7)))) )

 
           val dests = List.tabulate (nargs, fn x => argdest (x+1))
 
           val dests = List.tabulate (nargs, fn x => argdest (x+1))

-          val hf = List.map hasfixed l
-          val (d_hf, exps_hf) = ListPair.unzip (ListPair.foldr
+          val (exps,_) = ListPair.unzip l
+          val hf = List.map hasfixed exps
+          val (d_hf, l_hf) = ListPair.unzip (ListPair.foldr

             (fn (a,b,c) => if b then a::c else c)
             nil
             (ListPair.zip (dests,l), hf)
           )
             (fn (a,b,c) => if b then a::c else c)
             nil
             (ListPair.zip (dests,l), hf)
           )

-          val (d_nohf, exps_nohf) = ListPair.unzip (ListPair.foldr
+          val (d_nohf, l_nohf) = ListPair.unzip (ListPair.foldr

             (fn (a,b,c) => if b then c else a::c)
             nil
             (ListPair.zip (dests,l), hf)
           )
             (fn (a,b,c) => if b then c else a::c)
             nil
             (ListPair.zip (dests,l), hf)
           )

-          val temps = List.tabulate (List.length d_hf, fn x => Temp.new(Int.toString x ^ " arg"))
+          val temps = List.map (fn (_, sz) => Temp.new ("arg") sz (* xxx? *)) l_hf

           val argevals_hf = List.map
           val argevals_hf = List.map

-            (fn (t,exp) => munch_exp (X.TEMP t) exp)
-            (ListPair.zip (temps, exps_hf))
+            (fn (t,(exp,_)) => munch_exp (X.TEMP t) exp)
+            (ListPair.zip (temps, l_hf))

           val argpushes = List.map
           val argpushes = List.map

-            (fn (dest, t) => [(X.MOV (dest, X.TEMP t))])
+            (fn (dest, t) => [(X.MOV (X.OSIZE(X.sts (Temp.size t), dest), X.TEMP t))])

             (ListPair.zip (d_hf, temps))
           val argevals_nohf = List.map
             (ListPair.zip (d_hf, temps))
           val argevals_nohf = List.map

-            (fn (d,exp) => munch_exp d exp)
-            (ListPair.zip (d_nohf, exps_nohf))
+            (fn (d,(exp,sz)) => munch_exp (X.OSIZE (X.sts sz, d)) exp)
+            (ListPair.zip (d_nohf, l_nohf))

         in
           List.concat argevals_hf @ 
           List.concat argpushes @
           List.concat argevals_nohf @
         in
           List.concat argevals_hf @ 
           List.concat argpushes @
           List.concat argevals_nohf @

-          [ X.SIZE (X.Qword, X.SUB (X.REG X.RSP, X.CONST (Word32.fromInt stackb))),
+          [ X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stackb)),

             X.CALL (name, nargs),
             X.CALL (name, nargs),

-            X.SIZE (X.Qword, X.ADD (X.REG X.RSP, X.CONST (Word32.fromInt stackb))),
-            X.MOV (d, X.REG X.EAX) ]   (* Finally! *)
+            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
         end

-    | munch_exp d (T.BINOP(T.ADD, e1, T.CONST 0w0)) = munch_exp d e1
+(*    | 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.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, T.TEMP t, e2)) = (munch_exp d e2) @ [X.ADD(d, X.TEMP t)] *)

     | munch_exp d (T.BINOP(T.ADD, e1, e2)) =
         let
     | munch_exp d (T.BINOP(T.ADD, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("add"))
+          val t1 = X.TEMP (Temp.new ("add") 4)

         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.ADD(d, t1)]
         end
         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, 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.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, T.TEMP t)) = (munch_exp d e1) @ [X.SUB(d, X.TEMP t)] *)

     | munch_exp d (T.BINOP(T.SUB, e1, e2)) =
         let
     | munch_exp d (T.BINOP(T.SUB, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("sub"))
+          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)]
         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, 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, T.CONST n, e1)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] *)

     | munch_exp d (T.BINOP(T.MUL, e1, e2)) =
         let
     | munch_exp d (T.BINOP(T.MUL, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("mul"))
+          val t1 = X.TEMP (Temp.new ("mul") 4)

         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.IMUL(d, t1)]
         end
     | munch_exp d (T.BINOP(T.DIV, e1, e2)) =
         let
         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.IMUL(d, t1)]
         end
     | munch_exp d (T.BINOP(T.DIV, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("div"))
+          val t1 = X.TEMP (Temp.new ("div") 4)

         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)]
         end
     | munch_exp d (T.BINOP(T.MOD, e1, e2)) =
         let
         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)]
         end
     | munch_exp d (T.BINOP(T.MOD, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("mod"))
+          val t1 = X.TEMP (Temp.new ("mod") 4)

         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)]
         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)]


@@ -148,7 +154,7 @@ struct
     | 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)) =
         let
     | 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)) =
         let

-          val t = X.TEMP (Temp.new ("lsh"))
+          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)]
         end
         in
           (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAL (d, X.REG X.ECX)]
         end


@@ -156,7 +162,7 @@ struct
     | 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
     | 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"))
+          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
         in
           (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAR (d, X.REG X.ECX)]
         end


@@ -166,7 +172,7 @@ struct
     | 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)) =
         let
     | 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)) =
         let

-          val t1 = X.TEMP (Temp.new ("bitand"))
+          val t1 = X.TEMP (Temp.new ("bitand") 4)

         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.AND(d, t1)]
         end
         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.AND(d, t1)]
         end


@@ -176,7 +182,7 @@ struct
     | 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)) =
         let
     | 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)) =
         let

-          val t1 = X.TEMP (Temp.new ("bitor"))
+          val t1 = X.TEMP (Temp.new ("bitor") 4)

         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.OR(d, t1)]
         end
         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.OR(d, t1)]
         end


@@ -186,7 +192,7 @@ struct
     | 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)) =
         let
     | 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)) =
         let

-          val t1 = X.TEMP (Temp.new ("bitxor"))
+          val t1 = X.TEMP (Temp.new ("bitxor") 4)

         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.XOR(d, t1)]
         end
         in
           (munch_exp d e1) @ (munch_exp t1 e2) @ [X.XOR(d, t1)]
         end


@@ -194,8 +200,8 @@ struct
         let
           val (insn1, pos1, neg1) = munch_cond e1
           val (insn2, pos2, neg2) = munch_cond e2
         let
           val (insn1, pos1, neg1) = munch_cond e1
           val (insn2, pos2, neg2) = munch_cond e2

-          val t1 = X.TEMP (Temp.new("logand 1"))
-          val t2 = X.TEMP (Temp.new("logand 2"))
+          val t1 = X.TEMP (Temp.new("logand 1") 4)
+          val t2 = X.TEMP (Temp.new("logand 2") 4)

           val l = Label.new ()
         in
           if (effect e2 orelse (length insn2 > 10))
           val l = Label.new ()
         in
           if (effect e2 orelse (length insn2 > 10))


@@ -203,14 +209,14 @@ struct
                [X.SETcc(pos1, t1), X.Jcc (neg1, l)] @
                (insn2) @
                [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)]
                [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.SIZE(X.Byte, X.AND(t1, t2)), 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)]

         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"))
-          val t2 = X.TEMP (Temp.new("logor 2"))
+          val t1 = X.TEMP (Temp.new("logor 1") 4)
+          val t2 = X.TEMP (Temp.new("logor 2") 4)

           val l = Label.new ()
         in
           if (effect e2 orelse (length insn2 > 10))
           val l = Label.new ()
         in
           if (effect e2 orelse (length insn2 > 10))


@@ -218,7 +224,7 @@ struct
                [X.SETcc(pos1, t1), X.Jcc (pos1, l)] @
                (insn2) @
                [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)]
                [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.SIZE(X.Byte, X.OR(t1, t2)), 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)]

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


@@ -243,6 +249,15 @@ struct
         in
           insns @ [X.SETcc (neg, d), X.MOVZB(d, d)]
         end
         in
           insns @ [X.SETcc (neg, d), X.MOVZB(d, d)]
         end

+    | munch_exp d (T.MEMORY e1) =
+        let
+          val a = X.TEMP (Temp.new "addr" 8)
+        in
+          munch_exp a e1 @ [X.MOV (d, X.REL (a, X.CONST 0w0))]
+        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_cond : T.exp -> X.insn list * X.cond * X.cond
    * munch_cond stm generates code to set flags, and then returns a conditional
    * to test if the expression was true and for if it was false.
   (* munch_cond : T.exp -> X.insn list * X.cond * X.cond
    * munch_cond stm generates code to set flags, and then returns a conditional
    * to test if the expression was true and for if it was false.


@@ -256,17 +271,17 @@ struct
     | 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)) =
     | 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")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end
+        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)) =
     | munch_cond (T.BINOP(T.NEQ, e1, T.CONST n)) =

-        let val t = X.TEMP (Temp.new ("const neq")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end
+        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)) =
     | munch_cond (T.BINOP(T.NEQ, T.TEMP t, e1)) =

-        let val t1 = X.TEMP (Temp.new ("const neq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end
+        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)) =
     | munch_cond (T.BINOP(T.NEQ, e1, T.TEMP t)) =

-        let val t1 = X.TEMP (Temp.new ("const neq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end
+        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
     | munch_cond (T.BINOP(T.NEQ, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("var neq 1"))
-          val t2 = X.TEMP (Temp.new ("var neq 2"))
+          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)
         in
           (munch_exp t1 e1 @ munch_exp t2 e2 @
            [X.CMP(t1, t2)], X.NE, X.E)


@@ -274,17 +289,17 @@ struct
     | 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)) =
     | 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")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end
+        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)) =
     | munch_cond (T.BINOP(T.EQ, e1, T.CONST n)) =

-        let val t = X.TEMP (Temp.new ("const eq")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end
+        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)) =
     | munch_cond (T.BINOP(T.EQ, T.TEMP t, e1)) =

-        let val t1 = X.TEMP (Temp.new ("const eq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end
+        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)) =
     | munch_cond (T.BINOP(T.EQ, e1, T.TEMP t)) =

-        let val t1 = X.TEMP (Temp.new ("const eq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end
+        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
     | munch_cond (T.BINOP(T.EQ, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("var eq 1"))
-          val t2 = X.TEMP (Temp.new ("var eq 2"))
+          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)
         in
           (munch_exp t1 e1 @ munch_exp t2 e2 @
            [X.CMP(t1, t2)], X.E, X.NE)


@@ -292,17 +307,17 @@ struct
     | 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)) =
     | 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")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end
+        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)) =
     | munch_cond (T.BINOP(T.LE, e1, T.CONST n)) =

-        let val t = X.TEMP (Temp.new ("const le")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end
+        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)) =
     | munch_cond (T.BINOP(T.LE, T.TEMP t, e1)) =

-        let val t1 = X.TEMP (Temp.new ("const le")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end
+        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)) =
     | munch_cond (T.BINOP(T.LE, e1, T.TEMP t)) =

-        let val t1 = X.TEMP (Temp.new ("const le")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end
+        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
     | munch_cond (T.BINOP(T.LE, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("var le 1"))
-          val t2 = X.TEMP (Temp.new ("var le 2"))
+          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)
         in
           (munch_exp t1 e1 @ munch_exp t2 e2 @
            [X.CMP(t1, t2)], X.LE, X.G)


@@ -310,17 +325,17 @@ struct
     | 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)) =
     | 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")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end
+        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)) =
     | munch_cond (T.BINOP(T.LT, e1, T.CONST n)) =

-        let val t = X.TEMP (Temp.new ("const lt")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end
+        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)) =
     | munch_cond (T.BINOP(T.LT, T.TEMP t, e1)) =

-        let val t1 = X.TEMP (Temp.new ("const lt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end
+        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)) =
     | munch_cond (T.BINOP(T.LT, e1, T.TEMP t)) =

-        let val t1 = X.TEMP (Temp.new ("const lt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end
+        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
     | munch_cond (T.BINOP(T.LT, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("var lt 1"))
-          val t2 = X.TEMP (Temp.new ("var lt 2"))
+          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)
         in
           (munch_exp t1 e1 @ munch_exp t2 e2 @
            [X.CMP(t1, t2)], X.L, X.GE)


@@ -328,17 +343,17 @@ struct
     | 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)) =
     | 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")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end
+        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)) =
     | munch_cond (T.BINOP(T.GT, T.CONST n, e1)) =

-        let val t = X.TEMP (Temp.new ("const gt")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end
+        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)) =
     | munch_cond (T.BINOP(T.GT, e1, T.TEMP t)) =

-        let val t1 = X.TEMP (Temp.new ("const gt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end
+        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)) =
     | munch_cond (T.BINOP(T.GT, T.TEMP t, e1)) =

-        let val t1 = X.TEMP (Temp.new ("const gt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end
+        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
     | munch_cond (T.BINOP(T.GT, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("var gt 1"))
-          val t2 = X.TEMP (Temp.new ("var gt 2"))
+          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)
         in
           (munch_exp t1 e1 @ munch_exp t2 e2 @
            [X.CMP(t1, t2)], X.G, X.LE)


@@ -346,17 +361,17 @@ struct
     | 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)) =
     | 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")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end
+        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)) =
     | munch_cond (T.BINOP(T.GE, T.CONST n, e1)) =

-        let val t = X.TEMP (Temp.new ("const ge")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end
+        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)) =
     | munch_cond (T.BINOP(T.GE, e1, T.TEMP t)) =

-        let val t1 = X.TEMP (Temp.new ("const ge")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end
+        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)) =
     | munch_cond (T.BINOP(T.GE, T.TEMP t, e1)) =

-        let val t1 = X.TEMP (Temp.new ("const ge")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end
+        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
     | munch_cond (T.BINOP(T.GE, e1, e2)) =
         let

-          val t1 = X.TEMP (Temp.new ("var ge 1"))
-          val t2 = X.TEMP (Temp.new ("var ge 2"))
+          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)
         in
           (munch_exp t1 e1 @ munch_exp t2 e2 @
            [X.CMP(t1, t2)], X.GE, X.L)


@@ -365,62 +380,73 @@ struct
         let
           val (insn1, pos1, neg1) = munch_cond e1
           val (insn2, pos2, neg2) = munch_cond 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"))
-          val t2 = X.TEMP (Temp.new("logor c 2"))
+          val t1 = X.TEMP (Temp.new("logor c 1") 4)
+          val t2 = X.TEMP (Temp.new("logor c 2") 4)

           val l = Label.new ()
         in
           if (effect e2 orelse (length insn2 > 10))
           then ((insn1) @
                 [X.SETcc (pos1, t1), X.Jcc (pos1, l)] @
                 (insn2) @
           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.SIZE (X.Byte, X.TEST (t1, t1))],
+                [X.SETcc (pos2, t1), X.LABEL l, X.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))],

                 X.NE, X.E)
                 X.NE, X.E)

-          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.OR(t1, t2))], 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)

         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"))
-          val t2 = X.TEMP (Temp.new("logand c 2"))
+          val t1 = X.TEMP (Temp.new("logand c 1") 4)
+          val t2 = X.TEMP (Temp.new("logand c 2") 4)

           val l = Label.new ()
         in
           if (effect e2 orelse (length insn2 > 10))
           then ((insn1) @
                 [X.SETcc (pos1, t1), X.Jcc (neg1, l)] @
                 (insn2) @
           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.SIZE (X.Byte, X.TEST (t1, t1))],
+                [X.SETcc (pos2, t1), X.LABEL l, X.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))],

                 X.NE, X.E)
                 X.NE, X.E)

-          else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.AND(t1, t2))], 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)

         end
     | munch_cond e =
       let
         end
     | munch_cond e =
       let

-        val t = X.TEMP (Temp.new ("munch c"))
+        val t = X.TEMP (Temp.new ("munch c") 4)

       in
         (munch_exp t e @ [ X.TEST (t,t) ], X.NE, X.E)
       end
 
       in
         (munch_exp t e @ [ X.TEST (t,t) ], X.NE, X.E)
       end
 

+  (* munch_lval : T.exp -> (X.insn list * X.operand)
+   * Takes an expression that has been typechecked as being a valid lvalue, and then returns an instruction list and an operand to store your shit in.
+   *)
+  fun munch_lval (T.TEMP t) = ([], X.TEMP t)
+    | munch_lval (T.MEMORY m) = 
+      let
+        val t = Temp.new "lv addr" 8
+      in
+        (munch_exp (X.TEMP t) m, X.REL (X.TEMP t, X.CONST 0w0))
+      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 *)
   (* 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 _)) = 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(T.TEMP t1, e2)) =
+  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)) =

         let
         let

-          val t = Temp.new ("assign")
+          val t = Temp.new ("assign") sz
+          val (m, r) = munch_lval a

         in
         in

-          munch_exp (X.TEMP t) e2
-          @ [X.MOV(X.TEMP t1, X.TEMP t)]
+          m @ munch_exp (X.TEMP t) e2
+          @ [X.MOV(X.OSIZE (X.sts sz, r), X.TEMP t)]

         end
         end

-    | munch_stm (T.MOVE(_, _)) =
-        raise ErrorMsg.InternalError "Incorrect first operand for T.MOVE?"
-    | munch_stm (T.RETURN(e)) =
+    | munch_stm (T.RETURN(e, sz)) =

         let
         let

-          val t = Temp.new ("retval")
+          val t = Temp.new ("retval") sz

         in
           munch_exp (X.TEMP t) e
         in
           munch_exp (X.TEMP t) e

-          @ [X.MOV(X.REG X.EAX, X.TEMP t), X.RET]
+          @ [X.MOV(X.OSIZE (X.sts sz, X.REG X.EAX), X.TEMP t), X.RET]

         end
     | munch_stm (T.LABEL(l)) = [X.LABEL l]
     | munch_stm (T.JUMP(l)) = [X.JMP l]
         end
     | munch_stm (T.LABEL(l)) = [X.LABEL l]
     | munch_stm (T.JUMP(l)) = [X.JMP l]


@@ -430,6 +456,7 @@ struct
        in
          insns @ [X.Jcc (neg, l)]
        end
        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

 
   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/liveness.sml b/codegen/liveness.sml
index 24123b9013ffc3e1e5c7bc5feb98caa87f2cb714..4c8e4ad3fa868b45d00fc179e076b25198be7de7 100644 (file)
--- a/codegen/liveness.sml
+++ b/codegen/liveness.sml
@@ -77,10 +77,14 @@ struct
        * helper functions to discard constant operands *)
       fun defhit (X.REG a) = [DEF(X.REG a)]
         | defhit (X.TEMP a) = [DEF(X.TEMP a)]
        * 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

         | defhit (_) = nil
     
         | defhit (_) = nil
     

-      fun usehit (X.REG a) = [USE(X.REG a)]
+      and usehit (X.REG a) = [USE(X.REG a)]

         | usehit (X.TEMP a) = [USE(X.TEMP 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

         | usehit (_) = nil
 
       fun callhit 0 = nil
         | usehit (_) = nil
 
       fun callhit 0 = nil


@@ -98,8 +102,8 @@ struct
       fun gendef (n, X.DIRECTIVE(_))           = (nil)
         | gendef (n, X.COMMENT(_))             = (nil)
         | gendef (n, X.LIVEIGN (_))            = ([SUCC (n+1)])
       fun gendef (n, X.DIRECTIVE(_))           = (nil)
         | gendef (n, X.COMMENT(_))             = (nil)
         | gendef (n, X.LIVEIGN (_))            = ([SUCC (n+1)])

-        | gendef (n, X.SIZE(_, i))             = gendef (n,i)

         | gendef (n, X.MOV(dest, src))         = (defhit dest @ usehit src @ [SUCC(n+1), ISMOVE])
         | gendef (n, X.MOV(dest, src))         = (defhit dest @ usehit src @ [SUCC(n+1), ISMOVE])

+        | 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.IMUL3(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.IMUL3(dest, src, _))    = (defhit dest @ usehit src @ [SUCC(n+1)])

diff --git a/codegen/peephole.sml b/codegen/peephole.sml
index 7fa4554b305d5721dfbbedf8d305a8e8ed169c95..7bf55a1c9a9235e6b1888f9e06b652998d440d5c 100644 (file)
--- a/codegen/peephole.sml
+++ b/codegen/peephole.sml
@@ -40,7 +40,6 @@ struct
     | 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 (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 (X.SIZE (s, i)::l) = map (fn i => X.SIZE (s, i)) (peephole [i]) @ (peephole l)  (* :/ that kind of sucks, but oh well *)

     | peephole (a::l) = a::(peephole l)
     | peephole nil = nil
 
     | peephole (a::l) = a::(peephole l)
     | peephole nil = nil
 

diff --git a/codegen/solidify.sml b/codegen/solidify.sml
index 8c39017586297295225d1269b9123463244ac240..21b37bceccae003162161409f75a1bfa92fc1646 100644 (file)
--- a/codegen/solidify.sml
+++ b/codegen/solidify.sml
@@ -26,12 +26,12 @@ struct
   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 *)

-      val maxreg = X.regtonum X.R14D
+      val maxreg = X.regtonum X.R13D

       fun numtoreg n =
           if (n > maxreg)
           then raise Spilled
           else X.numtoreg n
       fun numtoreg n =
           if (n > maxreg)
           then raise Spilled
           else X.numtoreg n

-      
+

       fun temptonum (t: T.temp) : int =
         (List.hd
           (List.map (fn (_, n) => n)
       fun temptonum (t: T.temp) : int =
         (List.hd
           (List.map (fn (_, n) => n)


@@ -42,9 +42,10 @@ struct
         handle Empty => raise ErrorMsg.InternalError ("Uncolored temp "^(Temp.name t)^", agh!")
 
       val spillreg1 = X.R15D
         handle Empty => raise ErrorMsg.InternalError ("Uncolored temp "^(Temp.name t)^", agh!")
 
       val spillreg1 = X.R15D

+      val spillreg2 = X.R14D

 
       (* Determine which need to be saved. *)
 
       (* Determine which need to be saved. *)

-      val opsused = map (fn (_, n) => X.REG (numtoreg n handle Spilled => X.R15D)) regmap
+      val opsused = (map (fn (_, n) => X.REG (numtoreg n handle Spilled => X.R15D)) regmap) @ [X.REG X.R14D]

       val saveregs = X.OperSet.intersection (
         X.OperSet.addList (X.OperSet.empty, opsused),
         X.OperSet.addList (
       val saveregs = X.OperSet.intersection (
         X.OperSet.addList (X.OperSet.empty, opsused),
         X.OperSet.addList (


@@ -58,99 +59,135 @@ struct
       val savelist = X.OperSet.listItems saveregs
       val nsave = length savelist
 
       val savelist = X.OperSet.listItems saveregs
       val nsave = length savelist
 

-      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) handle Empty => false)        (* Whether a register is spilled *)
+      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.STACKARG _) = true
         | isspilled (X.REL _) = true

+        | isspilled (X.OSIZE (_, oo)) = isspilled oo

         | isspilled _ = false
       val stacksz = (nspilled + nsave) * 8
         | isspilled _ = false
       val stacksz = (nspilled + nsave) * 8

-      fun stackpos (reg: int) = stacksz - (reg - maxreg + nsave) * 8   (* Stack position of some register number *)
+      fun stackpos (reg: int) = stacksz - (reg - maxreg + nsave) * 8    (* Stack position of some register number *)

 
       val prologue =
 
       val prologue =

-        (X.SIZE (X.Qword, X.SUB (X.REG X.RSP, X.CONST (Word32.fromInt stacksz)))) ::
+        (X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))) ::

         (ListPair.map
           (fn (num, reg) =>
         (ListPair.map
           (fn (num, reg) =>

-            X.SIZE (X.Qword, X.MOV (X.REL (X.RSP, stacksz - 8*(num+1)), 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)))

           (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.SIZE (X.Qword, X.MOV (reg, X.REL (X.RSP, stacksz - 8*(num+1)))))
+            X.MOV (X.OSIZE (X.Qword, reg), X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz - 8*(num+1))))))

           (List.tabulate (nsave, fn x => x), savelist)) @
           (List.tabulate (nsave, fn x => x), savelist)) @

-        [X.SIZE (X.Qword, X.ADD (X.REG X.RSP, X.CONST (Word32.fromInt stacksz)))]
+        [X.ADD (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))]

       val endlbl = Label.new()
 
       val endlbl = Label.new()
 

-      fun spill (X.TEMP temp, xreg: x86.reg) = (* Spill a register if need be. *)
+      fun spill s (X.TEMP temp, xreg: x86.reg) =    (* Spill a register if need be. *)

         if (isspilled (X.TEMP temp))
         if (isspilled (X.TEMP temp))

-          then [X.MOV (X.REL (X.RSP, stackpos (temptonum temp)), X.REG xreg)]
+          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
           else nil

-        | spill (X.STACKARG _, _) = raise ErrorMsg.InternalError "Cannot spill to a stack arg"
-        | spill (a as X.REL _, xreg) = [X.MOV (a, X.REG xreg)]
-        | spill _ = nil                (* Nothing else can be spilled. *)
-      fun unspill (X.TEMP temp, xreg: x86.reg) =       (* Unspill a register if need be. *)
+        | 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))
         if (isspilled (X.TEMP temp))

-          then [X.MOV (X.REG xreg, X.REL (X.RSP, stackpos (temptonum 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
           else nil

-        | unspill (X.STACKARG arg, xreg) = [X.MOV (X.REG xreg, X.REL (X.RSP, stacksz + 8 + (arg * 8)))]
-        | unspill (a as X.REL _, xreg) = [X.MOV (X.REG xreg, a)]
-        | unspill _ = 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.REG (temptoreg temp)      (* Makes a operand 'real'. *)
+      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.STACKARG arg) = raise Spilled
         | realoper (X.REL _) = raise Spilled

+        | realoper (X.OSIZE (s, oo)) = X.OSIZE (s, realoper (X.stripsize oo))

         | realoper r = r
 
       fun stackoper (X.TEMP temp) =
             if not (isspilled (X.TEMP temp)) then raise ErrorMsg.InternalError "stackoper on unspilled temp?"
         | realoper r = r
 
       fun stackoper (X.TEMP temp) =
             if not (isspilled (X.TEMP temp)) then raise ErrorMsg.InternalError "stackoper on unspilled temp?"

-            else X.REL (X.RSP, stackpos (temptonum temp))
-        | stackoper (X.STACKARG arg) = X.REL (X.RSP, stacksz + 8 + (arg * 8))
+            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 (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?"
         | 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))
+            else
+              ([],
+                X.REL (realoper t1, realoper t2))
+          end
+        | ophit a = (nil, realoper a handle Spilled => stackoper a)
+

       fun transform (X.DIRECTIVE s) = [X.DIRECTIVE s]
         | transform (X.COMMENT s) = [X.COMMENT s]
         | transform (X.LIVEIGN a) = transform a
       fun transform (X.DIRECTIVE s) = [X.DIRECTIVE s]
         | transform (X.COMMENT s) = [X.COMMENT s]
         | transform (X.LIVEIGN a) = transform a

-        | transform (X.SIZE (s, i)) = map (fn i' => (X.SIZE (s, i'))) (transform i)

         | transform (X.MOV (dest, src)) =
         | transform (X.MOV (dest, src)) =

-            if (isspilled dest)
-            then
-              unspill (src, spillreg1) @
-              [X.MOV(
-                  realoper dest handle Spilled => stackoper dest,
-                  realoper src handle Spilled => X.REG spillreg1)]
-            else
-              [X.MOV(
-                  realoper dest handle Spilled => raise ErrorMsg.InternalError "But we said that wasn't spilled?",
-                  realoper src handle Spilled => stackoper 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, realop2)] @ insns1 @ [X.MOV (realop1, X.REG spillreg2)]
+              else
+                insns1 @ insns2 @ [X.MOV (realop1, realop2)]
+            end
+        | transform (X.LEA (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, realop2)] @ insns1 @ [X.LEA (realop1, X.REG spillreg2)]
+              else
+                insns1 @ insns2 @ [X.LEA (realop1, realop2)]
+            end

         | transform (X.SUB (dest, src)) =
         | transform (X.SUB (dest, src)) =

-            unspill (src, spillreg1) @
-            [ X.SUB(
-                realoper dest handle Spilled => stackoper dest,
-                realoper src handle Spilled => X.REG spillreg1)]
+            let
+              val (insns, realop) = ophit dest
+            in
+              unspill X.Long (src, spillreg2) @ insns @
+              [ X.SUB(realop,
+                  realoper src handle Spilled => X.REG spillreg2)]
+            end

         | transform (X.IMUL (dest, src)) =
         | transform (X.IMUL (dest, src)) =

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

             [ X.IMUL(
                 realoper dest handle Spilled => X.REG spillreg1,
                 realoper src handle Spilled => stackoper src)] @
             [ X.IMUL(
                 realoper dest handle Spilled => X.REG spillreg1,
                 realoper src handle Spilled => stackoper src)] @

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

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

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

             [ X.IMUL3(
                 realoper dest handle Spilled => X.REG spillreg1,
             [ X.IMUL3(
                 realoper dest handle Spilled => X.REG spillreg1,

-                realoper src handle Spilled => stackoper src,
+                realoper src handle Spilled => X.REG spillreg2,

                 const)] @
                 const)] @

-            spill (dest, spillreg1)
-        | transform (X.ADD (dest, src)) =      (* You can have either operand spilled, but not both. Pick one. *)
-            if (isspilled dest)
-            then
-              unspill (src, spillreg1) @
-              [ X.ADD(
-                  realoper dest handle Spilled => stackoper dest,
-                  realoper src handle Spilled => X.REG spillreg1)]
-            else
-              [ X.ADD(
-                  realoper dest handle Spilled => raise ErrorMsg.InternalError "But we said that wasn't spilled?",
-                  realoper src handle Spilled => stackoper src)]
+            spill X.Long (dest, spillreg1)
+        | transform (X.ADD (dest, src)) =
+            let
+              val (insns, realop) = ophit dest
+            in
+              unspill X.Long (src, spillreg2) @ insns @
+              [ X.ADD(realop,
+                  realoper src handle Spilled => X.REG spillreg2)]
+            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)]
         | transform (X.NOT (src)) = [ X.NOT(realoper src handle Spilled => stackoper src)]
         | transform (X.IDIV (src)) = [ X.IDIV(realoper src handle Spilled => stackoper src)]
         | transform (X.NEG (src)) = [ X.NEG(realoper src handle Spilled => stackoper src)]
         | transform (X.NOT (src)) = [ X.NOT(realoper src handle Spilled => stackoper src)]


@@ -164,27 +201,27 @@ struct
                 shft)]
         | transform (X.CLTD) = [ X.CLTD ]
         | transform (X.AND (dest, src)) =
                 shft)]
         | transform (X.CLTD) = [ X.CLTD ]
         | transform (X.AND (dest, src)) =

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

             [ X.AND(
                 realoper dest handle Spilled => stackoper dest,
                 realoper src handle Spilled => X.REG spillreg1)]
         | transform (X.OR (dest, src)) =
             [ X.AND(
                 realoper dest handle Spilled => stackoper dest,
                 realoper src handle Spilled => X.REG spillreg1)]
         | transform (X.OR (dest, src)) =

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

             [ X.OR(
                 realoper dest handle Spilled => stackoper dest,
                 realoper src handle Spilled => X.REG spillreg1)]
         | transform (X.XOR (dest, src)) =
             [ X.OR(
                 realoper dest handle Spilled => stackoper dest,
                 realoper src handle Spilled => X.REG spillreg1)]
         | transform (X.XOR (dest, src)) =

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

             [ X.XOR(
                 realoper dest handle Spilled => stackoper dest,
                 realoper src handle Spilled => X.REG spillreg1)]
         | transform (X.CMP (op1, op2)) =
             [ X.XOR(
                 realoper dest handle Spilled => stackoper dest,
                 realoper src handle Spilled => X.REG spillreg1)]
         | transform (X.CMP (op1, op2)) =

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

             [ X.CMP(
                 realoper op1 handle Spilled => stackoper op1,
                 realoper op2 handle Spilled => X.REG spillreg1)]
         | transform (X.TEST (op1, op2)) =
             [ X.CMP(
                 realoper op1 handle Spilled => stackoper op1,
                 realoper op2 handle Spilled => X.REG spillreg1)]
         | transform (X.TEST (op1, op2)) =

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

             [ X.TEST(
                 realoper op1 handle Spilled => stackoper op1,
                 realoper op2 handle Spilled => X.REG spillreg1)]
             [ X.TEST(
                 realoper op1 handle Spilled => stackoper op1,
                 realoper op2 handle Spilled => X.REG spillreg1)]


@@ -194,7 +231,7 @@ struct
             [ X.MOVZB(
                 realoper dest handle Spilled => X.REG spillreg1,
                 realoper src handle Spilled => stackoper src)]
             [ X.MOVZB(
                 realoper dest handle Spilled => X.REG spillreg1,
                 realoper src handle Spilled => stackoper src)]

-            @ spill (dest, spillreg1)
+            @ spill X.Long (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.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 ]

diff --git a/codegen/stringifier.sml b/codegen/stringifier.sml
index 74fe8c15b046cd4be77dfeeb22d98da862ea62ac..5010d7bc048d0b806491b2bec9dafb2092f79047 100644 (file)
--- a/codegen/stringifier.sml
+++ b/codegen/stringifier.sml
@@ -18,8 +18,8 @@ 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.Long (X.CALL ((Symbol.symbol (rn (Symbol.name l))), n))
-    | stringify' rn x = X.prettyprint X.Long x
+  fun stringify' rn (X.CALL (l, n)) = X.prettyprint (X.CALL ((Symbol.symbol (rn (Symbol.name l))), n))
+    | stringify' rn x = X.prettyprint x

 
   (* val stringify : asm -> string *)
   fun stringify realname l = foldr (fn (a,b) => (stringify' realname a) ^ b) ("") l
 
   (* val stringify : asm -> string *)
   fun stringify realname l = foldr (fn (a,b) => (stringify' realname a) ^ b) ("") l

diff --git a/codegen/x86.sml b/codegen/x86.sml
index 6ec426375fccc37b37c302cbdc1f84674085a742..e54d4beb2b0ec77085398cf5368e31670df14413 100644 (file)
--- a/codegen/x86.sml
+++ b/codegen/x86.sml
@@ -10,16 +10,16 @@ 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 oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (reg * int) | STACKARG of int | STR of string
-  datatype cc = E | NE | GE | LE | L | G

   datatype size = Byte | Word | Long | Qword
   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

   (* instructions *)
   datatype insn =
     DIRECTIVE of string |
     COMMENT of string |
     LABEL of Label.label |
   (* instructions *)
   datatype insn =
     DIRECTIVE of string |
     COMMENT of string |
     LABEL of Label.label |

-    SIZE of size * insn |

     MOV of oper * oper |
     MOV of oper * oper |

+    LEA of oper * oper |

     SUB of oper * oper |
     IMUL of oper * oper |
     IMUL3 of oper * oper * Word32.word |
     SUB of oper * oper |
     IMUL of oper * oper |
     IMUL3 of oper * oper * Word32.word |


@@ -48,6 +48,10 @@ sig
   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 cmpoper : oper * oper -> order
   val opereq : oper * oper -> bool
   val regname : size -> reg -> string
   val cmpoper : oper * oper -> order
   val opereq : oper * oper -> bool
   val regname : size -> reg -> string


@@ -56,7 +60,7 @@ sig
   val ccname : cc -> string
   val opsused : insn list -> OperSet.set
   val prettyprint_oper : size -> oper -> string
   val ccname : cc -> string
   val opsused : insn list -> OperSet.set
   val prettyprint_oper : size -> oper -> string

-  val prettyprint : size -> insn -> string
+  val prettyprint : insn -> string

 end
 
 structure x86 :> X86 =
 end
 
 structure x86 :> X86 =


@@ -65,15 +69,15 @@ 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 oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (reg * int) | STACKARG of int | STR of string
-  datatype cc = E | NE | GE | LE | L | G

   datatype size = Byte | Word | Long | Qword
   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 insn =
     DIRECTIVE of string |
     COMMENT of string |
     LABEL of Label.label |
   datatype insn =
     DIRECTIVE of string |
     COMMENT of string |
     LABEL of Label.label |

-    SIZE of size * insn |

     MOV of oper * oper |
     MOV of oper * oper |

+    LEA of oper * oper |

     SUB of oper * oper |
     IMUL of oper * oper |
     IMUL3 of oper * oper * Word32.word |
     SUB of oper * oper |
     IMUL of oper * oper |
     IMUL3 of oper * oper * Word32.word |


@@ -182,11 +186,11 @@ struct
     | cmpoper (CONST(const1), CONST(const2)) = Word32.compare (const1, const2)
     | cmpoper (REL (r1, i1), REL (r2, i2)) =
         let 
     | cmpoper (CONST(const1), CONST(const2)) = Word32.compare (const1, const2)
     | cmpoper (REL (r1, i1), REL (r2, i2)) =
         let 

-          val regorder = regcmp (r1, r2)
-          val intorder = Int.compare (i1, i2)
+          val order1 = cmpoper (r1, r2)
+          val order2 = cmpoper (i1, i2)

         in
         in

-          if (regorder = EQUAL) then intorder
-          else regorder
+          if (order1 = EQUAL) then order2
+          else order1

         end
     | cmpoper (CONST _, _) = LESS
     | cmpoper (REG _, _) = LESS
         end
     | cmpoper (CONST _, _) = LESS
     | cmpoper (REG _, _) = LESS


@@ -196,7 +200,8 @@ struct
   fun opereq (REG a, REG b) = a = b
     | opereq (TEMP a, TEMP b) = Temp.eq (a, b)
     | opereq (CONST a, CONST b) = a = b
   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 (ra, ia), REL (rb, ib)) = (ra = rb) andalso (ia = ib)
+    | 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 (
     | opereq (_, _) = false
     
   structure OperSet = ListSetFn (


@@ -215,6 +220,7 @@ struct
     | opsused ((COMMENT _)::l) = opsused l
     | opsused ((LABEL _)::l) = opsused l
     | opsused ((MOV (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
     | 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 ((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])


@@ -237,53 +243,63 @@ struct
     | 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)

-    | opsused ((SIZE (_, i))::l) = opsused (i::l)

 
 

-  (* integer tostring, except with more - and less ~ *)
-  fun moreDifferentToString (i) =
-       if (i >= 0) then Int.toString i
-       else "-" ^ (Int.toString (~i))
+  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"
 
   (* 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)
   fun prettyprint_oper s (REG r) = "%" ^ (regname s r)

-    | prettyprint_oper s (TEMP t) = (Temp.name t) ^ (sfx s)
+    | prettyprint_oper _ (TEMP t) = (Temp.name t) ^ (sfx (sts (Temp.size t)))

     | prettyprint_oper _ (CONST c) = "$0x" ^ (Word32.toString c)
     | prettyprint_oper _ (CONST c) = "$0x" ^ (Word32.toString c)

-    | prettyprint_oper _ (REL (r, i)) = (moreDifferentToString i) ^ "(%" ^ (regname Qword r) ^ ")"
-    | prettyprint_oper _ (STR s) = s
+    | 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 _ (STACKARG i) = "arg#"^Int.toString i

+    | prettyprint_oper _ (OSIZE (s, oo)) = prettyprint_oper s (stripsize oo)

 
   (* pretty prints (no...) *)
 
   (* pretty prints (no...) *)

-  fun prettyprint s (DIRECTIVE(str)) = str ^ "\n"
-    | prettyprint s (COMMENT(str)) = "// " ^ str ^ "\n"
-    | prettyprint s (LABEL(l)) = Label.name l ^ ":\n"
-    | prettyprint s (MOV(dst, src)) = "\tmov" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (SUB(dst, src)) = "\tsub" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (IMUL(dst, src)) = "\timul\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (IMUL3(dst, tmp, const)) = "\timul\t" ^ (prettyprint_oper s (CONST const)) ^ ", " ^ (prettyprint_oper s tmp) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (ADD(dst, src)) = "\tadd" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (IDIV(src)) = "\tidiv" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ "\n"
-    | prettyprint s (NEG (dst)) = "\tneg" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (NOT (dst)) = "\tnot" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (SAL (dst, shft)) = "\tsal" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (SAR (dst, shft)) = "\tsar" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (AND (dst, src)) = "\tand" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (OR (dst, src)) = "\tor" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (XOR (dst, src)) = "\txor" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (CMP (dst, src)) = "\tcmp" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (TEST (dst, src)) = "\ttest" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (prettyprint_oper Byte dst) ^ "\n"
-    | prettyprint s (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n"
-    | prettyprint s (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n"
-    | prettyprint s (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n"
-    | prettyprint s (MOVZB (dst, src)) = "\tmovzb" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
-    | prettyprint s (CLTD) = "\tcltd\n"
-    | prettyprint s (RET) = "\tret\n"
-    | prettyprint s (LIVEIGN i) = prettyprint s i
-    | prettyprint _ (SIZE (s, i)) = prettyprint s i
+  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?")*)
 end
 (*    | prettyprint _ = raise ErrorMsg.InternalError ("prettyprint: Type A? Hatchar de coneccion?")*)
 end

diff --git a/compile-l3c.sml b/compile-l4c.sml
similarity index 72%
rename from compile-l3c.sml
rename to compile-l4c.sml
index a8f95ec4fa56bd4576a605142d5169fee8fbff7c..7299ee821db62b075a9b082a3613a2a3cdd58de7 100644 (file)
--- a/compile-l3c.sml
+++ b/compile-l4c.sml
@@ -4,4 +4,4 @@
  *)
 
 CM.make "sources.cm";
  *)
 
 CM.make "sources.cm";

-SMLofNJ.exportFn ("bin/l3c.heap", Top.main);
+SMLofNJ.exportFn ("bin/l4c.heap", Top.main);

diff --git a/parse/ast.sml b/parse/ast.sml
index fce70ab9d9e69275415d4acdf39563621bece8b2..84b2356b74c146f728a598769b02264092c17176 100644 (file)
--- a/parse/ast.sml
+++ b/parse/ast.sml
@@ -13,8 +13,12 @@ signature AST =
 sig
   type ident = Symbol.symbol
   
 sig
   type ident = Symbol.symbol
   

-  datatype vtype = Int
+  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
   type variable = ident * vtype

+  datatype typedef = Struct of variable list
+                   | MarkedTypedef of typedef Mark.marked

 
   datatype oper = 
      PLUS
 
   datatype oper = 
      PLUS


@@ -45,8 +49,17 @@ sig
    | OpExp of oper * exp list
    | Marked of (* Kane *) exp Mark.marked
    | FuncCall of ident * (exp list)
    | OpExp of oper * exp list
    | Marked of (* Kane *) exp Mark.marked
    | FuncCall of ident * (exp list)

+   | Member of exp * ident
+   | DerefMember of exp * ident
+   | Dereference of exp
+   | ArrIndex of exp * exp
+   | New of vtype
+   | NewArr of vtype * exp
+   | Null

   and stm =
   and stm =

-     Assign of ident * exp
+     Assign of exp * exp
+   | AsnOp of oper * exp * exp
+   | Effect of exp (* Just side effect the expression *)

    | Return of exp
    | Nop
    | Break
    | Return of exp
    | Nop
    | Break


@@ -57,27 +70,39 @@ sig
    | MarkedStm of stm Mark.marked
 
   datatype function =
    | MarkedStm of stm Mark.marked
 
   datatype function =

-     Extern of vtype * ident * (variable list)
-   | Function of vtype * ident * (variable list) * (variable list) * stm list
+     Extern of vtype * (variable list)
+   | Function of vtype * (variable list) * (variable list) * stm list
+   | MarkedFunction of function Mark.marked

   
   

-  type program = function list
+  type program = 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

-

 end
 
 structure Ast :> AST =
 struct
   type ident = Symbol.symbol
 
 end
 
 structure Ast :> AST =
 struct
   type ident = Symbol.symbol
 

-  datatype vtype = Int
+  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
   type variable = ident * vtype

+  datatype typedef = Struct of variable list
+                   | MarkedTypedef of typedef Mark.marked

 
   datatype oper = 
      PLUS
 
   datatype oper = 
      PLUS


@@ -108,8 +133,17 @@ struct
    | OpExp of oper * exp list
    | Marked of exp Mark.marked
    | FuncCall of ident * (exp list)
    | OpExp of oper * exp list
    | Marked of exp Mark.marked
    | FuncCall of ident * (exp list)

+   | Member of exp * ident
+   | DerefMember of exp * ident
+   | Dereference of exp
+   | ArrIndex of exp * exp
+   | New of vtype
+   | NewArr of vtype * exp
+   | Null

   and stm =
   and stm =

-     Assign of ident * exp
+     Assign of exp * exp
+   | AsnOp of oper * exp * exp
+   | Effect of exp (* Just side effect the expression *)

    | Return of exp
    | Nop
    | Break
    | Return of exp
    | Nop
    | Break


@@ -120,10 +154,11 @@ struct
    | MarkedStm of stm Mark.marked
 
   datatype function =
    | MarkedStm of stm Mark.marked
 
   datatype function =

-     Extern of vtype * ident * (variable list)
-   | Function of vtype * ident * (variable list) * (variable list) * stm list
+     Extern of vtype * (variable list)
+   | Function of vtype * (variable list) * (variable list) * stm list
+   | MarkedFunction of function Mark.marked

   
   

-  type program = function list
+  type program = 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


@@ -166,22 +201,33 @@ struct
       | pp_exp (FuncCall(id, l)) = pp_ident id ^ "(" ^ pp_expl l ^ ")"
       | pp_exp (Marked(marked_exp)) =
          pp_exp (Mark.data marked_exp)
       | pp_exp (FuncCall(id, l)) = pp_ident id ^ "(" ^ pp_expl l ^ ")"
       | pp_exp (Marked(marked_exp)) =
          pp_exp (Mark.data marked_exp)

+      | pp_exp (Member(e, i)) = pp_exp e ^ "." ^ pp_ident i
+      | 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 Null = "NULL"

     
     and pp_expl nil = ""
       | pp_expl (e::a::l) = (pp_exp e) ^ ", " ^ (pp_expl (a::l))
       | pp_expl (e::l) = (pp_exp e) ^ (pp_expl l)
 
     
     and pp_expl nil = ""
       | pp_expl (e::a::l) = (pp_exp e) ^ ", " ^ (pp_expl (a::l))
       | pp_expl (e::l) = (pp_exp e) ^ (pp_expl l)
 

-    fun pp_stm (Assign (id,e)) =
-       pp_ident id ^ " = " ^ pp_exp e ^ ";"
+    and pp_stm (Assign (e1,e2)) =
+          pp_exp e1 ^ " = " ^ pp_exp e2 ^ ";\n"
+      | pp_stm (AsnOp (oop, e1, e2)) =
+          pp_exp e1 ^ " " ^ pp_oper oop ^ "= " ^ pp_exp e2 ^ ";\n"
+      | pp_stm (Effect (e)) = 
+          pp_exp e ^ ";\n"

       | pp_stm (Return e) =
       | pp_stm (Return e) =

-         "return " ^ pp_exp e ^ ";"
-      | pp_stm Nop = ";"
-      | pp_stm Break = "break;"
-      | pp_stm Continue = "continue;"
-      | pp_stm (If (e, s, NONE)) = "if ("^pp_exp e^")"^pp_block s
-      | pp_stm (If (e, s, SOME s2)) = "if ("^pp_exp e^")"^pp_block s^" else "^pp_block s2
-      | pp_stm (While (e, s)) = "while ("^pp_exp e^") "^pp_block s
-      | pp_stm (For (so1, e, so2, s)) = "for ("^ (if (isSome so1) then pp_stm (valOf so1) else "") ^ pp_exp e ^ (if(isSome so2) then pp_stm (valOf so2) else "") ^ ")" ^ pp_block s
+         "return " ^ pp_exp e ^ ";\n"
+      | pp_stm Nop = ";\n"
+      | pp_stm Break = "break;\n"
+      | pp_stm Continue = "continue;\n"
+      | pp_stm (If (e, s, NONE)) = "if ("^pp_exp e^")\n"^pp_block s
+      | pp_stm (If (e, s, SOME s2)) = "if ("^pp_exp e^")\n"^pp_block s^"else\n"^pp_block s2
+      | pp_stm (While (e, s)) = "while ("^pp_exp e^")\n"^pp_block s
+      | pp_stm (For (so1, e, so2, s)) = "for ("^ (if (isSome so1) then pp_stm (valOf so1) else "") ^ pp_exp e ^ (if(isSome so2) then pp_stm (valOf so2) else "") ^ ")\n" ^ pp_block s

       | pp_stm (MarkedStm m) = pp_stm (Mark.data m)
 
     and pp_block (nil) = ";"
       | pp_stm (MarkedStm m) = pp_stm (Mark.data m)
 
     and pp_block (nil) = ";"


@@ -196,6 +242,10 @@ struct
       | pp_stms (s::ss) = pp_stm s ^ "\n" ^ pp_stms ss
     
     and pp_type Int = "int"
       | pp_stms (s::ss) = pp_stm s ^ "\n" ^ pp_stms ss
     
     and pp_type Int = "int"

+      | pp_type (Typedef i) = pp_ident i
+      | pp_type (Pointer t) = pp_type t ^ "*"
+      | pp_type (Array t) = pp_type t ^ "[]"
+      | pp_type TNull = "{NULL type}"

     
     and pp_params nil = ""
       | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ ", " ^ (pp_params (a::l))
     
     and pp_params nil = ""
       | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ ", " ^ (pp_params (a::l))


@@ -204,9 +254,13 @@ struct
     and pp_vars nil = ""
       | pp_vars ((i, t)::l) = "var " ^ (pp_ident i) ^ " : " ^ (pp_type t) ^ ";\n" ^ (pp_vars l)
 
     and pp_vars nil = ""
       | pp_vars ((i, t)::l) = "var " ^ (pp_ident i) ^ " : " ^ (pp_type t) ^ ";\n" ^ (pp_vars l)
 

-    and pp_function (Extern(t, n, pl)) = "extern " ^ (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ");\n"
-      | pp_function (Function(t, n, 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 " ^ (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"
+      | 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 (p) = String.concat (map pp_function p)
+    and pp_program (types, funs) = String.concat ((map 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
new file mode 100644 (file)
index 0000000..72bdaeb
--- /dev/null
+++ b/parse/astutils.sml
@@ -0,0 +1,107 @@
+signature ASTUTILS =
+sig    
+  structure Program :
+  sig
+    val append_typedef : Ast.program -> (Ast.ident * Ast.typedef) -> Ast.program
+    val append_function : Ast.program -> (Ast.ident * Ast.function) -> Ast.program
+  end
+  
+  structure Typedef :
+  sig
+    val data : Ast.typedef -> Ast.typedef
+    val mark : Ast.typedef -> Mark.ext option
+  end
+  
+  structure Function :
+  sig
+    val data : Ast.function -> Ast.function
+    val mark : Ast.function -> Mark.ext option
+    val returntype : Ast.function -> Ast.vtype
+    val params : Ast.function -> Ast.variable list
+  end
+  
+  structure Type :
+  sig
+    val size : Ast.vtype -> int
+    val issmall : Ast.vtype -> bool
+  end
+end
+
+structure AstUtils :> ASTUTILS =
+struct
+  structure A = Ast
+
+  structure Program =
+  struct
+    fun append_typedef (tds, fns) (i, td) =
+      let
+        val mark = case td
+                   of A.MarkedTypedef m => Mark.ext m
+                    | _ => NONE
+        val _ = case (Symbol.look tds i)
+                of SOME (A.MarkedTypedef m) => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ;
+                                                ErrorMsg.error (Mark.ext m) "(was originally defined here)" ;
+                                                raise ErrorMsg.Error)
+                 | SOME _ => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ;
+                              raise ErrorMsg.Error)
+                 | _ => ()
+     in
+       (Symbol.bind tds (i, td), fns)
+     end
+    fun append_function (tds, fns) (i, func) =
+      let
+        val mark = case func
+                   of A.MarkedFunction m => Mark.ext m
+                    | _ => NONE
+        val _ = case (Symbol.look fns i)
+                of SOME (A.MarkedFunction m) => (ErrorMsg.error mark ("Redefining function " ^ Symbol.name i) ;
+                                                 ErrorMsg.error (Mark.ext m) "(was originally defined here)" ;
+                                                 raise ErrorMsg.Error)
+                 | SOME _ => (ErrorMsg.error mark ("Redefining function " ^ Symbol.name i) ;
+                              raise ErrorMsg.Error)
+                 | _ => ()
+     in
+       (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)
+      | data m = m
+    
+    fun mark (A.MarkedFunction m) = Mark.ext m
+      | mark _ = NONE
+    
+    fun returntype (A.MarkedFunction m) = returntype (Mark.data m)
+      | returntype (A.Function (r, _, _, _)) = r
+      | returntype (A.Extern (r, _)) = r
+    
+    fun params (A.MarkedFunction m) = params (Mark.data m)
+      | 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

diff --git a/parse/l3.grm b/parse/l4.grm
similarity index 62%
rename from parse/l3.grm
rename to parse/l4.grm
index cbf92ea4306768a426f024bb942f7dfc579d7cc0..3f14c331a0c69ea61e14bf378c47e1e0590724a9 100644 (file)
--- a/parse/l3.grm
+++ b/parse/l4.grm
@@ -1,5 +1,5 @@
-(* L3 Compiler
- * L3 grammar
+(* L4 Compiler
+ * L4 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,12 +7,16 @@
  *)
 
 structure A = Ast
  *)
 
 structure A = Ast

+structure AU = AstUtils
+structure AUP = AstUtils.Program

 
 (* for simplicity, we only mark expressions, not statements *)
 
 (* mark e with region (left, right) in source file *)
 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)))
 
 (* for simplicity, we only mark expressions, not statements *)
 
 (* mark e with region (left, right) in source file *)
 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)))

 
 (* 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 *)


@@ -22,19 +26,8 @@ fun make_lval (A.Var(id)) ext = id
   | make_lval _ ext = ( ErrorMsg.error ext "not a variable" ;
                        Symbol.bogus )
 
   | make_lval _ ext = ( ErrorMsg.error ext "not a variable" ;
                        Symbol.bogus )
 

-(* expand_asnop (exp1, "op=", exp2) region = "exp1 = exp1 op exps"
- * or = "exp1 = exp2" if asnop is "="
- * generates error if exp1 is an lval (identifier)
- * syntactically expands a compound assignment operator
- *)
-fun expand_asnop (exp1, NONE, exp2) (left, right) =
-      A.Assign(make_lval exp1 NONE, exp2)
-  | expand_asnop (exp1, SOME(oper), exp2) (left, right) =
-      A.Assign(make_lval exp1 NONE,
-              mark(A.OpExp(oper, [exp1, exp2]), (left, right)))
-

 %%
 %%

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

 
 %term 
    EOF
 
 %term 
    EOF


@@ -49,10 +42,11 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) =
  | LBRACE | RBRACE
  | LPAREN | RPAREN
  | UNARY | ASNOP (* dummy *)
  | LBRACE | RBRACE
  | LPAREN | RPAREN
  | UNARY | ASNOP (* dummy *)

- | EXTERN | VAR | INT | COLON | COMMA
+ | EXTERN | VAR | INT | COLON | COMMA | STRUCT | NULL | LBRACKET | RBRACKET | ARROW | DOT | NEW

 
 %nonterm 
    program of A.program
 
 %nonterm 
    program of A.program

+ | programx of A.program

  | stms of A.stm list
  | stm of A.stm
  | simp of A.stm
  | stms of A.stm list
  | stm of A.stm
  | simp of A.stm


@@ -60,18 +54,20 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) =
  | exp of A.exp
  | explist of A.exp list
  | control of A.stm
  | exp of A.exp
  | explist of A.exp list
  | control of A.stm

- | asnop of A.oper option
+ | asnop of A.oper

  | block of A.stm list
  | simpoption of A.stm option
  | elseoption of A.stm list option
  | idents of A.ident list
  | vtype of A.vtype
  | block of A.stm list
  | simpoption of A.stm option
  | elseoption of A.stm list option
  | idents of A.ident list
  | vtype of A.vtype

- | extdecls of A.function list
- | extdecl of A.function
+ | decls of A.program
+ | extdecl of A.ident * A.function

  | paramlist of A.variable list
  | param of A.variable
  | paramlist of A.variable list
  | param of A.variable

- | functions of A.function list
- | function of A.function
+ | typedecl of A.ident * A.typedef
+ | memberlist of (A.ident * A.vtype) list
+ | member of (A.ident * A.vtype)
+ | function of A.ident * A.function

  | vardecl of A.variable list
  | vardecls of A.variable list
 
  | vardecl of A.variable list
  | vardecls of A.variable list
 


@@ -81,7 +77,7 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) =
 %eop EOF
 %noshift EOF
 
 %eop EOF
 %noshift EOF
 

-%name L3
+%name L4

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


@@ -94,36 +90,49 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) =
 %left PLUS MINUS
 %left STAR SLASH PERCENT
 %right UNARY
 %left PLUS MINUS
 %left STAR SLASH PERCENT
 %right UNARY

-%left LPAREN
+%left LPAREN LBRACKET ARROW DOT

 
 %%
 
 
 %%
 

-program    : extdecls functions     (extdecls @ functions)
+program    : programx               (programx)
+
+programx   : decls                  (decls)
+           | programx function      (AUP.append_function programx function)

 
 vtype      : INT                    (A.Int)
 
 vtype      : INT                    (A.Int)

+           | IDENT                  (A.Typedef IDENT)
+           | vtype STAR             (A.Pointer vtype)
+           | vtype LBRACKET RBRACKET
+                                    (A.Array vtype)

 
 

-extdecls   :                        ([])
-           | extdecl extdecls       (extdecl :: extdecls)
+decls      :                        (Symbol.empty, Symbol.empty)
+           | typedecl decls         (AUP.append_typedef decls typedecl)
+           | extdecl decls          (AUP.append_function decls extdecl)

 
 extdecl    : EXTERN vtype IDENT LPAREN RPAREN SEMI
 
 extdecl    : EXTERN vtype IDENT LPAREN RPAREN SEMI

-                                    (A.Extern (vtype, IDENT, []))
-           | EXTERN vtype IDENT LPAREN param RPAREN SEMI
-                                    (A.Extern (vtype, IDENT, [param]))
+                                    (IDENT, markfunction (A.Extern (vtype, []), (EXTERNleft, SEMIright)))

            | EXTERN vtype IDENT LPAREN paramlist RPAREN SEMI
            | EXTERN vtype IDENT LPAREN paramlist RPAREN SEMI

-                                    (A.Extern (vtype, IDENT, paramlist))
+                                    (IDENT, markfunction (A.Extern (vtype, paramlist), (EXTERNleft, SEMIright)))

 
 paramlist  : param COMMA paramlist  (param :: paramlist)
            | param                  ([param])
 
 param      : IDENT COLON vtype      (IDENT, vtype)
 
 
 paramlist  : param COMMA paramlist  (param :: paramlist)
            | param                  ([param])
 
 param      : IDENT COLON vtype      (IDENT, vtype)
 

-functions  :                        ([])
-           | function functions     (function :: functions)
+typedecl   : STRUCT IDENT LBRACE RBRACE SEMI
+                                    (IDENT, marktypedef (A.Struct ([]), (STRUCTleft, SEMIright)))
+           | STRUCT IDENT LBRACE memberlist RBRACE SEMI
+                                    (IDENT, marktypedef (A.Struct (memberlist), (STRUCTleft, SEMIright)))
+
+memberlist : member memberlist      (member :: memberlist)
+           | member                 ([member])
+
+member     : IDENT COLON vtype SEMI (IDENT, vtype)

 
 

-function   : vtype IDENT LPAREN RPAREN LBRACE vardecls stms RBRACE
-                                    (A.Function (vtype, IDENT, [], vardecls, stms))
-           | vtype IDENT LPAREN paramlist RPAREN LBRACE vardecls stms RBRACE
-                                    (A.Function (vtype, IDENT, paramlist, vardecls, stms))
+function   : vtype IDENT LPAREN paramlist RPAREN LBRACE vardecls stms RBRACE
+                                    (IDENT, markfunction (A.Function (vtype, paramlist, vardecls, stms), (vtypeleft, RBRACEright)))
+           | vtype IDENT LPAREN RPAREN LBRACE vardecls stms RBRACE
+                                    (IDENT, markfunction (A.Function (vtype, [], vardecls, stms), (vtypeleft, RBRACEright)))

 
 vardecls   :                        ([])
            | vardecl vardecls       (vardecl @ vardecls)
 
 vardecls   :                        ([])
            | vardecl vardecls       (vardecl @ vardecls)


@@ -141,8 +150,11 @@ stm        : simp SEMI              (simp)
            | control                (control)
            | SEMI                   (A.Nop)
 
            | control                (control)
            | SEMI                   (A.Nop)
 

-simp       : exp asnop exp %prec ASNOP
-                                    (expand_asnop (exp1, asnop, exp2) (exp1left, exp2right))
+simp       : exp ASSIGN exp %prec ASNOP
+                                    (A.Assign(exp1, exp2))
+           | exp asnop exp %prec ASNOP
+                                    (A.AsnOp(asnop, exp1, exp2))
+           | exp                    (markstm (A.Effect (exp), (expleft, expright)))

 
 control    : IF LPAREN exp RPAREN block elseoption
                                     (markstm ((A.If (exp, block, elseoption)), (IFleft, elseoptionright)))
 
 control    : IF LPAREN exp RPAREN block elseoption
                                     (markstm ((A.If (exp, block, elseoption)), (IFleft, elseoptionright)))


@@ -166,6 +178,11 @@ block      : stm                    ([stm])
 exp        : LPAREN exp RPAREN      (exp)
            | INTNUM                 (mark (A.ConstExp(INTNUM),(INTNUMleft,INTNUMright)))
            | IDENT                  (mark (A.Var(IDENT), (IDENTleft,IDENTright)))
 exp        : LPAREN exp RPAREN      (exp)
            | INTNUM                 (mark (A.ConstExp(INTNUM),(INTNUMleft,INTNUMright)))
            | IDENT                  (mark (A.Var(IDENT), (IDENTleft,IDENTright)))

+           | exp DOT IDENT          (mark (A.Member(exp, IDENT), (expleft, IDENTright)))
+           | exp ARROW IDENT        (mark (A.DerefMember(exp, IDENT), (expleft, IDENTright)))
+           | STAR exp %prec UNARY   (mark (A.Dereference(exp), (STARleft, expright)))
+           | exp LBRACKET exp RBRACKET
+                                    (mark (A.ArrIndex(exp1, exp2), (exp1left, exp2right)))

            | exp PLUS exp           (mark (A.OpExp (A.PLUS, [exp1,exp2]), (exp1left,exp2right)))
            | exp MINUS exp          (mark (A.OpExp (A.MINUS, [exp1,exp2]), (exp1left,exp2right)))
            | exp STAR exp           (mark (A.OpExp (A.TIMES, [exp1,exp2]), (exp1left,exp2right)))
            | exp PLUS exp           (mark (A.OpExp (A.PLUS, [exp1,exp2]), (exp1left,exp2right)))
            | exp MINUS exp          (mark (A.OpExp (A.MINUS, [exp1,exp2]), (exp1left,exp2right)))
            | exp STAR exp           (mark (A.OpExp (A.TIMES, [exp1,exp2]), (exp1left,exp2right)))


@@ -184,11 +201,14 @@ exp        : LPAREN exp RPAREN      (exp)
            | exp LE exp             (mark (A.OpExp (A.LE, [exp1,exp2]), (exp1left,exp2right)))
            | exp GT exp             (mark (A.OpExp (A.GT, [exp1,exp2]), (exp1left,exp2right)))
            | exp GE exp             (mark (A.OpExp (A.GE, [exp1,exp2]), (exp1left,exp2right)))
            | exp LE exp             (mark (A.OpExp (A.LE, [exp1,exp2]), (exp1left,exp2right)))
            | exp GT exp             (mark (A.OpExp (A.GT, [exp1,exp2]), (exp1left,exp2right)))
            | exp GE exp             (mark (A.OpExp (A.GE, [exp1,exp2]), (exp1left,exp2right)))

+           | NULL                   (mark (A.Null, (NULLleft, NULLright)))

            | IDENT LPAREN RPAREN    (mark (A.FuncCall(IDENT, []), (IDENTleft, RPARENright)))
            | IDENT LPAREN RPAREN    (mark (A.FuncCall(IDENT, []), (IDENTleft, RPARENright)))

-           | IDENT LPAREN exp RPAREN
-                                    (mark (A.FuncCall(IDENT, [exp]), (IDENTleft, RPARENright)))

            | IDENT LPAREN explist RPAREN
                                     (mark (A.FuncCall(IDENT, explist), (IDENTleft, RPARENright)))
            | IDENT LPAREN explist RPAREN
                                     (mark (A.FuncCall(IDENT, explist), (IDENTleft, RPARENright)))

+           | NEW LPAREN vtype RPAREN
+                                    (mark (A.New (vtype), (NEWleft, RPARENright)))
+           | NEW LPAREN vtype LBRACKET exp RBRACKET RPAREN
+                                    (mark (A.NewArr (vtype, exp), (NEWleft, RPARENright)))

            | 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)))


@@ -196,14 +216,13 @@ exp        : LPAREN exp RPAREN      (exp)
 explist    : exp                    ([exp])
            | exp COMMA explist      (exp :: explist)
 
 explist    : exp                    ([exp])
            | exp COMMA explist      (exp :: explist)
 

-asnop      : ASSIGN                (NONE)
-           | PLUSEQ                (SOME(A.PLUS))
-           | MINUSEQ               (SOME(A.MINUS))
-           | STAREQ                (SOME(A.TIMES))
-           | SLASHEQ               (SOME(A.DIVIDEDBY))
-           | PERCENTEQ             (SOME(A.MODULO))
-           | LSHEQ                 (SOME(A.LSH))
-           | RSHEQ                 (SOME(A.RSH))
-           | BITOREQ               (SOME(A.BITOR))
-           | BITANDEQ              (SOME(A.BITAND))
-           | BITXOREQ              (SOME(A.BITXOR))
+asnop      : PLUSEQ                (A.PLUS)
+           | MINUSEQ               (A.MINUS)
+           | STAREQ                (A.TIMES)
+           | SLASHEQ               (A.DIVIDEDBY)
+           | PERCENTEQ             (A.MODULO)
+           | LSHEQ                 (A.LSH)
+           | RSHEQ                 (A.RSH)
+           | BITOREQ               (A.BITOR)
+           | BITANDEQ              (A.BITAND)
+           | BITXOREQ              (A.BITXOR)

diff --git a/parse/l3.lex b/parse/l4.lex
similarity index 91%
rename from parse/l3.lex
rename to parse/l4.lex
index d9c2217876c5e16338a8463a6a09bed4c6c20e5e..b988c3548851c533e6bb2215a7380305a961e7ca 100644 (file)
--- a/parse/l3.lex
+++ b/parse/l4.lex
@@ -1,4 +1,4 @@
-(* L3 Compiler
+(* L4 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>


@@ -51,7 +51,7 @@ in
 end
 
 %%
 end
 
 %%

-%header (functor L3LexFn(structure Tokens : L3_TOKENS));
+%header (functor L4LexFn(structure Tokens : L4_TOKENS));

 %full
 %s COMMENT COMMENT_LINE;
 
 %full
 %s COMMENT COMMENT_LINE;
 


@@ -108,6 +108,11 @@ ws = [\ \t\012];
 <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));
 

+<INITIAL> "["         => (Tokens.LBRACKET (yypos, yypos + size yytext));
+<INITIAL> "]"         => (Tokens.RBRACKET (yypos, yypos + size yytext));
+<INITIAL> "->"        => (Tokens.ARROW (yypos, yypos + size yytext));
+<INITIAL> "."         => (Tokens.DOT (yypos, yypos + size yytext));
+

 <INITIAL> "return"    => (Tokens.RETURN (yypos, yypos + size yytext));
 <INITIAL> "if"        => (Tokens.IF (yypos, yypos + size yytext));
 <INITIAL> "while"     => (Tokens.WHILE (yypos, yypos + size yytext));
 <INITIAL> "return"    => (Tokens.RETURN (yypos, yypos + size yytext));
 <INITIAL> "if"        => (Tokens.IF (yypos, yypos + size yytext));
 <INITIAL> "while"     => (Tokens.WHILE (yypos, yypos + size yytext));


@@ -118,6 +123,9 @@ ws = [\ \t\012];
 <INITIAL> "var"       => (Tokens.VAR (yypos, yypos + size yytext));
 <INITIAL> "int"       => (Tokens.INT (yypos, yypos + size yytext));
 <INITIAL> "extern"    => (Tokens.EXTERN (yypos, yypos + size yytext));
 <INITIAL> "var"       => (Tokens.VAR (yypos, yypos + size yytext));
 <INITIAL> "int"       => (Tokens.INT (yypos, yypos + size yytext));
 <INITIAL> "extern"    => (Tokens.EXTERN (yypos, yypos + size yytext));

+<INITIAL> "struct"    => (Tokens.STRUCT (yypos, yypos + size yytext));
+<INITIAL> "NULL"      => (Tokens.NULL (yypos, yypos + size yytext));
+<INITIAL> "new"       => (Tokens.NEW (yypos, yypos + size yytext));

 
 
 <INITIAL> {decnum}    => (number (yytext, yypos));
 
 
 <INITIAL> {decnum}    => (number (yytext, yypos));

diff --git a/parse/parse.sml b/parse/parse.sml
index aa701c41c89903b298b0f40d0c8aae4d3fb544d0..3786421ef2388a9f3e6b9c1e1c52fa7d548651e1 100644 (file)
--- a/parse/parse.sml
+++ b/parse/parse.sml
@@ -1,4 +1,4 @@
-(* L3 Compiler
+(* L4 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 L3LrVals = L3LrValsFn (structure Token = LrParser.Token)
-  structure L3Lex = L3LexFn (structure Tokens = L3LrVals.Tokens)
-  structure L3Parse = Join (structure ParserData = L3LrVals.ParserData
-                            structure Lex = L3Lex
+  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 LrParser = LrParser)
 
   (* Main parsing function *)
                             structure LrParser = LrParser)
 
   (* Main parsing function *)


@@ -31,9 +31,9 @@ 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

-                         (L3Lex.makeLexer (fn _ => TextIO.input instream))
+                         (L4Lex.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, _) = L3Parse.parse(0, lexer, parseerror, ())
+         val (absyn, _) = L4Parse.parse(0, lexer, parseerror, ())

           val _ = if !ErrorMsg.anyErrors
                  then raise ErrorMsg.Error
                  else ()
           val _ = if !ErrorMsg.anyErrors
                  then raise ErrorMsg.Error
                  else ()

diff --git a/sources.cm b/sources.cm
index 3dd6fa104e268220fdf873996a58675e5d1cecf0..351df5f4f65b4a35b7bb4543b056840df11d024d 100644 (file)
--- a/sources.cm
+++ b/sources.cm
@@ -11,9 +11,10 @@ Group is
         util/word32.sml
 
        parse/ast.sml
         util/word32.sml
 
        parse/ast.sml

+       parse/astutils.sml

        parse/parsestate.sml
        parse/parsestate.sml

-       parse/l3.lex
-       parse/l3.grm
+       parse/l4.lex
+       parse/l4.grm

        parse/parse.sml
 
        type/typechecker.sml
        parse/parse.sml
 
        type/typechecker.sml


@@ -26,7 +27,6 @@ Group is
 
        codegen/x86.sml
        codegen/codegen.sml
 
        codegen/x86.sml
        codegen/codegen.sml

-

        codegen/igraph.sml
        codegen/colororder.sml
        codegen/solidify.sml
        codegen/igraph.sml
        codegen/colororder.sml
        codegen/solidify.sml

diff --git a/sources.mlb b/sources.mlb
index d97bba40edc4fbd28f9435834238e84b8a842112..0f45274624517d5501567f0a5a45ac3d1bb28c0d 100644 (file)
--- a/sources.mlb
+++ b/sources.mlb
@@ -10,10 +10,11 @@ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
         util/word32.sml
 
        parse/ast.sml
         util/word32.sml
 
        parse/ast.sml

+       parse/astutils.sml

        parse/parsestate.sml
        parse/parsestate.sml

-       parse/l3.grm.sig
-       parse/l3.grm.sml
-       parse/l3.lex.sml
+       parse/l4.grm.sig
+       parse/l4.grm.sml
+       parse/l4.lex.sml

        parse/parse.sml
 
        type/typechecker.sml
        parse/parse.sml
 
        type/typechecker.sml

diff --git a/top/top.sml b/top/top.sml
index 5e564b18ad2e487f26b9b2d6b7ec557dd607a94d..c350c094c898d4002af110839f7415a77bd94251 100644 (file)
--- a/top/top.sml
+++ b/top/top.sml
@@ -73,18 +73,18 @@ struct
   
   fun processir externs (Tree.FUNCTION (id, ir)) =
       let
   
   fun processir externs (Tree.FUNCTION (id, ir)) =
       let

-        val name = "_l3_" ^ (Symbol.name id)
+        val name = "_l4_" ^ (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 "_l3_" ^ s
+                         else "_l4_" ^ s

       
         val _ = Flag.guard flag_verbose say ("Processing function: " ^ name)
 
         val _ = Flag.guard flag_verbose say "  Generating proto-x86_64 code..."
         val assem = Codegen.codegen ir
         val _ = Flag.guard flag_assem
       
         val _ = Flag.guard flag_verbose say ("Processing function: " ^ name)
 
         val _ = Flag.guard flag_verbose say "  Generating proto-x86_64 code..."
         val assem = Codegen.codegen ir
         val _ = Flag.guard flag_assem

-                  (fn () => List.app (TextIO.print o (x86.prettyprint x86.Long)) assem) ()
+                  (fn () => List.app (TextIO.print o (x86.prettyprint)) assem) ()

 
         val _ = Flag.guard flag_verbose say "  Analyzing liveness..."
         val (preds, liveness) = Liveness.liveness assem;
 
         val _ = Flag.guard flag_verbose say "  Analyzing liveness..."
         val (preds, liveness) = Liveness.liveness assem;


@@ -93,7 +93,7 @@ struct
                     (fn (asm, liv) =>
                       TextIO.print (
                         let
                     (fn (asm, liv) =>
                       TextIO.print (
                         let

-                          val xpp = x86.prettyprint x86.Long asm
+                          val xpp = x86.prettyprint 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


@@ -116,10 +116,10 @@ struct
                   (fn () => List.app (TextIO.print o
                     (fn (t, i) =>
                       (Temp.name t) ^ " => " ^ (
                   (fn () => List.app (TextIO.print o
                     (fn (t, i) =>
                       (Temp.name t) ^ " => " ^ (

-                        if (i <= x86.regtonum x86.R14D)
+                        if (i <= x86.regtonum x86.R13D)

                           then (x86.prettyprint_oper x86.Long (x86.REG (x86.numtoreg i)))
                         else
                           then (x86.prettyprint_oper x86.Long (x86.REG (x86.numtoreg i)))
                         else

-                          "spill[" ^ Int.toString (i - x86.regtonum x86.R14D) ^ "]")
+                          "spill[" ^ Int.toString (i - x86.regtonum x86.R13D) ^ "]")

                         ^ "--"^ Int.toString i ^ "\n"))
                     colors) ()
 
                         ^ "--"^ Int.toString i ^ "\n"))
                     colors) ()
 


@@ -165,22 +165,25 @@ struct
 
         val _ = Flag.guard flag_verbose say ("Parsing... " ^ source)
         val ast = Parse.parse source
 
         val _ = Flag.guard flag_verbose say ("Parsing... " ^ source)
         val ast = Parse.parse source

+        val (_, funcs) = ast

         val _ = Flag.guard flag_ast
                   (fn () => say (Ast.Print.pp_program ast)) ()
         val _ = Flag.guard flag_ast
                   (fn () => say (Ast.Print.pp_program ast)) ()

-        
-        val externs = List.mapPartial 
-                        (fn (Ast.Function _) => NONE
-                          | (Ast.Extern (_, s, _)) => SOME (Symbol.name s)) ast
-        
+
+        val externs = Symbol.mapPartiali
+                        (fn (a, b) => case (AstUtils.Function.data b)
+                                      of Ast.Extern _ => SOME(Symbol.name a)
+                                       | _ => NONE
+                        ) funcs
+

         val _ = Flag.guard flag_verbose say "Checking..."
         val ast = TypeChecker.typecheck ast
         val _ = Flag.guard flag_verbose say "Checking..."
         val ast = TypeChecker.typecheck ast

-        
+

         val _ = Flag.guard flag_verbose say "Translating..."
         val ir = Trans.translate ast
         val _ = Flag.guard flag_ir (fn () => say (Tree.Print.pp_program ir)) ()
         
         val _ = Flag.guard flag_verbose say "Translating..."
         val ir = Trans.translate ast
         val _ = Flag.guard flag_ir (fn () => say (Tree.Print.pp_program ir)) ()
         

-        val output = foldr (fn (func, code) => (processir externs func) ^ code) 
-          (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 L3 compiler by czl@ and jwise@\"\n") ir
+        val output = foldr (fn (func, code) => (processir ("calloc" (* lololololol *) :: (Symbol.elems externs)) func) ^ code) 
+          (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 L4 compiler by czl@ and jwise@\"\n") ir

 
         val afname = stem source ^ ".s"
         val _ = Flag.guard flag_verbose say ("Writing assembly to " ^ afname ^ " ...")
 
         val afname = stem source ^ ".s"
         val _ = Flag.guard flag_verbose say ("Writing assembly to " ^ afname ^ " ...")

diff --git a/trans/temp.sml b/trans/temp.sml
index d370d99ccd470eb1c341697127bc7bf49e56996f..1092dfcc3e64099cc0e47d733da709897f632d43 100644 (file)
--- a/trans/temp.sml
+++ b/trans/temp.sml
@@ -10,26 +10,28 @@ sig
   type temp
 
   val reset : unit -> unit     (* resets temp numbering *)
   type temp
 
   val reset : unit -> unit     (* resets temp numbering *)

-  val new : string -> temp     (* returns a unique new temp *)
+  val new : string -> int -> temp      (* returns a unique new temp *)

   val name : temp -> string    (* returns the name of a temp *)
   val name : temp -> string    (* returns the name of a temp *)

+  val size : temp -> int       (* returns the size of a temp *)

   val compare : temp * temp -> order (* comparison function *)
   val eq : temp * temp -> bool
 end
 
 structure Temp :> TEMP = 
 struct
   val compare : temp * temp -> order (* comparison function *)
   val eq : temp * temp -> bool
 end
 
 structure Temp :> TEMP = 
 struct

-  type temp = int * string
+  type temp = int * string * int

 
   local
     val counter = ref 1
   in
     (* warning: calling reset() may jeopardize uniqueness of temps! *)
     fun reset () = ( counter := 1 )
 
   local
     val counter = ref 1
   in
     (* warning: calling reset() may jeopardize uniqueness of temps! *)
     fun reset () = ( counter := 1 )

-    fun new str = (!counter, str) before ( counter := !counter + 1 )
+    fun new str size = (!counter, str, size) before ( counter := !counter + 1 )

   end
 
   end
 

-  fun name (t,s) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]"
-  fun compare ((t1,_),(t2,_)) = Int.compare (t1,t2)
+  fun name (t,s, sz) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]"
+  fun size (t, s, sz) = sz
+  fun compare ((t1,_,_),(t2,_,_)) = Int.compare (t1,t2)

 
 

-  fun eq ((t1,_), (t2,_)) = t1 = t2
+  fun eq ((t1,_,_), (t2,_,_)) = t1 = t2

 end
 end

diff --git a/trans/trans.sml b/trans/trans.sml
index 80802be332d71daf4744d4458e2da0e93f7850d8..6148ce82454349bb725d3f90267d49013e7a8486 100644 (file)
--- a/trans/trans.sml
+++ b/trans/trans.sml
@@ -17,6 +17,7 @@ structure Trans :> TRANS =
 struct
 
   structure A = Ast
 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


@@ -39,31 +40,156 @@ struct
     | trans_oper A.GT = T.GT
     | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"
 
     | trans_oper A.GT = T.GT
     | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"
 

-  fun translate p =
+  fun translate (defs, funcs) =

     let
     let

-      val allfuncs = foldr (fn (A.Extern(_),b) => b
-                             | (A.Function(_, id, _, _, _), b) => Symbol.bind b (id, () ))
-                           Symbol.empty p
+      val funclist = Symbol.elemsi funcs
+
+      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')) =
+        let
+          val shit = Symbol.look' defs id'
+          fun eat (A.Struct(l)) = l
+            | eat (A.MarkedTypedef(a)) = eat (Mark.data a)
+          fun offset_s' ((id1,t)::l') curofs =
+            let
+              val a = align t curofs
+            in
+              if Symbol.compare(id,id1) = EQUAL
+                then a
+              else offset_s' l' (a + sizeof_v t)
+            end
+            | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"
+        in
+          offset_s' (eat shit) 0
+        end
+        | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
+      
+      fun type_s id (A.Typedef id') =
+        let
+          val td = 
+            case AU.Typedef.data (Symbol.look' defs id')
+            of A.Struct d => d
+             | _ => raise ErrorMsg.InternalError "data didn't return struct"
+          fun type_s' ((id',t)::l) =
+            if (Symbol.compare (id, id') = EQUAL)
+            then t
+            else type_s' l
+            | type_s' nil = raise ErrorMsg.InternalError "struct member not found in type_s"
+        in
+          type_s' td
+        end
+        | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
+      
+      fun deref (A.Pointer i) = i
+        | deref (A.Array i) = i
+        | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer"

 
       fun trans_unop A.NEGATIVE = T.NEG
         | trans_unop A.BITNOT = T.BITNOT
         | trans_unop A.BANG = T.BANG
         | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"
 
       fun trans_unop A.NEGATIVE = T.NEG
         | trans_unop A.BITNOT = T.BITNOT
         | trans_unop A.BANG = T.BANG
         | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"

+      
+      fun typeof' vartypes exp = TypeChecker.typeof (defs, funcs) vartypes NONE exp

 
 

-      fun trans_exp env (A.Var(id)) =
+      fun trans_exp env vartypes (A.Var(id)) =

         (* after type-checking, id must be declared; do not guard lookup *)
             T.TEMP (Symbol.look' env id)
         (* after type-checking, id must be declared; do not guard lookup *)
             T.TEMP (Symbol.look' env id)

-        | trans_exp env (A.ConstExp c) = T.CONST(c)
-        | trans_exp env (A.OpExp(oper, [e1, e2])) =
-            T.BINOP(trans_oper oper, trans_exp env e1, trans_exp env e2)
-        | trans_exp env (A.OpExp(oper, [e])) =
-            T.UNOP(trans_unop oper, trans_exp env e)
-        | trans_exp env (A.OpExp(oper, _)) =
+        | trans_exp env vartypes (A.ConstExp c) = T.CONST(c)
+        | trans_exp env vartypes (A.OpExp(oper, [e1, e2])) =
+            T.BINOP(trans_oper oper, trans_exp env vartypes e1, trans_exp env vartypes e2)
+        | trans_exp env vartypes (A.OpExp(oper, [e])) =
+            T.UNOP(trans_unop oper, trans_exp env vartypes e)
+        | trans_exp env vartypes (A.OpExp(oper, _)) =

             raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"
             raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"

-        | trans_exp env (A.Marked(marked_exp)) =
-            trans_exp env (Mark.data marked_exp)
-        | trans_exp env (A.FuncCall(func, stms)) =
-            T.CALL(func, List.map (trans_exp env) stms)
+        | trans_exp env vartypes (A.Marked(marked_exp)) =
+            trans_exp env vartypes (Mark.data marked_exp)
+        | 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)))
+                stms,
+              AU.Type.size (AU.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))))
+            in
+             if (AU.Type.issmall (type_s id (typeof' vartypes exp)))
+             then T.MEMORY(apk)
+             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)
+            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))))))
+            in
+              if (AU.Type.issmall (deref (typeof' vartypes exp1)))
+              then T.MEMORY(asubk)
+              else asubk
+            end
+        | trans_exp env vartypes (A.New(tipo)) =
+            T.ALLOC(T.CONST (Word32.fromInt(sizeof_v tipo)))
+        | 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)

 
         (* anything else should be impossible *)
 
 
         (* anything else should be impossible *)
 


@@ -72,115 +198,123 @@ 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 ls (A.Assign(id,e)::stms) =
+      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)
+        | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) =

           let
           let

-            val t = Symbol.look' vars id handle Option => raise ErrorMsg.InternalError "Undeclared variable, should have been caught in typechecker..."
-            val remainder = trans_stms vars ls stms
+            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)

           in
           in

-            T.MOVE(T.TEMP(t), trans_exp vars e)
-            :: remainder
+            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)

           end
           end

-        | trans_stms vars ls (A.Return e::stms) =
+        | trans_stms vars vartypes ls (A.Return e::stms) =

           let
           let

-            val remainder = trans_stms vars ls stms
+            val remainder = trans_stms vars vartypes ls stms

           in 
           in 

-            T.RETURN (trans_exp vars e)
+            T.RETURN (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))

             :: remainder
           end
             :: remainder
           end

-        
-        | trans_stms vars ls (A.If(e, s, NONE)::stms) =
+        | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) =

           let
             val l = Label.new ()
           let
             val l = Label.new ()

-            val strans = trans_stms vars ls s
-            val remainder = trans_stms vars ls stms
+            val strans = trans_stms vars vartypes ls s
+            val remainder = trans_stms vars vartypes ls stms

           in
           in

-            (T.JUMPIFN(trans_exp vars e, l)
+            (T.JUMPIFN(trans_exp vars vartypes e, l)

             :: strans
             @ [T.LABEL (l)]
             @ remainder)
           end
             :: strans
             @ [T.LABEL (l)]
             @ remainder)
           end

-        | trans_stms vars ls (A.If(e, s, SOME s2)::stms) =
+        | trans_stms vars vartypes ls (A.If(e, s, SOME s2)::stms) =

           let
             val l = Label.new ()
             val l2 = Label.new ()
           let
             val l = Label.new ()
             val l2 = Label.new ()

-            val s1trans = trans_stms vars ls s
-            val s2trans = trans_stms vars ls s2
-            val remainder = trans_stms vars ls stms
+            val s1trans = trans_stms vars vartypes ls s
+            val s2trans = trans_stms vars vartypes ls s2
+            val remainder = trans_stms vars vartypes ls stms

           in
           in

-            (T.JUMPIFN(trans_exp vars e, l)
+            (T.JUMPIFN(trans_exp vars vartypes e, l)

             :: s1trans
             @ [T.JUMP (l2), T.LABEL (l)]
             @ s2trans
             @ [T.LABEL (l2)]
             @ remainder)
           end
             :: s1trans
             @ [T.JUMP (l2), T.LABEL (l)]
             @ s2trans
             @ [T.LABEL (l2)]
             @ remainder)
           end

-        | trans_stms vars ls (A.For(s1, e, s2, s)::stms) = 
+        | trans_stms vars vartypes ls (A.For(s1, e, s2, s)::stms) = 

           let
             val head = Label.new ()
             val tail = Label.new ()
             val loop = Label.new ()
           let
             val head = Label.new ()
             val tail = Label.new ()
             val loop = Label.new ()

-            val stm1 = if isSome s1 then trans_stms vars NONE [valOf s1] else nil
-            val strans = trans_stms vars (SOME(loop,tail)) s
-            val stm2 = if isSome s2 then trans_stms vars NONE [valOf s2] else nil
-            val remainder = trans_stms vars ls stms
+            val stm1 = if isSome s1 then trans_stms vars vartypes NONE [valOf s1] else nil
+            val strans = trans_stms vars vartypes (SOME(loop,tail)) s
+            val stm2 = if isSome s2 then trans_stms vars vartypes NONE [valOf s2] else nil
+            val remainder = trans_stms vars vartypes ls stms

           in
             (stm1
           in
             (stm1

-            @ [T.LABEL head, T.JUMPIFN(trans_exp vars e, tail)]
+            @ [T.LABEL head, T.JUMPIFN(trans_exp vars vartypes e, tail)]

             @ strans
             @ [T.LABEL loop]
             @ stm2
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end
             @ strans
             @ [T.LABEL loop]
             @ stm2
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end

-        | trans_stms vars ls (A.While(e, s)::stms) =
+        | trans_stms vars vartypes ls (A.While(e, s)::stms) =

           let
             val head = Label.new ()
             val tail = Label.new ()
           let
             val head = Label.new ()
             val tail = Label.new ()

-            val strans = trans_stms vars (SOME(head,tail)) s
-            val remainder = trans_stms vars ls stms
+            val strans = trans_stms vars vartypes (SOME(head,tail)) s
+            val remainder = trans_stms vars vartypes ls stms

           in
             (T.LABEL head
           in
             (T.LABEL head

-            :: T.JUMPIFN(trans_exp vars e, tail)
+            :: T.JUMPIFN(trans_exp vars vartypes e, tail)

             :: strans
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end
             :: strans
             @ [T.JUMP head, T.LABEL tail]
             @ remainder)
           end

-
-        | trans_stms vars (SOME(b,e)) (A.Break::stms) =
+        | 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 (SOME(b,e)) (A.Break::stms) =

           let
           let

-            val remainder = trans_stms vars (SOME(b,e)) stms
+            val remainder = trans_stms vars vartypes (SOME(b,e)) stms

           in
             ((T.JUMP e) :: remainder)
           end
           in
             ((T.JUMP e) :: remainder)
           end

-        | trans_stms vars  NONE       (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
-        | trans_stms vars (SOME(b,e)) (A.Continue::stms) =
+        | trans_stms vars vartypes  NONE       (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
+        | trans_stms vars vartypes (SOME(b,e)) (A.Continue::stms) =

           let
           let

-            val remainder = trans_stms vars (SOME(b,e)) stms
+            val remainder = trans_stms vars vartypes (SOME(b,e)) stms

           in
             ((T.JUMP b) :: remainder)
           end
           in
             ((T.JUMP b) :: remainder)
           end

-        | trans_stms vars  NONE       (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
-        | trans_stms vars ls (A.Nop::stms) = trans_stms vars ls stms
-        | trans_stms vars ls (A.MarkedStm m :: stms) = trans_stms vars ls ((Mark.data m) :: stms)
-        | trans_stms vars _ nil = nil
+        | trans_stms vars vartypes  NONE       (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
+        | trans_stms vars vartypes ls (A.Nop::stms) = trans_stms vars vartypes ls stms
+        | trans_stms vars vartypes ls (A.MarkedStm m :: stms) = trans_stms vars vartypes ls ((Mark.data m) :: stms)
+        | trans_stms vars vartypes _ nil = nil

 
 

-      fun trans_funcs (A.Extern(t, id, varl)::l) = trans_funcs l
-        | trans_funcs (A.Function(t, id, args, vars, body)::l) = 
+      fun trans_funcs ((id, A.Extern(_, _))::l) = trans_funcs l
+        | trans_funcs ((id, A.MarkedFunction a)::l) = trans_funcs ((id, Mark.data a)::l)
+        | trans_funcs ((id, A.Function(t, args, vars, body))::l) =

             let
             let

-              val (a,_) = ListPair.unzip (args @ vars)
-              val allvars = foldr (fn (a,b) => Symbol.bind b (a, Temp.new(Symbol.name(a)))) Symbol.empty a
-              val b = trans_stms allvars NONE body
+              val allvars = foldr
+                              (fn ((name, t),b) =>
+                                Symbol.bind b (name, Temp.new (Symbol.name(name)) (AU.Type.size t)))
+                              Symbol.empty
+                              (args @ vars)
+              val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars)
+              val b = trans_stms allvars vartypes NONE body

               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))
+                (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)))

                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
             end
         | trans_funcs nil = nil
                 numberedargs
             in
               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
             end
         | trans_funcs nil = nil

+

     in
     in

-      trans_funcs p
+      trans_funcs funclist

     end
     end

-

 end
 end

diff --git a/trans/tree.sml b/trans/tree.sml
index f5a92b5a3275451a8c47c123d9e3f1e3d4a5f060..d3e8c0d1ecc4f5869c0a3b5cdcb57dbceed20cc3 100644 (file)
--- a/trans/tree.sml
+++ b/trans/tree.sml
@@ -18,13 +18,16 @@ sig
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp

-    | ARG of Blarg (* I am j4cbo *)
+    | ARG of Blarg * int (* 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 list
+    | CALL of Ast.ident * (exp * int) list * int
+    | MEMORY of exp
+    | ALLOC of exp

   and stm =
   and stm =

-      MOVE of exp * exp
-    | RETURN of exp
+      MOVE of exp * exp * int
+    | RETURN of exp * int
+    | EFFECT of exp * int

     | 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


@@ -52,13 +55,16 @@ struct
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp
   datatype exp = 
       CONST of Word32.word
     | TEMP of Temp.temp

-    | ARG of Blarg
+    | ARG of Blarg * int

     | BINOP of binop * exp * exp
     | UNOP of unop * exp
     | BINOP of binop * exp * exp
     | UNOP of unop * exp

-    | CALL of Ast.ident * exp list
+    | CALL of Ast.ident * (exp * int) list * int
+    | MEMORY of exp
+    | ALLOC of exp

   and stm =
   and stm =

-      MOVE of exp * exp
-    | RETURN of exp
+      MOVE of exp * exp * int
+    | RETURN of exp * int
+    | EFFECT of exp * int

     | 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


@@ -97,18 +103,21 @@ struct
 
     fun pp_exp (CONST(x)) = Word32Signed.toString x
       | pp_exp (TEMP(t)) = Temp.name t
 
     fun pp_exp (CONST(x)) = Word32Signed.toString x
       | pp_exp (TEMP(t)) = Temp.name t

-      | pp_exp (ARG(n)) = "arg#"^Int.toString n
+      | 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 (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)) =
-          Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map pp_exp l)) ^ ")"
+      | 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)) =
+    fun pp_stm (MOVE (e1,e2, sz)) =

          pp_exp e1 ^ "  <--  " ^ pp_exp e2
          pp_exp e1 ^ "  <--  " ^ pp_exp e2

-      | pp_stm (RETURN e) =
+      | pp_stm (RETURN (e, sz)) =

          "return " ^ pp_exp e
          "return " ^ pp_exp e

+      | pp_stm (EFFECT (e, sz)) = pp_exp e

       | pp_stm (LABEL l) =
           Label.name l ^ ":"
       | pp_stm (JUMP l) = 
       | pp_stm (LABEL l) =
           Label.name l ^ ":"
       | pp_stm (JUMP l) = 

diff --git a/type/typechecker.sml b/type/typechecker.sml
index 63608bdb403628faaa4aed2d79e640a2e3476fee..35d2859e214068d1597be973148db5a31541830d 100644 (file)
--- a/type/typechecker.sml
+++ b/type/typechecker.sml
@@ -10,17 +10,150 @@ 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

 end;
 
 structure TypeChecker :> TYPE_CHECK = 
 struct
   structure A = Ast
 end;
 
 structure TypeChecker :> TYPE_CHECK = 
 struct
   structure A = Ast

+  structure AU = AstUtils
+  
+  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.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! *)
+             | (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 ))
+       | 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 => ()
+                                  | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error)))
+                              el ; A.Int)
+       | A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e)
+       | A.FuncCall (i, exps) =>
+         let
+           val func = (case Symbol.look funcs i
+                       of NONE => (ErrorMsg.error mark ("function `"^(Symbol.name i)^"' not declared") ; raise ErrorMsg.Error)
+                        | SOME f => f)
+           val funcmark = AU.Function.mark func
+           val (ftype, fparams) = (AU.Function.returntype func, AU.Function.params func)
+           val exptypes = List.map (fn znt => typeof (tds, funcs) vars mark znt) exps
+           val () = if (length exptypes = length fparams) then ()
+                    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))
+                        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))
+         in
+           ftype
+         end
+       | A.Member (e, i) =>
+         let
+           val t = typeof (tds, funcs) vars mark e
+           val name = case t
+                      of (A.Typedef i) => i
+                       | _ => (ErrorMsg.error mark ("member operation only exists for struct types") ; raise ErrorMsg.Error)
+           val s = case Symbol.look tds name
+                   of SOME s => s
+                    | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
+           val (s, smark) = (AU.Typedef.data s, AU.Typedef.mark s)
+           val vl = case s
+                    of A.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
+                    | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error)
+         in
+           t
+         end
+       | A.DerefMember (e, i) =>
+         let
+           val t = typeof (tds, funcs) vars mark e
+           val name = case t
+                      of (A.Pointer (A.Typedef i)) => i
+                       | _ => (ErrorMsg.error mark ("dereference and member operation only exists for struct pointer types") ; raise ErrorMsg.Error)
+           val s = case Symbol.look tds name
+                   of SOME s => s
+                    | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
+           val (s, smark) = case s
+                            of A.Struct vl => (s, NONE)
+                             | A.MarkedTypedef m => (Mark.data m, Mark.ext m)
+           val vl = case s
+                    of A.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
+                    | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error)
+         in
+           t
+         end
+       | A.Dereference e =>
+         (case typeof (tds, funcs) vars mark e
+          of (A.Pointer e') => e'
+           | _ => (ErrorMsg.error mark ("cannot deference non-pointer type") ; raise ErrorMsg.Error))
+       | A.ArrIndex (e, i) =>
+         (case (typeof (tds, funcs) vars mark e, typeof (tds, funcs) vars mark i)
+          of (A.Array e', A.Int) => e'
+           | (_, A.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error)
+           | _ => (ErrorMsg.error mark ("cannot index using non-int type") ; raise ErrorMsg.Error))
+       | A.New (t) => A.Pointer t
+       | A.NewArr (t, s) =>
+         (case typeof (tds, funcs) vars mark s
+          of A.Int => (A.Array t)
+           | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error))
+       | A.Null => A.TNull
+    )

   
   datatype asn = ASSIGNED | UNASSIGNED
 
   
   datatype asn = ASSIGNED | UNASSIGNED
 

+  (* returncheck prog vars mark t l
+   * Determines if the statement list 'l' is guaranteed to return vtype 't'.
+   * If it ever does not return vtype 't', then raises an error.
+   * true if vtype 't' is always returned, or false if there is a possibility that vtype 't' will not be returned.
+   *)
+  fun returncheck prog vars mark t l =
+    let
+      fun returns' nil = false
+        | returns' (A.Assign _ :: stms) = returns' 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))
+            then true
+            else (ErrorMsg.error mark ("return value of incorrect type for function") ; raise ErrorMsg.Error)
+        | returns' (A.Nop :: stms) = returns' stms
+        | returns' (A.Break :: stms) = true (* blah *)
+        | returns' (A.Continue :: stms) = true (* blah *)
+        | returns' (A.If (_, s1, NONE) :: stms) = returns' stms
+        | returns' (A.If (_, s1, SOME s2) :: stms) = (returns' s1 andalso returns' s2) orelse returns' stms
+        | returns' (A.For _ :: stms) = returns' stms
+        | returns' (A.While _ :: stms) = returns' stms
+        | returns' (A.MarkedStm m :: stms) = returncheck prog vars (Mark.ext m) t (Mark.kane m :: stms)
+    in
+      returns' l
+    end
+  
+  (* returns l
+   * true iff the statement list 'l' always returns.
+   *)

   fun returns nil = false
     | returns (A.Assign _ :: stms) = returns stms
   fun returns nil = false
     | returns (A.Assign _ :: stms) = returns stms

-    | returns (A.Return _ :: stms) = true
+    | returns (A.AsnOp _ :: stms) = returns stms
+    | returns (A.Effect _ :: stms) = returns stms
+    | returns (A.Return e :: stms) = true

     | returns (A.Nop :: stms) = returns stms
     | returns (A.Break :: stms) = true (* blah *)
     | returns (A.Continue :: stms) = true (* blah *)
     | returns (A.Nop :: stms) = returns stms
     | returns (A.Break :: stms) = true (* blah *)
     | returns (A.Continue :: stms) = true (* blah *)


@@ -30,6 +163,9 @@ struct
     | returns (A.While _ :: stms) = returns stms
     | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms)
   
     | returns (A.While _ :: stms) = returns stms
     | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms)
   

+  (* breakcheck l mark
+   * Throws an error exception if a break or continue ever occurs in an illegal context.
+   *)

   fun breakcheck nil mark = ()
     | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ;
                                              raise ErrorMsg.Error )
   fun breakcheck nil mark = ()
     | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ;
                                              raise ErrorMsg.Error )


@@ -45,38 +181,40 @@ struct
     | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
     | breakcheck (_ :: stms) mark = breakcheck stms mark
   
     | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
     | breakcheck (_ :: stms) mark = breakcheck stms mark
   

-  fun varcheck_exp env fenv (A.Var v) mark : Ast.vtype =
+  (* varcheck_exp env exp mark
+   * Throws an error exception if a variable used in this excpression was unassigned or undefined in this context.
+   *)
+  fun varcheck_exp env (A.Var v) mark =

         ( case Symbol.look env v
           of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
                        raise ErrorMsg.Error )
         ( case Symbol.look env v
           of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
                        raise ErrorMsg.Error )

-           | SOME (t, UNASSIGNED) => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;
-                                       raise ErrorMsg.Error )
-           | SOME (t, ASSIGNED) => t)
-    | varcheck_exp env fenv (A.ConstExp _) mark = (A.Int)
-    | varcheck_exp env fenv (A.OpExp (_, l)) mark = (List.app (fn znt => (varcheck_exp env fenv znt mark; ())) l; A.Int)
-    | varcheck_exp env fenv (A.FuncCall (f, l)) mark =
-      let
-        val types = map (fn znt => varcheck_exp env fenv znt mark) l
-        val func = case Symbol.look fenv f
-                     of NONE => ( ErrorMsg.error mark ("undefined function `" ^ Symbol.name f ^ "'") ;
+           | SOME UNASSIGNED => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;

                                   raise ErrorMsg.Error )
                                   raise ErrorMsg.Error )

-                      | SOME a => a
-        val (rtype, params) = case func
-                               of A.Extern (rtype, _, params) => (rtype, params)
-                                | A.Function (rtype, _, params, _, _) => (rtype, params)
-        val paramtypes = map (fn (i, t) => t) params
-        val () = if not (types = paramtypes)
-                 then ( ErrorMsg.error mark ("incorrect parameters for function `" ^ Symbol.name f ^ "'") ;
-                        raise ErrorMsg.Error )
-                 else ()
-      in
-        rtype
-      end
-    | varcheck_exp env fenv (A.Marked m) mark = varcheck_exp env fenv (Mark.kane m) (Mark.ext m)
+           | SOME ASSIGNED => ())
+    | varcheck_exp env (A.ConstExp _) mark = ()
+    | varcheck_exp env (A.OpExp (_, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l
+    | varcheck_exp env (A.FuncCall (f, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l
+    | varcheck_exp env (A.Marked m) mark = varcheck_exp env (Mark.kane m) (Mark.ext m)
+    | varcheck_exp env (A.Member (e, i)) mark = varcheck_exp env e mark
+    | varcheck_exp env (A.DerefMember (e, i)) mark = varcheck_exp env e mark
+    | varcheck_exp env (A.Dereference e) mark = varcheck_exp env e mark
+    | varcheck_exp env (A.ArrIndex (e1, e2)) mark = (varcheck_exp env e1 mark ; varcheck_exp env e2 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 = ()

   
   

+  (* computeassigns env exp
+   * Computes the assigned variables after expression exp has been executed with a starting context of env.
+   *)

   fun computeassigns env nil = env
   fun computeassigns env nil = env

-    | computeassigns env (A.Assign (id,e) :: stms) =
-        computeassigns (Symbol.bind env (id, (A.Int, ASSIGNED))) stms
+    | computeassigns env (A.Assign (A.Var id,e) :: stms) =
+        computeassigns (Symbol.bind env (id, ASSIGNED)) stms
+    | computeassigns env (A.Assign (A.Marked a, e) :: stms) =
+        computeassigns env (A.Assign (Mark.data a, e) :: stms)
+    | computeassigns env (A.AsnOp (oper, a, e) :: stms) =
+        computeassigns env (A.Assign (a, a) :: stms)
+    | computeassigns env (A.Assign (_) :: stms) = computeassigns env stms
+    | computeassigns env (A.Effect _ :: stms) = computeassigns env stms

     | computeassigns env (A.Return _ :: stms) = env
     | computeassigns env (A.Nop :: stms) = computeassigns env stms
     | computeassigns env (A.Break :: stms) = env
     | computeassigns env (A.Return _ :: stms) = env
     | computeassigns env (A.Nop :: stms) = computeassigns env stms
     | computeassigns env (A.Break :: stms) = env


@@ -88,8 +226,8 @@ struct
           val env2 = computeassigns env s2
           val env' =
             Symbol.intersect
           val env2 = computeassigns env s2
           val env' =
             Symbol.intersect

-              (fn ((t, ASSIGNED), (t', ASSIGNED)) => (t, ASSIGNED) (* XXX check types for equality *)
-                | ((t, _), (t', _)) => (t, UNASSIGNED))
+              (fn (ASSIGNED, ASSIGNED) => ASSIGNED
+                | _ => UNASSIGNED)

               (env1, env2)
           val env' =
             if (returns s1) then env2
               (env1, env2)
           val env' =
             if (returns s1) then env2


@@ -109,70 +247,94 @@ struct
        end
     | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
   
        end
     | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
   

-  fun varcheck env fenv nil mark = nil
-    | varcheck env fenv (A.Assign (id, e) :: stms) mark =
+  (* varcheck env l mark
+   * Checks that all variables used in the statement list l have been defined before being used, and removes code that is unreachable according to simple return analysis.
+   *)
+  fun varcheck env nil mark = nil
+    | varcheck env (A.Assign (A.Var id, e) :: stms) mark =

         let
           val sym = Symbol.look env id
           val _ = if not (isSome sym)
                   then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error)
                   else ()
         let
           val sym = Symbol.look env id
           val _ = if not (isSome sym)
                   then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error)
                   else ()

-          val (t, a) = valOf sym
-          val t' = varcheck_exp env fenv e mark
+          val t = valOf sym
+          val _ = varcheck_exp env e mark

         in 
         in 

-          A.Assign (id, e) :: (varcheck (Symbol.bind env (id, (t, ASSIGNED))) fenv stms mark)
+          A.Assign (A.Var id, e) :: (varcheck (Symbol.bind env (id, ASSIGNED)) stms mark)

         end
         end

-    | varcheck env fenv (A.Return (e) :: stms) mark =
-        ( varcheck_exp env fenv e mark;
+    | varcheck env (A.Assign (A.Marked a, e) :: stms) mark = varcheck env (A.Assign (Mark.data a, e) :: stms) mark
+    | varcheck env ((a as A.Assign (A.Member (e', i), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.DerefMember (e', i), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.Dereference e', e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.ArrIndex (e', e''), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e'' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.NewArr (_, e'), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         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.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;

           A.Return (e) :: nil )
           A.Return (e) :: nil )

-    | varcheck env fenv (A.Nop :: stms) mark =
-        ( A.Nop :: (varcheck env fenv stms mark))
-    | varcheck env fenv (A.Break :: stms) mark =
+    | varcheck env (A.Nop :: stms) mark =
+        ( A.Nop :: (varcheck env stms mark))
+    | varcheck env (A.Break :: stms) mark =

         ( A.Break :: nil )
         ( A.Break :: nil )

-    | varcheck env fenv (A.Continue :: stms) mark =
+    | varcheck env (A.Continue :: stms) mark =

         ( A.Continue :: nil )
         ( A.Continue :: nil )

-    | varcheck env fenv (A.If (e, s1, NONE) :: stms) mark =
-        ( varcheck_exp env fenv e mark ;
-          varcheck env fenv s1 mark ;
-          A.If (e, s1, NONE) :: (varcheck env fenv stms mark) )
-    | varcheck env fenv ((i as A.If (e, s1, SOME s2)) :: stms) mark =
-        ( varcheck_exp env fenv e mark ;
-          varcheck env fenv s1 mark ; 
-          varcheck env fenv s2 mark ;
+    | varcheck env (A.If (e, s1, NONE) :: stms) mark =
+        ( varcheck_exp env e mark ;
+          varcheck env s1 mark ;
+          A.If (e, s1, NONE) :: (varcheck env stms mark) )
+    | varcheck env ((i as A.If (e, s1, SOME s2)) :: stms) mark =
+        ( varcheck_exp env e mark ;
+          varcheck env s1 mark ; 
+          varcheck env s2 mark ;

           A.If (e, s1, SOME s2) ::
             (if (returns [i])
              then nil
           A.If (e, s1, SOME s2) ::
             (if (returns [i])
              then nil

-             else varcheck (computeassigns env [i]) fenv stms mark)  )
-    | varcheck env fenv (A.While (e, s1) :: stms) mark =
-        ( varcheck_exp env fenv e mark ;
-          varcheck env fenv s1 mark ;
-          A.While (e, s1) :: (varcheck env fenv stms mark) )
-    | varcheck env fenv (A.For (sbegin, e, sloop, inner) :: stms) mark =
+             else varcheck (computeassigns env [i]) stms mark)  )
+    | varcheck env (A.While (e, s1) :: stms) mark =
+        ( varcheck_exp env e mark ;
+          varcheck env s1 mark ;
+          A.While (e, s1) :: (varcheck env stms mark) )
+    | varcheck env (A.For (sbegin, e, sloop, inner) :: stms) mark =

         let
           val sbegin = case sbegin
         let
           val sbegin = case sbegin

-                       of SOME(s) => SOME (hd (varcheck env fenv [s] mark))
+                       of SOME(s) => SOME (hd (varcheck env [s] mark))

                         | NONE => NONE
           val env' = case sbegin
                      of SOME(s) => computeassigns env [s]
                       | NONE => env
                         | NONE => NONE
           val env' = case sbegin
                      of SOME(s) => computeassigns env [s]
                       | NONE => env

-          val _ = varcheck_exp env' fenv e
-          val inner = varcheck env' fenv inner mark
+          val _ = varcheck_exp env' e
+          val inner = varcheck env' inner mark

           val env'' = computeassigns env' inner
           val sloop = case sloop
           val env'' = computeassigns env' inner
           val sloop = case sloop

-                  of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark))
+                  of SOME(s) => SOME (hd (varcheck env'' [s] mark))

                    | NONE => NONE
         in
                    | NONE => NONE
         in

-          A.For (sbegin, e, sloop, inner) :: (varcheck env' fenv stms mark)
+          A.For (sbegin, e, sloop, inner) :: (varcheck env' stms mark)

         end
         end

-    | varcheck env fenv (A.MarkedStm m :: stms) mark = varcheck env fenv ((Mark.kane m) :: stms) (Mark.ext m)
+    | varcheck env (A.MarkedStm m :: stms) mark = varcheck env ((Mark.kane m) :: stms) (Mark.ext m)

 
 

-  fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,(t, stat))) sym l
-  fun bindfuns sym l =
-    foldr
-      (fn (a as (A.Function (_, id, _, _, _)), s) => Symbol.bind s (id, a)
-        | (a as (A.Extern (_, id, _)), s) => Symbol.bind s (id, a))
-      sym l
+  fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,stat)) sym l
+  fun bindtypes sym l = foldr (fn ((i,t), s) => Symbol.bind s (i,t)) sym l

 
 

-  fun dupchk l =
+  fun dupchk mark l src =

         List.app
           (fn (n, _) =>
             let
         List.app
           (fn (n, _) =>
             let


@@ -182,62 +344,172 @@ struct
             in
               if count = 1
               then ()
             in
               if count = 1
               then ()

-              else ( ErrorMsg.error NONE ("multiple definition of variable " ^ (Symbol.name n));
+              else ( ErrorMsg.error mark ("multiple definition of variable " ^ (Symbol.name n) ^ " in " ^ src);

                      raise ErrorMsg.Error )
             end) l
                      raise ErrorMsg.Error )
             end) l

+  
+  fun check_lvalue prog vars mark (A.Marked m) = check_lvalue prog vars (Mark.ext m) (Mark.data m)
+    | check_lvalue prog vars mark (e as A.Var _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.Member _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.DerefMember _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.Dereference _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.ArrIndex _) = typeof prog vars mark e
+    | check_lvalue prog vars mark _ = ( ErrorMsg.error mark ("invalid lvalue") ; raise ErrorMsg.Error )
+  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))
+         then (ErrorMsg.error mark "incompatible types in assignment" ; raise ErrorMsg.Error )
+         else if not (AU.Type.issmall (check_lvalue prog vars mark e1))
+         then (ErrorMsg.error mark "lvalue is not small" ; raise ErrorMsg.Error)
+         else ()
+     | A.AsnOp (oper, e1, e2) => typecheck_stm prog vars mark (A.Assign (e1, A.OpExp (oper, [e1, e2])))
+     | A.Effect e => 
+         if not (AU.Type.issmall (typeof prog vars mark e))
+         then (ErrorMsg.error mark "simple statement's value not small" ; raise ErrorMsg.Error )
+         else ()
+     | A.Return e => (typeof prog vars mark e ; ())
+     | A.Nop => ()
+     | A.Break => ()
+     | A.Continue => ()
+     | A.If (e, s, NONE) =>
+         if A.castable (A.Int, typeof prog vars mark e)
+         then (List.app (typecheck_stm prog vars mark) s)
+         else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error )
+     | A.If (e, s1, SOME s2) =>
+         if A.castable (A.Int, typeof prog vars mark e)
+         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)
+         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)
+         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) =
+        case (Symbol.look tds t)
+        of SOME _ => ()
+         | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name t)^"' does not exist") ; raise ErrorMsg.Error)

 
 

-  fun typecheck_fn p (e as (A.Extern (t, id, al))) = (dupchk al; e)
-    | typecheck_fn p (A.Function (t, id, al, vl, sl)) =
+  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))
+       then
+         let
+           val n = String.extract (Symbol.name id, 4, NONE)
+         in
+           if List.exists (fn (id, f) => case (AU.Function.data f) of A.Function _ => (Symbol.name id = n) | _ => false) (Symbol.elemsi funcs)
+           then (ErrorMsg.error mark ("you anus, extern " ^ Symbol.name id ^ " conflicts with local function"); raise ErrorMsg.Error)
+           else ()
+         end
+       else () ;
+       dupchk mark al ; 
+       List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) al) ;
+       A.Extern (t, al))
+    | typecheck_fn prog mark (id, A.Function (t, al, vl, sl)) =

       let
       let

-        val () = breakcheck sl NONE
-        val () = if not (returns sl)
-                 then ( ErrorMsg.error NONE ("function `"^ Symbol.name id ^ "' does not return in all cases");
-                        raise ErrorMsg.Error )
-                 else ()
+        val () = dupchk mark (al @ vl) ("function `"^Symbol.name id^"'")       (* Before we do any bindings, check for duplicate names. *)
+        val () = List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) (al @ vl))

         val env = Symbol.empty
         val env = bindvars env ASSIGNED al
         val env = bindvars env UNASSIGNED vl
         val env = Symbol.empty
         val env = bindvars env ASSIGNED al
         val env = bindvars env UNASSIGNED vl

-        val fenv = bindfuns Symbol.empty p
-        val () = dupchk (al @ vl)
+        val vars = Symbol.empty
+        val vars = bindtypes vars al
+        val vars = bindtypes vars vl
+        val () = breakcheck sl mark
+        val () = if not (returncheck prog vars NONE t sl)
+                 then ( ErrorMsg.error mark ("function `"^ Symbol.name id ^ "' does not return in all cases");
+                        raise ErrorMsg.Error )
+                 else ()
+        val () = List.app (
+                  fn (n, t) =>
+                    if (AU.Type.issmall t)
+                    then ()
+                    else ( ErrorMsg.error mark ("variable `"^(Symbol.name n)^"' in function `"^(Symbol.name id)^"' not small") ; raise ErrorMsg.Error))
+                 (al @ vl)
+        val () = List.app (typecheck_stm prog vars mark) sl

       in
       in

-        A.Function (t, id, al, vl, varcheck env fenv sl NONE)
+        A.Function (t, al, vl, varcheck env sl NONE)

       end
       end

+
+  structure SymbolSet = ListSetFn (
+    struct
+      type ord_key = Symbol.symbol
+      val compare = Symbol.compare
+    end
+  )
+  
+  fun typecheck_structs (prog as (tds, funcs)) =
+    let
+      exception Yuq
+      
+      val all = SymbolSet.addList (SymbolSet.empty, Symbol.keys tds)
+      fun lookup mark sym =
+        let
+          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"
+        in
+          (vl, AU.Typedef.mark s)
+        end
+      fun checksym mark sym stack k remaining =
+        if not (SymbolSet.member (remaining, sym))
+        then k remaining
+        else if (SymbolSet.member (stack, sym))
+        then ( ErrorMsg.error mark ("structure `"^ (Symbol.name sym) ^"' is involved in a recursive mess") ; raise Yuq)
+        else
+          let
+            val stack' = SymbolSet.add (stack, sym)
+            val (vl, mark') = lookup mark sym
+            val () = dupchk mark vl ("structure `"^(Symbol.name sym)^"'")
+            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'
+                  | (_, k') => k')
+                (remove k)
+                vl
+          in
+            newk remaining handle Yuq => (ErrorMsg.error mark' ("from structure `"^(Symbol.name sym)^"'") ; raise Yuq)
+          end
+      fun chooseone k set =
+        case (SymbolSet.listItems set)
+        of nil => k set
+         | (h::l) => checksym NONE h SymbolSet.empty (chooseone k) set
+    in
+      chooseone (fn _ => ()) all handle Yuq => raise ErrorMsg.Error
+    end

   
   

-  fun typecheck p =
+  fun typecheck (tds, funcs) =

       let
       let

-        fun getFun n =
-          List.find (fn A.Extern (_, id, _) => ((Symbol.name id) = n)
-                      | A.Function (_, id, _, _, _) => ((Symbol.name id) = n))
-                    p
-        val main = case (getFun "main")
+        val main = case (Symbol.look funcs (Symbol.symbol "main"))

                    of NONE => ( ErrorMsg.error NONE ("no function named main");
                                 raise ErrorMsg.Error )
                     | SOME m => m
                    of NONE => ( ErrorMsg.error NONE ("no function named main");
                                 raise ErrorMsg.Error )
                     | SOME m => m

+        val (main, mainp) = (AU.Function.data main, AU.Function.mark main)

         val () = case main
         val () = case main

-                 of A.Extern _ => ( ErrorMsg.error NONE ("you anus, main can't be an extern");
+                 of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern");

                                     raise ErrorMsg.Error )
                                     raise ErrorMsg.Error )

-                  | A.Function (A.Int, _, nil, _, _) => ()
-                  | A.Function (A.Int, _, _, _, _) => ( ErrorMsg.error NONE ("main should take no parameters");
+                  | A.Function (A.Int, nil, _, _) => ()
+                  | A.Function (A.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters");

                                                         raise ErrorMsg.Error )
                                                         raise ErrorMsg.Error )

-        val () = List.app
-                   (fn a =>
-                      let
-                        val id = case a
-                          of A.Extern (_, id, _) => id
-                           | A.Function (_, id, _, _, _) => id
-                        val name = Symbol.name id
-                        val all = List.filter
-                          (fn A.Extern (_, id, _) => (Symbol.name id) = name
-                            | A.Function (_, id, _, _, _) => (Symbol.name id) = name)
-                          p
-                        val num = length all
-                      in
-                        if num = 1
-                        then ()
-                        else ( ErrorMsg.error NONE ("multiple definition of " ^ name);
-                               raise ErrorMsg.Error )
-                      end) p
+                  | A.Function (_, _, _, _) => ( ErrorMsg.error mainp ("main has incorrect return type");
+                                                 raise ErrorMsg.Error )
+                  | _ => raise ErrorMsg.InternalError "marked of marked disallowed"
+        val () = typecheck_structs (tds, funcs)

       in
       in

-        List.map (typecheck_fn p) p
+        (tds, Symbol.mapi (typecheck_fn (tds, funcs) NONE) funcs)

       end
 end
       end
 end

diff --git a/util/graph.sml b/util/graph.sml
new file mode 100644 (file)
index 0000000..502cd7c
--- /dev/null
+++ b/util/graph.sml
@@ -0,0 +1,40 @@
+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/symbol.sml b/util/symbol.sml
index 87a0ab9c06b219e7c790cfca146e99f709f0c4eb..3111761560c14f517d9d591dc14b606de91e64d0 100644 (file)
--- a/util/symbol.sml
+++ b/util/symbol.sml
@@ -39,6 +39,11 @@ sig
   val elemsi : 'a table -> (symbol * 'a) list (* return the symbols with the associated data *)
   val keys : 'a table -> symbol list (* just the symbols *)
   val intersect : ('a * 'a -> 'a) -> 'a table * 'a table -> 'a table
   val elemsi : 'a table -> (symbol * 'a) list (* return the symbols with the associated data *)
   val keys : 'a table -> symbol list (* just the symbols *)
   val intersect : ('a * 'a -> 'a) -> 'a table * 'a table -> 'a table

+  
+  val mapi : (symbol * 'a -> 'b) -> 'a table -> 'b table
+  val mapPartial : ('a -> 'b option) -> 'a table -> 'b table
+  val mapPartiali : (symbol * 'a -> 'b option) -> 'a table -> 'b table
+  val appi : (symbol * 'a -> unit) -> 'a table -> unit

 
   (* symbol set -- similar to a () Symbol.table, elements can be removed *)
   type set
 
   (* symbol set -- similar to a () Symbol.table, elements can be removed *)
   type set


@@ -105,6 +110,10 @@ struct
   fun elemsi t = Map.listItemsi t
   fun keys t = Map.listKeys t
   fun intersect binding (t1,t2) = Map.intersectWith binding (t1,t2)
   fun elemsi t = Map.listItemsi t
   fun keys t = Map.listKeys t
   fun intersect binding (t1,t2) = Map.intersectWith binding (t1,t2)

+  fun mapi f t = Map.mapi f t
+  fun mapPartial f t = Map.mapPartial f t
+  fun mapPartiali f t = Map.mapPartiali f t
+  fun appi f t = Map.appi f t

 
   fun delimit' [] s = s
     | delimit' [x] s = s ^ x
 
   fun delimit' [] s = s
     | delimit' [x] s = s ^ x