Object assembly

1 files changed, 110 insertions, 28 deletions

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