Initial import of l4c
authorJoshua Wise <joshua@h2so4.joshuawise.com>
Thu, 14 May 2009 02:14:37 +0000 (22:14 -0400)
committerJoshua Wise <joshua@h2so4.joshuawise.com>
Thu, 14 May 2009 02:14:37 +0000 (22:14 -0400)
25 files changed:
Makefile
README
bin/l3c [deleted file]
bin/l4c [new file with mode: 0755]
codegen/codegen.sml
codegen/liveness.sml
codegen/peephole.sml
codegen/solidify.sml
codegen/stringifier.sml
codegen/x86.sml
compile-l4c.sml [moved from compile-l3c.sml with 72% similarity]
parse/ast.sml
parse/astutils.sml [new file with mode: 0644]
parse/l4.grm [moved from parse/l3.grm with 62% similarity]
parse/l4.lex [moved from parse/l3.lex with 91% similarity]
parse/parse.sml
sources.cm
sources.mlb
top/top.sml
trans/temp.sml
trans/trans.sml
trans/tree.sml
type/typechecker.sml
util/graph.sml [new file with mode: 0644]
util/symbol.sml

index 88508a2..2cb4352 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,23 +1,24 @@
 # 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.*
+       find . -type f -name '*~' | xargs rm -rf
 
 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
diff --git a/README b/README
index 4c6899b..ccc7581 100644 (file)
--- a/README
+++ b/README
@@ -1,58 +1,53 @@
 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.
 
-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
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 $*
index 8a5afe2..6ee8c2f 100644 (file)
@@ -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.MEMORY m) = true
+    | effect (T.ALLOC(_)) = true
     | 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.ALLOC(_)) = true
+    | hasfixed (T.MEMORY m) = hasfixed m
     | 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)
    *)
-  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.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)
@@ -63,83 +67,85 @@ struct
             | 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 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)
           )
-          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)
           )
-          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
-            (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
-            (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
-            (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 @
-          [ 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.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
-    | 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.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
-          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
-    | 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.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
-          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)]
+(*
     | 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
-          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
-          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
-          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)]
@@ -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
-          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
@@ -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
-          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
@@ -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
-          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
@@ -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
-          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
@@ -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
-          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
@@ -194,8 +200,8 @@ struct
         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))
@@ -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)]
-          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
-          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))
@@ -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)]
-          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
@@ -243,6 +249,15 @@ struct
         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.
@@ -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)) =
-        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)) =
-        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)) =
-        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)) =
-        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
-          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)
@@ -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)) =
-        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)) =
-        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)) =
-        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)) =
-        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
-          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)
@@ -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)) =
-        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)) =
-        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)) =
-        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)) =
-        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
-          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)
@@ -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)) =
-        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)) =
-        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)) =
-        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)) =
-        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
-          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)
@@ -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)) =
-        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)) =
-        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)) =
-        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)) =
-        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
-          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)
@@ -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)) =
-        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)) =
-        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)) =
-        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)) =
-        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
-          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)
@@ -365,62 +380,73 @@ struct
         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) @
-                [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)
-          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
-          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) @
-                [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)
-          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
-        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
 
+  (* 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 *)
-  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
-          val t = Temp.new ("assign")
+          val t = Temp.new ("assign") sz
+          val (m, r) = munch_lval a
         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
-    | 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
-          val t = Temp.new ("retval")
+          val t = Temp.new ("retval") sz
         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]
@@ -430,6 +456,7 @@ struct
        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
index 24123b9..4c8e4ad 100644 (file)
@@ -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)]
+        | defhit (X.REL(o1, o2)) = usehit o1 @ usehit o2
+        | defhit (X.OSIZE(s, oo)) = defhit oo
         | 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.REL(o1, o2)) = usehit o1 @ usehit o2
+        | usehit (X.OSIZE(s, oo)) = usehit oo
         | 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)])
-        | 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.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)])
index 7fa4554..7bf55a1 100644 (file)
@@ -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.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
 
index 8c39017..21b37bc 100644 (file)
@@ -26,12 +26,12 @@ struct
   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 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
+      val spillreg2 = X.R14D
 
       (* 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 (
@@ -58,99 +59,135 @@ struct
       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.OSIZE (_, oo)) = isspilled oo
         | 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 =
-        (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) =>
-            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) =>
-            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)) @
-        [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()
 
-      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))
-          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
-        | 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))
-          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
-        | 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.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?"
-            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 (X.OSIZE (s, oo)) = X.OSIZE (s, stackoper (X.stripsize oo))
         | stackoper _ = raise ErrorMsg.InternalError "stackoper on not temp?"
