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 384, Wed Jul 21 08:54:00 1999 UTC revision 403, Tue Aug 31 07:44:29 1999 UTC
# Line 14  Line 14 
14      structure GP = GeneralParams      structure GP = GeneralParams
15      structure E = GenericVC.Environment      structure E = GenericVC.Environment
16      structure Pid = GenericVC.PersStamps      structure Pid = GenericVC.PersStamps
17        structure P = PickMod
18      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv      structure UP = UnpickMod
19      type recomp = GP.info -> GG.group -> bool      structure E = GenericVC.Environment
     type pid = Pid.persstamp  
20  in  in
21    
22  signature STABILIZE = sig  signature STABILIZE = sig
23    
24      val loadStable :      val loadStable :
25          GP.info * (SrcPath.t -> GG.group option) * bool ref ->          GP.info -> { getGroup: SrcPath.t -> GG.group option,
26          SrcPath.t -> GG.group option                       anyerrors: bool ref }
27            -> SrcPath.t -> GG.group option
28    
29      val stabilize :      val stabilize :
30          GP.info -> { group: GG.group, anyerrors: bool ref } ->          GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
         GG.group option  
31  end  end
32    
33  functor StabilizeFn (val bn2statenv : statenvgetter  functor StabilizeFn (val destroy_state : GP.info -> SmlInfo.info -> unit
34                       val transfer_state : SmlInfo.info * BinInfo.info -> unit                       structure MachDepVC : MACHDEP_VC
35                       val recomp : recomp) :> STABILIZE = struct                       val recomp : GP.info -> GG.group ->
36                             (SmlInfo.info -> MachDepVC.Binfile.bfContent) option
37      structure PU = PickleUtil                       val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =
38      structure UU = UnpickleUtil  struct
39    
40      infix 3 $      structure BF = MachDepVC.Binfile
     infixr 4 &  
     val op & = PU.&  
     val % = PU.%  
41    
42      datatype uitem =      structure SSMap = BinaryMapFn
43          USS of SymbolSet.set          (struct
44        | US of Symbol.symbol               type ord_key = SymbolSet.set
45        | UBN of DG.bnode               val compare = SymbolSet.compare
46            end)
47    
48      structure SNMap = BinaryMapFn      structure SNMap = BinaryMapFn
49          (struct          (struct
# Line 55  Line 52 
52                   SmlInfo.compare (#smlinfo n, #smlinfo n')                   SmlInfo.compare (#smlinfo n, #smlinfo n')
53          end)          end)
54    
55      val initMap = SNMap.empty      structure PU = PickleUtil
56      val SNs = { find = SNMap.find, insert = SNMap.insert }      structure UU = UnpickleUtil
57    
58      fun genStableInfoMap (exports, group) = let      type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
59          (* find all the exported bnodes that are in the same group: *)  
60          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let      val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
61              val i = #bininfo b  
62          in      val lifter =
63              if SrcPath.compare (BinInfo.group i, group) = EQUAL then          { extract = fn (m: map) => #pm m,
64                  IntBinaryMap.insert (m, BinInfo.offset i, n)            patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
65              else m  
66          end      infix 3 $
67            | add (_, m) = m      infixr 4 &
68      in      val op & = PU.&
69          SymbolMap.foldl add IntBinaryMap.empty exports      val % = PU.%
70      end  
71        (* type info *)
72        val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
73    
74        val SSs =
75            { find = fn (m: map, k) => SSMap.find (#ss m, k),
76              insert = fn ({ ss, sn, pm }, k, v) =>
77                           { sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
78        val SNs =
79            { find = fn (m: map, k) => SNMap.find (#sn m, k),
80              insert = fn ({ ss, sn, pm }, k, v) =>
81                           { ss = ss, sn = SNMap.insert (sn, k, v), pm = pm } }
82    
83      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
84    
85          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
86          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
87            val pervasive = #pervasive (#param gp)
88    
89          val grouppath = #grouppath grec          val grouppath = #grouppath grec
90    
91          fun doit wrapped = let          fun doit (wrapped, getBFC) = let
92    
93                fun writeBFC s i = BF.write { stream = s,
94                                              content = getBFC i,
95                                              nopickle = true }
96                fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }
97    
98                val _ =
99                    Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
100    
101              val _ =              val _ =
102                  if StringSet.isEmpty wrapped then ()                  if StringSet.isEmpty wrapped then ()
# Line 88  Line 105 
105                               :: map (fn s => ("  " ^ s ^ "\n"))                               :: map (fn s => ("  " ^ s ^ "\n"))
106                                      (StringSet.listItems wrapped))                                      (StringSet.listItems wrapped))
107    
             val bname = SmlInfo.binname  
             val bsz = OS.FileSys.fileSize o bname  
   
             fun cpb s i = let  
                 val N = 4096  
                 fun copy ins = let  
                     fun cp () =  
                         if BinIO.endOfStream ins then ()  
                         else (BinIO.output (s, BinIO.inputN (ins, N));  
                               cp ())  
                 in  
                     cp ()  
                 end  
             in  
                 SafeIO.perform { openIt = fn () => BinIO.openIn (bname i),  
                                  closeIt = BinIO.closeIn,  
                                  work = copy,  
                                  cleanup = fn () => () }  
             end  
   
108              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
109    
110              val exports = #exports grec              val exports = #exports grec
# Line 117  Line 114 
114              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
115               *  - It starts with the size s of the pickled dependency               *  - It starts with the size s of the pickled dependency
116               *    graph. This size itself is written as four-byte string.               *    graph. This size itself is written as four-byte string.
117                 *  - The size t of the pickled environment for the entire
118                 *    library (using the pickleEnvN interface of the pickler)
119                 *    in the same format as s.
120               *  - The pickled dependency graph.  This graph contains               *  - The pickled dependency graph.  This graph contains
121               *    integer offsets of the binfiles for the individual ML               *    integer offsets of the binfiles for the individual ML
122               *    members. These offsets need to be adjusted by adding               *    members. These offsets need to be adjusted by adding
123               *    s + 4. The pickled dependency graph also contains integer               *    s + t + 8. The pickled dependency graph also contains integer
124               *    offsets relative to other stable groups.  These offsets               *    offsets relative to other stable groups.  These offsets
125               *    need no further adjustment.               *    need no further adjustment.
126               *  - Individual binfile contents (concatenated).               *  - The pickled environment (list).  To be unpickled using
127                 *    unpickleEnvN.
128                 *  - Individual binfile contents (concatenated) but without
129                 *    their static environments.
130               *)               *)
131    
132              (* Here we build a mapping that maps each BNODE to a number              (* Here we build a mapping that maps each BNODE to a number
133               * representing the sub-library that it came from and a               * representing the sub-library that it came from and a
134               * representative symbol that can be used to find the BNODE               * representative symbol that can be used to find the BNODE
135               * within the exports of that library *)               * within the exports of that library *)
136              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
137                  StableMap.insert (m, #bininfo n, (i, sy))                  StableMap.insert (m, #bininfo n, (i, sy))
138                | oneB i (_, _, m) = m                | oneB i (_, _, m) = m
139              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
# Line 154  Line 157 
157                  (reg, get)                  (reg, get)
158              end              end
159    
160                (* Collect all BNODEs and PNODEs that we see and build
161                 * a context suitable for P.envPickler. *)
162                fun mkContext () = let
163                    fun lst f [] k s = k s
164                      | lst f (h :: t) k s = f h (lst f t k) s
165    
166                    fun sbn n k (s as (prims, bnodes, snodes)) =
167                        case n of
168                            DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let
169                                val str = String.str (Primitive.toIdent primconf p)
170                                val prims' = StringMap.insert (prims, str, statenv)
171                            in
172                                k (prims', bnodes, snodes)
173                            end
174                          | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
175                                val { statenv, ... } = ii
176                                val nsy = valOf (StableMap.find (inverseMap, i))
177                                val bnodes' =
178                                    StableMap.insert (bnodes, i, (nsy, statenv))
179                            in
180                                k (prims, bnodes', snodes)
181                            end
182                          | DG.SB_SNODE n => sn n k s
183    
184                    and sn (DG.SNODE n) k (prims, bnodes, snodes) = let
185                        val i = #smlinfo n
186                        val li = #localimports n
187                        val gi = #globalimports n
188                    in
189                        if SmlInfoSet.member (snodes, i) then
190                            k (prims, bnodes, snodes)
191                        else let
192                            val snodes' = SmlInfoSet.add (snodes, i)
193                        in
194                            lst sn li (lst fsbn gi k) (prims, bnodes, snodes')
195                        end
196                    end
197    
198                    and fsbn (_, n) k s = sbn n k s
199    
200                    fun impexp (n, _) k s = fsbn n k s
201    
202                    val (prims, bnodes) =
203                        lst impexp (SymbolMap.listItems exports)
204                            (fn (prims, bnodes, _) => (prims, bnodes))
205                            (StringMap.empty, StableMap.empty, SmlInfoSet.empty)
206    
207                    val priml = StringMap.listItemsi prims
208                    val bnodel = StableMap.listItems bnodes
209    
210                    fun cvt lk id = let
211                        fun nloop [] = NONE
212                          | nloop ((k, ge) :: t) =
213                            (case lk (ge ()) id of
214                                 SOME _ => SOME (P.NodeKey k)
215                               | NONE => nloop t)
216                        fun ploop [] = nloop bnodel
217                          | ploop ((k, ge) :: t) =
218                            (case lk (ge ()) id of
219                                 SOME _ => SOME (P.PrimKey k)
220                               | NONE => ploop t)
221                    in
222                        case lk (E.staticPart pervasive) id of
223                            NONE => ploop priml
224                          | SOME _ => SOME (P.PrimKey "pv")
225                    end
226                in
227                    { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
228                      lookSIG = cvt GenericVC.CMStaticEnv.lookSIG,
229                      lookFCT = cvt GenericVC.CMStaticEnv.lookFCT,
230                      lookFSIG = cvt GenericVC.CMStaticEnv.lookFSIG,
231                      lookTYC = cvt GenericVC.CMStaticEnv.lookTYC,
232                      lookEENV = cvt GenericVC.CMStaticEnv.lookEENV }
233                end
234    
235                (* make the picklers for static and symbolic environments;
236                 * lift them so we can use them here... *)
237                val envContext = mkContext ()
238    
239                val env_orig = P.envPickler envContext
240                val env = PU.lift_pickler lifter env_orig
241                val symenv_orig = P.symenvPickler
242                val symenv = PU.lift_pickler lifter symenv_orig
243                val lazy_env = PU.w_lazy env
244                val lazy_symenv = PU.w_lazy symenv
245    
246              val int = PU.w_int              val int = PU.w_int
247              val symbol = PU.w_symbol              val symbol = PickleSymPid.w_symbol
248                val pid = PickleSymPid.w_pid
249              val share = PU.ah_share              val share = PU.ah_share
250              val option = PU.w_option              val option = PU.w_option
251              val list = PU.w_list              val list = PU.w_list
# Line 163  Line 253 
253              val bool = PU.w_bool              val bool = PU.w_bool
254              val int = PU.w_int              val int = PU.w_int
255    
256              val symbolset = list symbol o SymbolSet.listItems              fun symbolset ss = let
257                    val op $ = PU.$ SS
258                    fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
259                in
260                    share SSs raw_ss ss
261                end
262    
263              val filter = option symbolset              val filter = option symbolset
264    
265              val sh = option bool        (* sharing *)              fun shm (Sharing.SHARE true) = %SHM "a"
266                  | shm (Sharing.SHARE false) = %SHM "b"
267                  | shm Sharing.DONTSHARE = %SHM "c"
268    
269              fun si i = let              fun si i = let
270                  (* FIXME: this is not a technical flaw, but perhaps one                  (* FIXME: this is not a technical flaw, but perhaps one
# Line 178  Line 275 
275                   * operation of CM itself. *)                   * operation of CM itself. *)
276                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
277                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
278                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, sizeBFC i)
279                    val sh_mode = SmlInfo.sh_mode i
280                    val op $ = PU.$ SI
281              in              in
282                  string spec & string locs & int offset & sh (SmlInfo.share i)                  "s" $ string spec & string locs & int offset & shm sh_mode
283              end              end
284    
285              fun primitive p =              fun primitive p =
# Line 214  Line 313 
313                  list string pp                  list string pp
314              end              end
315    
             val BN = 1  
             val op $ = PU.$ BN  
             fun bn (DG.PNODE p) = "1" $ primitive p  
               | bn (DG.BNODE { bininfo = i, ... }) = let  
                     val (n, sy) = valOf (StableMap.find (inverseMap, i))  
                 in  
                     "2" $ int n & symbol sy  
                 end  
   
             local  
                 val SN = 2  
                 val SBN = 3  
             in  
316                  fun sn n = let                  fun sn n = let
317                    val op $ = PU.$ SN
318                      fun raw_sn (DG.SNODE n) =                      fun raw_sn (DG.SNODE n) =
319                          "a" $ si (#smlinfo n) & list sn (#localimports n) &                          "a" $ si (#smlinfo n) & list sn (#localimports n) &
320                                list fsbn (#globalimports n)                                list fsbn (#globalimports n)
# Line 235  Line 322 
322                      share SNs raw_sn n                      share SNs raw_sn n
323                  end                  end
324    
325                (* Here we ignore the interface info because we will not
326                 * need it anymore when we unpickle. *)
327                  and sbn x = let                  and sbn x = let
328                      val op $ = PU.$ SBN                      val op $ = PU.$ SBN
329                  in                  in
330                      case x of                      case x of
331                          DG.SB_BNODE n => "a" $ bn n                      DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
332                        | DG.SB_SNODE n => "b" $ sn n                          "1" $ primitive p
333                      | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
334                            val (n, sy) = valOf (StableMap.find (inverseMap, i))
335                        in
336                            "2" $ int n & symbol sy
337                        end
338                      | DG.SB_SNODE n => "3" $ sn n
339                  end                  end
340    
341                  and fsbn (f, n) = filter f & sbn n              and fsbn (f, n) = let
342                    val op $ = PU.$ FSBN
343                in
344                    "f" $ filter f & sbn n
345              end              end
346    
347              fun impexp (s, (n, _)) = symbol s & fsbn n              (* Here is the place where we need to write interface info. *)
348                fun impexp (s, (n, _)) = let
349                    val op $ = PU.$ IMPEXP
350                    val { statenv, symenv, statpid, sympid } =
351                        case n of
352                            (_, DG.SB_BNODE (_, ii)) => ii
353                          | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
354                                getII smlinfo
355                in
356                    "i" $ symbol s & fsbn n &
357                          lazy_env (GenericVC.CoerceEnv.es2bs o statenv) &
358                          lazy_symenv symenv &
359                          pid statpid &
360                          pid sympid
361                end
362    
363              fun w_exports e = list impexp (SymbolMap.listItemsi e)              fun w_exports e = list impexp (SymbolMap.listItemsi e)
364    
# Line 260  Line 372 
372                  list sg sublibs & w_exports exports & privileges required                  list sg sublibs & w_exports exports & privileges required
373              end              end
374    
375              val pickle = PU.pickle initMap (group ())              val dg_pickle =
376              val sz = size pickle                  Byte.stringToBytes (PU.pickle emptyMap (group ()))
377              val offset_adjustment = sz + 4  
378                val dg_sz = Word8Vector.length dg_pickle
379    
380                val offset_adjustment = dg_sz + 4
381    
382              fun mkStableGroup mksname = let              fun mkStableGroup mksname = let
383                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
# Line 278  Line 393 
393                              val spec = SrcPath.specOf sourcepath                              val spec = SrcPath.specOf sourcepath
394                              val offset =                              val offset =
395                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
396                              val share = SmlInfo.share smlinfo                              val sh_mode = SmlInfo.sh_mode smlinfo
397                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
398                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
399                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
400                                                    mkStablename = mksname,                                                    mkStablename = mksname,
401                                                    spec = spec,                                                    spec = spec,
402                                                    offset = offset,                                                    offset = offset,
403                                                    share = share,                                                    sh_mode = sh_mode,
404                                                    error = error }                                                    error = error }
405                              val n = DG.BNODE { bininfo = i,                              val n = DG.BNODE { bininfo = i,
406                                                 localimports = li,                                                 localimports = li,
407                                                 globalimports = gi }                                                 globalimports = gi }
408                          in                          in
409                              transfer_state (smlinfo, i);                              destroy_state gp smlinfo;
410                              m := SmlInfoMap.insert (!m, smlinfo, n);                              m := SmlInfoMap.insert (!m, smlinfo, n);
411                              n                              n
412                          end                          end
413    
414                  and sbn (DG.SB_SNODE n) = sn n                  and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
415                    | sbn (DG.SB_BNODE n) = n                      let val ii = getII i
416                        in
417                            (sn n, ii)
418                        end
419                      | sbn (DG.SB_BNODE (n, ii)) = (n, ii)
420    
421                  and fsbn (f, n) = (f, sbn n)                  and fsbn (f, n) = (f, #1 (sbn n))
422    
423                  fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)                  fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
424    
425                  val exports = SymbolMap.map impexp (#exports grec)                  val exports = SymbolMap.map impexp (#exports grec)
                 val simap = genStableInfoMap (exports, grouppath)  
426              in              in
427                  GG.GROUP { exports = exports,                  GG.GROUP { exports = exports,
428                             kind = GG.STABLELIB simap,                             kind = GG.STABLELIB,
429                             required = required,                             required = required,
430                             grouppath = grouppath,                             grouppath = grouppath,
431                             sublibs = sublibs }                             sublibs = sublibs }
# Line 321  Line 439 
439              end              end
440              val memberlist = rev (!members)              val memberlist = rev (!members)
441    
442              val gpath = #grouppath grec              fun mksname () = FilenamePolicy.mkStableName policy grouppath
             fun mksname () = FilenamePolicy.mkStableName policy gpath  
443              fun work outs =              fun work outs =
444                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];                  (writeInt32 (outs, dg_sz);
445                   writeInt32 (outs, sz);                   BinIO.output (outs, dg_pickle);
446                   BinIO.output (outs, Byte.stringToBytes pickle);                   app (writeBFC outs) memberlist;
                  app (cpb outs) memberlist;  
447                   mkStableGroup mksname)                   mkStableGroup mksname)
448          in          in
449              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
# Line 340  Line 456 
456          end          end
457      in      in
458          case #kind grec of          case #kind grec of
459              GG.STABLELIB _ => SOME g              GG.STABLELIB => SOME g
460            | GG.NOLIB => EM.impossible "stabilize: no library"            | GG.NOLIB => EM.impossible "stabilize: no library"
461            | GG.LIB wrapped =>            | GG.LIB wrapped =>
462                  if not (recomp gp g) then               (case recomp gp g of
463                      (anyerrors := true; NONE)                    NONE => (anyerrors := true; NONE)
464                  else let                  | SOME bfc_acc => let
465                      fun notStable (GG.GROUP { kind, ... }) =                      fun notStable (GG.GROUP { kind, ... }) =
466                          case kind of GG.STABLELIB _ => false | _ => true                            case kind of GG.STABLELIB => false | _ => true
467                  in                  in
468                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
469                          [] => doit wrapped                          [] => doit (wrapped, bfc_acc)
470                        | l => let                        | l => let
471                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
472                              fun ppb pps = let                              fun ppb pps = let
# Line 377  Line 493 
493                                 ppb;                                 ppb;
494                              NONE                              NONE
495                          end                          end
496                      end)
497                  end                  end
     end  
   
     fun loadStable (gp, getGroup, anyerrors) group = let  
498    
499          val es2bs = GenericVC.CoerceEnv.es2bs      fun loadStable gp { getGroup, anyerrors } group = let
         fun bn2env n =  
             Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))  
500    
501          val errcons = #errcons gp          val errcons = #errcons (gp: GeneralParams.info)
502          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
503          val gdescr = SrcPath.descr group          val gdescr = SrcPath.descr group
504          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
# Line 398  Line 510 
510          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
511          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
512          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
513            val pervasive = #pervasive (#param gp)
514    
515          fun mksname () = FilenamePolicy.mkStableName policy group          fun mksname () = FilenamePolicy.mkStableName policy group
516    
517          fun work s = let          fun work s = let
# Line 408  Line 522 
522                    | NONE => (error ["unable to find ", SrcPath.descr p];                    | NONE => (error ["unable to find ", SrcPath.descr p];
523                               raise Format)                               raise Format)
524    
             (* for getting sharing right... *)  
             val m = ref IntBinaryMap.empty  
             val next = ref 0  
   
             val pset = ref PidSet.empty  
   
525              fun bytesIn n = let              fun bytesIn n = let
526                  val bv = BinIO.inputN (s, n)                  val bv = BinIO.inputN (s, n)
527              in              in
# Line 421  Line 529 
529                  else raise Format                  else raise Format
530              end              end
531    
532              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))              val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
533              val pickle = Byte.bytesToString (bytesIn sz)              val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
534              val offset_adjustment = sz + 4              val offset_adjustment = dg_sz + 4
535                val session = UU.mkSession (UU.stringGetter dg_pickle)
             val session = UU.mkSession (UU.stringReader pickle)  
