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 360, Tue Jun 29 09:21:02 1999 UTC revision 385, Thu Jul 22 05:23:25 1999 UTC
# Line 32  Line 32 
32  end  end
33    
34  functor StabilizeFn (val bn2statenv : statenvgetter  functor StabilizeFn (val bn2statenv : statenvgetter
35                       val getPid : SmlInfo.info -> pid option                       val transfer_state : SmlInfo.info * BinInfo.info -> unit
                      val warmup : BinInfo.info * pid option -> unit  
36                       val recomp : recomp) :> STABILIZE = struct                       val recomp : recomp) :> STABILIZE = struct
37    
38      datatype pitem =      structure PU = PickleUtil
39          PSS of SymbolSet.set      structure UU = UnpickleUtil
       | PS of Symbol.symbol  
       | PSN of DG.snode  
   
     datatype uitem =  
         USS of SymbolSet.set  
       | US of Symbol.symbol  
       | UBN of DG.bnode  
   
     fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')  
       | compare (PS _, _) = GREATER  
       | compare (_, PS _) = LESS  
       | compare (PSS s, PSS s') = SymbolSet.compare (s, s')  
       | compare (PSS _, _) = GREATER  
       | compare (_, PSS _) = LESS  
       | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =  
         SmlInfo.compare (#smlinfo n, #smlinfo n')  
40    
41      structure Map =      infix 3 $
42          BinaryMapFn (struct      infixr 4 &
43                           type ord_key = pitem      val op & = PU.&
44                           val compare = compare      val % = PU.%
45    
46        (* type info *)
47        val (BN, SN, SBN, SS, SI, FSBN, IMPEXP) = (1, 2, 3, 4, 5, 6, 7)
48    
49        structure SSMap = BinaryMapFn
50            (struct
51                 type ord_key = SymbolSet.set
52                 val compare = SymbolSet.compare
53          end)          end)
54    
55        structure SNMap = BinaryMapFn
56            (struct
57                 type ord_key = DG.snode
58                 fun compare (DG.SNODE n, DG.SNODE n') =
59                     SmlInfo.compare (#smlinfo n, #smlinfo n')
60            end)
61    
62        type 'a maps = { ss: 'a SSMap.map, sn: 'a SNMap.map }
63    
64        val initMap = { ss = SSMap.empty, sn = SNMap.empty }
65        val SSs = { find = fn (m: 'a maps, k) => SSMap.find (#ss m, k),
66                    insert = fn ({ ss, sn }, k, v) =>
67                                 { sn = sn, ss = SSMap.insert (ss, k, v) } }
68        val SNs = { find = fn (m: 'a maps, k) => SNMap.find (#sn m, k),
69                    insert = fn ({ ss, sn }, k, v) =>
70                                 { ss = ss, sn = SNMap.insert (sn, k, v) } }
71    
72      fun genStableInfoMap (exports, group) = let      fun genStableInfoMap (exports, group) = let
73          (* find all the exported bnodes that are in the same group: *)          (* find all the exported bnodes that are in the same group: *)
74          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
# Line 136  Line 144 
144              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
145                  StableMap.insert (m, #bininfo n, (i, sy))                  StableMap.insert (m, #bininfo n, (i, sy))
146                | oneB i (_, _, m) = m                | oneB i (_, _, m) = m
147              fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
148                  (SymbolMap.foldli (oneB i) m exports, i + 1)                  (SymbolMap.foldli (oneB i) m exports, i + 1)
149              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
150    
# Line 157  Line 165 
165                  (reg, get)                  (reg, get)
166              end              end
167    
168              fun w_list w_item [] k m =              val int = PU.w_int
169                  "0" :: k m              val symbol = PU.w_symbol
170                | w_list w_item [a] k m =              val share = PU.ah_share
171                  "1" :: w_item a k m              val option = PU.w_option
172                | w_list w_item [a, b] k m =              val list = PU.w_list
173                  "2" :: w_item a (w_item b k) m              val string = PU.w_string
174                | w_list w_item [a, b, c] k m =              val bool = PU.w_bool
175                  "3" :: w_item a (w_item b (w_item c k)) m              val int = PU.w_int
176                | w_list w_item [a, b, c, d] k m =  
177                  "4" :: w_item a (w_item b (w_item c (w_item d k))) m              fun symbolset ss = let
178                | w_list w_item (a :: b :: c :: d :: e :: r) k m =                  val op $ = PU.$ SS
179                  "5" :: w_item a (w_item b (w_item c (w_item d (w_item e                  fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
180                                                       (w_list w_item r k))))) m              in
181                    share SSs raw_ss ss
182              fun w_option w_item NONE k m = "n" :: k m              end
               | w_option w_item (SOME i) k m = "s" :: w_item i k m  
   
             fun int_encode i = let  
                 (* this is the same mechanism that's also used in  
                  * TopLevel/batch/binfile.sml (maybe we should share it) *)  
                 val n = Word32.fromInt i  
                 val // = LargeWord.div  
                 val %% = LargeWord.mod  
                 val !! = LargeWord.orb  
                 infix // %% !!  
                 val toW8 = Word8.fromLargeWord  
                 fun r (0w0, l) = Word8Vector.fromList l  
                   | r (n, l) =  
                     r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)  
             in  
                 Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))  
             end  
   
             fun w_int i k m = int_encode i :: k m  
   
             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"  
             in  
                 ns :: Symbol.name s :: "." :: k m  
             end  
   
             val w_symbol = w_share w_symbol_raw PS  
   
             val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS  
   
             val w_filter = w_option w_ss  
   
             fun w_string s k m = let  
                 fun esc #"\\" = "\\\\"  
                   | esc #"\"" = "\\\""  
                   | esc c = String.str c  
             in  
                 String.translate esc s :: "\"" :: k m  
             end  
   
             fun w_sharing NONE k m = "n" :: k m  
               | w_sharing (SOME true) k m = "t" :: k m  
               | w_sharing (SOME false) k m = "f" :: k m  
183    
184              fun w_si i k = let              val filter = option symbolset
185    
186                val sh = option bool        (* sharing *)
187    
188                fun si i = let
189                  (* FIXME: this is not a technical flaw, but perhaps one                  (* FIXME: this is not a technical flaw, but perhaps one
190                   * that deserves fixing anyway:  If we only look at spec,                   * that deserves fixing anyway:  If we only look at spec,
191                   * then we are losing information about sub-grouping                   * then we are losing information about sub-grouping
# Line 236  Line 195 
195                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
196                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
197                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
198                    val share = SmlInfo.share i
199                    val op $ = PU.$ SI
200              in              in
201                  w_string spec                  "s" $ string spec & string locs & int offset & sh share
                    (w_string locs  
                          (w_int offset  
                                (w_sharing (SmlInfo.share i) k)))  
202              end              end
203    
204              fun w_primitive p k m =              fun primitive p =
205                  String.str (Primitive.toIdent primconf p) :: k m                  string (String.str (Primitive.toIdent primconf p))
206    
207              fun warn_relabs p abs = let              fun warn_relabs p abs = let
208                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
# Line 268  Line 226 
226                      ppb                      ppb
227              end              end
228    
229              fun w_abspath p k m =              fun abspath p = let
230                  w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))                  val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
231                                  k m              in
232                    list string pp
233                end
234    
235              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              val op $ = PU.$ BN
236                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let              fun bn (DG.PNODE p) = "1" $ primitive p
237                  | bn (DG.BNODE { bininfo = i, ... }) = let
238                      val (n, sy) = valOf (StableMap.find (inverseMap, i))                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
239                  in                  in
240                      "b" :: w_int n (w_symbol sy k) m                      "2" $ int n & symbol sy
241                  end                  end
242    
243              fun w_pid p = w_string (Byte.bytesToString (Pid.toBytes p))              fun sn n = let
244                    fun raw_sn (DG.SNODE n) =
245              fun w_sn_raw (DG.SNODE n) k =                      "a" $ si (#smlinfo n) & list sn (#localimports n) &
246                  w_option w_pid (getPid (#smlinfo n))                      list fsbn (#globalimports n)
247                           (w_si (#smlinfo n)              in
248                                 (w_list w_sn (#localimports n)                  share SNs raw_sn n
249                                         (w_list w_fsbn (#globalimports n) k)))              end
   
             and w_sn n = w_share w_sn_raw PSN n  
   
             and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m  
               | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m  
250    
251              and w_fsbn (f, n) k = w_filter f (w_sbn n k)              and sbn x = let
252                    val op $ = PU.$ SBN
253                in
254                    case x of
255                        DG.SB_BNODE n => "a" $ bn n
256                      | DG.SB_SNODE n => "b" $ sn n
257                end
258    
259              fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)              and fsbn (f, n) = let
260                    val op $ = PU.$ FSBN
261                in
262                    "f" $ filter f & sbn n
263                end
264    
265              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              fun impexp (s, (n, _)) = let
266                    val op $ = PU.$ IMPEXP
267                in
268                    "i" $ symbol s & fsbn n
269                end
270    
271              fun w_bool true k m = "t" :: k m              fun w_exports e = list impexp (SymbolMap.listItemsi e)
               | w_bool false k m = "f" :: k m  
272    
273              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun privileges p = list string (StringSet.listItems p)
274    
275              fun pickle_group () = let              fun group () = let
276                  fun w_sg (p, _) = w_abspath p                  fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
                 fun k0 m = []  
                 val m0 = (0, Map.empty)  
277              in              in
278                  (* Pickle the sublibs first because we need to already                  (* Pickle the sublibs first because we need to already
279                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
280                  concat (w_list w_sg sublibs                  list sg sublibs & w_exports exports & privileges required
                             (w_exports exports  
                                  (w_privileges required k0)) m0)  
281              end              end
282    
283              val pickle = pickle_group ()              val pickle = PU.pickle initMap (group ())
284              val sz = size pickle              val sz = size pickle
285              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
286    
287              fun mkStableGroup sname = let              fun mkStableGroup mksname = let
288                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
289                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
290                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
# Line 337  Line 302 
302                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
303                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
304                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
305                                                    stablename = sname,                                                    mkStablename = mksname,
306                                                    spec = spec,                                                    spec = spec,
307                                                    offset = offset,                                                    offset = offset,
308                                                    share = share,                                                    share = share,
# Line 346  Line 311 
311                                                 localimports = li,                                                 localimports = li,
312                                                 globalimports = gi }                                                 globalimports = gi }
313                          in                          in
314                                transfer_state (smlinfo, i);
315                              m := SmlInfoMap.insert (!m, smlinfo, n);                              m := SmlInfoMap.insert (!m, smlinfo, n);
316                              n                              n
317                          end                          end
# Line 376  Line 342 
342              val memberlist = rev (!members)              val memberlist = rev (!members)
343    
344              val gpath = #grouppath grec              val gpath = #grouppath grec
345              val sname = FilenamePolicy.mkStableName policy gpath              fun mksname () = FilenamePolicy.mkStableName policy gpath
346              fun work outs =              fun work outs =
347                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
348                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
349                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
350                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
351                   mkStableGroup sname)                   mkStableGroup mksname)
352          in          in
353              SOME (SafeIO.perform { openIt = fn () => AutoDir.openBinOut sname,              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
354                                     closeIt = BinIO.closeOut,                                     closeIt = BinIO.closeOut,
355                                     work = work,                                     work = work,
356                                     cleanup = fn () =>                                     cleanup = fn () =>
357                                      (OS.FileSys.remove sname handle _ => ()) })                                      (OS.FileSys.remove (mksname ())
358                                         handle _ => ()) })
359              handle exn => NONE              handle exn => NONE
360          end          end
361      in      in
# Line 399  Line 366 
366                  if not (recomp gp g) then                  if not (recomp gp g) then
367                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
368                  else let                  else let
369                      fun notStable (_, GG.GROUP { kind, ... }) =                      fun notStable (GG.GROUP { kind, ... }) =
370                          case kind of GG.STABLELIB _ => false | _ => true                          case kind of GG.STABLELIB _ => false | _ => true
371                  in                  in
372                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
# Line 408  Line 375 
375                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
376                              fun ppb pps = let                              fun ppb pps = let
377                                  fun loop [] = ()                                  fun loop [] = ()
378                                    | loop ((p, GG.GROUP { grouppath, ... })                                    | loop (GG.GROUP { grouppath, ... } :: t) =
                                           :: t) =  
379                                      (PP.add_string pps                                      (PP.add_string pps
380                                          (SrcPath.descr grouppath);                                          (SrcPath.descr grouppath);
                                      PP.add_string pps " (";  
                                      PP.add_string pps (SrcPath.descr p);  
                                      PP.add_string pps ")";  
381                                       PP.add_newline pps;                                       PP.add_newline pps;
382                                       loop t)                                       loop t)
383                              in                              in
# Line 447  Line 410 
410          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
411          val gdescr = SrcPath.descr group          val gdescr = SrcPath.descr group
412          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
413              EM.COMPLAIN (concat (gdescr :: ": " :: l)) EM.nullErrorBody              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
414                EM.nullErrorBody
415    
416          exception Format          exception Format = UU.Format
417    
418          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
419          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
420          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
421          val sname = FilenamePolicy.mkStableName policy group          fun mksname () = FilenamePolicy.mkStableName policy group
         val _ = Say.vsay ["[checking stable ", gdescr, "]\n"]  
422    
423          fun work s = let          fun work s = let
424    
# Line 479  Line 442 
442              end              end
443    
444              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
445              val pickle = bytesIn sz              val pickle = Byte.bytesToString (bytesIn sz)
446              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
447    
448              val rd = let              val session = UU.mkSession (UU.stringReader 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  
   
             fun r_list r () =  
                 case rd () of  
                     #"0" => []  
                   | #"1" => [r ()]  
                   | #"2" => [r (), r ()]  
                   | #"3" => [r (), r (), r ()]  
                   | #"4" => [r (), r (), r (), r ()]  
                   | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()  
                   | _ => raise Format  
   
             fun r_bool () =  
                 case rd () of  
                     #"t" => true  
                   | #"f" => false  
                   | _ => raise Format  
449    
450              fun r_option r_item () =              fun list m r = UU.r_list session m r
451                  case rd () of              fun option m r = UU.r_option session m r
452                      #"n" => NONE              val int = UU.r_int session
453                    | #"s" => SOME (r_item ())              fun share m r = UU.share session m r
454                    | _ => raise Format              val string = UU.r_string session
455                val symbol = UU.r_symbol session
456              fun r_int () = let              val bool = UU.r_bool session
457                  fun loop n = let  
458                      val w8 = Byte.charToByte (rd ())              val stringListM = UU.mkMap ()
459                      val n' =              val symbolListM = UU.mkMap ()
460                          n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))              val stringListM = UU.mkMap ()
461                  in              val ssM = UU.mkMap ()
462                      if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'              val ssoM = UU.mkMap ()
463                  end              val boolOptionM = UU.mkMap ()
464              in              val siM = UU.mkMap ()
465                  LargeWord.toIntX (loop 0w0)              val sgListM = UU.mkMap ()
466              end              val snM = UU.mkMap ()
467                val snListM = UU.mkMap ()
468              fun r_share r_raw C unC () =              val bnM = UU.mkMap ()
469                  case rd () of              val sbnM = UU.mkMap ()
470                      #"o" => (case IntBinaryMap.find (!m, r_int ()) of              val fsbnM = UU.mkMap ()
471                                   SOME x => unC x              val fsbnListM = UU.mkMap ()
472                                 | NONE => raise Format)              val impexpM = UU.mkMap ()
473                    | #"n" => let              val impexpListM = UU.mkMap ()
474                          val i = !next  
475                          val _ = next := i + 1              val stringlist = list stringListM string
476                          val v = r_raw ()  
477                      in              fun abspath () =
478                          m := IntBinaryMap.insert (!m, i, C v);                  SrcPath.unpickle pcmode (stringlist (), group)
479                          v                  handle SrcPath.Format => raise Format
480                      end                       | SrcPath.BadAnchor a =>
481                    | _ => raise Format                         (error ["configuration anchor \"", a, "\" undefined"];
482                            raise Format)
             fun r_string () = let  
                 fun loop l =  
                     case rd () of  
                         #"\"" => String.implode (rev l)  
                       | #"\\" => loop (rd () :: l)  
                       | c => loop (c :: l)  
             in  
                 loop []  
             end  
   
             fun r_abspath () =  
                 case SrcPath.unpickle pcmode (r_list r_string (), group) of  
                     SOME p => p  
                   | NONE => raise Format  
483    
484              val r_symbol = let              val symbollist = list symbolListM symbol
                 fun r_symbol_raw () = let  
                     val (ns, first) =  
                         case rd () of  
                             #"'" => (Symbol.sigSymbol, rd ())  
                           | #"(" => (Symbol.fctSymbol, rd ())  
                           | #")" => (Symbol.fsigSymbol, rd ())  
                           | c => (Symbol.strSymbol, c)  
                     fun loop (#".", l) = String.implode (rev l)  
                       | loop (c, l) = loop (rd (), c :: l)  
                 in  
                     ns (loop (first, []))  
                 end  
                 fun unUS (US x) = x  
                   | unUS _ = raise Format  
             in  
                 r_share r_symbol_raw US unUS  
             end  
485    
486              val r_ss = let              fun symbolset () = let
487                  fun r_ss_raw () =                  fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
488                      SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                    | s _ = raise Format
                 fun unUSS (USS s) = s  
                   | unUSS _ = raise Format  
489              in              in
490                  r_share r_ss_raw USS unUSS                  share ssM s
491              end              end
492    
493              val r_filter = r_option r_ss              val filter = option ssoM symbolset
494    
495              fun r_primitive () =              fun primitive () =
496                  case Primitive.fromIdent primconf (rd ()) of                  valOf (Primitive.fromIdent primconf
497                      NONE => raise Format                            (String.sub (string (), 0)))
498                    | SOME p => p                  handle _ => raise Format
499    
500              fun r_sharing () =              val sh = option boolOptionM bool
                 case rd () of  
                     #"n" => NONE  
                   | #"t" => SOME true  
                   | #"f" => SOME false  
                   | _ => raise Format  
501    
502              fun r_si () = let              fun si () = let
503                  val spec = r_string ()                  fun s #"s" =
504                  val locs = r_string ()                      let val spec = string ()
505                  val offset = r_int () + offset_adjustment                          val locs = string ()
506                  val share = r_sharing ()                          val offset = int () + offset_adjustment
507                            val share = sh ()
508                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
509              in              in
510                  BinInfo.new { group = group,                  BinInfo.new { group = group,
511                                stablename = sname,                                        mkStablename = mksname,
512                                error = error,                                error = error,
513                                spec = spec,                                spec = spec,
514                                offset = offset,                                offset = offset,
515                                share = share }                                share = share }
516              end              end
517                      | s _ = raise Format
             fun r_sg () = let  
                 val p = r_abspath ()  
518              in              in
519                  (p, getGroup' p)                  share siM s
520              end              end
521    
522              val sublibs = r_list r_sg ()              fun sg () = getGroup' (abspath ())
523    
524              fun r_bn () =              val sublibs = list sgListM sg ()
525                  case rd () of  
526                      #"p" => DG.PNODE (r_primitive ())              fun bn () = let
527                    | #"b" => let                  fun bn' #"1" = DG.PNODE (primitive ())
528                          val n = r_int ()                    | bn' #"2" = let
529                          val sy = r_symbol ()                          val n = int ()
530                          val (_, GG.GROUP { exports = slexp, ... }) =                          val sy = symbol ()
531                            val GG.GROUP { exports = slexp, ... } =
532                              List.nth (sublibs, n) handle _ => raise Format                              List.nth (sublibs, n) handle _ => raise Format
533                      in                      in
534                          case SymbolMap.find (slexp, sy) of                          case SymbolMap.find (slexp, sy) of
535                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
536                            | _ => raise Format                            | _ => raise Format
537                      end                      end
538                    | _ => raise Format                    | bn' _ = raise Format
539                in
540              fun r_pid () = Pid.fromBytes (Byte.stringToBytes (r_string ()))                  share bnM bn'
541                end
542    
543              (* this is the place where what used to be an              (* this is the place where what used to be an
544               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
545              fun r_sn_raw () = let              fun sn () = let
546                  val popt = r_option r_pid ()                  fun sn' #"a" =
547                  val i = r_si ()                      DG.BNODE { bininfo = si (),
548              in                                 localimports = snlist (),
549                  warmup (i, popt);                                 globalimports = fsbnlist () }
550                  DG.BNODE { bininfo = i,                    | sn' _ = raise Format
551                             localimports = r_list r_sn (),              in
552                             globalimports = r_list r_fsbn () }                  share snM sn'
553              end              end
554    
555              and r_sn () =              and snlist () = list snListM sn ()
                 r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()  
556    
557              (* this one changes from farsbnode to plain farbnode *)              (* this one changes from farsbnode to plain farbnode *)
558              and r_sbn () =              and sbn () = let
559                  case rd () of                  fun sbn' #"a" = bn ()
560                      #"b" => r_bn ()                    | sbn' #"b" = sn ()
561                    | #"s" => r_sn ()                    | sbn' _ = raise Format
562                    | _ => raise Format              in
563                    share sbnM sbn'
564                end
565    
566                and fsbn () = let
567                    fun f #"f" = (filter (), sbn ())
568                      | f _ = raise Format
569                in
570                    share fsbnM f
571                end
572    
573              and r_fsbn () = (r_filter (), r_sbn ())              and fsbnlist () = list fsbnListM fsbn ()
574    
575              fun r_impexp () = let              fun impexp () = let
576                  val sy = r_symbol ()                  fun ie #"i" =
577                  val (f, n) = r_fsbn ()  (* really reads farbnodes! *)                      let val sy = symbol ()
578                            val (f, n) = fsbn () (* really reads farbnodes! *)
579                  val e = bn2env n                  val e = bn2env n
580                  (* put a filter in front to avoid having the FCTENV being                          (* put a filter in front to avoid having the FCTENV
581                   * queried needlessly (this avoids spurious module loadings) *)                           * being queried needlessly (this avoids spurious
582                             * module loadings) *)
583                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
584              in              in
585                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)                          (* coerce to farsbnodes *)
586                            (sy, ((f, DG.SB_BNODE n), e'))
587                        end
588                      | ie _ = raise Format
589                in
590                    share impexpM ie
591              end              end
592    
593                val impexplist = list impexpListM impexp
594    
595              fun r_exports () =              fun r_exports () =
596                  foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())                  foldl SymbolMap.insert' SymbolMap.empty (impexplist ())
597    
598                val stringlist = list stringListM string
599    
600              fun r_privileges () =              fun privileges () =
601                  StringSet.addList (StringSet.empty, r_list r_string ())                  StringSet.addList (StringSet.empty, stringlist ())
602    
603              val exports = r_exports ()              val exports = r_exports ()
604              val required = r_privileges ()              val required = privileges ()
605              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
606          in          in
607              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
# Line 693  Line 611 
611                         sublibs = sublibs }                         sublibs = sublibs }
612          end          end
613      in      in
614          SOME (SafeIO.perform { openIt = fn () => BinIO.openIn sname,          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
615                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,
616                                 work = work,                                 work = work,
617                                 cleanup = fn () => () })                                 cleanup = fn () => () })

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

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