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 393, Fri Aug 6 08:41:25 1999 UTC revision 398, Wed Aug 25 15:36:43 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        structure UP = UnpickMod
19        structure E = GenericVC.Environment
20    
     type statenvgetter = GP.info -> DG.bnode -> E.staticEnv  
21      type recomp = GP.info -> GG.group -> bool      type recomp = GP.info -> GG.group -> bool
22      type pid = Pid.persstamp      type pid = Pid.persstamp
23  in  in
# Line 23  Line 25 
25  signature STABILIZE = sig  signature STABILIZE = sig
26    
27      val loadStable :      val loadStable :
28          GP.info * (SrcPath.t -> GG.group option) * bool ref ->          GP.info -> { getGroup: SrcPath.t -> GG.group option,
29          SrcPath.t -> GG.group option                       anyerrors: bool ref }
30            -> SrcPath.t -> GG.group option
31    
32      val stabilize :      val stabilize :
33          GP.info -> { group: GG.group, anyerrors: bool ref } ->          GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
         GG.group option  
34  end  end
35    
36  functor StabilizeFn (val bn2statenv : statenvgetter  functor StabilizeFn (val transfer_state : SmlInfo.info * BinInfo.info -> unit
37                       val transfer_state : SmlInfo.info * BinInfo.info -> unit                       val writeBFC: BinIO.outstream -> SmlInfo.info -> unit
38                         val sizeBFC: SmlInfo.info -> int
39                         val getII:  SmlInfo.info -> IInfo.info
40                       val recomp : recomp) :> STABILIZE = struct                       val recomp : recomp) :> STABILIZE = struct
41    
42      structure SSMap = BinaryMapFn      structure SSMap = BinaryMapFn
# Line 48  Line 52 
52                   SmlInfo.compare (#smlinfo n, #smlinfo n')                   SmlInfo.compare (#smlinfo n, #smlinfo n')
53          end)          end)
54    
55      type 'a maps = { ss: 'a SSMap.map, sn: 'a SNMap.map }      structure PU = PickleUtil
56        structure UU = UnpickleUtil
57    
58      val initMap = { ss = SSMap.empty, sn = SNMap.empty }      type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
59    
60      structure PU = PickleUtilFn (type 'a map = 'a maps val emptyMap = initMap)      val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
61      structure PSym = PickleSymbolFn (structure PU = PU)  
62      structure UU = UnpickleUtil      val lifter =
63            { extract = fn (m: map) => #pm m,
64              patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
65    
66      infix 3 $      infix 3 $
67      infixr 4 &      infixr 4 &
# Line 64  Line 71 
71      (* type info *)      (* type info *)
72      val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)      val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
73    
74      val SSs = { find = fn (m: 'a maps, k) => SSMap.find (#ss m, k),      val SSs =
75                  insert = fn ({ ss, sn }, k, v) =>          { find = fn (m: map, k) => SSMap.find (#ss m, k),
76                               { sn = sn, ss = SSMap.insert (ss, k, v) } }            insert = fn ({ ss, sn, pm }, k, v) =>
77      val SNs = { find = fn (m: 'a maps, k) => SNMap.find (#sn m, k),                         { sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
78                  insert = fn ({ ss, sn }, k, v) =>      val SNs =
79                               { ss = ss, sn = SNMap.insert (sn, k, v) } }          { find = fn (m: map, k) => SNMap.find (#sn m, k),
80              insert = fn ({ ss, sn, pm }, k, v) =>
81      fun genStableInfoMap (exports, group) = let                         { ss = ss, sn = SNMap.insert (sn, k, v), pm = pm } }
         (* find all the exported bnodes that are in the same group: *)  
         fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let  
             val i = #bininfo b  
         in  
             if SrcPath.compare (BinInfo.group i, group) = EQUAL then  
                 IntBinaryMap.insert (m, BinInfo.offset i, n)  
             else m  
         end  
           | add (_, m) = m  
     in  
         SymbolMap.foldl add IntBinaryMap.empty exports  
     end  
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    
# Line 101  Line 97 
97                               :: map (fn s => ("  " ^ s ^ "\n"))                               :: map (fn s => ("  " ^ s ^ "\n"))
98                                      (StringSet.listItems wrapped))                                      (StringSet.listItems wrapped))
99    
             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  
   
100              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
101    
102              val exports = #exports grec              val exports = #exports grec
# Line 130  Line 106 
106              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
107               *  - It starts with the size s of the pickled dependency               *  - It starts with the size s of the pickled dependency
108               *    graph. This size itself is written as four-byte string.               *    graph. This size itself is written as four-byte string.
109                 *  - The size t of the pickled environment for the entire
110                 *    library (using the pickleEnvN interface of the pickler)
111                 *    in the same format as s.
112               *  - The pickled dependency graph.  This graph contains               *  - The pickled dependency graph.  This graph contains
113               *    integer offsets of the binfiles for the individual ML               *    integer offsets of the binfiles for the individual ML
114               *    members. These offsets need to be adjusted by adding               *    members. These offsets need to be adjusted by adding
115               *    s + 4. The pickled dependency graph also contains integer               *    s + t + 8. The pickled dependency graph also contains integer
116               *    offsets relative to other stable groups.  These offsets               *    offsets relative to other stable groups.  These offsets
117               *    need no further adjustment.               *    need no further adjustment.
118               *  - Individual binfile contents (concatenated).               *  - The pickled environment (list).  To be unpickled using
119                 *    unpickleEnvN.
120                 *  - Individual binfile contents (concatenated) but without
121                 *    their static environments.
122               *)               *)
123    
124              (* Here we build a mapping that maps each BNODE to a number              (* Here we build a mapping that maps each BNODE to a number
125               * representing the sub-library that it came from and a               * representing the sub-library that it came from and a
126               * representative symbol that can be used to find the BNODE               * representative symbol that can be used to find the BNODE
127               * within the exports of that library *)               * within the exports of that library *)
128              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
129                  StableMap.insert (m, #bininfo n, (i, sy))                  StableMap.insert (m, #bininfo n, (i, sy))
130                | oneB i (_, _, m) = m                | oneB i (_, _, m) = m
131              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
# Line 167  Line 149 
149                  (reg, get)                  (reg, get)
150              end              end
151    
152                (* Collect all BNODEs and PNODEs that we see and build
153                 * a context suitable for P.envPickler. *)
154                fun mkContext () = let
155                    fun lst f [] k s = k s
156                      | lst f (h :: t) k s = f h (lst f t k) s
157    
158                    fun sbn n k (s as (prims, bnodes, snodes)) =
159                        case n of
160                            DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let
161                                val str = String.str (Primitive.toIdent primconf p)
162                                val prims' = StringMap.insert (prims, str, statenv)
163                            in
164                                k (prims', bnodes, snodes)
165                            end
166                          | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
167                                val { statenv, ... } = ii
168                                val nsy = valOf (StableMap.find (inverseMap, i))
169                                val bnodes' =
170                                    StableMap.insert (bnodes, i, (nsy, statenv))
171                            in
172                                k (prims, bnodes', snodes)
173                            end
174                          | DG.SB_SNODE n => sn n k s
175    
176                    and sn (DG.SNODE n) k (prims, bnodes, snodes) = let
177                        val i = #smlinfo n
178                        val li = #localimports n
179                        val gi = #globalimports n
180                    in
181                        if SmlInfoSet.member (snodes, i) then
182                            k (prims, bnodes, snodes)
183                        else let
184                            val snodes' = SmlInfoSet.add (snodes, i)
185                        in
186                            lst sn li (lst fsbn gi k) (prims, bnodes, snodes')
187                        end
188                    end
189    
190                    and fsbn (_, n) k s = sbn n k s
191    
192                    fun impexp (n, _) k s = fsbn n k s
193    
194                    val (prims, bnodes) =
195                        lst impexp (SymbolMap.listItems exports)
196                            (fn (prims, bnodes, _) => (prims, bnodes))
197                            (StringMap.empty, StableMap.empty, SmlInfoSet.empty)
198    
199                    val priml = StringMap.listItemsi prims
200                    val bnodel = StableMap.listItems bnodes
201    
202                    fun cvt lk id = let
203                        fun nloop [] = NONE
204                          | nloop ((k, ge) :: t) =
205                            (case lk (ge ()) id of
206                                 SOME _ => SOME (P.NodeKey k)
207                               | NONE => nloop t)
208                        fun ploop [] = nloop bnodel
209                          | ploop ((k, ge) :: t) =
210                            (case lk (ge ()) id of
211                                 SOME _ => SOME (P.PrimKey k)
212                               | NONE => ploop t)
213                    in
214                        case lk (E.staticPart pervasive) id of
215                            NONE => ploop priml
216                          | SOME _ => SOME (P.PrimKey "pv")
217                    end
218                in
219                    { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
220                      lookSIG = cvt GenericVC.CMStaticEnv.lookSIG,
221                      lookFCT = cvt GenericVC.CMStaticEnv.lookFCT,
222                      lookFSIG = cvt GenericVC.CMStaticEnv.lookFSIG,
223                      lookTYC = cvt GenericVC.CMStaticEnv.lookTYC,
224                      lookEENV = cvt GenericVC.CMStaticEnv.lookEENV }
225                end
226    
227                (* make the picklers for static and symbolic environments;
228                 * lift them so we can use them here... *)
229                val envContext = mkContext ()
230                val env_orig = P.envPickler envContext
231                val env = PU.lift_pickler lifter env_orig
232                val symenv_orig = P.symenvPickler
233                val symenv = PU.lift_pickler lifter symenv_orig
234                val lazy_env = PU.w_lazy env
235                val lazy_symenv = PU.w_lazy symenv
236    
237              val int = PU.w_int              val int = PU.w_int
238              val symbol = PSym.w_symbol              val symbol = PickleSymPid.w_symbol
239                val pid = PickleSymPid.w_pid
240              val share = PU.ah_share              val share = PU.ah_share
241              val option = PU.w_option              val option = PU.w_option
242              val list = PU.w_list              val list = PU.w_list
# Line 198  Line 266 
266                   * operation of CM itself. *)                   * operation of CM itself. *)
267                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
268                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
269                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, sizeBFC i)
270                  val sh_mode = SmlInfo.sh_mode i                  val sh_mode = SmlInfo.sh_mode i
271                  val op $ = PU.$ SI                  val op $ = PU.$ SI
272              in              in
# Line 236  Line 304 
304                  list string pp                  list string pp
305              end              end
306    
             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  
   
307              fun sn n = let              fun sn n = let
308                    val op $ = PU.$ SN
309                  fun raw_sn (DG.SNODE n) =                  fun raw_sn (DG.SNODE n) =
310                      "a" $ si (#smlinfo n) & list sn (#localimports n) &                      "a" $ si (#smlinfo n) & list sn (#localimports n) &
311                      list fsbn (#globalimports n)                      list fsbn (#globalimports n)
# Line 252  Line 313 
313                  share SNs raw_sn n                  share SNs raw_sn n
314              end              end
315    
316                (* Here we ignore the interface info because we will not
317                 * need it anymore when we unpickle. *)
318              and sbn x = let              and sbn x = let
319                  val op $ = PU.$ SBN                  val op $ = PU.$ SBN
320              in              in
321                  case x of                  case x of
322                      DG.SB_BNODE n => "a" $ bn n                      DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
323                    | DG.SB_SNODE n => "b" $ sn n                          "1" $ primitive p
324                      | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
325                            val (n, sy) = valOf (StableMap.find (inverseMap, i))
326                        in
327                            "2" $ int n & symbol sy
328                        end
329                      | DG.SB_SNODE n => "3" $ sn n
330              end              end
331    
332              and fsbn (f, n) = let              and fsbn (f, n) = let
# Line 266  Line 335 
335                  "f" $ filter f & sbn n                  "f" $ filter f & sbn n
336              end              end
337    
338                (* Here is the place where we need to write interface info. *)
339              fun impexp (s, (n, _)) = let              fun impexp (s, (n, _)) = let
340                  val op $ = PU.$ IMPEXP                  val op $ = PU.$ IMPEXP
341              in                  val { statenv, symenv, statpid, sympid } =
342                  "i" $ symbol s & fsbn n                      case n of
343                            (_, DG.SB_BNODE (_, ii)) => ii
344                          | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
345                                getII smlinfo
346                in
347                    "i" $ symbol s & fsbn n &
348                          lazy_env (GenericVC.CoerceEnv.es2bs o statenv) &
349                          lazy_symenv symenv &
350                          pid statpid &
351                          pid sympid
352              end              end
353    
354              fun w_exports e = list impexp (SymbolMap.listItemsi e)              fun w_exports e = list impexp (SymbolMap.listItemsi e)
# Line 284  Line 363 
363                  list sg sublibs & w_exports exports & privileges required                  list sg sublibs & w_exports exports & privileges required
364              end              end
365    
366              val pickle = PU.pickle (group ())              val dg_pickle =
367              val sz = size pickle                  Byte.stringToBytes (PU.pickle emptyMap (group ()))
368              val offset_adjustment = sz + 4              val dg_sz = Word8Vector.length dg_pickle
369    
370                val offset_adjustment = dg_sz + 4
371    
372              fun mkStableGroup mksname = let              fun mkStableGroup mksname = let
373                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
# Line 320  Line 401 
401                              n                              n
402                          end                          end
403    
404                  and sbn (DG.SB_SNODE n) = sn n                  and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
405                    | sbn (DG.SB_BNODE n) = n                      let val ii = getII i
406                        in
407                            (sn n, ii)
408                        end
409                      | sbn (DG.SB_BNODE (n, ii)) = (n, ii)
410    
411                  and fsbn (f, n) = (f, sbn n)                  and fsbn (f, n) = (f, #1 (sbn n))
412    
413                  fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)                  fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
414    
415                  val exports = SymbolMap.map impexp (#exports grec)                  val exports = SymbolMap.map impexp (#exports grec)
                 val simap = genStableInfoMap (exports, grouppath)  
416              in              in
417                  GG.GROUP { exports = exports,                  GG.GROUP { exports = exports,
418                             kind = GG.STABLELIB simap,                             kind = GG.STABLELIB,
419                             required = required,                             required = required,
420                             grouppath = grouppath,                             grouppath = grouppath,
421                             sublibs = sublibs }                             sublibs = sublibs }
# Line 349  Line 433 
433              fun mksname () = FilenamePolicy.mkStableName policy gpath              fun mksname () = FilenamePolicy.mkStableName policy gpath
434              fun work outs =              fun work outs =
435                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
436                   writeInt32 (outs, sz);                   writeInt32 (outs, dg_sz);
437                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, dg_pickle);
438                   app (cpb outs) memberlist;                   app (writeBFC outs) memberlist;
439                   mkStableGroup mksname)                   mkStableGroup mksname)
440          in          in
441              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
# Line 364  Line 448 
448          end          end
449      in      in
450          case #kind grec of          case #kind grec of
451              GG.STABLELIB _ => SOME g              GG.STABLELIB => SOME g
452            | GG.NOLIB => EM.impossible "stabilize: no library"            | GG.NOLIB => EM.impossible "stabilize: no library"
453            | GG.LIB wrapped =>            | GG.LIB wrapped =>
454                  if not (recomp gp g) then                  if not (recomp gp g) then
455                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
456                  else let                  else let
457                      fun notStable (GG.GROUP { kind, ... }) =                      fun notStable (GG.GROUP { kind, ... }) =
458                          case kind of GG.STABLELIB _ => false | _ => true                          case kind of GG.STABLELIB => false | _ => true
459                  in                  in
460                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
461                          [] => doit wrapped                          [] => doit wrapped
# Line 404  Line 488 
488                  end                  end
489      end      end
490    
491      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable gp { getGroup, anyerrors } group = let
   
         val es2bs = GenericVC.CoerceEnv.es2bs  
         fun bn2env n =  
             Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))  