536    
537              fun list m r = UU.r_list session m r              fun list m r = UU.r_list session m r
538                val string = UU.r_string session
539                val stringListM = UU.mkMap ()
540                val stringlist = list stringListM string
541    
542                fun abspath () =
543                    SrcPath.unpickle pcmode (stringlist (), group)
544                    handle SrcPath.Format => raise Format
545                         | SrcPath.BadAnchor a =>
546                           (error ["configuration anchor \"", a, "\" undefined"];
547                            raise Format)
548    
549                fun sg () = getGroup' (abspath ())
550                val sgListM = UU.mkMap ()
551                val sublibs = list sgListM sg ()
552    
553                (* Now that we have the list of sublibs, we can build the
554                 * environment for unpickling the environment list.
555                 * We will need the environment list when unpickling the
556                 * export list (making SB_BNODES). *)
557                fun prim_context "pv" = SOME (E.staticPart pervasive)
558                  | prim_context s =
559                    SOME (E.staticPart (Primitive.env primconf
560                                        (valOf (Primitive.fromIdent primconf
561                                                (String.sub (s, 0))))))
562                    handle _ => NONE
563                fun node_context (n, sy) = let
564                    val GG.GROUP { exports = slexp, ... } = List.nth (sublibs, n)
565                in
566                    case SymbolMap.find (slexp, sy) of
567                        SOME ((_, DG.SB_BNODE (_, { statenv = ge, ... })), _) =>
568                            SOME (ge ())
569                      | _ => NONE
570                end handle _ => NONE
571    
572                val { symenv, env, symbol, symbollist } =
573                    UP.mkUnpicklers session
574                        { prim_context = prim_context,
575                          node_context = node_context }
576    
577                val lazy_symenv = UU.r_lazy session symenv
578                val lazy_env = UU.r_lazy session env
579    
580              fun option m r = UU.r_option session m r              fun option m r = UU.r_option session m r
581              val int = UU.r_int session              val int = UU.r_int session
582              fun share m r = UU.share session m r              fun share m r = UU.share session m r
583              val string = UU.r_string session              fun nonshare r = UU.nonshare session r
             val symbol = UU.r_symbol session  
