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

Parent Directory | Revision Log

---

Revision 316 - (view) (download)

1 :	blume	295	(*
2 :			* Build an argument for the generic compilation functor.
3 :			* This gives a traversal that loads from binfiles, stable archives,
4 :			* or compiles sml source code. The "binfile content" cache gets
5 :			* warmed up that way, too. (The "ExecFn" functor takes advantage of
6 :			* this fact.)
7 :			*
8 :			* (C) 1999 Lucent Technologies, Bell Laboratories
9 :			*
10 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :			*)
12 :			functor RecompFn (structure PS : RECOMP_PERSSTATE) : COMPILATION_TYPE = struct
13 :
14 :			structure MachDepVC = PS.MachDepVC
15 :			structure E = GenericVC.Environment
16 :			structure PID = GenericVC.PersStamps
17 :			structure BF = MachDepVC.Binfile
18 :	blume	297	structure PP = PrettyPrint
19 :			structure EM = GenericVC.ErrorMsg
20 :	blume	316	structure DE = GenericVC.DynamicEnv
21 :	blume	295
22 :			type pid = PID.persstamp
23 :
24 :			type statenv = E.staticEnv
25 :			type symenv = E.symenv
26 :
27 :			type benv = statenv
28 :	blume	316	type result = { stat: statenv, sym: symenv }
29 :			type env = { envs: result, pids: PidSet.set }
30 :	blume	295
31 :	blume	316	val empty = { stat = E.staticPart E.emptyEnv,
32 :			sym = E.symbolicPart E.emptyEnv }
33 :	blume	314
34 :	blume	316	fun env2result (e: env) = #envs e
35 :
36 :			fun rlayer (r, r') = let
37 :			fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,
38 :			dynamic = DE.empty }
39 :			fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }
40 :			in
41 :			e2r (E.concatEnv (r2e r, r2e r'))
42 :			end
43 :
44 :	blume	295	type 'e wpid = 'e * pid
45 :
46 :			type envdelta = { stat: statenv wpid, sym: symenv wpid, ctxt: statenv }
47 :
48 :			type memorecord = { bfc: BF.bfContent, ctxt: statenv }
49 :
50 :			structure FilterMap = BinaryMapFn
51 :			(struct
52 :			type ord_key = pid * SymbolSet.set
53 :			fun compare ((u, f), (u', f')) =
54 :			case PID.compare (u, u') of
55 :			EQUAL => SymbolSet.compare (f, f')
56 :			| unequal => unequal
57 :			end)
58 :
59 :			(* persistent state! *)
60 :			val filtermap = ref (FilterMap.empty: pid FilterMap.map)
61 :
62 :			fun blayer (be, be') = E.layerStatic (be, be')
63 :
64 :	blume	316	fun layer ({ envs, pids }, { envs = e', pids = p' }) =
65 :			{ envs = rlayer (envs, e'), pids = PidSet.union (pids, p') }
66 :	blume	295
67 :			fun bfilter (d: envdelta, s) =
68 :			E.filterStaticEnv (#1 (#stat d), SymbolSet.listItems s)
69 :
70 :			fun pidset (p1, p2) =
71 :			PidSet.add (PidSet.singleton p1, p2)
72 :
73 :			fun filter (d, s) = let
74 :			val stat = bfilter (d, s)
75 :			val (sym, sympid) = #sym d
76 :			val statpid = #2 (#stat d)
77 :			val ctxt = #ctxt d
78 :			val key = (statpid, s)
79 :			val statpid' =
80 :			case FilterMap.find (!filtermap, key) of
81 :			SOME statpid' => statpid'
82 :			| NONE => let
83 :			val statpid' = GenericVC.MakePid.makePid (ctxt, stat)
84 :			in
85 :			filtermap := FilterMap.insert (!filtermap, key, statpid');
86 :			statpid'
87 :			end
88 :			in
89 :	blume	316	{ envs = { stat = stat, sym = sym }, pids = pidset (statpid', sympid) }
90 :	blume	295	end
91 :
92 :			fun bnofilter (d: envdelta) = #1 (#stat d)
93 :
94 :			fun nofilter (d: envdelta) = let
95 :			val (stat, statpid) = #stat d
96 :			val (sym, sympid) = #sym d
97 :			in
98 :	blume	316	{ envs = { stat = stat, sym = sym }, pids = pidset (statpid, sympid) }
99 :	blume	295	end
100 :
101 :	blume	299	fun primitive (gp: GeneralParams.info) p = let
102 :			val c = #primconf (#param gp)
103 :	blume	295	val e = Primitive.env c p
104 :			val { statpid, sympid, ctxt } = Primitive.pidInfo c p
105 :			in
106 :			{ stat = (E.staticPart e, statpid),
107 :			sym = (E.symbolicPart e, sympid),
108 :			ctxt = ctxt }
109 :			end
110 :
111 :	blume	299	fun pervasive (gp: GeneralParams.info) = let
112 :			val e = #pervasive (#param gp)
113 :			in
114 :	blume	316	{ envs = { stat = E.staticPart e, sym = E.symbolicPart e },
115 :			pids = PidSet.empty }
116 :	blume	299	end
117 :
118 :			fun bpervasive (gp: GeneralParams.info) =
119 :			E.staticPart (#pervasive (#param gp))
120 :
121 :	blume	295	fun memo2envdelta { bfc, ctxt } =
122 :			{ stat = (BF.senvOf bfc, BF.staticPidOf bfc),
123 :			sym = (BF.symenvOf bfc, BF.lambdaPidOf bfc),
124 :			ctxt = ctxt }
125 :
126 :	blume	306	fun dostable (i, mkenv, gp: GeneralParams.info) = let
127 :	blume	298	fun load be = let
128 :	blume	299	val fnp = #fnpolicy (#param gp)
129 :	blume	298	val stable = FilenamePolicy.mkStablePath fnp (BinInfo.group i)
130 :			val os = BinInfo.offset i
131 :			val descr = BinInfo.describe i
132 :	blume	310	val _ = Say.vsay ["[consulting ", descr, "]\n"]
133 :	blume	298	val s = AbsPath.openBinIn stable
134 :			fun load () = let
135 :			val _ = Seek.seek (s, os)
136 :			val bfc = BF.read { stream = s, name = descr, senv = be,
137 :			keep_code = true }
138 :			val memo = { bfc = bfc, ctxt = be }
139 :			in
140 :			BinIO.closeIn s;
141 :			PS.recomp_memo_stable (i, memo);
142 :			memo2envdelta memo
143 :			end
144 :	blume	295	in
145 :	blume	298	SOME (load ()) handle exn => let
146 :	blume	301	fun ppb pps =
147 :	blume	298	(PP.add_string pps (General.exnMessage exn);
148 :			PP.add_newline pps)
149 :			in
150 :			BinIO.closeIn s;
151 :	blume	306	BinInfo.error i EM.COMPLAIN
152 :	blume	301	"unable to load stable library module" ppb;
153 :	blume	298	NONE
154 :			end
155 :	blume	295	end
156 :			in
157 :	blume	298	case PS.recomp_look_stable i of
158 :			SOME memo => SOME (memo2envdelta memo)
159 :			| NONE =>
160 :			(case mkenv () of
161 :			NONE => NONE
162 :			| SOME be => load be)
163 :	blume	295	end
164 :
165 :	blume	316	fun dosml (i, { envs = { stat, sym }, pids }, gp) =
166 :	blume	298	case Option.map memo2envdelta (PS.recomp_look_sml (i, pids, gp)) of
167 :			SOME d => SOME d
168 :			| NONE => let
169 :	blume	310	val binpath = SmlInfo.binpath i
170 :	blume	298	val binname = AbsPath.name binpath
171 :			fun delete () = OS.FileSys.remove binname handle _ => ()
172 :	blume	295
173 :	blume	298	fun save bfc = let
174 :			val s = AbsPath.openBinOut binpath
175 :			fun writer () = BF.write { stream = s, content = bfc,
176 :			keep_code = true }
177 :			in
178 :	blume	301	Interrupt.guarded writer handle exn =>
179 :			(BinIO.closeOut s; raise exn);
180 :			BinIO.closeOut s;
181 :	blume	310	Say.vsay ["[wrote ", binname, "]\n"]
182 :	blume	298	end handle e as Interrupt.Interrupt => (delete (); raise e)
183 :			| exn => let
184 :	blume	301	fun ppb pps =
185 :	blume	298	(PP.add_string pps (General.exnMessage exn);
186 :			PP.add_newline pps)
187 :			in
188 :			delete ();
189 :			SmlInfo.error gp i EM.WARN
190 :	blume	301	("failed to write " ^ binname) ppb
191 :	blume	298	end
192 :	blume	297
193 :	blume	298	fun load () = let
194 :	blume	301	val bin_ts = AbsPath.tstamp binpath
195 :	blume	298	in
196 :	blume	301	if TStamp.earlier (bin_ts, SmlInfo.lastseen i) then
197 :			NONE
198 :			else let
199 :			val s = AbsPath.openBinIn binpath
200 :			fun read () = BF.read { stream = s, name = binname,
201 :			senv = stat, keep_code = true }
202 :			in
203 :			(SOME (Interrupt.guarded read)
204 :			before SmlInfo.forgetParsetree i)
205 :			handle exn => (BinIO.closeIn s; raise exn)
206 :			end handle e as Interrupt.Interrupt => raise e
207 :			| _ => NONE
208 :			end
209 :	blume	297
210 :	blume	299	fun compile () =
211 :			case SmlInfo.parsetree gp i of
212 :			NONE => NONE
213 :			| SOME (ast, source) => let
214 :	blume	310	val _ = Say.vsay ["[compiling ", SmlInfo.name i,
215 :			" -> ", binname, "...]\n"]
216 :	blume	301	val corenv = #corenv (#param gp)
217 :	blume	299	val cmData = PidSet.listItems pids
218 :			val bfc = BF.create { runtimePid = NONE,
219 :			splitting = true,
220 :			cmData = cmData,
221 :			ast = ast,
222 :			source = source,
223 :			senv = stat,
224 :			symenv = sym,
225 :			corenv = corenv }
226 :			val memo = { bfc = bfc, ctxt = stat }
227 :			in
228 :	blume	301	SmlInfo.forgetParsetree i;
229 :	blume	299	save bfc;
230 :			PS.recomp_memo_sml (i, memo);
231 :			SOME (memo2envdelta memo)
232 :			end handle e as Interrupt.Interrupt => raise e
233 :	blume	301	| BF.Compile _ => NONE
234 :			| e => let
235 :			fun ppb pps =
236 :			(PP.add_string pps
237 :			(General.exnMessage e);
238 :			PP.add_newline pps)
239 :			in
240 :			SmlInfo.error gp i EM.COMPLAIN
241 :			("exception raised while compiling "
242 :			^ SmlInfo.name i)
243 :			ppb;
244 :			NONE
245 :			end
246 :	blume	297
247 :	blume	298	fun isValid x =
248 :			PidSet.equal (PidSet.addList (PidSet.empty, BF.cmDataOf x),
249 :			pids)
250 :			in
251 :			case load () of
252 :			NONE => compile ()
253 :			| SOME bfc =>
254 :			if isValid bfc then let
255 :			val memo = { bfc = bfc, ctxt = stat }
256 :			in
257 :	blume	310	Say.vsay ["[", binname, " loaded]\n"];
258 :	blume	298	PS.recomp_memo_sml (i, memo);
259 :			SOME (memo2envdelta memo)
260 :			end
261 :			else compile ()
262 :			end
263 :	blume	295	end

---

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