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 306, Tue Jun 1 08:25:21 1999 UTC revision 340, Fri Jun 18 05:32:46 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      structure GG = GroupGraph
11      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
12        structure PP = PrettyPrint
13      datatype item =      structure SM = GenericVC.SourceMap
14          SS of SymbolSet.set      structure GP = GeneralParams
15        | S of Symbol.symbol      structure E = GenericVC.Environment
16        | SI of SmlInfo.info              (* only used during pickling *)  
17        | AP of AbsPath.t      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18        | BI of BinInfo.info              (* only used during unpickling *)      type recomp = GP.info -> GG.group -> bool
19    in
20      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')  
21        | compare (S _, _) = GREATER  signature STABILIZE = sig
22        | compare (_, S _) = LESS  
23        | compare (SS s, SS s') = SymbolSet.compare (s, s')      val loadStable :
24        | compare (SS _, _) = GREATER          GP.info * (AbsPath.t -> GG.group option) * bool ref ->
25        | compare (_, SS _) = LESS          AbsPath.t -> GG.group option
26        | compare (SI i, SI i') = SmlInfo.compare (i, i')  
27        | compare (SI _, _) = GREATER      val stabilize :
28        | compare (_, SI _) = LESS          GP.info -> { group: GG.group, anyerrors: bool ref } ->
29        | compare (AP p, AP p') = AbsPath.compare (p, p')          GG.group option
30        | compare (AP _, _) = GREATER  end
31        | compare (_, AP _) = LESS  
32        | compare (BI i, BI i') = BinInfo.compare (i, i')  functor StabilizeFn (val bn2statenv : statenvgetter
33                         val recomp: recomp) :> STABILIZE = struct
34    
35        datatype pitem =
36            PSS of SymbolSet.set
37          | PS of Symbol.symbol
38          | PSN of DG.snode
39    
40        datatype uitem =
41            USS of SymbolSet.set
42          | US of Symbol.symbol
43          | UBN of DG.bnode
44    
45        fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
46          | compare (PS _, _) = GREATER
47          | compare (_, PS _) = LESS
48          | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
49          | compare (PSS _, _) = GREATER
50          | compare (_, PSS _) = LESS
51          | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
52            SmlInfo.compare (#smlinfo n, #smlinfo n')
53    
54      structure Map =      structure Map =
55          BinaryMapFn (struct          BinaryMapFn (struct
56                           type ord_key = item                           type ord_key = pitem
57                           val compare = compare                           val compare = compare
58          end)          end)
59    
60      fun stabilize (g as GG.GROUP grec, binSizeOf, binCopy, gp) =      fun genStableInfoMap (exports, group) = let
61          case #stableinfo grec of          (* find all the exported bnodes that are in the same group: *)
62              GG.STABLE _ => g          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
63            | GG.NONSTABLE granted => let              val i = #bininfo b
64            in
65                if AbsPath.compare (BinInfo.group i, group) = EQUAL then
66                    IntBinaryMap.insert (m, BinInfo.offset i, n)
67                else m
68            end
69              | add (_, m) = m
70        in
71            SymbolMap.foldl add IntBinaryMap.empty exports
72        end
73    
74        fun deleteFile n = OS.FileSys.remove n
75            handle e as Interrupt.Interrupt => raise e
76                 | _ => ()
77    
78        fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
79    
80            val primconf = #primconf (#param gp)
81            val policy = #fnpolicy (#param gp)
82    
83            val grouppath = #grouppath grec
84            val groupdir = AbsPath.dir grouppath
85    
86            fun doit granted = let
87    
88                val _ =
89                    if StringSet.isEmpty granted then ()
90                    else
91                        Say.say ("$Stabilize: wrapping the following privileges:\n"
92                                 :: map (fn s => ("  " ^ s ^ "\n"))
93                                        (StringSet.listItems granted))
94    
95                val bname = AbsPath.name o SmlInfo.binpath
96                val bsz = OS.FileSys.fileSize o bname
97                fun cpb s i = let
98                    val ins = BinIO.openIn (bname i)
99                    fun cp () =
100                        if BinIO.endOfStream ins then ()
101                        else (BinIO.output (s, BinIO.input ins); cp ())
102                in
103                    cp () handle e => (BinIO.closeIn ins; raise e);
104                        BinIO.closeIn ins
105                end
106    
107                val grpSrcInfo = (#errcons gp, anyerrors)
108    
109                  val exports = #exports grec                  val exports = #exports grec
110                val islib = #islib grec
111                val required = StringSet.difference (#required grec, granted)
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                   *  - It starts with the size s of the pickled dependency
# Line 49  Line 122 
122                   *    need no further adjustment.                   *    need no further adjustment.
123                   *  - Individual binfile contents (concatenated).                   *  - Individual binfile contents (concatenated).
124                   *)                   *)
                 val members = let  
                     fun sn (DG.SNODE { smlinfo, localimports = l, ... }, s) =  
                               if SmlInfoSet.member (s, smlinfo) then s  
                               else foldl sn (SmlInfoSet.add (s, smlinfo)) l  
                     fun impexp (((_, DG.SB_BNODE _), _), s) = s  
                       | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)  
                 in  
                               SmlInfoSet.listItems  
                               (SymbolMap.foldl impexp SmlInfoSet.empty exports)  
                 end  
