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

Parent Directory | Revision Log

---

Revision 513 - (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	309	in
21 :	blume	304
22 :	blume	309	signature STABILIZE = sig
23 :
24 :			val loadStable :
25 :	blume	398	GP.info -> { getGroup: SrcPath.t -> GG.group option,
26 :			anyerrors: bool ref }
27 :			-> SrcPath.t -> GG.group option
28 :	blume	309
29 :			val stabilize :
30 :	blume	398	GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
31 :	blume	309	end
32 :
33 :	blume	403	functor StabilizeFn (val destroy_state : GP.info -> SmlInfo.info -> unit
34 :			structure MachDepVC : MACHDEP_VC
35 :			val recomp : GP.info -> GG.group ->
36 :			(SmlInfo.info -> MachDepVC.Binfile.bfContent) option
37 :			val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =
38 :			struct
39 :	blume	309
40 :	blume	403	structure BF = MachDepVC.Binfile
41 :
42 :	blume	447	structure SSMap = MapFn
43 :	blume	385	(struct
44 :			type ord_key = SymbolSet.set
45 :			val compare = SymbolSet.compare
46 :			end)
47 :
48 :	blume	447	structure SNMap = MapFn
49 :	blume	384	(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 :
68 :			(* type info *)
69 :	blume	513	val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM, G, AP,
70 :			PRIM, EXPORTS, PRIV) =
71 :			(1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010,
72 :			1011, 1012, 1013)
73 :	blume	393
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	505	fun fetch_pickle s = let
84 :			fun bytesIn n = let
85 :			val bv = BinIO.inputN (s, n)
86 :			in
87 :			if n = Word8Vector.length bv then bv
88 :			else raise UU.Format
89 :			end
90 :
91 :			val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
92 :			val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
93 :			in
94 :			{ size = dg_sz, pickle = dg_pickle }
95 :			end
96 :
97 :			fun mkPickleFetcher mksname () =
98 :			SafeIO.perform { openIt = BinIO.openIn o mksname,
99 :			closeIt = BinIO.closeIn,
100 :			work = #pickle o fetch_pickle,
101 :			cleanup = fn _ => () }
102 :
103 :	blume	311	fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
104 :	blume	304
105 :	blume	323	val primconf = #primconf (#param gp)
106 :			val policy = #fnpolicy (#param gp)
107 :	blume	398	val pervasive = #pervasive (#param gp)
108 :	blume	323
109 :	blume	340	val grouppath = #grouppath grec
110 :
111 :	blume	403	fun doit (wrapped, getBFC) = let
112 :	blume	312
113 :	blume	403	fun writeBFC s i = BF.write { stream = s,
114 :			content = getBFC i,
115 :			nopickle = true }
116 :			fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }
117 :
118 :	blume	314	val _ =
119 :	blume	403	Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
120 :
121 :			val _ =
122 :	blume	348	if StringSet.isEmpty wrapped then ()
123 :	blume	314	else
124 :			Say.say ("$Stabilize: wrapping the following privileges:\n"
125 :	blume	312	:: map (fn s => (" " ^ s ^ "\n"))
126 :	blume	348	(StringSet.listItems wrapped))
127 :	blume	312
128 :	blume	311	val grpSrcInfo = (#errcons gp, anyerrors)
129 :	blume	308
130 :	blume	311	val exports = #exports grec
131 :	blume	348	val required = StringSet.difference (#required grec, wrapped)
132 :	blume	340	val sublibs = #sublibs grec
133 :	blume	304
134 :	blume	311	(* The format of a stable archive is the following:
135 :			* - It starts with the size s of the pickled dependency
136 :			* graph. This size itself is written as four-byte string.
137 :	blume	398	* - The size t of the pickled environment for the entire
138 :			* library (using the pickleEnvN interface of the pickler)
139 :			* in the same format as s.
140 :	blume	311	* - The pickled dependency graph. This graph contains
141 :			* integer offsets of the binfiles for the individual ML
142 :			* members. These offsets need to be adjusted by adding
143 :	blume	398	* s + t + 8. The pickled dependency graph also contains integer
144 :	blume	311	* offsets relative to other stable groups. These offsets
145 :			* need no further adjustment.
146 :	blume	398	* - Individual binfile contents (concatenated) but without
147 :			* their static environments.
148 :	blume	311	*)
149 :	blume	304
150 :	blume	340	(* Here we build a mapping that maps each BNODE to a number
151 :			* representing the sub-library that it came from and a
152 :			* representative symbol that can be used to find the BNODE
153 :			* within the exports of that library *)
154 :	blume	398	fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
155 :	blume	340	StableMap.insert (m, #bininfo n, (i, sy))
156 :			| oneB i (_, _, m) = m
157 :	blume	444	fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
158 :	blume	340	(SymbolMap.foldli (oneB i) m exports, i + 1)
159 :			val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
160 :	blume	330
161 :	blume	311	val members = ref []
162 :			val (registerOffset, getOffset) = let
163 :			val dict = ref SmlInfoMap.empty
164 :			val cur = ref 0
165 :			fun reg (i, sz) = let
166 :			val os = !cur
167 :	blume	306	in
168 :	blume	311	cur := os + sz;
169 :			dict := SmlInfoMap.insert (!dict, i, os);
170 :			members := i :: (!members);
171 :			os
172 :	blume	306	end
173 :	blume	311	fun get i = valOf (SmlInfoMap.find (!dict, i))
174 :			in
175 :			(reg, get)
176 :			end
177 :	blume	304
178 :	blume	398	(* Collect all BNODEs and PNODEs that we see and build
179 :			* a context suitable for P.envPickler. *)
180 :			fun mkContext () = let
181 :			fun lst f [] k s = k s
182 :			| lst f (h :: t) k s = f h (lst f t k) s
183 :
184 :			fun sbn n k (s as (prims, bnodes, snodes)) =
185 :			case n of
186 :			DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let
187 :			val str = String.str (Primitive.toIdent primconf p)
188 :	blume	461	val prims' =
189 :			StringMap.insert (prims, str, #env o statenv)
190 :	blume	398	in
191 :			k (prims', bnodes, snodes)
192 :			end
193 :			| DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
194 :			val { statenv, ... } = ii
195 :			val nsy = valOf (StableMap.find (inverseMap, i))
196 :			val bnodes' =
197 :	blume	461	StableMap.insert (bnodes, i,
198 :			(nsy, #env o statenv))
199 :	blume	398	in
200 :			k (prims, bnodes', snodes)
201 :			end
202 :			| DG.SB_SNODE n => sn n k s
203 :
204 :			and sn (DG.SNODE n) k (prims, bnodes, snodes) = let
205 :			val i = #smlinfo n
206 :			val li = #localimports n
207 :			val gi = #globalimports n
208 :			in
209 :			if SmlInfoSet.member (snodes, i) then
210 :			k (prims, bnodes, snodes)
211 :			else let
212 :			val snodes' = SmlInfoSet.add (snodes, i)
213 :			in
214 :			lst sn li (lst fsbn gi k) (prims, bnodes, snodes')
215 :			end
216 :			end
217 :
218 :			and fsbn (_, n) k s = sbn n k s
219 :
220 :			fun impexp (n, _) k s = fsbn n k s
221 :
222 :			val (prims, bnodes) =
223 :			lst impexp (SymbolMap.listItems exports)
224 :			(fn (prims, bnodes, _) => (prims, bnodes))
225 :			(StringMap.empty, StableMap.empty, SmlInfoSet.empty)
226 :
227 :			val priml = StringMap.listItemsi prims
228 :			val bnodel = StableMap.listItems bnodes
229 :
230 :			fun cvt lk id = let
231 :			fun nloop [] = NONE
232 :			| nloop ((k, ge) :: t) =
233 :			(case lk (ge ()) id of
234 :			SOME _ => SOME (P.NodeKey k)
235 :			| NONE => nloop t)
236 :			fun ploop [] = nloop bnodel
237 :			| ploop ((k, ge) :: t) =
238 :			(case lk (ge ()) id of
239 :			SOME _ => SOME (P.PrimKey k)
240 :			| NONE => ploop t)
241 :			in
242 :			case lk (E.staticPart pervasive) id of
243 :			NONE => ploop priml
244 :			| SOME _ => SOME (P.PrimKey "pv")
245 :			end
246 :			in
247 :			{ lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
248 :			lookSIG = cvt GenericVC.CMStaticEnv.lookSIG,
249 :			lookFCT = cvt GenericVC.CMStaticEnv.lookFCT,
250 :			lookFSIG = cvt GenericVC.CMStaticEnv.lookFSIG,
251 :			lookTYC = cvt GenericVC.CMStaticEnv.lookTYC,
252 :			lookEENV = cvt GenericVC.CMStaticEnv.lookEENV }
253 :			end
254 :
255 :			(* make the picklers for static and symbolic environments;
256 :			* lift them so we can use them here... *)
257 :			val envContext = mkContext ()
258 :	blume	403
259 :	blume	398	val env_orig = P.envPickler envContext
260 :			val env = PU.lift_pickler lifter env_orig
261 :			val symenv_orig = P.symenvPickler
262 :			val symenv = PU.lift_pickler lifter symenv_orig
263 :			val lazy_env = PU.w_lazy env
264 :			val lazy_symenv = PU.w_lazy symenv
265 :
266 :	blume	384	val int = PU.w_int
267 :	blume	398	val symbol = PickleSymPid.w_symbol
268 :			val pid = PickleSymPid.w_pid
269 :	blume	384	val share = PU.ah_share
270 :			val option = PU.w_option
271 :			val list = PU.w_list
272 :			val string = PU.w_string
273 :			val bool = PU.w_bool
274 :			val int = PU.w_int
275 :	blume	304
276 :	blume	385	fun symbolset ss = let
277 :			val op $ = PU.$ SS
278 :	blume	513	fun raw_ss ss = "s" $ [list symbol (SymbolSet.listItems ss)]
279 :	blume	385	in
280 :			share SSs raw_ss ss
281 :			end
282 :	blume	304
283 :	blume	384	val filter = option symbolset
284 :	blume	304
285 :	blume	513	val op $ = PU.$ SHM
286 :			fun shm (Sharing.SHARE true) = "a" $ []
287 :			| shm (Sharing.SHARE false) = "b" $ []
288 :			| shm Sharing.DONTSHARE = "c" $ []
289 :	blume	304
290 :	blume	384	fun si i = let
291 :	blume	340	(* FIXME: this is not a technical flaw, but perhaps one
292 :			* that deserves fixing anyway: If we only look at spec,
293 :			* then we are losing information about sub-grouping
294 :			* within libraries. However, the spec in BinInfo.info
295 :			* is only used for diagnostics and has no impact on the
296 :			* operation of CM itself. *)
297 :	blume	354	val spec = SrcPath.specOf (SmlInfo.sourcepath i)
298 :	blume	311	val locs = SmlInfo.errorLocation gp i
299 :	blume	398	val offset = registerOffset (i, sizeBFC i)
300 :	blume	387	val sh_mode = SmlInfo.sh_mode i
301 :	blume	385	val op $ = PU.$ SI
302 :	blume	311	in
303 :	blume	513	"s" $ [string spec, string locs, int offset, shm sh_mode]
304 :	blume	311	end
305 :	blume	306
306 :	blume	513	fun primitive p = let
307 :			val op $ = PU.$ PRIM
308 :			in
309 :			"p" $ [string (String.str (Primitive.toIdent primconf p))]
310 :			end
311 :	blume	306
312 :	blume	340	fun warn_relabs p abs = let
313 :			val relabs = if abs then "absolute" else "relative"
314 :	blume	330	fun ppb pps =
315 :			(PP.add_newline pps;
316 :	blume	354	PP.add_string pps (SrcPath.descr p);
317 :	blume	330	PP.add_newline pps;
318 :			PP.add_string pps
319 :			"(This means that in order to be able to use the result of stabilization";
320 :			PP.add_newline pps;
321 :	blume	340	PP.add_string pps "the library must be in the same ";
322 :	blume	330	PP.add_string pps relabs;
323 :			PP.add_string pps " location as it is now.)";
324 :			PP.add_newline pps)
325 :			in
326 :			EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
327 :			EM.WARN
328 :	blume	354	(concat [SrcPath.descr grouppath,
329 :	blume	340	": library referred to by ", relabs,
330 :			" pathname:"])
331 :	blume	330	ppb
332 :			end
333 :	blume	306
334 :	blume	384	fun abspath p = let
335 :	blume	513	val op $ = PU.$ AP
336 :	blume	384	val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
337 :			in
338 :	blume	513	"p" $ [list string pp]
339 :	blume	384	end
340 :	blume	306
341 :	blume	385	fun sn n = let
342 :	blume	398	val op $ = PU.$ SN
343 :	blume	385	fun raw_sn (DG.SNODE n) =
344 :	blume	513	"a" $ [si (#smlinfo n), list sn (#localimports n),
345 :			list fsbn (#globalimports n)]
346 :	blume	384	in
347 :	blume	385	share SNs raw_sn n
348 :			end
349 :	blume	306
350 :	blume	398	(* Here we ignore the interface info because we will not
351 :			* need it anymore when we unpickle. *)
352 :	blume	385	and sbn x = let
353 :			val op $ = PU.$ SBN
354 :			in
355 :			case x of
356 :	blume	398	DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
357 :	blume	513	"1" $ [primitive p]
358 :	blume	398	| DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
359 :			val (n, sy) = valOf (StableMap.find (inverseMap, i))
360 :			in
361 :	blume	513	"2" $ [int n, symbol sy]
362 :	blume	398	end
363 :	blume	513	| DG.SB_SNODE n => "3" $ [sn n]
364 :	blume	385	end
365 :
366 :			and fsbn (f, n) = let
367 :			val op $ = PU.$ FSBN
368 :			in
369 :	blume	513	"f" $ [filter f, sbn n]
370 :	blume	385	end
371 :	blume	370
372 :	blume	398	(* Here is the place where we need to write interface info. *)
373 :	blume	385	fun impexp (s, (n, _)) = let
374 :			val op $ = PU.$ IMPEXP
375 :	blume	398	val { statenv, symenv, statpid, sympid } =
376 :			case n of
377 :			(_, DG.SB_BNODE (_, ii)) => ii
378 :			| (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
379 :			getII smlinfo
380 :	blume	461	fun es2bs { env, ctxt } =
381 :			{ env = GenericVC.CoerceEnv.es2bs env, ctxt = ctxt }
382 :	blume	385	in
383 :	blume	513	"i" $ [symbol s, fsbn n,
384 :			lazy_env (es2bs o statenv),
385 :			lazy_symenv symenv,
386 :			pid statpid,
387 :			pid sympid]
388 :	blume	384	end
389 :	blume	307
390 :	blume	513	fun w_exports e = let
391 :			val op $ = PU.$ EXPORTS
392 :			in
393 :			"e" $ [list impexp (SymbolMap.listItemsi e)]
394 :			end
395 :	blume	306
396 :	blume	513	fun privileges p = let
397 :			val op $ = PU.$ PRIV
398 :			in
399 :			"p" $ [list string (StringSet.listItems p)]
400 :			end
401 :	blume	306
402 :	blume	384	fun group () = let
403 :	blume	513	val op $ = PU.$ G
404 :	blume	444	fun sg (p, g) = abspath p
405 :	blume	311	in
406 :	blume	340	(* Pickle the sublibs first because we need to already
407 :	blume	330	* have them back when we unpickle BNODEs. *)
408 :	blume	513	"g" $ [list sg sublibs, w_exports exports, privileges required]
409 :	blume	311	end
410 :	blume	308
411 :	blume	398	val dg_pickle =
412 :			Byte.stringToBytes (PU.pickle emptyMap (group ()))
413 :	blume	403
414 :	blume	398	val dg_sz = Word8Vector.length dg_pickle
415 :	blume	308
416 :	blume	398	val offset_adjustment = dg_sz + 4
417 :
418 :	blume	361	fun mkStableGroup mksname = let
419 :	blume	311	val m = ref SmlInfoMap.empty
420 :			fun sn (DG.SNODE (n as { smlinfo, ... })) =
421 :			case SmlInfoMap.find (!m, smlinfo) of
422 :			SOME n => n
423 :			| NONE => let
424 :	blume	371	val li = map sn (#localimports n)
425 :			val gi = map fsbn (#globalimports n)
426 :	blume	311	val sourcepath = SmlInfo.sourcepath smlinfo
427 :	blume	340	(* FIXME: see the comment near the other
428 :	blume	354	* occurence of SrcPath.spec... *)
429 :			val spec = SrcPath.specOf sourcepath
430 :	blume	311	val offset =
431 :			getOffset smlinfo + offset_adjustment
432 :	blume	387	val sh_mode = SmlInfo.sh_mode smlinfo
433 :	blume	311	val locs = SmlInfo.errorLocation gp smlinfo
434 :			val error = EM.errorNoSource grpSrcInfo locs
435 :			val i = BinInfo.new { group = grouppath,
436 :	blume	361	mkStablename = mksname,
437 :	blume	311	spec = spec,
438 :			offset = offset,
439 :	blume	387	sh_mode = sh_mode,
440 :	blume	311	error = error }
441 :			val n = DG.BNODE { bininfo = i,
442 :			localimports = li,
443 :			globalimports = gi }
444 :			in
445 :			m := SmlInfoMap.insert (!m, smlinfo, n);
446 :			n
447 :			end
448 :	blume	308
449 :	blume	398	and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
450 :			let val ii = getII i
451 :			in
452 :			(sn n, ii)
453 :			end
454 :			| sbn (DG.SB_BNODE (n, ii)) = (n, ii)
455 :	blume	308
456 :	blume	398	and fsbn (f, n) = (f, #1 (sbn n))
457 :	blume	308
458 :	blume	311	fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
459 :	blume	308
460 :	blume	311	val exports = SymbolMap.map impexp (#exports grec)
461 :			in
462 :	blume	426	SmlInfoMap.appi (fn (i, _) => destroy_state gp i) (!m);
463 :	blume	311	GG.GROUP { exports = exports,
464 :	blume	505	kind = GG.STABLELIB (fn () => ()),
465 :	blume	311	required = required,
466 :			grouppath = grouppath,
467 :	blume	348	sublibs = sublibs }
468 :	blume	311	end
469 :	blume	308
470 :	blume	311	fun writeInt32 (s, i) = let
471 :			val a = Word8Array.array (4, 0w0)
472 :			val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
473 :			in
474 :			BinIO.output (s, Word8Array.extract (a, 0, NONE))
475 :			end
476 :			val memberlist = rev (!members)
477 :
478 :	blume	403	fun mksname () = FilenamePolicy.mkStableName policy grouppath
479 :	blume	345	fun work outs =
480 :	blume	403	(writeInt32 (outs, dg_sz);
481 :	blume	398	BinIO.output (outs, dg_pickle);
482 :			app (writeBFC outs) memberlist;
483 :	blume	361	mkStableGroup mksname)
484 :	blume	311	in
485 :	blume	361	SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
486 :	blume	345	closeIt = BinIO.closeOut,
487 :			work = work,
488 :	blume	459	cleanup = fn _ =>
489 :	blume	361	(OS.FileSys.remove (mksname ())
490 :			handle _ => ()) })
491 :	blume	426	handle exn =>
492 :			(EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
493 :			EM.COMPLAIN
494 :			(concat ["Exception raised while stabilizing ",
495 :			SrcPath.descr grouppath])
496 :			EM.nullErrorBody;
497 :			NONE)
498 :	blume	311	end
499 :			in
500 :	blume	348	case #kind grec of
501 :	blume	505	GG.STABLELIB _ => SOME g
502 :	blume	348	| GG.NOLIB => EM.impossible "stabilize: no library"
503 :			| GG.LIB wrapped =>
504 :	blume	403	(case recomp gp g of
505 :			NONE => (anyerrors := true; NONE)
506 :			| SOME bfc_acc => let
507 :	blume	444	fun notStable (_, GG.GROUP { kind, ... }) =
508 :	blume	505	case kind of GG.STABLELIB _ => false | _ => true
509 :	blume	403	in
510 :	blume	340	case List.filter notStable (#sublibs grec) of
511 :	blume	403	[] => doit (wrapped, bfc_acc)
512 :	blume	311	| l => let
513 :			val grammar = case l of [_] => " is" | _ => "s are"
514 :			fun ppb pps = let
515 :			fun loop [] = ()
516 :	blume	444	| loop ((p, _) :: t) =
517 :			(PP.add_string pps (SrcPath.descr p);
518 :	blume	311	PP.add_newline pps;
519 :			loop t)
520 :			in
521 :			PP.add_newline pps;
522 :			PP.add_string pps
523 :			(concat ["because the following sub-group",
524 :			grammar, " not stable:"]);
525 :			PP.add_newline pps;
526 :			loop l
527 :			end
528 :			val errcons = #errcons gp
529 :	blume	354	val gdescr = SrcPath.descr (#grouppath grec)
530 :	blume	311	in
531 :			EM.errorNoFile (errcons, anyerrors) SM.nullRegion
532 :			EM.COMPLAIN
533 :	blume	354	(gdescr ^ " cannot be stabilized")
534 :	blume	311	ppb;
535 :			NONE
536 :			end
537 :	blume	403	end)
538 :	blume	311	end
539 :	blume	310
540 :	blume	398	fun loadStable gp { getGroup, anyerrors } group = let
541 :	blume	306
542 :	blume	398	val errcons = #errcons (gp: GeneralParams.info)
543 :	blume	311	val grpSrcInfo = (errcons, anyerrors)
544 :	blume	354	val gdescr = SrcPath.descr group
545 :	blume	311	fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
546 :	blume	367	EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
547 :			EM.nullErrorBody
548 :	blume	309
549 :	blume	384	exception Format = UU.Format
550 :	blume	306
551 :	blume	318	val pcmode = #pcmode (#param gp)
552 :	blume	310	val policy = #fnpolicy (#param gp)
553 :	blume	323	val primconf = #primconf (#param gp)
554 :	blume	398	val pervasive = #pervasive (#param gp)
555 :
556 :	blume	361	fun mksname () = FilenamePolicy.mkStableName policy group
557 :	blume	310
558 :	blume	345	fun work s = let
559 :	blume	310
560 :	blume	345	fun getGroup' p =
561 :			case getGroup p of
562 :			SOME g => g
563 :	blume	354	| NONE => (error ["unable to find ", SrcPath.descr p];
564 :	blume	345	raise Format)
565 :	blume	306
566 :	blume	505	val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s
567 :	blume	398	val offset_adjustment = dg_sz + 4
568 :	blume	505	val { getter, dropper } =
569 :			UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
570 :			val session = UU.mkSession getter
571 :	blume	345
572 :	blume	398	val sgListM = UU.mkMap ()
573 :	blume	384	val stringListM = UU.mkMap ()
574 :	blume	513	val stringListM = UU.mkMap ()
575 :	blume	385	val ssM = UU.mkMap ()
576 :	blume	384	val ssoM = UU.mkMap ()
577 :			val boolOptionM = UU.mkMap ()
578 :	blume	385	val siM = UU.mkMap ()
579 :	blume	384	val snM = UU.mkMap ()
580 :			val snListM = UU.mkMap ()
581 :			val sbnM = UU.mkMap ()
582 :	blume	385	val fsbnM = UU.mkMap ()
583 :	blume	384	val fsbnListM = UU.mkMap ()
584 :	blume	385	val impexpM = UU.mkMap ()
585 :	blume	384	val impexpListM = UU.mkMap ()
586 :	blume	513	val groupM = UU.mkMap ()
587 :			val apM = UU.mkMap ()
588 :			val primitiveM = UU.mkMap ()
589 :			val exportsM = UU.mkMap ()
590 :			val privilegesM = UU.mkMap ()
591 :	blume	304
592 :	blume	513	fun list m r = UU.r_list session m r
593 :			val string = UU.r_string session
594 :			val stringlist = list stringListM string
595 :	blume	305
596 :	blume	513	fun option m r = UU.r_option session m r
597 :			val int = UU.r_int session
598 :			fun share m r = UU.share session m r
599 :			fun nonshare r = UU.nonshare session r
600 :			val bool = UU.r_bool session
601 :			val pid = UnpickleSymPid.r_pid (session, string)
602 :	blume	305
603 :	blume	513	fun abspath () = let
604 :			fun ap #"p" =
605 :			(SrcPath.unpickle pcmode (stringlist (), group)
606 :			handle SrcPath.Format => raise Format
607 :			| SrcPath.BadAnchor a =>
608 :			(error ["configuration anchor \"", a, "\" undefined"];
609 :			raise Format))
610 :			| ap _ = raise Format
611 :	blume	387	in
612 :	blume	513	share apM ap
613 :	blume	387	end
614 :	blume	305
615 :	blume	513	fun sg () = let
616 :			val p = abspath ()
617 :	blume	345	in
618 :	blume	513	(p, getGroup' p)
619 :	blume	345	end
620 :	blume	306
621 :	blume	513	fun gr #"g" =
622 :			let val sublibs = list sgListM sg ()
623 :	blume	306
624 :	blume	513	(* Now that we have the list of sublibs, we can build the
625 :			* environment for unpickling the environment list.
626 :			* We will need the environment list when unpickling the
627 :			* export list (making SB_BNODES). *)
628 :			fun prim_context "pv" = SOME (E.staticPart pervasive)
629 :			| prim_context s =
630 :			SOME (E.staticPart
631 :			(Primitive.env primconf
632 :			(valOf (Primitive.fromIdent primconf
633 :			(String.sub (s, 0))))))
634 :			handle _ => NONE
635 :			fun node_context (n, sy) = let
636 :	blume	444	val (_, GG.GROUP { exports = slexp, ... }) =
637 :	blume	513	List.nth (sublibs, n)
638 :	blume	398	in
639 :			case SymbolMap.find (slexp, sy) of
640 :	blume	513	SOME ((_, DG.SB_BNODE (_, x)), _) =>
641 :			SOME (#env (#statenv x ()))
642 :			| _ => NONE
643 :			end handle _ => NONE
644 :
645 :			val { symenv, env, symbol, symbollist } =
646 :			UP.mkUnpicklers session
647 :			{ prim_context = prim_context,
648 :			node_context = node_context }
649 :
650 :			val lazy_symenv = UU.r_lazy session symenv
651 :			val lazy_env = UU.r_lazy session env
652 :
653 :			fun symbolset () = let
654 :			fun s #"s" =
655 :			SymbolSet.addList (SymbolSet.empty, symbollist ())
656 :			| s _ = raise Format
657 :			in
658 :			share ssM s
659 :	blume	398	end
660 :	blume	306
661 :	blume	513	val filter = option ssoM symbolset
662 :	blume	306
663 :	blume	513	fun primitive () = let
664 :			fun p #"p" =
665 :			(valOf (Primitive.fromIdent primconf
666 :			(String.sub (string (), 0)))
667 :			handle _ => raise Format)
668 :			| p _ = raise Format
669 :			in
670 :			share primitiveM p
671 :			end
672 :	blume	384
673 :	blume	513	fun shm () = let
674 :			fun s #"a" = Sharing.SHARE true
675 :			| s #"b" = Sharing.SHARE false
676 :			| s #"c" = Sharing.DONTSHARE
677 :			| s _ = raise Format
678 :	blume	385	in
679 :	blume	513	nonshare s
680 :	blume	385	end
681 :	blume	330
682 :	blume	513	fun si () = let
683 :			fun s #"s" =
684 :			let val spec = string ()
685 :			val locs = string ()
686 :			val offset = int () + offset_adjustment
687 :			val sh_mode = shm ()
688 :			val error = EM.errorNoSource grpSrcInfo locs
689 :			in
690 :			BinInfo.new { group = group,
691 :			mkStablename = mksname,
692 :			error = error,
693 :			spec = spec,
694 :			offset = offset,
695 :			sh_mode = sh_mode }
696 :			end
697 :			| s _ = raise Format
698 :			in
699 :			share siM s
700 :			end
701 :	blume	384
702 :	blume	513	(* this is the place where what used to be an
703 :			* SNODE changes to a BNODE! *)
704 :			fun sn () = let
705 :			fun sn' #"a" =
706 :			DG.BNODE { bininfo = si (),
707 :			localimports = snlist (),
708 :			globalimports = fsbnlist () }
709 :			| sn' _ = raise Format
710 :			in
711 :			share snM sn'
712 :			end
713 :	blume	330
714 :	blume	513	and snlist () = list snListM sn ()
715 :	blume	330
716 :	blume	513	(* this one changes from farsbnode to plain farbnode *)
717 :			and sbn () = let
718 :			fun sbn' #"1" = DG.PNODE (primitive ())
719 :			| sbn' #"2" = let
720 :			val n = int ()
721 :			val sy = symbol ()
722 :			val (_, GG.GROUP { exports = slexp, ... }) =
723 :			List.nth (sublibs, n)
724 :			handle _ => raise Format
725 :			in
726 :			case SymbolMap.find (slexp, sy) of
727 :			SOME ((_, DG.SB_BNODE(n, _)), _) =>
728 :			(case n of
729 :			DG.BNODE _ => n
730 :			| _ => raise Format)
731 :			| _ => raise Format
732 :			end
733 :			| sbn' #"3" = sn ()
734 :			| sbn' _ = raise Format
735 :			in
736 :			share sbnM sbn'
737 :			end
738 :	blume	384
739 :	blume	513	and fsbn () = let
740 :			fun f #"f" = (filter (), sbn ())
741 :			| f _ = raise Format
742 :			in
743 :			share fsbnM f
744 :			end
745 :
746 :			and fsbnlist () = list fsbnListM fsbn ()
747 :
748 :			fun impexp () = let
749 :			fun ie #"i" =
750 :			let val sy = symbol ()
751 :			(* really reads farbnodes! *)
752 :			val (f, n) = fsbn ()
753 :			val ge = lazy_env ()
754 :			fun bs2es { env, ctxt } =
755 :			{ env = GenericVC.CoerceEnv.bs2es env,
756 :			ctxt = ctxt }
757 :			val ge' = bs2es o ge
758 :			val ii = { statenv = Memoize.memoize ge',
759 :			symenv = lazy_symenv (),
760 :			statpid = pid (),
761 :			sympid = pid () }
762 :			val e = Statenv2DAEnv.cvtMemo (#env o ge)
763 :			(* put a filter in front to avoid having the
764 :			* FCTENV being queried needlessly (this
765 :			* avoids spurious module loadings) *)
766 :			val e' =
767 :			DAEnv.FILTER (SymbolSet.singleton sy, e)
768 :			in
769 :			(sy, ((f, DG.SB_BNODE (n, ii)), e'))
770 :			end
771 :			| ie _ = raise Format
772 :			in
773 :			share impexpM ie
774 :			end
775 :
776 :			val impexplist = list impexpListM impexp
777 :
778 :			fun r_exports () = let
779 :			fun e #"e" =
780 :			foldl SymbolMap.insert'
781 :			SymbolMap.empty (impexplist ())
782 :			| e _ = raise Format
783 :			in
784 :			share exportsM e
785 :			end
786 :
787 :			val stringlist = list stringListM string
788 :
789 :			fun privileges () = let
790 :			fun p #"p" =
791 :			StringSet.addList (StringSet.empty, stringlist ())
792 :			| p _ = raise Format
793 :			in
794 :			share privilegesM p
795 :			end
796 :
797 :			val exports = r_exports ()
798 :			val required = privileges ()
799 :			in
800 :			GG.GROUP { exports = exports,
801 :			kind = GG.STABLELIB dropper,
802 :			required = required,
803 :			grouppath = group,
804 :			sublibs = sublibs }
805 :			end
806 :			| gr _ = raise Format
807 :	blume	306	in
808 :	blume	513	share groupM gr
809 :	blume	306	end
810 :	blume	304	in
811 :	blume	361	SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
812 :	blume	345	closeIt = BinIO.closeIn,
813 :			work = work,
814 :	blume	459	cleanup = fn _ => () })
815 :	blume	402	handle Format => (error ["file is corrupted (old version?)"];
816 :			NONE)
817 :	blume	346	| IO.Io _ => NONE
818 :	blume	345	end
819 :	blume	304	end
820 :	blume	309
821 :			end (* local *)

---

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