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/branches/primop-branch-3/cm/depend/build.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/cm/depend/build.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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