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

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