-      
+
+      fun ophit (X.OSIZE (s, oo)) = let val (insns, p) = ophit (X.stripsize oo) in (insns, X.OSIZE (s, p)) end
+        | ophit (X.REL(op1, op2)) =
+          let
+            val t1 = X.stripsize op1
+            val (s, t2) = X.sizeoper op2
+          in
+            if (isspilled t1 andalso isspilled t2) then
+              ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2),
+                X.ADD (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)],
+                X.REL (X.REG spillreg1, X.CONST 0w0))
+            else if(isspilled t1) then
+              ([X.MOV (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)],
+                X.REL (X.REG spillreg1, realoper t2))
+            else if(isspilled t2) then
+              ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2)],
+                X.REL (realoper t1, X.REG spillreg1))
+            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
-        | transform (X.SIZE (s, i)) = map (fn i' => (X.SIZE (s, i'))) (transform i)
         | 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)) =
-            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)) =
-            unspill (dest, spillreg1) @
+            unspill X.Long (dest, spillreg1) @
             [ 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)) =
+            unspill X.Long ((X.stripsize src), spillreg2) @
             [ X.IMUL3(
                 realoper dest handle Spilled => X.REG spillreg1,
-                realoper src handle Spilled => stackoper src,
+                realoper src handle Spilled => X.REG spillreg2,
                 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)]
@@ -164,27 +201,27 @@ struct
                 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)) =
-            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)) =
-            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)) =
-            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)) =
-            unspill (op2, spillreg1) @
+            unspill X.Long (op2, 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)]
-            @ 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 ]
index 74fe8c1..5010d7b 100644 (file)
@@ -18,8 +18,8 @@ struct
   (* val stringify : asm -> string
    * turns a x86 instruction list into a string of assembly code for these instructions *)
 
-  fun stringify' rn (X.CALL (l, n)) = X.prettyprint X.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
index 6ec4263..e54d4be 100644 (file)
@@ -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 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 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 |
-    SIZE of size * insn |
     MOV of oper * oper |
+    LEA of oper * oper |
     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;
   
+  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
@@ -56,7 +60,7 @@ sig
   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 =
@@ -65,15 +69,15 @@ struct
 
   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 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 |
-    SIZE of size * insn |
     MOV of oper * oper |
+    LEA of oper * oper |
     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 
-          val regorder = regcmp (r1, r2)
-          val intorder = Int.compare (i1, i2)
+          val order1 = cmpoper (r1, r2)
+          val order2 = cmpoper (i1, i2)
         in
-          if (regorder = EQUAL) then intorder
-          else regorder
+          if (order1 = EQUAL) then order2
+          else order1
         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
-    | 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 (
@@ -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 ((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])
@@ -237,53 +243,63 @@ struct
     | 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"
-  
+
+  fun osize (OSIZE (s, _)) = s
+    | osize _ = Long
+
+  fun stripsize (OSIZE (_, oo)) = stripsize oo
+    | stripsize oo = oo
+
+  fun sizeoper (OSIZE (s, oo)) = (s, stripsize oo)
+    | sizeoper oo = (Long, oo)
+
   fun prettyprint_oper s (REG r) = "%" ^ (regname s r)
-    | prettyprint_oper 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 _ (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 _ (OSIZE (s, oo)) = prettyprint_oper s (stripsize oo)
 
   (* pretty prints (no...) *)
-  fun prettyprint (DIRECTIVE(str)) = str ^ "\n"
-    | prettyprint (COMMENT(str)) = "// " ^ str ^ "\n"
-    | prettyprint (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
similarity index 72%
rename from compile-l3c.sml
rename to compile-l4c.sml
index a8f95ec..7299ee8 100644 (file)
@@ -4,4 +4,4 @@
  *)
 
 CM.make "sources.cm";
-SMLofNJ.exportFn ("bin/l3c.heap", Top.main);
+SMLofNJ.exportFn ("bin/l4c.heap", Top.main);
index fce70ab..84b2356 100644 (file)
@@ -13,8 +13,12 @@ signature AST =
 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
+  datatype typedef = Struct of variable list
+                   | MarkedTypedef of typedef Mark.marked
 
   datatype oper = 
      PLUS
@@ -45,8 +49,17 @@ sig
    | 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 =
-     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
@@ -57,27 +70,39 @@ sig
    | 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
+    val pp_type : vtype -> string
     val pp_stm : stm -> string
     val pp_program : program -> string
   end
-
 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
+  datatype typedef = Struct of variable list
+                   | MarkedTypedef of typedef Mark.marked
 
   datatype oper = 
      PLUS
@@ -108,8 +133,17 @@ struct
    | 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 =
-     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
@@ -120,10 +154,11 @@ struct
    | 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
@@ -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 (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)
 
-    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) =
-         "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) = ";"
@@ -196,6 +242,10 @@ struct
       | 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))
