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 360, Tue Jun 29 09:21:02 1999 UTC
# Line 1  Line 1 
1  structure Stablize = struct  (*
2     * Reading, generating, and writing stable groups.
3     *
4     * (C) 1999 Lucent Technologies, Bell Laboratories
5     *
6     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7     *)
8    local
9      structure DG = DependencyGraph      structure DG = DependencyGraph
10        structure GG = GroupGraph
11        structure EM = GenericVC.ErrorMsg
12        structure PP = PrettyPrint
13        structure SM = GenericVC.SourceMap
14        structure GP = GeneralParams
15        structure E = GenericVC.Environment
16        structure Pid = GenericVC.PersStamps
17    
18        type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
19        type recomp = GP.info -> GG.group -> bool
20        type pid = Pid.persstamp
21    in
22    
23    signature STABILIZE = sig
24    
25      datatype item =      val loadStable :
26          SS of SymbolSet.set          GP.info * (SrcPath.t -> GG.group option) * bool ref ->
27        | S of Symbol.symbol          SrcPath.t -> GG.group option
28        | SI of SmlInfo.info  
29        | AP of AbsPath.t      val stabilize :
30            GP.info -> { group: GG.group, anyerrors: bool ref } ->
31      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')          GG.group option
32        | compare (S _, _) = GREATER  end
33        | compare (_, S _) = LESS  
34        | compare (SS s, SS s') = SymbolSet.compare (s, s')  functor StabilizeFn (val bn2statenv : statenvgetter
35        | compare (SS _, _) = GREATER                       val getPid : SmlInfo.info -> pid option
36        | compare (_, SS _) = LESS                       val warmup : BinInfo.info * pid option -> unit
37        | compare (SI i, SI i') = SmlInfo.compare (i, i')                       val recomp : recomp) :> STABILIZE = struct
38        | compare (SI _, _) = GREATER  
39        | compare (_, SI _) = LESS      datatype pitem =
40        | compare (AP p, AP p') = AbsPath.compare (p, p')          PSS of SymbolSet.set
41          | PS of Symbol.symbol
42          | PSN of DG.snode
43    
44        datatype uitem =
45            USS of SymbolSet.set
46          | US of Symbol.symbol
47          | UBN of DG.bnode
48    
49        fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
50          | compare (PS _, _) = GREATER
51          | compare (_, PS _) = LESS
52          | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
53          | compare (PSS _, _) = GREATER
54          | compare (_, PSS _) = LESS
55          | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
56            SmlInfo.compare (#smlinfo n, #smlinfo n')
57    
58      structure Map =      structure Map =
59          BinaryMapFn (struct          BinaryMapFn (struct
60                           type ord_key = item                           type ord_key = pitem
61                           val compare = compare                           val compare = compare
62          end)          end)
63    
64      fun f (g as GroupGraph.GROUP { exports, ... }, binSizeOf, binCopy) = let      fun genStableInfoMap (exports, group) = let
65            (* find all the exported bnodes that are in the same group: *)
66            fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
67                val i = #bininfo b
68            in
69                if SrcPath.compare (BinInfo.group i, group) = EQUAL then
70                    IntBinaryMap.insert (m, BinInfo.offset i, n)
71                else m
72            end
73              | add (_, m) = m
74        in
75            SymbolMap.foldl add IntBinaryMap.empty exports
76        end
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    
85            fun doit wrapped = let
86    
87                val _ =
88                    if StringSet.isEmpty wrapped then ()
89                    else
90                        Say.say ("$Stabilize: wrapping the following privileges:\n"
91                                 :: map (fn s => ("  " ^ s ^ "\n"))
92                                        (StringSet.listItems wrapped))
93    
94                val bname = SmlInfo.binname
95                val bsz = OS.FileSys.fileSize o bname
96    
97                fun cpb s i = let
98                    val N = 4096
99                    fun copy ins = let
100                        fun cp () =
101                            if BinIO.endOfStream ins then ()
102                            else (BinIO.output (s, BinIO.inputN (ins, N));
103                                  cp ())
104                    in
105                        cp ()
106                    end
107                in
108                    SafeIO.perform { openIt = fn () => BinIO.openIn (bname i),
109                                     closeIt = BinIO.closeIn,
110                                     work = copy,
111                                     cleanup = fn () => () }
112                end
113    
114                val grpSrcInfo = (#errcons gp, anyerrors)
115    
116                val exports = #exports grec
117                val required = StringSet.difference (#required grec, wrapped)
118                val sublibs = #sublibs grec
119    
120          (* The format of a stable archive is the following:          (* The format of a stable archive is the following:
121           *  - It starts with the size s of the pickled dependency graph.               *  - It starts with the size s of the pickled dependency
122           *    This size itself is written as four-byte string.               *    graph. This size itself is written as four-byte string.
123           *  - The pickled dependency graph.  This graph contains integer               *  - The pickled dependency graph.  This graph contains
124           *    offsets of the binfiles for the individual ML members.               *    integer offsets of the binfiles for the individual ML
125           *    These offsets need to be adjusted by adding s + 4.               *    members. These offsets need to be adjusted by adding
126           *    The pickled dependency graph also contains integer offsets               *    s + 4. The pickled dependency graph also contains integer
127           *    relative to other stable groups.  These offsets need no               *    offsets relative to other stable groups.  These offsets
128           *    further adjustment.               *    need no further adjustment.
129           *  - Individual binfile contents (concatenated).           *  - Individual binfile contents (concatenated).
130           *)           *)
131          val members = let  
132              fun sn (DG.SNODE { smlinfo = i, localimports = l, ... }, s) =              (* Here we build a mapping that maps each BNODE to a number
133                  if SmlInfoSet.member (s, i) then s               * representing the sub-library that it came from and a
134                  else foldl sn (SmlInfoSet.add (s, i)) l               * representative symbol that can be used to find the BNODE
135              fun impexp (((_, DG.SB_BNODE _), _), s) = s               * within the exports of that library *)
136                | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
137                    StableMap.insert (m, #bininfo n, (i, sy))
138                  | oneB i (_, _, m) = m
139                fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
140                    (SymbolMap.foldli (oneB i) m exports, i + 1)
141                val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
142    
143                val members = ref []
144                val (registerOffset, getOffset) = let
145                    val dict = ref SmlInfoMap.empty
146                    val cur = ref 0
147                    fun reg (i, sz) = let
148                        val os = !cur
149          in          in
150              SmlInfoSet.listItems                      cur := os + sz;
151                    (SymbolMap.foldl impexp SmlInfoSet.empty exports)                      dict := SmlInfoMap.insert (!dict, i, os);
152                        members := i :: (!members);
153                        os
154          end          end
155                    fun get i = valOf (SmlInfoMap.find (!dict, i))
         val offsetDict = let  
             fun add (i, (d, n)) =  
                 (SmlInfoMap.insert (d, i, n), n + binSizeOf i)  
156          in          in
157              #1 (foldl add (SmlInfoMap.empty, 0) members)                  (reg, get)
158          end          end
159    
160          fun w_list w_item [] k m = ";" :: k m              fun w_list w_item [] k m =
161            | w_list w_item (h :: t) k m = w_item h (w_list w_item t k) m                  "0" :: k m
162                  | w_list w_item [a] k m =
163                    "1" :: w_item a k m
164                  | w_list w_item [a, b] k m =
165                    "2" :: w_item a (w_item b k) m
166                  | w_list w_item [a, b, c] k m =
167                    "3" :: w_item a (w_item b (w_item c k)) m
168                  | w_list w_item [a, b, c, d] k m =
169                    "4" :: w_item a (w_item b (w_item c (w_item d k))) m
170                  | w_list w_item (a :: b :: c :: d :: e :: r) k m =
171                    "5" :: w_item a (w_item b (w_item c (w_item d (w_item e
172                                                         (w_list w_item r k))))) m
173    
174          fun w_option w_item NONE k m = "n" :: k m          fun w_option w_item NONE k m = "n" :: k m
175            | 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
176    
177          fun int_encode i = let          fun int_encode i = let
178              (* this is the same mechanism that's also used in              (* this is the same mechanism that's also used in
179               * TopLevel/batch/binfile.sml -- maybe we should share it *)                   * TopLevel/batch/binfile.sml (maybe we should share it) *)
180              val n = Word32.fromInt i              val n = Word32.fromInt i
181              val // = LargeWord.div              val // = LargeWord.div
182              val %% = LargeWord.mod              val %% = LargeWord.mod
# Line 71  Line 184 
184              infix // %% !!              infix // %% !!
185              val toW8 = Word8.fromLargeWord              val toW8 = Word8.fromLargeWord
186              fun r (0w0, l) = Word8Vector.fromList l              fun r (0w0, l) = Word8Vector.fromList l
187                | r (n, l) = r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)                    | r (n, l) =
188                        r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
189          in          in
190              Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))              Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
191          end          end
# Line 81  Line 195 
195          fun w_share w C v k (i, m) =          fun w_share w C v k (i, m) =
196              case Map.find (m, C v) of              case Map.find (m, C v) of
197                  SOME i' => "o" :: w_int i' k (i, m)                  SOME i' => "o" :: w_int i' k (i, m)
198                | 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))
199    
200          fun w_symbol_raw s k m = SkelIO.w_name (s, k m)              fun w_symbol_raw s k m = let
201                    val ns = case Symbol.nameSpace s of
202                        Symbol.SIGspace => "'"
203                      | Symbol.FCTspace => "("
204                      | Symbol.FSIGspace => ")"
205                      | Symbol.STRspace => ""
206                      | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
207                in
208                    ns :: Symbol.name s :: "." :: k m
209                end
210    
211          val w_symbol = w_share w_symbol_raw S              val w_symbol = w_share w_symbol_raw PS
212    
213          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
214    
215          val w_filter = w_option w_ss          val w_filter = w_option w_ss
216    
# Line 95  Line 218 
218              fun esc #"\\" = "\\\\"              fun esc #"\\" = "\\\\"
219                | esc #"\"" = "\\\""                | esc #"\"" = "\\\""
220                | esc c = String.str c                | esc c = String.str c
   
