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

Parent Directory | Revision Log

---

Revision 280 - (view) (download)

1 :	blume	279	signature BUILDDEPEND = sig
2 :			val build : { subexports: (DependencyGraph.farnode * DependencyGraph.env)
3 :			SymbolMap.map,
4 :			smlfiles: SmlInfo.info list,
5 :			localdefs: SmlInfo.info SymbolMap.map }
6 :			-> { nodemap: DependencyGraph.node SymbolMap.map,
7 :			rootset: DependencyGraph.node list }
8 :			end
9 :	blume	277
10 :	blume	279	structure BuildDepend :> BUILDDEPEND = struct
11 :
12 :	blume	278	structure S = Symbol
13 :	blume	277	structure SS = SymbolSet
14 :	blume	278	structure SM = SymbolMap
15 :	blume	277	structure SK = Skeleton
16 :			structure DG = DependencyGraph
17 :	blume	279	structure EM = GenericVC.ErrorMsg
18 :			structure SP = GenericVC.SymPath
19 :	blume	277
20 :	blume	278	fun look otherwise DG.EMPTY s = otherwise s
21 :			| look otherwise (DG.BINDING (s', v)) s =
22 :			if S.eq (s, s') then v else otherwise s
23 :			| look otherwise (DG.LAYER (e, e')) s = look (look otherwise e') e s
24 :			| look otherwise (DG.FCTENV { looker, domain }) s =
25 :			(case looker s of NONE => otherwise s | SOME v => v)
26 :	blume	279
27 :			(* get the description for a symbol *)
28 :			fun symDesc (s, r) =
29 :			S.nameSpaceToString (S.nameSpace s) :: " " ::
30 :			S.name s :: r
31 :
32 :	blume	278	fun build { subexports, smlfiles, localdefs } = let
33 :	blume	277
34 :	blume	278	(* the "blackboard" where analysis results are announced *)
35 :			(* (also used for cycle detection) *)
36 :			val bb = ref AbsPathMap.empty
37 :			fun lock i = bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, NONE)
38 :	blume	277	fun release (i, r) =
39 :	blume	278	(bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, SOME r); r)
40 :			fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)
41 :	blume	277
42 :	blume	278	(* the "root set" *)
43 :	blume	279	val rs = ref AbsPathMap.empty
44 :			fun addRoot i =
45 :			rs := AbsPathMap.insert (!rs, SmlInfo.sourcepath i, i)
46 :	blume	278	fun delRoot i =
47 :	blume	279	(rs := #1 (AbsPathMap.remove (!rs, SmlInfo.sourcepath i)))
48 :	blume	278	handle LibBase.NotFound => ()
49 :
50 :			(* - get the result from the blackboard if it is there *)
51 :			(* - otherwise trigger analysis *)
52 :			(* - detect cycles using locking *)
53 :			(* - maintain root set *)
54 :	blume	277	fun getResult (i, history) =
55 :			case fetch i of
56 :	blume	278	NONE => (lock i; addRoot i; release (i, analyze (i, history)))
57 :			| SOME (SOME r) => (delRoot i; r)
58 :			| SOME NONE => let (* cycle found --> error message *)
59 :	blume	277	val f = SmlInfo.sourcepath i
60 :			fun pphist pps = let
61 :	blume	280	fun recur (_, []) = () (* shouldn't happen *)
62 :			| recur (n'', (s, i') :: r) = let
63 :	blume	277	val f' = SmlInfo.sourcepath i'
64 :	blume	280	val n' = AbsPath.spec f'
65 :	blume	278	val _ =
66 :	blume	279	if SmlInfo.eq (i, i') then ()
67 :	blume	280	else recur (n', r)
68 :	blume	277	val l =
69 :			n' :: " refers to " ::
70 :	blume	280	symDesc (s, [" defined in ", n''])
71 :	blume	277	in
72 :			app (PrettyPrint.add_string pps) l;
73 :			PrettyPrint.add_newline pps
74 :			end
75 :			in
76 :	blume	280	PrettyPrint.add_newline pps;
77 :			recur (AbsPath.spec f, history);
78 :			PrettyPrint.add_string pps "...";
79 :	blume	277	PrettyPrint.add_newline pps
80 :			end
81 :			in
82 :	blume	279	SmlInfo.error i "cyclic ML dependencies" pphist;
83 :			release (i, (DG.NODE { smlinfo = i,
84 :			localimports = [],
85 :			globalimports = [] },
86 :			DG.EMPTY))
87 :	blume	277	end
88 :
89 :	blume	279	(* do the actual analysis of an ML source and generate the
90 :			* corresponding node *)
91 :	blume	278	and analyze (i, history) = let
92 :	blume	279	val li = ref []
93 :			val gi = ref []
94 :
95 :			(* register a local import *)
96 :			fun localImport (n as DG.NODE { smlinfo = i, ... }) = let
97 :			fun sameNode (DG.NODE { smlinfo = i', ... }) =
98 :			SmlInfo.eq (i, i')
99 :			in
100 :			if List.exists sameNode (!li) then ()
101 :			else li := n :: !li
102 :			end
103 :
104 :			(* register a global import, maintain filter sets *)
105 :			fun globalImport (farn as DG.PNODE p) = let
106 :			fun sameFarNode (DG.FARNODE _) = false
107 :			| sameFarNode (DG.PNODE p') = Primitive.eq (p, p')
108 :			in
109 :			if List.exists sameFarNode (!gi) then ()
110 :			else gi := farn :: !gi
111 :			end
112 :			| globalImport (farn as DG.FARNODE (f, n)) = let
113 :			fun sameFarNode (DG.PNODE _) = false
114 :			| sameFarNode (DG.FARNODE (_, n')) = let
115 :			val DG.NODE { smlinfo = i, ... } = n
116 :			val DG.NODE { smlinfo = i', ... } = n'
117 :			in
118 :			SmlInfo.eq (i, i')
119 :			end
120 :			in
121 :			case List.find sameFarNode (!gi) of
122 :			NONE => gi := farn :: !gi (* brand new *)
123 :			| SOME (DG.FARNODE (NONE, n')) => ()
124 :			(* no filter before -> no change *)
125 :			| SOME (DG.FARNODE (SOME f', n')) => let
126 :			(* there is a filter ...
127 :			* calculate "union-filter", see if there is
128 :			* a change, and if so, replace the filter *)
129 :			fun replace filt =
130 :			gi :=
131 :			(DG.FARNODE (filt, n)) ::
132 :			(List.filter (not o sameFarNode) (!gi))
133 :			in
134 :			case f of
135 :			NONE => replace NONE
136 :			| SOME f =>
137 :			if SS.equal (f, f') then ()
138 :			else replace (SOME (SS.union (f, f')))
139 :			end
140 :
141 :			| SOME (DG.PNODE _) => () (* cannot happen *)
142 :			end
143 :
144 :			val f = SmlInfo.sourcepath i
145 :			fun isSelf i' = SmlInfo.eq (i, i')
146 :
147 :			(* lookup function for things not defined in the same ML file.
148 :			* As a side effect, this function registers local and
149 :			* global imports. *)
150 :			fun lookimport s = let
151 :			fun lookfar () =
152 :			case SM.find (subexports, s) of
153 :			SOME (farn, e) => (globalImport farn; e)
154 :			| NONE => (SmlInfo.error i
155 :	blume	280	(concat (AbsPath.spec f ::
156 :	blume	279	": reference to unknown " ::
157 :			symDesc (s, [])))
158 :			EM.nullErrorBody;
159 :			DG.EMPTY)
160 :			in
161 :	blume	278	case SM.find (localdefs, s) of
162 :	blume	279	SOME i' =>
163 :			if isSelf i' then lookfar ()
164 :			else let
165 :			val (n, e) = getResult (i', (s, i) :: history)
166 :			in
167 :			localImport n;
168 :			e
169 :			end
170 :			| NONE => lookfar ()
171 :			end
172 :
173 :			(* build the lookup function for DG.env *)
174 :			val lookup = look lookimport
175 :
176 :			fun lookSymPath e (SP.SPATH []) = DG.EMPTY
177 :			| lookSymPath e (SP.SPATH (p as (h :: t))) = let
178 :			fun dotPath [] = []
179 :			| dotPath [s] = [S.name s]
180 :			| dotPath (h :: t) = S.name h :: "." :: dotPath t
181 :			val firstTime = ref true
182 :			fun complain s =
183 :			if !firstTime then
184 :			(SmlInfo.error i
185 :			(concat
186 :			("undefined " ::
187 :			symDesc (s, " in path " :: dotPath p)))
188 :			EM.nullErrorBody;
189 :			firstTime := false;
190 :			DG.EMPTY)
191 :			else DG.EMPTY
192 :			val lookup' = look complain
193 :			fun loop (e, []) = e
194 :			| loop (e, h :: t) = loop (lookup' e h, t)
195 :			in
196 :			loop (lookup e h, t)
197 :			end
198 :
199 :			(* "eval" -- compute the export environment of a skeleton *)
200 :			fun eval sk = let
201 :			fun layer' f [] = DG.EMPTY
202 :			| layer' f [x] = f x
203 :			| layer' f (h :: t) =
204 :			foldl (fn (x, r) => DG.LAYER (f x, r)) (f h) t
205 :
206 :			fun evalDecl e (SK.StrDecl l) = let
207 :			fun one { name, def, constraint = NONE } =
208 :			DG.BINDING (name, evalStrExp e def)
209 :			| one { name, def, constraint = SOME constr } =
210 :			(ignore (evalStrExp e def);
211 :			DG.BINDING (name, evalStrExp e constr))
212 :	blume	278	in
213 :	blume	279	layer' one l
214 :	blume	278	end
215 :	blume	279	| evalDecl e (SK.FctDecl l) = let
216 :			fun one { name, def } =
217 :			DG.BINDING (name, evalFctExp e def)
218 :			in
219 :			layer' one l
220 :			end
221 :			| evalDecl e (SK.LocalDecl (d1, d2)) =
222 :			evalDecl (DG.LAYER (evalDecl e d1, e)) d2
223 :			| evalDecl e (SK.SeqDecl l) =
224 :			foldl (fn (d, e') =>
225 :			DG.LAYER (evalDecl (DG.LAYER (e', e)) d, e'))
226 :			DG.EMPTY l
227 :			| evalDecl e (SK.OpenDecl l) = layer' (evalStrExp e) l
228 :			| evalDecl e (SK.DeclRef s) =
229 :			(SS.app (ignore o lookup e) s; DG.EMPTY)
230 :	blume	278
231 :	blume	279	and evalStrExp e (SK.VarStrExp sp) = lookSymPath e sp
232 :			| evalStrExp e (SK.BaseStrExp d) = evalDecl e d
233 :			| evalStrExp e (SK.AppStrExp (sp, l)) =
234 :			(app (ignore o evalStrExp e) l; lookSymPath e sp)
235 :			| evalStrExp e (SK.LetStrExp (d, se)) =
236 :			evalStrExp (DG.LAYER (evalDecl e d, e)) se
237 :			| evalStrExp e (SK.ConStrExp (se1, se2)) =
238 :			(ignore (evalStrExp e se1); evalStrExp e se2)
239 :
240 :			and evalFctExp e (SK.VarFctExp (sp, feopt)) =
241 :			getOpt (Option.map (evalFctExp e) feopt,
242 :			lookSymPath e sp)
243 :			| evalFctExp e (SK.BaseFctExp x) = let
244 :			val { params, body, constraint } = x
245 :			val parame = evalDecl e params
246 :			val bodye = DG.LAYER (parame, e)
247 :			in
248 :			getOpt (Option.map (evalStrExp bodye) constraint,
249 :			evalStrExp bodye body)
250 :			end
251 :			| evalFctExp e (SK.AppFctExp (sp, l, feopt)) =
252 :			(app (ignore o evalStrExp e) l;
253 :			getOpt (Option.map (evalFctExp e) feopt,
254 :			lookSymPath e sp))
255 :			| evalFctExp e (SK.LetFctExp (d, fe)) =
256 :			evalFctExp (DG.LAYER (evalDecl e d, e)) fe
257 :			in
258 :			evalDecl DG.EMPTY sk
259 :			end
260 :
261 :			val e = eval (SmlInfo.skeleton i)
262 :			val n = DG.NODE { smlinfo = i,
263 :			localimports = !li,
264 :			globalimports = !gi }
265 :	blume	278	in
266 :	blume	279	(n, e)
267 :	blume	278	end
268 :
269 :			(* run the analysis on one ML file -- causing the blackboard
270 :			* and the root set to be updated accordingly *)
271 :			fun doSmlFile i = ignore (getResult (i, []))
272 :	blume	279
273 :			(* converting smlinfos to nodes *)
274 :			val i2n = #1 o valOf o valOf o fetch
275 :	blume	277	in
276 :	blume	279	(* run the analysis *)
277 :			app doSmlFile smlfiles;
278 :			(* generate map from export symbol to node and
279 :			* also return the root set *)
280 :			{ nodemap = SM.map i2n localdefs,
281 :			rootset = map i2n (AbsPathMap.listItems (!rs)) }
282 :	blume	277	end
283 :			end

---

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