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

Parent Directory | Revision Log

---

Revision 399 - (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	357	type pid = Pid.persstamp
23 :	blume	309	in
24 :	blume	304
25 :	blume	309	signature STABILIZE = sig
26 :
27 :			val loadStable :
28 :	blume	398	GP.info -> { getGroup: SrcPath.t -> GG.group option,
29 :			anyerrors: bool ref }
30 :			-> SrcPath.t -> GG.group option
31 :	blume	309
32 :			val stabilize :
33 :	blume	398	GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
34 :	blume	309	end
35 :
36 :	blume	399	functor StabilizeFn (val writeBFC : BinIO.outstream -> SmlInfo.info -> unit
37 :			val sizeBFC : SmlInfo.info -> int
38 :			val getII : SmlInfo.info -> IInfo.info
39 :			val destroy_state : SmlInfo.info -> unit
40 :	blume	357	val recomp : recomp) :> STABILIZE = struct
41 :	blume	309
42 :	blume	385	structure SSMap = BinaryMapFn
43 :			(struct
44 :			type ord_key = SymbolSet.set
45 :			val compare = SymbolSet.compare
46 :			end)
47 :
48 :	blume	384	structure SNMap = BinaryMapFn
49 :			(struct
50 :			type ord_key = DG.snode
51 :			fun compare (DG.SNODE n, DG.SNODE n') =
52 :			SmlInfo.compare (#smlinfo n, #smlinfo n')
53 :	blume	304	end)
54 :
55 :	blume	398	structure PU = PickleUtil
56 :			structure UU = UnpickleUtil
57 :	blume	384
58 :	blume	398	type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
59 :	blume	393
60 :	blume	398	val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
61 :	blume	393
62 :	blume	398	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 :	blume	393	infix 3 $
67 :			infixr 4 &
68 :			val op & = PU.&
69 :			val % = PU.%
70 :
71 :			(* type info *)
72 :			val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
73 :
74 :	blume	398	val SSs =
75 :			{ find = fn (m: map, k) => SSMap.find (#ss m, k),
76 :			insert = fn ({ ss, sn, pm }, k, v) =>
77 :			{ sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
78 :			val SNs =
79 :			{ find = fn (m: map, k) => SNMap.find (#sn m, k),
80 :			insert = fn ({ ss, sn, pm }, k, v) =>
81 :			{ ss = ss, sn = SNMap.insert (sn, k, v), pm = pm } }
82 :	blume	385
83 :	blume	311	fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
84 :	blume	304
85 :	blume	323	val primconf = #primconf (#param gp)
86 :			val policy = #fnpolicy (#param gp)
87 :	blume	398	val pervasive = #pervasive (#param gp)
88 :	blume	323
89 :	blume	340	val grouppath = #grouppath grec
90 :
91 :	blume	348	fun doit wrapped = let
92 :	blume	312
93 :	blume	314	val _ =
94 :	blume	348	if StringSet.isEmpty wrapped then ()
95 :	blume	314	else
96 :			Say.say ("$Stabilize: wrapping the following privileges:\n"
97 :	blume	312	:: map (fn s => (" " ^ s ^ "\n"))
98 :	blume	348	(StringSet.listItems wrapped))
99 :	blume	312
100 :	blume	311	val grpSrcInfo = (#errcons gp, anyerrors)
101 :	blume	308
102 :	blume	311	val exports = #exports grec
103 :	blume	348	val required = StringSet.difference (#required grec, wrapped)
104 :	blume	340	val sublibs = #sublibs grec
105 :	blume	304
106 :	blume	311	(* The format of a stable archive is the following:
107 :			* - It starts with the size s of the pickled dependency
108 :			* graph. This size itself is written as four-byte string.
109 :	blume	398	* - 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 :	blume	311	* - The pickled dependency graph. This graph contains
113 :			* integer offsets of the binfiles for the individual ML
114 :			* members. These offsets need to be adjusted by adding
115 :	blume	398	* s + t + 8. The pickled dependency graph also contains integer
116 :	blume	311	* offsets relative to other stable groups. These offsets
117 :			* need no further adjustment.
118 :	blume	398	* - The pickled environment (list). To be unpickled using
119 :			* unpickleEnvN.
120 :			* - Individual binfile contents (concatenated) but without
121 :			* their static environments.
122 :	blume	311	*)
123 :	blume	304
124 :	blume	340	(* Here we build a mapping that maps each BNODE to a number
125 :			* representing the sub-library that it came from and a
126 :			* representative symbol that can be used to find the BNODE
127 :			* within the exports of that library *)
128 :	blume	398	fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
129 :	blume	340	StableMap.insert (m, #bininfo n, (i, sy))
130 :			| oneB i (_, _, m) = m
131 :	blume	380	fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
132 :	blume	340	(SymbolMap.foldli (oneB i) m exports, i + 1)
133 :			val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
134 :	blume	330
135 :	blume	311	val members = ref []
136 :			val (registerOffset, getOffset) = let
137 :			val dict = ref SmlInfoMap.empty
138 :			val cur = ref 0
139 :			fun reg (i, sz) = let
140 :			val os = !cur
141 :	blume	306	in
142 :	blume	311	cur := os + sz;
143 :			dict := SmlInfoMap.insert (!dict, i, os);
144 :			members := i :: (!members);
145 :			os
146 :	blume	306	end
147 :	blume	311	fun get i = valOf (SmlInfoMap.find (!dict, i))
148 :			in
149 :			(reg, get)
150 :			end
151 :	blume	304
152 :	blume	398	(* 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 :	blume	384	val int = PU.w_int
238 :	blume	398	val symbol = PickleSymPid.w_symbol
239 :			val pid = PickleSymPid.w_pid
240 :	blume	384	val share = PU.ah_share
241 :			val option = PU.w_option
242 :			val list = PU.w_list
243 :			val string = PU.w_string
244 :			val bool = PU.w_bool
245 :			val int = PU.w_int
246 :	blume	304
247 :	blume	385	fun symbolset ss = let
248 :			val op $ = PU.$ SS
249 :			fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
250 :			in
251 :			share SSs raw_ss ss
252 :			end
253 :	blume	304
254 :	blume	384	val filter = option symbolset
255 :	blume	304
256 :	blume	387	fun shm (Sharing.SHARE true) = %SHM "a"
257 :			| shm (Sharing.SHARE false) = %SHM "b"
258 :			| shm Sharing.DONTSHARE = %SHM "c"
259 :	blume	304
260 :	blume	384	fun si i = let
261 :	blume	340	(* FIXME: this is not a technical flaw, but perhaps one
262 :			* that deserves fixing anyway: If we only look at spec,
263 :			* then we are losing information about sub-grouping
264 :			* within libraries. However, the spec in BinInfo.info
265 :			* is only used for diagnostics and has no impact on the
266 :			* operation of CM itself. *)
267 :	blume	354	val spec = SrcPath.specOf (SmlInfo.sourcepath i)
268 :	blume	311	val locs = SmlInfo.errorLocation gp i
269 :	blume	398	val offset = registerOffset (i, sizeBFC i)
270 :	blume	387	val sh_mode = SmlInfo.sh_mode i
271 :	blume	385	val op $ = PU.$ SI
272 :	blume	311	in
273 :	blume	387	"s" $ string spec & string locs & int offset & shm sh_mode
274 :	blume	311	end
275 :	blume	306
276 :	blume	384	fun primitive p =
277 :			string (String.str (Primitive.toIdent primconf p))
278 :	blume	306
279 :	blume	340	fun warn_relabs p abs = let
280 :			val relabs = if abs then "absolute" else "relative"
281 :	blume	330	fun ppb pps =
282 :			(PP.add_newline pps;
283 :	blume	354	PP.add_string pps (SrcPath.descr p);
284 :	blume	330	PP.add_newline pps;
285 :			PP.add_string pps
286 :			"(This means that in order to be able to use the result of stabilization";
287 :			PP.add_newline pps;
288 :	blume	340	PP.add_string pps "the library must be in the same ";
289 :	blume	330	PP.add_string pps relabs;
290 :			PP.add_string pps " location as it is now.)";
291 :			PP.add_newline pps)
292 :			in
293 :			EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
294 :			EM.WARN
295 :	blume	354	(concat [SrcPath.descr grouppath,
296 :	blume	340	": library referred to by ", relabs,
297 :			" pathname:"])
298 :	blume	330	ppb
299 :			end
300 :	blume	306
301 :	blume	384	fun abspath p = let
302 :			val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
303 :			in
304 :			list string pp
305 :			end
306 :	blume	306
307 :	blume	385	fun sn n = let
308 :	blume	398	val op $ = PU.$ SN
309 :	blume	385	fun raw_sn (DG.SNODE n) =
310 :			"a" $ si (#smlinfo n) & list sn (#localimports n) &
311 :			list fsbn (#globalimports n)
312 :	blume	384	in
313 :	blume	385	share SNs raw_sn n
314 :			end
315 :	blume	306
316 :	blume	398	(* Here we ignore the interface info because we will not
317 :			* need it anymore when we unpickle. *)
318 :	blume	385	and sbn x = let
319 :			val op $ = PU.$ SBN
320 :			in
321 :			case x of
322 :	blume	398	DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
323 :			"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 :	blume	385	end
331 :
332 :			and fsbn (f, n) = let
333 :			val op $ = PU.$ FSBN
334 :			in
335 :			"f" $ filter f & sbn n
336 :			end
337 :	blume	370
338 :	blume	398	(* Here is the place where we need to write interface info. *)
339 :	blume	385	fun impexp (s, (n, _)) = let
340 :			val op $ = PU.$ IMPEXP
341 :	blume	398	val { statenv, symenv, statpid, sympid } =
342 :			case n of
343 :			(_, DG.SB_BNODE (_, ii)) => ii
344 :			| (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
345 :			getII smlinfo
346 :	blume	385	in
347 :	blume	398	"i" $ symbol s & fsbn n &
348 :			lazy_env (GenericVC.CoerceEnv.es2bs o statenv) &
349 :			lazy_symenv symenv &
350 :			pid statpid &
351 :			pid sympid
352 :	blume	384	end
353 :	blume	307
354 :	blume	384	fun w_exports e = list impexp (SymbolMap.listItemsi e)
355 :	blume	306
356 :	blume	384	fun privileges p = list string (StringSet.listItems p)
357 :	blume	306
358 :	blume	384	fun group () = let
359 :			fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
360 :	blume	311	in
361 :	blume	340	(* Pickle the sublibs first because we need to already
362 :	blume	330	* have them back when we unpickle BNODEs. *)
363 :	blume	384	list sg sublibs & w_exports exports & privileges required
364 :	blume	311	end
365 :	blume	308
366 :	blume	398	val dg_pickle =
367 :			Byte.stringToBytes (PU.pickle emptyMap (group ()))
368 :			val dg_sz = Word8Vector.length dg_pickle
369 :	blume	308
370 :	blume	398	val offset_adjustment = dg_sz + 4
371 :
372 :	blume	361	fun mkStableGroup mksname = let
373 :	blume	311	val m = ref SmlInfoMap.empty
374 :			fun sn (DG.SNODE (n as { smlinfo, ... })) =
375 :			case SmlInfoMap.find (!m, smlinfo) of
376 :			SOME n => n
377 :			| NONE => let
378 :	blume	371	val li = map sn (#localimports n)
379 :			val gi = map fsbn (#globalimports n)
380 :	blume	311	val sourcepath = SmlInfo.sourcepath smlinfo
381 :	blume	340	(* FIXME: see the comment near the other
382 :	blume	354	* occurence of SrcPath.spec... *)
383 :			val spec = SrcPath.specOf sourcepath
384 :	blume	311	val offset =
385 :			getOffset smlinfo + offset_adjustment
386 :	blume	387	val sh_mode = SmlInfo.sh_mode smlinfo
387 :	blume	311	val locs = SmlInfo.errorLocation gp smlinfo
388 :			val error = EM.errorNoSource grpSrcInfo locs
389 :			val i = BinInfo.new { group = grouppath,
390 :	blume	361	mkStablename = mksname,
391 :	blume	311	spec = spec,
392 :			offset = offset,
393 :	blume	387	sh_mode = sh_mode,
394 :	blume	311	error = error }
395 :			val n = DG.BNODE { bininfo = i,
396 :			localimports = li,
397 :			globalimports = gi }
398 :			in
399 :	blume	399	destroy_state smlinfo;
400 :	blume	311	m := SmlInfoMap.insert (!m, smlinfo, n);
401 :			n
402 :			end
403 :	blume	308
404 :	blume	398	and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
405 :			let val ii = getII i
406 :			in
407 :			(sn n, ii)
408 :			end
409 :			| sbn (DG.SB_BNODE (n, ii)) = (n, ii)
410 :	blume	308
411 :	blume	398	and fsbn (f, n) = (f, #1 (sbn n))
412 :	blume	308
413 :	blume	311	fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
414 :	blume	308
415 :	blume	311	val exports = SymbolMap.map impexp (#exports grec)
416 :			in
417 :			GG.GROUP { exports = exports,
418 :	blume	398	kind = GG.STABLELIB,
419 :	blume	311	required = required,
420 :			grouppath = grouppath,
421 :	blume	348	sublibs = sublibs }
422 :	blume	311	end
423 :	blume	308
424 :	blume	311	fun writeInt32 (s, i) = let
425 :			val a = Word8Array.array (4, 0w0)
426 :			val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
427 :			in
428 :			BinIO.output (s, Word8Array.extract (a, 0, NONE))
429 :			end
430 :			val memberlist = rev (!members)
431 :
432 :			val gpath = #grouppath grec
433 :	blume	361	fun mksname () = FilenamePolicy.mkStableName policy gpath
434 :	blume	345	fun work outs =
435 :	blume	354	(Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
436 :	blume	398	writeInt32 (outs, dg_sz);
437 :			BinIO.output (outs, dg_pickle);
438 :			app (writeBFC outs) memberlist;
439 :	blume	361	mkStableGroup mksname)
440 :	blume	311	in
441 :	blume	361	SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
442 :	blume	345	closeIt = BinIO.closeOut,
443 :			work = work,
444 :	blume	354	cleanup = fn () =>
445 :	blume	361	(OS.FileSys.remove (mksname ())
446 :			handle _ => ()) })
447 :	blume	345	handle exn => NONE
448 :	blume	311	end
449 :			in
450 :	blume	348	case #kind grec of
451 :	blume	398	GG.STABLELIB => SOME g
452 :	blume	348	| GG.NOLIB => EM.impossible "stabilize: no library"
453 :			| GG.LIB wrapped =>
454 :	blume	314	if not (recomp gp g) then
455 :	blume	311	(anyerrors := true; NONE)
456 :			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 :			handle Format => NONE
728 :	blume	346	| IO.Io _ => NONE
729 :	blume	345	end
730 :	blume	304	end
731 :	blume	309
732 :			end (* local *)

---

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