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 400 - (view) (download)

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

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