diff options
Diffstat (limited to 'emit.fun')
| -rw-r--r-- | emit.fun | 364 |
1 files changed, 158 insertions, 206 deletions
@@ -20,29 +20,31 @@ functor Emit(I: IL) = struct datatype affinity = AfHard of reg | AfSoft of int list | AfUnk val regs = [ - (Rcx, 0), - (Rsi, 1), - (Rdi, 2), - (R8, 3), - (R9, 4), - (R10, 5), - (R11, 6), - - (Rbx, 7), - (R12, 8), - (R13, 9), - (R14, 10), - (R15, 11), - - (Rdx, 12), + (R8, 0), + (R9, 1), + (R10, 2), + (R11, 3), + + (Rbx, 4), + (R12, 5), + (R13, 6), + (R14, 7), + (R15, 8), + + (Rdi, 9), + (Rsi, 10), + (Rdx, 11), + (Rcx, 12), (Rax, 13), (Rsp, 14), (Rbp, 15) ] - val callerSavedRegs = 7 - val usedRegNum = 12 (* rdx is not counted *) + val callerSavedRegs = 4 + val usedRegNum = 9 + + val usedOverallRegNum = 13 fun reg2idx reg = case List.find (fn (r, _) => r = reg) regs of @@ -54,6 +56,24 @@ functor Emit(I: IL) = struct NONE => raise Unreachable | SOME (r, _) => r + val debugFile = ref NONE + + local + fun output s = + let + val outstream = !debugFile + in + case outstream of + NONE => () + | SOME outstream => TextIO.output (outstream, s) + end + + val ctx = ((false, makePrintfBase output), + fn (_: bool * ((string -> unit) * (unit -> unit))) => ()) + in + fun dprintf g = Fold.fold ctx g + end + local fun output s = let @@ -294,10 +314,11 @@ functor Emit(I: IL) = struct fun printInts ints = let - val () = printfn `"\nsorted intervals:\n" % - fun p (id, s, e) = printfn `"id: %" I id `" {" I s `", " I e `"}" % + val () = dprintf `"\nsorted intervals:\n" % + fun p (id, s, e) = dprintf `"id: %" I id `" {" I s `", " I e `"}\n" % in - List.app p ints + List.app p ints; + dprintf `"\n" % end fun updAff arr idx aff = @@ -451,25 +472,33 @@ functor Emit(I: IL) = struct let val rinfo = Array.array (D.length vregs, (AfUnk, VtUnk)) + val () = compAffinity rinfo ops paramNum; + fun transfer idx acc = if idx = D.length vregs then rev acc else let + val (aff, _) = Array.sub (rinfo, idx) + val (vt, cand) = case #t $ D.get vregs idx of I.RtRem => (VtUnk, NONE) | I.RtConst w => (VtConst (VConst w), NONE) - | I.RtAddrConst (id, w) => (VtConst (VAddrConst (id, w)), NONE) - | I.RtReg => (VtUnk, SOME idx) + | I.RtAddrConst (id, w) => + (VtConst (VAddrConst (id, w)), NONE) + | I.RtReg => ( + case aff of + AfHard reg => (VtReg reg, NONE) + | _ => (VtUnk, SOME idx) + ) in - Array.update (rinfo, idx, (AfUnk, vt)); + Array.update (rinfo, idx, (aff, vt)); transfer (idx + 1) (if isSome cand then valOf cand :: acc else acc) end val toAlloc = transfer 0 [] in - compAffinity rinfo ops paramNum; (toAlloc, rinfo) end @@ -505,12 +534,12 @@ functor Emit(I: IL) = struct fun p (idx, (aff, _)) = let - val () = printf `"%" I idx % + val () = dprintf `"%" I idx % in case aff of - AfUnk => printfn `" = unk" % - | AfHard reg => printfn `" <- " Preg reg % - | AfSoft rss => printfn `" <- " Plist pv rss (", ", true, 1) % + AfUnk => dprintf `" = unk\n" % + | AfHard reg => dprintf `" <- " Preg reg `"\n" % + | AfSoft rss => dprintf `" <- " Plist pv rss (", ", true, 1) `"\n" % end in Array.appi p rinfo @@ -526,12 +555,11 @@ functor Emit(I: IL) = struct FRU.makeUpdate5 (from, from, to) i end z - fun returnToPool (_, rdxRef) Rdx = rdxRef := NONE - | returnToPool (arr, _) reg = + fun returnToPool pool reg = let val idx = reg2idx reg in - Array.update (arr, idx, NONE) + Array.update (pool, idx, NONE) end fun expireOne { rinfo, active, pool, ... } (_, start, _) = @@ -545,9 +573,9 @@ functor Emit(I: IL) = struct val (_, vt) = Array.sub (rinfo, j) val reg = case vt of VtReg reg => reg | _ => raise Unreachable - val () = printfn `"III!!! interval %" + val () = dprintf `"III!!! interval %" ip j `"(" ip startp `", " ip endp `") " - `"with " Preg reg `" has expired" % + `"with " Preg reg `" has expired\n" % in returnToPool pool reg; active := acts; @@ -558,12 +586,12 @@ functor Emit(I: IL) = struct let fun loop I = case expireOne I int of - false => () + false => dprintf `"\n" % | true => loop I in case !active of [] => () - | _ => loop I + | _ => (dprintf `"\n" %; loop I) end fun addToActive int [] = [int] @@ -580,22 +608,17 @@ functor Emit(I: IL) = struct Array.update (arr, idx, (aff, reg)) end - fun getUser (_, rdxRef) Rdx = !rdxRef - | getUser (arr, _) r = Array.sub (arr, reg2idx r) - - fun setUser (_, rdxRef) u Rdx: unit = rdxRef := SOME u - | setUser (arr, _) u r = Array.update(arr, reg2idx r, SOME u) + fun getUser pool r = Array.sub (pool, reg2idx r) + fun setUser pool u r = Array.update(pool, reg2idx r, SOME u) fun assignFirstReg poff { rinfo, pool, ... } vr = let - val regArr = #1 pool - fun loop idx = - if idx = Array.length regArr then + if idx = Array.length pool then raise Unreachable else let - val user = Array.sub (regArr, idx) + val user = Array.sub (pool, idx) in case user of SOME _ => loop (idx + 1) @@ -604,8 +627,8 @@ functor Emit(I: IL) = struct val reg = idx2reg idx val () = setUser pool vr reg - val () = printfn R poff - `"assigned (first) reg " Preg reg `" to %" ip vr % + val () = dprintf R poff + `"assigned (first) reg " Preg reg `" to %" ip vr `"\n" % in updReg rinfo vr (VtReg reg) end @@ -614,7 +637,7 @@ functor Emit(I: IL) = struct loop 0 end - fun freeRegList (pool, _) = + fun freeRegList pool = let fun loop idx acc = if idx = Array.length pool then @@ -660,22 +683,22 @@ functor Emit(I: IL) = struct fun assignSoftReg poff affs (I as { rinfo, pool, ... }) vr = let - val () = printfn R poff - `"trying to assign register (by affinity) to %" ip vr % + val () = dprintf R poff + `"trying to assign register (by affinity) to %" ip vr `"\n" % val regs = freeRegList pool val affRegs = getAffRegList rinfo affs val common = findCommonRegs regs affRegs - val () = printfn R (poff + 1) - `"free registers: " Plist preg regs (", ", true, 0) % - val () = printfn R (poff + 1) - `"affinity registers: " Plist preg affRegs (", ", true, 0) % + val () = dprintf R (poff + 1) + `"free registers: " Plist preg regs (", ", true, 0) `"\n" % + val () = dprintf R (poff + 1) + `"affinity registers: " Plist preg affRegs (", ", true, 0) `"\n" % in case common of [] => let - val () = printfn R (poff + 1) `"affinity was not satisfied" % + val () = dprintf R (poff + 1) `"affinity was not satisfied\n" % in assignFirstReg (poff + 2) I vr end @@ -685,56 +708,24 @@ functor Emit(I: IL) = struct updReg rinfo vr (VtReg reg); setUser pool vr reg; - printfn R (poff + 1) - `"assigned (by affinity) reg " Preg reg `" to %" ip vr %; - printfn R (poff + 1) - `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) % + dprintf R (poff + 1) + `"assigned (by affinity) reg " Preg reg `" to %" ip vr `"\n" %; + dprintf R (poff + 1) + `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) + `"\n" % end end fun putToStack poff { rinfo, stackOff, ... } vr = let val newStackOff = !stackOff - 8 - val () = printfn R poff - `"puting %" ip vr `" to stack: " ip newStackOff % + val () = dprintf R poff + `"puting %" ip vr `" to stack: " ip newStackOff `"\n" % in updReg rinfo vr (VtStack newStackOff); stackOff := newStackOff end - fun assignHardReg poff (I as { rinfo, pool, ... }) vr reg = - let - val () = printfn R poff - `"trying to assign hard reg " A1 preg reg `" to %" ip vr % - - val user = getUser pool reg - - fun setOurReg () = - let - val () = printfn R (poff + 1) `"reg assigned" % - in - setUser pool vr reg; - updReg rinfo vr (VtReg reg) - end - in - case user of - NONE => setOurReg () - | SOME u => - let - val () = if reg = Rdx then raise Unreachable else () - - val () = printfn R (poff + 1) `"reg is taken by %" ip u % - val (aff, _) = Array.sub (rinfo, u) - in - case aff of - AfHard _ => raise Unreachable - | AfSoft affs => assignSoftReg poff affs I u - | AfUnk => assignFirstReg poff I u - ; - setOurReg () - end - end - fun assignReg (I as { rinfo, ... }) (vr, _, _) = let val (aff, _) = Array.sub (rinfo, vr) @@ -742,11 +733,10 @@ functor Emit(I: IL) = struct case aff of AfUnk => assignFirstReg 0 I vr | AfSoft affs => assignSoftReg 0 affs I vr - | AfHard reg => assignHardReg 0 I vr reg + | AfHard _ => raise Unreachable end - (* Ref is for Rdx *) - fun getPool () = (Array.array (usedRegNum, NONE), ref NONE) + fun getPool () = Array.array (usedRegNum, NONE) fun changeInActive active newInt oldVr = let @@ -756,42 +746,13 @@ functor Emit(I: IL) = struct active := addToActive newInt a end - fun expropriateReg (I as { rinfo, pool = (pool, _), active, ... }) - int reg = + fun userIdx pool vr = let - val vr = #1 int - - val () = if reg = Rdx then raise Unreachable else () - - val regIdx = reg2idx reg - val u = valOf $ Array.sub (pool, regIdx) - - val (uAff, _) = Array.sub (rinfo, u) - val () = - case uAff of - AfHard _ => raise Unreachable - | _ => () - - val () = putToStack 1 I u - val () = Array.update (pool, regIdx, SOME vr) - val () = updReg rinfo vr (VtReg reg) - in - changeInActive active int u - end - - fun userIdx (arr, rdxRef) vr = - let - val () = - if !rdxRef = SOME vr then - raise Unreachable - else - () - fun loop idx = - if idx = Array.length arr then + if idx = Array.length pool then raise Unreachable else - case Array.sub (arr, idx) of + case Array.sub (pool, idx) of SOME u => if u = vr then idx @@ -807,51 +768,25 @@ functor Emit(I: IL) = struct val spill = List.last (!active) val vr = #1 int - val (ourAff, _) = Array.sub (rinfo, vr) - - fun isNotHard vr = - case #1 $ Array.sub (rinfo, vr) of - AfHard _ => false - | _ => true - val () = printfn `"SpilAtInt" % - val () = printfn R 0 - `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) % + val () = dprintf `"SpillAtInt\n" % + val () = dprintf R 0 + `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) `"\n" % in - case ourAff of - AfHard reg => expropriateReg I int reg - | _ => - if #3 spill > #3 int andalso isNotHard (#1 spill) then - let - val idx = userIdx pool (#1 spill) - val () = printfn `"spilling!!!" % - val reg = idx2reg idx - in - setUser pool vr reg; - updReg rinfo vr (VtReg reg); - putToStack 1 I (#1 spill); - changeInActive active int (#1 spill) - end - else - putToStack 0 I vr - end - - fun haveRoomForVR { rinfo, active, pool = (_, rdxRef), ... } vr = - if length (!active) < usedRegNum then - true - else + if #3 spill > #3 int then let - val (aff, _) = Array.sub (rinfo, vr) + val () = dprintf `"spilling!!!\n" % + val idx = userIdx pool (#1 spill) + val reg = idx2reg idx in - case aff of - AfHard Rdx => - if isSome (!rdxRef) then - raise Unreachable - else - true - | _ => false + setUser pool vr reg; + updReg rinfo vr (VtReg reg); + putToStack 1 I (#1 spill); + changeInActive active int (#1 spill) end - + else + putToStack 0 I vr + end fun linearscan rinfo ints stackOff = let @@ -863,13 +798,13 @@ functor Emit(I: IL) = struct fun loop { stackOff, ... } [] = stackOff | loop (I as { active, ... }) (int :: ints) = let - val () = printfn `"\n\ninspectiing interval " - ip (#1 int) `": (" ip (#2 int) `", " ip (#3 int) `")" % - val () = expireOld I int + val () = dprintf `"inspecting interval %" + ip (#1 int) `": (" ip (#2 int) `", " ip (#3 int) `")\n" % + val () = - if haveRoomForVR I (#1 int) then + if length (!active) < usedRegNum then let val () = assignReg I int in @@ -885,17 +820,6 @@ functor Emit(I: IL) = struct stackOff = ref stackOff } ints end - fun printAllocVar rinfo v = - let - val () = printf `"%" I v `": " % - val (_, vt) = Array.sub (rinfo, v) - in - case vt of - VtStack off => printfn `"stack " I off % - | VtReg reg => printfn `"reg " A1 preg reg % - | VtConst _ | VtUnk => raise Unreachable - end - fun pr is8 reg out = let fun old s = @@ -927,16 +851,28 @@ functor Emit(I: IL) = struct | Rsp => old "rsp" | Rbp => old "rbp" end + + fun printAllocVar rinfo v = + let + val () = dprintf `"%" I v `": " % + val (_, vt) = Array.sub (rinfo, v) + in + case vt of + VtStack off => dprintf `"stack " I off `"\n" % + | VtReg reg => dprintf `"reg " A1 preg reg `"\n" % + | VtConst _ | VtUnk => raise Unreachable + end + fun printAlloced rinfo toAlloc = let - val () = printfn `"\nallocated:\n" % + val () = dprintf `"\nallocated:\n\n" % in List.app (printAllocVar rinfo) toAlloc end fun getUsedRegs rinfo = let - val regs = Array.array (usedRegNum + 1, false) + val regs = Array.array (usedOverallRegNum, false) fun loop idx = if idx = Array.length rinfo then @@ -946,10 +882,7 @@ functor Emit(I: IL) = struct val (_, vt) = Array.sub (rinfo, idx) in case vt of - VtReg reg => ( - printfn `"reg: " A2 pr true reg %; - Array.update (regs, reg2idx reg, true) - ) + VtReg reg => Array.update (regs, reg2idx reg, true) | _ => (); loop (idx + 1) end @@ -1016,30 +949,43 @@ functor Emit(I: IL) = struct fun printMap map = let - val () = printfn `"Register map\n" % + val () = dprintf `"Register map\n\n" % fun printHeader idx = if idx = callerSavedRegs then - printf `"\n" % - else ( - printfp 5 `" " Preg (idx2reg idx) `" " %; - printHeader (idx + 1) - ) - - val () = printf `" " % + dprintf `"\n" % + else + let + val reg = sprintf Preg (idx2reg idx) % + val reg = if size reg = 3 then reg else " " ^ reg + in + dprintf `" " `reg `" " %; + printHeader (idx + 1) + end + val () = dprintf `" " % val () = printHeader 0 fun printRow (idx, row) = let - val () = printf Ip 4 idx `": " % + val () = dprintf Ip 4 idx `": " % fun loop idx = if idx = callerSavedRegs then - printf `"\n" % + dprintf `"\n" % else ( case Array.sub (row, idx) of - NONE => printf `" " % - | SOME vr => printfp 5 `"%" I vr `" " %; + NONE => dprintf `" " % + | SOME vr => + let + val n: string = sprintf I vr % + val n = + if size n < 3 then + implode (List.tabulate (3 - size n, fn _ => #" ")) ^ n + else + n + in + dprintf `" " `n `" " % + end; loop (idx + 1) ) in @@ -1058,7 +1004,6 @@ functor Emit(I: IL) = struct 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 @@ -1081,7 +1026,7 @@ functor Emit(I: IL) = struct let val stackOffset = resolveAlloc ops val (toAlloc, regInfo) = prepareRegInfo paramNum ops vregs - val () = printfn `"for alloc: " Plist i toAlloc (", ", true, 0) % + val () = dprintf `"for alloc: " Plist i toAlloc (", ", true, 0) `"\n" % val () = affPrint regInfo @@ -1091,8 +1036,8 @@ functor Emit(I: IL) = struct val () = printAlloced regInfo toAlloc val regsToSave = getRegsToSave regInfo - val () = printfn - `"registers to save: " Plist preg regsToSave (", ", true, 0) % + val () = dprintf + `"registers to save: " Plist preg regsToSave (", ", true, 0) `"\n" % val regMap = computeMap (D.length ops) intervals regInfo val () = printMap regMap @@ -2115,8 +2060,15 @@ functor Emit(I: IL) = struct fun openFile fname = file := SOME (TextIO.openOut fname) fun emit fname - (I.Ctx { globSyms, extSyms, objsZI, objs, strlits, funcInfos, ... }) = + (I.Ctx { globSyms, extSyms, objsZI, objs, strlits, funcInfos, ... }) + debugFileName + = let + + val () = + case debugFileName of + NONE => () + | SOME fname => debugFile := SOME (TextIO.openOut fname) val () = openFile fname val () = List.app (fn gs => fprint `"global " PP.? gs `"\n" %) globSyms |