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 384, Wed Jul 21 08:54:00 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
40        | PS of Symbol.symbol  
41        | PSN of DG.snode      infix 3 $
42        infixr 4 &
43        val op & = PU.&
44        val % = PU.%
45    
46      datatype uitem =      datatype uitem =
47          USS of SymbolSet.set          USS of SymbolSet.set
48        | US of Symbol.symbol        | US of Symbol.symbol
49        | UBN of DG.bnode        | UBN of DG.bnode
50    
51      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')      structure SNMap = BinaryMapFn
52        | compare (PS _, _) = GREATER          (struct
53        | compare (_, PS _) = LESS               type ord_key = DG.snode
54        | compare (PSS s, PSS s') = SymbolSet.compare (s, s')               fun compare (DG.SNODE n, DG.SNODE n') =
       | compare (PSS _, _) = GREATER  
       | compare (_, PSS _) = LESS  
       | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =  
55          SmlInfo.compare (#smlinfo n, #smlinfo n')          SmlInfo.compare (#smlinfo n, #smlinfo n')
   
     structure Map =  
         BinaryMapFn (struct  
                          type ord_key = pitem  
                          val compare = compare  
56          end)          end)
57    
58        val initMap = SNMap.empty
59        val SNs = { find = SNMap.find, insert = SNMap.insert }
60    
61      fun genStableInfoMap (exports, group) = let      fun genStableInfoMap (exports, group) = let
62          (* find all the exported bnodes that are in the same group: *)          (* find all the exported bnodes that are in the same group: *)
63          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 133 
133              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
134                  StableMap.insert (m, #bininfo n, (i, sy))                  StableMap.insert (m, #bininfo n, (i, sy))
135                | oneB i (_, _, m) = m                | oneB i (_, _, m) = m
136              fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
137                  (SymbolMap.foldli (oneB i) m exports, i + 1)                  (SymbolMap.foldli (oneB i) m exports, i + 1)
138              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
139    
# Line 157  Line 154 
154                  (reg, get)                  (reg, get)
155              end              end
156    
157              fun w_list w_item [] k m =              val int = PU.w_int
158                  "0" :: k m              val symbol = PU.w_symbol
159                | w_list w_item [a] k m =              val share = PU.ah_share
160                  "1" :: w_item a k m              val option = PU.w_option
161                | w_list w_item [a, b] k m =              val list = PU.w_list
162                  "2" :: w_item a (w_item b k) m              val string = PU.w_string
163                | w_list w_item [a, b, c] k m =              val bool = PU.w_bool
164                  "3" :: w_item a (w_item b (w_item c k)) m              val int = PU.w_int
165                | w_list w_item [a, b, c, d] k m =  
166                  "4" :: w_item a (w_item b (w_item c (w_item d k))) m              val symbolset = list symbol o SymbolSet.listItems
               | 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  
   
             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  
167    
168              fun w_si i k = let              val filter = option symbolset
169    
170                val sh = option bool        (* sharing *)
171    
172                fun si i = let
173                  (* FIXME: this is not a technical flaw, but perhaps one                  (* FIXME: this is not a technical flaw, but perhaps one
174                   * that deserves fixing anyway:  If we only look at spec,                   * that deserves fixing anyway:  If we only look at spec,
175                   * then we are losing information about sub-grouping                   * then we are losing information about sub-grouping
# Line 237  Line 180 
180                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
181                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
182              in              in
183                  w_string spec                  string spec & string locs & int offset & sh (SmlInfo.share i)
                    (w_string locs  
                          (w_int offset  
                                (w_sharing (SmlInfo.share i) k)))  
184              end              end
185    
186              fun w_primitive p k m =              fun primitive p =
187                  String.str (Primitive.toIdent primconf p) :: k m                  string (String.str (Primitive.toIdent primconf p))
188    
189              fun warn_relabs p abs = let              fun warn_relabs p abs = let
190                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
# Line 268  Line 208 
208                      ppb                      ppb
209              end              end
210    
211              fun w_abspath p k m =              fun abspath p = let
212                  w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))                  val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
213                                  k m              in
214                    list string pp
215                end
216    
217              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              val BN = 1
218                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let              val op $ = PU.$ BN
219                fun bn (DG.PNODE p) = "1" $ primitive p
220                  | bn (DG.BNODE { bininfo = i, ... }) = let
221                      val (n, sy) = valOf (StableMap.find (inverseMap, i))                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
222                  in                  in
223                      "b" :: w_int n (w_symbol sy k) m                      "2" $ int n & symbol sy
224                  end                  end
225    
226              fun w_pid p = w_string (Byte.bytesToString (Pid.toBytes p))              local
227                    val SN = 2
228              fun w_sn_raw (DG.SNODE n) k =                  val SBN = 3
229                  w_option w_pid (getPid (#smlinfo n))              in
230                           (w_si (#smlinfo n)                  fun sn n = let
231                                 (w_list w_sn (#localimports n)                      fun raw_sn (DG.SNODE n) =
232                                         (w_list w_fsbn (#globalimports n) k)))                          "a" $ si (#smlinfo n) & list sn (#localimports n) &
233                                  list fsbn (#globalimports n)
234              and w_sn n = w_share w_sn_raw PSN n                  in
235                        share SNs raw_sn n
236              and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m                  end
               | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m  
237    
238              and w_fsbn (f, n) k = w_filter f (w_sbn n k)                  and sbn x = let
239                        val op $ = PU.$ SBN
240                    in
241                        case x of
242                            DG.SB_BNODE n => "a" $ bn n
243                          | DG.SB_SNODE n => "b" $ sn n
244                    end
245    
246              fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)                  and fsbn (f, n) = filter f & sbn n
247                end
248    
249              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              fun impexp (s, (n, _)) = symbol s & fsbn n
250    
251              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  
252    
253              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun privileges p = list string (StringSet.listItems p)
254    
255              fun pickle_group () = let              fun group () = let
256                  fun w_sg (p, _) = w_abspath p                  fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
                 fun k0 m = []  
                 val m0 = (0, Map.empty)  
257              in              in
258                  (* Pickle the sublibs first because we need to already                  (* Pickle the sublibs first because we need to already
259                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
260                  concat (w_list w_sg sublibs                  list sg sublibs & w_exports exports & privileges required
                             (w_exports exports  
                                  (w_privileges required k0)) m0)  
261              end              end
262    
263              val pickle = pickle_group ()              val pickle = PU.pickle initMap (group ())
264              val sz = size pickle              val sz = size pickle
265              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
266    
267              fun mkStableGroup sname = let              fun mkStableGroup mksname = let
268                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
269                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
270                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
# Line 337  Line 282 
282                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
283                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
284                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
285                                                    stablename = sname,                                                    mkStablename = mksname,
286                                                    spec = spec,                                                    spec = spec,
287                                                    offset = offset,                                                    offset = offset,
288                                                    share = share,                                                    share = share,
# Line 346  Line 291 
291                                                 localimports = li,                                                 localimports = li,
292                                                 globalimports = gi }                                                 globalimports = gi }
293                          in                          in
294                                transfer_state (smlinfo, i);
295                              m := SmlInfoMap.insert (!m, smlinfo, n);                              m := SmlInfoMap.insert (!m, smlinfo, n);
296                              n                              n
297                          end                          end
# Line 376  Line 322 
322              val memberlist = rev (!members)              val memberlist = rev (!members)
323    
324              val gpath = #grouppath grec              val gpath = #grouppath grec
325              val sname = FilenamePolicy.mkStableName policy gpath              fun mksname () = FilenamePolicy.mkStableName policy gpath
326              fun work outs =              fun work outs =
327                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
328                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
329                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
330                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
331                   mkStableGroup sname)                   mkStableGroup mksname)
332          in          in
333              SOME (SafeIO.perform { openIt = fn () => AutoDir.openBinOut sname,              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
334                                     closeIt = BinIO.closeOut,                                     closeIt = BinIO.closeOut,
335                                     work = work,                                     work = work,
336                                     cleanup = fn () =>                                     cleanup = fn () =>
337                                      (OS.FileSys.remove sname handle _ => ()) })                                      (OS.FileSys.remove (mksname ())
338                                         handle _ => ()) })
339              handle exn => NONE              handle exn => NONE
340          end          end
341      in      in
# Line 399  Line 346 
346                  if not (recomp gp g) then                  if not (recomp gp g) then
347                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
348                  else let                  else let
349                      fun notStable (_, GG.GROUP { kind, ... }) =                      fun notStable (GG.GROUP { kind, ... }) =
350                          case kind of GG.STABLELIB _ => false | _ => true                          case kind of GG.STABLELIB _ => false | _ => true
351                  in                  in
352                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
# Line 408  Line 355 
355                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
356                              fun ppb pps = let                              fun ppb pps = let
357                                  fun loop [] = ()                                  fun loop [] = ()
358                                    | loop ((p, GG.GROUP { grouppath, ... })                                    | loop (GG.GROUP { grouppath, ... } :: t) =
                                           :: t) =  
359                                      (PP.add_string pps                                      (PP.add_string pps
360                                          (SrcPath.descr grouppath);                                          (SrcPath.descr grouppath);
                                      PP.add_string pps " (";  
                                      PP.add_string pps (SrcPath.descr p);  
                                      PP.add_string pps ")";  
361                                       PP.add_newline pps;                                       PP.add_newline pps;
362                                       loop t)                                       loop t)
363                              in                              in
# Line 447  Line 390 
390          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
391          val gdescr = SrcPath.descr group          val gdescr = SrcPath.descr group
392          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
393              EM.COMPLAIN (concat (gdescr :: ": " :: l)) EM.nullErrorBody              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
394                EM.nullErrorBody
395    
396          exception Format          exception Format = UU.Format
397    
398          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
399          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
400          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
401          val sname = FilenamePolicy.mkStableName policy group          fun mksname () = FilenamePolicy.mkStableName policy group
         val _ = Say.vsay ["[checking stable ", gdescr, "]\n"]  
402    
403          fun work s = let          fun work s = let
404    
# Line 479  Line 422 
422              end              end
423    
424              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
425              val pickle = bytesIn sz              val pickle = Byte.bytesToString (bytesIn sz)
426              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
427    
428              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  
   
             fun r_option r_item () =  
                 case rd () of  
                     #"n" => NONE  
                   | #"s" => SOME (r_item ())  
                   | _ => raise Format  
   
             fun r_int () = let  
                 fun loop n = let  
                     val w8 = Byte.charToByte (rd ())  
                     val n' =  
                         n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))  
                 in  
                     if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'  
                 end  
             in  
                 LargeWord.toIntX (loop 0w0)  
             end  
   
             fun r_share r_raw C unC () =  
                 case rd () of  
                     #"o" => (case IntBinaryMap.find (!m, r_int ()) of  
                                  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  
429    
430              fun r_string () = let              fun list m r = UU.r_list session m r
431                  fun loop l =              fun option m r = UU.r_option session m r
432                      case rd () of              val int = UU.r_int session
433                          #"\"" => String.implode (rev l)              fun share m r = UU.share session m r
434                        | #"\\" => loop (rd () :: l)              val string = UU.r_string session
435                        | c => loop (c :: l)              val symbol = UU.r_symbol session
436              in              val bool = UU.r_bool session
437                  loop []  
438              end              val stringListM = UU.mkMap ()
439                val symbolListM = UU.mkMap ()
440                val stringListM = UU.mkMap ()
441                val ssoM = UU.mkMap ()
442                val boolOptionM = UU.mkMap ()
443                val sgListM = UU.mkMap ()
444                val snM = UU.mkMap ()
445                val snListM = UU.mkMap ()
446                val bnM = UU.mkMap ()
447                val sbnM = UU.mkMap ()
448                val fsbnListM = UU.mkMap ()
449                val impexpListM = UU.mkMap ()
450    
451                val stringlist = list stringListM string
452    
453                fun abspath () =
454                    SrcPath.unpickle pcmode (stringlist (), group)
455                    handle SrcPath.Format => raise Format
456                         | SrcPath.BadAnchor a =>
457                           (error ["configuration anchor \"", a, "\" undefined"];
458                            raise Format)
459    
460              fun r_abspath () =              val symbollist = list symbolListM symbol
                 case SrcPath.unpickle pcmode (r_list r_string (), group) of  
                     SOME p => p  
                   | NONE => raise Format  
461    
462              val r_symbol = let              fun symbolset () =
463                  fun r_symbol_raw () = let                  SymbolSet.addList (SymbolSet.empty, symbollist ())
                     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  
464    
465              val r_ss = let              val filter = option ssoM symbolset
                 fun r_ss_raw () =  
                     SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())  
                 fun unUSS (USS s) = s  
                   | unUSS _ = raise Format  
             in  
                 r_share r_ss_raw USS unUSS  
             end  
466    
467              val r_filter = r_option r_ss              fun primitive () =
468                    valOf (Primitive.fromIdent primconf
469                              (String.sub (string (), 0)))
470                    handle _ => raise Format
471    
472              fun r_primitive () =              val sh = option boolOptionM bool
                 case Primitive.fromIdent primconf (rd ()) of  
                     NONE => raise Format  
                   | SOME p => p  
473    
474              fun r_sharing () =              fun si () = let
475                  case rd () of                  val spec = string ()
476                      #"n" => NONE                  val locs = string ()
477                    | #"t" => SOME true                  val offset = int () + offset_adjustment
478                    | #"f" => SOME false                  val share = sh ()
                   | _ => raise Format  
   
             fun r_si () = let  
                 val spec = r_string ()  
                 val locs = r_string ()  
                 val offset = r_int () + offset_adjustment  
                 val share = r_sharing ()  
479                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
480              in              in
481                  BinInfo.new { group = group,                  BinInfo.new { group = group,
482                                stablename = sname,                                mkStablename = mksname,
483                                error = error,                                error = error,
484                                spec = spec,                                spec = spec,
485                                offset = offset,                                offset = offset,
486                                share = share }                                share = share }
487              end              end
488    
489              fun r_sg () = let              fun sg () = getGroup' (abspath ())
                 val p = r_abspath ()  
             in  
                 (p, getGroup' p)  
             end  
490    
491              val sublibs = r_list r_sg ()              val sublibs = list sgListM sg ()
492    
493              fun r_bn () =              fun bn () = let
494                  case rd () of                  fun bn' #"1" = DG.PNODE (primitive ())
495                      #"p" => DG.PNODE (r_primitive ())                    | bn' #"2" = let
496                    | #"b" => let                          val n = int ()
497                          val n = r_int ()                          val sy = symbol ()
498                          val sy = r_symbol ()                          val GG.GROUP { exports = slexp, ... } =
                         val (_, GG.GROUP { exports = slexp, ... }) =  
499                              List.nth (sublibs, n) handle _ => raise Format                              List.nth (sublibs, n) handle _ => raise Format
500                      in                      in
501                          case SymbolMap.find (slexp, sy) of                          case SymbolMap.find (slexp, sy) of
502                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
503                            | _ => raise Format                            | _ => raise Format
504                      end                      end
505                    | _ => raise Format                    | bn' _ = raise Format
506                in
507              fun r_pid () = Pid.fromBytes (Byte.stringToBytes (r_string ()))                  share bnM bn'
508                end
509    
510              (* this is the place where what used to be an              (* this is the place where what used to be an
511               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
512              fun r_sn_raw () = let              fun sn () = let
513                  val popt = r_option r_pid ()                  fun sn' #"a" =
514                  val i = r_si ()                      DG.BNODE { bininfo = si (),
515              in                                 localimports = snlist (),
516                  warmup (i, popt);                                 globalimports = fsbnlist () }
517                  DG.BNODE { bininfo = i,                    | sn' _ = raise Format
518                             localimports = r_list r_sn (),              in
519                             globalimports = r_list r_fsbn () }                  share snM sn'
520              end              end
521    
522              and r_sn () =              and snlist () = list snListM sn ()
                 r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()  
523    
524              (* this one changes from farsbnode to plain farbnode *)              (* this one changes from farsbnode to plain farbnode *)
525              and r_sbn () =              and sbn () = let
526                  case rd () of                  fun sbn' #"a" = bn ()
527                      #"b" => r_bn ()                    | sbn' #"b" = sn ()
528                    | #"s" => r_sn ()                    | sbn' _ = raise Format
529                    | _ => raise Format              in
530                    share sbnM sbn'
531                end
532    
533              and r_fsbn () = (r_filter (), r_sbn ())              and fsbn () = (filter (), sbn ())
534    
535              fun r_impexp () = let              and fsbnlist () = list fsbnListM fsbn ()
536                  val sy = r_symbol ()  
537                  val (f, n) = r_fsbn ()  (* really reads farbnodes! *)              fun impexp () = let
538                    val sy = symbol ()
539                    val (f, n) = fsbn ()    (* really reads farbnodes! *)
540                  val e = bn2env n                  val e = bn2env n
541                  (* put a filter in front to avoid having the FCTENV being                  (* put a filter in front to avoid having the FCTENV being
542                   * queried needlessly (this avoids spurious module loadings) *)                   * queried needlessly (this avoids spurious module loadings) *)
# Line 676  Line 545 
545                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
546              end              end
547    
548                val impexplist = list impexpListM impexp
549    
550              fun r_exports () =              fun r_exports () =
551                  foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())                  foldl SymbolMap.insert' SymbolMap.empty (impexplist ())
552    
553                val stringlist = list stringListM string
554    
555              fun r_privileges () =              fun privileges () =
556                  StringSet.addList (StringSet.empty, r_list r_string ())                  StringSet.addList (StringSet.empty, stringlist ())
557    
558              val exports = r_exports ()              val exports = r_exports ()
559              val required = r_privileges ()              val required = privileges ()
560              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
561          in          in
562              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
# Line 693  Line 566 
566                         sublibs = sublibs }                         sublibs = sublibs }
567          end          end
568      in      in
569          SOME (SafeIO.perform { openIt = fn () => BinIO.openIn sname,          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
570                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,
571                                 work = work,                                 work = work,
572                                 cleanup = fn () => () })                                 cleanup = fn () => () })

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

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