X-Git-Url: http://git.joshuawise.com/snipe.git/blobdiff_plain/1144856ba9d6018d9922c6ede7e97779a0fe6373..141a7120aec6ddf3ab097f275498d8e3a1b90401:/codegen/solidify.sml?ds=sidebyside 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))