584              val bool = UU.r_bool session              val bool = UU.r_bool session
585                val pid = UnpickleSymPid.r_pid string
586    
587              val stringListM = UU.mkMap ()              val stringListM = UU.mkMap ()
588              val symbolListM = UU.mkMap ()              val ssM = UU.mkMap ()
             val stringListM = UU.mkMap ()  
589              val ssoM = UU.mkMap ()              val ssoM = UU.mkMap ()
590              val boolOptionM = UU.mkMap ()              val boolOptionM = UU.mkMap ()
591              val sgListM = UU.mkMap ()              val siM = UU.mkMap ()
592              val snM = UU.mkMap ()              val snM = UU.mkMap ()
593              val snListM = UU.mkMap ()              val snListM = UU.mkMap ()
             val bnM = UU.mkMap ()  
594              val sbnM = UU.mkMap ()              val sbnM = UU.mkMap ()
595                val fsbnM = UU.mkMap ()
596              val fsbnListM = UU.mkMap ()              val fsbnListM = UU.mkMap ()
597                val impexpM = UU.mkMap ()
598              val impexpListM = UU.mkMap ()              val impexpListM = UU.mkMap ()
599    
600              val stringlist = list stringListM string              fun symbolset () = let
601                    fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
602              fun abspath () =                    | s _ = raise Format
603                  SrcPath.unpickle pcmode (stringlist (), group)              in
604                  handle SrcPath.Format => raise Format                  share ssM s
605                       | SrcPath.BadAnchor a =>              end
                        (error ["configuration anchor \"", a, "\" undefined"];  
                         raise Format)  
   
             val symbollist = list symbolListM symbol  
   
             fun symbolset () =  
                 SymbolSet.addList (SymbolSet.empty, symbollist ())  
