diff options
| -rw-r--r-- | common.sml | 5 | ||||
| -rw-r--r-- | il.fun | 774 | ||||
| -rw-r--r-- | parser.fun | 106 | ||||
| -rw-r--r-- | parser.sig | 4 |
4 files changed, 770 insertions, 119 deletions
@@ -26,6 +26,7 @@ structure FRU = struct fun f7 z = next f6 z fun f8 z = next f7 z fun f9 z = next f8 z + fun f10 z = next f9 z fun c0 from = from fun c1 from = c0 from f1 @@ -37,6 +38,7 @@ structure FRU = struct fun c7 from = c6 from f7 fun c8 from = c7 from f8 fun c9 from = c8 from f9 + fun c10 from = c9 from f10 fun makeUpdate cX (from, from', to) record = let @@ -55,6 +57,7 @@ structure FRU = struct fun makeUpdate7 z = makeUpdate c7 z fun makeUpdate8 z = makeUpdate c8 z fun makeUpdate9 z = makeUpdate c9 z + fun makeUpdate10 z = makeUpdate c10 z fun upd z = Fold.step2 (fn (s, f, (vars, ops)) => @@ -147,6 +150,8 @@ fun bindWith2str to = bind A1 (fn v => fn (output, _) => output $ to v) fun F z = bind A0 (fn (_, mf) => mf ()) z val I = fn z => bindWith2str Int.toString z +fun i v out = Printf out I v % + val C = fn z => bindWith2str str z val B = fn z => bindWith2str Bool.toString z val W = fn z => bindWith2str (Word.fmt StringCvt.DEC) z @@ -18,11 +18,12 @@ functor IL(P: PARSER) = struct type vreg = int type label = int - datatype setArg = SaVReg of vreg | SaConst of word | SaGL of P.nid + datatype setArg = SaVReg of vreg | SaConst of word | + SaAddr of P.nid * word datatype accessClass = AC1 | AC2 | AC4 | AC8 - datatype irIsn = + datatype irIns = IrSet of vreg * setArg | IrAdd of vreg * vreg * vreg | IrSub of vreg * vreg * vreg @@ -63,17 +64,34 @@ functor IL(P: PARSER) = struct | IrRet of vreg option | IrAlloc of vreg * word | IrCopy of vreg * label * word + | IrFcall of vreg * vreg * vreg list | IrNopLabel of label + | IrNop of string datatype ev = Reg of vreg | Addr of vreg + datatype regType = + RtUnk | + RtConst of word | + RtAddrConst of int * word + + type regInfo = { + class: vregClass, + use: int list, + defs: int list, + t: regType + } + datatype localCtx = Lctx of { localVars: { onStack: bool, t: P.ctype } vector, - vregs: { class: vregClass } D.t, + vregs: regInfo D.t, newLabelNum: int, - ops: irIsn list, - loopLabels: { break: label, continue: label } list + ops: irIns list, + opTable: (irIns option) array option, + curPos: int, (* length ops + 1 *) + loopLabels: { break: label, continue: label } list, + paramNum: int } (* @@ -90,14 +108,19 @@ functor IL(P: PARSER) = struct fun updateLctx (Lctx ctx) = fn z => let - fun from localVars vregs ops newLabelNum loopLabels = - { localVars, vregs, ops, newLabelNum, loopLabels } - fun to f { localVars, vregs, ops, newLabelNum, loopLabels } = - f localVars vregs ops newLabelNum loopLabels + fun from localVars vregs ops opTable curPos newLabelNum loopLabels + paramNum = + { localVars, vregs, ops, opTable, curPos, newLabelNum, loopLabels, + paramNum } + fun to f { localVars, vregs, ops, opTable, curPos, newLabelNum, + loopLabels, paramNum } = + f localVars vregs ops opTable curPos newLabelNum loopLabels paramNum in - FRU.makeUpdate5 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f)) + FRU.makeUpdate8 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f)) end + fun isLocal (Lctx { localVars, ... }) id = id < Vector.length localVars + fun typeAccessClass t = case P.sizeOfType t of 0w1 => AC1 @@ -106,6 +129,12 @@ functor IL(P: PARSER) = struct | 0w8 => AC8 | _ => raise Unreachable + fun ac2word AC1 = 0w1 + | ac2word AC2 = 0w2 + | ac2word AC4 = 0w4 + | ac2word AC8 = 0w8 + + fun getRegType vregs r = #t $ D.get vregs r fun setupLocalVars localVars = let @@ -116,7 +145,7 @@ functor IL(P: PARSER) = struct Vector.fromList (rev acc) else let - val { onStack: bool, t, ... } = Vector.sub (localVars, idx) + val { onStack: bool, t: P.ctype, ... } = Vector.sub (localVars, idx) in setup (idx + 1) ({ onStack, t } :: acc) end @@ -130,33 +159,144 @@ functor IL(P: PARSER) = struct | EQUAL => VR8 | LESS => VR4 - fun setupVregs localVars = + fun getClassSize VR4 = 0w4 + | getClassSize VR8 = 0w8 + + fun setupVregs localVars paramNum = let - val len = Vector.length localVars + val lvlen = Vector.length localVars + val len = lvlen + paramNum val vregs = D.create len + val () = printfn `"local + copies: " I len % + fun loop idx = if idx = len then () else - let - val { t, onStack, ... } = Vector.sub (localVars, idx) - val class = if onStack then VR8 else getClassForType t - in - D.push vregs ({ class }); - loop (idx + 1) - end + if idx < lvlen then + let + val { t, onStack, ... } = Vector.sub (localVars, idx) + val class = if onStack then VR8 else getClassForType t + val defs = if idx < paramNum then [0] else [] + in + D.push vregs ({ class, defs, use = [], t = RtUnk }); + loop (idx + 1) + end + else + let + val { class, ... } = D.get vregs (idx - lvlen) + in + D.push vregs ({ class, defs = [], use = [], t = RtUnk }); + loop (idx + 1) + end val () = loop 0 in vregs end - fun createLocalCtx localVars = + fun getInsInfo op' = + let + fun tr (rd, rs1, rs2) = { defs = [rd], use = [rs1, rs2] } + fun de (rd, rs1) = { defs = [rd], use = [rs1] } + fun set reg arg = + { defs = [reg], use = case arg of SaVReg rs => [rs] | _ => [] } + in + case op' of + IrAdd t => tr t + | IrSub t => tr t + | IrMul t => tr t + | IrIMul t => tr t + | IrDiv t => tr t + | IrIDiv t => tr t + | IrMod t => tr t + | IrIMod t => tr t + | IrShl t => tr t + | IrShr t => tr t + | IrSar t => tr t + | IrAnd t => tr t + | IrOr t => tr t + | IrXor t => tr t + | IrEq t => tr t + | IrNeq t => tr t + | IrCmpul t => tr t + | IrCmpug t => tr t + | IrCmpule t => tr t + | IrCmpuge t => tr t + | IrCmpsl t => tr t + | IrCmpsg t => tr t + | IrCmpsle t => tr t + | IrCmpsge t => tr t + + | IrExtZero (rd, rs, _) => de (rd, rs) + | IrExtSign (rd, rs, _) => de (rd ,rs) + + | IrSet (reg, arg) => set reg arg + + | IrLoad (r1, r2, _) => de (r1, r2) + | IrStore (r1, r2, _) => { defs = [], use = [r1, r2] } + | IrJmp _ => { defs = [], use = [] } + | IrJz (r, _) => { defs = [], use = [r] } + | IrJnz (r, _) => { defs = [], use = [r] } + | IrNopLabel _ | IrNop _ => { defs = [], use = [] } + | IrRet v => { defs = [], use = case v of SOME r => [r] | _ => [] } + | IrAlloc (r, _) => { defs = [r], use = [] } + | IrCopy (r, _, _) => { defs = [], use = [r] } + | IrFcall (rd, f, args) => + { defs = if rd = ~1 then [] else [rd], use = f :: args } + end + + fun updateDefsUse (Lctx { vregs, ... }) defs use pos = + let + fun updateDef vr = + let + val { class, defs, use, t } = D.get vregs vr + in + D.set vregs vr { class, defs = pos :: defs, use, t } + end + fun updateUse vr = + let + val { class, defs, use, t } = D.get vregs vr + in + D.set vregs vr { class, defs, use = pos :: use, t } + end + + in + List.app updateDef defs; + List.app updateUse use + end + + fun ctxPutOp (C as Lctx { curPos, ... }) op' = + let + val { defs, use } = getInsInfo op' + val insPos = curPos + 1 + val () = updateDefsUse C defs use insPos + in + updateLctx C u#ops (fn l => op' :: l) u#curPos (fn pos => pos + 1) % + end + + fun copyArgs (C as Lctx { localVars, paramNum, ... }) = + let + val lvlen = Vector.length localVars + + fun loop ctx idx = + if idx = paramNum then + ctx + else + loop (ctxPutOp ctx (IrSet (idx + lvlen, SaVReg idx))) (idx + 1) + val ctx = loop C 0 + in + ctx + end + + fun createLocalCtx localVars paramNum = let val localVars = setupLocalVars localVars - val vregs = setupVregs localVars + val vregs = setupVregs localVars paramNum + val ctx = Lctx { localVars, vregs, ops = [], opTable = NONE, curPos = 0, + newLabelNum = 0, loopLabels = [], paramNum } in - Lctx { localVars, vregs, ops = [], newLabelNum = 0, loopLabels = [] } + copyArgs ctx end (* @@ -172,7 +312,7 @@ functor IL(P: PARSER) = struct fun getNewVReg class (Lctx { vregs, ... }) = let - val id = D.pushAndGetId vregs ({ class }) + val id = D.pushAndGetId vregs ({ class, defs = [], use = [], t = RtUnk }) in id end @@ -180,8 +320,6 @@ functor IL(P: PARSER) = struct val getNew4 = getNewVReg VR4 val getNew8 = getNewVReg VR8 - fun ctxPutOp ctx op' = updateLctx ctx u#ops (fn l => op' :: l) % - fun newConst ctx class w = let val v = getNewVReg class ctx @@ -191,6 +329,9 @@ functor IL(P: PARSER) = struct fun getClass (Lctx { vregs, ... }) id = #class $ D.get vregs id + fun pv (Reg v) out = Printf out `"Reg %" I v % + | pv (Addr v) out = Printf out `"Addr %" I v % + fun convConst ctx (w, t) = let val class = @@ -207,7 +348,7 @@ functor IL(P: PARSER) = struct fun convGLconst ctx (id, isFunc) = let val v = getNew8 ctx - val ctx = ctxPutOp ctx (IrSet (v, SaGL id)) + val ctx = ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0))) in if isFunc then (Reg v, ctx) @@ -216,12 +357,15 @@ functor IL(P: PARSER) = struct end fun convId ctx (P.Gid p) = convGLconst ctx p - | convId (C as Lctx { localVars, ... }) (P.Lid id) = - let - val onStack = #onStack $ Vector.sub (localVars, id) - in - ((if onStack then Addr else Reg) id, C) - end + | convId (C as Lctx { localVars, paramNum, ... }) (P.Lid id) = + if id < paramNum then (* function parameter *) + (Reg $ id + Vector.length (localVars), C) + else + let + val onStack = #onStack $ Vector.sub (localVars, id) + in + ((if onStack then Addr else Reg) id, C) + end fun getOffset ea field = #1 $ valOf $ P.getFieldInfo (P.getT ea) field @@ -269,12 +413,18 @@ functor IL(P: PARSER) = struct (Reg v, ctx) end + and getSingleOffset t = + if P.isPointer t then + P.sizeOfType (P.pointsTo t) + else + 0w1 + and convPre op' ctx (v, t) = case v of Reg v => let val class = getClass ctx v - val (v1, ctx) = newConst ctx class 0w1 + val (v1, ctx) = newConst ctx class (getSingleOffset t) val ctx = ctxPutOp ctx (op' (v, v, v1)) in @@ -286,7 +436,7 @@ functor IL(P: PARSER) = struct val aClass = typeAccessClass t val vl = getNewVReg class ctx val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) - val (v1, ctx) = newConst ctx class 0w1 + val (v1, ctx) = newConst ctx class (getSingleOffset t) val ctx = ctxPutOp ctx (op' (vl, vl, v1)) val ctx = ctxPutOp ctx (IrStore (v, vl, aClass)) in @@ -300,7 +450,7 @@ functor IL(P: PARSER) = struct val class = getClass ctx v val vOld = getNewVReg class ctx val ctx = ctxPutOp ctx (IrSet (vOld, SaVReg v)) - val (v1, ctx) = newConst ctx class 0w1 + val (v1, ctx) = newConst ctx class (getSingleOffset t) val ctx = ctxPutOp ctx (op' (v, v, v1)) in (Reg vOld, ctx) @@ -313,7 +463,7 @@ functor IL(P: PARSER) = struct val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) val vOld = getNewVReg class ctx val ctx = ctxPutOp ctx (IrSet (vOld, SaVReg vl)) - val (v1, ctx) = newConst ctx class 0w1 + val (v1, ctx) = newConst ctx class (getSingleOffset t) val ctx = ctxPutOp ctx (op' (vl, vl, v1)) val ctx = ctxPutOp ctx (IrStore (v, vl, aClass)) in @@ -458,7 +608,7 @@ functor IL(P: PARSER) = struct (vNew, vLeft, vRight, ctx) end - and convSimple ctx t vLeft vRight op' = + and convSimple op' ctx t vLeft vRight = let val (vNew, vLeft, vRight, ctx) = binopPrepOpers ctx t vLeft vRight val ctx = ctxPutOp ctx (op' (vNew, vLeft, vRight)) @@ -559,7 +709,7 @@ functor IL(P: PARSER) = struct (Addr res, ctx) end - and convCompAssign ctx (leftT, vLeft) (rightT, vRight) (op', op2) = + and convCompAssign (op', op2) ctx (leftT, vLeft) (rightT, vRight) = let val (vRight, ctx) = loadIfNeeded ctx rightT vRight val leftT = P.resolveType leftT @@ -581,6 +731,18 @@ functor IL(P: PARSER) = struct val (vRight, ctx) = convIfNeeded ctx rightT vRight val op' = if P.isSigned commonType then op2 else op' + val (vRight, ctx) = + if P.isPointer leftT then + let + val (mul, ctx) = + newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT)) + val vm = getNew8 ctx + val ctx = ctxPutOp ctx (IrMul (vm, vRight, mul)) + in + (vm, ctx) + end + else + (vRight, ctx) val ctx = ctxPutOp ctx (op' (vLeft, vLeft, vRight)) in (vLeft, ctx) @@ -695,8 +857,8 @@ functor IL(P: PARSER) = struct fun commonWrapper f ctx (leftT, vLeft) (_, vRight) = f ctx leftT vLeft vRight - val convSimple = apply $ commonWrapper convSimple - val convCompAssign = apply convCompAssign + val convSimple = fn op' => apply $ commonWrapper (convSimple op') + val convCompAssign = fn opp => apply $ convCompAssign opp in case binop of P.BR P.BrMul => convSimple (chs IrIMul IrMul) @@ -759,9 +921,69 @@ functor IL(P: PARSER) = struct (Reg vRes, ctx) end - (* - EfuncCall of exprAug * exprAug list | - *) + and convFuncCall ctx func args = + let + val t = P.getT func + val (vFunc, ctx) = convExpr ctx func + val (vFunc, ctx) = loadIfNeeded ctx t vFunc + val (vFunc, ctx) = + case (getClass ctx vFunc) of + VR4 => + let + val v = getNew8 ctx + in + (v, ctxPutOp ctx (IrSet (v, SaVReg vFunc))) + end + | VR8 => (vFunc, ctx) + + fun genArgs ctx [] acc = + let + fun loop ctx _ [] acc2 = (rev acc2, ctx) + | loop ctx idx (vArg :: acc) acc2 = + let + val arg = getNewVReg (getClass ctx vArg) ctx + val ctx = ctxPutOp ctx (IrSet (arg, SaVReg vArg)) + in + loop ctx (idx + 1) acc (arg :: acc2) + end + in + loop ctx 0 acc [] + end + | genArgs ctx (arg :: args) acc = + let + val (vArg, ctx) = convExpr ctx arg + val (vArg, ctx) = loadIfNeeded ctx (P.getT arg) vArg + val (vArg, ctx) = + if isLocal ctx vArg then + let + val vA = getNewVReg (getClassForType t) ctx + val ctx = ctxPutOp ctx (IrSet (vA, SaVReg vArg)) + in + (vA, ctx) + end + else + (vArg, ctx) + + in + genArgs ctx args (vArg :: acc) + end + + val (args, ctx) = genArgs ctx args [] + + val rt = #1 $ P.funcParts (P.pointsTo t) + val vRes = + case P.resolveType rt of + P.void_t => ~1 + | t => + let + val class = getClassForType t + val vRes = getNewVReg class ctx + in + vRes + end + in + (Reg vRes, ctxPutOp ctx (IrFcall (vRes, vFunc, args))) + end and convExpr ctx ea: ev * localCtx = let @@ -778,7 +1000,7 @@ functor IL(P: PARSER) = struct | P.Eunop (unop, ea) => convUnop ctx unop ea t | P.Ebinop (binop, left, right) => convBinop ctx binop left right | P.Eternary (cond, left, right) => convTernary ctx cond left right - | P.EfuncCall (_, _) => raise Unimplemented + | P.EfuncCall (func, args) => convFuncCall ctx func args end fun convIni (C as Lctx { localVars, ... }) (id, NONE) = @@ -890,6 +1112,37 @@ functor IL(P: PARSER) = struct ctxPutOp C (IrJmp label) end + and convFor ctx (pre, cond, post, stmt) = + let + val ctx = + case pre of + NONE => ctx + | SOME ea => #2 $ convExpr ctx ea + val (startL, ctx) = getLabel ctx + val (breakL, contL, ctx) = ctxGetLoopLabels ctx + + val ctx = ctxPutOp ctx (IrNopLabel startL) + val ctx = + case cond of + NONE => ctx + | SOME cond => + let + val (cond, ctx) = genLogPart ctx cond + in + ctxPutOp ctx (IrJz (cond, breakL)) + end + val ctx = convStmt ctx stmt + val ctx = ctxPutOp ctx (IrNopLabel contL) + val ctx = + case post of + NONE => ctx + | SOME post => #2 $ convExpr ctx post + val ctx = ctxPutOp ctx (IrJmp startL) + val ctx = ctxPutOp ctx (IrNopLabel breakL) + in + ctx + end + and convStmt ctx stmt = case stmt of P.StmtExpr ea => #2 $ convExpr ctx ea @@ -903,18 +1156,11 @@ functor IL(P: PARSER) = struct end | P.StmtIf t => convIf ctx t | P.StmtReturn ea => convReturn ctx ea + | P.StmtFor quad => convFor ctx quad | P.StmtWhile pair => convWhile ctx pair | P.StmtDoWhile pair => convDoWhile ctx pair | P.StmtBreak => convBreakOrCont true ctx | P.StmtContinue => convBreakOrCont false ctx - | _ => raise Unimplemented - - val Preg = fn z => - let - fun f id out = Printf out `"%" I id % - in - bind A1 f - end z val Pl = fn z => let @@ -948,36 +1194,79 @@ functor IL(P: PARSER) = struct bind A2 f end z + fun printConst class w = + let + val (sign, w) = + case class of + VR4 => + if w < Word.<< (0w1, 0w31) then + ("+", w) + else + ("-", Word.~ (P.exts w 0w4)) + | VR8 => + if w < Word.<< (0w1, 0w63) then + ("+", w) + else + ("-", Word.~ w) + in + printf `sign W w % + end + + fun preg (C as Lctx { vregs, ... }) id out = + let + val rt = getRegType vregs id + in + case rt of + RtUnk => Printf out `"%" I id % + | RtConst w => printConst (getClass C id) w + | RtAddrConst (id, w) => (printf `"$" PP.? id %; printConst VR8 w) + end + val Preg = fn z => bind A2 preg z + fun printOpSet ctx reg arg = let - val () = printf `"\t" Preg reg `" " Pt ctx reg `" = " % + val () = printf `"\t" Preg ctx reg `" " Pt ctx reg `" = " % in case arg of - SaVReg reg => printf Preg reg % - | SaConst w => printf W w % - | SaGL id => printf PP.? id % + SaVReg reg => printf Preg ctx reg % + | SaConst w => printConst (getClass ctx reg) w + | SaAddr (id, w) => (printf PP.? id %; printConst VR8 w) end - fun printOp ctx op' = + fun printOp ctx (idx, SOME op') = let + + val () = printf I idx `":" % fun pt (reg1, reg2, reg3) op' = - printf `"\t" Preg reg1 `" " Pt ctx reg1 `" = " - `op' `" " Preg reg2 `", " Preg reg3 % + printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = " + `op' `" " Preg ctx reg2 `", " Preg ctx reg3 % fun pe (reg1, reg2, aClass) op' = - printf `"\t" Preg reg1 `" " Pt ctx reg1 `" = " - `op' `" " Pac aClass `" " Preg reg2 % + printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = " + `op' `" " Pac aClass `" " Preg ctx reg2 % - fun pj (r, l) op' = printf `"\t" `op' `" " Preg r `", " Pl l % + fun pj (r, l) op' = printf `"\t" `op' `" " Preg ctx r `", " Pl l % fun printRet NONE = printf `"\tret" % | printRet (SOME reg) = - printf `"\tret " Pt ctx reg `" " Preg reg % + printf `"\tret " Pt ctx reg `" " Preg ctx reg % - fun printAlloc (r, size) = printf `"\t" Preg r `" = alloc " W size % + fun printAlloc (r, size) = printf `"\t" Preg ctx r `" = alloc " W size % fun printCopy (to, from, size) = - printf `"\tcopy " Preg to `", .I" I from `", " W size % + printf `"\tcopy " Preg ctx to `", .I" I from `", " W size % + + fun printFcall (ret, f, args) = + let + val () = printf `"\t" % + val () = + if ret <> ~1 then + printf Preg ctx ret `" " Pt ctx ret `" = " % + else + () + in + printf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) % + end in case op' of IrSet (reg, arg) => printOpSet ctx reg arg @@ -1010,32 +1299,367 @@ functor IL(P: PARSER) = struct | IrExtSign t => pe t "exts" | IrLoad (r1, r2, ac) => - printf `"\t" Preg r1 `" = " Pac ac `" [" Preg r2 `"]" % + printf `"\t" Preg ctx r1 `" = " Pac ac `" [" Preg ctx r2 `"]" % | IrStore (r1, r2, ac) => - printf `"\t" Pac ac `" [" Preg r1 `"] <- " Preg r2 % + printf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 % | IrJmp l => printf `"\tjmp " Pl l % | IrJz p => pj p "jz" | IrJnz p => pj p "jnz" - | IrNopLabel l => printf Pl l `":" % + | IrNopLabel l => printf `"@" Pl l `":" % + | IrNop s => printf `"\t; " `s % | IrRet v => printRet v | IrAlloc p => printAlloc p | IrCopy t => printCopy t + | IrFcall t => printFcall t ; printf `"\n" % end + | printOp _ (_, NONE) = () + + fun printIns (C as Lctx { opTable, ... }) = + Array.appi (printOp C) (valOf opTable) + + fun printVar idx { class, defs, use, t = _ } = + let + in + printfn `"%" I idx `" " `(if class = VR4 then "w4" else "w8") + `": defs = " Plist i defs (", ", true, 0) + `", uses = " Plist i use (", ", true, 0) % + end + + fun printVars (Lctx { vregs, ... }) = + let + fun loop idx = + if idx = D.length vregs then + () + else ( + printVar idx (D.get vregs idx); + loop (idx + 1) + ) + in + loop 0 + end + + fun createInsTable (C as Lctx { ops, ... }) = + let + val l = NONE :: map (fn v => SOME v) (rev ops) + val arr = Array.fromList l + in + updateLctx C s#opTable (SOME arr) % + end + + fun constAdd vregs opTable vid v insId = + let + val () = printfn `"new constant: %" I vid % + + val { class, defs, use, t = _ } = D.get vregs vid + + val v = + case v of + RtConst w => + let + val w = P.extz w (getClassSize class) + in + RtConst w + end + | RtAddrConst (id, 0w0) => RtAddrConst (id, 0w0) + | RtAddrConst _ | RtUnk => raise Unreachable + val () = D.set vregs vid { class, defs, use, t = v } + in + Array.update (opTable, insId, NONE) + end + + fun getFirstConstants + (Lctx { vregs, opTable, localVars, paramNum, ... }) = + let + val opTable = valOf opTable + + fun loop vid acc = + if vid = D.length vregs then + rev acc + else + let + val { defs, ... } = D.get vregs vid + + fun addConst arg def = + let + val v = + case arg of + SaConst w => RtConst w + | SaAddr p => RtAddrConst p + | _ => raise Unreachable + in + constAdd vregs opTable vid v def + end + in + case defs of + [def] => + let + val ins = valOf $ Array.sub (opTable, def) + in + case ins of + IrSet(_, arg as SaConst _ | arg as SaAddr _) => + let + val () = addConst arg def + in + loop (vid + 1) (vid :: acc) + end + | _ => loop (vid + 1) acc + end + | _ => loop (vid + 1) acc + end + in + loop (Vector.length localVars + paramNum) [] + end + + datatype ext = ExtSign | ExtZero + + fun getCS vregs r = + let + val { class, ... } = D.get vregs r + in + getClassSize class + end + + fun evalPrep supThird vregs (rd, rs1, rs2) ext = + let + val getC = getCS vregs + + val () = + if getC rs1 <> getC rs2 then + raise Unreachable + else + if not supThird andalso getC rd <> getC rs1 then + raise Unreachable + else + () + + val rt1 = getRegType vregs rs1 + val rt2 = getRegType vregs rs2 + val size = getC rd + + in + case (rt1, rt2) of + (RtConst w1, RtConst w2) => ( + case ext of + ExtZero => SOME (P.extz w1 size, P.extz w2 size) + | ExtSign => SOME (P.exts w1 size, P.exts w2 size) + ) + | _ => NONE + end + + fun evalSimple supThird vregs ext triple op' = + case evalPrep supThird vregs triple ext of + SOME wp => RtConst (op' wp) + | NONE => RtUnk + + fun evalSet vregs (rd, SaVReg rs) = + let + val rt = getRegType vregs rs + val fromSize = getCS vregs rs + val toSize = getCS vregs rd + in + case rt of + RtConst w => RtConst $ P.extz w fromSize + | RtAddrConst p => + if toSize = 0w8 then + RtAddrConst p + else + RtUnk + | _ => raise Unreachable + end + | evalSet _ _ = raise Unreachable - fun printIns (C as Lctx { ops, ... }) = - List.app (printOp C) ops + fun evalExt vregs ext (_, rs, aClass) = + let + val rt = getRegType vregs rs + val ext = if ext = ExtZero then P.extz else P.exts + in + case rt of + RtConst w => RtConst $ ext w (ac2word aClass) + | RtAddrConst p => + if aClass = AC8 then + RtAddrConst p + else + RtUnk + | _ => raise Unreachable + end - fun translateFn (F as { localVars, stmt, ... }) = + fun evalAddSub op' vregs (rd, rs1, rs2) = + let + val getC = getCS vregs + val () = + if getC rs1 <> getC rs2 orelse getC rd <> getC rs1 then + raise Unreachable + else + () + val size = getC rd + + val rt1 = getRegType vregs rs1 + val rt2 = getRegType vregs rs2 + in + case (rt1, rt2) of + (RtConst w1, RtConst w2) => RtConst $ P.extz (op' (w1, w2)) size + | (RtAddrConst (id, w1), RtConst w2) => RtAddrConst (id, op' (w1, w2)) + | _ => RtUnk + end + + fun eval' ins vregs = + let + open Word + + val es = evalSimple false vregs + val esu = es ExtZero + val ess = es ExtSign + + fun opCommon conv op' (w1, w2) = + let + val i1 = word64Toint64 w1 + val i2 = word64Toint64 w2 + in + conv (op' (i1, i2)) + end + + val sop = opCommon int64Toword64 + + fun bop op' wp = + let + val res = op' wp + in + if res then 0w1 else 0w0 + end + + val sbop = opCommon (fn true => 0w1 | false => 0w0) + + fun eq wp = case compare wp of EQUAL => 0w1 | _ => 0w0 + fun neq wp = case compare wp of EQUAL => 0w0 | _ => 0w1 + in + case ins of + IrAdd t => evalAddSub Word.+ vregs t + | IrSub t => evalAddSub Word.- vregs t + + | IrAnd t => esu t Word.andb + | IrOr t => esu t Word.orb + | IrXor t => esu t Word.xorb + | IrMul t => esu t Word.* + | IrIMul t => ess t (sop Int64.*) + | IrDiv t => esu t Word.div + | IrIDiv t => ess t (sop Int64.div) + | IrMod t => esu t Word.mod + | IrIMod t => esu t (sop Int64.mod) + | IrShl t => esu t Word.<< + | IrShr t => esu t Word.>> + | IrSar t => ess t Word.~>> + + | IrCmpul t => esu t (bop Word.<) + | IrCmpug t => esu t (bop Word.<) + | IrCmpule t => esu t (bop Word.<=) + | IrCmpuge t => esu t (bop Word.>=) + | IrCmpsl t => ess t (sbop Int64.<) + | IrCmpsg t => ess t (sbop Int64.>) + | IrCmpsle t => ess t (sbop Int64.<=) + | IrCmpsge t => ess t (sbop Int64.>=) + | IrEq t => evalSimple true vregs ExtZero t eq + | IrNeq t => evalSimple true vregs ExtZero t neq + | IrSet t => evalSet vregs t + | IrExtZero p => evalExt vregs ExtZero p + | IrExtSign p => evalExt vregs ExtSign p + + | IrAlloc _ | IrLoad _ | IrStore _ | IrRet _ | IrFcall _ + | IrCopy _ | IrJz _ | IrJnz _ => RtUnk + | IrJmp _ | IrNop _ | IrNopLabel _ => raise Unreachable + end + + fun eval (SOME ins) vregs = + let + val res = eval' ins vregs + in + case res of + RtConst w => + let + val { defs, ... } = getInsInfo ins + val { class, ... } = D.get vregs (hd defs) + val w = P.extz w (getClassSize class) + in + RtConst w + end + | _ => res + end + | eval NONE _ = RtUnk + + fun defines (SOME ins) = + let + val { defs, ... } = getInsInfo ins + in + hd defs + end + | defines NONE = raise Unreachable + + fun propagate [] _ _ = () + | propagate (v :: vs) vregs opTable = + let + open Array + val { use, ... } = D.get vregs v + + fun loop (insId :: tail) acc = + let + val ins = sub (opTable, insId) + in + case eval ins vregs of + RtUnk => loop tail acc + | v => + let + val vd = defines ins + val { defs, ... } = D.get vregs vd + val newConst = + case defs of + [_] => (constAdd vregs opTable vd v insId; SOME vd) + | _ => + let + val vl = + case v of + RtConst w => SaConst w + | RtAddrConst p => SaAddr p + | _ => raise Unreachable + val ins = IrSet (vd, vl) + in + update (opTable, insId, SOME ins); + NONE + end + in + loop tail (case newConst of SOME vc => vc :: acc | NONE => acc) + end + end + | loop [] acc = acc + + val newConst = loop use [] + in + propagate (List.revAppend (newConst, vs)) vregs opTable + end + + fun constPropagate (C as Lctx { vregs, opTable, ... }) = + let + val opTable = valOf opTable + val worklist = getFirstConstants C + in + propagate worklist vregs opTable + end + + fun translateFn (F as { localVars, stmt, paramNum, ... }) = let val () = P.printDef (P.Definition F) - val ctx = createLocalCtx localVars + val ctx = createLocalCtx localVars paramNum val ctx = convStmt ctx stmt - val ctx = updateLctx ctx u#ops (fn ops => rev ops) % + val ctx = createInsTable ctx + val () = printVars ctx + val () = printIns ctx + + val () = printf `"\nconstant propagation\n" % + val () = constPropagate ctx + val () = printIns ctx in - printIns ctx + ctx end fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) = @@ -263,6 +263,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; tokenBuf: P.t * (token * P.tkPos) list list, loopLevel: int, + paramNum: int option, defs: def list, strlits: int list @@ -275,18 +276,18 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun updateCtx (Ctx ctx) = fn z => let fun from aggrTypeNames localScopes funcRetType globalSyms - tokenBuf loopLevel defs strlits + tokenBuf loopLevel paramNum defs strlits = { aggrTypeNames, localScopes, funcRetType, globalSyms, - tokenBuf, loopLevel, defs, strlits } + tokenBuf, loopLevel, paramNum, defs, strlits } fun to f { aggrTypeNames, localScopes, funcRetType, globalSyms, - tokenBuf, loopLevel, defs, strlits } + tokenBuf, loopLevel, paramNum, defs, strlits } = f aggrTypeNames localScopes funcRetType globalSyms tokenBuf - loopLevel defs strlits + loopLevel paramNum defs strlits in - FRU.makeUpdate8 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) + FRU.makeUpdate9 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) end datatype declParts = @@ -718,6 +719,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; globalSyms = Tree.empty, tokenBuf = (P.create { fname, incDirs, debugMode = false }, []), loopLevel = 0, + paramNum = NONE, defs = [], strlits = [] } @@ -1364,7 +1366,10 @@ functor Parser(structure Tree: TREE; structure P: PPC; val () = if under = UAddr then - reduceVarToStack lid + if lid < valOf (#paramNum ctx) then + P.error pos `"cannot take address of function argument" % + else + reduceVarToStack lid else () in @@ -1957,40 +1962,42 @@ functor Parser(structure Tree: TREE; structure P: PPC; and sizeofWrapper t = Word64.toInt $ sizeOfType t - and zeroExtend (ER (w, t)): word = + and zeroExtend (ER (w, t)): word = extz w (sizeOfType t) + + and extz w fromSize = let - val size = Word.fromLarge $ sizeOfType t val minus1 = Word64.notb (Word64.fromInt 0) - val mask = Word64.>> (minus1, 0w64 - size * 0w8) + val mask = Word64.>> (minus1, 0w64 - fromSize * 0w8) - val () = printf `"ZH0: " W w `"\n" % val res = Word64.andb (mask, w) - val () = printf `"ZH1: " W res `"\n" % in res end - and getSignBit w sizeInBits = + and getSignBit w sizeInBits: int = let - val shift = Word64.>> (w, Word.fromInt $ sizeInBits -1) - val bit = Word64.andb (shift, Word64.fromInt 1) + open Word + + val shift = >> (w, sizeInBits - 0w1) + val bit = andb (shift, 0w1) in - Word64.toInt bit + toInt bit end - and signExtend (R as (ER (w, t))) = + and signExtend (ER (w, t)) = exts w (sizeOfType t) + + and exts w fromSize = let - val sizeInBits = 8 * sizeofWrapper t + open Word + val sizeInBits = fromSize * 0w8 val signBit = getSignBit w sizeInBits - - val signExtMask = - Word64.<< (Word64.notb $ Word64.fromInt 0, Word.fromInt sizeInBits) + val signExtMask = << (notb 0w0, sizeInBits) in if Int.compare (signBit, 0) = EQUAL then - zeroExtend R + extz w fromSize else - Word64.orb (signExtMask, w) + orb (signExtMask, w) end and evalUnop UnopPos _ arg = arg @@ -2055,7 +2062,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; and ebIsNegative (ER (w, t)) = if isSigned t then - if getSignBit w (8 * sizeofWrapper t) = 1 then + if getSignBit w (0w8 * sizeOfType t) = 1 then true else false @@ -3248,7 +3255,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; in if class = DeclDefined then let - val ini = canonIni (isGlobalScope ctx) pos t (valOf ini) + val ini = canonIni true pos t (valOf ini) in (SOME $ ToplevId (id, pos, t, ini, linkage), ctx) end @@ -3301,10 +3308,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; printf R offset `"local var " P.?nid `"(" I varId `"): " Pctype t `"\n" %; - if isSome ini orelse not $ isScalar t then - (SOME $ LocalId (varId, ini), ctx) - else - (NONE, ctx) + (SOME $ LocalId (varId, ini), ctx) end fun handleTypedef (C as Ctx ctx) ({ pos, t, id, ini, ... }: rawDecl) = @@ -3611,20 +3615,30 @@ functor Parser(structure Tree: TREE; structure P: PPC; (StmtExpr ea, ctx) end - and handleInis ctx l = - let - fun handleIni (id, NONE) = (id, NONE) - | handleIni (id, SOME ini) = - let - val (pos, t) = (fn ({pos, t, ... }) => (pos, t)) $ - D.get localVars id + and handleLocalIni (id, NONE) = + if #onStack $ D.get localVars id then + SOME (id, NONE) + else + NONE + | handleLocalIni (id, SOME ini) = + let + val (pos, t) = (fn ({pos, t, ... }) => (pos, t)) $ + D.get localVars id - val ini = canonIni (isGlobalScope ctx) pos t ini - in - (id, SOME ini) - end + val ini = canonIni false pos t ini + in + SOME (id, SOME ini) + end + + and processLocalInis inis = + let + fun loop [] acc = rev acc + | loop (ini :: inis) acc = + case handleLocalIni ini of + NONE => loop inis acc + | SOME v => loop inis (v :: acc) in - List.map handleIni l + loop inis [] end and parseStmtCompound isFuncBody ctx = @@ -3636,12 +3650,12 @@ functor Parser(structure Tree: TREE; structure P: PPC; if isTypeNameStart ctx tk then let val (res, ctx) = parseDeclaration ctx - val inits = + val varInits = case res of - LocalVarInits l => handleInis ctx l + LocalVarInits l => l (* handleInis ctx l *) | _ => raise Unreachable in - collectDecls (List.revAppend (inits, acc)) ctx + collectDecls (List.revAppend (varInits, acc)) ctx end else (rev acc, ctx) @@ -3669,6 +3683,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (inits, ctx) = collectDecls [] ctx val (stmts, ctx) = collectStmts [] ctx + val inits = processLocalInis inits val ctx = updateCtx ctx u#localScopes tl % in @@ -3768,7 +3783,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; val scope = createLocalVars Tree.empty 0 paramTypes params in - updateCtx ctx s#localScopes [scope] s#funcRetType (SOME rt) % + updateCtx ctx s#localScopes [scope] s#funcRetType (SOME rt) + s#paramNum (SOME $ length params) % end fun worldPrepareForFunc () = D.reset localVars @@ -3788,6 +3804,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (stmt, ctx) = parseStmtCompound true ctx val localVars = finishLocalVars () + + val ctx = updateCtx ctx s#paramNum NONE % in (Definition { name = id, @@ -161,7 +161,11 @@ signature PARSER = sig val getLayoutSize: int -> word + val extz: word -> word -> word + val exts: word -> word -> word + val getT: exprAug -> ctype + val funcParts: ctype -> ctype * ctype list val getFieldInfo: ctype -> nid -> (word * ctype) option |