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 393, Fri Aug 6 08:41: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 SSMap = BinaryMapFn
39          PSS of SymbolSet.set          (struct
40        | PS of Symbol.symbol               type ord_key = SymbolSet.set
41        | PSN of DG.snode               val compare = SymbolSet.compare
42            end)
     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')  
43    
44      structure Map =      structure SNMap = BinaryMapFn
45          BinaryMapFn (struct          (struct
46                           type ord_key = pitem               type ord_key = DG.snode
47                           val compare = compare               fun compare (DG.SNODE n, DG.SNODE n') =
48                     SmlInfo.compare (#smlinfo n, #smlinfo n')
49          end)          end)
50    
51        type 'a maps = { ss: 'a SSMap.map, sn: 'a SNMap.map }
52    
53        val initMap = { ss = SSMap.empty, sn = SNMap.empty }
54    
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      fun genStableInfoMap (exports, group) = let
75          (* find all the exported bnodes that are in the same group: *)          (* find all the exported bnodes that are in the same group: *)
76          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 146 
146              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
147                  StableMap.insert (m, #bininfo n, (i, sy))                  StableMap.insert (m, #bininfo n, (i, sy))
148                | oneB i (_, _, m) = m                | oneB i (_, _, m) = m
149              fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
150                  (SymbolMap.foldli (oneB i) m exports, i + 1)                  (SymbolMap.foldli (oneB i) m exports, i + 1)
151              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
152    
# Line 157  Line 167 
167                  (reg, get)                  (reg, get)
168              end              end
169    
170              fun w_list w_item [] k m =              val int = PU.w_int
171                  "0" :: k m              val symbol = PSym.w_symbol
172                | w_list w_item [a] k m =              val share = PU.ah_share
173                  "1" :: w_item a k m              val option = PU.w_option
174                | w_list w_item [a, b] k m =              val list = PU.w_list
175                  "2" :: w_item a (w_item b k) m              val string = PU.w_string
176                | w_list w_item [a, b, c] k m =              val bool = PU.w_bool
177                  "3" :: w_item a (w_item b (w_item c k)) m              val int = PU.w_int
178                | w_list w_item [a, b, c, d] k m =  
179                  "4" :: w_item a (w_item b (w_item c (w_item d k))) m              fun symbolset ss = let
180                | w_list w_item (a :: b :: c :: d :: e :: r) k m =                  val op $ = PU.$ SS
181                  "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)
182                                                       (w_list w_item r k))))) m              in
183                    share SSs raw_ss ss
184              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  
185    
186              fun w_si i k = let              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                  (* FIXME: this is not a technical flaw, but perhaps one
194                   * that deserves fixing anyway:  If we only look at spec,                   * that deserves fixing anyway:  If we only look at spec,
195                   * then we are losing information about sub-grouping                   * then we are losing information about sub-grouping
# Line 236  Line 199 
199                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
200                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
201                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
202                    val sh_mode = SmlInfo.sh_mode i
203                    val op $ = PU.$ SI
204              in              in
205                  w_string spec                  "s" $ string spec & string locs & int offset & shm sh_mode
                    (w_string locs  
                          (w_int offset  
                                (w_sharing (SmlInfo.share i) k)))  
206              end              end
207    
208              fun w_primitive p k m =              fun primitive p =
209                  String.str (Primitive.toIdent primconf p) :: k m                  string (String.str (Primitive.toIdent primconf p))
210    
211              fun warn_relabs p abs = let              fun warn_relabs p abs = let
212                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
# Line 268  Line 230 
230                      ppb                      ppb
231              end              end
232    
233              fun w_abspath p k m =              fun abspath p = let
234                  w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))                  val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
235                                  k m              in
236                    list string pp
237                end
238    
239              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              val op $ = PU.$ BN
240                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let              fun bn (DG.PNODE p) = "1" $ primitive p
241                  | bn (DG.BNODE { bininfo = i, ... }) = let
242                      val (n, sy) = valOf (StableMap.find (inverseMap, i))                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
243                  in                  in
244                      "b" :: w_int n (w_symbol sy k) m                      "2" $ int n & symbol sy
245                  end                  end
246    
247              fun w_pid p = w_string (Byte.bytesToString (Pid.toBytes p))              fun sn n = let
248                    fun raw_sn (DG.SNODE n) =
249              fun w_sn_raw (DG.SNODE n) k =                      "a" $ si (#smlinfo n) & list sn (#localimports n) &
250                  w_option w_pid (getPid (#smlinfo n))                      list fsbn (#globalimports n)
251                           (w_si (#smlinfo n)              in
252                                 (w_list w_sn (#localimports n)                  share SNs raw_sn n
253                                         (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  
254    
255              and w_fsbn (f, n) k = w_filter f (w_sbn n k)              and sbn x = let
256                    val op $ = PU.$ SBN
257                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_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)              and fsbn (f, n) = let
264                    val op $ = PU.$ FSBN
265                in
266                    "f" $ filter f & sbn n
267                end
268    
269              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              fun impexp (s, (n, _)) = let
270                    val op $ = PU.$ IMPEXP
271                in
272                    "i" $ symbol s & fsbn n
273                end
274    
275              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  
276    
277              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun privileges p = list string (StringSet.listItems p)
278    
279              fun pickle_group () = let              fun group () = let
280                  fun w_sg (p, _) = w_abspath p                  fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
                 fun k0 m = []  
                 val m0 = (0, Map.empty)  
281              in              in
282                  (* Pickle the sublibs first because we need to already                  (* Pickle the sublibs first because we need to already
283                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
284                  concat (w_list w_sg sublibs                  list sg sublibs & w_exports exports & privileges required
                             (w_exports exports  
                                  (w_privileges required k0)) m0)  
285              end              end
286    
287              val pickle = pickle_group ()              val pickle = PU.pickle (group ())
288              val sz = size pickle              val sz = size pickle
289              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
290    
291              fun mkStableGroup sname = let              fun mkStableGroup mksname = let
292                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
293                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
294                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
# Line 333  Line 302 
302                              val spec = SrcPath.specOf sourcepath                              val spec = SrcPath.specOf sourcepath
303                              val offset =                              val offset =
304                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
305                              val share = SmlInfo.share smlinfo                              val sh_mode = SmlInfo.sh_mode smlinfo
306                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
307                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
308                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
309                                                    stablename = sname,                                                    mkStablename = mksname,
310                                                    spec = spec,                                                    spec = spec,
311                                                    offset = offset,                                                    offset = offset,
312                                                    share = share,                                                    sh_mode = sh_mode,
313                                                    error = error }                                                    error = error }
314                              val n = DG.BNODE { bininfo = i,                              val n = DG.BNODE { bininfo = i,
315                                                 localimports = li,                                                 localimports = li,
316                                                 globalimports = gi }                                                 globalimports = gi }
317                          in                          in
318                                transfer_state (smlinfo, i);
319                              m := SmlInfoMap.insert (!m, smlinfo, n);                              m := SmlInfoMap.insert (!m, smlinfo, n);
320                              n                              n
321                          end                          end
# Line 376  Line 346 
346              val memberlist = rev (!members)              val memberlist = rev (!members)
347    
348              val gpath = #grouppath grec              val gpath = #grouppath grec
349              val sname = FilenamePolicy.mkStableName policy gpath              fun mksname () = FilenamePolicy.mkStableName policy gpath
350              fun work outs =              fun work outs =
351                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
352                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
353                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
354                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
355                   mkStableGroup sname)                   mkStableGroup mksname)
356          in          in
357              SOME (SafeIO.perform { openIt = fn () => AutoDir.openBinOut sname,              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
358                                     closeIt = BinIO.closeOut,                                     closeIt = BinIO.closeOut,
359                                     work = work,                                     work = work,
360                                     cleanup = fn () =>                                     cleanup = fn () =>
361                                      (OS.FileSys.remove sname handle _ => ()) })                                      (OS.FileSys.remove (mksname ())
362                                         handle _ => ()) })
363              handle exn => NONE              handle exn => NONE
364          end          end
365      in      in
# Line 399  Line 370 
370                  if not (recomp gp g) then                  if not (recomp gp g) then
371                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
372                  else let                  else let
373                      fun notStable (_, GG.GROUP { kind, ... }) =                      fun notStable (GG.GROUP { kind, ... }) =
374                          case kind of GG.STABLELIB _ => false | _ => true                          case kind of GG.STABLELIB _ => false | _ => true
375                  in                  in
376                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
# Line 408  Line 379 
379                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
380                              fun ppb pps = let                              fun ppb pps = let
381                                  fun loop [] = ()                                  fun loop [] = ()
382                                    | loop ((p, GG.GROUP { grouppath, ... })                                    | loop (GG.GROUP { grouppath, ... } :: t) =
                                           :: t) =  
383                                      (PP.add_string pps                                      (PP.add_string pps
384                                          (SrcPath.descr grouppath);                                          (SrcPath.descr grouppath);
                                      PP.add_string pps " (";  
                                      PP.add_string pps (SrcPath.descr p);  
                                      PP.add_string pps ")";  
385                                       PP.add_newline pps;                                       PP.add_newline pps;
386                                       loop t)                                       loop t)
387                              in                              in
# Line 447  Line 414 
414          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
415          val gdescr = SrcPath.descr group          val gdescr = SrcPath.descr group
416          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
417              EM.COMPLAIN (concat (gdescr :: ": " :: l)) EM.nullErrorBody              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
418                EM.nullErrorBody
419    
420          exception Format          exception Format = UU.Format
421    
422          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
423          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
424          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
425          val sname = FilenamePolicy.mkStableName policy group          fun mksname () = FilenamePolicy.mkStableName policy group
         val _ = Say.vsay ["[checking stable ", gdescr, "]\n"]  
426    
427          fun work s = let          fun work s = let
428    
# Line 479  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  
   
             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  
453    
454              fun r_option r_item () =              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                      #"n" => NONE              val int = UU.r_int session
457                    | #"s" => SOME (r_item ())              fun share m r = UU.share session m r
458                    | _ => raise Format              fun nonshare r = UU.nonshare session r
459                val string = UU.r_string session
460                val symbol = UnpickleSymbol.r_symbol (session, string)
461                val bool = UU.r_bool session
462    
463                val stringListM = UU.mkMap ()
464                val symbolListM = UU.mkMap ()
465                val stringListM = UU.mkMap ()
466                val ssM = UU.mkMap ()
467                val ssoM = UU.mkMap ()
468                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              fun r_int () = let              val symbollist = list symbolListM symbol
                 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  
490    
491              fun r_string () = let              fun symbolset () = let
492                  fun loop l =                  fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
493                      case rd () of                    | s _ = raise Format
                         #"\"" => String.implode (rev l)  
                       | #"\\" => loop (rd () :: l)  
                       | c => loop (c :: l)  
494              in              in
495                  loop []                  share ssM s
496              end              end
497    
498              fun r_abspath () =              val filter = option ssoM symbolset
                 case SrcPath.unpickle pcmode (r_list r_string (), group) of  
                     SOME p => p  
                   | NONE => raise Format  
499    
500              val r_symbol = let              fun primitive () =
501                  fun r_symbol_raw () = let                  valOf (Primitive.fromIdent primconf
502                      val (ns, first) =                            (String.sub (string (), 0)))
503                          case rd () of                  handle _ => raise Format
                             #"'" => (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  
504    
505              val r_ss = let              fun shm () = let
506                  fun r_ss_raw () =                  fun s #"a" = Sharing.SHARE true
507                      SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                    | s #"b" = Sharing.SHARE false
508                  fun unUSS (USS s) = s                    | s #"c" = Sharing.DONTSHARE
509                    | unUSS _ = raise Format                    | s _ = raise Format
510              in              in
511                  r_share r_ss_raw USS unUSS                  nonshare s
512              end              end
513    
514              val r_filter = r_option r_ss              fun si () = let
515                    fun s #"s" =
516              fun r_primitive () =                      let val spec = string ()
517                  case Primitive.fromIdent primconf (rd ()) of                          val locs = string ()
518                      NONE => raise Format                          val offset = int () + offset_adjustment
519                    | SOME p => p                          val sh_mode = shm ()
   
             fun r_sharing () =  
                 case rd () of  
                     #"n" => NONE  
                   | #"t" => SOME true  
                   | #"f" => SOME false  
                   | _ => raise Format  
   
             fun r_si () = let  
                 val spec = r_string ()  
                 val locs = r_string ()  
                 val offset = r_int () + offset_adjustment  
                 val share = r_sharing ()  
520                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
521              in              in
522                  BinInfo.new { group = group,                  BinInfo.new { group = group,
523                                stablename = sname,                                        mkStablename = mksname,
524                                error = error,                                error = error,
525                                spec = spec,                                spec = spec,
526                                offset = offset,                                offset = offset,
527                                share = share }                                        sh_mode = sh_mode }
528              end              end
529                      | s _ = raise Format
             fun r_sg () = let  
                 val p = r_abspath ()  
530              in              in
531                  (p, getGroup' p)                  share siM s
532              end              end
533    
534              val sublibs = r_list r_sg ()              fun sg () = getGroup' (abspath ())
535    
536              fun r_bn () =              val sublibs = list sgListM sg ()
537                  case rd () of  
538                      #"p" => DG.PNODE (r_primitive ())              fun bn () = let
539                    | #"b" => let                  fun bn' #"1" = DG.PNODE (primitive ())
540                          val n = r_int ()                    | bn' #"2" = let
541                          val sy = r_symbol ()                          val n = int ()
542                          val (_, GG.GROUP { exports = slexp, ... }) =                          val sy = symbol ()
543                            val GG.GROUP { exports = slexp, ... } =
544                              List.nth (sublibs, n) handle _ => raise Format                              List.nth (sublibs, n) handle _ => raise Format
545                      in                      in
546                          case SymbolMap.find (slexp, sy) of                          case SymbolMap.find (slexp, sy) of
547                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
548                            | _ => raise Format                            | _ => raise Format
549                      end                      end
550                    | _ => raise Format                    | bn' _ = raise Format
551                in
552              fun r_pid () = Pid.fromBytes (Byte.stringToBytes (r_string ()))                  share bnM bn'
553                end
554    
555              (* this is the place where what used to be an              (* this is the place where what used to be an
556               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
557              fun r_sn_raw () = let              fun sn () = let
558                  val popt = r_option r_pid ()                  fun sn' #"a" =
559                  val i = r_si ()                      DG.BNODE { bininfo = si (),
560              in                                 localimports = snlist (),
561                  warmup (i, popt);                                 globalimports = fsbnlist () }
562                  DG.BNODE { bininfo = i,                    | sn' _ = raise Format
563                             localimports = r_list r_sn (),              in
564                             globalimports = r_list r_fsbn () }                  share snM sn'
565              end              end
566    
567              and r_sn () =              and snlist () = list snListM sn ()
                 r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()  
568    
569              (* this one changes from farsbnode to plain farbnode *)              (* this one changes from farsbnode to plain farbnode *)
570              and r_sbn () =              and sbn () = let
571                  case rd () of                  fun sbn' #"a" = bn ()
572                      #"b" => r_bn ()                    | sbn' #"b" = sn ()
573                    | #"s" => r_sn ()                    | sbn' _ = raise Format
574                    | _ => raise Format              in
575                    share sbnM sbn'
576                end
577    
578                and fsbn () = let
579                    fun f #"f" = (filter (), sbn ())
580                      | f _ = raise Format
581                in
582                    share fsbnM f
583                end
584    
585              and r_fsbn () = (r_filter (), r_sbn ())              and fsbnlist () = list fsbnListM fsbn ()
586    
587              fun r_impexp () = let              fun impexp () = let
588                  val sy = r_symbol ()                  fun ie #"i" =
589                  val (f, n) = r_fsbn ()  (* really reads farbnodes! *)                      let val sy = symbol ()
590                            val (f, n) = fsbn () (* really reads farbnodes! *)
591                  val e = bn2env n                  val e = bn2env n
592                  (* put a filter in front to avoid having the FCTENV being                          (* put a filter in front to avoid having the FCTENV
593                   * queried needlessly (this avoids spurious module loadings) *)                           * being queried needlessly (this avoids spurious
594                             * module loadings) *)
595                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
596              in              in
597                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)                          (* coerce to farsbnodes *)
598                            (sy, ((f, DG.SB_BNODE n), e'))
599                        end
600                      | ie _ = raise Format
601                in
602                    share impexpM ie
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                val stringlist = list stringListM string
611    
612              fun r_privileges () =              fun privileges () =
613                  StringSet.addList (StringSet.empty, r_list r_string ())                  StringSet.addList (StringSet.empty, stringlist ())
614    
615              val exports = r_exports ()              val exports = r_exports ()
616              val required = r_privileges ()              val required = privileges ()
617              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
618          in          in
619              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
# Line 693  Line 623 
623                         sublibs = sublibs }                         sublibs = sublibs }
624          end          end
625      in      in
626          SOME (SafeIO.perform { openIt = fn () => BinIO.openIn sname,          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
627                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,
628                                 work = work,                                 work = work,
629                                 cleanup = fn () => () })                                 cleanup = fn () => () })

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

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