From a4c60603f61dd1a9f0ce420be9067965586dd694 Mon Sep 17 00:00:00 2001 From: Vladimir Azarov Date: Mon, 4 Aug 2025 22:13:17 +0200 Subject: Object assembly --- parser.fun | 138 ++++++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 110 insertions(+), 28 deletions(-) (limited to 'parser.fun') diff --git a/parser.fun b/parser.fun index c0c9eaf..6081449 100644 --- a/parser.fun +++ b/parser.fun @@ -3,6 +3,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; structure P = P structure T = P.T + structure D = D type nid = int @@ -143,7 +144,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 { offset: word, t: ctype, value: word } list + CiniLayout of int datatype storageSpec = SpecTypedef | @@ -238,14 +239,20 @@ functor Parser(structure Tree: TREE; structure P: PPC; datatype taggedBody = EnumBody of (nid * P.tkPos * int) list | AggrBody of (nid * ctype) list + type decl = P.tkPos * declClass * ctype * linkage + datatype globalSym = - GsDecl of P.tkPos * declClass * ctype * linkage | + GsDecl of decl | GsEnumConst of int | GsTypedef of int val localVars: { name: nid, pos: P.tkPos, onStack: bool, t: ctype } D.t = D.create0 () + val iniLayouts: + (bool * word * { offset: word, t: ctype, value: word } list) D.t = + D.create0 () + datatype ctx = Ctx of { aggrTypeNames: scope, @@ -256,7 +263,10 @@ functor Parser(structure Tree: TREE; structure P: PPC; tokenBuf: P.t * (token * P.tkPos) list list, - loopLevel: int + loopLevel: int, + + defs: def list, + strlits: int list } val intCompare = fn a => fn b => Int.compare (a, b) @@ -266,17 +276,18 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun updateCtx (Ctx ctx) = fn z => let fun from aggrTypeNames localScopes funcRetType globalSyms - tokenBuf loopLevel + tokenBuf loopLevel defs strlits = - { aggrTypeNames, localScopes, - funcRetType, globalSyms, tokenBuf, loopLevel } + { aggrTypeNames, localScopes, funcRetType, globalSyms, + tokenBuf, loopLevel, defs, strlits } - fun to f { aggrTypeNames, localScopes, - funcRetType, globalSyms, tokenBuf, loopLevel } + fun to f { aggrTypeNames, localScopes, funcRetType, globalSyms, + tokenBuf, loopLevel, defs, strlits } = - f aggrTypeNames localScopes funcRetType globalSyms tokenBuf loopLevel + f aggrTypeNames localScopes funcRetType globalSyms tokenBuf + loopLevel defs strlits in - FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) + FRU.makeUpdate8 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) end datatype declParts = @@ -703,12 +714,13 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun createCtx fname incDirs = Ctx { aggrTypeNames = Tree.empty, - localScopes = [], funcRetType = NONE, globalSyms = Tree.empty, tokenBuf = (P.create { fname, incDirs, debugMode = false }, []), - loopLevel = 0 + loopLevel = 0, + defs = [], + strlits = [] } fun loopWrapper ctx f = @@ -1220,8 +1232,12 @@ functor Parser(structure Tree: TREE; structure P: PPC; case tk of Tk (T.Id id) => wrap $ Eid (id, NONE) | Tk (T.Strlit (id, size)) => - (EA (Estrlit id, pos, false, - array_t (Word64.fromInt size, char_t)), ctx) + let + val ctx = updateCtx ctx u#strlits (fn l => id :: l) % + in + (EA (Estrlit id, pos, false, + array_t (Word64.fromInt size, char_t)), ctx) + end | Tk (T.CharConst (id, v)) => wrapNum id (int_t, Ninteger v) | Tk (T.Num id) => wrapNum id $ parseNumber pos $ P.?? id | TkParens list => @@ -1860,7 +1876,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; | Eunop (_, _) => checkUnop check under E | EmemberByV _ => checkMemberAccessByV (check UNone) E | EmemberByP _ => checkMemberAccessByP (check UNone) E - | Econst _ | Estrlit _ => E + | Econst _ => E | Estrlit _ => E end and tryGetTypedefName (Ctx ctx) id = @@ -2813,8 +2829,9 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun printIni _ (CiniExpr ea) out = Printf out A1 pea ea % | printIni _ (CiniConst w) out = Printf out W w % - | printIni off (CiniLayout layout) out = + | printIni off (CiniLayout id) out = let + val (_, _, layout) = D.get iniLayouts id fun pentry ({ offset, t, value }) out = Printf out R off `"\t" W offset `": " Pctype t `": " W value `"\n" % @@ -3168,6 +3185,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun canonExprIni toplev t ea = if toplev then let + val () = printf `"Here\n" % val w = eval ea t in CiniConst w @@ -3193,8 +3211,11 @@ functor Parser(structure Tree: TREE; structure P: PPC; let val layout = calcOffsets 0w0 $ LcAux (0w0, computeTLayout t) val seq = flattenIni pos layout ini + + val id = D.length iniLayouts + val () = D.push iniLayouts (toplev, sizeOfType t, seq) in - CiniLayout seq + CiniLayout id end end @@ -3356,15 +3377,11 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (prefix, ctx) = parseDeclPrefix ctx fun finishNormal acc = - let - val acc = rev acc - in if toplev then ObjDefs $ map (fn ToplevId v => v | _ => raise Unreachable) acc else LocalVarInits $ map (fn LocalId v => v | _ => raise Unreachable) - acc - end + (rev acc) fun collectDeclarators acc ctx = let @@ -3812,21 +3829,86 @@ functor Parser(structure Tree: TREE; structure P: PPC; Vector.appi (fn (i, var) => printf A2 pLocalVar i var %) localVars end + type decl = P.tkPos * declClass * ctype * linkage + + fun ctxAddDef ctx def = updateCtx ctx u#defs (fn l => def :: l) % + + type objDef = int * P.tkPos * ctype * cini * linkage + + fun finalize (C as Ctx { globalSyms, ... }) = + let + fun f id (GsDecl (pos, DeclTentative, t, linkage)) acc = + (id, pos, t, CiniLayout (~1), linkage) :: acc + | f _ _ acc = acc + + fun ch (GsDecl (pos, DeclTentative, t, linkage)) = + (GsDecl (pos, DeclDefined, t, linkage)) + | ch v = v + + val promoted = Tree.traverse globalSyms f [] + val globalSyms = Tree.changeV globalSyms ch + in + updateCtx C u#defs (fn l => Objects promoted :: rev l) + s#globalSyms globalSyms % + end + + type progInfo = { + ext: nid list, + glob: nid list, + objsZI: objDef list, + objs: objDef list, + funcs: funcInfo list, + strlits: int list + } + + fun explode (Ctx { globalSyms, defs, strlits, ... }) = + let + fun findExtAndGlob id (GsDecl (_, declType, _, LinkExternal)) + (ext, glob) + = ( + case declType of + DeclRegular => (id :: ext, glob) + | DeclDefined => (ext, id :: glob) + | DeclTentative => raise Unreachable + ) + | findExtAndGlob _ _ acc = acc + + val (ext, glob) = Tree.traverse globalSyms findExtAndGlob ([], []) + val objsZI = + case hd defs of + Objects objs => objs + | _ => raise Unreachable + + fun partition (objs, funcDefs) (Objects obj :: tail) = + partition (List.revAppend (obj, objs), funcDefs) tail + | partition (objs, funcDefs) (Definition fi :: tail) = + partition (objs, fi :: funcDefs) tail + | partition (objs, funcDefs) [] = (rev objs, rev funcDefs) + + val (objs, funcs) = partition ([], []) (tl defs) + in + { ext, glob, objsZI, objs, funcs, strlits } + end + fun parseDef ctx = let val (tk, _, _) = getTokenCtx ctx in case tk of - Tk T.EOS => NONE + Tk T.EOS => (false, ctx) | _ => let - val (toplev, ctx) = parseDeclaration ctx + val (toplev: toplev, ctx) = parseDeclaration ctx in - SOME (case toplev of - ObjDefs objDefList => (Objects objDefList, ctx) + case toplev of + ObjDefs objDefList => (true, ctxAddDef ctx (Objects objDefList)) | FuncDef (id, body) => - ctxWithLayer ctx body (parseFuncDefinition id) - | LocalVarInits _ => raise Unreachable) + let + val (def, ctx) = ctxWithLayer ctx body (parseFuncDefinition id) + in + (true, ctxAddDef ctx def) + end + | LocalVarInits _ => raise Unreachable end end end -- cgit v1.2.3