# 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
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
+++ /dev/null
-sml @SMLcmdname=$0 @SMLload=bin/l3c.heap.x86-linux $*
--- /dev/null
+sml @SMLcmdname=$0 @SMLload=bin/l4c.heap.x86-linux $*
| 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
| 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 *)
* 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)
| 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)]
| 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
| 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
| 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
| 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
| 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
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))
[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))
[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
in
insns @ [X.SETcc (neg, d), X.MOVZB(d, d)]
end
+ | munch_exp d (T.MEMORY e1) =
+ let
+ val a = X.TEMP (Temp.new "addr" 8)
+ in
+ munch_exp a e1 @ [X.MOV (d, X.REL (a, X.CONST 0w0))]
+ end
+ | munch_exp d (T.ALLOC(exp)) = (munch_exp d (T.CALL (Symbol.symbol "calloc", [(exp, 4), (T.CONST 0w1, 4)], 8)))
+ @ [X.MOV (X.REL (d, X.CONST 0w0), X.CONST 0w0)]
+
(* munch_cond : T.exp -> X.insn list * X.cond * X.cond
* munch_cond stm generates code to set flags, and then returns a conditional
* to test if the expression was true and for if it was false.
| munch_cond (T.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)
| 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)
| 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)
| 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)
| 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)
| 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)
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]
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
* 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
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)])
| 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
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)
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 (
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)]
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)]
[ 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 ]
(* 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
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 |
structure LiveMap : ORD_MAP
where type Key.ord_key = int;
+ val sts : int -> size
+ val sizeoper : oper -> size * oper
+ val stripsize : oper -> oper
+ val osize : oper -> size
val cmpoper : oper * oper -> order
val opereq : oper * oper -> bool
val regname : size -> reg -> string
val 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 =
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 |
| 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
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 (
| opsused ((COMMENT _)::l) = opsused l
| opsused ((LABEL _)::l) = opsused l
| opsused ((MOV (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
+ | opsused ((LEA (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
| opsused ((SUB (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
| opsused ((IMUL (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
| opsused ((IMUL3 (dst, src, _))::l) = OperSet.addList (opsused l, [dst, src])
| opsused ((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 s (DIRECTIVE(str)) = str ^ "\n"
- | prettyprint s (COMMENT(str)) = "// " ^ str ^ "\n"
- | prettyprint s (LABEL(l)) = Label.name l ^ ":\n"
- | prettyprint s (MOV(dst, src)) = "\tmov" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (SUB(dst, src)) = "\tsub" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (IMUL(dst, src)) = "\timul\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (IMUL3(dst, tmp, const)) = "\timul\t" ^ (prettyprint_oper s (CONST const)) ^ ", " ^ (prettyprint_oper s tmp) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (ADD(dst, src)) = "\tadd" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (IDIV(src)) = "\tidiv" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ "\n"
- | prettyprint s (NEG (dst)) = "\tneg" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (NOT (dst)) = "\tnot" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (SAL (dst, shft)) = "\tsal" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (SAR (dst, shft)) = "\tsar" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (AND (dst, src)) = "\tand" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (OR (dst, src)) = "\tor" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (XOR (dst, src)) = "\txor" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (CMP (dst, src)) = "\tcmp" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (TEST (dst, src)) = "\ttest" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (prettyprint_oper Byte dst) ^ "\n"
- | prettyprint s (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n"
- | prettyprint s (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n"
- | prettyprint s (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n"
- | prettyprint s (MOVZB (dst, src)) = "\tmovzb" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
- | prettyprint s (CLTD) = "\tcltd\n"
- | prettyprint s (RET) = "\tret\n"
- | prettyprint s (LIVEIGN i) = prettyprint s i
- | prettyprint _ (SIZE (s, i)) = prettyprint s i
+ fun prettyprint (DIRECTIVE(str)) = str ^ "\n"
+ | prettyprint (COMMENT(str)) = "// " ^ str ^ "\n"
+ | prettyprint (LABEL(l)) = Label.name l ^ ":\n"
+ | prettyprint (LEA(dst, src)) = "\tlea" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (MOV(dst, src)) = "\tmov" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (SUB(dst, src)) = "\tsub" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (IMUL(dst, src)) = "\timul" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (IMUL3(dst, tmp, const)) = "\timul" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (CONST const)) ^ ", " ^ (prettyprint_oper (osize dst) (stripsize tmp)) ^ ", " ^ (prettyprint_oper (osize dst) dst) ^ "\n"
+ | prettyprint (ADD(dst, src)) = "\tadd" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (IDIV(src)) = "\tidiv" ^ (sfx (osize src)) ^ "\t" ^ (prettyprint_oper (osize src) src) ^ "\n"
+ | prettyprint (NEG (dst)) = "\tneg" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (NOT (dst)) = "\tnot" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (SAL (dst, shft)) = "\tsal" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (SAR (dst, shft)) = "\tsar" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (AND (dst, src)) = "\tand" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (OR (dst, src)) = "\tor" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (XOR (dst, src)) = "\txor" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (CMP (dst, src)) = "\tcmp" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (TEST (dst, src)) = "\ttest" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (prettyprint_oper Byte (stripsize dst)) ^ "\n"
+ | prettyprint (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n"
+ | prettyprint (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n"
+ | prettyprint (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n"
+ | prettyprint (MOVZB (dst, src)) = "\tmovzb" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n"
+ | prettyprint (CLTD) = "\tcltd\n"
+ | prettyprint (RET) = "\tret\n"
+ | prettyprint (LIVEIGN i) = prettyprint i
(* | prettyprint _ = raise ErrorMsg.InternalError ("prettyprint: Type A? Hatchar de coneccion?")*)
end
*)
CM.make "sources.cm";
-SMLofNJ.exportFn ("bin/l3c.heap", Top.main);
+SMLofNJ.exportFn ("bin/l4c.heap", Top.main);
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
| 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
| 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
| 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
| 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
| 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) = ";"
| pp_stms (s::ss) = pp_stm s ^ "\n" ^ pp_stms ss
and pp_type Int = "int"
+ | pp_type (Typedef i) = pp_ident i
+ | pp_type (Pointer t) = pp_type t ^ "*"
+ | pp_type (Array t) = pp_type t ^ "[]"
+ | pp_type TNull = "{NULL type}"
and pp_params nil = ""
| pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ ", " ^ (pp_params (a::l))
and pp_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
--- /dev/null
+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
-(* 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>
*)
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 *)
| 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
| 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
| 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
%eop EOF
%noshift EOF
-%name L3
+%name L4
%left LOGOR
%left LOGAND
%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)
| 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)))
exp : LPAREN exp RPAREN (exp)
| INTNUM (mark (A.ConstExp(INTNUM),(INTNUMleft,INTNUMright)))
| IDENT (mark (A.Var(IDENT), (IDENTleft,IDENTright)))
+ | exp DOT IDENT (mark (A.Member(exp, IDENT), (expleft, IDENTright)))
+ | exp ARROW IDENT (mark (A.DerefMember(exp, IDENT), (expleft, IDENTright)))
+ | STAR exp %prec UNARY (mark (A.Dereference(exp), (STARleft, expright)))
+ | exp LBRACKET exp RBRACKET
+ (mark (A.ArrIndex(exp1, exp2), (exp1left, exp2right)))
| exp PLUS exp (mark (A.OpExp (A.PLUS, [exp1,exp2]), (exp1left,exp2right)))
| exp MINUS exp (mark (A.OpExp (A.MINUS, [exp1,exp2]), (exp1left,exp2right)))
| exp STAR exp (mark (A.OpExp (A.TIMES, [exp1,exp2]), (exp1left,exp2right)))
| exp 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)))
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)
-(* L3 Compiler
+(* L4 Compiler
* Lexer
* Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
* Modified: Frank Pfenning <fp@cs.cmu.edu>
end
%%
-%header (functor L3LexFn(structure Tokens : L3_TOKENS));
+%header (functor L4LexFn(structure Tokens : L4_TOKENS));
%full
%s COMMENT COMMENT_LINE;
<INITIAL> ":" => (Tokens.COLON (yypos, yypos + size yytext));
<INITIAL> "," => (Tokens.COMMA (yypos, yypos + size yytext));
+<INITIAL> "[" => (Tokens.LBRACKET (yypos, yypos + size yytext));
+<INITIAL> "]" => (Tokens.RBRACKET (yypos, yypos + size yytext));
+<INITIAL> "->" => (Tokens.ARROW (yypos, yypos + size yytext));
+<INITIAL> "." => (Tokens.DOT (yypos, yypos + size yytext));
+
<INITIAL> "return" => (Tokens.RETURN (yypos, yypos + size yytext));
<INITIAL> "if" => (Tokens.IF (yypos, yypos + size yytext));
<INITIAL> "while" => (Tokens.WHILE (yypos, yypos + size yytext));
<INITIAL> "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));
-(* L3 Compiler
+(* L4 Compiler
* Parsing
* Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
* Modified: Frank Pfenning <fp@cs.cmu.edu>
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 *)
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 ()
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
codegen/x86.sml
codegen/codegen.sml
-
codegen/igraph.sml
codegen/colororder.sml
codegen/solidify.sml
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
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;
(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
(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) ()
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 ^ " ...")
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
struct
structure A = Ast
+ structure AU = AstUtils
structure T = Tree
fun trans_oper A.PLUS = T.ADD
| 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 *)
* 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
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
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
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) =
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 *)
| 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 )
| 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
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
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
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
--- /dev/null
+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
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
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
git.joshuawise.com / snipe.git / commitdiff