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 281 - (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 : blume 281 exception Lookup
148 :    
149 : blume 279 (* lookup function for things not defined in the same ML file.
150 :     * As a side effect, this function registers local and
151 :     * global imports. *)
152 :     fun lookimport s = let
153 :     fun lookfar () =
154 :     case SM.find (subexports, s) of
155 :     SOME (farn, e) => (globalImport farn; e)
156 :     | NONE => (SmlInfo.error i
157 : blume 280 (concat (AbsPath.spec f ::
158 : blume 279 ": reference to unknown " ::
159 :     symDesc (s, [])))
160 :     EM.nullErrorBody;
161 : blume 281 raise Lookup)
162 : blume 279 in
163 : blume 278 case SM.find (localdefs, s) of
164 : blume 279 SOME i' =>
165 :     if isSelf i' then lookfar ()
166 :     else let
167 :     val (n, e) = getResult (i', (s, i) :: history)
168 :     in
169 :     localImport n;
170 :     e
171 :     end
172 :     | NONE => lookfar ()
173 :     end
174 :    
175 :     (* build the lookup function for DG.env *)
176 : blume 281 val lookup_exn = look lookimport
177 : blume 279
178 :     fun lookSymPath e (SP.SPATH []) = DG.EMPTY
179 :     | lookSymPath e (SP.SPATH (p as (h :: t))) = let
180 :     fun dotPath [] = []
181 :     | dotPath [s] = [S.name s]
182 :     | dotPath (h :: t) = S.name h :: "." :: dotPath t
183 :     fun complain s =
184 : blume 281 (SmlInfo.error i
185 :     (concat
186 :     (AbsPath.spec f ::
187 :     ": undefined " ::
188 :     symDesc (s, " in path " :: dotPath p)))
189 :     EM.nullErrorBody;
190 :     raise Lookup)
191 :     val lookup_exn' = look complain
192 : blume 279 fun loop (e, []) = e
193 : blume 281 | loop (e, h :: t) = loop (lookup_exn' e h, t)
194 : blume 279 in
195 : blume 281 loop (lookup_exn e h, t) handle Lookup => DG.EMPTY
196 : blume 279 end
197 :    
198 : blume 281 fun lookup e s = lookup_exn e s handle Lookup => DG.EMPTY
199 :    
200 : blume 279 (* "eval" -- compute the export environment of a skeleton *)
201 :     fun eval sk = let
202 :     fun layer' f [] = DG.EMPTY
203 :     | layer' f [x] = f x
204 :     | layer' f (h :: t) =
205 :     foldl (fn (x, r) => DG.LAYER (f x, r)) (f h) t
206 :    
207 :     fun evalDecl e (SK.StrDecl l) = let
208 :     fun one { name, def, constraint = NONE } =
209 :     DG.BINDING (name, evalStrExp e def)
210 :     | one { name, def, constraint = SOME constr } =
211 :     (ignore (evalStrExp e def);
212 :     DG.BINDING (name, evalStrExp e constr))
213 : blume 278 in
214 : blume 279 layer' one l
215 : blume 278 end
216 : blume 279 | evalDecl e (SK.FctDecl l) = let
217 :     fun one { name, def } =
218 :     DG.BINDING (name, evalFctExp e def)
219 :     in
220 :     layer' one l
221 :     end
222 :     | evalDecl e (SK.LocalDecl (d1, d2)) =
223 :     evalDecl (DG.LAYER (evalDecl e d1, e)) d2
224 :     | evalDecl e (SK.SeqDecl l) =
225 :     foldl (fn (d, e') =>
226 :     DG.LAYER (evalDecl (DG.LAYER (e', e)) d, e'))
227 :     DG.EMPTY l
228 :     | evalDecl e (SK.OpenDecl l) = layer' (evalStrExp e) l
229 :     | evalDecl e (SK.DeclRef s) =
230 :     (SS.app (ignore o lookup e) s; DG.EMPTY)
231 : blume 278
232 : blume 279 and evalStrExp e (SK.VarStrExp sp) = lookSymPath e sp
233 :     | evalStrExp e (SK.BaseStrExp d) = evalDecl e d
234 :     | evalStrExp e (SK.AppStrExp (sp, l)) =
235 :     (app (ignore o evalStrExp e) l; lookSymPath e sp)
236 :     | evalStrExp e (SK.LetStrExp (d, se)) =
237 :     evalStrExp (DG.LAYER (evalDecl e d, e)) se
238 :     | evalStrExp e (SK.ConStrExp (se1, se2)) =
239 :     (ignore (evalStrExp e se1); evalStrExp e se2)
240 :    
241 :     and evalFctExp e (SK.VarFctExp (sp, feopt)) =
242 :     getOpt (Option.map (evalFctExp e) feopt,
243 :     lookSymPath e sp)
244 :     | evalFctExp e (SK.BaseFctExp x) = let
245 :     val { params, body, constraint } = x
246 :     val parame = evalDecl e params
247 :     val bodye = DG.LAYER (parame, e)
248 :     in
249 :     getOpt (Option.map (evalStrExp bodye) constraint,
250 :     evalStrExp bodye body)
251 :     end
252 :     | evalFctExp e (SK.AppFctExp (sp, l, feopt)) =
253 :     (app (ignore o evalStrExp e) l;
254 :     getOpt (Option.map (evalFctExp e) feopt,
255 :     lookSymPath e sp))
256 :     | evalFctExp e (SK.LetFctExp (d, fe)) =
257 :     evalFctExp (DG.LAYER (evalDecl e d, e)) fe
258 :     in
259 :     evalDecl DG.EMPTY sk
260 :     end
261 :    
262 :     val e = eval (SmlInfo.skeleton i)
263 :     val n = DG.NODE { smlinfo = i,
264 :     localimports = !li,
265 :     globalimports = !gi }
266 : blume 278 in
267 : blume 279 (n, e)
268 : blume 278 end
269 :    
270 :     (* run the analysis on one ML file -- causing the blackboard
271 :     * and the root set to be updated accordingly *)
272 :     fun doSmlFile i = ignore (getResult (i, []))
273 : blume 279
274 :     (* converting smlinfos to nodes *)
275 :     val i2n = #1 o valOf o valOf o fetch
276 : blume 277 in
277 : blume 279 (* run the analysis *)
278 :     app doSmlFile smlfiles;
279 :     (* generate map from export symbol to node and
280 :     * also return the root set *)
281 :     { nodemap = SM.map i2n localdefs,
282 :     rootset = map i2n (AbsPathMap.listItems (!rs)) }
283 : blume 277 end
284 :     end

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