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 316 - (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 :     type benv = statenv
28 : blume 316 type result = { stat: statenv, sym: symenv }
29 :     type env = { envs: 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 316 fun env2result (e: env) = #envs e
35 :    
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 :     fun blayer (be, be') = E.layerStatic (be, be')
63 :    
64 : blume 316 fun layer ({ envs, pids }, { envs = e', pids = p' }) =
65 :     { envs = rlayer (envs, e'), pids = PidSet.union (pids, p') }
66 : blume 295
67 :     fun bfilter (d: envdelta, s) =
68 :     E.filterStaticEnv (#1 (#stat d), SymbolSet.listItems s)
69 :    
70 :     fun pidset (p1, p2) =
71 :     PidSet.add (PidSet.singleton p1, p2)
72 :    
73 :     fun filter (d, s) = let
74 :     val stat = bfilter (d, s)
75 :     val (sym, sympid) = #sym d
76 :     val statpid = #2 (#stat d)
77 :     val ctxt = #ctxt d
78 :     val key = (statpid, s)
79 :     val statpid' =
80 :     case FilterMap.find (!filtermap, key) of
81 :     SOME statpid' => statpid'
82 :     | NONE => let
83 :     val statpid' = GenericVC.MakePid.makePid (ctxt, stat)
84 :     in
85 :     filtermap := FilterMap.insert (!filtermap, key, statpid');
86 :     statpid'
87 :     end
88 :     in
89 : blume 316 { envs = { stat = stat, sym = sym }, pids = pidset (statpid', sympid) }
90 : blume 295 end
91 :    
92 :     fun bnofilter (d: envdelta) = #1 (#stat d)
93 :    
94 :     fun nofilter (d: envdelta) = let
95 :     val (stat, statpid) = #stat d
96 :     val (sym, sympid) = #sym d
97 :     in
98 : blume 316 { envs = { stat = stat, sym = sym }, pids = pidset (statpid, sympid) }
99 : blume 295 end
100 :    
101 : blume 299 fun primitive (gp: GeneralParams.info) p = let
102 :     val c = #primconf (#param gp)
103 : blume 295 val e = Primitive.env c p
104 :     val { statpid, sympid, ctxt } = Primitive.pidInfo c p
105 :     in
106 :     { stat = (E.staticPart e, statpid),
107 :     sym = (E.symbolicPart e, sympid),
108 :     ctxt = ctxt }
109 :     end
110 :    
111 : blume 299 fun pervasive (gp: GeneralParams.info) = let
112 :     val e = #pervasive (#param gp)
113 :     in
114 : blume 316 { envs = { stat = E.staticPart e, sym = E.symbolicPart e },
115 :     pids = PidSet.empty }
116 : blume 299 end
117 :    
118 :     fun bpervasive (gp: GeneralParams.info) =
119 :     E.staticPart (#pervasive (#param gp))
120 :    
121 : blume 295 fun memo2envdelta { bfc, ctxt } =
122 :     { stat = (BF.senvOf bfc, BF.staticPidOf bfc),
123 :     sym = (BF.symenvOf bfc, BF.lambdaPidOf bfc),
124 :     ctxt = ctxt }
125 :    
126 : blume 306 fun dostable (i, mkenv, gp: GeneralParams.info) = let
127 : blume 298 fun load be = let
128 : blume 299 val fnp = #fnpolicy (#param gp)
129 : blume 298 val stable = FilenamePolicy.mkStablePath fnp (BinInfo.group i)
130 :     val os = BinInfo.offset i
131 :     val descr = BinInfo.describe i
132 : blume 310 val _ = Say.vsay ["[consulting ", descr, "]\n"]
133 : blume 298 val s = AbsPath.openBinIn stable
134 :     fun load () = let
135 :     val _ = Seek.seek (s, os)
136 :     val bfc = BF.read { stream = s, name = descr, senv = be,
137 :     keep_code = true }
138 :     val memo = { bfc = bfc, ctxt = be }
139 :     in
140 :     BinIO.closeIn s;
141 :     PS.recomp_memo_stable (i, memo);
142 :     memo2envdelta memo
143 :     end
144 : blume 295 in
145 : blume 298 SOME (load ()) handle exn => let
146 : blume 301 fun ppb pps =
147 : blume 298 (PP.add_string pps (General.exnMessage exn);
148 :     PP.add_newline pps)
149 :     in
150 :     BinIO.closeIn s;
151 : blume 306 BinInfo.error i EM.COMPLAIN
152 : blume 301 "unable to load stable library module" ppb;
153 : blume 298 NONE
154 :     end
155 : blume 295 end
156 :     in
157 : blume 298 case PS.recomp_look_stable i of
158 :     SOME memo => SOME (memo2envdelta memo)
159 :     | NONE =>
160 :     (case mkenv () of
161 :     NONE => NONE
162 :     | SOME be => load be)
163 : blume 295 end
164 :    
165 : blume 316 fun dosml (i, { envs = { stat, sym }, pids }, gp) =
166 : blume 298 case Option.map memo2envdelta (PS.recomp_look_sml (i, pids, gp)) of
167 :     SOME d => SOME d
168 :     | NONE => let
169 : blume 310 val binpath = SmlInfo.binpath i
170 : blume 298 val binname = AbsPath.name binpath
171 :     fun delete () = OS.FileSys.remove binname handle _ => ()
172 : blume 295
173 : blume 298 fun save bfc = let
174 :     val s = AbsPath.openBinOut binpath
175 :     fun writer () = BF.write { stream = s, content = bfc,
176 :     keep_code = true }
177 :     in
178 : blume 301 Interrupt.guarded writer handle exn =>
179 :     (BinIO.closeOut s; raise exn);
180 :     BinIO.closeOut s;
181 : blume 310 Say.vsay ["[wrote ", binname, "]\n"]
182 : blume 298 end handle e as Interrupt.Interrupt => (delete (); raise e)
183 :     | exn => let
184 : blume 301 fun ppb pps =
185 : blume 298 (PP.add_string pps (General.exnMessage exn);
186 :     PP.add_newline pps)
187 :     in
188 :     delete ();
189 :     SmlInfo.error gp i EM.WARN
190 : blume 301 ("failed to write " ^ binname) ppb
191 : blume 298 end
192 : blume 297
193 : blume 298 fun load () = let
194 : blume 301 val bin_ts = AbsPath.tstamp binpath
195 : blume 298 in
196 : blume 301 if TStamp.earlier (bin_ts, SmlInfo.lastseen i) then
197 :     NONE
198 :     else let
199 :     val s = AbsPath.openBinIn binpath
200 :     fun read () = BF.read { stream = s, name = binname,
201 :     senv = stat, keep_code = true }
202 :     in
203 :     (SOME (Interrupt.guarded read)
204 :     before SmlInfo.forgetParsetree i)
205 :     handle exn => (BinIO.closeIn s; raise exn)
206 :     end handle e as Interrupt.Interrupt => raise e
207 :     | _ => NONE
208 :     end
209 : blume 297
210 : blume 299 fun compile () =
211 :     case SmlInfo.parsetree gp i of
212 :     NONE => NONE
213 :     | SOME (ast, source) => let
214 : blume 310 val _ = Say.vsay ["[compiling ", SmlInfo.name i,
215 :     " -> ", binname, "...]\n"]
216 : blume 301 val corenv = #corenv (#param gp)
217 : blume 299 val cmData = PidSet.listItems pids
218 :     val bfc = BF.create { runtimePid = NONE,
219 :     splitting = true,
220 :     cmData = cmData,
221 :     ast = ast,
222 :     source = source,
223 :     senv = stat,
224 :     symenv = sym,
225 :     corenv = corenv }
226 :     val memo = { bfc = bfc, ctxt = stat }
227 :     in
228 : blume 301 SmlInfo.forgetParsetree i;
229 : blume 299 save bfc;
230 :     PS.recomp_memo_sml (i, memo);
231 :     SOME (memo2envdelta memo)
232 :     end handle e as Interrupt.Interrupt => raise e
233 : blume 301 | BF.Compile _ => NONE
234 :     | e => let
235 :     fun ppb pps =
236 :     (PP.add_string pps
237 :     (General.exnMessage e);
238 :     PP.add_newline pps)
239 :     in
240 :     SmlInfo.error gp i EM.COMPLAIN
241 :     ("exception raised while compiling "
242 :     ^ SmlInfo.name i)
243 :     ppb;
244 :     NONE
245 :     end
246 : blume 297
247 : blume 298 fun isValid x =
248 :     PidSet.equal (PidSet.addList (PidSet.empty, BF.cmDataOf x),
249 :     pids)
250 :     in
251 :     case load () of
252 :     NONE => compile ()
253 :     | SOME bfc =>
254 :     if isValid bfc then let
255 :     val memo = { bfc = bfc, ctxt = stat }
256 :     in
257 : blume 310 Say.vsay ["[", binname, " loaded]\n"];
258 : blume 298 PS.recomp_memo_sml (i, memo);
259 :     SOME (memo2envdelta memo)
260 :     end
261 :     else compile ()
262 :     end
263 : blume 295 end

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