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

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

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