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

Legend:
Removed from v.304  
changed lines
  Added in v.398

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