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

Parent Directory | Revision Log

---

Revision 326 - (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	299	fun info (gp: GeneralParams.info) arg = let
130 :	blume	326	val { sourcepath, group = gr as (group, region), share, split } = arg
131 :	blume	310	val policy = #fnpolicy (#param gp)
132 :			val skelpath = FNP.mkSkelPath policy sourcepath
133 :			val binpath = FNP.mkBinPath policy sourcepath
134 :	blume	297	val groupreg = #groupreg gp
135 :			fun newpersinfo () = let
136 :			val pi = PERS { group = gr, lastseen = ref TStamp.NOTSTAMP,
137 :			parsetree = ref NONE, skeleton = ref NONE }
138 :	blume	281	in
139 :	blume	297	knownInfo := AbsPathMap.insert (!knownInfo, sourcepath, pi);
140 :			pi
141 :	blume	281	end
142 :	blume	297	fun persinfo () =
143 :			case AbsPathMap.find (!knownInfo, sourcepath) of
144 :			NONE => newpersinfo ()
145 :			| SOME (pi as PERS { group = gr' as (g, r), ... }) =>
146 :	blume	322	if AbsPath.compare (group, g) <> EQUAL then let
147 :			val n = AbsPath.name sourcepath
148 :			in
149 :			if GroupReg.registered groupreg g then
150 :			(gerror gp gr EM.COMPLAIN
151 :			(concat ["ML source file ", n,
152 :			" appears in more than one group"])
153 :			EM.nullErrorBody;
154 :			gerror gp gr' EM.COMPLAIN
155 :			(concat ["(previous occurence of ", n, ")"])
156 :			EM.nullErrorBody)
157 :			else
158 :			gerror gp gr EM.WARN
159 :			(concat ["ML source file ", n,
160 :			" has switched groups"])
161 :			EM.nullErrorBody;
162 :			newpersinfo ()
163 :			end
164 :	blume	297	else pi
165 :	blume	281	in
166 :	blume	297	INFO { sourcepath = sourcepath,
167 :	blume	310	skelpath = skelpath,
168 :			binpath = binpath,
169 :	blume	297	persinfo = persinfo (),
170 :	blume	326	share = share,
171 :			split = split }
172 :	blume	281	end
173 :	blume	277
174 :	blume	275	(* check timestamp and throw away any invalid cache *)
175 :			fun validate (INFO ir) = let
176 :			(* don't use "..." pattern to have the compiler catch later
177 :			* additions to the type! *)
178 :	blume	326	val { sourcepath, skelpath, binpath, persinfo = PERS pir,
179 :			share, split } = ir
180 :	blume	297	val { group, lastseen, parsetree, skeleton } = pir
181 :	blume	275	val ts = !lastseen
182 :			val nts = AbsPath.tstamp sourcepath
183 :	blume	274	in
184 :	blume	275	if TStamp.earlier (ts, nts) then
185 :			(lastseen := nts;
186 :			parsetree := NONE;
187 :			skeleton := NONE)
188 :			else ()
189 :	blume	274	end
190 :
191 :	blume	275	(* the following functions are only concerned with getting the data,
192 :			* not with checking time stamps *)
193 :	blume	297	fun getParseTree gp (i as INFO ir, quiet, noerrors) = let
194 :			val { sourcepath, persinfo = PERS { parsetree, ... }, ... } = ir
195 :	blume	276	val name = AbsPath.name sourcepath
196 :	blume	281	val err = if noerrors then (fn m => ())
197 :	blume	297	else (fn m => error gp i EM.COMPLAIN m EM.nullErrorBody)
198 :	blume	274	in
199 :	blume	275	case !parsetree of
200 :			SOME pt => SOME pt
201 :			| NONE => let
202 :			val stream = AbsPath.openTextIn sourcepath
203 :	blume	281	val _ = if noerrors orelse quiet then ()
204 :	blume	310	else Say.vsay ["[parsing ", name, "]\n"]
205 :	blume	275	val source =
206 :	blume	309	Source.newSource (name, 1, stream, false, #errcons gp)
207 :	blume	275	val pto = let
208 :			val tree = SF.parse source
209 :			in
210 :	blume	299	SOME (tree, source)
211 :	blume	275	end handle SF.Compile msg => (TextIO.closeIn stream;
212 :	blume	281	err msg;
213 :	blume	275	NONE)
214 :	blume	276	| exn => (TextIO.closeIn stream; raise exn)
215 :	blume	275	in
216 :			TextIO.closeIn stream;
217 :			parsetree := pto;
218 :			pto
219 :	blume	281	end handle exn as IO.Io _ => (err (General.exnMessage exn);
220 :			NONE)
221 :	blume	274	end
222 :
223 :	blume	297	fun getSkeleton gp (i as INFO ir, noerrors) = let
224 :	blume	310	val { sourcepath, skelpath, persinfo = PERS pir, ... } = ir
225 :	blume	297	val { skeleton, lastseen, ... } = pir
226 :	blume	275	in
227 :			case !skeleton of
228 :	blume	301	SOME sk => SOME sk
229 :	blume	310	| NONE =>
230 :			(case SkelIO.read (skelpath, !lastseen) of
231 :			SOME sk => (skeleton := SOME sk; SOME sk)
232 :			| NONE =>
233 :			(case getParseTree gp (i, false, noerrors) of
234 :			SOME (tree, source) => let
235 :			fun err sv region s =
236 :			EM.error source region sv s
237 :			EM.nullErrorBody
238 :			val { skeleton = sk, complain } =
239 :			SkelCvt.convert { tree = tree,
240 :			err = err }
241 :			in
242 :			if noerrors then () else complain ();
243 :			if EM.anyErrors (EM.errors source) then
244 :			if noerrors then ()
245 :			else error gp i EM.COMPLAIN
246 :			"error(s) in ML source file"
247 :			EM.nullErrorBody
248 :			else (SkelIO.write (skelpath, sk);
249 :			skeleton := SOME sk);
250 :			SOME sk
251 :			end
252 :			| NONE => NONE))
253 :	blume	275	end
254 :
255 :			(* first check the time stamp, then do your stuff... *)
256 :	blume	297	fun skeleton0 noerrors gp i = (validate i; getSkeleton gp (i, noerrors))
257 :	blume	281
258 :			(* we only complain at the time of getting the exports *)
259 :	blume	301	fun exports gp i = Option.map SkelExports.exports (skeleton0 false gp i)
260 :	blume	281	val skeleton = skeleton0 true
261 :	blume	275
262 :	blume	301	fun parsetree gp i =
263 :			(validate i;
264 :			getParseTree gp (i, true, true))
265 :	blume	282
266 :	blume	280	fun spec (INFO { sourcepath, ... }) = AbsPath.spec sourcepath
267 :	blume	297	fun fullSpec (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
268 :			concat [AbsPath.spec (#1 group), "(", AbsPath.spec sourcepath, ")"]
269 :	blume	280	fun name (INFO { sourcepath, ... }) = AbsPath.name sourcepath
270 :	blume	297	fun fullName (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
271 :			concat [AbsPath.name (#1 group), "(", AbsPath.spec sourcepath, ")"]
272 :	blume	305
273 :	blume	306	fun errorLocation (gp: GeneralParams.info) (INFO i) = let
274 :			val { persinfo = PERS { group = (group, reg), ... }, ... } = i
275 :	blume	305	in
276 :	blume	306	EM.matchErrorString (GroupReg.lookup (#groupreg gp) group) reg
277 :	blume	305	end
278 :	blume	270	end

---

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