@@ -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_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
diff --git a/parse/astutils.sml b/parse/astutils.sml
new file mode 100644 (file)
index 0000000..72bdaeb
--- /dev/null
@@ -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
similarity index 62%
rename from parse/l3.grm
rename to parse/l4.grm
index cbf92ea..3f14c33 100644 (file)
@@ -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>
@@ -7,12 +7,16 @@
  *)
 
 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)))
+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 *)
@@ -22,19 +26,8 @@ fun make_lval (A.Var(id)) ext = id
   | 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
@@ -49,10 +42,11 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) =
  | 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
+ | programx of A.program
  | 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
- | 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
- | 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
- | 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
 
@@ -81,7 +77,7 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) =
 %eop EOF
 %noshift EOF
 
-%name L3
+%name L4
 
 %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 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)
+           | 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
-                                    (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
-                                    (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)
 
-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)
@@ -141,8 +150,11 @@ stm        : simp SEMI              (simp)
            | 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)))
@@ -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 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)))
@@ -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)))
+           | NULL                   (mark (A.Null, (NULLleft, NULLright)))
            | 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)))
+           | 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)))
@@ -196,14 +216,13 @@ exp        : LPAREN exp RPAREN      (exp)
 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)
similarity index 91%
rename from parse/l3.lex
rename to parse/l4.lex
index d9c2217..b988c35 100644 (file)
@@ -1,4 +1,4 @@
-(* L3 Compiler
+(* L4 Compiler
  * Lexer
  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
@@ -51,7 +51,7 @@ in
 end
 
 %%
-%header (functor L3LexFn(structure Tokens : L3_TOKENS));
+%header (functor L4LexFn(structure Tokens : L4_TOKENS));
 %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.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));
@@ -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> "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));
index aa701c4..3786421 100644 (file)
@@ -1,4 +1,4 @@
-(* L3 Compiler
+(* L4 Compiler
  * Parsing
  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
@@ -17,10 +17,10 @@ end
 structure Parse :> PARSE =
 struct 
 
-  structure 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 *)
@@ -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
-                         (L3Lex.makeLexer (fn _ => TextIO.input instream))
+                         (L4Lex.makeLexer (fn _ => TextIO.input instream))
          (* 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 ()
index 3dd6fa1..351df5f 100644 (file)
@@ -11,9 +11,10 @@ Group is
         util/word32.sml
 
        parse/ast.sml
+       parse/astutils.sml
        parse/parsestate.sml
-       parse/l3.lex
-       parse/l3.grm
+       parse/l4.lex
+       parse/l4.grm
        parse/parse.sml
 
        type/typechecker.sml
@@ -26,7 +27,6 @@ Group is
 
        codegen/x86.sml
        codegen/codegen.sml
-
        codegen/igraph.sml
        codegen/colororder.sml
        codegen/solidify.sml
index d97bba4..0f45274 100644 (file)
@@ -10,10 +10,11 @@ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
         util/word32.sml
 
        parse/ast.sml
+       parse/astutils.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
index 5e564b1..c350c09 100644 (file)
@@ -73,18 +73,18 @@ struct
   
   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
-                         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
-                  (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;
@@ -93,7 +93,7 @@ struct
                     (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
@@ -116,10 +116,10 @@ struct
                   (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
-                          "spill[" ^ Int.toString (i - x86.regtonum x86.R14D) ^ "]")
+                          "spill[" ^ Int.toString (i - x86.regtonum x86.R13D) ^ "]")
                         ^ "--"^ Int.toString i ^ "\n"))
                     colors) ()
 
@@ -165,22 +165,25 @@ struct
 
         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 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 "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 ^ " ...")
index d370d99..1092dfc 100644 (file)
@@ -10,26 +10,28 @@ sig
   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 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
