From: Joshua Wise Date: Thu, 14 May 2009 02:05:49 +0000 (-0400) Subject: Initial import of l3c X-Git-Url: http://git.joshuawise.com/snipe.git/commitdiff_plain/6ade8b0a3251e44b34c6bdbbd9403e36d6fd6231 Initial import of l3c --- diff --git a/Makefile b/Makefile index 8829383..88508a2 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,24 @@ # the following are SML-NJ specific defines SML = sml -l2c: FORCE - echo 'use "compile-l2c.sml";' | ${SML} +l3c: FORCE + echo 'use "compile-l3c.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 + +reallyclean: clean + ${RM} parse/*.lex.* parse/*.grm.* clean: find . -type d -name .cm | xargs rm -rf - ${RM} parse/*.lex.* parse/*.grm.* find . -type f | grep '~$$' | xargs ${RM} - ${RM} bin/l2c.heap.* + ${RM} bin/l3c.heap.* + ${RM} bin/l3c-mlton + TAGS: clean ${RM} TAGS diff --git a/README b/README index 66a2e23..4c6899b 100644 --- a/README +++ b/README @@ -1,69 +1,69 @@ README ------ -This compiler is a big long chain of modules that transform l2 code into +This compiler is a big long chain of modules that transform l3 code into x86_64 assembly. -These modules include: +Here is a breakdown of the modules and changes from l2: + + * 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 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 translator was extended with a CALL. + + * 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 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 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 color orderer had no changes. + + * The coloring module was slightly updated to recognize more fixed-color + registers. It implements a greedy coloring algorithm. + + * 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 peepholer is upgraded somewhat; it now eliminates more redundant + instructions (such as adding/subtracting 0). - * The parser. The parser was mainly brought in from lab 1, and mainly - just a straight-forward extension of the l1 parser. We continued to - mark expressions, and pass marking through as needed so that we could - produce reasonable error messages up through translation stage. We - introduced all needed grammar with no shift/reduce conflicts, but for - one in the IF/ELSE stage, with a construct such as: - if (x) - if (z) - a - else - b - (indentation intentionally omitted; there are at least two legitimate - ways to parse that!) - * The typechecker. This module was completely rewritten since lab1. Three - checks are instituted: a check to see if the program has misplaced break - or continue statements, a check to see that the program returns in all - control paths, and a check that all variables are initialized in all - control paths before usage. - - The return and break check is essentially implemented per the rules; the - only thing of interest for the variable initialization routine is that - there is a helper that computes all assigns to extend contexts from - block contents. It was determined that returning 2 accumulators from - varcheck would lead to returning 17 accumulators, which would lead to - 1984193248148132 accumulators; and 238547854478 accumulators leads to - the foldl, and foldl leads to anger, anger leads to hate, and hate leads - to the Dark Side. - * The translator is mainly intact; it was determined that the IR will have - basic control flow instructions of labels, jumps, and jump if not - conditional, which we deemed sufficient to implement all forms of l2 - control. - * The munch module was fully rewritten; we now munch directly to - pseudo-x86_64, in that it has temporaries allowed in it as well. We - believe that this allows us to generate much more optimal code than - munching into three op, converting from three to two, then converting - two to x86_64; in particular, we can run liveness on the x86_64 - directions directly, which makes translation significantly easier (we do - not have to worry about mashing necessary registers). - * The liveness analyzer was also fully rewritten; it is now fully - def-use-succ, giving us very pretty rules, and a lot of very ugly code - to mash them together. Luckily, the ugly code need not be touched ever - again. - * The grapher had about 4 characters of inconsequential change that had - the useful property of speeding it up by two orders of magnitude. You - need not worry about it. - * The orderer and colorer had no changes. - * A new module was introduced -- in particular, the solidifier. The - solidifier takes pseudo-x86_64 that is annotated with register locations - and emits needed spill and unspill operations to get everything into - real registers that the x86_64 chips can access. - * The peepholer remains pretty simple; redundant moves are optimized out, - and hence the code size drops by a factor of 1.5 or so. * The stringifier is of no interest to you, for it does real things that interact with the real world, and that is not of interest to people who write in ML. -We believe that it's fully functional; we have not had a case in quite some -time that caused us to generate incorrect code (at least, when we should -generate code). The internal debug mechanisms are very useful; often a -line-by-line examination of dumps after each translation phase can narrow -bugs down into single lines of ML code. + * Our internal representation of x86 assembly was changed. In particular, + conditional sets and jumps are now SETcc of cc * oper and Jcc of cc * + oper, instead of a separate SET or J for each condition code. This + simplifies other parts of the code as well. + +We believe that it is fully functional. We generate correct code whenever we +are supposed to, and we pass every test that we can lay our hands on +(including all of l2, and one of ours that killed the reference compiler). +Of course, our last bug was caught by only one failing test, so... \ No newline at end of file diff --git a/bin/l2c b/bin/l2c deleted file mode 100755 index 4b7579c..0000000 --- a/bin/l2c +++ /dev/null @@ -1 +0,0 @@ -sml @SMLcmdname=$0 @SMLload=bin/l2c.heap.x86-linux $* diff --git a/bin/l3c b/bin/l3c new file mode 100755 index 0000000..6350d67 --- /dev/null +++ b/bin/l3c @@ -0,0 +1 @@ +sml @SMLcmdname=$0 @SMLload=bin/l3c.heap.x86-linux $* diff --git a/codegen/codegen.sml b/codegen/codegen.sml index 9b99ef7..8a5afe2 100644 --- a/codegen/codegen.sml +++ b/codegen/codegen.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Assembly code generator for fake x86 assembly * Author: Joshua Wise * Author: Chris Lu @@ -14,172 +14,421 @@ struct structure T = Tree structure X = x86 + (* effect : T.exp -> bool + * true iff the given expression has an effect. + *) + fun effect (T.BINOP(T.DIV, _, _)) = true + | effect (T.BINOP(T.MOD, _, _)) = true + | effect (T.CALL _) = true + | effect (T.BINOP(_, a, b)) = (effect a) orelse (effect b) + | effect (T.UNOP (_, a)) = effect a + | effect _ = false + + (* hasfixed : T.exp -> bool + * true iff the given expression has an hasfixed. Somewhat like effect, hmm? + *) + fun hasfixed (T.BINOP(T.DIV, _, _)) = true + | hasfixed (T.BINOP(T.MOD, _, _)) = true + | hasfixed (T.BINOP(T.LSH, _, _)) = true + | hasfixed (T.BINOP(T.RSH, _, _)) = true + | hasfixed (T.CALL _) = true + | hasfixed (T.BINOP(_, a, b)) = (hasfixed a) orelse (hasfixed b) + | hasfixed (T.UNOP (_, a)) = hasfixed a + | hasfixed _ = false + (* munch_exp : prex86oper -> T.exp -> prex86insn list *) (* munch_exp d e * generates instructions to achieve d <- e * d must be TEMP(t) or REG(r) *) - fun munch_exp d (T.CONST(n)) = [X.MOVL(d, X.CONST n)] - | munch_exp d (T.TEMP(t)) = [X.MOVL(d, X.TEMP t)] - | munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = (munch_exp d e1) @ [X.ADDL(d, X.CONST n)] - | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = (munch_exp d e1) @ [X.ADDL(d, X.CONST n)] + fun 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. *) + let + val nargs = length l + val nstack = if (nargs <= 6) + then 0 + else nargs - 6 + val stackb = nstack * 8 + fun argdest 1 = X.REG X.EDI + | argdest 2 = X.REG X.ESI + | argdest 3 = X.REG X.EDX + | 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)))) + + 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 + (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 + (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 argevals_hf = List.map + (fn (t,exp) => munch_exp (X.TEMP t) exp) + (ListPair.zip (temps, exps_hf)) + val argpushes = List.map + (fn (dest, t) => [(X.MOV (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)) + 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.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! *) + end + | munch_exp d (T.BINOP(T.ADD, e1, T.CONST 0w0)) = munch_exp d e1 + | munch_exp d (T.BINOP(T.ADD, T.CONST 0w0, e1)) = munch_exp d e1 + | munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = (munch_exp d e1) @ [X.ADD(d, X.CONST n)] + | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = (munch_exp d e1) @ [X.ADD(d, X.CONST n)] + | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = (munch_exp d e1) @ [X.ADD(d, X.TEMP t)] + | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e2)) = (munch_exp d e2) @ [X.ADD(d, X.TEMP t)] | munch_exp d (T.BINOP(T.ADD, e1, e2)) = let - val t1 = Temp.new () + val t1 = X.TEMP (Temp.new ("add")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ [X.ADDL(d, X.TEMP t1)] + (munch_exp d e1) @ (munch_exp t1 e2) @ [X.ADD(d, t1)] end | munch_exp d (T.BINOP(T.SUB, T.CONST 0w0, e1)) = (munch_exp d e1) @ [X.NEG d] - | munch_exp d (T.BINOP(T.SUB, e1, T.CONST(n))) = (munch_exp d e1) @ [X.SUBL(d, X.CONST n)] + | munch_exp d (T.BINOP(T.SUB, e1, T.CONST 0w0)) = munch_exp d e1 + | munch_exp d (T.BINOP(T.SUB, e1, T.CONST(n))) = (munch_exp d e1) @ [X.SUB(d, X.CONST n)] + | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = (munch_exp d e1) @ [X.SUB(d, X.TEMP t)] | munch_exp d (T.BINOP(T.SUB, e1, e2)) = - let val - t1 = Temp.new () + let + val t1 = X.TEMP (Temp.new ("sub")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ [X.SUBL(d, X.TEMP t1)] + (munch_exp d e1) @ (munch_exp t1 e2) @ [X.SUB(d, t1)] end | munch_exp d (T.BINOP(T.MUL, T.TEMP t, T.CONST n)) = [X.IMUL3(d, X.TEMP t, n)] | munch_exp d (T.BINOP(T.MUL, T.CONST n, T.TEMP t)) = [X.IMUL3(d, X.TEMP t, n)] + | munch_exp d (T.BINOP(T.MUL, e1, T.CONST 0w1)) = munch_exp d e1 + | munch_exp d (T.BINOP(T.MUL, T.CONST 0w1, e1)) = munch_exp d e1 | munch_exp d (T.BINOP(T.MUL, e1, T.CONST n)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] | munch_exp d (T.BINOP(T.MUL, T.CONST n, e1)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] | munch_exp d (T.BINOP(T.MUL, e1, e2)) = let - val t1 = Temp.new () + val t1 = X.TEMP (Temp.new ("mul")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ [X.IMUL(d, X.TEMP t1)] + (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 = Temp.new () + val t1 = X.TEMP (Temp.new ("div")) in - (munch_exp (X.TEMP t1) e1) @ (munch_exp d e2) @ - [X.MOVL (X.REG X.EAX, X.TEMP t1), X.CLTD, X.IDIVL d, X.MOVL (d, X.REG X.EAX)] + (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 = Temp.new () + val t1 = X.TEMP (Temp.new ("mod")) in - (munch_exp (X.TEMP t1) e1) @ (munch_exp d e2) @ - [X.MOVL (X.REG X.EAX, X.TEMP t1), X.CLTD, X.IDIVL d, X.MOVL (d, X.REG X.EDX)] + (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)] end - | munch_exp d (T.BINOP(T.LSH, e1, T.CONST n)) = (munch_exp d e1) @ [X.SALL (d, X.CONST n)] + | munch_exp d (T.BINOP(T.LSH, e1, T.CONST n)) = (munch_exp d e1) @ [X.SAL (d, X.CONST (n mod 0w32))] + | munch_exp d (T.BINOP(T.LSH, e1, T.TEMP t)) = (munch_exp d e1) @ [X.MOV (X.REG X.ECX, X.TEMP t), X.SAL (d, X.REG X.ECX)] | munch_exp d (T.BINOP(T.LSH, e1, e2)) = let - val t1 = Temp.new() + val t = X.TEMP (Temp.new ("lsh")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.MOVL (X.REG X.ECX, X.TEMP t1), X.SALL (d, X.REG X.ECX)] + (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAL (d, X.REG X.ECX)] end - | munch_exp d (T.BINOP(T.RSH, e1, T.CONST n)) = (munch_exp d e1) @ [X.SARL (d, X.CONST n)] + | munch_exp d (T.BINOP(T.RSH, e1, T.CONST n)) = (munch_exp d e1) @ [X.SAR (d, X.CONST (n mod 0w32))] + | munch_exp d (T.BINOP(T.RSH, e1, T.TEMP t)) = (munch_exp d e1) @ [X.MOV (X.REG X.ECX, X.TEMP t), X.SAR (d, X.REG X.ECX)] | munch_exp d (T.BINOP(T.RSH, e1, e2)) = let - val t1 = Temp.new() + val t = X.TEMP (Temp.new ("rsh")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.MOVL (X.REG X.ECX, X.TEMP t1), X.SARL (d, X.REG X.ECX)] + (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAR (d, X.REG X.ECX)] end - | munch_exp d (T.BINOP(T.LOGOR, e1, e2)) = + | munch_exp d (T.BINOP(T.BITAND, T.CONST n, e1)) = (munch_exp d e1) @ [X.AND (d, X.CONST n)] + | munch_exp d (T.BINOP(T.BITAND, e1, T.CONST n)) = (munch_exp d e1) @ [X.AND (d, X.CONST n)] + | munch_exp d (T.BINOP(T.BITAND, T.TEMP t, e1)) = (munch_exp d e1) @ [X.AND (d, X.TEMP t)] + | munch_exp d (T.BINOP(T.BITAND, e1, T.TEMP t)) = (munch_exp d e1) @ [X.AND (d, X.TEMP t)] + | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = let - val l1 = Label.new() + val t1 = X.TEMP (Temp.new ("bitand")) in - (munch_exp d e1) @ [X.CMPL (d, X.CONST(0w0)), X.JNE l1] @ (munch_exp d e2) @ [X.CMPL (d, X.CONST(0w0)), X.LABEL l1, X.SETNE d, X.MOVZBL(d,d)] + (munch_exp d e1) @ (munch_exp t1 e2) @ [X.AND(d, t1)] end - | munch_exp d (T.BINOP(T.LOGAND, e1, e2)) = + | munch_exp d (T.BINOP(T.BITOR, T.CONST n, e1)) = (munch_exp d e1) @ [X.OR (d, X.CONST n)] + | munch_exp d (T.BINOP(T.BITOR, e1, T.CONST n)) = (munch_exp d e1) @ [X.OR (d, X.CONST n)] + | munch_exp d (T.BINOP(T.BITOR, T.TEMP t, e1)) = (munch_exp d e1) @ [X.OR (d, X.TEMP t)] + | munch_exp d (T.BINOP(T.BITOR, e1, T.TEMP t)) = (munch_exp d e1) @ [X.OR (d, X.TEMP t)] + | munch_exp d (T.BINOP(T.BITOR, e1, e2)) = let - val l1 = Label.new() + val t1 = X.TEMP (Temp.new ("bitor")) in - (munch_exp d e1) @ [X.CMPL (d, X.CONST(0w0)), X.JE l1] @ (munch_exp d e2) @ [X.CMPL (d, X.CONST(0w0)), X.LABEL l1, X.SETNE d, X.MOVZBL(d,d)] + (munch_exp d e1) @ (munch_exp t1 e2) @ [X.OR(d, t1)] end - | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = + | munch_exp d (T.BINOP(T.BITXOR, T.CONST n, e1)) = (munch_exp d e1) @ [X.XOR (d, X.CONST n)] + | munch_exp d (T.BINOP(T.BITXOR, e1, T.CONST n)) = (munch_exp d e1) @ [X.XOR (d, X.CONST n)] + | munch_exp d (T.BINOP(T.BITXOR, T.TEMP t, e1)) = (munch_exp d e1) @ [X.XOR (d, X.TEMP t)] + | munch_exp d (T.BINOP(T.BITXOR, e1, T.TEMP t)) = (munch_exp d e1) @ [X.XOR (d, X.TEMP t)] + | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) = let - val t1 = Temp.new () + val t1 = X.TEMP (Temp.new ("bitxor")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ [X.ANDL(d, X.TEMP t1)] + (munch_exp d e1) @ (munch_exp t1 e2) @ [X.XOR(d, t1)] end - | munch_exp d (T.BINOP(T.BITOR, e1, e2)) = + | munch_exp d (a as T.BINOP(T.LOGAND, e1, e2)) = let - val t1 = Temp.new () + 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 l = Label.new () in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ [X.ORL(d, X.TEMP t1)] + if (effect e2 orelse (length insn2 > 10)) + then (insn1) @ + [X.SETcc(pos1, t1), X.Jcc (neg1, l)] @ + (insn2) @ + [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)] + else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.AND(t1, t2)), X.MOVZB(d, t1)] end - | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) = + | munch_exp d (a as T.BINOP(T.LOGOR, e1, e2)) = let - val t1 = Temp.new () + 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 l = Label.new () in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ [X.XORL(d, X.TEMP t1)] + if (effect e2 orelse (length insn2 > 10)) + then (insn1) @ + [X.SETcc(pos1, t1), X.Jcc (pos1, l)] @ + (insn2) @ + [X.SETcc(pos2, t1), X.LABEL l, X.MOVZB(d, t1)] + else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.SIZE(X.Byte, X.OR(t1, t2)), X.MOVZB(d, t1)] end - | munch_exp d (T.BINOP(T.NEQ, e1, e2)) = + | munch_exp d (a as T.BINOP(T.EQ, _, _)) = + let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end + | munch_exp d (a as T.BINOP(T.NEQ, _, _)) = + let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end + | munch_exp d (a as T.BINOP(T.LE, _, _)) = + let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end + | munch_exp d (a as T.BINOP(T.LT, _, _)) = + let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end + | munch_exp d (a as T.BINOP(T.GE, _, _)) = + let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end + | munch_exp d (a as T.BINOP(T.GT, _, _)) = + let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end + | munch_exp d (T.UNOP(T.NEG, T.CONST n)) = [X.MOV (d, X.CONST (~n))] + | munch_exp d (T.UNOP(T.NEG, e1)) = (munch_exp d e1) @ [X.NEG d] + | munch_exp d (T.UNOP(T.BITNOT, T.CONST n)) = [X.MOV (d, X.CONST (Word32.notb n))] + | munch_exp d (T.UNOP(T.BITNOT, e1)) = (munch_exp d e1) @ [X.NOT d] + | munch_exp d (T.UNOP(T.BANG, T.CONST n)) = if (n = 0w0) then [X.MOV (d, X.CONST 0w1)] else [X.MOV (d, X.CONST 0w0)] + | munch_exp d (T.UNOP(T.BANG, e)) = let - val t1 = Temp.new () + val (insns, pos, neg) = munch_cond e in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.CMPL(d, X.TEMP t1), X.SETNE(d), X.MOVZBL(d, d)] + insns @ [X.SETcc (neg, d), X.MOVZB(d, d)] end - | munch_exp d (T.BINOP(T.EQ, e1, e2)) = + (* 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. + *) + and munch_cond (T.UNOP (T.BANG, e)) = let - val t1 = Temp.new () + val (insns, pos, neg) = munch_cond e in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.CMPL(d, X.TEMP t1), X.SETE(d), X.MOVZBL(d, d)] + (insns, neg, pos) end - | munch_exp d (T.BINOP(T.LE, e1, e2)) = + | 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 + | 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 + | 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 + | 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 + | munch_cond (T.BINOP(T.NEQ, e1, e2)) = let - val t1 = Temp.new () + val t1 = X.TEMP (Temp.new ("var neq 1")) + val t2 = X.TEMP (Temp.new ("var neq 2")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.CMPL(d, X.TEMP t1), X.SETLE(d), X.MOVZBL(d, d)] + (munch_exp t1 e1 @ munch_exp t2 e2 @ + [X.CMP(t1, t2)], X.NE, X.E) end - | munch_exp d (T.BINOP(T.LT, e1, e2)) = + | 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 + | 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 + | 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 + | 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 + | munch_cond (T.BINOP(T.EQ, e1, e2)) = let - val t1 = Temp.new () + val t1 = X.TEMP (Temp.new ("var eq 1")) + val t2 = X.TEMP (Temp.new ("var eq 2")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.CMPL(d, X.TEMP t1), X.SETL(d), X.MOVZBL(d, d)] + (munch_exp t1 e1 @ munch_exp t2 e2 @ + [X.CMP(t1, t2)], X.E, X.NE) end - | munch_exp d (T.BINOP(T.GE, e1, e2)) = + | 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 + | 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 + | 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 + | 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 + | munch_cond (T.BINOP(T.LE, e1, e2)) = let - val t1 = Temp.new () + val t1 = X.TEMP (Temp.new ("var le 1")) + val t2 = X.TEMP (Temp.new ("var le 2")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.CMPL(d, X.TEMP t1), X.SETGE(d), X.MOVZBL(d, d)] + (munch_exp t1 e1 @ munch_exp t2 e2 @ + [X.CMP(t1, t2)], X.LE, X.G) end - | munch_exp d (T.BINOP(T.GT, e1, e2)) = + | 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 + | 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 + | 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 + | 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 + | munch_cond (T.BINOP(T.LT, e1, e2)) = let - val t1 = Temp.new () + val t1 = X.TEMP (Temp.new ("var lt 1")) + val t2 = X.TEMP (Temp.new ("var lt 2")) in - (munch_exp d e1) @ (munch_exp (X.TEMP t1) e2) @ - [X.CMPL(d, X.TEMP t1), X.SETG(d), X.MOVZBL(d, d)] + (munch_exp t1 e1 @ munch_exp t2 e2 @ + [X.CMP(t1, t2)], X.L, X.GE) end - | munch_exp d (T.UNOP(T.NEG, e1)) = (munch_exp d e1) @ [X.NEG d] - | munch_exp d (T.UNOP(T.BITNOT, e1)) = (munch_exp d e1) @ [X.NOTL d] - | munch_exp d (T.UNOP(T.BANG, e1)) = (munch_exp d e1) @ - [X.TEST(d,d), X.SETE(d), X.MOVZBL(d, d)] + | 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 + | 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 + | 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 + | 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 + | 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")) + in + (munch_exp t1 e1 @ munch_exp t2 e2 @ + [X.CMP(t1, t2)], X.G, X.LE) + end + | munch_cond (T.BINOP(T.GE, T.TEMP t, T.CONST n)) = ([X.CMP(X.TEMP t, X.CONST n)], X.GE, X.L) + | munch_cond (T.BINOP(T.GE, T.CONST n, T.TEMP t)) = ([X.CMP(X.TEMP t, X.CONST n)], X.LE, X.G) + | munch_cond (T.BINOP(T.GE, e1, T.CONST n)) = + let val t = X.TEMP (Temp.new ("const ge")) 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 + | 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 + | 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 + | 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")) + in + (munch_exp t1 e1 @ munch_exp t2 e2 @ + [X.CMP(t1, t2)], X.GE, X.L) + end + | munch_cond (T.BINOP(T.LOGOR, e1, e2)) = + let + val (insn1, pos1, neg1) = munch_cond e1 + val (insn2, pos2, neg2) = munch_cond e2 + val t1 = X.TEMP (Temp.new("logor c 1")) + val t2 = X.TEMP (Temp.new("logor c 2")) + 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.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) + 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 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.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) + end + | munch_cond e = + let + val t = X.TEMP (Temp.new ("munch c")) + in + (munch_exp t e @ [ X.TEST (t,t) ], X.NE, X.E) + end (* munch_stm : T.stm -> X.insn list *) (* munch_stm stm generates code to execute stm *) - fun 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 _)) = 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)) = let - val t = Temp.new () + val t = Temp.new ("assign") in munch_exp (X.TEMP t) e2 - @ [X.MOVL(X.TEMP t1, X.TEMP t)] + @ [X.MOV(X.TEMP t1, X.TEMP t)] end | munch_stm (T.MOVE(_, _)) = raise ErrorMsg.InternalError "Incorrect first operand for T.MOVE?" | munch_stm (T.RETURN(e)) = let - val t = Temp.new () + val t = Temp.new ("retval") in munch_exp (X.TEMP t) e - @ [X.MOVL(X.REG X.EAX, X.TEMP t), X.RET] + @ [X.MOV(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] | munch_stm (T.JUMPIFN(e, l)) = let - val t = Temp.new () + val (insns, pos, neg) = munch_cond e in - munch_exp (X.TEMP t) e - @ [X.TEST(X.TEMP t, X.TEMP t), X.JE l] + insns @ [X.Jcc (neg, l)] end fun codegen nil = nil diff --git a/codegen/coloring.sml b/codegen/coloring.sml index eeca849..1e08e1d 100644 --- a/codegen/coloring.sml +++ b/codegen/coloring.sml @@ -1,4 +1,4 @@ -(* L2 compiler +(* L3 compiler * colorizer * colors a graph and returns a list of nodes with associated colors * Author: Joshua Wise @@ -7,18 +7,29 @@ signature COLORIZER = sig + structure OperSet : ORD_SET + where type Key.ord_key = x86.oper + structure LiveMap : ORD_MAP + where type Key.ord_key = int + structure TempMap : ORD_MAP + where type Key.ord_key = Temp.temp + type temps = Temp.temp list type colorlist = (Temp.temp * int) list - type igraph = (Temp.temp * x86.oper list) list + type igraph = OperSet.set TempMap.map - val colorize : temps -> igraph -> colorlist + val colorize : temps -> Igraph.graph -> colorlist end structure Colorizer :> COLORIZER = struct + structure OperSet = Igraph.OperSet + structure LiveMap = Igraph.LiveMap + structure TempMap = Igraph.TempMap + type temps = Temp.temp list type colorlist = (Temp.temp * int) list - type igraph = (Temp.temp * x86.oper list) list + type igraph = OperSet.set TempMap.map structure X = x86 @@ -27,19 +38,20 @@ struct * already-colored nodes, colors the temp, and adds it to the list * this is a helper function for the foldr in colorize *) - fun color_single (graph: igraph) (temp, regs) = + fun color_single (graph: Igraph.graph) (temp, regs) = let - (* Grab the list of interfering operands from the graph *) - val interfere = case List.find (fn (temp',_) => Temp.compare (temp', temp) = EQUAL) graph - of SOME(_, l) => l - | NONE => raise ErrorMsg.InternalError "Temporary not found in graph" + (* Grab the set of interfering operands from the graph *) + val interfere = case TempMap.find (graph, temp) + of SOME(l) => OperSet.listItems l + | NONE => [] +(* | NONE => raise ErrorMsg.InternalError "Temporary not found in graph" *) (* Grab the subset of those that are already colorized *) val colorized = List.filter (fn (t,_) => List.exists - (fn X.TEMP t' => Temp.compare (t, t') = EQUAL + (fn X.TEMP t' => Temp.eq (t, t') | _ => false) interfere ) regs @@ -57,10 +69,8 @@ struct (fn (_,i) => i) colorized) @ (List.map - (fn X.REG X.EAX => 0 - | X.REG X.EDX => 3 - | X.REG X.ECX => 2 - | _ => raise ErrorMsg.InternalError "Bad kind of specreg") + (fn X.REG a => X.regtonum a + | loss => raise ErrorMsg.InternalError ("Bad kind of specreg " ^ (X.prettyprint_oper X.Long loss ))) fixeds) (* Greedy-colorize -- pick the lowest number that isn't used by a neighbor *) fun greedy i l = diff --git a/codegen/colororder.sml b/codegen/colororder.sml index f533cea..0f25863 100644 --- a/codegen/colororder.sml +++ b/codegen/colororder.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Takes a interference graph and generates an ordering for coloring * Author: Joshua Wise * Author: Chris Lu @@ -6,10 +6,17 @@ signature COLORORDER = sig - type igraph = (Temp.temp * x86.oper list) list + structure OperSet : ORD_SET + where type Key.ord_key = x86.oper + structure LiveMap : ORD_MAP + where type Key.ord_key = int + structure TempMap : ORD_MAP + where type Key.ord_key = Temp.temp + + type igraph = OperSet.set TempMap.map type ordering = Temp.temp list - val colororder : igraph -> ordering + val colororder : Igraph.graph * Temp.temp list -> ordering end structure ColorOrder :> COLORORDER = @@ -17,12 +24,16 @@ struct structure T = Temp structure X = x86 - type igraph = (Temp.temp * x86.oper list) list + structure OperSet = Igraph.OperSet + structure LiveMap = Igraph.LiveMap + structure TempMap = Igraph.TempMap + + type igraph = OperSet.set TempMap.map type ordering = Temp.temp list - fun colororder graph = + fun colororder (graph,temps) = let - val initialWeights = map (fn (t, _) => (t, 0)) graph + val initialWeights = TempMap.mapi (fn (t, _) => (t, 0)) graph fun sortWeights weights = (* Sort the weights such that the largest is at left, ready to be grabbed. *) ListMergeSort.sort (fn ((_, a), (_, b)) => a < b) weights @@ -34,15 +45,14 @@ struct val (chosen, w) = List.hd sorted (* Grab the temp with the highest weight. *) val remaining = List.tl sorted val neighbors = (* Grab all the neighbors for some given temp. *) - List.hd - (List.map (fn (_, neighbors) => neighbors) - (List.filter (fn (t, _) => T.compare (t, chosen) = EQUAL) graph)) + (OperSet.listItems + (valOf (TempMap.find (graph, chosen)))) val newWeights = List.map (fn (t, wt) => (t, if (List.exists - (fn X.TEMP t' => (T.compare (t, t') = EQUAL) + (fn X.TEMP t' => (T.eq (t, t')) | _ => false) neighbors) then (wt + 1) @@ -61,7 +71,9 @@ struct in chosen :: (keepOrdering newWeights) end + + val ordered = keepOrdering (TempMap.listItems initialWeights) in - (keepOrdering initialWeights) + ordered @ (List.filter (fn a => not (List.exists (fn b => Temp.eq (a,b)) ordered)) temps) end end diff --git a/codegen/igraph.sml b/codegen/igraph.sml index 9fe50a0..30b17ee 100644 --- a/codegen/igraph.sml +++ b/codegen/igraph.sml @@ -1,4 +1,4 @@ -(* L2 compiler +(* L3 compiler * interference graph generator * Takes a list of interfering temps and generates the interference graph * Author: Chris Lu @@ -6,66 +6,109 @@ signature IGRAPH = sig - type interferences = x86.oper list list - type graph = (Temp.temp * x86.oper list) list - val gengraph : interferences -> graph + structure OperSet : ORD_SET + where type Key.ord_key = x86.oper + structure LiveMap : ORD_MAP + where type Key.ord_key = int + structure TempMap : ORD_MAP + where type Key.ord_key = Temp.temp + + type predicates = Liveness.predicates + type livenesses = Liveness.livenesses + type graph = OperSet.set TempMap.map + val gengraph : predicates * livenesses -> graph * Temp.temp list end structure Igraph :> IGRAPH = struct - type interferences = x86.oper list list - type graph = (Temp.temp * x86.oper list) list + structure OperSet = Liveness.OperSet + structure LiveMap = Liveness.LiveMap + + structure TempSet = BinarySetFn ( + struct + type ord_key = Temp.temp + val compare = Temp.compare + end + ) + + structure TempMap = SplayMapFn ( + struct + type ord_key = Temp.temp + val compare = Temp.compare + end) + + type predicates = Liveness.predicates + type livenesses = Liveness.livenesses + type graph = OperSet.set TempMap.map + structure X = x86 - (* val canonicalize : graph -> graph - * canonicalize a => puts a in the canonical form by eliminating repeat nodes and edges - * does so by sorting them first, then eliminating consecutive temps - *) - fun canonicalize orig = + fun add_temp_interfere g (t, oper) = let - val sorig = ListMergeSort.sort (fn ((a,_),(b,_)) => X.cmpoper (a,b) = LESS) orig - fun merge ((x, xl)::(y, yl)::rl) = (if X.opereq (x,y) then merge ((x, List.revAppend(yl,xl))::rl) else (x, xl) :: merge ((y, yl)::rl)) - | merge (a::nil) = [a] - | merge nil = nil - val ml = merge sorig - fun uniq l = - let - val sl = ListMergeSort.sort (fn (a,b) => X.cmpoper (a,b) = LESS) l - fun merge' (x::y::rl) = (if X.opereq (x,y) then merge' (x::rl) else x :: merge' (y::rl)) - | merge' (x::nil) = [x] - | merge' nil = nil - in - merge' sl - end + val set = (valOf (TempMap.find (g, t))) handle Option => OperSet.empty in - List.map (fn (a, x) => (a, uniq x)) ml + TempMap.insert (g, t, OperSet.union (set, OperSet.singleton oper)) + end + + fun add_interfere g (o1, o2) = + let + val g = case o1 + of (X.TEMP t) => add_temp_interfere g (t, o2) + | _ => g + in + case o2 + of (X.TEMP t) => add_temp_interfere g (t, o1) + | _ => g end - (* val proc_one : Temp.temp list * graph -> graph - * helper function to convert a list of interfering registers to a graph - *) - fun proc_one x = - List.map - (fn item1 => (item1, (List.filter (fn item2 => not (X.opereq(item1, item2))) x))) - x + fun alltemps preds = + LiveMap.foldr + (fn (ps, ts) => List.foldr + (fn (Liveness.DEF(X.TEMP t), ts') => TempSet.add (ts', t) + | (Liveness.USE(X.TEMP t), ts') => TempSet.add (ts', t) + | (_, ts') => ts') + ts + ps + ) + TempSet.empty + preds (* val gengraph : interferences -> graph * generates the interference graph from a list of interfering temps * by creating separate interference graphs for each line, concatenating them, * and putting them in canonical form *) - fun gengraph x = - let - val igraph' = canonicalize (List.concat (List.map proc_one x)) - in - foldr - (fn ((a,l),b) => case a - of X.REG(_) => b - | X.TEMP(t) => (t,l)::b - | _ => raise ErrorMsg.InternalError "Non-live register type found in igraph" + fun gengraph (preds, lives) : graph * Temp.temp list = + (LiveMap.foldri + (fn (ln, predlist, map) => + let + val ismove = Liveness.ismove predlist + in + List.foldr + (fn (oper, map) => + List.foldr + (fn (ln', map) => + let + val liveat = valOf (LiveMap.find (lives, ln')) + val liveat = + if not ismove + then liveat + else OperSet.difference + (liveat, + OperSet.addList (OperSet.empty, Liveness.uses predlist)) + in + OperSet.foldr + (fn (oper', map) => add_interfere map (oper, oper')) + map + liveat + end) + map + (Liveness.succs predlist)) + map + (Liveness.defs predlist) + end ) - nil - igraph' - end - + TempMap.empty + preds, + TempSet.listItems (alltemps preds)) end diff --git a/codegen/liveness.sml b/codegen/liveness.sml index 95f1f90..24123b9 100644 --- a/codegen/liveness.sml +++ b/codegen/liveness.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Turns pseudoasm into liveness-annotated pseudoasm * Author: Chris Lu * Author: Joshua Wise @@ -6,31 +6,47 @@ signature LIVENESS = sig - - type live = int * x86.oper list + structure OperSet : ORD_SET + where type Key.ord_key = x86.oper; + structure LiveMap : ORD_MAP + where type Key.ord_key = int; + + type live = int * OperSet.set type pseudoasm = x86.insn list - type livenesses = x86.oper list list - + type livenesses = OperSet.set LiveMap.map + type ident = int - datatype pred = DEF of x86.oper | USE of x86.oper | SUCC of ident + datatype pred = DEF of x86.oper | USE of x86.oper | SUCC of ident | ISMOVE + + type predicates = pred list LiveMap.map + + val uses : pred list -> x86.oper list + val succs : pred list -> ident list + val defs : pred list -> x86.oper list + val ismove : pred list -> bool - val liveness : pseudoasm -> livenesses - val prettyprint : x86.oper list -> string + val liveness : pseudoasm -> predicates * livenesses + val listify : livenesses -> OperSet.set list + val prettyprint : OperSet.set -> string end structure Liveness :> LIVENESS = struct structure T = Temp structure X = x86 + + structure OperSet = x86.OperSet + structure LiveMap = x86.LiveMap - - type live = int * x86.oper list + type live = int * OperSet.set type pseudoasm = X.insn list - type numasm = (int * X.insn) list - type livenesses = X.oper list list + type numasm = X.insn LiveMap.map + type livenesses = OperSet.set LiveMap.map type ident = int - datatype pred = DEF of X.oper | USE of X.oper | SUCC of ident + datatype pred = DEF of X.oper | USE of X.oper | SUCC of ident | ISMOVE + + type predicates = pred list LiveMap.map (* val number : pseudoasm -> numasm * numbers the instructions! @@ -40,7 +56,10 @@ struct let val nums = List.tabulate (List.length instrs, (fn i => i)) in - ListPair.zip (nums,instrs) + foldr + LiveMap.insert' + LiveMap.empty + (ListPair.zip (nums,instrs)) end (* val defusesucc : numasm -> (ident * pred list) list @@ -51,82 +70,112 @@ struct let fun findlabel (lb) = Option.valOf - (foldr (fn ((n, X.LABEL lb'), NONE) => if (Label.compare (lb, lb') = EQUAL) then SOME n else NONE - | (_, old) => old) NONE l) + (LiveMap.foldri (fn (n, X.LABEL lb', NONE) => if (Label.compare (lb, lb') = EQUAL) then SOME n else NONE + | (_, _, old) => old) NONE l) (* val defhit/usehit : X.oper -> pred list * helper functions to discard constant operands *) - fun defhit (a as X.CONST(_)) = nil - | defhit (a) = [DEF(a)] + fun defhit (X.REG a) = [DEF(X.REG a)] + | defhit (X.TEMP a) = [DEF(X.TEMP a)] + | defhit (_) = nil + + fun usehit (X.REG a) = [USE(X.REG a)] + | usehit (X.TEMP a) = [USE(X.TEMP a)] + | usehit (_) = nil - fun usehit (a as X.CONST(_)) = nil - | usehit (a) = [USE(a)] + fun callhit 0 = nil + | callhit 1 = USE(X.REG(X.EDI))::(callhit 0) + | callhit 2 = USE(X.REG(X.ESI))::(callhit 1) + | callhit 3 = USE(X.REG(X.EDX))::(callhit 2) + | callhit 4 = USE(X.REG(X.ECX))::(callhit 3) + | callhit 5 = USE(X.REG(X.R8D))::(callhit 4) + | callhit 6 = USE(X.REG(X.R9D))::(callhit 5) + | callhit _ = callhit 6 (* val gendef : ident * X.insn -> ident * pred list * generates the def/use/succ predicates for a single insn *) - fun gendef (n, X.DIRECTIVE(_)) = (n, nil) - | gendef (n, X.COMMENT(_)) = (n, nil) - | gendef (n, X.MOVL(dest, src)) = (n, defhit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.SUBL(dest, src)) = (n, defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.IMUL(dest, src)) = (n, defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.IMUL3(dest, src, _)) = (n, defhit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.ADDL(dest, src)) = (n, defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.IDIVL(src)) = (n, usehit src @ [DEF(X.REG(X.EAX)), DEF(X.REG(X.EDX)), + 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.SUB(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.IMUL(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.IMUL3(dest, src, _)) = (defhit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.ADD(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.IDIV(src)) = (usehit src @ [DEF(X.REG(X.EAX)), DEF(X.REG(X.EDX)), USE(X.REG(X.EAX)), USE(X.REG(X.EDX)), SUCC(n+1)]) - | gendef (n, X.CLTD) = (n, [USE(X.REG(X.EAX)), DEF(X.REG(X.EDX)), SUCC(n+1)]) - | gendef (n, X.SALL(dest, shft)) = (n, defhit dest @ usehit shft @ usehit dest @ [SUCC(n+1)]) - | gendef (n, X.SARL(dest, shft)) = (n, defhit dest @ usehit shft @ usehit dest @ [SUCC(n+1)]) - | gendef (n, X.NEG(src)) = (n, defhit src @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.NOTL(src)) = (n, defhit src @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.ANDL(dest, src)) = (n, defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.ORL(dest, src)) = (n, defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.XORL(dest, src)) = (n, defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.CMPL(dest, src)) = (n, usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.TEST(dest, src)) = (n, usehit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.SETNE(dest)) = (n, defhit dest @ [SUCC(n+1)]) - | gendef (n, X.SETE(dest)) = (n, defhit dest @ [SUCC(n+1)]) - | gendef (n, X.SETLE(dest)) = (n, defhit dest @ [SUCC(n+1)]) - | gendef (n, X.SETL(dest)) = (n, defhit dest @ [SUCC(n+1)]) - | gendef (n, X.SETGE(dest)) = (n, defhit dest @ [SUCC(n+1)]) - | gendef (n, X.SETG(dest)) = (n, defhit dest @ [SUCC(n+1)]) - | gendef (n, X.MOVZBL(dest, src)) = (n, defhit dest @ usehit src @ [SUCC(n+1)]) - | gendef (n, X.RET) = (n, nil) - | gendef (n, X.LABEL l) = (n, [SUCC (n+1)]) - | gendef (n, X.JMP l) = (n, [SUCC (findlabel l)]) - | gendef (n, X.JE l) = (n, [SUCC (n+1), SUCC (findlabel l)]) - | gendef (n, X.JNE l) = (n, [SUCC (n+1), SUCC (findlabel l)]) + | gendef (n, X.CLTD) = ([USE(X.REG(X.EAX)), DEF(X.REG(X.EDX)), SUCC(n+1)]) + | gendef (n, X.SAL(dest, shft)) = (defhit dest @ usehit shft @ usehit dest @ [SUCC(n+1)]) + | gendef (n, X.SAR(dest, shft)) = (defhit dest @ usehit shft @ usehit dest @ [SUCC(n+1)]) + | gendef (n, X.NEG(src)) = (defhit src @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.NOT(src)) = (defhit src @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.AND(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.OR(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.XOR(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.CMP(dest, src)) = (usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.TEST(dest, src)) = (usehit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.SETcc(_,dest)) = (defhit dest @ [SUCC(n+1)]) + | gendef (n, X.CALL(_, a)) = (callhit a @ [DEF(X.REG(X.EAX)), DEF(X.REG(X.ECX)), DEF(X.REG(X.EDX)), + DEF(X.REG(X.EDI)), DEF(X.REG(X.ESI)), DEF(X.REG(X.R8D)), + DEF(X.REG(X.R9D)), DEF(X.REG(X.R10D)), DEF(X.REG(X.R11D)), SUCC(n+1)]) + | gendef (n, X.MOVZB(dest, src)) = (defhit dest @ usehit src @ [SUCC(n+1)]) + | gendef (n, X.RET) = ([USE (X.REG X.EAX)]) + | gendef (n, X.LABEL l) = ([SUCC (n+1)]) + | gendef (n, X.JMP l) = ([SUCC (findlabel l)]) + | gendef (n, X.Jcc (_,l)) = ([SUCC (n+1), SUCC (findlabel l)]) in - List.map gendef l + LiveMap.mapi gendef l end - (* val uselive : (ident * pred list) list -> live list + (* val uselive : (int * pred list) list -> OperSet.set LiveMap.map * generates liveness for 'use' rules to get the iterative analyzer started *) fun uselive preds = - List.map - (fn (n, l) => (n, List.foldr - (fn (a,b) => case a of USE(x) => x::b | _ => b) - nil - l + LiveMap.mapi + (fn (n, pl) => + foldr + (fn (USE (l), set) => OperSet.add (set, l) + | (_, set) => set) + OperSet.empty + pl ) - ) - preds + preds - (* val subsetlive : (ident * pred list) * (ident * pred list) -> bool + (* val subsetlive : OperSet.set LiveMap.map * OperSet.set LiveMap.map -> bool * true if first is subset of second *) fun subsetlive (l1,l2) = - ListPair.all - (fn ((n1,a),(n2,b)) => (n1 = n2) andalso List.all - (fn x => List.exists (fn y => X.opereq (x,y)) b) - a - ) - (l1,l2) + LiveMap.foldri + (fn (_, _, false) => false + | (n, set1, _) => case LiveMap.find (l2, n) + of NONE => false + | SOME set2 => OperSet.isSubset (set1, set2)) + true + l1 + + (* val succs : pred list -> int list + * generates a list of lines that succeed a line given the predicates + * for that line + *) + fun succs (SUCC(a)::l') = a::(succs l') + | succs (_::l') = succs l' + | succs nil = nil + + fun defs (DEF(a)::l) = a::(defs l) + | defs (_::l) = defs l + | defs nil = nil + + fun uses (USE(a)::l) = a::(defs l) + | uses (_::l) = defs l + | uses nil = nil + + fun ismove l = List.exists (fn ISMOVE => true | _ => false) l - (* val liveiter : live list -> (ident * pred list) list -> live list + (* val liveiter : OperSet.set LiveMap.map -> (int * pred list) list -> OperSet.set LiveMap.map * iteratively generates livenesses from def/use/succ rules * it must be fed a liveness list generated from the use rule as it only * processes the second rule : @@ -138,42 +187,34 @@ struct * live(l,x) *) - fun liveiter l p = + fun liveiter livemap preds = let - (* val succs : pred list -> l - * generates a list of lines that succeed a line given the predicates - * for that line - *) - fun succs (SUCC(a)::l) = a::(succs l) - | succs (_::l) = succs l - | succs nil = nil - (* val lives : ident list -> live list -> X.oper list + + + (* val lives : int list -> OperSet.set LiveMap.map -> OperSet.set * scans l for live variables in succeeding lines *) fun lives l' idents = - List.foldr - (fn ((_,a),b) => a @ b) - nil - (List.filter (fn (n,_) => List.exists (fn a => a = n) idents) l') + let + val lines = List.mapPartial (fn a => LiveMap.find (l', a)) idents + in + foldr + (fn (set', set) => OperSet.union (set', set)) + OperSet.empty + lines + end (* val isndef : X.oper -> pred list -> bool * checks to see if x is defined in a predicate list *) - fun isndef x (DEF(y)::l) = not (X.opereq (x,y)) andalso isndef x l - | isndef x (a::l) = isndef x l + fun isndef (X.STACKARG(_)) _ = false + | isndef x (DEF(y)::l') = not (X.opereq (x,y)) andalso isndef x l' + | isndef x (a::l') = isndef x l' | isndef x nil = true - (* val addonce : X.oper list -> X.oper -> X.oper list - * eliminates duplicates, which speeds up compilation - *) - fun addonce l oper = - if (List.exists (fn x => X.opereq (x,oper)) l) - then l - else oper::l - - (* val liveadd : live -> live list -> live list *) - fun liveadd (n,oper) lives = List.map - (fn (x,a) => if (x = n) then (x,addonce a oper) else (x,a)) - lives + (* val liveadd : live -> OperSet.set LiveMap.map -> OperSet.set LiveMap.map *) + fun liveadd (n,oper) map = case LiveMap.find (map, n) + of SOME(x) => LiveMap.insert (map, n, OperSet.add (x, oper)) + | NONE => LiveMap.insert (map, n, OperSet.singleton oper) (* this does the dirty work! * for each line, checks if the live variables in succeeding lines are @@ -182,18 +223,25 @@ struct * changing the first foldr to a foldl slows down liveness by a factor * of at least 100 on cedar-anastulate.l2 *) - val newl = List.foldr - (fn ((n, a), b) => List.foldr + val newl = LiveMap.foldri + (fn (n, a, b) => OperSet.foldr (fn (a',b') => if (isndef a' a) then liveadd (n, a') b' else b') b (lives b (succs a)) ) - l - p + livemap + preds in - if subsetlive (newl, l) then l else liveiter newl p + if subsetlive (newl, livemap) + then livemap + else liveiter newl preds end + fun dustostring (DEF(a)) = "DEF(" ^ X.prettyprint_oper X.Long a ^ ")" + | dustostring (USE(a)) = "USE(" ^ X.prettyprint_oper X.Long a ^ ")" + | dustostring (SUCC(a)) = "SUCC(" ^ Int.toString a ^ ")" + | dustostring ISMOVE = "ISMOVE" + (* val liveness : pseudoasm -> livenesses * analyzes liveness of variables in the given pseudo-asm *) @@ -201,13 +249,31 @@ struct fun liveness instrs = let val preds = defusesucc (number instrs) +(* val (_,l) = ListPair.unzip preds + val () = print ( + String.concatWith "\n" ( + List.map + (fn a => String.concatWith ", " (List.map dustostring a)) + l + ) + )*) val init = uselive preds - val (_,lives) = ListPair.unzip (liveiter init preds) + val initmap = LiveMap.foldri (fn (n,a,b) => LiveMap.insert (b, n, a)) LiveMap.empty init in - lives + (preds, liveiter initmap preds) + end + + fun prettyprint (set) = + OperSet.foldr + (fn (oper, s) => (X.prettyprint_oper X.Long oper) ^ ", " ^ s) + "-\n" + set + + fun listify map = + let + val maxln = LiveMap.foldri (fn (a, _, b) => Int.max (a, b)) 0 map + val nums = List.tabulate (maxln+1, fn x => x) + in + List.map (fn num => valOf (LiveMap.find (map, num)) handle Option => OperSet.empty) nums end - - fun prettyprint (a::l) = (X.prettyprint_oper a) ^ ", " ^ prettyprint l - | prettyprint nil = "-\n" - end diff --git a/codegen/peephole.sml b/codegen/peephole.sml index 7880a45..7fa4554 100644 --- a/codegen/peephole.sml +++ b/codegen/peephole.sml @@ -1,4 +1,4 @@ -(* L2 compiler +(* L3 compiler * peephole optimizer * optimizes away redundant insns such as: mov a, b @@ -25,15 +25,22 @@ struct (* val peephole : x86.insn list -> x86.insn list *) - fun peephole ((insn1 as X.MOVL(a1,b1))::(insn2 as X.MOVL(a2,b2))::l) = + fun peephole ((insn1 as X.MOV(a1,b1))::(insn2 as X.MOV(a2,b2))::l) = if(x86.opereq(a1, b1) orelse (x86.opereq(a1, a2) andalso x86.opereq(b1, b2))) then peephole (insn2::l) else if(x86.opereq(a2, b2) orelse (x86.opereq(a1, b2) andalso x86.opereq(b1, a2))) then peephole (insn1::l) else insn1::(peephole (insn2::l)) - | peephole ((insn as X.MOVL(a,b))::l) = if x86.opereq(a, b) then peephole l else insn::(peephole l) + | peephole (X.MOV (X.REG r, X.CONST 0w0)::l) = (X.XOR (X.REG r, X.REG r))::(peephole l) + | peephole ((insn as X.MOV(a,b))::l) = if x86.opereq(a, b) then peephole l else insn::(peephole l) | peephole ((insn1 as X.NEG(a))::(insn2 as X.NEG(b))::l) = if x86.opereq(a, b) then peephole l else insn1::(peephole (insn2::l)) + | peephole (X.ADD (_, X.CONST 0w0)::l) = peephole l + | peephole (X.SUB (_, X.CONST 0w0)::l) = peephole l + | peephole (X.CMP (X.REG r, X.CONST 0w0)::l) = (X.TEST (X.REG r, X.REG r))::(peephole l) + | peephole ((X.JMP a)::(X.JMP b)::l) = peephole ((X.JMP a)::l) (* What the cock? Yes, we actually generate this. *) + | peephole ((X.JMP l1)::(X.LABEL l2)::l) = if (Label.compare (l1,l2) = EQUAL) then (X.LABEL l2)::(peephole l) else (X.JMP l1)::(X.LABEL l2)::(peephole l) + | peephole (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 48fad39..8c39017 100644 --- a/codegen/solidify.sml +++ b/codegen/solidify.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Takes a list of mappings of temporaries to colors and a pseudoasm listing, * then produces x86 code. * Author: Chris Lu @@ -26,7 +26,7 @@ struct fun solidify (regmap : colorings) (instrs : asm) : asm = let (* r14d and r15d is reserved for spilling *) - val maxreg = X.regtonum X.R13D + val maxreg = X.regtonum X.R14D fun numtoreg n = if (n > maxreg) then raise Spilled @@ -35,59 +35,97 @@ struct fun temptonum (t: T.temp) : int = (List.hd (List.map (fn (_, n) => n) - (List.filter (fn (a, _) => (Temp.compare (a, t) = EQUAL)) regmap))) + (List.filter (fn (a, _) => (Temp.eq (a, t))) regmap))) fun temptoreg (t: T.temp) : x86.reg = numtoreg (temptonum t) - handle Empty => - (ErrorMsg.warn NONE ("Uncolored temp "^(Temp.name t)^" -- dead code?") ; - X.R15D) (*If we don't care about the output, then it is cool to explode this; R15D is guaranteed not to be used across builtin blocks.*) - - val spillreg1 = X.R14D - - val prologue = [X.DIRECTIVE "\tpush %rbx\n\tpush %r12\n\tpush %r13\n\tpush %r14\n\tpush %r15"] (* Could be done better. *) - val epilogue = [X.DIRECTIVE "\tpop %r15\n\tpop %r14\n\tpop %r13\n\tpop %r12\n\tpop %rbx"] - + handle Empty => raise ErrorMsg.InternalError ("Uncolored temp "^(Temp.name t)^", agh!") + + val spillreg1 = X.R15D + + (* Determine which need to be saved. *) + val opsused = map (fn (_, n) => X.REG (numtoreg n handle Spilled => X.R15D)) regmap + val saveregs = X.OperSet.intersection ( + X.OperSet.addList (X.OperSet.empty, opsused), + X.OperSet.addList ( + X.OperSet.empty, + [X.REG X.EBX, + X.REG X.EBP, + X.REG X.R12D, + X.REG X.R13D, + X.REG X.R14D, + X.REG X.R15D])) + 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 *) + | isspilled (X.STACKARG _) = true + | isspilled (X.REL _) = true | isspilled _ = false - fun stackpos (reg: int) = (reg - maxreg) * ~4 (* Stack position of some register number *) - + val stacksz = (nspilled + nsave) * 8 + 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)))) :: + (ListPair.map + (fn (num, reg) => + X.SIZE (X.Qword, X.MOV (X.REL (X.RSP, stacksz - 8*(num+1)), 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))))) + (List.tabulate (nsave, fn x => x), savelist)) @ + [X.SIZE (X.Qword, X.ADD (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. *) if (isspilled (X.TEMP temp)) - then [X.MOVL (X.REL (X.RSP, stackpos (temptonum temp)), X.REG xreg)] + then [X.MOV (X.REL (X.RSP, stackpos (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. *) if (isspilled (X.TEMP temp)) - then [X.MOVL (X.REG xreg, X.REL (X.RSP, stackpos (temptonum temp)))] + then [X.MOV (X.REG xreg, X.REL (X.RSP, stackpos (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 fun realoper (X.TEMP temp) = X.REG (temptoreg temp) (* Makes a operand 'real'. *) + | realoper (X.STACKARG arg) = raise Spilled + | realoper (X.REL _) = raise Spilled | 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)) + | stackoper (a as X.REL _) = a | stackoper _ = raise ErrorMsg.InternalError "stackoper on not temp?" fun transform (X.DIRECTIVE s) = [X.DIRECTIVE s] | transform (X.COMMENT s) = [X.COMMENT s] - | transform (X.MOVL (dest, src)) = + | 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.MOVL( + [X.MOV( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] else - [ X.MOVL( + [X.MOV( realoper dest handle Spilled => raise ErrorMsg.InternalError "But we said that wasn't spilled?", realoper src handle Spilled => stackoper src)] - | transform (X.SUBL (dest, src)) = + | transform (X.SUB (dest, src)) = unspill (src, spillreg1) @ - [ X.SUBL( + [ X.SUB( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] | transform (X.IMUL (dest, src)) = @@ -102,47 +140,47 @@ struct realoper src handle Spilled => stackoper src, const)] @ spill (dest, spillreg1) - | transform (X.ADDL (dest, src)) = (* You can have either operand spilled, but not both. Pick one. *) + | transform (X.ADD (dest, src)) = (* You can have either operand spilled, but not both. Pick one. *) if (isspilled dest) then unspill (src, spillreg1) @ - [ X.ADDL( + [ X.ADD( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] else - [ X.ADDL( + [ X.ADD( realoper dest handle Spilled => raise ErrorMsg.InternalError "But we said that wasn't spilled?", realoper src handle Spilled => stackoper src)] - | transform (X.IDIVL (src)) = [ X.IDIVL(realoper src handle Spilled => stackoper src)] + | transform (X.IDIV (src)) = [ X.IDIV(realoper src handle Spilled => stackoper src)] | transform (X.NEG (src)) = [ X.NEG(realoper src handle Spilled => stackoper src)] - | transform (X.NOTL (src)) = [ X.NOTL(realoper src handle Spilled => stackoper src)] - | transform (X.SALL (dest, shft)) = - [ X.SALL ( + | transform (X.NOT (src)) = [ X.NOT(realoper src handle Spilled => stackoper src)] + | transform (X.SAL (dest, shft)) = + [ X.SAL ( realoper dest handle Spilled => stackoper dest, shft)] - | transform (X.SARL (dest, shft)) = - [ X.SARL ( + | transform (X.SAR (dest, shft)) = + [ X.SAR ( realoper dest handle Spilled => stackoper dest, shft)] | transform (X.CLTD) = [ X.CLTD ] - | transform (X.ANDL (dest, src)) = + | transform (X.AND (dest, src)) = unspill (src, spillreg1) @ - [ X.ANDL( + [ X.AND( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] - | transform (X.ORL (dest, src)) = + | transform (X.OR (dest, src)) = unspill (src, spillreg1) @ - [ X.ORL( + [ X.OR( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] - | transform (X.XORL (dest, src)) = + | transform (X.XOR (dest, src)) = unspill (src, spillreg1) @ - [ X.XORL( + [ X.XOR( realoper dest handle Spilled => stackoper dest, realoper src handle Spilled => X.REG spillreg1)] - | transform (X.CMPL (op1, op2)) = + | transform (X.CMP (op1, op2)) = unspill (op2, spillreg1) @ - [ X.CMPL( + [ X.CMP( realoper op1 handle Spilled => stackoper op1, realoper op2 handle Spilled => X.REG spillreg1)] | transform (X.TEST (op1, op2)) = @@ -150,25 +188,21 @@ struct [ X.TEST( realoper op1 handle Spilled => stackoper op1, realoper op2 handle Spilled => X.REG spillreg1)] - | transform (X.SETNE (src)) = [ X.SETNE(realoper src handle Spilled => stackoper src)] - | transform (X.SETE (src)) = [ X.SETE(realoper src handle Spilled => stackoper src)] - | transform (X.SETLE (src)) = [ X.SETLE(realoper src handle Spilled => stackoper src)] - | transform (X.SETL (src)) = [ X.SETL(realoper src handle Spilled => stackoper src)] - | transform (X.SETGE (src)) = [ X.SETGE(realoper src handle Spilled => stackoper src)] - | transform (X.SETG (src)) = [ X.SETG(realoper src handle Spilled => stackoper src)] - | transform (X.MOVZBL (dest, src)) = - [ X.MOVZBL( + | transform (X.SETcc (c,src)) = [ X.SETcc(c, realoper src handle Spilled => stackoper src)] + | transform (X.CALL l) = [ X.CALL l ] + | transform (X.MOVZB (dest, src)) = + [ X.MOVZB( realoper dest handle Spilled => X.REG spillreg1, realoper src handle Spilled => stackoper src)] @ spill (dest, spillreg1) - | transform (X.RET) = epilogue @ [X.RET] + | transform (X.RET) = if nsave < 2 then (epilogue @ [X.RET]) else [X.JMP endlbl] | transform (X.LABEL l) = [ X.LABEL l ] | transform (X.JMP l) = [ X.JMP l ] - | transform (X.JE l) = [ X.JE l] - | transform (X.JNE l) = [ X.JNE l] -(* | transform _ = raise ErrorMsg.InternalError ("Unimplemented transform")*) + | transform (X.Jcc (c,l)) = [X.Jcc (c,l)] in - List.concat (prologue :: (map transform instrs)) - + if (nsave < 2) then + List.concat (prologue :: (map transform instrs)) + else + List.concat (prologue :: ((map transform instrs) @ [[X.LABEL endlbl], epilogue, [X.RET]])) end end diff --git a/codegen/stringifier.sml b/codegen/stringifier.sml index 5cb2113..74fe8c1 100644 --- a/codegen/stringifier.sml +++ b/codegen/stringifier.sml @@ -1,4 +1,4 @@ -(* L2 compiler +(* L3 compiler * stringifier * turns a list of x86 insns into the assembly code to generate them * Author: Chris Lu @@ -7,7 +7,7 @@ signature STRINGIFY = sig type asm = x86.insn list - val stringify : asm -> string + val stringify : (string -> string) -> asm -> string end structure Stringify :> STRINGIFY = @@ -18,42 +18,10 @@ struct (* val stringify : asm -> string * turns a x86 instruction list into a string of assembly code for these instructions *) - fun stringify' (X.MOVL (r1, r2)) = "\tmovl " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.SUBL (r1, r2)) = "\tsubl " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.IMUL (r1, r2)) = "\timul " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.IMUL3 (r1, r2, k)) = "\timul " ^ X.prettyprint_oper (X.CONST k) ^ ", " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.ADDL (r1, r2)) = "\taddl " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.IDIVL (r1)) = "\tidivl " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.NEG (r1)) = "\tnegl " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.NOTL (r1)) = "\tnotl " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.RET) = "\tret\n" - | stringify' (X.CLTD) = "\tcltd\n" - | stringify' (X.SALL (r1, X.REG X.ECX)) = "\tsall %cl, " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.SALL (r1, X.CONST k)) = "\tsall " ^ X.prettyprint_operb (X.CONST k) ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.SALL _) = raise ErrorMsg.InternalError "Invalid operand generated for SALL" - | stringify' (X.SARL (r1, X.REG X.ECX)) = "\tsarl %cl, " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.SARL (r1, X.CONST k)) = "\tsarl " ^ X.prettyprint_operb (X.CONST k) ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.SARL _) = raise ErrorMsg.InternalError "Invalid operand generated for SARL" - | stringify' (X.ANDL (r1, r2)) = "\tandl " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.ORL (r1, r2)) = "\torl " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.XORL (r1, r2)) = "\txorl " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.CMPL (r1, r2)) = "\tcmpl " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.TEST (r1, r2)) = "\ttest " ^ X.prettyprint_oper r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.SETNE (r1)) = "\tsetne " ^ X.prettyprint_operb r1 ^ "\n" - | stringify' (X.SETE (r1)) = "\tsete " ^ X.prettyprint_operb r1 ^ "\n" - | stringify' (X.SETLE (r1)) = "\tsetle " ^ X.prettyprint_operb r1 ^ "\n" - | stringify' (X.SETL (r1)) = "\tsetl " ^ X.prettyprint_operb r1 ^ "\n" - | stringify' (X.SETGE (r1)) = "\tsetge " ^ X.prettyprint_operb r1 ^ "\n" - | stringify' (X.SETG (r1)) = "\tsetg " ^ X.prettyprint_operb r1 ^ "\n" - | stringify' (X.MOVZBL (r1, r2)) = "\tmovzbl " ^ X.prettyprint_operb r2 ^ ", " ^ X.prettyprint_oper r1 ^ "\n" - | stringify' (X.DIRECTIVE(s)) = s ^ "\n" - | stringify' (X.COMMENT(s)) = "\t// " ^ s ^ "\n" - | stringify' (X.LABEL l) = Label.name l ^ ":\n" - | stringify' (X.JMP l) = "\tjmp " ^ Label.name l ^ "\n" - | stringify' (X.JE l) = "\tje " ^ Label.name l ^ "\n" - | stringify' (X.JNE l) = "\tjne " ^ Label.name l ^ "\n" + 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 (* val stringify : asm -> string *) - fun stringify l = foldr (fn (a,b) => (stringify' a) ^ b) ("") l + fun stringify realname l = foldr (fn (a,b) => (stringify' realname a) ^ b) ("") l end diff --git a/codegen/x86.sml b/codegen/x86.sml index 33ddd60..6ec4263 100644 --- a/codegen/x86.sml +++ b/codegen/x86.sml @@ -1,4 +1,4 @@ -(* L2 compiler +(* L3 compiler * X86 instruction/operand internal representation and manipulation * Author: Joshua Wise * Author: Chris Lu @@ -10,138 +10,143 @@ 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) - (* instructions - * a better way to do SET would be SET of cc * oper, - * same with JMP - *) + 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 + (* instructions *) datatype insn = DIRECTIVE of string | COMMENT of string | LABEL of Label.label | - MOVL of oper * oper | - SUBL of oper * oper | + SIZE of size * insn | + MOV of oper * oper | + SUB of oper * oper | IMUL of oper * oper | IMUL3 of oper * oper * Word32.word | - ADDL of oper * oper | - IDIVL of oper | + ADD of oper * oper | + IDIV of oper | NEG of oper | - NOTL of oper | - SALL of oper * oper | - SARL of oper * oper | - ANDL of oper * oper | - ORL of oper * oper | - XORL of oper * oper | - CMPL of oper * oper | + NOT of oper | + SAL of oper * oper | + SAR of oper * oper | + AND of oper * oper | + OR of oper * oper | + XOR of oper * oper | + CMP of oper * oper | TEST of oper * oper | - SETNE of oper | - SETE of oper | - SETLE of oper | - SETL of oper | - SETGE of oper | - SETG of oper | + SETcc of cc * oper | JMP of Label.label | - JE of Label.label | - JNE of Label.label | - MOVZBL of oper * oper | + Jcc of cc * Label.label | + CALL of Symbol.symbol * int | + MOVZB of oper * oper | CLTD | + LIVEIGN of insn | RET + structure OperSet : ORD_SET + where type Key.ord_key = oper; + structure LiveMap : ORD_MAP + where type Key.ord_key = int; + val cmpoper : oper * oper -> order val opereq : oper * oper -> bool - val regname : reg -> string - val regnameb : reg -> string + val regname : size -> reg -> string val regtonum : reg -> int val numtoreg : int -> reg - val prettyprint_oper : oper -> string - val prettyprint_operb : oper -> string - val prettyprint : insn -> string + val ccname : cc -> string + val opsused : insn list -> OperSet.set + val prettyprint_oper : size -> oper -> string + val prettyprint : size -> insn -> string end structure x86 :> X86 = 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) + 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 insn = DIRECTIVE of string | COMMENT of string | LABEL of Label.label | - MOVL of oper * oper | - SUBL of oper * oper | + SIZE of size * insn | + MOV of oper * oper | + SUB of oper * oper | IMUL of oper * oper | IMUL3 of oper * oper * Word32.word | - ADDL of oper * oper | - IDIVL of oper | + ADD of oper * oper | + IDIV of oper | NEG of oper | - NOTL of oper | - SALL of oper * oper | - SARL of oper * oper | - ANDL of oper * oper | - ORL of oper * oper | - XORL of oper * oper | - CMPL of oper * oper | + NOT of oper | + SAL of oper * oper | + SAR of oper * oper | + AND of oper * oper | + OR of oper * oper | + XOR of oper * oper | + CMP of oper * oper | TEST of oper * oper | - SETNE of oper | - SETE of oper | - SETLE of oper | - SETL of oper | - SETGE of oper | - SETG of oper | + SETcc of cc * oper | JMP of Label.label | - JE of Label.label | - JNE of Label.label | - MOVZBL of oper * oper | + Jcc of cc * Label.label | + CALL of Symbol.symbol * int | + MOVZB of oper * oper | CLTD | + LIVEIGN of insn | RET + + type func = Ast.ident * insn list (* gives name of reg *) - fun regname EAX = "eax" - | regname EBX = "ebx" - | regname ECX = "ecx" - | regname EDX = "edx" - | regname ESI = "esi" - | regname EDI = "edi" - | regname EBP = "ebp" - | regname RSP = "rsp" - | regname R8D = "r8d" - | regname R9D = "r9d" - | regname R10D = "r10d" - | regname R11D = "r11d" - | regname R12D = "r12d" - | regname R13D = "r13d" - | regname R14D = "r14d" - | regname R15D = "r15d" + val regnames = + [ (EAX, ("al", "ax", "eax", "rax")), + (EBX, ("bl", "bx", "ebx", "rbx")), + (ECX, ("cl", "cx", "ecx", "rcx")), + (EDX, ("dl", "dx", "edx", "rdx")), + (ESI, ("sil", "si", "esi", "rsi")), + (EDI, ("dil", "di", "edi", "rdi")), + (EBP, ("bpl", "bp", "ebp", "rbp")), + (RSP, ("spl", "sp", "esp", "rsp")), + (R8D, ("r8b", "r8w", "r8d", "r8")), + (R9D, ("r9b", "r9w", "r9d", "r9")), + (R10D, ("r10b", "r10w", "r10d", "r10")), + (R11D, ("r11b", "r11w", "r11d", "r11")), + (R12D, ("r12b", "r12w", "r12d", "r12")), + (R13D, ("r13b", "r13w", "r13d", "r13")), + (R14D, ("r14b", "r14w", "r14d", "r14")), + (R15D, ("r15b", "r15w", "r15d", "r15")) ]; - (* like regname, but for the byte name *) - fun regnameb EAX = "al" - | regnameb EBX = "bl" - | regnameb ECX = "cl" - | regnameb EDX = "dl" - | regnameb ESI = "sil" - | regnameb EDI = "dil" - | regnameb EBP = "bpl" - | regnameb RSP = "spl" - | regnameb R8D = "r8b" - | regnameb R9D = "r9b" - | regnameb R10D = "r10b" - | regnameb R11D = "r11b" - | regnameb R12D = "r12b" - | regnameb R13D = "r13b" - | regnameb R14D = "r14b" - | regnameb R15D = "r15b" + fun regname sz reg = + let + val (n, (b, w, l, q)) = valOf (List.find (fn (r, _) => r = reg) regnames) + in + case sz + of Byte => b + | Word => w + | Long => l + | Qword => q + end + + fun ccname E = "e" + | ccname NE = "ne" + | ccname GE = "ge" + | ccname LE = "le" + | ccname G = "g" + | ccname L = "l" (* gives number (color) associated with reg *) fun regtonum EAX = 0 - | regtonum EBX = 1 - | regtonum ECX = 2 - | regtonum EDX = 3 - | regtonum ESI = 4 - | regtonum EDI = 5 - | regtonum R8D = 6 - | regtonum R9D = 7 - | regtonum R10D = 8 - | regtonum R11D = 9 + | regtonum ESI = 1 + | regtonum EDI = 2 + | regtonum ECX = 3 + | regtonum R8D = 4 + | regtonum R9D = 5 + | regtonum EDX = 6 + | regtonum R10D = 7 + | regtonum R11D = 8 + | regtonum EBX = 9 | regtonum R12D = 10 | regtonum R13D = 11 | regtonum R14D = 12 @@ -151,15 +156,15 @@ struct (* gives reg associated with number (color) *) fun numtoreg 0 = EAX - | numtoreg 1 = EBX - | numtoreg 2 = ECX - | numtoreg 3 = EDX - | numtoreg 4 = ESI - | numtoreg 5 = EDI - | numtoreg 6 = R8D - | numtoreg 7 = R9D - | numtoreg 8 = R10D - | numtoreg 9 = R11D + | numtoreg 1 = ESI + | numtoreg 2 = EDI + | numtoreg 3 = ECX + | numtoreg 4 = R8D + | numtoreg 5 = R9D + | numtoreg 6 = EDX + | numtoreg 7 = R10D + | numtoreg 8 = R11D + | numtoreg 9 = EBX | numtoreg 10 = R12D | numtoreg 11 = R13D | numtoreg 12 = R14D @@ -188,7 +193,51 @@ struct | cmpoper (REL _, _) = LESS | cmpoper (_, _) = GREATER - fun opereq (a, b) = cmpoper (a, b) = EQUAL + 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 (_, _) = false + + structure OperSet = ListSetFn ( + struct + type ord_key = oper + val compare = cmpoper + end) + + structure LiveMap = SplayMapFn(struct + type ord_key = int + val compare = Int.compare + end) + + fun opsused nil = OperSet.empty + | opsused ((DIRECTIVE _)::l) = opsused l + | opsused ((COMMENT _)::l) = opsused l + | opsused ((LABEL _)::l) = opsused l + | opsused ((MOV (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((SUB (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((IMUL (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((IMUL3 (dst, src, _))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((ADD (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((IDIV (src))::l) = OperSet.addList (opsused l, [src, REG EDX, REG EAX]) + | opsused ((NEG (dst))::l) = OperSet.addList (opsused l, [dst]) + | opsused ((NOT (dst))::l) = OperSet.addList (opsused l, [dst]) + | opsused ((SAL (dst, shft))::l) = OperSet.addList (opsused l, [dst, shft]) + | opsused ((SAR (dst, shft))::l) = OperSet.addList (opsused l, [dst, shft]) + | opsused ((AND (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((OR (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((XOR (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((CMP (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((TEST (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((SETcc (c, dst))::l) = OperSet.addList (opsused l, [dst]) + | opsused ((JMP _)::l) = opsused l + | opsused ((Jcc _)::l) = opsused l + | opsused ((CALL _)::l) = opsused l + | opsused ((MOVZB (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((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) = @@ -196,47 +245,45 @@ struct else "-" ^ (Int.toString (~i)) (* pretty prints an operand *) - fun prettyprint_oper (REG r) = "%" ^ (regname r) - | prettyprint_oper (TEMP t) = Temp.name t - | prettyprint_oper (CONST c) = "$0x" ^ (Word32.toString c) - | prettyprint_oper (REL (r, i)) = (moreDifferentToString i) ^ "(%" ^ (regname r) ^ ")" - - (* pretty prints an operand as a byte *) - fun prettyprint_operb (REG r) = "%" ^ (regnameb r) - | prettyprint_operb (TEMP t) = Temp.name t ^ "b" - | prettyprint_operb (CONST c) = "$0x" ^ (Word32.toString (c mod 0w32)) - | prettyprint_operb x = prettyprint_oper x + fun sfx Byte = "b" + | sfx Word = "w" + | sfx Long = "l" + | sfx Qword = "q" + + fun prettyprint_oper s (REG r) = "%" ^ (regname s r) + | prettyprint_oper s (TEMP t) = (Temp.name t) ^ (sfx s) + | 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 _ (STACKARG i) = "arg#"^Int.toString i (* pretty prints (no...) *) - fun prettyprint (DIRECTIVE(str)) = str ^ "\n" - | prettyprint (COMMENT(str)) = "// " ^ str ^ "\n" - | prettyprint (LABEL(l)) = Label.name l ^ "\n" - | prettyprint (MOVL(src, dst)) = "\tMOVL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (SUBL(src, dst)) = "\tSUBL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (IMUL(src, dst)) = "\tIMUL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (IMUL3(dst, tmp, const)) = "\tIMUL\t" ^ (prettyprint_oper (CONST const)) ^ ", " ^ (prettyprint_oper tmp) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (ADDL(src, dst)) = "\tADDL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (IDIVL(src)) = "\tIDIVL\t" ^ (prettyprint_oper src) ^ "\n" - | prettyprint (NEG (src)) = "\tNEG\t" ^ (prettyprint_oper src) ^ "\n" - | prettyprint (NOTL (src)) = "\tNOTL\t" ^ (prettyprint_oper src) ^ "\n" - | prettyprint (SALL (dst, shft)) = "\tSALL\t" ^ (prettyprint_oper dst) ^ ", " ^ (prettyprint_operb shft) ^ "\n" - | prettyprint (SARL (dst, shft)) = "\tSARL\t" ^ (prettyprint_oper dst) ^ ", " ^ (prettyprint_operb shft) ^ "\n" - | prettyprint (ANDL(src, dst)) = "\tANDL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (ORL(src, dst)) = "\tORL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (XORL(src, dst)) = "\tXORL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (CMPL(src, dst)) = "\tCMPL\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (TEST(src, dst)) = "\tTEST\t" ^ (prettyprint_oper src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (SETNE(dst)) = "\tSETNE\t" ^ (prettyprint_operb dst) ^ "\n" - | prettyprint (SETE(dst)) = "\tSETE\t" ^ (prettyprint_operb dst) ^ "\n" - | prettyprint (SETLE(dst)) = "\tSETLE\t" ^ (prettyprint_operb dst) ^ "\n" - | prettyprint (SETL(dst)) = "\tSETL\t" ^ (prettyprint_operb dst) ^ "\n" - | prettyprint (SETGE(dst)) = "\tSETGE\t" ^ (prettyprint_operb dst) ^ "\n" - | prettyprint (SETG(dst)) = "\tSETG\t" ^ (prettyprint_operb dst) ^ "\n" - | prettyprint (JMP(label)) = "\tJMP\t" ^ (Label.name label) ^ "\n" - | prettyprint (JE(label)) = "\tJE\t" ^ (Label.name label) ^ "\n" - | prettyprint (JNE(label)) = "\tJNE\t" ^ (Label.name label) ^ "\n" - | prettyprint (MOVZBL(src, dst)) = "\tMOVZBL\t" ^ (prettyprint_operb src) ^ ", " ^ (prettyprint_oper dst) ^ "\n" - | prettyprint (CLTD) = "\tCLTD\n" - | prettyprint (RET) = "\tRET\n" -(* | prettyprint _ = raise ErrorMsg.InternalError ("prettyprint: unknown instruction")*) + 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 +(* | prettyprint _ = raise ErrorMsg.InternalError ("prettyprint: Type A? Hatchar de coneccion?")*) end diff --git a/compile-l2c.sml b/compile-l3c.sml similarity index 63% rename from compile-l2c.sml rename to compile-l3c.sml index 651b99f..a8f95ec 100644 --- a/compile-l2c.sml +++ b/compile-l3c.sml @@ -1,7 +1,7 @@ -(* L1 Compiler +(* L3 Compiler * Helper for compilation * Author: Kaustuv Chaudhuri *) CM.make "sources.cm"; -SMLofNJ.exportFn ("bin/l2c.heap", Top.main); +SMLofNJ.exportFn ("bin/l3c.heap", Top.main); diff --git a/parse/ast.sml b/parse/ast.sml index ec53880..fce70ab 100644 --- a/parse/ast.sml +++ b/parse/ast.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Abstract Syntax Trees * Author: Alex Vaynberg * Modified: Frank Pfenning @@ -12,6 +12,9 @@ signature AST = sig type ident = Symbol.symbol + + datatype vtype = Int + type variable = ident * vtype datatype oper = PLUS @@ -41,6 +44,7 @@ sig | ConstExp of Word32.word | OpExp of oper * exp list | Marked of (* Kane *) exp Mark.marked + | FuncCall of ident * (exp list) and stm = Assign of ident * exp | Return of exp @@ -52,7 +56,11 @@ sig | While of exp * stm list | MarkedStm of stm Mark.marked - type program = stm list + datatype function = + Extern of vtype * ident * (variable list) + | Function of vtype * ident * (variable list) * (variable list) * stm list + + type program = function list (* print as source, with redundant parentheses *) structure Print : @@ -68,6 +76,9 @@ structure Ast :> AST = struct type ident = Symbol.symbol + datatype vtype = Int + type variable = ident * vtype + datatype oper = PLUS | MINUS @@ -96,6 +107,7 @@ struct | ConstExp of Word32.word | OpExp of oper * exp list | Marked of exp Mark.marked + | FuncCall of ident * (exp list) and stm = Assign of ident * exp | Return of exp @@ -107,7 +119,11 @@ struct | While of exp * stm list | MarkedStm of stm Mark.marked - type program = stm list + datatype function = + Extern of vtype * ident * (variable list) + | Function of vtype * ident * (variable list) * (variable list) * stm list + + type program = function list (* print programs and expressions in source form * using redundant parentheses to clarify precedence @@ -147,8 +163,13 @@ struct ^ " " ^ pp_exp e2 ^ ")" | pp_exp (OpExp(oper, _)) = pp_oper oper + | pp_exp (FuncCall(id, l)) = pp_ident id ^ "(" ^ pp_expl l ^ ")" | pp_exp (Marked(marked_exp)) = pp_exp (Mark.data marked_exp) + + 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 ^ ";" @@ -168,12 +189,24 @@ struct | pp_block (l) = let val contents = map pp_stm l in - "{" ^ String.concat contents ^ "}" + "{\n" ^ String.concat contents ^ "}\n" end - fun pp_stms nil = "" + and pp_stms nil = "" | pp_stms (s::ss) = pp_stm s ^ "\n" ^ pp_stms ss - - fun pp_program ss = "{\n" ^ pp_stms ss ^ "}" + + and pp_type Int = "int" + + and pp_params nil = "" + | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ ", " ^ (pp_params (a::l)) + | pp_params ((i, t)::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ (pp_params l) + + 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_program (p) = String.concat (map pp_function p) end end diff --git a/parse/l2.grm b/parse/l3.grm similarity index 71% rename from parse/l2.grm rename to parse/l3.grm index 6376e1c..cbf92ea 100644 --- a/parse/l2.grm +++ b/parse/l3.grm @@ -1,5 +1,5 @@ -(* L2 Compiler - * L2 grammar +(* L3 Compiler + * L3 grammar * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning * Modified: Joshua Wise @@ -34,7 +34,7 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = mark(A.OpExp(oper, [exp1, exp2]), (left, right))) %% -%header (functor L2LrValsFn (structure Token : TOKEN)) +%header (functor L3LrValsFn (structure Token : TOKEN)) %term EOF @@ -49,6 +49,7 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = | LBRACE | RBRACE | LPAREN | RPAREN | UNARY | ASNOP (* dummy *) + | EXTERN | VAR | INT | COLON | COMMA %nonterm program of A.program @@ -57,11 +58,22 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = | simp of A.stm | return of A.stm | exp of A.exp + | explist of A.exp list | control of A.stm | asnop of A.oper option | 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 + | paramlist of A.variable list + | param of A.variable + | functions of A.function list + | function of A.function + | vardecl of A.variable list + | vardecls of A.variable list %verbose (* print summary of errors *) %pos int (* positions *) @@ -69,7 +81,7 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = %eop EOF %noshift EOF -%name L2 +%name L3 %left LOGOR %left LOGAND @@ -86,15 +98,48 @@ fun expand_asnop (exp1, NONE, exp2) (left, right) = %% -program : LBRACE stms RBRACE - (stms) +program : extdecls functions (extdecls @ functions) + +vtype : INT (A.Int) + +extdecls : ([]) + | extdecl extdecls (extdecl :: extdecls) + +extdecl : EXTERN vtype IDENT LPAREN RPAREN SEMI + (A.Extern (vtype, IDENT, [])) + | EXTERN vtype IDENT LPAREN param RPAREN SEMI + (A.Extern (vtype, IDENT, [param])) + | EXTERN vtype IDENT LPAREN paramlist RPAREN SEMI + (A.Extern (vtype, IDENT, paramlist)) + +paramlist : param COMMA paramlist (param :: paramlist) + | param ([param]) + +param : IDENT COLON vtype (IDENT, vtype) + +functions : ([]) + | function functions (function :: functions) + +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)) + +vardecls : ([]) + | vardecl vardecls (vardecl @ vardecls) + +vardecl : VAR idents COLON vtype SEMI + (map (fn x => (x, vtype)) idents) + +idents : IDENT ([IDENT]) + | IDENT COMMA idents (IDENT :: idents) stms : ([]) | stm stms (stm :: stms) -stm : simp SEMI (simp) - | control (control) - | SEMI (A.Nop) +stm : simp SEMI (simp) + | control (control) + | SEMI (A.Nop) simp : exp asnop exp %prec ASNOP (expand_asnop (exp1, asnop, exp2) (exp1left, exp2right)) @@ -139,10 +184,18 @@ 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))) + | 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))) | MINUS exp %prec UNARY (mark (A.OpExp (A.NEGATIVE, [exp]), (MINUSleft,expright))) | BITNOT exp %prec UNARY (mark (A.OpExp (A.BITNOT, [exp]), (BITNOTleft,expright))) | BANG exp %prec UNARY (mark (A.OpExp (A.BANG, [exp]), (BANGleft,expright))) +explist : exp ([exp]) + | exp COMMA explist (exp :: explist) + asnop : ASSIGN (NONE) | PLUSEQ (SOME(A.PLUS)) | MINUSEQ (SOME(A.MINUS)) diff --git a/parse/l2.lex b/parse/l3.lex similarity index 93% rename from parse/l2.lex rename to parse/l3.lex index 9caa8e1..d9c2217 100644 --- a/parse/l2.lex +++ b/parse/l3.lex @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Lexer * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning @@ -51,7 +51,7 @@ in end %% -%header (functor L2LexFn(structure Tokens : L2_TOKENS)); +%header (functor L3LexFn(structure Tokens : L3_TOKENS)); %full %s COMMENT COMMENT_LINE; @@ -105,6 +105,9 @@ ws = [\ \t\012]; ">=" => (Tokens.GE (yypos, yypos + size yytext)); ">" => (Tokens.GT (yypos, yypos + size yytext)); + ":" => (Tokens.COLON (yypos, yypos + size yytext)); + "," => (Tokens.COMMA (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)); @@ -112,6 +115,10 @@ ws = [\ \t\012]; "continue" => (Tokens.CONTINUE (yypos, yypos + size yytext)); "break" => (Tokens.BREAK (yypos, yypos + size yytext)); "else" => (Tokens.ELSE (yypos, yypos + size yytext)); + "var" => (Tokens.VAR (yypos, yypos + size yytext)); + "int" => (Tokens.INT (yypos, yypos + size yytext)); + "extern" => (Tokens.EXTERN (yypos, yypos + size yytext)); + {decnum} => (number (yytext, yypos)); diff --git a/parse/parse.sml b/parse/parse.sml index 1fc612f..aa701c4 100644 --- a/parse/parse.sml +++ b/parse/parse.sml @@ -1,4 +1,4 @@ -(* L1 Compiler +(* L3 Compiler * Parsing * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning @@ -17,10 +17,10 @@ end structure Parse :> PARSE = struct - structure L2LrVals = L2LrValsFn (structure Token = LrParser.Token) - structure L2Lex = L2LexFn (structure Tokens = L2LrVals.Tokens) - structure L2Parse = Join (structure ParserData = L2LrVals.ParserData - structure Lex = L2Lex + 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 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 - (L2Lex.makeLexer (fn _ => TextIO.input instream)) + (L3Lex.makeLexer (fn _ => TextIO.input instream)) (* 0 = no error correction, 15 = reasonable lookahead for correction *) - val (absyn, _) = L2Parse.parse(0, lexer, parseerror, ()) + val (absyn, _) = L3Parse.parse(0, lexer, parseerror, ()) val _ = if !ErrorMsg.anyErrors then raise ErrorMsg.Error else () @@ -41,7 +41,7 @@ struct absyn end) handle Fail s => ( ErrorMsg.error NONE ("lexer error: "^s) ; - raise ErrorMsg.Error ) + raise ErrorMsg.Error ) | LrParser.ParseError => raise ErrorMsg.Error (* always preceded by msg *) | e as IO.Io _ => ( ErrorMsg.error NONE (exnMessage e); raise ErrorMsg.Error ) diff --git a/parse/parsestate.sml b/parse/parsestate.sml index 5e27137..2ce6fd6 100644 --- a/parse/parsestate.sml +++ b/parse/parsestate.sml @@ -1,4 +1,4 @@ -(* L1 Compiler +(* L3 Compiler * Parse State System * Author: Kaustuv Chaudhuri * Annotations: Alex Vaynberg diff --git a/sources.cm b/sources.cm index fb9b604..3dd6fa1 100644 --- a/sources.cm +++ b/sources.cm @@ -12,25 +12,27 @@ Group is parse/ast.sml parse/parsestate.sml - parse/l2.lex - parse/l2.grm + parse/l3.lex + parse/l3.grm parse/parse.sml type/typechecker.sml trans/temp.sml + trans/label.sml trans/tree.sml trans/trans.sml codegen/x86.sml + codegen/codegen.sml + codegen/igraph.sml codegen/colororder.sml codegen/solidify.sml codegen/coloring.sml codegen/stringifier.sml codegen/peephole.sml - codegen/codegen.sml codegen/liveness.sml top/top.sml diff --git a/sources.mlb b/sources.mlb new file mode 100644 index 0000000..d97bba4 --- /dev/null +++ b/sources.mlb @@ -0,0 +1,38 @@ +$(SML_LIB)/basis/basis.mlb +$(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb +$(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb + + util/mark.sml + util/flag.sml + util/symbol.sml + util/errormsg.sml + util/safe-io.sml + util/word32.sml + + parse/ast.sml + parse/parsestate.sml + parse/l3.grm.sig + parse/l3.grm.sml + parse/l3.lex.sml + parse/parse.sml + + type/typechecker.sml + + trans/temp.sml + trans/label.sml + trans/tree.sml + trans/trans.sml + + codegen/x86.sml + codegen/liveness.sml + codegen/igraph.sml + codegen/colororder.sml + codegen/solidify.sml + codegen/coloring.sml + codegen/stringifier.sml + codegen/peephole.sml + codegen/codegen.sml + + top/top.sml + + top/top_mlton.sml \ No newline at end of file diff --git a/top/top.sml b/top/top.sml index 35e03a6..5e564b1 100644 --- a/top/top.sml +++ b/top/top.sml @@ -1,4 +1,4 @@ -(* L1 Compiler +(* L3 Compiler * Top Level Environment * Author: Kaustuv Chaudhuri * Modified: Alex Vaynberg @@ -34,6 +34,7 @@ struct val flag_ast = Flag.flag "ast" val flag_ir = Flag.flag "ir" val flag_assem = Flag.flag "assem" + val flag_color = Flag.flag "color" fun reset_flags () = List.app Flag.unset [flag_verbose, flag_ast, @@ -53,7 +54,10 @@ struct help="pretty print the liveness results"}, {short = "s", long=["dump-assem"], desc=G.NoArg (fn () => Flag.set flag_assem), - help="pretty print the assembly before register allocaction"} + help="pretty print the assembly before register allocaction"}, + {short = "c", long=["dump-color"], + desc=G.NoArg (fn () => Flag.set flag_color), + help="pretty print the allocated regs"} ] @@ -66,6 +70,73 @@ struct then s (* return whole string *) else Substring.string (Substring.trimr 1 prefix) end + + fun processir externs (Tree.FUNCTION (id, ir)) = + let + val name = "_l3_" ^ (Symbol.name id) + + fun realname s = if (List.exists (fn n => s = n) externs) + then s + else "_l3_" ^ 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) () + + val _ = Flag.guard flag_verbose say " Analyzing liveness..." + val (preds, liveness) = Liveness.liveness assem; + val _ = Flag.guard flag_liveness + (fn () => List.app + (fn (asm, liv) => + TextIO.print ( + let + val xpp = x86.prettyprint x86.Long asm + val xpp = String.extract (xpp, 0, SOME (size xpp - 1)) + val spaces = implode (List.tabulate (40 - size xpp, fn _ => #" ")) handle size => "" + val lpp = Liveness.prettyprint liv + val lpp = String.extract (lpp, 0, SOME (size lpp - 1)) + val spaces2 = implode (List.tabulate (40 - size lpp, fn _ => #" ")) handle size => "" + in + xpp ^ spaces ^ lpp ^ spaces2 ^ "\n" + end)) + (ListPair.zip (assem, Liveness.listify liveness))) () + + val _ = Flag.guard flag_verbose say " Graphing..." + val (igraph,temps) = Igraph.gengraph (preds, liveness) + + val _ = Flag.guard flag_verbose say " Ordering..." + val order = ColorOrder.colororder (igraph,temps) + + val _ = Flag.guard flag_verbose say " Coloring..." + val colors = Colorizer.colorize order igraph; + val _ = Flag.guard flag_color + (fn () => List.app (TextIO.print o + (fn (t, i) => + (Temp.name t) ^ " => " ^ ( + if (i <= x86.regtonum x86.R14D) + then (x86.prettyprint_oper x86.Long (x86.REG (x86.numtoreg i))) + else + "spill[" ^ Int.toString (i - x86.regtonum x86.R14D) ^ "]") + ^ "--"^ Int.toString i ^ "\n")) + colors) () + + val _ = Flag.guard flag_verbose say " Solidifying x86_64 code..." + val x86 = Solidify.solidify colors assem; + + val _ = Flag.guard flag_verbose say " Peepholing..." + val x86p = Peephole.peephole x86; + + val _ = Flag.guard flag_verbose say " Stringifying..." + val x86d = [x86.DIRECTIVE(".globl " ^ name), + x86.DIRECTIVE(name ^ ":")] + @ x86p + val code = Stringify.stringify realname x86d + in + code + end fun main (name, args) = let @@ -96,51 +167,25 @@ struct val ast = Parse.parse source 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 _ = Flag.guard flag_verbose say "Checking..." val ast = TypeChecker.typecheck ast - + val _ = Flag.guard flag_verbose say "Translating..." val ir = Trans.translate ast val _ = Flag.guard flag_ir (fn () => say (Tree.Print.pp_program ir)) () - - val _ = Flag.guard flag_verbose say "Generating proto-x86_64 code..." - val assem = Codegen.codegen ir - val _ = Flag.guard flag_assem - (fn () => List.app (TextIO.print o x86.prettyprint) assem) () - - val _ = Flag.guard flag_verbose say "Analyzing liveness..." - val liveness = Liveness.liveness assem; - val _ = Flag.guard flag_liveness - (fn () => List.app (TextIO.print o Liveness.prettyprint) liveness) () - - val _ = Flag.guard flag_verbose say "Graphing..." - val igraph = Igraph.gengraph liveness; - - val _ = Flag.guard flag_verbose say "Ordering..." - val order = ColorOrder.colororder igraph; - val _ = Flag.guard flag_verbose say "Coloring..." - val colors = Colorizer.colorize order igraph; - - val _ = Flag.guard flag_verbose say "Solidifying x86_64 code..." - val x86 = Solidify.solidify colors assem; - - val _ = Flag.guard flag_verbose say "Peepholing..." - val x86p = Peephole.peephole x86; - - val _ = Flag.guard flag_verbose say "Stringifying..." - val x86d = [x86.DIRECTIVE(".file\t\"" ^ source ^ "\""), - x86.DIRECTIVE(".globl _l2_main"), - x86.DIRECTIVE("_l2_main:")] - @ x86p - @ [x86.DIRECTIVE ".ident\t\"15-411 L2 compiler by czl@ and jwise@\""] - val code = Stringify.stringify x86d + 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 afname = stem source ^ ".s" val _ = Flag.guard flag_verbose say ("Writing assembly to " ^ afname ^ " ...") val _ = SafeIO.withOpenOut afname (fn afstream => - TextIO.output (afstream, code)) + TextIO.output (afstream, output)) in OS.Process.success end diff --git a/top/top_mlton.sml b/top/top_mlton.sml new file mode 100644 index 0000000..3f6ea30 --- /dev/null +++ b/top/top_mlton.sml @@ -0,0 +1,5 @@ +val _ = + OS.Process.exit + (Top.main + (CommandLine.name (), CommandLine.arguments ()) + ) diff --git a/trans/label.sml b/trans/label.sml index 76041f4..3a6a14b 100644 --- a/trans/label.sml +++ b/trans/label.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Labeloraries * Like temporaries, except more different * Author: Joshua Wise diff --git a/trans/temp.sml b/trans/temp.sml index 13411f1..d370d99 100644 --- a/trans/temp.sml +++ b/trans/temp.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * Temporaries * Author: Kaustuv Chaudhuri * Modified: Alex Vaynberg @@ -10,24 +10,26 @@ sig type temp val reset : unit -> unit (* resets temp numbering *) - val new : unit -> temp (* returns a unique new temp *) + val new : string -> temp (* returns a unique new temp *) val name : temp -> string (* returns the name of a temp *) val compare : temp * temp -> order (* comparison function *) + val eq : temp * temp -> bool end structure Temp :> TEMP = struct - type temp = int + type temp = int * string local val counter = ref 1 in (* warning: calling reset() may jeopardize uniqueness of temps! *) fun reset () = ( counter := 1 ) - fun new () = !counter before ( counter := !counter + 1 ) + fun new str = (!counter, str) before ( counter := !counter + 1 ) end - fun name t = "+t" ^ Int.toString t - - fun compare (t1,t2) = Int.compare (t1,t2) + fun name (t,s) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]" + fun compare ((t1,_),(t2,_)) = Int.compare (t1,t2) + + fun eq ((t1,_), (t2,_)) = t1 = t2 end diff --git a/trans/trans.sml b/trans/trans.sml index 57e5faa..80802be 100644 --- a/trans/trans.sml +++ b/trans/trans.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * AST -> IR Translator * Author: Kaustuv Chaudhuri * Modified by: Alex Vaynberg @@ -10,7 +10,7 @@ signature TRANS = sig (* translate abstract syntax tree to IR tree *) - val translate : Ast.program -> Tree.stm list + val translate : Ast.program -> Tree.func list end structure Trans :> TRANS = @@ -38,121 +38,149 @@ struct | trans_oper A.GE = T.GE | trans_oper A.GT = T.GT | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop" - - and 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" - and trans_exp env (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, _)) = - 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) - (* anything else should be impossible *) + fun translate p = + let + val allfuncs = foldr (fn (A.Extern(_),b) => b + | (A.Function(_, id, _, _, _), b) => Symbol.bind b (id, () )) + Symbol.empty p + + fun trans_unop A.NEGATIVE = T.NEG + | trans_unop A.BITNOT = T.BITNOT + | trans_unop A.BANG = T.BANG + | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop" + + fun trans_exp env (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, _)) = + 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_stms : Temp.temp Symbol.table -> (Label.label * Label.label) option -> A.stm list -> (Tree.stm list * Symbol.table) - * translates a statement to the corresponding IR - * 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 env ls (A.Assign(id,e)::stms) = - let val t = Symbol.look' env id handle Option => Temp.new() - val env' = Symbol.bind env (id, t) - val (remainder, env') = trans_stms env' ls stms - in - (T.MOVE(T.TEMP(t), trans_exp env e) - :: remainder, env') - end - | trans_stms env ls (A.Return e::stms) = - let val (remainder, env') = trans_stms env ls stms - in - (T.RETURN (trans_exp env e) - :: remainder, env') - end + (* anything else should be impossible *) + + (* trans_stms : Temp.temp Symbol.table -> (Label.label * Label.label) option -> A.stm list -> Tree.stm list + * translates a statement to the corresponding IR + * 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) = + 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 + in + T.MOVE(T.TEMP(t), trans_exp vars e) + :: remainder + end + | trans_stms vars ls (A.Return e::stms) = + let + val remainder = trans_stms vars ls stms + in + T.RETURN (trans_exp vars e) + :: remainder + end - | trans_stms env ls (A.If(e, s, NONE)::stms) = - let val l = Label.new () - val (strans, env') = trans_stms env ls s - val (remainder, env') = trans_stms env' ls stms - in - (T.JUMPIFN(trans_exp env e, l) + | trans_stms vars 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 + in + (T.JUMPIFN(trans_exp vars e, l) :: strans @ [T.LABEL (l)] - @ remainder, env') - end - | trans_stms env ls (A.If(e, s, SOME s2)::stms) = - let val l = Label.new () + @ remainder) + end + | trans_stms vars ls (A.If(e, s, SOME s2)::stms) = + let + val l = Label.new () val l2 = Label.new () - val (s1trans, env') = trans_stms env ls s - val (s2trans, env') = trans_stms env' ls s2 - val (remainder, env') = trans_stms env' ls stms - in - (T.JUMPIFN(trans_exp env e, l) + val s1trans = trans_stms vars ls s + val s2trans = trans_stms vars ls s2 + val remainder = trans_stms vars ls stms + in + (T.JUMPIFN(trans_exp vars e, l) :: s1trans @ [T.JUMP (l2), T.LABEL (l)] @ s2trans @ [T.LABEL (l2)] - @ remainder, env') - end - | trans_stms env ls (A.For(s1, e, s2, s)::stms) = - let - val head = Label.new () - val tail = Label.new () - val loop = Label.new () - val (stm1, env') = if isSome s1 then trans_stms env NONE [valOf s1] else (nil, env) - val (strans, env') = trans_stms env' (SOME(loop,tail)) s - val (stm2, env') = if isSome s2 then trans_stms env' NONE [valOf s2] else (nil, env') - val (remainder, env') = trans_stms env' ls stms - in - (stm1 - @ [T.LABEL head, T.JUMPIFN(trans_exp env' e, tail)] - @ strans - @ [T.LABEL loop] - @ stm2 - @ [T.JUMP head, T.LABEL tail] - @ remainder, env') - end - | trans_stms env ls (A.While(e, s)::stms) = - let - val head = Label.new () - val tail = Label.new () - val (strans, env') = trans_stms env (SOME(head,tail)) s - val (remainder, env') = trans_stms env' ls stms - in - (T.LABEL head - :: T.JUMPIFN(trans_exp env e, tail) - :: strans - @ [T.JUMP head, T.LABEL tail] - @ remainder, env') - end - - | trans_stms env (SOME(b,e)) (A.Break::stms) = - let - val (remainder, env') = trans_stms env (SOME(b,e)) stms - in - ((T.JUMP e) :: remainder, env') - end - | trans_stms env NONE (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker" - | trans_stms env (SOME(b,e)) (A.Continue::stms) = - let - val (remainder, env') = trans_stms env (SOME(b,e)) stms - in - ((T.JUMP b) :: remainder, env') - end - | trans_stms env NONE (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker" + @ remainder) + end + | trans_stms vars 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 + in + (stm1 + @ [T.LABEL head, T.JUMPIFN(trans_exp vars e, tail)] + @ strans + @ [T.LABEL loop] + @ stm2 + @ [T.JUMP head, T.LABEL tail] + @ remainder) + end + | trans_stms vars 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 + in + (T.LABEL head + :: T.JUMPIFN(trans_exp vars e, tail) + :: strans + @ [T.JUMP head, T.LABEL tail] + @ remainder) + end - | trans_stms env ls (A.Nop::stms) = trans_stms env ls stms - | trans_stms env ls (A.MarkedStm m :: stms) = trans_stms env ls ((Mark.data m) :: stms) - | trans_stms env _ nil = (nil, env) + | trans_stms vars (SOME(b,e)) (A.Break::stms) = + let + val remainder = trans_stms vars (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) = + let + val remainder = trans_stms vars (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 - fun translate p = let val (trans, _) = trans_stms Symbol.empty NONE p in trans end + fun trans_funcs (A.Extern(t, id, varl)::l) = trans_funcs l + | trans_funcs (A.Function(t, id, 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 (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)) + numberedargs + in + (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l) + end + | trans_funcs nil = nil + in + trans_funcs p + end end diff --git a/trans/tree.sml b/trans/tree.sml index f69cefb..f5a92b5 100644 --- a/trans/tree.sml +++ b/trans/tree.sml @@ -1,8 +1,10 @@ -(* L2 Compiler +(* L3 Compiler * IR Trees * Author: Kaustuv Chaudhuri * Modified: Alex Vaynberg * Modified: Frank Pfenning + * Modified: Joshua Wise + * Modified: Chris Lu *) signature TREE = @@ -11,19 +13,25 @@ sig datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE datatype unop = NEG | BITNOT | BANG + type Blarg = int + datatype exp = CONST of Word32.word | TEMP of Temp.temp + | ARG of Blarg (* I am j4cbo *) | BINOP of binop * exp * exp | UNOP of unop * exp + | CALL of Ast.ident * exp list and stm = MOVE of exp * exp | RETURN of exp | LABEL of Label.label | JUMPIFN of exp * Label.label | JUMP of Label.label + and func = + FUNCTION of Ast.ident * stm list - type program = stm list + type program = func list structure Print : sig @@ -39,23 +47,31 @@ struct datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE datatype unop = NEG | BITNOT | BANG + type Blarg = int + datatype exp = CONST of Word32.word | TEMP of Temp.temp + | ARG of Blarg | BINOP of binop * exp * exp | UNOP of unop * exp + | CALL of Ast.ident * exp list and stm = MOVE of exp * exp | RETURN of exp | LABEL of Label.label | JUMPIFN of exp * Label.label | JUMP of Label.label + and func = + FUNCTION of Ast.ident * stm list - type program = stm list + type program = func list structure Print = struct + exception Aaaasssssss + fun pp_binop ADD = "+" | pp_binop SUB = "-" | pp_binop MUL = "*" @@ -81,10 +97,13 @@ 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 (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)) ^ ")" fun pp_stm (MOVE (e1,e2)) = pp_exp e1 ^ " <-- " ^ pp_exp e2 @@ -98,6 +117,11 @@ struct "jump "^Label.name l^" if! "^pp_exp e fun pp_program (nil) = "" - | pp_program (stm::stms) = pp_stm stm ^ "\n" ^ pp_program stms + | pp_program (FUNCTION(id, stms)::funcs) = + (Symbol.name id) ^ + "\n{\n" ^ + (foldr (fn (a,b) => (pp_stm a) ^ "\n" ^ b) "" stms) ^ + "}\n" ^ + pp_program funcs end end diff --git a/type/typechecker.sml b/type/typechecker.sml index 32f80a1..63608bd 100644 --- a/type/typechecker.sml +++ b/type/typechecker.sml @@ -1,10 +1,9 @@ -(* L1 Compiler +(* L3 Compiler * TypeChecker * Author: Alex Vaynberg * Modified: Frank Pfenning - * - * Simple typechecker that is based on a unit Symbol.table - * This is all that is needed since there is only an integer type present + * Modified: Joshua Wise + * Modified: Chris Lu *) signature TYPE_CHECK = @@ -16,6 +15,8 @@ end; structure TypeChecker :> TYPE_CHECK = struct structure A = Ast + + datatype asn = ASSIGNED | UNASSIGNED fun returns nil = false | returns (A.Assign _ :: stms) = returns stms @@ -27,7 +28,7 @@ struct | 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) = returns (Mark.data m :: stms) + | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms) fun breakcheck nil mark = () | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ; @@ -41,21 +42,41 @@ struct ( breakcheck s1 mark; breakcheck s2 mark; breakcheck stms mark) - | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.data m)] (Mark.ext m); breakcheck stms mark) + | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark) | breakcheck (_ :: stms) mark = breakcheck stms mark - fun varcheck_exp env (A.Var v) mark = + fun varcheck_exp env fenv (A.Var v) mark : Ast.vtype = ( case Symbol.look env v of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ; raise ErrorMsg.Error ) - | SOME _ => ()) - | 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.Marked m) mark = varcheck_exp env (Mark.data m) (Mark.ext m) + | 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 ^ "'") ; + 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) fun computeassigns env nil = env | computeassigns env (A.Assign (id,e) :: stms) = - computeassigns (Symbol.bind env (id, ())) stms + computeassigns (Symbol.bind env (id, (A.Int, ASSIGNED))) stms | computeassigns env (A.Return _ :: stms) = env | computeassigns env (A.Nop :: stms) = computeassigns env stms | computeassigns env (A.Break :: stms) = env @@ -65,7 +86,11 @@ struct let val env1 = computeassigns env s1 val env2 = computeassigns env s2 - val env' = Symbol.intersect (env1, env2) + val env' = + Symbol.intersect + (fn ((t, ASSIGNED), (t', ASSIGNED)) => (t, ASSIGNED) (* XXX check types for equality *) + | ((t, _), (t', _)) => (t, UNASSIGNED)) + (env1, env2) val env' = if (returns s1) then env2 else if (returns s2) then env1 @@ -82,59 +107,137 @@ struct in computeassigns env' stms end - | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.data m) :: stms) + | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms) - fun varcheck env nil mark = nil - | varcheck env (A.Assign (id, e) :: stms) mark = - ( varcheck_exp env e mark ; - A.Assign (id, e) :: (varcheck (Symbol.bind env (id, ())) stms mark) ) - | varcheck env (A.Return (e) :: stms) mark = - ( varcheck_exp env e mark; + fun varcheck env fenv nil mark = nil + | varcheck env fenv (A.Assign (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 + in + A.Assign (id, e) :: (varcheck (Symbol.bind env (id, (t, ASSIGNED))) fenv stms mark) + end + | varcheck env fenv (A.Return (e) :: stms) mark = + ( varcheck_exp env fenv e mark; A.Return (e) :: nil ) - | varcheck env (A.Nop :: stms) mark = - ( A.Nop :: (varcheck env stms mark)) - | varcheck env (A.Break :: stms) mark = + | varcheck env fenv (A.Nop :: stms) mark = + ( A.Nop :: (varcheck env fenv stms mark)) + | varcheck env fenv (A.Break :: stms) mark = ( A.Break :: nil ) - | varcheck env (A.Continue :: stms) mark = + | varcheck env fenv (A.Continue :: stms) mark = ( A.Continue :: nil ) - | 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 ; + | 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 ; A.If (e, s1, SOME s2) :: (if (returns [i]) then nil - 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 = + 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 = let val sbegin = case sbegin - of SOME(s) => SOME (hd (varcheck env [s] mark)) + of SOME(s) => SOME (hd (varcheck env fenv [s] mark)) | NONE => NONE val env' = case sbegin of SOME(s) => computeassigns env [s] | NONE => env - val _ = varcheck_exp env' e - val inner = varcheck env' inner mark + val _ = varcheck_exp env' fenv e + val inner = varcheck env' fenv inner mark val env'' = computeassigns env' inner val sloop = case sloop - of SOME(s) => SOME (hd (varcheck env'' [s] mark)) + of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark)) | NONE => NONE in - A.For (sbegin, e, sloop, inner) :: (varcheck env' stms mark) + A.For (sbegin, e, sloop, inner) :: (varcheck env' fenv stms mark) end - | varcheck env (A.MarkedStm m :: stms) mark = varcheck env ((Mark.data m) :: stms) (Mark.ext m) + | varcheck env fenv (A.MarkedStm m :: stms) mark = varcheck env fenv ((Mark.kane m) :: stms) (Mark.ext m) - fun typecheck prog = - ( breakcheck prog NONE ; - if not (returns prog) - then (ErrorMsg.error NONE ("program does not return in all cases"); raise ErrorMsg.Error) - else varcheck Symbol.empty prog NONE) + 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 dupchk l = + List.app + (fn (n, _) => + let + val name = Symbol.name n + val all = List.filter (fn (n', _) => name = (Symbol.name n')) l + val count = length all + in + if count = 1 + then () + else ( ErrorMsg.error NONE ("multiple definition of variable " ^ (Symbol.name n)); + raise ErrorMsg.Error ) + end) l + + fun typecheck_fn p (e as (A.Extern (t, id, al))) = (dupchk al; e) + | typecheck_fn p (A.Function (t, id, 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 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) + in + A.Function (t, id, al, vl, varcheck env fenv sl NONE) + end + + fun typecheck p = + 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") + of NONE => ( ErrorMsg.error NONE ("no function named main"); + raise ErrorMsg.Error ) + | SOME m => m + val () = case main + of A.Extern _ => ( ErrorMsg.error NONE ("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"); + 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 + in + List.map (typecheck_fn p) p + end end diff --git a/util/mark.sml b/util/mark.sml index a83f65a..c3b8348 100644 --- a/util/mark.sml +++ b/util/mark.sml @@ -27,6 +27,7 @@ sig (* data: remove the markings *) val data : 'a marked -> 'a + val kane : 'a marked -> 'a (* ext: retrieve positional information from marked value*) val ext : 'a marked -> ext option @@ -64,6 +65,7 @@ struct fun naked d = (d, NONE) fun data (d, e) = d + val kane = data fun ext (d, e) = e fun extmin ((l1, c1), (l2, c2)) = diff --git a/util/symbol.sml b/util/symbol.sml index 77878b4..87a0ab9 100644 --- a/util/symbol.sml +++ b/util/symbol.sml @@ -38,7 +38,7 @@ sig val elems : 'a table -> 'a list (* return all the data as a list *) 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 table * 'a table -> 'a table + val intersect : ('a * 'a -> 'a) -> 'a table * 'a table -> 'a table (* symbol set -- similar to a () Symbol.table, elements can be removed *) type set @@ -104,7 +104,7 @@ struct fun elems t = Map.listItems t fun elemsi t = Map.listItemsi t fun keys t = Map.listKeys t - fun intersect (t1,t2) = Map.intersectWith (fn (a,_) => a) (t1,t2) + fun intersect binding (t1,t2) = Map.intersectWith binding (t1,t2) fun delimit' [] s = s | delimit' [x] s = s ^ x