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 298 - (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 295
21 :     type pid = PID.persstamp
22 :    
23 :     type statenv = E.staticEnv
24 :     type symenv = E.symenv
25 :    
26 :     type benv = statenv
27 :     type env = { stat: statenv, sym: symenv, pids: PidSet.set }
28 :    
29 :     type 'e wpid = 'e * pid
30 :    
31 :     type envdelta = { stat: statenv wpid, sym: symenv wpid, ctxt: statenv }
32 :    
33 :     type memorecord = { bfc: BF.bfContent, ctxt: statenv }
34 :    
35 :     structure FilterMap = BinaryMapFn
36 :     (struct
37 :     type ord_key = pid * SymbolSet.set
38 :     fun compare ((u, f), (u', f')) =
39 :     case PID.compare (u, u') of
40 :     EQUAL => SymbolSet.compare (f, f')
41 :     | unequal => unequal
42 :     end)
43 :    
44 :     (* persistent state! *)
45 :     val filtermap = ref (FilterMap.empty: pid FilterMap.map)
46 :    
47 :     fun blayer (be, be') = E.layerStatic (be, be')
48 :    
49 :     fun layer ({ stat, sym, pids }, { stat = stat', sym = sym', pids = p' }) =
50 :     { stat = E.layerStatic (stat, stat'),
51 :     sym = E.layerSymbolic (sym, sym'),
52 :     pids = PidSet.union (pids, p') }
53 :    
54 :     fun bfilter (d: envdelta, s) =
55 :     E.filterStaticEnv (#1 (#stat d), SymbolSet.listItems s)
56 :    
57 :     fun pidset (p1, p2) =
58 :     PidSet.add (PidSet.singleton p1, p2)
59 :    
60 :     fun filter (d, s) = let
61 :     val stat = bfilter (d, s)
62 :     val (sym, sympid) = #sym d
63 :     val statpid = #2 (#stat d)
64 :     val ctxt = #ctxt d
65 :     val key = (statpid, s)
66 :     val statpid' =
67 :     case FilterMap.find (!filtermap, key) of
68 :     SOME statpid' => statpid'
69 :     | NONE => let
70 :     val statpid' = GenericVC.MakePid.makePid (ctxt, stat)
71 :     in
72 :     filtermap := FilterMap.insert (!filtermap, key, statpid');
73 :     statpid'
74 :     end
75 :     in
76 :     { stat = stat, sym = sym, pids = pidset (statpid', sympid) }
77 :     end
78 :    
79 :     fun bnofilter (d: envdelta) = #1 (#stat d)
80 :    
81 :     fun nofilter (d: envdelta) = let
82 :     val (stat, statpid) = #stat d
83 :     val (sym, sympid) = #sym d
84 :     in
85 :     { stat = stat, sym = sym, pids = pidset (statpid, sympid) }
86 :     end
87 :    
88 :     fun primitive c p = let
89 :     val e = Primitive.env c p
90 :     val { statpid, sympid, ctxt } = Primitive.pidInfo c p
91 :     in
92 :     { stat = (E.staticPart e, statpid),
93 :     sym = (E.symbolicPart e, sympid),
94 :     ctxt = ctxt }
95 :     end
96 :    
97 :     fun memo2envdelta { bfc, ctxt } =
98 :     { stat = (BF.senvOf bfc, BF.staticPidOf bfc),
99 :     sym = (BF.symenvOf bfc, BF.lambdaPidOf bfc),
100 :     ctxt = ctxt }
101 :    
102 : blume 298 fun dostable (i, mkenv, gp) = let
103 :     fun load be = let
104 :     val fnp = #fnpolicy gp
105 :     val stable = FilenamePolicy.mkStablePath fnp (BinInfo.group i)
106 :     val os = BinInfo.offset i
107 :     val descr = BinInfo.describe i
108 :     val _ = Say.vsay (concat ["[consulting ", descr, "]\n"])
109 :     val s = AbsPath.openBinIn stable
110 :     fun load () = let
111 :     val _ = Seek.seek (s, os)
112 :     val bfc = BF.read { stream = s, name = descr, senv = be,
113 :     keep_code = true }
114 :     val memo = { bfc = bfc, ctxt = be }
115 :     in
116 :     BinIO.closeIn s;
117 :     PS.recomp_memo_stable (i, memo);
118 :     memo2envdelta memo
119 :     end
120 : blume 295 in
121 : blume 298 SOME (load ()) handle exn => let
122 :     fun pphist pps =
123 :     (PP.add_string pps (General.exnMessage exn);
124 :     PP.add_newline pps)
125 :     in
126 :     BinIO.closeIn s;
127 :     BinInfo.error gp i EM.COMPLAIN
128 :     "unable to load stable library module" pphist;
129 :     NONE
130 :     end
131 : blume 295 end
132 :     in
133 : blume 298 case PS.recomp_look_stable i of
134 :     SOME memo => SOME (memo2envdelta memo)
135 :     | NONE =>
136 :     (case mkenv () of
137 :     NONE => NONE
138 :     | SOME be => load be)
139 : blume 295 end
140 :    
141 : blume 298 fun dosml (i, { stat, sym, pids }, gp) =
142 :     case Option.map memo2envdelta (PS.recomp_look_sml (i, pids, gp)) of
143 :     SOME d => SOME d
144 :     | NONE => let
145 :     val mkBinPath = FilenamePolicy.mkBinPath (#fnpolicy gp)
146 :     val binpath = mkBinPath (SmlInfo.sourcepath i)
147 :     val binname = AbsPath.name binpath
148 :     fun delete () = OS.FileSys.remove binname handle _ => ()
149 : blume 295
150 : blume 298 fun save bfc = let
151 :     val s = AbsPath.openBinOut binpath
152 :     fun writer () = BF.write { stream = s, content = bfc,
153 :     keep_code = true }
154 :     in
155 :     Interrupt.guarded writer
156 :     handle exn => (BinIO.closeOut s; raise exn);
157 :     BinIO.closeOut s;
158 :     Say.vsay (concat ["wrote ", binname, "]\n"])
159 :     end handle e as Interrupt.Interrupt => (delete (); raise e)
160 :     | exn => let
161 :     fun pphist pps =
162 :     (PP.add_string pps (General.exnMessage exn);
163 :     PP.add_newline pps)
164 :     in
165 :     delete ();
166 :     SmlInfo.error gp i EM.WARN
167 :     ("failed to write " ^ binname) pphist
168 :     end
169 : blume 297
170 : blume 298 fun load () = let
171 :     val s = AbsPath.openBinIn binpath
172 :     fun read () = BF.read { stream = s, name = binname,
173 :     senv = stat,keep_code = true }
174 :     in
175 :     SOME (Interrupt.guarded read)
176 :     handle exn => (BinIO.closeIn s; raise exn)
177 :     end handle e as Interrupt.Interrupt => raise e
178 :     | _ => NONE
179 : blume 297
180 : blume 298 fun compile () = Dummy.f ()
181 : blume 297
182 : blume 298 fun isValid x =
183 :     PidSet.equal (PidSet.addList (PidSet.empty, BF.cmDataOf x),
184 :     pids)
185 :     in
186 :     case load () of
187 :     NONE => compile ()
188 :     | SOME bfc =>
189 :     if isValid bfc then let
190 :     val memo = { bfc = bfc, ctxt = stat }
191 :     in
192 :     Say.vsay (concat ["[", binname, " loaded]\n"]);
193 :     PS.recomp_memo_sml (i, memo);
194 :     SOME (memo2envdelta memo)
195 :     end
196 :     else compile ()
197 :     end
198 : blume 295 end

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