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 536, Fri Feb 18 16:51:54 2000 UTC revision 537, Fri Feb 18 17:20:16 2000 UTC
# Line 30  Line 30 
30          GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option          GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
31  end  end
32    
33  functor StabilizeFn (val destroy_state : GP.info -> SmlInfo.info -> unit  functor StabilizeFn (structure MachDepVC : MACHDEP_VC
                      structure MachDepVC : MACHDEP_VC  
34                       val recomp : GP.info -> GG.group ->                       val recomp : GP.info -> GG.group ->
35                           (SmlInfo.info -> MachDepVC.Binfile.bfContent) option                           (SmlInfo.info -> MachDepVC.Binfile.bfContent) option
36                       val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =                       val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =
37  struct  struct
   
38      structure BF = MachDepVC.Binfile      structure BF = MachDepVC.Binfile
39    
40      structure SSMap = MapFn      structure SSMap = MapFn
# Line 100  Line 98 
98                           work = #pickle o fetch_pickle,                           work = #pickle o fetch_pickle,
99                           cleanup = fn _ => () }                           cleanup = fn _ => () }
100    
101        fun loadStable gp { getGroup, anyerrors } group = let
102    
103            val errcons = #errcons (gp: GeneralParams.info)
104            val grpSrcInfo = (errcons, anyerrors)
105            val gdescr = SrcPath.descr group
106            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
107                EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
108                EM.nullErrorBody
109    
110            exception Format = UU.Format
111    
112            val pcmode = #pcmode (#param gp)
113            val policy = #fnpolicy (#param gp)
114    
115            fun mksname () = FilenamePolicy.mkStableName policy group
116    
117            fun work s = let
118    
119                fun getGroup' p =
120                    case getGroup p of
121                        SOME g => g
122                      | NONE => (error ["unable to find ", SrcPath.descr p];
123                                 raise Format)
124    
125                val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s
126                val offset_adjustment = dg_sz + 4
127                val { getter, dropper } =
128                    UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
129                val session = UU.mkSession getter
130    
131                val sgListM = UU.mkMap ()
132                val stringListM = UU.mkMap ()
133                val stringListM = UU.mkMap ()
134                val ssM = UU.mkMap ()
135                val ssoM = UU.mkMap ()
136                val boolOptionM = UU.mkMap ()
137                val siM = UU.mkMap ()
138                val snM = UU.mkMap ()
139                val snListM = UU.mkMap ()
140                val sbnM = UU.mkMap ()
141                val fsbnM = UU.mkMap ()
142                val fsbnListM = UU.mkMap ()
143                val impexpM = UU.mkMap ()
144                val impexpListM = UU.mkMap ()
145                val groupM = UU.mkMap ()
146                val apM = UU.mkMap ()
147                val exportsM = UU.mkMap ()
148                val privilegesM = UU.mkMap ()
149                val poM = UU.mkMap ()
150    
151                fun list m r = UU.r_list session m r
152                val string = UU.r_string session
153                val stringlist = list stringListM string
154    
155                fun option m r = UU.r_option session m r
156                val int = UU.r_int session
157                val bool = UU.r_bool session
158                fun share m r = UU.share session m r
159                fun nonshare r = UU.nonshare session r
160                val bool = UU.r_bool session
161                val pid = UnpickleSymPid.r_pid (session, string)
162    
163                fun abspath () = let
164                    fun ap #"p" =
165                        (SrcPath.unpickle pcmode (stringlist (), group)
166                         handle SrcPath.Format => raise Format
167                              | SrcPath.BadAnchor a =>
168                             (error ["configuration anchor \"", a, "\" undefined"];
169                              raise Format))
170                      | ap _ = raise Format
171                in
172                    share apM ap
173                end
174    
175                fun sg () = let
176                    val p = abspath ()
177                in
178                    (p, getGroup' p)
179                end
180    
181                fun gr #"g" =
182                    let val sublibs = list sgListM sg ()
183    
184                        (* Now that we have the list of sublibs, we can build the
185                         * environment for unpickling the environment list.
186                         * We will need the environment list when unpickling the
187                         * export list (making SB_BNODES). *)
188                        fun node_context (n, sy) = let
189                            val (_, GG.GROUP { exports = slexp, ... }) =
190                                List.nth (sublibs, n)
191                        in
192                            case SymbolMap.find (slexp, sy) of
193                                SOME ((_, DG.SB_BNODE (_, x)), _) =>
194                                    SOME (#env (#statenv x ()))
195                              | _ => NONE
196                        end handle _ => NONE
197    
198                        val { symenv, env, symbol, symbollist } =
199                            UP.mkUnpicklers session
200                               { node_context = node_context,
201                                 prim_context = E.primEnv }
202    
203                        val lazy_symenv = UU.r_lazy session symenv
204                        val lazy_env = UU.r_lazy session env
205    
206                        fun symbolset () = let
207                            fun s #"s" =
208                                SymbolSet.addList (SymbolSet.empty, symbollist ())
209                              | s _ = raise Format
210                        in
211                            share ssM s
212                        end
213    
214                        val filter = option ssoM symbolset
215    
216                        fun shm () = let
217                            fun s #"a" = Sharing.SHARE true
218                              | s #"b" = Sharing.SHARE false
219                              | s #"c" = Sharing.DONTSHARE
220                              | s _ = raise Format
221                        in
222                            nonshare s
223                        end
224    
225                        val pidoption = option poM pid
226    
227                        fun si () = let
228                            fun s #"s" =
229                                let val spec = string ()
230                                    val locs = string ()
231                                    val offset = int () + offset_adjustment
232                                    val rts_pid = pidoption ()
233                                    val sh_mode = shm ()
234                                    val error = EM.errorNoSource grpSrcInfo locs
235                                in
236                                    BinInfo.new { group = group,
237                                                  mkStablename = mksname,
238                                                  error = error,
239                                                  spec = spec,
240                                                  offset = offset,
241                                                  rts_pid = rts_pid,
242                                                  sh_mode = sh_mode }
243                                end
244                              | s _ = raise Format
245                        in
246                            share siM s
247                        end
248    
249                        (* this is the place where what used to be an
250                         * SNODE changes to a BNODE! *)
251                        fun sn () = let
252                            fun sn' #"a" =
253                                DG.BNODE { bininfo = si (),
254                                           localimports = snlist (),
255                                           globalimports = fsbnlist () }
256                              | sn' _ = raise Format
257                        in
258                            share snM sn'
259                        end
260    
261                        and snlist () = list snListM sn ()
262    
263                        (* this one changes from farsbnode to plain farbnode *)
264                        and sbn () = let
265                            fun sbn' #"2" = let
266                                    val n = int ()
267                                    val sy = symbol ()
268                                    val (_, GG.GROUP { exports = slexp, ... }) =
269                                        List.nth (sublibs, n)
270                                        handle _ => raise Format
271                                in
272                                    case SymbolMap.find (slexp, sy) of
273                                        SOME ((_, DG.SB_BNODE(n, _)), _) => n
274                                      | _ => raise Format
275                                end
276                              | sbn' #"3" = sn ()
277                              | sbn' _ = raise Format
278                        in
279                            share sbnM sbn'
280                        end
281    
282                        and fsbn () = let
283                            fun f #"f" = (filter (), sbn ())
284                              | f _ = raise Format
285                        in
286                            share fsbnM f
287                        end
288    
289                        and fsbnlist () = list fsbnListM fsbn ()
290    
291                        fun impexp () = let
292                            fun ie #"i" =
293                                let val sy = symbol ()
294                                    (* really reads farbnodes! *)
295                                    val (f, n) = fsbn ()
296                                    val ge = lazy_env ()
297                                    fun bs2es { env, ctxt } =
298                                        { env = GenericVC.CoerceEnv.bs2es env,
299                                          ctxt = ctxt }
300                                    val ge' = bs2es o ge
301                                    val ii = { statenv = Memoize.memoize ge',
302                                               symenv = lazy_symenv (),
303                                               statpid = pid (),
304                                               sympid = pid () }
305                                    val e = Statenv2DAEnv.cvtMemo (#env o ge)
306                                    (* put a filter in front to avoid having the
307                                     * FCTENV being queried needlessly (this
308                                     * avoids spurious module loadings) *)
309                                    val e' =
310                                        DAEnv.FILTER (SymbolSet.singleton sy, e)
311                                in
312                                    (sy, ((f, DG.SB_BNODE (n, ii)), e'))
313                                end
314                              | ie _ = raise Format
315                        in
316                            share impexpM ie
317                        end
318    
319                        val impexplist = list impexpListM impexp
320    
321                        fun r_exports () = let
322                            fun e #"e" =
323                                foldl SymbolMap.insert'
324                                      SymbolMap.empty (impexplist ())
325                              | e _ = raise Format
326                        in
327                            share exportsM e
328                        end
329    
330                        val stringlist = list stringListM string
331    
332                        fun privileges () = let
333                            fun p #"p" =
334                                StringSet.addList (StringSet.empty, stringlist ())
335                              | p _ = raise Format
336                        in
337                            share privilegesM p
338                        end
339    
340                        val exports = r_exports ()
341                        val required = privileges ()
342                    in
343                        GG.GROUP { exports = exports,
344                                   kind = GG.STABLELIB dropper,
345                                   required = required,
346                                   grouppath = group,
347                                   sublibs = sublibs }
348                    end
349                  | gr _ = raise Format
350            in
351                share groupM gr
352            end
353        in
354            SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
355                                   closeIt = BinIO.closeIn,
356                                   work = work,
357                                   cleanup = fn _ => () })
358            handle Format => (error ["file is corrupted (old version?)"];
359                              NONE)
360                 | IO.Io _ => NONE
361        end
362    
363      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
364    
         val primconf = #primconf (#param gp)  
365          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
         val pervasive = #pervasive (#param gp)  
366    
367          val grouppath = #grouppath grec          val grouppath = #grouppath grec
368    
# Line 114  Line 372 
372                                            content = getBFC i,                                            content = getBFC i,
373                                            nopickle = true }                                            nopickle = true }
374              fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }              fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }
375                fun pidBFC i = BF.staticPidOf (getBFC i)
376    
377              val _ =              val _ =
378                  Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]                  Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
# Line 175  Line 434 
434                  (reg, get)                  (reg, get)
435              end              end
436    
437              (* Collect all BNODEs and PNODEs that we see and build              (* Collect all BNODEs that we see and build
438               * a context suitable for P.envPickler. *)               * a context suitable for P.envPickler. *)
439              fun mkContext () = let              fun mkContext () = let
440                  fun lst f [] k s = k s                  fun lst f [] k s = k s
441                    | lst f (h :: t) k s = f h (lst f t k) s                    | lst f (h :: t) k s = f h (lst f t k) s
442    
443                  fun sbn n k (s as (prims, bnodes, snodes)) =                  fun sbn n k (s as (bnodes, snodes)) =
444                      case n of                      case n of
445                          DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let                          DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
                             val str = String.str (Primitive.toIdent primconf p)  
                             val prims' =  
                                 StringMap.insert (prims, str, #env o statenv)  
                         in  
                             k (prims', bnodes, snodes)  
                         end  
                       | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let  
446                              val { statenv, ... } = ii                              val { statenv, ... } = ii
447                              val nsy = valOf (StableMap.find (inverseMap, i))                              val nsy = valOf (StableMap.find (inverseMap, i))
448                              val bnodes' =                              val bnodes' =
449                                  StableMap.insert (bnodes, i,                                  StableMap.insert (bnodes, i,
450                                                    (nsy, #env o statenv))                                                    (nsy, #env o statenv))
451                          in                          in
452                              k (prims, bnodes', snodes)                              k (bnodes', snodes)
453                          end                          end
454                        | DG.SB_SNODE n => sn n k s                        | DG.SB_SNODE n => sn n k s
455    
456                  and sn (DG.SNODE n) k (prims, bnodes, snodes) = let                  and sn (DG.SNODE n) k (bnodes, snodes) = let
457                      val i = #smlinfo n                      val i = #smlinfo n
458                      val li = #localimports n                      val li = #localimports n
459                      val gi = #globalimports n                      val gi = #globalimports n
460                  in                  in
461                      if SmlInfoSet.member (snodes, i) then                      if SmlInfoSet.member (snodes, i) then
462                          k (prims, bnodes, snodes)                          k (bnodes, snodes)
463                      else let                      else let
464                          val snodes' = SmlInfoSet.add (snodes, i)                          val snodes' = SmlInfoSet.add (snodes, i)
465                      in                      in
466                          lst sn li (lst fsbn gi k) (prims, bnodes, snodes')                          lst sn li (lst fsbn gi k) (bnodes, snodes')
467                      end                      end
468                  end                  end
469    
# Line 219  Line 471 
471    
472                  fun impexp (n, _) k s = fsbn n k s                  fun impexp (n, _) k s = fsbn n k s
473    
474                  val (prims, bnodes) =                  val bnodes =
475                      lst impexp (SymbolMap.listItems exports)                      lst impexp (SymbolMap.listItems exports)
476                          (fn (prims, bnodes, _) => (prims, bnodes))                           #1
477                          (StringMap.empty, StableMap.empty, SmlInfoSet.empty)                          (StableMap.empty, SmlInfoSet.empty)
478    
                 val priml = StringMap.listItemsi prims  
479                  val bnodel = StableMap.listItems bnodes                  val bnodel = StableMap.listItems bnodes
480    
481                  fun cvt lk id = let                  fun cvt lk id = let
# Line 233  Line 484 
484                          (case lk (ge ()) id of                          (case lk (ge ()) id of
485                               SOME _ => SOME (P.NodeKey k)                               SOME _ => SOME (P.NodeKey k)
486                             | NONE => nloop t)                             | NONE => nloop t)
                     fun ploop [] = nloop bnodel  
                       | ploop ((k, ge) :: t) =  
                         (case lk (ge ()) id of  
                              SOME _ => SOME (P.PrimKey k)  
                            | NONE => ploop t)  
487                  in                  in
488                      case lk (E.staticPart pervasive) id of                      case lk E.primEnv id of
489                          NONE => ploop priml                          SOME _ => SOME P.PrimKey
490                        | SOME _ => SOME (P.PrimKey "pv")                        | NONE => nloop bnodel
491                  end                  end
492              in              in
493                  { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,                  { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
# Line 263  Line 509 
509              val lazy_env = PU.w_lazy env              val lazy_env = PU.w_lazy env
510              val lazy_symenv = PU.w_lazy symenv              val lazy_symenv = PU.w_lazy symenv
511    
512                val bool = PU.w_bool
513              val int = PU.w_int              val int = PU.w_int
514              val symbol = PickleSymPid.w_symbol              val symbol = PickleSymPid.w_symbol
515              val pid = PickleSymPid.w_pid              val pid = PickleSymPid.w_pid
# Line 297  Line 544 
544                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
545                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
546                  val offset = registerOffset (i, sizeBFC i)                  val offset = registerOffset (i, sizeBFC i)
547                    val { is_rts, ... } = SmlInfo.attribs i
548                  val sh_mode = SmlInfo.sh_mode i                  val sh_mode = SmlInfo.sh_mode i
549                  val op $ = PU.$ SI                  val op $ = PU.$ SI
550                    val rts_pid = if is_rts then SOME (pidBFC i) else NONE
551              in              in
552                  "s" $ [string spec, string locs, int offset, shm sh_mode]                  "s" $ [string spec, string locs, int offset,
553              end                         option pid rts_pid, shm sh_mode]
   
             fun primitive p = let  
                 val op $ = PU.$ PRIM  
             in  
                 "p" $ [string (String.str (Primitive.toIdent primconf p))]  
554              end              end
555    
556              fun warn_relabs p abs = let              fun warn_relabs p abs = let
# Line 353  Line 597 
597                  val op $ = PU.$ SBN                  val op $ = PU.$ SBN
598              in              in
599                  case x of                  case x of
600                      DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>                      DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
                         "1" $ [primitive p]  
                   | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let  
601                          val (n, sy) = valOf (StableMap.find (inverseMap, i))                          val (n, sy) = valOf (StableMap.find (inverseMap, i))
602                      in                      in
603                          "2" $ [int n, symbol sy]                          "2" $ [int n, symbol sy]
# Line 415  Line 657 
657    
658              val offset_adjustment = dg_sz + 4              val offset_adjustment = dg_sz + 4
659    
660              fun mkStableGroup mksname = let              (* We could generate the graph for a stable group here directly
661                  val m = ref SmlInfoMap.empty               * by transcribing the original graph.  However, it is cumbersome
662                  fun sn (DG.SNODE (n as { smlinfo, ... })) =               * and is likely to result in a larger memory footprint because
663                      case SmlInfoMap.find (!m, smlinfo) of               * we don't get the benefit of lazy unpickling of environments.
664                          SOME n => n               * It seems easier to simply rely on "loadStable" to re-fetch
665                        | NONE => let               * the stable graph. *)
666                              val li = map sn (#localimports n)              fun refetchStableGroup () = let
667                              val gi = map fsbn (#globalimports n)                  fun getGroup p = let
668                              val sourcepath = SmlInfo.sourcepath smlinfo                      fun theSublib (q, _) = SrcPath.compare (p, q) = EQUAL
                             (* FIXME: see the comment near the other  
                              * occurence of SrcPath.spec... *)  
                             val spec = SrcPath.specOf sourcepath  
                             val offset =  
                                 getOffset smlinfo + offset_adjustment  
                             val sh_mode = SmlInfo.sh_mode smlinfo  
                             val locs = SmlInfo.errorLocation gp smlinfo  
                             val error = EM.errorNoSource grpSrcInfo locs  
                             val i = BinInfo.new { group = grouppath,  
                                                   mkStablename = mksname,  
                                                   spec = spec,  
                                                   offset = offset,  
                                                   sh_mode = sh_mode,  
                                                   error = error }  
                             val n = DG.BNODE { bininfo = i,  
                                                localimports = li,  
                                                globalimports = gi }  
669                          in                          in
670                              m := SmlInfoMap.insert (!m, smlinfo, n);                      Option.map #2 (List.find theSublib sublibs)
                             n  
671                          end                          end
   
                 and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =  
                     let val ii = getII i  
672                      in                      in
673                          (sn n, ii)                  loadStable gp { getGroup = getGroup, anyerrors = anyerrors }
674                      end                             grouppath
                   | sbn (DG.SB_BNODE (n, ii)) = (n, ii)  
   
                 and fsbn (f, n) = (f, #1 (sbn n))  
   
                 fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)  
   
                 val exports = SymbolMap.map impexp (#exports grec)  
             in  
                 SmlInfoMap.appi (fn (i, _) => destroy_state gp i) (!m);  
                 GG.GROUP { exports = exports,  
                            kind = GG.STABLELIB (fn () => ()),  
                            required = required,  
                            grouppath = grouppath,  
                            sublibs = sublibs }  
675              end              end
676    
677              fun writeInt32 (s, i) = let              fun writeInt32 (s, i) = let
# Line 479  Line 686 
686              fun work outs =              fun work outs =
687                  (writeInt32 (outs, dg_sz);                  (writeInt32 (outs, dg_sz);
688                   BinIO.output (outs, dg_pickle);                   BinIO.output (outs, dg_pickle);
689                   app (writeBFC outs) memberlist;                   app (writeBFC outs) memberlist)
                  mkStableGroup mksname)  
690          in          in
691              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,             (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
692                                     closeIt = BinIO.closeOut,                                     closeIt = BinIO.closeOut,
693                                     work = work,                                     work = work,
694                                     cleanup = fn _ =>                                     cleanup = fn _ =>
695                                      (OS.FileSys.remove (mksname ())                                      (OS.FileSys.remove (mksname ())
696                                       handle _ => ()) })                                       handle _ => ()) };
697                refetchStableGroup ())
698              handle exn =>              handle exn =>
699                  (EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion                  (EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
700                      EM.COMPLAIN                      EM.COMPLAIN
# Line 499  Line 706 
706      in      in
707          case #kind grec of          case #kind grec of
708              GG.STABLELIB _ => SOME g              GG.STABLELIB _ => SOME g
709            | GG.NOLIB => EM.impossible "stabilize: no library"            | GG.NOLIB _ => EM.impossible "stabilize: no library"
710            | GG.LIB wrapped =>            | GG.LIB (wrapped, _) =>
711               (case recomp gp g of               (case recomp gp g of
712                    NONE => (anyerrors := true; NONE)                    NONE => (anyerrors := true; NONE)
713                  | SOME bfc_acc => let                  | SOME bfc_acc => let
# Line 536  Line 743 
743                          end                          end
744                    end)                    end)
745      end      end
746    end (* functor Stabilize *)
     fun loadStable gp { getGroup, anyerrors } group = let  
   
         val errcons = #errcons (gp: GeneralParams.info)  
         val grpSrcInfo = (errcons, anyerrors)  
         val gdescr = SrcPath.descr group  
         fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion  
             EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))  
             EM.nullErrorBody  
   
         exception Format = UU.Format  
   
         val pcmode = #pcmode (#param gp)  
         val policy = #fnpolicy (#param gp)  
         val primconf = #primconf (#param gp)  
         val pervasive = #pervasive (#param gp)  
   
         fun mksname () = FilenamePolicy.mkStableName policy group  
   
         fun work s = let  
   
             fun getGroup' p =  
                 case getGroup p of  
                     SOME g => g  
                   | NONE => (error ["unable to find ", SrcPath.descr p];  
                              raise Format)  
   
             val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s  
             val offset_adjustment = dg_sz + 4  
             val { getter, dropper } =  
                 UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)  
             val session = UU.mkSession getter  
   
             val sgListM = UU.mkMap ()  
             val stringListM = UU.mkMap ()  
             val stringListM = UU.mkMap ()  
             val ssM = UU.mkMap ()  
             val ssoM = UU.mkMap ()  
             val boolOptionM = UU.mkMap ()  
             val siM = UU.mkMap ()  
             val snM = UU.mkMap ()  
             val snListM = UU.mkMap ()  
             val sbnM = UU.mkMap ()  
             val fsbnM = UU.mkMap ()  
             val fsbnListM = UU.mkMap ()  
             val impexpM = UU.mkMap ()  
             val impexpListM = UU.mkMap ()  
             val groupM = UU.mkMap ()  
             val apM = UU.mkMap ()  
             val primitiveM = UU.mkMap ()  
             val exportsM = UU.mkMap ()  
             val privilegesM = UU.mkMap ()  
   
             fun list m r = UU.r_list session m r  
             val string = UU.r_string session  
             val stringlist = list stringListM string  
   
             fun option m r = UU.r_option session m r  
             val int = UU.r_int session  
             fun share m r = UU.share session m r  
             fun nonshare r = UU.nonshare session r  
             val bool = UU.r_bool session  
             val pid = UnpickleSymPid.r_pid (session, string)  
   
             fun abspath () = let  
                 fun ap #"p" =  
                     (SrcPath.unpickle pcmode (stringlist (), group)  
                      handle SrcPath.Format => raise Format  
                           | SrcPath.BadAnchor a =>  
                          (error ["configuration anchor \"", a, "\" undefined"];  
                           raise Format))  
                   | ap _ = raise Format  
             in  
                 share apM ap  
             end  
   
             fun sg () = let  
                 val p = abspath ()  
             in  
                 (p, getGroup' p)  
             end  
   
             fun gr #"g" =  
                 let val sublibs = list sgListM sg ()  
   
                     (* Now that we have the list of sublibs, we can build the  
                      * environment for unpickling the environment list.  
                      * We will need the environment list when unpickling the  
                      * export list (making SB_BNODES). *)  
                     fun prim_context "pv" = SOME (E.staticPart pervasive)  
                       | prim_context s =  
                         SOME (E.staticPart  
                               (Primitive.env primconf  
                                (valOf (Primitive.fromIdent primconf  
                                        (String.sub (s, 0))))))  
                         handle _ => NONE  
                     fun node_context (n, sy) = let  
                         val (_, GG.GROUP { exports = slexp, ... }) =  
                             List.nth (sublibs, n)  
                     in  
                         case SymbolMap.find (slexp, sy) of  
                             SOME ((_, DG.SB_BNODE (_, x)), _) =>  
                                 SOME (#env (#statenv x ()))  
                           | _ => NONE  
                     end handle _ => NONE  
   
                     val { symenv, env, symbol, symbollist } =  
                         UP.mkUnpicklers session  
                           { prim_context = prim_context,  
                             node_context = node_context }  
   
                     val lazy_symenv = UU.r_lazy session symenv  
                     val lazy_env = UU.r_lazy session env  
   
                     fun symbolset () = let  
                         fun s #"s" =  
                             SymbolSet.addList (SymbolSet.empty, symbollist ())  
                           | s _ = raise Format  
                     in  
                         share ssM s  
                     end  
   
                     val filter = option ssoM symbolset  
   
                     fun primitive () = let  
                         fun p #"p" =  
                             (valOf (Primitive.fromIdent primconf  
                                     (String.sub (string (), 0)))  
                              handle _ => raise Format)  
                           | p _ = raise Format  
                     in  
                         share primitiveM p  
                     end  
   
                     fun shm () = let  
                         fun s #"a" = Sharing.SHARE true  
                           | s #"b" = Sharing.SHARE false  
                           | s #"c" = Sharing.DONTSHARE  
                           | s _ = raise Format  
                     in  
                         nonshare s  
                     end  
   
                     fun si () = let  
                         fun s #"s" =  
                             let val spec = string ()  
                                 val locs = string ()  
                                 val offset = int () + offset_adjustment  
                                 val sh_mode = shm ()  
                                 val error = EM.errorNoSource grpSrcInfo locs  
                             in  
                                 BinInfo.new { group = group,  
                                               mkStablename = mksname,  
                                               error = error,  
                                               spec = spec,  
                                               offset = offset,  
                                               sh_mode = sh_mode }  
                             end  
                           | s _ = raise Format  
                     in  
                         share siM s  
                     end  
   
                     (* this is the place where what used to be an  
                      * SNODE changes to a BNODE! *)  
                     fun sn () = let  
                         fun sn' #"a" =  
                             DG.BNODE { bininfo = si (),  
                                        localimports = snlist (),  
                                        globalimports = fsbnlist () }  
                           | sn' _ = raise Format  
                     in  
                         share snM sn'  
                     end  
   
                     and snlist () = list snListM sn ()  
   
                     (* this one changes from farsbnode to plain farbnode *)  
                     and sbn () = let  
                         fun sbn' #"1" = DG.PNODE (primitive ())  
                           | sbn' #"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, _)), _) =>  
                                         (case n of  
                                              DG.BNODE _ => n  
                                            | _ => raise Format)  
                                   | _ => raise Format  
                             end  
                           | sbn' #"3" = sn ()  
                           | sbn' _ = raise Format  
                     in  
                         share sbnM sbn'  
                     end  
   
                     and fsbn () = let  
                         fun f #"f" = (filter (), sbn ())  
                           | f _ = raise Format  
                     in  
                         share fsbnM f  
                     end  
   
                     and fsbnlist () = list fsbnListM fsbn ()  
   
                     fun impexp () = let  
                         fun ie #"i" =  
                             let val sy = symbol ()  
                                 (* really reads farbnodes! *)  
                                 val (f, n) = fsbn ()  
                                 val ge = lazy_env ()  
                                 fun bs2es { env, ctxt } =  
                                     { env = GenericVC.CoerceEnv.bs2es env,  
                                       ctxt = ctxt }  
                                 val ge' = bs2es o ge  
                                 val ii = { statenv = Memoize.memoize ge',  
                                            symenv = lazy_symenv (),  
                                            statpid = pid (),  
                                            sympid = pid () }  
                                 val e = Statenv2DAEnv.cvtMemo (#env o ge)  
                                 (* put a filter in front to avoid having the  
                                  * FCTENV being queried needlessly (this  
                                  * avoids spurious module loadings) *)  
                                 val e' =  
                                     DAEnv.FILTER (SymbolSet.singleton sy, e)  
                             in  
                                 (sy, ((f, DG.SB_BNODE (n, ii)), e'))  
                             end  
                           | ie _ = raise Format  
                     in  
                         share impexpM ie  
                     end  
   
                     val impexplist = list impexpListM impexp  
   
                     fun r_exports () = let  
                         fun e #"e" =  
                             foldl SymbolMap.insert'  
                                   SymbolMap.empty (impexplist ())  
                           | e _ = raise Format  
                     in  
                         share exportsM e  
                     end  
   
                     val stringlist = list stringListM string  
   
                     fun privileges () = let  
                         fun p #"p" =  
                             StringSet.addList (StringSet.empty, stringlist ())  
                           | p _ = raise Format  
                     in  
                         share privilegesM p  
                     end  
   
                     val exports = r_exports ()  
                     val required = privileges ()  
                 in  
                     GG.GROUP { exports = exports,  
                               kind = GG.STABLELIB dropper,  
                               required = required,  
                               grouppath = group,  
                               sublibs = sublibs }  
                 end  
               | gr _ = raise Format  
         in  
             share groupM gr  
         end  
     in  
         SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,  
                                closeIt = BinIO.closeIn,  
                                work = work,  
                                cleanup = fn _ => () })  
         handle Format => (error ["file is corrupted (old version?)"];  
                           NONE)  
              | IO.Io _ => NONE  
     end  
 end  
747    
748  end (* local *)  end (* local *)

Legend:
Removed from v.536  
changed lines
  Added in v.537

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