Annotation of /sml/trunk/src/cm/depend/build.sml

Parent Directory | Revision Log

---

Revision 370 - (view) (download)

1 :	blume	286	(*
2 :			* Build the dependency graph for one group/library.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :	blume	279	signature BUILDDEPEND = sig
9 :	blume	283	type impexp = DependencyGraph.impexp
10 :
11 :			val build :
12 :			{ imports: impexp SymbolMap.map,
13 :			gimports: impexp SymbolMap.map,
14 :			smlfiles: SmlInfo.info list,
15 :	blume	294	localdefs: SmlInfo.info SymbolMap.map,
16 :	blume	354	subgroups: (SrcPath.t * GroupGraph.group) list,
17 :	blume	301	reqpriv: GroupGraph.privileges }
18 :	blume	283	* SymbolSet.set option (* filter *)
19 :	blume	299	* GeneralParams.info
20 :	blume	283	->
21 :			impexp SymbolMap.map (* exports *)
22 :	blume	301	* GroupGraph.privileges (* required privileges (aggregate) *)
23 :	blume	355
24 :			(* for the autoloader *)
25 :			type looker = Symbol.symbol -> DAEnv.env
26 :			val look : looker -> DAEnv.env -> looker
27 :			val processOneSkeleton : looker -> Skeleton.decl -> unit
28 :	blume	279	end
29 :	blume	277
30 :	blume	279	structure BuildDepend :> BUILDDEPEND = struct
31 :
32 :	blume	278	structure S = Symbol
33 :	blume	277	structure SS = SymbolSet
34 :	blume	278	structure SM = SymbolMap
35 :	blume	277	structure SK = Skeleton
36 :			structure DG = DependencyGraph
37 :	blume	286	structure DE = DAEnv
38 :	blume	279	structure EM = GenericVC.ErrorMsg
39 :			structure SP = GenericVC.SymPath
40 :	blume	277
41 :	blume	283	type impexp = DG.impexp
42 :
43 :	blume	355	type looker = Symbol.symbol -> DAEnv.env
44 :
45 :	blume	286	fun look otherwise DE.EMPTY s = otherwise s
46 :			| look otherwise (DE.BINDING (s', v)) s =
47 :	blume	278	if S.eq (s, s') then v else otherwise s
48 :	blume	286	| look otherwise (DE.LAYER (e, e')) s = look (look otherwise e') e s
49 :	blume	308	| look otherwise (DE.FCTENV looker) s =
50 :	blume	278	(case looker s of NONE => otherwise s | SOME v => v)
51 :	blume	286	| look otherwise (DE.FILTER (ss, e)) s =
52 :			if SymbolSet.member (ss, s) then look otherwise e s else otherwise s
53 :	blume	279
54 :	blume	355	fun evalOneSkeleton lookimport = let
55 :			(* build the lookup function for DG.env *)
56 :			val lookup = look lookimport
57 :
58 :			fun lookSymPath e (SP.SPATH []) = DE.EMPTY
59 :			| lookSymPath e (SP.SPATH (p as (h :: t))) = let
60 :			(* again, if we don't find it here we just ignore
61 :			* the problem and let the compiler catch it later *)
62 :			val lookup' = look (fn _ => DE.EMPTY)
63 :			fun loop (e, []) = e
64 :			| loop (e, h :: t) = loop (lookup' e h, t)
65 :			in
66 :			loop (lookup e h, t)
67 :			end
68 :
69 :			(* "eval" -- compute the export environment of a skeleton *)
70 :			fun eval sk = let
71 :			fun evalDecl e (SK.Bind (name, def)) =
72 :			DE.BINDING (name, evalModExp e def)
73 :			| evalDecl e (SK.Local (d1, d2)) =
74 :			evalDecl (DE.LAYER (evalDecl e d1, e)) d2
75 :			| evalDecl e (SK.Seq l) = evalSeqDecl e l
76 :			| evalDecl e (SK.Par []) = DE.EMPTY
77 :			| evalDecl e (SK.Par (h :: t)) =
78 :			foldl (fn (x, r) => DE.LAYER (evalDecl e x, r))
79 :			(evalDecl e h) t
80 :			| evalDecl e (SK.Open s) = evalModExp e s
81 :			| evalDecl e (SK.Ref s) =
82 :			(SS.app (ignore o lookup e) s; DE.EMPTY)
83 :
84 :			and evalSeqDecl e [] = DE.EMPTY
85 :			| evalSeqDecl e (h :: t) = let
86 :			fun one (d, e') =
87 :			DE.LAYER (evalDecl (DE.LAYER (e', e)) d, e')
88 :			in
89 :			foldl one (evalDecl e h) t
90 :			end
91 :
92 :			and evalModExp e (SK.Var sp) = lookSymPath e sp
93 :			| evalModExp e (SK.Decl l) = evalSeqDecl e l
94 :			| evalModExp e (SK.Let (d, m)) =
95 :			evalModExp (DE.LAYER (evalSeqDecl e d, e)) m
96 :			| evalModExp e (SK.Ign1 (m1, m2)) =
97 :			(ignore (evalModExp e m1); evalModExp e m2)
98 :			in
99 :			evalDecl DE.EMPTY sk
100 :			end
101 :			in
102 :			eval
103 :			end
104 :
105 :			fun processOneSkeleton lookimport sk =
106 :			ignore (evalOneSkeleton lookimport sk)
107 :
108 :	blume	279	(* get the description for a symbol *)
109 :			fun symDesc (s, r) =
110 :	blume	294	S.nameSpaceToString (S.nameSpace s) :: " " :: S.name s :: r
111 :	blume	279
112 :	blume	364	fun build (coll, fopt, gp) = let
113 :	blume	301	val { imports, gimports, smlfiles, localdefs, subgroups, reqpriv } =
114 :			coll
115 :	blume	277
116 :	blume	278	(* the "blackboard" where analysis results are announced *)
117 :			(* (also used for cycle detection) *)
118 :	blume	305	val bb = ref SmlInfoMap.empty
119 :			fun lock i = bb := SmlInfoMap.insert (!bb, i, NONE)
120 :			fun release (i, r) = (bb := SmlInfoMap.insert (!bb, i, SOME r); r)
121 :			fun fetch i = SmlInfoMap.find (!bb, i)
122 :	blume	277
123 :	blume	278	(* - get the result from the blackboard if it is there *)
124 :			(* - otherwise trigger analysis *)
125 :			(* - detect cycles using locking *)
126 :			(* - maintain root set *)
127 :	blume	277	fun getResult (i, history) =
128 :			case fetch i of
129 :	blume	286	NONE => (lock i; release (i, analyze (i, history)))
130 :			| SOME (SOME r) => r
131 :	blume	278	| SOME NONE => let (* cycle found --> error message *)
132 :	blume	277	val f = SmlInfo.sourcepath i
133 :			fun pphist pps = let
134 :	blume	280	fun recur (_, []) = () (* shouldn't happen *)
135 :			| recur (n'', (s, i') :: r) = let
136 :	blume	277	val f' = SmlInfo.sourcepath i'
137 :	blume	354	val n' = SrcPath.specOf f'
138 :	blume	278	val _ =
139 :	blume	279	if SmlInfo.eq (i, i') then ()
140 :	blume	280	else recur (n', r)
141 :	blume	277	val l =
142 :			n' :: " refers to " ::
143 :	blume	280	symDesc (s, [" defined in ", n''])
144 :	blume	277	in
145 :			app (PrettyPrint.add_string pps) l;
146 :			PrettyPrint.add_newline pps
147 :			end
148 :			in
149 :	blume	280	PrettyPrint.add_newline pps;
150 :	blume	354	recur (SrcPath.specOf f, history)
151 :	blume	277	end
152 :			in
153 :	blume	297	SmlInfo.error gp i EM.COMPLAIN
154 :	blume	295	"cyclic ML dependencies" pphist;
155 :	blume	282	release (i, (DG.SNODE { smlinfo = i,
156 :			localimports = [],
157 :			globalimports = [] },
158 :	blume	286	DE.EMPTY))
159 :	blume	277	end
160 :
161 :	blume	279	(* do the actual analysis of an ML source and generate the
162 :			* corresponding node *)
163 :	blume	278	and analyze (i, history) = let
164 :	blume	279	val li = ref []
165 :			val gi = ref []
166 :
167 :			(* register a local import *)
168 :	blume	282	fun localImport n =
169 :			if List.exists (fn n' => DG.seq (n, n')) (!li) then ()
170 :	blume	279	else li := n :: !li
171 :
172 :			(* register a global import, maintain filter sets *)
173 :	blume	282	fun globalImport (f, n) = let
174 :			fun sameN (_, n') = DG.sbeq (n, n')
175 :			in
176 :			case List.find sameN (!gi) of
177 :			NONE => gi := (f, n) :: !gi (* brand new *)
178 :			| SOME (NONE, n') => () (* no filter -> no change *)
179 :			| SOME (SOME f', n') => let
180 :			(* there is a filter...
181 :			* calculate "union", see if there is a change,
182 :			* and if so, replace the filter *)
183 :			fun replace filt =
184 :			gi := (filt, n) :: List.filter (not o sameN) (!gi)
185 :			in
186 :			case f of
187 :			NONE => replace NONE
188 :			| SOME f =>
189 :			if SS.equal (f, f') then ()
190 :			else replace (SOME (SS.union (f, f')))
191 :			end
192 :			end
193 :	blume	279
194 :			val f = SmlInfo.sourcepath i
195 :			fun isSelf i' = SmlInfo.eq (i, i')
196 :
197 :			(* lookup function for things not defined in the same ML file.
198 :			* As a side effect, this function registers local and
199 :			* global imports. *)
200 :			fun lookimport s = let
201 :	blume	309	fun internalError s =
202 :			EM.impossible "build/lookimport/lookfar"
203 :	blume	279	fun lookfar () =
204 :	blume	283	case SM.find (imports, s) of
205 :	blume	309	SOME (farn, e) => (globalImport farn;
206 :			look internalError e s)
207 :	blume	301	| NONE =>
208 :			(* We could complain here about an undefined
209 :			* name. However, since CM doesn't have the
210 :			* proper source locations available, it is
211 :			* better to handle this case silently and
212 :			* have the compiler catch the problem later. *)
213 :			DE.EMPTY
214 :	blume	279	in
215 :	blume	278	case SM.find (localdefs, s) of
216 :	blume	279	SOME i' =>
217 :			if isSelf i' then lookfar ()
218 :			else let
219 :			val (n, e) = getResult (i', (s, i) :: history)
220 :			in
221 :			localImport n;
222 :			e
223 :			end
224 :			| NONE => lookfar ()
225 :			end
226 :
227 :	blume	355	val eval = evalOneSkeleton lookimport
228 :	blume	279
229 :	blume	301	val e = case SmlInfo.skeleton gp i of
230 :			SOME sk => eval sk
231 :			| NONE => DE.EMPTY
232 :
233 :	blume	370	fun addTrap n = (n, ref false)
234 :	blume	282	val n = DG.SNODE { smlinfo = i,
235 :	blume	370	localimports = map addTrap (!li),
236 :			globalimports = map addTrap (!gi) }
237 :	blume	278	in
238 :	blume	279	(n, e)
239 :	blume	278	end
240 :
241 :			(* run the analysis on one ML file -- causing the blackboard
242 :	blume	286	* to be updated accordingly *)
243 :	blume	278	fun doSmlFile i = ignore (getResult (i, []))
244 :	blume	279
245 :	blume	283	(* converting smlinfos to sbnodes * env *)
246 :			fun i2sbn i = let
247 :			val (sn, e) = valOf (valOf (fetch i))
248 :			in
249 :			(DG.SB_SNODE sn, e)
250 :			end
251 :
252 :			(* run the analysis *)
253 :			val _ = app doSmlFile smlfiles
254 :
255 :			fun addDummyFilt (sbn, e) = ((NONE, sbn), e)
256 :
257 :			(* First we make a map of all locally defined symbols to
258 :			* the local "far sb node"
259 :			* but with only a dummy filter attached.
260 :			* This makes it consistent with the current state
261 :			* of "imports" and "gimports" where there can be filters, but
262 :			* where those filters are not yet strengthened according to fopt *)
263 :			val localmap = SM.map (addDummyFilt o i2sbn) localdefs
264 :
265 :			val exports =
266 :			case fopt of
267 :			NONE =>
268 :			(* There is no filter -- so we are in an ordinary
269 :			* group and should export all gimports as well as
270 :			* all local definitions.
271 :			* No filter strengthening is necessary. *)
272 :			SM.unionWith #1 (localmap, gimports)
273 :			| SOME ss => let
274 :			(* There is a filter.
275 :			* We export only the things in the filter.
276 :			* They can be taken from either localmap or else from
277 :			* imports. In either case, it is necessary to strengthen
278 :			* the filter attached to each node. *)
279 :			fun strengthen ((fopt', sbn), e) = let
280 :			val new_fopt =
281 :			case fopt' of
282 :			NONE => fopt
283 :			| SOME ss' => SOME (SS.intersection (ss, ss'))
284 :			in
285 :	blume	286	((new_fopt, sbn), DE.FILTER (ss, e))
286 :	blume	283	end
287 :			val availablemap = SM.unionWith #1 (localmap, imports)
288 :			fun addNodeFor (s, m) =
289 :			case SM.find (availablemap, s) of
290 :			SOME n => SM.insert (m, s, strengthen n)
291 :	blume	357	| NONE =>
292 :			(* This should never happen since we
293 :			* checked beforehand during
294 :			* parsing/semantic analysis *)
295 :			EM.impossible "build: undefined export"
296 :	blume	283	in
297 :			SS.foldl addNodeFor SM.empty ss
298 :			end
299 :	blume	277	in
300 :	blume	301	(exports, reqpriv)
301 :	blume	277	end
302 :			end

---

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