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/SMLNJ/src/cm/depend/build.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/cm/depend/build.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 630 - (view) (download)

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

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