221          in          in
222              String.translate esc s :: "\"" :: k m              String.translate esc s :: "\"" :: k m
223          end          end
# Line 104  Line 226 
226            | w_sharing (SOME true) k m = "t" :: k m            | w_sharing (SOME true) k m = "t" :: k m
227            | w_sharing (SOME false) k m = "f" :: k m            | w_sharing (SOME false) k m = "f" :: k m
228    
229          fun w_si_raw i k = let              fun w_si i k = let
230              val spec = AbsPath.spec (SmlInfo.sourcepath i)                  (* FIXME: this is not a technical flaw, but perhaps one
231              val offset = valOf (SmlInfoMap.find (offsetDict, i))                   * that deserves fixing anyway:  If we only look at spec,
232                     * then we are losing information about sub-grouping
233                     * within libraries.  However, the spec in BinInfo.info
234                     * is only used for diagnostics and has no impact on the
235                     * operation of CM itself. *)
236                    val spec = SrcPath.specOf (SmlInfo.sourcepath i)
237                    val locs = SmlInfo.errorLocation gp i
238                    val offset = registerOffset (i, bsz i)
239          in          in
240              w_string spec (w_int offset (w_sharing (SmlInfo.share i) k))                  w_string spec
241                       (w_string locs
242                             (w_int offset
243                                   (w_sharing (SmlInfo.share i) k)))
244          end          end
245    
246          val w_si = w_share w_si_raw SI              fun w_primitive p k m =
247                    String.str (Primitive.toIdent primconf p) :: k m
         fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m  
   
         fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m  
