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

Parent Directory | Revision Log | Patch

	revision 306, Tue Jun 1 08:25:21 1999 UTC	revision 307, Tue Jun 1 09:38:28 1999 UTC
#	Line 4	Line 4
4	structure GG = GroupGraph	structure GG = GroupGraph
5	structure EM = GenericVC.ErrorMsg	structure EM = GenericVC.ErrorMsg
6
7	datatype item =	datatype pitem =
8	SS of SymbolSet.set	PSS of SymbolSet.set
9	| S of Symbol.symbol	| PS of Symbol.symbol
10	| SI of SmlInfo.info              (* only used during pickling *)	| PSN of DG.snode
11	| AP of AbsPath.t	| PAP of AbsPath.t
12	| BI of BinInfo.info              (* only used during unpickling *)
13		datatype uitem =
14	fun compare (S s, S s') = SymbolOrdKey.compare (s, s')	USS of SymbolSet.set
15	| compare (S _, _) = GREATER	| US of Symbol.symbol
16	| compare (_, S _) = LESS	| UBN of DG.bnode
17	| compare (SS s, SS s') = SymbolSet.compare (s, s')	| UAP of AbsPath.t
18	| compare (SS _, _) = GREATER
19	| compare (_, SS _) = LESS	fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
20	| compare (SI i, SI i') = SmlInfo.compare (i, i')	| compare (PS _, _) = GREATER
21	| compare (SI _, _) = GREATER	| compare (_, PS _) = LESS
22	| compare (_, SI _) = LESS	| compare (PSS s, PSS s') = SymbolSet.compare (s, s')
23	| compare (AP p, AP p') = AbsPath.compare (p, p')	| compare (PSS _, _) = GREATER
24	| compare (AP _, _) = GREATER	| compare (_, PSS _) = LESS
25	| compare (_, AP _) = LESS	| compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
26	| compare (BI i, BI i') = BinInfo.compare (i, i')	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	structure Map =	structure Map =
32	BinaryMapFn (struct	BinaryMapFn (struct
33	type ord_key = item	type ord_key = pitem
34	val compare = compare	val compare = compare
35	end)	end)
36
#	Line 49	Line 52
52	*    need no further adjustment.	*    need no further adjustment.
53	*  - Individual binfile contents (concatenated).	*  - Individual binfile contents (concatenated).
54	*)	*)
	val members = let
	fun sn (DG.SNODE { smlinfo, localimports = l, ... }, s) =
	if SmlInfoSet.member (s, smlinfo) then s
	else foldl sn (SmlInfoSet.add (s, smlinfo)) l
	fun impexp (((_, DG.SB_BNODE _), _), s) = s
	| impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)
	in
	SmlInfoSet.listItems
	(SymbolMap.foldl impexp SmlInfoSet.empty exports)
	end
	val offsetDict = let
	fun add (i, (d, n)) =
	(SmlInfoMap.insert (d, i, n), n + binSizeOf i)
	in
	#1 (foldl add (SmlInfoMap.empty, 0) members)
	end
55
56	fun w_list w_item [] k m = "0" :: k m	val offsetDict = ref SmlInfoMap.empty
57	| w_list w_item [a] k m = "1" :: w_item a k m	val members = ref []
58	| w_list w_item [a, b] k m = "2" :: w_item a (w_item b k) m	val registerOffset = let
59		val cur = ref 0
60		fun reg (i, sz) = let
61		val os = !cur
62		in
63		cur := os + sz;
64		offsetDict := SmlInfoMap.insert (!offsetDict, i, os);
65		members := i :: (!members);
66		os
67		end
68		in
69		reg
70		end
71
72		fun w_list w_item [] k m =
73		"0" :: k m
74		| w_list w_item [a] k m =
75		"1" :: w_item a k m
76		| w_list w_item [a, b] k m =
77		"2" :: w_item a (w_item b k) m
78	| w_list w_item [a, b, c] k m =	| w_list w_item [a, b, c] k m =
79	"3" :: w_item a (w_item b (w_item c k)) m	"3" :: w_item a (w_item b (w_item c k)) m
80	| w_list w_item [a, b, c, d] k m =	| w_list w_item [a, b, c, d] k m =
#	Line 115	Line 120
120	ns :: Symbol.name s :: "." :: k m	ns :: Symbol.name s :: "." :: k m
121	end	end
122
123	val w_symbol = w_share w_symbol_raw S	val w_symbol = w_share w_symbol_raw PS
124
125	val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) SS	val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
126
127	val w_filter = w_option w_ss	val w_filter = w_option w_ss
128
#	Line 134	Line 139
139	| w_sharing (SOME true) k m = "t" :: k m	| w_sharing (SOME true) k m = "t" :: k m
140	| w_sharing (SOME false) k m = "f" :: k m	| w_sharing (SOME false) k m = "f" :: k m
141
142	fun w_si_raw i k = let	fun w_si i k = let
143	val spec = AbsPath.spec (SmlInfo.sourcepath i)	val spec = AbsPath.spec (SmlInfo.sourcepath i)
144	val locs = SmlInfo.errorLocation gp i	val locs = SmlInfo.errorLocation gp i
145	val offset = valOf (SmlInfoMap.find (offsetDict, i))	val offset = registerOffset (i, binSizeOf i)
146	in	in
147	w_string spec	w_string spec
148	(w_string locs	(w_string locs
#	Line 145	Line 150
150	(w_sharing (SmlInfo.share i) k)))	(w_sharing (SmlInfo.share i) k)))
151	end	end
152
	val w_si = w_share w_si_raw SI
