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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 370 - (view) (download)

1 : blume 295 (*
2 :     * Build an argument for the generic compilation functor.
3 :     * This gives a traversal that loads from binfiles, stable archives,
4 :     * or compiles sml source code. The "binfile content" cache gets
5 :     * warmed up that way, too. (The "ExecFn" functor takes advantage of
6 :     * this fact.)
7 :     *
8 :     * (C) 1999 Lucent Technologies, Bell Laboratories
9 :     *
10 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :     *)
12 :     functor RecompFn (structure PS : RECOMP_PERSSTATE) : COMPILATION_TYPE = struct
13 :    
14 :     structure MachDepVC = PS.MachDepVC
15 :     structure E = GenericVC.Environment
16 : blume 369 structure Pid = GenericVC.PersStamps
17 : blume 295 structure BF = MachDepVC.Binfile
18 : blume 297 structure PP = PrettyPrint
19 :     structure EM = GenericVC.ErrorMsg
20 : blume 316 structure DE = GenericVC.DynamicEnv
21 : blume 370 structure CMSE = GenericVC.CMStaticEnv
22 : blume 295
23 : blume 369 type pid = Pid.persstamp
24 :     type bfc = BF.bfContent
25 : blume 295
26 :     type statenv = E.staticEnv
27 :     type symenv = E.symenv
28 :    
29 : blume 351 type benv = unit -> statenv
30 : blume 316 type result = { stat: statenv, sym: symenv }
31 : blume 351 type env = { envs: unit -> result, pids: PidSet.set }
32 : blume 295
33 : blume 316 val empty = { stat = E.staticPart E.emptyEnv,
34 :     sym = E.symbolicPart E.emptyEnv }
35 : blume 314
36 : blume 351 fun env2result (e: env) = #envs e ()
37 : blume 316
38 :     fun rlayer (r, r') = let
39 :     fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,
40 :     dynamic = DE.empty }
41 :     fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }
42 :     in
43 :     e2r (E.concatEnv (r2e r, r2e r'))
44 :     end
45 :    
46 : blume 295 type 'e wpid = 'e * pid
47 :    
48 : blume 369 (* bfc will be NONE for primitives, SOME ... for anybody else *)
49 :     type envdelta = { stat: statenv wpid, sym: symenv wpid, ctxt: statenv,
50 :     bfc: bfc option }
51 : blume 295
52 : blume 369 type memorecord = { bfc: bfc, ctxt: statenv }
53 : blume 295
54 :     structure FilterMap = BinaryMapFn
55 :     (struct
56 :     type ord_key = pid * SymbolSet.set
57 :     fun compare ((u, f), (u', f')) =
58 : blume 369 case Pid.compare (u, u') of
59 : blume 295 EQUAL => SymbolSet.compare (f, f')
60 :     | unequal => unequal
61 :     end)
62 :    
63 :     (* persistent state! *)
64 :     val filtermap = ref (FilterMap.empty: pid FilterMap.map)
65 :    
66 : blume 361 fun reset () = (filtermap := FilterMap.empty)
67 :    
68 : blume 351 fun blayer (be, be') = fn () => E.layerStatic (be (), be' ())
69 : blume 295
70 : blume 351 fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =
71 :     { envs = fn () => rlayer (e (), e' ()),
72 :     pids = PidSet.union (p, p') }
73 : blume 295
74 : blume 351 fun exportsNothingBut set se =
75 :     List.all (fn sy => SymbolSet.member (set, sy)) (E.catalogEnv se)
76 : blume 295
77 : blume 351 fun bfilter (d: envdelta, s) = let
78 :     val se = #1 (#stat d)
79 :     in
80 :     if exportsNothingBut s se then (fn () => se)
81 :     else (fn () => E.filterStaticEnv (se, SymbolSet.listItems s))
82 :     end
83 :    
84 : blume 295 fun pidset (p1, p2) =
85 :     PidSet.add (PidSet.singleton p1, p2)
86 :    
87 : blume 351 fun filter (d: envdelta, s) = let
88 :     val se = #1 (#stat d)
89 : blume 295 val (sym, sympid) = #sym d
90 :     val statpid = #2 (#stat d)
91 :     in
92 : blume 351 if exportsNothingBut s se then
93 :     { envs = fn () => { stat = se, sym = sym },
94 :     pids = pidset (statpid, sympid) }
95 :     else let
96 :     val stat = E.filterStaticEnv (se, SymbolSet.listItems s)
97 :     val ctxt = #ctxt d
98 :     val key = (statpid, s)
99 :     val statpid' =
100 :     case FilterMap.find (!filtermap, key) of
101 :     SOME statpid' => statpid'
102 :     | NONE => let
103 :     val statpid' = GenericVC.MakePid.makePid (ctxt, stat)
104 :     in
105 :     filtermap :=
106 :     FilterMap.insert (!filtermap, key, statpid');
107 :     statpid'
108 :     end
109 :     in
110 :     { envs = fn () => { stat = stat, sym = sym },
111 :     pids = pidset (statpid', sympid) }
112 :     end
113 : blume 295 end
114 :    
115 : blume 351 fun bnofilter (d: envdelta) = (fn () => #1 (#stat d))
116 : blume 295
117 :     fun nofilter (d: envdelta) = let
118 :     val (stat, statpid) = #stat d
119 :     val (sym, sympid) = #sym d
120 :     in
121 : blume 351 { envs = fn () => { stat = stat, sym = sym },
122 :     pids = pidset (statpid, sympid) }
123 : blume 295 end
124 :    
125 : blume 299 fun primitive (gp: GeneralParams.info) p = let
126 :     val c = #primconf (#param gp)
127 : blume 295 val e = Primitive.env c p
128 :     val { statpid, sympid, ctxt } = Primitive.pidInfo c p
129 :     in
130 :     { stat = (E.staticPart e, statpid),
131 :     sym = (E.symbolicPart e, sympid),
132 : blume 369 ctxt = ctxt,
133 :     bfc = NONE }
134 : blume 295 end
135 :    
136 : blume 299 fun pervasive (gp: GeneralParams.info) = let
137 :     val e = #pervasive (#param gp)
138 :     in
139 : blume 351 { envs = fn () => { stat = E.staticPart e, sym = E.symbolicPart e },
140 : blume 316 pids = PidSet.empty }
141 : blume 299 end
142 :    
143 :     fun bpervasive (gp: GeneralParams.info) =
144 : blume 351 (fn () => E.staticPart (#pervasive (#param gp)))
145 : blume 299
146 : blume 295 fun memo2envdelta { bfc, ctxt } =
147 :     { stat = (BF.senvOf bfc, BF.staticPidOf bfc),
148 :     sym = (BF.symenvOf bfc, BF.lambdaPidOf bfc),
149 : blume 369 ctxt = ctxt, bfc = SOME bfc }
150 : blume 295
151 : blume 369 fun dostable (i, mkenv, gp: GeneralParams.info, bn) = let
152 : blume 298 fun load be = let
153 : blume 354 val stable = BinInfo.stablename i
154 : blume 298 val os = BinInfo.offset i
155 :     val descr = BinInfo.describe i
156 : blume 310 val _ = Say.vsay ["[consulting ", descr, "]\n"]
157 : blume 345 fun work s = let
158 : blume 298 val _ = Seek.seek (s, os)
159 :     val bfc = BF.read { stream = s, name = descr, senv = be,
160 :     keep_code = true }
161 :     val memo = { bfc = bfc, ctxt = be }
162 :     in
163 :     PS.recomp_memo_stable (i, memo);
164 :     memo2envdelta memo
165 :     end
166 : blume 295 in
167 : blume 354 SOME (SafeIO.perform { openIt = fn () => BinIO.openIn stable,
168 : blume 345 closeIt = BinIO.closeIn,
169 :     work = work,
170 :     cleanup = fn () => () })
171 :     handle exn => let
172 : blume 301 fun ppb pps =
173 : blume 353 (PP.add_newline pps;
174 :     PP.add_string pps (General.exnMessage exn))
175 : blume 298 in
176 : blume 306 BinInfo.error i EM.COMPLAIN
177 : blume 301 "unable to load stable library module" ppb;
178 : blume 298 NONE
179 :     end
180 : blume 295 end
181 :     in
182 : blume 298 case PS.recomp_look_stable i of
183 :     SOME memo => SOME (memo2envdelta memo)
184 :     | NONE =>
185 :     (case mkenv () of
186 :     NONE => NONE
187 : blume 351 | SOME be => load (be ()))
188 : blume 295 end
189 :    
190 : blume 369 fun dosml (i, { envs, pids }, gp, sn) = let
191 : blume 327 val pids = PidSet.union (pids, #pervcorepids (#param gp))
192 :     in
193 : blume 298 case Option.map memo2envdelta (PS.recomp_look_sml (i, pids, gp)) of
194 :     SOME d => SOME d
195 :     | NONE => let
196 : blume 354 val binname = SmlInfo.binname i
197 : blume 351 val { stat, sym } = envs ()
198 : blume 295
199 : blume 298 fun save bfc = let
200 : blume 345 fun writer s =
201 :     (BF.write { stream = s, content = bfc,
202 :     keep_code = true };
203 :     Say.vsay ["[wrote ", binname, "]\n"])
204 : blume 354 fun cleanup () = OS.FileSys.remove binname handle _ => ()
205 : blume 298 in
206 : blume 345 SafeIO.perform { openIt =
207 : blume 354 fn () => AutoDir.openBinOut binname,
208 : blume 345 closeIt = BinIO.closeOut,
209 :     work = writer,
210 :     cleanup = cleanup }
211 :     handle exn => let
212 :     fun ppb pps =
213 : blume 353 (PP.add_newline pps;
214 :     PP.add_string pps (General.exnMessage exn))
215 : blume 345 in
216 :     SmlInfo.error gp i EM.WARN
217 :     ("failed to write " ^ binname) ppb
218 :     end;
219 : blume 354 TStamp.setTime (binname, SmlInfo.lastseen i)
220 : blume 345 end
221 : blume 297
222 : blume 298 fun load () = let
223 : blume 354 val bin_ts = TStamp.fmodTime binname
224 :     fun openIt () = BinIO.openIn binname
225 : blume 345 fun reader s = BF.read { stream = s, name = binname,
226 :     senv = stat, keep_code = true }
227 : blume 298 in
228 : blume 345 if TStamp.needsUpdate { target = bin_ts,
229 :     source = SmlInfo.lastseen i } then
230 : blume 301 NONE
231 : blume 345 else
232 :     SOME (SafeIO.perform { openIt = openIt,
233 :     closeIt = BinIO.closeIn,
234 :     work = reader,
235 :     cleanup = fn () => () })
236 :     handle _ => NONE
237 : blume 301 end
238 : blume 297
239 : blume 299 fun compile () =
240 :     case SmlInfo.parsetree gp i of
241 :     NONE => NONE
242 :     | SOME (ast, source) => let
243 : blume 368 val _ =
244 :     Say.vsay ["[compiling ", SmlInfo.descr i, "]\n"]
245 : blume 301 val corenv = #corenv (#param gp)
246 : blume 299 val cmData = PidSet.listItems pids
247 : blume 345 (* clear error flag (could still be set from
248 :     * earlier run) *)
249 :     val _ = #anyErrors source := false
250 : blume 299 val bfc = BF.create { runtimePid = NONE,
251 : blume 326 splitting = SmlInfo.split i,
252 : blume 299 cmData = cmData,
253 :     ast = ast,
254 :     source = source,
255 :     senv = stat,
256 :     symenv = sym,
257 :     corenv = corenv }
258 :     val memo = { bfc = bfc, ctxt = stat }
259 :     in
260 : blume 301 SmlInfo.forgetParsetree i;
261 : blume 299 save bfc;
262 :     PS.recomp_memo_sml (i, memo);
263 :     SOME (memo2envdelta memo)
264 : blume 345 end handle BF.Compile _ => NONE
265 : blume 301 | e => let
266 :     fun ppb pps =
267 : blume 320 (PP.add_newline pps;
268 :     PP.add_string pps
269 :     (General.exnMessage e))
270 : blume 301 in
271 :     SmlInfo.error gp i EM.COMPLAIN
272 :     ("exception raised while compiling "
273 : blume 354 ^ SmlInfo.descr i)
274 : blume 301 ppb;
275 :     NONE
276 :     end
277 : blume 297
278 : blume 298 fun isValid x =
279 :     PidSet.equal (PidSet.addList (PidSet.empty, BF.cmDataOf x),
280 :     pids)
281 :     in
282 :     case load () of
283 :     NONE => compile ()
284 :     | SOME bfc =>
285 :     if isValid bfc then let
286 :     val memo = { bfc = bfc, ctxt = stat }
287 :     in
288 : blume 310 Say.vsay ["[", binname, " loaded]\n"];
289 : blume 298 PS.recomp_memo_sml (i, memo);
290 :     SOME (memo2envdelta memo)
291 :     end
292 :     else compile ()
293 :     end
294 : blume 327 end
295 : blume 369
296 :     fun nestedTraversalReset () = ()
297 : blume 370
298 :     fun withAccessTrap r { envs, pids } = let
299 :     fun envs' () = let
300 :     val { stat, sym } = envs ()
301 :     in
302 :     { stat = CMSE.withAccessTrap (stat, r), sym = sym }
303 :     end
304 :     in
305 :     { envs = envs', pids = pids }
306 :     end
307 : blume 295 end

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