125    
126                  val offsetDict = let              (* Here we build a mapping that maps each BNODE to a number
127                      fun add (i, (d, n)) =               * representing the sub-library that it came from and a
128                          (SmlInfoMap.insert (d, i, n), n + binSizeOf i)               * representative symbol that can be used to find the BNODE
129                  in               * within the exports of that library *)
130                      #1 (foldl add (SmlInfoMap.empty, 0) members)              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
131                  end                  StableMap.insert (m, #bininfo n, (i, sy))
132                  | oneB i (_, _, m) = m
133                  fun w_list w_item [] k m = "0" :: k m              fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
134                    | w_list w_item [a] k m = "1" :: w_item a k m                  (SymbolMap.foldli (oneB i) m exports, i + 1)
135                    | w_list w_item [a, b] k m = "2" :: w_item a (w_item b k) m              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
136    
137                val members = ref []
138                val (registerOffset, getOffset) = let
139                    val dict = ref SmlInfoMap.empty
140                    val cur = ref 0
141                    fun reg (i, sz) = let
142                        val os = !cur
143                    in
144                        cur := os + sz;
145                        dict := SmlInfoMap.insert (!dict, i, os);
146                        members := i :: (!members);
147                        os
148                    end
149                    fun get i = valOf (SmlInfoMap.find (!dict, i))
150                in
151                    (reg, get)
152                end
153    
154                fun w_list w_item [] k m =
155                    "0" :: k m
156                  | w_list w_item [a] k m =
157                    "1" :: w_item a k m
158                  | w_list w_item [a, b] k m =
159                    "2" :: w_item a (w_item b k) m
160                    | w_list w_item [a, b, c] k m =                    | w_list w_item [a, b, c] k m =
161                      "3" :: w_item a (w_item b (w_item c k)) m                      "3" :: w_item a (w_item b (w_item c k)) m
162                    | w_list w_item [a, b, c, d] k m =                    | w_list w_item [a, b, c, d] k m =
# Line 115  Line 202 
202                      ns :: Symbol.name s :: "." :: k m                      ns :: Symbol.name s :: "." :: k m
203                  end                  end
204    
205                  val w_symbol = w_share w_symbol_raw S              val w_symbol = w_share w_symbol_raw PS
206    
207                  val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) SS              val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
208    
209                  val w_filter = w_option w_ss                  val w_filter = w_option w_ss
210    
# Line 125  Line 212 
212                      fun esc #"\\" = "\\\\"                      fun esc #"\\" = "\\\\"
213                        | esc #"\"" = "\\\""                        | esc #"\"" = "\\\""
214                        | esc c = String.str c                        | esc c = String.str c
   
