diff options
Diffstat (limited to 'il.fun')
| -rw-r--r-- | il.fun | 922 |
1 files changed, 489 insertions, 433 deletions
@@ -4,15 +4,6 @@ functor IL(P: PARSER) = struct structure PP = P.P structure D = P.D - datatype ctx = Ctx of { - objs: P.objDef list, - objsZI: P.objDef list, - extSyms: P.nid list, - globSyms: P.nid list, - funcs: P.funcInfo list, - strlits: int list - } - datatype vregClass = VR4 | VR8 type vreg = int @@ -72,7 +63,8 @@ functor IL(P: PARSER) = struct datatype ev = Reg of vreg | Addr of vreg datatype regType = - RtUnk | + RtReg | + RtRem | RtConst of word | RtAddrConst of int * word @@ -85,38 +77,40 @@ functor IL(P: PARSER) = struct datatype localCtx = Lctx of { localVars: { onStack: bool, t: P.ctype } vector, + paramNum: int, + vregs: regInfo D.t, - newLabelNum: int, - ops: irIns list, - opTable: (irIns option) array option, - curPos: int, (* length ops + 1 *) - loopLabels: { break: label, continue: label } list, - paramNum: int + ops: (irIns option) D.t, + + loopLabels: { break: label, continue: label } D.t, + labels: (int option * int) D.t } - (* - fun updateCtx (Ctx ctx) = fn z => - let - fun from objs objsZI extSyms globSyms funcs 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 - *) + datatype funcInfo = Fi of { + name: int, + localBound: int, + vregs: regInfo D.t, + ops: (irIns option) D.t, + labels: int option D.t + } + + datatype ctx = Ctx of { + objs: P.objDef list, + objsZI: P.objDef list, + extSyms: P.nid list, + globSyms: P.nid list, + funcInfos: funcInfo list, + strlits: int list + } fun updateLctx (Lctx ctx) = fn z => let - 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 + fun from localVars paramNum vregs ops loopLabels labels = + { localVars, paramNum, vregs, ops, loopLabels, labels } + fun to f { localVars, paramNum, vregs, ops, loopLabels, labels } = + f localVars paramNum vregs ops loopLabels labels in - FRU.makeUpdate8 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f)) + FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f)) end fun isLocal (Lctx { localVars, ... }) id = id < Vector.length localVars @@ -178,16 +172,16 @@ functor IL(P: PARSER) = struct 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 [] + val defs = if idx < paramNum then [~1] else [] in - D.push vregs ({ class, defs, use = [], t = RtUnk }); + D.push vregs ({ class, defs, use = [], t = RtReg }); loop (idx + 1) end else let val { class, ... } = D.get vregs (idx - lvlen) in - D.push vregs ({ class, defs = [], use = [], t = RtUnk }); + D.push vregs ({ class, defs = [], use = [], t = RtReg }); loop (idx + 1) end val () = loop 0 @@ -266,53 +260,63 @@ functor IL(P: PARSER) = struct List.app updateUse use end - fun ctxPutOp (C as Lctx { curPos, ... }) op' = + fun ctxPutOp (C as Lctx { ops, labels, ... }) op' = let val { defs, use } = getInsInfo op' - val insPos = curPos + 1 + val insPos = D.length ops val () = updateDefsUse C defs use insPos + val () = D.push ops (SOME op') + + fun setPos (NONE, use) = (SOME insPos, use) + | setPos (SOME _, _) = raise Unreachable + + fun inc (v, use) = (v, use + 1) in - updateLctx C u#ops (fn l => op' :: l) u#curPos (fn pos => pos + 1) % + case op' of + IrNopLabel lid => D.update labels setPos lid + | IrJmp lid | IrJnz (_, lid) | IrJz (_, lid) => D.update labels inc lid + | _ => () end fun copyArgs (C as Lctx { localVars, paramNum, ... }) = let val lvlen = Vector.length localVars - fun loop ctx idx = + fun loop idx = if idx = paramNum then - ctx + () else - loop (ctxPutOp ctx (IrSet (idx + lvlen, SaVReg idx))) (idx + 1) - val ctx = loop C 0 + let + val () = ctxPutOp C (IrSet (idx + lvlen, SaVReg idx)) + in + loop (idx + 1) + end in - ctx + loop 0 end + fun getLabel (Lctx { labels, ... }) = D.pushAndGetId labels (NONE, 0) + fun createLocalCtx localVars paramNum = let val localVars = setupLocalVars localVars val vregs = setupVregs localVars paramNum - val ctx = Lctx { localVars, vregs, ops = [], opTable = NONE, curPos = 0, - newLabelNum = 0, loopLabels = [], paramNum } + val labels = D.create0 () + + val ctx = Lctx { + localVars, paramNum, + vregs, ops = D.create0 (), + loopLabels = D.create0 (), labels + } + val _ = getLabel ctx (* label before ret *) + val () = copyArgs ctx in - copyArgs ctx + ctx end - (* - type funcInfo = { - name: int, - pos: P.tkPos, - t: ctype, - paramNum: int, - localVars: { name: nid, pos: P.tkPos, onStack: bool, t: ctype } vector, - stmt: stmt - } - *) - fun getNewVReg class (Lctx { vregs, ... }) = let - val id = D.pushAndGetId vregs ({ class, defs = [], use = [], t = RtUnk }) + val id = D.pushAndGetId vregs ({ class, defs = [], use = [], t = RtReg }) in id end @@ -323,8 +327,9 @@ functor IL(P: PARSER) = struct fun newConst ctx class w = let val v = getNewVReg class ctx + val () = ctxPutOp ctx (IrSet (v, SaConst w)) in - (v, ctxPutOp ctx (IrSet (v, SaConst w))) + v end fun getClass (Lctx { vregs, ... }) id = #class $ D.get vregs id @@ -341,46 +346,44 @@ functor IL(P: PARSER) = struct | LESS => VR4 val v = getNewVReg class ctx + val () = ctxPutOp ctx (IrSet (v, SaConst w)) in - (Reg v, ctxPutOp ctx (IrSet (v, SaConst w))) + Reg v end fun convGLconst ctx (id, isFunc) = let val v = getNew8 ctx - val ctx = ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0))) in - if isFunc then - (Reg v, ctx) - else - (Addr v, ctx) + ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0))); + if isFunc then Reg v else Addr v end fun convId ctx (P.Gid p) = convGLconst ctx p - | convId (C as Lctx { localVars, paramNum, ... }) (P.Lid id) = + | convId (Lctx { localVars, paramNum, ... }) (P.Lid id) = if id < paramNum then (* function parameter *) - (Reg $ id + Vector.length (localVars), C) + (Reg (id + Vector.length localVars)) else let val onStack = #onStack $ Vector.sub (localVars, id) in - ((if onStack then Addr else Reg) id, C) + (if onStack then Addr else Reg) id end fun getOffset ea field = #1 $ valOf $ P.getFieldInfo (P.getT ea) field fun computeFieldFromVReg ctx v offset = let - val (vOff, ctx) = newConst ctx VR8 offset + val vOff = newConst ctx VR8 offset val vRes = getNew8 ctx - val ctx = ctxPutOp ctx (IrAdd (vRes, v, vOff)) + val () = ctxPutOp ctx (IrAdd (vRes, v, vOff)) in - (Addr vRes, ctx) + Addr vRes end - fun convFieldAccessByV ctx ea field = + fun convFieldAccessByV ctx ea field: ev = let - val (v, ctx) = convExpr ctx ea + val v: ev = convExpr ctx ea val offset = getOffset ea field in case v of @@ -390,27 +393,27 @@ functor IL(P: PARSER) = struct and convFieldAccesByP ctx ea field = let - val (v, ctx) = convExpr ctx ea + val v = convExpr ctx ea val offset = getOffset ea field in case v of Reg v => computeFieldFromVReg ctx v offset | Addr v => - let - val vl = getNew8 ctx - val ctx = ctxPutOp ctx (IrLoad (vl, v, AC8)) - in - computeFieldFromVReg ctx vl offset - end + let + val vl = getNew8 ctx + val () = ctxPutOp ctx (IrLoad (vl, v, AC8)) + in + computeFieldFromVReg ctx vl offset + end end - and convSizeOfType ctx t: ev * localCtx = + and convSizeOfType ctx t: ev = let val w = P.sizeOfType t - val (v, ctx) = newConst ctx VR8 w + val v = newConst ctx VR8 w in - (Reg v, ctx) + Reg v end and getSingleOffset t = @@ -424,23 +427,22 @@ functor IL(P: PARSER) = struct Reg v => let val class = getClass ctx v - val (v1, ctx) = newConst ctx class (getSingleOffset t) - - val ctx = ctxPutOp ctx (op' (v, v, v1)) + val v1 = newConst ctx class (getSingleOffset t) in - (Reg v, ctx) + ctxPutOp ctx (op' (v, v, v1)); + Reg v end | Addr v => let val class = getClassForType t val aClass = typeAccessClass t val vl = getNewVReg class ctx - val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) - val (v1, ctx) = newConst ctx class (getSingleOffset t) - val ctx = ctxPutOp ctx (op' (vl, vl, v1)) - val ctx = ctxPutOp ctx (IrStore (v, vl, aClass)) + val v1 = newConst ctx class (getSingleOffset t) in - (Reg vl, ctx) + ctxPutOp ctx (IrLoad (vl, v, aClass)); + ctxPutOp ctx (op' (vl, vl, v1)); + ctxPutOp ctx (IrStore (v, vl, aClass)); + Reg vl end and convPost op' ctx (v, t) = @@ -449,62 +451,62 @@ functor IL(P: PARSER) = struct let val class = getClass ctx v val vOld = getNewVReg class ctx - val ctx = ctxPutOp ctx (IrSet (vOld, SaVReg v)) - val (v1, ctx) = newConst ctx class (getSingleOffset t) - val ctx = ctxPutOp ctx (op' (v, v, v1)) + val v1 = newConst ctx class (getSingleOffset t) in - (Reg vOld, ctx) + ctxPutOp ctx (IrSet (vOld, SaVReg v)); + ctxPutOp ctx (op' (v, v, v1)); + Reg vOld end | Addr v => let val class = getClassForType t val aClass = typeAccessClass t val vl = getNewVReg class ctx - 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 (getSingleOffset t) - val ctx = ctxPutOp ctx (op' (vl, vl, v1)) - val ctx = ctxPutOp ctx (IrStore (v, vl, aClass)) + val v1 = newConst ctx class (getSingleOffset t) in - (Reg vOld, ctx) + ctxPutOp ctx (IrLoad (vl, v, aClass)); + ctxPutOp ctx (IrSet (vOld, SaVReg vl)); + ctxPutOp ctx (op' (vl, vl, v1)); + ctxPutOp ctx (IrStore (v, vl, aClass)); + Reg vOld end - and convAddr ctx v = + and convAddr v = case v of Reg _ => raise Unreachable - | Addr v => (Reg v, ctx) + | Addr v => Reg v and convDeref ctx v = case v of - Reg v => (Addr v, ctx) + Reg v => Addr v | Addr v => let val vD = getNew8 ctx - val ctx = ctxPutOp ctx (IrLoad (vD, v, AC8)) + val () = ctxPutOp ctx (IrLoad (vD, v, AC8)) in - (Addr vD, ctx) + Addr vD end - and convPos ctx v = (v, ctx) + and convPos v = v and prepIsZero ctx vDest vSrc = let - val (vc, ctx) = newConst ctx (getClass ctx vSrc) 0w0 + val vc = newConst ctx (getClass ctx vSrc) 0w0 in ctxPutOp ctx (IrEq (vDest, vSrc, vc)) end and prepNeg ctx vDest vSrc = let - val (vc, ctx) = newConst ctx (getClass ctx vSrc) 0w0 + val vc = newConst ctx (getClass ctx vSrc) 0w0 in ctxPutOp ctx (IrSub (vDest, vc, vSrc)) end and prepComp ctx vDest vSrc = let - val (vc, ctx) = newConst ctx (getClass ctx vSrc) (Word.~ 0w1) + val vc = newConst ctx (getClass ctx vSrc) (Word.~ 0w1) in ctxPutOp ctx (IrXor (vDest, vSrc, vc)) end @@ -514,36 +516,36 @@ functor IL(P: PARSER) = struct Reg v => let val vNew = getNewVReg (getClass ctx v) ctx - val ctx = fop ctx vNew v in - (Reg vNew, ctx) + fop ctx vNew v; + Reg vNew end | Addr v => let val aClass = typeAccessClass t val class = getClassForType t val vl = getNewVReg class ctx - val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) - val ctx = fop ctx vl vl - val ctx = ctxPutOp ctx (IrStore (v, vl, aClass)) in - (Reg vl, ctx) + ctxPutOp ctx (IrLoad (vl, v, aClass)); + fop ctx vl vl; + ctxPutOp ctx (IrStore (v, vl, aClass)); + Reg vl end - and convCast ctx (v, _, P.void_t) = (v, ctx) + and convCast _ (v, _, P.void_t) = v | convCast ctx (v, fromT, toT) = case Word.compare (P.sizeOfType toT, P.sizeOfType fromT) of - EQUAL => (v, ctx) + EQUAL => v | LESS => ( case v of Reg v => let val vNew = getNew4 ctx - val ctx = ctxPutOp ctx (IrSet (vNew, SaVReg v)) in - (Reg vNew, ctx) + ctxPutOp ctx (IrSet (vNew, SaVReg v)); + Reg vNew end - | Addr v => (Addr v, ctx) + | Addr v => Addr v ) | GREATER => let @@ -551,25 +553,25 @@ functor IL(P: PARSER) = struct val aClass = typeAccessClass fromT val toTClass = getClassForType toT - val (v, ctx) = + val v = case v of Addr v => let val vl = getNew4 ctx - val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) in - (vl, ctx) + ctxPutOp ctx (IrLoad (vl, v, aClass)); + vl end - | Reg v => (v, ctx) - val vNew = getNewVReg toTClass ctx - val ctx = ctxPutOp ctx (op' (vNew, v, aClass)) + | Reg v => v + val vNew = getNewVReg toTClass ctx in - (Reg vNew, ctx) + ctxPutOp ctx (op' (vNew, v, aClass)); + Reg vNew end - and convUnop ctx unop ea t = + and convUnop ctx unop ea t: ev = let - val (v, ctx) = convExpr ctx ea + val v: ev = convExpr ctx ea val subT = P.getT ea in case unop of @@ -578,9 +580,9 @@ functor IL(P: PARSER) = struct | P.UnopPostInc => convPost IrAdd ctx (v, subT) | P.UnopPostDec => convPost IrSub ctx (v, subT) | P.UnopSizeof => convSizeOfType ctx subT - | P.UnopAddr => convAddr ctx v + | P.UnopAddr => convAddr v | P.UnopDeref => convDeref ctx v - | P.UnopPos => convPos ctx v + | P.UnopPos => convPos v | P.UnopNeg => convSimpleUnop prepNeg ctx (v, subT) | P.UnopComp => convSimpleUnop prepComp ctx (v, subT) | P.UnopLogNeg => convSimpleUnop prepIsZero ctx (v, subT) @@ -589,130 +591,123 @@ functor IL(P: PARSER) = struct and loadIfNeeded ctx t vLeft = case vLeft of - Reg v => (v, ctx) + Reg v => v | Addr v => let val aClass = typeAccessClass t val class = getClassForType t val vl = getNewVReg class ctx - val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) in - (vl, ctx) + ctxPutOp ctx (IrLoad (vl, v, aClass)); + vl end and binopPrepOpers ctx t vLeft vRight = let - val (vLeft, ctx) = loadIfNeeded ctx t vLeft - val (vRight, ctx) = loadIfNeeded ctx t vRight + val vLeft = loadIfNeeded ctx t vLeft + val vRight = loadIfNeeded ctx t vRight val vNew = getNewVReg (getClass ctx vLeft) ctx in - (vNew, vLeft, vRight, ctx) + (vNew, vLeft, vRight) end 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)) + val (vNew, vLeft, vRight) = binopPrepOpers ctx t vLeft vRight in - (Reg vNew, ctx) + ctxPutOp ctx (op' (vNew, vLeft, vRight)); + Reg vNew end and shiftPointer ctx op' (leftT, vLeft) (rightT, vRight) = let - val (v, ctx) = + val v = case convCast ctx (Reg vRight, rightT, P.ulong_t) of - (Reg v, ctx) => (v, ctx) - | (Addr _, _) => raise Unreachable - val (multiplier, ctx) = - newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT)) + Reg v => v + | Addr _ => raise Unreachable + val multiplier = newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT)) val vm = getNew8 ctx - val ctx = ctxPutOp ctx (IrMul (vm, v, multiplier)) val vRes = getNew8 ctx - val ctx = ctxPutOp ctx (op' (vRes, vLeft, vm)) in - (Reg vRes, ctx) + ctxPutOp ctx (IrMul (vm, v, multiplier)); + ctxPutOp ctx (op' (vRes, vLeft, vm)); + Reg vRes end and convSum ctx (leftT, vLeft) (rightT, vRight) = let - val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft - val (vRight, ctx) = loadIfNeeded ctx rightT vRight + val vLeft = loadIfNeeded ctx leftT vLeft + val vRight = loadIfNeeded ctx rightT vRight in if P.isPointer leftT then shiftPointer ctx IrAdd (leftT, vLeft) (rightT, vRight) else let val vNew = getNewVReg (getClass ctx vLeft) ctx - val ctx = ctxPutOp ctx (IrAdd (vNew, vLeft, vRight)) in - (Reg vNew, ctx) + ctxPutOp ctx (IrAdd (vNew, vLeft, vRight)); + Reg vNew end end and convSub ctx (leftT, vLeft) (rightT, vRight) = let - val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft - val (vRight, ctx) = loadIfNeeded ctx rightT vRight + val vLeft = loadIfNeeded ctx leftT vLeft + val vRight = loadIfNeeded ctx rightT vRight in if P.isPointer leftT then if P.isPointer rightT then let val vDiff = getNew8 ctx - val ctx = ctxPutOp ctx (IrSub (vDiff, vLeft, vRight)) - val (divider, ctx) = - newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT)) val vRes = getNew8 ctx - val ctx = ctxPutOp ctx (IrDiv (vRes, vDiff, divider)) + val divider = newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT)) in - (Reg vRes, ctx) + ctxPutOp ctx (IrSub (vDiff, vLeft, vRight)); + ctxPutOp ctx (IrDiv (vRes, vDiff, divider)); + Reg vRes end else shiftPointer ctx IrSub (leftT, vLeft) (rightT, vRight) else let val vNew = getNewVReg (getClass ctx vLeft) ctx - val ctx = ctxPutOp ctx (IrSub (vNew, vLeft, vRight)) in - (Reg vNew, ctx) + ctxPutOp ctx (IrSub (vNew, vLeft, vRight)); + Reg vNew end end and convSimpleAssignment ctx leftT vLeft vRight = let - val (vRight, ctx) = loadIfNeeded ctx leftT vRight + val vRight = loadIfNeeded ctx leftT vRight in case vLeft of - Reg v => - let - val ctx = ctxPutOp ctx (IrSet (v, SaVReg vRight)) - in - (Reg v, ctx) - end - | Addr v => - let - val ctx = - ctxPutOp ctx (IrStore (v, vRight, typeAccessClass leftT)) - in - (Reg vRight, ctx) - end + Reg v => ( + ctxPutOp ctx (IrSet (v, SaVReg vRight)); + Reg v + ) + | Addr v => ( + ctxPutOp ctx (IrStore (v, vRight, typeAccessClass leftT)); + Reg vRight + ) end and convSubscript ctx (leftT, vLeft) (rightT, vRight) = let - val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft - val (vRight, ctx) = loadIfNeeded ctx rightT vRight + val vLeft = loadIfNeeded ctx leftT vLeft + val vRight = loadIfNeeded ctx rightT vRight - val (res, ctx) = + val res = case shiftPointer ctx IrAdd (leftT, vLeft) (rightT, vRight) of - (Reg v, ctx) => (v, ctx) - | (Addr _, _) => raise Unreachable + Reg v => v + | Addr _ => raise Unreachable in - (Addr res, ctx) + Addr res end and convCompAssign (op', op2) ctx (leftT, vLeft) (rightT, vRight) = let - val (vRight, ctx) = loadIfNeeded ctx rightT vRight + val vRight = loadIfNeeded ctx rightT vRight val leftT = P.resolveType leftT val rightT = P.resolveType rightT @@ -721,123 +716,117 @@ functor IL(P: PARSER) = struct fun convIfNeeded ctx t v = if t <> commonType then case convCast ctx (Reg v, t, commonType) of - (Reg v, ctx) => (v, ctx) - | (Addr _, _) => raise Unreachable + Reg v => v + | Addr _ => raise Unreachable else - (v, ctx) + v fun apply ctx leftV = let - val (vLeft, ctx) = convIfNeeded ctx leftT leftV - val (vRight, ctx) = convIfNeeded ctx rightT vRight + val vLeft = convIfNeeded ctx leftT leftV + val vRight = convIfNeeded ctx rightT vRight val op' = if P.isSigned commonType then op2 else op' - val (vRight, ctx) = + val vRight = if P.isPointer leftT then let - val (mul, ctx) = - newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT)) + val mul = newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT)) val vm = getNew8 ctx - val ctx = ctxPutOp ctx (IrMul (vm, vRight, mul)) in - (vm, ctx) + ctxPutOp ctx (IrMul (vm, vRight, mul)); + vm end else - (vRight, ctx) - val ctx = ctxPutOp ctx (op' (vLeft, vLeft, vRight)) + vRight in - (vLeft, ctx) + ctxPutOp ctx (op' (vLeft, vLeft, vRight)); + vLeft end in case vLeft of Reg v => let - val (vLeft, ctx) = apply ctx v - - val ctx = - if leftT <> commonType then - ctxPutOp ctx (IrSet (v, SaVReg vLeft)) - else - ctx + val vLeft = apply ctx v in - (Reg v, ctx) + if leftT <> commonType then + ctxPutOp ctx (IrSet (v, SaVReg vLeft)) + else + (); + Reg v end | Addr v => let val class = getClassForType leftT val aClass = typeAccessClass leftT val vl = getNewVReg class ctx - val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) + val () = ctxPutOp ctx (IrLoad (vl, v, aClass)) - val (vLeft, ctx) = apply ctx vl - val ctx = ctxPutOp ctx (IrStore (v, vLeft, aClass)) + val vLeft = apply ctx vl in - (Reg vLeft, ctx) + ctxPutOp ctx (IrStore (v, vLeft, aClass)); + Reg vLeft end end - and convComma ctx _ (_, vRight) = (vRight, ctx) - - and getLabel (C as Lctx { newLabelNum, ... }) = - (newLabelNum, updateLctx C u#newLabelNum (fn l => l + 1) %) + and convComma _ _ (_, vRight) = vRight and getLabelPair ctx = let - val (l1, ctx) = getLabel ctx - val (l2, ctx) = getLabel ctx + val l1 = getLabel ctx + val l2 = getLabel ctx in - (l1, l2, ctx) + (l1, l2) end and genLogPart ctx ea = let val t = P.getT ea - val (v, ctx) = convExpr ctx ea - val (v, ctx) = loadIfNeeded ctx t v - val (v, ctx) = + val v = convExpr ctx ea + val v = loadIfNeeded ctx t v + val v = if P.typeRank t < P.typeRank P.int_t then case convCast ctx (Reg v, t, P.int_t) of - (Reg v, ctx) => (v, ctx) - | (Addr _, _) => raise Unreachable + Reg v => v + | Addr _ => raise Unreachable else - (v, ctx) + v in - (v, ctx) + v end and convLogOr ctx left right = let - val (vLeft, ctx) = genLogPart ctx left + val vLeft = genLogPart ctx left - val (elseLabel, endLabel, ctx) = getLabelPair ctx - val ctx = ctxPutOp ctx (IrJz (vLeft, elseLabel)) + val (elseLabel, endLabel) = getLabelPair ctx val vRes = getNew4 ctx - val ctx = ctxPutOp ctx (IrSet (vRes, SaConst 0w1)) - val ctx = ctxPutOp ctx (IrJmp endLabel) - val ctx = ctxPutOp ctx (IrNopLabel elseLabel) + val () = ctxPutOp ctx (IrJz (vLeft, elseLabel)) + val () = ctxPutOp ctx (IrSet (vRes, SaConst 0w1)) + val () = ctxPutOp ctx (IrJmp endLabel) + val () = ctxPutOp ctx (IrNopLabel elseLabel) - val (vRight, ctx) = genLogPart ctx right - val (vC, ctx) = newConst ctx (getClass ctx vRight) 0w0 - val ctx = ctxPutOp ctx (IrNeq (vRes, vRight, vC)) + val vRight = genLogPart ctx right + val vC = newConst ctx (getClass ctx vRight) 0w0 + val () = ctxPutOp ctx (IrNeq (vRes, vRight, vC)) in - (Reg vRes, ctx) + Reg vRes end and convLogAnd ctx left right = let - val (vLeft, ctx) = genLogPart ctx left - val (falseLabel, endLabel, ctx) = getLabelPair ctx - val ctx = ctxPutOp ctx (IrJz (vLeft, falseLabel)) - val (vRight, ctx) = genLogPart ctx right + val vLeft = genLogPart ctx left + val (falseLabel, endLabel) = getLabelPair ctx + val () = ctxPutOp ctx (IrJz (vLeft, falseLabel)) + val vRight = genLogPart ctx right val vRes = getNew4 ctx - val (vC, ctx) = newConst ctx (getClass ctx vRight) 0w0 - val ctx = ctxPutOp ctx (IrNeq (vRes, vRight, vC)) - val ctx = ctxPutOp ctx (IrJmp endLabel) - val ctx = ctxPutOp ctx (IrNopLabel (falseLabel)) - val ctx = ctxPutOp ctx (IrSet (vRes, SaConst 0w0)) - val ctx = ctxPutOp ctx (IrNopLabel endLabel) + val vC = newConst ctx (getClass ctx vRight) 0w0 in - (Reg vRes, ctx) + ctxPutOp ctx (IrNeq (vRes, vRight, vC)); + ctxPutOp ctx (IrJmp endLabel); + ctxPutOp ctx (IrNopLabel (falseLabel)); + ctxPutOp ctx (IrSet (vRes, SaConst 0w0)); + ctxPutOp ctx (IrNopLabel endLabel); + Reg vRes end and convBinop ctx binop left right = @@ -849,8 +838,8 @@ functor IL(P: PARSER) = struct fun apply f = let - val (vLeft, ctx) = convExpr ctx left - val (vRight, ctx) = convExpr ctx right + val vLeft = convExpr ctx left + val vRight = convExpr ctx right in f ctx (leftT, vLeft) (rightT, vRight) end @@ -905,71 +894,64 @@ functor IL(P: PARSER) = struct let val leftT = P.getT left - val (cond, ctx) = genLogPart ctx cond - val (elseLabel, endLabel, ctx) = getLabelPair ctx - val ctx = ctxPutOp ctx (IrJz (cond, elseLabel)) + val cond = genLogPart ctx cond + val (elseLabel, endLabel) = getLabelPair ctx + val () = ctxPutOp ctx (IrJz (cond, elseLabel)) val vRes = getNewVReg (getClassForType leftT) ctx - val (vLeft, ctx) = convExpr ctx left - val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft - val ctx = ctxPutOp ctx (IrSet (vRes, SaVReg vLeft)) - val ctx = ctxPutOp ctx (IrJmp endLabel) - val ctx = ctxPutOp ctx (IrNopLabel elseLabel) - val (vRight, ctx) = convExpr ctx right - val (vRight, ctx) = loadIfNeeded ctx leftT vRight - val ctx = ctxPutOp ctx (IrSet (vRes, SaVReg vRight)) - val ctx = ctxPutOp ctx (IrNopLabel endLabel) + val vLeft = convExpr ctx left + val vLeft = loadIfNeeded ctx leftT vLeft + val () = ctxPutOp ctx (IrSet (vRes, SaVReg vLeft)) + val () = ctxPutOp ctx (IrJmp endLabel) + val () = ctxPutOp ctx (IrNopLabel elseLabel) + val vRight = convExpr ctx right + val vRight = loadIfNeeded ctx leftT vRight + val () = ctxPutOp ctx (IrSet (vRes, SaVReg vRight)) + val () = ctxPutOp ctx (IrNopLabel endLabel) in - (Reg vRes, ctx) + Reg vRes end 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) = + val vFunc = convExpr ctx func + val vFunc = loadIfNeeded ctx t vFunc + val vFunc = case (getClass ctx vFunc) of VR4 => let val v = getNew8 ctx in - (v, ctxPutOp ctx (IrSet (v, SaVReg vFunc))) + ctxPutOp ctx (IrSet (v, SaVReg vFunc)); + v end - | VR8 => (vFunc, ctx) + | VR8 => vFunc - fun genArgs ctx [] acc = + fun genArgs [] acc = let - fun loop ctx _ [] acc2 = (rev acc2, ctx) - | loop ctx idx (vArg :: acc) acc2 = + + fun loop _ [] acc2 = rev acc2 + | loop 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) + ctxPutOp ctx (IrSet (arg, SaVReg vArg)); + loop (idx + 1) acc (arg :: acc2) end + + val () = ctxPutOp ctx (IrNop "here") in - loop ctx 0 acc [] + loop 0 acc [] end - | genArgs ctx (arg :: args) acc = + | genArgs (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) - + val vArg = convExpr ctx arg + val vArg = loadIfNeeded ctx (P.getT arg) vArg in - genArgs ctx args (vArg :: acc) + genArgs args (vArg :: acc) end - val (args, ctx) = genArgs ctx args [] + val args = genArgs args [] val rt = #1 $ P.funcParts (P.pointsTo t) val vRes = @@ -983,10 +965,11 @@ functor IL(P: PARSER) = struct vRes end in - (Reg vRes, ctxPutOp ctx (IrFcall (vRes, vFunc, args))) + ctxPutOp ctx (IrFcall (vRes, vFunc, args)); + Reg vRes end - and convExpr ctx ea: ev * localCtx = + and convExpr ctx ea: ev = let val P.EA (e, _, _, t) = ea in @@ -1013,13 +996,13 @@ functor IL(P: PARSER) = struct | convIni (C as Lctx { localVars, ... }) (id, SOME (P.CiniExpr ea)) = let val t = P.getT ea - val (v, ctx) = convExpr C ea - val (v, ctx) = loadIfNeeded ctx t v + val v = convExpr C ea + val v = loadIfNeeded C t v in if #onStack $ Vector.sub (localVars, id) then - ctxPutOp ctx (IrLoad (id, v, typeAccessClass t)) + ctxPutOp C (IrLoad (id, v, typeAccessClass t)) else - ctxPutOp ctx (IrSet (id, SaVReg v)) + ctxPutOp C (IrSet (id, SaVReg v)) end | convIni ctx (id, SOME (P.CiniLayout lid)) = let @@ -1032,8 +1015,8 @@ functor IL(P: PARSER) = struct case ea of SOME ea => let - val (v, ctx) = convExpr ctx ea - val (v, ctx) = loadIfNeeded ctx (P.getT ea) v + val v = convExpr ctx ea + val v = loadIfNeeded ctx (P.getT ea) v in ctxPutOp ctx (IrRet $ SOME v) end @@ -1041,73 +1024,63 @@ functor IL(P: PARSER) = struct fun convIf ctx (cond, thenPart, elsePart) = let - val (v, ctx) = genLogPart ctx cond - val (elseL, endL, ctx) = getLabelPair ctx - val ctx = ctxPutOp ctx (IrJz (v, elseL)) - val ctx = convStmt ctx thenPart - - val ctx = if isSome elsePart then ctxPutOp ctx (IrJmp endL) else ctx - val ctx = ctxPutOp ctx (IrNopLabel elseL) - - val ctx = - case elsePart of - SOME elsePart => - let - val ctx = convStmt ctx elsePart - val ctx = ctxPutOp ctx (IrNopLabel endL) - in - ctx - end - | NONE => ctx + val v = genLogPart ctx cond + val (elseL, endL) = getLabelPair ctx in - ctx + ctxPutOp ctx (IrJz (v, elseL)); + convStmt ctx thenPart; + + if isSome elsePart then ctxPutOp ctx (IrJmp endL) else (); + ctxPutOp ctx (IrNopLabel elseL); + case elsePart of + SOME elsePart => ( + convStmt ctx elsePart; + ctxPutOp ctx (IrNopLabel endL) + ) + | NONE => () end - and ctxGetLoopLabels ctx = + and ctxGetLoopLabels (C as Lctx { loopLabels, ... }) = let - val (l1, l2, ctx) = getLabelPair ctx - val ctx = updateLctx ctx u#loopLabels - (fn l => { break = l1, continue = l2 } :: l) % + val (l1, l2) = getLabelPair C + + val () = D.push loopLabels { break = l1, continue = l2 } in - (l1, l2, ctx) + (l1, l2) end - and ctxLoopExit ctx = updateLctx ctx u#loopLabels tl % + and ctxLoopExit (Lctx { loopLabels, ... }) = ignore $ D.pop loopLabels and convWhile ctx (cond, body) = let - val (breakL, contL, ctx) = ctxGetLoopLabels ctx - val ctx = ctxPutOp ctx (IrNopLabel contL) - val (cond, ctx) = genLogPart ctx cond - val ctx = ctxPutOp ctx (IrJz (cond, breakL)) - val ctx = convStmt ctx body - val ctx = ctxPutOp ctx (IrJmp contL) - val ctx = ctxPutOp ctx (IrNopLabel breakL) - - val ctx = ctxLoopExit ctx + val (breakL, contL) = ctxGetLoopLabels ctx + val () = ctxPutOp ctx (IrNopLabel contL) + val cond = genLogPart ctx cond in - ctx + ctxPutOp ctx (IrJz (cond, breakL)); + convStmt ctx body; + ctxPutOp ctx (IrJmp contL); + ctxPutOp ctx (IrNopLabel breakL); + ctxLoopExit ctx end and convDoWhile ctx (body, cond) = let - val (breakL, contL, ctx) = ctxGetLoopLabels ctx - val (startL, ctx) = getLabel ctx - val ctx = ctxPutOp ctx (IrNopLabel startL) - val ctx = convStmt ctx body - val ctx = ctxPutOp ctx (IrNopLabel contL) - val (cond, ctx) = genLogPart ctx cond - val ctx = ctxPutOp ctx (IrJnz (cond, startL)) - val ctx = ctxPutOp ctx (IrNopLabel breakL) - - val ctx = ctxLoopExit ctx + val (breakL, contL) = ctxGetLoopLabels ctx + val startL = getLabel ctx + val () = ctxPutOp ctx (IrNopLabel startL) + val () = convStmt ctx body + val () = ctxPutOp ctx (IrNopLabel contL) + val cond = genLogPart ctx cond in - ctx + ctxPutOp ctx (IrJnz (cond, startL)); + ctxPutOp ctx (IrNopLabel breakL); + ctxLoopExit ctx end and convBreakOrCont isBreak (C as Lctx { loopLabels, ... }) = let - val { break, continue } = hd loopLabels + val { break, continue } = D.last loopLabels val label = if isBreak then break else continue in ctxPutOp C (IrJmp label) @@ -1115,46 +1088,42 @@ functor IL(P: PARSER) = struct and convFor ctx (pre, cond, post, stmt) = let - val ctx = + val () = case pre of - NONE => ctx - | SOME ea => #2 $ convExpr ctx ea - val (startL, ctx) = getLabel ctx - val (breakL, contL, ctx) = ctxGetLoopLabels ctx + NONE => () + | SOME ea => ignore $ convExpr ctx ea + val startL = getLabel ctx + val (breakL, contL) = ctxGetLoopLabels ctx - val ctx = ctxPutOp ctx (IrNopLabel startL) - val ctx = + val () = ctxPutOp ctx (IrNopLabel startL) + val () = case cond of - NONE => ctx + NONE => () | SOME cond => let - val (cond, ctx) = genLogPart ctx cond + val cond = genLogPart ctx cond in ctxPutOp ctx (IrJz (cond, breakL)) end - val ctx = convStmt ctx stmt - val ctx = ctxPutOp ctx (IrNopLabel contL) - val ctx = + val () = convStmt ctx stmt + val () = ctxPutOp ctx (IrNopLabel contL) + val () = case post of - NONE => ctx - | SOME post => #2 $ convExpr ctx post - val ctx = ctxPutOp ctx (IrJmp startL) - val ctx = ctxPutOp ctx (IrNopLabel breakL) + NONE => () + | SOME post => ignore $ convExpr ctx post + val () = ctxPutOp ctx (IrJmp startL) + val () = ctxPutOp ctx (IrNopLabel breakL) in - ctx + () end - and convStmt ctx stmt = + and convStmt ctx stmt: unit = case stmt of - P.StmtExpr ea => #2 $ convExpr ctx ea - | P.StmtCompound (inis, stmts) => - let - open List - val ctx = foldl (fn (ini, ctx) => convIni ctx ini) ctx inis - val ctx = foldl (fn (stmt, ctx) => convStmt ctx stmt) ctx stmts - in - ctx - end + P.StmtExpr ea => ignore $ convExpr ctx ea + | P.StmtCompound (inis, stmts) => ( + List.app (fn ini => convIni ctx ini) inis; + List.app (fn stmt => convStmt ctx stmt) stmts + ) | P.StmtIf t => convIf ctx t | P.StmtReturn ea => convReturn ctx ea | P.StmtFor quad => convFor ctx quad @@ -1216,9 +1185,16 @@ functor IL(P: PARSER) = struct fun preg (C as Lctx { vregs, ... }) id out = let val rt = getRegType vregs id + + val () = + if id = 10 then + printfn `"printing 10" % + else + () in case rt of - RtUnk => Printf out `"%" I id % + RtReg => Printf out `"%" I id % + | RtRem => raise Unreachable | RtConst w => printConst (getClass C id) w | RtAddrConst (id, w) => (printf `"$" PP.? id %; printConst VR8 w) end @@ -1268,6 +1244,13 @@ functor IL(P: PARSER) = struct in printf `"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 `"):" % + end in case op' of IrSet (reg, arg) => printOpSet ctx reg arg @@ -1306,7 +1289,7 @@ functor IL(P: PARSER) = struct | IrJmp l => printf `"\tjmp " Pl l % | IrJz p => pj p "jz" | IrJnz p => pj p "jnz" - | IrNopLabel l => printf `"@" Pl l `":" % + | IrNopLabel l => printLabel ctx l | IrNop s => printf `"\t; " `s % | IrRet v => printRet v | IrAlloc p => printAlloc p @@ -1317,16 +1300,26 @@ functor IL(P: PARSER) = struct end | printOp _ (_, NONE) = () - fun printIns (C as Lctx { opTable, ... }) = - Array.appi (printOp C) (valOf opTable) + fun printIns (C as Lctx { ops, ... }) = + D.appi (printOp C) ops - fun printVar idx { class, defs, use, t = _ } = - if length defs = 0 andalso length use = 0 then - () - else - printfn `"%" I idx `" " `(if class = VR4 then "w4" else "w8") + fun printVar idx { class, defs, use, t } = + let + val c = if class = VR4 then "w4" else "w8" + + val () = printf `"%" I 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 "; printConst class w) + | RtAddrConst (id, w) => + (printf `" addr const " PP.? id; printConst class w) + ; + printf `"\n" % + end fun printVars (Lctx { vregs, ... }) = let @@ -1341,19 +1334,11 @@ functor IL(P: PARSER) = struct 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 = + fun constAdd vregs ops vid v insId = let val () = printfn `"new constant: %" I vid % - val { class, ... } = D.get vregs vid + val { class, defs, use, ... } = D.get vregs vid val v = case v of @@ -1364,17 +1349,15 @@ functor IL(P: PARSER) = struct RtConst w end | RtAddrConst (id, w) => RtAddrConst (id, w) - | RtUnk => raise Unreachable - val () = D.set vregs vid { class, defs = [], use = [], t = v } + | RtReg | RtRem => raise Unreachable + val () = D.set vregs vid { class, defs, use, t = v } in - Array.update (opTable, insId, NONE) + D.set ops insId NONE end fun getFirstConstants - (Lctx { vregs, opTable, localVars, paramNum, ... }) = + (Lctx { vregs, ops, localVars, paramNum, ... }) = let - val opTable = valOf opTable - fun loop vid acc = if vid = D.length vregs then rev acc @@ -1390,13 +1373,13 @@ functor IL(P: PARSER) = struct | SaAddr p => RtAddrConst p | _ => raise Unreachable in - constAdd vregs opTable vid v def + constAdd vregs ops vid v def end in case defs of [def] => let - val ins = valOf $ Array.sub (opTable, def) + val ins = valOf $ D.get ops def in case ins of IrSet(_, arg as SaConst _ | arg as SaAddr _) => @@ -1452,7 +1435,7 @@ functor IL(P: PARSER) = struct fun evalSimple supThird vregs ext triple op' = case evalPrep supThird vregs triple ext of SOME wp => RtConst (op' wp) - | NONE => RtUnk + | NONE => RtReg fun evalSet vregs (rd, SaVReg rs) = let @@ -1466,7 +1449,7 @@ functor IL(P: PARSER) = struct if toSize = 0w8 then RtAddrConst p else - RtUnk + RtReg | _ => raise Unreachable end | evalSet _ _ = raise Unreachable @@ -1475,6 +1458,8 @@ 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) @@ -1482,7 +1467,7 @@ functor IL(P: PARSER) = struct if aClass = AC8 then RtAddrConst p else - RtUnk + RtReg | _ => raise Unreachable end @@ -1502,7 +1487,8 @@ functor IL(P: PARSER) = struct 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 + | (RtRem, _) | (_, RtRem) => raise Unreachable + | _ => RtReg end fun eval' ins vregs = @@ -1567,7 +1553,7 @@ functor IL(P: PARSER) = struct | IrExtSign p => evalExt vregs ExtSign p | IrAlloc _ | IrLoad _ | IrStore _ | IrRet _ | IrFcall _ - | IrCopy _ | IrJz _ | IrJnz _ => RtUnk + | IrCopy _ | IrJz _ | IrJnz _ => RtReg | IrJmp _ | IrNop _ | IrNopLabel _ => raise Unreachable end @@ -1584,9 +1570,10 @@ functor IL(P: PARSER) = struct in RtConst w end + | RtRem => raise Unreachable | _ => res end - | eval NONE _ = RtUnk + | eval NONE _ = RtReg fun defines (SOME ins) = let @@ -1597,24 +1584,33 @@ functor IL(P: PARSER) = struct | defines NONE = raise Unreachable fun propagate [] _ _ = () - | propagate (v :: vs) vregs opTable = + | propagate (v :: vs) vregs ops = let - open Array val { use, ... } = D.get vregs v + (* + val () = printfn `"Took from worklist: " I v % + val () = printfn `"usage: " Plist i use (", ", true, 0) % + *) + fun loop (insId :: tail) acc = let - val ins = sub (opTable, insId) + val ins = D.get ops insId + + (* + val () = printfn `"v: " I v `", Ins: " I insId % + *) in case eval ins vregs of - RtUnk => loop tail acc + RtReg => loop tail acc + | RtRem => raise Unreachable | 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) + [_] => (constAdd vregs ops vd v insId; SOME vd) | _ => let val vl = @@ -1624,7 +1620,7 @@ functor IL(P: PARSER) = struct | _ => raise Unreachable val ins = IrSet (vd, vl) in - update (opTable, insId, SOME ins); + D.set ops insId (SOME ins); NONE end in @@ -1635,15 +1631,14 @@ functor IL(P: PARSER) = struct val newConst = loop use [] in - propagate (List.revAppend (newConst, vs)) vregs opTable + propagate (List.revAppend (newConst, vs)) vregs ops end - fun constPropagate (C as Lctx { vregs, opTable, ... }) = + fun constPropagate (C as Lctx { vregs, ops, ... }) = let - val opTable = valOf opTable val worklist = getFirstConstants C in - propagate worklist vregs opTable + propagate worklist vregs ops end fun changeDest rd ins = @@ -1686,16 +1681,16 @@ functor IL(P: PARSER) = struct | IrJnz _ | IrStore _ => raise Unreachable end - fun mergeIns (Lctx { vregs, opTable, ... }) idx rd rs = + fun mergeIns (Lctx { vregs, ops, ... }) idx rd rs = let - val opTable = valOf opTable + val () = printfn `"removing %" I rs % - val { class, t, ... } = D.get vregs rs - val () = D.set vregs rs { defs = [], use = [], class, t } - val ins = valOf $ Array.sub (opTable, idx - 1) + val { class, ... } = D.get vregs rs + val () = D.set vregs rs { defs = [], use = [], class, t = RtRem } + val ins = valOf $ D.get ops (idx - 1) val ir = changeDest rd ins - val () = Array.update (opTable, idx - 1, SOME ir) - val () = Array.update (opTable, idx, NONE) + val () = D.set ops (idx - 1) (SOME ir) + val () = D.set ops idx NONE val { defs, use, class, t } = D.get vregs rd @@ -1707,7 +1702,7 @@ functor IL(P: PARSER) = struct () end - fun optSet (C as Lctx { vregs, opTable, localVars, ... }) + fun optSet (C as Lctx { vregs, localVars, paramNum, ... }) (idx, SOME (IrSet (rd, SaVReg rs))) = if getCS vregs rd <> getCS vregs rs then @@ -1718,7 +1713,8 @@ functor IL(P: PARSER) = struct in case (defs, use) of ([d], [_]) => - if d = idx - 1 andalso rs >= Vector.length localVars then + if d = idx - 1 andalso rs >= Vector.length localVars + paramNum + then mergeIns C idx rd rs else () @@ -1726,51 +1722,111 @@ functor IL(P: PARSER) = struct end | optSet _ _ = () - fun peephole (C as Lctx { opTable, ... }) = + fun peephole (C as Lctx { ops, ... }) = let - val () = Array.appi (optSet C) (valOf opTable) + val () = D.appi (optSet C) ops in () end - fun translateFn (F as { localVars, stmt, paramNum, ... }) = + fun removeUnusedLabels (Lctx { ops, labels, ... }) = + let + fun f (insId, op') = + case op' of + SOME (IrNopLabel lid) => + let + val (_, usage) = D.get labels lid + in + if usage = 0 then + (printfn `"removing label: " I lid %; D.set ops insId NONE) + else + () + end + | _ => () + + fun loop idx = + if idx = D.length ops then + () + else ( + f (idx, D.get ops idx); + loop (idx + 1) + ) + in + loop 0 + end + + fun removeUnusedVars (Lctx { vregs, ... }) = + let + fun loop idx = + if idx = D.length vregs then + () + else + let + val { defs, use, t, class } = D.get vregs idx + val t = + if t = RtReg andalso defs = [] andalso use = [] then + RtRem + else + t + in + D.set vregs idx { defs, use, t, class }; + loop (idx + 1) + end + in + loop 0 + end + + fun translateFn (F as { localVars, stmt, paramNum, name, ... }) = let val () = P.printDef (P.Definition F) val ctx = createLocalCtx localVars paramNum - val ctx = convStmt ctx stmt + val () = convStmt ctx stmt + + val () = ctxPutOp ctx (IrNopLabel 0) - val ctx = createInsTable ctx val () = printVars ctx val () = printIns ctx val () = printf `"\nconstant propagation\n\n" % val () = constPropagate ctx + val () = printVars ctx val () = printIns ctx - val () = printf `"\npeephole il optimizations\n\n" % + val () = printf `"\nmisc il optimizations\n\n" % + + val () = removeUnusedLabels ctx + val () = removeUnusedVars ctx val () = peephole ctx + + val () = printVars ctx val () = printIns ctx val () = printf `"\nvariables\n\n" % val () = printVars ctx + + val Lctx { vregs, ops, labels, ... } = ctx in - ctx + Fi { name, localBound = Vector.length localVars + paramNum, + vregs, ops, labels = D.copy labels (fn (v, _) => v) } end fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) = let - val _ = List.map (fn func => translateFn func) funcs + val fis = List.map (fn func => translateFn func) funcs in - Ctx { objs, objsZI, extSyms = ext, globSyms = glob, funcs, strlits } + Ctx { objs, objsZI, extSyms = ext, globSyms = glob, + funcInfos = fis, strlits } end + (* fun updateCtx (Ctx ctx) = fn z => let - fun from objs objsZI extSyms globSyms funcs strlits = + 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 |