492    
493          val errcons = #errcons gp          val errcons = #errcons (gp: GeneralParams.info)
494          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
495          val gdescr = SrcPath.descr group          val gdescr = SrcPath.descr group
496          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
# Line 422  Line 502 
502          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
503          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
504          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
505            val pervasive = #pervasive (#param gp)
506    
507          fun mksname () = FilenamePolicy.mkStableName policy group          fun mksname () = FilenamePolicy.mkStableName policy group
508    
509          fun work s = let          fun work s = let
# Line 432  Line 514 
514                    | NONE => (error ["unable to find ", SrcPath.descr p];                    | NONE => (error ["unable to find ", SrcPath.descr p];
515                               raise Format)                               raise Format)
516    
             (* for getting sharing right... *)  
             val m = ref IntBinaryMap.empty  
             val next = ref 0  
   
             val pset = ref PidSet.empty  
   
517              fun bytesIn n = let              fun bytesIn n = let
518                  val bv = BinIO.inputN (s, n)                  val bv = BinIO.inputN (s, n)
519              in              in
# Line 445  Line 521 
521                  else raise Format                  else raise Format
522              end              end
523    
524              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))              val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
525              val pickle = Byte.bytesToString (bytesIn sz)              val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
526              val offset_adjustment = sz + 4              val offset_adjustment = dg_sz + 4
527                val session = UU.mkSession (UU.stringGetter dg_pickle)
             val session = UU.mkSession (UU.stringGetter pickle)  
