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

Parent Directory | Revision Log

---

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

---

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