summaryrefslogtreecommitdiff
path: root/il.fun
diff options
context:
space:
mode:
Diffstat (limited to 'il.fun')
-rw-r--r--il.fun144
1 files changed, 80 insertions, 64 deletions
diff --git a/il.fun b/il.fun
index 0e2240c..286cd32 100644
--- a/il.fun
+++ b/il.fun
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-22 16:08:57 +0000