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

Parent Directory | Revision Log

---

Revision 402 - (view) (download)

1 :	blume	402	(*
2 :			* Compilation traversals.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :	blume	398	local
9 :			structure GP = GeneralParams
10 :			structure DG = DependencyGraph
11 :			structure GG = GroupGraph
12 :			structure E = GenericVC.Environment
13 :			structure Pid = GenericVC.PersStamps
14 :			structure DE = GenericVC.DynamicEnv
15 :			structure PP = PrettyPrint
16 :			structure EM = GenericVC.ErrorMsg
17 :
18 :			type pid = Pid.persstamp
19 :			type statenv = E.staticEnv
20 :			type symenv = E.symenv
21 :			type result = { stat: statenv, sym: symenv }
22 :			type ed = { ii: IInfo.info, ctxt: statenv }
23 :			in
24 :			signature COMPILE = sig
25 :	blume	402
26 :	blume	400	type bfc
27 :
28 :	blume	398	(* reset internal persistent state *)
29 :			val reset : unit -> unit
30 :	blume	399
31 :			(* notify linkage module about recompilation *)
32 :	blume	400	type notifier = GP.info -> SmlInfo.info -> unit
33 :	blume	399
34 :	blume	398	val sizeBFC : SmlInfo.info -> int
35 :			val writeBFC : BinIO.outstream -> SmlInfo.info -> unit
36 :			val getII : SmlInfo.info -> IInfo.info
37 :	blume	400	val getBFC : SmlInfo.info -> bfc
38 :	blume	399
39 :	blume	400	val evict : SmlInfo.info -> unit
40 :	blume	402	val evictAll : unit -> unit
41 :	blume	399
42 :	blume	400	val newSbnodeTraversal : unit -> GP.info -> DG.sbnode -> ed option
43 :
44 :	blume	399	val newTraversal : notifier * GG.group ->
45 :			{ group: GP.info -> result option,
46 :			exports: (GP.info -> result option) SymbolMap.map }
47 :	blume	398	end
48 :
49 :	blume	400	functor CompileFn (structure MachDepVC : MACHDEP_VC) :>
50 :			COMPILE where type bfc = MachDepVC.Binfile.bfContent =
51 :			struct
52 :	blume	398
53 :	blume	400	type notifier = GP.info -> SmlInfo.info -> unit
54 :	blume	399
55 :	blume	398	structure BF = MachDepVC.Binfile
56 :
57 :			type bfc = BF.bfContent
58 :
59 :			structure FilterMap = BinaryMapFn
60 :			(struct
61 :			type ord_key = pid * SymbolSet.set
62 :			fun compare ((u, f), (u', f')) =
63 :			case Pid.compare (u, u') of
64 :			EQUAL => SymbolSet.compare (f, f')
65 :			| unequal => unequal
66 :			end)
67 :
68 :	blume	399	type env = { envs: unit -> result, pids: PidSet.set }
69 :	blume	398	type envdelta =
70 :			{ ii: IInfo.info, ctxt: unit -> statenv, bfc: bfc option }
71 :
72 :			type memo = { bfc: bfc, ctxt: statenv, ts: TStamp.t }
73 :
74 :			(* persistent state! *)
75 :			val filtermap = ref (FilterMap.empty: pid FilterMap.map)
76 :
77 :			(* more persistent state! *)
78 :	blume	402	val globalstate = ref (SmlInfoMap.empty: memo SmlInfoMap.map)
79 :	blume	398
80 :			fun reset () =
81 :			(filtermap := FilterMap.empty;
82 :	blume	402	globalstate := SmlInfoMap.empty)
83 :	blume	398
84 :			fun isValidMemo (memo: memo, provided, smlinfo) =
85 :			not (TStamp.needsUpdate { source = SmlInfo.lastseen smlinfo,
86 :			target = #ts memo })
87 :			andalso let
88 :			val demanded =
89 :			PidSet.addList (PidSet.empty, BF.cmDataOf (#bfc memo))
90 :			in
91 :			PidSet.equal (provided, demanded)
92 :			end
93 :
94 :			fun memo2ii (memo: memo) =
95 :			{ statenv = fn () => BF.senvOf (#bfc memo),
96 :			symenv = fn () => BF.symenvOf (#bfc memo),
97 :			statpid = BF.staticPidOf (#bfc memo),
98 :			sympid = BF.lambdaPidOf (#bfc memo) }
99 :
100 :			fun memo2ed memo =
101 :			{ ii = memo2ii memo,
102 :			ctxt = fn () => #ctxt memo,
103 :			bfc = SOME (#bfc memo) }
104 :
105 :			fun pidset (p1, p2) = PidSet.add (PidSet.singleton p1, p2)
106 :
107 :			fun nofilter (ed: envdelta) = let
108 :			val { ii = { statenv, symenv, statpid, sympid }, ctxt, bfc } = ed
109 :			in
110 :			{ envs = fn () => { stat = statenv (), sym = symenv () },
111 :			pids = pidset (statpid, sympid) }
112 :			end
113 :
114 :			fun exportsNothingBut set se =
115 :			List.all (fn sy => SymbolSet.member (set, sy)) (E.catalogEnv se)
116 :
117 :			fun filter ({ ii, ctxt, bfc }: envdelta, s) = let
118 :			val { statenv, symenv, statpid, sympid } = ii
119 :			val ste = statenv ()
120 :			in
121 :			if exportsNothingBut s ste then
122 :			{ envs = fn () => { stat = ste, sym = symenv () },
123 :			pids = pidset (statpid, sympid) }
124 :			else let
125 :			val ste' = E.filterStaticEnv (ste, SymbolSet.listItems s)
126 :			val key = (statpid, s)
127 :			val statpid' =
128 :			case FilterMap.find (!filtermap, key) of
129 :			SOME statpid' => statpid'
130 :			| NONE => let
131 :			val statpid' =
132 :			GenericVC.MakePid.makePid (ctxt (), ste')
133 :			in
134 :			filtermap :=
135 :			FilterMap.insert (!filtermap, key, statpid');
136 :			statpid'
137 :			end
138 :			in
139 :			{ envs = fn () => { stat = ste', sym = symenv () },
140 :			pids = pidset (statpid', sympid) }
141 :			end
142 :			end
143 :
144 :	blume	399	local
145 :	blume	398	fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,
146 :			dynamic = DE.empty }
147 :			fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }
148 :			in
149 :	blume	399	(* This is a bit ugly because somehow we need to mix dummy
150 :			* dynamic envs into the equation just to be able to use
151 :			* concatEnv. But, alas', that's life... *)
152 :			fun rlayer (r, r') = e2r (E.concatEnv (r2e r, r2e r'))
153 :
154 :			val emptyEnv =
155 :			{ envs = fn () => e2r E.emptyEnv, pids = PidSet.empty }
156 :	blume	398	end
157 :
158 :			fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =
159 :			{ envs = fn () => rlayer (e (), e' ()),
160 :			pids = PidSet.union (p, p') }
161 :
162 :	blume	399	fun layerwork k w v0 l = let
163 :			fun lw v0 [] = v0
164 :			| lw NONE (h :: t) =
165 :			if k then (ignore (w h); lw NONE t)
166 :			else NONE
167 :			| lw (SOME v) (h :: t) = let
168 :			fun lay (NONE, v) = NONE
169 :			| lay (SOME v', v) = SOME (layer (v', v))
170 :			in
171 :			lw (lay (w h, v)) t
172 :			end
173 :			in
174 :			lw v0 l
175 :			end
176 :
177 :			fun mkTraversal notify = let
178 :	blume	402	val localstate = ref SmlInfoMap.empty
179 :	blume	398
180 :			fun pervenv (gp: GP.info) = let
181 :			val e = #pervasive (#param gp)
182 :			val ste = E.staticPart e
183 :			val sye = E.symbolicPart e
184 :			in
185 :			{ envs = fn () => { stat = ste, sym = sye },
186 :			pids = PidSet.empty }
187 :			end
188 :
189 :			fun sbnode gp n =
190 :			case n of
191 :			DG.SB_BNODE (_, ii) =>
192 :			(* The beauty of this scheme is that we don't have
193 :			* to do anything at all for SB_BNODEs: Everything
194 :			* is prepared ready to be used when the library
195 :			* is unpickled.
196 :			*
197 :			* Making ctxt equal to ste is basically a hack
198 :			* because we want to avoid having to keep the
199 :			* real context around. As a result there is a
200 :			* slight loss of "smart recompilation":
201 :			* eliminating a definition is not the same as
202 :			* stripping it away using a filter. This is a
203 :			* minor issue anyway, and in the present case
204 :			* it only happens when a stable library is
205 :			* replaced by a different one. *)
206 :			SOME { ii = ii, ctxt = #statenv ii, bfc = NONE }
207 :			| DG.SB_SNODE n => snode gp n
208 :
209 :			and fsbnode gp (f, n) =
210 :			case (sbnode gp n, f) of
211 :			(NONE, _) => NONE
212 :			| (SOME d, NONE) => SOME (nofilter d)
213 :			| (SOME d, SOME s) => SOME (filter (d, s))
214 :
215 :			and snode gp (DG.SNODE n) = let
216 :			val { smlinfo = i, localimports = li, globalimports = gi } = n
217 :			val binname = SmlInfo.binname i
218 :
219 :			fun compile (stat, sym, pids) = let
220 :			fun save bfc = let
221 :			fun writer s =
222 :			(BF.write { stream = s, content = bfc,
223 :			nopickle = false };
224 :			Say.vsay ["[wrote ", binname, "]\n"])
225 :			fun cleanup () =
226 :			OS.FileSys.remove binname handle _ => ()
227 :			in
228 :	blume	400	notify gp i;
229 :	blume	398	SafeIO.perform { openIt =
230 :			fn () => AutoDir.openBinOut binname,
231 :			closeIt = BinIO.closeOut,
232 :			work = writer,
233 :			cleanup = cleanup }
234 :			handle exn => let
235 :			fun ppb pps =
236 :			(PP.add_newline pps;
237 :			PP.add_string pps (General.exnMessage exn))
238 :			in
239 :			SmlInfo.error gp i EM.WARN
240 :			("failed to write " ^ binname) ppb
241 :			end;
242 :			TStamp.setTime (binname, SmlInfo.lastseen i)
243 :			end (* save *)
244 :			in
245 :			case SmlInfo.parsetree gp i of
246 :			NONE => NONE
247 :			| SOME (ast, source) => let
248 :			val _ =
249 :			Say.vsay ["[compiling ", SmlInfo.descr i, "]\n"]
250 :			val corenv = #corenv (#param gp)
251 :			val cmData = PidSet.listItems pids
252 :			(* clear error flag (could still be set from
253 :			* earlier run) *)
254 :			val _ = #anyErrors source := false
255 :			val bfc = BF.create { runtimePid = NONE,
256 :			splitting = SmlInfo.split i,
257 :			cmData = cmData,
258 :			ast = ast,
259 :			source = source,
260 :			senv = stat,
261 :			symenv = sym,
262 :			corenv = corenv }
263 :			val memo = { bfc = bfc, ctxt = stat,
264 :			ts = SmlInfo.lastseen i}
265 :			in
266 :			SmlInfo.forgetParsetree i;
267 :			save bfc;
268 :	blume	402	SOME memo
269 :	blume	398	end
270 :			end (* compile *)
271 :			fun notlocal () = let
272 :	blume	402	(* Ok, it is not in the local state, so we first have
273 :	blume	398	* to traverse all children before we can proceed... *)
274 :			val k = #keep_going (#param gp)
275 :			fun loc li_n = Option.map nofilter (snode gp li_n)
276 :			fun glob gi_n = fsbnode gp gi_n
277 :			val e =
278 :			layerwork k loc
279 :			(layerwork k glob (SOME (pervenv gp)) gi)
280 :			li
281 :			in
282 :			case e of
283 :			NONE => NONE
284 :			| SOME { envs, pids } => let
285 :			(* We have successfully traversed all
286 :			* children. Now it is time to check the
287 :			* global map... *)
288 :			fun fromfile () = let
289 :			val { stat, sym } = envs ()
290 :			fun load () = let
291 :			val ts = TStamp.fmodTime binname
292 :			fun openIt () = BinIO.openIn binname
293 :			fun reader s =
294 :			(BF.read { stream = s,
295 :			name = binname,
296 :			senv = stat },
297 :			ts)
298 :	blume	402	before
299 :			Say.vsay ["[", binname, " loaded]\n"]
300 :	blume	398	in
301 :			SOME (SafeIO.perform
302 :			{ openIt = openIt,
303 :			closeIt = BinIO.closeIn,
304 :			work = reader,
305 :			cleanup = fn () => () })
306 :			handle _ => NONE
307 :			end (* load *)
308 :			in
309 :			case load () of
310 :			NONE => compile (stat, sym, pids)
311 :			| SOME (bfc, ts) => let
312 :			val memo = { bfc = bfc,
313 :			ctxt = stat,
314 :			ts = ts }
315 :			in
316 :			if isValidMemo (memo, pids, i) then
317 :	blume	402	SOME memo
318 :	blume	398	else compile (stat, sym, pids)
319 :			end
320 :			end (* fromfile *)
321 :	blume	402	fun notglobal () =
322 :			case fromfile () of
323 :			NONE => NONE
324 :			| SOME memo =>
325 :			(globalstate :=
326 :			SmlInfoMap.insert (!globalstate, i,
327 :			memo);
328 :			SOME memo)
329 :	blume	398	in
330 :	blume	402	case SmlInfoMap.find (!globalstate, i) of
331 :			NONE => notglobal ()
332 :	blume	398	| SOME memo =>
333 :			if isValidMemo (memo, pids, i) then
334 :	blume	402	SOME memo
335 :			else notglobal ()
336 :	blume	398	end
337 :			end (* notlocal *)
338 :			in
339 :	blume	402	case SmlInfoMap.find (!localstate, i) of
340 :			SOME mopt => Option.map memo2ed mopt
341 :	blume	398	| NONE => let
342 :	blume	402	val mopt = notlocal ()
343 :	blume	398	in
344 :	blume	402	localstate :=
345 :			SmlInfoMap.insert (!localstate, i, mopt);
346 :			Option.map memo2ed mopt
347 :	blume	398	end
348 :			end (* snode *)
349 :
350 :			fun impexp gp (n, _) = fsbnode gp n
351 :	blume	399	in
352 :			{ sbnode = sbnode, impexp = impexp }
353 :			end
354 :	blume	398
355 :	blume	399	fun newTraversal (notify, GG.GROUP { exports, ... }) = let
356 :			val { impexp, ... } = mkTraversal notify
357 :			fun group gp = let
358 :			val k = #keep_going (#param gp)
359 :			fun loop ([], success) = success
360 :			| loop (h :: t, success) =
361 :			if isSome (impexp gp h) then loop (t, success)
362 :			else if k then loop (t, false) else false
363 :			val eo =
364 :			layerwork k (impexp gp) (SOME emptyEnv)
365 :			(SymbolMap.listItems exports)
366 :			in
367 :			case eo of
368 :			NONE => NONE
369 :			| SOME e => SOME (#envs e ())
370 :			end
371 :			fun mkExport ie gp =
372 :			case impexp gp ie of
373 :			NONE => NONE
374 :			| SOME e => SOME (#envs e ())
375 :	blume	398	in
376 :	blume	399	{ group = group,
377 :			exports = SymbolMap.map mkExport exports }
378 :	blume	398	end
379 :
380 :	blume	400	fun newSbnodeTraversal () = let
381 :			val { sbnode, ... } = mkTraversal (fn _ => fn _ => ())
382 :	blume	399	fun envdelta2ed { ii, bfc, ctxt } = { ii = ii, ctxt = ctxt () }
383 :	blume	398	in
384 :	blume	399	fn gp => fn n => Option.map envdelta2ed (sbnode gp n)
385 :	blume	398	end
386 :
387 :			local
388 :	blume	402	fun get i = valOf (SmlInfoMap.find (!globalstate, i))
389 :	blume	398	in
390 :			fun sizeBFC i = BF.size { content = #bfc (get i), nopickle = true }
391 :			fun writeBFC s i = BF.write { content = #bfc (get i),
392 :			stream = s, nopickle = true }
393 :			fun getII i = memo2ii (get i)
394 :	blume	400	fun getBFC i = #bfc (get i)
395 :
396 :			fun evict i =
397 :	blume	402	(globalstate := #1 (SmlInfoMap.remove (!globalstate, i)))
398 :	blume	400	handle LibBase.NotFound => ()
399 :	blume	402
400 :			fun evictAll () = globalstate := SmlInfoMap.empty
401 :	blume	398	end
402 :			end
403 :			end

---

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