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 279 - (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 :     fun recur [] = () (* shouldn't happen *)
62 :     | recur ((s, i') :: r) = let
63 :     val f' = SmlInfo.sourcepath i'
64 : blume 278 val _ =
65 : blume 279 if SmlInfo.eq (i, i') then ()
66 : blume 277 else recur r
67 :     val n' = AbsPath.name f'
68 :     val l =
69 :     n' :: " refers to " ::
70 :     symDesc (s, [" defined in ..."])
71 :     in
72 :     app (PrettyPrint.add_string pps) l;
73 :     PrettyPrint.add_newline pps
74 :     end
75 :     in
76 :     recur history;
77 :     PrettyPrint.add_string pps (AbsPath.name f);
78 :     PrettyPrint.add_newline pps
79 :     end
80 :     in
81 : blume 279 SmlInfo.error i "cyclic ML dependencies" pphist;
82 :     release (i, (DG.NODE { smlinfo = i,
83 :     localimports = [],
84 :     globalimports = [] },
85 :     DG.EMPTY))
86 : blume 277 end
87 :    
88 : blume 279 (* do the actual analysis of an ML source and generate the
89 :     * corresponding node *)
90 : blume 278 and analyze (i, history) = let
91 : blume 279 val li = ref []
92 :     val gi = ref []
93 :    
94 :     (* register a local import *)
95 :     fun localImport (n as DG.NODE { smlinfo = i, ... }) = let
96 :     fun sameNode (DG.NODE { smlinfo = i', ... }) =
97 :     SmlInfo.eq (i, i')
98 :     in
99 :     if List.exists sameNode (!li) then ()
100 :     else li := n :: !li
101 :     end
102 :    
103 :     (* register a global import, maintain filter sets *)
104 :     fun globalImport (farn as DG.PNODE p) = let
105 :     fun sameFarNode (DG.FARNODE _) = false
106 :     | sameFarNode (DG.PNODE p') = Primitive.eq (p, p')
107 :     in
108 :     if List.exists sameFarNode (!gi) then ()
109 :     else gi := farn :: !gi
110 :     end
111 :     | globalImport (farn as DG.FARNODE (f, n)) = let
112 :     fun sameFarNode (DG.PNODE _) = false
113 :     | sameFarNode (DG.FARNODE (_, n')) = let
114 :     val DG.NODE { smlinfo = i, ... } = n
115 :     val DG.NODE { smlinfo = i', ... } = n'
116 :     in
117 :     SmlInfo.eq (i, i')
118 :     end
119 :     in
120 :     case List.find sameFarNode (!gi) of
121 :     NONE => gi := farn :: !gi (* brand new *)
122 :     | SOME (DG.FARNODE (NONE, n')) => ()
123 :     (* no filter before -> no change *)
124 :     | SOME (DG.FARNODE (SOME f', n')) => let
125 :     (* there is a filter ...
126 :     * calculate "union-filter", see if there is
127 :     * a change, and if so, replace the filter *)
128 :     fun replace filt =
129 :     gi :=
130 :     (DG.FARNODE (filt, n)) ::
131 :     (List.filter (not o sameFarNode) (!gi))
132 :     in
133 :     case f of
134 :     NONE => replace NONE
135 :     | SOME f =>
136 :     if SS.equal (f, f') then ()
137 :     else replace (SOME (SS.union (f, f')))
138 :     end
139 :    
140 :     | SOME (DG.PNODE _) => () (* cannot happen *)
141 :     end
142 :    
143 :     val f = SmlInfo.sourcepath i
144 :     fun isSelf i' = SmlInfo.eq (i, i')
145 :    
146 :     (* lookup function for things not defined in the same ML file.
147 :     * As a side effect, this function registers local and
148 :     * global imports. *)
149 :     fun lookimport s = let
150 :     fun lookfar () =
151 :     case SM.find (subexports, s) of
152 :     SOME (farn, e) => (globalImport farn; e)
153 :     | NONE => (SmlInfo.error i
154 :     (concat (AbsPath.name f ::
155 :     ": reference to unknown " ::
156 :     symDesc (s, [])))
157 :     EM.nullErrorBody;
158 :     DG.EMPTY)
159 :     in
160 : blume 278 case SM.find (localdefs, s) of
161 : blume 279 SOME i' =>
162 :     if isSelf i' then lookfar ()
163 :     else let
164 :     val (n, e) = getResult (i', (s, i) :: history)
165 :     in
166 :     localImport n;
167 :     e
168 :     end
169 :     | NONE => lookfar ()
170 :     end
171 :    
172 :     (* build the lookup function for DG.env *)
173 :     val lookup = look lookimport
174 :    
175 :     fun lookSymPath e (SP.SPATH []) = DG.EMPTY
176 :     | lookSymPath e (SP.SPATH (p as (h :: t))) = let
177 :     fun dotPath [] = []
178 :     | dotPath [s] = [S.name s]
179 :     | dotPath (h :: t) = S.name h :: "." :: dotPath t
180 :     val firstTime = ref true
181 :     fun complain s =
182 :     if !firstTime then
183 :     (SmlInfo.error i
184 :     (concat
185 :     ("undefined " ::
186 :     symDesc (s, " in path " :: dotPath p)))
187 :     EM.nullErrorBody;
188 :     firstTime := false;
189 :     DG.EMPTY)
190 :     else DG.EMPTY
191 :     val lookup' = look complain
192 :     fun loop (e, []) = e
193 :     | loop (e, h :: t) = loop (lookup' e h, t)
194 :     in
195 :     loop (lookup e h, t)
196 :     end
197 :    
198 :     (* "eval" -- compute the export environment of a skeleton *)
199 :     fun eval sk = let
200 :     fun layer' f [] = DG.EMPTY
201 :     | layer' f [x] = f x
202 :     | layer' f (h :: t) =
203 :     foldl (fn (x, r) => DG.LAYER (f x, r)) (f h) t
204 :    
205 :     fun evalDecl e (SK.StrDecl l) = let
206 :     fun one { name, def, constraint = NONE } =
207 :     DG.BINDING (name, evalStrExp e def)
208 :     | one { name, def, constraint = SOME constr } =
209 :     (ignore (evalStrExp e def);
210 :     DG.BINDING (name, evalStrExp e constr))
211 : blume 278 in
212 : blume 279 layer' one l
213 : blume 278 end
214 : blume 279 | evalDecl e (SK.FctDecl l) = let
215 :     fun one { name, def } =
216 :     DG.BINDING (name, evalFctExp e def)
217 :     in
218 :     layer' one l
219 :     end
220 :     | evalDecl e (SK.LocalDecl (d1, d2)) =
221 :     evalDecl (DG.LAYER (evalDecl e d1, e)) d2
222 :     | evalDecl e (SK.SeqDecl l) =
223 :     foldl (fn (d, e') =>
224 :     DG.LAYER (evalDecl (DG.LAYER (e', e)) d, e'))
225 :     DG.EMPTY l
226 :     | evalDecl e (SK.OpenDecl l) = layer' (evalStrExp e) l
227 :     | evalDecl e (SK.DeclRef s) =
228 :     (SS.app (ignore o lookup e) s; DG.EMPTY)
229 : blume 278
230 : blume 279 and evalStrExp e (SK.VarStrExp sp) = lookSymPath e sp
231 :     | evalStrExp e (SK.BaseStrExp d) = evalDecl e d
232 :     | evalStrExp e (SK.AppStrExp (sp, l)) =
233 :     (app (ignore o evalStrExp e) l; lookSymPath e sp)
234 :     | evalStrExp e (SK.LetStrExp (d, se)) =
235 :     evalStrExp (DG.LAYER (evalDecl e d, e)) se
236 :     | evalStrExp e (SK.ConStrExp (se1, se2)) =
237 :     (ignore (evalStrExp e se1); evalStrExp e se2)
238 :    
239 :     and evalFctExp e (SK.VarFctExp (sp, feopt)) =
240 :     getOpt (Option.map (evalFctExp e) feopt,
241 :     lookSymPath e sp)
242 :     | evalFctExp e (SK.BaseFctExp x) = let
243 :     val { params, body, constraint } = x
244 :     val parame = evalDecl e params
245 :     val bodye = DG.LAYER (parame, e)
246 :     in
247 :     getOpt (Option.map (evalStrExp bodye) constraint,
248 :     evalStrExp bodye body)
249 :     end
250 :     | evalFctExp e (SK.AppFctExp (sp, l, feopt)) =
251 :     (app (ignore o evalStrExp e) l;
252 :     getOpt (Option.map (evalFctExp e) feopt,
253 :     lookSymPath e sp))
254 :     | evalFctExp e (SK.LetFctExp (d, fe)) =
255 :     evalFctExp (DG.LAYER (evalDecl e d, e)) fe
256 :     in
257 :     evalDecl DG.EMPTY sk
258 :     end
259 :    
260 :     val e = eval (SmlInfo.skeleton i)
261 :     val n = DG.NODE { smlinfo = i,
262 :     localimports = !li,
263 :     globalimports = !gi }
264 : blume 278 in
265 : blume 279 (n, e)
266 : blume 278 end
267 :    
268 :     (* run the analysis on one ML file -- causing the blackboard
269 :     * and the root set to be updated accordingly *)
270 :     fun doSmlFile i = ignore (getResult (i, []))
271 : blume 279
272 :     (* converting smlinfos to nodes *)
273 :     val i2n = #1 o valOf o valOf o fetch
274 : blume 277 in
275 : blume 279 (* run the analysis *)
276 :     app doSmlFile smlfiles;
277 :     (* generate map from export symbol to node and
278 :     * also return the root set *)
279 :     { nodemap = SM.map i2n localdefs,
280 :     rootset = map i2n (AbsPathMap.listItems (!rs)) }
281 : blume 277 end
282 :     end

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