-  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 )
-    fun new str = (!counter, str) before ( counter := !counter + 1 )
+    fun new str size = (!counter, str, size) before ( counter := !counter + 1 )
   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
index 80802be..6148ce8 100644 (file)
@@ -17,6 +17,7 @@ structure Trans :> TRANS =
 struct
 
   structure A = Ast
+  structure AU = AstUtils
   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"
 
-  fun translate p =
+  fun translate (defs, funcs) =
     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 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)
-        | 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"
-        | 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 *)
 
@@ -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)
        *)
-      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
-            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
-            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
-        | trans_stms vars ls (A.Return e::stms) =
+        | trans_stms vars vartypes ls (A.Return e::stms) =
           let
-            val remainder = trans_stms vars ls stms
+            val remainder = trans_stms vars vartypes ls stms
           in 
-            T.RETURN (trans_exp vars e)
+            T.RETURN (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))
             :: 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 ()
-            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
-            (T.JUMPIFN(trans_exp vars e, l)
+            (T.JUMPIFN(trans_exp vars vartypes e, l)
             :: 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 ()
-            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
-            (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
-        | 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 ()
-            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
-            @ [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
-        | 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 ()
-            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
-            :: T.JUMPIFN(trans_exp vars e, tail)
+            :: T.JUMPIFN(trans_exp vars vartypes e, tail)
             :: 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
-            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
-        | 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
-            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
-        | 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
-              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
-                (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
+
     in
-      trans_funcs p
+      trans_funcs funclist
     end
-
 end
index f5a92b5..d3e8c0d 100644 (file)
@@ -18,13 +18,16 @@ sig
   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
-    | CALL of Ast.ident * exp list
+    | CALL of Ast.ident * (exp * int) list * int
+    | MEMORY of exp
+    | ALLOC of exp
   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
@@ -52,13 +55,16 @@ struct
   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
-    | CALL of Ast.ident * exp list
+    | CALL of Ast.ident * (exp * int) list * int
+    | MEMORY of exp
+    | ALLOC of exp
   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
@@ -97,18 +103,21 @@ struct
 
     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 (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_stm (RETURN e) =
+      | pp_stm (RETURN (e, sz)) =
          "return " ^ pp_exp e
+      | pp_stm (EFFECT (e, sz)) = pp_exp e
       | pp_stm (LABEL l) =
           Label.name l ^ ":"
       | pp_stm (JUMP l) = 
index 63608bd..35d2859 100644 (file)
@@ -10,17 +10,150 @@ signature TYPE_CHECK =
 sig
   (* prints error message and raises ErrorMsg.error if error found *)
   val typecheck : Ast.program -> Ast.program
+  val typeof : Ast.program -> Ast.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Ast.vtype
 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
 
+  (* 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
-    | 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 *)
@@ -30,6 +163,9 @@ struct
     | 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 )
@@ -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
   
-  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 )
-           | 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 )
-                      | 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
-    | 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
@@ -88,8 +226,8 @@ struct
           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
@@ -109,70 +247,94 @@ struct
        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 ()
-          val (t, a) = valOf sym
-          val t' = varcheck_exp env fenv e mark
+          val t = valOf sym
+          val _ = varcheck_exp env e mark
         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
-    | 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 )
-    | 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 )
-    | varcheck env fenv (A.Continue :: stms) mark =
+    | varcheck env (A.Continue :: stms) mark =
         ( 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
-             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
-                       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
-          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
-                  of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark))
+                  of SOME(s) => SOME (hd (varcheck env'' [s] mark))
                    | 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
-    | 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
@@ -182,62 +344,172 @@ struct
             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
+  
+  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
-        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 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
-        A.Function (t, id, al, vl, varcheck env fenv sl NONE)
+        A.Function (t, al, vl, varcheck env sl NONE)
       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
-        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
+        val (main, mainp) = (AU.Function.data main, AU.Function.mark 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 )
-                  | 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 )
-        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
-        List.map (typecheck_fn p) p
+        (tds, Symbol.mapi (typecheck_fn (tds, funcs) NONE) funcs)
       end
 end
diff --git a/util/graph.sml b/util/graph.sml
new file mode 100644 (file)
index 0000000..502cd7c
--- /dev/null
@@ -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
index 87a0ab9..3111761 100644 (file)
@@ -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 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
@@ -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 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
This page took 0.621579 seconds and 4 git commands to generate.