Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/stable/stabilize.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/stable/stabilize.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 402 - (view) (download)

1 : blume 309 (*
2 :     * Reading, generating, and writing stable groups.
3 :     *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 :     local
9 : blume 304 structure DG = DependencyGraph
10 : blume 306 structure GG = GroupGraph
11 :     structure EM = GenericVC.ErrorMsg
12 : blume 311 structure PP = PrettyPrint
13 :     structure SM = GenericVC.SourceMap
14 : blume 309 structure GP = GeneralParams
15 :     structure E = GenericVC.Environment
16 : blume 357 structure Pid = GenericVC.PersStamps
17 : blume 398 structure P = PickMod
18 :     structure UP = UnpickMod
19 :     structure E = GenericVC.Environment
20 : blume 310
21 : blume 314 type recomp = GP.info -> GG.group -> bool
22 : blume 402
23 : blume 357 type pid = Pid.persstamp
24 : blume 309 in
25 : blume 304
26 : blume 309 signature STABILIZE = sig
27 :    
28 :     val loadStable :
29 : blume 398 GP.info -> { getGroup: SrcPath.t -> GG.group option,
30 :     anyerrors: bool ref }
31 :     -> SrcPath.t -> GG.group option
32 : blume 309
33 :     val stabilize :
34 : blume 398 GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
35 : blume 309 end
36 :    
37 : blume 399 functor StabilizeFn (val writeBFC : BinIO.outstream -> SmlInfo.info -> unit
38 :     val sizeBFC : SmlInfo.info -> int
39 :     val getII : SmlInfo.info -> IInfo.info
40 : blume 400 val destroy_state : GP.info -> SmlInfo.info -> unit
41 : blume 357 val recomp : recomp) :> STABILIZE = struct
42 : blume 309
43 : blume 385 structure SSMap = BinaryMapFn
44 :     (struct
45 :     type ord_key = SymbolSet.set
46 :     val compare = SymbolSet.compare
47 :     end)
48 :    
49 : blume 384 structure SNMap = BinaryMapFn
50 :     (struct
51 :     type ord_key = DG.snode
52 :     fun compare (DG.SNODE n, DG.SNODE n') =
53 :     SmlInfo.compare (#smlinfo n, #smlinfo n')
54 : blume 304 end)
55 :    
56 : blume 398 structure PU = PickleUtil
57 :     structure UU = UnpickleUtil
58 : blume 384
59 : blume 398 type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
60 : blume 393
61 : blume 398 val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
62 : blume 393
63 : blume 398 val lifter =
64 :     { extract = fn (m: map) => #pm m,
65 :     patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
66 :    
67 : blume 393 infix 3 $
68 :     infixr 4 &
69 :     val op & = PU.&
70 :     val % = PU.%
71 :    
72 :     (* type info *)
73 :     val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
74 :    
75 : blume 398 val SSs =
76 :     { find = fn (m: map, k) => SSMap.find (#ss m, k),
77 :     insert = fn ({ ss, sn, pm }, k, v) =>
78 :     { sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
79 :     val SNs =
80 :     { find = fn (m: map, k) => SNMap.find (#sn m, k),
81 :     insert = fn ({ ss, sn, pm }, k, v) =>
82 :     { ss = ss, sn = SNMap.insert (sn, k, v), pm = pm } }
83 : blume 385
84 : blume 311 fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
85 : blume 304
86 : blume 323 val primconf = #primconf (#param gp)
87 :     val policy = #fnpolicy (#param gp)
88 : blume 398 val pervasive = #pervasive (#param gp)
89 : blume 323
90 : blume 340 val grouppath = #grouppath grec
91 :    
92 : blume 348 fun doit wrapped = let
93 : blume 312
94 : blume 314 val _ =
95 : blume 348 if StringSet.isEmpty wrapped then ()
96 : blume 314 else
97 :     Say.say ("$Stabilize: wrapping the following privileges:\n"
98 : blume 312 :: map (fn s => (" " ^ s ^ "\n"))
99 : blume 348 (StringSet.listItems wrapped))
100 : blume 312
101 : blume 311 val grpSrcInfo = (#errcons gp, anyerrors)
102 : blume 308
103 : blume 311 val exports = #exports grec
104 : blume 348 val required = StringSet.difference (#required grec, wrapped)
105 : blume 340 val sublibs = #sublibs grec
106 : blume 304
107 : blume 311 (* The format of a stable archive is the following:
108 :     * - It starts with the size s of the pickled dependency
109 :     * graph. This size itself is written as four-byte string.
110 : blume 398 * - The size t of the pickled environment for the entire
111 :     * library (using the pickleEnvN interface of the pickler)
112 :     * in the same format as s.
113 : blume 311 * - The pickled dependency graph. This graph contains
114 :     * integer offsets of the binfiles for the individual ML
115 :     * members. These offsets need to be adjusted by adding
116 : blume 398 * s + t + 8. The pickled dependency graph also contains integer
117 : blume 311 * offsets relative to other stable groups. These offsets
118 :     * need no further adjustment.
119 : blume 398 * - The pickled environment (list). To be unpickled using
120 :     * unpickleEnvN.
121 :     * - Individual binfile contents (concatenated) but without
122 :     * their static environments.
123 : blume 311 *)
124 : blume 304
125 : blume 340 (* Here we build a mapping that maps each BNODE to a number
126 :     * representing the sub-library that it came from and a
127 :     * representative symbol that can be used to find the BNODE
128 :     * within the exports of that library *)
129 : blume 398 fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
130 : blume 340 StableMap.insert (m, #bininfo n, (i, sy))
131 :     | oneB i (_, _, m) = m
132 : blume 380 fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
133 : blume 340 (SymbolMap.foldli (oneB i) m exports, i + 1)
134 :     val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
135 : blume 330
136 : blume 311 val members = ref []
137 :     val (registerOffset, getOffset) = let
138 :     val dict = ref SmlInfoMap.empty
139 :     val cur = ref 0
140 :     fun reg (i, sz) = let
141 :     val os = !cur
142 : blume 306 in
143 : blume 311 cur := os + sz;
144 :     dict := SmlInfoMap.insert (!dict, i, os);
145 :     members := i :: (!members);
146 :     os
147 : blume 306 end
148 : blume 311 fun get i = valOf (SmlInfoMap.find (!dict, i))
149 :     in
150 :     (reg, get)
151 :     end
152 : blume 304
153 : blume 398 (* Collect all BNODEs and PNODEs that we see and build
154 :     * a context suitable for P.envPickler. *)
155 :     fun mkContext () = let
156 :     fun lst f [] k s = k s
157 :     | lst f (h :: t) k s = f h (lst f t k) s
158 :    
159 :     fun sbn n k (s as (prims, bnodes, snodes)) =
160 :     case n of
161 :     DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let
162 :     val str = String.str (Primitive.toIdent primconf p)
163 :     val prims' = StringMap.insert (prims, str, statenv)
164 :     in
165 :     k (prims', bnodes, snodes)
166 :     end
167 :     | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
168 :     val { statenv, ... } = ii
169 :     val nsy = valOf (StableMap.find (inverseMap, i))
170 :     val bnodes' =
171 :     StableMap.insert (bnodes, i, (nsy, statenv))
172 :     in
173 :     k (prims, bnodes', snodes)
174 :     end
175 :     | DG.SB_SNODE n => sn n k s
176 :    
177 :     and sn (DG.SNODE n) k (prims, bnodes, snodes) = let
178 :     val i = #smlinfo n
179 :     val li = #localimports n
180 :     val gi = #globalimports n
181 :     in
182 :     if SmlInfoSet.member (snodes, i) then
183 :     k (prims, bnodes, snodes)
184 :     else let
185 :     val snodes' = SmlInfoSet.add (snodes, i)
186 :     in
187 :     lst sn li (lst fsbn gi k) (prims, bnodes, snodes')
188 :     end
189 :     end
190 :    
191 :     and fsbn (_, n) k s = sbn n k s
192 :    
193 :     fun impexp (n, _) k s = fsbn n k s
194 :    
195 :     val (prims, bnodes) =
196 :     lst impexp (SymbolMap.listItems exports)
197 :     (fn (prims, bnodes, _) => (prims, bnodes))
198 :     (StringMap.empty, StableMap.empty, SmlInfoSet.empty)
199 :    
200 :     val priml = StringMap.listItemsi prims
201 :     val bnodel = StableMap.listItems bnodes
202 :    
203 :     fun cvt lk id = let
204 :     fun nloop [] = NONE
205 :     | nloop ((k, ge) :: t) =
206 :     (case lk (ge ()) id of
207 :     SOME _ => SOME (P.NodeKey k)
208 :     | NONE => nloop t)
209 :     fun ploop [] = nloop bnodel
210 :     | ploop ((k, ge) :: t) =
211 :     (case lk (ge ()) id of
212 :     SOME _ => SOME (P.PrimKey k)
213 :     | NONE => ploop t)
214 :     in
215 :     case lk (E.staticPart pervasive) id of
216 :     NONE => ploop priml
217 :     | SOME _ => SOME (P.PrimKey "pv")
218 :     end
219 :     in
220 :     { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
221 :     lookSIG = cvt GenericVC.CMStaticEnv.lookSIG,
222 :     lookFCT = cvt GenericVC.CMStaticEnv.lookFCT,
223 :     lookFSIG = cvt GenericVC.CMStaticEnv.lookFSIG,
224 :     lookTYC = cvt GenericVC.CMStaticEnv.lookTYC,
225 :     lookEENV = cvt GenericVC.CMStaticEnv.lookEENV }
226 :     end
227 :    
228 :     (* make the picklers for static and symbolic environments;
229 :     * lift them so we can use them here... *)
230 :     val envContext = mkContext ()
231 :     val env_orig = P.envPickler envContext
232 :     val env = PU.lift_pickler lifter env_orig
233 :     val symenv_orig = P.symenvPickler
234 :     val symenv = PU.lift_pickler lifter symenv_orig
235 :     val lazy_env = PU.w_lazy env
236 :     val lazy_symenv = PU.w_lazy symenv
237 :    
238 : blume 384 val int = PU.w_int
239 : blume 398 val symbol = PickleSymPid.w_symbol
240 :     val pid = PickleSymPid.w_pid
241 : blume 384 val share = PU.ah_share
242 :     val option = PU.w_option
243 :     val list = PU.w_list
244 :     val string = PU.w_string
245 :     val bool = PU.w_bool
246 :     val int = PU.w_int
247 : blume 304
248 : blume 385 fun symbolset ss = let
249 :     val op $ = PU.$ SS
250 :     fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
251 :     in
252 :     share SSs raw_ss ss
253 :     end
254 : blume 304
255 : blume 384 val filter = option symbolset
256 : blume 304
257 : blume 387 fun shm (Sharing.SHARE true) = %SHM "a"
258 :     | shm (Sharing.SHARE false) = %SHM "b"
259 :     | shm Sharing.DONTSHARE = %SHM "c"
260 : blume 304
261 : blume 384 fun si i = let
262 : blume 340 (* FIXME: this is not a technical flaw, but perhaps one
263 :     * that deserves fixing anyway: If we only look at spec,
264 :     * then we are losing information about sub-grouping
265 :     * within libraries. However, the spec in BinInfo.info
266 :     * is only used for diagnostics and has no impact on the
267 :     * operation of CM itself. *)
268 : blume 354 val spec = SrcPath.specOf (SmlInfo.sourcepath i)
269 : blume 311 val locs = SmlInfo.errorLocation gp i
270 : blume 398 val offset = registerOffset (i, sizeBFC i)
271 : blume 387 val sh_mode = SmlInfo.sh_mode i
272 : blume 385 val op $ = PU.$ SI
273 : blume 311 in
274 : blume 387 "s" $ string spec & string locs & int offset & shm sh_mode
275 : blume 311 end
276 : blume 306
277 : blume 384 fun primitive p =
278 :     string (String.str (Primitive.toIdent primconf p))
279 : blume 306
280 : blume 340 fun warn_relabs p abs = let
281 :     val relabs = if abs then "absolute" else "relative"
282 : blume 330 fun ppb pps =
283 :     (PP.add_newline pps;
284 : blume 354 PP.add_string pps (SrcPath.descr p);
285 : blume 330 PP.add_newline pps;
286 :     PP.add_string pps
287 :     "(This means that in order to be able to use the result of stabilization";
288 :     PP.add_newline pps;
289 : blume 340 PP.add_string pps "the library must be in the same ";
290 : blume 330 PP.add_string pps relabs;
291 :     PP.add_string pps " location as it is now.)";
292 :     PP.add_newline pps)
293 :     in
294 :     EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
295 :     EM.WARN
296 : blume 354 (concat [SrcPath.descr grouppath,
297 : blume 340 ": library referred to by ", relabs,
298 :     " pathname:"])
299 : blume 330 ppb
300 :     end
301 : blume 306
302 : blume 384 fun abspath p = let
303 :     val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
304 :     in
305 :     list string pp
306 :     end
307 : blume 306
308 : blume 385 fun sn n = let
309 : blume 398 val op $ = PU.$ SN
310 : blume 385 fun raw_sn (DG.SNODE n) =
311 :     "a" $ si (#smlinfo n) & list sn (#localimports n) &
312 :     list fsbn (#globalimports n)
313 : blume 384 in
314 : blume 385 share SNs raw_sn n
315 :     end
316 : blume 306
317 : blume 398 (* Here we ignore the interface info because we will not
318 :     * need it anymore when we unpickle. *)
319 : blume 385 and sbn x = let
320 :     val op $ = PU.$ SBN
321 :     in
322 :     case x of
323 : blume 398 DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
324 :     "1" $ primitive p
325 :     | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
326 :     val (n, sy) = valOf (StableMap.find (inverseMap, i))
327 :     in
328 :     "2" $ int n & symbol sy
329 :     end
330 :     | DG.SB_SNODE n => "3" $ sn n
331 : blume 385 end
332 :    
333 :     and fsbn (f, n) = let
334 :     val op $ = PU.$ FSBN
335 :     in
336 :     "f" $ filter f & sbn n
337 :     end
338 : blume 370
339 : blume 398 (* Here is the place where we need to write interface info. *)
340 : blume 385 fun impexp (s, (n, _)) = let
341 :     val op $ = PU.$ IMPEXP
342 : blume 398 val { statenv, symenv, statpid, sympid } =
343 :     case n of
344 :     (_, DG.SB_BNODE (_, ii)) => ii
345 :     | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
346 :     getII smlinfo
347 : blume 385 in
348 : blume 398 "i" $ symbol s & fsbn n &
349 :     lazy_env (GenericVC.CoerceEnv.es2bs o statenv) &
350 :     lazy_symenv symenv &
351 :     pid statpid &
352 :     pid sympid
353 : blume 384 end
354 : blume 307
355 : blume 384 fun w_exports e = list impexp (SymbolMap.listItemsi e)
356 : blume 306
357 : blume 384 fun privileges p = list string (StringSet.listItems p)
358 : blume 306
359 : blume 384 fun group () = let
360 :     fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
361 : blume 311 in
362 : blume 340 (* Pickle the sublibs first because we need to already
363 : blume 330 * have them back when we unpickle BNODEs. *)
364 : blume 384 list sg sublibs & w_exports exports & privileges required
365 : blume 311 end
366 : blume 308
367 : blume 398 val dg_pickle =
368 :     Byte.stringToBytes (PU.pickle emptyMap (group ()))
369 :     val dg_sz = Word8Vector.length dg_pickle
370 : blume 308
371 : blume 398 val offset_adjustment = dg_sz + 4
372 :    
373 : blume 361 fun mkStableGroup mksname = let
374 : blume 311 val m = ref SmlInfoMap.empty
375 :     fun sn (DG.SNODE (n as { smlinfo, ... })) =
376 :     case SmlInfoMap.find (!m, smlinfo) of
377 :     SOME n => n
378 :     | NONE => let
379 : blume 371 val li = map sn (#localimports n)
380 :     val gi = map fsbn (#globalimports n)
381 : blume 311 val sourcepath = SmlInfo.sourcepath smlinfo
382 : blume 340 (* FIXME: see the comment near the other
383 : blume 354 * occurence of SrcPath.spec... *)
384 :     val spec = SrcPath.specOf sourcepath
385 : blume 311 val offset =
386 :     getOffset smlinfo + offset_adjustment
387 : blume 387 val sh_mode = SmlInfo.sh_mode smlinfo
388 : blume 311 val locs = SmlInfo.errorLocation gp smlinfo
389 :     val error = EM.errorNoSource grpSrcInfo locs
390 :     val i = BinInfo.new { group = grouppath,
391 : blume 361 mkStablename = mksname,
392 : blume 311 spec = spec,
393 :     offset = offset,
394 : blume 387 sh_mode = sh_mode,
395 : blume 311 error = error }
396 :     val n = DG.BNODE { bininfo = i,
397 :     localimports = li,
398 :     globalimports = gi }
399 :     in
400 : blume 400 destroy_state gp smlinfo;
401 : blume 311 m := SmlInfoMap.insert (!m, smlinfo, n);
402 :     n
403 :     end
404 : blume 308
405 : blume 398 and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
406 :     let val ii = getII i
407 :     in
408 :     (sn n, ii)
409 :     end
410 :     | sbn (DG.SB_BNODE (n, ii)) = (n, ii)
411 : blume 308
412 : blume 398 and fsbn (f, n) = (f, #1 (sbn n))
413 : blume 308
414 : blume 311 fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
415 : blume 308
416 : blume 311 val exports = SymbolMap.map impexp (#exports grec)
417 :     in
418 :     GG.GROUP { exports = exports,
419 : blume 398 kind = GG.STABLELIB,
420 : blume 311 required = required,
421 :     grouppath = grouppath,
422 : blume 348 sublibs = sublibs }
423 : blume 311 end
424 : blume 308
425 : blume 311 fun writeInt32 (s, i) = let
426 :     val a = Word8Array.array (4, 0w0)
427 :     val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
428 :     in
429 :     BinIO.output (s, Word8Array.extract (a, 0, NONE))
430 :     end
431 :     val memberlist = rev (!members)
432 :    
433 :     val gpath = #grouppath grec
434 : blume 361 fun mksname () = FilenamePolicy.mkStableName policy gpath
435 : blume 345 fun work outs =
436 : blume 354 (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
437 : blume 398 writeInt32 (outs, dg_sz);
438 :     BinIO.output (outs, dg_pickle);
439 :     app (writeBFC outs) memberlist;
440 : blume 361 mkStableGroup mksname)
441 : blume 311 in
442 : blume 361 SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
443 : blume 345 closeIt = BinIO.closeOut,
444 :     work = work,
445 : blume 354 cleanup = fn () =>
446 : blume 361 (OS.FileSys.remove (mksname ())
447 :     handle _ => ()) })
448 : blume 345 handle exn => NONE
449 : blume 311 end
450 :     in
451 : blume 348 case #kind grec of
452 : blume 398 GG.STABLELIB => SOME g
453 : blume 348 | GG.NOLIB => EM.impossible "stabilize: no library"
454 :     | GG.LIB wrapped =>
455 : blume 402 if not (recomp gp g) then (anyerrors := true; NONE)
456 : blume 311 else let
457 : blume 380 fun notStable (GG.GROUP { kind, ... }) =
458 : blume 398 case kind of GG.STABLELIB => false | _ => true
459 : blume 308 in
460 : blume 340 case List.filter notStable (#sublibs grec) of
461 : blume 348 [] => doit wrapped
462 : blume 311 | l => let
463 :     val grammar = case l of [_] => " is" | _ => "s are"
464 :     fun ppb pps = let
465 :     fun loop [] = ()
466 : blume 380 | loop (GG.GROUP { grouppath, ... } :: t) =
467 : blume 311 (PP.add_string pps
468 : blume 354 (SrcPath.descr grouppath);
469 : blume 311 PP.add_newline pps;
470 :     loop t)
471 :     in
472 :     PP.add_newline pps;
473 :     PP.add_string pps
474 :     (concat ["because the following sub-group",
475 :     grammar, " not stable:"]);
476 :     PP.add_newline pps;
477 :     loop l
478 :     end
479 :     val errcons = #errcons gp
480 : blume 354 val gdescr = SrcPath.descr (#grouppath grec)
481 : blume 311 in
482 :     EM.errorNoFile (errcons, anyerrors) SM.nullRegion
483 :     EM.COMPLAIN
484 : blume 354 (gdescr ^ " cannot be stabilized")
485 : blume 311 ppb;
486 :     NONE
487 :     end
488 : blume 308 end
489 : blume 311 end
490 : blume 310
491 : blume 398 fun loadStable gp { getGroup, anyerrors } group = let
492 : blume 306
493 : blume 398 val errcons = #errcons (gp: GeneralParams.info)
494 : blume 311 val grpSrcInfo = (errcons, anyerrors)
495 : blume 354 val gdescr = SrcPath.descr group
496 : blume 311 fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
497 : blume 367 EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
498 :     EM.nullErrorBody
499 : blume 309
500 : blume 384 exception Format = UU.Format
501 : blume 306
502 : blume 318 val pcmode = #pcmode (#param gp)
503 : blume 310 val policy = #fnpolicy (#param gp)
504 : blume 323 val primconf = #primconf (#param gp)
505 : blume 398 val pervasive = #pervasive (#param gp)
506 :    
507 : blume 361 fun mksname () = FilenamePolicy.mkStableName policy group
508 : blume 310
509 : blume 345 fun work s = let
510 : blume 310
511 : blume 345 fun getGroup' p =
512 :     case getGroup p of
513 :     SOME g => g
514 : blume 354 | NONE => (error ["unable to find ", SrcPath.descr p];
515 : blume 345 raise Format)
516 : blume 306
517 : blume 345 fun bytesIn n = let
518 :     val bv = BinIO.inputN (s, n)
519 :     in
520 :     if n = Word8Vector.length bv then bv
521 :     else raise Format
522 :     end
523 : blume 304
524 : blume 398 val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
525 :     val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
526 :     val offset_adjustment = dg_sz + 4
527 :     val session = UU.mkSession (UU.stringGetter dg_pickle)
528 : blume 345
529 : blume 398 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 : blume 304
534 : blume 398 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 : blume 384 fun option m r = UU.r_option session m r
573 :     val int = UU.r_int session
574 :     fun share m r = UU.share session m r
575 : blume 387 fun nonshare r = UU.nonshare session r
576 : blume 384 val bool = UU.r_bool session
577 : blume 398 val pid = UnpickleSymPid.r_pid string
578 : blume 304
579 : blume 384 val stringListM = UU.mkMap ()
580 : blume 385 val ssM = UU.mkMap ()
581 : blume 384 val ssoM = UU.mkMap ()
582 :     val boolOptionM = UU.mkMap ()
583 : blume 385 val siM = UU.mkMap ()
584 : blume 384 val snM = UU.mkMap ()
585 :     val snListM = UU.mkMap ()
586 :     val sbnM = UU.mkMap ()
587 : blume 385 val fsbnM = UU.mkMap ()
588 : blume 384 val fsbnListM = UU.mkMap ()
589 : blume 385 val impexpM = UU.mkMap ()
590 : blume 384 val impexpListM = UU.mkMap ()
591 : blume 304
592 : blume 385 fun symbolset () = let
593 :     fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
594 :     | s _ = raise Format
595 :     in
596 :     share ssM s
597 :     end
598 : blume 305
599 : blume 384 val filter = option ssoM symbolset
600 : blume 305
601 : blume 384 fun primitive () =
602 :     valOf (Primitive.fromIdent primconf
603 :     (String.sub (string (), 0)))
604 :     handle _ => raise Format
605 : blume 305
606 : blume 387 fun shm () = let
607 :     fun s #"a" = Sharing.SHARE true
608 :     | s #"b" = Sharing.SHARE false
609 :     | s #"c" = Sharing.DONTSHARE
610 :     | s _ = raise Format
611 :     in
612 :     nonshare s
613 :     end
614 : blume 305
615 : blume 384 fun si () = let
616 : blume 385 fun s #"s" =
617 :     let val spec = string ()
618 :     val locs = string ()
619 :     val offset = int () + offset_adjustment
620 : blume 387 val sh_mode = shm ()
621 : blume 385 val error = EM.errorNoSource grpSrcInfo locs
622 :     in
623 :     BinInfo.new { group = group,
624 :     mkStablename = mksname,
625 :     error = error,
626 :     spec = spec,
627 :     offset = offset,
628 : blume 387 sh_mode = sh_mode }
629 : blume 385 end
630 :     | s _ = raise Format
631 : blume 345 in
632 : blume 385 share siM s
633 : blume 345 end
634 : blume 306
635 : blume 330 (* this is the place where what used to be an
636 :     * SNODE changes to a BNODE! *)
637 : blume 384 fun sn () = let
638 :     fun sn' #"a" =
639 :     DG.BNODE { bininfo = si (),
640 :     localimports = snlist (),
641 :     globalimports = fsbnlist () }
642 :     | sn' _ = raise Format
643 :     in
644 :     share snM sn'
645 :     end
646 : blume 306
647 : blume 384 and snlist () = list snListM sn ()
648 : blume 306
649 : blume 330 (* this one changes from farsbnode to plain farbnode *)
650 : blume 384 and sbn () = let
651 : blume 398 fun sbn' #"1" = DG.PNODE (primitive ())
652 :     | 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 : blume 384 | sbn' _ = raise Format
665 :     in
666 :     share sbnM sbn'
667 :     end
668 : blume 306
669 : blume 385 and fsbn () = let
670 :     fun f #"f" = (filter (), sbn ())
671 :     | f _ = raise Format
672 :     in
673 :     share fsbnM f
674 :     end
675 : blume 306
676 : blume 384 and fsbnlist () = list fsbnListM fsbn ()
677 :    
678 :     fun impexp () = let
679 : blume 385 fun ie #"i" =
680 :     let val sy = symbol ()
681 :     val (f, n) = fsbn () (* really reads farbnodes! *)
682 : blume 398 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 : blume 385 (* put a filter in front to avoid having the FCTENV
689 :     * being queried needlessly (this avoids spurious
690 :     * module loadings) *)
691 :     val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
692 :     in
693 : blume 398 (sy, ((f, DG.SB_BNODE (n, ii)), e'))
694 : blume 385 end
695 :     | ie _ = raise Format
696 : blume 330 in
697 : blume 385 share impexpM ie
698 : blume 330 end
699 :    
700 : blume 384 val impexplist = list impexpListM impexp
701 :    
702 : blume 398 fun r_exports () = let
703 :     val iel = impexplist ()
704 :     in
705 :     foldl SymbolMap.insert' SymbolMap.empty iel
706 :     end
707 : blume 330
708 : blume 384 val stringlist = list stringListM string
709 : blume 330
710 : blume 384 fun privileges () =
711 :     StringSet.addList (StringSet.empty, stringlist ())
712 :    
713 : blume 306 val exports = r_exports ()
714 : blume 384 val required = privileges ()
715 : blume 306 in
716 :     GG.GROUP { exports = exports,
717 : blume 398 kind = GG.STABLELIB,
718 : blume 306 required = required,
719 : blume 308 grouppath = group,
720 : blume 348 sublibs = sublibs }
721 : blume 306 end
722 : blume 304 in
723 : blume 361 SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
724 : blume 345 closeIt = BinIO.closeIn,
725 :     work = work,
726 :     cleanup = fn () => () })
727 : blume 402 handle Format => (error ["file is corrupted (old version?)"];
728 :     NONE)
729 : blume 346 | IO.Io _ => NONE
730 : blume 345 end
731 : blume 304 end
732 : blume 309
733 :     end (* local *)

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