528    
529              fun list m r = UU.r_list session m r              fun list m r = UU.r_list session m r
530                val string = UU.r_string session
531                val stringListM = UU.mkMap ()
532                val stringlist = list stringListM string
533    
534                fun abspath () =
535                    SrcPath.unpickle pcmode (stringlist (), group)
536                    handle SrcPath.Format => raise Format
537                         | SrcPath.BadAnchor a =>
538                           (error ["configuration anchor \"", a, "\" undefined"];
539                            raise Format)
540    
541                fun sg () = getGroup' (abspath ())
542                val sgListM = UU.mkMap ()
543                val sublibs = list sgListM sg ()
544    
545                (* Now that we have the list of sublibs, we can build the
546                 * environment for unpickling the environment list.
547                 * We will need the environment list when unpickling the
548                 * export list (making SB_BNODES). *)
549                fun prim_context "pv" = SOME (E.staticPart pervasive)
550                  | prim_context s =
551                    SOME (E.staticPart (Primitive.env primconf
552                                        (valOf (Primitive.fromIdent primconf
553                                                (String.sub (s, 0))))))
554                    handle _ => NONE
555                fun node_context (n, sy) = let
556                    val GG.GROUP { exports = slexp, ... } = List.nth (sublibs, n)
557                in
558                    case SymbolMap.find (slexp, sy) of
559                        SOME ((_, DG.SB_BNODE (_, { statenv = ge, ... })), _) =>
560                            SOME (ge ())
561                      | _ => NONE
562                end handle _ => NONE
563    
564                val { symenv, env, symbol, symbollist } =
565                    UP.mkUnpicklers session
566                        { prim_context = prim_context,
567                          node_context = node_context }
568    
569                val lazy_symenv = UU.r_lazy session symenv
570                val lazy_env = UU.r_lazy session env
571    
572              fun option m r = UU.r_option session m r              fun option m r = UU.r_option session m r
573              val int = UU.r_int session              val int = UU.r_int session
574              fun share m r = UU.share session m r              fun share m r = UU.share session m r
575              fun nonshare r = UU.nonshare session r              fun nonshare r = UU.nonshare session r
             val string = UU.r_string session  
             val symbol = UnpickleSymbol.r_symbol (session, string)  
