diff options
| -rw-r--r-- | emit.fun | 691 | ||||
| -rw-r--r-- | il.fun | 35 | ||||
| -rw-r--r-- | il.sig | 4 | ||||
| -rw-r--r-- | parser.fun | 15 |
4 files changed, 714 insertions, 31 deletions
@@ -502,10 +502,10 @@ functor Emit(I: IL) = struct fun updateI i = fn z => let - fun from rinfo active pool intervals stackCand = - { rinfo, active, pool, intervals, stackCand } - fun to f { rinfo, active, pool, intervals, stackCand } = - f rinfo active pool intervals stackCand + fun from rinfo active pool intervals stackOff = + { rinfo, active, pool, intervals, stackOff } + fun to f { rinfo, active, pool, intervals, stackOff } = + f rinfo active pool intervals stackOff in FRU.makeUpdate5 (from, from, to) i end z @@ -666,13 +666,14 @@ functor Emit(I: IL) = struct end end - fun putToStack poff { rinfo, stackCand, ... } vr = + fun putToStack poff { rinfo, stackOff, ... } vr = let + val newStackOff = !stackOff - 8 val () = printfn R poff - `"puting %" ip vr `" to stack: " ip (!stackCand) % + `"puting %" ip vr `" to stack: " ip newStackOff % in - updReg rinfo vr (VtStack (!stackCand)); - stackCand := !stackCand - 8 + updReg rinfo vr (VtStack newStackOff); + stackOff := newStackOff end fun assignHardReg poff (I as { rinfo, pool, ... }) vr reg = @@ -797,14 +798,14 @@ functor Emit(I: IL) = struct putToStack 0 I vr end - fun linearscan rinfo ints = + fun linearscan rinfo ints stackOff = let fun incStart ((_, start1, _), (_, start2, _)) = start1 <= start2 val ints = sort incStart ints val () = printInts ints - fun loop _ [] = () + fun loop { stackOff, ... } [] = stackOff | loop (I as { active, ... }) (int :: ints) = let val () = printfn `"\n\ninspectiing interval " @@ -826,7 +827,7 @@ functor Emit(I: IL) = struct end in loop { active = ref [], pool = getPool (), rinfo, - stackCand = ref (~8) } ints + stackOff = ref stackOff } ints end fun printAllocVar rinfo v = @@ -959,8 +960,34 @@ functor Emit(I: IL) = struct Array.appi printRow map end + fun resolveAlloc ops = + let + fun loop idx stackOffset = + if idx = D.length ops then + stackOffset + else + case D.get ops idx of + (SOME (I.IrAlloc (v, size, _)), li) => + let + val () = printfn `"alloca size: " W size % + val () = + if Word.mod (size, 0w8) <> 0w0 then raise Unreachable else () + + val stackOffset = stackOffset - Word.toInt size + val negOffset = ~stackOffset + val ins = (SOME $ I.IrAlloc (v, size, SOME negOffset), li) + in + D.set ops idx ins; + loop (idx + 1) stackOffset + end + | (NONE, _) | (SOME _, _) => loop (idx + 1) stackOffset + in + loop 0 0 + end + fun regAlloc (F as I.Fi { vregs, ops, paramNum, ... }) = let + val stackOffset = resolveAlloc ops val (toAlloc, regInfo) = prepareRegInfo paramNum ops vregs val () = printfn `"for alloc: " Plist i toAlloc (", ", true, 0) % @@ -968,7 +995,7 @@ functor Emit(I: IL) = struct val intervals = computeInts F toAlloc - val () = linearscan regInfo intervals + val stackOffset = linearscan regInfo intervals stackOffset val () = printAlloced regInfo toAlloc val regsToSave = getRegsToSave regInfo @@ -978,14 +1005,646 @@ functor Emit(I: IL) = struct val regMap = computeMap (D.length ops) intervals regInfo val () = printMap regMap in - raise Unimplemented + { regsToSave, stackOffset = !stackOffset, regMap, ops, + rinfo = regInfo, vregs } + end + + fun emitPushReg reg = fprinttn `"push " Preg reg % + + fun emitPrologue ({ stackOffset, regsToSave, ... }) name = + let + val () = fprint PP.? name `":\n" % + val () = fprinttn `"push rbp" % + val () = fprinttn `"mov rbp, rsp" % + val () = + if stackOffset <> 0 then + fprinttn `"sub rsp, " I (~ stackOffset) % + else + () + in + List.app emitPushReg regsToSave + end + + fun emitEpilogue { regsToSave, ... } = + let + val () = List.app emitPushReg (rev regsToSave) + val () = fprinttn `"mov rsp, rbp" % + val () = fprinttn `"pop rbp" % + val () = fprinttn `"ret" % + in + () end - fun emitFunc (F as I.Fi { vregs, ... }) = + fun pr is8 reg out = + let + fun old s = + let + val s = if is8 then s else "e" ^ String.extract (s, 1, NONE) + in + Printf out `s % + end + + fun new s = Printf out `(if is8 then s else s ^ "d") % + in + case reg of + Rcx => old "rcx" + | Rsi => old "rsi" + | Rdi => old "rdi" + | R8 => new "r8" + | R9 => new "r9" + | R10 => new "r10" + | R11 => new "r11" + + | Rbx => old "rbx" + | R12 => new "r12" + | R13 => new "r13" + | R14 => new "r14" + | R15 => new "r15" + + | Rax => old "rax" + | Rdx => old "rdx" + | Rsp => old "rsp" + | Rbp => old "rbp" + end + + fun pm is8 off out = + Printf out `(if is8 then "qword" else "dword") `" [rbp-" I off `"]"% + + fun getType { rinfo, vregs, ... } vr = + let + val (_, vt) = Array.sub (rinfo, vr) + val { class, ... } = D.get vregs vr + in + (if class = I.VR8 then true else false, vt) + end + + datatype template = + RRR of reg * reg * reg | + RRM of reg * reg * int | + RRV of reg * reg * vConst | + RMR of reg * int * reg | + RMM of reg * int * int | + RMV of reg * int * vConst | + RVR of reg * vConst * reg | + RVM of reg * vConst * int | + + MRR of int * reg * reg | + MRM of int * reg * int | + MRV of int * reg * vConst | + MMR of int * int * reg | + MMM of int * int * int | + MMV of int * int * vConst | + MVR of int * vConst * reg | + MVM of int * vConst * int | + + RR of reg * reg | + RM of reg * int | + RV of reg * vConst | + MR of int * reg | + MM of int * int | + MV of int * vConst + + fun pc is8 c out = + case c of + VConst w => + if is8 then + Printf out W w % + else + Printf out W (P.extz w 0w32) % + | VAddrConst (id, w) => Printf out PP.? id I.Pwc I.VR8 w % + + fun wordFitsInNsx N w = + let + open Word + val nm1 = fromInt N - 0w1 + in + if w < << (0w1, nm1) then (* sign bit is zero *) + true + else + let + val mask = << (~ 0w1, nm1) + in + andb (mask, w) = mask (* sign bit and all bits after == 1 *) + end + end + + fun fitsInNsx N c = + case c of + VConst w => wordFitsInNsx N w + | VAddrConst _ => false + + fun opRR is8 op' r1 r2 = sprintf `op' `" " A2 pr is8 r1 `", " A2 pr is8 r2 % + fun opRM is8 op' r off = sprintf `op' `" " A2 pr is8 r `", " A2 pm is8 off % + fun opMR is8 op' off r = sprintf `op' `" " A2 pm is8 off `", " A2 pr is8 r % + + fun opRV is8 op' r c = + sprintf `op' `" " A2 pr is8 r `", " A2 pc is8 c % + + fun opMV is8 op' off c = + sprintf `op' `" " A2 pm is8 off `", " A2 pc is8 c % + + fun movRR is8 r1 r2 = sprintf `"mov " A2 pr is8 r1 `", " A2 pr is8 r2 % + fun movRM is8 r off = sprintf `"mov " A2 pr is8 r `", " A2 pm is8 off % + fun movMR is8 off r = sprintf `"mov " A2 pm is8 off `", " A2 pr is8 r % + + fun movRV is8 r c = sprintf `"mov " A2 pr is8 r `", " A2 pc is8 c % + fun movMV is8 off c = + let + val () = if not $ fitsInNsx 32 c then raise Unreachable else () + in + opMV is8 "mov" off c + end + + fun getTripleTemplate I (rd, rs1, rs2) comm = + let + val (is81, t1) = getType I rd + val (is82, t2) = getType I rs1 + val (is83, t3) = getType I rs2 + + val () = + if is81 <> is82 orelse is82 <> is83 then raise Unreachable else () + + val tmp = + case (t1, t2, t3) of + (VtReg r1, VtReg r2, VtReg r3) => + if r1 = r2 then + RR (r1, r3) + else if r1 = r3 andalso comm then + RR (r1, r2) + else + RRR (r1, r2, r3) + + | (VtReg r1, VtReg r2, VtStack off) => + if r1 = r2 then + RM (r1, off) + else + RRM (r1, r2, off) + | (VtReg r1, VtStack off, VtReg r2) => + if r1 = r2 andalso comm then + RM (r1, off) + else + RMR (r1, off, r2) + + | (VtReg r1, VtReg r2, VtConst c) => + if r1 = r2 then + RV (r1, c) + else + RRV (r1, r2, c) + | (VtReg r1, VtConst c, VtReg r2) => + if r1 = r2 andalso comm then + RV (r1, c) + else + RVR (r1, c, r2) + + | (VtReg r, VtStack off1, VtStack off2) => RMM (r, off1, off2) + + | (VtReg r, VtStack off, VtConst c) => RMV (r, off, c) + | (VtReg r, VtConst c, VtStack off) => RVM (r, c, off) + + | (VtStack off, VtReg r1, VtReg r2) => MRR (off, r1, r2) + + | (VtStack off1, VtReg r, VtStack off2) => + if off1 = off2 andalso comm then + MR (off1, r) + else + MRM (off1, r, off2) + | (VtStack off1, VtStack off2, VtReg r) => + if off1 = off2 then + MR (off1, r) + else + MMR (off1, off2, r) + + | (VtStack off, VtReg r, VtConst c) => MRV (off, r, c) + | (VtStack off, VtConst c, VtReg r) => MVR (off, c, r) + + | (VtStack off1, VtStack off2, VtStack off3) => + if off1 = off2 then + MM (off1, off3) + else if off1 = off3 andalso comm then + MM (off1, off2) + else + MMM (off1, off2, off3) + + | (VtStack off1, VtStack off2, VtConst c) => + if off1 = off2 then + MV (off1, c) + else + MMV (off1, off2, c) + | (VtStack off1, VtConst c, VtStack off2) => + if off1 = off2 andalso comm then + MV (off1, c) + else + MVM (off1, c, off2) + | (VtConst _, _, _) | (VtUnk, _, _) | (_, VtUnk, _) | + (_, _, VtUnk) | (_, VtConst _, VtConst _) => raise Unreachable + in + (is81, tmp) + end + + fun getUtilMovs is8 = + let + val movRR = movRR is8 + val movRM = movRM is8 + val movMR = movMR is8 + val movRV = movRV is8 + in + { movRR, movRM, movRV, movMR } + end + + fun getUtilOps is8 op' = + let + val opRR = opRR is8 op' + val opRM = opRM is8 op' + val opRV = opRV is8 op' + val opMR = opMR is8 op' + val opMV = opMV is8 op' + in + { opRR, opRM, opRV, opMR, opMV } + end + + fun emitGenComm I op' triple = + let + val (is8, tmp) = getTripleTemplate I triple true + val Pr = fn z => bind A1 (pr is8) z + val { movRR, movRM, movMR, movRV } = getUtilMovs is8 + val { opRR, opRM, opMR, opRV, opMV } = getUtilOps is8 op' + in + case tmp of + RRR (r1, r2, r3) => + if op' = "add" then + [sprintf `"lea " Pr r1 `", [" Pr r2 `"+" Pr r3 `"]" % ] + else + [movRR r1 r2, opRR r1 r3] + | RRM (r1, r2, off) | RMR (r1, off, r2) => [ movRR r1 r2, opRM r1 off ] + | MMM (off1, off2, off3) => + [ movRM Rax off2, opRM Rax off3, movMR off1 Rax ] + | MRM (off1, r, off2) | MMR (off1, off2, r) => + [ movMR off1 r, movRM Rax off2, opMR off1 Rax ] + | MRR (off, r1, r2) => [ movMR off r1, opMR off r2 ] + | RMM (r, off1, off2) => [ movRM r off1, opRM r off2 ] + | RRV (r1, r2, c) | RVR (r1, c, r2) => + if fitsInNsx 32 c then + [ movRR r1 r2, opRV r1 c ] + else + [ movRV r1 c, opRR r1 r2 ] + | MMV (off1, off2, c) | MVM (off1, c, off2) => + [ movRV Rax c, opRM Rax off2, movMR off1 Rax ] + | MRV (off, r, c) | MVR (off, c, r) => + [ movRV Rax c, opRR Rax r, movMR off Rax ] + | RMV (r, off, c) | RVM (r, c, off) => [ movRV r c, opRM r off ] + | MM (off1, off2) => [ movRM Rax off2, opMR off1 Rax ] + | MR (off, r) => [ opMR off r ] + | MV (off, c) => + if fitsInNsx 32 c then + [ opMV off c ] + else + [ movRV Rax c, opMR off Rax ] + | RR (r1, r2) => [ opRR r1 r2 ] + | RM (r, off) => [ opRM r off ] + | RV (r, c) => + if fitsInNsx 32 c then + [ opRV r c ] + else + [ movRV Rax c, opRR r Rax ] + end + + fun truncConst (VConst w) N = VConst $ P.extz w (Word.fromInt N) + | truncConst (C as (VAddrConst _)) _ = C + + fun emitShift I op' triple = + let + val (is8, tmp) = getTripleTemplate I triple false + val Pr = fn z => bind A1 (pr is8) z + val { movRR, movRM, movMR, movRV } = getUtilMovs is8 + val opRV = opRV is8 op' + val opRR = opRR is8 op' + val opMV = opMV is8 op' + + fun shift3 r1 r2 r3 = + sprintf `op' `"x " Pr r1 `", " Pr r2 `", " Pr r3 % + + fun shift3m r1 off r2 = + sprintf `op' `" x" Pr r1 `", " A2 pm is8 off `", " Pr r2 % + + fun t v = truncConst v 8 + in + case tmp of + RRR (r1, r2, r3) => [shift3 r1 r2 r3] + | RRM (r1, r2, off) => [movRM Rax off, shift3 r1 r2 Rax] + | RRV (r1, r2, v) => [movRR r1 r2, opRV r1 (t v)] + | RMR (r1, off, r2) => [shift3m r1 off r2] + | RMM (r1, off1, off2) => + [movRM Rax off1, movRM Rdx off2, shift3 r1 Rax Rdx] + | RMV (r, off, v) => [movRM r off, opRV r (truncConst v 8)] + | RVR (r1, v, r2) => [movRV Rax v, shift3 r1 Rax r2] + | RVM (r, v, off) => [movRV Rax v, movRM Rdx off, shift3 r Rax Rdx] + | MRR (off, r1, r2) => [shift3 Rax r1 r2, movMR off Rax] + | MRM (off1, r1, off2) => + [movRM Rax off2, shift3 Rax r1 Rax, movMR off1 Rax] + | MRV (off, r, v) => [movRV Rax (t v), shift3 Rax r Rax, movMR off Rax] + | MMR (off1, off2, v) => [shift3m Rax off2 v, movMR off1 Rax] + | MMM (off1, off2, off3) => + [movRM Rdx off3, shift3m Rax off2 Rdx, movMR off1 Rax] + | MMV (off1, off2, v) => + [movRM Rax off2, opRV Rax (t v), movMR off1 Rax] + | MVR (off1, v, r) => [movRV Rax v, opRR Rax r, movMR off1 Rax] + | MVM (off1, v, off2) => + [movRV Rax v, movRM Rdx off2, opRR Rax Rdx, movMR off1 Rax] + + | RR (r1, r2) => [opRR r1 r2] + | RM (r1, off) => [movRM Rax off, shift3 r1 r1 Rax] + | RV (r1, v) => [opRV r1 (t v)] + | MR (off, r) => [movRM Rax off, opRR Rax r, movMR off Rax] + | MM (off1, off2) => + [movRM Rax off1, movRM Rdx off2, opRR Rax Rdx, movMR off1 Rax] + | MV (off, v) => [opMV off (t v)] + end + + fun emitSub I triple = + let + val (is8, tmp) = getTripleTemplate I triple false + val { movRR, movRM, movRV, movMR } = getUtilMovs is8 + val { opRR, opRM, opRV, opMR, opMV } = getUtilOps is8 "sub" + in + case tmp of + RRR (r1, r2, r3) => [movRR r1 r2, opRR r1 r3] + | RRM (r1, r2, off) => [movRR r1 r2, opRM r1 off] + | RRV (r1, r2, c) => + if fitsInNsx 32 c then + [movRR r1 r2, opRV r1 c] + else + [movRR r1 r2, movRV Rax c, opRR r1 Rax] + | RMR (r1, off, r2) => [movRM r1 off, opRR r1 r2] + | RMM (r1, off1, off2) => + [movRM r1 off1, movRM Rax off2, opRR r1 Rax] + | RMV (r1, off, v) => + if fitsInNsx 32 v then + [movRM r1 off, opRV r1 v] + else + [movRM r1 off, movRV Rax v, opRR r1 Rax] + | RVR (r1, v, r2) => [movRV r1 v, opRR r1 r2] + | RVM (r, v, off) => [movRV r v, opRM r off] + | MRR (off, r1, r2) => [movRR Rax r1, opRR Rax r2, movMR off Rax] + | MRM (off1, r, off2) => [opRM r off2, movMR off1 r] + | MRV (off, r, v) => + if fitsInNsx 32 v then + [movRR Rax r, opRV Rax v, movMR off Rax] + else + [movRR Rax r, movRV Rdx v, opRR Rax Rdx, movMR off Rax] + | MMR (off1, off2, r) => [movRM Rax off2, opRR Rax r, movMR off1 Rax] + | MMM (off1, off2, off3) => + [movRM Rax off2, opRM Rax off3, movMR off1 Rax] + | MMV (off1, off2, v) => + if fitsInNsx 32 v then + [movRM Rax off2, opRV Rax v, movMR off1 Rax] + else + [movRM Rax off2, movRV Rdx v, opRR Rax Rdx, movMR off1 Rax] + | MVM (off1, v, off2) => [movRV Rax v, opRM Rax off2, movMR off1 Rax] + | MVR (off1, v, r) => [movRV Rax v, opRR Rax r, movMR off1 Rax] + | RR (r1, r2) => [opRR r1 r2] + | RM (r, off) => [opRM r off] + | RV (r, v) => + if fitsInNsx 32 v then + [opRV r v] + else + [movRV Rax v, opRR r Rax] + | MR (off, r) => [opMR off r] + | MM (off1, off2) => [movRM Rax off2, opMR off1 Rax] + | MV (off, v) => + if fitsInNsx 32 v then + [opMV off v] + else + [movRV Rax v, opMR off Rax] + end + + fun emitSet I (vrd, I.SaVReg vrs) = + let + val (is81, t1) = getType I vrd + val (is82, t2) = getType I vrs + in + case (is81, t1, is82, t2) of + (false, VtReg r1, false, VtReg r2) + | (false, VtReg r1, true, VtReg r2) + | (true, VtReg r1, true, VtReg r2) => + if r1 = r2 then + [] + else + [movRR true r1 r2] + | (true, VtReg r1, false, VtReg r2) => [movRR false r1 r2] + + | (_, VtReg r1, _, VtConst c) => [movRV true r1 c] + | (_, VtReg r1, _, VtStack off) => [movRM true r1 off] + | (_, VtStack off, _, VtReg r) => [movMR true off r] + | (_, VtStack off1, _, VtStack off2) => + [movRM true Rax off2, movMR true off1 Rax] + + | (_, VtStack off, _, VtConst c) => + if fitsInNsx 32 c then + [movMV true off c] + else + [movRV true Rax c, movMR true off Rax] + + | (_, VtConst _, _, _) | (_, VtUnk, _, _) | (_, _, _, VtUnk) => + raise Unreachable + end + | emitSet I (vrd, I.SaConst w) = + let + val (_, t1) = getType I vrd + val c = VConst w + in + case t1 of + VtReg r => [movRV true r c] + | VtStack off => + if fitsInNsx 32 c then + [movMV true off c] + else + [movRV true Rax c, movMR true off Rax] + | VtConst _ | VtUnk => raise Unreachable + end + | emitSet I (vrd, I.SaAddr p) = + let + val (_, t1) = getType I vrd + val c = VAddrConst p + in + case t1 of + VtReg r => [movRV true r c] + | VtStack off => [movRV true Rax c, movMR true off Rax] + | VtUnk | VtConst _ => raise Unreachable + end + + fun emitAlloc E (vrd, _, SOME stackOffset) = + let + val (is8, t1) = getType E vrd + val () = if not is8 then raise Unreachable else () + in + case t1 of + VtReg r => + [ sprintf `"lea " A2 pr true r `", [rsp-" I stackOffset `"]" % ] + | _ => raise Unreachable + end + | emitAlloc _ (_, _, NONE) = raise Unreachable + + fun jmp lid = sprintf `"jmp .L" I lid % + + fun emitRet (E as { ops, ... }) vr idx = + let + val begin = + case vr of + NONE => [] + | SOME vr => + let + val (is8, t) = getType E vr + in + case t of + VtReg r => [movRR is8 Rax r] + | VtStack off => [movRM is8 Rax off] + | VtConst c => [movRV is8 Rax c] + | VtUnk => raise Unreachable + end + in + if idx < D.length ops - 2 then + begin @ [ jmp 0 ] + else + begin + end + + fun emitCopy E (vr, lid, size) = + let + val (is8, t) = getType E vr + val () = if not is8 then raise Unreachable else () + val (prolog, destReg) = + case t of + VtReg r => ([], r) + | VtStack off => ([movRM true Rdx off], Rdx) + | VtConst _ | VtUnk => raise Unreachable + + fun loop off acc = + if off = size then + rev acc + else + let + val from = sprintf `"mov rax, qword [.I" I lid `"+" W off `"]" % + val to = + sprintf `"mov [" A2 pr true destReg `"+" W off `"], rax" % + in + loop (off + 0w8) (to :: from :: acc) + end + in + loop 0w0 prolog + end + + fun wordIsZero w = + case Word.compare (w, 0w0) of + EQUAL => true + | _ => false + + datatype cbv = CbvTrue | CbvFalse | CbvUnsure of int * word + + fun constBoolVal (VConst w) = if wordIsZero w then CbvFalse else CbvTrue + | constBoolVal (VAddrConst (id, off)) = + if wordIsZero off then + CbvTrue + else + CbvUnsure (id, off) + + fun emitJz E (vr, lid) isJz = + let + val (is8, vt) = getType E vr + val jmp' = sprintf `"j" `(if isJz then "z" else "nz") `" .L" I lid % + in + case vt of + VtReg reg => + [sprintf `"test " A2 pr is8 reg `", " A2 pr is8 reg %, jmp'] + | VtStack off => [sprintf `"cmp " A2 pm is8 off `", 0" %, jmp'] + | VtConst c => ( + case constBoolVal c of + CbvTrue => [ jmp lid ] + | CbvFalse => [] + | CbvUnsure (id, off) => [ + sprintf `"lea rax, [" PP.? id I.Pwc I.VR8 off `"]" %, + sprintf `"test rax, 0" %, + jmp' + ] + ) + | VtUnk => raise Unreachable + end + + fun emitOpStrList ins E idx = + case ins of + I.IrSet p => emitSet E p + | I.IrAdd t => emitGenComm E "add" t + | I.IrAnd t => emitGenComm E "and" t + | I.IrOr t => emitGenComm E "or" t + | I.IrXor t => emitGenComm E "xor" t + + | I.IrSub t => emitSub E t + + | I.IrShl t => emitShift E "shl" t + | I.IrShr t => emitShift E "shr" t + | I.IrSar t => emitShift E "sar" t + + | I.IrAlloc t => emitAlloc E t + | I.IrRet vr => emitRet E vr idx + | I.IrCopy t => emitCopy E t + | I.IrNopLabel lid => [ sprintf `".L" I lid % ] + | I.IrJmp lid => [ jmp lid ] + | I.IrJz p => emitJz E p true + | I.IrJnz p => emitJz E p false + | _ => [] + + fun emitIns (I as { ops, ... }) = + let + val outputBuf = Array.array (D.length ops, []) + + fun printFromBuf () = + let + fun printLine line = ( + if String.sub (line, 0) <> #"." then + fprint `"\t" % + else + (); + fprint `line `"\n" % + ) + + in + Array.app + (fn lines => List.app printLine lines) + outputBuf + end + + fun loop idx = + if idx < 0 then + printFromBuf () + else + let + val (ins, _) = D.get ops idx + in + case ins of + SOME ins => + let + val slist = emitOpStrList ins I idx + in + Array.update (outputBuf, idx, slist); + loop (idx - 1) + end + | NONE => loop (idx - 1) + end + in + loop (D.length ops - 1) + end + + fun emitFunction info name = ( + fprint `"\nsection .text\n" %; + emitPrologue info name; + emitIns info; + emitEpilogue info + ) + + fun emitFunc (F as I.Fi { name, ... }) = let - val () = regAlloc F vregs + val info = regAlloc F in - raise Unimplemented + emitFunction info name end fun openFile fname = file := SOME (TextIO.openOut fname) @@ -53,7 +53,7 @@ functor IL(P: PARSER) = struct | IrJmp of label | IrRet of vreg option - | IrAlloc of vreg * word + | IrAlloc of vreg * word * int option | IrCopy of vreg * label * word | IrFcall of vreg * vreg * vreg list @@ -240,7 +240,7 @@ functor IL(P: PARSER) = struct | IrJnz (r, _) => { defs = [], use = [r] } | IrNopLabel _ | IrNop _ => { defs = [], use = [] } | IrRet v => { defs = [], use = case v of SOME r => [r] | _ => [] } - | IrAlloc (r, _) => { defs = [r], use = [] } + | IrAlloc (r, _, _) => { defs = [r], use = [] } | IrCopy (r, _, _) => { defs = [], use = [r] } | IrFcall (rd, f, args) => { defs = if rd = ~1 then [] else [rd], use = f :: args } @@ -1024,7 +1024,7 @@ functor IL(P: PARSER) = struct let val size = P.sizeOfType $ #t $ Vector.sub (localVars, id) in - ctxPutOp C (IrAlloc (id, size)) + ctxPutOp C (IrAlloc (id, size, NONE)) end | convIni (C as Lctx { localVars, ... }) (id, SOME (P.CiniExpr ea)) = let @@ -1041,6 +1041,7 @@ functor IL(P: PARSER) = struct let val size = P.getLayoutSize lid in + ctxPutOp ctx (IrAlloc (id, size, NONE)); ctxPutOp ctx (IrCopy (id, lid, size)) end @@ -1236,7 +1237,7 @@ functor IL(P: PARSER) = struct bind A2 f end z - fun printConst class w = + fun pwc class w out = let val (sign, w) = case class of @@ -1251,9 +1252,11 @@ functor IL(P: PARSER) = struct else ("-", Word.~ w) in - printf `sign W w % + Printf out `sign W w % end + val Pwc = fn z => bind A2 pwc z + fun preg (C as Lctx { vregs, ... }) id out = let val rt = getRegType vregs id @@ -1261,8 +1264,8 @@ functor IL(P: PARSER) = struct case rt of RtReg => Printf out `"%" I id % | RtRem => raise Unreachable - | RtConst w => printConst (getClass C id) w - | RtAddrConst (id, w) => (printf `"$" PP.? id %; printConst VR8 w) + | RtConst w => printf Pwc (getClass C id) w % + | RtAddrConst (id, w) => printf `"$" PP.? id Pwc VR8 w % end val Preg = fn z => bind A2 preg z @@ -1272,8 +1275,8 @@ functor IL(P: PARSER) = struct in case arg of SaVReg reg => printf Preg ctx reg % - | SaConst w => printConst (getClass ctx reg) w - | SaAddr (id, w) => (printf PP.? id %; printConst VR8 w) + | SaConst w => printf Pwc (getClass ctx reg) w % + | SaAddr (id, w) => printf PP.? id Pwc VR8 w % end fun printOp ctx (idx, (SOME op', li)) = @@ -1304,7 +1307,15 @@ functor IL(P: PARSER) = struct | printRet (SOME reg) = printf `"\tret " Pt ctx reg `" " Preg ctx reg % - fun printAlloc (r, size) = printf `"\t" Preg ctx r `" = alloc " W size % + fun printAlloc (r, size, off) = + let + val () = printf `"\t" Preg ctx r `" = alloc " W size % + in + case off of + SOME off => printf `" [rbp-" I off `"]" % + | NONE => () + end + fun printCopy (to, from, size) = printf `"\tcopy " Preg ctx to `", .I" I from `", " W size % @@ -1389,9 +1400,9 @@ functor IL(P: PARSER) = struct case t of RtReg => printf `" regular" % | RtRem => printf `" removed" % - | RtConst w => (printf `" const "; printConst class w) + | RtConst w => printf `" const " Pwc class w % | RtAddrConst (id, w) => - (printf `" addr const " PP.? id; printConst class w) + printf `" addr const " PP.? id Pwc class w % ; printf `"\n" % end @@ -53,7 +53,7 @@ signature IL = sig | IrJmp of label | IrRet of vreg option - | IrAlloc of vreg * word + | IrAlloc of vreg * word * int option | IrCopy of vreg * label * word | IrFcall of vreg * vreg * vreg list @@ -75,6 +75,8 @@ signature IL = sig t: regType } + val Pwc: (vregClass, word, 'a, 'b, 'c) a2printer + datatype funcInfo = Fi of { name: int, paramNum: int, @@ -1150,7 +1150,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; if Char.isDigit c then SOME $ ord c - ord #"0" else if Char.isHexDigit c then - SOME $ ord c - ord #"a" + 10 + SOME $ ord (Char.toLower c) - ord #"a" + 10 else NONE @@ -3253,8 +3253,19 @@ functor Parser(structure Tree: TREE; structure P: PPC; ) end + fun makeDivBy8 v = + let + open Word + in + (v + 0w7) div 0w8 * 0w8 + end + fun registerLayout layout t toplev = - D.pushAndGetId iniLayouts (toplev, sizeOfType t, layout) + let + val size = makeDivBy8 $ sizeOfType t + in + D.pushAndGetId iniLayouts (toplev, size, layout) + end fun getLayoutSize id = #2 $ D.get iniLayouts id |