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