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

SCM Repository

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

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

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

revision 305, Mon May 31 15:00:06 1999 UTC revision 311, Wed Jun 2 09:08:48 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    
17        type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18        type recomp = GG.group * GP.info -> bool
19    in
20    
21    signature STABILIZE = sig
22    
23        val loadStable :
24            GP.info * (AbsPath.t -> GG.group option) * bool ref ->
25            AbsPath.t -> GG.group option
26    
27        val stabilize :
28            GP.info -> { group: GG.group, anyerrors: bool ref } ->
29            GG.group option
30    end
31    
32      datatype item =  functor StabilizeFn (val bn2statenv : statenvgetter
33          SS of SymbolSet.set                       val recomp: recomp) :> STABILIZE = struct
34        | S of Symbol.symbol  
35        | SI of SmlInfo.info      datatype pitem =
36        | AP of AbsPath.t          PSS of SymbolSet.set
37          | PS of Symbol.symbol
38      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')        | PSN of DG.snode
39        | compare (S _, _) = GREATER        | PAP of AbsPath.t
40        | compare (_, S _) = LESS  
41        | compare (SS s, SS s') = SymbolSet.compare (s, s')      datatype uitem =
42        | compare (SS _, _) = GREATER          USS of SymbolSet.set
43        | compare (_, SS _) = LESS        | US of Symbol.symbol
44        | compare (SI i, SI i') = SmlInfo.compare (i, i')        | UBN of DG.bnode
45        | compare (SI _, _) = GREATER        | UAP of AbsPath.t
46        | compare (_, SI _) = LESS  
47        | compare (AP p, AP p') = AbsPath.compare (p, p')      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
48          | compare (PS _, _) = GREATER
49          | compare (_, PS _) = LESS
50          | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
51          | compare (PSS _, _) = GREATER
52          | compare (_, PSS _) = LESS
53          | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
54            SmlInfo.compare (#smlinfo n, #smlinfo n')
55          | compare (PSN _, _) = GREATER
56          | compare (_, PSN _) = LESS
57          | compare (PAP p, PAP p') = AbsPath.compare (p, p')
58    
59      structure Map =      structure Map =
60          BinaryMapFn (struct          BinaryMapFn (struct
61                           type ord_key = item                           type ord_key = pitem
62                           val compare = compare                           val compare = compare
63          end)          end)
64    
65      fun f (g as GroupGraph.GROUP { exports, ... }, binSizeOf, binCopy) = let      fun genStableInfoMap (exports, group) = let
66            (* find all the exported bnodes that are in the same group: *)
67            fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
68                val i = #bininfo b
69            in
70                if AbsPath.compare (BinInfo.group i, group) = EQUAL then
71                    IntBinaryMap.insert (m, BinInfo.offset i, n)
72                else m
73            end
74              | add (_, m) = m
75        in
76            SymbolMap.foldl add IntBinaryMap.empty exports
77        end
78    
79        fun deleteFile n = OS.FileSys.remove n
80            handle e as Interrupt.Interrupt => raise e
81                 | _ => ()
82    
83        fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
84    
85            fun doit granted = let
86                val bname = AbsPath.name o SmlInfo.binpath
87                val bsz = OS.FileSys.fileSize o bname
88                fun cpb s i = let
89                    val ins = BinIO.openIn (bname i)
90                    fun cp () =
91                        if BinIO.endOfStream ins then ()
92                        else (BinIO.output (s, BinIO.input ins); cp ())
93                in
94                    cp () handle e => (BinIO.closeIn ins; raise e);
95                        BinIO.closeIn ins
96                end
97                val delb = deleteFile o bname
98    
99                val grpSrcInfo = (#errcons gp, anyerrors)
100    
101                val exports = #exports grec
102                val islib = #islib grec
103                val required = StringSet.difference (#required grec, granted)
104                val grouppath = #grouppath grec
105                val subgroups = #subgroups grec
106    
107          (* The format of a stable archive is the following:          (* The format of a stable archive is the following:
108           *  - It starts with the size s of the pickled dependency graph.               *  - It starts with the size s of the pickled dependency
109           *    This size itself is written as four-byte string.               *    graph. This size itself is written as four-byte string.
110           *  - The pickled dependency graph.  This graph contains integer               *  - The pickled dependency graph.  This graph contains
111           *    offsets of the binfiles for the individual ML members.               *    integer offsets of the binfiles for the individual ML
112           *    These offsets need to be adjusted by adding s + 4.               *    members. These offsets need to be adjusted by adding
113           *    The pickled dependency graph also contains integer offsets               *    s + 4. The pickled dependency graph also contains integer
114           *    relative to other stable groups.  These offsets need no               *    offsets relative to other stable groups.  These offsets
115           *    further adjustment.               *    need no further adjustment.
116           *  - Individual binfile contents (concatenated).           *  - Individual binfile contents (concatenated).
117           *)           *)
118          val members = let  
119              fun sn (DG.SNODE { smlinfo = i, localimports = l, ... }, s) =              val members = ref []
120                  if SmlInfoSet.member (s, i) then s              val (registerOffset, getOffset) = let
121                  else foldl sn (SmlInfoSet.add (s, i)) l                  val dict = ref SmlInfoMap.empty
122              fun impexp (((_, DG.SB_BNODE _), _), s) = s                  val cur = ref 0
123                | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)                  fun reg (i, sz) = let
124                        val os = !cur
125          in          in
126              SmlInfoSet.listItems                      cur := os + sz;
127                    (SymbolMap.foldl impexp SmlInfoSet.empty exports)                      dict := SmlInfoMap.insert (!dict, i, os);
128                        members := i :: (!members);
129                        os
130          end          end
131                    fun get i = valOf (SmlInfoMap.find (!dict, i))
         val offsetDict = let  
             fun add (i, (d, n)) =  
                 (SmlInfoMap.insert (d, i, n), n + binSizeOf i)  
132          in          in
133              #1 (foldl add (SmlInfoMap.empty, 0) members)                  (reg, get)
134          end          end
135    
136          fun w_list w_item [] k m = ";" :: k m              fun w_list w_item [] k m =
137            | w_list w_item (h :: t) k m = w_item h (w_list w_item t k) m                  "0" :: k m
138                  | w_list w_item [a] k m =
139                    "1" :: w_item a k m
140                  | w_list w_item [a, b] k m =
141                    "2" :: w_item a (w_item b k) m
142                  | w_list w_item [a, b, c] k m =
143                    "3" :: w_item a (w_item b (w_item c k)) m
144                  | w_list w_item [a, b, c, d] k m =
145                    "4" :: w_item a (w_item b (w_item c (w_item d k))) m
146                  | w_list w_item (a :: b :: c :: d :: e :: r) k m =
147                    "5" :: w_item a (w_item b (w_item c (w_item d (w_item e
148                                                         (w_list w_item r k))))) m
149    
150          fun w_option w_item NONE k m = "n" :: k m          fun w_option w_item NONE k m = "n" :: k m
151            | w_option w_item (SOME i) k m = "s" :: w_item i k m            | w_option w_item (SOME i) k m = "s" :: w_item i k m
152    
153          fun int_encode i = let          fun int_encode i = let
154              (* this is the same mechanism that's also used in              (* this is the same mechanism that's also used in
155               * TopLevel/batch/binfile.sml -- maybe we should share it *)                   * TopLevel/batch/binfile.sml (maybe we should share it) *)
156              val n = Word32.fromInt i              val n = Word32.fromInt i
157              val // = LargeWord.div              val // = LargeWord.div
158              val %% = LargeWord.mod              val %% = LargeWord.mod
# Line 71  Line 160 
160              infix // %% !!              infix // %% !!
161              val toW8 = Word8.fromLargeWord              val toW8 = Word8.fromLargeWord
162              fun r (0w0, l) = Word8Vector.fromList l              fun r (0w0, l) = Word8Vector.fromList l
163                | r (n, l) = r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)                    | r (n, l) =
164                        r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
165          in          in
166              Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))              Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
167          end          end
# Line 81  Line 171 
171          fun w_share w C v k (i, m) =          fun w_share w C v k (i, m) =
172              case Map.find (m, C v) of              case Map.find (m, C v) of
173                  SOME i' => "o" :: w_int i' k (i, m)                  SOME i' => "o" :: w_int i' k (i, m)
174                | NONE => "n" :: w_int i (w v k) (i + 1, Map.insert (m, C v, i))                    | NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
175    
176          fun w_symbol_raw s k m = SkelIO.w_name (s, k m)              fun w_symbol_raw s k m = let
177                    val ns = case Symbol.nameSpace s of
178                        Symbol.SIGspace => "'"
179                      | Symbol.FCTspace => "("
180                      | Symbol.FSIGspace => ")"
181                      | Symbol.STRspace => ""
182                      | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
183                in
184                    ns :: Symbol.name s :: "." :: k m
185                end
186    
187          val w_symbol = w_share w_symbol_raw S              val w_symbol = w_share w_symbol_raw PS
188    
189          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
190    
191          val w_filter = w_option w_ss          val w_filter = w_option w_ss
192    
# Line 95  Line 194 
194              fun esc #"\\" = "\\\\"              fun esc #"\\" = "\\\\"
195                | esc #"\"" = "\\\""                | esc #"\"" = "\\\""
196                | esc c = String.str c                | esc c = String.str c
   
