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

Parent Directory | Revision Log

---

Revision 302 - (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 :	blume	299	fun primitive (gp: GeneralParams.info) p =
36 :			{ dyn = fn () => E.dynamicPart (Primitive.env
37 :			(#primconf (#param gp)) p),
38 :	blume	295	dts = DTS.ancient }
39 :
40 :	blume	299	fun pervasive (gp: GeneralParams.info) =
41 :			{ dyn = fn () => E.dynamicPart (#pervasive (#param gp)),
42 :			dts = DTS.ancient }
43 :
44 :			val bpervasive = pervasive
45 :
46 :	blume	295	fun thunkify { dyn, dts } = { dyn = fn () => dyn, dts = dts }
47 :
48 :			fun execute (bfc, { dyn = mkdyn, dts }, share, error, descr, memo) = let
49 :			val (tryshare, mustshare) =
50 :			case share of
51 :			NONE => (true, false)
52 :			| SOME true => (true, true)
53 :			| SOME false => (false, false)
54 :			fun doit () = let
55 :			val dts' = if tryshare then DTS.current ()
56 :			else DTS.noshare descr
57 :			val e = BF.exec (bfc, mkdyn ())
58 :			val m = { dyn = E.dynamicPart e, dts = DTS.join (dts, dts') }
59 :			in
60 :			memo m;
61 :			SOME (thunkify m)
62 :			end handle exn => let
63 :	blume	302	fun ppb pps =
64 :			(PP.add_newline pps;
65 :			PP.add_string pps (General.exnMessage exn);
66 :	blume	295	PP.add_newline pps)
67 :			in
68 :	blume	302	error ("link-time error in " ^ descr) ppb;
69 :	blume	295	NONE
70 :			end
71 :			in
72 :			if mustshare then
73 :			case DTS.can'tShare dts of
74 :			NONE => doit ()
75 :			| SOME sl => let
76 :	blume	302	fun ppb pps = let
77 :			fun loop [] = ()
78 :			| loop (h :: t) =
79 :			(PP.add_string pps h; PP.add_newline pps; loop t)
80 :			in
81 :			PP.add_newline pps;
82 :			PP.add_string pps
83 :			"because of dependence on private module(s):";
84 :			PP.add_newline pps;
85 :			loop sl
86 :			end
87 :	blume	295	in
88 :	blume	302	error ("cannot share state of " ^ descr) ppb;
89 :	blume	295	NONE
90 :			end
91 :			else doit ()
92 :			end
93 :
94 :	blume	298	fun dostable (i, mkenv, gp) =
95 :			case mkenv () of
96 :			NONE => NONE
97 :			| SOME (e as { dyn, dts }) =>
98 :			(case PS.exec_look_stable (i, dts, gp) of
99 :			SOME memo => SOME (thunkify memo)
100 :			| NONE => execute (PS.bfc_fetch_stable i, e,
101 :			BinInfo.share i,
102 :			BinInfo.error gp i EM.COMPLAIN,
103 :			BinInfo.describe i,
104 :			fn m => PS.exec_memo_stable (i, m)))
105 :	blume	295
106 :	blume	302	fun dosml (i, e as { dyn, dts }, gp) =
107 :			case PS.exec_look_sml (i, dts, gp) of
108 :			SOME memo => SOME (thunkify memo)
109 :	blume	298	| NONE => execute (PS.bfc_fetch_sml i, e,
110 :			SmlInfo.share i,
111 :			SmlInfo.error gp i EM.COMPLAIN,
112 :			SmlInfo.name i,
113 :			fn m => PS.exec_memo_sml (i, m))
114 :	blume	295	end

---

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