From: Joshua Wise Date: Thu, 14 May 2009 02:23:00 +0000 (-0400) Subject: Initial import of l5c X-Git-Url: http://git.joshuawise.com/snipe.git/commitdiff_plain/5c79bb689ab446551bc7ec4497e6c9b75582837e Initial import of l5c --- diff --git a/Makefile b/Makefile index 2cb4352..2ae3db6 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,14 @@ # the following are SML-NJ specific defines SML = sml -l4c: FORCE - echo 'use "compile-l4c.sml";' | ${SML} +l5c: FORCE + echo 'use "compile-l5c.sml";' | ${SML} -l4c-mlton: FORCE - mllex parse/l4.lex - mlyacc parse/l4.grm - mlton -output bin/l4c-mlton sources.mlb - ${RM} parse/l4.lex.sml +l5c-mlton: FORCE + mllex parse/l5.lex + mlyacc parse/l5.grm + mlton -profile time -profile-branch true -output bin/l5c-mlton sources.mlb + ${RM} parse/l5.lex.sml reallyclean: clean ${RM} parse/*.lex.* parse/*.grm.* @@ -17,8 +17,8 @@ reallyclean: clean clean: find . -type d -name .cm | xargs rm -rf find . -type f | grep '~$$' | xargs ${RM} - ${RM} bin/l4c.heap.* - ${RM} bin/l4c-mlton + ${RM} bin/l5c.heap.* + ${RM} bin/l5c-mlton TAGS: clean diff --git a/README b/README index ccc7581..3c068e3 100644 --- a/README +++ b/README @@ -1,64 +1,69 @@ README ------ -This compiler is a big long chain of modules that transform l4 code into +This compiler is a big long chain of modules that transform L5 code into x86_64 assembly. -Here is a breakdown of the modules and changes from l3: +Here is a breakdown of the modules and changes from L5: - * The parser. The parser was mainly brought in from lab 3, and mainly - just a straight-forward extension of the l3 parser. We changed asops, - since they now side-effect and need special properties. We also added - dereferences, arrays, other nice things. + * The parser. The parser was mainly brought in from lab 4, and mainly + just a straight-forward extension of the L4 parser to have increments, + decrements, conditionals, and hex constants. - * AST utilities. Some of those now exist to make common operations on raw - AST structures less painful. - - * The typechecker. The typechecker was significantly revamped. A - 'typeof' function was added that did most of the typechecking work; - the rest was relatively trivial compared to typeof. There were many - annoying things other than typeof, but typeof was the most interesting - to comment on. - - * The translator was extended with support for sizing up structs. It now - is smarter about translating asops. A MEMORY thingo was added to the - Tree, as was ALLOC. - - * The x86/munch modules were extended with support for multiple operand - sizes. This was done in a fashion of extreme type A, and needs to be - blasted before the next lab, for it is worthless, terrible, awful, ... A - major falling-down of this compiler is that it passes size information - around in no less than 235784 different fashions, and the translation - between each has caused us no end of grief. If we had time to rewrite - it instead of firefighting broken tests, uh... we would. Many of our - optimizations from last lab needed to be commented out because of this - temporary sizing sadness. - - * The liveness analyzer was mainly unchanged, but for a few rules. + * AST utilities were updated to use the new temp typing system. + + * Temporaries now are the only source of sizing information until we hit + the stage at which point instructions are generated. At that point, + instructions get sizing info, too, but really, that's about it. + + * The typechecker was mostly unchanged. + + * The translator was changed to use the new sizing system. Of interest, + the 'safe' alloc routine and the 'safe' dereference routines have been + moved into the IR stage, as opposed to having custom instructions + generated for them at the munch stage. This was done with the addition + of the 'stmvar' IR function, which is equivalent to the GCC C extension: + ({ stm; stm; ... expr }) + in that it evaluates the statements first, then returns the evaluation + of the expression. + + * The munch modules were updated to remove a lot of their suck and make + them correct again. Specifically, they were updated to use the new + typing system and perform type inference of sorts (i.e. adding a + quadword base pointer and a long offset yields a quad, etc.). This is + far superior to the previous sizing method, in which we gave some loose + (and disgusting) annotations of size and left the final sizing decisions + to the stringifier (O.o). + + * The liveness analyzer was mainly unchanged. * The grapher was fully unchanged. Nice. - * The color orderer was fully unchanged. Nice. + * The color orderer was optimized a bit. * The coloring module was fully unchanged. Nice. - * The solidifier was modified to deal with the fact that certain things - could not be accessed directly. It, too, has become an unmitigated - disaster. It must deal with all 875847384 of the sizes, and I am sad - about this. + * The solidifier was similarly ripped out and hit by the diqing beam, sent + on a flight to Diqing airport, which is in Diqing which is in + the Diqing province in China, and subsequently it was diqed. It is now + much happier. + + * The peepholer has been moved into the optimization framework. - * The peepholer lost one form of fail and loss sizing. + * An optimization framework was added, allowing optimizers to be + individually turned off from the command line with approximately no work + on our part. I'm particularly proud of the simplicity with which it + allows one to write optimizations; see optimize/feckful.sml. They need + only be hooked in one place (in particular, in a list at the top of + top.sml). Individual optimizations will be discussed in the paper to be + handed in tomorrow. * 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. - * 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 +(including all of the regression suite). There are a number of optimizations +that we wish to do, especially various interprocedural ones, but we ran out +of time. diff --git a/bin/l4c b/bin/l4c deleted file mode 100755 index 0259f69..0000000 --- a/bin/l4c +++ /dev/null @@ -1 +0,0 @@ -sml @SMLcmdname=$0 @SMLload=bin/l4c.heap.x86-linux $* diff --git a/bin/l5c b/bin/l5c new file mode 100755 index 0000000..d883d20 --- /dev/null +++ b/bin/l5c @@ -0,0 +1 @@ +sml @SMLcmdname=$0 @SMLload=bin/l5c.heap.x86-linux $* diff --git a/codegen/codegen.sml b/codegen/codegen.sml index 6ee8c2f..18ac4af 100644 --- a/codegen/codegen.sml +++ b/codegen/codegen.sml @@ -12,22 +12,12 @@ end structure Codegen :> CODEGEN = struct structure T = Tree + structure TU = TreeUtils 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 (T.MEMORY m) = true - | effect (T.ALLOC(_)) = true - | effect _ = false + structure Tm = Temp (* hasfixed : T.exp -> bool - * true iff the given expression has an hasfixed. Somewhat like effect, hmm? + * true iff the given expression has an hasfixed. *) fun hasfixed (T.BINOP(T.DIV, _, _)) = true | hasfixed (T.BINOP(T.MOD, _, _)) = true @@ -37,24 +27,52 @@ struct | hasfixed (T.BINOP(_, a, b)) = (hasfixed a) orelse (hasfixed b) | hasfixed (T.UNOP (_, a)) = hasfixed a | hasfixed (T.ALLOC(_)) = true - | hasfixed (T.MEMORY m) = hasfixed m + | hasfixed (T.MEMORY (m,s)) = hasfixed m + | hasfixed (T.STMVAR _) = true | hasfixed _ = false + fun offshit a b 0w4 d = [X.LEA(d, (X.REL((a, Tm.Quad), (b, Tm.Quad), 0w4), Tm.Quad))] + | offshit a b 0w8 d = [X.LEA(d, (X.REL((a, Tm.Quad), (b, Tm.Quad), 0w8), Tm.Quad))] + | offshit a b n d = [X.IMUL((b, Tm.Long), (X.CONST n, Tm.Long)), X.MOV(d, (a, Tm.Quad)), X.ADD(d, (b, Tm.Quad))] + + fun binophit_c d oper e c = let val (i, s) = munch_exp d e in (i @ [oper ((d,s), (X.CONST c, s))], s) end + and binophit_t d oper e t = + let + val (i, s) = munch_exp d e + val ts = Tm.size t + val rs = if Tm.cmpsize (s, ts) = GREATER then s else ts + in + (i @ [oper ((d, rs), (X.TEMP t, rs))], rs) + end + and binophit d oper e1 e2 = + let + val t = X.TEMP (Tm.new "add" Tm.Long) + val (i1, s1) = munch_exp d e1 + val (i2, s2) = munch_exp t e2 +(* val _ = print ("s1 = " ^ Tm.sfx s1 ^ ", s2 = " ^ Tm.sfx s2 ^ ", ") *) + val rs = if Tm.cmpsize (s1, s2) = GREATER then s1 else s2 +(* val _ = print ("rs = " ^ Tm.sfx rs ^ " from " ^ TU.Print.pp_exp e1 ^ " and " ^ TU.Print.pp_exp e2 ^ "\n") *) + in + (i1 @ i2 @ [oper ((d,rs), (t,rs))], rs) + end + and cmphit d a = let val (insns, pos, neg) = munch_cond a in (insns @ [X.SETcc (pos, (d, Tm.Byte)), X.MOVZB((d, Tm.Long), (d, Tm.Byte))], Tm.Long) end + (* 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) *) - and munch_exp d (T.CONST(n)) = [X.MOV(d, X.CONST n)] - | munch_exp d (T.TEMP(t)) = [X.MOV(d, X.TEMP t)] - | munch_exp d (T.ARG(0, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.EDI))] - | munch_exp d (T.ARG(1, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.ESI))] - | munch_exp d (T.ARG(2, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.EDX))] - | munch_exp d (T.ARG(3, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.ECX))] - | munch_exp d (T.ARG(4, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.R8D))] - | munch_exp d (T.ARG(5, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.REG X.R9D))] - | munch_exp d (T.ARG(t, sz)) = [X.MOV(d, X.OSIZE (X.sts sz, X.STACKARG (t - 6)))] - | munch_exp d (T.CALL(name, l, rsz)) = (* Scary demons live here. *) + and munch_exp d (T.CONST n) = ([X.MOV((d, Tm.Long), (X.CONST n, Tm.Long))], Tm.Long) + | munch_exp d (T.NULLPTR) = ([X.MOV((d, Tm.Quad), (X.CONST 0w0, Tm.Quad))], Tm.Quad) + | munch_exp d (T.TEMP(t)) = ([X.MOV((d, Tm.size t), (X.TEMP t, Tm.size t))], Tm.size t) + | munch_exp d (T.ARG(0, sz)) = ([X.MOV((d, sz), (X.REG X.EDI, sz))], sz) + | munch_exp d (T.ARG(1, sz)) = ([X.MOV((d, sz), (X.REG X.ESI, sz))], sz) + | munch_exp d (T.ARG(2, sz)) = ([X.MOV((d, sz), (X.REG X.EDX, sz))], sz) + | munch_exp d (T.ARG(3, sz)) = ([X.MOV((d, sz), (X.REG X.ECX, sz))], sz) + | munch_exp d (T.ARG(4, sz)) = ([X.MOV((d, sz), (X.REG X.R8D, sz))], sz) + | munch_exp d (T.ARG(5, sz)) = ([X.MOV((d, sz), (X.REG X.R9D, sz))], sz) + | munch_exp d (T.ARG(t, sz)) = ([X.MOV((d, sz), (X.STACKARG (t - 6), sz))], sz) + | munch_exp d (T.CALL(name, l, rsz)) = (* Scary demons live here. *) let val nargs = length l val nstack = if (nargs <= 6) @@ -67,7 +85,7 @@ struct | argdest 4 = X.REG X.ECX | argdest 5 = X.REG X.R8D | argdest 6 = X.REG X.R9D - | argdest n = X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (~(stackb - 8 * (n - 7)))) ) + | argdest n = X.REL ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt (~(stackb - 8 * (n - 7)))), Tm.Quad), 0w1) val dests = List.tabulate (nargs, fn x => argdest (x+1)) val (exps,_) = ListPair.unzip l @@ -83,180 +101,205 @@ struct (ListPair.zip (dests,l), hf) ) val temps = List.map (fn (_, sz) => Temp.new ("arg") sz (* xxx? *)) l_hf - val argevals_hf = List.map + val (argevals_hf,_) = ListPair.unzip (List.map (fn (t,(exp,_)) => munch_exp (X.TEMP t) exp) - (ListPair.zip (temps, l_hf)) + (ListPair.zip (temps, l_hf))) val argpushes = List.map - (fn (dest, t) => [(X.MOV (X.OSIZE(X.sts (Temp.size t), dest), X.TEMP t))]) + (fn (dest, t) => [X.MOV ((dest, Tm.size t), (X.TEMP t, Tm.size t))]) (ListPair.zip (d_hf, temps)) - val argevals_nohf = List.map - (fn (d,(exp,sz)) => munch_exp (X.OSIZE (X.sts sz, d)) exp) - (ListPair.zip (d_nohf, l_nohf)) + val (argevals_nohf,_) = ListPair.unzip (List.map + (fn (d,(exp,sz)) => munch_exp d exp) + (ListPair.zip (d_nohf, l_nohf))) in - List.concat argevals_hf @ - List.concat argpushes @ - List.concat argevals_nohf @ - [ X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stackb)), - X.CALL (name, nargs), - X.ADD (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stackb)), - X.MOV (d, X.OSIZE (X.sts rsz, X.REG X.EAX)) ] (* Finally! *) - end -(* | munch_exp d (T.BINOP(T.ADD, e1, T.CONST 0w0)) = munch_exp d e1 - | munch_exp d (T.BINOP(T.ADD, 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 = X.TEMP (Temp.new ("add") 4) - in - (munch_exp d e1) @ (munch_exp t1 e2) @ [X.ADD(d, t1)] - end -(* | munch_exp d (T.BINOP(T.SUB, T.CONST 0w0, e1)) = (munch_exp d e1) @ [X.NEG d] - | munch_exp d (T.BINOP(T.SUB, 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 = X.TEMP (Temp.new ("sub") 4) - in - (munch_exp d e1) @ (munch_exp t1 e2) @ [X.SUB(d, t1)] - end - | munch_exp d (T.BINOP(T.MUL, T.TEMP t, T.CONST n)) = [X.IMUL3(d, X.TEMP t, n)] - | munch_exp d (T.BINOP(T.MUL, T.CONST n, T.TEMP t)) = [X.IMUL3(d, X.TEMP t, n)] -(* - | munch_exp d (T.BINOP(T.MUL, e1, T.CONST 0w1)) = munch_exp d e1 - | munch_exp d (T.BINOP(T.MUL, T.CONST 0w1, e1)) = munch_exp d e1 - | munch_exp d (T.BINOP(T.MUL, e1, T.CONST n)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] - | munch_exp d (T.BINOP(T.MUL, T.CONST n, e1)) = (munch_exp d e1) @ [X.IMUL(d, X.CONST n)] *) - | munch_exp d (T.BINOP(T.MUL, e1, e2)) = - let - val t1 = X.TEMP (Temp.new ("mul") 4) - in - (munch_exp d e1) @ (munch_exp t1 e2) @ [X.IMUL(d, t1)] + (List.concat argevals_hf @ + List.concat argpushes @ + List.concat argevals_nohf @ + [ X.SUB ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stackb), Tm.Quad)), + X.CALL (name, nargs), + X.ADD ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stackb), Tm.Quad)), + X.MOV ((d, rsz), (X.REG X.EAX, rsz))], rsz) (* Finally! *) end + | munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = binophit_c d X.ADD e1 n + | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = binophit_c d X.ADD e1 n + | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = binophit_t d X.ADD e1 t + | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e1)) = binophit_t d X.ADD e1 t + | munch_exp d (T.BINOP(T.ADD, e1, e2)) = binophit d X.ADD e1 e2 + + | munch_exp d (T.BINOP(T.SUB, e1, T.CONST n)) = binophit_c d X.SUB e1 n + | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = binophit_t d X.SUB e1 t + | munch_exp d (T.BINOP(T.SUB, e1, e2)) = binophit d X.SUB e1 e2 + | munch_exp d (T.BINOP(T.MUL, T.TEMP t, T.CONST n)) = let val s = Tm.size t in ([X.IMUL3((d,s), (X.TEMP t,s), n)], Tm.size t) end + | munch_exp d (T.BINOP(T.MUL, T.CONST n, T.TEMP t)) = let val s = Tm.size t in ([X.IMUL3((d,s), (X.TEMP t,s), n)], Tm.size t) end + | munch_exp d (T.BINOP(T.MUL, e1, T.CONST n)) = binophit_c d X.IMUL e1 n + | munch_exp d (T.BINOP(T.MUL, T.CONST n, e1)) = binophit_c d X.IMUL e1 n + | munch_exp d (T.BINOP(T.MUL, e1, e2)) = binophit d X.IMUL e1 e2 | munch_exp d (T.BINOP(T.DIV, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("div") 4) + val t1 = X.TEMP (Temp.new ("div") Tm.Long) + val (i1, s1) = munch_exp t1 e1 + val (i2, s2) = munch_exp d e2 in - (munch_exp t1 e1) @ (munch_exp d e2) @ - [X.MOV (X.REG X.EAX, t1), X.CLTD, X.IDIV d, X.MOV (d, X.REG X.EAX)] + (i1 @ i2 @ [X.MOV ((X.REG X.EAX, s1), (t1, s1)), X.CLTD, X.IDIV (d, s2), X.MOV ((d, s2), (X.REG X.EAX, s2))], Tm.Long) end | munch_exp d (T.BINOP(T.MOD, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("mod") 4) + val t1 = X.TEMP (Temp.new ("div") Tm.Long) + val (i1, s1) = munch_exp t1 e1 + val (i2, s2) = munch_exp d e2 in - (munch_exp t1 e1) @ (munch_exp d e2) @ - [X.MOV (X.REG X.EAX, t1), X.CLTD, X.IDIV d, X.MOV (d, X.REG X.EDX)] + (i1 @ i2 @ [X.MOV ((X.REG X.EAX, s1), (t1, s1)), X.CLTD, X.IDIV (d, s2), X.MOV ((d, s2), (X.REG X.EDX, s2))], Tm.Long) end - | 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)) = + | munch_exp d (T.BINOP(T.LSH, e1, T.CONST n)) = let val (i,s) = munch_exp d e1 in (i @ [X.SAL ((d,s), (X.CONST (n mod 0w32),s))],s) end + | munch_exp d (T.BINOP(T.LSH, e1, T.TEMP t)) = let - val t = X.TEMP (Temp.new ("lsh") 4) - in - (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAL (d, X.REG X.ECX)] + val (i,s) = munch_exp d e1 + in + (i @ [X.MOV ((X.REG X.ECX, s), (X.TEMP t, s)), X.SAL ((d,s), (X.REG X.ECX, Tm.Byte))], s) end - | 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 t = X.TEMP (Temp.new ("rsh") 4) - in - (munch_exp d e1) @ (munch_exp t e2) @ [X.MOV (X.REG X.ECX, t), X.SAR (d, X.REG X.ECX)] - end - | munch_exp d (T.BINOP(T.BITAND, 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)) = + | munch_exp d (T.BINOP(T.LSH, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("bitand") 4) + val t = X.TEMP (Temp.new ("lsh") Tm.Long) + val (i1, s1) = munch_exp d e1 + val (i2, s2) = munch_exp t e2 in - (munch_exp d e1) @ (munch_exp t1 e2) @ [X.AND(d, t1)] + (i1 @ i2 @ [X.MOV ((X.REG X.ECX, s1), (t, s1)), X.SAL ((d, s2), (X.REG X.ECX, Tm.Byte))], s2) end - | 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)) = + | munch_exp d (T.BINOP(T.RSH, e1, T.CONST n)) = let val (i,s) = munch_exp d e1 in (i @ [X.SAR ((d,s), (X.CONST (n mod 0w32),s))],s) end + | munch_exp d (T.BINOP(T.RSH, e1, T.TEMP t)) = let - val t1 = X.TEMP (Temp.new ("bitor") 4) - in - (munch_exp d e1) @ (munch_exp t1 e2) @ [X.OR(d, t1)] + val (i,s) = munch_exp d e1 + in + (i @ [X.MOV ((X.REG X.ECX, s), (X.TEMP t, s)), X.SAR ((d,s), (X.REG X.ECX, Tm.Byte))], s) end - | 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)) = + | munch_exp d (T.BINOP(T.RSH, e1, e2)) = let - val t1 = X.TEMP (Temp.new ("bitxor") 4) + val t = X.TEMP (Temp.new ("lsh") Tm.Long) + val (i1, s1) = munch_exp d e1 + val (i2, s2) = munch_exp t e2 in - (munch_exp d e1) @ (munch_exp t1 e2) @ [X.XOR(d, t1)] + (i1 @ i2 @ [X.MOV ((X.REG X.ECX, s1), (t, s1)), X.SAR ((d, s2), (X.REG X.ECX, Tm.Byte))], s2) end + | munch_exp d (T.BINOP(T.BITAND, T.CONST n, e1)) = binophit_c d X.AND e1 n + | munch_exp d (T.BINOP(T.BITAND, e1, T.CONST n)) = binophit_c d X.AND e1 n + | munch_exp d (T.BINOP(T.BITAND, T.TEMP t, e1)) = binophit_t d X.AND e1 t + | munch_exp d (T.BINOP(T.BITAND, e1, T.TEMP t)) = binophit_t d X.AND e1 t + | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = binophit d X.AND e1 e2 + + | munch_exp d (T.BINOP(T.BITOR, T.CONST n, e1)) = binophit_c d X.OR e1 n + | munch_exp d (T.BINOP(T.BITOR, e1, T.CONST n)) = binophit_c d X.OR e1 n + | munch_exp d (T.BINOP(T.BITOR, T.TEMP t, e1)) = binophit_t d X.OR e1 t + | munch_exp d (T.BINOP(T.BITOR, e1, T.TEMP t)) = binophit_t d X.OR e1 t + | munch_exp d (T.BINOP(T.BITOR, e1, e2)) = binophit d X.OR e1 e2 + + | munch_exp d (T.BINOP(T.BITXOR, T.CONST n, e1)) = binophit_c d X.XOR e1 n + | munch_exp d (T.BINOP(T.BITXOR, e1, T.CONST n)) = binophit_c d X.XOR e1 n + | munch_exp d (T.BINOP(T.BITXOR, T.TEMP t, e1)) = binophit_t d X.XOR e1 t + | munch_exp d (T.BINOP(T.BITXOR, e1, T.TEMP t)) = binophit_t d X.XOR e1 t + | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) = binophit d X.XOR e1 e2 + | munch_exp d (a as 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 1") 4) - val t2 = X.TEMP (Temp.new("logand 2") 4) + val t1 = (X.TEMP (Tm.new "logand 1" Tm.Byte), Tm.Byte) + val t2 = (X.TEMP (Tm.new "logand 2" Tm.Byte), Tm.Byte) 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.MOVZB(d, t1)] - else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2)), X.MOVZB(d, t1)] + if (TU.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, Tm.Long), t1)], Tm.Long) + else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(t1,t2), X.MOVZB((d, Tm.Long), t1)], Tm.Long) end | munch_exp d (a as T.BINOP(T.LOGOR, e1, e2)) = let val (insn1, pos1, neg1) = munch_cond e1 val (insn2, pos2, neg2) = munch_cond e2 - val t1 = X.TEMP (Temp.new("logor 1") 4) - val t2 = X.TEMP (Temp.new("logor 2") 4) + val t1 = (X.TEMP (Tm.new "logand 1" Tm.Byte), Tm.Byte) + val t2 = (X.TEMP (Tm.new "logand 2" Tm.Byte), Tm.Byte) 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.MOVZB(d, t1)] - else insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2)), X.MOVZB(d, t1)] + if (TU.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, Tm.Long), t1)], Tm.Long) + else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(t1,t2), X.MOVZB((d, Tm.Long), t1)], Tm.Long) end - | munch_exp d (a as T.BINOP(T.EQ, _, _)) = - let val (insns, pos, neg) = munch_cond a in insns @ [X.SETcc (pos, d), X.MOVZB(d, d)] end - | 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 (a as T.BINOP(T.EQ, _, _)) = cmphit d a + | munch_exp d (a as T.BINOP(T.NEQ, _, _)) = cmphit d a + | munch_exp d (a as T.BINOP(T.LE, _, _)) = cmphit d a + | munch_exp d (a as T.BINOP(T.LT, _, _)) = cmphit d a + | munch_exp d (a as T.BINOP(T.GE, _, _)) = cmphit d a + | munch_exp d (a as T.BINOP(T.GT, _, _)) = cmphit d a + | munch_exp d (a as T.BINOP(T.BE, _, _)) = cmphit d a + + | munch_exp d (T.UNOP(T.NEG, e1)) = let val (i, s) = munch_exp d e1 in (i @ [X.NEG (d, Tm.Long)], s) end + | munch_exp d (T.UNOP(T.BITNOT, e1)) = let val (i, s) = munch_exp d e1 in (i @ [X.NOT (d, Tm.Long)], s) end | munch_exp d (T.UNOP(T.BANG, e)) = let val (insns, pos, neg) = munch_cond e in - insns @ [X.SETcc (neg, d), X.MOVZB(d, d)] + (insns @ [X.SETcc (neg, (d, Tm.Byte)), X.MOVZB((d, Tm.Long), (d, Tm.Byte))], Tm.Long) + end + | munch_exp d (T.MEMORY (e1,s)) = + let + val a = X.TEMP (Temp.new "addr" Tm.Quad) + val (i, s') = munch_exp a e1 + val _ = if s' = Tm.Quad then () else raise ErrorMsg.InternalError "memory fuxed." + in + (i @ [X.MOV ((d,s), (X.REL ((a, Tm.Quad), (X.CONST 0w0, Tm.Quad), 0w1), s))], s) end - | munch_exp d (T.MEMORY e1) = + | munch_exp d (T.ALLOC(exp)) = + let - val a = X.TEMP (Temp.new "addr" 8) + val t1 = Temp.new "alloc" Tm.Long + val l1 = Label.new() + val (einsn, _) = munch_exp (X.TEMP t1) exp + val (insns, _) = munch_exp d (T.CALL (Symbol.symbol "calloc", [(T.TEMP t1, Tm.Long), (T.CONST 0w1, Tm.Long)], Tm.Quad)) + val rd = (d, Tm.Quad) in - munch_exp a e1 @ [X.MOV (d, X.REL (a, X.CONST 0w0))] + (einsn @ insns, Tm.Quad) end - | munch_exp d (T.ALLOC(exp)) = (munch_exp d (T.CALL (Symbol.symbol "calloc", [(exp, 4), (T.CONST 0w1, 4)], 8))) - @ [X.MOV (X.REL (d, X.CONST 0w0), X.CONST 0w0)] +(* | munch_exp d (T.COND(c, T.CONST n1, T.CONST n2)) = let val (i,p,n) = munch_cond c in ((X.MOV (d, X.CONST n1))::i) @ [X.CMOVcc (p, d, X.CONST n2)] end *) + | munch_exp d (T.COND(c,e1,e2)) = + let + val (insns, pos, neg) = munch_cond c + val l1 = Label.new() + val l2 = Label.new() + val (i1, s1) = munch_exp d e1 + val (i2, s2) = munch_exp d e2 +(* val _ = print ("cond: size " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp e1 ^ ", " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ "\n") *) + in + (insns @ [X.Jcc(neg, l1)] @ i1 @ [X.JMP l2, X.LABEL l1] @ i2 @ [X.LABEL l2], if s1 = s2 then s1 else raise ErrorMsg.InternalError "condfuxed.") + end + | munch_exp d (T.STMVAR (sl, e)) = let val (i, s) = munch_exp d e in (List.concat (map munch_stm sl) @ i, s) end + + and condhit_tc t c (pos, neg) = ([X.CMP((X.TEMP t, Tm.size t), (X.CONST c, Tm.size t))], pos, neg) + and condhit_c e c (pos, neg) = + let + val t = X.TEMP (Temp.new "consthit" Tm.Long) + val (i,s) = munch_exp t e + in + (i @ [X.CMP ((t,s), (X.CONST c,s))], pos, neg) + end + and condhit_t e t (pos, neg) = + let + val t' = X.TEMP (Temp.new "consthit" Tm.Long) + val (i,s) = munch_exp t' e + in + (i @ [X.CMP ((t',s), (X.TEMP t,s))], pos, neg) + end + and condhit e1 e2 (pos, neg) = + let + val t1 = X.TEMP (Temp.new ("var neq 1") Tm.Long) + val t2 = X.TEMP (Temp.new ("var neq 2") Tm.Long) + val (i1, s1) = munch_exp t1 e1 + val (i2, s2) = munch_exp t2 e2 + in + (i1 @ i2 @ [X.CMP((t1,s1),(t2,s2))], pos, neg) + end (* munch_cond : T.exp -> X.insn list * X.cond * X.cond * munch_cond stm generates code to set flags, and then returns a conditional @@ -268,195 +311,156 @@ struct in (insns, neg, pos) end - | 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") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end - | munch_cond (T.BINOP(T.NEQ, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.NE, X.E) end - | munch_cond (T.BINOP(T.NEQ, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end - | munch_cond (T.BINOP(T.NEQ, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const neq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.NE, X.E) end - | munch_cond (T.BINOP(T.NEQ, e1, e2)) = - let - val t1 = X.TEMP (Temp.new ("var neq 1") 4) - val t2 = X.TEMP (Temp.new ("var neq 2") 4) - in - (munch_exp t1 e1 @ munch_exp t2 e2 @ - [X.CMP(t1, t2)], X.NE, X.E) - end - | 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") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end - | munch_cond (T.BINOP(T.EQ, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.E, X.NE) end - | munch_cond (T.BINOP(T.EQ, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end - | munch_cond (T.BINOP(T.EQ, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const eq") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.E, X.NE) end - | munch_cond (T.BINOP(T.EQ, e1, e2)) = - let - val t1 = X.TEMP (Temp.new ("var eq 1") 4) - val t2 = X.TEMP (Temp.new ("var eq 2") 4) - in - (munch_exp t1 e1 @ munch_exp t2 e2 @ - [X.CMP(t1, t2)], X.E, X.NE) - end - | 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") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end - | munch_cond (T.BINOP(T.LE, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const le") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end - | munch_cond (T.BINOP(T.LE, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const le") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end - | munch_cond (T.BINOP(T.LE, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const le") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end - | munch_cond (T.BINOP(T.LE, e1, e2)) = - let - val t1 = X.TEMP (Temp.new ("var le 1") 4) - val t2 = X.TEMP (Temp.new ("var le 2") 4) - in - (munch_exp t1 e1 @ munch_exp t2 e2 @ - [X.CMP(t1, t2)], X.LE, X.G) - end - | 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") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end - | munch_cond (T.BINOP(T.LT, e1, T.CONST n)) = - let val t = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end - | munch_cond (T.BINOP(T.LT, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end - | munch_cond (T.BINOP(T.LT, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const lt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end - | munch_cond (T.BINOP(T.LT, e1, e2)) = - let - val t1 = X.TEMP (Temp.new ("var lt 1") 4) - val t2 = X.TEMP (Temp.new ("var lt 2") 4) - in - (munch_exp t1 e1 @ munch_exp t2 e2 @ - [X.CMP(t1, t2)], X.L, X.GE) - end - | 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") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.G, X.LE) end - | munch_cond (T.BINOP(T.GT, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.L, X.GE) end - | munch_cond (T.BINOP(T.GT, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.G, X.LE) end - | munch_cond (T.BINOP(T.GT, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const gt") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.L, X.GE) end - | munch_cond (T.BINOP(T.GT, e1, e2)) = - let - val t1 = X.TEMP (Temp.new ("var gt 1") 4) - val t2 = X.TEMP (Temp.new ("var gt 2") 4) - in - (munch_exp t1 e1 @ munch_exp t2 e2 @ - [X.CMP(t1, t2)], X.G, X.LE) - 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") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.GE, X.L) end - | munch_cond (T.BINOP(T.GE, T.CONST n, e1)) = - let val t = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t e1 @ [X.CMP(t, X.CONST n)], X.LE, X.G) end - | munch_cond (T.BINOP(T.GE, e1, T.TEMP t)) = - let val t1 = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.GE, X.L) end - | munch_cond (T.BINOP(T.GE, T.TEMP t, e1)) = - let val t1 = X.TEMP (Temp.new ("const ge") 4) in (munch_exp t1 e1 @ [X.CMP(t1, X.TEMP t)], X.LE, X.G) end - | munch_cond (T.BINOP(T.GE, e1, e2)) = - let - val t1 = X.TEMP (Temp.new ("var ge 1") 4) - val t2 = X.TEMP (Temp.new ("var ge 2") 4) - in - (munch_exp t1 e1 @ munch_exp t2 e2 @ - [X.CMP(t1, t2)], X.GE, X.L) - end + | munch_cond (T.BINOP(T.NEQ, T.TEMP t, T.CONST n)) = condhit_tc t n (X.NE, X.E) + | munch_cond (T.BINOP(T.NEQ, T.CONST n, T.TEMP t)) = condhit_tc t n (X.NE, X.E) + | munch_cond (T.BINOP(T.NEQ, T.CONST n, e1)) = condhit_c e1 n (X.NE, X.E) + | munch_cond (T.BINOP(T.NEQ, e1, T.CONST n)) = condhit_c e1 n (X.NE, X.E) + | munch_cond (T.BINOP(T.NEQ, T.TEMP t, e1)) = condhit_t e1 t (X.NE, X.E) + | munch_cond (T.BINOP(T.NEQ, e1, T.TEMP t)) = condhit_t e1 t (X.NE, X.E) + | munch_cond (T.BINOP(T.NEQ, e1, e2)) = condhit e1 e2 (X.NE, X.E) + + | munch_cond (T.BINOP(T.EQ, T.TEMP t, T.CONST n)) = condhit_tc t n (X.E, X.NE) + | munch_cond (T.BINOP(T.EQ, T.CONST n, T.TEMP t)) = condhit_tc t n (X.E, X.NE) + | munch_cond (T.BINOP(T.EQ, T.CONST n, e1)) = condhit_c e1 n (X.E, X.NE) + | munch_cond (T.BINOP(T.EQ, e1, T.CONST n)) = condhit_c e1 n (X.E, X.NE) + | munch_cond (T.BINOP(T.EQ, T.TEMP t, e1)) = condhit_t e1 t (X.E, X.NE) + | munch_cond (T.BINOP(T.EQ, e1, T.TEMP t)) = condhit_t e1 t (X.E, X.NE) + | munch_cond (T.BINOP(T.EQ, e1, e2)) = condhit e1 e2 (X.E, X.NE) + + | munch_cond (T.BINOP(T.LE, T.TEMP t, T.CONST n)) = condhit_tc t n (X.LE, X.G) + | munch_cond (T.BINOP(T.LE, T.CONST n, T.TEMP t)) = condhit_tc t n (X.GE, X.L) + | munch_cond (T.BINOP(T.LE, T.CONST n, e1)) = condhit_c e1 n (X.GE, X.L) + | munch_cond (T.BINOP(T.LE, e1, T.CONST n)) = condhit_c e1 n (X.LE, X.G) + | munch_cond (T.BINOP(T.LE, T.TEMP t, e1)) = condhit_t e1 t (X.GE, X.L) + | munch_cond (T.BINOP(T.LE, e1, T.TEMP t)) = condhit_t e1 t (X.LE, X.G) + | munch_cond (T.BINOP(T.LE, e1, e2)) = condhit e1 e2 (X.LE, X.G) + + | munch_cond (T.BINOP(T.LT, T.TEMP t, T.CONST n)) = condhit_tc t n (X.L, X.GE) + | munch_cond (T.BINOP(T.LT, T.CONST n, T.TEMP t)) = condhit_tc t n (X.G, X.LE) + | munch_cond (T.BINOP(T.LT, T.CONST n, e1)) = condhit_c e1 n (X.G, X.LE) + | munch_cond (T.BINOP(T.LT, e1, T.CONST n)) = condhit_c e1 n (X.L, X.GE) + | munch_cond (T.BINOP(T.LT, T.TEMP t, e1)) = condhit_t e1 t (X.G, X.LE) + | munch_cond (T.BINOP(T.LT, e1, T.TEMP t)) = condhit_t e1 t (X.L, X.GE) + | munch_cond (T.BINOP(T.LT, e1, e2)) = condhit e1 e2 (X.L, X.GE) + + | munch_cond (T.BINOP(T.GT, T.TEMP t, T.CONST n)) = condhit_tc t n (X.G, X.LE) + | munch_cond (T.BINOP(T.GT, T.CONST n, T.TEMP t)) = condhit_tc t n (X.L, X.GE) + | munch_cond (T.BINOP(T.GT, T.CONST n, e1)) = condhit_c e1 n (X.L, X.GE) + | munch_cond (T.BINOP(T.GT, e1, T.CONST n)) = condhit_c e1 n (X.G, X.LE) + | munch_cond (T.BINOP(T.GT, T.TEMP t, e1)) = condhit_t e1 t (X.L, X.GE) + | munch_cond (T.BINOP(T.GT, e1, T.TEMP t)) = condhit_t e1 t (X.G, X.LE) + | munch_cond (T.BINOP(T.GT, e1, e2)) = condhit e1 e2 (X.G, X.LE) + + | munch_cond (T.BINOP(T.GE, T.TEMP t, T.CONST n)) = condhit_tc t n (X.GE, X.L) + | munch_cond (T.BINOP(T.GE, T.CONST n, T.TEMP t)) = condhit_tc t n (X.LE, X.G) + | munch_cond (T.BINOP(T.GE, T.CONST n, e1)) = condhit_c e1 n (X.LE, X.G) + | munch_cond (T.BINOP(T.GE, e1, T.CONST n)) = condhit_c e1 n (X.GE, X.L) + | munch_cond (T.BINOP(T.GE, T.TEMP t, e1)) = condhit_t e1 t (X.LE, X.G) + | munch_cond (T.BINOP(T.GE, e1, T.TEMP t)) = condhit_t e1 t (X.GE, X.L) + | munch_cond (T.BINOP(T.GE, e1, e2)) = condhit e1 e2 (X.GE, X.L) + + | munch_cond (T.BINOP(T.BE, T.TEMP t, T.CONST n)) = condhit_tc t n (X.BE, X.A) + | munch_cond (T.BINOP(T.BE, T.CONST n, T.TEMP t)) = condhit_tc t n (X.AE, X.B) + | munch_cond (T.BINOP(T.BE, T.CONST n, e1)) = condhit_c e1 n (X.AE, X.B) + | munch_cond (T.BINOP(T.BE, e1, T.CONST n)) = condhit_c e1 n (X.BE, X.A) + | munch_cond (T.BINOP(T.BE, T.TEMP t, e1)) = condhit_t e1 t (X.AE, X.B) + | munch_cond (T.BINOP(T.BE, e1, T.TEMP t)) = condhit_t e1 t (X.BE, X.A) + | munch_cond (T.BINOP(T.BE, e1, e2)) = condhit e1 e2 (X.BE, X.A) + | 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") 4) - val t2 = X.TEMP (Temp.new("logor c 2") 4) + val t1 = (X.TEMP (Temp.new("logor c 1") Tm.Byte), Tm.Byte) + val t2 = (X.TEMP (Temp.new("logor c 2") Tm.Byte), Tm.Byte) val l = Label.new () in - if (effect e2 orelse (length insn2 > 10)) + if (TU.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.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))], + [X.SETcc (pos2, t1), X.LABEL l, X.TEST(t1, t1)], X.NE, X.E) - else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.OR(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2))], X.NE, X.E) + else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), 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") 4) - val t2 = X.TEMP (Temp.new("logand c 2") 4) + val t1 = (X.TEMP (Temp.new("logand c 1") Tm.Byte), Tm.Byte) + val t2 = (X.TEMP (Temp.new("logand c 2") Tm.Byte), Tm.Byte) val l = Label.new () in - if (effect e2 orelse (length insn2 > 10)) + if (TU.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.TEST(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t1))], + [X.SETcc (pos2, t1), X.LABEL l, X.TEST(t1, t1)], X.NE, X.E) - else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(X.OSIZE (X.Byte, t1), X.OSIZE (X.Byte, t2))], X.NE, X.E) + else (insn1 @ [X.SETcc (pos1, t1)] @ insn2 @ [X.SETcc (pos2, t2), X.AND(t1, t2)], X.NE, X.E) end | munch_cond e = let - val t = X.TEMP (Temp.new ("munch c") 4) + val t = X.TEMP (Temp.new ("munch c") Tm.Long) + val (i, s) = munch_exp t e in - (munch_exp t e @ [ X.TEST (t,t) ], X.NE, X.E) + (i @ [ X.TEST ((t,s),(t,s)) ], X.NE, X.E) end (* munch_lval : T.exp -> (X.insn list * X.operand) * Takes an expression that has been typechecked as being a valid lvalue, and then returns an instruction list and an operand to store your shit in. *) - fun munch_lval (T.TEMP t) = ([], X.TEMP t) - | munch_lval (T.MEMORY m) = + and munch_lval (T.TEMP t) = ([], (X.TEMP t, Tm.size t)) + | munch_lval (T.MEMORY (m,s)) = let - val t = Temp.new "lv addr" 8 + val t = X.TEMP (Tm.new "lv addr" Tm.Quad) + val (i,s') = munch_exp t m in - (munch_exp (X.TEMP t) m, X.REL (X.TEMP t, X.CONST 0w0)) + (i, (X.REL ((t, Tm.Quad), (X.CONST 0w0, Tm.Quad), 0w1), s)) end | munch_lval _ = raise ErrorMsg.InternalError "That wasn't really a valid lvalue..." (* munch_stm : T.stm -> X.insn list *) (* munch_stm stm generates code to execute stm *) - fun munch_stm (T.MOVE (T.TEMP t, a as T.TEMP _, _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE (T.TEMP t, a as T.CONST _, _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an, sz), _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _, _)) = munch_exp (X.TEMP t) a - | munch_stm (T.MOVE (a, e2, sz)) = + and munch_stm (T.MOVE (T.TEMP t1, T.TEMP t2)) = if Tm.size t1 = Tm.size t2 then [X.MOV((X.TEMP t1, Tm.size t1), (X.TEMP t2, Tm.size t2))] + else raise ErrorMsg.InternalError "temp to temp move fuxed." + | munch_stm (T.MOVE (T.TEMP t, T.CONST n)) = if Tm.size t = Tm.Long then [X.MOV((X.TEMP t, Tm.size t), (X.CONST n, Tm.size t))] + else raise ErrorMsg.InternalError "const to temp move fuxed." + | munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an, sz))) = + let + val (i, s) = munch_exp (X.TEMP t) a + in + if s = Tm.size t + then i + else raise ErrorMsg.InternalError "arg to tmp fuxed." + end + | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _)) = let val (i, _) = munch_exp (X.TEMP t) a in i end + | munch_stm (T.MOVE (a, e2)) = let - val t = Temp.new ("assign") sz - val (m, r) = munch_lval a + val t = X.TEMP (Temp.new ("assign") Tm.Long) + val (m, (r,s1)) = munch_lval a + val (i, s2) = munch_exp t e2 +(* val _ = print ("move: size " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ ", " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp a ^ "\n") *) + val _ = if s1 = s2 then () else raise ErrorMsg.InternalError "move generic fuxed." in - m @ munch_exp (X.TEMP t) e2 - @ [X.MOV(X.OSIZE (X.sts sz, r), X.TEMP t)] + m @ i @ [X.MOV((r,s1), (t,s2))] end | munch_stm (T.RETURN(e, sz)) = let - val t = Temp.new ("retval") sz + val t = X.TEMP (Temp.new ("retval") sz) + val (i, s) = munch_exp t e in - munch_exp (X.TEMP t) e - @ [X.MOV(X.OSIZE (X.sts sz, X.REG X.EAX), X.TEMP t), X.RET] + i @ [X.MOV((X.REG X.EAX, sz), (t, if sz = s then sz else raise ErrorMsg.InternalError "retfuxed.")), X.RET] end - | munch_stm (T.LABEL(l)) = [X.LABEL l] - | munch_stm (T.JUMP(l)) = [X.JMP l] + | munch_stm (T.LABEL l) = [X.LABEL l] + | munch_stm (T.JUMP l) = [X.JMP l] | munch_stm (T.JUMPIFN(e, l)) = let val (insns, pos, neg) = munch_cond e in insns @ [X.Jcc (neg, l)] end - | munch_stm (T.EFFECT(exp, sz)) = let val t = X.TEMP (Temp.new "throwaway" sz) in munch_exp t exp end + | munch_stm (T.EFFECT exp) = let val t = X.TEMP (Temp.new "throwaway" Tm.Quad) val (i, _) = munch_exp t exp in i end fun codegen nil = nil | codegen (stm::stms) = munch_stm stm @ codegen stms diff --git a/codegen/coloring.sml b/codegen/coloring.sml index 1e08e1d..fc5fdf7 100644 --- a/codegen/coloring.sml +++ b/codegen/coloring.sml @@ -8,7 +8,7 @@ signature COLORIZER = sig structure OperSet : ORD_SET - where type Key.ord_key = x86.oper + where type Key.ord_key = x86.basicop structure LiveMap : ORD_MAP where type Key.ord_key = int structure TempMap : ORD_MAP @@ -70,7 +70,7 @@ struct colorized) @ (List.map (fn X.REG a => X.regtonum a - | loss => raise ErrorMsg.InternalError ("Bad kind of specreg " ^ (X.prettyprint_oper X.Long loss ))) + | loss => raise ErrorMsg.InternalError ("Bad kind of specreg " ^ (X.pp_oper (loss, Temp.Long)))) 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 0f25863..16dd163 100644 --- a/codegen/colororder.sml +++ b/codegen/colororder.sml @@ -7,7 +7,7 @@ signature COLORORDER = sig structure OperSet : ORD_SET - where type Key.ord_key = x86.oper + where type Key.ord_key = x86.basicop structure LiveMap : ORD_MAP where type Key.ord_key = int structure TempMap : ORD_MAP @@ -35,15 +35,25 @@ struct let 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 - (* Chooses one temporary to pick, and updates the weights. *) fun orderOne (weights : (Temp.temp * int) list) : Temp.temp * (Temp.temp * int) list = let - val sorted = sortWeights weights - val (chosen, w) = List.hd sorted (* Grab the temp with the highest weight. *) - val remaining = List.tl sorted + val (chosen, w) = + foldr + (fn ((t1, w1), (t2, w2)) => + if (w2 > w1) + then (t2, w2) + else (t1, w1)) + (Temp.new "emarnus" Temp.Word, ~9999) + weights + + fun ditchOne f nil = nil (* Special case of filter, which bails out after it removes one. *) + | ditchOne f (h::l) = + if f h + then l + else h::(ditchOne f l) + val remaining = ditchOne (fn (t, w) => Temp.eq (t, chosen)) weights + val neighbors = (* Grab all the neighbors for some given temp. *) (OperSet.listItems (valOf (TempMap.find (graph, chosen)))) diff --git a/codegen/igraph.sml b/codegen/igraph.sml index 30b17ee..7e71043 100644 --- a/codegen/igraph.sml +++ b/codegen/igraph.sml @@ -7,7 +7,7 @@ signature IGRAPH = sig structure OperSet : ORD_SET - where type Key.ord_key = x86.oper + where type Key.ord_key = x86.basicop structure LiveMap : ORD_MAP where type Key.ord_key = int structure TempMap : ORD_MAP diff --git a/codegen/liveness.sml b/codegen/liveness.sml index 4c8e4ad..b030f94 100644 --- a/codegen/liveness.sml +++ b/codegen/liveness.sml @@ -7,22 +7,22 @@ signature LIVENESS = sig structure OperSet : ORD_SET - where type Key.ord_key = x86.oper; + where type Key.ord_key = x86.basicop; structure LiveMap : ORD_MAP where type Key.ord_key = int; - + type live = int * OperSet.set type pseudoasm = x86.insn list type livenesses = OperSet.set LiveMap.map type ident = int - datatype pred = DEF of x86.oper | USE of x86.oper | SUCC of ident | ISMOVE + datatype pred = DEF of x86.basicop | USE of x86.basicop | SUCC of ident | ISMOVE type predicates = pred list LiveMap.map - val uses : pred list -> x86.oper list + val uses : pred list -> x86.basicop list val succs : pred list -> ident list - val defs : pred list -> x86.oper list + val defs : pred list -> x86.basicop list val ismove : pred list -> bool val liveness : pseudoasm -> predicates * livenesses @@ -37,6 +37,10 @@ struct structure OperSet = x86.OperSet structure LiveMap = x86.LiveMap + structure LabelMap = SplayMapFn(struct + type ord_key = Label.label + val compare = Label.compare + end) type live = int * OperSet.set type pseudoasm = X.insn list @@ -44,8 +48,8 @@ struct type livenesses = OperSet.set LiveMap.map type ident = int - datatype pred = DEF of X.oper | USE of X.oper | SUCC of ident | ISMOVE - + datatype pred = DEF of X.basicop | USE of X.basicop | SUCC of ident | ISMOVE + type predicates = pred list LiveMap.map (* val number : pseudoasm -> numasm @@ -65,26 +69,25 @@ struct (* val defusesucc : numasm -> (ident * pred list) list * generates def/use/succ predicates according to rules *) - fun defusesucc l = let - fun findlabel (lb) = - Option.valOf - (LiveMap.foldri (fn (n, X.LABEL lb', NONE) => if (Label.compare (lb, lb') = EQUAL) then SOME n else NONE - | (_, _, old) => old) NONE l) - + val labelmap = LiveMap.foldri + (fn (n, a, b) => LabelMap.insert(b, a, n)) + (LabelMap.empty) + (LiveMap.mapPartial (fn (X.LABEL lb) => SOME(lb) | _ => NONE) l) + + fun findlabel (lb) = valOf (LabelMap.find (labelmap, lb)) + (* val defhit/usehit : X.oper -> pred list * helper functions to discard constant operands *) - fun defhit (X.REG a) = [DEF(X.REG a)] - | defhit (X.TEMP a) = [DEF(X.TEMP a)] - | defhit (X.REL(o1, o2)) = usehit o1 @ usehit o2 - | defhit (X.OSIZE(s, oo)) = defhit oo + fun defhit (X.REG a,_) = [DEF(X.REG a)] + | defhit (X.TEMP a,_) = [DEF(X.TEMP a)] + | defhit (X.REL(o1, o2, _),_) = usehit o1 @ usehit o2 | defhit (_) = nil - and usehit (X.REG a) = [USE(X.REG a)] - | usehit (X.TEMP a) = [USE(X.TEMP a)] - | usehit (X.REL(o1, o2)) = usehit o1 @ usehit o2 - | usehit (X.OSIZE(s, oo)) = usehit oo + and usehit (X.REG a,_) = [USE(X.REG a)] + | usehit (X.TEMP a,_) = [USE(X.TEMP a)] + | usehit (X.REL(o1, o2, _),_) = usehit o1 @ usehit o2 | usehit (_) = nil fun callhit 0 = nil @@ -103,6 +106,7 @@ struct | gendef (n, X.COMMENT(_)) = (nil) | gendef (n, X.LIVEIGN (_)) = ([SUCC (n+1)]) | gendef (n, X.MOV(dest, src)) = (defhit dest @ usehit src @ [SUCC(n+1), ISMOVE]) + | gendef (n, X.MOVSC(dest, src)) = (defhit dest @ usehit src @ [SUCC(n+1)]) | gendef (n, X.LEA(dest, src)) = (defhit dest @ usehit src @ [SUCC(n+1)]) | gendef (n, X.SUB(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) | gendef (n, X.IMUL(dest, src)) = (defhit dest @ usehit dest @ usehit src @ [SUCC(n+1)]) @@ -122,9 +126,10 @@ struct | 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.CMOVcc(_,src, dest)) = (defhit dest @ usehit src @ [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)]) + 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)]) @@ -211,7 +216,7 @@ struct (* val isndef : X.oper -> pred list -> bool * checks to see if x is defined in a predicate list *) fun isndef (X.STACKARG(_)) _ = false - | isndef x (DEF(y)::l') = not (X.opereq (x,y)) andalso isndef x l' + | isndef x (DEF(y)::l') = not (X.basiceq (x,y)) andalso isndef x l' | isndef x (a::l') = isndef x l' | isndef x nil = true @@ -241,8 +246,8 @@ struct 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 ^ ")" + fun dustostring (DEF(a)) = "DEF(" ^ X.pp_oper (a,Temp.Quad) ^ ")" + | dustostring (USE(a)) = "USE(" ^ X.pp_oper (a,Temp.Quad) ^ ")" | dustostring (SUCC(a)) = "SUCC(" ^ Int.toString a ^ ")" | dustostring ISMOVE = "ISMOVE" @@ -269,7 +274,7 @@ struct fun prettyprint (set) = OperSet.foldr - (fn (oper, s) => (X.prettyprint_oper X.Long oper) ^ ", " ^ s) + (fn (oper, s) => (X.pp_oper (oper,Temp.Quad)) ^ ", " ^ s) "-\n" set diff --git a/codegen/peephole.sml b/codegen/peephole.sml deleted file mode 100644 index 7bf55a1..0000000 --- a/codegen/peephole.sml +++ /dev/null @@ -1,46 +0,0 @@ -(* L3 compiler - * peephole optimizer - * optimizes away redundant insns such as: - mov a, b - mov a, b - - mov a, b - mov b, a - - mov a, a - - neg a - neg a - * Author: Chris Lu - *) - -signature PEEPHOLE = -sig - val peephole : x86.insn list -> x86.insn list -end - -structure Peephole :> PEEPHOLE = -struct - structure X = x86 - - (* val peephole : x86.insn list -> x86.insn list *) - - 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 (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 (a::l) = a::(peephole l) - | peephole nil = nil - -end diff --git a/codegen/solidify.sml b/codegen/solidify.sml index 21b37bc..07ae420 100644 --- a/codegen/solidify.sml +++ b/codegen/solidify.sml @@ -22,7 +22,13 @@ struct type asm = x86.insn list exception Spilled - + + structure TempMap = SplayMapFn(struct + type ord_key = Temp.temp + val compare = Temp.compare + end) + structure Tm = Temp + fun solidify (regmap : colorings) (instrs : asm) : asm = let (* r14d and r15d is reserved for spilling *) @@ -32,11 +38,9 @@ struct then raise Spilled else X.numtoreg n - fun temptonum (t: T.temp) : int = - (List.hd - (List.map (fn (_, n) => n) - (List.filter (fn (a, _) => (Temp.eq (a, t))) regmap))) - + val tempnums = List.foldr (fn ((t,n),b) => TempMap.insert(b,t,n)) (TempMap.empty) regmap + fun temptonum (t: T.temp) : int = valOf (TempMap.find (tempnums, t)) + fun temptoreg (t: T.temp) : x86.reg = numtoreg (temptonum t) handle Empty => raise ErrorMsg.InternalError ("Uncolored temp "^(Temp.name t)^", agh!") @@ -61,79 +65,99 @@ struct val numreg = foldr (Int.max) 0 (map (fn (_, n) => n) regmap) (* Number of registers used. *) val nspilled = Int.max (numreg - maxreg, 0) (* Number of spilled registers. *) - fun isspilled (X.TEMP temp) = (temptonum temp) > maxreg (* Whether a register is spilled *) - | isspilled (X.STACKARG _) = true - | isspilled (X.REL _) = true - | isspilled (X.OSIZE (_, oo)) = isspilled oo + fun isspilled (X.TEMP temp, _) = (temptonum temp) > maxreg (* Whether a register is spilled *) + | isspilled (X.STACKARG _, _) = true + | isspilled (X.REL _, _) = true | isspilled _ = false + val stacksz = (nspilled + nsave) * 8 fun stackpos (reg: int) = stacksz - (reg - maxreg + nsave) * 8 (* Stack position of some register number *) val prologue = - (X.SUB (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))) :: + (X.SUB ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stacksz), Tm.Quad))) :: (ListPair.map (fn (num, reg) => - X.MOV (X.OSIZE (X.Qword, X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz - 8*(num+1))))), X.OSIZE (X.Qword, reg))) + X.MOV ((X.REL ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt (stacksz - 8*(num+1))), Tm.Quad), 0w1), Tm.Quad), (reg, Tm.Quad))) (List.tabulate (nsave, fn x => x), savelist)) val epilogue = (ListPair.map (fn (num, reg) => - X.MOV (X.OSIZE (X.Qword, reg), X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz - 8*(num+1)))))) + X.MOV ((reg, Tm.Quad), (X.REL ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt (stacksz - 8*(num+1))), Tm.Quad), 0w1), Tm.Quad))) (List.tabulate (nsave, fn x => x), savelist)) @ - [X.ADD (X.OSIZE (X.Qword, X.REG X.RSP), X.CONST (Word32.fromInt stacksz))] + [X.ADD ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt stacksz), Tm.Quad))] val endlbl = Label.new() - fun spill s (X.TEMP temp, xreg: x86.reg) = (* Spill a register if need be. *) - if (isspilled (X.TEMP temp)) - then [X.MOV (X.OSIZE(s, X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp)), X.REG xreg)] - else nil - | spill s (X.STACKARG _, _) = raise ErrorMsg.InternalError "Cannot spill to a stack arg" - | spill s (a as X.REL _, xreg) = [X.MOV (X.OSIZE(s,a), X.REG xreg)] - | spill s (X.OSIZE (s', oo), xreg) = spill s' (X.stripsize oo, xreg) - | spill _ _ = nil (* Nothing else can be spilled. *) - fun unspill s (X.TEMP temp, xreg: x86.reg) = (* Unspill a register if need be. *) - if (isspilled (X.TEMP temp)) - then [X.MOV (X.OSIZE(s, X.REG xreg), X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp))] - else nil - | unspill s (X.STACKARG arg, xreg) = [X.MOV (X.OSIZE(s, X.REG xreg), X.REL (X.REG X.RSP, X.CONST (Word32.fromInt (stacksz + 8 + (arg * 8)))))] - | unspill s (a as X.REL _, xreg) = [X.MOV (X.OSIZE(s, X.REG xreg), a)] - | unspill s (X.OSIZE (s', oo), xreg) = unspill s' (X.stripsize oo, xreg) - | unspill _ _ = nil - - fun realoper (X.TEMP temp) = X.OSIZE (X.sts (Temp.size temp), X.REG (temptoreg temp)) (* Makes a operand 'real'. *) - | realoper (X.STACKARG arg) = raise Spilled - | realoper (X.REL _) = raise Spilled - | realoper (X.OSIZE (s, oo)) = X.OSIZE (s, realoper (X.stripsize oo)) + fun spill ((X.TEMP temp, s), xreg: x86.reg) = (* Spill a register if need be. *) + let + val base = (X.REG X.RSP, Tm.Quad) + val offs = (X.CONST (Word32.fromInt (stackpos (temptonum temp))), Tm.Quad) + in + if (isspilled (X.TEMP temp, s)) + then [X.MOV ((X.REL (base, offs, 0w1), Tm.Quad), (X.REG xreg, Tm.Quad))] + else nil + end + | spill ((X.STACKARG _, s), _) = raise ErrorMsg.InternalError "Cannot spill to a stack arg" + | spill ((a as X.REL _, s), xreg) = [X.MOV ((a,s), (X.REG xreg,s))] + | spill _ = nil (* Nothing else can be spilled. *) + fun unspill ((X.TEMP temp, s), xreg: x86.reg) = (* Unspill a register if need be. *) + let + val base = (X.REG X.RSP, Tm.Quad) + val offs = (X.CONST (Word32.fromInt (stackpos (temptonum temp))), Tm.Quad) + in + if (isspilled (X.TEMP temp, s)) + then [X.MOV ((X.REG xreg, Tm.Quad), (X.REL (base, offs, 0w1), Tm.Quad))] + else nil + end + | unspill ((X.STACKARG arg, s), xreg) = + let + val base = (X.REG X.RSP, Tm.Quad) + val offs = (X.CONST (Word32.fromInt (stacksz + 8 + (arg * 8))), Tm.Quad) + in + [X.MOV ((X.REG xreg, s), (X.REL (base, offs, 0w1), s))] + end + | unspill ((a as X.REL _, s), xreg) = [X.MOV ((X.REG xreg, s), (a,s))] + | unspill _ = nil + + fun realoper (X.TEMP temp, s) = (X.REG (temptoreg temp), s) (* makes an 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.OSIZE (X.sts (Temp.size temp), X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt o stackpos o temptonum) temp)) - | stackoper (X.STACKARG arg) = X.REL (X.REG X.RSP, (X.CONST o Word32.fromInt) (stacksz + 8 + (arg * 8))) - | stackoper (a as X.REL _) = a - | stackoper (X.OSIZE (s, oo)) = X.OSIZE (s, stackoper (X.stripsize oo)) - | stackoper _ = raise ErrorMsg.InternalError "stackoper on not temp?" - - fun ophit (X.OSIZE (s, oo)) = let val (insns, p) = ophit (X.stripsize oo) in (insns, X.OSIZE (s, p)) end - | ophit (X.REL(op1, op2)) = - let - val t1 = X.stripsize op1 - val (s, t2) = X.sizeoper op2 - in - if (isspilled t1 andalso isspilled t2) then - ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2), - X.ADD (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)], - X.REL (X.REG spillreg1, X.CONST 0w0)) - else if(isspilled t1) then - ([X.MOV (X.OSIZE (X.Qword, X.REG spillreg1), stackoper t1)], - X.REL (X.REG spillreg1, realoper t2)) - else if(isspilled t2) then - ([X.MOV (X.OSIZE (s, X.REG spillreg1), stackoper t2)], - X.REL (realoper t1, X.REG spillreg1)) + fun stackoper (X.TEMP temp, s) = + let + val base = (X.REG X.RSP, Tm.Quad) + val offs = (X.CONST (Word32.fromInt (stackpos (temptonum temp))), Tm.Quad) + in + if (isspilled (X.TEMP temp, s)) + then (X.REL (base, offs, 0w1), s) + else raise ErrorMsg.InternalError "stackoper on unspilled temp?" + end + | stackoper (X.STACKARG arg, s) = + let + val base = (X.REG X.RSP, Tm.Quad) + val offs = (X.CONST (Word32.fromInt (stacksz + 8 + (arg * 8))), Tm.Quad) + in + (X.REL (base, offs, 0w1), s) + end + | stackoper (a as (X.REL _, s)) = a + | stackoper (a as (X.CONST _, s)) = a + | stackoper anous = raise ErrorMsg.InternalError ("stackoper on not temp " ^ X.pp_oper anous) + + fun ophit (X.REL(op1, op2, m), s) = + if (isspilled op1 andalso isspilled op2) then + ([X.MOV ((X.REG spillreg1, Tm.Long), stackoper op2), + X.IMUL((X.REG spillreg1, Tm.Quad), (X.CONST m, Tm.Quad)), + X.ADD ((X.REG spillreg1, Tm.Quad), stackoper op1)], + (X.REL ((X.REG spillreg1, Tm.Quad), (X.CONST 0w0, Tm.Quad), 0w1), s)) + else if(isspilled op1) then + ([X.MOV ((X.REG spillreg1, Tm.Quad), stackoper op1)], + (X.REL ((X.REG spillreg1, Tm.Quad), realoper op2, m), s)) + else if(isspilled op2) then + ([X.MOV ((X.REG spillreg1, Tm.Long), stackoper op2)], + (X.REL (realoper op1, (X.REG spillreg1, Tm.Quad), m), s)) else ([], - X.REL (realoper t1, realoper t2)) - end + (X.REL (realoper op1, realoper op2, m), s)) | ophit a = (nil, realoper a handle Spilled => stackoper a) fun transform (X.DIRECTIVE s) = [X.DIRECTIVE s] @@ -141,21 +165,21 @@ struct | transform (X.LIVEIGN a) = transform a | transform (X.MOV (dest, src)) = let - val (insns1, realop1) = ophit dest - val (insns2, realop2) = ophit src + val (insns1, realop1 as (_,s1)) = ophit dest + val (insns2, realop2 as (_,s2)) = ophit src in if(isspilled dest andalso isspilled src) then - insns2 @ [X.MOV (X.REG spillreg2, realop2)] @ insns1 @ [X.MOV (realop1, X.REG spillreg2)] + insns2 @ [X.MOV ((X.REG spillreg2, s2), realop2)] @ insns1 @ [X.MOV (realop1, (X.REG spillreg2, s1))] else insns1 @ insns2 @ [X.MOV (realop1, realop2)] end | transform (X.LEA (dest, src)) = let - val (insns1, realop1) = ophit dest - val (insns2, realop2) = ophit src + val (insns1, realop1 as (_,s1)) = ophit dest + val (insns2, realop2 as (_,s2)) = ophit src in if(isspilled dest andalso isspilled src) then - insns2 @ [X.MOV (X.REG spillreg2, realop2)] @ insns1 @ [X.LEA (realop1, X.REG spillreg2)] + insns2 @ [X.LEA ((X.REG spillreg2, s2), realop2)] @ insns1 @ [X.MOV (realop1, (X.REG spillreg2, s1))] else insns1 @ insns2 @ [X.LEA (realop1, realop2)] end @@ -163,30 +187,30 @@ struct let val (insns, realop) = ophit dest in - unspill X.Long (src, spillreg2) @ insns @ + unspill (src, spillreg2) @ insns @ [ X.SUB(realop, - realoper src handle Spilled => X.REG spillreg2)] + realoper src handle Spilled => (X.REG spillreg2, X.osize realop))] end | transform (X.IMUL (dest, src)) = - unspill X.Long (dest, spillreg1) @ + unspill (dest, spillreg1) @ [ X.IMUL( - realoper dest handle Spilled => X.REG spillreg1, + realoper dest handle Spilled => (X.REG spillreg1, X.osize dest), realoper src handle Spilled => stackoper src)] @ - spill X.Long (dest, spillreg1) + spill (dest, spillreg1) | transform (X.IMUL3 (dest, src, const)) = - unspill X.Long ((X.stripsize src), spillreg2) @ + unspill (src, spillreg2) @ [ X.IMUL3( - realoper dest handle Spilled => X.REG spillreg1, - realoper src handle Spilled => X.REG spillreg2, + realoper dest handle Spilled => (X.REG spillreg1, X.osize dest), + realoper src handle Spilled => (X.REG spillreg2, X.osize src), const)] @ - spill X.Long (dest, spillreg1) + spill (dest, spillreg1) | transform (X.ADD (dest, src)) = let val (insns, realop) = ophit dest in - unspill X.Long (src, spillreg2) @ insns @ + unspill (src, spillreg2) @ insns @ [ X.ADD(realop, - realoper src handle Spilled => X.REG spillreg2)] + realoper src handle Spilled => (X.REG spillreg2, X.osize realop))] end | transform (X.IDIV (src)) = [ X.IDIV(realoper src handle Spilled => stackoper src)] | transform (X.NEG (src)) = [ X.NEG(realoper src handle Spilled => stackoper src)] @@ -201,41 +225,56 @@ struct shft)] | transform (X.CLTD) = [ X.CLTD ] | transform (X.AND (dest, src)) = - unspill X.Long (src, spillreg1) @ + unspill (src, spillreg1) @ [ X.AND( realoper dest handle Spilled => stackoper dest, - realoper src handle Spilled => X.REG spillreg1)] + realoper src handle Spilled => (X.REG spillreg1, X.osize src))] | transform (X.OR (dest, src)) = - unspill X.Long (src, spillreg1) @ + unspill (src, spillreg1) @ [ X.OR( realoper dest handle Spilled => stackoper dest, - realoper src handle Spilled => X.REG spillreg1)] + realoper src handle Spilled => (X.REG spillreg1, X.osize src))] | transform (X.XOR (dest, src)) = - unspill X.Long (src, spillreg1) @ + unspill (src, spillreg1) @ [ X.XOR( realoper dest handle Spilled => stackoper dest, - realoper src handle Spilled => X.REG spillreg1)] + realoper src handle Spilled => (X.REG spillreg1, X.osize src))] | transform (X.CMP (op1, op2)) = - unspill X.Long (op2, spillreg1) @ - [ X.CMP( - realoper op1 handle Spilled => stackoper op1, - realoper op2 handle Spilled => X.REG spillreg1)] + let + val (insns1, realop1) = ophit op1 + in + if(isspilled realop1 andalso isspilled op2) then + unspill (op2, spillreg2) @ insns1 @ [X.CMP (realop1, (X.REG spillreg2, X.osize realop1))] + else + insns1 @ [X.CMP (realop1, realoper op2 handle Spilled => stackoper op2)] + end | transform (X.TEST (op1, op2)) = - unspill X.Long (op2, spillreg1) @ + unspill (op2, spillreg1) @ [ X.TEST( realoper op1 handle Spilled => stackoper op1, - realoper op2 handle Spilled => X.REG spillreg1)] + realoper op2 handle Spilled => (X.REG spillreg1, X.osize op2))] | transform (X.SETcc (c,src)) = [ X.SETcc(c, realoper src handle Spilled => stackoper src)] + | transform (X.CMOVcc (c, dest, src)) = + let + val (insns1, realop1) = ophit dest + val (insns2, realop2) = ophit src + in + if(isspilled dest andalso isspilled src) then + insns2 @ [X.MOV ((X.REG spillreg2, X.osize src), realop2)] @ insns1 @ [X.CMOVcc (c, realop1, (X.REG spillreg2, X.osize src))] + else + insns1 @ insns2 @ [X.CMOVcc (c, realop1, realop2)] + end | transform (X.CALL l) = [ X.CALL l ] | transform (X.MOVZB (dest, src)) = [ X.MOVZB( - realoper dest handle Spilled => X.REG spillreg1, + realoper dest handle Spilled => (X.REG spillreg1, X.osize dest), realoper src handle Spilled => stackoper src)] - @ spill X.Long (dest, spillreg1) + @ spill (dest, spillreg1) | transform (X.RET) = if nsave < 2 then (epilogue @ [X.RET]) else [X.JMP endlbl] | transform (X.LABEL l) = [ X.LABEL l ] | transform (X.JMP l) = [ X.JMP l ] | transform (X.Jcc (c,l)) = [X.Jcc (c,l)] + | transform _ = raise ErrorMsg.InternalError "probably movsc: unimplemented" in if (nsave < 2) then List.concat (prologue :: (map transform instrs)) diff --git a/codegen/stringifier.sml b/codegen/stringifier.sml index 5010d7b..7ab1e89 100644 --- a/codegen/stringifier.sml +++ b/codegen/stringifier.sml @@ -18,10 +18,10 @@ struct (* val stringify : asm -> string * turns a x86 instruction list into a string of assembly code for these instructions *) - fun stringify' rn (X.CALL (l, n)) = X.prettyprint (X.CALL ((Symbol.symbol (rn (Symbol.name l))), n)) - | stringify' rn x = X.prettyprint x + fun stringify' rn (X.CALL (l, n)) = X.print (X.CALL ((Symbol.symbol (rn (Symbol.name l))), n)) + | stringify' rn x = X.print x (* val stringify : asm -> string *) - fun stringify realname l = foldr (fn (a,b) => (stringify' realname a) ^ b) ("") l + fun stringify realname l = String.concat (List.map (stringify' realname) l) end diff --git a/codegen/x86.sml b/codegen/x86.sml index e54d4be..c0ff0b8 100644 --- a/codegen/x86.sml +++ b/codegen/x86.sml @@ -10,15 +10,20 @@ sig datatype reg = EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D (* operands to instructions *) - datatype size = Byte | Word | Long | Qword - datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (oper * oper) | STACKARG of int | OSIZE of (size * oper) - datatype cc = E | NE | GE | LE | L | G + datatype basicop = REG of reg | + TEMP of Temp.temp | + CONST of Word32.word | + REL of ((basicop * Temp.size) * (basicop * Temp.size) * Word32.word) | + STACKARG of int + type oper = basicop * Temp.size + datatype cc = E | NE | GE | LE | L | G | B | BE | A | AE (* instructions *) datatype insn = DIRECTIVE of string | COMMENT of string | LABEL of Label.label | MOV of oper * oper | + MOVSC of oper * oper | LEA of oper * oper | SUB of oper * oper | IMUL of oper * oper | @@ -35,6 +40,7 @@ sig CMP of oper * oper | TEST of oper * oper | SETcc of cc * oper | + CMOVcc of cc * oper * oper | JMP of Label.label | Jcc of cc * Label.label | CALL of Symbol.symbol * int | @@ -42,41 +48,48 @@ sig CLTD | LIVEIGN of insn | RET - + structure OperSet : ORD_SET - where type Key.ord_key = oper; + where type Key.ord_key = basicop; structure LiveMap : ORD_MAP where type Key.ord_key = int; - val sts : int -> size - val sizeoper : oper -> size * oper - val stripsize : oper -> oper - val osize : oper -> size + val resize : Temp.size -> oper -> oper + val regcmp : reg * reg -> order + val getop : oper -> basicop + val osize : oper -> Temp.size val cmpoper : oper * oper -> order + val cmpbasic : basicop * basicop -> order val opereq : oper * oper -> bool - val regname : size -> reg -> string + val basiceq : basicop * basicop -> bool + val regname : Temp.size -> reg -> string val regtonum : reg -> int val numtoreg : int -> reg val ccname : cc -> string val opsused : insn list -> OperSet.set - val prettyprint_oper : size -> oper -> string - val prettyprint : insn -> string + val pp_oper : oper -> string + val print : 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 size = Byte | Word | Long | Qword - datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (oper * oper) | STACKARG of int | OSIZE of (size * oper) - datatype cc = E | NE | GE | LE | L | G + (* operands to instructions *) + datatype basicop = REG of reg | + TEMP of Temp.temp | + CONST of Word32.word | + REL of ((basicop * Temp.size) * (basicop * Temp.size) * Word32.word) | + STACKARG of int + datatype cc = E | NE | GE | LE | L | G | B | BE | A | AE + type oper = basicop * Temp.size datatype insn = DIRECTIVE of string | COMMENT of string | LABEL of Label.label | MOV of oper * oper | + MOVSC of oper * oper | LEA of oper * oper | SUB of oper * oper | IMUL of oper * oper | @@ -93,6 +106,7 @@ struct CMP of oper * oper | TEST of oper * oper | SETcc of cc * oper | + CMOVcc of cc * oper * oper | JMP of Label.label | Jcc of cc * Label.label | CALL of Symbol.symbol * int | @@ -127,10 +141,10 @@ struct 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 + of Temp.Byte => b + | Temp.Word => w + | Temp.Long => l + | Temp.Quad => q end fun ccname E = "e" @@ -139,6 +153,10 @@ struct | ccname LE = "le" | ccname G = "g" | ccname L = "l" + | ccname B = "b" + | ccname A = "a" + | ccname AE = "ae" + | ccname BE = "be" (* gives number (color) associated with reg *) fun regtonum EAX = 0 @@ -151,11 +169,11 @@ struct | regtonum R10D = 7 | regtonum R11D = 8 | regtonum EBX = 9 - | regtonum R12D = 10 - | regtonum R13D = 11 - | regtonum R14D = 12 - | regtonum R15D = 13 - | regtonum EBP = 14 (* Dummy numbers -- not permitted for allocation, but there so that we can compare *) + | regtonum EBP = 10 + | regtonum R12D = 11 + | regtonum R13D = 12 + | regtonum R14D = 13 + | regtonum R15D = 14 | regtonum RSP = 15 (* gives reg associated with number (color) *) @@ -169,45 +187,54 @@ struct | numtoreg 7 = R10D | numtoreg 8 = R11D | numtoreg 9 = EBX - | numtoreg 10 = R12D - | numtoreg 11 = R13D - | numtoreg 12 = R14D - | numtoreg 13 = R15D - | numtoreg n = raise ErrorMsg.InternalError ("numtoreg: Unknown register "^(Int.toString n)) + | numtoreg 10 = EBP + | numtoreg 11 = R12D + | numtoreg 12 = R13D + | numtoreg 13 = R14D + | numtoreg 14 = R15D + | numtoreg n = raise ErrorMsg.InternalError ("numtoreg: Invalid register "^(Int.toString n)) (* register compare *) fun regcmp (r1, r2) = Int.compare (regtonum r1, regtonum r2) + fun osize (_,s) = s + fun resize ss (a,_) = (a,ss) + fun getop (a,_) = a (* operand compare; arbitrary order imposed to make * various things easier (e.g. liveness, for sorting) *) - fun cmpoper (REG(reg1), REG(reg2)) = regcmp (reg1, reg2) - | cmpoper (TEMP(temp1), TEMP(temp2)) = Temp.compare (temp1,temp2) - | cmpoper (CONST(const1), CONST(const2)) = Word32.compare (const1, const2) - | cmpoper (REL (r1, i1), REL (r2, i2)) = - let - val order1 = cmpoper (r1, r2) - val order2 = cmpoper (i1, i2) + fun cmpbasic (REG reg1, REG reg2) = regcmp (reg1, reg2) + | cmpbasic (TEMP temp1, TEMP temp2) = Temp.compare (temp1,temp2) + | cmpbasic (CONST(const1), CONST(const2)) = Word32.compare (const1, const2) + | cmpbasic (REL (r1, i1, m1), REL (r2, i2, m2)) = + let + val orderm = Word32.compare (m1,m2) + val order1 = cmpbasic (getop r1, getop r2) + val order2 = cmpbasic (getop i1, getop i2) + val o1 = if(order1 = EQUAL) then order2 else order1 in - if (order1 = EQUAL) then order2 - else order1 + if (o1 = EQUAL) then orderm + else o1 end - | cmpoper (CONST _, _) = LESS - | cmpoper (REG _, _) = LESS - | cmpoper (REL _, _) = LESS - | cmpoper (_, _) = GREATER + | cmpbasic (CONST _, _) = LESS + | cmpbasic (REG _, _) = LESS + | cmpbasic (REL _, _) = LESS + | cmpbasic (_, _) = GREATER + + fun cmpoper ((o1,s1),(o2,s2)) = (case (cmpbasic (o1,o2)) of EQUAL => Temp.cmpsize (s1,s2) | a => a) + + fun basiceq (REG a, REG b) = a = b + | basiceq (TEMP a, TEMP b) = Temp.eq (a, b) + | basiceq (CONST a, CONST b) = a = b + | basiceq (REL (a1, b1, m1), REL (a2, b2, m2)) = m1 = m2 andalso basiceq (getop a1, getop a2) andalso basiceq (getop b1, getop b2) + | basiceq (_, _) = false + + fun opereq ((o1,s1),(o2,s2)) = basiceq (o1,o2) andalso s1 = s2 - 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 (a1, b1), REL (a2, b2)) = opereq (a1,a2) andalso opereq (b1,b2) -(* | opereq (OSIZE (s1, o1), OSIZE (s2, o2)) = (s1 = s2) andalso opereq (o1, o2)*) (* This breaks the peepholer, shit *) - | opereq (_, _) = false - structure OperSet = ListSetFn ( struct - type ord_key = oper - val compare = cmpoper + type ord_key = basicop + val compare = cmpbasic end) structure LiveMap = SplayMapFn(struct @@ -219,87 +246,73 @@ struct | 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 ((LEA (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) - | opsused ((SUB (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) - | opsused ((IMUL (dst, src))::l) = OperSet.addList (opsused l, [dst, src]) - | opsused ((IMUL3 (dst, src, _))::l) = OperSet.addList (opsused l, [dst, src]) - | opsused ((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 ((MOV ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((MOVSC((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((LEA ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((SUB ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((IMUL ((dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((IMUL3 ((dst,_), (src,_), _))::l) = OperSet.addList (opsused l, [dst, src]) + | opsused ((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 ((CMOVcc (c, (dst,_), (src,_)))::l) = OperSet.addList (opsused l, [dst, src]) | 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 ((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) - fun sts 8 = Qword - | sts 4 = Long - | sts 2 = Word - | sts 1 = Byte - | sts _ = raise ErrorMsg.InternalError "invalid size" - - (* pretty prints an operand *) - fun sfx Byte = "b" - | sfx Word = "w" - | sfx Long = "l" - | sfx Qword = "q" - - fun osize (OSIZE (s, _)) = s - | osize _ = Long - - fun stripsize (OSIZE (_, oo)) = stripsize oo - | stripsize oo = oo - - fun sizeoper (OSIZE (s, oo)) = (s, stripsize oo) - | sizeoper oo = (Long, oo) - fun prettyprint_oper s (REG r) = "%" ^ (regname s r) - | prettyprint_oper _ (TEMP t) = (Temp.name t) ^ (sfx (sts (Temp.size t))) - | prettyprint_oper _ (CONST c) = "$0x" ^ (Word32.toString c) - | prettyprint_oper _ (REL (r, CONST n)) = (Word32Signed.toString n) ^ "(" ^ (prettyprint_oper Qword r) ^ ")" - | prettyprint_oper s (REL (r1, r2)) = "(" ^ (prettyprint_oper Qword (stripsize r1)) ^ "," ^ (prettyprint_oper Qword (stripsize r2)) ^ ")" - | prettyprint_oper _ (STACKARG i) = "arg#"^Int.toString i - | prettyprint_oper _ (OSIZE (s, oo)) = prettyprint_oper s (stripsize oo) + fun pp_oper (REG r, s) = "%" ^ (regname s r) + | pp_oper (TEMP t, _) = (Temp.name t) ^ (Temp.sfx (Temp.size t)) + | pp_oper (CONST c, _) = "$" ^ Word32Signed.toString c + | pp_oper (REL ((CONST n, _), _, _), _) = Word32Signed.toString n + | pp_oper (REL (r, (CONST n, _), _), _) = (Word32Signed.toString n) ^ "(" ^ (pp_oper r) ^ ")" + | pp_oper (REL (r1, r2, m), _) = "(" ^ (pp_oper r1) ^ "," ^ (pp_oper r2) ^ "," ^ + (Word32.toString m) ^ ")" + | pp_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 (LEA(dst, src)) = "\tlea" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (MOV(dst, src)) = "\tmov" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (SUB(dst, src)) = "\tsub" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (IMUL(dst, src)) = "\timul" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (IMUL3(dst, tmp, const)) = "\timul" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (CONST const)) ^ ", " ^ (prettyprint_oper (osize dst) (stripsize tmp)) ^ ", " ^ (prettyprint_oper (osize dst) dst) ^ "\n" - | prettyprint (ADD(dst, src)) = "\tadd" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (IDIV(src)) = "\tidiv" ^ (sfx (osize src)) ^ "\t" ^ (prettyprint_oper (osize src) src) ^ "\n" - | prettyprint (NEG (dst)) = "\tneg" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (NOT (dst)) = "\tnot" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (SAL (dst, shft)) = "\tsal" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (SAR (dst, shft)) = "\tsar" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (AND (dst, src)) = "\tand" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (OR (dst, src)) = "\tor" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (XOR (dst, src)) = "\txor" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (CMP (dst, src)) = "\tcmp" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (TEST (dst, src)) = "\ttest" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper (osize dst) (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (prettyprint_oper Byte (stripsize dst)) ^ "\n" - | prettyprint (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n" - | prettyprint (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n" - | prettyprint (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n" - | prettyprint (MOVZB (dst, src)) = "\tmovzb" ^ (sfx (osize dst)) ^ "\t" ^ (prettyprint_oper Byte (stripsize src)) ^ ", " ^ (prettyprint_oper Long dst) ^ "\n" - | prettyprint (CLTD) = "\tcltd\n" - | prettyprint (RET) = "\tret\n" - | prettyprint (LIVEIGN i) = prettyprint i -(* | prettyprint _ = raise ErrorMsg.InternalError ("prettyprint: Type A? Hatchar de coneccion?")*) + (* pretty prints the asm *) + fun print (DIRECTIVE(str)) = str ^ "\n" + | print (COMMENT(str)) = "// " ^ str ^ "\n" + | print (LABEL(l)) = Label.name l ^ ":\n" + | print (LEA(dst, src)) = "\tlea" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (MOV(dst, src)) = "\tmov" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (MOVSC((d,Temp.Long), (s,Temp.Quad))) = "\tmov" ^ (Temp.sfx Temp.Long) ^ "\t" ^ (pp_oper (s,Temp.Long)) ^ ", " ^ (pp_oper (d,Temp.Long)) ^ " // sex change\n" + | print (MOVSC((d,Temp.Quad), (s,Temp.Long))) = "\tmov" ^ (Temp.sfx Temp.Long) ^ "\t" ^ (pp_oper (s,Temp.Long)) ^ ", " ^ (pp_oper (d,Temp.Long)) ^ " // sex change\n" + | print (MOVSC(_,_)) = raise ErrorMsg.InternalError "invalid size change" + | print (SUB(dst, src)) = "\tsub" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (IMUL(dst, src)) = "\timul" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (IMUL3(dst, tmp, const)) = "\timul" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper (CONST const, Temp.Long)) ^ ", " ^ (pp_oper tmp) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (ADD(dst, src)) = "\tadd" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (IDIV(src)) = "\tidiv" ^ (Temp.sfx (osize src)) ^ "\t" ^ (pp_oper src) ^ "\n" + | print (NEG (dst)) = "\tneg" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper dst) ^ "\n" + | print (NOT (dst)) = "\tnot" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper dst) ^ "\n" + | print (SAL (dst, shft)) = "\tsal" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper shft) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (SAR (dst, shft)) = "\tsar" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper shft) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (AND (dst, src)) = "\tand" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (OR (dst, src)) = "\tor" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (XOR (dst, src)) = "\txor" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (CMP (dst, src)) = "\tcmp" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (TEST (dst, src)) = "\ttest" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (pp_oper dst) ^ "\n" + | print (CMOVcc (c, dst, src)) = "\tcmov" ^ (ccname c) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n" + | print (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n" + | print (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n" + | print (MOVZB (dst, src)) = "\tmovzb" ^ (Temp.sfx (osize dst)) ^ "\t" ^ (pp_oper src) ^ ", " ^ (pp_oper dst) ^ "\n" + | print (CLTD) = "\tcltd\n" + | print (RET) = "\tret\n" + | print (LIVEIGN i) = print i end diff --git a/compile-l4c.sml b/compile-l5c.sml similarity index 72% rename from compile-l4c.sml rename to compile-l5c.sml index 7299ee8..f5af6ed 100644 --- a/compile-l4c.sml +++ b/compile-l5c.sml @@ -4,4 +4,4 @@ *) CM.make "sources.cm"; -SMLofNJ.exportFn ("bin/l4c.heap", Top.main); +SMLofNJ.exportFn ("bin/l5c.heap", Top.main); diff --git a/optimize/constfold.sml b/optimize/constfold.sml new file mode 100644 index 0000000..43e9d38 --- /dev/null +++ b/optimize/constfold.sml @@ -0,0 +1,69 @@ +structure ConstantFold :> OPTIMIZATION = +struct + structure T = Tree + +(* fun isconstret (T.FUNCTION (id, stml)) = foldr (fn (l,(b)) => noeffect l andalso ) true stml *) + + fun operate (T.ADD) a b = a + b + | operate (T.SUB) a b = a - b + | operate (T.MUL) a b = a * b + | operate (T.DIV) a b = Word32Signed.adiv (a,b) + | operate (T.MOD) a b = Word32Signed.amod (a,b) + | operate (T.LSH) a b = Suq.Word32_lsh (a, Word32.mod (b, 0w32)) + | operate (T.RSH) a b = Suq.Word32_rsh (a, Word32.mod (b, 0w32)) + | operate (T.BITOR) a b = Word32.orb (a,b) + | operate (T.BITAND) a b = Word32.andb (a,b) + | operate (T.BITXOR) a b = Word32.xorb (a,b) + | operate (T.LOGOR) a b = if (a <> 0w0 orelse b <> 0w0) then 0w1 else 0w0 + | operate (T.LOGAND) a b = if (a <> 0w0 andalso b <> 0w0) then 0w1 else 0w0 + | operate (T.NEQ) a b = if (a <> b) then 0w1 else 0w0 + | operate (T.EQ) a b = if (a = b) then 0w1 else 0w0 + | operate (T.LT) a b = if (Word32Signed.lt (a,b)) then 0w1 else 0w0 + | operate (T.GT) a b = if (Word32Signed.gt (a,b)) then 0w1 else 0w0 + | operate (T.LE) a b = if (Word32Signed.le (a,b)) then 0w1 else 0w0 + | operate (T.GE) a b = if (Word32Signed.ge (a,b)) then 0w1 else 0w0 + | operate (T.BE) a b = if (Word32.>= (a,b)) then 0w1 else 0w0 + + fun operate_unop (T.NEG) a = 0w0 - a + | operate_unop (T.BITNOT) a = Word32.notb a + | operate_unop (T.BANG) a = if (a = 0w0) then 0w1 else 0w0 + + fun foldexp (T.BINOP(oper, e1, e2)) = + let + val f1 = foldexp e1 + val f2 = foldexp e2 + in + case f1 + of T.CONST n1 => (case f2 + of T.CONST n2 => (T.CONST (operate oper n1 n2) handle _ (* Might be either 'div' on smlnj or 'overflow' on mlton *) => T.BINOP(oper, T.CONST n1, T.CONST n2)) + | _ => T.BINOP(oper, T.CONST n1, f2)) + | _ => T.BINOP (oper, f1, f2) + end + | foldexp (T.UNOP(oper, e)) = (case foldexp e of T.CONST n => T.CONST (operate_unop oper n) | a => T.UNOP(oper, a)) + | foldexp (T.CONST(n)) = T.CONST n + | foldexp (T.TEMP(t)) = T.TEMP t + | foldexp (T.ARG(n)) = T.ARG n + | foldexp (T.CALL(id, l, n)) = T.CALL (id, List.map (fn (a,n) => (foldexp a, n)) l, n) + | foldexp (T.MEMORY (e, s)) = T.MEMORY (foldexp e, s) + | foldexp (T.ALLOC (e)) = T.ALLOC (foldexp e) + | foldexp (T.STMVAR (sl, e)) = T.STMVAR (List.map foldstm sl, foldexp e) + | foldexp (T.COND (c, e1, e2)) = + let + val f1 = foldexp e1 + val f2 = foldexp e2 + in + case foldexp c + of T.CONST n => if n <> 0w0 then f1 else f2 + | a => T.COND (a, f1, f2) + end + | foldexp (T.NULLPTR) = T.NULLPTR + + and foldstm (T.MOVE (e1, e2)) = T.MOVE (foldexp e1, foldexp e2) + | foldstm (T.RETURN (e, s)) = T.RETURN (foldexp e, s) + | foldstm (T.EFFECT e) = T.EFFECT (foldexp e) + | foldstm (a as T.LABEL _) = a + | foldstm (T.JUMPIFN (e, l)) = T.JUMPIFN (foldexp e, l) + | foldstm (a as T.JUMP _) = a + + val optimizer = { shortname = "constant-fold", description = "Folds constant expressions into constants", func = Optimizer.IREXP foldexp } +end diff --git a/optimize/feckful.sml b/optimize/feckful.sml new file mode 100644 index 0000000..ec6bdc5 --- /dev/null +++ b/optimize/feckful.sml @@ -0,0 +1,13 @@ +structure FeckfulnessAnalysis :> OPTIMIZATION = +struct + structure T = Tree + structure TU = TreeUtils + + fun feckstm (a as T.EFFECT e) = + if (TU.effect e) + then [a] + else [] + | feckstm a = [a] + + val optimizer = { shortname = "feckfulness", description = "Removes simple side effect statements that have no effect", func = Optimizer.IRSTM feckstm } +end diff --git a/optimize/labelcoalescing.sml b/optimize/labelcoalescing.sml new file mode 100644 index 0000000..5188e95 --- /dev/null +++ b/optimize/labelcoalescing.sml @@ -0,0 +1,28 @@ +structure LabelCoalescing :> OPTIMIZATION = +struct + structure X = x86 + + structure LabelMap = SplayMapFn(struct + type ord_key = Label.label + val compare = Label.compare + end) + + fun coalesce insns = + let + fun lmap (SOME(a)) ((X.LABEL l)::is) = let val (m, il) = lmap (SOME(a)) is in (LabelMap.insert(m, l, a), il) end + | lmap (NONE) ((X.LABEL l)::is) = let val (m, il) = lmap (SOME(l)) is in (LabelMap.insert(m, l, l), (X.LABEL l)::il) end + | lmap _ (i::is) = let val (m, il) = lmap NONE is in (m, i::il) end + | lmap _ nil = (LabelMap.empty, nil) + + val (labelmap, insns') = lmap NONE insns + + fun convert ((X.Jcc(c,l))::is) = (X.Jcc(c, valOf(LabelMap.find(labelmap,l))))::(convert is) + | convert ((X.JMP(l))::is) = (X.JMP(valOf(LabelMap.find(labelmap,l))))::(convert is) + | convert (i::is) = i::(convert is) + | convert nil = nil + in + convert insns' + end + + val optimizer = { shortname = "labelcoalescing", description = "Coalesces adjacent labels", func = Optimizer.PRELIVENESS coalesce } +end diff --git a/optimize/optimizer.sml b/optimize/optimizer.sml new file mode 100644 index 0000000..fba6485 --- /dev/null +++ b/optimize/optimizer.sml @@ -0,0 +1,76 @@ +signature OPTIMIZER = +sig + datatype optfunc = + IRPROG of (Tree.program -> Tree.program) | + IRFUNC of (Tree.func -> Tree.func) | + IRSTM of (Tree.stm -> Tree.stm list) | + IREXP of (Tree.exp -> Tree.exp) | + PRELIVENESS of (x86.insn list -> x86.insn list) | + FINAL of (x86.insn list -> x86.insn list) + + type optimization = { + shortname : string, + description : string, + func : optfunc + } + + val optimize_ir : optimization list -> Tree.program -> Tree.program + val optimize_preliveness : optimization list -> x86.insn list -> x86.insn list + val optimize_final : optimization list -> x86.insn list -> x86.insn list +end + +structure Optimizer :> OPTIMIZER = +struct + structure T = Tree + + datatype optfunc = + IRPROG of (Tree.program -> Tree.program) | + IRFUNC of (Tree.func -> Tree.func) | + IRSTM of (Tree.stm -> Tree.stm list) | + IREXP of (Tree.exp -> Tree.exp) | + PRELIVENESS of (x86.insn list -> x86.insn list) | + FINAL of (x86.insn list -> x86.insn list) + + type optimization = { + shortname : string, + description : string, + func : optfunc + } + + fun foldfunc f (T.FUNCTION (id, stml)) = T.FUNCTION (id, List.concat (List.map f stml)) + fun expfunc f (T.MOVE (e1, e2)) = [T.MOVE (f e1, f e2)] + | expfunc f (T.RETURN (e, s)) = [T.RETURN (f e, s)] + | expfunc f (T.EFFECT e) = [T.EFFECT (f e)] + | expfunc f (a as T.LABEL _) = [a] + | expfunc f (T.JUMPIFN (e, l)) = [T.JUMPIFN (f e, l)] + | expfunc f (a as T.JUMP _) = [a] + + fun optimize_ir ol prog = + foldr ( + fn (IRPROG f, prog) => f prog + | (IRFUNC f, prog) => List.map f prog + | (IRSTM f, prog) => List.map (foldfunc (f)) prog + | (IREXP f, prog) => List.map (foldfunc (expfunc f)) prog + | (_, prog) => prog) + prog + (map (fn (x : optimization) => #func x) ol) + + fun optimize_preliveness ol assem = + foldr ( + fn (PRELIVENESS f, assem) => f assem + | (_, assem) => assem) + assem + (map (fn (x : optimization) => #func x) ol) + + fun optimize_final ol assem = + foldr ( + fn (FINAL f, assem) => f assem + | (_, assem) => assem) + assem + (map (fn (x : optimization) => #func x) ol) +end + +signature OPTIMIZATION = +sig + val optimizer : Optimizer.optimization +end diff --git a/optimize/peephole.sml b/optimize/peephole.sml new file mode 100644 index 0000000..2c8ef5d --- /dev/null +++ b/optimize/peephole.sml @@ -0,0 +1,48 @@ +(* L3 compiler + * peephole optimizer + * optimizes away redundant insns such as: + mov a, b + mov a, b + + mov a, b + mov b, a + + mov a, a + + neg a + neg a + * Author: Chris Lu + *) + +structure Peephole :> OPTIMIZATION = +struct + structure X = x86 + + (* val peephole : x86.insn list -> x86.insn list *) + fun peephole ((insn1 as X.MOV(d1, s1 as (X.REL a,_)))::(insn2 as X.MOV(d2, s2 as (X.REL(a2,b2,m),_)))::l) = + if(X.opereq(a2,d1) orelse X.opereq(b2,d1)) then + insn1::(peephole (insn2::l)) + else if(X.opereq(s1,s2) andalso X.opereq (d1,d2)) then + peephole (insn2::l) + else + insn1::(peephole (insn2::l)) + | peephole ((insn1 as X.MOV(a1,b1))::(insn2 as X.MOV(a2,b2))::l) = + if(X.opereq(a1, b1) orelse (X.opereq(a1, a2) andalso X.opereq(b1, b2))) then + peephole (insn2::l) + else if(X.opereq(a2, b2) orelse (X.opereq(a1, b2) andalso X.opereq(b1, a2))) then + peephole (insn1::l) + else + insn1::(peephole (insn2::l)) + | peephole (X.MOV (a as (X.REG r,s), (X.CONST 0w0,_))::l) = (X.XOR (a, a))::(peephole l) + | peephole ((insn as X.MOV(a,b))::l) = if X.opereq(a, b) then peephole l else insn::(peephole l) + | peephole ((insn1 as X.NEG(a))::(insn2 as X.NEG(b))::l) = if X.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,s), (X.CONST 0w0,_))::l) = (X.TEST ((X.REG r,s), (X.REG r,s)))::(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 (a::l) = a::(peephole l) + | peephole nil = nil + + val optimizer = { shortname = "peephole", description = "Peephole analysis", func = Optimizer.FINAL peephole } +end diff --git a/optimize/stupidfunc.sml b/optimize/stupidfunc.sml new file mode 100644 index 0000000..99bd6b0 --- /dev/null +++ b/optimize/stupidfunc.sml @@ -0,0 +1,58 @@ +structure StupidFunctionElim :> OPTIMIZATION = +struct + structure T = Tree + structure TU = TreeUtils + + datatype rval = Any | Const of Word32.word + + fun stmhit NONE _ = NONE + | stmhit _ (T.JUMPIFN _) = NONE + | stmhit (SOME(Any)) (T.RETURN (T.CONST n, s)) = SOME(Const(n)) + | stmhit (SOME(Const(n))) (T.RETURN (T.CONST n',s)) = if n' = n then SOME(Const(n)) else NONE + | stmhit _ (T.RETURN _) = NONE + | stmhit opt s = if TU.effect_stm s then NONE else opt + + fun stupid (T.FUNCTION (id, fl)) = (foldr (fn (a,b) => stmhit b a) (SOME(Any)) fl, id) + + fun findstupids prog = foldr (fn ((SOME(Const(n)),id),b) => Symbol.bind b (id, SOME(n)) + | ((SOME(Any), id),b) => raise ErrorMsg.InternalError "wtf, this function no return" + | ((NONE, id),b) => Symbol.bind b (id, NONE)) + Symbol.empty + (List.map stupid prog) + + fun ds_exp t (T.CALL(id, l, s)) = + let + val effecting = List.mapPartial (fn (a,_) => if TU.effect a then SOME(ds_exp t a) else NONE) l + in + (case Symbol.look' t id + of SOME(n) => T.STMVAR(List.map T.EFFECT effecting, T.CONST n) + | NONE => T.CALL(id, List.map (fn (a,i) => (ds_exp t a, i)) l, s)) + handle Option => T.CALL(id, List.map (fn (a,i) => (ds_exp t a, i)) l, s) + end + | ds_exp t (T.BINOP(oper, e1, e2)) = T.BINOP(oper, ds_exp t e1, ds_exp t e2) + | ds_exp t (T.UNOP(oper, e)) = T.UNOP(oper, ds_exp t e) + | ds_exp t (T.MEMORY (e,s)) = T.MEMORY (ds_exp t e, s) + | ds_exp t (T.COND (c, e1, e2)) = T.COND (ds_exp t c, ds_exp t e1, ds_exp t e2) + | ds_exp t (T.ALLOC e) = T.ALLOC (ds_exp t e) + | ds_exp t (T.STMVAR (sl, e)) = T.STMVAR (List.map (ds_stm t) sl, ds_exp t e) + | ds_exp t a = a + + and ds_stm t (T.MOVE (e1, e2)) = T.MOVE (ds_exp t e1, ds_exp t e2) + | ds_stm t (T.RETURN (e, s)) = T.RETURN (ds_exp t e, s) + | ds_stm t (T.EFFECT e) = T.EFFECT (ds_exp t e) + | ds_stm t (a as T.LABEL _) = a + | ds_stm t (T.JUMPIFN (e, l)) = T.JUMPIFN (ds_exp t e, l) + | ds_stm t (a as T.JUMP _) = a + + fun diestupids prog = + let + val stupids = findstupids prog + fun kill (T.FUNCTION (id, sl)) = T.FUNCTION (id, List.map (ds_stm stupids) sl) + in + List.map kill prog + end + + val optimizer = { shortname = "stupidfn", + description = "Turns stupid functions with constant return and no side effect into constant", + func = Optimizer.IRPROG diestupids } +end diff --git a/parse/ast.sml b/parse/ast.sml index 84b2356..75f7042 100644 --- a/parse/ast.sml +++ b/parse/ast.sml @@ -13,13 +13,6 @@ signature AST = sig type ident = Symbol.symbol - datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull - val typeeq : vtype * vtype -> bool - val castable : vtype * vtype -> bool (* true if the second type can be casted to the first implicitly *) - type variable = ident * vtype - datatype typedef = Struct of variable list - | MarkedTypedef of typedef Mark.marked - datatype oper = PLUS | MINUS @@ -53,9 +46,10 @@ sig | DerefMember of exp * ident | Dereference of exp | ArrIndex of exp * exp - | New of vtype - | NewArr of vtype * exp + | New of Type.vtype + | NewArr of Type.vtype * exp | Null + | Conditional of exp * exp * exp and stm = Assign of exp * exp | AsnOp of oper * exp * exp @@ -70,17 +64,16 @@ sig | MarkedStm of stm Mark.marked datatype function = - Extern of vtype * (variable list) - | Function of vtype * (variable list) * (variable list) * stm list + Extern of Type.vtype * (Type.variable list) + | Function of Type.vtype * (Type.variable list) * (Type.variable list) * stm list | MarkedFunction of function Mark.marked - type program = typedef Symbol.table * function Symbol.table + type program = Type.typedef Symbol.table * function Symbol.table (* print as source, with redundant parentheses *) structure Print : sig val pp_exp : exp -> string - val pp_type : vtype -> string val pp_stm : stm -> string val pp_program : program -> string end @@ -90,20 +83,6 @@ structure Ast :> AST = struct type ident = Symbol.symbol - datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull - fun typeeq (Int, Int) = true - | typeeq (Typedef a, Typedef b) = (Symbol.name a) = (Symbol.name b) - | typeeq (Pointer a, Pointer b) = typeeq (a, b) - | typeeq (Array a, Array b) = typeeq (a, b) - | typeeq (TNull, TNull) = true - | typeeq _ = false - fun castable (Pointer _, TNull) = true - | castable (Array _, TNull) = true - | castable (a, b) = typeeq (a, b) - type variable = ident * vtype - datatype typedef = Struct of variable list - | MarkedTypedef of typedef Mark.marked - datatype oper = PLUS | MINUS @@ -137,9 +116,10 @@ struct | DerefMember of exp * ident | Dereference of exp | ArrIndex of exp * exp - | New of vtype - | NewArr of vtype * exp + | New of Type.vtype + | NewArr of Type.vtype * exp | Null + | Conditional of exp * exp * exp and stm = Assign of exp * exp | AsnOp of oper * exp * exp @@ -154,11 +134,11 @@ struct | MarkedStm of stm Mark.marked datatype function = - Extern of vtype * (variable list) - | Function of vtype * (variable list) * (variable list) * stm list + Extern of Type.vtype * (Type.variable list) + | Function of Type.vtype * (Type.variable list) * (Type.variable list) * stm list | MarkedFunction of function Mark.marked - type program = typedef Symbol.table * function Symbol.table + type program = Type.typedef Symbol.table * function Symbol.table (* print programs and expressions in source form * using redundant parentheses to clarify precedence @@ -205,9 +185,10 @@ struct | pp_exp (DerefMember(e, i)) = pp_exp e ^ "->" ^ pp_ident i | pp_exp (Dereference(e)) = "*(" ^ pp_exp e ^ ")" | pp_exp (ArrIndex(e1, e2)) = pp_exp e1 ^ "[" ^pp_exp e2 ^ "]" - | pp_exp (New t) = "new(" ^ pp_type t ^ ")" - | pp_exp (NewArr (t, s)) = "new(" ^ pp_type t ^ "[" ^ pp_exp s ^ "])" + | pp_exp (New t) = "new(" ^ Type.Print.pp_type t ^ ")" + | pp_exp (NewArr (t, s)) = "new(" ^ Type.Print.pp_type t ^ "[" ^ pp_exp s ^ "])" | pp_exp Null = "NULL" + | pp_exp (Conditional (q, e1, e2)) = "("^(pp_exp q)^"?"^(pp_exp e1)^":"^(pp_exp e2)^")" and pp_expl nil = "" | pp_expl (e::a::l) = (pp_exp e) ^ ", " ^ (pp_expl (a::l)) @@ -240,27 +221,18 @@ struct and pp_stms nil = "" | pp_stms (s::ss) = pp_stm s ^ "\n" ^ pp_stms ss - - and pp_type Int = "int" - | pp_type (Typedef i) = pp_ident i - | pp_type (Pointer t) = pp_type t ^ "*" - | pp_type (Array t) = pp_type t ^ "[]" - | pp_type TNull = "{NULL type}" - + and pp_params nil = "" - | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ ", " ^ (pp_params (a::l)) - | pp_params ((i, t)::l) = (pp_ident i) ^ " : " ^ (pp_type t) ^ (pp_params l) + | pp_params ((i, t)::a::l) = (pp_ident i) ^ " : " ^ (Type.Print.pp_type t) ^ ", " ^ (pp_params (a::l)) + | pp_params ((i, t)::l) = (pp_ident i) ^ " : " ^ (Type.Print.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) + | pp_vars ((i, t)::l) = "var " ^ (pp_ident i) ^ " : " ^ (Type.Print.pp_type t) ^ ";\n" ^ (pp_vars l) - and pp_function (n, Extern(t, pl)) = "extern " ^ (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ");\n" - | pp_function (n, Function(t, pl, vl, stms)) = (pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ")\n{\n" ^ (pp_vars vl) ^ (String.concat (map pp_stm stms)) ^ "\n}\n" + and pp_function (n, Extern(t, pl)) = "extern " ^ (Type.Print.pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ");\n" + | pp_function (n, Function(t, pl, vl, stms)) = (Type.Print.pp_type t) ^ " " ^ (pp_ident n) ^ "(" ^ (pp_params pl) ^ ")\n{\n" ^ (pp_vars vl) ^ (String.concat (map pp_stm stms)) ^ "\n}\n" | pp_function (n, MarkedFunction d) = pp_function (n, Mark.data d) - - and pp_typedef (i, Struct (v)) = "struct " ^ (pp_ident i) ^ " {\n" ^ (String.concat (map (fn (i', t) => " " ^ (pp_ident i') ^ " : " ^ (pp_type t) ^ ";\n") v)) ^ "}\n" - | pp_typedef (i, MarkedTypedef d) = pp_typedef (i, Mark.data d) - - and pp_program (types, funs) = String.concat ((map pp_typedef (Symbol.elemsi types)) @ (map pp_function (Symbol.elemsi funs))) + + and pp_program (types, funs) = String.concat ((map Type.Print.pp_typedef (Symbol.elemsi types)) @ (map pp_function (Symbol.elemsi funs))) end end diff --git a/parse/astutils.sml b/parse/astutils.sml index 72bdaeb..7031e67 100644 --- a/parse/astutils.sml +++ b/parse/astutils.sml @@ -2,33 +2,22 @@ signature ASTUTILS = sig structure Program : sig - val append_typedef : Ast.program -> (Ast.ident * Ast.typedef) -> Ast.program + val append_typedef : Ast.program -> (Ast.ident * Type.typedef) -> Ast.program val append_function : Ast.program -> (Ast.ident * Ast.function) -> Ast.program end - - structure Typedef : - sig - val data : Ast.typedef -> Ast.typedef - val mark : Ast.typedef -> Mark.ext option - end - + structure Function : sig val data : Ast.function -> Ast.function val mark : Ast.function -> Mark.ext option - val returntype : Ast.function -> Ast.vtype - val params : Ast.function -> Ast.variable list - end - - structure Type : - sig - val size : Ast.vtype -> int - val issmall : Ast.vtype -> bool + val returntype : Ast.function -> Type.vtype + val params : Ast.function -> Type.variable list end end structure AstUtils :> ASTUTILS = struct + structure T = Type structure A = Ast structure Program = @@ -36,10 +25,10 @@ struct fun append_typedef (tds, fns) (i, td) = let val mark = case td - of A.MarkedTypedef m => Mark.ext m + of T.MarkedTypedef m => Mark.ext m | _ => NONE val _ = case (Symbol.look tds i) - of SOME (A.MarkedTypedef m) => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ; + of SOME (T.MarkedTypedef m) => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ; ErrorMsg.error (Mark.ext m) "(was originally defined here)" ; raise ErrorMsg.Error) | SOME _ => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ; @@ -64,16 +53,7 @@ struct (tds, Symbol.bind fns (i, func)) end end - - structure Typedef = - struct - fun data (A.MarkedTypedef m) = data (Mark.data m) - | data m = m - - fun mark (A.MarkedTypedef m) = Mark.ext m - | mark _ = NONE - end - + structure Function = struct fun data (A.MarkedFunction m) = data (Mark.data m) @@ -90,18 +70,5 @@ struct | params (A.Function (_, pl, _, _)) = pl | params (A.Extern (_, pl)) = pl end - - structure Type = - struct - fun size A.Int = 4 - | size (A.Typedef _) = raise ErrorMsg.InternalError "AU.Type.size on non-small type?" - | size (A.Pointer _) = 8 - | size (A.Array _) = 8 - | size A.TNull = 8 - - fun issmall A.Int = true - | issmall (A.Pointer _) = true - | issmall (A.Array _) = true - | issmall _ = false - end + end diff --git a/parse/l4.grm b/parse/l5.grm similarity index 88% rename from parse/l4.grm rename to parse/l5.grm index 3f14c33..7195271 100644 --- a/parse/l4.grm +++ b/parse/l5.grm @@ -1,5 +1,5 @@ -(* L4 Compiler - * L4 grammar +(* L5 Compiler + * L5 grammar * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning * Modified: Joshua Wise @@ -7,6 +7,7 @@ *) structure A = Ast +structure T = Type structure AU = AstUtils structure AUP = AstUtils.Program @@ -16,7 +17,7 @@ structure AUP = AstUtils.Program fun mark (e, (left, right)) = A.Marked (Mark.mark' (e, ParseState.ext (left, right))) fun markstm (e, (left, right)) = A.MarkedStm (Mark.mark' (e, ParseState.ext (left, right))) fun markfunction (e, (left, right)) = A.MarkedFunction (Mark.mark' (e, ParseState.ext (left, right))) -fun marktypedef (e, (left, right)) = A.MarkedTypedef (Mark.mark' (e, ParseState.ext (left, right))) +fun marktypedef (e, (left, right)) = T.MarkedTypedef (Mark.mark' (e, ParseState.ext (left, right))) (* create lval from expression; here just an id *) (* generates error if not an identifier *) @@ -27,7 +28,7 @@ fun make_lval (A.Var(id)) ext = id Symbol.bogus ) %% -%header (functor L4LrValsFn (structure Token : TOKEN)) +%header (functor L5LrValsFn (structure Token : TOKEN)) %term EOF @@ -42,7 +43,8 @@ fun make_lval (A.Var(id)) ext = id | LBRACE | RBRACE | LPAREN | RPAREN | UNARY | ASNOP (* dummy *) - | EXTERN | VAR | INT | COLON | COMMA | STRUCT | NULL | LBRACKET | RBRACKET | ARROW | DOT | NEW + | EXTERN | VAR | INT | QUESTION | COLON | COMMA | STRUCT | NULL | LBRACKET | RBRACKET | ARROW | DOT | NEW + | PLUSPLUS | MINUSMINUS %nonterm program of A.program @@ -59,17 +61,17 @@ fun make_lval (A.Var(id)) ext = id | simpoption of A.stm option | elseoption of A.stm list option | idents of A.ident list - | vtype of A.vtype + | vtype of T.vtype | decls of A.program | extdecl of A.ident * A.function - | paramlist of A.variable list - | param of A.variable - | typedecl of A.ident * A.typedef - | memberlist of (A.ident * A.vtype) list - | member of (A.ident * A.vtype) + | paramlist of T.variable list + | param of T.variable + | typedecl of T.ident * T.typedef + | memberlist of (T.ident * T.vtype) list + | member of (T.ident * T.vtype) | function of A.ident * A.function - | vardecl of A.variable list - | vardecls of A.variable list + | vardecl of T.variable list + | vardecls of T.variable list %verbose (* print summary of errors *) %pos int (* positions *) @@ -77,8 +79,9 @@ fun make_lval (A.Var(id)) ext = id %eop EOF %noshift EOF -%name L4 +%name L5 +%right QUESTION COLON %left LOGOR %left LOGAND %left BITOR @@ -99,11 +102,11 @@ program : programx (programx) programx : decls (decls) | programx function (AUP.append_function programx function) -vtype : INT (A.Int) - | IDENT (A.Typedef IDENT) - | vtype STAR (A.Pointer vtype) +vtype : INT (T.Int) + | IDENT (T.Typedef IDENT) + | vtype STAR (T.Pointer vtype) | vtype LBRACKET RBRACKET - (A.Array vtype) + (T.Array vtype) decls : (Symbol.empty, Symbol.empty) | typedecl decls (AUP.append_typedef decls typedecl) @@ -120,9 +123,9 @@ paramlist : param COMMA paramlist (param :: paramlist) param : IDENT COLON vtype (IDENT, vtype) typedecl : STRUCT IDENT LBRACE RBRACE SEMI - (IDENT, marktypedef (A.Struct ([]), (STRUCTleft, SEMIright))) + (IDENT, marktypedef (T.Struct ([]), (STRUCTleft, SEMIright))) | STRUCT IDENT LBRACE memberlist RBRACE SEMI - (IDENT, marktypedef (A.Struct (memberlist), (STRUCTleft, SEMIright))) + (IDENT, marktypedef (T.Struct (memberlist), (STRUCTleft, SEMIright))) memberlist : member memberlist (member :: memberlist) | member ([member]) @@ -154,6 +157,10 @@ simp : exp ASSIGN exp %prec ASNOP (A.Assign(exp1, exp2)) | exp asnop exp %prec ASNOP (A.AsnOp(asnop, exp1, exp2)) + | exp PLUSPLUS %prec ASNOP + (A.AsnOp(A.PLUS, exp, A.ConstExp(0w1))) + | exp MINUSMINUS %prec ASNOP + (A.AsnOp(A.MINUS, exp, A.ConstExp(0w1))) | exp (markstm (A.Effect (exp), (expleft, expright))) control : IF LPAREN exp RPAREN block elseoption @@ -212,6 +219,8 @@ exp : LPAREN exp RPAREN (exp) | 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))) + | exp QUESTION exp COLON exp + (mark (A.Conditional (exp1, exp2, exp3), (exp1left, exp3right))) explist : exp ([exp]) | exp COMMA explist (exp :: explist) diff --git a/parse/l4.lex b/parse/l5.lex similarity index 86% rename from parse/l4.lex rename to parse/l5.lex index b988c35..e10f8b7 100644 --- a/parse/l4.lex +++ b/parse/l5.lex @@ -1,4 +1,4 @@ -(* L4 Compiler +(* L5 Compiler * Lexer * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning @@ -41,6 +41,22 @@ in Tokens.INTNUM (Word32Signed.ZERO, yyp, yyp + size yyt) ) | SOME n => Tokens.INTNUM (n,yyp,yyp + size yyt) end + fun hexnumber (yyt, yyp) = + let + val t = String.extract (yyt, 2, NONE) + val ext = ParseState.ext (yyp, yyp + size yyt) + val numOpt = StringCvt.scanString (Word32.scan StringCvt.HEX) t + handle Overflow => + ( ErrorMsg.error ext + ("integral constant `" ^ yyt ^ "' too large") ; + NONE ) + in + case numOpt + of NONE => ( ErrorMsg.error ext + ("cannot parse integral constant `" ^ yyt ^ "'"); + Tokens.INTNUM (Word32Signed.ZERO, yyp, yyp + size yyt) ) + | SOME n => Tokens.INTNUM (n,yyp,yyp + size yyt) + end fun eof () = ( if (!commentLevel > 0) @@ -51,12 +67,13 @@ in end %% -%header (functor L4LexFn(structure Tokens : L4_TOKENS)); +%header (functor L5LexFn(structure Tokens : L5_TOKENS)); %full %s COMMENT COMMENT_LINE; id = [A-Za-z_][A-Za-z0-9_]*; decnum = [0-9][0-9]*; +hexnum = 0x[0-9a-fA-F][0-9a-fA-F]*; ws = [\ \t\012]; @@ -84,6 +101,9 @@ ws = [\ \t\012]; "^=" => (Tokens.BITXOREQ (yypos, yypos + size yytext)); "|=" => (Tokens.BITOREQ (yypos, yypos + size yytext)); + "++" => (Tokens.PLUSPLUS (yypos, yypos + size yytext)); + "--" => (Tokens.MINUSMINUS (yypos, yypos + size yytext)); + "+" => (Tokens.PLUS (yypos, yypos + size yytext)); "-" => (Tokens.MINUS (yypos, yypos + size yytext)); "!" => (Tokens.BANG (yypos, yypos + size yytext)); @@ -105,6 +125,7 @@ ws = [\ \t\012]; ">=" => (Tokens.GE (yypos, yypos + size yytext)); ">" => (Tokens.GT (yypos, yypos + size yytext)); + "?" => (Tokens.QUESTION (yypos, yypos + size yytext)); ":" => (Tokens.COLON (yypos, yypos + size yytext)); "," => (Tokens.COMMA (yypos, yypos + size yytext)); @@ -129,6 +150,7 @@ ws = [\ \t\012]; {decnum} => (number (yytext, yypos)); + {hexnum} => (hexnumber (yytext, yypos)); {id} => (let val id = Symbol.symbol yytext diff --git a/parse/parse.sml b/parse/parse.sml index 3786421..a2cc2fe 100644 --- a/parse/parse.sml +++ b/parse/parse.sml @@ -1,4 +1,4 @@ -(* L4 Compiler +(* L5 Compiler * Parsing * Author: Kaustuv Chaudhuri * Modified: Frank Pfenning @@ -17,10 +17,10 @@ end structure Parse :> PARSE = struct - structure L4LrVals = L4LrValsFn (structure Token = LrParser.Token) - structure L4Lex = L4LexFn (structure Tokens = L4LrVals.Tokens) - structure L4Parse = Join (structure ParserData = L4LrVals.ParserData - structure Lex = L4Lex + structure L5LrVals = L5LrValsFn (structure Token = LrParser.Token) + structure L5Lex = L5LexFn (structure Tokens = L5LrVals.Tokens) + structure L5Parse = Join (structure ParserData = L5LrVals.ParserData + structure Lex = L5Lex structure LrParser = LrParser) (* Main parsing function *) @@ -31,18 +31,18 @@ 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 - (L4Lex.makeLexer (fn _ => TextIO.input instream)) + (L5Lex.makeLexer (fn _ => TextIO.input instream)) (* 0 = no error correction, 15 = reasonable lookahead for correction *) - val (absyn, _) = L4Parse.parse(0, lexer, parseerror, ()) + val (absyn, _) = L5Parse.parse(0, lexer, parseerror, ()) val _ = if !ErrorMsg.anyErrors then raise ErrorMsg.Error else () in absyn end) - handle Fail s => ( ErrorMsg.error NONE ("lexer error: "^s) ; - raise ErrorMsg.Error ) - | LrParser.ParseError => raise ErrorMsg.Error (* always preceded by msg *) + handle (*L5Lex.LexError => ( ErrorMsg.error NONE "lexer 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/sources.cm b/sources.cm index 351df5f..5fdb4c7 100644 --- a/sources.cm +++ b/sources.cm @@ -3,6 +3,8 @@ Group is $/smlnj-lib.cm $/ml-yacc-lib.cm + top/smlnj-specific.sml + util/mark.sml util/flag.sml util/symbol.sml @@ -10,29 +12,38 @@ Group is util/safe-io.sml util/word32.sml + top/flags.sml + + type/type.sml parse/ast.sml parse/astutils.sml parse/parsestate.sml - parse/l4.lex - parse/l4.grm + parse/l5.lex + parse/l5.grm parse/parse.sml type/typechecker.sml trans/temp.sml - trans/label.sml trans/tree.sml + trans/treeutils.sml trans/trans.sml codegen/x86.sml codegen/codegen.sml + codegen/liveness.sml codegen/igraph.sml codegen/colororder.sml codegen/solidify.sml codegen/coloring.sml codegen/stringifier.sml - codegen/peephole.sml - codegen/liveness.sml + + optimize/optimizer.sml + optimize/constfold.sml + optimize/feckful.sml + optimize/labelcoalescing.sml + optimize/peephole.sml + optimize/stupidfunc.sml top/top.sml diff --git a/sources.mlb b/sources.mlb index 0f45274..63f9acf 100644 --- a/sources.mlb +++ b/sources.mlb @@ -2,6 +2,8 @@ $(SML_LIB)/basis/basis.mlb $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb + top/mlton-specific.sml + util/mark.sml util/flag.sml util/symbol.sml @@ -9,12 +11,15 @@ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb util/safe-io.sml util/word32.sml + top/flags.sml + + type/type.sml parse/ast.sml parse/astutils.sml parse/parsestate.sml - parse/l4.grm.sig - parse/l4.grm.sml - parse/l4.lex.sml + parse/l5.grm.sig + parse/l5.grm.sml + parse/l5.lex.sml parse/parse.sml type/typechecker.sml @@ -22,18 +27,24 @@ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb trans/temp.sml trans/label.sml trans/tree.sml + trans/treeutils.sml trans/trans.sml codegen/x86.sml + codegen/codegen.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 + optimize/optimizer.sml + optimize/constfold.sml + optimize/feckful.sml + optimize/labelcoalescing.sml + optimize/peephole.sml + optimize/stupidfunc.sml - top/top_mlton.sml \ No newline at end of file + top/top.sml + top/top_mlton.sml diff --git a/top/flags.sml b/top/flags.sml new file mode 100644 index 0000000..2017230 --- /dev/null +++ b/top/flags.sml @@ -0,0 +1,28 @@ +signature FLAGS = +sig + val verbose : Flag.flag + val liveness : Flag.flag + val ast : Flag.flag + val ir : Flag.flag + val assem : Flag.flag + val color : Flag.flag + val safe : Flag.flag + + val reset : unit -> unit (* Anus... *) +end + +structure Flags :> FLAGS = +struct + val verbose = Flag.flag "verbose" + val liveness = Flag.flag "liveness" + val ast = Flag.flag "ast" + val ir = Flag.flag "ir" + val assem = Flag.flag "assem" + val color = Flag.flag "color" + val safe = Flag.flag "safe" + + fun reset () = + (List.app Flag.unset [verbose, ast, + ir, assem, liveness, safe]) +end + \ No newline at end of file diff --git a/top/mlton-specific.sml b/top/mlton-specific.sml new file mode 100644 index 0000000..e37b093 --- /dev/null +++ b/top/mlton-specific.sml @@ -0,0 +1,11 @@ +signature SUQ = +sig + val Word32_lsh : Word32.word * Word32.word -> Word32.word + val Word32_rsh : Word32.word * Word32.word -> Word32.word +end + +structure Suq :> SUQ = +struct + fun Word32_lsh (a, b) = Word32.<< (a, b) + fun Word32_rsh (a, b) = Word32.~>> (a, b) +end \ No newline at end of file diff --git a/top/smlnj-specific.sml b/top/smlnj-specific.sml new file mode 100644 index 0000000..e57cae6 --- /dev/null +++ b/top/smlnj-specific.sml @@ -0,0 +1,12 @@ +signature SUQ = +sig + val Word32_lsh : Word32.word * Word32.word -> Word32.word + val Word32_rsh : Word32.word * Word32.word -> Word32.word +end + +structure Suq :> SUQ = +struct + fun loseBit (x: Word32.word) : word = Word31.fromInt (Word32.toInt x) + fun Word32_lsh (a, b) = Word32.<< (a, loseBit b) + fun Word32_rsh (a, b) = Word32.~>> (a, loseBit b) +end diff --git a/top/top.sml b/top/top.sml index c350c09..4b58d00 100644 --- a/top/top.sml +++ b/top/top.sml @@ -27,38 +27,61 @@ struct fun newline () = TextIO.output (TextIO.stdErr, "\n") exception EXIT + + val alloptimizations = + [ConstantFold.optimizer, + StupidFunctionElim.optimizer, + FeckfulnessAnalysis.optimizer, + ConstantFold.optimizer, + LabelCoalescing.optimizer, + Peephole.optimizer] + + val uniqopts = + foldr + (fn (opt : Optimizer.optimization, l) => + if (List.exists (fn (x : Optimizer.optimization) => (#shortname opt) = (#shortname x)) l) + then l + else opt :: l) + [] + alloptimizations - (* see flag explanations below *) - val flag_verbose = Flag.flag "verbose" - val flag_liveness = Flag.flag "liveness" - 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, - flag_ir, flag_assem, flag_liveness]; + val enabledopts = ref alloptimizations val options = [{short = "v", long=["verbose"], - desc=G.NoArg (fn () => Flag.set flag_verbose), + desc=G.NoArg (fn () => Flag.set Flags.verbose), help="verbose messages"}, {short = "a", long=["dump-ast"], - desc=G.NoArg (fn () => Flag.set flag_ast), + desc=G.NoArg (fn () => Flag.set Flags.ast), help="pretty print the AST"}, {short = "i", long=["dump-ir"], - desc=G.NoArg (fn () => Flag.set flag_ir), + desc=G.NoArg (fn () => Flag.set Flags.ir), help="pretty print the IR"}, {short = "l", long=["dump-liveness"], - desc=G.NoArg (fn () => Flag.set flag_liveness), + desc=G.NoArg (fn () => Flag.set Flags.liveness), help="pretty print the liveness results"}, {short = "s", long=["dump-assem"], - desc=G.NoArg (fn () => Flag.set flag_assem), + desc=G.NoArg (fn () => Flag.set Flags.assem), 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"} - ] + desc=G.NoArg (fn () => Flag.set Flags.color), + help="pretty print the allocated regs"}, + {short = "", long=["safe"], + desc=G.NoArg (fn () => Flag.set Flags.safe), + help="enable memory-safety"}, + {short = "", long=["unsafe"], + desc=G.NoArg (fn () => Flag.unset Flags.safe), + help="disable memory-safety"}, + {short = "", long = ["disable-all"], + desc=G.NoArg (fn () => enabledopts := nil), + help="disable all optimizations"} + ] @ + map + (fn (opt : Optimizer.optimization) => + { short = "", long=["disable-" ^ (#shortname opt)], + desc = G.NoArg (* This is nasty. *) + (fn () => enabledopts := List.filter (fn x => (#shortname x) <> (#shortname opt)) (!enabledopts)), + help = "disable optimization: " ^ (#description opt) }) + uniqopts fun stem s = @@ -73,27 +96,30 @@ struct fun processir externs (Tree.FUNCTION (id, ir)) = let - val name = "_l4_" ^ (Symbol.name id) + val name = "_l5_" ^ (Symbol.name id) fun realname s = if (List.exists (fn n => s = n) externs) then s - else "_l4_" ^ s + else "_l5_" ^ s - val _ = Flag.guard flag_verbose say ("Processing function: " ^ name) + val _ = Flag.guard Flags.verbose say ("Processing function: " ^ name) - val _ = Flag.guard flag_verbose say " Generating proto-x86_64 code..." + val _ = Flag.guard Flags.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 Flags.assem + (fn () => List.app (TextIO.print o (x86.print)) assem) () - val _ = Flag.guard flag_verbose say " Analyzing liveness..." + val _ = Flag.guard Flags.verbose say " Optimizing pre-liveness..." + val assem = Optimizer.optimize_preliveness (!enabledopts) assem + + val _ = Flag.guard Flags.verbose say " Analyzing liveness..." val (preds, liveness) = Liveness.liveness assem; - val _ = Flag.guard flag_liveness + val _ = Flag.guard Flags.liveness (fn () => List.app (fn (asm, liv) => TextIO.print ( let - val xpp = x86.prettyprint asm + val xpp = x86.print 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 @@ -104,32 +130,32 @@ struct end)) (ListPair.zip (assem, Liveness.listify liveness))) () - val _ = Flag.guard flag_verbose say " Graphing..." + val _ = Flag.guard Flags.verbose say " Graphing..." val (igraph,temps) = Igraph.gengraph (preds, liveness) - val _ = Flag.guard flag_verbose say " Ordering..." + val _ = Flag.guard Flags.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 + val _ = Flag.guard Flags.verbose say " Coloring..." + val colors = Colorizer.colorize order igraph + val _ = Flag.guard Flags.color (fn () => List.app (TextIO.print o (fn (t, i) => (Temp.name t) ^ " => " ^ ( if (i <= x86.regtonum x86.R13D) - then (x86.prettyprint_oper x86.Long (x86.REG (x86.numtoreg i))) + then (x86.pp_oper (x86.REG (x86.numtoreg i), Temp.Long)) else "spill[" ^ Int.toString (i - x86.regtonum x86.R13D) ^ "]") ^ "--"^ Int.toString i ^ "\n")) colors) () - val _ = Flag.guard flag_verbose say " Solidifying x86_64 code..." - val x86 = Solidify.solidify colors assem; + val _ = Flag.guard Flags.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 Flags.verbose say " Optimizing final assembly..." + val x86p = Optimizer.optimize_final (!enabledopts) x86 - val _ = Flag.guard flag_verbose say " Stringifying..." + val _ = Flag.guard Flags.verbose say " Stringifying..." val x86d = [x86.DIRECTIVE(".globl " ^ name), x86.DIRECTIVE(name ^ ":")] @ x86p @@ -145,7 +171,7 @@ struct fun errfn msg = (say (msg ^ "\n" ^ usageinfo) ; raise EXIT) val _ = Temp.reset (); (* reset temp variable counter *) - val _ = reset_flags (); (* return all flags to default value *) + val _ = Flags.reset (); (* return all flags to default value *) val _ = if List.length args = 0 then (say usageinfo; raise EXIT) @@ -163,10 +189,12 @@ struct | [filename] => filename | _ => errfn "Error: more than one input file" - val _ = Flag.guard flag_verbose say ("Parsing... " ^ source) + val _ = Flag.guard Flags.verbose say ("Enabled optimizations: " ^ String.concat (map (fn x => (#shortname x) ^ " ") (!enabledopts))) + + val _ = Flag.guard Flags.verbose say ("Parsing... " ^ source) val ast = Parse.parse source val (_, funcs) = ast - val _ = Flag.guard flag_ast + val _ = Flag.guard Flags.ast (fn () => say (Ast.Print.pp_program ast)) () val externs = Symbol.mapPartiali @@ -175,18 +203,23 @@ struct | _ => NONE ) funcs - val _ = Flag.guard flag_verbose say "Checking..." + val _ = Flag.guard Flags.verbose say "Checking..." val ast = TypeChecker.typecheck ast - val _ = Flag.guard flag_verbose say "Translating..." + val _ = Flag.guard Flags.verbose say "Translating..." val ir = Trans.translate ast - val _ = Flag.guard flag_ir (fn () => say (Tree.Print.pp_program ir)) () - + val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) () + + val _ = Flag.guard Flags.verbose say "Optimizing whole-program IR..." + val ir = Optimizer.optimize_ir (!enabledopts) ir + val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) () + val output = foldr (fn (func, code) => (processir ("calloc" (* lololololol *) :: (Symbol.elems externs)) func) ^ code) - (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 L4 compiler by czl@ and jwise@\"\n") ir + (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 ASS compiler by czl@ and jwise@\"\n" ^ + ".ident \"Optimizations enabled: " ^ String.concat (map (fn x => (#shortname x) ^ " ") (!enabledopts)) ^ "\"\n") ir val afname = stem source ^ ".s" - val _ = Flag.guard flag_verbose say ("Writing assembly to " ^ afname ^ " ...") + val _ = Flag.guard Flags.verbose say ("Writing assembly to " ^ afname ^ " ...") val _ = SafeIO.withOpenOut afname (fn afstream => TextIO.output (afstream, output)) in diff --git a/trans/temp.sml b/trans/temp.sml index 1092dfc..bd311c4 100644 --- a/trans/temp.sml +++ b/trans/temp.sml @@ -8,18 +8,23 @@ signature TEMP = sig type temp + datatype size = Byte | Word | Long | Quad - val reset : unit -> unit (* resets temp numbering *) - val new : string -> int -> temp (* returns a unique new temp *) - val name : temp -> string (* returns the name of a temp *) - val size : temp -> int (* returns the size of a temp *) + val reset : unit -> unit (* resets temp numbering *) + val new : string -> size -> temp (* returns a unique new temp *) + val name : temp -> string (* returns the name of a temp *) + val size : temp -> size (* returns the size of a temp *) val compare : temp * temp -> order (* comparison function *) val eq : temp * temp -> bool + val cmpsize : size * size -> order + val sfx : size -> string + val sts : int -> size end structure Temp :> TEMP = struct - type temp = int * string * int + datatype size = Byte | Word | Long | Quad + type temp = int * string * size local val counter = ref 1 @@ -29,9 +34,32 @@ struct fun new str size = (!counter, str, size) before ( counter := !counter + 1 ) end - fun name (t,s, sz) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]" + fun sfx Byte = "b" + | sfx Word = "w" + | sfx Long = "l" + | sfx Quad = "q" + + fun name (t,s, sz) = "+t" ^ Int.toString t ^ "[" ^ s ^ "]" ^ sfx sz fun size (t, s, sz) = sz fun compare ((t1,_,_),(t2,_,_)) = Int.compare (t1,t2) fun eq ((t1,_,_), (t2,_,_)) = t1 = t2 + + fun cmpsize (Quad,Quad) = EQUAL + | cmpsize (Quad,_) = GREATER + | cmpsize (_,Quad) = LESS + | cmpsize (Long,Long) = EQUAL + | cmpsize (Long,_) = GREATER + | cmpsize (_,Long) = LESS + | cmpsize (Word,Word) = EQUAL + | cmpsize (Word,_) = GREATER + | cmpsize (_,Word) = LESS + | cmpsize (Byte,Byte) = EQUAL + + fun sts 8 = Quad + | sts 4 = Long + | sts 2 = Word + | sts 1 = Byte + | sts _ = raise ErrorMsg.InternalError "Temp.sts: invalid size" + end diff --git a/trans/trans.sml b/trans/trans.sml index 6148ce8..7c70af1 100644 --- a/trans/trans.sml +++ b/trans/trans.sml @@ -10,14 +10,13 @@ signature TRANS = sig (* translate abstract syntax tree to IR tree *) - val translate : Ast.program -> Tree.func list + val translate : Ast.program -> Tree.program end structure Trans :> TRANS = struct structure A = Ast - structure AU = AstUtils structure T = Tree fun trans_oper A.PLUS = T.ADD @@ -43,72 +42,24 @@ struct fun translate (defs, funcs) = let val funclist = Symbol.elemsi funcs + val _ = Type.alignment_reset() + val _ = Type.sizeof_reset() + fun sizeof a = Type.sizeof defs a + fun alignment a = Type.alignment defs a + fun align t curpos = Type.align defs t curpos - val alignments = ref Symbol.empty (* Ref for memoization. *) - fun alignment A.Int = 4 - | alignment (A.Typedef(id)) = - (case Symbol.look (!alignments) id - of NONE => - let - val r = alignment_s (Symbol.look' defs id) - val _ = (alignments := (Symbol.bind (!alignments) (id, r))) - in - r - end - | SOME r => r) - | alignment (A.Pointer(_)) = 8 - | alignment (A.Array(_)) = 8 - | alignment (A.TNull) = raise ErrorMsg.InternalError "alignmentof TNull?" - and alignment_s (A.Struct(members)) = - foldl - (fn ((_,t),al) => Int.max (al, alignment t)) - 1 - members - | alignment_s (A.MarkedTypedef(a)) = alignment_s (Mark.data a) - - fun align t curpos = - let - val al = alignment t - in - if (curpos mod al) = 0 - then curpos - else curpos + al - (curpos mod al) - end - - val sizes = ref Symbol.empty - fun sizeof_v A.Int = 4 - | sizeof_v (A.Typedef(id)) = - (case Symbol.look (!sizes) id - of NONE => - let - val r = sizeof_s (Symbol.look' defs id) - val _ = (sizes := (Symbol.bind (!sizes) (id, r))) - in - r - end - | SOME r => r) - | sizeof_v (A.Pointer(_)) = 8 - | sizeof_v (A.Array(_)) = 8 - | sizeof_v (A.TNull) = raise ErrorMsg.InternalError "sizeof TNull?" - and sizeof_s (A.Struct(l)) = - foldl - (fn ((_,t),curpos) => align t curpos + sizeof_v t) - 0 - l - | sizeof_s (A.MarkedTypedef(a)) = sizeof_s (Mark.data a) - - fun offset_s id (A.Typedef(id')) = + fun offset_s id (Type.Typedef(id')) = let val shit = Symbol.look' defs id' - fun eat (A.Struct(l)) = l - | eat (A.MarkedTypedef(a)) = eat (Mark.data a) + fun eat (Type.Struct(l)) = l + | eat (Type.MarkedTypedef(a)) = eat (Mark.data a) fun offset_s' ((id1,t)::l') curofs = let val a = align t curofs in if Symbol.compare(id,id1) = EQUAL then a - else offset_s' l' (a + sizeof_v t) + else offset_s' l' (a + sizeof t) end | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure" in @@ -116,11 +67,11 @@ struct end | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef" - fun type_s id (A.Typedef id') = + fun type_s id (Type.Typedef id') = let val td = - case AU.Typedef.data (Symbol.look' defs id') - of A.Struct d => d + case Type.defdata (Symbol.look' defs id') + of Type.Struct d => d | _ => raise ErrorMsg.InternalError "data didn't return struct" fun type_s' ((id',t)::l) = if (Symbol.compare (id, id') = EQUAL) @@ -132,8 +83,8 @@ struct end | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef" - fun deref (A.Pointer i) = i - | deref (A.Array i) = i + fun deref (Type.Pointer i) = i + | deref (Type.Array i) = i | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer" fun trans_unop A.NEGATIVE = T.NEG @@ -158,38 +109,80 @@ struct | trans_exp env vartypes (A.FuncCall(func, stms)) = T.CALL(func, List.map - (fn exp => (trans_exp env vartypes exp, AU.Type.size (typeof' vartypes exp))) + (fn exp => (trans_exp env vartypes exp, Temp.sts (Type.size (typeof' vartypes exp)))) stms, - AU.Type.size (AU.Function.returntype (Symbol.look' funcs func)) ) + Temp.sts (Type.size (AstUtils.Function.returntype (Symbol.look' funcs func)))) | trans_exp env vartypes (A.Member (exp, id)) = let val apk = T.BINOP (T.ADD, trans_exp env vartypes exp, T.CONST (Word32.fromInt (offset_s id (typeof' vartypes exp)))) + val tipo = type_s id (typeof' vartypes exp) in - if (AU.Type.issmall (type_s id (typeof' vartypes exp))) - then T.MEMORY(apk) + if Type.issmall tipo + then T.MEMORY(apk, Temp.sts (Type.size tipo)) else apk end | trans_exp env vartypes (A.DerefMember (exp, id)) = trans_exp env vartypes (A.Member (A.Dereference (exp), id)) | trans_exp env vartypes (A.Dereference(exp)) = - if (AU.Type.issmall (deref (typeof' vartypes exp))) - then T.MEMORY(trans_exp env vartypes exp) + if (Type.issmall (deref (typeof' vartypes exp))) + then T.MEMORY(trans_exp env vartypes exp, Temp.sts (Type.size (deref (typeof' vartypes exp)))) else trans_exp env vartypes exp | trans_exp env vartypes (A.ArrIndex(exp1, exp2)) = let val asubk = T.BINOP(T.ADD, trans_exp env vartypes exp1, T.BINOP(T.MUL, trans_exp env vartypes exp2, - T.CONST(Word32.fromInt(sizeof_v (deref (typeof' vartypes exp1)))))) + T.CONST(Word32.fromInt(sizeof (deref (typeof' vartypes exp1)))))) + val tipo = deref (typeof' vartypes exp1) + val d = + if not (Flag.isset Flags.safe) + then asubk + else T.COND (T.BINOP + (T.BE, + T.MEMORY (T.BINOP ( + T.SUB, + trans_exp env vartypes exp1, + T.CONST 0w8), Temp.Long), + trans_exp env vartypes exp2), + T.NULLPTR, + asubk) in - if (AU.Type.issmall (deref (typeof' vartypes exp1))) - then T.MEMORY(asubk) - else asubk + if Type.issmall tipo + then T.MEMORY(d, Temp.sts (Type.size tipo)) + else d end | trans_exp env vartypes (A.New(tipo)) = - T.ALLOC(T.CONST (Word32.fromInt(sizeof_v tipo))) + let + val t1 = T.TEMP (Temp.new "result" Temp.Quad) + in + T.STMVAR ( + [T.MOVE (t1, T.ALLOC (T.CONST (Word32.fromInt(sizeof tipo)))), + T.EFFECT (T.MEMORY (t1, Temp.Long))], + t1) + end | trans_exp env vartypes (A.NewArr(tipo, exp)) = - T.ALLOC(T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof_v tipo)))) - | trans_exp env vartypes (A.Null) = T.CONST(0w0) + let + val size = T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof tipo))) + val t1 = T.TEMP (Temp.new "allocated address" Temp.Quad) + val ts = T.TEMP (Temp.new "size" Temp.Long) + in + if not (Flag.isset Flags.safe) + then T.STMVAR ([T.MOVE (t1, T.ALLOC size), + T.EFFECT (T.COND (T.BINOP (T.EQ, trans_exp env vartypes exp, T.CONST 0w0), T.CONST 0w0, T.MEMORY (t1, Temp.Long)))], + t1) + else T.COND (T.BINOP(T.EQ, size, T.CONST 0w0), + T.NULLPTR, + T.STMVAR ( + [T.MOVE(t1, + T.COND( + T.BINOP(T.LT, size, T.CONST 0w0), + T.NULLPTR, + T.ALLOC (T.BINOP (T.ADD, size, T.CONST 0w8))) + ), + T.MOVE(T.MEMORY (t1, Temp.Long), trans_exp env vartypes exp)], + T.BINOP(T.ADD, t1, T.CONST 0w8))) + end + | trans_exp env vartypes (A.Null) = T.NULLPTR + | trans_exp env vartypes (A.Conditional(c,e1,e2)) = T.COND(trans_exp env vartypes c, trans_exp env vartypes e1, trans_exp env vartypes e2) (* anything else should be impossible *) @@ -198,23 +191,22 @@ struct * we pass around the environment and the current loop context, if any * (usually called ls, which contains a continue label and a break label) *) - fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2, AU.Type.size (typeof' vartypes e2))::(trans_stms vars vartypes ls stms) + fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2)::(trans_stms vars vartypes ls stms) | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) = let val te1 = trans_exp vars vartypes e1 val te2 = trans_exp vars vartypes e2 - val t1 = T.TEMP (Temp.new "memory deref cache" 8) - val size = AU.Type.size (typeof' vartypes e2) + val t1 = T.TEMP (Temp.new "memory deref cache" Temp.Quad) in case te1 - of T.MEMORY(m) => T.MOVE(t1, m, 8) :: T.MOVE (T.MEMORY(t1), T.BINOP(trans_oper oop, T.MEMORY(t1), te2), size) :: (trans_stms vars vartypes ls stms) - | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2), size) :: (trans_stms vars vartypes ls stms) + of T.MEMORY(m,s) => T.MOVE(t1, m) :: T.MOVE (T.MEMORY(t1,s), T.BINOP(trans_oper oop, T.MEMORY(t1,s), te2)) :: (trans_stms vars vartypes ls stms) + | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2)) :: (trans_stms vars vartypes ls stms) end | trans_stms vars vartypes ls (A.Return e::stms) = let val remainder = trans_stms vars vartypes ls stms in - T.RETURN (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e)) + T.RETURN (trans_exp vars vartypes e, Temp.sts (Type.size (typeof' vartypes e))) :: remainder end | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) = @@ -274,7 +266,7 @@ struct @ [T.JUMP head, T.LABEL tail] @ remainder) end - | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))) :: (trans_stms vars vartypes ls stms) + | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e)) :: (trans_stms vars vartypes ls stms) | trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) = let val remainder = trans_stms vars vartypes (SOME(b,e)) stms @@ -299,7 +291,7 @@ struct let val allvars = foldr (fn ((name, t),b) => - Symbol.bind b (name, Temp.new (Symbol.name(name)) (AU.Type.size t))) + Symbol.bind b (name, Temp.new (Symbol.name(name)) (Temp.sts (Type.size t)))) Symbol.empty (args @ vars) val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars) @@ -307,7 +299,7 @@ struct 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, Temp.size (Symbol.look' allvars argname)), Temp.size (Symbol.look' allvars argname))) + (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n, Temp.size (Symbol.look' allvars argname)))) numberedargs in (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l) diff --git a/trans/tree.sml b/trans/tree.sml index d3e8c0d..dbd0efc 100644 --- a/trans/tree.sml +++ b/trans/tree.sml @@ -9,8 +9,7 @@ signature TREE = sig - - datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE + datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE | BE datatype unop = NEG | BITNOT | BANG type Blarg = int @@ -18,16 +17,19 @@ sig datatype exp = CONST of Word32.word | TEMP of Temp.temp - | ARG of Blarg * int (* I am j4cbo *) + | ARG of Blarg * Temp.size (* I am j4cbo *) | BINOP of binop * exp * exp | UNOP of unop * exp - | CALL of Ast.ident * (exp * int) list * int - | MEMORY of exp + | CALL of Ast.ident * (exp * Temp.size) list * Temp.size + | MEMORY of exp * Temp.size | ALLOC of exp + | COND of exp * exp * exp + | STMVAR of stm list * exp + | NULLPTR and stm = - MOVE of exp * exp * int - | RETURN of exp * int - | EFFECT of exp * int + MOVE of exp * exp + | RETURN of exp * Temp.size + | EFFECT of exp | LABEL of Label.label | JUMPIFN of exp * Label.label | JUMP of Label.label @@ -35,19 +37,11 @@ sig FUNCTION of Ast.ident * stm list type program = func list - - structure Print : - sig - val pp_exp : exp -> string - val pp_stm : stm -> string - val pp_program : program -> string - end end structure Tree :> TREE = struct - - datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE + datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE | BE datatype unop = NEG | BITNOT | BANG type Blarg = int @@ -55,16 +49,19 @@ struct datatype exp = CONST of Word32.word | TEMP of Temp.temp - | ARG of Blarg * int + | ARG of Blarg * Temp.size (* I am j4cbo *) | BINOP of binop * exp * exp | UNOP of unop * exp - | CALL of Ast.ident * (exp * int) list * int - | MEMORY of exp + | CALL of Ast.ident * (exp * Temp.size) list * Temp.size + | MEMORY of exp * Temp.size | ALLOC of exp + | COND of exp * exp * exp + | STMVAR of stm list * exp + | NULLPTR and stm = - MOVE of exp * exp * int - | RETURN of exp * int - | EFFECT of exp * int + MOVE of exp * exp + | RETURN of exp * Temp.size + | EFFECT of exp | LABEL of Label.label | JUMPIFN of exp * Label.label | JUMP of Label.label @@ -72,65 +69,4 @@ struct FUNCTION of Ast.ident * stm list type program = func list - - structure Print = - struct - - exception Aaaasssssss - - fun pp_binop ADD = "+" - | pp_binop SUB = "-" - | pp_binop MUL = "*" - | pp_binop DIV = "/" - | pp_binop MOD = "%" - | pp_binop LSH = "<<" - | pp_binop RSH = ">>" - | pp_binop LOGOR = "||" - | pp_binop LOGAND = "&&" - | pp_binop BITOR = "|" - | pp_binop BITAND = "&" - | pp_binop BITXOR = "^" - | pp_binop NEQ = "!=" - | pp_binop EQ = "==" - | pp_binop LE = "<=" - | pp_binop LT = "<" - | pp_binop GE = ">=" - | pp_binop GT = ">" - - fun pp_unop NEG = "-" - | pp_unop BITNOT = "~" - | pp_unop BANG = "!" - - fun pp_exp (CONST(x)) = Word32Signed.toString x - | pp_exp (TEMP(t)) = Temp.name t - | pp_exp (ARG(n, sz)) = "arg#"^Int.toString n - | pp_exp (BINOP (binop, e1, e2)) = - "(" ^ pp_exp e1 ^ " " ^ pp_binop binop ^ " " ^ pp_exp e2 ^ ")" - | pp_exp (UNOP (unop, e1)) = - pp_unop unop ^ "(" ^ pp_exp e1 ^ ")" - | pp_exp (CALL (f, l, sz)) = - Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map (fn (e, _) => pp_exp e) l)) ^ ")" - | pp_exp (MEMORY exp) = "M[" ^ pp_exp exp ^ "]" - | pp_exp (ALLOC(e)) = "NEW(" ^ pp_exp e ^ ")" - - fun pp_stm (MOVE (e1,e2, sz)) = - pp_exp e1 ^ " <-- " ^ pp_exp e2 - | pp_stm (RETURN (e, sz)) = - "return " ^ pp_exp e - | pp_stm (EFFECT (e, sz)) = pp_exp e - | pp_stm (LABEL l) = - Label.name l ^ ":" - | pp_stm (JUMP l) = - "jump "^Label.name l - | pp_stm (JUMPIFN (e, l)) = - "jump "^Label.name l^" if! "^pp_exp e - - fun pp_program (nil) = "" - | 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/trans/treeutils.sml b/trans/treeutils.sml new file mode 100644 index 0000000..b5217b0 --- /dev/null +++ b/trans/treeutils.sml @@ -0,0 +1,104 @@ +signature TREEUTILS = +sig + val effect : Tree.exp -> bool + val effect_stm : Tree.stm -> bool + + structure Print : + sig + val pp_exp : Tree.exp -> string + val pp_stm : Tree.stm -> string + val pp_program : Tree.program -> string + end +end + +structure TreeUtils :> TREEUTILS = +struct + structure T = Tree + + (* effect : T.exp -> bool + * true iff the given expression has an effect. + *) + fun effect (T.CONST _) = false + | effect (T.TEMP _) = false + | effect (T.ARG _) = false + | 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 (T.MEMORY _) = true + | effect (T.ALLOC _) = true + | effect (T.COND (a, b, c)) = (effect a) orelse (effect b) orelse (effect c) + | effect (T.STMVAR (sl, e)) = true (* Has to be, to be safe <--- jwise is an assclown, he was too lazy to write a effect_stm *) + | effect (T.NULLPTR) = false + + fun effect_stm (T.MOVE (e1,e2)) = effect e1 orelse effect e2 + | effect_stm (T.RETURN (e1,e2)) = effect e1 orelse effect e1 + | effect_stm (T.EFFECT e) = effect e + | effect_stm (T.JUMPIFN (e,_)) = effect e + | effect_stm _ = false + + structure Print = + struct + exception Aaaasssssss + + fun pp_binop T.ADD = "+" + | pp_binop T.SUB = "-" + | pp_binop T.MUL = "*" + | pp_binop T.DIV = "/" + | pp_binop T.MOD = "%" + | pp_binop T.LSH = "<<" + | pp_binop T.RSH = ">>" + | pp_binop T.LOGOR = "||" + | pp_binop T.LOGAND = "&&" + | pp_binop T.BITOR = "|" + | pp_binop T.BITAND = "&" + | pp_binop T.BITXOR = "^" + | pp_binop T.NEQ = "!=" + | pp_binop T.EQ = "==" + | pp_binop T.LE = "<=" + | pp_binop T.LT = "<" + | pp_binop T.GE = ">=" + | pp_binop T.GT = ">" + | pp_binop T.BE = "[BE]" + + fun pp_unop T.NEG = "-" + | pp_unop T.BITNOT = "~" + | pp_unop T.BANG = "!" + + fun pp_exp (T.CONST(x)) = Word32Signed.toString x + | pp_exp (T.TEMP(t)) = Temp.name t + | pp_exp (T.ARG(n, sz)) = "arg#"^Int.toString n + | pp_exp (T.BINOP (binop, e1, e2)) = + "(" ^ pp_exp e1 ^ " " ^ pp_binop binop ^ " " ^ pp_exp e2 ^ ")" + | pp_exp (T.UNOP (unop, e1)) = + pp_unop unop ^ "(" ^ pp_exp e1 ^ ")" + | pp_exp (T.CALL (f, l, sz)) = + Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map (fn (e, _) => pp_exp e) l)) ^ ")" + | pp_exp (T.MEMORY (exp, sz)) = "M(" ^ Temp.sfx sz ^ ")[" ^ pp_exp exp ^ "]" + | pp_exp (T.ALLOC(e)) = "NEW(" ^ pp_exp e ^ ")" + | pp_exp (T.COND(c,e1,e2)) = "(" ^ pp_exp c ^ ") ? (" ^ pp_exp e1 ^ ") : (" ^ pp_exp e2 ^ ")" + | pp_exp (T.STMVAR(sl,v)) = "({" ^ (foldr (fn (st,s) => (pp_stm st) ^ "; " ^ s) "" sl) ^ (pp_exp v) ^ "})" + | pp_exp (T.NULLPTR) = "NULL" + + and pp_stm (T.MOVE (e1,e2)) = + pp_exp e1 ^ " <-- " ^ pp_exp e2 + | pp_stm (T.RETURN (e, sz)) = + "return " ^ pp_exp e + | pp_stm (T.EFFECT e) = pp_exp e + | pp_stm (T.LABEL l) = + Label.name l ^ ":" + | pp_stm (T.JUMP l) = + "jump "^Label.name l + | pp_stm (T.JUMPIFN (e, l)) = + "jump "^Label.name l^" if! "^pp_exp e + + fun pp_program (nil) = "" + | pp_program (T.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/type.sml b/type/type.sml new file mode 100644 index 0000000..69f35f8 --- /dev/null +++ b/type/type.sml @@ -0,0 +1,143 @@ +signature TYPE = +sig + type ident = Symbol.symbol + datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull + type variable = ident * vtype + datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list + + val typeeq : vtype * vtype -> bool + val castable : vtype * vtype -> bool + val size : vtype -> int + val sizeof : typedef Symbol.table -> vtype -> int + val sizeof_reset : unit -> unit + val alignment : typedef Symbol.table -> vtype -> int + val alignment_reset : unit -> unit + val align : typedef Symbol.table -> vtype -> int -> int + val issmall : vtype -> bool + val defdata : typedef -> typedef + val defmark : typedef -> Mark.ext option + + structure Print : + sig + val pp_type : vtype -> string + val pp_typedef : (ident * typedef) -> string + end + +end + +structure Type :> TYPE = +struct + type ident = Symbol.symbol + datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull + type variable = ident * vtype + datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list + + fun size (Int) = 4 + | size (Pointer _) = 8 + | size (Array _) = 8 + | size (TNull) = 8 + | size _ = raise ErrorMsg.InternalError "Type.size on non-small type..." + + (************************************************) + (* this is full of shit *************************) + (************************************************) + local + val size_memotable = ref Symbol.empty + val align_memotable = ref Symbol.empty + in + (* determine size of items *) + fun sizeof_reset () = ( size_memotable := Symbol.empty ) + fun alignment_reset () = ( align_memotable := Symbol.empty ) + fun sizeof _ (Int) = 4 + | sizeof _ (Pointer _) = 8 + | sizeof _ (Array _) = 8 + | sizeof _ (TNull) = raise ErrorMsg.InternalError "Type.sizeof on TNull?" + | sizeof d (Typedef id) = + (case (Symbol.look (!size_memotable) id) + of SOME(r) => r + | NONE => + let + val r = sizeof_s d (Symbol.look' d id) + val _ = (size_memotable := (Symbol.bind (!size_memotable) (id, r))) + in + r + end) + and sizeof_s d (Struct(l)) = + foldl + (fn ((_,t),curpos) => align d t curpos + sizeof d t) + 0 + l + | sizeof_s d (MarkedTypedef(a)) = sizeof_s d (Mark.data a) + + (* determine alignment of items *) + and alignment _ (Int) = 4 + | alignment _ (Pointer _) = 8 + | alignment _ (Array _) = 8 + | alignment d (Typedef id) = + (case Symbol.look (!align_memotable) id + of SOME(r) => r + | NONE => + let + val r = alignment_s d (Symbol.look' d id) + val _ = (align_memotable := (Symbol.bind (!align_memotable) (id,r))) + in + r + end) + | alignment _ (TNull) = raise ErrorMsg.InternalError "Type.alignment on TNull?" + and alignment_s d (Struct(members)) = + foldl + (fn ((_,t),al) => Int.max (al, alignment d t)) + 1 + members + | alignment_s d (MarkedTypedef(a)) = alignment_s d (Mark.data a) + and align d t curpos = + let + val al = alignment d t + in + if(curpos mod al) = 0 then curpos + else curpos + al - (curpos mod al) + end + end + (************************************************) + (* end of shit **********************************) + (************************************************) + + + fun issmall (Int) = true + | issmall (Pointer _) = true + | issmall (Array _) = true + | issmall (TNull) = true + | issmall _ = false + + fun typeeq (Int, Int) = true + | typeeq (Typedef a, Typedef b) = (Symbol.name a) = (Symbol.name b) + | typeeq (Pointer a, Pointer b) = typeeq (a, b) + | typeeq (Array a, Array b) = typeeq (a, b) + | typeeq (TNull, TNull) = true + | typeeq _ = false + + fun castable (Pointer _, TNull) = true + | castable (Array _, TNull) = true + | castable (a, b) = typeeq (a, b) + + fun defdata (MarkedTypedef m) = defdata (Mark.data m) + | defdata m = m + + fun defmark (MarkedTypedef m) = Mark.ext m + | defmark _ = NONE + + structure Print = + struct + fun pp_ident i = Symbol.name i + + fun pp_type (Int) = "int" + | pp_type (Pointer t) = pp_type t ^ "*" + | pp_type (Array t) = pp_type t ^ "[]" + | pp_type (TNull) = "{NULL type}" + | pp_type (Typedef id) = pp_ident id + + and pp_typedef (i, Struct (v)) = "struct " ^ (pp_ident i) ^ " {\n" ^ (String.concat (map (fn (i', t) => " " ^ (pp_ident i') ^ " : " ^ (pp_type t) ^ ";\n") v)) ^ "}\n" + | pp_typedef (i, MarkedTypedef d) = pp_typedef (i, Mark.data d) + end + +end diff --git a/type/typechecker.sml b/type/typechecker.sml index 35d2859..06c6d89 100644 --- a/type/typechecker.sml +++ b/type/typechecker.sml @@ -10,36 +10,37 @@ signature TYPE_CHECK = sig (* prints error message and raises ErrorMsg.error if error found *) val typecheck : Ast.program -> Ast.program - val typeof : Ast.program -> Ast.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Ast.vtype + val typeof : Ast.program -> Type.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Type.vtype end; structure TypeChecker :> TYPE_CHECK = struct structure A = Ast structure AU = AstUtils + structure T = Type fun typeof (tds, funcs) vars mark e = ( case e of A.Var a => (case Symbol.look vars a of NONE => (ErrorMsg.error mark ("variable `"^(Symbol.name a)^"' not declared here") ; raise ErrorMsg.Error) | SOME t => t) - | A.ConstExp _ => A.Int + | A.ConstExp _ => T.Int | A.OpExp (A.EQ, [a, b]) => (case (typeof (tds, funcs) vars mark a, typeof (tds, funcs) vars mark b) - of (A.Int, A.Int) => A.Int (* You shall pass! *) + of (T.Int, T.Int) => T.Int (* You shall pass! *) | (a', b') => - if (A.typeeq (a', A.TNull) andalso A.castable (b', A.TNull)) orelse - (A.typeeq (b', A.TNull) andalso A.castable (a', A.TNull)) orelse - (A.typeeq (a', b')) - then A.Int - else (ErrorMsg.error mark ("incorrect types for equality opexp: " ^ A.Print.pp_type a' ^ ", " ^ A.Print.pp_type b') ; raise ErrorMsg.Error )) + if (T.typeeq (a', T.TNull) andalso T.castable (b', T.TNull)) orelse + (T.typeeq (b', T.TNull) andalso T.castable (a', T.TNull)) orelse + (T.typeeq (a', b')) + then T.Int + else (ErrorMsg.error mark ("incorrect types for equality opexp:" ^ T.Print.pp_type a' ^ ", " ^ T.Print.pp_type b') ; raise ErrorMsg.Error )) | A.OpExp (A.NEQ, el) => typeof (tds, funcs) vars mark (A.OpExp (A.EQ, el)) | A.OpExp (_, el) => (List.app (fn e => (case (typeof (tds, funcs) vars mark e) - of A.Int => () + of T.Int => () | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error))) - el ; A.Int) + el ; T.Int) | A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e) | A.FuncCall (i, exps) => let @@ -53,7 +54,7 @@ struct else (ErrorMsg.error mark ("call to function `"^(Symbol.name i)^"' has incorrect parameter count [you must construct additional tycons]") ; raise ErrorMsg.Error) val () = List.app (fn (t, (i, t')) => - if not (A.castable (t', t)) + if not (T.castable (t', t)) then (ErrorMsg.error mark ("parameter `"^(Symbol.name i)^"' in function call has wrong type [you must construct additional tycons]") ; raise ErrorMsg.Error) else ()) (ListPair.zip (exptypes, fparams)) @@ -64,14 +65,14 @@ struct let val t = typeof (tds, funcs) vars mark e val name = case t - of (A.Typedef i) => i + of (T.Typedef i) => i | _ => (ErrorMsg.error mark ("member operation only exists for struct types") ; raise ErrorMsg.Error) val s = case Symbol.look tds name of SOME s => s | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error) - val (s, smark) = (AU.Typedef.data s, AU.Typedef.mark s) + val (s, smark) = (T.defdata s, T.defmark s) val vl = case s - of A.Struct vl => vl + of T.Struct vl => vl | _ => raise ErrorMsg.InternalError "mark of marked typedef?" val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl) of SOME (_, t) => t @@ -83,16 +84,16 @@ struct let val t = typeof (tds, funcs) vars mark e val name = case t - of (A.Pointer (A.Typedef i)) => i + of (T.Pointer (T.Typedef i)) => i | _ => (ErrorMsg.error mark ("dereference and member operation only exists for struct pointer types") ; raise ErrorMsg.Error) val s = case Symbol.look tds name of SOME s => s | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error) val (s, smark) = case s - of A.Struct vl => (s, NONE) - | A.MarkedTypedef m => (Mark.data m, Mark.ext m) + of T.Struct vl => (s, NONE) + | T.MarkedTypedef m => (Mark.data m, Mark.ext m) val vl = case s - of A.Struct vl => vl + of T.Struct vl => vl | _ => raise ErrorMsg.InternalError "mark of marked typedef?" val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl) of SOME (_, t) => t @@ -102,19 +103,33 @@ struct end | A.Dereference e => (case typeof (tds, funcs) vars mark e - of (A.Pointer e') => e' + of (T.Pointer e') => e' | _ => (ErrorMsg.error mark ("cannot deference non-pointer type") ; raise ErrorMsg.Error)) | A.ArrIndex (e, i) => (case (typeof (tds, funcs) vars mark e, typeof (tds, funcs) vars mark i) - of (A.Array e', A.Int) => e' - | (_, A.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error) + of (T.Array e', T.Int) => e' + | (_, T.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error) | _ => (ErrorMsg.error mark ("cannot index using non-int type") ; raise ErrorMsg.Error)) - | A.New (t) => A.Pointer t + | A.New (t) => T.Pointer t | A.NewArr (t, s) => (case typeof (tds, funcs) vars mark s - of A.Int => (A.Array t) + of T.Int => (T.Array t) | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error)) - | A.Null => A.TNull + | A.Null => T.TNull + | A.Conditional (q, e1, e2) => + let + val _ = case typeof (tds, funcs) vars mark q + of T.Int => () + | _ => (ErrorMsg.error mark ("ternary condition not of Int type") ; raise ErrorMsg.Error) + val t1 = typeof (tds, funcs) vars mark e1 + val t2 = typeof (tds, funcs) vars mark e2 + in + if (T.typeeq (t1, t2) orelse T.castable (t1, t2)) + then t1 + else if (T.castable (t2, t1)) + then t2 + else (ErrorMsg.error mark ("ternary types do not agree [you must construct additional tycons]") ; raise ErrorMsg.Error) + end ) datatype asn = ASSIGNED | UNASSIGNED @@ -131,7 +146,7 @@ struct | returns' (A.AsnOp _ :: stms) = returns' stms | returns' (A.Effect _ :: stms) = returns' stms | returns' (A.Return e :: stms) = - if (A.castable (t, typeof prog vars mark e)) + if (T.castable (t, typeof prog vars mark e)) then true else (ErrorMsg.error mark ("return value of incorrect type for function") ; raise ErrorMsg.Error) | returns' (A.Nop :: stms) = returns' stms @@ -202,6 +217,7 @@ struct | varcheck_exp env (A.New _) mark = () | varcheck_exp env (A.NewArr (_, e)) mark = varcheck_exp env e mark | varcheck_exp env (A.Null) mark = () + | varcheck_exp env (A.Conditional (q, e1, e2)) mark = (varcheck_exp env q mark ; varcheck_exp env e1 mark ; varcheck_exp env e2 mark) (* computeassigns env exp * Computes the assigned variables after expression exp has been executed with a starting context of env. @@ -285,7 +301,7 @@ struct varcheck_exp env e mark ; a :: varcheck env stms mark) | varcheck env ((A.Assign _) :: stms) mark = raise ErrorMsg.InternalError "assign to non lvalue" - | varcheck env ((a as A.AsnOp (oper, e1, e2)) :: stms) mark = ( varcheck env [(A.Assign (e1, A.OpExp (oper, [e1, e2])))] ; a :: varcheck env stms mark) + | varcheck env ((a as A.AsnOp (oper, e1, e2)) :: stms) mark = ( varcheck_exp env e1 mark ; varcheck_exp env e2 mark ; a :: varcheck env stms mark ) | varcheck env ((a as A.Effect e) :: stms) mark = (varcheck_exp env e mark ; a :: varcheck env stms mark) | varcheck env (A.Return (e) :: stms) mark = ( varcheck_exp env e mark; @@ -320,7 +336,7 @@ struct val env' = case sbegin of SOME(s) => computeassigns env [s] | NONE => env - val _ = varcheck_exp env' e + val _ = varcheck_exp env' e mark val inner = varcheck env' inner mark val env'' = computeassigns env' inner val sloop = case sloop @@ -358,14 +374,14 @@ struct fun typecheck_stm prog vars mark stm = case stm of A.Assign (e1, e2) => - if not (A.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2)) + if not (T.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2)) then (ErrorMsg.error mark "incompatible types in assignment" ; raise ErrorMsg.Error ) - else if not (AU.Type.issmall (check_lvalue prog vars mark e1)) + else if not (T.issmall (check_lvalue prog vars mark e1)) then (ErrorMsg.error mark "lvalue is not small" ; raise ErrorMsg.Error) else () | A.AsnOp (oper, e1, e2) => typecheck_stm prog vars mark (A.Assign (e1, A.OpExp (oper, [e1, e2]))) | A.Effect e => - if not (AU.Type.issmall (typeof prog vars mark e)) + if not (T.issmall (typeof prog vars mark e)) then (ErrorMsg.error mark "simple statement's value not small" ; raise ErrorMsg.Error ) else () | A.Return e => (typeof prog vars mark e ; ()) @@ -373,36 +389,36 @@ struct | A.Break => () | A.Continue => () | A.If (e, s, NONE) => - if A.castable (A.Int, typeof prog vars mark e) + if T.castable (T.Int, typeof prog vars mark e) then (List.app (typecheck_stm prog vars mark) s) else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error ) | A.If (e, s1, SOME s2) => - if A.castable (A.Int, typeof prog vars mark e) + if T.castable (T.Int, typeof prog vars mark e) then (List.app (typecheck_stm prog vars mark) s1 ; List.app (typecheck_stm prog vars mark) s2) else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error ) | A.For (sbegin, e, sloop, s) => - if A.castable (A.Int, typeof prog vars mark e) + if T.castable (T.Int, typeof prog vars mark e) then (List.app (typecheck_stm prog vars mark) ((case sbegin of SOME l => [l] | NONE => nil) @ (case sloop of SOME l => [l] | NONE => nil) @ s)) else (ErrorMsg.error mark "conditional in for statement is not of int type" ; raise ErrorMsg.Error ) | A.While (e, s) => - if A.castable (A.Int, typeof prog vars mark e) + if T.castable (T.Int, typeof prog vars mark e) then (List.app (typecheck_stm prog vars mark) s) else (ErrorMsg.error mark "conditional in while statement is not of int type" ; raise ErrorMsg.Error ) | A.MarkedStm (m) => typecheck_stm prog vars (Mark.ext m) (Mark.data m) (* XXX does not check big vs. small types *) - fun typecheck_type (tds, funcs) mark A.Int = () - | typecheck_type (tds, funcs) mark A.TNull = () - | typecheck_type (tds, funcs) mark (A.Pointer t) = typecheck_type (tds, funcs) mark t - | typecheck_type (tds, funcs) mark (A.Array t) = typecheck_type (tds, funcs) mark t - | typecheck_type (tds, funcs) mark (A.Typedef t) = + fun typecheck_type (tds, funcs) mark T.Int = () + | typecheck_type (tds, funcs) mark T.TNull = () + | typecheck_type (tds, funcs) mark (T.Pointer t) = typecheck_type (tds, funcs) mark t + | typecheck_type (tds, funcs) mark (T.Array t) = typecheck_type (tds, funcs) mark t + | typecheck_type (tds, funcs) mark (T.Typedef t) = case (Symbol.look tds t) of SOME _ => () | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name t)^"' does not exist") ; raise ErrorMsg.Error) fun typecheck_fn prog _ (id, A.MarkedFunction m) = typecheck_fn prog (Mark.ext m) (id, Mark.data m) | typecheck_fn (prog as (tds, funcs)) mark (id, A.Extern (t, al)) = - (if (String.isPrefix "_l4_" (Symbol.name id)) + (if (String.isPrefix "_l5_" (Symbol.name id)) then let val n = String.extract (Symbol.name id, 4, NONE) @@ -432,7 +448,7 @@ struct else () val () = List.app ( fn (n, t) => - if (AU.Type.issmall t) + if (T.issmall t) then () else ( ErrorMsg.error mark ("variable `"^(Symbol.name n)^"' in function `"^(Symbol.name id)^"' not small") ; raise ErrorMsg.Error)) (al @ vl) @@ -458,11 +474,11 @@ struct val s = case Symbol.look tds sym of SOME a => a | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name sym)^"' does not exist") ; raise ErrorMsg.Error) - val vl = case AU.Typedef.data s - of A.Struct vl => vl - | A.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type" + val vl = case T.defdata s + of T.Struct vl => vl + | T.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type" in - (vl, AU.Typedef.mark s) + (vl, T.defmark s) end fun checksym mark sym stack k remaining = if not (SymbolSet.member (remaining, sym)) @@ -477,7 +493,7 @@ struct fun remove k remaining' = k (SymbolSet.delete (remaining', sym)) val newk = (* OH GOD D: *) foldr - (fn ((_, A.Typedef s), k') => checksym mark' s stack' k' + (fn ((_, T.Typedef s), k') => checksym mark' s stack' k' | (_, k') => k') (remove k) vl @@ -502,8 +518,8 @@ struct val () = case main of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern"); raise ErrorMsg.Error ) - | A.Function (A.Int, nil, _, _) => () - | A.Function (A.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters"); + | A.Function (T.Int, nil, _, _) => () + | A.Function (T.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters"); raise ErrorMsg.Error ) | A.Function (_, _, _, _) => ( ErrorMsg.error mainp ("main has incorrect return type"); raise ErrorMsg.Error ) diff --git a/util/graph.sml b/util/graph.sml deleted file mode 100644 index 502cd7c..0000000 --- a/util/graph.sml +++ /dev/null @@ -1,40 +0,0 @@ -signature GRAPH = -sig - type node - type graph - val addnode : graph -> node -> node list -> graph - val addedge : graph -> node -> node -> graph - val isdag : graph -> node -> bool -end - -functor Graph (structure Node : ORD_KEY) :> GRAPH where type node = Node.key = -struct - structure Map = SplayMapFn(Node) - structure Set = HashSetFn(Node) - type node = Node.key - type graph = (Set.set) Map.map - - (* val addnode : graph -> node -> node list -> graph - * adds a node given its links (directed) - *) - fun addnode g n nl = - case Map.find (g,n) - of SOME(ns) => Map.insert (g, n, Set.addList (ns, nl)) - | NONE => Map.insert (g, n, Set.addList (Set.empty, nl)) - - fun addedge g n1 n2 = - let - val set1 = case Map.find (g,n1) of SOME(a) => a | NONE => Set.empty - val set2 = case Map.find (g,n2) of SOME(a) => a | NONE => Set.empty - in - Map.insert (Map.insert (g, n2, set2), n1, Set.add (set1, n2)) - end - - fun isdag g n = - let - val nn = Set.numItems (case Map.find (g,n) of SOME(a) => a | NONE => Set.empty) - - in - end - -end diff --git a/util/word32.sml b/util/word32.sml index d830c9d..c25c285 100644 --- a/util/word32.sml +++ b/util/word32.sml @@ -14,16 +14,25 @@ signature WORD32_SIGNED = sig + val TMAX : Word32.word (* largest signed positive word, 2^31-1 *) val TMIN : Word32.word (* smallest signed negative word -2^31 *) val ZERO : Word32.word (* 0 *) val fromString : string -> Word32.word option (* parse from string, no sign *) (* raises Overflow if not 0 <= n < 2^32 *) val toString : Word32.word -> string (* print to string, with sign *) + val abs : Word32.word -> Word32.word + val adiv : Word32.word * Word32.word -> Word32.word + val amod : Word32.word * Word32.word -> Word32.word + val lt : Word32.word * Word32.word -> bool + val gt : Word32.word * Word32.word -> bool + val le : Word32.word * Word32.word -> bool + val ge : Word32.word * Word32.word -> bool end structure Word32Signed :> WORD32_SIGNED = struct + val TMIN = Word32.<<(Word32.fromInt(1), Word.fromInt(Word32.wordSize-1)) val TMAX = Word32.-(TMIN, Word32.fromInt(1)) val ZERO = Word32.fromInt(0) @@ -36,6 +45,22 @@ struct fun toString (w) = if neg w - then "-" ^ Word32.fmt StringCvt.DEC (Word32.~(w)) - else Word32.fmt StringCvt.DEC w + then "-0x" ^ Word32.fmt StringCvt.HEX (Word32.~(w)) + else "0x" ^ Word32.fmt StringCvt.HEX w + + fun toInt32 w = Int32.fromLarge (Word32.toLargeInt w) + fun fromInt32 i = Word32.fromLargeInt (Int32.toLarge i) + + fun abs w = if neg w then Word32.~ (w) else w + fun adiv (a,b) = fromInt32 (Int32.div (toInt32 a, toInt32 b)) + fun amod (a,b) = fromInt32 (Int32.mod (toInt32 a, if neg a andalso neg b then toInt32 b + else if neg b then toInt32 (abs b) + else if neg a then toInt32 (Word32.~ b) + else toInt32 b)) + + fun lt (a,b) = Int32.compare (toInt32 a, toInt32 b) = LESS + fun gt (a,b) = Int32.compare (toInt32 a, toInt32 b) = GREATER + fun le (a,b) = case Int32.compare (toInt32 a, toInt32 b) of LESS => true | EQUAL => true | _ => false + fun ge (a,b) = case Int32.compare (toInt32 a, toInt32 b) of GREATER => true | EQUAL => true | _ => false + end