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

Parent Directory | Revision Log

---

Revision 308 - (view) (download)

1 :	blume	304	structure Stablize = struct
2 :
3 :			structure DG = DependencyGraph
4 :	blume	306	structure GG = GroupGraph
5 :			structure EM = GenericVC.ErrorMsg
6 :	blume	304
7 :	blume	307	datatype pitem =
8 :			PSS of SymbolSet.set
9 :			| PS of Symbol.symbol
10 :			| PSN of DG.snode
11 :			| PAP of AbsPath.t
12 :	blume	304
13 :	blume	307	datatype uitem =
14 :			USS of SymbolSet.set
15 :			| US of Symbol.symbol
16 :			| UBN of DG.bnode
17 :			| UAP of AbsPath.t
18 :	blume	304
19 :	blume	307	fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
20 :			| compare (PS _, _) = GREATER
21 :			| compare (_, PS _) = LESS
22 :			| compare (PSS s, PSS s') = SymbolSet.compare (s, s')
23 :			| compare (PSS _, _) = GREATER
24 :			| compare (_, PSS _) = LESS
25 :			| compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
26 :			SmlInfo.compare (#smlinfo n, #smlinfo n')
27 :			| compare (PSN _, _) = GREATER
28 :			| compare (_, PSN _) = LESS
29 :			| compare (PAP p, PAP p') = AbsPath.compare (p, p')
30 :
31 :	blume	304	structure Map =
32 :			BinaryMapFn (struct
33 :	blume	307	type ord_key = pitem
34 :	blume	304	val compare = compare
35 :			end)
36 :
37 :	blume	308	fun genStableInfoMap (exports, group) = let
38 :			(* find all the exported bnodes that are in the same group: *)
39 :			fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
40 :			val i = #bininfo b
41 :			in
42 :			if AbsPath.compare (BinInfo.group i, group) = EQUAL then
43 :			IntBinaryMap.insert (m, BinInfo.offset i, n)
44 :			else m
45 :			end
46 :			| add (_, m) = m
47 :			in
48 :			SymbolMap.foldl add IntBinaryMap.empty exports
49 :			end
50 :
51 :			fun stabilize gp (g as GG.GROUP grec, binSizeOf, copyBin, outs) =
52 :	blume	306	case #stableinfo grec of
53 :			GG.STABLE _ => g
54 :			| GG.NONSTABLE granted => let
55 :	blume	304
56 :	blume	308	(* this needs to be refined (perhaps) *)
57 :			val grpSrcInfo = (EM.defaultConsumer (), ref false)
58 :
59 :	blume	306	val exports = #exports grec
60 :	blume	308	val islib = #islib grec
61 :			val required = StringSet.difference (#required grec,
62 :			granted)
63 :			val grouppath = #grouppath grec
64 :			val subgroups = #subgroups grec
65 :	blume	304
66 :	blume	306	(* The format of a stable archive is the following:
67 :			* - It starts with the size s of the pickled dependency
68 :			* graph. This size itself is written as four-byte string.
69 :			* - The pickled dependency graph. This graph contains
70 :			* integer offsets of the binfiles for the individual ML
71 :			* members. These offsets need to be adjusted by adding
72 :			* s + 4. The pickled dependency graph also contains integer
73 :			* offsets relative to other stable groups. These offsets
74 :			* need no further adjustment.
75 :			* - Individual binfile contents (concatenated).
76 :			*)
77 :	blume	304
78 :	blume	307	val members = ref []
79 :	blume	308	val (registerOffset, getOffset) = let
80 :			val dict = ref SmlInfoMap.empty
81 :	blume	307	val cur = ref 0
82 :			fun reg (i, sz) = let
83 :			val os = !cur
84 :			in
85 :			cur := os + sz;
86 :	blume	308	dict := SmlInfoMap.insert (!dict, i, os);
87 :	blume	307	members := i :: (!members);
88 :			os
89 :			end
90 :	blume	308	fun get i = valOf (SmlInfoMap.find (!dict, i))
91 :	blume	306	in
92 :	blume	308	(reg, get)
93 :	blume	306	end
94 :	blume	304
95 :	blume	307	fun w_list w_item [] k m =
96 :			"0" :: k m
97 :			| w_list w_item [a] k m =
98 :			"1" :: w_item a k m
99 :			| w_list w_item [a, b] k m =
100 :			"2" :: w_item a (w_item b k) m
101 :	blume	306	| w_list w_item [a, b, c] k m =
102 :			"3" :: w_item a (w_item b (w_item c k)) m
103 :			| w_list w_item [a, b, c, d] k m =
104 :			"4" :: w_item a (w_item b (w_item c (w_item d k))) m
105 :			| w_list w_item (a :: b :: c :: d :: e :: r) k m =
106 :			"5" :: w_item a (w_item b (w_item c (w_item d (w_item e
107 :	blume	307	(w_list w_item r k))))) m
108 :	blume	304
109 :	blume	306	fun w_option w_item NONE k m = "n" :: k m
110 :			| w_option w_item (SOME i) k m = "s" :: w_item i k m
111 :	blume	304
112 :	blume	306	fun int_encode i = let
113 :			(* this is the same mechanism that's also used in
114 :			* TopLevel/batch/binfile.sml (maybe we should share it) *)
115 :			val n = Word32.fromInt i
116 :			val // = LargeWord.div
117 :			val %% = LargeWord.mod
118 :			val !! = LargeWord.orb
119 :			infix // %% !!
120 :			val toW8 = Word8.fromLargeWord
121 :			fun r (0w0, l) = Word8Vector.fromList l
122 :			| r (n, l) =
123 :			r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
124 :			in
125 :			Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
126 :			end
127 :	blume	304
128 :	blume	306	fun w_int i k m = int_encode i :: k m
129 :	blume	304
130 :	blume	306	fun w_share w C v k (i, m) =
131 :			case Map.find (m, C v) of
132 :			SOME i' => "o" :: w_int i' k (i, m)
133 :			| NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
134 :	blume	304
135 :	blume	306	fun w_symbol_raw s k m = let
136 :			val ns = case Symbol.nameSpace s of
137 :			Symbol.SIGspace => "'"
138 :			| Symbol.FCTspace => "("
139 :			| Symbol.FSIGspace => ")"
140 :			| Symbol.STRspace => ""
141 :			| _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
142 :			in
143 :			ns :: Symbol.name s :: "." :: k m
144 :			end
145 :	blume	304
146 :	blume	307	val w_symbol = w_share w_symbol_raw PS
147 :	blume	304
148 :	blume	307	val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
149 :	blume	306
150 :			val w_filter = w_option w_ss
151 :
152 :			fun w_string s k m = let
153 :			fun esc #"\\" = "\\\\"
154 :			| esc #"\"" = "\\\""
155 :			| esc c = String.str c
156 :	blume	304
157 :	blume	306	in
158 :			String.translate esc s :: "\"" :: k m
159 :			end
160 :
161 :			fun w_sharing NONE k m = "n" :: k m
162 :			| w_sharing (SOME true) k m = "t" :: k m
163 :			| w_sharing (SOME false) k m = "f" :: k m
164 :
165 :	blume	307	fun w_si i k = let
166 :	blume	306	val spec = AbsPath.spec (SmlInfo.sourcepath i)
167 :			val locs = SmlInfo.errorLocation gp i
168 :	blume	307	val offset = registerOffset (i, binSizeOf i)
169 :	blume	306	in
170 :			w_string spec
171 :			(w_string locs
172 :			(w_int offset
173 :			(w_sharing (SmlInfo.share i) k)))
174 :			end
175 :
176 :			fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
177 :
178 :			fun w_abspath_raw p k m =
179 :			w_list w_string (AbsPath.pickle p) k m
180 :
181 :	blume	307	val w_abspath = w_share w_abspath_raw PAP
182 :	blume	306
183 :			fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
184 :			| w_bn (DG.BNODE { bininfo = i, ... }) k m =
185 :			"b" :: w_abspath (BinInfo.group i)
186 :			(w_int (BinInfo.offset i) k) m
187 :
188 :	blume	307	fun w_sn_raw (DG.SNODE n) k =
189 :	blume	306	w_si (#smlinfo n)
190 :			(w_list w_sn (#localimports n)
191 :			(w_list w_fsbn (#globalimports n) k))
192 :
193 :	blume	307	and w_sn n = w_share w_sn_raw PSN n
194 :
195 :	blume	306	and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
196 :			| w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
197 :
198 :			and w_fsbn (f, n) k = w_filter f (w_sbn n k)
199 :
200 :			fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)
201 :
202 :			fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)
203 :
204 :			fun w_bool true k m = "t" :: k m
205 :			| w_bool false k m = "f" :: k m
206 :
207 :			fun w_privileges p = w_list w_string (StringSet.listItems p)
208 :
209 :	blume	308	fun pickle_group () = let
210 :	blume	306	fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)
211 :			fun k0 m = []
212 :			val m0 = (0, Map.empty)
213 :			in
214 :			concat
215 :	blume	308	(w_exports exports
216 :			(w_bool islib
217 :			(w_privileges required
218 :			(w_list w_sg subgroups k0))) m0)
219 :	blume	306	end
220 :	blume	308
221 :			val pickle = pickle_group ()
222 :	blume	306	val sz = size pickle
223 :	blume	308	val offset_adjustment = sz + 4
224 :
225 :			fun mkStableGroup () = let
226 :			val m = ref SmlInfoMap.empty
227 :			fun sn (DG.SNODE (n as { smlinfo, ... })) =
228 :			case SmlInfoMap.find (!m, smlinfo) of
229 :			SOME n => n
230 :			| NONE => let
231 :			val li = map sn (#localimports n)
232 :			val gi = map fsbn (#globalimports n)
233 :			val sourcepath = SmlInfo.sourcepath smlinfo
234 :			val spec = AbsPath.spec sourcepath
235 :			val offset =
236 :			getOffset smlinfo + offset_adjustment
237 :			val share = SmlInfo.share smlinfo
238 :			val locs = SmlInfo.errorLocation gp smlinfo
239 :			val error = EM.errorNoSource grpSrcInfo locs
240 :			val i = BinInfo.new { group = grouppath,
241 :			spec = spec,
242 :			offset = offset,
243 :			share = share,
244 :			error = error }
245 :			val n = DG.BNODE { bininfo = i,
246 :			localimports = li,
247 :			globalimports = gi }
248 :			in
249 :			m := SmlInfoMap.insert (!m, smlinfo, n);
250 :			n
251 :			end
252 :
253 :			and sbn (DG.SB_SNODE n) = sn n
254 :			| sbn (DG.SB_BNODE n) = n
255 :
256 :			and fsbn (f, n) = (f, sbn n)
257 :
258 :			fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
259 :
260 :			val exports = SymbolMap.map impexp (#exports grec)
261 :			val simap = genStableInfoMap (exports, grouppath)
262 :			in
263 :			GG.GROUP { exports = exports,
264 :			islib = islib,
265 :			required = required,
266 :			grouppath = grouppath,
267 :			subgroups = subgroups,
268 :			stableinfo = GG.STABLE simap }
269 :			end
270 :
271 :			fun writeInt32 (s, i) = let
272 :			val a = Word8Array.array (4, 0w0)
273 :			val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
274 :			in
275 :			BinIO.output (s, Word8Array.extract (a, 0, NONE))
276 :			end
277 :	blume	306	in
278 :	blume	308	writeInt32 (outs, sz);
279 :			BinIO.output (outs, Byte.stringToBytes pickle);
280 :			app (copyBin outs) (rev (!members));
281 :			mkStableGroup ()
282 :	blume	306	end
283 :
284 :	blume	308	fun g (getGroup, bn2env, group, s) = let
285 :	blume	306
286 :	blume	308	(* we don't care about errors... (?) *)
287 :			val grpSrcInfo = (EM.defaultConsumer (), ref false)
288 :
289 :	blume	306	exception Format
290 :
291 :			(* for getting sharing right... *)
292 :			val m = ref IntBinaryMap.empty
293 :			val next = ref 0
294 :
295 :			fun bytesIn n = let
296 :			val bv = BinIO.inputN (s, n)
297 :	blume	304	in
298 :	blume	306	if n = Word8Vector.length bv then bv
299 :			else raise Format
300 :	blume	304	end
301 :
302 :	blume	306	val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
303 :			val pickle = bytesIn sz
304 :			val offset_adjustment = sz + 4
305 :	blume	304
306 :	blume	306	val rd = let
307 :			val pos = ref 0
308 :			fun rd () = let
309 :			val p = !pos
310 :			in
311 :			pos := p + 1;
312 :			Byte.byteToChar (Word8Vector.sub (pickle, p))
313 :			handle _ => raise Format
314 :			end
315 :	blume	304	in
316 :	blume	306	rd
317 :	blume	304	end
318 :
319 :	blume	306	fun r_list r () =
320 :			case rd () of
321 :			#"0" => []
322 :			| #"1" => [r ()]
323 :			| #"2" => [r (), r ()]
324 :			| #"3" => [r (), r (), r ()]
325 :			| #"4" => [r (), r (), r (), r ()]
326 :			| #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
327 :			| _ => raise Format
328 :	blume	304
329 :	blume	306	fun r_bool () =
330 :			case rd () of
331 :			#"t" => true
332 :			| #"f" => false
333 :			| _ => raise Format
334 :	blume	304
335 :	blume	306	fun r_option r_item () =
336 :			case rd () of
337 :			#"n" => NONE
338 :			| #"s" => SOME (r_item ())
339 :			| _ => raise Format
340 :	blume	304
341 :	blume	306	fun r_int () = let
342 :			fun loop n = let
343 :			val w8 = Byte.charToByte (rd ())
344 :			val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
345 :			in
346 :			if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
347 :			end
348 :			in
349 :			LargeWord.toIntX (loop 0w0)
350 :			end
351 :	blume	304
352 :	blume	306	fun r_share r_raw C unC () =
353 :			case rd () of
354 :			#"o" => (case IntBinaryMap.find (!m, r_int ()) of
355 :			SOME x => unC x
356 :			| NONE => raise Format)
357 :			| #"n" => let
358 :			val i = !next
359 :			val _ = next := i + 1
360 :			val v = r_raw ()
361 :			in
362 :			m := IntBinaryMap.insert (!m, i, C v);
363 :			v
364 :			end
365 :			| _ => raise Format
366 :	blume	304
367 :	blume	306	fun r_string () = let
368 :			fun loop l =
369 :			case rd () of
370 :			#"\"" => String.implode (rev l)
371 :			| #"\\" => loop (rd () :: l)
372 :			| c => loop (c :: l)
373 :			in
374 :			loop []
375 :			end
376 :	blume	304
377 :	blume	306	val r_abspath = let
378 :			fun r_abspath_raw () =
379 :			case AbsPath.unpickle (r_list r_string ()) of
380 :			SOME p => p
381 :			| NONE => raise Format
382 :	blume	307	fun unUAP (UAP x) = x
383 :			| unUAP _ = raise Format
384 :	blume	306	in
385 :	blume	307	r_share r_abspath_raw UAP unUAP
386 :	blume	306	end
387 :	blume	304
388 :	blume	306	val r_symbol = let
389 :			fun r_symbol_raw () = let
390 :			val (ns, first) =
391 :			case rd () of
392 :			#"`" => (Symbol.sigSymbol, rd ())
393 :			| #"(" => (Symbol.fctSymbol, rd ())
394 :			| #")" => (Symbol.fsigSymbol, rd ())
395 :			| c => (Symbol.strSymbol, c)
396 :			fun loop (#".", l) = String.implode (rev l)
397 :			| loop (c, l) = loop (rd (), c :: l)
398 :			in
399 :			ns (loop (first, []))
400 :			end
401 :	blume	307	fun unUS (US x) = x
402 :			| unUS _ = raise Format
403 :	blume	306	in
404 :	blume	307	r_share r_symbol_raw US unUS
405 :	blume	306	end
406 :	blume	304
407 :	blume	306	val r_ss = let
408 :			fun r_ss_raw () =
409 :			SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
410 :	blume	307	fun unUSS (USS s) = s
411 :			| unUSS _ = raise Format
412 :	blume	306	in
413 :	blume	307	r_share r_ss_raw USS unUSS
414 :	blume	306	end
415 :	blume	304
416 :	blume	306	val r_filter = r_option r_ss
417 :	blume	305
418 :	blume	306	fun r_primitive () =
419 :			case Primitive.fromIdent (rd ()) of
420 :			NONE => raise Format
421 :			| SOME p => p
422 :	blume	305
423 :	blume	306	fun r_sharing () =
424 :			case rd () of
425 :			#"n" => NONE
426 :			| #"t" => SOME true
427 :			| #"f" => SOME false
428 :			| _ => raise Format
429 :	blume	305
430 :	blume	307	fun r_si () = let
431 :			val spec = r_string ()
432 :			val locs = r_string ()
433 :			val offset = r_int () + offset_adjustment
434 :			val share = r_sharing ()
435 :			val error = EM.errorNoSource grpSrcInfo locs
436 :	blume	306	in
437 :	blume	307	BinInfo.new { group = group,
438 :			error = error,
439 :			spec = spec,
440 :			offset = offset,
441 :			share = share }
442 :	blume	306	end
443 :	blume	305
444 :	blume	306	fun r_bn () =
445 :			case rd () of
446 :			#"p" => DG.PNODE (r_primitive ())
447 :	blume	307	| #"b" => let
448 :			val p = r_abspath ()
449 :			val os = r_int ()
450 :			val GG.GROUP { stableinfo, ... } = getGroup p
451 :			in
452 :			case stableinfo of
453 :			GG.NONSTABLE _ => raise Format
454 :			| GG.STABLE im =>
455 :			(case IntBinaryMap.find (im, os) of
456 :			NONE => raise Format
457 :			| SOME n => n)
458 :			end
459 :	blume	306	| _ => raise Format
460 :
461 :			(* this is the place where what used to be an
462 :			* SNODE changes to a BNODE! *)
463 :	blume	307	fun r_sn_raw () =
464 :	blume	306	DG.BNODE { bininfo = r_si (),
465 :			localimports = r_list r_sn (),
466 :			globalimports = r_list r_fsbn () }
467 :
468 :	blume	307	and r_sn () =
469 :			r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
470 :
471 :	blume	306	(* this one changes from farsbnode to plain farbnode *)
472 :			and r_sbn () =
473 :			case rd () of
474 :			#"b" => r_bn ()
475 :			| #"s" => r_sn ()
476 :			| _ => raise Format
477 :
478 :			and r_fsbn () = (r_filter (), r_sbn ())
479 :
480 :			fun r_impexp () = let
481 :			val sy = r_symbol ()
482 :			val (f, n) = r_fsbn () (* really reads farbnodes! *)
483 :	blume	307	val e = bn2env n
484 :	blume	305	in
485 :	blume	306	(sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)
486 :	blume	305	end
487 :	blume	306
488 :			fun r_exports () =
489 :			foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
490 :
491 :			fun r_privileges () =
492 :			StringSet.addList (StringSet.empty, r_list r_string ())
493 :
494 :			fun unpickle_group () = let
495 :			val exports = r_exports ()
496 :			val islib = r_bool ()
497 :			val required = r_privileges ()
498 :			val subgroups = r_list (getGroup o r_abspath) ()
499 :	blume	308	val simap = genStableInfoMap (exports, group)
500 :	blume	306	in
501 :			GG.GROUP { exports = exports,
502 :			islib = islib,
503 :			required = required,
504 :	blume	308	grouppath = group,
505 :	blume	306	subgroups = subgroups,
506 :	blume	307	stableinfo = GG.STABLE simap }
507 :	blume	306	end
508 :	blume	304	in
509 :	blume	306	SOME (unpickle_group ()) handle Format => NONE
510 :	blume	304	end
511 :			end

---

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