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 735 - (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 : blume 587 structure SE = GenericVC.StaticEnv
14 : blume 398 structure Pid = GenericVC.PersStamps
15 :     structure DE = GenericVC.DynamicEnv
16 :     structure PP = PrettyPrint
17 :     structure EM = GenericVC.ErrorMsg
18 :    
19 :     type pid = Pid.persstamp
20 :     type statenv = E.staticEnv
21 :     type symenv = E.symenv
22 :     type result = { stat: statenv, sym: symenv }
23 : blume 460 type ed = IInfo.info
24 : blume 398 in
25 :     signature COMPILE = sig
26 : blume 402
27 : blume 400 type bfc
28 :    
29 : blume 398 (* reset internal persistent state *)
30 :     val reset : unit -> unit
31 : blume 399
32 :     (* notify linkage module about recompilation *)
33 : blume 400 type notifier = GP.info -> SmlInfo.info -> unit
34 : blume 399
35 : blume 403 (* type of a function to store away the binfile contents *)
36 :     type bfcReceiver = SmlInfo.info * bfc -> unit
37 :    
38 : blume 398 val getII : SmlInfo.info -> IInfo.info
39 : blume 399
40 : blume 537 val evictStale : unit -> unit
41 : blume 402 val evictAll : unit -> unit
42 : blume 399
43 : blume 400 val newSbnodeTraversal : unit -> GP.info -> DG.sbnode -> ed option
44 :    
45 : blume 403 val newTraversal : notifier * bfcReceiver * GG.group ->
46 : blume 399 { group: GP.info -> result option,
47 :     exports: (GP.info -> result option) SymbolMap.map }
48 : blume 398 end
49 :    
50 : blume 448 functor CompileFn (structure MachDepVC : MACHDEP_VC
51 : blume 588 structure StabModmap : STAB_MODMAP
52 : blume 677 val useStream : TextIO.instream -> unit
53 : blume 666 val compile_there : SrcPath.file -> bool) :>
54 : blume 400 COMPILE where type bfc = MachDepVC.Binfile.bfContent =
55 :     struct
56 : blume 398
57 : blume 400 type notifier = GP.info -> SmlInfo.info -> unit
58 : blume 399
59 : blume 398 structure BF = MachDepVC.Binfile
60 :    
61 :     type bfc = BF.bfContent
62 :    
63 : blume 403 type bfcReceiver = SmlInfo.info * bfc -> unit
64 :    
65 : blume 447 structure FilterMap = MapFn
66 : blume 398 (struct
67 :     type ord_key = pid * SymbolSet.set
68 :     fun compare ((u, f), (u', f')) =
69 :     case Pid.compare (u, u') of
70 :     EQUAL => SymbolSet.compare (f, f')
71 :     | unequal => unequal
72 :     end)
73 :    
74 : blume 403 type bfinfo =
75 :     { cmdata: PidSet.set,
76 :     statenv: unit -> statenv,
77 :     symenv: unit -> symenv,
78 :     statpid: pid,
79 :     sympid: pid }
80 :    
81 : blume 399 type env = { envs: unit -> result, pids: PidSet.set }
82 : blume 460 type envdelta = IInfo.info
83 : blume 398
84 : blume 460 type memo = { ii: IInfo.info, ts: TStamp.t, cmdata: PidSet.set }
85 : blume 398
86 :     (* persistent state! *)
87 :     val filtermap = ref (FilterMap.empty: pid FilterMap.map)
88 :    
89 :     (* more persistent state! *)
90 : blume 402 val globalstate = ref (SmlInfoMap.empty: memo SmlInfoMap.map)
91 : blume 398
92 :     fun reset () =
93 :     (filtermap := FilterMap.empty;
94 : blume 402 globalstate := SmlInfoMap.empty)
95 : blume 398
96 :     fun isValidMemo (memo: memo, provided, smlinfo) =
97 :     not (TStamp.needsUpdate { source = SmlInfo.lastseen smlinfo,
98 :     target = #ts memo })
99 : blume 403 andalso PidSet.equal (provided, #cmdata memo)
100 : blume 398
101 : blume 587 fun memo2ii (memo: memo) = #ii memo
102 : blume 398
103 : blume 460 fun memo2ed memo = memo2ii memo
104 : blume 398
105 : blume 460 fun bfc2memo (bfc, ts) = let
106 : blume 403 val ii = { statenv = fn () => BF.senvOf bfc,
107 :     symenv = fn () => BF.symenvOf bfc,
108 :     statpid = BF.staticPidOf bfc,
109 :     sympid = BF.lambdaPidOf bfc }
110 :     val cmdata = PidSet.addList (PidSet.empty, BF.cmDataOf bfc)
111 :     in
112 : blume 460 { ii = ii, ts = ts, cmdata = cmdata }
113 : blume 403 end
114 :    
115 : blume 398 fun pidset (p1, p2) = PidSet.add (PidSet.singleton p1, p2)
116 :    
117 :     fun nofilter (ed: envdelta) = let
118 : blume 460 val { statenv, symenv, statpid, sympid } = ed
119 : blume 587 val statenv' = Memoize.memoize statenv
120 : blume 398 in
121 : blume 587 { envs = fn () => { stat = statenv' (), sym = symenv () },
122 : blume 398 pids = pidset (statpid, sympid) }
123 :     end
124 :    
125 : blume 735 fun requiredFiltering set se = let
126 :     val dom = SymbolSet.addList (SymbolSet.empty, E.catalogEnv se)
127 :     val filt = SymbolSet.intersection (set, dom)
128 :     in
129 :     if SymbolSet.equal (dom, filt) then NONE
130 :     else SOME filt
131 :     end
132 : blume 398
133 : blume 460 fun filter (ii, s) = let
134 : blume 398 val { statenv, symenv, statpid, sympid } = ii
135 : blume 587 val ste = statenv ()
136 : blume 398 in
137 : blume 735 case requiredFiltering s ste of
138 :     NONE => { envs = fn () => { stat = ste, sym = symenv () },
139 :     pids = pidset (statpid, sympid) }
140 :     | SOME s => let
141 : blume 587 val ste' = E.filterStaticEnv (ste, SymbolSet.listItems s)
142 :     val key = (statpid, s)
143 :     val statpid' =
144 :     case FilterMap.find (!filtermap, key) of
145 :     SOME statpid' => statpid'
146 :     | NONE => let
147 :     val statpid' = GenericVC.Rehash.rehash
148 :     { env = ste', orig_hash = statpid }
149 :     in
150 :     filtermap :=
151 :     FilterMap.insert (!filtermap, key, statpid');
152 :     statpid'
153 :     end
154 :     in
155 :     { envs = fn () => { stat = ste', sym = symenv () },
156 :     pids = pidset (statpid', sympid) }
157 :     end
158 : blume 398 end
159 :    
160 : blume 399 local
161 : blume 398 fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,
162 :     dynamic = DE.empty }
163 :     fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }
164 :     in
165 : blume 399 (* This is a bit ugly because somehow we need to mix dummy
166 :     * dynamic envs into the equation just to be able to use
167 :     * concatEnv. But, alas', that's life... *)
168 :     fun rlayer (r, r') = e2r (E.concatEnv (r2e r, r2e r'))
169 :    
170 :     val emptyEnv =
171 :     { envs = fn () => e2r E.emptyEnv, pids = PidSet.empty }
172 : blume 398 end
173 :    
174 :     fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =
175 :     { envs = fn () => rlayer (e (), e' ()),
176 :     pids = PidSet.union (p, p') }
177 :    
178 : blume 462 (* I would rather not use an exception here, but short of a better
179 :     * implementation of concurrency I see no choice.
180 :     * The problem is that at each node we sequentiallay wait for the
181 :     * children nodes. But the scheduler might (and probably will)
182 :     * let a child run that we are not currently waiting for, so an
183 :     * error there will not result in "wait" to immediately return
184 :     * as it should for clean error recovery.
185 :     * Using the exception avoids having to implement a
186 :     * "wait for any child -- whichever finishes first" kind of call. *)
187 :     exception Abort
188 : blume 399
189 : blume 462 fun layer'wait u (p, NONE) =
190 :     (ignore (Concur.waitU u p); NONE)
191 :     | layer'wait u (p, SOME e) =
192 :     (case Concur.waitU u p of
193 :     SOME e' => SOME (layer (e', e))
194 :     | NONE => NONE)
195 :    
196 : blume 454 fun mkTraversal (notify, storeBFC, getUrgency) = let
197 : blume 402 val localstate = ref SmlInfoMap.empty
198 : blume 398
199 : blume 537 fun sbnode gp (DG.SB_SNODE n) = snode gp n
200 :     (* The beauty of this scheme is that we don't have
201 :     * to do anything at all for SB_BNODEs: Everything
202 :     * is prepared ready to be used when the library
203 :     * is unpickled: *)
204 :     | sbnode gp (DG.SB_BNODE (_, ii)) = SOME ii
205 : blume 398
206 :     and fsbnode gp (f, n) =
207 :     case (sbnode gp n, f) of
208 :     (NONE, _) => NONE
209 :     | (SOME d, NONE) => SOME (nofilter d)
210 :     | (SOME d, SOME s) => SOME (filter (d, s))
211 :    
212 :     and snode gp (DG.SNODE n) = let
213 : blume 692 val youngest = #youngest gp
214 : blume 398 val { smlinfo = i, localimports = li, globalimports = gi } = n
215 :     val binname = SmlInfo.binname i
216 :    
217 : blume 462 fun fail () =
218 :     if #keep_going (#param gp) then NONE else raise Abort
219 :    
220 : blume 537 fun compile_here (stat, sym, pids, split) = let
221 : blume 677 fun perform_setup _ NONE = ()
222 :     | perform_setup what (SOME code) =
223 :     (Say.vsay ["[setup (", what, "): ", code, "]\n"];
224 :     SafeIO.perform
225 :     { openIt = fn () => TextIO.openString code,
226 :     closeIt = TextIO.closeIn,
227 :     work = useStream,
228 :     cleanup = fn _ => () })
229 : blume 398 fun save bfc = let
230 :     fun writer s =
231 :     (BF.write { stream = s, content = bfc,
232 :     nopickle = false };
233 :     Say.vsay ["[wrote ", binname, "]\n"])
234 : blume 459 fun cleanup _ =
235 : blume 398 OS.FileSys.remove binname handle _ => ()
236 :     in
237 : blume 400 notify gp i;
238 : blume 398 SafeIO.perform { openIt =
239 :     fn () => AutoDir.openBinOut binname,
240 :     closeIt = BinIO.closeOut,
241 :     work = writer,
242 :     cleanup = cleanup }
243 :     handle exn => let
244 :     fun ppb pps =
245 :     (PP.add_newline pps;
246 :     PP.add_string pps (General.exnMessage exn))
247 :     in
248 :     SmlInfo.error gp i EM.WARN
249 :     ("failed to write " ^ binname) ppb
250 :     end;
251 :     TStamp.setTime (binname, SmlInfo.lastseen i)
252 :     end (* save *)
253 :     in
254 :     case SmlInfo.parsetree gp i of
255 : blume 462 NONE => fail ()
256 : blume 398 | SOME (ast, source) => let
257 : blume 592 val ast =
258 :     case #explicit_core_sym (SmlInfo.attribs i) of
259 :     NONE => ast
260 :     | SOME sy => CoreHack.rewrite (ast, sy)
261 : blume 398 val cmData = PidSet.listItems pids
262 : blume 677 val (pre, post) = SmlInfo.setup i
263 :     val toplenv = #get GenericVC.EnvRef.topLevel ()
264 :     before perform_setup "pre" pre
265 : blume 398 (* clear error flag (could still be set from
266 :     * earlier run) *)
267 :     val _ = #anyErrors source := false
268 : blume 537 val bfc = BF.create
269 : blume 587 { splitting = split,
270 : blume 537 cmData = cmData,
271 :     ast = ast,
272 :     source = source,
273 :     senv = stat,
274 : blume 592 symenv = sym }
275 : blume 460 val memo = bfc2memo (bfc, SmlInfo.lastseen i)
276 : blume 398 in
277 : blume 677 perform_setup "post" post;
278 :     #set GenericVC.EnvRef.topLevel toplenv;
279 : blume 398 save bfc;
280 : blume 403 storeBFC (i, bfc);
281 : blume 402 SOME memo
282 : blume 462 end handle _ => fail () (* catch elaborator exn *)
283 : blume 448 end (* compile_here *)
284 : blume 398 fun notlocal () = let
285 : blume 692 val _ = youngest := TStamp.max (!youngest,
286 :     SmlInfo.lastseen i)
287 : blume 454 val urgency = getUrgency i
288 : blume 402 (* Ok, it is not in the local state, so we first have
289 : blume 398 * to traverse all children before we can proceed... *)
290 :     fun loc li_n = Option.map nofilter (snode gp li_n)
291 :     fun glob gi_n = fsbnode gp gi_n
292 : blume 448 val gi_cl =
293 :     map (fn gi_n => Concur.fork (fn () => glob gi_n)) gi
294 :     val li_cl =
295 :     map (fn li_n => Concur.fork (fn () => loc li_n)) li
296 : blume 398 val e =
297 : blume 462 foldl (layer'wait urgency)
298 :     (foldl (layer'wait urgency)
299 : blume 537 (SOME emptyEnv)
300 : blume 462 gi_cl)
301 :     li_cl
302 : blume 398 in
303 :     case e of
304 :     NONE => NONE
305 :     | SOME { envs, pids } => let
306 :     (* We have successfully traversed all
307 :     * children. Now it is time to check the
308 :     * global map... *)
309 :     fun fromfile () = let
310 :     val { stat, sym } = envs ()
311 : blume 537 val { split, extra_compenv, ... } =
312 :     SmlInfo.attribs i
313 :     val stat =
314 :     case extra_compenv of
315 :     NONE => stat
316 :     | SOME s => E.layerStatic (stat, s)
317 : blume 398 fun load () = let
318 :     val ts = TStamp.fmodTime binname
319 :     fun openIt () = BinIO.openIn binname
320 : blume 588 fun reader s = let
321 :     val mm0 = StabModmap.get ()
322 :     val m = GenModIdMap.mkMap' (stat, mm0)
323 :     in
324 : blume 398 (BF.read { stream = s,
325 :     name = binname,
326 : blume 588 modmap = m },
327 : blume 398 ts)
328 : blume 588 end
329 : blume 403
330 : blume 398 in
331 :     SOME (SafeIO.perform
332 :     { openIt = openIt,
333 :     closeIt = BinIO.closeIn,
334 :     work = reader,
335 : blume 459 cleanup = fn _ => () })
336 : blume 398 handle _ => NONE
337 :     end (* load *)
338 : blume 448 fun tryload (what, otherwise) =
339 :     case load () of
340 :     NONE => otherwise ()
341 :     | SOME (bfc, ts) => let
342 : blume 460 val memo = bfc2memo (bfc, ts)
343 : blume 448 in
344 :     if isValidMemo (memo, pids, i) then
345 :     (Say.vsay ["[", binname,
346 :     " ", what, "]\n"];
347 :     storeBFC (i, bfc);
348 :     SOME memo)
349 :     else otherwise ()
350 :     end
351 : blume 632 fun bottleneck () =
352 :     (* Are we the only runable task? *)
353 :     Servers.allIdle () andalso
354 :     Concur.noTasks ()
355 : blume 448 fun compile_again () =
356 : blume 452 (Say.vsay ["[compiling ",
357 :     SmlInfo.descr i, "]\n"];
358 : blume 537 compile_here (stat, sym, pids, split))
359 : blume 632 fun compile_there' p =
360 :     not (bottleneck ()) andalso
361 :     compile_there p
362 : blume 448 fun compile () = let
363 :     val sp = SmlInfo.sourcepath i
364 :     in
365 : blume 692 youngest := TStamp.NOTSTAMP;
366 : blume 632 if compile_there' sp then
367 : blume 450 tryload ("received", compile_again)
368 : blume 448 else compile_again ()
369 :     end
370 : blume 398 in
371 : blume 448 (* If anything goes wrong loading the first
372 :     * time, we go and compile. Compiling
373 :     * may mean compiling externally, and if so,
374 :     * we must load the result of that.
375 :     * If the second load also goes wrong, we
376 :     * compile locally to gather error messages
377 :     * and make everything look "normal". *)
378 :     tryload ("loaded", compile)
379 : blume 398 end (* fromfile *)
380 : blume 402 fun notglobal () =
381 :     case fromfile () of
382 :     NONE => NONE
383 :     | SOME memo =>
384 :     (globalstate :=
385 :     SmlInfoMap.insert (!globalstate, i,
386 :     memo);
387 :     SOME memo)
388 : blume 398 in
389 : blume 402 case SmlInfoMap.find (!globalstate, i) of
390 :     NONE => notglobal ()
391 : blume 398 | SOME memo =>
392 :     if isValidMemo (memo, pids, i) then
393 : blume 402 SOME memo
394 :     else notglobal ()
395 : blume 398 end
396 :     end (* notlocal *)
397 :     in
398 : blume 462 (* Here we just wait (no "waitU") so we don't get
399 :     * priority over threads that may have to clean up after
400 :     * errors. *)
401 : blume 402 case SmlInfoMap.find (!localstate, i) of
402 : blume 448 SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)
403 : blume 398 | NONE => let
404 : blume 448 val mopt_c = Concur.fork
405 :     (fn () => notlocal () before
406 :     (* "Not local" means that we have not processed
407 :     * this file before. Therefore, we should now
408 :     * remove its parse tree... *)
409 :     SmlInfo.forgetParsetree i)
410 : blume 398 in
411 : blume 402 localstate :=
412 : blume 632 SmlInfoMap.insert (!localstate, i, mopt_c);
413 : blume 448 Option.map memo2ed (Concur.wait mopt_c)
414 : blume 398 end
415 :     end (* snode *)
416 :    
417 : blume 652 fun impexp gp (nth, _, _) = fsbnode gp (nth ())
418 : blume 399 in
419 :     { sbnode = sbnode, impexp = impexp }
420 :     end
421 : blume 398
422 : blume 587 fun newTraversal (_, _, GG.ERRORGROUP) =
423 :     { group = fn _ => NONE, exports = SymbolMap.empty }
424 :     | newTraversal (notify, storeBFC, g as GG.GROUP grec) = let
425 :     val { exports, ... } = grec
426 : blume 652 val um = Memoize.memoize (fn () => Indegree.indegrees g)
427 :     fun getUrgency i = getOpt (SmlInfoMap.find (um (), i), 0)
428 :     (* generate the traversal -- lazily *)
429 :     val impexpth =
430 :     Memoize.memoize
431 :     (fn () =>
432 :     #impexp
433 :     (mkTraversal (notify, storeBFC, getUrgency)))
434 : blume 587 fun group gp = let
435 :     val eo_cl =
436 : blume 652 map (fn x => Concur.fork (fn () => impexpth () gp x))
437 : blume 587 (SymbolMap.listItems exports)
438 :     val eo = foldl (layer'wait 0) (SOME emptyEnv) eo_cl
439 :     in
440 :     case eo of
441 :     NONE => (Servers.reset false; NONE)
442 :     | SOME e => SOME (#envs e ())
443 :     end handle Abort => (Servers.reset false; NONE)
444 :     fun mkExport ie gp =
445 : blume 652 case impexpth () gp ie handle Abort => NONE of
446 : blume 587 NONE => (Servers.reset false; NONE)
447 :     | SOME e => SOME (#envs e ())
448 : blume 399 in
449 : blume 587 { group = group,
450 :     exports = SymbolMap.map mkExport exports }
451 :     end
452 : blume 398
453 : blume 400 fun newSbnodeTraversal () = let
454 : blume 537 val { sbnode, ... } =
455 :     mkTraversal (fn _ => fn _ => (), fn _ => (), fn _ => 0)
456 : blume 461 fun sbn_trav gp g = let
457 : blume 462 val r = sbnode gp g handle Abort => NONE
458 : blume 461 in
459 :     if isSome r then () else Servers.reset false;
460 :     r
461 :     end
462 : blume 398 in
463 : blume 461 sbn_trav
464 : blume 398 end
465 :    
466 : blume 537 fun evictStale () =
467 :     globalstate :=
468 :     SmlInfoMap.filteri (SmlInfo.isKnown o #1) (!globalstate)
469 : blume 400
470 : blume 403 fun evictAll () = globalstate := SmlInfoMap.empty
471 : blume 402
472 : blume 403 fun getII i = memo2ii (valOf (SmlInfoMap.find (!globalstate, i)))
473 : blume 398 end
474 :     end

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