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

Parent Directory | Revision Log

---

Revision 400 - (view) (download)

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

---

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