606    
607              val filter = option ssoM symbolset              val filter = option ssoM symbolset
608    
# Line 469  Line 611 
611                            (String.sub (string (), 0)))                            (String.sub (string (), 0)))
612                  handle _ => raise Format                  handle _ => raise Format
613    
614              val sh = option boolOptionM bool              fun shm () = let
615                    fun s #"a" = Sharing.SHARE true
616                      | s #"b" = Sharing.SHARE false
617                      | s #"c" = Sharing.DONTSHARE
618                      | s _ = raise Format
619                in
620                    nonshare s
621                end
622    
623              fun si () = let              fun si () = let
624                  val spec = string ()                  fun s #"s" =
625                        let val spec = string ()
626                  val locs = string ()                  val locs = string ()
627                  val offset = int () + offset_adjustment                  val offset = int () + offset_adjustment
628                  val share = sh ()                          val sh_mode = shm ()
629                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
630              in              in
631                  BinInfo.new { group = group,                  BinInfo.new { group = group,
# Line 483  Line 633 
633                                error = error,                                error = error,
634                                spec = spec,                                spec = spec,
635                                offset = offset,                                offset = offset,
636                                share = share }                                        sh_mode = sh_mode }
             end  
   
             fun sg () = getGroup' (abspath ())  
   
             val sublibs = list sgListM sg ()  
   
             fun bn () = let  
                 fun bn' #"1" = DG.PNODE (primitive ())  
                   | bn' #"2" = let  
                         val n = int ()  
                         val sy = symbol ()  
                         val GG.GROUP { exports = slexp, ... } =  
                             List.nth (sublibs, n) handle _ => raise Format  
                     in  
                         case SymbolMap.find (slexp, sy) of  
                             SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n  
                           | _ => raise Format  
