Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/compile/compile.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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