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/compiler/TopLevel/environ/environ.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/TopLevel/environ/environ.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1989 by AT&T Bell Laboratories *)
2 :     (* environ.sml *)
3 :    
4 :     structure Environment: ENVIRONMENT =
5 :     struct
6 :    
7 :     local structure A = Access
8 :     structure S = Symbol
9 :     structure M = Modules
10 :     structure V = VarCon
11 :     structure T = Types
12 :     structure MU = ModuleUtil
13 :     structure B = Bindings
14 :     structure SE = StaticEnv
15 :     structure DE = DynamicEnv
16 :     structure SY = SymbolicEnv
17 :     in
18 :    
19 :     type symbol = S.symbol
20 :     type staticEnv = SE.staticEnv
21 :     type dynenv = DE.dynenv
22 :     type symenv = SY.symenv
23 :    
24 :     type environment = { static: staticEnv, dynamic: dynenv, symbolic: symenv }
25 :    
26 :     fun bug msg = ErrorMsg.impossible("Environment: "^msg)
27 :    
28 :     fun staticPart (e: environment) = #static e
29 :     fun dynamicPart (e: environment) = #dynamic e
30 :     fun symbolicPart (e: environment) = #symbolic e
31 :    
32 :     fun mkenv (e as { static, dynamic, symbolic }) = e
33 :    
34 :     val emptyEnv = {static = SE.empty,
35 :     dynamic = DE.empty,
36 :     symbolic = SY.empty}
37 :    
38 :     fun layerEnv({static, dynamic, symbolic},
39 :     {static=sta, dynamic=dy, symbolic=sy}) =
40 :     {static = SE.atop (static, sta),
41 :     dynamic = DE.atop (dynamic, dy),
42 :     symbolic = SY.atop (symbolic, sy)}
43 :    
44 :     val layerStatic = SE.atop
45 :     val layerSymbolic = SY.atop
46 :    
47 :     fun consolidateEnv ({ static, dynamic, symbolic }) =
48 :     {static = SE.consolidate static,
49 :     dynamic = DE.consolidate dynamic,
50 :     symbolic = SY.consolidate symbolic}
51 :    
52 :     val consolidateStatic = SE.consolidate
53 :     val consolidateSymbolic = SY.consolidate
54 :    
55 :     fun root(A.EXTERN pid) = SOME pid
56 :     | root(A.PATH(p,i)) = root p
57 :     | root _ = NONE
58 :    
59 :     (* getting the stamp from a binding *)
60 :     fun stampOf(B.VALbind(V.VALvar {access=a, ...})) = root a
61 :     | stampOf(B.CONbind(T.DATACON {rep=A.EXN a, ...})) = root a
62 :     | stampOf(B.STRbind(M.STR {access=a, ...})) = root a
63 :     | stampOf(B.FCTbind(M.FCT {access=a, ...})) = root a
64 :     | stampOf _ = NONE
65 :    
66 :    
67 :     (* functions to collect stale dynamic pids for unbinding in concatEnv *)
68 :    
69 :     (*
70 :     * stalePids: takes a new environment and a base environment to which
71 :     * it is to be added and returns a list of pids that are unreachable
72 :     * when the new environment is added to the base environment
73 :     *
74 :     * what we do instead:
75 :     * - count the number of occurences for each pid in baseEnv bindings
76 :     * that is going to be shadowed by deltaEnv
77 :     * - count the total number of total occurences for each such
78 :     * pids in baseEnv
79 :     * - the ones where the counts coincide are stale
80 :     *
81 :     * This code is ok, because deltaEnv is the output of `export'. `export'
82 :     * calls consolidateStatic, therefore we don't have duplicate bindings
83 :     * of the same symbol.
84 :     *)
85 :     fun stalePids (deltaEnv, baseEnv) =
86 :     let
87 :    
88 :     (* any rebindings? *)
89 :     val anyrebound = ref false
90 :    
91 :     (* counting map *)
92 :     val countM = ref (PersMap.empty: int ref PersMap.map)
93 :     fun look s =
94 :     SOME (PersMap.lookup (!countM) s) handle PersMap.MapF => NONE
95 :    
96 :     (* initialize the counter map: for each new binding with stamp
97 :     * check if the same symbol was bound in the old env and enter
98 :     * the old stamp into the map *)
99 :     fun initOne s =
100 :     case look s
101 :     of NONE => countM := PersMap.add (!countM, s, ref (~1))
102 :     | SOME r => r := (!r) - 1
103 :    
104 :     fun initC (sy, _) =
105 :     (case stampOf (SE.look (baseEnv, sy))
106 :     of NONE => ()
107 :     | SOME s => (initOne s; anyrebound := true))
108 :     handle SE.Unbound => ()
109 :     (* increment counter for a given stamp *)
110 :     fun incr NONE = ()
111 :     | incr (SOME s) =
112 :     case look s
113 :     of NONE => ()
114 :     | SOME r => r := (!r) + 1
115 :    
116 :     fun incC (_, b) = incr (stampOf b)
117 :     (* select the 0s *)
118 :     fun selZero ((s, ref 0), zeros) = s :: zeros
119 :     | selZero (_, zeros) = zeros
120 :     in
121 :     SE.app initC deltaEnv; (* init counter map *)
122 :     if !anyrebound then let (* shortcut if no rebindings *)
123 :     (* count the pids *)
124 :     val _ = SE.app incC baseEnv
125 :     (* pick out the stale ones *)
126 :     val stalepids = foldl selZero [] (PersMap.members (!countM))
127 :     in
128 :     stalepids
129 :     end
130 :     else []
131 :     end
132 :    
133 :     fun concatEnv ({ static = newstat, dynamic = newdyn, symbolic = newsym },
134 :     { static = oldstat, dynamic = olddyn, symbolic = oldsym }) =
135 :     let val hidden_pids = stalePids (newstat, oldstat)
136 :     val slimdyn = DE.remove (hidden_pids, olddyn)
137 :     val slimsym = SY.remove (hidden_pids, oldsym)
138 :     in {static=SE.consolidateLazy(SE.atop(newstat, oldstat)),
139 :     dynamic=DE.atop(newdyn, slimdyn),
140 :     symbolic=SY.atop(newsym, slimsym)}
141 :     end
142 :    
143 :     fun getbindings(static: staticEnv, symbols: S.symbol list) :
144 :     (S.symbol * B.binding) list =
145 :     let fun loop([], bindings) = bindings
146 :     | loop(s::rest, bindings) =
147 :     let val bindings' = (s,SE.look(static,s)) :: bindings
148 :     handle SE.Unbound => bindings
149 :     in loop (rest, bindings')
150 :     end
151 :     in loop(symbols,[])
152 :     end
153 :    
154 :     fun copystat([], senv) = senv
155 :     | copystat((s,b)::l, senv) = copystat(l,SE.bind(s, b, senv))
156 :    
157 :     fun filterStaticEnv(static: staticEnv, symbols: S.symbol list) : staticEnv =
158 :     copystat(getbindings(static, symbols), SE.empty)
159 :    
160 :     fun filterEnv({static, dynamic, symbolic}: environment, symbols) =
161 :     let val sbindings = getbindings (static, symbols)
162 :     fun copydynsym ([], denv, syenv) = (denv, syenv)
163 :     | copydynsym ((_, b) :: l, denv, syenv) =
164 :     (case stampOf b
165 :     of NONE => copydynsym (l, denv, syenv)
166 :     | SOME pid =>
167 :     let val dy = DE.look dynamic pid
168 :     val denv = DE.bind (pid, dy, denv)
169 :     val sy = SY.look symbolic pid
170 :     val syenv = case sy
171 :     of NONE => syenv
172 :     | SOME sy => SY.bind (pid, sy, syenv)
173 :     in copydynsym (l, denv, syenv)
174 :     end)
175 :     val senv = copystat(sbindings, SE.empty)
176 :     val (denv, syenv) = copydynsym(sbindings, DE.empty, SY.empty)
177 :     in {static =senv, dynamic = denv, symbolic = syenv}
178 :     end
179 :    
180 :     fun catalogEnv static : S.symbol list = map #1 (SE.sort static)
181 :    
182 :     (* CM-style environment lookup *)
183 :     datatype cmEnv
184 :     = CM_NONE
185 :     | CM_ENV of {look : S.symbol -> cmEnv,
186 :     symbols : unit -> S.symbol list}
187 :    
188 :     exception CmEnvOfModule
189 :    
190 :     fun lookElems elements sym =
191 :     (case MU.getSpec(elements,sym)
192 :     of M.STRspec{sign,...} => sigenv sign
193 :     | M.FCTspec{sign,...} => fsgenv sign
194 :     | _ => CM_NONE)
195 :     handle MU.Unbound _ => CM_NONE
196 :    
197 :     and sigenv (s as M.SIG{elements, ...}) =
198 :     CM_ENV {look = lookElems(elements),
199 :     symbols = (fn () => MU.getSigSymbols s)}
200 :     | sigenv _ = CM_NONE
201 :    
202 :     (*
203 :     * The following is a hack to make the cmEnvOfModule function consistent
204 :     * with the changes made on ast during the elaboration of ast into absyn.
205 :     * Syntactic changes made on ast by the elaborator should be propagated
206 :     * to this function so that CM can do the correct job. I personally think
207 :     * that syntactic changes on curried functors and insertions of <resultStr>s
208 :     * should be done on Ast directly, before the elaboration --- this way, we
209 :     * don't have to write the following ugly sigenvSp function.
210 :     *
211 :     *)
212 :     and sigenvSp (M.SIG{elements=[(sym,M.STRspec{sign,...})],...}) =
213 :     if S.name sym = "<resultStr>" then sigenv sign
214 :     else bug "unexpected case <resultStr> in sigenvSp"
215 :     | sigenvSp (M.SIG{elements=[(sym,M.FCTspec{sign,...})],...}) =
216 :     if S.name sym = "<functor>" then fsgenv sign
217 :     else bug "unexpected case <functtor> in sigenvSp"
218 :     | sigenvSp _ = bug "unexpected case in signenvSp"
219 :    
220 :     and fsgenv (M.FSIG{bodysig,...}) = sigenvSp bodysig
221 :     | fsgenv _ = CM_NONE
222 :    
223 :     fun strenv(M.STR{sign,...}) = sigenv sign
224 :     | strenv M.ERRORstr = CM_NONE
225 :    
226 :     fun fctenv(M.FCT{sign,...}) = fsgenv sign
227 :     | fctenv _ = CM_NONE
228 :    
229 :     fun cmEnvOfModule env sym =
230 :     (case SE.look(env,sym)
231 :     of B.SIGbind b => sigenv b
232 :     | B.STRbind b => strenv b
233 :     | B.FSGbind b => fsgenv b
234 :     | B.FCTbind b => fctenv b
235 :     | _ => CM_NONE)
236 :     handle SE.Unbound => CM_NONE
237 :    
238 :     fun describe static (s: symbol) : unit =
239 :     let open PrettyPrint
240 :     in with_pp (ErrorMsg.defaultConsumer())
241 :     (fn ppstrm =>
242 :     (begin_block ppstrm CONSISTENT 0;
243 :     PPModules.ppBinding ppstrm
244 :     (s, SE.look(static,s), static, !Control.Print.printDepth);
245 :     add_newline ppstrm;
246 :     end_block ppstrm))
247 :     end handle SE.Unbound => print (S.name s ^ " not found\n")
248 :    
249 :     val primEnv = PrimEnv.primEnv
250 :    
251 :     end (* local *)
252 :     end (* structure Environment *)
253 :    
254 :    
255 :     (*
256 :     * $Log: environ.sml,v $
257 :     * Revision 1.3 1997/12/03 05:10:22 dbm
258 :     * Fix for spurious error messages (e.g. testing/modules/tests/228.sml)
259 :     * caused by CM autoloading. cmEnvOfModule changed to bypass <resultStr>
260 :     * and <functor> special bindings.
261 :     *
262 :     * Revision 1.2 1997/08/15 20:39:53 dbm
263 :     * Use new consolidateLazy in place of consolidate to reduce top-level
264 :     * loop overhead.
265 :     *
266 :     * Revision 1.1.1.1 1997/01/14 01:38:36 george
267 :     * Version 109.24
268 :     *
269 :     *)

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