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

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