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 986 - (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 879 type complainer = ErrorMsg.complainer
16 :     type ast = Ast.dec
17 :     type region = SourceMap.region
18 :     type source = Source.inputSource
19 :     type splitrequest = Control.LambdaSplitting.localsetting
20 : blume 274
21 : blume 537 type attribs =
22 : blume 818 { split: splitrequest,
23 : blume 592 is_rts: bool,
24 :     explicit_core_sym: Symbol.symbol option,
25 : blume 905 extra_compenv: StaticEnv.staticEnv option }
26 : blume 537
27 : blume 818 type info_args =
28 :     { sourcepath: SrcPath.file,
29 :     group: SrcPath.file * region,
30 :     sh_spec: Sharing.request,
31 : blume 986 setup: string option * string option,
32 :     locl: bool }
33 : blume 818
34 : blume 279 val eq : info * info -> bool (* compares sourcepaths *)
35 :     val compare : info * info -> order (* compares sourcepaths *)
36 :    
37 : blume 487 (* The idea behind "newGeneration" is the following:
38 :     * Before parsing .cm files (on behalf of CM.make/recomp or CMB.make etc.)
39 :     * we start a new generation. While parsing, when we encounter a new
40 :     * SML source we re-use existing information and bump its generation
41 :     * number to "now". After we are done with one group we can safely
42 :     * evict all info records for files in this group if their generation
43 :     * is not "now".
44 :     * Moreover, if we encounter an entry that has a different owner group,
45 :     * we can either signal an error (if the generation is "now" which means
46 :     * that the file was found in another group during the same parse) or
47 :     * issue a "switched groups" warning (if the generation is older than
48 :     * now which means that the file used to be in another group). *)
49 :     val newGeneration : unit -> unit
50 :    
51 : blume 818 val info : splitrequest -> GeneralParams.info -> info_args -> info
52 : blume 270
53 : blume 818 val info' : attribs -> GeneralParams.info -> info_args -> info
54 : blume 537
55 : blume 666 val sourcepath : info -> SrcPath.file
56 : blume 354 val skelname : info -> string
57 :     val binname : info -> string
58 : blume 666 val group : info -> SrcPath.file
59 : blume 299 val error : GeneralParams.info -> info -> complainer
60 : blume 277
61 : blume 299 val parsetree : GeneralParams.info -> info -> (ast * source) option
62 : blume 301 val exports : GeneralParams.info -> info -> SymbolSet.set option
63 :     val skeleton : GeneralParams.info -> info -> Skeleton.decl option
64 : blume 387 val sh_spec : info -> Sharing.request
65 :     val set_sh_mode : info * Sharing.mode -> unit
66 :     val sh_mode : info -> Sharing.mode
67 : blume 537 val attribs : info -> attribs
68 : blume 301 val lastseen : info -> TStamp.t
69 : blume 677 val setup : info -> string option * string option
70 : blume 986 val is_local : info -> bool
71 : blume 279
72 : blume 301 (* forget a parse tree that we are done with *)
73 :     val forgetParsetree : info -> unit
74 :    
75 : blume 487 (* Evict all elements that belong to a given group but which
76 :     * are not of the current generation. "cleanGroup" should be
77 : blume 514 * called right after finishing to parse the group file.
78 :     * If the boolean flag ("nowStable") is set to true, then all
79 :     * members of the group are dismissed regardless of their
80 :     * generation. This is used to get rid of the information for
81 :     * members of now-stable libraries. *)
82 : blume 666 val cleanGroup : bool -> SrcPath.file -> unit
83 : blume 301
84 : blume 537 (* See if a given piece of info is (still) known here: *)
85 :     val isKnown : info -> bool
86 :    
87 : blume 487 (* Delete all known info. *)
88 :     val reset : unit -> unit
89 :    
90 : blume 280 (* different ways of describing an sml file using group and source *)
91 : blume 354 val descr : info -> string (* sname *)
92 : blume 305
93 : blume 306 val errorLocation : GeneralParams.info -> info -> string
94 : blume 270 end
95 :    
96 :     structure SmlInfo :> SMLINFO = struct
97 :    
98 : blume 879 structure Source = Source
99 :     structure SF = SmlFile
100 :     structure EM = ErrorMsg
101 : blume 286 structure FNP = FilenamePolicy
102 : blume 275
103 :     type source = Source.inputSource
104 : blume 879 type ast = Ast.dec
105 :     type region = SourceMap.region
106 :     type splitrequest = Control.LambdaSplitting.localsetting
107 : blume 274
108 : blume 295 type complainer = EM.complainer
109 : blume 274
110 : blume 879 type attribs = { split: splitrequest,
111 :     is_rts: bool,
112 :     explicit_core_sym: Symbol.symbol option,
113 : blume 905 extra_compenv: StaticEnv.staticEnv option }
114 : blume 537
115 : blume 879 type info_args = { sourcepath: SrcPath.file,
116 :     group: SrcPath.file * region,
117 :     sh_spec: Sharing.request,
118 : blume 986 setup: string option * string option,
119 :     locl: bool }
120 : blume 818
121 : blume 487 type generation = unit ref
122 :    
123 : blume 389 (* sh_mode is an elaboration of sh_spec; it must be persistent
124 :     * and gets properly re-computed when there is a new sh_spec *)
125 : blume 297 datatype persinfo =
126 : blume 666 PERS of { group: SrcPath.file * region,
127 : blume 487 generation: generation ref,
128 : blume 297 lastseen: TStamp.t ref,
129 : blume 299 parsetree: (ast * source) option ref,
130 : blume 389 skeleton: Skeleton.decl option ref,
131 :     sh_mode: Sharing.mode ref }
132 : blume 297
133 : blume 275 datatype info =
134 : blume 666 INFO of { sourcepath: SrcPath.file,
135 : blume 361 mkSkelname: unit -> string,
136 :     mkBinname: unit -> string,
137 : blume 297 persinfo: persinfo,
138 : blume 387 sh_spec: Sharing.request,
139 : blume 677 attribs: attribs,
140 : blume 986 setup: string option * string option,
141 :     locl: bool }
142 : blume 270
143 : blume 305 type ord_key = info
144 :    
145 : blume 487 local
146 :     val generation = ref (ref ())
147 :     in
148 :     fun now () = !generation
149 :     fun newGeneration () = generation := ref ()
150 :     end
151 :    
152 : blume 277 fun sourcepath (INFO { sourcepath = sp, ... }) = sp
153 : blume 361 fun skelname (INFO { mkSkelname = msn, ... }) = msn ()
154 :     fun binname (INFO { mkBinname = mbn, ... }) = mbn ()
155 : blume 387 fun sh_spec (INFO { sh_spec = s, ... }) = s
156 : blume 389 fun sh_mode (INFO { persinfo = PERS { sh_mode = ref m, ... }, ... }) = m
157 :     fun set_sh_mode (INFO { persinfo = PERS { sh_mode, ... }, ... }, m) =
158 :     sh_mode := m
159 : blume 537 fun attribs (INFO { attribs = a, ... }) = a
160 : blume 677 fun setup (INFO { setup = s, ... }) = s
161 : blume 986 fun is_local (INFO { locl, ... }) = locl
162 : blume 270
163 : blume 299 fun gerror (gp: GeneralParams.info) = GroupReg.error (#groupreg gp)
164 : blume 297
165 :     fun error gp (INFO { persinfo = PERS { group, ... }, ... }) =
166 :     gerror gp group
167 :    
168 : blume 632 fun group (INFO { persinfo = PERS { group = (g, _), ... }, ... }) = g
169 :    
170 : blume 279 fun compare (INFO { sourcepath = p, ... }, INFO { sourcepath = p', ... }) =
171 : blume 354 SrcPath.compare (p, p')
172 : blume 279 fun eq (i, i') = compare (i, i') = EQUAL
173 :    
174 : blume 301 fun lastseen (INFO { persinfo = PERS { lastseen, ... }, ... }) =
175 :     !lastseen
176 :    
177 : blume 354 val knownInfo = ref (SrcPathMap.empty: persinfo SrcPathMap.map)
178 : blume 277
179 : blume 537 fun isKnown (INFO { sourcepath, ... }) =
180 :     isSome (SrcPathMap.find (!knownInfo, sourcepath))
181 :    
182 : blume 365 fun countParseTrees () = let
183 :     fun one (PERS { parsetree = ref (SOME _), ... }, i) = i + 1
184 :     | one (_, i) = i
185 :     in
186 :     SrcPathMap.foldl one 0 (!knownInfo)
187 :     end
188 :    
189 : blume 301 fun forgetParsetree (INFO { persinfo = PERS { parsetree, ... }, ... }) =
190 :     parsetree := NONE
191 :    
192 : blume 514 fun cleanGroup nowStable g = let
193 : blume 487 val n = now ()
194 :     fun isCurrent (PERS { generation = ref gen, group = (g', _), ... }) =
195 : blume 514 ((not nowStable) andalso gen = n)
196 :     orelse SrcPath.compare (g, g') <> EQUAL
197 : blume 301 in
198 : blume 487 knownInfo := SrcPathMap.filter isCurrent (!knownInfo)
199 : blume 301 end
200 :    
201 : blume 487 fun reset () = knownInfo := SrcPathMap.empty
202 :    
203 : blume 330 (* check timestamp and throw away any invalid cache *)
204 :     fun validate (sourcepath, PERS pir) = let
205 :     (* don't use "..." pattern to have the compiler catch later
206 :     * additions to the type! *)
207 : blume 487 val { group, lastseen, parsetree, skeleton, sh_mode, generation } = pir
208 : blume 330 val ts = !lastseen
209 : blume 354 val nts = SrcPath.tstamp sourcepath
210 : blume 330 in
211 : blume 345 if TStamp.needsUpdate { source = nts, target = ts } then
212 : blume 330 (lastseen := nts;
213 : blume 487 generation := now ();
214 : blume 330 parsetree := NONE;
215 :     skeleton := NONE)
216 :     else ()
217 :     end
218 :    
219 : blume 537 fun info' attribs (gp: GeneralParams.info) arg = let
220 : blume 986 val { sourcepath, group = gr as (group, region), sh_spec, setup, locl }
221 :     = arg
222 : blume 310 val policy = #fnpolicy (#param gp)
223 : blume 361 fun mkSkelname () = FNP.mkSkelName policy sourcepath
224 :     fun mkBinname () = FNP.mkBinName policy sourcepath
225 : blume 297 val groupreg = #groupreg gp
226 :     fun newpersinfo () = let
227 : blume 354 val ts = SrcPath.tstamp sourcepath
228 : blume 330 val pi = PERS { group = gr, lastseen = ref ts,
229 : blume 389 parsetree = ref NONE, skeleton = ref NONE,
230 : blume 487 sh_mode = ref (Sharing.SHARE false),
231 :     generation = ref (now ()) }
232 : blume 281 in
233 : blume 354 knownInfo := SrcPathMap.insert (!knownInfo, sourcepath, pi);
234 : blume 297 pi
235 : blume 281 end
236 : blume 297 fun persinfo () =
237 : blume 354 case SrcPathMap.find (!knownInfo, sourcepath) of
238 : blume 297 NONE => newpersinfo ()
239 : blume 487 | SOME (pi as PERS { group = gr' as (g, r), generation, ... }) =>
240 : blume 354 if SrcPath.compare (group, g) <> EQUAL then let
241 :     val n = SrcPath.descr sourcepath
242 : blume 322 in
243 : blume 487 if !generation = now () then
244 : blume 322 (gerror gp gr EM.COMPLAIN
245 :     (concat ["ML source file ", n,
246 :     " appears in more than one group"])
247 :     EM.nullErrorBody;
248 :     gerror gp gr' EM.COMPLAIN
249 :     (concat ["(previous occurence of ", n, ")"])
250 :     EM.nullErrorBody)
251 :     else
252 :     gerror gp gr EM.WARN
253 :     (concat ["ML source file ", n,
254 :     " has switched groups"])
255 :     EM.nullErrorBody;
256 :     newpersinfo ()
257 :     end
258 : blume 330 else (validate (sourcepath, pi); pi)
259 : blume 281 in
260 : blume 297 INFO { sourcepath = sourcepath,
261 : blume 361 mkSkelname = mkSkelname,
262 :     mkBinname = mkBinname,
263 : blume 297 persinfo = persinfo (),
264 : blume 387 sh_spec = sh_spec,
265 : blume 677 attribs = attribs,
266 : blume 986 setup = setup,
267 :     locl = locl }
268 : blume 281 end
269 : blume 277
270 : blume 818 fun info split = info' { split = split, extra_compenv = NONE,
271 :     is_rts = false, explicit_core_sym = NONE }
272 : blume 537
273 : blume 275 (* the following functions are only concerned with getting the data,
274 :     * not with checking time stamps *)
275 : blume 297 fun getParseTree gp (i as INFO ir, quiet, noerrors) = let
276 :     val { sourcepath, persinfo = PERS { parsetree, ... }, ... } = ir
277 : blume 281 val err = if noerrors then (fn m => ())
278 : blume 297 else (fn m => error gp i EM.COMPLAIN m EM.nullErrorBody)
279 : blume 274 in
280 : blume 275 case !parsetree of
281 :     SOME pt => SOME pt
282 :     | NONE => let
283 : blume 345 fun work stream = let
284 :     val _ = if noerrors orelse quiet then ()
285 : blume 354 else Say.vsay ["[parsing ",
286 :     SrcPath.descr sourcepath, "]\n"]
287 : blume 710 (* The logic is a bit tricky here:
288 :     * If "noerrors" is set we want to suppress error
289 :     * messages from the parser. This is done using
290 :     * a dummy error consumer that does nothing. However,
291 :     * if we do that we get a "source" object that has
292 :     * a dummy error consumer hard-wired into it. As a
293 :     * result we also don't see error messages from the
294 :     * elaborator in this case -- bad. So we make
295 :     * TWO "source" objects that share the same input
296 :     * stream but used different error consumers. *)
297 :     val (source, parse_source) = let
298 :     val normal_ec = #errcons gp
299 :     val source =
300 :     Source.newSource (SrcPath.osstring' sourcepath,
301 :     1, stream, false, normal_ec)
302 :     in
303 :     if noerrors then let
304 :     val dummy_ec = { consumer = fn (x: string) => (),
305 :     linewidth = #linewidth normal_ec,
306 :     flush = fn () => () }
307 :     val parse_source =
308 : blume 711 (* clone of "source", mute error consumer *)
309 :     { sourceMap = #sourceMap source,
310 :     fileOpened = #fileOpened source,
311 :     interactive = #interactive source,
312 :     sourceStream = #sourceStream source,
313 :     anyErrors = #anyErrors source,
314 :     errConsumer = dummy_ec }
315 : blume 710 in
316 :     (source, parse_source)
317 :     end
318 :     else (source, source)
319 :     end
320 : blume 275 in
321 : blume 710 (SF.parse parse_source, source)
322 : blume 345 end
323 : blume 364 fun openIt () = TextIO.openIn (SrcPath.osstring sourcepath)
324 : blume 345 val pto =
325 :     SOME (SafeIO.perform { openIt = openIt,
326 :     closeIt = TextIO.closeIn,
327 :     work = work,
328 : blume 459 cleanup = fn _ => () })
329 : blume 365 (* Counting the trees explicitly may be a bit slow,
330 :     * but maintaining an accurate count is difficult, so
331 :     * this method should be robust. (I don't think that
332 :     * the overhead of counting will make a noticeable
333 :     * difference.) *)
334 :     val ntrees = countParseTrees ()
335 : blume 433 val treelimit = #get StdConfig.parse_caching ()
336 : blume 275 in
337 : blume 365 if ntrees < treelimit then
338 :     parsetree := pto
339 :     else ();
340 : blume 275 pto
341 : blume 345 end handle exn as IO.Io _ => (err (General.exnMessage exn); NONE)
342 : blume 879 | CompileExn.Compile msg => (err msg; NONE)
343 : blume 274 end
344 :    
345 : blume 297 fun getSkeleton gp (i as INFO ir, noerrors) = let
346 : blume 361 val { sourcepath, mkSkelname, persinfo = PERS pir, ... } = ir
347 : blume 297 val { skeleton, lastseen, ... } = pir
348 : blume 275 in
349 :     case !skeleton of
350 : blume 301 SOME sk => SOME sk
351 : blume 361 | NONE => let
352 :     val skelname = mkSkelname ()
353 :     in
354 :     case SkelIO.read (skelname, !lastseen) of
355 :     SOME sk => (skeleton := SOME sk; SOME sk)
356 :     | NONE =>
357 :     (case getParseTree gp (i, false, noerrors) of
358 :     SOME (tree, source) => let
359 :     fun err sv region s =
360 :     EM.error source region sv s
361 :     EM.nullErrorBody
362 :     val { skeleton = sk, complain } =
363 :     SkelCvt.convert { tree = tree,
364 :     err = err }
365 :     in
366 :     if noerrors then () else complain ();
367 : blume 310 if EM.anyErrors (EM.errors source) then
368 : blume 361 if noerrors then ()
369 :     else error gp i EM.COMPLAIN
370 : blume 310 "error(s) in ML source file"
371 :     EM.nullErrorBody
372 : blume 354 else (SkelIO.write (skelname, sk, !lastseen);
373 : blume 310 skeleton := SOME sk);
374 :     SOME sk
375 : blume 361 end
376 :     | NONE => NONE)
377 :     end
378 : blume 275 end
379 :    
380 : blume 330 fun skeleton0 noerrors gp i = getSkeleton gp (i, noerrors)
381 : blume 281
382 :     (* we only complain at the time of getting the exports *)
383 : blume 301 fun exports gp i = Option.map SkelExports.exports (skeleton0 false gp i)
384 : blume 281 val skeleton = skeleton0 true
385 : blume 275
386 : blume 330 fun parsetree gp i = getParseTree gp (i, true, true)
387 : blume 282
388 : blume 354 fun descr (INFO { sourcepath, ... }) = SrcPath.descr sourcepath
389 : blume 305
390 : blume 306 fun errorLocation (gp: GeneralParams.info) (INFO i) = let
391 :     val { persinfo = PERS { group = (group, reg), ... }, ... } = i
392 : blume 305 in
393 : blume 306 EM.matchErrorString (GroupReg.lookup (#groupreg gp) group) reg
394 : blume 305 end
395 : blume 270 end

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