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

Parent Directory | Revision Log

---

Revision 323 - (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	310
17 :			type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18 :	blume	314	type recomp = GP.info -> GG.group -> bool
19 :	blume	309	in
20 :	blume	304
21 :	blume	309	signature STABILIZE = sig
22 :
23 :			val loadStable :
24 :	blume	310	GP.info * (AbsPath.t -> GG.group option) * bool ref ->
25 :			AbsPath.t -> GG.group option
26 :	blume	309
27 :			val stabilize :
28 :	blume	311	GP.info -> { group: GG.group, anyerrors: bool ref } ->
29 :	blume	310	GG.group option
30 :	blume	309	end
31 :
32 :	blume	311	functor StabilizeFn (val bn2statenv : statenvgetter
33 :			val recomp: recomp) :> STABILIZE = struct
34 :	blume	309
35 :	blume	307	datatype pitem =
36 :			PSS of SymbolSet.set
37 :			| PS of Symbol.symbol
38 :			| PSN of DG.snode
39 :			| PAP of AbsPath.t
40 :	blume	304
41 :	blume	307	datatype uitem =
42 :			USS of SymbolSet.set
43 :			| US of Symbol.symbol
44 :			| UBN of DG.bnode
45 :			| UAP of AbsPath.t
46 :	blume	304
47 :	blume	307	fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
48 :			| compare (PS _, _) = GREATER
49 :			| compare (_, PS _) = LESS
50 :			| compare (PSS s, PSS s') = SymbolSet.compare (s, s')
51 :			| compare (PSS _, _) = GREATER
52 :			| compare (_, PSS _) = LESS
53 :			| compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
54 :			SmlInfo.compare (#smlinfo n, #smlinfo n')
55 :			| compare (PSN _, _) = GREATER
56 :			| compare (_, PSN _) = LESS
57 :			| compare (PAP p, PAP p') = AbsPath.compare (p, p')
58 :
59 :	blume	304	structure Map =
60 :			BinaryMapFn (struct
61 :	blume	307	type ord_key = pitem
62 :	blume	304	val compare = compare
63 :			end)
64 :
65 :	blume	308	fun genStableInfoMap (exports, group) = let
66 :			(* find all the exported bnodes that are in the same group: *)
67 :			fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
68 :			val i = #bininfo b
69 :			in
70 :			if AbsPath.compare (BinInfo.group i, group) = EQUAL then
71 :			IntBinaryMap.insert (m, BinInfo.offset i, n)
72 :			else m
73 :			end
74 :			| add (_, m) = m
75 :			in
76 :			SymbolMap.foldl add IntBinaryMap.empty exports
77 :			end
78 :
79 :	blume	310	fun deleteFile n = OS.FileSys.remove n
80 :			handle e as Interrupt.Interrupt => raise e
81 :			| _ => ()
82 :
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 :
88 :	blume	311	fun doit granted = let
89 :	blume	312
90 :	blume	314	val _ =
91 :			if StringSet.isEmpty granted then ()
92 :			else
93 :			Say.say ("$Stabilize: wrapping the following privileges:\n"
94 :	blume	312	:: map (fn s => (" " ^ s ^ "\n"))
95 :			(StringSet.listItems granted))
96 :
97 :	blume	311	val bname = AbsPath.name o SmlInfo.binpath
98 :			val bsz = OS.FileSys.fileSize o bname
99 :			fun cpb s i = let
100 :			val ins = BinIO.openIn (bname i)
101 :			fun cp () =
102 :			if BinIO.endOfStream ins then ()
103 :			else (BinIO.output (s, BinIO.input ins); cp ())
104 :			in
105 :			cp () handle e => (BinIO.closeIn ins; raise e);
106 :	blume	310	BinIO.closeIn ins
107 :	blume	311	end
108 :			val delb = deleteFile o bname
109 :	blume	310
110 :	blume	311	val grpSrcInfo = (#errcons gp, anyerrors)
111 :	blume	308
112 :	blume	311	val exports = #exports grec
113 :			val islib = #islib grec
114 :			val required = StringSet.difference (#required grec, granted)
115 :			val grouppath = #grouppath grec
116 :			val subgroups = #subgroups grec
117 :	blume	304
118 :	blume	311	(* The format of a stable archive is the following:
119 :			* - It starts with the size s of the pickled dependency
120 :			* graph. This size itself is written as four-byte string.
121 :			* - The pickled dependency graph. This graph contains
122 :			* integer offsets of the binfiles for the individual ML
123 :			* members. These offsets need to be adjusted by adding
124 :			* s + 4. The pickled dependency graph also contains integer
125 :			* offsets relative to other stable groups. These offsets
126 :			* need no further adjustment.
127 :			* - Individual binfile contents (concatenated).
128 :			*)
129 :	blume	304
130 :	blume	311	val members = ref []
131 :			val (registerOffset, getOffset) = let
132 :			val dict = ref SmlInfoMap.empty
133 :			val cur = ref 0
134 :			fun reg (i, sz) = let
135 :			val os = !cur
136 :	blume	306	in
137 :	blume	311	cur := os + sz;
138 :			dict := SmlInfoMap.insert (!dict, i, os);
139 :			members := i :: (!members);
140 :			os
141 :	blume	306	end
142 :	blume	311	fun get i = valOf (SmlInfoMap.find (!dict, i))
143 :			in
144 :			(reg, get)
145 :			end
146 :	blume	304
147 :	blume	311	fun w_list w_item [] k m =
148 :			"0" :: k m
149 :			| w_list w_item [a] k m =
150 :			"1" :: w_item a k m
151 :			| w_list w_item [a, b] k m =
152 :			"2" :: w_item a (w_item b k) m
153 :			| w_list w_item [a, b, c] k m =
154 :			"3" :: w_item a (w_item b (w_item c k)) m
155 :			| w_list w_item [a, b, c, d] k m =
156 :			"4" :: w_item a (w_item b (w_item c (w_item d k))) m
157 :			| w_list w_item (a :: b :: c :: d :: e :: r) k m =
158 :			"5" :: w_item a (w_item b (w_item c (w_item d (w_item e
159 :			(w_list w_item r k))))) m
160 :	blume	304
161 :	blume	311	fun w_option w_item NONE k m = "n" :: k m
162 :			| w_option w_item (SOME i) k m = "s" :: w_item i k m
163 :	blume	304
164 :	blume	311	fun int_encode i = let
165 :			(* this is the same mechanism that's also used in
166 :			* TopLevel/batch/binfile.sml (maybe we should share it) *)
167 :			val n = Word32.fromInt i
168 :			val // = LargeWord.div
169 :			val %% = LargeWord.mod
170 :			val !! = LargeWord.orb
171 :			infix // %% !!
172 :			val toW8 = Word8.fromLargeWord
173 :			fun r (0w0, l) = Word8Vector.fromList l
174 :			| r (n, l) =
175 :			r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
176 :			in
177 :			Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
178 :			end
179 :	blume	304
180 :	blume	311	fun w_int i k m = int_encode i :: k m
181 :	blume	304
182 :	blume	311	fun w_share w C v k (i, m) =
183 :			case Map.find (m, C v) of
184 :			SOME i' => "o" :: w_int i' k (i, m)
185 :			| NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
186 :	blume	304
187 :	blume	311	fun w_symbol_raw s k m = let
188 :			val ns = case Symbol.nameSpace s of
189 :			Symbol.SIGspace => "'"
190 :			| Symbol.FCTspace => "("
191 :			| Symbol.FSIGspace => ")"
192 :			| Symbol.STRspace => ""
193 :			| _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
194 :			in
195 :			ns :: Symbol.name s :: "." :: k m
196 :			end
197 :	blume	304
198 :	blume	311	val w_symbol = w_share w_symbol_raw PS
199 :	blume	304
200 :	blume	311	val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
201 :	blume	306
202 :	blume	311	val w_filter = w_option w_ss
203 :	blume	306
204 :	blume	311	fun w_string s k m = let
205 :			fun esc #"\\" = "\\\\"
206 :			| esc #"\"" = "\\\""
207 :			| esc c = String.str c
208 :			in
209 :			String.translate esc s :: "\"" :: k m
210 :			end
211 :	blume	306
212 :	blume	311	fun w_sharing NONE k m = "n" :: k m
213 :			| w_sharing (SOME true) k m = "t" :: k m
214 :			| w_sharing (SOME false) k m = "f" :: k m
215 :	blume	306
216 :	blume	311	fun w_si i k = let
217 :			val spec = AbsPath.spec (SmlInfo.sourcepath i)
218 :			val locs = SmlInfo.errorLocation gp i
219 :			val offset = registerOffset (i, bsz i)
220 :			in
221 :			w_string spec
222 :			(w_string locs
223 :			(w_int offset
224 :			(w_sharing (SmlInfo.share i) k)))
225 :			end
226 :	blume	306
227 :	blume	323	fun w_primitive p k m =
228 :			String.str (Primitive.toIdent primconf p) :: k m
229 :	blume	306
230 :	blume	311	fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m
231 :	blume	306
232 :	blume	311	val w_abspath = w_share w_abspath_raw PAP
233 :	blume	306
234 :	blume	311	fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
235 :			| w_bn (DG.BNODE { bininfo = i, ... }) k m =
236 :			"b" :: w_abspath (BinInfo.group i)
237 :			(w_int (BinInfo.offset i) k) m
238 :	blume	306
239 :	blume	311	fun w_sn_raw (DG.SNODE n) k =
240 :			w_si (#smlinfo n)
241 :			(w_list w_sn (#localimports n)
242 :			(w_list w_fsbn (#globalimports n) k))
243 :	blume	306
244 :	blume	311	and w_sn n = w_share w_sn_raw PSN n
245 :	blume	307
246 :	blume	311	and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
247 :			| w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
248 :	blume	306
249 :	blume	311	and w_fsbn (f, n) k = w_filter f (w_sbn n k)
250 :	blume	306
251 :	blume	311	fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)
252 :	blume	306
253 :	blume	311	fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)
254 :	blume	306
255 :	blume	311	fun w_bool true k m = "t" :: k m
256 :			| w_bool false k m = "f" :: k m
257 :	blume	306
258 :	blume	311	fun w_privileges p = w_list w_string (StringSet.listItems p)
259 :	blume	306
260 :	blume	311	fun pickle_group () = let
261 :			fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)
262 :			fun k0 m = []
263 :			val m0 = (0, Map.empty)
264 :			in
265 :			concat (w_exports exports
266 :			(w_bool islib
267 :			(w_privileges required
268 :			(w_list w_sg subgroups k0))) m0)
269 :			end
270 :	blume	308
271 :	blume	311	val pickle = pickle_group ()
272 :			val sz = size pickle
273 :			val offset_adjustment = sz + 4
274 :	blume	308
275 :	blume	311	fun mkStableGroup () = let
276 :			val m = ref SmlInfoMap.empty
277 :			fun sn (DG.SNODE (n as { smlinfo, ... })) =
278 :			case SmlInfoMap.find (!m, smlinfo) of
279 :			SOME n => n
280 :			| NONE => let
281 :			val li = map sn (#localimports n)
282 :			val gi = map fsbn (#globalimports n)
283 :			val sourcepath = SmlInfo.sourcepath smlinfo
284 :			val spec = AbsPath.spec sourcepath
285 :			val offset =
286 :			getOffset smlinfo + offset_adjustment
287 :			val share = SmlInfo.share smlinfo
288 :			val locs = SmlInfo.errorLocation gp smlinfo
289 :			val error = EM.errorNoSource grpSrcInfo locs
290 :			val i = BinInfo.new { group = grouppath,
291 :			spec = spec,
292 :			offset = offset,
293 :			share = share,
294 :			error = error }
295 :			val n = DG.BNODE { bininfo = i,
296 :			localimports = li,
297 :			globalimports = gi }
298 :			in
299 :			m := SmlInfoMap.insert (!m, smlinfo, n);
300 :			n
301 :			end
302 :	blume	308
303 :	blume	311	and sbn (DG.SB_SNODE n) = sn n
304 :			| sbn (DG.SB_BNODE n) = n
305 :	blume	308
306 :	blume	311	and fsbn (f, n) = (f, sbn n)
307 :	blume	308
308 :	blume	311	fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
309 :	blume	308
310 :	blume	311	val exports = SymbolMap.map impexp (#exports grec)
311 :			val simap = genStableInfoMap (exports, grouppath)
312 :			in
313 :			GG.GROUP { exports = exports,
314 :			islib = islib,
315 :			required = required,
316 :			grouppath = grouppath,
317 :			subgroups = subgroups,
318 :			stableinfo = GG.STABLE simap }
319 :			end
320 :	blume	308
321 :	blume	311	fun writeInt32 (s, i) = let
322 :			val a = Word8Array.array (4, 0w0)
323 :			val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
324 :			in
325 :			BinIO.output (s, Word8Array.extract (a, 0, NONE))
326 :			end
327 :			val memberlist = rev (!members)
328 :
329 :			val gpath = #grouppath grec
330 :			val spath = FilenamePolicy.mkStablePath policy gpath
331 :			fun delete () = deleteFile (AbsPath.name spath)
332 :			val outs = AbsPath.openBinOut spath
333 :			fun try () =
334 :			(Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
335 :			writeInt32 (outs, sz);
336 :			BinIO.output (outs, Byte.stringToBytes pickle);
337 :			app (cpb outs) memberlist;
338 :			app delb memberlist;
339 :			BinIO.closeOut outs;
340 :			SOME (mkStableGroup ()))
341 :			in
342 :			Interrupt.guarded try
343 :			handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
344 :			delete ();
345 :			raise e)
346 :			| exn => (BinIO.closeOut outs; NONE)
347 :			end
348 :			in
349 :			case #stableinfo grec of
350 :			GG.STABLE _ => SOME g
351 :			| GG.NONSTABLE granted =>
352 :	blume	314	if not (recomp gp g) then
353 :	blume	311	(anyerrors := true; NONE)
354 :			else let
355 :			fun notStable (GG.GROUP { stableinfo, ... }) =
356 :			case stableinfo of
357 :			GG.STABLE _ => false
358 :			| GG.NONSTABLE _ => true
359 :	blume	308	in
360 :	blume	311	case List.filter notStable (#subgroups grec) of
361 :			[] => doit granted
362 :			| l => let
363 :			val grammar = case l of [_] => " is" | _ => "s are"
364 :			fun ppb pps = let
365 :			fun loop [] = ()
366 :			| loop (GG.GROUP { grouppath, ... } :: t) =
367 :			(PP.add_string pps
368 :			(AbsPath.name grouppath);
369 :			PP.add_newline pps;
370 :			loop t)
371 :			in
372 :			PP.add_newline pps;
373 :			PP.add_string pps
374 :			(concat ["because the following sub-group",
375 :			grammar, " not stable:"]);
376 :			PP.add_newline pps;
377 :			loop l
378 :			end
379 :			val errcons = #errcons gp
380 :			val gname = AbsPath.name (#grouppath grec)
381 :			in
382 :			EM.errorNoFile (errcons, anyerrors) SM.nullRegion
383 :			EM.COMPLAIN
384 :			(gname ^ " cannot be stabilized")
385 :			ppb;
386 :			NONE
387 :			end
388 :	blume	308	end
389 :	blume	311	end
390 :	blume	310
391 :			fun loadStable (gp, getGroup, anyerrors) group = let
392 :	blume	306
393 :	blume	310	fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
394 :	blume	308
395 :	blume	311	val errcons = #errcons gp
396 :			val grpSrcInfo = (errcons, anyerrors)
397 :			val gname = AbsPath.name group
398 :			fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
399 :			EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
400 :	blume	309
401 :	blume	306	exception Format
402 :
403 :	blume	318	val pcmode = #pcmode (#param gp)
404 :	blume	310	val policy = #fnpolicy (#param gp)
405 :	blume	323	val primconf = #primconf (#param gp)
406 :	blume	310	val spath = FilenamePolicy.mkStablePath policy group
407 :	blume	311	val _ = Say.vsay ["[checking stable ", gname, "]\n"]
408 :	blume	310	val s = AbsPath.openBinIn spath
409 :
410 :			fun getGroup' p =
411 :			case getGroup p of
412 :			SOME g => g
413 :	blume	311	| NONE =>
414 :			(error ["unable to find ", AbsPath.name p];
415 :			raise Format)
416 :	blume	310
417 :	blume	306	(* for getting sharing right... *)
418 :			val m = ref IntBinaryMap.empty
419 :			val next = ref 0
420 :
421 :			fun bytesIn n = let
422 :			val bv = BinIO.inputN (s, n)
423 :	blume	304	in
424 :	blume	306	if n = Word8Vector.length bv then bv
425 :			else raise Format
426 :	blume	304	end
427 :
428 :	blume	306	val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
429 :			val pickle = bytesIn sz
430 :			val offset_adjustment = sz + 4
431 :	blume	304
432 :	blume	306	val rd = let
433 :			val pos = ref 0
434 :			fun rd () = let
435 :			val p = !pos
436 :			in
437 :			pos := p + 1;
438 :			Byte.byteToChar (Word8Vector.sub (pickle, p))
439 :			handle _ => raise Format
440 :			end
441 :	blume	304	in
442 :	blume	306	rd
443 :	blume	304	end
444 :
445 :	blume	306	fun r_list r () =
446 :			case rd () of
447 :			#"0" => []
448 :			| #"1" => [r ()]
449 :			| #"2" => [r (), r ()]
450 :			| #"3" => [r (), r (), r ()]
451 :			| #"4" => [r (), r (), r (), r ()]
452 :			| #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
453 :			| _ => raise Format
454 :	blume	304
455 :	blume	306	fun r_bool () =
456 :			case rd () of
457 :			#"t" => true
458 :			| #"f" => false
459 :			| _ => raise Format
460 :	blume	304
461 :	blume	306	fun r_option r_item () =
462 :			case rd () of
463 :			#"n" => NONE
464 :			| #"s" => SOME (r_item ())
465 :			| _ => raise Format
466 :	blume	304
467 :	blume	306	fun r_int () = let
468 :			fun loop n = let
469 :			val w8 = Byte.charToByte (rd ())
470 :			val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
471 :			in
472 :			if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
473 :			end
474 :			in
475 :			LargeWord.toIntX (loop 0w0)
476 :			end
477 :	blume	304
478 :	blume	306	fun r_share r_raw C unC () =
479 :			case rd () of
480 :			#"o" => (case IntBinaryMap.find (!m, r_int ()) of
481 :			SOME x => unC x
482 :			| NONE => raise Format)
483 :			| #"n" => let
484 :			val i = !next
485 :			val _ = next := i + 1
486 :			val v = r_raw ()
487 :			in
488 :			m := IntBinaryMap.insert (!m, i, C v);
489 :			v
490 :			end
491 :			| _ => raise Format
492 :	blume	304
493 :	blume	306	fun r_string () = let
494 :			fun loop l =
495 :			case rd () of
496 :			#"\"" => String.implode (rev l)
497 :			| #"\\" => loop (rd () :: l)
498 :			| c => loop (c :: l)
499 :			in
500 :			loop []
501 :			end
502 :	blume	304
503 :	blume	306	val r_abspath = let
504 :			fun r_abspath_raw () =
505 :	blume	318	case AbsPath.unpickle pcmode (r_list r_string ()) of
506 :	blume	306	SOME p => p
507 :			| NONE => raise Format
508 :	blume	307	fun unUAP (UAP x) = x
509 :			| unUAP _ = raise Format
510 :	blume	306	in
511 :	blume	307	r_share r_abspath_raw UAP unUAP
512 :	blume	306	end
513 :	blume	304
514 :	blume	306	val r_symbol = let
515 :			fun r_symbol_raw () = let
516 :			val (ns, first) =
517 :			case rd () of
518 :			#"`" => (Symbol.sigSymbol, rd ())
519 :			| #"(" => (Symbol.fctSymbol, rd ())
520 :			| #")" => (Symbol.fsigSymbol, rd ())
521 :			| c => (Symbol.strSymbol, c)
522 :			fun loop (#".", l) = String.implode (rev l)
523 :			| loop (c, l) = loop (rd (), c :: l)
524 :			in
525 :			ns (loop (first, []))
526 :			end
527 :	blume	307	fun unUS (US x) = x
528 :			| unUS _ = raise Format
529 :	blume	306	in
530 :	blume	307	r_share r_symbol_raw US unUS
531 :	blume	306	end
532 :	blume	304
533 :	blume	306	val r_ss = let
534 :			fun r_ss_raw () =
535 :			SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
536 :	blume	307	fun unUSS (USS s) = s
537 :			| unUSS _ = raise Format
538 :	blume	306	in
539 :	blume	307	r_share r_ss_raw USS unUSS
540 :	blume	306	end
541 :	blume	304
542 :	blume	306	val r_filter = r_option r_ss
543 :	blume	305
544 :	blume	306	fun r_primitive () =
545 :	blume	323	case Primitive.fromIdent primconf (rd ()) of
546 :	blume	306	NONE => raise Format
547 :			| SOME p => p
548 :	blume	305
549 :	blume	306	fun r_sharing () =
550 :			case rd () of
551 :			#"n" => NONE
552 :			| #"t" => SOME true
553 :			| #"f" => SOME false
554 :			| _ => raise Format
555 :	blume	305
556 :	blume	307	fun r_si () = let
557 :			val spec = r_string ()
558 :			val locs = r_string ()
559 :			val offset = r_int () + offset_adjustment
560 :			val share = r_sharing ()
561 :			val error = EM.errorNoSource grpSrcInfo locs
562 :	blume	306	in
563 :	blume	307	BinInfo.new { group = group,
564 :			error = error,
565 :			spec = spec,
566 :			offset = offset,
567 :			share = share }
568 :	blume	306	end
569 :	blume	305
570 :	blume	306	fun r_bn () =
571 :			case rd () of
572 :			#"p" => DG.PNODE (r_primitive ())
573 :	blume	307	| #"b" => let
574 :			val p = r_abspath ()
575 :			val os = r_int ()
576 :			in
577 :	blume	310	case getGroup' p of
578 :			GG.GROUP { stableinfo = GG.STABLE im, ... } =>
579 :	blume	307	(case IntBinaryMap.find (im, os) of
580 :			NONE => raise Format
581 :			| SOME n => n)
582 :	blume	310	| _ => raise Format
583 :	blume	307	end
584 :	blume	306	| _ => raise Format
585 :
586 :			(* this is the place where what used to be an
587 :			* SNODE changes to a BNODE! *)
588 :	blume	307	fun r_sn_raw () =
589 :	blume	306	DG.BNODE { bininfo = r_si (),
590 :			localimports = r_list r_sn (),
591 :			globalimports = r_list r_fsbn () }
592 :
593 :	blume	307	and r_sn () =
594 :			r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
595 :
596 :	blume	306	(* this one changes from farsbnode to plain farbnode *)
597 :			and r_sbn () =
598 :			case rd () of
599 :			#"b" => r_bn ()
600 :			| #"s" => r_sn ()
601 :			| _ => raise Format
602 :
603 :			and r_fsbn () = (r_filter (), r_sbn ())
604 :
605 :			fun r_impexp () = let
606 :			val sy = r_symbol ()
607 :			val (f, n) = r_fsbn () (* really reads farbnodes! *)
608 :	blume	307	val e = bn2env n
609 :	blume	310	(* put a filter in front to avoid having the FCTENV being
610 :			* queried needlessly (this avoids spurious module loadings) *)
611 :			val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
612 :	blume	305	in
613 :	blume	310	(sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
614 :	blume	305	end
615 :	blume	306
616 :			fun r_exports () =
617 :			foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
618 :
619 :			fun r_privileges () =
620 :			StringSet.addList (StringSet.empty, r_list r_string ())
621 :
622 :			fun unpickle_group () = let
623 :			val exports = r_exports ()
624 :			val islib = r_bool ()
625 :			val required = r_privileges ()
626 :	blume	310	val subgroups = r_list (getGroup' o r_abspath) ()
627 :	blume	308	val simap = genStableInfoMap (exports, group)
628 :	blume	306	in
629 :			GG.GROUP { exports = exports,
630 :			islib = islib,
631 :			required = required,
632 :	blume	308	grouppath = group,
633 :	blume	306	subgroups = subgroups,
634 :	blume	307	stableinfo = GG.STABLE simap }
635 :	blume	310	before BinIO.closeIn s
636 :	blume	306	end
637 :	blume	304	in
638 :	blume	310	SOME (unpickle_group ())
639 :			handle Format => (BinIO.closeIn s; NONE)
640 :			| exn => (BinIO.closeIn s; raise exn)
641 :			end handle IO.Io _ => NONE
642 :	blume	304	end
643 :	blume	309
644 :			end (* local *)

---

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