Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/depend/build.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 291 - (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 layer' f [] = DE.EMPTY
189 : blume 279 | layer' f [x] = f x
190 :     | layer' f (h :: t) =
191 : blume 286 foldl (fn (x, r) => DE.LAYER (f x, r)) (f h) t
192 : blume 279
193 : blume 286 fun evalDecl e (SK.Bind (name, def)) =
194 :     DE.BINDING (name, evalModExp e def)
195 :     | evalDecl e (SK.Local (d1, d2)) =
196 :     evalDecl (DE.LAYER (evalDecl e d1, e)) d2
197 :     | evalDecl e (SK.Seq l) =
198 : blume 279 foldl (fn (d, e') =>
199 : blume 286 DE.LAYER (evalDecl (DE.LAYER (e', e)) d, e'))
200 :     DE.EMPTY l
201 :     | evalDecl e (SK.Par l) = layer' (evalDecl e) l
202 :     | evalDecl e (SK.Open s) = evalModExp e s
203 :     | evalDecl e (SK.Ref s) =
204 :     (SS.app (ignore o lookup e) s; DE.EMPTY)
205 : blume 278
206 : blume 286 and evalModExp e (SK.Var sp) = lookSymPath e sp
207 :     | evalModExp e (SK.Decl d) = evalDecl e d
208 :     | evalModExp e (SK.Let (d, m)) =
209 :     evalModExp (DE.LAYER (evalDecl e d, e)) m
210 : blume 291 | evalModExp e (SK.Ign1 (m1, m2)) =
211 : blume 286 (ignore (evalModExp e m1); evalModExp e m2)
212 : blume 279 in
213 : blume 286 evalDecl DE.EMPTY sk
214 : blume 279 end
215 :    
216 :     val e = eval (SmlInfo.skeleton i)
217 : blume 282 val n = DG.SNODE { smlinfo = i,
218 :     localimports = !li,
219 :     globalimports = !gi }
220 : blume 278 in
221 : blume 279 (n, e)
222 : blume 278 end
223 :    
224 :     (* run the analysis on one ML file -- causing the blackboard
225 : blume 286 * to be updated accordingly *)
226 : blume 278 fun doSmlFile i = ignore (getResult (i, []))
227 : blume 279
228 : blume 283 (* converting smlinfos to sbnodes * env *)
229 :     fun i2sbn i = let
230 :     val (sn, e) = valOf (valOf (fetch i))
231 :     in
232 :     (DG.SB_SNODE sn, e)
233 :     end
234 :    
235 :     (* run the analysis *)
236 :     val _ = app doSmlFile smlfiles
237 :    
238 :     fun addDummyFilt (sbn, e) = ((NONE, sbn), e)
239 :    
240 :     (* First we make a map of all locally defined symbols to
241 :     * the local "far sb node"
242 :     * but with only a dummy filter attached.
243 :     * This makes it consistent with the current state
244 :     * of "imports" and "gimports" where there can be filters, but
245 :     * where those filters are not yet strengthened according to fopt *)
246 :     val localmap = SM.map (addDummyFilt o i2sbn) localdefs
247 :    
248 :     val exports =
249 :     case fopt of
250 :     NONE =>
251 :     (* There is no filter -- so we are in an ordinary
252 :     * group and should export all gimports as well as
253 :     * all local definitions.
254 :     * No filter strengthening is necessary. *)
255 :     SM.unionWith #1 (localmap, gimports)
256 :     | SOME ss => let
257 :     (* There is a filter.
258 :     * We export only the things in the filter.
259 :     * They can be taken from either localmap or else from
260 :     * imports. In either case, it is necessary to strengthen
261 :     * the filter attached to each node. *)
262 :     fun strengthen ((fopt', sbn), e) = let
263 :     val new_fopt =
264 :     case fopt' of
265 :     NONE => fopt
266 :     | SOME ss' => SOME (SS.intersection (ss, ss'))
267 :     in
268 : blume 286 ((new_fopt, sbn), DE.FILTER (ss, e))
269 : blume 283 end
270 :     val availablemap = SM.unionWith #1 (localmap, imports)
271 :     fun addNodeFor (s, m) =
272 :     case SM.find (availablemap, s) of
273 :     SOME n => SM.insert (m, s, strengthen n)
274 :     | NONE => (error
275 :     (concat ("exported " ::
276 :     symDesc (s, [" not defined"])));
277 :     m)
278 :     in
279 :     SS.foldl addNodeFor SM.empty ss
280 :     end
281 : blume 277 in
282 : blume 283 exports
283 : blume 277 end
284 :     end

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