From 47ce22ee86ad9fb329585e7d9ae2052772248c95 Mon Sep 17 00:00:00 2001 From: Vladimir Azarov Date: Mon, 11 Aug 2025 16:23:42 +0200 Subject: IrJmpc --- emit.fun | 71 +++++++++++++-------- il.fun | 213 ++++++++++++++++++++++++++++++++++++++++++++----------------- il.sig | 4 ++ parser.fun | 72 ++++++++++----------- parser.sig | 4 +- 5 files changed, 243 insertions(+), 121 deletions(-) diff --git a/emit.fun b/emit.fun index 215c335..6b8ceb2 100644 --- a/emit.fun +++ b/emit.fun @@ -125,6 +125,7 @@ functor Emit(I: IL) = struct fun emitAggrLayout id = let val (_, size, layout) = D.get P.iniLayouts id + val size = I.wrapTo8 size val () = fprint `"\n" % @@ -212,7 +213,7 @@ functor Emit(I: IL) = struct val parts = collectStr symbols [] in - fprint `".S" I id `":\t" %; + fprint `"S." I id `":\t" %; fprint `"db " %; List.app (fn p => fprint A1 printPart p `", " %) parts; fprint `"0\n" % @@ -227,7 +228,7 @@ functor Emit(I: IL) = struct fun f (_, (true, _, _)) = () | f (n, (false, _, _)) = ( fprint `"\talign 16\n" %; - fprint `".I" I n `":" %; + fprint `"I." I n `":" %; emitAggrLayout n ) in @@ -378,7 +379,7 @@ functor Emit(I: IL) = struct | I.IrExtZero _ | I.IrExtSign _ | I.IrLoad _ | I.IrStore _ | I.IrJmp _ - | I.IrJz _ | I.IrJnz _ | I.IrNopLabel _ + | I.IrJz _ | I.IrJnz _ | I.IrJmpc _ | I.IrNopLabel _ | I.IrNop _ | I.IrRet _ | I.IrAlloc _ | I.IrCopy _ => IaNone | I.IrFcall (_, _, args) => fcallAff args @@ -1121,7 +1122,7 @@ functor Emit(I: IL) = struct val repr = PP.?? id val repr = if String.sub (repr, 0) = #"\"" then - ".S" ^ Int.toString id + "S." ^ Int.toString id else repr in @@ -1175,6 +1176,7 @@ functor Emit(I: IL) = struct xorIdiom r else sprintf `"mov " A2 pr is8 r `", " A2 pc is8 c % + fun movMV is8 off c = let val () = if not $ fitsInNsx 32 c then raise Unreachable else () @@ -1676,9 +1678,21 @@ functor Emit(I: IL) = struct pre @ mid @ main end - fun emitCmp E (cmpop, rd, rs1, rs2) = + fun cmpOp2cc op' = + case op' of + I.Cmpeq => "e" + | I.Cmpneq => "ne" + | I.Cmpul => "b" + | I.Cmpug => "a" + | I.Cmpule => "be" + | I.Cmpuge => "ae" + | I.Cmpsl => "l" + | I.Cmpsg => "g" + | I.Cmpsle => "le" + | I.Cmpsge => "ge" + + fun getCmpSeq E rs1 rs2 = let - val (_, td) = getType E rd val (is82, ts1) = getType E rs1 val (is83, ts2) = getType E rs2 @@ -1692,8 +1706,6 @@ functor Emit(I: IL) = struct fun RwithRM r vt = sprintf `"cmp " A2 pr is82 r `", " A2 prm is82 vt % - val zeroing = sprintf `"xor " A2 pr false Rax `", " A2 pr false Rax % - val (pre, main) = case (ts1, ts2) of (VtReg _ | VtStack _, VtConst c) => @@ -1708,22 +1720,25 @@ functor Emit(I: IL) = struct | (VtStack off, VtStack _) => ([movRM is82 Rax off], RwithRM Rax ts2) | (VtUnk, _) | (_, VtUnk) => raise Unreachable - val flags = - case cmpop of - I.Cmpeq => "e" - | I.Cmpneq => "ne" - | I.Cmpul => "b" - | I.Cmpug => "a" - | I.Cmpule => "be" - | I.Cmpuge => "ae" - | I.Cmpsl => "l" - | I.Cmpsg => "g" - | I.Cmpsle => "le" - | I.Cmpsge => "ge" + in + pre @ [main] + end - val setPart = sprintf `"set" `flags `" al" % + fun emitCmp E (op', rd, rs1, rs2) = + let + val (_, td) = getType E rd + val cmpPart = getCmpSeq E rs1 rs2 + val setPart = sprintf `"set" `(cmpOp2cc op') `" dl" % + in + [xorIdiom Rdx] @ cmpPart @ [setPart] @ [mov true td (VtReg Rdx)] + end + + fun emitJmpc E (op', rs1, rs2, lid) = + let + val cmpPart = getCmpSeq E rs1 rs2 + val jmp = sprintf `"j" `(cmpOp2cc op') `" " I.Pl lid % in - [zeroing] @ pre @ [main] @ [setPart] @ [mov true td (VtReg Rax)] + cmpPart @ [jmp] end fun emitExt E (vd, vs, from) op' = @@ -1742,7 +1757,12 @@ functor Emit(I: IL) = struct val main = case (to, from) of (I.AC4, I.AC1) | (I.AC4, I.AC2) => ext () - | (I.AC8, I.AC1) | (I.AC8, I.AC2) | (I.AC8, I.AC4) => ext () + | (I.AC8, I.AC1) | (I.AC8, I.AC2) => ext () + | (I.AC8, I.AC4) => + if op' = "movzx" then + mov false (VtReg dest) ts + else + ext () | (I.AC4, I.AC4) | (I.AC4, I.AC8) => raise Unreachable | (I.AC8, I.AC8) => raise Unreachable @@ -1814,7 +1834,7 @@ functor Emit(I: IL) = struct in case t1 of VtReg r => - [ sprintf `"lea " A2 pr true r `", [rsp-" I stackOffset `"]" % ] + [ sprintf `"lea " A2 pr true r `", [rbp-" I stackOffset `"]" % ] | _ => raise Unreachable end | emitAlloc _ (_, _, NONE) = raise Unreachable @@ -1858,7 +1878,7 @@ functor Emit(I: IL) = struct rev acc else let - val from = sprintf `"mov rax, qword [.I" I lid `"+" W off `"]" % + val from = sprintf `"mov rax, qword [I." I lid `"+" W off `"]" % val to = sprintf `"mov [" A2 pr true destReg `"+" W off `"], rax" % in @@ -1990,6 +2010,7 @@ functor Emit(I: IL) = struct | I.IrIMod t => emitDivMod E t "idiv" Rdx true | I.IrCmp q => emitCmp E q + | I.IrJmpc q => emitJmpc E q | I.IrLoad t => emitLoad E t | I.IrStore t => emitStore E t diff --git a/il.fun b/il.fun index 286cd32..0d45676 100644 --- a/il.fun +++ b/il.fun @@ -43,6 +43,7 @@ functor IL(P: PARSER) = struct | IrLoad of vreg * vreg * accessClass (* %1 <- [%2] *) | IrStore of vreg * vreg * accessClass (* [%1] <- %2 *) + | IrJmpc of cmpOp * vreg * vreg * label | IrJz of vreg * label | IrJnz of vreg * label | IrJmp of label @@ -243,6 +244,7 @@ functor IL(P: PARSER) = struct | IrLoad (r1, r2, _) => de (r1, r2) | IrStore (r1, r2, _) => { defs = [], use = [r1, r2] } | IrJmp _ => { defs = [], use = [] } + | IrJmpc (_, r1, r2, _) => { defs = [], use = [r1, r2] } | IrJz (r, _) => { defs = [], use = [r] } | IrJnz (r, _) => { defs = [], use = [r] } | IrNopLabel _ | IrNop _ => { defs = [], use = [] } @@ -387,12 +389,12 @@ functor IL(P: PARSER) = struct Reg v end - fun convGLconst ctx (id, isFunc) = + fun convGLconst ctx id = let val v = getNew8 ctx in ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0))); - if isFunc then Reg v else Addr v + Addr v end fun convStrlit ctx id t = @@ -403,7 +405,7 @@ functor IL(P: PARSER) = struct (if P.isArray t then Addr else Reg) v end - fun convId ctx (P.Gid p) = convGLconst ctx p + fun convId ctx (P.Gid id) = convGLconst ctx id | convId (Lctx { localVars, paramNum, ... }) (P.Lid id) = if id < paramNum then (* function parameter *) (Reg (id + Vector.length localVars)) @@ -576,8 +578,7 @@ functor IL(P: PARSER) = struct Reg vl end - and convCast _ (v, _, P.void_t) = v - | convCast ctx (v, fromT, toT) = + and convCastScalar ctx v fromT toT = case Word.compare (P.sizeOfType toT, P.sizeOfType fromT) of EQUAL => v | LESS => ( @@ -613,6 +614,30 @@ functor IL(P: PARSER) = struct Reg vNew end + and convCast _ (v, _, P.void_t) = v + | convCast ctx (v, fromT, toT) = + if P.isArray fromT then + let + val elT = P.elementType fromT + val () = + if toT <> P.pointer_t (1, elT) then raise Unreachable else () + in + case v of + Addr v => Reg v + | _ => raise Unreachable + end + else if P.isFunc fromT then + let + val () = + if toT <> P.pointer_t (1, fromT) then raise Unreachable else () + in + case v of + Addr v => Reg v + | _ => raise Unreachable + end + else + convCastScalar ctx v fromT toT + and convUnop ctx unop ea t: ev = let val v: ev = convExpr ctx ea @@ -1050,20 +1075,17 @@ functor IL(P: PARSER) = struct val t = P.getT ea val v = convExpr C ea val v = loadIfNeeded C t v + in - if #onStack $ Vector.sub (localVars, id) then - ctxPutOp C (IrLoad (id, v, typeAccessClass t)) - else + if #onStack $ Vector.sub (localVars, id) then ( + ctxPutOp C (IrAlloc (id, 0w8, NONE)); + ctxPutOp C (IrStore (id, v, typeAccessClass t)) + ) else ctxPutOp C (IrSet (id, SaVReg v)) end | convIni ctx (id, SOME (P.CiniLayout lid)) = let - val size = P.getLayoutSize lid - val () = - if Word.mod (size, 0w8) <> 0w0 then - raise Unreachable - else - () + val size = wrapTo8 $ P.getLayoutSize lid in ctxPutOp ctx (IrAlloc (id, size, NONE)); ctxPutOp ctx (IrCopy (id, lid, size)) @@ -1340,7 +1362,7 @@ functor IL(P: PARSER) = struct end fun printCopy (to, from, size) = - dprintf `"\tcopy " Preg ctx to `", .I" I from `", " W size % + dprintf `"\tcopy " Preg ctx to `", I." I from `", " W size % fun printFcall (ret, f, args) = let @@ -1353,6 +1375,7 @@ functor IL(P: PARSER) = struct in dprintf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) % end + fun printLabel (Lctx { labels, ... }) lid = let val (labelPos, use) = D.get labels lid @@ -1373,6 +1396,15 @@ functor IL(P: PARSER) = struct | Cmpsg => "cmpsg" | Cmpsle => "cmpsle" | Cmpsge => "cmpsge" + + fun pjc (op', r1, r2, lid) = + let + val opRepr = cmpOpStr op' + val opRepr = "jmp" ^ String.extract (opRepr, 3, NONE) + in + dprintf `"\t" `opRepr `" " + Preg ctx r1 `", " Preg ctx r2 `", " Pl lid % + end in case op' of IrSet (reg, arg) => printOpSet ctx reg arg @@ -1401,6 +1433,7 @@ functor IL(P: PARSER) = struct | IrStore (r1, r2, ac) => dprintf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 % | IrJmp l => dprintf `"\tjmp " Pl l % + | IrJmpc q => pjc q | IrJz p => pj p "jz" | IrJnz p => pj p "jnz" | IrNopLabel l => printLabel ctx l @@ -1681,7 +1714,7 @@ functor IL(P: PARSER) = struct | IrAlloc _ | IrLoad _ | IrStore _ | IrRet _ | IrFcall _ | IrCopy _ | IrJz _ | IrJnz _ => RtReg - | IrJmp _ | IrNop _ | IrNopLabel _ => raise Unreachable + | IrJmpc _ | IrJmp _ | IrNop _ | IrNopLabel _ => raise Unreachable end fun eval (SOME ins) vregs = @@ -1800,63 +1833,129 @@ functor IL(P: PARSER) = struct | IrRet NONE => raise Unreachable | IrSet (_, arg) => IrSet (rd, arg) | IrNop _ | IrNopLabel _ | IrAlloc _ | IrCopy _ | IrJmp _ | IrJz _ - | IrJnz _ | IrStore _ => raise Unreachable + | IrJmpc _ | IrJnz _ | IrStore _ => raise Unreachable end - fun mergeIns (Lctx { vregs, ops, ... }) idx rd rs = + fun removeVR vregs vr = let - val () = dprintf `"removing %" I rs `"\n" % - - val { class, ... } = D.get vregs rs - val () = D.set vregs rs + val { class, ... } = D.get vregs vr + in + D.set vregs vr { defs = [], use = [], class, t = RtRem, canFold = false } - val ins = valOf o #1 $ D.get ops (idx - 1) - val ir = changeDest rd ins + end + + fun changeIns ops idx ins = + let + fun f (SOME _, v) = (ins, v) + | f (NONE, _) = raise Unreachable + in + D.update ops f idx + end - fun f1 (SOME _, v) = (SOME ir, v) - | f1 (NONE, _) = raise Unreachable - fun f2 (SOME _, v) = (NONE, v) - | f2 (NONE, _) = raise Unreachable + fun changeEl from to (x :: xs) acc = + changeEl from to xs $ (if x = from then to else x) :: acc + | changeEl _ _ [] acc = rev acc - val () = D.update ops f1 (idx - 1) - val () = D.update ops f2 idx + fun changeDef vregs vr from to = + let + val { defs, use, class, t, canFold } = D.get vregs vr + in + D.set vregs vr { defs = changeEl from to defs [], use, class, t, + canFold } + end - val { defs, use, class, t, canFold } = D.get vregs rd + fun changeUse vregs vr from to = + let + val { defs, use, class, t, canFold } = D.get vregs vr + in + D.set vregs vr { defs, use = changeEl from to use [], class, t, + canFold } + end - fun loop (d :: ds) acc = - loop ds $ (if d = idx then idx - 1 else d) :: acc - | loop [] acc = rev acc - val () = D.set vregs rd { defs = loop defs [], use, class, t, canFold } + fun singleDefUse vregs vr = + let + val { defs, use, ... } = D.get vregs vr in - () + case (defs, use) of + ([d], [_]) => SOME d + | _ => NONE end - fun optSet (C as Lctx { vregs, localVars, paramNum, ... }) + fun fuseSet (Lctx { vregs, localVars, paramNum, ops, ... }) (idx, (SOME (IrSet (rd, SaVReg rs)), _)) = if getCS vregs rd <> getCS vregs rs then () - else - let - val { defs, use, ... } = D.get vregs rs - in - case (defs, use) of - ([d], [_]) => - if d = idx - 1 andalso rs >= Vector.length localVars + paramNum - then - mergeIns C idx rd rs - else - () - | _ => () - end - | optSet _ _ = () + else ( + case singleDefUse vregs rs of + NONE => () + | SOME d => ( + if d = idx - 1 andalso rs >= Vector.length localVars + paramNum + then + let + val () = dprintf `"fusing instruction " I d `" with " I idx % + val () = removeVR vregs rs - fun peephole (C as Lctx { ops, ... }) = - let - val () = D.appi (optSet C) ops - in - () - end + val ins = valOf o #1 $ D.get ops (idx - 1) + val ir = changeDest rd ins + + val () = changeIns ops (idx - 1) (SOME ir) + val () = changeIns ops idx NONE + in + changeDef vregs rd idx (idx - 1) + end + else + () + ) + ) + | fuseSet _ _ = () + + fun convCmpOp op' false = op' + | convCmpOp op' true = + case op' of + Cmpeq => Cmpneq + | Cmpneq => Cmpeq + | Cmpul => Cmpuge + | Cmpug => Cmpule + | Cmpule => Cmpug + | Cmpuge => Cmpul + | Cmpsl => Cmpsge + | Cmpsg => Cmpsle + | Cmpsle => Cmpsg + | Cmpsge => Cmpsl + + fun fuseJmpCommon (Lctx { ops, vregs, ... }) idx rs lid isRev = + case singleDefUse vregs rs of + NONE => () + | SOME d => ( + case #1 $ D.get ops d of + SOME (IrCmp (op', _, r1, r2)) => + let + val () = dprintf `"fusing instruction " I d `" with " I idx % + val () = removeVR vregs rs + val () = changeUse vregs r1 d idx + val () = changeUse vregs r2 d idx + val ins = IrJmpc (convCmpOp op' isRev, r1, r2, lid) + in + changeIns ops d NONE; + changeIns ops idx (SOME ins) + end + | _ => () + ) + + fun fuseJmpc C (idx, (ins, _)) = + case ins of + SOME (IrJnz (rs, lid)) => fuseJmpCommon C idx rs lid false + | SOME (IrJz (rs, lid)) => fuseJmpCommon C idx rs lid true + | _ => () + + fun lowerMul C (idx, (ins, _)) = raise Unimplemented + + fun peephole (C as Lctx { ops, ... }) = ( + D.appi (fuseSet C) ops; + D.appi (fuseJmpc C) ops; + D.appi (lowerMul C) ops + ) fun removeUnusedLabels (Lctx { ops, labels, ... }) = let diff --git a/il.sig b/il.sig index 4705c1b..4c9e3a6 100644 --- a/il.sig +++ b/il.sig @@ -43,6 +43,7 @@ signature IL = sig | IrLoad of vreg * vreg * accessClass (* %1 <- [%2] *) | IrStore of vreg * vreg * accessClass (* [%1] <- %2 *) + | IrJmpc of cmpOp * vreg * vreg * label | IrJz of vreg * label | IrJnz of vreg * label | IrJmp of label @@ -73,6 +74,9 @@ signature IL = sig val Pwc: (vregClass, word, 'a, 'b, 'c) a2printer val Pac: (accessClass, 'a, 'b, 'c) a1printer + val Pl: (label, 'a, 'b, 'c) a1printer + + val wrapTo8: word -> word datatype funcInfo = Fi of { name: int, diff --git a/parser.fun b/parser.fun index f080d9e..a954a8e 100644 --- a/parser.fun +++ b/parser.fun @@ -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 * bool + and id = Lid of int | Gid of int and expr = Eid of int * id option | @@ -692,6 +692,11 @@ functor Parser(structure Tree: TREE; structure P: PPC; array_t _ => true | _ => false + fun elementType t = + case resolveType t of + array_t (_, elT) => elT + | _ => raise Unreachable + fun isStruct t = case resolveType t of struct_t _ => true @@ -1371,15 +1376,20 @@ functor Parser(structure Tree: TREE; structure P: PPC; ((eof, expr), ctx) end - and convAggr under t lvalue = + and convAggr under ea = + let + fun wrap t = EA (Eunop (UnopCast, ea), getPos ea, false, t) + val t = getT ea + in case under of UNone => ( - case t of - function_t _ => (pointer_t (1, t), false) - | array_t (_, el_t) => (pointer_t (1, el_t), false) - | _ => (t, lvalue) + case resolveType t of + function_t _ => wrap $ pointer_t (1, t) + | array_t (_, el_t) => wrap $ pointer_t (1, el_t) + | _ => ea ) - | _ => (t, lvalue) + | _ => ea + end and reduceVarToStack id = let @@ -1408,9 +1418,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; reduceVarToStack lid else () - val (t, lvalue) = convAggr under t (not $ isFunc t) in - SOME (Lid lid, lvalue, t, NONE) + SOME $ convAggr under (EA (Eid (id, SOME $ Lid lid), pos, true, t)) end | NONE => findLocal scopes end @@ -1423,12 +1432,9 @@ functor Parser(structure Tree: TREE; structure P: PPC; in case res of SOME (GsDecl (_, _, t, _)) => - let - val (t', lvalue) = convAggr under t (not $ isFunc t) - in - (Gid (id, isFunc t), lvalue, t', NONE) - end - | SOME (GsEnumConst v) => (Gid (id, false), false, int_t, SOME v) + convAggr under (EA (Eid (id, SOME (Gid id)), pos, true, t)) + | SOME (GsEnumConst v) => + EA (Econst (id, Ninteger (Word.fromInt v)), pos, false, int_t) | SOME (GsTypedef _) => P.error pos `"type in place of an identifier" % | NONE => P.error pos `"unknown identifier" % @@ -1915,30 +1921,14 @@ functor Parser(structure Tree: TREE; structure P: PPC; end | checkMemberAccessByP _ _ = raise Unreachable - and checkStrlit under (EA (Estrlit id, pos, lvalue, t)) = - let - val (t, lvalue) = convAggr under t lvalue - in - EA (Estrlit id, pos, lvalue, t) - end - | checkStrlit _ _ = raise Unreachable - - and checkExpr ctx (under: under) (E as EA (e, pos, _, _)) = + and checkExpr ctx under (E as EA (e, pos, _, _)) = let val check = checkExpr ctx (* val () = printf `"Checking " A1 pea E `"\n" % *) in case e of - Eid (id', _) => - let - val (id, lvalue, t, const) = findId ctx pos under id' - in - case const of - SOME v => - EA (Econst (id', Ninteger (Word.fromInt v)), pos, false, int_t) - | _ => EA (Eid (id', SOME id), pos, lvalue, t) - end + Eid (id', _) => findId ctx pos under id' | EsizeofType _ => checkSizeofType E | EfuncCall _ => checkFuncCall (check UNone) E | Ebinop (_, _, _) => checkBinop (check UNone) E @@ -1947,7 +1937,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; | EmemberByV _ => checkMemberAccessByV (check UNone) E | EmemberByP _ => checkMemberAccessByP (check UNone) E | Econst _ => E - | Estrlit _ => checkStrlit under E + | Estrlit _ => convAggr under E end and tryGetTypedefName (Ctx ctx) id = @@ -2966,8 +2956,6 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (ini, ctx) = ctxWithLayer ctx' list parseCompoundInitializer val (tk, pos, ctx) = getTokenCtx ctx val status = oneOfEndTks tk terms - - val () = printf `"Status: " I status % in if status = 0 then dieExpTerms pos terms @@ -3249,7 +3237,15 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun getCharArrayLen t = case resolveType t of - array_t (n, t) => if resolveType t = char_t then SOME n else NONE + array_t (n, t) => + let + val t = resolveType t + in + if t = char_t orelse t = uchar_t then + SOME n + else + NONE + end | _ => NONE fun convStrlitIni pos t ini = @@ -3737,7 +3733,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (res, ctx) = parseDeclaration ctx val varInits = case res of - LocalVarInits l => l (* handleInis ctx l *) + LocalVarInits l => l | _ => raise Unreachable in collectDecls (List.revAppend (varInits, acc)) ctx diff --git a/parser.sig b/parser.sig index 0577d36..0406052 100644 --- a/parser.sig +++ b/parser.sig @@ -90,7 +90,7 @@ signature PARSER = sig | Nfloat of Real32.real | Ndouble of Real64.real - and id = Lid of int | Gid of int * bool + and id = Lid of int | Gid of int and expr = Eid of int * id option | @@ -152,10 +152,12 @@ signature PARSER = sig val alignOfType: ctype -> word val sizeOfType: ctype -> word + val isFunc: ctype -> bool val isSigned: ctype -> bool val isPointer: ctype -> bool val pointsTo: ctype -> ctype val isArray: ctype -> bool + val elementType: ctype -> ctype val typeRank: ctype -> int val resolveType: ctype -> ctype -- cgit v1.2.3