576              val bool = UU.r_bool session              val bool = UU.r_bool session
577                val pid = UnpickleSymPid.r_pid string
578    
579              val stringListM = UU.mkMap ()              val stringListM = UU.mkMap ()
             val symbolListM = UU.mkMap ()  
             val stringListM = UU.mkMap ()  
580              val ssM = UU.mkMap ()              val ssM = UU.mkMap ()
581              val ssoM = UU.mkMap ()              val ssoM = UU.mkMap ()
582              val boolOptionM = UU.mkMap ()              val boolOptionM = UU.mkMap ()
583              val siM = UU.mkMap ()              val siM = UU.mkMap ()
             val sgListM = UU.mkMap ()  
584              val snM = UU.mkMap ()              val snM = UU.mkMap ()
585              val snListM = UU.mkMap ()              val snListM = UU.mkMap ()
             val bnM = UU.mkMap ()  
586              val sbnM = UU.mkMap ()              val sbnM = UU.mkMap ()
587              val fsbnM = UU.mkMap ()              val fsbnM = UU.mkMap ()
588              val fsbnListM = UU.mkMap ()              val fsbnListM = UU.mkMap ()
589              val impexpM = UU.mkMap ()              val impexpM = UU.mkMap ()
590              val impexpListM = UU.mkMap ()              val impexpListM = UU.mkMap ()
591    
             val stringlist = list stringListM string  
   
             fun abspath () =  
                 SrcPath.unpickle pcmode (stringlist (), group)  
                 handle SrcPath.Format => raise Format  
                      | SrcPath.BadAnchor a =>  
                        (error ["configuration anchor \"", a, "\" undefined"];  
                         raise Format)  
   
             val symbollist = list symbolListM symbol  
   
