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 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