Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/stable/stabilize.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/stable/stabilize.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 305, Mon May 31 15:00:06 1999 UTC revision 403, Tue Aug 31 07:44:29 1999 UTC
# Line 1  Line 1 
1  structure Stablize = struct  (*
2     * Reading, generating, and writing stable groups.
3     *
4     * (C) 1999 Lucent Technologies, Bell Laboratories
5     *
6     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7     *)
8    local
9      structure DG = DependencyGraph      structure DG = DependencyGraph
10        structure GG = GroupGraph
11        structure EM = GenericVC.ErrorMsg
12        structure PP = PrettyPrint
13        structure SM = GenericVC.SourceMap
14        structure GP = GeneralParams
15        structure E = GenericVC.Environment
16        structure Pid = GenericVC.PersStamps
17        structure P = PickMod
18        structure UP = UnpickMod
19        structure E = GenericVC.Environment
20    in
21    
22    signature STABILIZE = sig
23    
24      datatype item =      val loadStable :
25          SS of SymbolSet.set          GP.info -> { getGroup: SrcPath.t -> GG.group option,
26        | S of Symbol.symbol                       anyerrors: bool ref }
27        | SI of SmlInfo.info          -> SrcPath.t -> GG.group option
28        | AP of AbsPath.t  
29        val stabilize :
30      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')          GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
31        | compare (S _, _) = GREATER  end
32        | compare (_, S _) = LESS  
33        | compare (SS s, SS s') = SymbolSet.compare (s, s')  functor StabilizeFn (val destroy_state : GP.info -> SmlInfo.info -> unit
34        | compare (SS _, _) = GREATER                       structure MachDepVC : MACHDEP_VC
35        | compare (_, SS _) = LESS                       val recomp : GP.info -> GG.group ->
36        | compare (SI i, SI i') = SmlInfo.compare (i, i')                           (SmlInfo.info -> MachDepVC.Binfile.bfContent) option
37        | compare (SI _, _) = GREATER                       val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =
38        | compare (_, SI _) = LESS  struct
39        | compare (AP p, AP p') = AbsPath.compare (p, p')  
40        structure BF = MachDepVC.Binfile
41      structure Map =  
42          BinaryMapFn (struct      structure SSMap = BinaryMapFn
43                           type ord_key = item          (struct
44                           val compare = compare               type ord_key = SymbolSet.set
45                 val compare = SymbolSet.compare
46          end)          end)
47    
48      fun f (g as GroupGraph.GROUP { exports, ... }, binSizeOf, binCopy) = let      structure SNMap = BinaryMapFn
49            (struct
50                 type ord_key = DG.snode
51                 fun compare (DG.SNODE n, DG.SNODE n') =
52                     SmlInfo.compare (#smlinfo n, #smlinfo n')
53            end)
54    
55        structure PU = PickleUtil
56        structure UU = UnpickleUtil
57    
58        type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
59    
60        val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
61    
62        val lifter =
63            { extract = fn (m: map) => #pm m,
64              patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
65    
66        infix 3 $
67        infixr 4 &
68        val op & = PU.&
69        val % = PU.%
70    
71        (* type info *)
72        val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
73    
74        val SSs =
75            { find = fn (m: map, k) => SSMap.find (#ss m, k),
76              insert = fn ({ ss, sn, pm }, k, v) =>
77                           { sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
78        val SNs =
79            { find = fn (m: map, k) => SNMap.find (#sn m, k),
80              insert = fn ({ ss, sn, pm }, k, v) =>
81                           { ss = ss, sn = SNMap.insert (sn, k, v), pm = pm } }
82    
83        fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
84    
85            val primconf = #primconf (#param gp)
86            val policy = #fnpolicy (#param gp)
87            val pervasive = #pervasive (#param gp)
88    
89            val grouppath = #grouppath grec
90    
91            fun doit (wrapped, getBFC) = let
92    
93                fun writeBFC s i = BF.write { stream = s,
94                                              content = getBFC i,
95                                              nopickle = true }
96                fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }
97    
98                val _ =
99                    Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
100    
101                val _ =
102                    if StringSet.isEmpty wrapped then ()
103                    else
104                        Say.say ("$Stabilize: wrapping the following privileges:\n"
105                                 :: map (fn s => ("  " ^ s ^ "\n"))
106                                        (StringSet.listItems wrapped))
107    
108                val grpSrcInfo = (#errcons gp, anyerrors)
109    
110                val exports = #exports grec
111                val required = StringSet.difference (#required grec, wrapped)
112                val sublibs = #sublibs grec
113    
114          (* The format of a stable archive is the following:          (* The format of a stable archive is the following:
115           *  - It starts with the size s of the pickled dependency graph.               *  - It starts with the size s of the pickled dependency
116           *    This size itself is written as four-byte string.               *    graph. This size itself is written as four-byte string.
117           *  - The pickled dependency graph.  This graph contains integer               *  - The size t of the pickled environment for the entire
118           *    offsets of the binfiles for the individual ML members.               *    library (using the pickleEnvN interface of the pickler)
119           *    These offsets need to be adjusted by adding s + 4.               *    in the same format as s.
120           *    The pickled dependency graph also contains integer offsets               *  - The pickled dependency graph.  This graph contains
121           *    relative to other stable groups.  These offsets need no               *    integer offsets of the binfiles for the individual ML
122           *    further adjustment.               *    members. These offsets need to be adjusted by adding
123           *  - Individual binfile contents (concatenated).               *    s + t + 8. The pickled dependency graph also contains integer
124                 *    offsets relative to other stable groups.  These offsets
125                 *    need no further adjustment.
126                 *  - The pickled environment (list).  To be unpickled using
127                 *    unpickleEnvN.
128                 *  - Individual binfile contents (concatenated) but without
129                 *    their static environments.
130           *)           *)
131          val members = let  
132              fun sn (DG.SNODE { smlinfo = i, localimports = l, ... }, s) =              (* Here we build a mapping that maps each BNODE to a number
133                  if SmlInfoSet.member (s, i) then s               * representing the sub-library that it came from and a
134                  else foldl sn (SmlInfoSet.add (s, i)) l               * representative symbol that can be used to find the BNODE
135              fun impexp (((_, DG.SB_BNODE _), _), s) = s               * within the exports of that library *)
136                | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
137                    StableMap.insert (m, #bininfo n, (i, sy))
138                  | oneB i (_, _, m) = m
139                fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
140                    (SymbolMap.foldli (oneB i) m exports, i + 1)
141                val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
142    
143                val members = ref []
144                val (registerOffset, getOffset) = let
145                    val dict = ref SmlInfoMap.empty
146                    val cur = ref 0
147                    fun reg (i, sz) = let
148                        val os = !cur
149                    in
150                        cur := os + sz;
151                        dict := SmlInfoMap.insert (!dict, i, os);
152                        members := i :: (!members);
153                        os
154                    end
155                    fun get i = valOf (SmlInfoMap.find (!dict, i))
156                in
157                    (reg, get)
158                end
159    
160                (* Collect all BNODEs and PNODEs that we see and build
161                 * a context suitable for P.envPickler. *)
162                fun mkContext () = let
163                    fun lst f [] k s = k s
164                      | lst f (h :: t) k s = f h (lst f t k) s
165    
166                    fun sbn n k (s as (prims, bnodes, snodes)) =
167                        case n of
168                            DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let
169                                val str = String.str (Primitive.toIdent primconf p)
170                                val prims' = StringMap.insert (prims, str, statenv)
171                            in
172                                k (prims', bnodes, snodes)
173                            end
174                          | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
175                                val { statenv, ... } = ii
176                                val nsy = valOf (StableMap.find (inverseMap, i))
177                                val bnodes' =
178                                    StableMap.insert (bnodes, i, (nsy, statenv))
179                            in
180                                k (prims, bnodes', snodes)
181                            end
182                          | DG.SB_SNODE n => sn n k s
183    
184                    and sn (DG.SNODE n) k (prims, bnodes, snodes) = let
185                        val i = #smlinfo n
186                        val li = #localimports n
187                        val gi = #globalimports n
188                    in
189                        if SmlInfoSet.member (snodes, i) then
190                            k (prims, bnodes, snodes)
191                        else let
192                            val snodes' = SmlInfoSet.add (snodes, i)
193                        in
194                            lst sn li (lst fsbn gi k) (prims, bnodes, snodes')
195                        end
196                    end
197    
198                    and fsbn (_, n) k s = sbn n k s
199    
200                    fun impexp (n, _) k s = fsbn n k s
201    
202                    val (prims, bnodes) =
203                        lst impexp (SymbolMap.listItems exports)
204                            (fn (prims, bnodes, _) => (prims, bnodes))
205                            (StringMap.empty, StableMap.empty, SmlInfoSet.empty)
206    
207                    val priml = StringMap.listItemsi prims
208                    val bnodel = StableMap.listItems bnodes
209    
210                    fun cvt lk id = let
211                        fun nloop [] = NONE
212                          | nloop ((k, ge) :: t) =
213                            (case lk (ge ()) id of
214                                 SOME _ => SOME (P.NodeKey k)
215                               | NONE => nloop t)
216                        fun ploop [] = nloop bnodel
217                          | ploop ((k, ge) :: t) =
218                            (case lk (ge ()) id of
219                                 SOME _ => SOME (P.PrimKey k)
220                               | NONE => ploop t)
221                    in
222                        case lk (E.staticPart pervasive) id of
223                            NONE => ploop priml
224                          | SOME _ => SOME (P.PrimKey "pv")
225                    end
226                in
227                    { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
228                      lookSIG = cvt GenericVC.CMStaticEnv.lookSIG,
229                      lookFCT = cvt GenericVC.CMStaticEnv.lookFCT,
230                      lookFSIG = cvt GenericVC.CMStaticEnv.lookFSIG,
231                      lookTYC = cvt GenericVC.CMStaticEnv.lookTYC,
232                      lookEENV = cvt GenericVC.CMStaticEnv.lookEENV }
233                end
234    
235                (* make the picklers for static and symbolic environments;
236                 * lift them so we can use them here... *)
237                val envContext = mkContext ()
238    
239                val env_orig = P.envPickler envContext
240                val env = PU.lift_pickler lifter env_orig
241                val symenv_orig = P.symenvPickler
242                val symenv = PU.lift_pickler lifter symenv_orig
243                val lazy_env = PU.w_lazy env
244                val lazy_symenv = PU.w_lazy symenv
245    
246                val int = PU.w_int
247                val symbol = PickleSymPid.w_symbol
248                val pid = PickleSymPid.w_pid
249                val share = PU.ah_share
250                val option = PU.w_option
251                val list = PU.w_list
252                val string = PU.w_string
253                val bool = PU.w_bool
254                val int = PU.w_int
255    
256                fun symbolset ss = let
257                    val op $ = PU.$ SS
258                    fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
259                in
260                    share SSs raw_ss ss
261                end
262    
263                val filter = option symbolset
264    
265                fun shm (Sharing.SHARE true) = %SHM "a"
266                  | shm (Sharing.SHARE false) = %SHM "b"
267                  | shm Sharing.DONTSHARE = %SHM "c"
268    
269                fun si i = let
270                    (* FIXME: this is not a technical flaw, but perhaps one
271                     * that deserves fixing anyway:  If we only look at spec,
272                     * then we are losing information about sub-grouping
273                     * within libraries.  However, the spec in BinInfo.info
274                     * is only used for diagnostics and has no impact on the
275                     * operation of CM itself. *)
276                    val spec = SrcPath.specOf (SmlInfo.sourcepath i)
277                    val locs = SmlInfo.errorLocation gp i
278                    val offset = registerOffset (i, sizeBFC i)
279                    val sh_mode = SmlInfo.sh_mode i
280                    val op $ = PU.$ SI
281                in
282                    "s" $ string spec & string locs & int offset & shm sh_mode
283                end
284    
285                fun primitive p =
286                    string (String.str (Primitive.toIdent primconf p))
287    
288                fun warn_relabs p abs = let
289                    val relabs = if abs then "absolute" else "relative"
290                    fun ppb pps =
291                        (PP.add_newline pps;
292                         PP.add_string pps (SrcPath.descr p);
293                         PP.add_newline pps;
294                         PP.add_string pps
295        "(This means that in order to be able to use the result of stabilization";
296                         PP.add_newline pps;
297                         PP.add_string pps "the library must be in the same ";
298                         PP.add_string pps relabs;
299                         PP.add_string pps " location as it is now.)";
300                         PP.add_newline pps)
301                in
302                    EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
303                        EM.WARN
304                        (concat [SrcPath.descr grouppath,
305                                 ": library referred to by ", relabs,
306                                 " pathname:"])
307                        ppb
308                end
309    
310                fun abspath p = let
311                    val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
312          in          in
313              SmlInfoSet.listItems                  list string pp
                   (SymbolMap.foldl impexp SmlInfoSet.empty exports)  
314          end          end
315    
316          val offsetDict = let              fun sn n = let
317              fun add (i, (d, n)) =                  val op $ = PU.$ SN
318                  (SmlInfoMap.insert (d, i, n), n + binSizeOf i)                  fun raw_sn (DG.SNODE n) =
319                        "a" $ si (#smlinfo n) & list sn (#localimports n) &
320                        list fsbn (#globalimports n)
321          in          in
322              #1 (foldl add (SmlInfoMap.empty, 0) members)                  share SNs raw_sn n
323          end          end
324    
325          fun w_list w_item [] k m = ";" :: k m              (* Here we ignore the interface info because we will not
326            | w_list w_item (h :: t) k m = w_item h (w_list w_item t k) m               * need it anymore when we unpickle. *)
327                and sbn x = let
328                    val op $ = PU.$ SBN
329                in
330                    case x of
331                        DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
332                            "1" $ primitive p
333                      | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
334                            val (n, sy) = valOf (StableMap.find (inverseMap, i))
335                        in
336                            "2" $ int n & symbol sy
337                        end
338                      | DG.SB_SNODE n => "3" $ sn n
339                end
340    
341          fun w_option w_item NONE k m = "n" :: k m              and fsbn (f, n) = let
342            | w_option w_item (SOME i) k m = "s" :: w_item i k m                  val op $ = PU.$ FSBN
343                in
344                    "f" $ filter f & sbn n
345                end
346    
347          fun int_encode i = let              (* Here is the place where we need to write interface info. *)
348              (* this is the same mechanism that's also used in              fun impexp (s, (n, _)) = let
349               * TopLevel/batch/binfile.sml -- maybe we should share it *)                  val op $ = PU.$ IMPEXP
350              val n = Word32.fromInt i                  val { statenv, symenv, statpid, sympid } =
351              val // = LargeWord.div                      case n of
352              val %% = LargeWord.mod                          (_, DG.SB_BNODE (_, ii)) => ii
353              val !! = LargeWord.orb                        | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
354              infix // %% !!                              getII smlinfo
             val toW8 = Word8.fromLargeWord  
             fun r (0w0, l) = Word8Vector.fromList l  
               | r (n, l) = r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)  
355          in          in
356              Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))                  "i" $ symbol s & fsbn n &
357                          lazy_env (GenericVC.CoerceEnv.es2bs o statenv) &
358                          lazy_symenv symenv &
359                          pid statpid &
360                          pid sympid
361          end          end
362    
363          fun w_int i k m = int_encode i :: k m              fun w_exports e = list impexp (SymbolMap.listItemsi e)
364    
365          fun w_share w C v k (i, m) =              fun privileges p = list string (StringSet.listItems p)
             case Map.find (m, C v) of  
                 SOME i' => "o" :: w_int i' k (i, m)  
               | NONE => "n" :: w_int i (w v k) (i + 1, Map.insert (m, C v, i))  
366    
367          fun w_symbol_raw s k m = SkelIO.w_name (s, k m)              fun group () = let
368                    fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
369                in
370                    (* Pickle the sublibs first because we need to already
371                     * have them back when we unpickle BNODEs. *)
372                    list sg sublibs & w_exports exports & privileges required
373                end
374    
375          val w_symbol = w_share w_symbol_raw S              val dg_pickle =
376                    Byte.stringToBytes (PU.pickle emptyMap (group ()))
377    
378          val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) SS              val dg_sz = Word8Vector.length dg_pickle
379    
380          val w_filter = w_option w_ss              val offset_adjustment = dg_sz + 4
381    
382          fun w_string s k m = let              fun mkStableGroup mksname = let
383              fun esc #"\\" = "\\\\"                  val m = ref SmlInfoMap.empty
384                | esc #"\"" = "\\\""                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
385                | esc c = String.str c                      case SmlInfoMap.find (!m, smlinfo) of
386                            SOME n => n
387                          | NONE => let
388                                val li = map sn (#localimports n)
389                                val gi = map fsbn (#globalimports n)
390                                val sourcepath = SmlInfo.sourcepath smlinfo
391                                (* FIXME: see the comment near the other
392                                 * occurence of SrcPath.spec... *)
393                                val spec = SrcPath.specOf sourcepath
394                                val offset =
395                                    getOffset smlinfo + offset_adjustment
396                                val sh_mode = SmlInfo.sh_mode smlinfo
397                                val locs = SmlInfo.errorLocation gp smlinfo
398                                val error = EM.errorNoSource grpSrcInfo locs
399                                val i = BinInfo.new { group = grouppath,
400                                                      mkStablename = mksname,
401                                                      spec = spec,
402                                                      offset = offset,
403                                                      sh_mode = sh_mode,
404                                                      error = error }
405                                val n = DG.BNODE { bininfo = i,
406                                                   localimports = li,
407                                                   globalimports = gi }
408                            in
409                                destroy_state gp smlinfo;
410                                m := SmlInfoMap.insert (!m, smlinfo, n);
411                                n
412                            end
413    
414                    and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
415                        let val ii = getII i
416          in          in
417              String.translate esc s :: "\"" :: k m                          (sn n, ii)
418          end          end
419                      | sbn (DG.SB_BNODE (n, ii)) = (n, ii)
420    
421          fun w_sharing NONE k m = "n" :: k m                  and fsbn (f, n) = (f, #1 (sbn n))
           | w_sharing (SOME true) k m = "t" :: k m  
           | w_sharing (SOME false) k m = "f" :: k m  
422    
423          fun w_si_raw i k = let                  fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
424              val spec = AbsPath.spec (SmlInfo.sourcepath i)  
425              val offset = valOf (SmlInfoMap.find (offsetDict, i))                  val exports = SymbolMap.map impexp (#exports grec)
426          in          in
427              w_string spec (w_int offset (w_sharing (SmlInfo.share i) k))                  GG.GROUP { exports = exports,
428                               kind = GG.STABLELIB,
429                               required = required,
430                               grouppath = grouppath,
431                               sublibs = sublibs }
432          end          end
433    
434          val w_si = w_share w_si_raw SI              fun writeInt32 (s, i) = let
435                    val a = Word8Array.array (4, 0w0)
436                    val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
437                in
438                    BinIO.output (s, Word8Array.extract (a, 0, NONE))
439                end
440                val memberlist = rev (!members)
441    
442          fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m              fun mksname () = FilenamePolicy.mkStableName policy grouppath
443                fun work outs =
444                    (writeInt32 (outs, dg_sz);
445                     BinIO.output (outs, dg_pickle);
446                     app (writeBFC outs) memberlist;
447                     mkStableGroup mksname)
448            in
449                SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
450                                       closeIt = BinIO.closeOut,
451                                       work = work,
452                                       cleanup = fn () =>
453                                        (OS.FileSys.remove (mksname ())
454                                         handle _ => ()) })
455                handle exn => NONE
456            end
457        in
458            case #kind grec of
459                GG.STABLELIB => SOME g
460              | GG.NOLIB => EM.impossible "stabilize: no library"
461              | GG.LIB wrapped =>
462                 (case recomp gp g of
463                      NONE => (anyerrors := true; NONE)
464                    | SOME bfc_acc => let
465                          fun notStable (GG.GROUP { kind, ... }) =
466                              case kind of GG.STABLELIB => false | _ => true
467                      in
468                        case List.filter notStable (#sublibs grec) of
469                            [] => doit (wrapped, bfc_acc)
470                          | l => let
471                                val grammar = case l of [_] => " is" | _ => "s are"
472                                fun ppb pps = let
473                                    fun loop [] = ()
474                                      | loop (GG.GROUP { grouppath, ... } :: t) =
475                                        (PP.add_string pps
476                                            (SrcPath.descr grouppath);
477                                         PP.add_newline pps;
478                                         loop t)
479                                in
480                                    PP.add_newline pps;
481                                    PP.add_string pps
482                                        (concat ["because the following sub-group",
483                                                 grammar, " not stable:"]);
484                                    PP.add_newline pps;
485                                    loop l
486                                end
487                                val errcons = #errcons gp
488                                val gdescr = SrcPath.descr (#grouppath grec)
489                            in
490                                EM.errorNoFile (errcons, anyerrors) SM.nullRegion
491                                   EM.COMPLAIN
492                                   (gdescr ^ " cannot be stabilized")
493                                   ppb;
494                                NONE
495                            end
496                      end)
497        end
498    
499          fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m      fun loadStable gp { getGroup, anyerrors } group = let
500    
501          val w_abspath = w_share w_abspath_raw AP          val errcons = #errcons (gp: GeneralParams.info)
502            val grpSrcInfo = (errcons, anyerrors)
503            val gdescr = SrcPath.descr group
504            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
505                EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
506                EM.nullErrorBody
507    
508            exception Format = UU.Format
509    
510            val pcmode = #pcmode (#param gp)
511            val policy = #fnpolicy (#param gp)
512            val primconf = #primconf (#param gp)
513            val pervasive = #pervasive (#param gp)
514    
515            fun mksname () = FilenamePolicy.mkStableName policy group
516    
517            fun work s = let
518    
519                fun getGroup' p =
520                    case getGroup p of
521                        SOME g => g
522                      | NONE => (error ["unable to find ", SrcPath.descr p];
523                                 raise Format)
524    
525          fun w_bi i k = w_abspath (BinInfo.group i) (w_int (BinInfo.offset i) k)              fun bytesIn n = let
526                    val bv = BinIO.inputN (s, n)
527                in
528                    if n = Word8Vector.length bv then bv
529                    else raise Format
530                end
531    
532          fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
533            | w_bn (DG.BNODE { bininfo, ... }) k m = "b" :: w_bi bininfo k m              val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
534                val offset_adjustment = dg_sz + 4
535                val session = UU.mkSession (UU.stringGetter dg_pickle)
536    
537                fun list m r = UU.r_list session m r
538                val string = UU.r_string session
539                val stringListM = UU.mkMap ()
540                val stringlist = list stringListM string
541    
542                fun abspath () =
543                    SrcPath.unpickle pcmode (stringlist (), group)
544                    handle SrcPath.Format => raise Format
545                         | SrcPath.BadAnchor a =>
546                           (error ["configuration anchor \"", a, "\" undefined"];
547                            raise Format)
548    
549                fun sg () = getGroup' (abspath ())
550                val sgListM = UU.mkMap ()
551                val sublibs = list sgListM sg ()
552    
553                (* Now that we have the list of sublibs, we can build the
554                 * environment for unpickling the environment list.
555                 * We will need the environment list when unpickling the
556                 * export list (making SB_BNODES). *)
557                fun prim_context "pv" = SOME (E.staticPart pervasive)
558                  | prim_context s =
559                    SOME (E.staticPart (Primitive.env primconf
560                                        (valOf (Primitive.fromIdent primconf
561                                                (String.sub (s, 0))))))
562                    handle _ => NONE
563                fun node_context (n, sy) = let
564                    val GG.GROUP { exports = slexp, ... } = List.nth (sublibs, n)
565                in
566                    case SymbolMap.find (slexp, sy) of
567                        SOME ((_, DG.SB_BNODE (_, { statenv = ge, ... })), _) =>
568                            SOME (ge ())
569                      | _ => NONE
570                end handle _ => NONE
571    
572                val { symenv, env, symbol, symbollist } =
573                    UP.mkUnpicklers session
574                        { prim_context = prim_context,
575                          node_context = node_context }
576    
577                val lazy_symenv = UU.r_lazy session symenv
578                val lazy_env = UU.r_lazy session env
579    
580                fun option m r = UU.r_option session m r
581                val int = UU.r_int session
582                fun share m r = UU.share session m r
583                fun nonshare r = UU.nonshare session r
584                val bool = UU.r_bool session
585                val pid = UnpickleSymPid.r_pid string
586    
587                val stringListM = UU.mkMap ()
588                val ssM = UU.mkMap ()
589                val ssoM = UU.mkMap ()
590                val boolOptionM = UU.mkMap ()
591                val siM = UU.mkMap ()
592                val snM = UU.mkMap ()
593                val snListM = UU.mkMap ()
594                val sbnM = UU.mkMap ()
595                val fsbnM = UU.mkMap ()
596                val fsbnListM = UU.mkMap ()
597                val impexpM = UU.mkMap ()
598                val impexpListM = UU.mkMap ()
599    
600                fun symbolset () = let
601                    fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
602                      | s _ = raise Format
603                in
604                    share ssM s
605                end
606    
607                val filter = option ssoM symbolset
608    
609                fun primitive () =
610                    valOf (Primitive.fromIdent primconf
611                              (String.sub (string (), 0)))
612                    handle _ => raise Format
613    
614                fun shm () = let
615                    fun s #"a" = Sharing.SHARE true
616                      | s #"b" = Sharing.SHARE false
617                      | s #"c" = Sharing.DONTSHARE
618                      | s _ = raise Format
619                in
620                    nonshare s
621                end
622    
623                fun si () = let
624                    fun s #"s" =
625                        let val spec = string ()
626                            val locs = string ()
627                            val offset = int () + offset_adjustment
628                            val sh_mode = shm ()
629                            val error = EM.errorNoSource grpSrcInfo locs
630                        in
631                            BinInfo.new { group = group,
632                                          mkStablename = mksname,
633                                          error = error,
634                                          spec = spec,
635                                          offset = offset,
636                                          sh_mode = sh_mode }
637                        end
638                      | s _ = raise Format
639                in
640                    share siM s
641                end
642    
643                (* this is the place where what used to be an
644                 * SNODE changes to a BNODE! *)
645                fun sn () = let
646                    fun sn' #"a" =
647                        DG.BNODE { bininfo = si (),
648                                   localimports = snlist (),
649                                   globalimports = fsbnlist () }
650                      | sn' _ = raise Format
651                in
652                    share snM sn'
653                end
654    
655                and snlist () = list snListM sn ()
656    
657          fun w_sn (DG.SNODE n) k =              (* this one changes from farsbnode to plain farbnode *)
658              w_si (#smlinfo n)              and sbn () = let
659                   (w_list w_sn (#localimports n)                  fun sbn' #"1" = DG.PNODE (primitive ())
660                                (w_list w_fsbn (#globalimports n) k))                    | sbn' #"2" = let
661                            val n = int ()
662                            val sy = symbol ()
663                            val GG.GROUP { exports = slexp, ... } =
664                                List.nth (sublibs, n) handle _ => raise Format
665                        in
666                            case SymbolMap.find (slexp, sy) of
667                                SOME ((_, DG.SB_BNODE (n as DG.BNODE _, _)), _) =>
668                                    n
669                              | _ => raise Format
670                        end
671                      | sbn' #"3" = sn ()
672                      | sbn' _ = raise Format
673                in
674                    share sbnM sbn'
675                end
676    
677                and fsbn () = let
678                    fun f #"f" = (filter (), sbn ())
679                      | f _ = raise Format
680                in
681                    share fsbnM f
682                end
683    
684          and w_sbn (DG.SB_BNODE n) = w_bn n              and fsbnlist () = list fsbnListM fsbn ()
           | w_sbn (DG.SB_SNODE n) = GenericVC.ErrorMsg.impossible  
             "stabilize: non-stabilized subgroup? (2)"  
685    
686          and w_fsbn (f, n) k = w_filter f (w_sbn n k)              fun impexp () = let
687                    fun ie #"i" =
688                        let val sy = symbol ()
689                            val (f, n) = fsbn () (* really reads farbnodes! *)
690                            val ge = lazy_env ()
691                            val ii = { statenv = GenericVC.CoerceEnv.bs2es o ge,
692                                       symenv = lazy_symenv (),
693                                       statpid = pid (),
694                                       sympid = pid () }
695                            val e = Statenv2DAEnv.cvtMemo ge
696                            (* put a filter in front to avoid having the FCTENV
697                             * being queried needlessly (this avoids spurious
698                             * module loadings) *)
699                            val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
700                        in
701                            (sy, ((f, DG.SB_BNODE (n, ii)), e'))
702                        end
703                      | ie _ = raise Format
704                in
705                    share impexpM ie
706                end
707    
708          fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)              val impexplist = list impexpListM impexp
709    
710          fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              fun r_exports () = let
711                    val iel = impexplist ()
712                in
713                    foldl SymbolMap.insert' SymbolMap.empty iel
714                end
715    
716          fun w_bool true k m = "t" :: k m              val stringlist = list stringListM string
           | w_bool false k m = "f" :: k m  
717    
718          fun w_privileges p = w_list w_string (StringSet.listItems p)              fun privileges () =
719                    StringSet.addList (StringSet.empty, stringlist ())
720    
721          fun pickle_group (GroupGraph.GROUP g) = let              val exports = r_exports ()
722              val { exports, islib, required, grouppath, subgroups, ... } = g              val required = privileges ()
             fun w_sg (GroupGraph.GROUP { grouppath = gp, ... }) = w_abspath gp  
             fun k0 m = []  
             val m0 = (0, Map.empty)  
723          in          in
724              concat              GG.GROUP { exports = exports,
725                (w_exports exports                         kind = GG.STABLELIB,
726                     (w_bool islib                         required = required,
727                            (w_privileges required                         grouppath = group,
728                                     (w_abspath grouppath                         sublibs = sublibs }
                                               (w_list w_sg subgroups k0)))) m0)  
729          end          end
         val pickle = pickle_group g  
         val sz = size pickle  
730      in      in
731          ()          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
732                                   closeIt = BinIO.closeIn,
733                                   work = work,
734                                   cleanup = fn () => () })
735            handle Format => (error ["file is corrupted (old version?)"];
736                              NONE)
737                 | IO.Io _ => NONE
738      end      end
739  end  end
740    
741    end (* local *)

Legend:
Removed from v.305  
changed lines
  Added in v.403

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0