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

Parent Directory | Revision Log | Patch

	revision 461, Thu Nov 4 08:06:56 1999 UTC	revision 462, Fri Nov 5 05:45:48 1999 UTC
#	Line 171	Line 171
171	{ envs = fn () => rlayer (e (), e' ()),	{ envs = fn () => rlayer (e (), e' ()),
172	pids = PidSet.union (p, p') }	pids = PidSet.union (p, p') }
173
174	fun layerwork k w v0 l = let	(* I would rather not use an exception here, but short of a better
175	fun lw v0 [] = v0	* implementation of concurrency I see no choice.
176	| lw NONE (h :: t) =	* The problem is that at each node we sequentiallay wait for the
177	if k then (ignore (w h); lw NONE t)	* children nodes.  But the scheduler might (and probably will)
178	else NONE	* let a child run that we are not currently waiting for, so an
179	| lw (SOME v) (h :: t) = let	* error there will not result in "wait" to immediately return
180	fun lay (NONE, v) = NONE	* as it should for clean error recovery.
181	| lay (SOME v', v) = SOME (layer (v', v))	* Using the exception avoids having to implement a
182	in	* "wait for any child -- whichever finishes first" kind of call. *)
183	lw (lay (w h, v)) t	exception Abort
184	end
185	in	fun layer'wait u (p, NONE) =
186	lw v0 l	(ignore (Concur.waitU u p); NONE)
187	end	| layer'wait u (p, SOME e) =
188		(case Concur.waitU u p of
189		SOME e' => SOME (layer (e', e))
190		| NONE => NONE)
191
192	fun mkTraversal (notify, storeBFC, getUrgency) = let	fun mkTraversal (notify, storeBFC, getUrgency) = let
193	val localstate = ref SmlInfoMap.empty	val localstate = ref SmlInfoMap.empty
#	Line 221	Line 224
224	val { smlinfo = i, localimports = li, globalimports = gi } = n	val { smlinfo = i, localimports = li, globalimports = gi } = n
225	val binname = SmlInfo.binname i	val binname = SmlInfo.binname i
226
227		fun fail () =
228		if #keep_going (#param gp) then NONE else raise Abort
229
230	fun compile_here (stat, sym, pids) = let	fun compile_here (stat, sym, pids) = let
231	fun save bfc = let	fun save bfc = let
232	fun writer s =	fun writer s =
#	Line 248	Line 254
254	end (* save *)	end (* save *)
255	in	in
256	case SmlInfo.parsetree gp i of	case SmlInfo.parsetree gp i of
257	NONE => NONE	NONE => fail ()
258	| SOME (ast, source) => let	| SOME (ast, source) => let
259	val corenv = #corenv (#param gp)	val corenv = #corenv (#param gp)
260	val cmData = PidSet.listItems pids	val cmData = PidSet.listItems pids
#	Line 268	Line 274
274	save bfc;	save bfc;
275	storeBFC (i, bfc);	storeBFC (i, bfc);
276	SOME memo	SOME memo
277	end handle _ => NONE (* catch elaborator exn *)	end handle _ => fail () (* catch elaborator exn *)
278	end (* compile_here *)	end (* compile_here *)
279	fun notlocal () = let	fun notlocal () = let
280	val urgency = getUrgency i	val urgency = getUrgency i
281	(* Ok, it is not in the local state, so we first have	(* Ok, it is not in the local state, so we first have
282	* to traverse all children before we can proceed... *)	* to traverse all children before we can proceed... *)
	val k = #keep_going (#param gp)
283	fun loc li_n = Option.map nofilter (snode gp li_n)	fun loc li_n = Option.map nofilter (snode gp li_n)
284	fun glob gi_n = fsbnode gp gi_n	fun glob gi_n = fsbnode gp gi_n
285	val gi_cl =	val gi_cl =
#	Line 282	Line 287
287	val li_cl =	val li_cl =
288	map (fn li_n => Concur.fork (fn () => loc li_n)) li	map (fn li_n => Concur.fork (fn () => loc li_n)) li
289	val e =	val e =
290	layerwork k (Concur.wait' urgency)	foldl (layer'wait urgency)
291	(layerwork k (Concur.wait' urgency)	(foldl (layer'wait urgency)
292	(SOME (pervenv gp)) gi_cl)	(SOME (pervenv gp))
293		gi_cl)
294	li_cl	li_cl
295	in	in
296	case e of	case e of
#	Line 364	Line 370
370	end	end
371	end (* notlocal *)	end (* notlocal *)
372	in	in
373		(* Here we just wait (no "waitU") so we don't get
374		* priority over threads that may have to clean up after
375		* errors. *)
376	case SmlInfoMap.find (!localstate, i) of	case SmlInfoMap.find (!localstate, i) of
377	SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)	SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)
378	| NONE => let	| NONE => let
#	Line 391	Line 400
400	fun getUrgency i = getOpt (SmlInfoMap.find (um, i), 0)	fun getUrgency i = getOpt (SmlInfoMap.find (um, i), 0)
401	val { impexp, ... } = mkTraversal (notify, storeBFC, getUrgency)	val { impexp, ... } = mkTraversal (notify, storeBFC, getUrgency)
402	fun group gp = let	fun group gp = let
	val k = #keep_going (#param gp)
	fun loop ([], success) = success
	| loop (h :: t, success) =
	if isSome (impexp gp h) then loop (t, success)
	else if k then loop (t, false) else false
403	val eo_cl =	val eo_cl =
404	map (fn x => Concur.fork (fn () => impexp gp x))	map (fn x => Concur.fork (fn () => impexp gp x))
405	(SymbolMap.listItems exports)	(SymbolMap.listItems exports)
406	val eo = layerwork k Concur.wait (SOME emptyEnv) eo_cl	val eo = foldl (layer'wait 0) (SOME emptyEnv) eo_cl
407	in	in
408	case eo of	case eo of
409	NONE => (Servers.reset false; NONE)	NONE => (Servers.reset false; NONE)
410	| SOME e => SOME (#envs e ())	| SOME e => SOME (#envs e ())
411	end	end handle Abort => (Servers.reset false; NONE)
412	fun mkExport ie gp =	fun mkExport ie gp =
413	case impexp gp ie of	case impexp gp ie handle Abort => NONE of
414	NONE => (Servers.reset false; NONE)	NONE => (Servers.reset false; NONE)
415	| SOME e => SOME (#envs e ())	| SOME e => SOME (#envs e ())
416	in	in
#	Line 419	Line 423
423	fn _ => (),	fn _ => (),
424	fn _ => 0)	fn _ => 0)
425	fun sbn_trav gp g = let	fun sbn_trav gp g = let
426	val r = sbnode gp g	val r = sbnode gp g handle Abort => NONE
427	in	in
428	if isSome r then () else Servers.reset false;	if isSome r then () else Servers.reset false;
429	r	r

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.461   changed lines   Added in v.462

---

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