diff options
| -rw-r--r-- | dynarray.sig | 1 | ||||
| -rw-r--r-- | dynarray.sml | 10 | ||||
| -rw-r--r-- | emit.fun | 8 | ||||
| -rw-r--r-- | il.fun | 1035 | ||||
| -rw-r--r-- | parser.fun | 69 | ||||
| -rw-r--r-- | parser.sig | 19 |
6 files changed, 1096 insertions, 46 deletions
diff --git a/dynarray.sig b/dynarray.sig index 8e2da7c..7b148c1 100644 --- a/dynarray.sig +++ b/dynarray.sig @@ -7,6 +7,7 @@ signature DYNARRAY = sig val length: 'a t -> int val push: 'a t -> 'a -> unit + val pushAndGetId: 'a t -> 'a -> int val get: 'a t -> int -> 'a val set: 'a t -> int -> 'a -> unit diff --git a/dynarray.sml b/dynarray.sml index 371362e..d52f148 100644 --- a/dynarray.sml +++ b/dynarray.sml @@ -20,7 +20,7 @@ structure Dynarray: DYNARRAY = struct case Int.compare (len, Array.length arr) of EQUAL => let - val arr2 = Array.array (len * 2, NONE) + val arr2 = Array.array (len * 2 + 1, NONE) in Array.copy { src = arr, dst = arr2, di = 0 }; dynarr := (len, arr2); @@ -33,6 +33,14 @@ structure Dynarray: DYNARRAY = struct | GREATER => raise Unreachable end + fun pushAndGetId dynarr v = + let + val (len, _ ) = !dynarr + val () = push dynarr v + in + len + end + fun get dynarr n = let val (len, arr) = !dynarr @@ -55,10 +55,6 @@ functor Emit(I: IL) = struct fprint `cmd `" " W w % end - fun emitScalarIni size w = ( - fprint `"\t" %; dd size w; fprint `"\n" % - ) - fun emitAggrLayout id = let val (_, size, layout) = D.get P.iniLayouts id @@ -93,13 +89,11 @@ functor Emit(I: IL) = struct fun emitLayout (id, _, t, ini, _) = let val align = P.alignOfType t - val size = P.sizeOfType t val () = fprinttn `"align\t" W align % val () = fprint PP.? id `":" % in case ini of - P.CiniConst w => emitScalarIni size w - | P.CiniLayout id => emitAggrLayout id + P.CiniLayout id => emitAggrLayout id | P.CiniExpr _ => raise Unreachable end in @@ -2,6 +2,7 @@ functor IL(P: PARSER) = struct structure P = P structure PP = P.P + structure D = P.D datatype ctx = Ctx of { objs: P.objDef list, @@ -12,9 +13,70 @@ functor IL(P: PARSER) = struct strlits: int list } - fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) = - Ctx { objs, objsZI, extSyms = ext, globSyms = glob, funcs, strlits } + datatype vregClass = VR4 | VR8 + + type vreg = int + type label = int + + datatype setArg = SaVReg of vreg | SaConst of word | SaGL of P.nid + + datatype accessClass = AC1 | AC2 | AC4 | AC8 + + datatype irIsn = + IrSet of vreg * setArg + | IrAdd of vreg * vreg * vreg + | IrSub of vreg * vreg * vreg + | IrMul of vreg * vreg * vreg + | IrIMul of vreg * vreg * vreg + | IrDiv of vreg * vreg * vreg + | IrIDiv of vreg * vreg * vreg + | IrMod of vreg * vreg * vreg + | IrIMod of vreg * vreg * vreg + | IrShr of vreg * vreg * vreg + | IrShl of vreg * vreg * vreg + | IrSar of vreg * vreg * vreg + | IrAnd of vreg * vreg * vreg + | IrOr of vreg * vreg * vreg + | IrXor of vreg * vreg * vreg + | IrEq of vreg * vreg * vreg + | IrNeq of vreg * vreg * vreg + + | IrCmpul of vreg * vreg * vreg + | IrCmpug of vreg * vreg * vreg + | IrCmpule of vreg * vreg * vreg + | IrCmpuge of vreg * vreg * vreg + + | IrCmpsl of vreg * vreg * vreg + | IrCmpsg of vreg * vreg * vreg + | IrCmpsle of vreg * vreg * vreg + | IrCmpsge of vreg * vreg * vreg + + | IrExtZero of vreg * vreg * accessClass + | IrExtSign of vreg * vreg * accessClass + | IrLoad of vreg * vreg * accessClass (* %1 <- [%2] *) + | IrStore of vreg * vreg * accessClass (* [%1] <- %2 *) + | IrJz of vreg * label + | IrJnz of vreg * label + | IrJmp of label + + | IrRet of vreg option + | IrAlloc of vreg * word + | IrCopy of vreg * label * word + + | IrNopLabel of label + + datatype ev = Reg of vreg | Addr of vreg + + datatype localCtx = Lctx of { + localVars: { onStack: bool, t: P.ctype } vector, + vregs: { class: vregClass } D.t, + newLabelNum: int, + ops: irIsn list, + loopLabels: { break: label, continue: label } list + } + + (* fun updateCtx (Ctx ctx) = fn z => let fun from objs objsZI extSyms globSyms funcs strlits = @@ -24,13 +86,972 @@ functor IL(P: PARSER) = struct in FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) end + *) + + 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 + in + FRU.makeUpdate5 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f)) + end + + fun typeAccessClass t = + case P.sizeOfType t of + 0w1 => AC1 + | 0w2 => AC2 + | 0w4 => AC4 + | 0w8 => AC8 + | _ => raise Unreachable + + + fun setupLocalVars localVars = + let + val len = Vector.length localVars + + fun setup idx acc = + if idx = len then + Vector.fromList (rev acc) + else + let + val { onStack: bool, t, ... } = Vector.sub (localVars, idx) + in + setup (idx + 1) ({ onStack, t } :: acc) + end + in + setup 0 [] + end + + fun getClassForType t = + case Word.compare (P.sizeOfType t, 0w8) of + GREATER => raise Unreachable + | EQUAL => VR8 + | LESS => VR4 + + fun setupVregs localVars = + let + val len = Vector.length localVars + val vregs = D.create 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 + val () = loop 0 + in + vregs + end - fun register ctx (P.Objects revObjs) = - updateCtx ctx u#objs (fn objs => List.revAppend (revObjs, objs)) % - | register ctx (P.Definition _) = ctx + fun createLocalCtx localVars = + let + val localVars = setupLocalVars localVars + val vregs = setupVregs localVars + in + Lctx { localVars, vregs, ops = [], newLabelNum = 0, loopLabels = [] } + end (* - type objDef = int * P.tkPos * ctype * cini * linkage - type decl = P.tkPos * declClass * ctype * linkage + 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 }) + in + id + end + + 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 + in + (v, ctxPutOp ctx (IrSet (v, SaConst w))) + end + + fun getClass (Lctx { vregs, ... }) id = #class $ D.get vregs id + + fun convConst ctx (w, t) = + let + val class = + case Word.compare (P.sizeOfType t, 0w8) of + GREATER => raise Unreachable + | EQUAL => VR8 + | LESS => VR4 + + val v = getNewVReg class ctx + in + (Reg v, ctxPutOp ctx (IrSet (v, SaConst w))) + end + + fun convGLconst ctx (id, isFunc) = + let + val v = getNew8 ctx + val ctx = ctxPutOp ctx (IrSet (v, SaGL id)) + in + if isFunc then + (Reg v, ctx) + else + (Addr v, ctx) + 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 + + 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 vRes = getNew8 ctx + val ctx = ctxPutOp ctx (IrAdd (vRes, v, vOff)) + in + (Addr vRes, ctx) + end + + fun convFieldAccessByV ctx ea field = + let + val (v, ctx) = convExpr ctx ea + val offset = getOffset ea field + in + case v of + Addr v => computeFieldFromVReg ctx v offset + | Reg _ => raise Unreachable + end + + and convFieldAccesByP ctx ea field = + let + val (v, ctx) = 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 + end + + and convSizeOfType ctx t: ev * localCtx = + let + val w = P.sizeOfType t + val (v, ctx) = newConst ctx VR8 w + in + (Reg v, ctx) + end + + 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 ctx = ctxPutOp ctx (op' (v, v, v1)) + in + (Reg v, ctx) + 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 0w1 + val ctx = ctxPutOp ctx (op' (vl, vl, v1)) + val ctx = ctxPutOp ctx (IrStore (v, vl, aClass)) + in + (Reg vl, ctx) + end + + and convPost op' ctx (v, t) = + case v of + Reg v => + 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 0w1 + val ctx = ctxPutOp ctx (op' (v, v, v1)) + in + (Reg vOld, ctx) + 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 0w1 + val ctx = ctxPutOp ctx (op' (vl, vl, v1)) + val ctx = ctxPutOp ctx (IrStore (v, vl, aClass)) + in + (Reg vOld, ctx) + end + + and convAddr ctx v = + case v of + Reg _ => raise Unreachable + | Addr v => (Reg v, ctx) + + and convDeref ctx v = + case v of + Reg v => (Addr v, ctx) + | Addr v => + let + val vD = getNew8 ctx + val ctx = ctxPutOp ctx (IrLoad (vD, v, AC8)) + in + (Addr vD, ctx) + end + + and convPos ctx v = (v, ctx) + + and prepIsZero ctx vDest vSrc = + let + val (vc, ctx) = 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 + in + ctxPutOp ctx (IrSub (vDest, vc, vSrc)) + end + + and prepComp ctx vDest vSrc = + let + val (vc, ctx) = newConst ctx (getClass ctx vSrc) (Word.~ 0w1) + in + ctxPutOp ctx (IrXor (vDest, vSrc, vc)) + end + + and convSimpleUnop fop ctx (v, t) = + case v of + Reg v => + let + val vNew = getNewVReg (getClass ctx v) ctx + val ctx = fop ctx vNew v + in + (Reg vNew, ctx) + 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) + end + + and convCast ctx (v, fromT, toT) = + case Word.compare (P.sizeOfType toT, P.sizeOfType fromT) of + EQUAL => (v, ctx) + | LESS => ( + case v of + Reg v => + let + val vNew = getNew4 ctx + val ctx = ctxPutOp ctx (IrSet (vNew, SaVReg v)) + in + (Reg vNew, ctx) + end + | Addr v => (Addr v, ctx) + ) + | GREATER => + let + val op' = if P.isSigned fromT then IrExtSign else IrExtZero + val aClass = typeAccessClass fromT + val toTClass = getClassForType toT + + val (v, ctx) = + case v of + Addr v => + let + val vl = getNew4 ctx + val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass)) + in + (vl, ctx) + end + | Reg v => (v, ctx) + val vNew = getNewVReg toTClass ctx + val ctx = ctxPutOp ctx (op' (vNew, v, aClass)) + in + (Reg vNew, ctx) + end + + and convUnop ctx unop ea t = + let + val (v, ctx) = convExpr ctx ea + val subT = P.getT ea + in + case unop of + P.UnopPreInc => convPre IrAdd ctx (v, subT) + | P.UnopPreDec => convPre IrSub ctx (v, subT) + | 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.UnopDeref => convDeref ctx v + | P.UnopPos => convPos ctx v + | P.UnopNeg => convSimpleUnop prepNeg ctx (v, subT) + | P.UnopComp => convSimpleUnop prepComp ctx (v, subT) + | P.UnopLogNeg => convSimpleUnop prepIsZero ctx (v, subT) + | P.UnopCast => convCast ctx (v, subT, t) + end + + and loadIfNeeded ctx t vLeft = + case vLeft of + Reg v => (v, ctx) + | 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) + end + + and binopPrepOpers ctx t vLeft vRight = + let + val (vLeft, ctx) = loadIfNeeded ctx t vLeft + val (vRight, ctx) = loadIfNeeded ctx t vRight + val vNew = getNewVReg (getClass ctx vLeft) ctx + in + (vNew, vLeft, vRight, ctx) + end + + and convSimple ctx t vLeft vRight op' = + let + val (vNew, vLeft, vRight, ctx) = binopPrepOpers ctx t vLeft vRight + val ctx = ctxPutOp ctx (op' (vNew, vLeft, vRight)) + in + (Reg vNew, ctx) + end + + and shiftPointer ctx op' (leftT, vLeft) (rightT, vRight) = + let + val (v, ctx) = + 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)) + 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) + end + + and convSum ctx (leftT, vLeft) (rightT, vRight) = + let + val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft + val (vRight, ctx) = 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) + end + end + + and convSub ctx (leftT, vLeft) (rightT, vRight) = + let + val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft + val (vRight, ctx) = 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)) + in + (Reg vRes, ctx) + 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) + end + end + + and convSimpleAssignment ctx leftT vLeft vRight = + let + val (vRight, ctx) = 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 + end + + and convSubscript ctx (leftT, vLeft) (rightT, vRight) = + let + val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft + val (vRight, ctx) = loadIfNeeded ctx rightT vRight + + val (res, ctx) = + case shiftPointer ctx IrAdd (leftT, vLeft) (rightT, vRight) of + (Reg v, ctx) => (v, ctx) + | (Addr _, _) => raise Unreachable + in + (Addr res, ctx) + end + + and convCompAssign ctx (leftT, vLeft) (rightT, vRight) (op', op2) = + let + val (vRight, ctx) = loadIfNeeded ctx rightT vRight + val leftT = P.resolveType leftT + val rightT = P.resolveType rightT + + val commonType = P.commonType leftT rightT + + 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 + else + (v, ctx) + + fun apply ctx leftV = + let + val (vLeft, ctx) = convIfNeeded ctx leftT leftV + val (vRight, ctx) = convIfNeeded ctx rightT vRight + + val op' = if P.isSigned commonType then op2 else op' + val ctx = ctxPutOp ctx (op' (vLeft, vLeft, vRight)) + in + (vLeft, ctx) + 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 + in + (Reg v, ctx) + 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 (vLeft, ctx) = apply ctx vl + val ctx = ctxPutOp ctx (IrStore (v, vLeft, aClass)) + in + (Reg vLeft, ctx) + end + end + + and convComma ctx _ (_, vRight) = (vRight, ctx) + + and getLabel (C as Lctx { newLabelNum, ... }) = + (newLabelNum, updateLctx C u#newLabelNum (fn l => l + 1) %) + + and getLabelPair ctx = + let + val (l1, ctx) = getLabel ctx + val (l2, ctx) = getLabel ctx + in + (l1, l2, ctx) + 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) = + 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 + else + (v, ctx) + in + (v, ctx) + end + + and convLogOr ctx left right = + let + val (vLeft, ctx) = genLogPart ctx left + + val (elseLabel, endLabel, ctx) = getLabelPair ctx + val ctx = ctxPutOp ctx (IrJz (vLeft, elseLabel)) + 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 (vRight, ctx) = genLogPart ctx right + val (vC, ctx) = newConst ctx (getClass ctx vRight) 0w0 + val ctx = ctxPutOp ctx (IrNeq (vRes, vRight, vC)) + in + (Reg vRes, ctx) + 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 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) + in + (Reg vRes, ctx) + end + + and convBinop ctx binop left right = + let + val leftT = P.getT left + val rightT = P.getT right + + fun chs opS opU = if P.isSigned leftT then opS else opU + + fun apply f = + let + val (vLeft, ctx) = convExpr ctx left + val (vRight, ctx) = convExpr ctx right + in + f ctx (leftT, vLeft) (rightT, vRight) + end + + fun commonWrapper f ctx (leftT, vLeft) (_, vRight) = + f ctx leftT vLeft vRight + + val convSimple = apply $ commonWrapper convSimple + val convCompAssign = apply convCompAssign + in + case binop of + P.BR P.BrMul => convSimple (chs IrIMul IrMul) + | P.BR P.BrDiv => convSimple (chs IrIDiv IrDiv) + | P.BR P.BrMod => convSimple (chs IrIMod IrMod) + | P.BR P.BrShiftLeft => convSimple IrShl + | P.BR P.BrShiftRight => convSimple (chs IrSar IrShr) + | P.BR P.BrBitAnd => convSimple IrAnd + | P.BR P.BrBitOr => convSimple IrOr + | P.BR P.BrBitXor => convSimple IrXor + | P.BR P.BrEqual => convSimple IrEq + | P.BR P.BrNotEqual => convSimple IrNeq + | P.BR P.BrGreater => convSimple (chs IrCmpsg IrCmpug) + | P.BR P.BrLess => convSimple (chs IrCmpsl IrCmpul) + | P.BR P.BrGreaterEqual => convSimple (chs IrCmpsge IrCmpuge) + | P.BR P.BrLessEqual => convSimple (chs IrCmpsle IrCmpule) + + | P.BR P.BrAssign => apply $ commonWrapper convSimpleAssignment + | P.BR P.BrBitAndAssign => convCompAssign (IrAnd, IrAnd) + | P.BR P.BrBitOrAssign => convCompAssign (IrOr, IrOr) + | P.BR P.BrBitXorAssign => convCompAssign (IrXor, IrXor) + + | P.BR P.BrLeftShiftAssign => convCompAssign (IrShl, IrShl) + | P.BR P.BrRightShiftAssign => convCompAssign (IrShr, IrSar) + | P.BR P.BrDivAssign => convCompAssign (IrDiv, IrIDiv) + | P.BR P.BrMulAssign => convCompAssign (IrMul, IrIMul) + | P.BR P.BrModAssign => convCompAssign (IrMod, IrIMod) + + | P.BR P.BrSubscript => apply convSubscript + | P.BR P.BrComma => apply convComma + + | P.BR P.BrSum => apply convSum + | P.BR P.BrSub => apply convSub + | P.BR P.BrSumAssign => convCompAssign (IrAdd, IrAdd) + | P.BR P.BrSubAssign => convCompAssign (IrSub, IrSub) + + | P.BR P.BrLogOr => convLogOr ctx left right + | P.BR P.BrLogAnd => convLogAnd ctx left right + | P.BinopTernaryIncomplete _ => raise Unreachable + end + + and convTernary ctx cond left right = + 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 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) + in + (Reg vRes, ctx) + end + + (* + EfuncCall of exprAug * exprAug list | *) + + and convExpr ctx ea: ev * localCtx = + let + val P.EA (e, _, _, t) = ea + in + case e of + P.Eid (_, loc) => convId ctx (valOf loc) + | P.Econst (_, P.Ninteger w) => convConst ctx (w, t) + | P.Econst (_, _) => raise Unreachable + | P.Estrlit id => convGLconst ctx (id, false) + | P.EmemberByV (ea, field) => convFieldAccessByV ctx ea field + | P.EmemberByP (ea, field) => convFieldAccesByP ctx ea field + | P.EsizeofType t => convSizeOfType ctx t + | 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 + end + + fun convIni (C as Lctx { localVars, ... }) (id, NONE) = + let + val size = P.sizeOfType $ #t $ Vector.sub (localVars, id) + in + ctxPutOp C (IrAlloc (id, size)) + end + | 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 + in + if #onStack $ Vector.sub (localVars, id) then + ctxPutOp ctx (IrLoad (id, v, typeAccessClass t)) + else + ctxPutOp ctx (IrSet (id, SaVReg v)) + end + | convIni ctx (id, SOME (P.CiniLayout lid)) = + let + val size = P.getLayoutSize lid + in + ctxPutOp ctx (IrCopy (id, lid, size)) + end + + fun convReturn ctx ea = + case ea of + SOME ea => + let + val (v, ctx) = convExpr ctx ea + val (v, ctx) = loadIfNeeded ctx (P.getT ea) v + in + ctxPutOp ctx (IrRet $ SOME v) + end + | NONE => ctxPutOp ctx (IrRet NONE) + + 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 + in + ctx + end + + and ctxGetLoopLabels ctx = + let + val (l1, l2, ctx) = getLabelPair ctx + val ctx = updateLctx ctx u#loopLabels + (fn l => { break = l1, continue = l2 } :: l) % + in + (l1, l2, ctx) + end + + and ctxLoopExit ctx = updateLctx ctx u#loopLabels tl % + + 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 + in + 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 + in + ctx + end + + and convBreakOrCont isBreak (C as Lctx { loopLabels, ... }) = + let + val { break, continue } = hd loopLabels + val label = if isBreak then break else continue + in + ctxPutOp C (IrJmp label) + end + + and convStmt ctx stmt = + 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.StmtIf t => convIf ctx t + | P.StmtReturn ea => convReturn ctx ea + | 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 + fun f l out = Printf out `".L" I l % + in + bind A1 f + end z + + val Pac = fn z => + let + fun f ac out = + Printf out `( + case ac of + AC1 => "byte" + | AC2 => "word" + | AC4 => "dword" + | AC8 => "qword") % + in + bind A1 f + end z + + val Pt = fn z => + let + fun f ctx id out = + let + val c = getClass ctx id + in + Printf out `(case c of VR4 => "w4" | VR8 => "w8") % + end + in + bind A2 f + end z + + fun printOpSet ctx reg arg = + let + val () = printf `"\t" Preg reg `" " Pt ctx reg `" = " % + in + case arg of + SaVReg reg => printf Preg reg % + | SaConst w => printf W w % + | SaGL id => printf PP.? id % + end + + fun printOp ctx op' = + let + fun pt (reg1, reg2, reg3) op' = + printf `"\t" Preg reg1 `" " Pt ctx reg1 `" = " + `op' `" " Preg reg2 `", " Preg reg3 % + + fun pe (reg1, reg2, aClass) op' = + printf `"\t" Preg reg1 `" " Pt ctx reg1 `" = " + `op' `" " Pac aClass `" " Preg reg2 % + + fun pj (r, l) op' = printf `"\t" `op' `" " Preg r `", " Pl l % + + + fun printRet NONE = printf `"\tret" % + | printRet (SOME reg) = + printf `"\tret " Pt ctx reg `" " Preg reg % + + fun printAlloc (r, size) = printf `"\t" Preg r `" = alloc " W size % + fun printCopy (to, from, size) = + printf `"\tcopy " Preg to `", .I" I from `", " W size % + in + case op' of + IrSet (reg, arg) => printOpSet ctx reg arg + | IrAdd t => pt t "add" + | IrSub t => pt t "sub" + | IrMul t => pt t "mul" + | IrIMul t => pt t "imul" + | IrDiv t => pt t "div" + | IrIDiv t => pt t "idiv" + | IrMod t => pt t "mod" + | IrIMod t => pt t "imod" + | IrShl t => pt t "shl" + | IrShr t => pt t "shr" + | IrSar t => pt t "sar" + | IrAnd t => pt t "and" + | IrOr t => pt t "or" + | IrXor t => pt t "xor" + | IrEq t => pt t "eq" + | IrNeq t => pt t "neq" + | IrCmpul t => pt t "cmpul" + | IrCmpug t => pt t "cmpug" + | IrCmpule t => pt t "cmpule" + | IrCmpuge t => pt t "cmpuge" + | IrCmpsl t => pt t "cmpsl" + | IrCmpsg t => pt t "cmpsg" + | IrCmpsle t => pt t "cmpsle" + | IrCmpsge t => pt t "cmpsge" + + | IrExtZero t => pe t "extz" + | IrExtSign t => pe t "exts" + + | IrLoad (r1, r2, ac) => + printf `"\t" Preg r1 `" = " Pac ac `" [" Preg r2 `"]" % + | IrStore (r1, r2, ac) => + printf `"\t" Pac ac `" [" Preg r1 `"] <- " Preg r2 % + | IrJmp l => printf `"\tjmp " Pl l % + | IrJz p => pj p "jz" + | IrJnz p => pj p "jnz" + | IrNopLabel l => printf Pl l `":" % + | IrRet v => printRet v + | IrAlloc p => printAlloc p + | IrCopy t => printCopy t + ; + printf `"\n" % + end + + fun printIns (C as Lctx { ops, ... }) = + List.app (printOp C) ops + + fun translateFn (F as { localVars, stmt, ... }) = + let + val () = P.printDef (P.Definition F) + val ctx = createLocalCtx localVars + val ctx = convStmt ctx stmt + + val ctx = updateLctx ctx u#ops (fn ops => rev ops) % + in + printIns ctx + end + + fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) = + let + val _ = List.map (fn func => translateFn func) funcs + in + Ctx { objs, objsZI, extSyms = ext, globSyms = glob, funcs, strlits } + end + + 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 end @@ -65,7 +65,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; and evalRes = ER of word * ctype - and id = Lid of int | Gid of int + and id = Lid of int | Gid of int * bool and expr = Eid of int * id option | @@ -143,8 +143,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; datatype ini = IniExpr of exprAug | IniCompound of ini list - datatype cini = CiniExpr of exprAug | CiniConst of word | - CiniLayout of int + datatype cini = CiniExpr of exprAug | CiniLayout of int datatype storageSpec = SpecTypedef | @@ -1382,8 +1381,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; in case res of SOME (GsDecl (_, _, t, _)) => - (Gid id, not $ isFunc t, convAggr under t, NONE) - | SOME (GsEnumConst v) => (Gid id, false, int_t, SOME v) + (Gid (id, isFunc t), not $ isFunc t, convAggr under t, NONE) + | SOME (GsEnumConst v) => (Gid (id, false), false, int_t, SOME v) | SOME (GsTypedef _) => P.error pos `"type in place of an identifier" % | NONE => P.error pos `"unknown identifier" % @@ -1424,6 +1423,13 @@ functor Parser(structure Tree: TREE; structure P: PPC; else E + and commonType t1 t2 = + let + val common = if typeRank t1 > typeRank t2 then t1 else t2 + in + if typeRank common < typeRank int_t then int_t else common + end + and convArith (E1 as EA (_, pos1, _, t1)) (E2 as EA (_, pos2, _, t2)) = let val rank1 = typeRank t1 @@ -1479,7 +1485,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; case unop of UnopPostInc | UnopPostDec | UnopPreInc | UnopPreDec => if isScalar ot andalso isLvalue oper then - EA (Eunop (unop, oper), pos, true, ot) + EA (Eunop (unop, oper), pos, false, ot) else P.error (getPos oper) `"expected an arithmetic or a pointer lvalue expression" % @@ -1598,12 +1604,16 @@ functor Parser(structure Tree: TREE; structure P: PPC; val rightPos = getPos right val isSub = case binop of BR BrSub => true | _ => false + + fun swap (EA (Ebinop (binop, left, right), pos, lvalue, t)) = + EA (Ebinop (binop, right, left), pos, lvalue, t) + | swap _ = raise Unreachable in if isArith leftT then if isArith rightT then justConvArith E ResFromHigher else if isPointerToObj rightT then - setT E rightT + swap $ setT E rightT else P.error rightPos `"expeced pointer" % else if isPointerToObj leftT then @@ -1804,6 +1814,15 @@ functor Parser(structure Tree: TREE; structure P: PPC; end | checkTernary _ _ = raise Unreachable + and getFieldInfo t field = + let + val fields = tryGetFields t + in + case List.find (fn (f, _, _) => f = field) fields of + SOME (_, offset, fieldType) => SOME (offset, fieldType) + | NONE => NONE + end + and checkMemberAccessByV check (EA (EmemberByV (ea, field), pos, _, _)) = let val ea = check ea @@ -1814,13 +1833,10 @@ functor Parser(structure Tree: TREE; structure P: PPC; t else P.error (getPos ea) `"expected an aggregate" % - - val fields = tryGetFields t in - case List.find (fn (f, _, _) => f = field) fields of + case getFieldInfo t field of NONE => P.error pos `"unknown field" % - | SOME (_, _, field_type) => - EA (EmemberByV (ea, field), pos, true, field_type) + | SOME (_, ft) => EA (EmemberByV (ea, field), pos, true, ft) end | checkMemberAccessByV _ _ = raise Unreachable @@ -1842,14 +1858,10 @@ functor Parser(structure Tree: TREE; structure P: PPC; end else P.error (getPos ea) `"expected a pointer to an aggregate" % - - - val fields = tryGetFields t in - case List.find (fn (f, _, _) => f = field) fields of + case getFieldInfo t field of NONE => P.error pos `"unknown field" % - | SOME (_, _, field_type) => - EA (EmemberByP (ea, field), pos, true, field_type) + | SOME (_, ft) => EA (EmemberByP (ea, field), pos, true, ft) end | checkMemberAccessByP _ _ = raise Unreachable @@ -2828,7 +2840,6 @@ functor Parser(structure Tree: TREE; structure P: PPC; end fun printIni _ (CiniExpr ea) out = Printf out A1 pea ea % - | printIni _ (CiniConst w) out = Printf out W w % | printIni off (CiniLayout id) out = let val (_, _, layout) = D.get iniLayouts id @@ -3182,18 +3193,23 @@ functor Parser(structure Tree: TREE; structure P: PPC; ) end + fun registerLayout layout t toplev = + D.pushAndGetId iniLayouts (toplev, sizeOfType t, layout) + + fun getLayoutSize id = #2 $ D.get iniLayouts id + fun canonExprIni toplev t ea = if toplev then let val () = printf `"Here\n" % - val w = eval ea t + val value = eval ea t + val layout = [{ offset = 0w0, t, value }] in - CiniConst w + CiniLayout (registerLayout layout t toplev) end else CiniExpr $ convEA t ea - fun canonIni toplev pos t ini = let val ini = convStrlitIni pos t ini @@ -3210,10 +3226,9 @@ functor Parser(structure Tree: TREE; structure P: PPC; | _ => let val layout = calcOffsets 0w0 $ LcAux (0w0, computeTLayout t) - val seq = flattenIni pos layout ini + val layout = flattenIni pos layout ini - val id = D.length iniLayouts - val () = D.push iniLayouts (toplev, sizeOfType t, seq) + val id = registerLayout layout t toplev in CiniLayout id end @@ -3265,10 +3280,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; let val varId = D.length localVars - val () = printfn `"vid: " I varId `": " P.? id `": len " % - val () = D.push localVars - ({ name = id, pos, t, onStack = false }) + ({ name = id, pos, t, onStack = not $ isScalar t }) val (_, scope) = Tree.insert intCompare scope id varId in @@ -90,7 +90,7 @@ signature PARSER = sig | Nfloat of Real32.real | Ndouble of Real64.real - and id = Lid of int | Gid of int + and id = Lid of int | Gid of int * bool and expr = Eid of int * id option | @@ -113,8 +113,7 @@ signature PARSER = sig val iniLayouts: (bool * word * { offset: word, t: ctype, value: word } list) D.t - datatype cini = CiniExpr of exprAug | CiniConst of word | - CiniLayout of int + datatype cini = CiniExpr of exprAug | CiniLayout of int type objDef = int * P.tkPos * ctype * cini * linkage @@ -152,6 +151,20 @@ signature PARSER = sig val alignOfType: ctype -> word val sizeOfType: ctype -> word + val isSigned: ctype -> bool + val isPointer: ctype -> bool + val pointsTo: ctype -> ctype + + val typeRank: ctype -> int + val resolveType: ctype -> ctype + val commonType: ctype -> ctype -> ctype + + val getLayoutSize: int -> word + + val getT: exprAug -> ctype + + val getFieldInfo: ctype -> nid -> (word * ctype) option + val finalize: ctx -> ctx type progInfo = { |