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

Parent Directory | Revision Log | Patch

	revision 512, Mon Dec 13 05:43:09 1999 UTC	revision 513, Thu Dec 16 03:14:18 1999 UTC
#	Line 64	Line 64
64	patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }	patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
65
66	infix 3 $	infix 3 $
	infixr 4 &
	val op & = PU.&
	val % = PU.%
67
68	(* type info *)	(* type info *)
69	val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)	val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM, G, AP,
70		PRIM, EXPORTS, PRIV) =
71		(1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010,
72		1011, 1012, 1013)
73
74	val SSs =	val SSs =
75	{ find = fn (m: map, k) => SSMap.find (#ss m, k),	{ find = fn (m: map, k) => SSMap.find (#ss m, k),
#	Line 275	Line 275
275
276	fun symbolset ss = let	fun symbolset ss = let
277	val op $ = PU.$ SS	val op $ = PU.$ SS
278	fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)	fun raw_ss ss = "s" $ [list symbol (SymbolSet.listItems ss)]
279	in	in
280	share SSs raw_ss ss	share SSs raw_ss ss
281	end	end
282
283	val filter = option symbolset	val filter = option symbolset
284
285	fun shm (Sharing.SHARE true) = %SHM "a"	val op $ = PU.$ SHM
286	| shm (Sharing.SHARE false) = %SHM "b"	fun shm (Sharing.SHARE true) = "a" $ []
287	| shm Sharing.DONTSHARE = %SHM "c"	| shm (Sharing.SHARE false) = "b" $ []
288		| shm Sharing.DONTSHARE = "c" $ []
289
290	fun si i = let	fun si i = let
291	(* FIXME: this is not a technical flaw, but perhaps one	(* FIXME: this is not a technical flaw, but perhaps one
#	Line 299	Line 300
300	val sh_mode = SmlInfo.sh_mode i	val sh_mode = SmlInfo.sh_mode i
301	val op $ = PU.$ SI	val op $ = PU.$ SI
302	in	in
303	"s" $ string spec & string locs & int offset & shm sh_mode	"s" $ [string spec, string locs, int offset, shm sh_mode]
304	end	end
305
306	fun primitive p =	fun primitive p = let
307	string (String.str (Primitive.toIdent primconf p))	val op $ = PU.$ PRIM
308		in
309		"p" $ [string (String.str (Primitive.toIdent primconf p))]
310		end
311
312	fun warn_relabs p abs = let	fun warn_relabs p abs = let
313	val relabs = if abs then "absolute" else "relative"	val relabs = if abs then "absolute" else "relative"
#	Line 328	Line 332
332	end	end
333
334	fun abspath p = let	fun abspath p = let
335		val op $ = PU.$ AP
336	val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)	val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
337	in	in
338	list string pp	"p" $ [list string pp]
339	end	end
340
341	fun sn n = let	fun sn n = let
342	val op $ = PU.$ SN	val op $ = PU.$ SN
343	fun raw_sn (DG.SNODE n) =	fun raw_sn (DG.SNODE n) =
344	"a" $ si (#smlinfo n) & list sn (#localimports n) &	"a" $ [si (#smlinfo n), list sn (#localimports n),
345	list fsbn (#globalimports n)	list fsbn (#globalimports n)]
346	in	in
347	share SNs raw_sn n	share SNs raw_sn n
348	end	end
#	Line 349	Line 354
354	in	in
355	case x of	case x of
356	DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>	DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
357	"1" $ primitive p	"1" $ [primitive p]
358	| DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let	| DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
359	val (n, sy) = valOf (StableMap.find (inverseMap, i))	val (n, sy) = valOf (StableMap.find (inverseMap, i))
360	in	in
361	"2" $ int n & symbol sy	"2" $ [int n, symbol sy]
362	end	end
363	| DG.SB_SNODE n => "3" $ sn n	| DG.SB_SNODE n => "3" $ [sn n]
364	end	end
365
366	and fsbn (f, n) = let	and fsbn (f, n) = let
367	val op $ = PU.$ FSBN	val op $ = PU.$ FSBN
368	in	in
369	"f" $ filter f & sbn n	"f" $ [filter f, sbn n]
370	end	end
371
372	(* Here is the place where we need to write interface info. *)	(* Here is the place where we need to write interface info. *)
#	Line 375	Line 380
380	fun es2bs { env, ctxt } =	fun es2bs { env, ctxt } =
381	{ env = GenericVC.CoerceEnv.es2bs env, ctxt = ctxt }	{ env = GenericVC.CoerceEnv.es2bs env, ctxt = ctxt }
382	in	in
383	"i" $ symbol s & fsbn n &	"i" $ [symbol s, fsbn n,
384	lazy_env (es2bs o statenv) &	lazy_env (es2bs o statenv),
385	lazy_symenv symenv &	lazy_symenv symenv,
386	pid statpid &	pid statpid,
387	pid sympid	pid sympid]
388	end	end
389
390	fun w_exports e = list impexp (SymbolMap.listItemsi e)	fun w_exports e = let
391		val op $ = PU.$ EXPORTS
392		in
393		"e" $ [list impexp (SymbolMap.listItemsi e)]
394		end
395
396	fun privileges p = list string (StringSet.listItems p)	fun privileges p = let
397		val op $ = PU.$ PRIV
398		in
399		"p" $ [list string (StringSet.listItems p)]
400		end
401
402	fun group () = let	fun group () = let
403		val op $ = PU.$ G
404	fun sg (p, g) = abspath p	fun sg (p, g) = abspath p
405	in	in
406	(* Pickle the sublibs first because we need to already	(* Pickle the sublibs first because we need to already
407	* have them back when we unpickle BNODEs. *)	* have them back when we unpickle BNODEs. *)
408	list sg sublibs & w_exports exports & privileges required	"g" $ [list sg sublibs, w_exports exports, privileges required]
409	end	end
410
411	val dg_pickle =	val dg_pickle =
#	Line 555	Line 569
569	UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)	UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
570	val session = UU.mkSession getter	val session = UU.mkSession getter
571
572		val sgListM = UU.mkMap ()
573		val stringListM = UU.mkMap ()
574		val stringListM = UU.mkMap ()
575		val ssM = UU.mkMap ()
576		val ssoM = UU.mkMap ()
577		val boolOptionM = UU.mkMap ()
578		val siM = UU.mkMap ()
579		val snM = UU.mkMap ()
580		val snListM = UU.mkMap ()
581		val sbnM = UU.mkMap ()
582		val fsbnM = UU.mkMap ()
583		val fsbnListM = UU.mkMap ()
584		val impexpM = UU.mkMap ()
585		val impexpListM = UU.mkMap ()
586		val groupM = UU.mkMap ()
587		val apM = UU.mkMap ()
588		val primitiveM = UU.mkMap ()
589		val exportsM = UU.mkMap ()
590		val privilegesM = UU.mkMap ()
591
592	fun list m r = UU.r_list session m r	fun list m r = UU.r_list session m r
593	val string = UU.r_string session	val string = UU.r_string session
	val stringListM = UU.mkMap ()
594	val stringlist = list stringListM string	val stringlist = list stringListM string
595
596	fun abspath () =	fun option m r = UU.r_option session m r
597	SrcPath.unpickle pcmode (stringlist (), group)	val int = UU.r_int session
598		fun share m r = UU.share session m r
599		fun nonshare r = UU.nonshare session r
600		val bool = UU.r_bool session
601		val pid = UnpickleSymPid.r_pid (session, string)
602
603		fun abspath () = let
604		fun ap #"p" =
605		(SrcPath.unpickle pcmode (stringlist (), group)
606	handle SrcPath.Format => raise Format	handle SrcPath.Format => raise Format
607	| SrcPath.BadAnchor a =>	| SrcPath.BadAnchor a =>
608	(error ["configuration anchor \"", a, "\" undefined"];	(error ["configuration anchor \"", a, "\" undefined"];
609	raise Format)	raise Format))
610		| ap _ = raise Format
611		in
612		share apM ap
613		end
614
615	fun sg () = let	fun sg () = let
616	val p = abspath ()	val p = abspath ()
617	in	in
618	(p, getGroup' p)	(p, getGroup' p)
619	end	end
620	val sgListM = UU.mkMap ()
621	val sublibs = list sgListM sg ()	fun gr #"g" =
622		let val sublibs = list sgListM sg ()
623
624	(* Now that we have the list of sublibs, we can build the	(* Now that we have the list of sublibs, we can build the
625	* environment for unpickling the environment list.	* environment for unpickling the environment list.
#	Line 581	Line 627
627	* export list (making SB_BNODES). *)	* export list (making SB_BNODES). *)
628	fun prim_context "pv" = SOME (E.staticPart pervasive)	fun prim_context "pv" = SOME (E.staticPart pervasive)
629	| prim_context s =	| prim_context s =
630	SOME (E.staticPart (Primitive.env primconf	SOME (E.staticPart
631		(Primitive.env primconf
632	(valOf (Primitive.fromIdent primconf	(valOf (Primitive.fromIdent primconf
633	(String.sub (s, 0))))))	(String.sub (s, 0))))))
634	handle _ => NONE	handle _ => NONE
#	Line 590	Line 637
637	List.nth (sublibs, n)	List.nth (sublibs, n)
638	in	in
639	case SymbolMap.find (slexp, sy) of	case SymbolMap.find (slexp, sy) of
640	SOME ((_, DG.SB_BNODE (_, { statenv = ge, ... })), _) =>	SOME ((_, DG.SB_BNODE (_, x)), _) =>
641	SOME (#env (ge ()))	SOME (#env (#statenv x ()))
642	| _ => NONE	| _ => NONE
643	end handle _ => NONE	end handle _ => NONE
644
#	Line 603	Line 650
650	val lazy_symenv = UU.r_lazy session symenv	val lazy_symenv = UU.r_lazy session symenv
651	val lazy_env = UU.r_lazy session env	val lazy_env = UU.r_lazy session env
652
	fun option m r = UU.r_option session m r
	val int = UU.r_int session
	fun share m r = UU.share session m r
	fun nonshare r = UU.nonshare session r
	val bool = UU.r_bool session
	val pid = UnpickleSymPid.r_pid string
	val stringListM = UU.mkMap ()
	val ssM = UU.mkMap ()
	val ssoM = UU.mkMap ()
	val boolOptionM = UU.mkMap ()
	val siM = UU.mkMap ()
	val snM = UU.mkMap ()
	val snListM = UU.mkMap ()
	val sbnM = UU.mkMap ()
	val fsbnM = UU.mkMap ()
	val fsbnListM = UU.mkMap ()
	val impexpM = UU.mkMap ()
	val impexpListM = UU.mkMap ()
653	fun symbolset () = let	fun symbolset () = let
654	fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())	fun s #"s" =
655		SymbolSet.addList (SymbolSet.empty, symbollist ())
656	| s _ = raise Format	| s _ = raise Format
657	in	in
658	share ssM s	share ssM s
#	Line 632	Line 660
660
661	val filter = option ssoM symbolset	val filter = option ssoM symbolset
662
663	fun primitive () =	fun primitive () = let
664	valOf (Primitive.fromIdent primconf	fun p #"p" =
665		(valOf (Primitive.fromIdent primconf
666	(String.sub (string (), 0)))	(String.sub (string (), 0)))
667	handle _ => raise Format	handle _ => raise Format)
668		| p _ = raise Format
669		in
670		share primitiveM p
671		end
672
673	fun shm () = let	fun shm () = let
674	fun s #"a" = Sharing.SHARE true	fun s #"a" = Sharing.SHARE true
#	Line 687	Line 720
720	val n = int ()	val n = int ()
721	val sy = symbol ()	val sy = symbol ()
722	val (_, GG.GROUP { exports = slexp, ... }) =	val (_, GG.GROUP { exports = slexp, ... }) =
723	List.nth (sublibs, n) handle _ => raise Format	List.nth (sublibs, n)
724		handle _ => raise Format
725	in	in
726	case SymbolMap.find (slexp, sy) of	case SymbolMap.find (slexp, sy) of
727	SOME ((_, DG.SB_BNODE (n as DG.BNODE _, _)), _) =>	SOME ((_, DG.SB_BNODE(n, _)), _) =>
728	n	(case n of
729		DG.BNODE _ => n
730		| _ => raise Format)
731	| _ => raise Format	| _ => raise Format
732	end	end
733	| sbn' #"3" = sn ()	| sbn' #"3" = sn ()
#	Line 712	Line 748
748	fun impexp () = let	fun impexp () = let
749	fun ie #"i" =	fun ie #"i" =
750	let val sy = symbol ()	let val sy = symbol ()
751	val (f, n) = fsbn () (* really reads farbnodes! *)	(* really reads farbnodes! *)
752		val (f, n) = fsbn ()
753	val ge = lazy_env ()	val ge = lazy_env ()
754	fun bs2es { env, ctxt } =	fun bs2es { env, ctxt } =
755	{ env = GenericVC.CoerceEnv.bs2es env,	{ env = GenericVC.CoerceEnv.bs2es env,
#	Line 723	Line 760
760	statpid = pid (),	statpid = pid (),
761	sympid = pid () }	sympid = pid () }
762	val e = Statenv2DAEnv.cvtMemo (#env o ge)	val e = Statenv2DAEnv.cvtMemo (#env o ge)
763	(* put a filter in front to avoid having the FCTENV	(* put a filter in front to avoid having the
764	* being queried needlessly (this avoids spurious	* FCTENV being queried needlessly (this
765	* module loadings) *)	* avoids spurious module loadings) *)
766	val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)	val e' =
767		DAEnv.FILTER (SymbolSet.singleton sy, e)
768	in	in
769	(sy, ((f, DG.SB_BNODE (n, ii)), e'))	(sy, ((f, DG.SB_BNODE (n, ii)), e'))
770	end	end
#	Line 738	Line 776
776	val impexplist = list impexpListM impexp	val impexplist = list impexpListM impexp
777
778	fun r_exports () = let	fun r_exports () = let
779	val iel = impexplist ()	fun e #"e" =
780		foldl SymbolMap.insert'
781		SymbolMap.empty (impexplist ())
782		| e _ = raise Format
783	in	in
784	foldl SymbolMap.insert' SymbolMap.empty iel	share exportsM e
785	end	end
786
787	val stringlist = list stringListM string	val stringlist = list stringListM string
788
789	fun privileges () =	fun privileges () = let
790		fun p #"p" =
791	StringSet.addList (StringSet.empty, stringlist ())	StringSet.addList (StringSet.empty, stringlist ())
792		| p _ = raise Format
793		in
794		share privilegesM p
795		end
796
797	val exports = r_exports ()	val exports = r_exports ()
798	val required = privileges ()	val required = privileges ()
#	Line 757	Line 803
803	grouppath = group,	grouppath = group,
804	sublibs = sublibs }	sublibs = sublibs }
805	end	end
806		| gr _ = raise Format
807		in
808		share groupM gr
809		end
810	in	in
811	SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,	SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
812	closeIt = BinIO.closeIn,	closeIt = BinIO.closeIn,

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.512   changed lines   Added in v.513

---

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