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

Parent Directory | Revision Log | Patch

	revision 383, Tue Jul 20 06:05:56 1999 UTC	revision 384, Wed Jul 21 08:54:00 1999 UTC
#	Line 35	Line 35
35	val transfer_state : SmlInfo.info * BinInfo.info -> unit	val transfer_state : SmlInfo.info * BinInfo.info -> unit
36	val recomp : recomp) :> STABILIZE = struct	val recomp : recomp) :> STABILIZE = struct
37
38	datatype pitem =	structure PU = PickleUtil
39	PSS of SymbolSet.set	structure UU = UnpickleUtil
40	| PS of Symbol.symbol
41	| PSN of DG.snode	infix 3 $
42		infixr 4 &
43		val op & = PU.&
44		val % = PU.%
45
46	datatype uitem =	datatype uitem =
47	USS of SymbolSet.set	USS of SymbolSet.set
48	| US of Symbol.symbol	| US of Symbol.symbol
49	| UBN of DG.bnode	| UBN of DG.bnode
50
51	fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')	structure SNMap = BinaryMapFn
52	| compare (PS _, _) = GREATER	(struct
53	| compare (_, PS _) = LESS	type ord_key = DG.snode
54	| compare (PSS s, PSS s') = SymbolSet.compare (s, s')	fun compare (DG.SNODE n, DG.SNODE n') =
	| compare (PSS _, _) = GREATER
	| compare (_, PSS _) = LESS
	| compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
55	SmlInfo.compare (#smlinfo n, #smlinfo n')	SmlInfo.compare (#smlinfo n, #smlinfo n')
	structure Map =
	BinaryMapFn (struct
	type ord_key = pitem
	val compare = compare
56	end)	end)
57
58		val initMap = SNMap.empty
59		val SNs = { find = SNMap.find, insert = SNMap.insert }
60
61	fun genStableInfoMap (exports, group) = let	fun genStableInfoMap (exports, group) = let
62	(* find all the exported bnodes that are in the same group: *)	(* find all the exported bnodes that are in the same group: *)
63	fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let	fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
#	Line 156	Line 154
154	(reg, get)	(reg, get)
155	end	end
156
157	fun w_list w_item [] k m =	val int = PU.w_int
158	"0" :: k m	val symbol = PU.w_symbol
159	| w_list w_item [a] k m =	val share = PU.ah_share
160	"1" :: w_item a k m	val option = PU.w_option
161	| w_list w_item [a, b] k m =	val list = PU.w_list
162	"2" :: w_item a (w_item b k) m	val string = PU.w_string
163	| w_list w_item [a, b, c] k m =	val bool = PU.w_bool
164	"3" :: w_item a (w_item b (w_item c k)) m	val int = PU.w_int
165	| w_list w_item [a, b, c, d] k m =
166	"4" :: w_item a (w_item b (w_item c (w_item d k))) m	val symbolset = list symbol o SymbolSet.listItems
167	| w_list w_item (a :: b :: c :: d :: e :: r) k m =
168	"5" :: w_item a (w_item b (w_item c (w_item d (w_item e	val filter = option symbolset
169	(w_list w_item r k))))) m
170		val sh = option bool        (* sharing *)
	fun w_option w_item NONE k m = "n" :: k m
	| w_option w_item (SOME i) k m = "s" :: w_item i k m
	fun int_encode i = let
	(* this is the same mechanism that's also used in
	* TopLevel/batch/binfile.sml (maybe we should share it) *)
	val n = Word32.fromInt i
	val // = LargeWord.div
	val %% = LargeWord.mod
	val !! = LargeWord.orb
	infix // %% !!
	val toW8 = Word8.fromLargeWord
	fun r (0w0, l) = Word8Vector.fromList l
	| r (n, l) =
	r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
	in
	Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
	end
	fun w_int i k m = int_encode i :: k m
	fun w_share w C v k (i, m) =
	case Map.find (m, C v) of
	SOME i' => "o" :: w_int i' k (i, m)
	| NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
	fun w_symbol_raw s k m = let
	val ns = case Symbol.nameSpace s of
	Symbol.SIGspace => "'"
	| Symbol.FCTspace => "("
	| Symbol.FSIGspace => ")"
	| Symbol.STRspace => ""
	| _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
	in
	ns :: Symbol.name s :: "." :: k m
	end
	val w_symbol = w_share w_symbol_raw PS
	val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
	val w_filter = w_option w_ss
	fun w_string s k m = let
	fun esc #"\\" = "\\\\"
	| esc #"\"" = "\\\""
	| esc c = String.str c
	in
	String.translate esc s :: "\"" :: k m
	end
	fun w_sharing NONE k m = "n" :: k m
	| w_sharing (SOME true) k m = "t" :: k m
	| w_sharing (SOME false) k m = "f" :: k m
171
172	fun w_si i k = let	fun si i = let
173	(* FIXME: this is not a technical flaw, but perhaps one	(* FIXME: this is not a technical flaw, but perhaps one
174	* that deserves fixing anyway:  If we only look at spec,	* that deserves fixing anyway:  If we only look at spec,
175	* then we are losing information about sub-grouping	* then we are losing information about sub-grouping
#	Line 236	Line 180
180	val locs = SmlInfo.errorLocation gp i	val locs = SmlInfo.errorLocation gp i
181	val offset = registerOffset (i, bsz i)	val offset = registerOffset (i, bsz i)
182	in	in
183	w_string spec	string spec & string locs & int offset & sh (SmlInfo.share i)
	(w_string locs
	(w_int offset
	(w_sharing (SmlInfo.share i) k)))
184	end	end
185
186	fun w_primitive p k m =	fun primitive p =
187	String.str (Primitive.toIdent primconf p) :: k m	string (String.str (Primitive.toIdent primconf p))
188
189	fun warn_relabs p abs = let	fun warn_relabs p abs = let
190	val relabs = if abs then "absolute" else "relative"	val relabs = if abs then "absolute" else "relative"
#	Line 267	Line 208
208	ppb	ppb
209	end	end
210
211	fun w_abspath p k m =	fun abspath p = let
212	w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))	val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
213	k m	in
214		list string pp
215		end
216
217	fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m	val BN = 1
218	| w_bn (DG.BNODE { bininfo = i, ... }) k m = let	val op $ = PU.$ BN
219		fun bn (DG.PNODE p) = "1" $ primitive p
220		| bn (DG.BNODE { bininfo = i, ... }) = let
221	val (n, sy) = valOf (StableMap.find (inverseMap, i))	val (n, sy) = valOf (StableMap.find (inverseMap, i))
222	in	in
223	"b" :: w_int n (w_symbol sy k) m	"2" $ int n & symbol sy
224	end	end
225
226	fun w_bool true k m = "t" :: k m	local
227	| w_bool false k m = "f" :: k m	val SN = 2
228		val SBN = 3
229	fun w_sn_raw (DG.SNODE n) k =	in
230	w_si (#smlinfo n)	fun sn n = let
231	(w_list w_sn (#localimports n)	fun raw_sn (DG.SNODE n) =
232	(w_list w_fsbn (#globalimports n) k))	"a" $ si (#smlinfo n) & list sn (#localimports n) &
233		list fsbn (#globalimports n)
234	and w_sn n = w_share w_sn_raw PSN n	in
235		share SNs raw_sn n
236		end
237
238	and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m	and sbn x = let
239	| w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m	val op $ = PU.$ SBN
240		in
241		case x of
242		DG.SB_BNODE n => "a" $ bn n
243		| DG.SB_SNODE n => "b" $ sn n
244		end
245
246	and w_fsbn (f, n) k = w_filter f (w_sbn n k)	and fsbn (f, n) = filter f & sbn n
247		end
248
249	fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)	fun impexp (s, (n, _)) = symbol s & fsbn n
250
251	fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)	fun w_exports e = list impexp (SymbolMap.listItemsi e)
252
253	fun w_privileges p = w_list w_string (StringSet.listItems p)	fun privileges p = list string (StringSet.listItems p)
254
255	fun pickle_group () = let	fun group () = let
256	fun w_sg (GG.GROUP { grouppath, ... }) = w_abspath grouppath	fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
	fun k0 m = []
	val m0 = (0, Map.empty)
257	in	in
258	(* Pickle the sublibs first because we need to already	(* Pickle the sublibs first because we need to already
259	* have them back when we unpickle BNODEs. *)	* have them back when we unpickle BNODEs. *)
260	concat (w_list w_sg sublibs	list sg sublibs & w_exports exports & privileges required
	(w_exports exports
	(w_privileges required k0)) m0)
261	end	end
262
263	val pickle = pickle_group ()	val pickle = PU.pickle initMap (group ())
264	val sz = size pickle	val sz = size pickle
265	val offset_adjustment = sz + 4	val offset_adjustment = sz + 4
266
#	Line 444	Line 393
393	EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))	EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
394	EM.nullErrorBody	EM.nullErrorBody
395
396	exception Format	exception Format = UU.Format
397
398	val pcmode = #pcmode (#param gp)	val pcmode = #pcmode (#param gp)
399	val policy = #fnpolicy (#param gp)	val policy = #fnpolicy (#param gp)
#	Line 473	Line 422
422	end	end
423
424	val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))	val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
425	val pickle = bytesIn sz	val pickle = Byte.bytesToString (bytesIn sz)
426	val offset_adjustment = sz + 4	val offset_adjustment = sz + 4
427
428	val rd = let	val session = UU.mkSession (UU.stringReader pickle)
	val pos = ref 0
	fun rd () = let
	val p = !pos
	in
	pos := p + 1;
	Byte.byteToChar (Word8Vector.sub (pickle, p))
	handle _ => raise Format
	end
	in
	rd
	end
	fun r_list r () =
	case rd () of
	#"0" => []
	| #"1" => [r ()]
	| #"2" => [r (), r ()]
	| #"3" => [r (), r (), r ()]
	| #"4" => [r (), r (), r (), r ()]
	| #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
	| _ => raise Format
	fun r_bool () =
	case rd () of
	#"t" => true
	| #"f" => false
	| _ => raise Format
	fun r_option r_item () =
	case rd () of
	#"n" => NONE
	| #"s" => SOME (r_item ())
	| _ => raise Format
429
430	fun r_int () = let	fun list m r = UU.r_list session m r
431	fun loop n = let	fun option m r = UU.r_option session m r
432	val w8 = Byte.charToByte (rd ())	val int = UU.r_int session
433	val n' =	fun share m r = UU.share session m r
434	n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))	val string = UU.r_string session
435	in	val symbol = UU.r_symbol session
436	if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'	val bool = UU.r_bool session
437	end
438	in	val stringListM = UU.mkMap ()
439	LargeWord.toIntX (loop 0w0)	val symbolListM = UU.mkMap ()
440	end	val stringListM = UU.mkMap ()
441		val ssoM = UU.mkMap ()
442	fun r_share r_raw C unC () =	val boolOptionM = UU.mkMap ()
443	case rd () of	val sgListM = UU.mkMap ()
444	#"o" => (case IntBinaryMap.find (!m, r_int ()) of	val snM = UU.mkMap ()
445	SOME x => unC x	val snListM = UU.mkMap ()
446	| NONE => raise Format)	val bnM = UU.mkMap ()
447	| #"n" => let	val sbnM = UU.mkMap ()
448	val i = !next	val fsbnListM = UU.mkMap ()
449	val _ = next := i + 1	val impexpListM = UU.mkMap ()
	val v = r_raw ()
	in
	m := IntBinaryMap.insert (!m, i, C v);
	v
	end
	| _ => raise Format
