From: Joshua Wise Date: Thu, 14 May 2009 02:14:37 +0000 (-0400) Subject: Initial import of l4c X-Git-Url: http://git.joshuawise.com/snipe.git/commitdiff_plain/1144856ba9d6018d9922c6ede7e97779a0fe6373 Initial import of l4c --- diff --git a/Makefile b/Makefile index 88508a2..2cb4352 100644 --- a/Makefile +++ b/Makefile @@ -1,23 +1,24 @@ # the following are SML-NJ specific defines SML = sml -l3c: FORCE - echo 'use "compile-l3c.sml";' | ${SML} +l4c: FORCE + echo 'use "compile-l4c.sml";' | ${SML} -l3c-mlton: FORCE - mllex parse/l3.lex - mlyacc parse/l3.grm - mlton -output bin/l3c-mlton sources.mlb - ${RM} parse/l3.lex.sml +l4c-mlton: FORCE + mllex parse/l4.lex + mlyacc parse/l4.grm + mlton -output bin/l4c-mlton sources.mlb + ${RM} parse/l4.lex.sml reallyclean: clean ${RM} parse/*.lex.* parse/*.grm.* + find . -type f -name '*~' | xargs rm -rf clean: find . -type d -name .cm | xargs rm -rf find . -type f | grep '~$$' | xargs ${RM} - ${RM} bin/l3c.heap.* - ${RM} bin/l3c-mlton + ${RM} bin/l4c.heap.* + ${RM} bin/l4c-mlton TAGS: clean diff --git a/README b/README index 4c6899b..ccc7581 100644 --- a/README +++ b/README @@ -1,58 +1,53 @@ README ------ -This compiler is a big long chain of modules that transform l3 code into +This compiler is a big long chain of modules that transform l4 code into x86_64 assembly. -Here is a breakdown of the modules and changes from l2: +Here is a breakdown of the modules and changes from l3: - * The parser. The parser was mainly brought in from lab 2, and mainly - just a straight-forward extension of the l2 parser. We added the - ability to parse functions, function calls, and variable declarations. + * The parser. The parser was mainly brought in from lab 3, and mainly + just a straight-forward extension of the l3 parser. We changed asops, + since they now side-effect and need special properties. We also added + dereferences, arrays, other nice things. + + * AST utilities. Some of those now exist to make common operations on raw + AST structures less painful. - * The typechecker. This module is mostly the same as that from l2. It - performs function-related typechecking as well now, such as ensuring - that the correct number of arguments is supplied in a function call, - that there are no multiple definitions of functions, and that there is a - main function that takes only one argument. + * The typechecker. The typechecker was significantly revamped. A + 'typeof' function was added that did most of the typechecking work; + the rest was relatively trivial compared to typeof. There were many + annoying things other than typeof, but typeof was the most interesting + to comment on. - * The translator was extended with a CALL. + * The translator was extended with support for sizing up structs. It now + is smarter about translating asops. A MEMORY thingo was added to the + Tree, as was ALLOC. - * The munch module was also extended with the ability to munch CALL; a - major improvement was made when we realized we could determine what - expressions had effects and what had fixed registers. Any expressions - that use no fixed registers and have no effects can be reordered during - evaluation of a function call's arguments. This enabled us to save a - bunch of register-register moves. Saving the caller save registers is - left to the liveness analyzer, which we believe results in substantially - better code than saving and restoring all caller saves. + * The x86/munch modules were extended with support for multiple operand + sizes. This was done in a fashion of extreme type A, and needs to be + blasted before the next lab, for it is worthless, terrible, awful, ... A + major falling-down of this compiler is that it passes size information + around in no less than 235784 different fashions, and the translation + between each has caused us no end of grief. If we had time to rewrite + it instead of firefighting broken tests, uh... we would. Many of our + optimizations from last lab needed to be commented out because of this + temporary sizing sadness. - * The liveness analyzer remains in more or less the same form, but with - substantial performance and cleanliness improvements by replacing lists - with maps (via BinaryMapFn) and sets (via ListSetFn). Also, a bug of - incredible type A was discovered through much pain and suffering, and - promptly fixed; it involved not realizing that a def on one line led to - an interference on any succeeding lines. Somehow we got away with this - for lab 2. Otherwise, we just explicitly state rules to generate - def/use/succ predicates which we then iterate over to find a fixed point - for livenesses using the standard rules. + * The liveness analyzer was mainly unchanged, but for a few rules. - * The grapher was changed to use the binary map and list set for - performance boosts (needed to pass certain large tests, like - pine-tree_print.l3). It generates an interference graph from a list of - livenesses at each source line. + * The grapher was fully unchanged. Nice. - * The color orderer had no changes. + * The color orderer was fully unchanged. Nice. - * The coloring module was slightly updated to recognize more fixed-color - registers. It implements a greedy coloring algorithm. + * The coloring module was fully unchanged. Nice. - * The solidifier was modified to change the callee save system. Now we - only save the registers we need to. This improvement was pushed by - excessively slow execution time on one of the tests. + * The solidifier was modified to deal with the fact that certain things + could not be accessed directly. It, too, has become an unmitigated + disaster. It must deal with all 875847384 of the sizes, and I am sad + about this. - * The peepholer is upgraded somewhat; it now eliminates more redundant - instructions (such as adding/subtracting 0). + * The peepholer lost one form of fail and loss sizing. * The stringifier is of no interest to you, for it does real things that interact with the real world, and that is not of interest to people who diff --git a/bin/l3c b/bin/l3c deleted file mode 100755 index 6350d67..0000000 --- a/bin/l3c +++ /dev/null @@ -1 +0,0 @@ -sml @SMLcmdname=$0 @SMLload=bin/l3c.heap.x86-linux $* diff --git a/bin/l4c b/bin/l4c new file mode 100755 index 0000000..0259f69 --- /dev/null +++ b/bin/l4c @@ -0,0 +1 @@ +sml @SMLcmdname=$0 @SMLload=bin/l4c.heap.x86-linux $* diff --git a/codegen/codegen.sml b/codegen/codegen.sml index 8a5afe2..6ee8c2f 100644 --- a/codegen/codegen.sml +++ b/codegen/codegen.sml @@ -22,6 +22,8 @@ struct | effect (T.CALL _) = true | effect (T.BINOP(_, a, b)) = (effect a) orelse (effect b) | effect (T.UNOP (_, a)) = effect a + | effect (T.MEMORY m) = true + | effect (T.ALLOC(_)) = true | effect _ = false (* hasfixed : T.exp -> bool @@ -34,6 +36,8 @@ struct | hasfixed (T.CALL _) = true | hasfixed (T.BINOP(_, a, b)) = (hasfixed a) orelse (hasfixed b) | hasfixed (T.UNOP (_, a)) = hasfixed a + | hasfixed (T.ALLOC(_)) = true + | hasfixed (T.MEMORY m) = hasfixed m | hasfixed _ = false (* munch_exp : prex86oper -> T.exp -> prex86insn list *) @@ -41,16 +45,16 @@ struct * generates instructions to achieve d <- e * d must be TEMP(t) or REG(r) *) - fun munch_exp d (T.CONST(n)) = [X.MOV(d, X.CONST n)] + and munch_exp d (T.CONST(n)) = [X.MOV(d, X.CONST n)] | munch_exp d (T.TEMP(t)) = [X.MOV(d, X.TEMP t)] - | munch_exp d (T.ARG(0)) = [X.MOV(d, X.REG X.EDI)] - | munch_exp d (T.ARG(1)) = [X.MOV(d, X.REG X.ESI)] - | munch_exp d (T.ARG(2)) = [X.MOV(d, X.REG X.EDX)] - | munch_exp d (T.ARG(3)) = [X.MOV(d, X.REG X.ECX)] - | munch_exp d (T.ARG(4)) = [X.MOV(d, X.REG X.R8D)] - | munch_exp d (T.ARG(5)) = [X.MOV(d, X.REG X.R9D)] - | munch_exp d (T.ARG(t)) = [X.MOV(d, X.STACKARG (t - 6))] - | munch_exp d (T.CALL(name, l)) = (* Scary demons live here. *) + | munch_exp d (T.ARG(0, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.EDI))] + | munch_exp d (T.ARG(1, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.ESI))] + | munch_exp d (T.ARG(2, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.EDX))] + | munch_exp d (T.ARG(3, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.ECX))] + | munch_exp d (T.ARG(4, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.R8D))] + | munch_exp d (T.ARG(5, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.R9D))] + | munch_exp d (T.ARG(t, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.STACKARG (t - 6)))] + | munch_exp d (T.CALL(name, l, rsz)) = (* Scary demons live here. *) let val nargs = length l val nstack = if (nargs <= 6) @@ -63,83 +67,85 @@ struct | argdest 4 = X.REG X.ECX | argdest 5 = X.REG X.R8D | argdest 6 = X.REG X.R9D - | argdest n = X.REL (X.RSP, (~(stackb - 8 * (n - 7)))) + | argdest n = X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (~(stackb - 8 * (n - 7)))) ) val dests = List.tabulate (nargs, fn x => argdest (x+1)) - val hf = List.map hasfixed l - val (d_hf, exps_hf) = ListPair.unzip (ListPair.foldr + val (exps,_) = ListPair.unzip l + val hf = List.map hasfixed exps + val (d_hf, l_hf) = ListPair.unzip (ListPair.foldr (fn (a,b,c) => if b then a::c else c) nil (ListPair.zip (dests,l), hf) ) - val (d_nohf, exps_nohf) = ListPair.unzip (ListPair.foldr + val (d_nohf, l_nohf) = ListPair.unzip (ListPair.foldr (fn (a,b,c) => if b then c else a::c) nil (ListPair.zip (dests,l), hf) ) - val temps = List.tabulate (List.length d_hf, fn x => Temp.new(Int.toString x ^ " arg")) + val temps = List.map (fn (_, sz) => Temp.new ("arg") sz (* xxx? *)) l_hf val argevals_hf = List.map - (fn (t,exp) => munch_exp (X.TEMP t) exp) - (ListPair.zip (temps, exps_hf)) + (fn (t,(exp,_)) => munch_exp (X.TEMP t) exp) + (ListPair.zip (temps, l_hf)) val argpushes = List.map - (fn (dest, t) => [(X.MOV (dest, X.TEMP t))]) + (fn (dest, t) => [(X.MOV (X.OSIZE(X.sts (Temp.size t), dest), X.TEMP t))]) (ListPair.zip (d_hf, temps)) val argevals_nohf = List.map - (fn (d,exp) => munch_exp d exp) - (ListPair.zip (d_nohf, exps_nohf)) + (fn (d,(exp,sz)) => munch_exp (X.OSIZE (X.sts sz, d)) exp) + (ListPair.zip (d_nohf, l_nohf)) in List.concat argevals_hf @ List.concat argpushes @ List.concat argevals_nohf @ - [ X.SIZE (X.Qword, X.SUB (X.REG X.RSP, X.CONST (Word32.fromInt stackb))), + [ X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stackb)), X.CALL (name, nargs), - X.SIZE (X.Qword, X.ADD (X.REG X.RSP, X.CONST (Word32.fromInt stackb))), - X.MOV (d, X.REG X.EAX) ] (* Finally! *) + X.ADD (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stackb)), + X.MOV (d, X.OSIZE (X.sts rsz, X.REG X.EAX)) ] (* Finally! *) end - | munch_exp d (T.BINOP(T.ADD, e1, T.CONST 0w0)) = munch_exp d e1 +(* | munch_exp d (T.BINOP(T.ADD, e1, T.CONST 0w0)) = munch_exp d e1 | munch_exp d (T.BINOP(T.ADD, T.CONST 0w0, e1)) = munch_exp d e1 | munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = (munch_exp d e1) @ [X.ADD(d, X.CONST n)] | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = (munch_exp d e1) @ [X.ADD(d, X.CONST n)] | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = (munch_exp d e1) @ [X.ADD(d, X.TEMP t)] - | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e2)) = (munch_exp d e2) @ [X.ADD(d, X.TEMP t)] + | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e2)) = (munch_exp d e2) @ [X.ADD(d, X.TEMP t)] *) | munch_exp d (T.BINOP(T.ADD, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("add")) + val t1 = X.TEMP (Temp.new ("add") 4) in (munch_exp d e1) @ (munch_exp t1 e2) @ [X.ADD(d, t1)] end - | munch_exp d (T.BINOP(T.SUB, T.CONST 0w0, e1)) = (munch_exp d e1) @ [X.NEG d] +(* | munch_exp d (T.BINOP(T.SUB, T.CONST 0w0, e1)) = (munch_exp d e1) @ [X.NEG d] | munch_exp d (T.BINOP(T.SUB, e1, T.CONST 0w0)) = munch_exp d e1 | munch_exp d (T.BINOP(T.SUB, e1, T.CONST(n))) = (munch_exp d e1) @ [X.SUB(d, X.CONST n)] - | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = (munch_exp d e1) @ [X.SUB(d, X.TEMP t)] + | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = (munch_exp d e1) @ [X.SUB(d, X.TEMP t)] *) | munch_exp d (T.BINOP(T.SUB, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("sub")) + val t1 = X.TEMP (Temp.new ("sub") 4) in (munch_exp d e1) @ (munch_exp t1 e2) @ [X.SUB(d, t1)] end | munch_exp d (T.BINOP(T.MUL, T.TEMP t, T.CONST n)) = [X.IMUL3(d, X.TEMP t, n)] | munch_exp d (T.BINOP(T.MUL, T.CONST n, T.TEMP t)) = [X.IMUL3(d, X.TEMP t, n)] +(* | munch_exp d (T.BINOP(T.MUL, e1, T.CONST 0w1)) = munch_exp d e1 | munch_exp d (T.BINOP(T.MUL, T.CONST 0w1, e1)) = munch_exp d e1 | munch_exp d (T.BINOP(T.MUL, e1, T.CONST n)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] - | munch_exp d (T.BINOP(T.MUL, T.CONST n, e1)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] + | munch_exp d (T.BINOP(T.MUL, T.CONST n, e1)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] *) | munch_exp d (T.BINOP(T.MUL, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("mul")) + val t1 = X.TEMP (Temp.new ("mul") 4) in (munch_exp d e1) @ (munch_exp t1 e2) @ [X.IMUL(d, t1)] end | munch_exp d (T.BINOP(T.DIV, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("div")) + val t1 = X.TEMP (Temp.new ("div") 4) in (munch_exp t1 e1) @ (munch_exp d e2) @ [X.MOV (X.REG X.EAX, t1), X.CLTD, X.IDIV d, X.MOV (d, X.REG X.EAX)] end | munch_exp d (T.BINOP(T.MOD, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("mod")) + val t1 = X.TEMP (Temp.new ("mod") 4) in (munch_exp t1 e1) @ (munch_exp d e2) @ [X.MOV (X.REG X.EAX, t1), X.CLTD, X.IDIV d, X.MOV (d, X.REG X.EDX)] @@ -148,7 +154,7 @@ struct | munch_exp d (T.BINOP(T.LSH, e1, T.TEMP t)) = (munch_exp d e1) @ [X.MOV (X.REG X.ECX, X.TEMP t), X.SAL (d, X.REG X.ECX)] | munch_exp d (T.BINOP(T.LSH, e1, e2)) = let - val t = X.TEMP (Temp.new ("lsh")) + val t = X.TEMP (Temp.new ("lsh") 4) in (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAL (d, X.REG X.ECX)] end @@ -156,7 +162,7 @@ struct | munch_exp d (T.BINOP(T.RSH, e1, T.TEMP t)) = (munch_exp d e1) @ [X.MOV (X.REG X.ECX, X.TEMP t), X.SAR (d, X.REG X.ECX)] | munch_exp d (T.BINOP(T.RSH, e1, e2)) = let - val t = X.TEMP (Temp.new ("rsh")) + val t = X.TEMP (Temp.new ("rsh") 4) in (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAR (d, X.REG X.ECX)] end @@ -166,7 +172,7 @@ struct | munch_exp d (T.BINOP(T.BITAND, e1, T.TEMP t)) = (munch_exp d e1) @ [X.AND (d, X.TEMP t)] | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("bitand")) + val t1 = X.TEMP (Temp.new ("bitand") 4) in (munch_exp d e1) @ (munch_exp t1 e2) @ [X.AND(d, t1)] end @@ -176,7 +182,7 @@ struct | munch_exp d (T.BINOP(T.BITOR, e1, T.TEMP t)) = (munch_exp d e1) @ [X.OR (d, X.TEMP t)] | munch_exp d (T.BINOP(T.BITOR, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("bitor")) + val t1 = X.TEMP (Temp.new ("bitor") 4) in (munch_exp d e1) @ (munch_exp t1 e2) @ [X.OR(d, t1)] end @@ -186,7 +192,7 @@ struct | munch_exp d (T.BINOP(T.BITXOR, e1, T.TEMP t)) = (munch_exp d e1) @ [X.XOR (d, X.TEMP t)] | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("bitxor")) + val t1 = X.TEMP (Temp.new ("bitxor") 4) in (munch_exp d e1) @ (munch_exp t1 e2) @ [X.XOR(d, t1)] end @@ -194,8 +200,8 @@ struct let val (insn1, pos1, neg1) = munch_cond e1 val (insn2, pos2, neg2) = munch_cond e2 - val t1 = X.TEMP (Temp.new("logand 1")) - val t2 = X.TEMP (Temp.new("logand 2")) + val t1 = X.TEMP (Temp.new("logand 1") 4) + val t2 = X.TEMP (Temp.new("logand 2") 4) val l = Label.new () in if (effect e2 orelse (length insn2 > 10)) @@ -203,14 +209,14 @@ struct [X.SETcc(pos1, t1), X.Jcc (neg1, l)] @ (insn2) @ [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)] - else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.AND(t1, t2)), X.MOVZB(d, t1)] + else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2)), X.MOVZB(d, t1)] end | munch_exp d (a as T.BINOP(T.LOGOR, e1, e2)) = let val (insn1, pos1, neg1) = munch_cond e1 val (insn2, pos2, neg2) = munch_cond e2 - val t1 = X.TEMP (Temp.new("logor 1")) - val t2 = X.TEMP (Temp.new("logor 2")) + val t1 = X.TEMP (Temp.new("logor 1") 4) + val t2 = X.TEMP (Temp.new("logor 2") 4) val l = Label.new () in if (effect e2 orelse (length insn2 > 10)) @@ -218,7 +224,7 @@ struct [X.SETcc(pos1, t1), X.Jcc (pos1, l)] @ (insn2) @ [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)] - else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.OR(t1, t2)), X.MOVZB(d, t1)] + else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2)), X.MOVZB(d, t1)] end | munch_exp d (a as T.BINOP(T.EQ, _, _)) = let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end @@ -243,6 +249,15 @@ struct in insns @ [X.SETcc (neg, d), X.MOVZB(d, d)] end + | munch_exp d (T.MEMORY e1) = + let + val a = X.TEMP (Temp.new "addr" 8) + in + munch_exp a e1 @ [X.MOV (d, X.REL (a, X.CONST 0w0))] + end + | munch_exp d (T.ALLOC(exp)) = (munch_exp d (T.CALL (Symbol.symbol "calloc", [(exp, 4), (T.CONST 0w1, 4)], 8))) + @ [X.MOV (X.REL (d, X.CONST 0w0), X.CONST 0w0)] + (* munch_cond : T.exp -> X.insn list * X.cond * X.cond * munch_cond stm generates code to set flags, and then returns a conditional * to test if the expression was true and for if it was false. @@ -256,17 +271,17 @@ struct | munch_cond (T.BINOP(T.NEQ, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.NE, X.E) | munch_cond (T.BINOP(T.NEQ, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.NE, X.E) | munch_cond (T.BINOP(T.NEQ, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const neq")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end + let val t = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end | munch_cond (T.BINOP(T.NEQ, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const neq")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end + let val t = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end | munch_cond (T.BINOP(T.NEQ, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const neq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end + let val t1 = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end | munch_cond (T.BINOP(T.NEQ, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const neq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end + let val t1 = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end | munch_cond (T.BINOP(T.NEQ, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("var neq 1")) - val t2 = X.TEMP (Temp.new ("var neq 2")) + val t1 = X.TEMP (Temp.new ("var neq 1") 4) + val t2 = X.TEMP (Temp.new ("var neq 2") 4) in (munch_exp t1 e1 @ munch_exp t2 e2 @ [X.CMP(t1, t2)], X.NE, X.E) @@ -274,17 +289,17 @@ struct | munch_cond (T.BINOP(T.EQ, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.E, X.NE) | munch_cond (T.BINOP(T.EQ, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.E, X.NE) | munch_cond (T.BINOP(T.EQ, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const eq")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end + let val t = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end | munch_cond (T.BINOP(T.EQ, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const eq")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end + let val t = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end | munch_cond (T.BINOP(T.EQ, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const eq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end + let val t1 = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end | munch_cond (T.BINOP(T.EQ, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const eq")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end + let val t1 = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end | munch_cond (T.BINOP(T.EQ, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("var eq 1")) - val t2 = X.TEMP (Temp.new ("var eq 2")) + val t1 = X.TEMP (Temp.new ("var eq 1") 4) + val t2 = X.TEMP (Temp.new ("var eq 2") 4) in (munch_exp t1 e1 @ munch_exp t2 e2 @ [X.CMP(t1, t2)], X.E, X.NE) @@ -292,17 +307,17 @@ struct | munch_cond (T.BINOP(T.LE, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.LE, X.G) | munch_cond (T.BINOP(T.LE, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.GE, X.L) | munch_cond (T.BINOP(T.LE, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const le")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end + let val t = X.TEMP (Temp.new ("const le") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end | munch_cond (T.BINOP(T.LE, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const le")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end + let val t = X.TEMP (Temp.new ("const le") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end | munch_cond (T.BINOP(T.LE, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const le")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end + let val t1 = X.TEMP (Temp.new ("const le") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end | munch_cond (T.BINOP(T.LE, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const le")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end + let val t1 = X.TEMP (Temp.new ("const le") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end | munch_cond (T.BINOP(T.LE, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("var le 1")) - val t2 = X.TEMP (Temp.new ("var le 2")) + val t1 = X.TEMP (Temp.new ("var le 1") 4) + val t2 = X.TEMP (Temp.new ("var le 2") 4) in (munch_exp t1 e1 @ munch_exp t2 e2 @ [X.CMP(t1, t2)], X.LE, X.G) @@ -310,17 +325,17 @@ struct | munch_cond (T.BINOP(T.LT, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.L, X.GE) | munch_cond (T.BINOP(T.LT, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.G, X.LE) | munch_cond (T.BINOP(T.LT, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const lt")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end + let val t = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end | munch_cond (T.BINOP(T.LT, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const lt")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end + let val t = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end | munch_cond (T.BINOP(T.LT, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const lt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end + let val t1 = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end | munch_cond (T.BINOP(T.LT, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const lt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end + let val t1 = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end | munch_cond (T.BINOP(T.LT, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("var lt 1")) - val t2 = X.TEMP (Temp.new ("var lt 2")) + val t1 = X.TEMP (Temp.new ("var lt 1") 4) + val t2 = X.TEMP (Temp.new ("var lt 2") 4) in (munch_exp t1 e1 @ munch_exp t2 e2 @ [X.CMP(t1, t2)], X.L, X.GE) @@ -328,17 +343,17 @@ struct | munch_cond (T.BINOP(T.GT, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.G, X.LE) | munch_cond (T.BINOP(T.GT, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.L, X.GE) | munch_cond (T.BINOP(T.GT, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const gt")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end + let val t = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end | munch_cond (T.BINOP(T.GT, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const gt")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end + let val t = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end | munch_cond (T.BINOP(T.GT, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const gt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end + let val t1 = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end | munch_cond (T.BINOP(T.GT, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const gt")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end + let val t1 = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end | munch_cond (T.BINOP(T.GT, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("var gt 1")) - val t2 = X.TEMP (Temp.new ("var gt 2")) + val t1 = X.TEMP (Temp.new ("var gt 1") 4) + val t2 = X.TEMP (Temp.new ("var gt 2") 4) in (munch_exp t1 e1 @ munch_exp t2 e2 @ [X.CMP(t1, t2)], X.G, X.LE) @@ -346,17 +361,17 @@ struct | munch_cond (T.BINOP(T.GE, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.GE, X.L) | munch_cond (T.BINOP(T.GE, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.LE, X.G) | munch_cond (T.BINOP(T.GE, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const ge")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end + let val t = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end | munch_cond (T.BINOP(T.GE, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const ge")) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end + let val t = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end | munch_cond (T.BINOP(T.GE, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const ge")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end + let val t1 = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end | munch_cond (T.BINOP(T.GE, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const ge")) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end + let val t1 = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end | munch_cond (T.BINOP(T.GE, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("var ge 1")) - val t2 = X.TEMP (Temp.new ("var ge 2")) + val t1 = X.TEMP (Temp.new ("var ge 1") 4) + val t2 = X.TEMP (Temp.new ("var ge 2") 4) in (munch_exp t1 e1 @ munch_exp t2 e2 @ [X.CMP(t1, t2)], X.GE, X.L) @@ -365,62 +380,73 @@ struct let val (insn1, pos1, neg1) = munch_cond e1 val (insn2, pos2, neg2) = munch_cond e2 - val t1 = X.TEMP (Temp.new("logor c 1")) - val t2 = X.TEMP (Temp.new("logor c 2")) + val t1 = X.TEMP (Temp.new("logor c 1") 4) + val t2 = X.TEMP (Temp.new("logor c 2") 4) val l = Label.new () in if (effect e2 orelse (length insn2 > 10)) then ((insn1) @ [X.SETcc (pos1, t1), X.Jcc (pos1, l)] @ (insn2) @ - [X.SETcc (pos2, t1), X.LABEL l, X.SIZE (X.Byte, X.TEST (t1, t1))], + [X.SETcc (pos2, t1), X.LABEL l, X.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))], X.NE, X.E) - else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.OR(t1, t2))], X.NE, X.E) + else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2))], X.NE, X.E) end | munch_cond (T.BINOP(T.LOGAND, e1, e2)) = let val (insn1, pos1, neg1) = munch_cond e1 val (insn2, pos2, neg2) = munch_cond e2 - val t1 = X.TEMP (Temp.new("logand c 1")) - val t2 = X.TEMP (Temp.new("logand c 2")) + val t1 = X.TEMP (Temp.new("logand c 1") 4) + val t2 = X.TEMP (Temp.new("logand c 2") 4) val l = Label.new () in if (effect e2 orelse (length insn2 > 10)) then ((insn1) @ [X.SETcc (pos1, t1), X.Jcc (neg1, l)] @ (insn2) @ - [X.SETcc (pos2, t1), X.LABEL l, X.SIZE (X.Byte, X.TEST (t1, t1))], + [X.SETcc (pos2, t1), X.LABEL l, X.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))], X.NE, X.E) - else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.AND(t1, t2))], X.NE, X.E) + else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2))], X.NE, X.E) end | munch_cond e = let - val t = X.TEMP (Temp.new ("munch c")) + val t = X.TEMP (Temp.new ("munch c") 4) in (munch_exp t e @ [ X.TEST (t,t) ], X.NE, X.E) end + (* munch_lval : T.exp -> (X.insn list * X.operand) + * Takes an expression that has been typechecked as being a valid lvalue, and then returns an instruction list and an operand to store your shit in. + *) + fun munch_lval (T.TEMP t) = ([], X.TEMP t) + | munch_lval (T.MEMORY m) = + let + val t = Temp.new "lv addr" 8 + in + (munch_exp (X.TEMP t) m, X.REL (X.TEMP t, X.CONST 0w0)) + end + | munch_lval _ = raise ErrorMsg.InternalError "That wasn't really a valid lvalue..." + (* munch_stm : T.stm -> X.insn list *) (* munch_stm stm generates code to execute stm *) - fun munch_stm (T.MOVE (T.TEMP t, a as T.TEMP _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE (T.TEMP t, a as T.CONST _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE (T.TEMP t, a as T.ARG _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE(T.TEMP t1, e2)) = + fun munch_stm (T.MOVE (T.TEMP t, a as T.TEMP _, _)) = munch_exp (X.TEMP t) a + | munch_stm (T.MOVE (T.TEMP t, a as T.CONST _, _)) = munch_exp (X.TEMP t) a + | munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an, sz), _)) = munch_exp (X.TEMP t) a + | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _, _)) = munch_exp (X.TEMP t) a + | munch_stm (T.MOVE (a, e2, sz)) = let - val t = Temp.new ("assign") + val t = Temp.new ("assign") sz + val (m, r) = munch_lval a in - munch_exp (X.TEMP t) e2 - @ [X.MOV(X.TEMP t1, X.TEMP t)] + m @ munch_exp (X.TEMP t) e2 + @ [X.MOV(X.OSIZE (X.sts sz, r), X.TEMP t)] end - | munch_stm (T.MOVE(_, _)) = - raise ErrorMsg.InternalError "Incorrect first operand for T.MOVE?" - | munch_stm (T.RETURN(e)) = + | munch_stm (T.RETURN(e, sz)) = let - val t = Temp.new ("retval") + val t = Temp.new ("retval") sz in munch_exp (X.TEMP t) e - @ [X.MOV(X.REG X.EAX, X.TEMP t), X.RET] + @ [X.MOV(X.OSIZE (X.sts sz, X.REG X.EAX), X.TEMP t), X.RET] end | munch_stm (T.LABEL(l)) = [X.LABEL l] | munch_stm (T.JUMP(l)) = [X.JMP l] @@ -430,6 +456,7 @@ struct in insns @ [X.Jcc (neg, l)] end + | munch_stm (T.EFFECT(exp, sz)) = let val t = X.TEMP (Temp.new "throwaway" sz) in munch_exp t exp end fun codegen nil = nil | codegen (stm::stms) = munch_stm stm @ codegen stms diff --git a/codegen/liveness.sml b/codegen/liveness.sml index 24123b9..4c8e4ad 100644 --- a/codegen/liveness.sml +++ b/codegen/liveness.sml @@ -77,10 +77,14 @@ struct * helper functions to discard constant operands *) fun defhit (X.REG a) = [DEF(X.REG a)] | defhit (X.TEMP a) = [DEF(X.TEMP a)] + | defhit (X.REL(o1, o2)) = usehit o1 @ usehit o2 + | defhit (X.OSIZE(s, oo)) = defhit oo | defhit (_) = nil - fun usehit (X.REG a) = [USE(X.REG a)] + and usehit (X.REG a) = [USE(X.REG a)] | usehit (X.TEMP a) = [USE(X.TEMP a)] + | usehit (X.REL(o1, o2)) = usehit o1 @ usehit o2 + | usehit (X.OSIZE(s, oo)) = usehit oo | usehit (_) = nil fun callhit 0 = nil @@ -98,8 +102,8 @@ struct fun gendef (n, X.DIRECTIVE(_)) = (nil) | gendef (n, X.COMMENT(_)) = (nil) | gendef (n, X.LIVEIGN (_)) = ([SUCC (n+1)]) - | gendef (n, X.SIZE(_, i)) = gendef (n,i) | gendef (n, X.MOV(dest, src)) = (defhit dest @ usehit src @ [SUCC(n+1), ISMOVE]) + | gendef (n, X.LEA(dest, src)) = (defhit dest @ usehit src @ [SUCC(n+1)]) | gendef (n, X.SUB(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) | gendef (n, X.IMUL(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) | gendef (n, X.IMUL3(dest, src, _)) = (defhit dest @ usehit src @ [SUCC(n+1)]) diff --git a/codegen/peephole.sml b/codegen/peephole.sml index 7fa4554..7bf55a1 100644 --- a/codegen/peephole.sml +++ b/codegen/peephole.sml @@ -40,7 +40,6 @@ struct | peephole (X.CMP (X.REG r, X.CONST 0w0)::l) = (X.TEST (X.REG r, X.REG r))::(peephole l) | peephole ((X.JMP a)::(X.JMP b)::l) = peephole ((X.JMP a)::l) (* What the cock? Yes, we actually generate this. *) | peephole ((X.JMP l1)::(X.LABEL l2)::l) = if (Label.compare (l1,l2) = EQUAL) then (X.LABEL l2)::(peephole l) else (X.JMP l1)::(X.LABEL l2)::(peephole l) - | peephole (X.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 diff --git a/codegen/solidify.sml b/codegen/solidify.sml index 8c39017..21b37bc 100644 --- a/codegen/solidify.sml +++ b/codegen/solidify.sml @@ -26,12 +26,12 @@ struct fun solidify (regmap : colorings) (instrs : asm) : asm = let (* r14d and r15d is reserved for spilling *) - val maxreg = X.regtonum X.R14D + val maxreg = X.regtonum X.R13D fun numtoreg n = if (n > maxreg) then raise Spilled else X.numtoreg n - + fun temptonum (t: T.temp) : int = (List.hd (List.map (fn (_, n) => n) @@ -42,9 +42,10 @@ struct handle Empty => raise ErrorMsg.InternalError ("Uncolored temp "^(Temp.name t)^", agh!") val spillreg1 = X.R15D + val spillreg2 = X.R14D (* Determine which need to be saved. *) - val opsused = map (fn (_, n) => X.REG (numtoreg n handle Spilled => X.R15D)) regmap + val opsused = (map (fn (_, n) => X.REG (numtoreg n handle Spilled => X.R15D)) regmap) @ [X.REG X.R14D] val saveregs = X.OperSet.intersection ( X.OperSet.addList (X.OperSet.empty, opsused), X.OperSet.addList ( @@ -58,99 +59,135 @@ struct val savelist = X.OperSet.listItems saveregs val nsave = length savelist - val numreg = foldr (Int.max) 0 (map (fn (_, n) => n) regmap) (* Number of registers used. *) - val nspilled = Int.max (numreg - maxreg, 0) (* Number of spilled registers. *) - fun isspilled (X.TEMP temp) = (((temptonum temp) > maxreg) handle Empty => false) (* Whether a register is spilled *) + val numreg = foldr (Int.max) 0 (map (fn (_, n) => n) regmap) (* Number of registers used. *) + val nspilled = Int.max (numreg - maxreg, 0) (* Number of spilled registers. *) + fun isspilled (X.TEMP temp) = (temptonum temp) > maxreg (* Whether a register is spilled *) | isspilled (X.STACKARG _) = true | isspilled (X.REL _) = true + | isspilled (X.OSIZE (_, oo)) = isspilled oo | isspilled _ = false val stacksz = (nspilled + nsave) * 8 - fun stackpos (reg: int) = stacksz - (reg - maxreg + nsave) * 8 (* Stack position of some register number *) + fun stackpos (reg: int) = stacksz - (reg - maxreg + nsave) * 8 (* Stack position of some register number *) val prologue = - (X.SIZE (X.Qword, X.SUB (X.REG X.RSP, X.CONST (Word32.fromInt stacksz)))) :: + (X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))) :: (ListPair.map (fn (num, reg) => - X.SIZE (X.Qword, X.MOV (X.REL (X.RSP, stacksz - 8*(num+1)), reg))) + X.MOV (X.OSIZE (X.Qword, X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz - 8*(num+1))))), X.OSIZE (X.Qword, reg))) (List.tabulate (nsave, fn x => x), savelist)) val epilogue = (ListPair.map (fn (num, reg) => - X.SIZE (X.Qword, X.MOV (reg, X.REL (X.RSP, stacksz - 8*(num+1))))) + X.MOV (X.OSIZE (X.Qword, reg), X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz - 8*(num+1)))))) (List.tabulate (nsave, fn x => x), savelist)) @ - [X.SIZE (X.Qword, X.ADD (X.REG X.RSP, X.CONST (Word32.fromInt stacksz)))] + [X.ADD (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))] val endlbl = Label.new() - fun spill (X.TEMP temp, xreg: x86.reg) = (* Spill a register if need be. *) + fun spill s (X.TEMP temp, xreg: x86.reg) = (* Spill a register if need be. *) if (isspilled (X.TEMP temp)) - then [X.MOV (X.REL (X.RSP, stackpos (temptonum temp)), X.REG xreg)] + then [X.MOV (X.OSIZE(s, X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp)), X.REG xreg)] else nil - | spill (X.STACKARG _, _) = raise ErrorMsg.InternalError "Cannot spill to a stack arg" - | spill (a as X.REL _, xreg) = [X.MOV (a, X.REG xreg)] - | spill _ = nil (* Nothing else can be spilled. *) - fun unspill (X.TEMP temp, xreg: x86.reg) = (* Unspill a register if need be. *) + | spill s (X.STACKARG _, _) = raise ErrorMsg.InternalError "Cannot spill to a stack arg" + | spill s (a as X.REL _, xreg) = [X.MOV (X.OSIZE(s,a), X.REG xreg)] + | spill s (X.OSIZE (s', oo), xreg) = spill s' (X.stripsize oo, xreg) + | spill _ _ = nil (* Nothing else can be spilled. *) + fun unspill s (X.TEMP temp, xreg: x86.reg) = (* Unspill a register if need be. *) if (isspilled (X.TEMP temp)) - then [X.MOV (X.REG xreg, X.REL (X.RSP, stackpos (temptonum temp)))] + then [X.MOV (X.OSIZE(s, X.REG xreg), X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp))] else nil - | unspill (X.STACKARG arg, xreg) = [X.MOV (X.REG xreg, X.REL (X.RSP, stacksz + 8 + (arg * 8)))] - | unspill (a as X.REL _, xreg) = [X.MOV (X.REG xreg, a)] - | unspill _ = nil + | unspill s (X.STACKARG arg, xreg) = [X.MOV (X.OSIZE(s, X.REG xreg), X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz + 8 + (arg * 8)))))] + | unspill s (a as X.REL _, xreg) = [X.MOV (X.OSIZE(s, X.REG xreg), a)] + | unspill s (X.OSIZE (s', oo), xreg) = unspill s' (X.stripsize oo, xreg) + | unspill _ _ = nil - fun realoper (X.TEMP temp) = X.REG (temptoreg temp) (* Makes a operand 'real'. *) + fun realoper (X.TEMP temp) = X.OSIZE (X.sts (Temp.size temp), X.REG (temptoreg temp)) (* Makes a operand 'real'. *) | realoper (X.STACKARG arg) = raise Spilled | realoper (X.REL _) = raise Spilled + | realoper (X.OSIZE (s, oo)) = X.OSIZE (s, realoper (X.stripsize oo)) | realoper r = r fun stackoper (X.TEMP temp) = if not (isspilled (X.TEMP temp)) then raise ErrorMsg.InternalError "stackoper on unspilled temp?" - else X.REL (X.RSP, stackpos (temptonum temp)) - | stackoper (X.STACKARG arg) = X.REL (X.RSP, stacksz + 8 + (arg * 8)) + else X.OSIZE (X.sts (Temp.size temp), X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp)) + | stackoper (X.STACKARG arg) = X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt) (stacksz + 8 + (arg * 8))) | stackoper (a as X.REL _) = a + | stackoper (X.OSIZE (s, oo)) = X.OSIZE (s, stackoper (X.stripsize oo)) | stackoper _ = raise ErrorMsg.InternalError "stackoper on not temp?" - + + fun ophit (X.OSIZE (s, oo)) = let val (insns, p) = ophit (X.stripsize oo) in (insns, X.OSIZE (s, p)) end + | ophit (X.REL(op1, op2)) = + let + val t1 = X.stripsize op1 + val (s, t2) = X.sizeoper op2 + in + if (isspilled t1 andalso isspilled t2) then + ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2), + X.ADD (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)], + X.REL (X.REG spillreg1, X.CONST 0w0)) + else if(isspilled t1) then + ([X.MOV (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)], + X.REL (X.REG spillreg1, realoper t2)) + else if(isspilled t2) then + ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2)], + X.REL (realoper t1, X.REG spillreg1)) + else + ([], + X.REL (realoper t1, realoper t2)) + end + | ophit a = (nil, realoper a handle Spilled => stackoper a) + fun transform (X.DIRECTIVE s) = [X.DIRECTIVE s] | transform (X.COMMENT s) = [X.COMMENT s] | transform (X.LIVEIGN a) = transform a - | transform (X.SIZE (s, i)) = map (fn i' => (X.SIZE (s, i'))) (transform i) | transform (X.MOV (dest, src)) = - if (isspilled dest) - then - unspill (src, spillreg1) @ - [X.MOV( - realoper dest handle Spilled => stackoper dest, - realoper src handle Spilled => X.REG spillreg1)] - else - [X.MOV( - realoper dest handle Spilled => raise ErrorMsg.InternalError "But we said that wasn't spilled?", - realoper src handle Spilled => stackoper src)] + let + val (insns1, realop1) = ophit dest + val (insns2, realop2) = ophit src + in + if(isspilled dest andalso isspilled src) then + insns2 @ [X.MOV (X.REG spillreg2, realop2)] @ insns1 @ [X.MOV (realop1, X.REG spillreg2)] + else + insns1 @ insns2 @ [X.MOV (realop1, realop2)] + end + | transform (X.LEA (dest, src)) = + let + val (insns1, realop1) = ophit dest + val (insns2, realop2) = ophit src + in + if(isspilled dest andalso isspilled src) then + insns2 @ [X.MOV (X.REG spillreg2, realop2)] @ insns1 @ [X.LEA (realop1, X.REG spillreg2)] + else + insns1 @ insns2 @ [X.LEA (realop1, realop2)] + end | transform (X.SUB (dest, src)) = - unspill (src, spillreg1) @ - [ X.SUB( - realoper dest handle Spilled => stackoper dest, - realoper src handle Spilled => X.REG spillreg1)] + let + val (insns, realop) = ophit dest + in + unspill X.Long (src, spillreg2) @ insns @ + [ X.SUB(realop, + realoper src handle Spilled => X.REG spillreg2)] + end | transform (X.IMUL (dest, src)) = - unspill (dest, spillreg1) @ + unspill X.Long (dest, spillreg1) @ [ X.IMUL( realoper dest handle Spilled => X.REG spillreg1, realoper src handle Spilled => stackoper src)] @ - spill (dest, spillreg1) + spill X.Long (dest, spillreg1) | transform (X.IMUL3 (dest, src, const)) = + unspill X.Long ((X.stripsize src), spillreg2) @ [ X.IMUL3( realoper dest handle Spilled => X.REG spillreg1, - realoper src handle Spilled => stackoper src, + realoper src handle Spilled => X.REG spillreg2, const)] @ - spill (dest, spillreg1) - | transform (X.ADD (dest, src)) = (* You can have either operand spilled, but not both. Pick one. *) - if (isspilled dest) - then - unspill (src, spillreg1) @ - [ X.ADD( - realoper dest handle Spilled => stackoper dest, - realoper src handle Spilled => X.REG spillreg1)] - else - [ X.ADD( - realoper dest handle Spilled => raise ErrorMsg.InternalError "But we said that wasn't spilled?", - realoper src handle Spilled => stackoper src)] + spill X.Long (dest, spillreg1) + | transform (X.ADD (dest, src)) = + let + val (insns, realop) = ophit dest + in + unspill X.Long (src, spillreg2) @ insns @ + [ X.ADD(realop, + realoper src handle Spilled => X.REG spillreg2)] + end | transform (X.IDIV (src)) = [ X.IDIV(realoper src handle Spilled => stackoper src)] | transform (X.NEG (src)) = [ X.NEG(realoper src handle Spilled => stackoper src)] | transform (X.NOT (src)) = [ X.NOT(realoper src handle Spilled => stackoper src)] @@ -164,27 +201,27 @@ struct shft)] | transform (X.CLTD) = [ X.CLTD ] | transform (X.AND (dest, src)) = - unspill (src, spillreg1) @ + unspill X.Long (src, spillreg1) @ [ X.AND( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] | transform (X.OR (dest, src)) = - unspill (src, spillreg1) @ + unspill X.Long (src, spillreg1) @ [ X.OR( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] | transform (X.XOR (dest, src)) = - unspill (src, spillreg1) @ + unspill X.Long (src, spillreg1) @ [ X.XOR( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] | transform (X.CMP (op1, op2)) = - unspill (op2, spillreg1) @ + unspill X.Long (op2, spillreg1) @ [ X.CMP( realoper op1 handle Spilled => stackoper op1, realoper op2 handle Spilled => X.REG spillreg1)] | transform (X.TEST (op1, op2)) = - unspill (op2, spillreg1) @ + unspill X.Long (op2, spillreg1) @ [ X.TEST( realoper op1 handle Spilled => stackoper op1, realoper op2 handle Spilled => X.REG spillreg1)] @@ -194,7 +231,7 @@ struct [ X.MOVZB( realoper dest handle Spilled => X.REG spillreg1, realoper src handle Spilled => stackoper src)] - @ spill (dest, spillreg1) + @ spill X.Long (dest, spillreg1) | transform (X.RET) = if nsave < 2 then (epilogue @ [X.RET]) else [X.JMP endlbl] | transform (X.LABEL l) = [ X.LABEL l ] | transform (X.JMP l) = [ X.JMP l ] diff --git a/codegen/stringifier.sml b/codegen/stringifier.sml index 74fe8c1..5010d7b 100644 --- a/codegen/stringifier.sml +++ b/codegen/stringifier.sml @@ -18,8 +18,8 @@ struct (* val stringify : asm -> string * turns a x86 instruction list into a string of assembly code for these instructions *) - 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 diff --git a/codegen/x86.sml b/codegen/x86.sml index 6ec4263..e54d4be 100644 --- a/codegen/x86.sml +++ b/codegen/x86.sml @@ -10,16 +10,16 @@ sig datatype reg = EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D (* operands to instructions *) - datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (reg * int) | STACKARG of int | STR of string - datatype cc = E | NE | GE | LE | L | G datatype size = Byte | Word | Long | Qword + datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (oper * oper) | STACKARG of int | OSIZE of (size * oper) + datatype cc = E | NE | GE | LE | L | G (* instructions *) datatype insn = DIRECTIVE of string | COMMENT of string | LABEL of Label.label | - SIZE of size * insn | MOV of oper * oper | + LEA of oper * oper | SUB of oper * oper | IMUL of oper * oper | IMUL3 of oper * oper * Word32.word | @@ -48,6 +48,10 @@ sig structure LiveMap : ORD_MAP where type Key.ord_key = int; + val sts : int -> size + val sizeoper : oper -> size * oper + val stripsize : oper -> oper + val osize : oper -> size val cmpoper : oper * oper -> order val opereq : oper * oper -> bool val regname : size -> reg -> string @@ -56,7 +60,7 @@ sig val ccname : cc -> string val opsused : insn list -> OperSet.set val prettyprint_oper : size -> oper -> string - val prettyprint : size -> insn -> string + val prettyprint : insn -> string end structure x86 :> X86 = @@ -65,15 +69,15 @@ struct datatype reg = EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D - datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (reg * int) | STACKARG of int | STR of string - datatype cc = E | NE | GE | LE | L | G datatype size = Byte | Word | Long | Qword + datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (oper * oper) | STACKARG of int | OSIZE of (size * oper) + datatype cc = E | NE | GE | LE | L | G datatype insn = DIRECTIVE of string | COMMENT of string | LABEL of Label.label | - SIZE of size * insn | MOV of oper * oper | + LEA of oper * oper | SUB of oper * oper | IMUL of oper * oper | IMUL3 of oper * oper * Word32.word | @@ -182,11 +186,11 @@ struct | cmpoper (CONST(const1), CONST(const2)) = Word32.compare (const1, const2) | cmpoper (REL (r1, i1), REL (r2, i2)) = let - val regorder = regcmp (r1, r2) - val intorder = Int.compare (i1, i2) + val order1 = cmpoper (r1, r2) + val order2 = cmpoper (i1, i2) in - if (regorder = EQUAL) then intorder - else regorder + if (order1 = EQUAL) then order2 + else order1 end | cmpoper (CONST _, _) = LESS | cmpoper (REG _, _) = LESS @@ -196,7 +200,8 @@ struct fun opereq (REG a, REG b) = a = b | opereq (TEMP a, TEMP b) = Temp.eq (a, b) | opereq (CONST a, CONST b) = a = b - | opereq (REL (ra, ia), REL (rb, ib)) = (ra = rb) andalso (ia = ib) + | opereq (REL (a1, b1), REL (a2, b2)) = opereq (a1,a2) andalso opereq (b1,b2) +(* | opereq (OSIZE (s1, o1), OSIZE (s2, o2)) = (s1 = s2) andalso opereq (o1, o2)*) (* This breaks the peepholer, shit *) | opereq (_, _) = false structure OperSet = ListSetFn ( @@ -215,6 +220,7 @@ struct | opsused ((COMMENT _)::l) = opsused l | opsused ((LABEL _)::l) = opsused l | opsused ((MOV (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((LEA (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) | opsused ((SUB (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) | opsused ((IMUL (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) | opsused ((IMUL3 (dst, src, _))::l) = OperSet.addList (opsused l, [dst, src]) @@ -237,53 +243,63 @@ struct | opsused ((CLTD)::l) = opsused l | opsused ((RET)::l) = opsused l | opsused ((LIVEIGN i)::l) = opsused (i::l) - | opsused ((SIZE (_, i))::l) = opsused (i::l) - (* integer tostring, except with more - and less ~ *) - fun moreDifferentToString (i) = - if (i >= 0) then Int.toString i - else "-" ^ (Int.toString (~i)) + fun sts 8 = Qword + | sts 4 = Long + | sts 2 = Word + | sts 1 = Byte + | sts _ = raise ErrorMsg.InternalError "invalid size" (* pretty prints an operand *) fun sfx Byte = "b" | sfx Word = "w" | sfx Long = "l" | sfx Qword = "q" - + + fun osize (OSIZE (s, _)) = s + | osize _ = Long + + fun stripsize (OSIZE (_, oo)) = stripsize oo + | stripsize oo = oo + + fun sizeoper (OSIZE (s, oo)) = (s, stripsize oo) + | sizeoper oo = (Long, oo) + fun prettyprint_oper s (REG r) = "%" ^ (regname s r) - | prettyprint_oper s (TEMP t) = (Temp.name t) ^ (sfx s) + | prettyprint_oper _ (TEMP t) = (Temp.name t) ^ (sfx (sts (Temp.size t))) | prettyprint_oper _ (CONST c) = "$0x" ^ (Word32.toString c) - | prettyprint_oper _ (REL (r, i)) = (moreDifferentToString i) ^ "(%" ^ (regname Qword r) ^ ")" - | prettyprint_oper _ (STR s) = s + | prettyprint_oper _ (REL (r, CONST n)) = (Word32Signed.toString n) ^ "(" ^ (prettyprint_oper Qword r) ^ ")" + | prettyprint_oper s (REL (r1, r2)) = "(" ^ (prettyprint_oper Qword (stripsize r1)) ^ "," ^ (prettyprint_oper Qword (stripsize r2)) ^ ")" | prettyprint_oper _ (STACKARG i) = "arg#"^Int.toString i + | prettyprint_oper _ (OSIZE (s, oo)) = prettyprint_oper s (stripsize oo) (* pretty prints (no...) *) - fun prettyprint 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 diff --git a/compile-l3c.sml b/compile-l4c.sml similarity index 72% rename from compile-l3c.sml rename to compile-l4c.sml index a8f95ec..7299ee8 100644 --- a/compile-l3c.sml +++ b/compile-l4c.sml @@ -4,4 +4,4 @@ *) CM.make "sources.cm"; -SMLofNJ.exportFn ("bin/l3c.heap", Top.main); +SMLofNJ.exportFn ("bin/l4c.heap", Top.main); diff --git a/parse/ast.sml b/parse/ast.sml index fce70ab..84b2356 100644 --- a/parse/ast.sml +++ b/parse/ast.sml @@ -13,8 +13,12 @@ signature AST = sig type ident = Symbol.symbol - datatype vtype = Int + datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull + val typeeq : vtype * vtype -> bool + val castable : vtype * vtype -> bool (* true if the second type can be casted to the first implicitly *) type variable = ident * vtype + datatype typedef = Struct of variable list + | MarkedTypedef of typedef Mark.marked datatype oper = PLUS @@ -45,8 +49,17 @@ sig | OpExp of oper * exp list | Marked of (* Kane *) exp Mark.marked | FuncCall of ident * (exp list) + | Member of exp * ident + | DerefMember of exp * ident + | Dereference of exp + | ArrIndex of exp * exp + | New of vtype + | NewArr of vtype * exp + | Null and stm = - Assign of ident * exp + Assign of exp * exp + | AsnOp of oper * exp * exp + | Effect of exp (* Just side effect the expression *) | Return of exp | Nop | Break @@ -57,27 +70,39 @@ sig | MarkedStm of stm Mark.marked datatype function = - Extern of vtype * ident * (variable list) - | Function of vtype * ident * (variable list) * (variable list) * stm list + Extern of vtype * (variable list) + | Function of vtype * (variable list) * (variable list) * stm list + | MarkedFunction of function Mark.marked - type program = function list + type program = typedef Symbol.table * function Symbol.table (* print as source, with redundant parentheses *) structure Print : sig val pp_exp : exp -> string + val pp_type : vtype -> string val pp_stm : stm -> string val pp_program : program -> string end - end structure Ast :> AST = struct type ident = Symbol.symbol - datatype vtype = Int + datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull + fun typeeq (Int, Int) = true + | typeeq (Typedef a, Typedef b) = (Symbol.name a) = (Symbol.name b) + | typeeq (Pointer a, Pointer b) = typeeq (a, b) + | typeeq (Array a, Array b) = typeeq (a, b) + | typeeq (TNull, TNull) = true + | typeeq _ = false + fun castable (Pointer _, TNull) = true + | castable (Array _, TNull) = true + | castable (a, b) = typeeq (a, b) type variable = ident * vtype + datatype typedef = Struct of variable list + | MarkedTypedef of typedef Mark.marked datatype oper = PLUS @@ -108,8 +133,17 @@ struct | OpExp of oper * exp list | Marked of exp Mark.marked | FuncCall of ident * (exp list) + | Member of exp * ident + | DerefMember of exp * ident + | Dereference of exp + | ArrIndex of exp * exp + | New of vtype + | NewArr of vtype * exp + | Null and stm = - Assign of ident * exp + Assign of exp * exp + | AsnOp of oper * exp * exp + | Effect of exp (* Just side effect the expression *) | Return of exp | Nop | Break @@ -120,10 +154,11 @@ struct | MarkedStm of stm Mark.marked datatype function = - Extern of vtype * ident * (variable list) - | Function of vtype * ident * (variable list) * (variable list) * stm list + Extern of vtype * (variable list) + | Function of vtype * (variable list) * (variable list) * stm list + | MarkedFunction of function Mark.marked - type program = function list + type program = typedef Symbol.table * function Symbol.table (* print programs and expressions in source form * using redundant parentheses to clarify precedence @@ -166,22 +201,33 @@ struct | pp_exp (FuncCall(id, l)) = pp_ident id ^ "(" ^ pp_expl l ^ ")" | pp_exp (Marked(marked_exp)) = pp_exp (Mark.data marked_exp) + | pp_exp (Member(e, i)) = pp_exp e ^ "." ^ pp_ident i + | pp_exp (DerefMember(e, i)) = pp_exp e ^ "->" ^ pp_ident i + | pp_exp (Dereference(e)) = "*(" ^ pp_exp e ^ ")" + | pp_exp (ArrIndex(e1, e2)) = pp_exp e1 ^ "[" ^pp_exp e2 ^ "]" + | pp_exp (New t) = "new(" ^ pp_type t ^ ")" + | pp_exp (NewArr (t, s)) = "new(" ^ pp_type t ^ "[" ^ pp_exp s ^ "])" + | pp_exp Null = "NULL" and pp_expl nil = "" | pp_expl (e::a::l) = (pp_exp e) ^ ", " ^ (pp_expl (a::l)) | pp_expl (e::l) = (pp_exp e) ^ (pp_expl l) - fun pp_stm (Assign (id,e)) = - pp_ident id ^ " = " ^ pp_exp e ^ ";" + and pp_stm (Assign (e1,e2)) = + pp_exp e1 ^ " = " ^ pp_exp e2 ^ ";\n" + | pp_stm (AsnOp (oop, e1, e2)) = + pp_exp e1 ^ " " ^ pp_oper oop ^ "= " ^ pp_exp e2 ^ ";\n" + | pp_stm (Effect (e)) = + pp_exp e ^ ";\n" | pp_stm (Return e) = - "return " ^ pp_exp e ^ ";" - | pp_stm Nop = ";" - | pp_stm Break = "break;" - | pp_stm Continue = "continue;" - | pp_stm (If (e, s, NONE)) = "if ("^pp_exp e^")"^pp_block s - | pp_stm (If (e, s, SOME s2)) = "if ("^pp_exp e^")"^pp_block s^" else "^pp_block s2 - | pp_stm (While (e, s)) = "while ("^pp_exp e^") "^pp_block s - | pp_stm (For (so1, e, so2, s)) = "for ("^ (if (isSome so1) then pp_stm (valOf so1) else "") ^ pp_exp e ^ (if(isSome so2) then pp_stm (valOf so2) else "") ^ ")" ^ pp_block s + "return " ^ pp_exp e ^ ";\n" + | pp_stm Nop = ";\n" + | pp_stm Break = "break;\n" + | pp_stm Continue = "continue;\n" + | pp_stm (If (e, s, NONE)) = "if ("^pp_exp e^")\n"^pp_block s + | pp_stm (If (e, s, SOME s2)) = "if ("^pp_exp e^")\n"^pp_block s^"else\n"^pp_block s2 + | pp_stm (While (e, s)) = "while ("^pp_exp e^")\n"^pp_block s + | pp_stm (For (so1, e, so2, s)) = "for ("^ (if (isSome so1) then pp_stm (valOf so1) else "") ^ pp_exp e ^ (if(isSome so2) then pp_stm (valOf so2) else "") ^ ")\n" ^ pp_block s | pp_stm (MarkedStm m) = pp_stm (Mark.data m) and pp_block (nil) = ";" @@ -196,6 +242,10 @@ struct | pp_stms (s::ss) = pp_stm s ^ "\n" ^ pp_stms ss and pp_type Int = "int" + | pp_type (Typedef i) = pp_ident i + | pp_type (Pointer t) = pp_type t ^ "*" + | pp_type (Array t) = pp_type t ^ "[]" + | pp_type TNull = "{NULL type}" and pp_params nil = "" | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ ", " ^ (pp_params (a::l)) @@ -204,9 +254,13 @@ struct and pp_vars nil = "" | pp_vars ((i, t)::l) = "var " ^ (pp_ident i) ^ " : " ^ (pp_type t) ^ ";\n" ^ (pp_vars l) - and pp_function (Extern(t, n, pl)) = "extern " ^ (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ");\n" - | pp_function (Function(t, n, pl, vl, stms)) = (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ")\n{\n" ^ (pp_vars vl) ^ (String.concat (map pp_stm stms)) ^ "\n}\n" + and pp_function (n, Extern(t, pl)) = "extern " ^ (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ");\n" + | pp_function (n, Function(t, pl, vl, stms)) = (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ")\n{\n" ^ (pp_vars vl) ^ (String.concat (map pp_stm stms)) ^ "\n}\n" + | pp_function (n, MarkedFunction d) = pp_function (n, Mark.data d) + + and pp_typedef (i, Struct (v)) = "struct " ^ (pp_ident i) ^ " {\n" ^ (String.concat (map (fn (i', t) => " " ^ (pp_ident i') ^ " : " ^ (pp_type t) ^ ";\n") v)) ^ "}\n" + | pp_typedef (i, MarkedTypedef d) = pp_typedef (i, Mark.data d) - and pp_program (p) = String.concat (map pp_function p) + and pp_program (types, funs) = String.concat ((map pp_typedef (Symbol.elemsi types)) @ (map pp_function (Symbol.elemsi funs))) end end diff --git a/parse/astutils.sml b/parse/astutils.sml new file mode 100644 index 0000000..72bdaeb --- /dev/null +++ b/parse/astutils.sml @@ -0,0 +1,107 @@ +signature ASTUTILS = +sig + structure Program : + sig + val append_typedef : Ast.program -> (Ast.ident * Ast.typedef) -> Ast.program + val append_function : Ast.program -> (Ast.ident * Ast.function) -> Ast.program + end + + structure Typedef : + sig + val data : Ast.typedef -> Ast.typedef + val mark : Ast.typedef -> Mark.ext option + end + + structure Function : + sig + val data : Ast.function -> Ast.function + val mark : Ast.function -> Mark.ext option + val returntype : Ast.function -> Ast.vtype + val params : Ast.function -> Ast.variable list + end + + structure Type : + sig + val size : Ast.vtype -> int + val issmall : Ast.vtype -> bool + end +end + +structure AstUtils :> ASTUTILS = +struct + structure A = Ast + + structure Program = + struct + fun append_typedef (tds, fns) (i, td) = + let + val mark = case td + of A.MarkedTypedef m => Mark.ext m + | _ => NONE + val _ = case (Symbol.look tds i) + of SOME (A.MarkedTypedef m) => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ; + ErrorMsg.error (Mark.ext m) "(was originally defined here)" ; + raise ErrorMsg.Error) + | SOME _ => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ; + raise ErrorMsg.Error) + | _ => () + in + (Symbol.bind tds (i, td), fns) + end + fun append_function (tds, fns) (i, func) = + let + val mark = case func + of A.MarkedFunction m => Mark.ext m + | _ => NONE + val _ = case (Symbol.look fns i) + of SOME (A.MarkedFunction m) => (ErrorMsg.error mark ("Redefining function " ^ Symbol.name i) ; + ErrorMsg.error (Mark.ext m) "(was originally defined here)" ; + raise ErrorMsg.Error) + | SOME _ => (ErrorMsg.error mark ("Redefining function " ^ Symbol.name i) ; + raise ErrorMsg.Error) + | _ => () + in + (tds, Symbol.bind fns (i, func)) + end + end + + structure Typedef = + struct + fun data (A.MarkedTypedef m) = data (Mark.data m) + | data m = m + + fun mark (A.MarkedTypedef m) = Mark.ext m + | mark _ = NONE + end + + structure Function = + struct + fun data (A.MarkedFunction m) = data (Mark.data m) + | data m = m + + fun mark (A.MarkedFunction m) = Mark.ext m + | mark _ = NONE + + fun returntype (A.MarkedFunction m) = returntype (Mark.data m) + | returntype (A.Function (r, _, _, _)) = r + | returntype (A.Extern (r, _)) = r + + fun params (A.MarkedFunction m) = params (Mark.data m) + | params (A.Function (_, pl, _, _)) = pl + | params (A.Extern (_, pl)) = pl + end + + structure Type = + struct + fun size A.Int = 4 + | size (A.Typedef _) = raise ErrorMsg.InternalError "AU.Type.size on non-small type?" + | size (A.Pointer _) = 8 + | size (A.Array _) = 8 + | size A.TNull = 8 + + fun issmall A.Int = true + | issmall (A.Pointer _) = true + | issmall (A.Array _) = true + | issmall _ = false + end +end diff --git a/parse/l3.grm b/parse/l4.grm similarity index 62% rename from parse/l3.grm rename to parse/l4.grm index cbf92ea..3f14c33 100644 --- a/parse/l3.grm +++ b/parse/l4.grm @@ -1,5 +1,5 @@ -(* L3 Compiler - * L3 grammar +(* L4 Compiler + * L4 grammar * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning * Modified: Joshua Wise @@ -7,12 +7,16 @@ *) structure A = Ast +structure AU = AstUtils +structure AUP = AstUtils.Program (* for simplicity, we only mark expressions, not statements *) (* mark e with region (left, right) in source file *) fun mark (e, (left, right)) = A.Marked (Mark.mark' (e, ParseState.ext (left, right))) fun markstm (e, (left, right)) = A.MarkedStm (Mark.mark' (e, ParseState.ext (left, right))) +fun markfunction (e, (left, right)) = A.MarkedFunction (Mark.mark' (e, ParseState.ext (left, right))) +fun marktypedef (e, (left, right)) = A.MarkedTypedef (Mark.mark' (e, ParseState.ext (left, right))) (* create lval from expression; here just an id *) (* generates error if not an identifier *) @@ -22,19 +26,8 @@ fun make_lval (A.Var(id)) ext = id | make_lval _ ext = ( ErrorMsg.error ext "not a variable" ; Symbol.bogus ) -(* expand_asnop (exp1, "op=", exp2) region = "exp1 = exp1 op exps" - * or = "exp1 = exp2" if asnop is "=" - * generates error if exp1 is an lval (identifier) - * syntactically expands a compound assignment operator - *) -fun expand_asnop (exp1, NONE, exp2) (left, right) = - A.Assign(make_lval exp1 NONE, exp2) - | expand_asnop (exp1, SOME(oper), exp2) (left, right) = - A.Assign(make_lval exp1 NONE, - mark(A.OpExp(oper, [exp1, exp2]), (left, right))) - %% -%header (functor L3LrValsFn (structure Token : TOKEN)) +%header (functor L4LrValsFn (structure Token : TOKEN)) %term EOF @@ -49,10 +42,11 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = | LBRACE | RBRACE | LPAREN | RPAREN | UNARY | ASNOP (* dummy *) - | EXTERN | VAR | INT | COLON | COMMA + | EXTERN | VAR | INT | COLON | COMMA | STRUCT | NULL | LBRACKET | RBRACKET | ARROW | DOT | NEW %nonterm program of A.program + | programx of A.program | stms of A.stm list | stm of A.stm | simp of A.stm @@ -60,18 +54,20 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = | exp of A.exp | explist of A.exp list | control of A.stm - | asnop of A.oper option + | asnop of A.oper | block of A.stm list | simpoption of A.stm option | elseoption of A.stm list option | idents of A.ident list | vtype of A.vtype - | extdecls of A.function list - | extdecl of A.function + | decls of A.program + | extdecl of A.ident * A.function | paramlist of A.variable list | param of A.variable - | functions of A.function list - | function of A.function + | typedecl of A.ident * A.typedef + | memberlist of (A.ident * A.vtype) list + | member of (A.ident * A.vtype) + | function of A.ident * A.function | vardecl of A.variable list | vardecls of A.variable list @@ -81,7 +77,7 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = %eop EOF %noshift EOF -%name L3 +%name L4 %left LOGOR %left LOGAND @@ -94,36 +90,49 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = %left PLUS MINUS %left STAR SLASH PERCENT %right UNARY -%left LPAREN +%left LPAREN LBRACKET ARROW DOT %% -program : extdecls functions (extdecls @ functions) +program : programx (programx) + +programx : decls (decls) + | programx function (AUP.append_function programx function) vtype : INT (A.Int) + | IDENT (A.Typedef IDENT) + | vtype STAR (A.Pointer vtype) + | vtype LBRACKET RBRACKET + (A.Array vtype) -extdecls : ([]) - | extdecl extdecls (extdecl :: extdecls) +decls : (Symbol.empty, Symbol.empty) + | typedecl decls (AUP.append_typedef decls typedecl) + | extdecl decls (AUP.append_function decls extdecl) extdecl : EXTERN vtype IDENT LPAREN RPAREN SEMI - (A.Extern (vtype, IDENT, [])) - | EXTERN vtype IDENT LPAREN param RPAREN SEMI - (A.Extern (vtype, IDENT, [param])) + (IDENT, markfunction (A.Extern (vtype, []), (EXTERNleft, SEMIright))) | EXTERN vtype IDENT LPAREN paramlist RPAREN SEMI - (A.Extern (vtype, IDENT, paramlist)) + (IDENT, markfunction (A.Extern (vtype, paramlist), (EXTERNleft, SEMIright))) paramlist : param COMMA paramlist (param :: paramlist) | param ([param]) param : IDENT COLON vtype (IDENT, vtype) -functions : ([]) - | function functions (function :: functions) +typedecl : STRUCT IDENT LBRACE RBRACE SEMI + (IDENT, marktypedef (A.Struct ([]), (STRUCTleft, SEMIright))) + | STRUCT IDENT LBRACE memberlist RBRACE SEMI + (IDENT, marktypedef (A.Struct (memberlist), (STRUCTleft, SEMIright))) + +memberlist : member memberlist (member :: memberlist) + | member ([member]) + +member : IDENT COLON vtype SEMI (IDENT, vtype) -function : vtype IDENT LPAREN RPAREN LBRACE vardecls stms RBRACE - (A.Function (vtype, IDENT, [], vardecls, stms)) - | vtype IDENT LPAREN paramlist RPAREN LBRACE vardecls stms RBRACE - (A.Function (vtype, IDENT, paramlist, vardecls, stms)) +function : vtype IDENT LPAREN paramlist RPAREN LBRACE vardecls stms RBRACE + (IDENT, markfunction (A.Function (vtype, paramlist, vardecls, stms), (vtypeleft, RBRACEright))) + | vtype IDENT LPAREN RPAREN LBRACE vardecls stms RBRACE + (IDENT, markfunction (A.Function (vtype, [], vardecls, stms), (vtypeleft, RBRACEright))) vardecls : ([]) | vardecl vardecls (vardecl @ vardecls) @@ -141,8 +150,11 @@ stm : simp SEMI (simp) | control (control) | SEMI (A.Nop) -simp : exp asnop exp %prec ASNOP - (expand_asnop (exp1, asnop, exp2) (exp1left, exp2right)) +simp : exp ASSIGN exp %prec ASNOP + (A.Assign(exp1, exp2)) + | exp asnop exp %prec ASNOP + (A.AsnOp(asnop, exp1, exp2)) + | exp (markstm (A.Effect (exp), (expleft, expright))) control : IF LPAREN exp RPAREN block elseoption (markstm ((A.If (exp, block, elseoption)), (IFleft, elseoptionright))) @@ -166,6 +178,11 @@ block : stm ([stm]) exp : LPAREN exp RPAREN (exp) | INTNUM (mark (A.ConstExp(INTNUM),(INTNUMleft,INTNUMright))) | IDENT (mark (A.Var(IDENT), (IDENTleft,IDENTright))) + | exp DOT IDENT (mark (A.Member(exp, IDENT), (expleft, IDENTright))) + | exp ARROW IDENT (mark (A.DerefMember(exp, IDENT), (expleft, IDENTright))) + | STAR exp %prec UNARY (mark (A.Dereference(exp), (STARleft, expright))) + | exp LBRACKET exp RBRACKET + (mark (A.ArrIndex(exp1, exp2), (exp1left, exp2right))) | exp PLUS exp (mark (A.OpExp (A.PLUS, [exp1,exp2]), (exp1left,exp2right))) | exp MINUS exp (mark (A.OpExp (A.MINUS, [exp1,exp2]), (exp1left,exp2right))) | exp STAR exp (mark (A.OpExp (A.TIMES, [exp1,exp2]), (exp1left,exp2right))) @@ -184,11 +201,14 @@ exp : LPAREN exp RPAREN (exp) | exp LE exp (mark (A.OpExp (A.LE, [exp1,exp2]), (exp1left,exp2right))) | exp GT exp (mark (A.OpExp (A.GT, [exp1,exp2]), (exp1left,exp2right))) | exp GE exp (mark (A.OpExp (A.GE, [exp1,exp2]), (exp1left,exp2right))) + | NULL (mark (A.Null, (NULLleft, NULLright))) | IDENT LPAREN RPAREN (mark (A.FuncCall(IDENT, []), (IDENTleft, RPARENright))) - | IDENT LPAREN exp RPAREN - (mark (A.FuncCall(IDENT, [exp]), (IDENTleft, RPARENright))) | IDENT LPAREN explist RPAREN (mark (A.FuncCall(IDENT, explist), (IDENTleft, RPARENright))) + | NEW LPAREN vtype RPAREN + (mark (A.New (vtype), (NEWleft, RPARENright))) + | NEW LPAREN vtype LBRACKET exp RBRACKET RPAREN + (mark (A.NewArr (vtype, exp), (NEWleft, RPARENright))) | MINUS exp %prec UNARY (mark (A.OpExp (A.NEGATIVE, [exp]), (MINUSleft,expright))) | BITNOT exp %prec UNARY (mark (A.OpExp (A.BITNOT, [exp]), (BITNOTleft,expright))) | BANG exp %prec UNARY (mark (A.OpExp (A.BANG, [exp]), (BANGleft,expright))) @@ -196,14 +216,13 @@ exp : LPAREN exp RPAREN (exp) explist : exp ([exp]) | exp COMMA explist (exp :: explist) -asnop : ASSIGN (NONE) - | PLUSEQ (SOME(A.PLUS)) - | MINUSEQ (SOME(A.MINUS)) - | STAREQ (SOME(A.TIMES)) - | SLASHEQ (SOME(A.DIVIDEDBY)) - | PERCENTEQ (SOME(A.MODULO)) - | LSHEQ (SOME(A.LSH)) - | RSHEQ (SOME(A.RSH)) - | BITOREQ (SOME(A.BITOR)) - | BITANDEQ (SOME(A.BITAND)) - | BITXOREQ (SOME(A.BITXOR)) +asnop : PLUSEQ (A.PLUS) + | MINUSEQ (A.MINUS) + | STAREQ (A.TIMES) + | SLASHEQ (A.DIVIDEDBY) + | PERCENTEQ (A.MODULO) + | LSHEQ (A.LSH) + | RSHEQ (A.RSH) + | BITOREQ (A.BITOR) + | BITANDEQ (A.BITAND) + | BITXOREQ (A.BITXOR) diff --git a/parse/l3.lex b/parse/l4.lex similarity index 91% rename from parse/l3.lex rename to parse/l4.lex index d9c2217..b988c35 100644 --- a/parse/l3.lex +++ b/parse/l4.lex @@ -1,4 +1,4 @@ -(* L3 Compiler +(* L4 Compiler * Lexer * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning @@ -51,7 +51,7 @@ in end %% -%header (functor L3LexFn(structure Tokens : L3_TOKENS)); +%header (functor L4LexFn(structure Tokens : L4_TOKENS)); %full %s COMMENT COMMENT_LINE; @@ -108,6 +108,11 @@ ws = [\ \t\012]; ":" => (Tokens.COLON (yypos, yypos + size yytext)); "," => (Tokens.COMMA (yypos, yypos + size yytext)); + "[" => (Tokens.LBRACKET (yypos, yypos + size yytext)); + "]" => (Tokens.RBRACKET (yypos, yypos + size yytext)); + "->" => (Tokens.ARROW (yypos, yypos + size yytext)); + "." => (Tokens.DOT (yypos, yypos + size yytext)); + "return" => (Tokens.RETURN (yypos, yypos + size yytext)); "if" => (Tokens.IF (yypos, yypos + size yytext)); "while" => (Tokens.WHILE (yypos, yypos + size yytext)); @@ -118,6 +123,9 @@ ws = [\ \t\012]; "var" => (Tokens.VAR (yypos, yypos + size yytext)); "int" => (Tokens.INT (yypos, yypos + size yytext)); "extern" => (Tokens.EXTERN (yypos, yypos + size yytext)); + "struct" => (Tokens.STRUCT (yypos, yypos + size yytext)); + "NULL" => (Tokens.NULL (yypos, yypos + size yytext)); + "new" => (Tokens.NEW (yypos, yypos + size yytext)); {decnum} => (number (yytext, yypos)); diff --git a/parse/parse.sml b/parse/parse.sml index aa701c4..3786421 100644 --- a/parse/parse.sml +++ b/parse/parse.sml @@ -1,4 +1,4 @@ -(* L3 Compiler +(* L4 Compiler * Parsing * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning @@ -17,10 +17,10 @@ end structure Parse :> PARSE = struct - structure L3LrVals = L3LrValsFn (structure Token = LrParser.Token) - structure L3Lex = L3LexFn (structure Tokens = L3LrVals.Tokens) - structure L3Parse = Join (structure ParserData = L3LrVals.ParserData - structure Lex = L3Lex + structure L4LrVals = L4LrValsFn (structure Token = LrParser.Token) + structure L4Lex = L4LexFn (structure Tokens = L4LrVals.Tokens) + structure L4Parse = Join (structure ParserData = L4LrVals.ParserData + structure Lex = L4Lex structure LrParser = LrParser) (* Main parsing function *) @@ -31,9 +31,9 @@ struct val _ = ParseState.setfile filename (* start at position 0 in filename *) fun parseerror (s, p1, p2) = ErrorMsg.error (ParseState.ext (p1,p2)) s val lexer = LrParser.Stream.streamify - (L3Lex.makeLexer (fn _ => TextIO.input instream)) + (L4Lex.makeLexer (fn _ => TextIO.input instream)) (* 0 = no error correction, 15 = reasonable lookahead for correction *) - val (absyn, _) = L3Parse.parse(0, lexer, parseerror, ()) + val (absyn, _) = L4Parse.parse(0, lexer, parseerror, ()) val _ = if !ErrorMsg.anyErrors then raise ErrorMsg.Error else () diff --git a/sources.cm b/sources.cm index 3dd6fa1..351df5f 100644 --- a/sources.cm +++ b/sources.cm @@ -11,9 +11,10 @@ Group is util/word32.sml parse/ast.sml + parse/astutils.sml parse/parsestate.sml - parse/l3.lex - parse/l3.grm + parse/l4.lex + parse/l4.grm parse/parse.sml type/typechecker.sml @@ -26,7 +27,6 @@ Group is codegen/x86.sml codegen/codegen.sml - codegen/igraph.sml codegen/colororder.sml codegen/solidify.sml diff --git a/sources.mlb b/sources.mlb index d97bba4..0f45274 100644 --- a/sources.mlb +++ b/sources.mlb @@ -10,10 +10,11 @@ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb util/word32.sml parse/ast.sml + parse/astutils.sml parse/parsestate.sml - parse/l3.grm.sig - parse/l3.grm.sml - parse/l3.lex.sml + parse/l4.grm.sig + parse/l4.grm.sml + parse/l4.lex.sml parse/parse.sml type/typechecker.sml diff --git a/top/top.sml b/top/top.sml index 5e564b1..c350c09 100644 --- a/top/top.sml +++ b/top/top.sml @@ -73,18 +73,18 @@ struct fun processir externs (Tree.FUNCTION (id, ir)) = let - val name = "_l3_" ^ (Symbol.name id) + val name = "_l4_" ^ (Symbol.name id) fun realname s = if (List.exists (fn n => s = n) externs) then s - else "_l3_" ^ s + else "_l4_" ^ s val _ = Flag.guard flag_verbose say ("Processing function: " ^ name) val _ = Flag.guard flag_verbose say " Generating proto-x86_64 code..." val assem = Codegen.codegen ir val _ = Flag.guard flag_assem - (fn () => List.app (TextIO.print o (x86.prettyprint x86.Long)) assem) () + (fn () => List.app (TextIO.print o (x86.prettyprint)) assem) () val _ = Flag.guard flag_verbose say " Analyzing liveness..." val (preds, liveness) = Liveness.liveness assem; @@ -93,7 +93,7 @@ struct (fn (asm, liv) => TextIO.print ( let - val xpp = x86.prettyprint x86.Long asm + val xpp = x86.prettyprint asm val xpp = String.extract (xpp, 0, SOME (size xpp - 1)) val spaces = implode (List.tabulate (40 - size xpp, fn _ => #" ")) handle size => "" val lpp = Liveness.prettyprint liv @@ -116,10 +116,10 @@ struct (fn () => List.app (TextIO.print o (fn (t, i) => (Temp.name t) ^ " => " ^ ( - if (i <= x86.regtonum x86.R14D) + if (i <= x86.regtonum x86.R13D) then (x86.prettyprint_oper x86.Long (x86.REG (x86.numtoreg i))) else - "spill[" ^ Int.toString (i - x86.regtonum x86.R14D) ^ "]") + "spill[" ^ Int.toString (i - x86.regtonum x86.R13D) ^ "]") ^ "--"^ Int.toString i ^ "\n")) colors) () @@ -165,22 +165,25 @@ struct val _ = Flag.guard flag_verbose say ("Parsing... " ^ source) val ast = Parse.parse source + val (_, funcs) = ast val _ = Flag.guard flag_ast (fn () => say (Ast.Print.pp_program ast)) () - - val externs = List.mapPartial - (fn (Ast.Function _) => NONE - | (Ast.Extern (_, s, _)) => SOME (Symbol.name s)) ast - + + val externs = Symbol.mapPartiali + (fn (a, b) => case (AstUtils.Function.data b) + of Ast.Extern _ => SOME(Symbol.name a) + | _ => NONE + ) funcs + val _ = Flag.guard flag_verbose say "Checking..." val ast = TypeChecker.typecheck ast - + val _ = Flag.guard flag_verbose say "Translating..." val ir = Trans.translate ast val _ = Flag.guard flag_ir (fn () => say (Tree.Print.pp_program ir)) () - val output = foldr (fn (func, code) => (processir externs func) ^ code) - (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 L3 compiler by czl@ and jwise@\"\n") ir + val output = foldr (fn (func, code) => (processir ("calloc" (* lololololol *) :: (Symbol.elems externs)) func) ^ code) + (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 L4 compiler by czl@ and jwise@\"\n") ir val afname = stem source ^ ".s" val _ = Flag.guard flag_verbose say ("Writing assembly to " ^ afname ^ " ...") diff --git a/trans/temp.sml b/trans/temp.sml index d370d99..1092dfc 100644 --- a/trans/temp.sml +++ b/trans/temp.sml @@ -10,26 +10,28 @@ sig type temp val reset : unit -> unit (* resets temp numbering *) - val new : string -> temp (* returns a unique new temp *) + val new : string -> int -> temp (* returns a unique new temp *) val name : temp -> string (* returns the name of a temp *) + val size : temp -> int (* returns the size of a temp *) val compare : temp * temp -> order (* comparison function *) val eq : temp * temp -> bool end structure Temp :> TEMP = struct - type temp = int * string + type temp = int * string * int local val counter = ref 1 in (* warning: calling reset() may jeopardize uniqueness of temps! *) fun reset () = ( counter := 1 ) - fun new str = (!counter, str) before ( counter := !counter + 1 ) + fun new str size = (!counter, str, size) before ( counter := !counter + 1 ) end - fun name (t,s) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]" - fun compare ((t1,_),(t2,_)) = Int.compare (t1,t2) + fun name (t,s, sz) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]" + fun size (t, s, sz) = sz + fun compare ((t1,_,_),(t2,_,_)) = Int.compare (t1,t2) - fun eq ((t1,_), (t2,_)) = t1 = t2 + fun eq ((t1,_,_), (t2,_,_)) = t1 = t2 end diff --git a/trans/trans.sml b/trans/trans.sml index 80802be..6148ce8 100644 --- a/trans/trans.sml +++ b/trans/trans.sml @@ -17,6 +17,7 @@ structure Trans :> TRANS = struct structure A = Ast + structure AU = AstUtils structure T = Tree fun trans_oper A.PLUS = T.ADD @@ -39,31 +40,156 @@ struct | trans_oper A.GT = T.GT | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop" - fun translate p = + fun translate (defs, funcs) = let - val allfuncs = foldr (fn (A.Extern(_),b) => b - | (A.Function(_, id, _, _, _), b) => Symbol.bind b (id, () )) - Symbol.empty p + val funclist = Symbol.elemsi funcs + + val alignments = ref Symbol.empty (* Ref for memoization. *) + fun alignment A.Int = 4 + | alignment (A.Typedef(id)) = + (case Symbol.look (!alignments) id + of NONE => + let + val r = alignment_s (Symbol.look' defs id) + val _ = (alignments := (Symbol.bind (!alignments) (id, r))) + in + r + end + | SOME r => r) + | alignment (A.Pointer(_)) = 8 + | alignment (A.Array(_)) = 8 + | alignment (A.TNull) = raise ErrorMsg.InternalError "alignmentof TNull?" + and alignment_s (A.Struct(members)) = + foldl + (fn ((_,t),al) => Int.max (al, alignment t)) + 1 + members + | alignment_s (A.MarkedTypedef(a)) = alignment_s (Mark.data a) + + fun align t curpos = + let + val al = alignment t + in + if (curpos mod al) = 0 + then curpos + else curpos + al - (curpos mod al) + end + + val sizes = ref Symbol.empty + fun sizeof_v A.Int = 4 + | sizeof_v (A.Typedef(id)) = + (case Symbol.look (!sizes) id + of NONE => + let + val r = sizeof_s (Symbol.look' defs id) + val _ = (sizes := (Symbol.bind (!sizes) (id, r))) + in + r + end + | SOME r => r) + | sizeof_v (A.Pointer(_)) = 8 + | sizeof_v (A.Array(_)) = 8 + | sizeof_v (A.TNull) = raise ErrorMsg.InternalError "sizeof TNull?" + and sizeof_s (A.Struct(l)) = + foldl + (fn ((_,t),curpos) => align t curpos + sizeof_v t) + 0 + l + | sizeof_s (A.MarkedTypedef(a)) = sizeof_s (Mark.data a) + + fun offset_s id (A.Typedef(id')) = + let + val shit = Symbol.look' defs id' + fun eat (A.Struct(l)) = l + | eat (A.MarkedTypedef(a)) = eat (Mark.data a) + fun offset_s' ((id1,t)::l') curofs = + let + val a = align t curofs + in + if Symbol.compare(id,id1) = EQUAL + then a + else offset_s' l' (a + sizeof_v t) + end + | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure" + in + offset_s' (eat shit) 0 + end + | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef" + + fun type_s id (A.Typedef id') = + let + val td = + case AU.Typedef.data (Symbol.look' defs id') + of A.Struct d => d + | _ => raise ErrorMsg.InternalError "data didn't return struct" + fun type_s' ((id',t)::l) = + if (Symbol.compare (id, id') = EQUAL) + then t + else type_s' l + | type_s' nil = raise ErrorMsg.InternalError "struct member not found in type_s" + in + type_s' td + end + | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef" + + fun deref (A.Pointer i) = i + | deref (A.Array i) = i + | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer" fun trans_unop A.NEGATIVE = T.NEG | trans_unop A.BITNOT = T.BITNOT | trans_unop A.BANG = T.BANG | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop" + + fun typeof' vartypes exp = TypeChecker.typeof (defs, funcs) vartypes NONE exp - fun trans_exp env (A.Var(id)) = + fun trans_exp env vartypes (A.Var(id)) = (* after type-checking, id must be declared; do not guard lookup *) T.TEMP (Symbol.look' env id) - | trans_exp env (A.ConstExp c) = T.CONST(c) - | trans_exp env (A.OpExp(oper, [e1, e2])) = - T.BINOP(trans_oper oper, trans_exp env e1, trans_exp env e2) - | trans_exp env (A.OpExp(oper, [e])) = - T.UNOP(trans_unop oper, trans_exp env e) - | trans_exp env (A.OpExp(oper, _)) = + | trans_exp env vartypes (A.ConstExp c) = T.CONST(c) + | trans_exp env vartypes (A.OpExp(oper, [e1, e2])) = + T.BINOP(trans_oper oper, trans_exp env vartypes e1, trans_exp env vartypes e2) + | trans_exp env vartypes (A.OpExp(oper, [e])) = + T.UNOP(trans_unop oper, trans_exp env vartypes e) + | trans_exp env vartypes (A.OpExp(oper, _)) = raise ErrorMsg.InternalError "expected one or two operands, got it in the oven" - | trans_exp env (A.Marked(marked_exp)) = - trans_exp env (Mark.data marked_exp) - | trans_exp env (A.FuncCall(func, stms)) = - T.CALL(func, List.map (trans_exp env) stms) + | trans_exp env vartypes (A.Marked(marked_exp)) = + trans_exp env vartypes (Mark.data marked_exp) + | trans_exp env vartypes (A.FuncCall(func, stms)) = + T.CALL(func, + List.map + (fn exp => (trans_exp env vartypes exp, AU.Type.size (typeof' vartypes exp))) + stms, + AU.Type.size (AU.Function.returntype (Symbol.look' funcs func)) ) + | trans_exp env vartypes (A.Member (exp, id)) = + let + val apk = T.BINOP (T.ADD, trans_exp env vartypes exp, T.CONST (Word32.fromInt (offset_s id (typeof' vartypes exp)))) + in + if (AU.Type.issmall (type_s id (typeof' vartypes exp))) + then T.MEMORY(apk) + else apk + end + | trans_exp env vartypes (A.DerefMember (exp, id)) = + trans_exp env vartypes (A.Member (A.Dereference (exp), id)) + | trans_exp env vartypes (A.Dereference(exp)) = + if (AU.Type.issmall (deref (typeof' vartypes exp))) + then T.MEMORY(trans_exp env vartypes exp) + else trans_exp env vartypes exp + | trans_exp env vartypes (A.ArrIndex(exp1, exp2)) = + let + val asubk = T.BINOP(T.ADD, trans_exp env vartypes exp1, + T.BINOP(T.MUL, trans_exp env vartypes exp2, + T.CONST(Word32.fromInt(sizeof_v (deref (typeof' vartypes exp1)))))) + in + if (AU.Type.issmall (deref (typeof' vartypes exp1))) + then T.MEMORY(asubk) + else asubk + end + | trans_exp env vartypes (A.New(tipo)) = + T.ALLOC(T.CONST (Word32.fromInt(sizeof_v tipo))) + | trans_exp env vartypes (A.NewArr(tipo, exp)) = + T.ALLOC(T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof_v tipo)))) + | trans_exp env vartypes (A.Null) = T.CONST(0w0) (* anything else should be impossible *) @@ -72,115 +198,123 @@ struct * we pass around the environment and the current loop context, if any * (usually called ls, which contains a continue label and a break label) *) - fun trans_stms vars ls (A.Assign(id,e)::stms) = + fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2, AU.Type.size (typeof' vartypes e2))::(trans_stms vars vartypes ls stms) + | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) = let - val t = Symbol.look' vars id handle Option => raise ErrorMsg.InternalError "Undeclared variable, should have been caught in typechecker..." - val remainder = trans_stms vars ls stms + val te1 = trans_exp vars vartypes e1 + val te2 = trans_exp vars vartypes e2 + val t1 = T.TEMP (Temp.new "memory deref cache" 8) + val size = AU.Type.size (typeof' vartypes e2) in - T.MOVE(T.TEMP(t), trans_exp vars e) - :: remainder + case te1 + of T.MEMORY(m) => T.MOVE(t1, m, 8) :: T.MOVE (T.MEMORY(t1), T.BINOP(trans_oper oop, T.MEMORY(t1), te2), size) :: (trans_stms vars vartypes ls stms) + | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2), size) :: (trans_stms vars vartypes ls stms) end - | trans_stms vars ls (A.Return e::stms) = + | trans_stms vars vartypes ls (A.Return e::stms) = let - val remainder = trans_stms vars ls stms + val remainder = trans_stms vars vartypes ls stms in - T.RETURN (trans_exp vars e) + T.RETURN (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e)) :: remainder end - - | trans_stms vars ls (A.If(e, s, NONE)::stms) = + | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) = let val l = Label.new () - val strans = trans_stms vars ls s - val remainder = trans_stms vars ls stms + val strans = trans_stms vars vartypes ls s + val remainder = trans_stms vars vartypes ls stms in - (T.JUMPIFN(trans_exp vars e, l) + (T.JUMPIFN(trans_exp vars vartypes e, l) :: strans @ [T.LABEL (l)] @ remainder) end - | trans_stms vars ls (A.If(e, s, SOME s2)::stms) = + | trans_stms vars vartypes ls (A.If(e, s, SOME s2)::stms) = let val l = Label.new () val l2 = Label.new () - val s1trans = trans_stms vars ls s - val s2trans = trans_stms vars ls s2 - val remainder = trans_stms vars ls stms + val s1trans = trans_stms vars vartypes ls s + val s2trans = trans_stms vars vartypes ls s2 + val remainder = trans_stms vars vartypes ls stms in - (T.JUMPIFN(trans_exp vars e, l) + (T.JUMPIFN(trans_exp vars vartypes e, l) :: s1trans @ [T.JUMP (l2), T.LABEL (l)] @ s2trans @ [T.LABEL (l2)] @ remainder) end - | trans_stms vars ls (A.For(s1, e, s2, s)::stms) = + | trans_stms vars vartypes ls (A.For(s1, e, s2, s)::stms) = let val head = Label.new () val tail = Label.new () val loop = Label.new () - val stm1 = if isSome s1 then trans_stms vars NONE [valOf s1] else nil - val strans = trans_stms vars (SOME(loop,tail)) s - val stm2 = if isSome s2 then trans_stms vars NONE [valOf s2] else nil - val remainder = trans_stms vars ls stms + val stm1 = if isSome s1 then trans_stms vars vartypes NONE [valOf s1] else nil + val strans = trans_stms vars vartypes (SOME(loop,tail)) s + val stm2 = if isSome s2 then trans_stms vars vartypes NONE [valOf s2] else nil + val remainder = trans_stms vars vartypes ls stms in (stm1 - @ [T.LABEL head, T.JUMPIFN(trans_exp vars e, tail)] + @ [T.LABEL head, T.JUMPIFN(trans_exp vars vartypes e, tail)] @ strans @ [T.LABEL loop] @ stm2 @ [T.JUMP head, T.LABEL tail] @ remainder) end - | trans_stms vars ls (A.While(e, s)::stms) = + | trans_stms vars vartypes ls (A.While(e, s)::stms) = let val head = Label.new () val tail = Label.new () - val strans = trans_stms vars (SOME(head,tail)) s - val remainder = trans_stms vars ls stms + val strans = trans_stms vars vartypes (SOME(head,tail)) s + val remainder = trans_stms vars vartypes ls stms in (T.LABEL head - :: T.JUMPIFN(trans_exp vars e, tail) + :: T.JUMPIFN(trans_exp vars vartypes e, tail) :: strans @ [T.JUMP head, T.LABEL tail] @ remainder) end - - | trans_stms vars (SOME(b,e)) (A.Break::stms) = + | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))) :: (trans_stms vars vartypes ls stms) + | trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) = let - val remainder = trans_stms vars (SOME(b,e)) stms + val remainder = trans_stms vars vartypes (SOME(b,e)) stms in ((T.JUMP e) :: remainder) end - | trans_stms vars NONE (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker" - | trans_stms vars (SOME(b,e)) (A.Continue::stms) = + | trans_stms vars vartypes NONE (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker" + | trans_stms vars vartypes (SOME(b,e)) (A.Continue::stms) = let - val remainder = trans_stms vars (SOME(b,e)) stms + val remainder = trans_stms vars vartypes (SOME(b,e)) stms in ((T.JUMP b) :: remainder) end - | trans_stms vars NONE (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker" - | trans_stms vars ls (A.Nop::stms) = trans_stms vars ls stms - | trans_stms vars ls (A.MarkedStm m :: stms) = trans_stms vars ls ((Mark.data m) :: stms) - | trans_stms vars _ nil = nil + | trans_stms vars vartypes NONE (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker" + | trans_stms vars vartypes ls (A.Nop::stms) = trans_stms vars vartypes ls stms + | trans_stms vars vartypes ls (A.MarkedStm m :: stms) = trans_stms vars vartypes ls ((Mark.data m) :: stms) + | trans_stms vars vartypes _ nil = nil - fun trans_funcs (A.Extern(t, id, varl)::l) = trans_funcs l - | trans_funcs (A.Function(t, id, args, vars, body)::l) = + fun trans_funcs ((id, A.Extern(_, _))::l) = trans_funcs l + | trans_funcs ((id, A.MarkedFunction a)::l) = trans_funcs ((id, Mark.data a)::l) + | trans_funcs ((id, A.Function(t, args, vars, body))::l) = let - val (a,_) = ListPair.unzip (args @ vars) - val allvars = foldr (fn (a,b) => Symbol.bind b (a, Temp.new(Symbol.name(a)))) Symbol.empty a - val b = trans_stms allvars NONE body + val allvars = foldr + (fn ((name, t),b) => + Symbol.bind b (name, Temp.new (Symbol.name(name)) (AU.Type.size t))) + Symbol.empty + (args @ vars) + val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars) + val b = trans_stms allvars vartypes NONE body val (argn,_) = ListPair.unzip args val numberedargs = ListPair.zip (List.tabulate (length argn, fn x => x), argn) val argmv = map - (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG n)) + (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n, Temp.size (Symbol.look' allvars argname)), Temp.size (Symbol.look' allvars argname))) numberedargs in (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l) end | trans_funcs nil = nil + in - trans_funcs p + trans_funcs funclist end - end diff --git a/trans/tree.sml b/trans/tree.sml index f5a92b5..d3e8c0d 100644 --- a/trans/tree.sml +++ b/trans/tree.sml @@ -18,13 +18,16 @@ sig datatype exp = CONST of Word32.word | TEMP of Temp.temp - | ARG of Blarg (* I am j4cbo *) + | ARG of Blarg * int (* I am j4cbo *) | BINOP of binop * exp * exp | UNOP of unop * exp - | CALL of Ast.ident * exp list + | CALL of Ast.ident * (exp * int) list * int + | MEMORY of exp + | ALLOC of exp and stm = - MOVE of exp * exp - | RETURN of exp + MOVE of exp * exp * int + | RETURN of exp * int + | EFFECT of exp * int | LABEL of Label.label | JUMPIFN of exp * Label.label | JUMP of Label.label @@ -52,13 +55,16 @@ struct datatype exp = CONST of Word32.word | TEMP of Temp.temp - | ARG of Blarg + | ARG of Blarg * int | BINOP of binop * exp * exp | UNOP of unop * exp - | CALL of Ast.ident * exp list + | CALL of Ast.ident * (exp * int) list * int + | MEMORY of exp + | ALLOC of exp and stm = - MOVE of exp * exp - | RETURN of exp + MOVE of exp * exp * int + | RETURN of exp * int + | EFFECT of exp * int | LABEL of Label.label | JUMPIFN of exp * Label.label | JUMP of Label.label @@ -97,18 +103,21 @@ struct fun pp_exp (CONST(x)) = Word32Signed.toString x | pp_exp (TEMP(t)) = Temp.name t - | pp_exp (ARG(n)) = "arg#"^Int.toString n + | pp_exp (ARG(n, sz)) = "arg#"^Int.toString n | pp_exp (BINOP (binop, e1, e2)) = "(" ^ pp_exp e1 ^ " " ^ pp_binop binop ^ " " ^ pp_exp e2 ^ ")" | pp_exp (UNOP (unop, e1)) = pp_unop unop ^ "(" ^ pp_exp e1 ^ ")" - | pp_exp (CALL (f, l)) = - Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map pp_exp l)) ^ ")" + | pp_exp (CALL (f, l, sz)) = + Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map (fn (e, _) => pp_exp e) l)) ^ ")" + | pp_exp (MEMORY exp) = "M[" ^ pp_exp exp ^ "]" + | pp_exp (ALLOC(e)) = "NEW(" ^ pp_exp e ^ ")" - fun pp_stm (MOVE (e1,e2)) = + fun pp_stm (MOVE (e1,e2, sz)) = pp_exp e1 ^ " <-- " ^ pp_exp e2 - | pp_stm (RETURN e) = + | pp_stm (RETURN (e, sz)) = "return " ^ pp_exp e + | pp_stm (EFFECT (e, sz)) = pp_exp e | pp_stm (LABEL l) = Label.name l ^ ":" | pp_stm (JUMP l) = diff --git a/type/typechecker.sml b/type/typechecker.sml index 63608bd..35d2859 100644 --- a/type/typechecker.sml +++ b/type/typechecker.sml @@ -10,17 +10,150 @@ signature TYPE_CHECK = sig (* prints error message and raises ErrorMsg.error if error found *) val typecheck : Ast.program -> Ast.program + val typeof : Ast.program -> Ast.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Ast.vtype end; structure TypeChecker :> TYPE_CHECK = struct structure A = Ast + structure AU = AstUtils + + fun typeof (tds, funcs) vars mark e = + ( case e + of A.Var a => (case Symbol.look vars a + of NONE => (ErrorMsg.error mark ("variable `"^(Symbol.name a)^"' not declared here") ; raise ErrorMsg.Error) + | SOME t => t) + | A.ConstExp _ => A.Int + | A.OpExp (A.EQ, [a, b]) => + (case (typeof (tds, funcs) vars mark a, typeof (tds, funcs) vars mark b) + of (A.Int, A.Int) => A.Int (* You shall pass! *) + | (a', b') => + if (A.typeeq (a', A.TNull) andalso A.castable (b', A.TNull)) orelse + (A.typeeq (b', A.TNull) andalso A.castable (a', A.TNull)) orelse + (A.typeeq (a', b')) + then A.Int + else (ErrorMsg.error mark ("incorrect types for equality opexp: " ^ A.Print.pp_type a' ^ ", " ^ A.Print.pp_type b') ; raise ErrorMsg.Error )) + | A.OpExp (A.NEQ, el) => typeof (tds, funcs) vars mark (A.OpExp (A.EQ, el)) + | A.OpExp (_, el) => (List.app + (fn e => + (case (typeof (tds, funcs) vars mark e) + of A.Int => () + | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error))) + el ; A.Int) + | A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e) + | A.FuncCall (i, exps) => + let + val func = (case Symbol.look funcs i + of NONE => (ErrorMsg.error mark ("function `"^(Symbol.name i)^"' not declared") ; raise ErrorMsg.Error) + | SOME f => f) + val funcmark = AU.Function.mark func + val (ftype, fparams) = (AU.Function.returntype func, AU.Function.params func) + val exptypes = List.map (fn znt => typeof (tds, funcs) vars mark znt) exps + val () = if (length exptypes = length fparams) then () + else (ErrorMsg.error mark ("call to function `"^(Symbol.name i)^"' has incorrect parameter count [you must construct additional tycons]") ; raise ErrorMsg.Error) + val () = List.app + (fn (t, (i, t')) => + if not (A.castable (t', t)) + then (ErrorMsg.error mark ("parameter `"^(Symbol.name i)^"' in function call has wrong type [you must construct additional tycons]") ; raise ErrorMsg.Error) + else ()) + (ListPair.zip (exptypes, fparams)) + in + ftype + end + | A.Member (e, i) => + let + val t = typeof (tds, funcs) vars mark e + val name = case t + of (A.Typedef i) => i + | _ => (ErrorMsg.error mark ("member operation only exists for struct types") ; raise ErrorMsg.Error) + val s = case Symbol.look tds name + of SOME s => s + | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error) + val (s, smark) = (AU.Typedef.data s, AU.Typedef.mark s) + val vl = case s + of A.Struct vl => vl + | _ => raise ErrorMsg.InternalError "mark of marked typedef?" + val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl) + of SOME (_, t) => t + | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error) + in + t + end + | A.DerefMember (e, i) => + let + val t = typeof (tds, funcs) vars mark e + val name = case t + of (A.Pointer (A.Typedef i)) => i + | _ => (ErrorMsg.error mark ("dereference and member operation only exists for struct pointer types") ; raise ErrorMsg.Error) + val s = case Symbol.look tds name + of SOME s => s + | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error) + val (s, smark) = case s + of A.Struct vl => (s, NONE) + | A.MarkedTypedef m => (Mark.data m, Mark.ext m) + val vl = case s + of A.Struct vl => vl + | _ => raise ErrorMsg.InternalError "mark of marked typedef?" + val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl) + of SOME (_, t) => t + | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error) + in + t + end + | A.Dereference e => + (case typeof (tds, funcs) vars mark e + of (A.Pointer e') => e' + | _ => (ErrorMsg.error mark ("cannot deference non-pointer type") ; raise ErrorMsg.Error)) + | A.ArrIndex (e, i) => + (case (typeof (tds, funcs) vars mark e, typeof (tds, funcs) vars mark i) + of (A.Array e', A.Int) => e' + | (_, A.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error) + | _ => (ErrorMsg.error mark ("cannot index using non-int type") ; raise ErrorMsg.Error)) + | A.New (t) => A.Pointer t + | A.NewArr (t, s) => + (case typeof (tds, funcs) vars mark s + of A.Int => (A.Array t) + | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error)) + | A.Null => A.TNull + ) datatype asn = ASSIGNED | UNASSIGNED + (* returncheck prog vars mark t l + * Determines if the statement list 'l' is guaranteed to return vtype 't'. + * If it ever does not return vtype 't', then raises an error. + * true if vtype 't' is always returned, or false if there is a possibility that vtype 't' will not be returned. + *) + fun returncheck prog vars mark t l = + let + fun returns' nil = false + | returns' (A.Assign _ :: stms) = returns' stms + | returns' (A.AsnOp _ :: stms) = returns' stms + | returns' (A.Effect _ :: stms) = returns' stms + | returns' (A.Return e :: stms) = + if (A.castable (t, typeof prog vars mark e)) + then true + else (ErrorMsg.error mark ("return value of incorrect type for function") ; raise ErrorMsg.Error) + | returns' (A.Nop :: stms) = returns' stms + | returns' (A.Break :: stms) = true (* blah *) + | returns' (A.Continue :: stms) = true (* blah *) + | returns' (A.If (_, s1, NONE) :: stms) = returns' stms + | returns' (A.If (_, s1, SOME s2) :: stms) = (returns' s1 andalso returns' s2) orelse returns' stms + | returns' (A.For _ :: stms) = returns' stms + | returns' (A.While _ :: stms) = returns' stms + | returns' (A.MarkedStm m :: stms) = returncheck prog vars (Mark.ext m) t (Mark.kane m :: stms) + in + returns' l + end + + (* returns l + * true iff the statement list 'l' always returns. + *) fun returns nil = false | returns (A.Assign _ :: stms) = returns stms - | returns (A.Return _ :: stms) = true + | returns (A.AsnOp _ :: stms) = returns stms + | returns (A.Effect _ :: stms) = returns stms + | returns (A.Return e :: stms) = true | returns (A.Nop :: stms) = returns stms | returns (A.Break :: stms) = true (* blah *) | returns (A.Continue :: stms) = true (* blah *) @@ -30,6 +163,9 @@ struct | returns (A.While _ :: stms) = returns stms | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms) + (* breakcheck l mark + * Throws an error exception if a break or continue ever occurs in an illegal context. + *) fun breakcheck nil mark = () | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ; raise ErrorMsg.Error ) @@ -45,38 +181,40 @@ struct | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark) | breakcheck (_ :: stms) mark = breakcheck stms mark - fun varcheck_exp env fenv (A.Var v) mark : Ast.vtype = + (* varcheck_exp env exp mark + * Throws an error exception if a variable used in this excpression was unassigned or undefined in this context. + *) + fun varcheck_exp env (A.Var v) mark = ( case Symbol.look env v of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ; raise ErrorMsg.Error ) - | SOME (t, UNASSIGNED) => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ; - raise ErrorMsg.Error ) - | SOME (t, ASSIGNED) => t) - | varcheck_exp env fenv (A.ConstExp _) mark = (A.Int) - | varcheck_exp env fenv (A.OpExp (_, l)) mark = (List.app (fn znt => (varcheck_exp env fenv znt mark; ())) l; A.Int) - | varcheck_exp env fenv (A.FuncCall (f, l)) mark = - let - val types = map (fn znt => varcheck_exp env fenv znt mark) l - val func = case Symbol.look fenv f - of NONE => ( ErrorMsg.error mark ("undefined function `" ^ Symbol.name f ^ "'") ; + | SOME UNASSIGNED => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ; raise ErrorMsg.Error ) - | SOME a => a - val (rtype, params) = case func - of A.Extern (rtype, _, params) => (rtype, params) - | A.Function (rtype, _, params, _, _) => (rtype, params) - val paramtypes = map (fn (i, t) => t) params - val () = if not (types = paramtypes) - then ( ErrorMsg.error mark ("incorrect parameters for function `" ^ Symbol.name f ^ "'") ; - raise ErrorMsg.Error ) - else () - in - rtype - end - | varcheck_exp env fenv (A.Marked m) mark = varcheck_exp env fenv (Mark.kane m) (Mark.ext m) + | SOME ASSIGNED => ()) + | varcheck_exp env (A.ConstExp _) mark = () + | varcheck_exp env (A.OpExp (_, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l + | varcheck_exp env (A.FuncCall (f, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l + | varcheck_exp env (A.Marked m) mark = varcheck_exp env (Mark.kane m) (Mark.ext m) + | varcheck_exp env (A.Member (e, i)) mark = varcheck_exp env e mark + | varcheck_exp env (A.DerefMember (e, i)) mark = varcheck_exp env e mark + | varcheck_exp env (A.Dereference e) mark = varcheck_exp env e mark + | varcheck_exp env (A.ArrIndex (e1, e2)) mark = (varcheck_exp env e1 mark ; varcheck_exp env e2 mark) + | varcheck_exp env (A.New _) mark = () + | varcheck_exp env (A.NewArr (_, e)) mark = varcheck_exp env e mark + | varcheck_exp env (A.Null) mark = () + (* computeassigns env exp + * Computes the assigned variables after expression exp has been executed with a starting context of env. + *) fun computeassigns env nil = env - | computeassigns env (A.Assign (id,e) :: stms) = - computeassigns (Symbol.bind env (id, (A.Int, ASSIGNED))) stms + | computeassigns env (A.Assign (A.Var id,e) :: stms) = + computeassigns (Symbol.bind env (id, ASSIGNED)) stms + | computeassigns env (A.Assign (A.Marked a, e) :: stms) = + computeassigns env (A.Assign (Mark.data a, e) :: stms) + | computeassigns env (A.AsnOp (oper, a, e) :: stms) = + computeassigns env (A.Assign (a, a) :: stms) + | computeassigns env (A.Assign (_) :: stms) = computeassigns env stms + | computeassigns env (A.Effect _ :: stms) = computeassigns env stms | computeassigns env (A.Return _ :: stms) = env | computeassigns env (A.Nop :: stms) = computeassigns env stms | computeassigns env (A.Break :: stms) = env @@ -88,8 +226,8 @@ struct val env2 = computeassigns env s2 val env' = Symbol.intersect - (fn ((t, ASSIGNED), (t', ASSIGNED)) => (t, ASSIGNED) (* XXX check types for equality *) - | ((t, _), (t', _)) => (t, UNASSIGNED)) + (fn (ASSIGNED, ASSIGNED) => ASSIGNED + | _ => UNASSIGNED) (env1, env2) val env' = if (returns s1) then env2 @@ -109,70 +247,94 @@ struct end | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms) - fun varcheck env fenv nil mark = nil - | varcheck env fenv (A.Assign (id, e) :: stms) mark = + (* varcheck env l mark + * Checks that all variables used in the statement list l have been defined before being used, and removes code that is unreachable according to simple return analysis. + *) + fun varcheck env nil mark = nil + | varcheck env (A.Assign (A.Var id, e) :: stms) mark = let val sym = Symbol.look env id val _ = if not (isSome sym) then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error) else () - val (t, a) = valOf sym - val t' = varcheck_exp env fenv e mark + val t = valOf sym + val _ = varcheck_exp env e mark in - A.Assign (id, e) :: (varcheck (Symbol.bind env (id, (t, ASSIGNED))) fenv stms mark) + A.Assign (A.Var id, e) :: (varcheck (Symbol.bind env (id, ASSIGNED)) stms mark) end - | varcheck env fenv (A.Return (e) :: stms) mark = - ( varcheck_exp env fenv e mark; + | varcheck env (A.Assign (A.Marked a, e) :: stms) mark = varcheck env (A.Assign (Mark.data a, e) :: stms) mark + | varcheck env ((a as A.Assign (A.Member (e', i), e)) :: stms) mark = + (varcheck_exp env e' mark ; + varcheck_exp env e mark ; + a :: varcheck env stms mark) + | varcheck env ((a as A.Assign (A.DerefMember (e', i), e)) :: stms) mark = + (varcheck_exp env e' mark ; + varcheck_exp env e mark ; + a :: varcheck env stms mark) + | varcheck env ((a as A.Assign (A.Dereference e', e)) :: stms) mark = + (varcheck_exp env e' mark ; + varcheck_exp env e mark ; + a :: varcheck env stms mark) + | varcheck env ((a as A.Assign (A.ArrIndex (e', e''), e)) :: stms) mark = + (varcheck_exp env e' mark ; + varcheck_exp env e'' mark ; + varcheck_exp env e mark ; + a :: varcheck env stms mark) + | varcheck env ((a as A.Assign (A.NewArr (_, e'), e)) :: stms) mark = + (varcheck_exp env e' mark ; + varcheck_exp env e mark ; + a :: varcheck env stms mark) + | varcheck env ((A.Assign _) :: stms) mark = raise ErrorMsg.InternalError "assign to non lvalue" + | varcheck env ((a as A.AsnOp (oper, e1, e2)) :: stms) mark = ( varcheck env [(A.Assign (e1, A.OpExp (oper, [e1, e2])))] ; a :: varcheck env stms mark) + | varcheck env ((a as A.Effect e) :: stms) mark = (varcheck_exp env e mark ; a :: varcheck env stms mark) + | varcheck env (A.Return (e) :: stms) mark = + ( varcheck_exp env e mark; A.Return (e) :: nil ) - | varcheck env fenv (A.Nop :: stms) mark = - ( A.Nop :: (varcheck env fenv stms mark)) - | varcheck env fenv (A.Break :: stms) mark = + | varcheck env (A.Nop :: stms) mark = + ( A.Nop :: (varcheck env stms mark)) + | varcheck env (A.Break :: stms) mark = ( A.Break :: nil ) - | varcheck env fenv (A.Continue :: stms) mark = + | varcheck env (A.Continue :: stms) mark = ( A.Continue :: nil ) - | varcheck env fenv (A.If (e, s1, NONE) :: stms) mark = - ( varcheck_exp env fenv e mark ; - varcheck env fenv s1 mark ; - A.If (e, s1, NONE) :: (varcheck env fenv stms mark) ) - | varcheck env fenv ((i as A.If (e, s1, SOME s2)) :: stms) mark = - ( varcheck_exp env fenv e mark ; - varcheck env fenv s1 mark ; - varcheck env fenv s2 mark ; + | varcheck env (A.If (e, s1, NONE) :: stms) mark = + ( varcheck_exp env e mark ; + varcheck env s1 mark ; + A.If (e, s1, NONE) :: (varcheck env stms mark) ) + | varcheck env ((i as A.If (e, s1, SOME s2)) :: stms) mark = + ( varcheck_exp env e mark ; + varcheck env s1 mark ; + varcheck env s2 mark ; A.If (e, s1, SOME s2) :: (if (returns [i]) then nil - else varcheck (computeassigns env [i]) fenv stms mark) ) - | varcheck env fenv (A.While (e, s1) :: stms) mark = - ( varcheck_exp env fenv e mark ; - varcheck env fenv s1 mark ; - A.While (e, s1) :: (varcheck env fenv stms mark) ) - | varcheck env fenv (A.For (sbegin, e, sloop, inner) :: stms) mark = + else varcheck (computeassigns env [i]) stms mark) ) + | varcheck env (A.While (e, s1) :: stms) mark = + ( varcheck_exp env e mark ; + varcheck env s1 mark ; + A.While (e, s1) :: (varcheck env stms mark) ) + | varcheck env (A.For (sbegin, e, sloop, inner) :: stms) mark = let val sbegin = case sbegin - of SOME(s) => SOME (hd (varcheck env fenv [s] mark)) + of SOME(s) => SOME (hd (varcheck env [s] mark)) | NONE => NONE val env' = case sbegin of SOME(s) => computeassigns env [s] | NONE => env - val _ = varcheck_exp env' fenv e - val inner = varcheck env' fenv inner mark + val _ = varcheck_exp env' e + val inner = varcheck env' inner mark val env'' = computeassigns env' inner val sloop = case sloop - of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark)) + of SOME(s) => SOME (hd (varcheck env'' [s] mark)) | NONE => NONE in - A.For (sbegin, e, sloop, inner) :: (varcheck env' fenv stms mark) + A.For (sbegin, e, sloop, inner) :: (varcheck env' stms mark) end - | varcheck env fenv (A.MarkedStm m :: stms) mark = varcheck env fenv ((Mark.kane m) :: stms) (Mark.ext m) + | varcheck env (A.MarkedStm m :: stms) mark = varcheck env ((Mark.kane m) :: stms) (Mark.ext m) - fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,(t, stat))) sym l - fun bindfuns sym l = - foldr - (fn (a as (A.Function (_, id, _, _, _)), s) => Symbol.bind s (id, a) - | (a as (A.Extern (_, id, _)), s) => Symbol.bind s (id, a)) - sym l + fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,stat)) sym l + fun bindtypes sym l = foldr (fn ((i,t), s) => Symbol.bind s (i,t)) sym l - fun dupchk l = + fun dupchk mark l src = List.app (fn (n, _) => let @@ -182,62 +344,172 @@ struct in if count = 1 then () - else ( ErrorMsg.error NONE ("multiple definition of variable " ^ (Symbol.name n)); + else ( ErrorMsg.error mark ("multiple definition of variable " ^ (Symbol.name n) ^ " in " ^ src); raise ErrorMsg.Error ) end) l + + fun check_lvalue prog vars mark (A.Marked m) = check_lvalue prog vars (Mark.ext m) (Mark.data m) + | check_lvalue prog vars mark (e as A.Var _) = typeof prog vars mark e + | check_lvalue prog vars mark (e as A.Member _) = typeof prog vars mark e + | check_lvalue prog vars mark (e as A.DerefMember _) = typeof prog vars mark e + | check_lvalue prog vars mark (e as A.Dereference _) = typeof prog vars mark e + | check_lvalue prog vars mark (e as A.ArrIndex _) = typeof prog vars mark e + | check_lvalue prog vars mark _ = ( ErrorMsg.error mark ("invalid lvalue") ; raise ErrorMsg.Error ) + fun typecheck_stm prog vars mark stm = + case stm + of A.Assign (e1, e2) => + if not (A.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2)) + then (ErrorMsg.error mark "incompatible types in assignment" ; raise ErrorMsg.Error ) + else if not (AU.Type.issmall (check_lvalue prog vars mark e1)) + then (ErrorMsg.error mark "lvalue is not small" ; raise ErrorMsg.Error) + else () + | A.AsnOp (oper, e1, e2) => typecheck_stm prog vars mark (A.Assign (e1, A.OpExp (oper, [e1, e2]))) + | A.Effect e => + if not (AU.Type.issmall (typeof prog vars mark e)) + then (ErrorMsg.error mark "simple statement's value not small" ; raise ErrorMsg.Error ) + else () + | A.Return e => (typeof prog vars mark e ; ()) + | A.Nop => () + | A.Break => () + | A.Continue => () + | A.If (e, s, NONE) => + if A.castable (A.Int, typeof prog vars mark e) + then (List.app (typecheck_stm prog vars mark) s) + else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error ) + | A.If (e, s1, SOME s2) => + if A.castable (A.Int, typeof prog vars mark e) + then (List.app (typecheck_stm prog vars mark) s1 ; List.app (typecheck_stm prog vars mark) s2) + else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error ) + | A.For (sbegin, e, sloop, s) => + if A.castable (A.Int, typeof prog vars mark e) + then (List.app (typecheck_stm prog vars mark) ((case sbegin of SOME l => [l] | NONE => nil) @ (case sloop of SOME l => [l] | NONE => nil) @ s)) + else (ErrorMsg.error mark "conditional in for statement is not of int type" ; raise ErrorMsg.Error ) + | A.While (e, s) => + if A.castable (A.Int, typeof prog vars mark e) + then (List.app (typecheck_stm prog vars mark) s) + else (ErrorMsg.error mark "conditional in while statement is not of int type" ; raise ErrorMsg.Error ) + | A.MarkedStm (m) => typecheck_stm prog vars (Mark.ext m) (Mark.data m) + + (* XXX does not check big vs. small types *) + fun typecheck_type (tds, funcs) mark A.Int = () + | typecheck_type (tds, funcs) mark A.TNull = () + | typecheck_type (tds, funcs) mark (A.Pointer t) = typecheck_type (tds, funcs) mark t + | typecheck_type (tds, funcs) mark (A.Array t) = typecheck_type (tds, funcs) mark t + | typecheck_type (tds, funcs) mark (A.Typedef t) = + case (Symbol.look tds t) + of SOME _ => () + | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name t)^"' does not exist") ; raise ErrorMsg.Error) - fun typecheck_fn p (e as (A.Extern (t, id, al))) = (dupchk al; e) - | typecheck_fn p (A.Function (t, id, al, vl, sl)) = + fun typecheck_fn prog _ (id, A.MarkedFunction m) = typecheck_fn prog (Mark.ext m) (id, Mark.data m) + | typecheck_fn (prog as (tds, funcs)) mark (id, A.Extern (t, al)) = + (if (String.isPrefix "_l4_" (Symbol.name id)) + then + let + val n = String.extract (Symbol.name id, 4, NONE) + in + if List.exists (fn (id, f) => case (AU.Function.data f) of A.Function _ => (Symbol.name id = n) | _ => false) (Symbol.elemsi funcs) + then (ErrorMsg.error mark ("you anus, extern " ^ Symbol.name id ^ " conflicts with local function"); raise ErrorMsg.Error) + else () + end + else () ; + dupchk mark al ; + List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) al) ; + A.Extern (t, al)) + | typecheck_fn prog mark (id, A.Function (t, al, vl, sl)) = let - val () = breakcheck sl NONE - val () = if not (returns sl) - then ( ErrorMsg.error NONE ("function `"^ Symbol.name id ^ "' does not return in all cases"); - raise ErrorMsg.Error ) - else () + val () = dupchk mark (al @ vl) ("function `"^Symbol.name id^"'") (* Before we do any bindings, check for duplicate names. *) + val () = List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) (al @ vl)) val env = Symbol.empty val env = bindvars env ASSIGNED al val env = bindvars env UNASSIGNED vl - val fenv = bindfuns Symbol.empty p - val () = dupchk (al @ vl) + val vars = Symbol.empty + val vars = bindtypes vars al + val vars = bindtypes vars vl + val () = breakcheck sl mark + val () = if not (returncheck prog vars NONE t sl) + then ( ErrorMsg.error mark ("function `"^ Symbol.name id ^ "' does not return in all cases"); + raise ErrorMsg.Error ) + else () + val () = List.app ( + fn (n, t) => + if (AU.Type.issmall t) + then () + else ( ErrorMsg.error mark ("variable `"^(Symbol.name n)^"' in function `"^(Symbol.name id)^"' not small") ; raise ErrorMsg.Error)) + (al @ vl) + val () = List.app (typecheck_stm prog vars mark) sl in - A.Function (t, id, al, vl, varcheck env fenv sl NONE) + A.Function (t, al, vl, varcheck env sl NONE) end + + structure SymbolSet = ListSetFn ( + struct + type ord_key = Symbol.symbol + val compare = Symbol.compare + end + ) + + fun typecheck_structs (prog as (tds, funcs)) = + let + exception Yuq + + val all = SymbolSet.addList (SymbolSet.empty, Symbol.keys tds) + fun lookup mark sym = + let + val s = case Symbol.look tds sym + of SOME a => a + | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name sym)^"' does not exist") ; raise ErrorMsg.Error) + val vl = case AU.Typedef.data s + of A.Struct vl => vl + | A.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type" + in + (vl, AU.Typedef.mark s) + end + fun checksym mark sym stack k remaining = + if not (SymbolSet.member (remaining, sym)) + then k remaining + else if (SymbolSet.member (stack, sym)) + then ( ErrorMsg.error mark ("structure `"^ (Symbol.name sym) ^"' is involved in a recursive mess") ; raise Yuq) + else + let + val stack' = SymbolSet.add (stack, sym) + val (vl, mark') = lookup mark sym + val () = dupchk mark vl ("structure `"^(Symbol.name sym)^"'") + fun remove k remaining' = k (SymbolSet.delete (remaining', sym)) + val newk = (* OH GOD D: *) + foldr + (fn ((_, A.Typedef s), k') => checksym mark' s stack' k' + | (_, k') => k') + (remove k) + vl + in + newk remaining handle Yuq => (ErrorMsg.error mark' ("from structure `"^(Symbol.name sym)^"'") ; raise Yuq) + end + fun chooseone k set = + case (SymbolSet.listItems set) + of nil => k set + | (h::l) => checksym NONE h SymbolSet.empty (chooseone k) set + in + chooseone (fn _ => ()) all handle Yuq => raise ErrorMsg.Error + end - fun typecheck p = + fun typecheck (tds, funcs) = let - fun getFun n = - List.find (fn A.Extern (_, id, _) => ((Symbol.name id) = n) - | A.Function (_, id, _, _, _) => ((Symbol.name id) = n)) - p - val main = case (getFun "main") + val main = case (Symbol.look funcs (Symbol.symbol "main")) of NONE => ( ErrorMsg.error NONE ("no function named main"); raise ErrorMsg.Error ) | SOME m => m + val (main, mainp) = (AU.Function.data main, AU.Function.mark main) val () = case main - of A.Extern _ => ( ErrorMsg.error NONE ("you anus, main can't be an extern"); + of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern"); raise ErrorMsg.Error ) - | A.Function (A.Int, _, nil, _, _) => () - | A.Function (A.Int, _, _, _, _) => ( ErrorMsg.error NONE ("main should take no parameters"); + | A.Function (A.Int, nil, _, _) => () + | A.Function (A.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters"); raise ErrorMsg.Error ) - val () = List.app - (fn a => - let - val id = case a - of A.Extern (_, id, _) => id - | A.Function (_, id, _, _, _) => id - val name = Symbol.name id - val all = List.filter - (fn A.Extern (_, id, _) => (Symbol.name id) = name - | A.Function (_, id, _, _, _) => (Symbol.name id) = name) - p - val num = length all - in - if num = 1 - then () - else ( ErrorMsg.error NONE ("multiple definition of " ^ name); - raise ErrorMsg.Error ) - end) p + | A.Function (_, _, _, _) => ( ErrorMsg.error mainp ("main has incorrect return type"); + raise ErrorMsg.Error ) + | _ => raise ErrorMsg.InternalError "marked of marked disallowed" + val () = typecheck_structs (tds, funcs) in - List.map (typecheck_fn p) p + (tds, Symbol.mapi (typecheck_fn (tds, funcs) NONE) funcs) end end diff --git a/util/graph.sml b/util/graph.sml new file mode 100644 index 0000000..502cd7c --- /dev/null +++ b/util/graph.sml @@ -0,0 +1,40 @@ +signature GRAPH = +sig + type node + type graph + val addnode : graph -> node -> node list -> graph + val addedge : graph -> node -> node -> graph + val isdag : graph -> node -> bool +end + +functor Graph (structure Node : ORD_KEY) :> GRAPH where type node = Node.key = +struct + structure Map = SplayMapFn(Node) + structure Set = HashSetFn(Node) + type node = Node.key + type graph = (Set.set) Map.map + + (* val addnode : graph -> node -> node list -> graph + * adds a node given its links (directed) + *) + fun addnode g n nl = + case Map.find (g,n) + of SOME(ns) => Map.insert (g, n, Set.addList (ns, nl)) + | NONE => Map.insert (g, n, Set.addList (Set.empty, nl)) + + fun addedge g n1 n2 = + let + val set1 = case Map.find (g,n1) of SOME(a) => a | NONE => Set.empty + val set2 = case Map.find (g,n2) of SOME(a) => a | NONE => Set.empty + in + Map.insert (Map.insert (g, n2, set2), n1, Set.add (set1, n2)) + end + + fun isdag g n = + let + val nn = Set.numItems (case Map.find (g,n) of SOME(a) => a | NONE => Set.empty) + + in + end + +end diff --git a/util/symbol.sml b/util/symbol.sml index 87a0ab9..3111761 100644 --- a/util/symbol.sml +++ b/util/symbol.sml @@ -39,6 +39,11 @@ sig val elemsi : 'a table -> (symbol * 'a) list (* return the symbols with the associated data *) val keys : 'a table -> symbol list (* just the symbols *) val intersect : ('a * 'a -> 'a) -> 'a table * 'a table -> 'a table + + val mapi : (symbol * 'a -> 'b) -> 'a table -> 'b table + val mapPartial : ('a -> 'b option) -> 'a table -> 'b table + val mapPartiali : (symbol * 'a -> 'b option) -> 'a table -> 'b table + val appi : (symbol * 'a -> unit) -> 'a table -> unit (* symbol set -- similar to a () Symbol.table, elements can be removed *) type set @@ -105,6 +110,10 @@ struct fun elemsi t = Map.listItemsi t fun keys t = Map.listKeys t fun intersect binding (t1,t2) = Map.intersectWith binding (t1,t2) + fun mapi f t = Map.mapi f t + fun mapPartial f t = Map.mapPartial f t + fun mapPartiali f t = Map.mapPartiali f t + fun appi f t = Map.appi f t fun delimit' [] s = s | delimit' [x] s = s ^ x