215                  in                  in
216                      String.translate esc s :: "\"" :: k m                      String.translate esc s :: "\"" :: k m
217                  end                  end
# Line 134  Line 220 
220                    | w_sharing (SOME true) k m = "t" :: k m                    | w_sharing (SOME true) k m = "t" :: k m
221                    | w_sharing (SOME false) k m = "f" :: k m                    | w_sharing (SOME false) k m = "f" :: k m
222    
223                  fun w_si_raw i k = let              fun w_si i k = let
224                    (* FIXME: this is not a technical flaw, but perhaps one
225                     * that deserves fixing anyway:  If we only look at spec,
226                     * then we are losing information about sub-grouping
227                     * within libraries.  However, the spec in BinInfo.info
228                     * is only used for diagnostics and has no impact on the
229                     * operation of CM itself. *)
230                      val spec = AbsPath.spec (SmlInfo.sourcepath i)                      val spec = AbsPath.spec (SmlInfo.sourcepath i)
231                      val locs = SmlInfo.errorLocation gp i                      val locs = SmlInfo.errorLocation gp i
232                      val offset = valOf (SmlInfoMap.find (offsetDict, i))                  val offset = registerOffset (i, bsz i)
233                  in                  in
234                      w_string spec                      w_string spec
235                          (w_string locs                          (w_string locs
# Line 145  Line 237 
237                                   (w_sharing (SmlInfo.share i) k)))                                   (w_sharing (SmlInfo.share i) k)))
238                  end                  end
239    
240                  val w_si = w_share w_si_raw SI              fun w_primitive p k m =
241                    String.str (Primitive.toIdent primconf p) :: k m
242    
243                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m              fun warn_relabs p abs = let
244                    val relabs = if abs then "absolute" else "relative"
245                  fun w_abspath_raw p k m =                  fun ppb pps =
246                      w_list w_string (AbsPath.pickle p) k m                      (PP.add_newline pps;
247                         PP.add_string pps (AbsPath.name p);
248                  val w_abspath = w_share w_abspath_raw AP                       PP.add_newline pps;
249                         PP.add_string pps
250        "(This means that in order to be able to use the result of stabilization";
251                         PP.add_newline pps;
252                         PP.add_string pps "the library must be in the same ";
253                         PP.add_string pps relabs;
254                         PP.add_string pps " location as it is now.)";
255                         PP.add_newline pps)
256                in
257                    EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
258                        EM.WARN
259                        (concat [AbsPath.name grouppath,
260                                 ": library referred to by ", relabs,
261                                 " pathname:"])
262                        ppb
263                end
264    
265                fun w_abspath p k m =
266                    w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))
267                                    k m
268    
269                  fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m                  fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
270                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let
271                      "b" :: w_abspath (BinInfo.group i)                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
272                                (w_int (BinInfo.offset i) k) m                  in
273                        "b" :: w_int n (w_symbol sy k) m
274                    end
275    
276                  fun w_sn (DG.SNODE n) k =              fun w_sn_raw (DG.SNODE n) k =
277                      w_si (#smlinfo n)                      w_si (#smlinfo n)
278                          (w_list w_sn (#localimports n)                          (w_list w_sn (#localimports n)
279                                (w_list w_fsbn (#globalimports n) k))                                (w_list w_fsbn (#globalimports n) k))
280    
281                and w_sn n = w_share w_sn_raw PSN n
282    
283                  and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m                  and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
284                    | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m                    | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
285    
# Line 178  Line 294 
294    
295                  fun w_privileges p = w_list w_string (StringSet.listItems p)                  fun w_privileges p = w_list w_string (StringSet.listItems p)
296    
297                  fun pickle_group (GG.GROUP g, granted) = let              fun pickle_group () = let
298                      fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)                  fun w_sg (p, _) = w_abspath p
                     val req' = StringSet.difference (#required g, granted)  
299                      fun k0 m = []                      fun k0 m = []
300                      val m0 = (0, Map.empty)                      val m0 = (0, Map.empty)
301                  in                  in
302                      concat                  (* Pickle the sublibs first because we need to already
303                         (w_exports (#exports g)                   * have them back when we unpickle BNODEs. *)
304                            (w_bool (#islib g)                  concat (w_list w_sg sublibs
305                                (w_privileges req'                              (w_exports exports
306                                     (w_abspath (#grouppath g)                                  (w_bool islib
307                                           (w_list w_sg (#subgroups g) k0)))) m0)                                      (w_privileges required k0))) m0)
308                  end                  end
309                  val pickle = pickle_group (g, granted)  
310                val pickle = pickle_group ()
311                  val sz = size pickle                  val sz = size pickle
312                val offset_adjustment = sz + 4
313    
314                fun mkStableGroup spath = let
315                    val m = ref SmlInfoMap.empty
316                    fun sn (DG.SNODE (n as { smlinfo, ... })) =
317                        case SmlInfoMap.find (!m, smlinfo) of
318                            SOME n => n
319                          | NONE => let
320                                val li = map sn (#localimports n)
321                                val gi = map fsbn (#globalimports n)
322                                val sourcepath = SmlInfo.sourcepath smlinfo
323                                (* FIXME: see the comment near the other
324                                 * occurence of AbsPath.spec... *)
325                                val spec = AbsPath.spec sourcepath
326                                val offset =
327                                    getOffset smlinfo + offset_adjustment
328                                val share = SmlInfo.share smlinfo
329                                val locs = SmlInfo.errorLocation gp smlinfo
330                                val error = EM.errorNoSource grpSrcInfo locs
331                                val i = BinInfo.new { group = grouppath,
332                                                      stablepath = spath,
333                                                      spec = spec,
334                                                      offset = offset,
335                                                      share = share,
336                                                      error = error }
337                                val n = DG.BNODE { bininfo = i,
338                                                   localimports = li,
339                                                   globalimports = gi }
340              in              in
341                  Dummy.f ()                              m := SmlInfoMap.insert (!m, smlinfo, n);
342                                n
343              end              end
344    
345      fun g (getGroup, fsbn2env, knownStable, grpSrcInfo, group, s) = let                  and sbn (DG.SB_SNODE n) = sn n
346                      | sbn (DG.SB_BNODE n) = n
347    
348                    and fsbn (f, n) = (f, sbn n)
349    
350                    fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
351    
352                    val exports = SymbolMap.map impexp (#exports grec)
353                    val simap = genStableInfoMap (exports, grouppath)
354                in
355                    GG.GROUP { exports = exports,
356                               islib = islib,
357                               required = required,
358                               grouppath = grouppath,
359                               sublibs = sublibs,
360                               stableinfo = GG.STABLE simap }
361                end
362    
363                fun writeInt32 (s, i) = let
364                    val a = Word8Array.array (4, 0w0)
365                    val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
366                in
367                    BinIO.output (s, Word8Array.extract (a, 0, NONE))
368                end
369                val memberlist = rev (!members)
370    
371                val gpath = #grouppath grec
372                val spath = FilenamePolicy.mkStablePath policy gpath
373                fun delete () = deleteFile (AbsPath.name spath)
374                val outs = AbsPath.openBinOut spath
375                fun try () =
376                    (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
377                     writeInt32 (outs, sz);
378                     BinIO.output (outs, Byte.stringToBytes pickle);
379                     app (cpb outs) memberlist;
380                     BinIO.closeOut outs;
381                     SOME (mkStableGroup spath))
382            in
383                Interrupt.guarded try
384                handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
385                                                    delete ();
386                                                    raise e)
387                     | exn => (BinIO.closeOut outs; NONE)
388            end
389        in
390            case #stableinfo grec of
391                GG.STABLE _ => SOME g
392              | GG.NONSTABLE granted =>
393                    if not (recomp gp g) then
394                        (anyerrors := true; NONE)
395                    else let
396                        fun notStable (_, GG.GROUP { stableinfo, ... }) =
397                            case stableinfo of
398                                GG.STABLE _ => false
399                              | GG.NONSTABLE _ => true
400                    in
401                        case List.filter notStable (#sublibs grec) of
402                            [] => doit granted
403                          | l => let
404                                val grammar = case l of [_] => " is" | _ => "s are"
405                                fun ppb pps = let
406                                    fun loop [] = ()
407                                      | loop ((p, GG.GROUP { grouppath, ... })
408                                              :: t) =
409                                        (PP.add_string pps
410                                            (AbsPath.name grouppath);
411                                         PP.add_string pps " (";
412                                         PP.add_string pps (AbsPath.name p);
413                                         PP.add_string pps ")";
414                                         PP.add_newline pps;
415                                         loop t)
416                                in
417                                    PP.add_newline pps;
418                                    PP.add_string pps
419                                        (concat ["because the following sub-group",
420                                                 grammar, " not stable:"]);
421                                    PP.add_newline pps;
422                                    loop l
423                                end
424                                val errcons = #errcons gp
425                                val gname = AbsPath.name (#grouppath grec)
426                            in
427                                EM.errorNoFile (errcons, anyerrors) SM.nullRegion
428                                   EM.COMPLAIN
429                                   (gname ^ " cannot be stabilized")
430                                   ppb;
431                                NONE
432                            end
433                    end
434        end
435    
436        fun loadStable (gp, getGroup, anyerrors) group = let
437    
438            val groupdir = AbsPath.dir group
439            fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
440    
441            val errcons = #errcons gp
442            val grpSrcInfo = (errcons, anyerrors)
443            val gname = AbsPath.name group
444            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
445                EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
446    
447          exception Format          exception Format
448    
449            val pcmode = #pcmode (#param gp)
450            val policy = #fnpolicy (#param gp)
451            val primconf = #primconf (#param gp)
452            val spath = FilenamePolicy.mkStablePath policy group
453            val _ = Say.vsay ["[checking stable ", gname, "]\n"]
454            val s = AbsPath.openBinIn spath
455    
456            fun getGroup' p =
457                case getGroup p of
458                    SOME g => g
459                  | NONE =>
460                        (error ["unable to find ", AbsPath.name p];
461                         raise Format)
462    
463          (* for getting sharing right... *)          (* for getting sharing right... *)
464          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty
465          val next = ref 0          val next = ref 0
466    
         (* to build the stable info *)  
         val simap = ref IntBinaryMap.empty  
   
467          fun bytesIn n = let          fun bytesIn n = let
468              val bv = BinIO.inputN (s, n)              val bv = BinIO.inputN (s, n)
469          in          in
# Line 290  Line 546 
546              loop []              loop []
547          end          end
548    
549          val r_abspath = let          fun r_abspath () =
550              fun r_abspath_raw () =              case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of
                 case AbsPath.unpickle (r_list r_string ()) of  
551                      SOME p => p                      SOME p => p
552                    | NONE => raise Format                    | NONE => raise Format
             fun unAP (AP x) = x  
               | unAP _ = raise Format  
         in  
             r_share r_abspath_raw AP unAP  
         end  
553    
554          val r_symbol = let          val r_symbol = let
555              fun r_symbol_raw () = let              fun r_symbol_raw () = let
# Line 314  Line 564 
564              in              in
565                  ns (loop (first, []))                  ns (loop (first, []))
566              end              end
567              fun unS (S x) = x              fun unUS (US x) = x
568                | unS _ = raise Format                | unUS _ = raise Format
569          in          in
570              r_share r_symbol_raw S unS              r_share r_symbol_raw US unUS
571          end          end
572    
573          val r_ss = let          val r_ss = let
574              fun r_ss_raw () =              fun r_ss_raw () =
575                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
576              fun unSS (SS s) = s              fun unUSS (USS s) = s
577                | unSS _ = raise Format                | unUSS _ = raise Format
578          in          in
579              r_share r_ss_raw SS unSS              r_share r_ss_raw USS unUSS
580          end          end
581    
582          val r_filter = r_option r_ss          val r_filter = r_option r_ss
583    
584          fun r_primitive () =          fun r_primitive () =
585              case Primitive.fromIdent (rd ()) of              case Primitive.fromIdent primconf (rd ()) of
586                  NONE => raise Format                  NONE => raise Format
587                | SOME p => p                | SOME p => p
588    
# Line 343  Line 593 
593                | #"f" => SOME false                | #"f" => SOME false
594                | _ => raise Format                | _ => raise Format
595    
596          val r_si = let          fun r_si () = let
             fun r_si_raw () = let  
597                  val spec = r_string ()                  val spec = r_string ()
598                  val locs = r_string ()                  val locs = r_string ()
599                  val offset = r_int () + offset_adjustment                  val offset = r_int () + offset_adjustment
600                  val share = r_sharing ()                  val share = r_sharing ()
601                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
602                  val i = BinInfo.new { group = group,          in
603                BinInfo.new { group = group,
604                              stablepath = spath,
605                                        error = error,                                        error = error,
606                                        spec = spec,                                        spec = spec,
607                                        offset = offset,                                        offset = offset,
608                                        share = share }                                        share = share }
             in  
                 simap := IntBinaryMap.insert (!simap, offset, i);  
                 i  
609              end              end
610              fun unBI (BI i) = i  
611                | unBI _ = raise Format          fun r_sg () = let
612                val p = r_abspath ()
613          in          in
614              r_share r_si_raw BI unBI              (p, getGroup' p)
615          end          end
616    
617            fun unpickle_group () = let
618    
619                val sublibs = r_list r_sg ()
620    
621          fun r_bn () =          fun r_bn () =
622              case rd () of              case rd () of
623                  #"p" => DG.PNODE (r_primitive ())                  #"p" => DG.PNODE (r_primitive ())
624                | #"b" =>                    | #"b" => let
625                      (case AbsPathMap.find (knownStable, r_abspath ()) of                          val n = r_int ()
626                           NONE => raise Format                          val sy = r_symbol ()
627                         | SOME im =>                          val (_, GG.GROUP { exports = slexp, ... }) =
628                               (case IntBinaryMap.find (im, r_int ()) of                              List.nth (sublibs, n) handle _ => raise Format
629                                    NONE => raise Format                      in
630                                  | SOME n => n))                          case SymbolMap.find (slexp, sy) of
631                                SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
632                              | _ => raise Format
633                        end
634                | _ => raise Format                | _ => raise Format
635    
636          (* this is the place where what used to be an          (* this is the place where what used to be an
637           * SNODE changes to a BNODE! *)           * SNODE changes to a BNODE! *)
638          fun r_sn () =              fun r_sn_raw () =
639              DG.BNODE { bininfo = r_si (),              DG.BNODE { bininfo = r_si (),
640                         localimports = r_list r_sn (),                         localimports = r_list r_sn (),
641                         globalimports = r_list r_fsbn () }                         globalimports = r_list r_fsbn () }
642    
643                and r_sn () =
644                    r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
645    
646          (* this one changes from farsbnode to plain farbnode *)          (* this one changes from farsbnode to plain farbnode *)
647          and r_sbn () =          and r_sbn () =
648              case rd () of              case rd () of
# Line 396  Line 655 
655          fun r_impexp () = let          fun r_impexp () = let
656              val sy = r_symbol ()              val sy = r_symbol ()
657              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
658              val e = fsbn2env n                  val e = bn2env n
659                    (* put a filter in front to avoid having the FCTENV being
660                     * queried needlessly (this avoids spurious module loadings) *)
661                    val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
662          in          in
663              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
664          end          end
665    
666          fun r_exports () =          fun r_exports () =
# Line 407  Line 669 
669          fun r_privileges () =          fun r_privileges () =
670              StringSet.addList (StringSet.empty, r_list r_string ())              StringSet.addList (StringSet.empty, r_list r_string ())
671    
         fun unpickle_group () = let  
672              val exports = r_exports ()              val exports = r_exports ()
673              val islib = r_bool ()              val islib = r_bool ()
674              val required = r_privileges ()              val required = r_privileges ()
675              val grouppath = r_abspath ()              val simap = genStableInfoMap (exports, group)
             val subgroups = r_list (getGroup o r_abspath) ()  
             fun add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), s) =  
                 IntBinarySet.add (s, BinInfo.offset bininfo)  
               | add (_, s) = s  
             val ens = SymbolMap.foldl add IntBinarySet.empty exports  
             fun isExported (os, _) = IntBinarySet.member (ens, os)  
             val final_simap = IntBinaryMap.filteri isExported (!simap)  
676          in          in
677              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
678                         islib = islib,                         islib = islib,
679                         required = required,                         required = required,
680                         grouppath = grouppath,                         grouppath = group,
681                         subgroups = subgroups,                         sublibs = sublibs,
682                         stableinfo = GG.STABLE final_simap }                         stableinfo = GG.STABLE simap }
683                before BinIO.closeIn s
684          end          end
685      in      in
686          SOME (unpickle_group ()) handle Format => NONE          SOME (unpickle_group ())
687      end          handle Format => (BinIO.closeIn s; NONE)
688                 | exn => (BinIO.closeIn s; raise exn)
689        end handle IO.Io _ => NONE
690  end  end
691    
692    end (* local *)

Legend:
Removed from v.306  
changed lines
  Added in v.340

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