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

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