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

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