diff options
| -rw-r--r-- | driver.fun | 20 | ||||
| -rw-r--r-- | emit.fun | 364 | ||||
| -rw-r--r-- | emit.sig | 2 | ||||
| -rw-r--r-- | il.fun | 144 | ||||
| -rw-r--r-- | il.sig | 2 | ||||
| -rw-r--r-- | parser.fun | 68 | ||||
| -rw-r--r-- | parser.sig | 2 |
7 files changed, 308 insertions, 294 deletions
@@ -42,7 +42,19 @@ functor Driver(E: EMIT): DRIVER = struct parseFlag C arg tail else case file of - NONE => parseCmdArgs (updateC C s#file (SOME arg) %) tail + NONE => + let + val size = size arg + in + if String.extract (arg, size - 2, NONE) <> ".c" then + die `arg `": expected file with .c suffix" % + else + let + val file = String.substring (arg, 0, size - 2) + in + parseCmdArgs (updateC C s#file (SOME file) %) tail + end + end | SOME _ => die `arg `": file already specified" % fun exec () = @@ -53,7 +65,7 @@ functor Driver(E: EMIT): DRIVER = struct case (#mode config) of Normal => let - val parseCtx = P.createCtx file (#includeDirs config) + val parseCtx = P.createCtx file (#includeDirs config) true fun collect ctx = let @@ -67,9 +79,9 @@ functor Driver(E: EMIT): DRIVER = struct val parseCtx = collect parseCtx val progInfo = P.explode parseCtx - val ilCtx = I.createCtx progInfo + val ilCtx = I.createCtx progInfo (SOME $ file ^ ".i") in - E.emit "/tmp/prog.s" ilCtx + E.emit (file ^ ".s") ilCtx (SOME $ file ^ ".e") end | DebugT => P.P.T.debugPrint file | DebugE => P.P.debugPrint file (#includeDirs config) @@ -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 @@ -2,5 +2,5 @@ signature EMIT = sig structure I: IL - val emit: string -> I.ctx -> unit + val emit: string -> I.ctx -> string option -> unit end @@ -105,6 +105,24 @@ functor IL(P: PARSER) = struct strlits: int list } + 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 + fun updateLctx (Lctx ctx) = fn z => let fun from fname localVars paramNum vregs ops scopes labels = @@ -164,7 +182,7 @@ functor IL(P: PARSER) = struct val len = lvlen + paramNum val vregs = D.create len - val () = printfn `"local + copies: " I len % + val () = dprintf `"local + copies: " I len `"\n" % fun loop idx = if idx = len then @@ -421,7 +439,6 @@ functor IL(P: PARSER) = struct let val v = convExpr ctx ea - val () = printfn `"TYPE: " P.Pctype (P.getT ea) % val offset = getOffset (P.pointsTo $ P.getT ea)field in case v of @@ -1271,78 +1288,77 @@ functor IL(P: PARSER) = struct case rt of RtReg => Printf out `"%" I id % | RtRem => raise Unreachable - | RtConst w => printf Pwc (getClass C id) w % - | RtAddrConst (id, w) => printf `"$" PP.? id Pwc VR8 w % + | RtConst w => Printf out Pwc (getClass C id) w % + | RtAddrConst (id, w) => Printf out `"$" PP.? id Pwc VR8 w % end val Preg = fn z => bind A2 preg z fun printOpSet ctx reg arg = let - val () = printf `"\t" Preg ctx reg `" " Pt ctx reg `" = " % + val () = dprintf `"\t" Preg ctx reg `" " Pt ctx reg `" = " % in case arg of - SaVReg reg => printf Preg ctx reg % - | SaConst w => printf Pwc (getClass ctx reg) w % - | SaAddr (id, w) => printf PP.? id Pwc VR8 w % + SaVReg reg => dprintf Preg ctx reg % + | SaConst w => dprintf Pwc (getClass ctx reg) w % + | SaAddr (id, w) => dprintf PP.? id Pwc VR8 w % end fun printOp ctx (idx, (SOME op', li)) = let - - fun printTail NONE = printf `"\n" % + fun printTail NONE = dprintf `"\n" % | printTail (SOME (startL, endL)) = case op' of - IrNopLabel _ => printf `"\n" % - | _ => printf `" ; (l" I startL `", l" I endL `")\n" % + IrNopLabel _ => dprintf `"\n" % + | _ => dprintf `" ; (l" I startL `", l" I endL `")\n" % - val () = printf I idx `":" % + val () = dprintf I idx `":" % val () = case op' of IrNopLabel _ => () - | _ => printf `"\t" % + | _ => dprintf `"\t" % fun pt (reg1, reg2, reg3) op' = - printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = " + dprintf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = " `op' `" " Preg ctx reg2 `", " Preg ctx reg3 % fun pe (reg1, reg2, aClass) op' = - printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = " + dprintf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = " `op' `" " Pac aClass `" " Preg ctx reg2 % - fun pj (r, l) op' = printf `"\t" `op' `" " Preg ctx r `", " Pl l % + fun pj (r, l) op' = dprintf `"\t" `op' `" " Preg ctx r `", " Pl l % - fun printRet NONE = printf `"\tret" % + fun printRet NONE = dprintf `"\tret" % | printRet (SOME reg) = - printf `"\tret " Pt ctx reg `" " Preg ctx reg % + dprintf `"\tret " Pt ctx reg `" " Preg ctx reg % fun printAlloc (r, size, off) = let - val () = printf `"\t" Preg ctx r `" = alloc " W size % + val () = dprintf `"\t" Preg ctx r `" = alloc " W size % in case off of - SOME off => printf `" [rbp-" I off `"]" % + SOME off => dprintf `" [rbp-" I off `"]" % | NONE => () end fun printCopy (to, from, size) = - printf `"\tcopy " Preg ctx to `", .I" I from `", " W size % + dprintf `"\tcopy " Preg ctx to `", .I" I from `", " W size % fun printFcall (ret, f, args) = let - val () = printf `"\t" % + val () = dprintf `"\t" % val () = if ret <> ~1 then - printf Preg ctx ret `" " Pt ctx ret `" = " % + dprintf Preg ctx ret `" " Pt ctx ret `" = " % else () in - printf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) % + dprintf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) % end fun printLabel (Lctx { labels, ... }) lid = let val (labelPos, use) = D.get labels lid val () = if valOf labelPos <> idx then raise Unreachable else () in - printf `"@" Pl lid `"(" I use `"):" % + dprintf `"@" Pl lid `"(" I use `"):" % end fun cmpOpStr cmpop = @@ -1381,14 +1397,14 @@ functor IL(P: PARSER) = struct | IrExtSign t => pe t "exts" | IrLoad (r1, r2, ac) => - printf `"\t" Preg ctx r1 `" = " Pac ac `" [" Preg ctx r2 `"]" % + dprintf `"\t" Preg ctx r1 `" = " Pac ac `" [" Preg ctx r2 `"]" % | IrStore (r1, r2, ac) => - printf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 % - | IrJmp l => printf `"\tjmp " Pl l % + dprintf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 % + | IrJmp l => dprintf `"\tjmp " Pl l % | IrJz p => pj p "jz" | IrJnz p => pj p "jnz" | IrNopLabel l => printLabel ctx l - | IrNop s => printf `"\t; " `s % + | IrNop s => dprintf `"\t; " `s % | IrRet v => printRet v | IrAlloc p => printAlloc p | IrCopy t => printCopy t @@ -1405,18 +1421,18 @@ functor IL(P: PARSER) = struct let val c = if class = VR4 then "w4" else "w8" - val () = printf `"%" Ip 4 idx `" " `c + val () = dprintf `"%" Ip 4 idx `" " `c `": defs = " Plist i defs (", ", true, 0) `", uses = " Plist i use (", ", true, 0) % in case t of - RtReg => printf `" regular" % - | RtRem => printf `" removed" % - | RtConst w => printf `" const " Pwc class w % + RtReg => dprintf `" regular" % + | RtRem => dprintf `" removed" % + | RtConst w => dprintf `" const " Pwc class w % | RtAddrConst (id, w) => - printf `" addr const " PP.? id Pwc class w % + dprintf `" addr const " PP.? id Pwc class w % ; - printf `"\n" % + dprintf `"\n" % end fun printVars (Lctx { vregs, ... }) = @@ -1434,10 +1450,7 @@ functor IL(P: PARSER) = struct fun constAdd vregs ops vid v insId = let - val () = printfn `"new constant: %" I vid % - val { class, defs, use, ... } = D.get vregs vid - val v = case v of RtConst w => @@ -1453,6 +1466,7 @@ functor IL(P: PARSER) = struct fun f (SOME _, li) = (NONE, li) | f (NONE, _) = raise Unreachable in + dprintf `"%" I vid `", " %; D.update ops f insId end @@ -1564,8 +1578,6 @@ functor IL(P: PARSER) = struct let val rt = getRegType vregs rs val ext = if ext = ExtZero then P.extz else P.exts - - val () = printfn `"eval EXT" % in case rt of RtConst w => RtConst $ ext w (ac2word aClass) @@ -1751,9 +1763,11 @@ functor IL(P: PARSER) = struct fun constPropagate (C as Lctx { vregs, ops, ... }) = let + val () = dprintf `"constants: " % val worklist = getFirstConstants C in - propagate worklist vregs ops + propagate worklist vregs ops; + dprintf `"\n" % end fun changeDest rd ins = @@ -1791,7 +1805,7 @@ functor IL(P: PARSER) = struct fun mergeIns (Lctx { vregs, ops, ... }) idx rd rs = let - val () = printfn `"removing %" I rs % + val () = dprintf `"removing %" I rs `"\n" % val { class, ... } = D.get vregs rs val () = D.set vregs rs @@ -1846,6 +1860,7 @@ functor IL(P: PARSER) = struct fun removeUnusedLabels (Lctx { ops, labels, ... }) = let + val () = dprintf `"removing labels: " % fun rem (insId, (op', _)) = case op' of SOME (IrNopLabel lid) => @@ -1853,7 +1868,7 @@ functor IL(P: PARSER) = struct val (_, usage) = D.get labels lid in if usage = 0 andalso lid <> 0 then ( - printfn `"removing label: " I lid %; + dprintf `"L" I lid `", " %; D.set ops insId (NONE, NONE) ) else () @@ -1868,7 +1883,8 @@ functor IL(P: PARSER) = struct loop (idx + 1) ) in - loop 0 + loop 0; + dprintf `"\n" % end fun removeUnusedVars (Lctx { fname, vregs, localVars, ... }) = @@ -1905,23 +1921,28 @@ functor IL(P: PARSER) = struct loop 0 end - fun translateFn (F as { localVars, stmt, paramNum, name, ... }) = + fun translateFn ({ localVars, stmt, paramNum, name, ... }: P.funcInfo) = let - val () = P.printDef (P.Definition F) + val () = dprintf `"\n\nfunction " PP.? name `"\n\n" % + val ctx = createLocalCtx name localVars paramNum val () = convStmt ctx stmt val () = ctxPutOp ctx (IrNopLabel 0) - val () = printVars ctx val () = printIns ctx + (* + val () = printVars ctx + *) - val () = printf `"\nconstant propagation\n\n" % + val () = dprintf `"\nconstant propagation\n\n" % val () = constPropagate ctx + (* val () = printVars ctx val () = printIns ctx + *) - val () = printf `"\nmisc il optimizations\n\n" % + val () = dprintf `"\nmisc il optimizations\n\n" % val () = removeUnusedLabels ctx val () = removeUnusedVars ctx @@ -1930,8 +1951,10 @@ functor IL(P: PARSER) = struct val () = printVars ctx val () = printIns ctx - val () = printf `"\nvariables\n\n" % + (* + val () = dprintf `"\nvariables\n\n" % val () = printVars ctx + *) val Lctx { vregs, ops, labels, ... } = ctx in @@ -1939,23 +1962,16 @@ functor IL(P: PARSER) = struct paramNum, vregs, ops, labels = D.copy labels (fn (v, _) => v) } end - fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) = + fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) debugFileName = let + val () = + case debugFileName of + NONE => () + | SOME fname => debugFile := SOME (TextIO.openOut fname) + val fis = List.map (fn func => translateFn func) funcs in Ctx { objs, objsZI, extSyms = ext, globSyms = glob, funcInfos = fis, strlits } end - - (* - fun updateCtx (Ctx ctx) = fn z => - let - fun from objs objsZI extSyms globSyms funcInfos strlits = - { objs, objsZI, extSyms, globSyms, funcs, strlits } - fun to f { objs, objsZI, extSyms, globSyms, funcs, strlits } = - f objs objsZI extSyms globSyms funcs strlits - in - FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) - end - *) end @@ -92,5 +92,5 @@ signature IL = sig strlits: int list } - val createCtx: P.progInfo -> ctx + val createCtx: P.progInfo -> string option -> ctx end @@ -720,17 +720,45 @@ functor Parser(structure Tree: TREE; structure P: PPC; | (union_t { fields, ... }) => fields | _ => raise Unreachable - fun createCtx fname incDirs = Ctx { - aggrTypeNames = Tree.empty, - localScopes = [], - funcRetType = NONE, - globalSyms = Tree.empty, - tokenBuf = (P.create { fname, incDirs, debugMode = false }, []), - loopLevel = 0, - paramNum = NONE, - defs = [], - strlits = [] - } + 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 + + fun createCtx fname incDirs debug = + let + val () = + if debug then + debugFile := SOME (TextIO.openOut (fname ^ ".p")) + else + () + in + Ctx { + aggrTypeNames = Tree.empty, + localScopes = [], + funcRetType = NONE, + globalSyms = Tree.empty, + tokenBuf = + (P.create { fname = fname ^ ".c", incDirs, debugMode = false }, []), + loopLevel = 0, + paramNum = NONE, + defs = [], + strlits = [] + } + end fun loopWrapper ctx f = let @@ -3055,7 +3083,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; | f (SOME (GsTypedef _)) = P.error pos `"symbol is already typedef'ed" % - val () = printf `(class2str class) `" decl " + val () = dprintf `(class2str class) `" decl " `(link2str linkage) `" " P.?id `": " Pctype t `"\n" % val ((), tree) = lookup2 (#globalSyms ctx) id f @@ -3905,7 +3933,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; function_t (ret, _, v) => (ret, v) | _ => raise Unreachable in - printf P.?name `" " Plist printParam params (", ", true, 2) + dprintf P.?name `" " Plist printParam params (", ", true, 2) `(if variadic then " variadic" else "") `" -> " Pctype ret `"\n" % end @@ -3920,7 +3948,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; `" = " A2 printIni 0 ini `"\n" % end in - printf Plist pobj objs ("", false, 2) % + dprintf Plist pobj objs ("", false, 2) % end | printDef (Definition (D as { stmt, localVars, ... })) = let @@ -3929,8 +3957,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; `(if onStack then "& " else "") Pctype t `"\n" % in printFuncHeader D; - printf Pstmt 0 stmt %; - Vector.appi (fn (i, var) => printf A2 pLocalVar i var %) localVars + dprintf Pstmt 0 stmt %; + Vector.appi (fn (i, var) => dprintf A2 pLocalVar i var %) localVars end type decl = P.tkPos * declClass * ctype * linkage @@ -4005,10 +4033,16 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (toplev: toplev, ctx) = parseDeclaration ctx in case toplev of - ObjDefs objDefList => (true, ctxAddDef ctx (Objects objDefList)) + ObjDefs objDefList => + let + val () = printDef (Objects objDefList) + in + (true, ctxAddDef ctx (Objects objDefList)) + end | FuncDef (id, body) => let val (def, ctx) = ctxWithLayer ctx body (parseFuncDefinition id) + val () = printDef def in (true, ctxAddDef ctx def) end @@ -145,7 +145,7 @@ signature PARSER = sig (* Objects are in reverse order *) datatype def = Objects of objDef list | Definition of funcInfo - val createCtx: string -> string list -> ctx + val createCtx: string -> string list -> bool -> ctx val parseDef: ctx -> bool * ctx val printDef: def -> unit |