592              fun symbolset () = let              fun symbolset () = let
593                  fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())                  fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
594                    | s _ = raise Format                    | s _ = raise Format
# Line 531  Line 632 
632                  share siM s                  share siM s
633              end              end
634    
             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  
                     end  
                   | bn' _ = raise Format  
             in  
                 share bnM bn'  
             end  
   
635              (* this is the place where what used to be an              (* this is the place where what used to be an
636               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
637              fun sn () = let              fun sn () = let
# Line 568  Line 648 
648    
649              (* this one changes from farsbnode to plain farbnode *)              (* this one changes from farsbnode to plain farbnode *)
650              and sbn () = let              and sbn () = let
651                  fun sbn' #"a" = bn ()                  fun sbn' #"1" = DG.PNODE (primitive ())
652                    | sbn' #"b" = sn ()                    | sbn' #"2" = let
653                            val n = int ()
654                            val sy = symbol ()
655                            val GG.GROUP { exports = slexp, ... } =
656                                List.nth (sublibs, n) handle _ => raise Format
657                        in
658                            case SymbolMap.find (slexp, sy) of
659                                SOME ((_, DG.SB_BNODE (n as DG.BNODE _, _)), _) =>
660                                    n
661                              | _ => raise Format
662                        end
663                      | sbn' #"3" = sn ()
664                    | sbn' _ = raise Format                    | sbn' _ = raise Format
665              in              in
666                  share sbnM sbn'                  share sbnM sbn'
# Line 588  Line 679 
679                  fun ie #"i" =                  fun ie #"i" =
680                      let val sy = symbol ()                      let val sy = symbol ()
681                          val (f, n) = fsbn () (* really reads farbnodes! *)                          val (f, n) = fsbn () (* really reads farbnodes! *)
682                          val e = bn2env n                          val ge = lazy_env ()
683                            val ii = { statenv = GenericVC.CoerceEnv.bs2es o ge,
684                                       symenv = lazy_symenv (),
685                                       statpid = pid (),
686                                       sympid = pid () }
687                            val e = Statenv2DAEnv.cvtMemo ge
688                          (* put a filter in front to avoid having the FCTENV                          (* put a filter in front to avoid having the FCTENV
689                           * being queried needlessly (this avoids spurious                           * being queried needlessly (this avoids spurious
690                           * module loadings) *)                           * module loadings) *)
691                          val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)                          val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
692                      in                      in
693                          (* coerce to farsbnodes *)                          (sy, ((f, DG.SB_BNODE (n, ii)), e'))
                         (sy, ((f, DG.SB_BNODE n), e'))  
694                      end                      end
695                    | ie _ = raise Format                    | ie _ = raise Format
696              in              in
# Line 604  Line 699 
699    
700              val impexplist = list impexpListM impexp              val impexplist = list impexpListM impexp
701    
702              fun r_exports () =              fun r_exports () = let
703                  foldl SymbolMap.insert' SymbolMap.empty (impexplist ())                  val iel = impexplist ()
704                in
705                    foldl SymbolMap.insert' SymbolMap.empty iel
706                end
707    
708              val stringlist = list stringListM string              val stringlist = list stringListM string
709    
# Line 614  Line 712 
712    
713              val exports = r_exports ()              val exports = r_exports ()
714              val required = privileges ()              val required = privileges ()
             val simap = genStableInfoMap (exports, group)  
715          in          in
716              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
717                         kind = GG.STABLELIB simap,                         kind = GG.STABLELIB,
718                         required = required,                         required = required,
719                         grouppath = group,                         grouppath = group,
720                         sublibs = sublibs }                         sublibs = sublibs }

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

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