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

Parent Directory | Revision Log

---

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

---

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