Diff of /sml/trunk/src/cm/compile/generic.sml

Parent Directory | Revision Log | Patch

	revision 350, Wed Jun 23 00:38:58 1999 UTC	revision 351, Wed Jun 23 06:44:27 1999 UTC
#	Line 17	Line 17
17	type envdelta = CT.envdelta	type envdelta = CT.envdelta
18	type result = CT.result	type result = CT.result
19
	(* "bnode" does not expect failures, and "group" automatically
	* clears failures... *)
20	val bnode : GP.info -> DG.bnode -> envdelta option	val bnode : GP.info -> DG.bnode -> envdelta option
21	val group : GP.info -> GG.group -> result option	val group : GP.info -> GG.group -> result option
22
23	(* ... but if you go through the "snode" interface, then	(* if you go through the "snode" interface, then
24	* you must clear failures explicitly when you are done. *)	* you must reset explicitly when you are done. *)
25	val snode : GP.info -> DG.snode -> envdelta option	val snode : GP.info -> DG.snode -> envdelta option
26	val clearFailures : unit -> unit	val reset : unit -> unit
27
28		val resetAll : unit -> unit
29	end = struct	end = struct
30
31	type envdelta = CT.envdelta	type envdelta = CT.envdelta
#	Line 33	Line 33
33	type benv = CT.benv	type benv = CT.benv
34	type result = CT.result	type result = CT.result
35
36	(* This is to prevent re-execution of dosml if the first one failed *)	val smlcache = ref (SmlInfoMap.empty: envdelta option SmlInfoMap.map)
37	local	val stablecache = ref (StableMap.empty: envdelta option StableMap.map)
38	val failures = ref SmlInfoSet.empty	fun reset () = smlcache := SmlInfoMap.empty
39	in	fun resetAll () = (reset (); stablecache := StableMap.empty)
	fun dosml (i, e, gp) =
	if SmlInfoSet.member (!failures, i) then NONE
	else case CT.dosml (i, e, gp) of
	SOME r => SOME r
	| NONE => (failures := SmlInfoSet.add (!failures, i); NONE)
	fun clearFailures () = failures := SmlInfoSet.empty
	end
40
41	(* To implement "keep_going" we have two different ways of	(* To implement "keep_going" we have two different ways of
42	* combining a "work" function with a "layer" function.	* combining a "work" function with a "layer" function.
#	Line 68	Line 61
61	fun bn (DG.PNODE p) = SOME (CT.primitive gp p)	fun bn (DG.PNODE p) = SOME (CT.primitive gp p)
62	| bn (DG.BNODE n) = let	| bn (DG.BNODE n) = let
63	val { bininfo, localimports = li, globalimports = gi } = n	val { bininfo, localimports = li, globalimports = gi } = n
	fun mkenv () = loc (glob (SOME (CT.bpervasive gp)) gi) li
64	in	in
65	CT.dostable (bininfo, mkenv, gp)	case StableMap.find (!stablecache, bininfo) of
66		SOME r => r
67		| NONE => let
68		fun mkenv () =
69		loc (glob (SOME (CT.bpervasive gp)) gi) li
70		val r = CT.dostable (bininfo, mkenv, gp)
71		in
72		stablecache :=
73		StableMap.insert (!stablecache, bininfo, r);
74		r
75		end
76	end	end
77	in	in
78	(* don't eta-reduce this -- it'll lead to an infinite loop! *)	(* don't eta-reduce this -- it'll lead to an infinite loop! *)
#	Line 93	Line 95
95	Option.map CT.nofilter o snode gp))	Option.map CT.nofilter o snode gp))
96
97	val { smlinfo, localimports = li, globalimports = gi } = n	val { smlinfo, localimports = li, globalimports = gi } = n
98	val desc = SmlInfo.fullSpec smlinfo	in
99		case SmlInfoMap.find (!smlcache, smlinfo) of
100		SOME r => r
101		| NONE => let
102	val pe = SOME (CT.pervasive gp)	val pe = SOME (CT.pervasive gp)
103	val ge = glob pe gi	val ge = glob pe gi
104	val e = loc ge li	val e = loc ge li
105	in	val r = case e of
	case e of
106	NONE => NONE	NONE => NONE
107	| SOME e => dosml (smlinfo, e, gp)	| SOME e => CT.dosml (smlinfo, e, gp)
108		in
109		smlcache := SmlInfoMap.insert (!smlcache, smlinfo, r);
110		r
111		end
112	end	end
113
114	and sbnode gp (DG.SB_BNODE b) = bnode gp b	and sbnode gp (DG.SB_BNODE b) = bnode gp b
#	Line 120	Line 128
128	impexp gp))	impexp gp))
129	(SOME CT.empty)	(SOME CT.empty)
130	(SymbolMap.listItems exports))	(SymbolMap.listItems exports))
131	before clearFailures ()	before reset ()
132	end	end
133	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.350   changed lines   Added in v.351

---

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