197          in          in
198              String.translate esc s :: "\"" :: k m              String.translate esc s :: "\"" :: k m
199          end          end
# Line 104  Line 202 
202            | w_sharing (SOME true) k m = "t" :: k m            | w_sharing (SOME true) k m = "t" :: k m
203            | w_sharing (SOME false) k m = "f" :: k m            | w_sharing (SOME false) k m = "f" :: k m
204    
205          fun w_si_raw i k = let              fun w_si i k = let
206              val spec = AbsPath.spec (SmlInfo.sourcepath i)              val spec = AbsPath.spec (SmlInfo.sourcepath i)
207              val offset = valOf (SmlInfoMap.find (offsetDict, i))                  val locs = SmlInfo.errorLocation gp i
208                    val offset = registerOffset (i, bsz i)
209          in          in
210              w_string spec (w_int offset (w_sharing (SmlInfo.share i) k))                  w_string spec
211                       (w_string locs
212                             (w_int offset
213                                   (w_sharing (SmlInfo.share i) k)))
214          end          end
215    
         val w_si = w_share w_si_raw SI  
   
216          fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m          fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
217    
218          fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m          fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m
219    
220          val w_abspath = w_share w_abspath_raw AP              val w_abspath = w_share w_abspath_raw PAP
   
         fun w_bi i k = w_abspath (BinInfo.group i) (w_int (BinInfo.offset i) k)  
