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

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

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