Annotation of /sml/trunk/src/cm/compile/exec.sml

Parent Directory | Revision Log

---

Revision 298 - (view) (download)

1 :	blume	295	(*
2 :			* Build an argument for the generic compilation functor.
3 :			* This gives a traversal that executes the code in each node as
4 :			* necessary (and builds the dynamic environment).
5 :			* A traversal requires prior successful traversal using the
6 :			* "RecompFn" functor (using the same persistent state).
7 :			*
8 :			* (C) 1999 Lucent Technologies, Bell Laboratories
9 :			*
10 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :			*)
12 :			functor ExecFn (structure PS : FULL_PERSSTATE) : COMPILATION_TYPE = struct
13 :
14 :			structure E = GenericVC.Environment
15 :			structure DTS = DynTStamp
16 :			structure DE = GenericVC.DynamicEnv
17 :			structure BF = PS.MachDepVC.Binfile
18 :			structure PP = PrettyPrint
19 :			structure EM = GenericVC.ErrorMsg
20 :
21 :			type env = { dyn: unit -> E.dynenv, dts: DTS.dts }
22 :			type benv = env
23 :			type envdelta = env
24 :
25 :			fun layer ({ dyn = d, dts = s }, { dyn = d', dts = s' }) =
26 :			{ dyn = fn () => DE.atop (d (), d' ()), dts = DTS.join (s, s') }
27 :
28 :			fun filter (e, _) = e
29 :			fun nofilter e = e
30 :
31 :			val blayer = layer
32 :			val bfilter = filter
33 :			val bnofilter = nofilter
34 :
35 :			fun primitive c p =
36 :			{ dyn = fn () => E.dynamicPart (Primitive.env c p),
37 :			dts = DTS.ancient }
38 :
39 :			fun thunkify { dyn, dts } = { dyn = fn () => dyn, dts = dts }
40 :
41 :			fun execute (bfc, { dyn = mkdyn, dts }, share, error, descr, memo) = let
42 :			val (tryshare, mustshare) =
43 :			case share of
44 :			NONE => (true, false)
45 :			| SOME true => (true, true)
46 :			| SOME false => (false, false)
47 :			fun doit () = let
48 :			val dts' = if tryshare then DTS.current ()
49 :			else DTS.noshare descr
50 :			val e = BF.exec (bfc, mkdyn ())
51 :			val m = { dyn = E.dynamicPart e, dts = DTS.join (dts, dts') }
52 :			in
53 :			memo m;
54 :			SOME (thunkify m)
55 :			end handle exn => let
56 :			fun pphist pps =
57 :			(PP.add_string pps (General.exnMessage exn);
58 :			PP.add_newline pps)
59 :			in
60 :			error "exception in module initialization code" pphist;
61 :			NONE
62 :			end
63 :			in
64 :			if mustshare then
65 :			case DTS.can'tShare dts of
66 :			NONE => doit ()
67 :			| SOME sl => let
68 :			fun pphist [] pps = ()
69 :			| pphist (h :: t) pps =
70 :			(PP.add_string pps h;
71 :			PP.add_newline pps;
72 :			pphist t pps)
73 :			in
74 :			error
75 :			"cannot share state: dependence on non-shareable modules"
76 :			(pphist sl);
77 :			NONE
78 :			end
79 :			else doit ()
80 :			end
81 :
82 :	blume	298	fun dostable (i, mkenv, gp) =
83 :			case mkenv () of
84 :			NONE => NONE
85 :			| SOME (e as { dyn, dts }) =>
86 :			(case PS.exec_look_stable (i, dts, gp) of
87 :			SOME memo => SOME (thunkify memo)
88 :			| NONE => execute (PS.bfc_fetch_stable i, e,
89 :			BinInfo.share i,
90 :			BinInfo.error gp i EM.COMPLAIN,
91 :			BinInfo.describe i,
92 :			fn m => PS.exec_memo_stable (i, m)))
93 :	blume	295
94 :	blume	298	fun dosml (i, e as { dyn, dts }, gp) = let
95 :			fun looksml () =
96 :			Option.map thunkify (PS.exec_look_sml (i, dts, gp))
97 :			in
98 :			case looksml () of
99 :			SOME d => SOME d
100 :			| NONE => execute (PS.bfc_fetch_sml i, e,
101 :			SmlInfo.share i,
102 :			SmlInfo.error gp i EM.COMPLAIN,
103 :			SmlInfo.name i,
104 :			fn m => PS.exec_memo_sml (i, m))
105 :			end
106 :	blume	295	end

---

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