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 462 - (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 : blume 460 type ed = IInfo.info
23 : blume 398 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 448 functor CompileFn (structure MachDepVC : MACHDEP_VC
50 :     val compile_there : SrcPath.t -> bool) :>
51 : blume 400 COMPILE where type bfc = MachDepVC.Binfile.bfContent =
52 :     struct
53 : blume 398
54 : blume 400 type notifier = GP.info -> SmlInfo.info -> unit
55 : blume 399
56 : blume 398 structure BF = MachDepVC.Binfile
57 :    
58 :     type bfc = BF.bfContent
59 :    
60 : blume 403 type bfcReceiver = SmlInfo.info * bfc -> unit
61 :    
62 : blume 447 structure FilterMap = MapFn
63 : blume 398 (struct
64 :     type ord_key = pid * SymbolSet.set
65 :     fun compare ((u, f), (u', f')) =
66 :     case Pid.compare (u, u') of
67 :     EQUAL => SymbolSet.compare (f, f')
68 :     | unequal => unequal
69 :     end)
70 :    
71 : blume 403 type bfinfo =
72 :     { cmdata: PidSet.set,
73 :     statenv: unit -> statenv,
74 :     symenv: unit -> symenv,
75 :     statpid: pid,
76 :     sympid: pid }
77 :    
78 : blume 399 type env = { envs: unit -> result, pids: PidSet.set }
79 : blume 460 type envdelta = IInfo.info
80 : blume 398
81 : blume 460 type memo = { ii: IInfo.info, 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 460 fun memo2ed memo = memo2ii memo
101 : blume 398
102 : blume 460 fun bfc2memo (bfc, ts) = let
103 : blume 403 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 : blume 460 { ii = ii, ts = ts, cmdata = cmdata }
110 : blume 403 end
111 :    
112 : blume 398 fun pidset (p1, p2) = PidSet.add (PidSet.singleton p1, p2)
113 :    
114 :     fun nofilter (ed: envdelta) = let
115 : blume 460 val { statenv, symenv, statpid, sympid } = ed
116 : blume 398 in
117 : blume 461 { envs = fn () => { stat = #env (statenv ()), sym = symenv () },
118 : blume 398 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 460 fun filter (ii, s) = let
125 : blume 398 val { statenv, symenv, statpid, sympid } = ii
126 : blume 461 val { env = ste, ctxt } = statenv ()
127 : blume 398 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 : blume 460 (* We re-pickle the filtered ste relative to
139 :     * the original one. This should give a fairly
140 :     * minimal pickle. *)
141 : blume 461 val statpid' = GenericVC.Rehash.rehash
142 :     { context = ctxt,
143 :     env = GenericVC.CoerceEnv.es2bs ste',
144 :     orig_hash = statpid }
145 : blume 398 in
146 :     filtermap :=
147 :     FilterMap.insert (!filtermap, key, statpid');
148 :     statpid'
149 :     end
150 :     in
151 :     { envs = fn () => { stat = ste', sym = symenv () },
152 :     pids = pidset (statpid', sympid) }
153 :     end
154 :     end
155 :    
156 : blume 399 local
157 : blume 398 fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,
158 :     dynamic = DE.empty }
159 :     fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }
160 :     in
161 : blume 399 (* This is a bit ugly because somehow we need to mix dummy
162 :     * dynamic envs into the equation just to be able to use
163 :     * concatEnv. But, alas', that's life... *)
164 :     fun rlayer (r, r') = e2r (E.concatEnv (r2e r, r2e r'))
165 :    
166 :     val emptyEnv =
167 :     { envs = fn () => e2r E.emptyEnv, pids = PidSet.empty }
168 : blume 398 end
169 :    
170 :     fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =
171 :     { envs = fn () => rlayer (e (), e' ()),
172 :     pids = PidSet.union (p, p') }
173 :    
174 : blume 462 (* I would rather not use an exception here, but short of a better
175 :     * implementation of concurrency I see no choice.
176 :     * The problem is that at each node we sequentiallay wait for the
177 :     * children nodes. But the scheduler might (and probably will)
178 :     * let a child run that we are not currently waiting for, so an
179 :     * error there will not result in "wait" to immediately return
180 :     * as it should for clean error recovery.
181 :     * Using the exception avoids having to implement a
182 :     * "wait for any child -- whichever finishes first" kind of call. *)
183 :     exception Abort
184 : blume 399
185 : blume 462 fun layer'wait u (p, NONE) =
186 :     (ignore (Concur.waitU u p); NONE)
187 :     | layer'wait u (p, SOME e) =
188 :     (case Concur.waitU u p of
189 :     SOME e' => SOME (layer (e', e))
190 :     | NONE => NONE)
191 :    
192 : blume 454 fun mkTraversal (notify, storeBFC, getUrgency) = let
193 : blume 402 val localstate = ref SmlInfoMap.empty
194 : blume 398
195 :     fun pervenv (gp: GP.info) = let
196 :     val e = #pervasive (#param gp)
197 :     val ste = E.staticPart e
198 :     val sye = E.symbolicPart e
199 :     in
200 :     { envs = fn () => { stat = ste, sym = sye },
201 :     pids = PidSet.empty }
202 :     end
203 :    
204 :     fun sbnode gp n =
205 :     case n of
206 :     DG.SB_BNODE (_, ii) =>
207 :     (* The beauty of this scheme is that we don't have
208 :     * to do anything at all for SB_BNODEs: Everything
209 :     * is prepared ready to be used when the library
210 : blume 460 * is unpickled. *)
211 :     SOME ii
212 : blume 432 | DG.SB_SNODE n =>
213 :     (case snode gp n of
214 :     NONE => NONE
215 : blume 460 | SOME ii => SOME ii)
216 : blume 398
217 :     and fsbnode gp (f, n) =
218 :     case (sbnode gp n, f) of
219 :     (NONE, _) => NONE
220 :     | (SOME d, NONE) => SOME (nofilter d)
221 :     | (SOME d, SOME s) => SOME (filter (d, s))
222 :    
223 :     and snode gp (DG.SNODE n) = let
224 :     val { smlinfo = i, localimports = li, globalimports = gi } = n
225 :     val binname = SmlInfo.binname i
226 :    
227 : blume 462 fun fail () =
228 :     if #keep_going (#param gp) then NONE else raise Abort
229 :    
230 : blume 448 fun compile_here (stat, sym, pids) = let
231 : blume 398 fun save bfc = let
232 :     fun writer s =
233 :     (BF.write { stream = s, content = bfc,
234 :     nopickle = false };
235 :     Say.vsay ["[wrote ", binname, "]\n"])
236 : blume 459 fun cleanup _ =
237 : blume 398 OS.FileSys.remove binname handle _ => ()
238 :     in
239 : blume 400 notify gp i;
240 : blume 398 SafeIO.perform { openIt =
241 :     fn () => AutoDir.openBinOut binname,
242 :     closeIt = BinIO.closeOut,
243 :     work = writer,
244 :     cleanup = cleanup }
245 :     handle exn => let
246 :     fun ppb pps =
247 :     (PP.add_newline pps;
248 :     PP.add_string pps (General.exnMessage exn))
249 :     in
250 :     SmlInfo.error gp i EM.WARN
251 :     ("failed to write " ^ binname) ppb
252 :     end;
253 :     TStamp.setTime (binname, SmlInfo.lastseen i)
254 :     end (* save *)
255 :     in
256 :     case SmlInfo.parsetree gp i of
257 : blume 462 NONE => fail ()
258 : blume 398 | SOME (ast, source) => let
259 :     val corenv = #corenv (#param gp)
260 :     val cmData = PidSet.listItems pids
261 :     (* clear error flag (could still be set from
262 :     * earlier run) *)
263 :     val _ = #anyErrors source := false
264 :     val bfc = BF.create { runtimePid = NONE,
265 :     splitting = SmlInfo.split i,
266 :     cmData = cmData,
267 :     ast = ast,
268 :     source = source,
269 :     senv = stat,
270 :     symenv = sym,
271 :     corenv = corenv }
272 : blume 460 val memo = bfc2memo (bfc, SmlInfo.lastseen i)
273 : blume 398 in
274 :     save bfc;
275 : blume 403 storeBFC (i, bfc);
276 : blume 402 SOME memo
277 : blume 462 end handle _ => fail () (* catch elaborator exn *)
278 : blume 448 end (* compile_here *)
279 : blume 398 fun notlocal () = let
280 : blume 454 val urgency = getUrgency i
281 : blume 402 (* Ok, it is not in the local state, so we first have
282 : blume 398 * to traverse all children before we can proceed... *)
283 :     fun loc li_n = Option.map nofilter (snode gp li_n)
284 :     fun glob gi_n = fsbnode gp gi_n
285 : blume 448 val gi_cl =
286 :     map (fn gi_n => Concur.fork (fn () => glob gi_n)) gi
287 :     val li_cl =
288 :     map (fn li_n => Concur.fork (fn () => loc li_n)) li
289 : blume 398 val e =
290 : blume 462 foldl (layer'wait urgency)
291 :     (foldl (layer'wait urgency)
292 :     (SOME (pervenv gp))
293 :     gi_cl)
294 :     li_cl
295 : blume 398 in
296 :     case e of
297 :     NONE => NONE
298 :     | SOME { envs, pids } => let
299 :     (* We have successfully traversed all
300 :     * children. Now it is time to check the
301 :     * global map... *)
302 :     fun fromfile () = let
303 :     val { stat, sym } = envs ()
304 :     fun load () = let
305 :     val ts = TStamp.fmodTime binname
306 :     fun openIt () = BinIO.openIn binname
307 :     fun reader s =
308 :     (BF.read { stream = s,
309 :     name = binname,
310 :     senv = stat },
311 :     ts)
312 : blume 403
313 : blume 398 in
314 :     SOME (SafeIO.perform
315 :     { openIt = openIt,
316 :     closeIt = BinIO.closeIn,
317 :     work = reader,
318 : blume 459 cleanup = fn _ => () })
319 : blume 398 handle _ => NONE
320 :     end (* load *)
321 : blume 448 fun tryload (what, otherwise) =
322 :     case load () of
323 :     NONE => otherwise ()
324 :     | SOME (bfc, ts) => let
325 : blume 460 val memo = bfc2memo (bfc, ts)
326 : blume 448 in
327 :     if isValidMemo (memo, pids, i) then
328 :     (Say.vsay ["[", binname,
329 :     " ", what, "]\n"];
330 :     storeBFC (i, bfc);
331 :     SOME memo)
332 :     else otherwise ()
333 :     end
334 :     fun compile_again () =
335 : blume 452 (Say.vsay ["[compiling ",
336 :     SmlInfo.descr i, "]\n"];
337 :     compile_here (stat, sym, pids))
338 : blume 448 fun compile () = let
339 :     val sp = SmlInfo.sourcepath i
340 :     in
341 :     if compile_there sp then
342 : blume 450 tryload ("received", compile_again)
343 : blume 448 else compile_again ()
344 :     end
345 : blume 398 in
346 : blume 448 (* If anything goes wrong loading the first
347 :     * time, we go and compile. Compiling
348 :     * may mean compiling externally, and if so,
349 :     * we must load the result of that.
350 :     * If the second load also goes wrong, we
351 :     * compile locally to gather error messages
352 :     * and make everything look "normal". *)
353 :     tryload ("loaded", compile)
354 : blume 398 end (* fromfile *)
355 : blume 402 fun notglobal () =
356 :     case fromfile () of
357 :     NONE => NONE
358 :     | SOME memo =>
359 :     (globalstate :=
360 :     SmlInfoMap.insert (!globalstate, i,
361 :     memo);
362 :     SOME memo)
363 : blume 398 in
364 : blume 402 case SmlInfoMap.find (!globalstate, i) of
365 :     NONE => notglobal ()
366 : blume 398 | SOME memo =>
367 :     if isValidMemo (memo, pids, i) then
368 : blume 402 SOME memo
369 :     else notglobal ()
370 : blume 398 end
371 :     end (* notlocal *)
372 :     in
373 : blume 462 (* Here we just wait (no "waitU") so we don't get
374 :     * priority over threads that may have to clean up after
375 :     * errors. *)
376 : blume 402 case SmlInfoMap.find (!localstate, i) of
377 : blume 448 SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)
378 : blume 398 | NONE => let
379 : blume 448 val mopt_c = Concur.fork
380 :     (fn () => notlocal () before
381 :     (* "Not local" means that we have not processed
382 :     * this file before. Therefore, we should now
383 :     * remove its parse tree... *)
384 :     SmlInfo.forgetParsetree i)
385 : blume 398 in
386 : blume 402 localstate :=
387 : blume 448 SmlInfoMap.insert (!localstate, i, mopt_c);
388 :     Option.map memo2ed (Concur.wait mopt_c)
389 : blume 398 end
390 :     end (* snode *)
391 :    
392 :     fun impexp gp (n, _) = fsbnode gp n
393 : blume 399 in
394 :     { sbnode = sbnode, impexp = impexp }
395 :     end
396 : blume 398
397 : blume 454 fun newTraversal (notify, storeBFC, g) = let
398 :     val GG.GROUP { exports, ... } = g
399 :     val um = Indegree.indegrees g
400 :     fun getUrgency i = getOpt (SmlInfoMap.find (um, i), 0)
401 :     val { impexp, ... } = mkTraversal (notify, storeBFC, getUrgency)
402 : blume 399 fun group gp = let
403 : blume 448 val eo_cl =
404 :     map (fn x => Concur.fork (fn () => impexp gp x))
405 :     (SymbolMap.listItems exports)
406 : blume 462 val eo = foldl (layer'wait 0) (SOME emptyEnv) eo_cl
407 : blume 399 in
408 :     case eo of
409 : blume 461 NONE => (Servers.reset false; NONE)
410 : blume 399 | SOME e => SOME (#envs e ())
411 : blume 462 end handle Abort => (Servers.reset false; NONE)
412 : blume 399 fun mkExport ie gp =
413 : blume 462 case impexp gp ie handle Abort => NONE of
414 : blume 461 NONE => (Servers.reset false; NONE)
415 : blume 399 | SOME e => SOME (#envs e ())
416 : blume 398 in
417 : blume 399 { group = group,
418 :     exports = SymbolMap.map mkExport exports }
419 : blume 398 end
420 :    
421 : blume 400 fun newSbnodeTraversal () = let
422 : blume 403 val { sbnode, ... } = mkTraversal (fn _ => fn _ => (),
423 : blume 454 fn _ => (),
424 :     fn _ => 0)
425 : blume 461 fun sbn_trav gp g = let
426 : blume 462 val r = sbnode gp g handle Abort => NONE
427 : blume 461 in
428 :     if isSome r then () else Servers.reset false;
429 :     r
430 :     end
431 : blume 398 in
432 : blume 461 sbn_trav
433 : blume 398 end
434 :    
435 : blume 403 fun evict i =
436 :     (globalstate := #1 (SmlInfoMap.remove (!globalstate, i)))
437 :     handle LibBase.NotFound => ()
438 : blume 400
439 : blume 403 fun evictAll () = globalstate := SmlInfoMap.empty
440 : blume 402
441 : blume 403 fun getII i = memo2ii (valOf (SmlInfoMap.find (!globalstate, i)))
442 : blume 398 end
443 :     end

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