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

Parent Directory | Revision Log

---

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

---

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