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 345 - (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 282 val resync : unit -> unit (* rebuild internal table *)
21 : blume 277
22 : blume 279 val eq : info * info -> bool (* compares sourcepaths *)
23 :     val compare : info * info -> order (* compares sourcepaths *)
24 :    
25 : blume 299 val info : GeneralParams.info ->
26 : blume 274 { sourcepath: AbsPath.t,
27 : blume 297 group: AbsPath.t * region,
28 : blume 326 share: bool option,
29 :     split: bool }
30 : blume 270 -> info
31 :    
32 : blume 277 val sourcepath : info -> AbsPath.t
33 : blume 310 val skelpath : info -> AbsPath.t
34 :     val binpath : info -> AbsPath.t
35 : blume 299 val error : GeneralParams.info -> info -> complainer
36 : blume 277
37 : blume 299 val parsetree : GeneralParams.info -> info -> (ast * source) option
38 : blume 301 val exports : GeneralParams.info -> info -> SymbolSet.set option
39 :     val skeleton : GeneralParams.info -> info -> Skeleton.decl option
40 : blume 295 val share : info -> bool option
41 : blume 326 val split : info -> bool
42 : blume 301 val lastseen : info -> TStamp.t
43 : blume 279
44 : blume 301 (* forget a parse tree that we are done with *)
45 :     val forgetParsetree : info -> unit
46 :    
47 :     (* evict all but the reachable nodes in the cache *)
48 :     val forgetAllBut : AbsPathSet.set -> unit
49 :    
50 : blume 280 (* different ways of describing an sml file using group and source *)
51 :     val spec : info -> string (* sspec *)
52 :     val fullSpec : info -> string (* gspec(sspec) *)
53 :     val name : info -> string (* sname *)
54 :     val fullName : info -> string (* gname(sspec) *)
55 : blume 305
56 : blume 306 val errorLocation : GeneralParams.info -> info -> string
57 : blume 270 end
58 :    
59 :     structure SmlInfo :> SMLINFO = struct
60 :    
61 : blume 275 structure Source = GenericVC.Source
62 :     structure SF = GenericVC.SmlFile
63 :     structure EM = GenericVC.ErrorMsg
64 : blume 286 structure FNP = FilenamePolicy
65 : blume 275
66 :     type source = Source.inputSource
67 : blume 297 type ast = GenericVC.Ast.dec
68 :     type region = GenericVC.SourceMap.region
69 : blume 274
70 : blume 295 type complainer = EM.complainer
71 : blume 274
72 : blume 297 datatype persinfo =
73 :     PERS of { group: AbsPath.t * region,
74 :     lastseen: TStamp.t ref,
75 : blume 299 parsetree: (ast * source) option ref,
76 : blume 297 skeleton: Skeleton.decl option ref }
77 :    
78 : blume 275 datatype info =
79 : blume 297 INFO of { sourcepath: AbsPath.t,
80 : blume 310 skelpath: AbsPath.t,
81 :     binpath: AbsPath.t,
82 : blume 297 persinfo: persinfo,
83 : blume 326 share: bool option,
84 :     split: bool }
85 : blume 270
86 : blume 305 type ord_key = info
87 :    
88 : blume 277 fun sourcepath (INFO { sourcepath = sp, ... }) = sp
89 : blume 310 fun skelpath (INFO { skelpath = sp, ... }) = sp
90 :     fun binpath (INFO { binpath = bp, ... }) = bp
91 : blume 295 fun share (INFO { share = s, ... }) = s
92 : blume 326 fun split (INFO { split = s, ... }) = s
93 : blume 270
94 : blume 299 fun gerror (gp: GeneralParams.info) = GroupReg.error (#groupreg gp)
95 : blume 297
96 :     fun error gp (INFO { persinfo = PERS { group, ... }, ... }) =
97 :     gerror gp group
98 :    
99 : blume 279 fun compare (INFO { sourcepath = p, ... }, INFO { sourcepath = p', ... }) =
100 :     AbsPath.compare (p, p')
101 :     fun eq (i, i') = compare (i, i') = EQUAL
102 :    
103 : blume 301 fun lastseen (INFO { persinfo = PERS { lastseen, ... }, ... }) =
104 :     !lastseen
105 :    
106 : blume 277 (* If files change their file ids, then CM will be seriously
107 :     * disturbed because the ordering relation will change.
108 :     * We'll asume that this won't happen in general. However, we provide
109 :     * a "resync" function that -- at the very least -- should be run
110 :     * at startup time. *)
111 : blume 297 val knownInfo = ref (AbsPathMap.empty: persinfo AbsPathMap.map)
112 : blume 277
113 :     fun resync () = let
114 :     val l = AbsPathMap.listItemsi (!knownInfo)
115 :     in
116 :     AbsPath.newEra (); (* force recalculation of file ids *)
117 :     knownInfo := foldl AbsPathMap.insert' AbsPathMap.empty l
118 :     end
119 :    
120 : blume 301 fun forgetParsetree (INFO { persinfo = PERS { parsetree, ... }, ... }) =
121 :     parsetree := NONE
122 :    
123 :     fun forgetAllBut reachable = let
124 : blume 302 fun isReachable (p, m) = AbsPathSet.member (reachable, p)
125 : blume 301 in
126 : blume 302 knownInfo := AbsPathMap.filteri isReachable (!knownInfo)
127 : blume 301 end
128 :    
129 : blume 330 (* check timestamp and throw away any invalid cache *)
130 :     fun validate (sourcepath, PERS pir) = let
131 :     (* don't use "..." pattern to have the compiler catch later
132 :     * additions to the type! *)
133 :     val { group, lastseen, parsetree, skeleton } = pir
134 :     val ts = !lastseen
135 :     val nts = AbsPath.tstamp sourcepath
136 :     in
137 : blume 345 if TStamp.needsUpdate { source = nts, target = ts } then
138 : blume 330 (lastseen := nts;
139 :     parsetree := NONE;
140 :     skeleton := NONE)
141 :     else ()
142 :     end
143 :    
144 : blume 299 fun info (gp: GeneralParams.info) arg = let
145 : blume 326 val { sourcepath, group = gr as (group, region), share, split } = arg
146 : blume 310 val policy = #fnpolicy (#param gp)
147 :     val skelpath = FNP.mkSkelPath policy sourcepath
148 :     val binpath = FNP.mkBinPath policy sourcepath
149 : blume 297 val groupreg = #groupreg gp
150 :     fun newpersinfo () = let
151 : blume 330 val ts = AbsPath.tstamp sourcepath
152 :     val pi = PERS { group = gr, lastseen = ref ts,
153 : blume 297 parsetree = ref NONE, skeleton = ref NONE }
154 : blume 281 in
155 : blume 297 knownInfo := AbsPathMap.insert (!knownInfo, sourcepath, pi);
156 :     pi
157 : blume 281 end
158 : blume 297 fun persinfo () =
159 :     case AbsPathMap.find (!knownInfo, sourcepath) of
160 :     NONE => newpersinfo ()
161 :     | SOME (pi as PERS { group = gr' as (g, r), ... }) =>
162 : blume 322 if AbsPath.compare (group, g) <> EQUAL then let
163 :     val n = AbsPath.name sourcepath
164 :     in
165 :     if GroupReg.registered groupreg g then
166 :     (gerror gp gr EM.COMPLAIN
167 :     (concat ["ML source file ", n,
168 :     " appears in more than one group"])
169 :     EM.nullErrorBody;
170 :     gerror gp gr' EM.COMPLAIN
171 :     (concat ["(previous occurence of ", n, ")"])
172 :     EM.nullErrorBody)
173 :     else
174 :     gerror gp gr EM.WARN
175 :     (concat ["ML source file ", n,
176 :     " has switched groups"])
177 :     EM.nullErrorBody;
178 :     newpersinfo ()
179 :     end
180 : blume 330 else (validate (sourcepath, pi); pi)
181 : blume 281 in
182 : blume 297 INFO { sourcepath = sourcepath,
183 : blume 310 skelpath = skelpath,
184 :     binpath = binpath,
185 : blume 297 persinfo = persinfo (),
186 : blume 326 share = share,
187 :     split = split }
188 : blume 281 end
189 : blume 277
190 : blume 275 (* the following functions are only concerned with getting the data,
191 :     * not with checking time stamps *)
192 : blume 297 fun getParseTree gp (i as INFO ir, quiet, noerrors) = let
193 :     val { sourcepath, persinfo = PERS { parsetree, ... }, ... } = ir
194 : blume 276 val name = AbsPath.name sourcepath
195 : blume 281 val err = if noerrors then (fn m => ())
196 : blume 297 else (fn m => error gp i EM.COMPLAIN m EM.nullErrorBody)
197 : blume 274 in
198 : blume 275 case !parsetree of
199 :     SOME pt => SOME pt
200 :     | NONE => let
201 : blume 345 fun work stream = let
202 :     val _ = if noerrors orelse quiet then ()
203 :     else Say.vsay ["[parsing ", name, "]\n"]
204 :     val source =
205 :     Source.newSource (name, 1, stream, false, #errcons gp)
206 : blume 275 in
207 : blume 345 (SF.parse source, source)
208 :     end
209 :     fun openIt () = AbsPath.openTextIn sourcepath
210 :     val pto =
211 :     SOME (SafeIO.perform { openIt = openIt,
212 :     closeIt = TextIO.closeIn,
213 :     work = work,
214 :     cleanup = fn () => () })
215 : blume 275 in
216 :     parsetree := pto;
217 :     pto
218 : blume 345 end handle exn as IO.Io _ => (err (General.exnMessage exn); NONE)
219 :     | SF.Compile msg => (err msg; NONE)
220 : blume 274 end
221 :    
222 : blume 297 fun getSkeleton gp (i as INFO ir, noerrors) = let
223 : blume 310 val { sourcepath, skelpath, persinfo = PERS pir, ... } = ir
224 : blume 297 val { skeleton, lastseen, ... } = pir
225 : blume 275 in
226 :     case !skeleton of
227 : blume 301 SOME sk => SOME sk
228 : blume 310 | NONE =>
229 :     (case SkelIO.read (skelpath, !lastseen) of
230 :     SOME sk => (skeleton := SOME sk; SOME sk)
231 :     | NONE =>
232 :     (case getParseTree gp (i, false, noerrors) of
233 :     SOME (tree, source) => let
234 :     fun err sv region s =
235 :     EM.error source region sv s
236 :     EM.nullErrorBody
237 :     val { skeleton = sk, complain } =
238 :     SkelCvt.convert { tree = tree,
239 :     err = err }
240 :     in
241 :     if noerrors then () else complain ();
242 :     if EM.anyErrors (EM.errors source) then
243 :     if noerrors then ()
244 :     else error gp i EM.COMPLAIN
245 :     "error(s) in ML source file"
246 :     EM.nullErrorBody
247 : blume 345 else (SkelIO.write (skelpath, sk, !lastseen);
248 : blume 310 skeleton := SOME sk);
249 :     SOME sk
250 :     end
251 :     | NONE => NONE))
252 : blume 275 end
253 :    
254 : blume 330 fun skeleton0 noerrors gp i = getSkeleton gp (i, noerrors)
255 : blume 281
256 :     (* we only complain at the time of getting the exports *)
257 : blume 301 fun exports gp i = Option.map SkelExports.exports (skeleton0 false gp i)
258 : blume 281 val skeleton = skeleton0 true
259 : blume 275
260 : blume 330 fun parsetree gp i = getParseTree gp (i, true, true)
261 : blume 282
262 : blume 280 fun spec (INFO { sourcepath, ... }) = AbsPath.spec sourcepath
263 : blume 297 fun fullSpec (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
264 :     concat [AbsPath.spec (#1 group), "(", AbsPath.spec sourcepath, ")"]
265 : blume 280 fun name (INFO { sourcepath, ... }) = AbsPath.name sourcepath
266 : blume 297 fun fullName (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
267 :     concat [AbsPath.name (#1 group), "(", AbsPath.spec sourcepath, ")"]
268 : blume 305
269 : blume 306 fun errorLocation (gp: GeneralParams.info) (INFO i) = let
270 :     val { persinfo = PERS { group = (group, reg), ... }, ... } = i
271 : blume 305 in
272 : blume 306 EM.matchErrorString (GroupReg.lookup (#groupreg gp) group) reg
273 : blume 305 end
274 : blume 270 end

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