248    
249          val w_abspath = w_share w_abspath_raw AP              fun warn_relabs p abs = let
250                    val relabs = if abs then "absolute" else "relative"
251                    fun ppb pps =
252                        (PP.add_newline pps;
253                         PP.add_string pps (SrcPath.descr p);
254                         PP.add_newline pps;
255                         PP.add_string pps
256        "(This means that in order to be able to use the result of stabilization";
257                         PP.add_newline pps;
258                         PP.add_string pps "the library must be in the same ";
259                         PP.add_string pps relabs;
260                         PP.add_string pps " location as it is now.)";
261                         PP.add_newline pps)
262                in
263                    EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
264                        EM.WARN
265                        (concat [SrcPath.descr grouppath,
266                                 ": library referred to by ", relabs,
267                                 " pathname:"])
268                        ppb
269                end
270    
271          fun w_bi i k = w_abspath (BinInfo.group i) (w_int (BinInfo.offset i) k)              fun w_abspath p k m =
272                    w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))
273                                    k m
274    
275          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
276            | w_bn (DG.BNODE { bininfo, ... }) k m = "b" :: w_bi bininfo k m                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let
277                        val (n, sy) = valOf (StableMap.find (inverseMap, i))
278                    in
279                        "b" :: w_int n (w_symbol sy k) m
280                    end
281    
282          fun w_sn (DG.SNODE n) k =              fun w_pid p = w_string (Byte.bytesToString (Pid.toBytes p))
283              w_si (#smlinfo n)  
284                fun w_sn_raw (DG.SNODE n) k =
285                    w_option w_pid (getPid (#smlinfo n))
286                             (w_si (#smlinfo n)
287                   (w_list w_sn (#localimports n)                   (w_list w_sn (#localimports n)
288                                (w_list w_fsbn (#globalimports n) k))                                         (w_list w_fsbn (#globalimports n) k)))
289    
290                and w_sn n = w_share w_sn_raw PSN n
291    
292          and w_sbn (DG.SB_BNODE n) = w_bn n              and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
293            | w_sbn (DG.SB_SNODE n) = GenericVC.ErrorMsg.impossible                | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
             "stabilize: non-stabilized subgroup? (2)"  
294    
295          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)
296    
# Line 144  Line 303 
303    
304          fun w_privileges p = w_list w_string (StringSet.listItems p)          fun w_privileges p = w_list w_string (StringSet.listItems p)
305    
306          fun pickle_group (GroupGraph.GROUP g) = let              fun pickle_group () = let
307              val { exports, islib, required, grouppath, subgroups, ... } = g                  fun w_sg (p, _) = w_abspath p
             fun w_sg (GroupGraph.GROUP { grouppath = gp, ... }) = w_abspath gp  
308              fun k0 m = []              fun k0 m = []
309              val m0 = (0, Map.empty)              val m0 = (0, Map.empty)
310          in          in
311              concat                  (* Pickle the sublibs first because we need to already
312                     * have them back when we unpickle BNODEs. *)
313                    concat (w_list w_sg sublibs
314                (w_exports exports                (w_exports exports
315                     (w_bool islib                                   (w_privileges required k0)) m0)
                           (w_privileges required  
                                    (w_abspath grouppath  
                                               (w_list w_sg subgroups k0)))) m0)  
316          end          end
317          val pickle = pickle_group g  
318                val pickle = pickle_group ()
319          val sz = size pickle          val sz = size pickle
320                val offset_adjustment = sz + 4
321    
322                fun mkStableGroup sname = let
323                    val m = ref SmlInfoMap.empty
324                    fun sn (DG.SNODE (n as { smlinfo, ... })) =
325                        case SmlInfoMap.find (!m, smlinfo) of
326                            SOME n => n
327                          | NONE => let
328                                val li = map sn (#localimports n)
329                                val gi = map fsbn (#globalimports n)
330                                val sourcepath = SmlInfo.sourcepath smlinfo
331                                (* FIXME: see the comment near the other
332                                 * occurence of SrcPath.spec... *)
333                                val spec = SrcPath.specOf sourcepath
334                                val offset =
335                                    getOffset smlinfo + offset_adjustment
336                                val share = SmlInfo.share smlinfo
337                                val locs = SmlInfo.errorLocation gp smlinfo
338                                val error = EM.errorNoSource grpSrcInfo locs
339                                val i = BinInfo.new { group = grouppath,
340                                                      stablename = sname,
341                                                      spec = spec,
342                                                      offset = offset,
343                                                      share = share,
344                                                      error = error }
345                                val n = DG.BNODE { bininfo = i,
346                                                   localimports = li,
347                                                   globalimports = gi }
348                            in
349                                m := SmlInfoMap.insert (!m, smlinfo, n);
350                                n
351                            end
352    
353                    and sbn (DG.SB_SNODE n) = sn n
354                      | sbn (DG.SB_BNODE n) = n
355    
356                    and fsbn (f, n) = (f, sbn n)
357    
358                    fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
359    
360                    val exports = SymbolMap.map impexp (#exports grec)
361                    val simap = genStableInfoMap (exports, grouppath)
362                in
363                    GG.GROUP { exports = exports,
364                               kind = GG.STABLELIB simap,
365                               required = required,
366                               grouppath = grouppath,
367                               sublibs = sublibs }
368                end
369    
370                fun writeInt32 (s, i) = let
371                    val a = Word8Array.array (4, 0w0)
372                    val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
373                in
374                    BinIO.output (s, Word8Array.extract (a, 0, NONE))
375                end
376                val memberlist = rev (!members)
377    
378                val gpath = #grouppath grec
379                val sname = FilenamePolicy.mkStableName policy gpath
380                fun work outs =
381                    (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
382                     writeInt32 (outs, sz);
383                     BinIO.output (outs, Byte.stringToBytes pickle);
384                     app (cpb outs) memberlist;
385                     mkStableGroup sname)
386            in
387                SOME (SafeIO.perform { openIt = fn () => AutoDir.openBinOut sname,
388                                       closeIt = BinIO.closeOut,
389                                       work = work,
390                                       cleanup = fn () =>
391                                        (OS.FileSys.remove sname handle _ => ()) })
392                handle exn => NONE
393            end
394        in
395            case #kind grec of
396                GG.STABLELIB _ => SOME g
397              | GG.NOLIB => EM.impossible "stabilize: no library"
398              | GG.LIB wrapped =>
399                    if not (recomp gp g) then
400                        (anyerrors := true; NONE)
401                    else let
402                        fun notStable (_, GG.GROUP { kind, ... }) =
403                            case kind of GG.STABLELIB _ => false | _ => true
404                    in
405                        case List.filter notStable (#sublibs grec) of
406                            [] => doit wrapped
407                          | l => let
408                                val grammar = case l of [_] => " is" | _ => "s are"
409                                fun ppb pps = let
410                                    fun loop [] = ()
411                                      | loop ((p, GG.GROUP { grouppath, ... })
412                                              :: t) =
413                                        (PP.add_string pps
414                                            (SrcPath.descr grouppath);
415                                         PP.add_string pps " (";
416                                         PP.add_string pps (SrcPath.descr p);
417                                         PP.add_string pps ")";
418                                         PP.add_newline pps;
419                                         loop t)
420                                in
421                                    PP.add_newline pps;
422                                    PP.add_string pps
423                                        (concat ["because the following sub-group",
424                                                 grammar, " not stable:"]);
425                                    PP.add_newline pps;
426                                    loop l
427                                end
428                                val errcons = #errcons gp
429                                val gdescr = SrcPath.descr (#grouppath grec)
430                            in
431                                EM.errorNoFile (errcons, anyerrors) SM.nullRegion
432                                   EM.COMPLAIN
433                                   (gdescr ^ " cannot be stabilized")
434                                   ppb;
435                                NONE
436                            end
437                    end
438        end
439    
440        fun loadStable (gp, getGroup, anyerrors) group = let
441    
442            val es2bs = GenericVC.CoerceEnv.es2bs
443            fun bn2env n =
444                Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))
445    
446            val errcons = #errcons gp
447            val grpSrcInfo = (errcons, anyerrors)
448            val gdescr = SrcPath.descr group
449            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
450                EM.COMPLAIN (concat (gdescr :: ": " :: l)) EM.nullErrorBody
451    
452            exception Format
453    
454            val pcmode = #pcmode (#param gp)
455            val policy = #fnpolicy (#param gp)
456            val primconf = #primconf (#param gp)
457            val sname = FilenamePolicy.mkStableName policy group
458            val _ = Say.vsay ["[checking stable ", gdescr, "]\n"]
459    
460            fun work s = let
461    
462                fun getGroup' p =
463                    case getGroup p of
464                        SOME g => g
465                      | NONE => (error ["unable to find ", SrcPath.descr p];
466                                 raise Format)
467    
468                (* for getting sharing right... *)
469                val m = ref IntBinaryMap.empty
470                val next = ref 0
471    
472                val pset = ref PidSet.empty
473    
474                fun bytesIn n = let
475                    val bv = BinIO.inputN (s, n)
476      in      in
477          ()                  if n = Word8Vector.length bv then bv
478                    else raise Format
479      end      end
480    
481                val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
482                val pickle = bytesIn sz
483                val offset_adjustment = sz + 4
484    
485                val rd = let
486                    val pos = ref 0
487                    fun rd () = let
488                        val p = !pos
489                    in
490                        pos := p + 1;
491                        Byte.byteToChar (Word8Vector.sub (pickle, p))
492                        handle _ => raise Format
493                    end
494                in
495                    rd
496                end
497    
498                fun r_list r () =
499                    case rd () of
500                        #"0" => []
501                      | #"1" => [r ()]
502                      | #"2" => [r (), r ()]
503                      | #"3" => [r (), r (), r ()]
504                      | #"4" => [r (), r (), r (), r ()]
505                      | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
506                      | _ => raise Format
507    
508                fun r_bool () =
509                    case rd () of
510                        #"t" => true
511                      | #"f" => false
512                      | _ => raise Format
513    
514                fun r_option r_item () =
515                    case rd () of
516                        #"n" => NONE
517                      | #"s" => SOME (r_item ())
518                      | _ => raise Format
519    
520                fun r_int () = let
521                    fun loop n = let
522                        val w8 = Byte.charToByte (rd ())
523                        val n' =
524                            n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
525                    in
526                        if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
527                    end
528                in
529                    LargeWord.toIntX (loop 0w0)
530                end
531    
532                fun r_share r_raw C unC () =
533                    case rd () of
534                        #"o" => (case IntBinaryMap.find (!m, r_int ()) of
535                                     SOME x => unC x
536                                   | NONE => raise Format)
537                      | #"n" => let
538                            val i = !next
539                            val _ = next := i + 1
540                            val v = r_raw ()
541                        in
542                            m := IntBinaryMap.insert (!m, i, C v);
543                            v
544                        end
545                      | _ => raise Format
546    
547                fun r_string () = let
548                    fun loop l =
549                        case rd () of
550                            #"\"" => String.implode (rev l)
551                          | #"\\" => loop (rd () :: l)
552                          | c => loop (c :: l)
553                in
554                    loop []
555                end
556    
557                fun r_abspath () =
558                    case SrcPath.unpickle pcmode (r_list r_string (), group) of
559                        SOME p => p
560                      | NONE => raise Format
561    
562                val r_symbol = let
563                    fun r_symbol_raw () = let
564                        val (ns, first) =
565                            case rd () of
566                                #"'" => (Symbol.sigSymbol, rd ())
567                              | #"(" => (Symbol.fctSymbol, rd ())
568                              | #")" => (Symbol.fsigSymbol, rd ())
569                              | c => (Symbol.strSymbol, c)
570                        fun loop (#".", l) = String.implode (rev l)
571                          | loop (c, l) = loop (rd (), c :: l)
572                    in
573                        ns (loop (first, []))
574                    end
575                    fun unUS (US x) = x
576                      | unUS _ = raise Format
577                in
578                    r_share r_symbol_raw US unUS
579                end
580    
581                val r_ss = let
582                    fun r_ss_raw () =
583                        SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
584                    fun unUSS (USS s) = s
585                      | unUSS _ = raise Format
586                in
587                    r_share r_ss_raw USS unUSS
588  end  end
589    
590                val r_filter = r_option r_ss
591    
592                fun r_primitive () =
593                    case Primitive.fromIdent primconf (rd ()) of
594                        NONE => raise Format
595                      | SOME p => p
596    
597                fun r_sharing () =
598                    case rd () of
599                        #"n" => NONE
600                      | #"t" => SOME true
601                      | #"f" => SOME false
602                      | _ => raise Format
603    
604                fun r_si () = let
605                    val spec = r_string ()
606                    val locs = r_string ()
607                    val offset = r_int () + offset_adjustment
608                    val share = r_sharing ()
609                    val error = EM.errorNoSource grpSrcInfo locs
610                in
611                    BinInfo.new { group = group,
612                                  stablename = sname,
613                                  error = error,
614                                  spec = spec,
615                                  offset = offset,
616                                  share = share }
617                end
618    
619                fun r_sg () = let
620                    val p = r_abspath ()
621                in
622                    (p, getGroup' p)
623                end
624    
625                val sublibs = r_list r_sg ()
626    
627                fun r_bn () =
628                    case rd () of
629                        #"p" => DG.PNODE (r_primitive ())
630                      | #"b" => let
631                            val n = r_int ()
632                            val sy = r_symbol ()
633                            val (_, GG.GROUP { exports = slexp, ... }) =
634                                List.nth (sublibs, n) handle _ => raise Format
635                        in
636                            case SymbolMap.find (slexp, sy) of
637                                SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
638                              | _ => raise Format
639                        end
640                      | _ => raise Format
641    
642                fun r_pid () = Pid.fromBytes (Byte.stringToBytes (r_string ()))
643    
644                (* this is the place where what used to be an
645                 * SNODE changes to a BNODE! *)
646                fun r_sn_raw () = let
647                    val popt = r_option r_pid ()
648                    val i = r_si ()
649                in
650                    warmup (i, popt);
651                    DG.BNODE { bininfo = i,
652                               localimports = r_list r_sn (),
653                               globalimports = r_list r_fsbn () }
654                end
655    
656                and r_sn () =
657                    r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
658    
659                (* this one changes from farsbnode to plain farbnode *)
660                and r_sbn () =
661                    case rd () of
662                        #"b" => r_bn ()
663                      | #"s" => r_sn ()
664                      | _ => raise Format
665    
666                and r_fsbn () = (r_filter (), r_sbn ())
667    
668                fun r_impexp () = let
669                    val sy = r_symbol ()
670                    val (f, n) = r_fsbn ()  (* really reads farbnodes! *)
671                    val e = bn2env n
672                    (* put a filter in front to avoid having the FCTENV being
673                     * queried needlessly (this avoids spurious module loadings) *)
674                    val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
675                in
676                    (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
677                end
678    
679                fun r_exports () =
680                    foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
681    
682                fun r_privileges () =
683                    StringSet.addList (StringSet.empty, r_list r_string ())
684    
685                val exports = r_exports ()
686                val required = r_privileges ()
687                val simap = genStableInfoMap (exports, group)
688            in
689                GG.GROUP { exports = exports,
690                           kind = GG.STABLELIB simap,
691                           required = required,
692                           grouppath = group,
693                           sublibs = sublibs }
694            end
695        in
696            SOME (SafeIO.perform { openIt = fn () => BinIO.openIn sname,
697                                   closeIt = BinIO.closeIn,
698                                   work = work,
699                                   cleanup = fn () => () })
700            handle Format => NONE
701                 | IO.Io _ => NONE
702        end
703    end
704    
705    end (* local *)

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

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