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

Parent Directory | Revision Log

---

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

---

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