153	fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m	fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
154
155	fun w_abspath_raw p k m =	fun w_abspath_raw p k m =
156	w_list w_string (AbsPath.pickle p) k m	w_list w_string (AbsPath.pickle p) k m
157
158	val w_abspath = w_share w_abspath_raw AP	val w_abspath = w_share w_abspath_raw PAP
159
160	fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m	fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
161	| w_bn (DG.BNODE { bininfo = i, ... }) k m =	| w_bn (DG.BNODE { bininfo = i, ... }) k m =
162	"b" :: w_abspath (BinInfo.group i)	"b" :: w_abspath (BinInfo.group i)
163	(w_int (BinInfo.offset i) k) m	(w_int (BinInfo.offset i) k) m
164
165	fun w_sn (DG.SNODE n) k =	fun w_sn_raw (DG.SNODE n) k =
166	w_si (#smlinfo n)	w_si (#smlinfo n)
167	(w_list w_sn (#localimports n)	(w_list w_sn (#localimports n)
168	(w_list w_fsbn (#globalimports n) k))	(w_list w_fsbn (#globalimports n) k))
169
170		and w_sn n = w_share w_sn_raw PSN n
171
172	and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m	and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
173	| w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m	| w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
174
#	Line 197	Line 202
202	Dummy.f ()	Dummy.f ()
203	end	end
204
205	fun g (getGroup, fsbn2env, knownStable, grpSrcInfo, group, s) = let	fun g (getGroup, bn2env, grpSrcInfo, group, s) = let
206
207	exception Format	exception Format
208
#	Line 205	Line 210
210	val m = ref IntBinaryMap.empty	val m = ref IntBinaryMap.empty
211	val next = ref 0	val next = ref 0
212
	(* to build the stable info *)
	val simap = ref IntBinaryMap.empty
213	fun bytesIn n = let	fun bytesIn n = let
214	val bv = BinIO.inputN (s, n)	val bv = BinIO.inputN (s, n)
215	in	in
#	Line 295	Line 297
297	case AbsPath.unpickle (r_list r_string ()) of	case AbsPath.unpickle (r_list r_string ()) of
298	SOME p => p	SOME p => p
299	| NONE => raise Format	| NONE => raise Format
300	fun unAP (AP x) = x	fun unUAP (UAP x) = x
301	| unAP _ = raise Format	| unUAP _ = raise Format
302	in	in
303	r_share r_abspath_raw AP unAP	r_share r_abspath_raw UAP unUAP
304	end	end
305
306	val r_symbol = let	val r_symbol = let
#	Line 314	Line 316
316	in	in
317	ns (loop (first, []))	ns (loop (first, []))
318	end	end
319	fun unS (S x) = x	fun unUS (US x) = x
320	| unS _ = raise Format	| unUS _ = raise Format
321	in	in
322	r_share r_symbol_raw S unS	r_share r_symbol_raw US unUS
323	end	end
324
325	val r_ss = let	val r_ss = let
326	fun r_ss_raw () =	fun r_ss_raw () =
327	SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())	SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
328	fun unSS (SS s) = s	fun unUSS (USS s) = s
329	| unSS _ = raise Format	| unUSS _ = raise Format
330	in	in
331	r_share r_ss_raw SS unSS	r_share r_ss_raw USS unUSS
332	end	end
333
334	val r_filter = r_option r_ss	val r_filter = r_option r_ss
#	Line 343	Line 345
345	| #"f" => SOME false	| #"f" => SOME false
346	| _ => raise Format	| _ => raise Format
347
348	val r_si = let	fun r_si () = let
	fun r_si_raw () = let
349	val spec = r_string ()	val spec = r_string ()
350	val locs = r_string ()	val locs = r_string ()
351	val offset = r_int () + offset_adjustment	val offset = r_int () + offset_adjustment
352	val share = r_sharing ()	val share = r_sharing ()
353	val error = EM.errorNoSource grpSrcInfo locs	val error = EM.errorNoSource grpSrcInfo locs
354	val i = BinInfo.new { group = group,	in
355		BinInfo.new { group = group,
356	error = error,	error = error,
357	spec = spec,	spec = spec,
358	offset = offset,	offset = offset,
359	share = share }	share = share }
	in
	simap := IntBinaryMap.insert (!simap, offset, i);
	i
	end
	fun unBI (BI i) = i
	| unBI _ = raise Format
	in
	r_share r_si_raw BI unBI
360	end	end
361
362	fun r_bn () =	fun r_bn () =
363	case rd () of	case rd () of
364	#"p" => DG.PNODE (r_primitive ())	#"p" => DG.PNODE (r_primitive ())
365	| #"b" =>	| #"b" => let
366	(case AbsPathMap.find (knownStable, r_abspath ()) of	val p = r_abspath ()
367		val os = r_int ()
368		val GG.GROUP { stableinfo, ... } = getGroup p
369		in
370		case stableinfo of
371		GG.NONSTABLE _ => raise Format
372		| GG.STABLE im =>
373		(case IntBinaryMap.find (im, os) of
374	NONE => raise Format	NONE => raise Format
375	| SOME im =>	| SOME n => n)
376	(case IntBinaryMap.find (im, r_int ()) of	end
	NONE => raise Format
	| SOME n => n))
377	| _ => raise Format	| _ => raise Format
378
379	(* this is the place where what used to be an	(* this is the place where what used to be an
380	* SNODE changes to a BNODE! *)	* SNODE changes to a BNODE! *)
381	fun r_sn () =	fun r_sn_raw () =
382	DG.BNODE { bininfo = r_si (),	DG.BNODE { bininfo = r_si (),
383	localimports = r_list r_sn (),	localimports = r_list r_sn (),
384	globalimports = r_list r_fsbn () }	globalimports = r_list r_fsbn () }
385
386		and r_sn () =
387		r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
388
389	(* this one changes from farsbnode to plain farbnode *)	(* this one changes from farsbnode to plain farbnode *)
390	and r_sbn () =	and r_sbn () =
391	case rd () of	case rd () of
#	Line 396	Line 398
398	fun r_impexp () = let	fun r_impexp () = let
399	val sy = r_symbol ()	val sy = r_symbol ()
400	val (f, n) = r_fsbn ()      (* really reads farbnodes! *)	val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
401	val e = fsbn2env n	val e = bn2env n
402	in	in
403	(sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)	(sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)
404	end	end
#	Line 413	Line 415
415	val required = r_privileges ()	val required = r_privileges ()
416	val grouppath = r_abspath ()	val grouppath = r_abspath ()
417	val subgroups = r_list (getGroup o r_abspath) ()	val subgroups = r_list (getGroup o r_abspath) ()
418	fun add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), s) =	(* find all the exported bnodes that are in the same group: *)
419	IntBinarySet.add (s, BinInfo.offset bininfo)	fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
420	| add (_, s) = s	val i = #bininfo b
421	val ens = SymbolMap.foldl add IntBinarySet.empty exports	in
422	fun isExported (os, _) = IntBinarySet.member (ens, os)	if AbsPath.compare (BinInfo.group i, group) = EQUAL then
423	val final_simap = IntBinaryMap.filteri isExported (!simap)	IntBinaryMap.insert (m, BinInfo.offset i, n)
424		else m
425		end
426		| add (_, m) = m
427		val simap = SymbolMap.foldl add IntBinaryMap.empty exports
428	in	in
429	GG.GROUP { exports = exports,	GG.GROUP { exports = exports,
430	islib = islib,	islib = islib,
431	required = required,	required = required,
432	grouppath = grouppath,	grouppath = grouppath,
433	subgroups = subgroups,	subgroups = subgroups,
434	stableinfo = GG.STABLE final_simap }	stableinfo = GG.STABLE simap }
435	end	end
436	in	in
437	SOME (unpickle_group ()) handle Format => NONE	SOME (unpickle_group ()) handle Format => NONE

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.306   changed lines   Added in v.307

---

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