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

Parent Directory | Revision Log

---

Revision 733 - (view) (download)

1 :	blume	309	(*
2 :	blume	588	* Reading, generating, and writing stable libraries.
3 :	blume	309	*
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	587	structure MI = GenericVC.ModuleId
21 :	blume	309	in
22 :	blume	304
23 :	blume	309	signature STABILIZE = sig
24 :
25 :	blume	632	val libStampIsValid : GP.info
26 :	blume	666	-> (SrcPath.file * DG.sbnode list * GG.subgrouplist) * Version.t option
27 :	blume	632	-> bool
28 :	blume	569
29 :	blume	666	type groupgetter =
30 :			GP.info * SrcPath.file * Version.t option * SrcPath.rebindings ->
31 :			GG.group option
32 :	blume	632
33 :	blume	309	val loadStable :
34 :	blume	666	{ getGroup: groupgetter, anyerrors: bool ref } -> groupgetter
35 :	blume	309
36 :			val stabilize :
37 :	blume	398	GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
38 :	blume	309	end
39 :
40 :	blume	537	functor StabilizeFn (structure MachDepVC : MACHDEP_VC
41 :	blume	588	structure StabModmap : STAB_MODMAP
42 :	blume	403	val recomp : GP.info -> GG.group ->
43 :			(SmlInfo.info -> MachDepVC.Binfile.bfContent) option
44 :			val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =
45 :			struct
46 :	blume	666	type groupgetter =
47 :			GP.info * SrcPath.file * Version.t option * SrcPath.rebindings ->
48 :			GG.group option
49 :	blume	632
50 :	blume	403	structure BF = MachDepVC.Binfile
51 :
52 :	blume	447	structure SSMap = MapFn
53 :	blume	385	(struct
54 :			type ord_key = SymbolSet.set
55 :			val compare = SymbolSet.compare
56 :			end)
57 :
58 :	blume	398	structure PU = PickleUtil
59 :			structure UU = UnpickleUtil
60 :	blume	384
61 :	blume	569	val libstamp_nbytes = 16
62 :
63 :	blume	653	type map = { ss: PU.id SSMap.map, sn: PU.id SmlInfoMap.map, pm: P.map }
64 :	blume	393
65 :	blume	653	val emptyMap : map =
66 :			{ ss = SSMap.empty, sn = SmlInfoMap.empty, pm = P.emptyMap }
67 :	blume	393
68 :	blume	398	val lifter =
69 :			{ extract = fn (m: map) => #pm m,
70 :			patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
71 :
72 :	blume	393	infix 3 $
73 :
74 :			(* type info *)
75 :	blume	513	val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM, G, AP,
76 :	blume	666	PRIM, EXPORTS, PRIV, VERSION, SG, RB) =
77 :	blume	513	(1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010,
78 :	blume	666	1011, 1012, 1013, 1014, 1015, 1016)
79 :	blume	393
80 :	blume	398	val SSs =
81 :			{ find = fn (m: map, k) => SSMap.find (#ss m, k),
82 :			insert = fn ({ ss, sn, pm }, k, v) =>
83 :			{ sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
84 :	blume	653	val SNs =
85 :			{ find = fn (m: map, DG.SNODE k) => SmlInfoMap.find (#sn m,#smlinfo k),
86 :			insert = fn ({ ss, sn, pm }, DG.SNODE k, v) =>
87 :			{ ss = ss,
88 :			sn = SmlInfoMap.insert (sn, #smlinfo k, v),
89 :			pm = pm } }
90 :	blume	385
91 :	blume	505	fun fetch_pickle s = let
92 :			fun bytesIn n = let
93 :			val bv = BinIO.inputN (s, n)
94 :			in
95 :			if n = Word8Vector.length bv then bv
96 :			else raise UU.Format
97 :			end
98 :
99 :	blume	569	val libstamp = bytesIn libstamp_nbytes (* ignored *)
100 :	blume	505	val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
101 :			val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
102 :			in
103 :			{ size = dg_sz, pickle = dg_pickle }
104 :			end
105 :
106 :			fun mkPickleFetcher mksname () =
107 :			SafeIO.perform { openIt = BinIO.openIn o mksname,
108 :			closeIt = BinIO.closeIn,
109 :			work = #pickle o fetch_pickle,
110 :			cleanup = fn _ => () }
111 :
112 :	blume	569	fun mkInverseMap sublibs = let
113 :	blume	632	(* Here we build a mapping that maps each BNODE to the
114 :			* position of its exporting sub-library and a representative
115 :			* symbol that can be used to find the BNODE within the
116 :			* exports of that library. *)
117 :	blume	652	fun oneB i (sy, (nth, _, _), m) =
118 :			case nth () of
119 :			(_, DG.SB_BNODE (DG.BNODE n, _)) =>
120 :	blume	733	(* we blindly override existing info for the same bnode;
121 :			* this means that the last guy wins... *)
122 :	blume	652	StableMap.insert (m, #bininfo n, (i, sy))
123 :			| _ => m
124 :	blume	733	(* ... but we want the first guy to win, so we do foldr
125 :			* and count from the top. *)
126 :	blume	652	fun oneSL (g as GG.GROUP { exports, ... }, (m, i)) =
127 :	blume	733	(SymbolMap.foldli (oneB i) m exports, i - 1)
128 :			| oneSL (_, (m, i)) = (m, i - 1)
129 :	blume	666	fun oneSL' ((_, gth, _), a) = oneSL (gth (), a)
130 :	blume	733	val (im, _) =
131 :			foldr oneSL' (StableMap.empty, length sublibs - 1) sublibs
132 :	blume	569	fun look i =
133 :			case StableMap.find (im, i) of
134 :			SOME p => p
135 :			| NONE => EM.impossible "stabilize: bad inverse map"
136 :			in
137 :			look
138 :			end
139 :
140 :			(* A stamp for a library is created by "pickling" the dependency graph
141 :			* of the library in a cursory fashion, thereby recording the ii pids
142 :			* of external references. The so-created pickle string is never used
143 :			* for unpickling. Instead, it is hashed and recorded as part of
144 :			* the regular library file. In paranoia mode CM checks if the recorded
145 :			* hash is identical to the one that _would_ be created if one were
146 :			* to re-build the library now. *)
147 :			fun libStampOf (grouppath, export_nodes, sublibs) = let
148 :			val inverseMap = mkInverseMap sublibs
149 :
150 :			val pid = PickleSymPid.w_pid
151 :			val share = PU.ah_share
152 :			val symbol = PickleSymPid.w_symbol
153 :			val string = PU.w_string
154 :			val list = PU.w_list
155 :	blume	632	val int = PU.w_int
156 :	blume	569
157 :			fun abspath p = let
158 :			val op $ = PU.$ AP
159 :	blume	666	val l = SrcPath.pickle { warn = fn _ => () }
160 :			{ file = SrcPath.pre p, relativeTo = grouppath }
161 :	blume	569	in
162 :			"p" $ [list string l]
163 :			end
164 :
165 :			fun sn n = let
166 :			val op $ = PU.$ SN
167 :			fun raw_sn (DG.SNODE n) =
168 :			"a" $ [list sn (#localimports n), list fsbn (#globalimports n)]
169 :			in
170 :			share SNs raw_sn n
171 :			end
172 :
173 :			and sbn x = let
174 :			val op $ = PU.$ SBN
175 :			in
176 :			case x of
177 :			DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
178 :	blume	632	val (i, sy) = inverseMap i
179 :	blume	569	val { statpid, sympid, ... } = ii
180 :			in
181 :	blume	632	"2" $ [int i, pid statpid, pid sympid]
182 :	blume	569	end
183 :			| DG.SB_SNODE n => "3" $ [sn n]
184 :			end
185 :
186 :			and fsbn (_, n) = let val op $ = PU.$ FSBN in "f" $ [sbn n] end
187 :
188 :			fun group () = let
189 :			val op $ = PU.$ G
190 :			in "g" $ [list sbn export_nodes]
191 :			end
192 :			in
193 :			P.pickle2hash (Byte.stringToBytes (PU.pickle emptyMap (group ())))
194 :			end
195 :
196 :			(* Comparison of old and new library stamps. *)
197 :	blume	632	fun libStampIsValid (gp: GP.info) (a as (grouppath, _, _), version) = let
198 :	blume	569	val newStamp = Byte.bytesToString (Pid.toBytes (libStampOf a))
199 :			val policy = #fnpolicy (#param gp)
200 :	blume	632	val sname = FilenamePolicy.mkStableName policy (grouppath, version)
201 :	blume	569	fun work s = let
202 :			val oldStamp =
203 :			Byte.bytesToString (BinIO.inputN (s, libstamp_nbytes))
204 :			in
205 :			oldStamp = newStamp
206 :			end
207 :			in
208 :			SafeIO.perform { openIt = fn () => BinIO.openIn sname,
209 :			closeIt = BinIO.closeIn,
210 :			work = work,
211 :			cleanup = fn _ => () }
212 :			handle _ => false
213 :			end
214 :
215 :	blume	666	fun loadStable { getGroup, anyerrors } (gp, group, version, rebinds) = let
216 :	blume	537
217 :	blume	666	val gp = GeneralParams.bind gp rebinds
218 :
219 :	blume	537	val errcons = #errcons (gp: GeneralParams.info)
220 :			val grpSrcInfo = (errcons, anyerrors)
221 :			val gdescr = SrcPath.descr group
222 :			fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
223 :			EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
224 :			EM.nullErrorBody
225 :
226 :			exception Format = UU.Format
227 :
228 :	blume	666	val penv = #penv (#param gp)
229 :	blume	537	val policy = #fnpolicy (#param gp)
230 :
231 :	blume	632	fun mksname () = FilenamePolicy.mkStableName policy (group, version)
232 :	blume	537
233 :			fun work s = let
234 :
235 :	blume	666	fun getGroup' (gp, p, vo, rb) =
236 :			case getGroup (gp, p, vo, rb) of
237 :	blume	537	SOME g => g
238 :			| NONE => (error ["unable to find ", SrcPath.descr p];
239 :			raise Format)
240 :
241 :			val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s
242 :	blume	569	val offset_adjustment = dg_sz + 4 + libstamp_nbytes
243 :	blume	537	val { getter, dropper } =
244 :			UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
245 :			val session = UU.mkSession getter
246 :
247 :			val sgListM = UU.mkMap ()
248 :			val ssM = UU.mkMap ()
249 :			val ssoM = UU.mkMap ()
250 :			val boolOptionM = UU.mkMap ()
251 :			val siM = UU.mkMap ()
252 :			val snM = UU.mkMap ()
253 :			val snListM = UU.mkMap ()
254 :			val sbnM = UU.mkMap ()
255 :			val fsbnM = UU.mkMap ()
256 :			val fsbnListM = UU.mkMap ()
257 :			val impexpM = UU.mkMap ()
258 :			val impexpListM = UU.mkMap ()
259 :			val groupM = UU.mkMap ()
260 :			val apM = UU.mkMap ()
261 :			val exportsM = UU.mkMap ()
262 :			val privilegesM = UU.mkMap ()
263 :			val poM = UU.mkMap ()
264 :	blume	569	val stringListM = UU.mkMap ()
265 :	blume	632	val versionM = UU.mkMap ()
266 :			val versionOptM = UU.mkMap ()
267 :			val sgM = UU.mkMap ()
268 :	blume	666	val rbM = UU.mkMap ()
269 :			val rblM = UU.mkMap ()
270 :	blume	537
271 :			fun list m r = UU.r_list session m r
272 :			val string = UU.r_string session
273 :
274 :			fun option m r = UU.r_option session m r
275 :			val int = UU.r_int session
276 :			val bool = UU.r_bool session
277 :			fun share m r = UU.share session m r
278 :			fun nonshare r = UU.nonshare session r
279 :			val bool = UU.r_bool session
280 :			val pid = UnpickleSymPid.r_pid (session, string)
281 :
282 :	blume	587	val stringlist = list stringListM string
283 :
284 :	blume	666	fun list2path c sl =
285 :			c (SrcPath.unpickle penv { pickled = sl, relativeTo = group })
286 :	blume	569	handle SrcPath.Format => raise Format
287 :
288 :	blume	537	fun abspath () = let
289 :	blume	666	fun ap #"p" = list2path SrcPath.file (stringlist ())
290 :	blume	537	| ap _ = raise Format
291 :			in
292 :			share apM ap
293 :			end
294 :
295 :	blume	632	fun version () = let
296 :			fun v #"v" =
297 :			(case Version.fromString (string ()) of
298 :			SOME v => v
299 :			| NONE => raise Format)
300 :			| v _ = raise Format
301 :			in
302 :			share versionM v
303 :			end
304 :
305 :	blume	666	fun rb () = let
306 :			fun r #"b" =
307 :			{ anchor = string (),
308 :			value = list2path (fn x => x) (stringlist ()) }
309 :			| r _ = raise Format
310 :			in
311 :			share rbM r
312 :			end
313 :
314 :	blume	537	fun sg () = let
315 :	blume	666	fun doit getRbl =
316 :	blume	632	let val p = abspath ()
317 :			val vo = option versionOptM version ()
318 :	blume	666	val rbl = getRbl ()
319 :			fun gth () = getGroup' (gp, p, vo, rbl)
320 :	blume	632	in
321 :	blume	666	(p, Memoize.memoize gth, rbl)
322 :	blume	632	end
323 :	blume	666	fun xsg #"s" = doit (fn () => []) (* backward-compatible *)
324 :			| xsg #"S" = doit (list rblM rb)
325 :	blume	632	| xsg _ = raise Format
326 :	blume	537	in
327 :	blume	632	share sgM xsg
328 :	blume	537	end
329 :
330 :			fun gr #"g" =
331 :	blume	632	let val version = option versionOptM version ()
332 :			val sublibs = list sgListM sg ()
333 :	blume	537
334 :	blume	632	fun getSublib i =
335 :	blume	652	(case #2 (List.nth (sublibs, i)) () of
336 :	blume	632	GG.GROUP x => x
337 :			| GG.ERRORGROUP =>
338 :			EM.impossible "loadStable: ERRORGROUP")
339 :			handle General.Subscript => raise Format
340 :
341 :	blume	587	fun context NONE = raise Format
342 :	blume	632	| context (SOME (pos, sy)) = let
343 :			val { exports, ... } = getSublib pos
344 :	blume	587	in
345 :	blume	632	case SymbolMap.find (exports, sy) of
346 :	blume	652	SOME (nth, _, _) =>
347 :			(case nth () of
348 :			(_, DG.SB_BNODE (_, x)) =>
349 :			StabModmap.addEnv (#statenv x ())
350 :			| _ => raise Format)
351 :			| NONE => raise Format
352 :	blume	587	end
353 :	blume	537
354 :	blume	587	val { symenv, statenv, symbol, symbollist } =
355 :			UP.mkUnpicklers
356 :			{ session = session,
357 :			stringlist = stringlist }
358 :			context
359 :
360 :	blume	537	val lazy_symenv = UU.r_lazy session symenv
361 :	blume	587	val lazy_statenv = UU.r_lazy session statenv
362 :	blume	537
363 :			fun symbolset () = let
364 :			fun s #"s" =
365 :			SymbolSet.addList (SymbolSet.empty, symbollist ())
366 :			| s _ = raise Format
367 :			in
368 :			share ssM s
369 :			end
370 :
371 :			val filter = option ssoM symbolset
372 :
373 :			fun shm () = let
374 :			fun s #"a" = Sharing.SHARE true
375 :			| s #"b" = Sharing.SHARE false
376 :			| s #"c" = Sharing.DONTSHARE
377 :			| s _ = raise Format
378 :			in
379 :			nonshare s
380 :			end
381 :
382 :			val pidoption = option poM pid
383 :
384 :			fun si () = let
385 :			fun s #"s" =
386 :			let val spec = string ()
387 :			val locs = string ()
388 :			val offset = int () + offset_adjustment
389 :			val rts_pid = pidoption ()
390 :			val sh_mode = shm ()
391 :			val error = EM.errorNoSource grpSrcInfo locs
392 :			in
393 :			BinInfo.new { group = group,
394 :			mkStablename = mksname,
395 :			error = error,
396 :			spec = spec,
397 :			offset = offset,
398 :			rts_pid = rts_pid,
399 :			sh_mode = sh_mode }
400 :			end
401 :			| s _ = raise Format
402 :			in
403 :			share siM s
404 :			end
405 :
406 :			(* this is the place where what used to be an
407 :			* SNODE changes to a BNODE! *)
408 :			fun sn () = let
409 :			fun sn' #"a" =
410 :			DG.BNODE { bininfo = si (),
411 :			localimports = snlist (),
412 :			globalimports = fsbnlist () }
413 :			| sn' _ = raise Format
414 :			in
415 :			share snM sn'
416 :			end
417 :
418 :			and snlist () = list snListM sn ()
419 :
420 :			(* this one changes from farsbnode to plain farbnode *)
421 :			and sbn () = let
422 :			fun sbn' #"2" = let
423 :	blume	632	val pos = int ()
424 :	blume	537	val sy = symbol ()
425 :	blume	632	val { exports = slexp, ... } = getSublib pos
426 :	blume	537	in
427 :			case SymbolMap.find (slexp, sy) of
428 :	blume	652	SOME (nth, _, _) =>
429 :			(case nth () of
430 :			(_, DG.SB_BNODE (n, _)) => n
431 :			| _ => raise Format)
432 :			| NONE => raise Format
433 :	blume	537	end
434 :			| sbn' #"3" = sn ()
435 :			| sbn' _ = raise Format
436 :			in
437 :			share sbnM sbn'
438 :			end
439 :
440 :			and fsbn () = let
441 :			fun f #"f" = (filter (), sbn ())
442 :			| f _ = raise Format
443 :			in
444 :			share fsbnM f
445 :			end
446 :
447 :	blume	715	and fsbnlist () = list fsbnListM lazy_fsbn ()
448 :	blume	537
449 :	blume	715	and lazy_fsbn () = UU.r_lazy session fsbn ()
450 :	blume	652
451 :	blume	537	fun impexp () = let
452 :			fun ie #"i" =
453 :			let val sy = symbol ()
454 :			(* really reads farbnodes! *)
455 :	blume	652	val nth = lazy_fsbn ()
456 :	blume	587	val ge = lazy_statenv ()
457 :	blume	652	val sye = lazy_symenv ()
458 :			val statpid = pid ()
459 :			val sympid = pid ()
460 :			val allsyms = symbolset ()
461 :			fun ieth () = let
462 :			val (f, n) = nth ()
463 :			val ii = { statenv = ge,
464 :			symenv = sye,
465 :			statpid = statpid,
466 :			sympid = sympid }
467 :			in
468 :			(f, DG.SB_BNODE (n, ii))
469 :			end
470 :	blume	587	val e = Statenv2DAEnv.cvtMemo ge
471 :	blume	652	(* put a filter in front to avoid having
472 :			* the FCTENV being queried needlessly
473 :			* (avoids spurious module loadings) *)
474 :			val e' = DAEnv.FILTER
475 :			(SymbolSet.singleton sy, e)
476 :	blume	537	in
477 :	blume	652	(sy, (Memoize.memoize ieth, e', allsyms))
478 :	blume	537	end
479 :			| ie _ = raise Format
480 :			in
481 :			share impexpM ie
482 :			end
483 :
484 :			val impexplist = list impexpListM impexp
485 :
486 :			fun r_exports () = let
487 :			fun e #"e" =
488 :			foldl SymbolMap.insert'
489 :			SymbolMap.empty (impexplist ())
490 :			| e _ = raise Format
491 :			in
492 :			share exportsM e
493 :			end
494 :
495 :			fun privileges () = let
496 :			fun p #"p" =
497 :			StringSet.addList (StringSet.empty, stringlist ())
498 :			| p _ = raise Format
499 :			in
500 :			share privilegesM p
501 :			end
502 :
503 :			val exports = r_exports ()
504 :			val required = privileges ()
505 :			in
506 :			GG.GROUP { exports = exports,
507 :	blume	632	kind = GG.LIB { version = version,
508 :			kind = GG.STABLE dropper },
509 :	blume	537	required = required,
510 :			grouppath = group,
511 :	blume	642	sources = SrcPathMap.empty,
512 :	blume	537	sublibs = sublibs }
513 :			end
514 :			| gr _ = raise Format
515 :			in
516 :			share groupM gr
517 :			end
518 :			in
519 :			SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
520 :			closeIt = BinIO.closeIn,
521 :			work = work,
522 :			cleanup = fn _ => () })
523 :			handle Format => (error ["file is corrupted (old version?)"];
524 :			NONE)
525 :			| IO.Io _ => NONE
526 :			end
527 :
528 :	blume	587	fun stabilize _ { group = GG.ERRORGROUP, ... } = NONE
529 :			| stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
530 :	blume	304
531 :	blume	323	val policy = #fnpolicy (#param gp)
532 :
533 :	blume	632	fun doit (wrapped, getBFC, vers) = let
534 :	blume	312
535 :	blume	569	val grouppath = #grouppath grec
536 :			val sublibs = #sublibs grec
537 :			val exports = #exports grec
538 :
539 :	blume	652	fun force f = f ()
540 :
541 :	blume	569	val libstamp =
542 :			libStampOf (grouppath,
543 :	blume	652	map (#2 o force o #1)
544 :			(SymbolMap.listItems exports),
545 :	blume	569	sublibs)
546 :
547 :	blume	403	fun writeBFC s i = BF.write { stream = s,
548 :			content = getBFC i,
549 :			nopickle = true }
550 :			fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }
551 :	blume	537	fun pidBFC i = BF.staticPidOf (getBFC i)
552 :	blume	403
553 :	blume	314	val _ =
554 :	blume	403	Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
555 :
556 :			val _ =
557 :	blume	348	if StringSet.isEmpty wrapped then ()
558 :	blume	314	else
559 :			Say.say ("$Stabilize: wrapping the following privileges:\n"
560 :	blume	312	:: map (fn s => (" " ^ s ^ "\n"))
561 :	blume	348	(StringSet.listItems wrapped))
562 :	blume	312
563 :	blume	311	val grpSrcInfo = (#errcons gp, anyerrors)
564 :	blume	308
565 :	blume	348	val required = StringSet.difference (#required grec, wrapped)
566 :	blume	304
567 :	blume	311	(* The format of a stable archive is the following:
568 :			* - It starts with the size s of the pickled dependency
569 :			* graph. This size itself is written as four-byte string.
570 :	blume	398	* - The size t of the pickled environment for the entire
571 :			* library (using the pickleEnvN interface of the pickler)
572 :			* in the same format as s.
573 :	blume	311	* - The pickled dependency graph. This graph contains
574 :			* integer offsets of the binfiles for the individual ML
575 :			* members. These offsets need to be adjusted by adding
576 :	blume	398	* s + t + 8. The pickled dependency graph also contains integer
577 :	blume	311	* offsets relative to other stable groups. These offsets
578 :			* need no further adjustment.
579 :	blume	398	* - Individual binfile contents (concatenated) but without
580 :			* their static environments.
581 :	blume	311	*)
582 :	blume	304
583 :	blume	569	val inverseMap = mkInverseMap sublibs
584 :	blume	330
585 :	blume	311	val members = ref []
586 :			val (registerOffset, getOffset) = let
587 :			val dict = ref SmlInfoMap.empty
588 :			val cur = ref 0
589 :	blume	653	fun get0 i = SmlInfoMap.find (!dict, i)
590 :			fun reg (i, sz) =
591 :			case get0 i of
592 :			(* This test is necessary because of a tiny chance
593 :			* that a portion of a pickle needs to be re-done
594 :			* by the pickler because it underestimated its
595 :			* size during lazy pickling. Ideally, the pickler
596 :			* should run without side-effects, but in the
597 :			* present case all we need is idempotence. *)
598 :			SOME os => os
599 :			| NONE => let
600 :			val os = !cur
601 :			in
602 :			cur := os + sz;
603 :			dict := SmlInfoMap.insert (!dict, i, os);
604 :			members := i :: (!members);
605 :			os
606 :			end
607 :			val get = valOf o get0
608 :	blume	311	in
609 :			(reg, get)
610 :			end
611 :	blume	304
612 :	blume	666	fun prepath2list what p = let
613 :			fun warn_relabs (abs, descr) = let
614 :	blume	643	val (relabs, is) = if abs then ("absolute", "is: ")
615 :			else ("relative", "was resolved as: ")
616 :	blume	569	fun ppb pps =
617 :			(PP.add_newline pps;
618 :	blume	666	PP.add_string pps (concat ["The ", what,
619 :			"'s path ", is]);
620 :			PP.add_string pps descr;
621 :	blume	569	PP.add_newline pps;
622 :			PP.add_string pps
623 :	blume	643	"(This means that in order to be able to use the result of stabilization,";
624 :	blume	569	PP.add_newline pps;
625 :	blume	666	PP.add_string pps
626 :			"objects referred to using this path must be in the same ";
627 :	blume	569	PP.add_string pps relabs;
628 :	blume	666	PP.add_newline pps;
629 :			PP.add_string pps "location as they are now.)";
630 :	blume	569	PP.add_newline pps)
631 :			in
632 :			EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
633 :			EM.WARN
634 :			(concat [SrcPath.descr grouppath,
635 :	blume	666	": ", what, " referred to by ",
636 :	blume	643	relabs, " pathname."])
637 :	blume	569	ppb
638 :			end
639 :			in
640 :	blume	666	SrcPath.pickle { warn = warn_relabs }
641 :			{ file = p, relativeTo = grouppath }
642 :	blume	569	end
643 :
644 :	blume	537	(* Collect all BNODEs that we see and build
645 :	blume	398	* a context suitable for P.envPickler. *)
646 :	blume	587	val libctxt = let
647 :	blume	398	fun lst f [] k s = k s
648 :			| lst f (h :: t) k s = f h (lst f t k) s
649 :
650 :	blume	537	fun sbn n k (s as (bnodes, snodes)) =
651 :	blume	398	case n of
652 :	blume	537	DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
653 :	blume	632	val (pos, sy) = inverseMap i
654 :	blume	398	val bnodes' =
655 :	blume	461	StableMap.insert (bnodes, i,
656 :	blume	632	((pos, sy), #statenv ii))
657 :	blume	398	in
658 :	blume	537	k (bnodes', snodes)
659 :	blume	398	end
660 :			| DG.SB_SNODE n => sn n k s
661 :
662 :	blume	537	and sn (DG.SNODE n) k (bnodes, snodes) = let
663 :	blume	398	val i = #smlinfo n
664 :			val li = #localimports n
665 :			val gi = #globalimports n
666 :			in
667 :			if SmlInfoSet.member (snodes, i) then
668 :	blume	537	k (bnodes, snodes)
669 :	blume	398	else let
670 :			val snodes' = SmlInfoSet.add (snodes, i)
671 :			in
672 :	blume	537	lst sn li (lst fsbn gi k) (bnodes, snodes')
673 :	blume	398	end
674 :			end
675 :
676 :			and fsbn (_, n) k s = sbn n k s
677 :
678 :	blume	652	fun impexp (nth, _, _) k s = fsbn (nth ()) k s
679 :	blume	398
680 :	blume	537	val bnodes =
681 :	blume	398	lst impexp (SymbolMap.listItems exports)
682 :	blume	537	#1
683 :			(StableMap.empty, SmlInfoSet.empty)
684 :	blume	398
685 :			val bnodel = StableMap.listItems bnodes
686 :
687 :	blume	587	fun libArg ([], _) = []
688 :			| libArg ((lsm, ge) :: t, m) = let
689 :			val m' = GenModIdMap.mkMap' (ge (), m)
690 :			in
691 :			(SOME lsm, m') :: libArg (t, m')
692 :			end
693 :	blume	398	in
694 :	blume	587	libArg (bnodel, MI.emptyTmap)
695 :	blume	398	end
696 :
697 :	blume	587	val env_orig = P.envPickler (fn _ => ()) (P.LIBRARY libctxt)
698 :	blume	398	val env = PU.lift_pickler lifter env_orig
699 :			val symenv_orig = P.symenvPickler
700 :			val symenv = PU.lift_pickler lifter symenv_orig
701 :			val lazy_env = PU.w_lazy env
702 :			val lazy_symenv = PU.w_lazy symenv
703 :
704 :	blume	537	val bool = PU.w_bool
705 :	blume	384	val int = PU.w_int
706 :	blume	398	val symbol = PickleSymPid.w_symbol
707 :			val pid = PickleSymPid.w_pid
708 :	blume	384	val share = PU.ah_share
709 :			val option = PU.w_option
710 :			val list = PU.w_list
711 :			val string = PU.w_string
712 :			val bool = PU.w_bool
713 :			val int = PU.w_int
714 :	blume	304
715 :	blume	385	fun symbolset ss = let
716 :			val op $ = PU.$ SS
717 :	blume	513	fun raw_ss ss = "s" $ [list symbol (SymbolSet.listItems ss)]
718 :	blume	385	in
719 :			share SSs raw_ss ss
720 :			end
721 :	blume	304
722 :	blume	384	val filter = option symbolset
723 :	blume	304
724 :	blume	513	val op $ = PU.$ SHM
725 :			fun shm (Sharing.SHARE true) = "a" $ []
726 :			| shm (Sharing.SHARE false) = "b" $ []
727 :			| shm Sharing.DONTSHARE = "c" $ []
728 :	blume	304
729 :	blume	384	fun si i = let
730 :	blume	340	(* FIXME: this is not a technical flaw, but perhaps one
731 :			* that deserves fixing anyway: If we only look at spec,
732 :			* then we are losing information about sub-grouping
733 :			* within libraries. However, the spec in BinInfo.info
734 :			* is only used for diagnostics and has no impact on the
735 :			* operation of CM itself. *)
736 :	blume	666	val spec = SrcPath.osstring_relative (SmlInfo.sourcepath i)
737 :	blume	311	val locs = SmlInfo.errorLocation gp i
738 :	blume	398	val offset = registerOffset (i, sizeBFC i)
739 :	blume	537	val { is_rts, ... } = SmlInfo.attribs i
740 :	blume	387	val sh_mode = SmlInfo.sh_mode i
741 :	blume	385	val op $ = PU.$ SI
742 :	blume	537	val rts_pid = if is_rts then SOME (pidBFC i) else NONE
743 :	blume	311	in
744 :	blume	537	"s" $ [string spec, string locs, int offset,
745 :			option pid rts_pid, shm sh_mode]
746 :	blume	311	end
747 :	blume	306
748 :	blume	384	fun abspath p = let
749 :	blume	513	val op $ = PU.$ AP
750 :	blume	384	in
751 :	blume	666	"p" $ [list string (prepath2list "library" (SrcPath.pre p))]
752 :	blume	384	end
753 :	blume	306
754 :	blume	385	fun sn n = let
755 :	blume	398	val op $ = PU.$ SN
756 :	blume	385	fun raw_sn (DG.SNODE n) =
757 :	blume	513	"a" $ [si (#smlinfo n), list sn (#localimports n),
758 :	blume	715	list lazy_fsbn' (#globalimports n)]
759 :	blume	384	in
760 :	blume	385	share SNs raw_sn n
761 :			end
762 :	blume	306
763 :	blume	398	(* Here we ignore the interface info because we will not
764 :			* need it anymore when we unpickle. *)
765 :	blume	385	and sbn x = let
766 :			val op $ = PU.$ SBN
767 :			in
768 :			case x of
769 :	blume	537	DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
770 :	blume	632	val (pos, sy) = inverseMap i
771 :	blume	398	in
772 :	blume	632	"2" $ [int pos, symbol sy]
773 :	blume	398	end
774 :	blume	513	| DG.SB_SNODE n => "3" $ [sn n]
775 :	blume	385	end
776 :
777 :			and fsbn (f, n) = let
778 :			val op $ = PU.$ FSBN
779 :			in
780 :	blume	513	"f" $ [filter f, sbn n]
781 :	blume	385	end
782 :	blume	370
783 :	blume	715	and lazy_fsbn arg = PU.w_lazy fsbn arg
784 :	blume	652
785 :	blume	715	and lazy_fsbn' arg = lazy_fsbn (fn () => arg)
786 :
787 :	blume	398	(* Here is the place where we need to write interface info. *)
788 :	blume	652	fun impexp (s, (nth, _, allsyms)) = let
789 :	blume	385	val op $ = PU.$ IMPEXP
790 :	blume	398	val { statenv, symenv, statpid, sympid } =
791 :	blume	652	case nth () of
792 :	blume	398	(_, DG.SB_BNODE (_, ii)) => ii
793 :			| (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
794 :			getII smlinfo
795 :	blume	385	in
796 :	blume	652	"i" $ [symbol s,
797 :			lazy_fsbn nth,
798 :	blume	587	lazy_env statenv,
799 :	blume	513	lazy_symenv symenv,
800 :			pid statpid,
801 :	blume	652	pid sympid,
802 :			symbolset allsyms]
803 :	blume	384	end
804 :	blume	307
805 :	blume	513	fun w_exports e = let
806 :			val op $ = PU.$ EXPORTS
807 :			in
808 :			"e" $ [list impexp (SymbolMap.listItemsi e)]
809 :			end
810 :	blume	306
811 :	blume	513	fun privileges p = let
812 :			val op $ = PU.$ PRIV
813 :			in
814 :			"p" $ [list string (StringSet.listItems p)]
815 :			end
816 :	blume	306
817 :	blume	632	fun version v = let
818 :			val op $ = PU.$ VERSION
819 :			in
820 :			"v" $ [string (Version.toString v)]
821 :			end
822 :
823 :	blume	666	fun rb { anchor, value } = let
824 :			val op $ = PU.$ RB
825 :			in
826 :			"b" $ [string anchor,
827 :			list string (prepath2list "anchor binding" value)]
828 :			end
829 :
830 :			fun sg (p, gth, rbl) = let
831 :	blume	632	val op $ = PU.$ SG
832 :	blume	652	val vo = case gth () of
833 :			GG.GROUP { kind = GG.LIB x, ... } => #version x
834 :			| _ => NONE
835 :	blume	632	in
836 :	blume	666	"S" $ [abspath p, option version vo, list rb rbl]
837 :	blume	632	end
838 :
839 :	blume	384	fun group () = let
840 :	blume	513	val op $ = PU.$ G
841 :	blume	311	in
842 :	blume	340	(* Pickle the sublibs first because we need to already
843 :	blume	330	* have them back when we unpickle BNODEs. *)
844 :	blume	632	"g" $ [option version vers,
845 :			list sg sublibs,
846 :	blume	569	w_exports exports,
847 :			privileges required]
848 :	blume	311	end
849 :	blume	308
850 :	blume	398	val dg_pickle =
851 :			Byte.stringToBytes (PU.pickle emptyMap (group ()))
852 :	blume	403
853 :	blume	398	val dg_sz = Word8Vector.length dg_pickle
854 :	blume	308
855 :	blume	569	val offset_adjustment = dg_sz + 4 + libstamp_nbytes
856 :	blume	398
857 :	blume	537	(* We could generate the graph for a stable group here directly
858 :			* by transcribing the original graph. However, it is cumbersome
859 :			* and is likely to result in a larger memory footprint because
860 :			* we don't get the benefit of lazy unpickling of environments.
861 :			* It seems easier to simply rely on "loadStable" to re-fetch
862 :			* the stable graph. *)
863 :			fun refetchStableGroup () = let
864 :	blume	666	fun getGroup (_, p, _, _) = let
865 :			fun theSublib (q, _, _) = SrcPath.compare (p, q) = EQUAL
866 :	blume	652	fun force f = f ()
867 :	blume	537	in
868 :	blume	652	Option.map (force o #2) (List.find theSublib sublibs)
869 :	blume	537	end
870 :	blume	311	in
871 :	blume	666	(* We don't need to worry about rebindings here. *)
872 :			loadStable { getGroup = getGroup, anyerrors = anyerrors }
873 :			(gp, grouppath, NONE, [])
874 :	blume	311	end
875 :	blume	537
876 :	blume	311	fun writeInt32 (s, i) = let
877 :			val a = Word8Array.array (4, 0w0)
878 :			val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
879 :			in
880 :			BinIO.output (s, Word8Array.extract (a, 0, NONE))
881 :			end
882 :			val memberlist = rev (!members)
883 :
884 :	blume	632	(* We do not use version information for making the stable path! *)
885 :			fun mksname () =
886 :			FilenamePolicy.mkStableName policy (grouppath, NONE)
887 :
888 :	blume	569	val libstamp_bytes = Pid.toBytes libstamp
889 :			val _ =
890 :			if Word8Vector.length libstamp_bytes <> libstamp_nbytes then
891 :			EM.impossible "stabilize: libstamp size wrong"
892 :			else ()
893 :	blume	345	fun work outs =
894 :	blume	569	(BinIO.output (outs, libstamp_bytes);
895 :			writeInt32 (outs, dg_sz);
896 :	blume	398	BinIO.output (outs, dg_pickle);
897 :	blume	537	app (writeBFC outs) memberlist)
898 :	blume	311	in
899 :	blume	537	(SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
900 :			closeIt = BinIO.closeOut,
901 :			work = work,
902 :			cleanup = fn _ =>
903 :	blume	361	(OS.FileSys.remove (mksname ())
904 :	blume	537	handle _ => ()) };
905 :			refetchStableGroup ())
906 :	blume	426	handle exn =>
907 :			(EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
908 :			EM.COMPLAIN
909 :			(concat ["Exception raised while stabilizing ",
910 :			SrcPath.descr grouppath])
911 :			EM.nullErrorBody;
912 :			NONE)
913 :	blume	311	end
914 :			in
915 :	blume	348	case #kind grec of
916 :	blume	632	GG.LIB { kind = GG.STABLE _, ... } => SOME g
917 :	blume	537	| GG.NOLIB _ => EM.impossible "stabilize: no library"
918 :	blume	632	| GG.LIB { kind = GG.DEVELOPED { wrapped, ... }, version } =>
919 :	blume	403	(case recomp gp g of
920 :			NONE => (anyerrors := true; NONE)
921 :			| SOME bfc_acc => let
922 :	blume	666	fun notStable (_, gth, _) =
923 :	blume	652	case gth () of
924 :			GG.GROUP { kind =
925 :			GG.LIB { kind = GG.STABLE _,
926 :			... }, ... } =>
927 :			false
928 :			| _ => true
929 :	blume	403	in
930 :	blume	340	case List.filter notStable (#sublibs grec) of
931 :	blume	632	[] => doit (wrapped, bfc_acc, version)
932 :	blume	311	| l => let
933 :			val grammar = case l of [_] => " is" | _ => "s are"
934 :			fun ppb pps = let
935 :			fun loop [] = ()
936 :	blume	666	| loop ((p, _, _) :: t) =
937 :	blume	444	(PP.add_string pps (SrcPath.descr p);
938 :	blume	311	PP.add_newline pps;
939 :			loop t)
940 :			in
941 :			PP.add_newline pps;
942 :			PP.add_string pps
943 :			(concat ["because the following sub-group",
944 :			grammar, " not stable:"]);
945 :			PP.add_newline pps;
946 :			loop l
947 :			end
948 :			val errcons = #errcons gp
949 :	blume	354	val gdescr = SrcPath.descr (#grouppath grec)
950 :	blume	311	in
951 :			EM.errorNoFile (errcons, anyerrors) SM.nullRegion
952 :			EM.COMPLAIN
953 :	blume	354	(gdescr ^ " cannot be stabilized")
954 :	blume	311	ppb;
955 :			NONE
956 :			end
957 :	blume	403	end)
958 :	blume	311	end
959 :	blume	537	end (* functor Stabilize *)
960 :	blume	310
961 :	blume	309	end (* local *)

---

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