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

Annotation of /sml/trunk/src/cm/smlfile/smlinfo.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 487 - (view) (download)

1 : blume 275 (*
2 : blume 282 * Bundling information pertaining to one SML source file.
3 :     * - only includes information that does not require running
4 :     * the machine-dependent part of the compiler
5 : blume 275 *
6 :     * (C) 1999 Lucent Technologies, Bell Laboratories
7 :     *
8 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
9 :     *)
10 : blume 270 signature SMLINFO = sig
11 :    
12 :     type info
13 : blume 305 type ord_key = info
14 : blume 270
15 : blume 295 type complainer = GenericVC.ErrorMsg.complainer
16 : blume 297 type ast = GenericVC.Ast.dec
17 :     type region = GenericVC.SourceMap.region
18 : blume 299 type source = GenericVC.Source.inputSource
19 : blume 274
20 : blume 279 val eq : info * info -> bool (* compares sourcepaths *)
21 :     val compare : info * info -> order (* compares sourcepaths *)
22 :    
23 : blume 487 (* The idea behind "newGeneration" is the following:
24 :     * Before parsing .cm files (on behalf of CM.make/recomp or CMB.make etc.)
25 :     * we start a new generation. While parsing, when we encounter a new
26 :     * SML source we re-use existing information and bump its generation
27 :     * number to "now". After we are done with one group we can safely
28 :     * evict all info records for files in this group if their generation
29 :     * is not "now".
30 :     * Moreover, if we encounter an entry that has a different owner group,
31 :     * we can either signal an error (if the generation is "now" which means
32 :     * that the file was found in another group during the same parse) or
33 :     * issue a "switched groups" warning (if the generation is older than
34 :     * now which means that the file used to be in another group). *)
35 :     val newGeneration : unit -> unit
36 :    
37 : blume 299 val info : GeneralParams.info ->
38 : blume 354 { sourcepath: SrcPath.t,
39 :     group: SrcPath.t * region,
40 : blume 387 sh_spec: Sharing.request,
41 : blume 326 split: bool }
42 : blume 270 -> info
43 :    
44 : blume 354 val sourcepath : info -> SrcPath.t
45 :     val skelname : info -> string
46 :     val binname : info -> string
47 : blume 299 val error : GeneralParams.info -> info -> complainer
48 : blume 277
49 : blume 299 val parsetree : GeneralParams.info -> info -> (ast * source) option
50 : blume 301 val exports : GeneralParams.info -> info -> SymbolSet.set option
51 :     val skeleton : GeneralParams.info -> info -> Skeleton.decl option
52 : blume 387 val sh_spec : info -> Sharing.request
53 :     val set_sh_mode : info * Sharing.mode -> unit
54 :     val sh_mode : info -> Sharing.mode
55 : blume 326 val split : info -> bool
56 : blume 301 val lastseen : info -> TStamp.t
57 : blume 279
58 : blume 301 (* forget a parse tree that we are done with *)
59 :     val forgetParsetree : info -> unit
60 :    
61 : blume 487 (* Evict all elements that belong to a given group but which
62 :     * are not of the current generation. "cleanGroup" should be
63 :     * called right after finishing to parse the group file. *)
64 :     val cleanGroup : SrcPath.t -> unit
65 : blume 301
66 : blume 487 (* Delete all known info. *)
67 :     val reset : unit -> unit
68 :    
69 : blume 280 (* different ways of describing an sml file using group and source *)
70 :     val spec : info -> string (* sspec *)
71 :     val fullSpec : info -> string (* gspec(sspec) *)
72 : blume 354 val descr : info -> string (* sname *)
73 :     val fullDescr : info -> string (* gname(sspec) *)
74 : blume 305
75 : blume 306 val errorLocation : GeneralParams.info -> info -> string
76 : blume 270 end
77 :    
78 :     structure SmlInfo :> SMLINFO = struct
79 :    
80 : blume 275 structure Source = GenericVC.Source
81 :     structure SF = GenericVC.SmlFile
82 :     structure EM = GenericVC.ErrorMsg
83 : blume 286 structure FNP = FilenamePolicy
84 : blume 275
85 :     type source = Source.inputSource
86 : blume 297 type ast = GenericVC.Ast.dec
87 :     type region = GenericVC.SourceMap.region
88 : blume 274
89 : blume 295 type complainer = EM.complainer
90 : blume 274
91 : blume 487 type generation = unit ref
92 :    
93 : blume 389 (* sh_mode is an elaboration of sh_spec; it must be persistent
94 :     * and gets properly re-computed when there is a new sh_spec *)
95 : blume 297 datatype persinfo =
96 : blume 354 PERS of { group: SrcPath.t * region,
97 : blume 487 generation: generation ref,
98 : blume 297 lastseen: TStamp.t ref,
99 : blume 299 parsetree: (ast * source) option ref,
100 : blume 389 skeleton: Skeleton.decl option ref,
101 :     sh_mode: Sharing.mode ref }
102 : blume 297
103 : blume 275 datatype info =
104 : blume 354 INFO of { sourcepath: SrcPath.t,
105 : blume 361 mkSkelname: unit -> string,
106 :     mkBinname: unit -> string,
107 : blume 297 persinfo: persinfo,
108 : blume 387 sh_spec: Sharing.request,
109 : blume 326 split: bool }
110 : blume 270
111 : blume 305 type ord_key = info
112 :    
113 : blume 487 local
114 :     val generation = ref (ref ())
115 :     in
116 :     fun now () = !generation
117 :     fun newGeneration () = generation := ref ()
118 :     end
119 :    
120 : blume 277 fun sourcepath (INFO { sourcepath = sp, ... }) = sp
121 : blume 361 fun skelname (INFO { mkSkelname = msn, ... }) = msn ()
122 :     fun binname (INFO { mkBinname = mbn, ... }) = mbn ()
123 : blume 387 fun sh_spec (INFO { sh_spec = s, ... }) = s
124 : blume 389 fun sh_mode (INFO { persinfo = PERS { sh_mode = ref m, ... }, ... }) = m
125 :     fun set_sh_mode (INFO { persinfo = PERS { sh_mode, ... }, ... }, m) =
126 :     sh_mode := m
127 : blume 326 fun split (INFO { split = s, ... }) = s
128 : blume 270
129 : blume 299 fun gerror (gp: GeneralParams.info) = GroupReg.error (#groupreg gp)
130 : blume 297
131 :     fun error gp (INFO { persinfo = PERS { group, ... }, ... }) =
132 :     gerror gp group
133 :    
134 : blume 279 fun compare (INFO { sourcepath = p, ... }, INFO { sourcepath = p', ... }) =
135 : blume 354 SrcPath.compare (p, p')
136 : blume 279 fun eq (i, i') = compare (i, i') = EQUAL
137 :    
138 : blume 301 fun lastseen (INFO { persinfo = PERS { lastseen, ... }, ... }) =
139 :     !lastseen
140 :    
141 : blume 354 val knownInfo = ref (SrcPathMap.empty: persinfo SrcPathMap.map)
142 : blume 277
143 : blume 365 fun countParseTrees () = let
144 :     fun one (PERS { parsetree = ref (SOME _), ... }, i) = i + 1
145 :     | one (_, i) = i
146 :     in
147 :     SrcPathMap.foldl one 0 (!knownInfo)
148 :     end
149 :    
150 : blume 301 fun forgetParsetree (INFO { persinfo = PERS { parsetree, ... }, ... }) =
151 :     parsetree := NONE
152 :    
153 : blume 487 fun cleanGroup g = let
154 :     val n = now ()
155 :     fun isCurrent (PERS { generation = ref gen, group = (g', _), ... }) =
156 :     gen = n orelse SrcPath.compare (g, g') <> EQUAL
157 : blume 301 in
158 : blume 487 knownInfo := SrcPathMap.filter isCurrent (!knownInfo)
159 : blume 301 end
160 :    
161 : blume 487 fun reset () = knownInfo := SrcPathMap.empty
162 :    
163 : blume 330 (* check timestamp and throw away any invalid cache *)
164 :     fun validate (sourcepath, PERS pir) = let
165 :     (* don't use "..." pattern to have the compiler catch later
166 :     * additions to the type! *)
167 : blume 487 val { group, lastseen, parsetree, skeleton, sh_mode, generation } = pir
168 : blume 330 val ts = !lastseen
169 : blume 354 val nts = SrcPath.tstamp sourcepath
170 : blume 330 in
171 : blume 345 if TStamp.needsUpdate { source = nts, target = ts } then
172 : blume 330 (lastseen := nts;
173 : blume 487 generation := now ();
174 : blume 330 parsetree := NONE;
175 :     skeleton := NONE)
176 :     else ()
177 :     end
178 :    
179 : blume 299 fun info (gp: GeneralParams.info) arg = let
180 : blume 387 val { sourcepath, group = gr as (group, region), sh_spec, split } = arg
181 : blume 310 val policy = #fnpolicy (#param gp)
182 : blume 361 fun mkSkelname () = FNP.mkSkelName policy sourcepath
183 :     fun mkBinname () = FNP.mkBinName policy sourcepath
184 : blume 297 val groupreg = #groupreg gp
185 :     fun newpersinfo () = let
186 : blume 354 val ts = SrcPath.tstamp sourcepath
187 : blume 330 val pi = PERS { group = gr, lastseen = ref ts,
188 : blume 389 parsetree = ref NONE, skeleton = ref NONE,
189 : blume 487 sh_mode = ref (Sharing.SHARE false),
190 :     generation = ref (now ()) }
191 : blume 281 in
192 : blume 354 knownInfo := SrcPathMap.insert (!knownInfo, sourcepath, pi);
193 : blume 297 pi
194 : blume 281 end
195 : blume 297 fun persinfo () =
196 : blume 354 case SrcPathMap.find (!knownInfo, sourcepath) of
197 : blume 297 NONE => newpersinfo ()
198 : blume 487 | SOME (pi as PERS { group = gr' as (g, r), generation, ... }) =>
199 : blume 354 if SrcPath.compare (group, g) <> EQUAL then let
200 :     val n = SrcPath.descr sourcepath
201 : blume 322 in
202 : blume 487 if !generation = now () then
203 : blume 322 (gerror gp gr EM.COMPLAIN
204 :     (concat ["ML source file ", n,
205 :     " appears in more than one group"])
206 :     EM.nullErrorBody;
207 :     gerror gp gr' EM.COMPLAIN
208 :     (concat ["(previous occurence of ", n, ")"])
209 :     EM.nullErrorBody)
210 :     else
211 :     gerror gp gr EM.WARN
212 :     (concat ["ML source file ", n,
213 :     " has switched groups"])
214 :     EM.nullErrorBody;
215 :     newpersinfo ()
216 :     end
217 : blume 330 else (validate (sourcepath, pi); pi)
218 : blume 281 in
219 : blume 297 INFO { sourcepath = sourcepath,
220 : blume 361 mkSkelname = mkSkelname,
221 :     mkBinname = mkBinname,
222 : blume 297 persinfo = persinfo (),
223 : blume 387 sh_spec = sh_spec,
224 : blume 326 split = split }
225 : blume 281 end
226 : blume 277
227 : blume 275 (* the following functions are only concerned with getting the data,
228 :     * not with checking time stamps *)
229 : blume 297 fun getParseTree gp (i as INFO ir, quiet, noerrors) = let
230 :     val { sourcepath, persinfo = PERS { parsetree, ... }, ... } = ir
231 : blume 281 val err = if noerrors then (fn m => ())
232 : blume 297 else (fn m => error gp i EM.COMPLAIN m EM.nullErrorBody)
233 : blume 274 in
234 : blume 275 case !parsetree of
235 :     SOME pt => SOME pt
236 :     | NONE => let
237 : blume 345 fun work stream = let
238 :     val _ = if noerrors orelse quiet then ()
239 : blume 354 else Say.vsay ["[parsing ",
240 :     SrcPath.descr sourcepath, "]\n"]
241 : blume 345 val source =
242 : blume 354 Source.newSource (SrcPath.osstring sourcepath,
243 :     1, stream, false, #errcons gp)
244 : blume 275 in
245 : blume 345 (SF.parse source, source)
246 :     end
247 : blume 364 fun openIt () = TextIO.openIn (SrcPath.osstring sourcepath)
248 : blume 345 val pto =
249 :     SOME (SafeIO.perform { openIt = openIt,
250 :     closeIt = TextIO.closeIn,
251 :     work = work,
252 : blume 459 cleanup = fn _ => () })
253 : blume 365 (* Counting the trees explicitly may be a bit slow,
254 :     * but maintaining an accurate count is difficult, so
255 :     * this method should be robust. (I don't think that
256 :     * the overhead of counting will make a noticeable
257 :     * difference.) *)
258 :     val ntrees = countParseTrees ()
259 : blume 433 val treelimit = #get StdConfig.parse_caching ()
260 : blume 275 in
261 : blume 365 if ntrees < treelimit then
262 :     parsetree := pto
263 :     else ();
264 : blume 275 pto
265 : blume 345 end handle exn as IO.Io _ => (err (General.exnMessage exn); NONE)
266 :     | SF.Compile msg => (err msg; NONE)
267 : blume 274 end
268 :    
269 : blume 297 fun getSkeleton gp (i as INFO ir, noerrors) = let
270 : blume 361 val { sourcepath, mkSkelname, persinfo = PERS pir, ... } = ir
271 : blume 297 val { skeleton, lastseen, ... } = pir
272 : blume 275 in
273 :     case !skeleton of
274 : blume 301 SOME sk => SOME sk
275 : blume 361 | NONE => let
276 :     val skelname = mkSkelname ()
277 :     in
278 :     case SkelIO.read (skelname, !lastseen) of
279 :     SOME sk => (skeleton := SOME sk; SOME sk)
280 :     | NONE =>
281 :     (case getParseTree gp (i, false, noerrors) of
282 :     SOME (tree, source) => let
283 :     fun err sv region s =
284 :     EM.error source region sv s
285 :     EM.nullErrorBody
286 :     val { skeleton = sk, complain } =
287 :     SkelCvt.convert { tree = tree,
288 :     err = err }
289 :     in
290 :     if noerrors then () else complain ();
291 : blume 310 if EM.anyErrors (EM.errors source) then
292 : blume 361 if noerrors then ()
293 :     else error gp i EM.COMPLAIN
294 : blume 310 "error(s) in ML source file"
295 :     EM.nullErrorBody
296 : blume 354 else (SkelIO.write (skelname, sk, !lastseen);
297 : blume 310 skeleton := SOME sk);
298 :     SOME sk
299 : blume 361 end
300 :     | NONE => NONE)
301 :     end
302 : blume 275 end
303 :    
304 : blume 330 fun skeleton0 noerrors gp i = getSkeleton gp (i, noerrors)
305 : blume 281
306 :     (* we only complain at the time of getting the exports *)
307 : blume 301 fun exports gp i = Option.map SkelExports.exports (skeleton0 false gp i)
308 : blume 281 val skeleton = skeleton0 true
309 : blume 275
310 : blume 330 fun parsetree gp i = getParseTree gp (i, true, true)
311 : blume 282
312 : blume 354 fun spec (INFO { sourcepath, ... }) = SrcPath.specOf sourcepath
313 : blume 297 fun fullSpec (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
314 : blume 354 concat [SrcPath.specOf (#1 group), "(", SrcPath.specOf sourcepath, ")"]
315 :     fun descr (INFO { sourcepath, ... }) = SrcPath.descr sourcepath
316 :     fun fullDescr (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
317 :     concat [SrcPath.descr (#1 group), "(", SrcPath.specOf sourcepath, ")"]
318 : blume 305
319 : blume 306 fun errorLocation (gp: GeneralParams.info) (INFO i) = let
320 :     val { persinfo = PERS { group = (group, reg), ... }, ... } = i
321 : blume 305 in
322 : blume 306 EM.matchErrorString (GroupReg.lookup (#groupreg gp) group) reg
323 : blume 305 end
324 : blume 270 end

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