221    
222          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
223            | w_bn (DG.BNODE { bininfo, ... }) k m = "b" :: w_bi bininfo k m                | w_bn (DG.BNODE { bininfo = i, ... }) k m =
224                    "b" :: w_abspath (BinInfo.group i)
225                               (w_int (BinInfo.offset i) k) m
226    
227          fun w_sn (DG.SNODE n) k =              fun w_sn_raw (DG.SNODE n) k =
228              w_si (#smlinfo n)              w_si (#smlinfo n)
229                   (w_list w_sn (#localimports n)                   (w_list w_sn (#localimports n)
230                                (w_list w_fsbn (#globalimports n) k))                                (w_list w_fsbn (#globalimports n) k))
231    
232          and w_sbn (DG.SB_BNODE n) = w_bn n              and w_sn n = w_share w_sn_raw PSN n
233            | w_sbn (DG.SB_SNODE n) = GenericVC.ErrorMsg.impossible  
234              "stabilize: non-stabilized subgroup? (2)"              and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
235                  | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
236    
237          and w_fsbn (f, n) k = w_filter f (w_sbn n k)          and w_fsbn (f, n) k = w_filter f (w_sbn n k)
238    
# Line 144  Line 245 
245    
246          fun w_privileges p = w_list w_string (StringSet.listItems p)          fun w_privileges p = w_list w_string (StringSet.listItems p)
247    
248          fun pickle_group (GroupGraph.GROUP g) = let              fun pickle_group () = let
249              val { exports, islib, required, grouppath, subgroups, ... } = g                  fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)
             fun w_sg (GroupGraph.GROUP { grouppath = gp, ... }) = w_abspath gp  
250              fun k0 m = []              fun k0 m = []
251              val m0 = (0, Map.empty)              val m0 = (0, Map.empty)
252          in          in
253              concat                  concat (w_exports exports
               (w_exports exports  
254                     (w_bool islib                     (w_bool islib
255                            (w_privileges required                            (w_privileges required
256                                     (w_abspath grouppath                                            (w_list w_sg subgroups k0))) m0)
                                               (w_list w_sg subgroups k0)))) m0)  
257          end          end
258          val pickle = pickle_group g  
259                val pickle = pickle_group ()
260          val sz = size pickle          val sz = size pickle
261                val offset_adjustment = sz + 4
262    
263                fun mkStableGroup () = let
264                    val m = ref SmlInfoMap.empty
265                    fun sn (DG.SNODE (n as { smlinfo, ... })) =
266                        case SmlInfoMap.find (!m, smlinfo) of
267                            SOME n => n
268                          | NONE => let
269                                val li = map sn (#localimports n)
270                                val gi = map fsbn (#globalimports n)
271                                val sourcepath = SmlInfo.sourcepath smlinfo
272                                val spec = AbsPath.spec sourcepath
273                                val offset =
274                                    getOffset smlinfo + offset_adjustment
275                                val share = SmlInfo.share smlinfo
276                                val locs = SmlInfo.errorLocation gp smlinfo
277                                val error = EM.errorNoSource grpSrcInfo locs
278                                val i = BinInfo.new { group = grouppath,
279                                                      spec = spec,
280                                                      offset = offset,
281                                                      share = share,
282                                                      error = error }
283                                val n = DG.BNODE { bininfo = i,
284                                                   localimports = li,
285                                                   globalimports = gi }
286                            in
287                                m := SmlInfoMap.insert (!m, smlinfo, n);
288                                n
289                            end
290    
291                    and sbn (DG.SB_SNODE n) = sn n
292                      | sbn (DG.SB_BNODE n) = n
293    
294                    and fsbn (f, n) = (f, sbn n)
295    
296                    fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
297    
298                    val exports = SymbolMap.map impexp (#exports grec)
299                    val simap = genStableInfoMap (exports, grouppath)
300                in
301                    GG.GROUP { exports = exports,
302                               islib = islib,
303                               required = required,
304                               grouppath = grouppath,
305                               subgroups = subgroups,
306                               stableinfo = GG.STABLE simap }
307                end
308    
309                fun writeInt32 (s, i) = let
310                    val a = Word8Array.array (4, 0w0)
311                    val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
312                in
313                    BinIO.output (s, Word8Array.extract (a, 0, NONE))
314                end
315                val memberlist = rev (!members)
316    
317                val policy = #fnpolicy (#param gp)
318                val gpath = #grouppath grec
319                val spath = FilenamePolicy.mkStablePath policy gpath
320                fun delete () = deleteFile (AbsPath.name spath)
321                val outs = AbsPath.openBinOut spath
322                fun try () =
323                    (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
324                     writeInt32 (outs, sz);
325                     BinIO.output (outs, Byte.stringToBytes pickle);
326                     app (cpb outs) memberlist;
327                     app delb memberlist;
328                     BinIO.closeOut outs;
329                     SOME (mkStableGroup ()))
330            in
331                Interrupt.guarded try
332                handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
333                                                    delete ();
334                                                    raise e)
335                     | exn => (BinIO.closeOut outs; NONE)
336            end
337        in
338            case #stableinfo grec of
339                GG.STABLE _ => SOME g
340              | GG.NONSTABLE granted =>
341                    if not (recomp (g, gp)) then
342                        (anyerrors := true; NONE)
343                    else let
344                        fun notStable (GG.GROUP { stableinfo, ... }) =
345                            case stableinfo of
346                                GG.STABLE _ => false
347                              | GG.NONSTABLE _ => true
348                    in
349                        case List.filter notStable (#subgroups grec) of
350                            [] => doit granted
351                          | l => let
352                                val grammar = case l of [_] => " is" | _ => "s are"
353                                fun ppb pps = let
354                                    fun loop [] = ()
355                                      | loop (GG.GROUP { grouppath, ... } :: t) =
356                                        (PP.add_string pps
357                                            (AbsPath.name grouppath);
358                                         PP.add_newline pps;
359                                         loop t)
360                                in
361                                    PP.add_newline pps;
362                                    PP.add_string pps
363                                        (concat ["because the following sub-group",
364                                                 grammar, " not stable:"]);
365                                    PP.add_newline pps;
366                                    loop l
367                                end
368                                val errcons = #errcons gp
369                                val gname = AbsPath.name (#grouppath grec)
370                            in
371                                EM.errorNoFile (errcons, anyerrors) SM.nullRegion
372                                   EM.COMPLAIN
373                                   (gname ^ " cannot be stabilized")
374                                   ppb;
375                                NONE
376                            end
377                    end
378        end
379    
380        fun loadStable (gp, getGroup, anyerrors) group = let
381    
382            fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
383    
384            val errcons = #errcons gp
385            val grpSrcInfo = (errcons, anyerrors)
386            val gname = AbsPath.name group
387            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
388                EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
389    
390            exception Format
391    
392            val policy = #fnpolicy (#param gp)
393            val spath = FilenamePolicy.mkStablePath policy group
394            val _ = Say.vsay ["[checking stable ", gname, "]\n"]
395            val s = AbsPath.openBinIn spath
396    
397            fun getGroup' p =
398                case getGroup p of
399                    SOME g => g
400                  | NONE =>
401                        (error ["unable to find ", AbsPath.name p];
402                         raise Format)
403    
404            (* for getting sharing right... *)
405            val m = ref IntBinaryMap.empty
406            val next = ref 0
407    
408            fun bytesIn n = let
409                val bv = BinIO.inputN (s, n)
410      in      in
411          ()              if n = Word8Vector.length bv then bv
412                else raise Format
413      end      end
414    
415            val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
416            val pickle = bytesIn sz
417            val offset_adjustment = sz + 4
418    
419            val rd = let
420                val pos = ref 0
421                fun rd () = let
422                    val p = !pos
423                in
424                    pos := p + 1;
425                    Byte.byteToChar (Word8Vector.sub (pickle, p))
426                    handle _ => raise Format
427  end  end
428            in
429                rd
430            end
431    
432            fun r_list r () =
433                case rd () of
434                    #"0" => []
435                  | #"1" => [r ()]
436                  | #"2" => [r (), r ()]
437                  | #"3" => [r (), r (), r ()]
438                  | #"4" => [r (), r (), r (), r ()]
439                  | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
440                  | _ => raise Format
441    
442            fun r_bool () =
443                case rd () of
444                    #"t" => true
445                  | #"f" => false
446                  | _ => raise Format
447    
448            fun r_option r_item () =
449                case rd () of
450                    #"n" => NONE
451                  | #"s" => SOME (r_item ())
452                  | _ => raise Format
453    
454            fun r_int () = let
455                fun loop n = let
456                    val w8 = Byte.charToByte (rd ())
457                    val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
458                in
459                    if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
460                end
461            in
462                LargeWord.toIntX (loop 0w0)
463            end
464    
465            fun r_share r_raw C unC () =
466                case rd () of
467                    #"o" => (case IntBinaryMap.find (!m, r_int ()) of
468                                 SOME x => unC x
469                               | NONE => raise Format)
470                  | #"n" => let
471                        val i = !next
472                        val _ = next := i + 1
473                        val v = r_raw ()
474                    in
475                        m := IntBinaryMap.insert (!m, i, C v);
476                        v
477                    end
478                  | _ => raise Format
479    
480            fun r_string () = let
481                fun loop l =
482                    case rd () of
483                        #"\"" => String.implode (rev l)
484                      | #"\\" => loop (rd () :: l)
485                      | c => loop (c :: l)
486            in
487                loop []
488            end
489    
490            val r_abspath = let
491                fun r_abspath_raw () =
492                    case AbsPath.unpickle (r_list r_string ()) of
493                        SOME p => p
494                      | NONE => raise Format
495                fun unUAP (UAP x) = x
496                  | unUAP _ = raise Format
497            in
498                r_share r_abspath_raw UAP unUAP
499            end
500    
501            val r_symbol = let
502                fun r_symbol_raw () = let
503                    val (ns, first) =
504                        case rd () of
505                            #"`" => (Symbol.sigSymbol, rd ())
506                          | #"(" => (Symbol.fctSymbol, rd ())
507                          | #")" => (Symbol.fsigSymbol, rd ())
508                          | c => (Symbol.strSymbol, c)
509                    fun loop (#".", l) = String.implode (rev l)
510                      | loop (c, l) = loop (rd (), c :: l)
511                in
512                    ns (loop (first, []))
513                end
514                fun unUS (US x) = x
515                  | unUS _ = raise Format
516            in
517                r_share r_symbol_raw US unUS
518            end
519    
520            val r_ss = let
521                fun r_ss_raw () =
522                    SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
523                fun unUSS (USS s) = s
524                  | unUSS _ = raise Format
525            in
526                r_share r_ss_raw USS unUSS
527            end
528    
529            val r_filter = r_option r_ss
530    
531            fun r_primitive () =
532                case Primitive.fromIdent (rd ()) of
533                    NONE => raise Format
534                  | SOME p => p
535    
536            fun r_sharing () =
537                case rd () of
538                    #"n" => NONE
539                  | #"t" => SOME true
540                  | #"f" => SOME false
541                  | _ => raise Format
542    
543            fun r_si () = let
544                val spec = r_string ()
545                val locs = r_string ()
546                val offset = r_int () + offset_adjustment
547                val share = r_sharing ()
548                val error = EM.errorNoSource grpSrcInfo locs
549            in
550                BinInfo.new { group = group,
551                              error = error,
552                              spec = spec,
553                              offset = offset,
554                              share = share }
555            end
556    
557            fun r_bn () =
558                case rd () of
559                    #"p" => DG.PNODE (r_primitive ())
560                  | #"b" => let
561                        val p = r_abspath ()
562                        val os = r_int ()
563                    in
564                        case getGroup' p of
565                            GG.GROUP { stableinfo = GG.STABLE im, ... } =>
566                                (case IntBinaryMap.find (im, os) of
567                                     NONE => raise Format
568                                   | SOME n => n)
569                          | _ => raise Format
570                    end
571                  | _ => raise Format
572    
573            (* this is the place where what used to be an
574             * SNODE changes to a BNODE! *)
575            fun r_sn_raw () =
576                DG.BNODE { bininfo = r_si (),
577                           localimports = r_list r_sn (),
578                           globalimports = r_list r_fsbn () }
579    
580            and r_sn () =
581                r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
582    
583            (* this one changes from farsbnode to plain farbnode *)
584            and r_sbn () =
585                case rd () of
586                    #"b" => r_bn ()
587                  | #"s" => r_sn ()
588                  | _ => raise Format
589    
590            and r_fsbn () = (r_filter (), r_sbn ())
591    
592            fun r_impexp () = let
593                val sy = r_symbol ()
594                val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
595                val e = bn2env n
596                (* put a filter in front to avoid having the FCTENV being
597                 * queried needlessly (this avoids spurious module loadings) *)
598                val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
599            in
600                (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
601            end
602    
603            fun r_exports () =
604                foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
605    
606            fun r_privileges () =
607                StringSet.addList (StringSet.empty, r_list r_string ())
608    
609            fun unpickle_group () = let
610                val exports = r_exports ()
611                val islib = r_bool ()
612                val required = r_privileges ()
613                val subgroups = r_list (getGroup' o r_abspath) ()
614                val simap = genStableInfoMap (exports, group)
615            in
616                GG.GROUP { exports = exports,
617                           islib = islib,
618                           required = required,
619                           grouppath = group,
620                           subgroups = subgroups,
621                           stableinfo = GG.STABLE simap }
622                before BinIO.closeIn s
623            end
624        in
625            SOME (unpickle_group ())
626            handle Format => (BinIO.closeIn s; NONE)
627                 | exn => (BinIO.closeIn s; raise exn)
628        end handle IO.Io _ => NONE
629    end
630    
631    end (* local *)

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

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