450
451	fun r_string () = let	val stringlist = list stringListM string
	fun loop l =
	case rd () of
	#"\"" => String.implode (rev l)
	| #"\\" => loop (rd () :: l)
	| c => loop (c :: l)
	in
	loop []
	end
452
453	fun r_abspath () =	fun abspath () =
454	SrcPath.unpickle pcmode (r_list r_string (), group)	SrcPath.unpickle pcmode (stringlist (), group)
455	handle SrcPath.Format => raise Format	handle SrcPath.Format => raise Format
456	| SrcPath.BadAnchor a =>	| SrcPath.BadAnchor a =>
457	(error ["configuration anchor \"", a, "\" undefined"];	(error ["configuration anchor \"", a, "\" undefined"];
458	raise Format)	raise Format)
459
460		val symbollist = list symbolListM symbol
461
462	val r_symbol = let	fun symbolset () =
463	fun r_symbol_raw () = let	SymbolSet.addList (SymbolSet.empty, symbollist ())
464	val (ns, first) =
465	case rd () of	val filter = option ssoM symbolset
466	#"'" => (Symbol.sigSymbol, rd ())
467	| #"(" => (Symbol.fctSymbol, rd ())	fun primitive () =
468	| #")" => (Symbol.fsigSymbol, rd ())	valOf (Primitive.fromIdent primconf
469	| c => (Symbol.strSymbol, c)	(String.sub (string (), 0)))
470	fun loop (#".", l) = String.implode (rev l)	handle _ => raise Format
	| loop (c, l) = loop (rd (), c :: l)
	in
	ns (loop (first, []))
	end
	fun unUS (US x) = x
	| unUS _ = raise Format
	in
	r_share r_symbol_raw US unUS
	end
	val r_ss = let
	fun r_ss_raw () =
	SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
	fun unUSS (USS s) = s
	| unUSS _ = raise Format
	in
	r_share r_ss_raw USS unUSS
	end
	val r_filter = r_option r_ss
	fun r_primitive () =
	case Primitive.fromIdent primconf (rd ()) of
	NONE => raise Format
	| SOME p => p
	fun r_sharing () =
	case rd () of
	#"n" => NONE
	| #"t" => SOME true
	| #"f" => SOME false
	| _ => raise Format
471
472	fun r_si () = let	val sh = option boolOptionM bool
473	val spec = r_string ()
474	val locs = r_string ()	fun si () = let
475	val offset = r_int () + offset_adjustment	val spec = string ()
476	val share = r_sharing ()	val locs = string ()
477		val offset = int () + offset_adjustment
478		val share = sh ()
479	val error = EM.errorNoSource grpSrcInfo locs	val error = EM.errorNoSource grpSrcInfo locs
480	in	in
481	BinInfo.new { group = group,	BinInfo.new { group = group,
#	Line 613	Line 486
486	share = share }	share = share }
487	end	end
488
489	fun r_sg () = getGroup' (r_abspath ())	fun sg () = getGroup' (abspath ())
490
491	val sublibs = r_list r_sg ()	val sublibs = list sgListM sg ()
492
493	fun r_bn () =	fun bn () = let
494	case rd () of	fun bn' #"1" = DG.PNODE (primitive ())
495	#"p" => DG.PNODE (r_primitive ())	| bn' #"2" = let
496	| #"b" => let	val n = int ()
497	val n = r_int ()	val sy = symbol ()
	val sy = r_symbol ()
498	val GG.GROUP { exports = slexp, ... } =	val GG.GROUP { exports = slexp, ... } =
499	List.nth (sublibs, n) handle _ => raise Format	List.nth (sublibs, n) handle _ => raise Format
500	in	in
#	Line 630	Line 502
502	SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n	SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
503	| _ => raise Format	| _ => raise Format
504	end	end
505	| _ => raise Format	| bn' _ = raise Format
506		in
507		share bnM bn'
508		end
509
510	(* this is the place where what used to be an	(* this is the place where what used to be an
511	* SNODE changes to a BNODE! *)	* SNODE changes to a BNODE! *)
512	fun r_sn_raw () =	fun sn () = let
513	DG.BNODE { bininfo = r_si (),	fun sn' #"a" =
514	localimports = r_list r_sn (),	DG.BNODE { bininfo = si (),
515	globalimports = r_list r_fsbn () }	localimports = snlist (),
516		globalimports = fsbnlist () }
517		| sn' _ = raise Format
518		in
519		share snM sn'
520		end
521
522	and r_sn () =	and snlist () = list snListM sn ()
	r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
523
524	(* this one changes from farsbnode to plain farbnode *)	(* this one changes from farsbnode to plain farbnode *)
525	and r_sbn () =	and sbn () = let
526	case rd () of	fun sbn' #"a" = bn ()
527	#"b" => r_bn ()	| sbn' #"b" = sn ()
528	| #"s" => r_sn ()	| sbn' _ = raise Format
529	| _ => raise Format	in
530		share sbnM sbn'
531		end
532
533	and r_fsbn () = (r_filter (), r_sbn ())	and fsbn () = (filter (), sbn ())
534
535	fun r_impexp () = let	and fsbnlist () = list fsbnListM fsbn ()
536	val sy = r_symbol ()
537	val (f, n) = r_fsbn ()  (* really reads farbnodes! *)	fun impexp () = let
538		val sy = symbol ()
539		val (f, n) = fsbn ()    (* really reads farbnodes! *)
540	val e = bn2env n	val e = bn2env n
541	(* put a filter in front to avoid having the FCTENV being	(* put a filter in front to avoid having the FCTENV being
542	* queried needlessly (this avoids spurious module loadings) *)	* queried needlessly (this avoids spurious module loadings) *)
#	Line 662	Line 545
545	(sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)	(sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
546	end	end
547
548		val impexplist = list impexpListM impexp
549
550	fun r_exports () =	fun r_exports () =
551	foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())	foldl SymbolMap.insert' SymbolMap.empty (impexplist ())
552
553		val stringlist = list stringListM string
554
555	fun r_privileges () =	fun privileges () =
556	StringSet.addList (StringSet.empty, r_list r_string ())	StringSet.addList (StringSet.empty, stringlist ())
557
558	val exports = r_exports ()	val exports = r_exports ()
559	val required = r_privileges ()	val required = privileges ()
560	val simap = genStableInfoMap (exports, group)	val simap = genStableInfoMap (exports, group)
561	in	in
562	GG.GROUP { exports = exports,	GG.GROUP { exports = exports,

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.383   changed lines   Added in v.384

---

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