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 224 - (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 : monnier 113 local
161 :     fun copydynsym (bindings, dynamic, symbolic) = let
162 :     fun loop ([], denv, syenv) = (denv, syenv)
163 :     | loop ((_, b) :: l, denv, syenv) =
164 :     (case stampOf b
165 :     of NONE => loop (l, denv, syenv)
166 :     | SOME pid =>
167 : monnier 16 let val dy = DE.look dynamic pid
168 : monnier 113 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 loop (l, denv, syenv)
174 : monnier 16 end)
175 : monnier 113 in
176 :     loop (bindings, DE.empty, SY.empty)
177 :     end
178 :     in
179 :     fun filterEnv({static, dynamic, symbolic}: environment, symbols) =
180 :     let val sbindings = getbindings (static, symbols)
181 :     val senv = copystat(sbindings, SE.empty)
182 :     val (denv, syenv) = copydynsym(sbindings, dynamic, symbolic)
183 :     in {static =senv, dynamic = denv, symbolic = syenv}
184 :     end
185 : monnier 16
186 : monnier 113 fun catalogEnv static : S.symbol list = map #1 (SE.sort static)
187 : monnier 16
188 : monnier 113 fun trimEnv { static, dynamic, symbolic } = let
189 :     val syms = catalogEnv static
190 :     val (dynamic, symbolic) =
191 :     copydynsym (getbindings (static, syms), dynamic, symbolic)
192 :     in
193 :     { static = static, dynamic = dynamic, symbolic = symbolic }
194 :     end
195 :     end
196 :    
197 : monnier 16 (* CM-style environment lookup *)
198 :     datatype cmEnv
199 :     = CM_NONE
200 :     | CM_ENV of {look : S.symbol -> cmEnv,
201 :     symbols : unit -> S.symbol list}
202 :    
203 :     exception CmEnvOfModule
204 :    
205 :     fun lookElems elements sym =
206 :     (case MU.getSpec(elements,sym)
207 :     of M.STRspec{sign,...} => sigenv sign
208 :     | M.FCTspec{sign,...} => fsgenv sign
209 :     | _ => CM_NONE)
210 :     handle MU.Unbound _ => CM_NONE
211 :    
212 :     and sigenv (s as M.SIG{elements, ...}) =
213 :     CM_ENV {look = lookElems(elements),
214 :     symbols = (fn () => MU.getSigSymbols s)}
215 :     | sigenv _ = CM_NONE
216 :    
217 :     (*
218 :     * The following is a hack to make the cmEnvOfModule function consistent
219 :     * with the changes made on ast during the elaboration of ast into absyn.
220 :     * Syntactic changes made on ast by the elaborator should be propagated
221 :     * to this function so that CM can do the correct job. I personally think
222 :     * that syntactic changes on curried functors and insertions of <resultStr>s
223 :     * should be done on Ast directly, before the elaboration --- this way, we
224 :     * don't have to write the following ugly sigenvSp function.
225 :     *
226 :     *)
227 :     and sigenvSp (M.SIG{elements=[(sym,M.STRspec{sign,...})],...}) =
228 :     if S.name sym = "<resultStr>" then sigenv sign
229 :     else bug "unexpected case <resultStr> in sigenvSp"
230 :     | sigenvSp (M.SIG{elements=[(sym,M.FCTspec{sign,...})],...}) =
231 :     if S.name sym = "<functor>" then fsgenv sign
232 :     else bug "unexpected case <functtor> in sigenvSp"
233 :     | sigenvSp _ = bug "unexpected case in signenvSp"
234 :    
235 :     and fsgenv (M.FSIG{bodysig,...}) = sigenvSp bodysig
236 :     | fsgenv _ = CM_NONE
237 :    
238 :     fun strenv(M.STR{sign,...}) = sigenv sign
239 :     | strenv M.ERRORstr = CM_NONE
240 :    
241 :     fun fctenv(M.FCT{sign,...}) = fsgenv sign
242 :     | fctenv _ = CM_NONE
243 :    
244 :     fun cmEnvOfModule env sym =
245 :     (case SE.look(env,sym)
246 :     of B.SIGbind b => sigenv b
247 :     | B.STRbind b => strenv b
248 :     | B.FSGbind b => fsgenv b
249 :     | B.FCTbind b => fctenv b
250 :     | _ => CM_NONE)
251 :     handle SE.Unbound => CM_NONE
252 :    
253 :     fun describe static (s: symbol) : unit =
254 :     let open PrettyPrint
255 :     in with_pp (ErrorMsg.defaultConsumer())
256 :     (fn ppstrm =>
257 :     (begin_block ppstrm CONSISTENT 0;
258 :     PPModules.ppBinding ppstrm
259 :     (s, SE.look(static,s), static, !Control.Print.printDepth);
260 :     add_newline ppstrm;
261 :     end_block ppstrm))
262 :     end handle SE.Unbound => print (S.name s ^ " not found\n")
263 :    
264 :     val primEnv = PrimEnv.primEnv
265 :    
266 :     end (* local *)
267 :     end (* structure Environment *)
268 :    
269 :    
270 :     (*
271 : monnier 223 * $Log: environ.sml,v $
272 :     * Revision 1.2 1998/06/02 17:39:28 george
273 :     * Changes to integrate CM functionality into the compiler --- blume
274 :     *
275 : monnier 16 *)

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