637                      end                      end
638                    | bn' _ = raise Format                    | s _ = raise Format
639              in              in
640                  share bnM bn'                  share siM s
641              end              end
642    
643              (* this is the place where what used to be an              (* this is the place where what used to be an
# Line 523  Line 656 
656    
657              (* this one changes from farsbnode to plain farbnode *)              (* this one changes from farsbnode to plain farbnode *)
658              and sbn () = let              and sbn () = let
659                  fun sbn' #"a" = bn ()                  fun sbn' #"1" = DG.PNODE (primitive ())
660                    | sbn' #"b" = sn ()                    | sbn' #"2" = let
661                            val n = int ()
662                            val sy = symbol ()
663                            val GG.GROUP { exports = slexp, ... } =
664                                List.nth (sublibs, n) handle _ => raise Format
665                        in
666                            case SymbolMap.find (slexp, sy) of
667                                SOME ((_, DG.SB_BNODE (n as DG.BNODE _, _)), _) =>
668                                    n
669                              | _ => raise Format
670                        end
671                      | sbn' #"3" = sn ()
672                    | sbn' _ = raise Format                    | sbn' _ = raise Format
673              in              in
674                  share sbnM sbn'                  share sbnM sbn'
675              end              end
676    
677              and fsbn () = (filter (), sbn ())              and fsbn () = let
678                    fun f #"f" = (filter (), sbn ())
679                      | f _ = raise Format
680                in
681                    share fsbnM f
682                end
683    
684              and fsbnlist () = list fsbnListM fsbn ()              and fsbnlist () = list fsbnListM fsbn ()
685    
686              fun impexp () = let              fun impexp () = let
687                  val sy = symbol ()                  fun ie #"i" =
688                        let val sy = symbol ()
689                  val (f, n) = fsbn ()    (* really reads farbnodes! *)                  val (f, n) = fsbn ()    (* really reads farbnodes! *)
690                  val e = bn2env n                          val ge = lazy_env ()
691                  (* put a filter in front to avoid having the FCTENV being                          val ii = { statenv = GenericVC.CoerceEnv.bs2es o ge,
692                   * queried needlessly (this avoids spurious module loadings) *)                                     symenv = lazy_symenv (),
693                                       statpid = pid (),
694                                       sympid = pid () }
695                            val e = Statenv2DAEnv.cvtMemo ge
696                            (* put a filter in front to avoid having the FCTENV
697                             * being queried needlessly (this avoids spurious
698                             * module loadings) *)
699                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
700              in              in
701                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)                          (sy, ((f, DG.SB_BNODE (n, ii)), e'))
702                        end
703                      | ie _ = raise Format
704                in
705                    share impexpM ie
706              end              end
707    
708              val impexplist = list impexpListM impexp              val impexplist = list impexpListM impexp
709    
710              fun r_exports () =              fun r_exports () = let
711                  foldl SymbolMap.insert' SymbolMap.empty (impexplist ())                  val iel = impexplist ()
712                in
713                    foldl SymbolMap.insert' SymbolMap.empty iel
714                end
715    
716              val stringlist = list stringListM string              val stringlist = list stringListM string
717    
# Line 557  Line 720 
720    
721              val exports = r_exports ()              val exports = r_exports ()
722              val required = privileges ()              val required = privileges ()
             val simap = genStableInfoMap (exports, group)  
723          in          in
724              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
725                         kind = GG.STABLELIB simap,                         kind = GG.STABLELIB,
726                         required = required,                         required = required,
727                         grouppath = group,                         grouppath = group,
728                         sublibs = sublibs }                         sublibs = sublibs }
# Line 570  Line 732 
732                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,
733                                 work = work,                                 work = work,
734                                 cleanup = fn () => () })                                 cleanup = fn () => () })
735          handle Format => NONE          handle Format => (error ["file is corrupted (old version?)"];
736                              NONE)
737               | IO.Io _ => NONE               | IO.Io _ => NONE
738      end      end
739  end  end

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

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