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/cm/compile/compile.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2333 - (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 : blume 879 structure SE = StaticEnv
13 :     structure Pid = PersStamps
14 : blume 398 structure PP = PrettyPrint
15 : blume 879 structure EM = ErrorMsg
16 :     structure SF = SmlFile
17 : blume 398
18 :     type pid = Pid.persstamp
19 : blume 905 type statenv = StaticEnv.staticEnv
20 :     type symenv = SymbolicEnv.env
21 : blume 398 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 : blume 771 type stats
28 : blume 400
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 : blume 771 type bfcReceiver =
37 : blume 879 SmlInfo.info * { contents: bfc, stats: stats } -> unit
38 : blume 403
39 : blume 398 val getII : SmlInfo.info -> IInfo.info
40 : blume 399
41 : blume 537 val evictStale : unit -> unit
42 : blume 402 val evictAll : unit -> unit
43 : blume 399
44 : blume 771 val newSbnodeTraversal : unit -> DG.sbnode -> GP.info -> ed option
45 : blume 400
46 : blume 403 val newTraversal : notifier * bfcReceiver * GG.group ->
47 : blume 399 { group: GP.info -> result option,
48 : blume 801 allgroups: GP.info -> bool,
49 : blume 399 exports: (GP.info -> result option) SymbolMap.map }
50 : blume 398 end
51 :    
52 : blume 879 functor CompileFn (structure Backend : BACKEND
53 : blume 588 structure StabModmap : STAB_MODMAP
54 : blume 677 val useStream : TextIO.instream -> unit
55 : blume 666 val compile_there : SrcPath.file -> bool) :>
56 : blume 879 COMPILE where type bfc = Binfile.bfContents
57 :     where type stats = Binfile.stats =
58 : blume 400 struct
59 : blume 398
60 : blume 879 val arch = Backend.architecture
61 : mblume 1639 val version = #version_id SMLNJVersion.version
62 : blume 879
63 : blume 400 type notifier = GP.info -> SmlInfo.info -> unit
64 : blume 399
65 : blume 879 structure BF = Binfile
66 :     structure C = Backend.Compile
67 : blume 398
68 : blume 879 type bfc = BF.bfContents
69 : blume 771 type stats = BF.stats
70 : blume 398
71 : blume 771 type bfcReceiver =
72 : blume 879 SmlInfo.info * { contents: bfc, stats: stats } -> unit
73 : blume 403
74 : blume 447 structure FilterMap = MapFn
75 : blume 398 (struct
76 :     type ord_key = pid * SymbolSet.set
77 :     fun compare ((u, f), (u', f')) =
78 :     case Pid.compare (u, u') of
79 :     EQUAL => SymbolSet.compare (f, f')
80 :     | unequal => unequal
81 :     end)
82 :    
83 : blume 399 type env = { envs: unit -> result, pids: PidSet.set }
84 : blume 460 type envdelta = IInfo.info
85 : blume 398
86 : blume 460 type memo = { ii: IInfo.info, ts: TStamp.t, cmdata: PidSet.set }
87 : blume 398
88 :     (* persistent state! *)
89 :     val filtermap = ref (FilterMap.empty: pid FilterMap.map)
90 :    
91 :     (* more persistent state! *)
92 : blume 402 val globalstate = ref (SmlInfoMap.empty: memo SmlInfoMap.map)
93 : blume 398
94 :     fun reset () =
95 :     (filtermap := FilterMap.empty;
96 : blume 402 globalstate := SmlInfoMap.empty)
97 : blume 398
98 :     fun isValidMemo (memo: memo, provided, smlinfo) =
99 :     not (TStamp.needsUpdate { source = SmlInfo.lastseen smlinfo,
100 :     target = #ts memo })
101 : blume 403 andalso PidSet.equal (provided, #cmdata memo)
102 : blume 398
103 : blume 587 fun memo2ii (memo: memo) = #ii memo
104 : blume 398
105 : blume 460 fun memo2ed memo = memo2ii memo
106 : blume 398
107 : blume 879 fun bfc2memo (bfc, ts, context_senv) = let
108 :     fun statenv () =
109 :     let val mm0 = StabModmap.get ()
110 :     val m = GenModIdMap.mkMap' (context_senv, mm0)
111 :     fun context _ = m
112 :     val { pid, pickle } = BF.senvPickleOf bfc
113 :     in UnpickMod.unpickleEnv context (pid, pickle)
114 :     end
115 :     fun symenv () =
116 :     let val { pickle, ... } = BF.lambdaPickleOf bfc
117 :     val l = if Word8Vector.length pickle = 0 then NONE
118 :     else UnpickMod.unpickleFLINT pickle
119 :     in SymbolicEnv.mk (BF.exportPidOf bfc, l)
120 :     end
121 :     val ii = { statenv = Memoize.memoize statenv,
122 :     symenv = Memoize.memoize symenv,
123 : blume 403 statpid = BF.staticPidOf bfc,
124 : blume 1058 sympid = BF.lambdaPidOf bfc,
125 : blume 1137 guid = BF.guidOf bfc }
126 : blume 403 val cmdata = PidSet.addList (PidSet.empty, BF.cmDataOf bfc)
127 :     in
128 : blume 460 { ii = ii, ts = ts, cmdata = cmdata }
129 : blume 403 end
130 :    
131 : blume 398 fun pidset (p1, p2) = PidSet.add (PidSet.singleton p1, p2)
132 :    
133 :     fun nofilter (ed: envdelta) = let
134 : blume 1137 val { statenv, symenv, statpid, sympid, guid } = ed
135 : blume 587 val statenv' = Memoize.memoize statenv
136 : blume 398 in
137 : blume 587 { envs = fn () => { stat = statenv' (), sym = symenv () },
138 : blume 398 pids = pidset (statpid, sympid) }
139 :     end
140 :    
141 : blume 735 fun requiredFiltering set se = let
142 : blume 905 val dom = SymbolSet.addList (SymbolSet.empty,
143 :     BrowseStatEnv.catalog se)
144 : blume 735 val filt = SymbolSet.intersection (set, dom)
145 :     in
146 :     if SymbolSet.equal (dom, filt) then NONE
147 :     else SOME filt
148 :     end
149 : blume 398
150 : blume 460 fun filter (ii, s) = let
151 : blume 1137 val { statenv, symenv, statpid, sympid, guid } = ii
152 : blume 587 val ste = statenv ()
153 : blume 398 in
154 : blume 735 case requiredFiltering s ste of
155 :     NONE => { envs = fn () => { stat = ste, sym = symenv () },
156 :     pids = pidset (statpid, sympid) }
157 :     | SOME s => let
158 : blume 905 val ste' = SE.filter (ste, SymbolSet.listItems s)
159 : blume 587 val key = (statpid, s)
160 :     val statpid' =
161 :     case FilterMap.find (!filtermap, key) of
162 :     SOME statpid' => statpid'
163 :     | NONE => let
164 : blume 879 val statpid' = Rehash.rehash
165 : blume 1058 { env = ste', orig_pid = statpid,
166 : blume 1137 guid = guid }
167 : blume 587 in
168 :     filtermap :=
169 :     FilterMap.insert (!filtermap, key, statpid');
170 :     statpid'
171 :     end
172 :     in
173 :     { envs = fn () => { stat = ste', sym = symenv () },
174 :     pids = pidset (statpid', sympid) }
175 :     end
176 : blume 398 end
177 :    
178 : blume 905 fun rlayer ({ stat, sym }, { stat = stat', sym = sym' }) =
179 :     { stat = SE.consolidateLazy (SE.atop (stat, stat')),
180 :     (* let's not bother with stale pids here... *)
181 :     sym = SymbolicEnv.atop (sym, sym') }
182 : blume 399
183 : blume 905 val emptyEnv =
184 :     { envs = fn () => { stat = SE.empty, sym = SymbolicEnv.empty },
185 :     pids = PidSet.empty }
186 : blume 398
187 :     fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =
188 :     { envs = fn () => rlayer (e (), e' ()),
189 :     pids = PidSet.union (p, p') }
190 :    
191 : blume 462 (* I would rather not use an exception here, but short of a better
192 :     * implementation of concurrency I see no choice.
193 :     * The problem is that at each node we sequentiallay wait for the
194 :     * children nodes. But the scheduler might (and probably will)
195 :     * let a child run that we are not currently waiting for, so an
196 :     * error there will not result in "wait" to immediately return
197 :     * as it should for clean error recovery.
198 :     * Using the exception avoids having to implement a
199 :     * "wait for any child -- whichever finishes first" kind of call. *)
200 :     exception Abort
201 : blume 399
202 : blume 462 fun layer'wait u (p, NONE) =
203 :     (ignore (Concur.waitU u p); NONE)
204 :     | layer'wait u (p, SOME e) =
205 :     (case Concur.waitU u p of
206 :     SOME e' => SOME (layer (e', e))
207 :     | NONE => NONE)
208 :    
209 : blume 454 fun mkTraversal (notify, storeBFC, getUrgency) = let
210 : blume 402 val localstate = ref SmlInfoMap.empty
211 : blume 398
212 : blume 1058 fun storeBFC' (gp, i, x) = let
213 :     val src = SmlInfo.sourcepath i
214 :     val c = #contents x
215 :     in
216 :     storeBFC (i, x)
217 :     end
218 :    
219 :    
220 : blume 537 fun sbnode gp (DG.SB_SNODE n) = snode gp n
221 :     (* The beauty of this scheme is that we don't have
222 :     * to do anything at all for SB_BNODEs: Everything
223 :     * is prepared ready to be used when the library
224 :     * is unpickled: *)
225 : blume 737 | sbnode gp (DG.SB_BNODE (_, ii, _)) = SOME ii
226 : blume 398
227 :     and fsbnode gp (f, n) =
228 :     case (sbnode gp n, f) of
229 :     (NONE, _) => NONE
230 :     | (SOME d, NONE) => SOME (nofilter d)
231 :     | (SOME d, SOME s) => SOME (filter (d, s))
232 :    
233 :     and snode gp (DG.SNODE n) = let
234 : blume 692 val youngest = #youngest gp
235 : blume 398 val { smlinfo = i, localimports = li, globalimports = gi } = n
236 :     val binname = SmlInfo.binname i
237 : blume 771 val descr = SmlInfo.descr i
238 : blume 398
239 : blume 771 fun pstats (s: BF.stats) = let
240 :     fun info ((sel, lab), (l, t)) =
241 :     case sel s of
242 :     0 => (l, t)
243 :     | n => (lab :: ": " :: Int.toString n ::
244 :     t :: " " :: l,
245 :     ",")
246 :     in
247 :     Say.vsay ("[" :: #1 (foldr info
248 :     (["bytes]\n"], "")
249 :     [(#code, "code"),
250 :     (#data, "data"),
251 :     (#env, "env"),
252 :     (#inlinfo, "inlinable")]))
253 :     end
254 :    
255 : blume 801 fun loaded _ = Say.vsay ["[loading ", descr, "]\n"]
256 :     fun received s =
257 :     (Say.vsay ["[receiving ", descr, "]\n"];
258 :     pstats s)
259 : blume 771
260 : blume 462 fun fail () =
261 :     if #keep_going (#param gp) then NONE else raise Abort
262 :    
263 : blume 1137 fun compile_here (stat, sym, pids, split) = let
264 : blume 677 fun perform_setup _ NONE = ()
265 :     | perform_setup what (SOME code) =
266 :     (Say.vsay ["[setup (", what, "): ", code, "]\n"];
267 :     SafeIO.perform
268 :     { openIt = fn () => TextIO.openString code,
269 :     closeIt = TextIO.closeIn,
270 :     work = useStream,
271 :     cleanup = fn _ => () })
272 : blume 398 fun save bfc = let
273 : blume 757 fun writer s = let
274 : blume 902 val s = BF.write { arch = arch, version = version,
275 :     nopickle = false,
276 : blume 879 stream = s, contents = bfc }
277 : blume 771 in pstats s; s
278 : blume 757 end
279 : blume 459 fun cleanup _ =
280 : blume 398 OS.FileSys.remove binname handle _ => ()
281 :     in
282 : blume 400 notify gp i;
283 : blume 771 (SafeIO.perform { openIt =
284 : blume 398 fn () => AutoDir.openBinOut binname,
285 : blume 771 closeIt = BinIO.closeOut,
286 :     work = writer,
287 :     cleanup = cleanup }
288 :     before TStamp.setTime (binname, SmlInfo.lastseen i))
289 : blume 398 handle exn => let
290 :     fun ppb pps =
291 : macqueen 1344 (PP.newline pps;
292 :     PP.string pps (General.exnMessage exn))
293 : blume 398 in
294 :     SmlInfo.error gp i EM.WARN
295 : blume 771 ("failed to write " ^ binname) ppb;
296 :     { code = 0, env = 0, inlinfo = 0, data = 0 }
297 :     end
298 : blume 398 end (* save *)
299 :     in
300 :     case SmlInfo.parsetree gp i of
301 : blume 462 NONE => fail ()
302 : blume 398 | SOME (ast, source) => let
303 : blume 592 val ast =
304 :     case #explicit_core_sym (SmlInfo.attribs i) of
305 :     NONE => ast
306 :     | SOME sy => CoreHack.rewrite (ast, sy)
307 : blume 398 val cmData = PidSet.listItems pids
308 : blume 677 val (pre, post) = SmlInfo.setup i
309 : mblume 1632 val controllers = SmlInfo.controllers i
310 : blume 905 val topLevel = EnvRef.loc ()
311 : mblume 1632 val orig_settings =
312 :     map (fn c => #save'restore c ()) controllers
313 :     val orig_toplenv = #get topLevel ()
314 :     fun reset _ =
315 :     (#set topLevel orig_toplenv;
316 :     app (fn r => r ()) orig_settings)
317 :     fun work () = let
318 : blume 2219 val _ = map (fn c => #set c ()) controllers
319 : mblume 1632 val _ = perform_setup "pre" pre
320 :     (* clear error flag (could still be set from
321 :     * earlier run) *)
322 :     val _ = #anyErrors source := false
323 :     (* we actually run the compiler here;
324 :     * Binfile is not doing it anymore *)
325 :     val err = EM.errors source
326 :     fun check phase =
327 :     if EM.anyErrors err then
328 :     raise CompileExn.Compile
329 :     (phase ^ " failed")
330 :     else ()
331 :     val cinfo = C.mkCompInfo { source = source,
332 :     transform = fn x => x }
333 :     val splitting = Control.LambdaSplitting.get' split
334 :     val guid = SmlInfo.guid i
335 :     val { csegments, newstatenv, exportPid,
336 :     staticPid, imports, pickle = senvP,
337 :     inlineExp, ... } =
338 :     C.compile { source = source, ast = ast,
339 :     statenv = stat, symenv = sym,
340 :     compInfo = cinfo, checkErr = check,
341 :     splitting = splitting,
342 :     guid = guid }
343 :     val { hash = lambdaPid, pickle = lambdaP } =
344 :     PickMod.pickleFLINT inlineExp
345 :     val lambdaP = case inlineExp of
346 :     NONE => Byte.stringToBytes ""
347 :     | SOME _ => lambdaP
348 :     val bfc = BF.create
349 :     { imports = imports,
350 :     exportPid = exportPid,
351 :     cmData = cmData,
352 :     senv = { pickle = senvP,
353 :     pid = staticPid },
354 :     lambda = { pickle = lambdaP,
355 :     pid = lambdaPid },
356 :     guid = guid,
357 :     csegments = csegments }
358 :     val memo =
359 :     bfc2memo (bfc, SmlInfo.lastseen i, stat)
360 :     in
361 :     perform_setup "post" post;
362 :     reset ();
363 :     storeBFC' (gp, i,
364 :     { contents = bfc,
365 :     stats = save bfc });
366 :     SOME memo
367 :     end
368 : blume 398 in
369 : mblume 1632 SafeIO.perform { openIt = fn () => (),
370 :     work = work,
371 :     closeIt = fn () => (),
372 :     cleanup = reset }
373 : blume 879 end handle (EM.Error | CompileExn.Compile _)
374 : blume 757 (* At this point we handle only
375 :     * explicit compiler bugs and ordinary
376 :     * compilation errors because for those
377 :     * there will already have been
378 :     * explanatory messages. Everything
379 :     * else "falls through" and will be
380 :     * treated at top level. *)
381 :     => fail ()
382 : blume 448 end (* compile_here *)
383 : blume 398 fun notlocal () = let
384 : blume 692 val _ = youngest := TStamp.max (!youngest,
385 :     SmlInfo.lastseen i)
386 : blume 454 val urgency = getUrgency i
387 : blume 402 (* Ok, it is not in the local state, so we first have
388 : blume 398 * to traverse all children before we can proceed... *)
389 :     fun loc li_n = Option.map nofilter (snode gp li_n)
390 :     fun glob gi_n = fsbnode gp gi_n
391 : blume 448 val gi_cl =
392 :     map (fn gi_n => Concur.fork (fn () => glob gi_n)) gi
393 :     val li_cl =
394 :     map (fn li_n => Concur.fork (fn () => loc li_n)) li
395 : blume 398 val e =
396 : blume 462 foldl (layer'wait urgency)
397 :     (foldl (layer'wait urgency)
398 : blume 537 (SOME emptyEnv)
399 : blume 462 gi_cl)
400 :     li_cl
401 : blume 398 in
402 :     case e of
403 :     NONE => NONE
404 :     | SOME { envs, pids } => let
405 :     (* We have successfully traversed all
406 :     * children. Now it is time to check the
407 :     * global map... *)
408 :     fun fromfile () = let
409 :     val { stat, sym } = envs ()
410 : blume 537 val { split, extra_compenv, ... } =
411 :     SmlInfo.attribs i
412 :     val stat =
413 :     case extra_compenv of
414 :     NONE => stat
415 : blume 905 | SOME s => SE.atop (stat, s)
416 : blume 398 fun load () = let
417 :     val ts = TStamp.fmodTime binname
418 :     fun openIt () = BinIO.openIn binname
419 : blume 588 fun reader s = let
420 :     val mm0 = StabModmap.get ()
421 :     val m = GenModIdMap.mkMap' (stat, mm0)
422 : blume 879 val { contents, stats } =
423 :     BF.read { arch = arch,
424 : blume 902 version = version,
425 : blume 986 stream = s }
426 : blume 588 in
427 : blume 1137 SmlInfo.setguid (i, BF.guidOf contents);
428 : blume 879 (contents, ts, stats)
429 : blume 588 end
430 : blume 398 in
431 :     SOME (SafeIO.perform
432 :     { openIt = openIt,
433 :     closeIt = BinIO.closeIn,
434 :     work = reader,
435 : blume 459 cleanup = fn _ => () })
436 : blume 398 handle _ => NONE
437 :     end (* load *)
438 : blume 801 fun tryload (sync, report, otherwise) =
439 :     case (sync (); load ()) of
440 : blume 448 NONE => otherwise ()
441 : blume 771 | SOME (bfc, ts, stats) => let
442 : blume 879 val memo = bfc2memo (bfc, ts, stat)
443 :     val contst = { contents = bfc,
444 : blume 771 stats = stats }
445 : blume 448 in
446 :     if isValidMemo (memo, pids, i) then
447 : blume 2333 (notify gp i;
448 :     report stats;
449 : blume 1058 storeBFC' (gp, i, contst);
450 : blume 448 SOME memo)
451 :     else otherwise ()
452 :     end
453 : blume 801 fun sy0 () = ()
454 : blume 632 fun bottleneck () =
455 :     (* Are we the only runable task? *)
456 :     Servers.allIdle () andalso
457 :     Concur.noTasks ()
458 : blume 1137 fun compile_again () =
459 : blume 771 (Say.vsay ["[compiling ", descr, "]\n"];
460 : blume 1137 compile_here (stat, sym, pids, split))
461 : blume 632 fun compile_there' p =
462 :     not (bottleneck ()) andalso
463 :     compile_there p
464 : blume 448 fun compile () = let
465 :     val sp = SmlInfo.sourcepath i
466 : blume 801 fun sy () = let
467 :     fun ready () =
468 :     OS.FileSys.fileSize binname > 0
469 :     handle _ => false
470 :     in
471 :     (***** busy wait for file to appear;
472 :     * this is obviously very bad! *)
473 :     while not (ready ()) do ()
474 :     end
475 : blume 448 in
476 : blume 801 OS.FileSys.remove binname handle _ => ();
477 : blume 692 youngest := TStamp.NOTSTAMP;
478 : blume 632 if compile_there' sp then
479 : blume 801 tryload (sy, received, compile_again)
480 : blume 448 else compile_again ()
481 :     end
482 : blume 398 in
483 : blume 448 (* If anything goes wrong loading the first
484 :     * time, we go and compile. Compiling
485 :     * may mean compiling externally, and if so,
486 :     * we must load the result of that.
487 :     * If the second load also goes wrong, we
488 :     * compile locally to gather error messages
489 :     * and make everything look "normal". *)
490 : blume 801 tryload (sy0, loaded, compile)
491 : blume 398 end (* fromfile *)
492 : blume 402 fun notglobal () =
493 :     case fromfile () of
494 :     NONE => NONE
495 :     | SOME memo =>
496 :     (globalstate :=
497 :     SmlInfoMap.insert (!globalstate, i,
498 :     memo);
499 :     SOME memo)
500 : blume 398 in
501 : blume 402 case SmlInfoMap.find (!globalstate, i) of
502 :     NONE => notglobal ()
503 : blume 398 | SOME memo =>
504 :     if isValidMemo (memo, pids, i) then
505 : blume 402 SOME memo
506 :     else notglobal ()
507 : blume 398 end
508 :     end (* notlocal *)
509 :     in
510 : blume 462 (* Here we just wait (no "waitU") so we don't get
511 :     * priority over threads that may have to clean up after
512 :     * errors. *)
513 : blume 402 case SmlInfoMap.find (!localstate, i) of
514 : blume 448 SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)
515 : blume 398 | NONE => let
516 : blume 448 val mopt_c = Concur.fork
517 :     (fn () => notlocal () before
518 :     (* "Not local" means that we have not processed
519 :     * this file before. Therefore, we should now
520 :     * remove its parse tree... *)
521 :     SmlInfo.forgetParsetree i)
522 : blume 398 in
523 : blume 402 localstate :=
524 : blume 632 SmlInfoMap.insert (!localstate, i, mopt_c);
525 : blume 448 Option.map memo2ed (Concur.wait mopt_c)
526 : blume 398 end
527 :     end (* snode *)
528 :    
529 : blume 652 fun impexp gp (nth, _, _) = fsbnode gp (nth ())
530 : blume 399 in
531 :     { sbnode = sbnode, impexp = impexp }
532 :     end
533 : blume 398
534 : blume 587 fun newTraversal (_, _, GG.ERRORGROUP) =
535 : blume 801 { group = fn _ => NONE,
536 :     allgroups = fn _ => false,
537 :     exports = SymbolMap.empty }
538 : blume 587 | newTraversal (notify, storeBFC, g as GG.GROUP grec) = let
539 :     val { exports, ... } = grec
540 : blume 652 val um = Memoize.memoize (fn () => Indegree.indegrees g)
541 :     fun getUrgency i = getOpt (SmlInfoMap.find (um (), i), 0)
542 :     (* generate the traversal -- lazily *)
543 :     val impexpth =
544 :     Memoize.memoize
545 :     (fn () =>
546 :     #impexp
547 :     (mkTraversal (notify, storeBFC, getUrgency)))
548 : blume 801
549 :     fun many (gp, iel) = let
550 : blume 587 val eo_cl =
551 : blume 652 map (fn x => Concur.fork (fn () => impexpth () gp x))
552 : blume 801 iel
553 : blume 587 val eo = foldl (layer'wait 0) (SOME emptyEnv) eo_cl
554 :     in
555 :     case eo of
556 :     NONE => (Servers.reset false; NONE)
557 :     | SOME e => SOME (#envs e ())
558 :     end handle Abort => (Servers.reset false; NONE)
559 : blume 801
560 : blume 1137 fun group gp = many (gp, SymbolMap.listItems exports)
561 : blume 801
562 :     fun allgroups gp = let
563 :     fun addgroup ((_, th, _), gl) = th () :: gl
564 :     fun collect ([], _, l) = l
565 :     | collect (GG.ERRORGROUP :: gl, done, l) =
566 :     collect (gl, done, l)
567 :     | collect (GG.GROUP g :: gl, done, l) =
568 :     if SrcPathSet.member (done, #grouppath g) then
569 :     collect (gl, done, l)
570 :     else
571 :     collect (foldl addgroup gl (#sublibs g),
572 :     SrcPathSet.add (done, #grouppath g),
573 :     SymbolMap.foldl (op ::) l (#exports g))
574 :     val l = collect ([g], SrcPathSet.empty, [])
575 :     in
576 :     isSome (many (gp, l))
577 :     end
578 :    
579 : blume 587 fun mkExport ie gp =
580 : blume 652 case impexpth () gp ie handle Abort => NONE of
581 : blume 587 NONE => (Servers.reset false; NONE)
582 :     | SOME e => SOME (#envs e ())
583 : blume 399 in
584 : blume 587 { group = group,
585 : blume 801 allgroups = allgroups,
586 : blume 587 exports = SymbolMap.map mkExport exports }
587 :     end
588 : blume 398
589 : blume 400 fun newSbnodeTraversal () = let
590 : blume 537 val { sbnode, ... } =
591 :     mkTraversal (fn _ => fn _ => (), fn _ => (), fn _ => 0)
592 : blume 771 fun sbn_trav n gp = let
593 :     val r = sbnode gp n handle Abort => NONE
594 : blume 461 in
595 :     if isSome r then () else Servers.reset false;
596 :     r
597 :     end
598 : blume 398 in
599 : blume 461 sbn_trav
600 : blume 398 end
601 :    
602 : blume 537 fun evictStale () =
603 :     globalstate :=
604 :     SmlInfoMap.filteri (SmlInfo.isKnown o #1) (!globalstate)
605 : blume 400
606 : blume 403 fun evictAll () = globalstate := SmlInfoMap.empty
607 : blume 402
608 : blume 403 fun getII i = memo2ii (valOf (SmlInfoMap.find (!globalstate, i)))
609 : blume 398 end
610 :     end

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