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 677 - (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 :     fun exportsNothingBut set se =
126 :     List.all (fn sy => SymbolSet.member (set, sy)) (E.catalogEnv se)
127 :    
128 : blume 460 fun filter (ii, s) = let
129 : blume 398 val { statenv, symenv, statpid, sympid } = ii
130 : blume 587 val ste = statenv ()
131 : blume 398 in
132 :     if exportsNothingBut s ste then
133 :     { envs = fn () => { stat = ste, sym = symenv () },
134 :     pids = pidset (statpid, sympid) }
135 :     else let
136 : blume 587 val ste' = E.filterStaticEnv (ste, SymbolSet.listItems s)
137 :     val key = (statpid, s)
138 :     val statpid' =
139 :     case FilterMap.find (!filtermap, key) of
140 :     SOME statpid' => statpid'
141 :     | NONE => let
142 :     val statpid' = GenericVC.Rehash.rehash
143 :     { env = ste', orig_hash = statpid }
144 :     in
145 :     filtermap :=
146 :     FilterMap.insert (!filtermap, key, statpid');
147 :     statpid'
148 :     end
149 :     in
150 :     { envs = fn () => { stat = ste', sym = symenv () },
151 :     pids = pidset (statpid', sympid) }
152 :     end
153 : blume 398 end
154 :    
155 : blume 399 local
156 : blume 398 fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,
157 :     dynamic = DE.empty }
158 :     fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }
159 :     in
160 : blume 399 (* This is a bit ugly because somehow we need to mix dummy
161 :     * dynamic envs into the equation just to be able to use
162 :     * concatEnv. But, alas', that's life... *)
163 :     fun rlayer (r, r') = e2r (E.concatEnv (r2e r, r2e r'))
164 :    
165 :     val emptyEnv =
166 :     { envs = fn () => e2r E.emptyEnv, pids = PidSet.empty }
167 : blume 398 end
168 :    
169 :     fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =
170 :     { envs = fn () => rlayer (e (), e' ()),
171 :     pids = PidSet.union (p, p') }
172 :    
173 : blume 462 (* I would rather not use an exception here, but short of a better
174 :     * implementation of concurrency I see no choice.
175 :     * The problem is that at each node we sequentiallay wait for the
176 :     * children nodes. But the scheduler might (and probably will)
177 :     * let a child run that we are not currently waiting for, so an
178 :     * error there will not result in "wait" to immediately return
179 :     * as it should for clean error recovery.
180 :     * Using the exception avoids having to implement a
181 :     * "wait for any child -- whichever finishes first" kind of call. *)
182 :     exception Abort
183 : blume 399
184 : blume 462 fun layer'wait u (p, NONE) =
185 :     (ignore (Concur.waitU u p); NONE)
186 :     | layer'wait u (p, SOME e) =
187 :     (case Concur.waitU u p of
188 :     SOME e' => SOME (layer (e', e))
189 :     | NONE => NONE)
190 :    
191 : blume 454 fun mkTraversal (notify, storeBFC, getUrgency) = let
192 : blume 402 val localstate = ref SmlInfoMap.empty
193 : blume 398
194 : blume 537 fun sbnode gp (DG.SB_SNODE n) = snode gp n
195 :     (* The beauty of this scheme is that we don't have
196 :     * to do anything at all for SB_BNODEs: Everything
197 :     * is prepared ready to be used when the library
198 :     * is unpickled: *)
199 :     | sbnode gp (DG.SB_BNODE (_, ii)) = SOME ii
200 : blume 398
201 :     and fsbnode gp (f, n) =
202 :     case (sbnode gp n, f) of
203 :     (NONE, _) => NONE
204 :     | (SOME d, NONE) => SOME (nofilter d)
205 :     | (SOME d, SOME s) => SOME (filter (d, s))
206 :    
207 :     and snode gp (DG.SNODE n) = let
208 :     val { smlinfo = i, localimports = li, globalimports = gi } = n
209 :     val binname = SmlInfo.binname i
210 :    
211 : blume 462 fun fail () =
212 :     if #keep_going (#param gp) then NONE else raise Abort
213 :    
214 : blume 537 fun compile_here (stat, sym, pids, split) = let
215 : blume 677 fun perform_setup _ NONE = ()
216 :     | perform_setup what (SOME code) =
217 :     (Say.vsay ["[setup (", what, "): ", code, "]\n"];
218 :     SafeIO.perform
219 :     { openIt = fn () => TextIO.openString code,
220 :     closeIt = TextIO.closeIn,
221 :     work = useStream,
222 :     cleanup = fn _ => () })
223 : blume 398 fun save bfc = let
224 :     fun writer s =
225 :     (BF.write { stream = s, content = bfc,
226 :     nopickle = false };
227 :     Say.vsay ["[wrote ", binname, "]\n"])
228 : blume 459 fun cleanup _ =
229 : blume 398 OS.FileSys.remove binname handle _ => ()
230 :     in
231 : blume 400 notify gp i;
232 : blume 398 SafeIO.perform { openIt =
233 :     fn () => AutoDir.openBinOut binname,
234 :     closeIt = BinIO.closeOut,
235 :     work = writer,
236 :     cleanup = cleanup }
237 :     handle exn => let
238 :     fun ppb pps =
239 :     (PP.add_newline pps;
240 :     PP.add_string pps (General.exnMessage exn))
241 :     in
242 :     SmlInfo.error gp i EM.WARN
243 :     ("failed to write " ^ binname) ppb
244 :     end;
245 :     TStamp.setTime (binname, SmlInfo.lastseen i)
246 :     end (* save *)
247 :     in
248 :     case SmlInfo.parsetree gp i of
249 : blume 462 NONE => fail ()
250 : blume 398 | SOME (ast, source) => let
251 : blume 592 val ast =
252 :     case #explicit_core_sym (SmlInfo.attribs i) of
253 :     NONE => ast
254 :     | SOME sy => CoreHack.rewrite (ast, sy)
255 : blume 398 val cmData = PidSet.listItems pids
256 : blume 677 val (pre, post) = SmlInfo.setup i
257 :     val toplenv = #get GenericVC.EnvRef.topLevel ()
258 :     before perform_setup "pre" pre
259 : blume 398 (* clear error flag (could still be set from
260 :     * earlier run) *)
261 :     val _ = #anyErrors source := false
262 : blume 537 val bfc = BF.create
263 : blume 587 { splitting = split,
264 : blume 537 cmData = cmData,
265 :     ast = ast,
266 :     source = source,
267 :     senv = stat,
268 : blume 592 symenv = sym }
269 : blume 460 val memo = bfc2memo (bfc, SmlInfo.lastseen i)
270 : blume 398 in
271 : blume 677 perform_setup "post" post;
272 :     #set GenericVC.EnvRef.topLevel toplenv;
273 : blume 398 save bfc;
274 : blume 403 storeBFC (i, bfc);
275 : blume 402 SOME memo
276 : blume 462 end handle _ => fail () (* catch elaborator exn *)
277 : blume 448 end (* compile_here *)
278 : blume 398 fun notlocal () = let
279 : blume 454 val urgency = getUrgency i
280 : blume 402 (* Ok, it is not in the local state, so we first have
281 : blume 398 * to traverse all children before we can proceed... *)
282 :     fun loc li_n = Option.map nofilter (snode gp li_n)
283 :     fun glob gi_n = fsbnode gp gi_n
284 : blume 448 val gi_cl =
285 :     map (fn gi_n => Concur.fork (fn () => glob gi_n)) gi
286 :     val li_cl =
287 :     map (fn li_n => Concur.fork (fn () => loc li_n)) li
288 : blume 398 val e =
289 : blume 462 foldl (layer'wait urgency)
290 :     (foldl (layer'wait urgency)
291 : blume 537 (SOME emptyEnv)
292 : blume 462 gi_cl)
293 :     li_cl
294 : blume 398 in
295 :     case e of
296 :     NONE => NONE
297 :     | SOME { envs, pids } => let
298 :     (* We have successfully traversed all
299 :     * children. Now it is time to check the
300 :     * global map... *)
301 :     fun fromfile () = let
302 :     val { stat, sym } = envs ()
303 : blume 537 val { split, extra_compenv, ... } =
304 :     SmlInfo.attribs i
305 :     val stat =
306 :     case extra_compenv of
307 :     NONE => stat
308 :     | SOME s => E.layerStatic (stat, s)
309 : blume 398 fun load () = let
310 :     val ts = TStamp.fmodTime binname
311 :     fun openIt () = BinIO.openIn binname
312 : blume 588 fun reader s = let
313 :     val mm0 = StabModmap.get ()
314 :     val m = GenModIdMap.mkMap' (stat, mm0)
315 :     in
316 : blume 398 (BF.read { stream = s,
317 :     name = binname,
318 : blume 588 modmap = m },
319 : blume 398 ts)
320 : blume 588 end
321 : blume 403
322 : blume 398 in
323 :     SOME (SafeIO.perform
324 :     { openIt = openIt,
325 :     closeIt = BinIO.closeIn,
326 :     work = reader,
327 : blume 459 cleanup = fn _ => () })
328 : blume 398 handle _ => NONE
329 :     end (* load *)
330 : blume 448 fun tryload (what, otherwise) =
331 :     case load () of
332 :     NONE => otherwise ()
333 :     | SOME (bfc, ts) => let
334 : blume 460 val memo = bfc2memo (bfc, ts)
335 : blume 448 in
336 :     if isValidMemo (memo, pids, i) then
337 :     (Say.vsay ["[", binname,
338 :     " ", what, "]\n"];
339 :     storeBFC (i, bfc);
340 :     SOME memo)
341 :     else otherwise ()
342 :     end
343 : blume 632 fun bottleneck () =
344 :     (* Are we the only runable task? *)
345 :     Servers.allIdle () andalso
346 :     Concur.noTasks ()
347 : blume 448 fun compile_again () =
348 : blume 452 (Say.vsay ["[compiling ",
349 :     SmlInfo.descr i, "]\n"];
350 : blume 537 compile_here (stat, sym, pids, split))
351 : blume 632 fun compile_there' p =
352 :     not (bottleneck ()) andalso
353 :     compile_there p
354 : blume 448 fun compile () = let
355 :     val sp = SmlInfo.sourcepath i
356 :     in
357 : blume 632 if compile_there' sp then
358 : blume 450 tryload ("received", compile_again)
359 : blume 448 else compile_again ()
360 :     end
361 : blume 398 in
362 : blume 448 (* If anything goes wrong loading the first
363 :     * time, we go and compile. Compiling
364 :     * may mean compiling externally, and if so,
365 :     * we must load the result of that.
366 :     * If the second load also goes wrong, we
367 :     * compile locally to gather error messages
368 :     * and make everything look "normal". *)
369 :     tryload ("loaded", compile)
370 : blume 398 end (* fromfile *)
371 : blume 402 fun notglobal () =
372 :     case fromfile () of
373 :     NONE => NONE
374 :     | SOME memo =>
375 :     (globalstate :=
376 :     SmlInfoMap.insert (!globalstate, i,
377 :     memo);
378 :     SOME memo)
379 : blume 398 in
380 : blume 402 case SmlInfoMap.find (!globalstate, i) of
381 :     NONE => notglobal ()
382 : blume 398 | SOME memo =>
383 :     if isValidMemo (memo, pids, i) then
384 : blume 402 SOME memo
385 :     else notglobal ()
386 : blume 398 end
387 :     end (* notlocal *)
388 :     in
389 : blume 462 (* Here we just wait (no "waitU") so we don't get
390 :     * priority over threads that may have to clean up after
391 :     * errors. *)
392 : blume 402 case SmlInfoMap.find (!localstate, i) of
393 : blume 448 SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)
394 : blume 398 | NONE => let
395 : blume 448 val mopt_c = Concur.fork
396 :     (fn () => notlocal () before
397 :     (* "Not local" means that we have not processed
398 :     * this file before. Therefore, we should now
399 :     * remove its parse tree... *)
400 :     SmlInfo.forgetParsetree i)
401 : blume 398 in
402 : blume 402 localstate :=
403 : blume 632 SmlInfoMap.insert (!localstate, i, mopt_c);
404 : blume 448 Option.map memo2ed (Concur.wait mopt_c)
405 : blume 398 end
406 :     end (* snode *)
407 :    
408 : blume 652 fun impexp gp (nth, _, _) = fsbnode gp (nth ())
409 : blume 399 in
410 :     { sbnode = sbnode, impexp = impexp }
411 :     end
412 : blume 398
413 : blume 587 fun newTraversal (_, _, GG.ERRORGROUP) =
414 :     { group = fn _ => NONE, exports = SymbolMap.empty }
415 :     | newTraversal (notify, storeBFC, g as GG.GROUP grec) = let
416 :     val { exports, ... } = grec
417 : blume 652 val um = Memoize.memoize (fn () => Indegree.indegrees g)
418 :     fun getUrgency i = getOpt (SmlInfoMap.find (um (), i), 0)
419 :     (* generate the traversal -- lazily *)
420 :     val impexpth =
421 :     Memoize.memoize
422 :     (fn () =>
423 :     #impexp
424 :     (mkTraversal (notify, storeBFC, getUrgency)))
425 : blume 587 fun group gp = let
426 :     val eo_cl =
427 : blume 652 map (fn x => Concur.fork (fn () => impexpth () gp x))
428 : blume 587 (SymbolMap.listItems exports)
429 :     val eo = foldl (layer'wait 0) (SOME emptyEnv) eo_cl
430 :     in
431 :     case eo of
432 :     NONE => (Servers.reset false; NONE)
433 :     | SOME e => SOME (#envs e ())
434 :     end handle Abort => (Servers.reset false; NONE)
435 :     fun mkExport ie gp =
436 : blume 652 case impexpth () gp ie handle Abort => NONE of
437 : blume 587 NONE => (Servers.reset false; NONE)
438 :     | SOME e => SOME (#envs e ())
439 : blume 399 in
440 : blume 587 { group = group,
441 :     exports = SymbolMap.map mkExport exports }
442 :     end
443 : blume 398
444 : blume 400 fun newSbnodeTraversal () = let
445 : blume 537 val { sbnode, ... } =
446 :     mkTraversal (fn _ => fn _ => (), fn _ => (), fn _ => 0)
447 : blume 461 fun sbn_trav gp g = let
448 : blume 462 val r = sbnode gp g handle Abort => NONE
449 : blume 461 in
450 :     if isSome r then () else Servers.reset false;
451 :     r
452 :     end
453 : blume 398 in
454 : blume 461 sbn_trav
455 : blume 398 end
456 :    
457 : blume 537 fun evictStale () =
458 :     globalstate :=
459 :     SmlInfoMap.filteri (SmlInfo.isKnown o #1) (!globalstate)
460 : blume 400
461 : blume 403 fun evictAll () = globalstate := SmlInfoMap.empty
462 : blume 402
463 : blume 403 fun getII i = memo2ii (valOf (SmlInfoMap.find (!globalstate, i)))
464 : blume 398 end
465 :     end

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