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

SCM Repository

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

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

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

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

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

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