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 1344 - (view) (download)

1 : monnier 249 (* 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 : blume 902 type dynenv = DE.env
22 :     type symenv = SY.env
23 : monnier 249
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 : blume 587 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, ... })) = root access
63 :     | stampOf(B.FCTbind (M.FCT { access, ... })) = root access
64 : monnier 249 | stampOf _ = NONE
65 :    
66 :     (* functions to collect stale dynamic pids for unbinding in concatEnv *)
67 :    
68 :     (*
69 :     * stalePids: takes a new environment and a base environment to which
70 :     * it is to be added and returns a list of pids that are unreachable
71 :     * when the new environment is added to the base environment
72 :     *
73 :     * what we do instead:
74 :     * - count the number of occurences for each pid in baseEnv bindings
75 :     * that is going to be shadowed by deltaEnv
76 :     * - count the total number of total occurences for each such
77 :     * pids in baseEnv
78 :     * - the ones where the counts coincide are stale
79 :     *
80 :     * This code is ok, because deltaEnv is the output of `export'. `export'
81 :     * calls consolidateStatic, therefore we don't have duplicate bindings
82 :     * of the same symbol.
83 :     *)
84 :     fun stalePids (deltaEnv, baseEnv) =
85 :     let
86 :    
87 :     (* any rebindings? *)
88 :     val anyrebound = ref false
89 :    
90 :     (* counting map *)
91 :     val countM = ref (PersMap.empty: int ref PersMap.map)
92 : monnier 411 fun look s = PersMap.find (!countM, s)
93 : monnier 249
94 :     (* initialize the counter map: for each new binding with stamp
95 :     * check if the same symbol was bound in the old env and enter
96 :     * the old stamp into the map *)
97 :     fun initOne s =
98 :     case look s
99 : monnier 411 of NONE => countM := PersMap.insert (!countM, s, ref (~1))
100 : monnier 249 | SOME r => r := (!r) - 1
101 :    
102 :     fun initC (sy, _) =
103 :     (case stampOf (SE.look (baseEnv, sy))
104 :     of NONE => ()
105 :     | SOME s => (initOne s; anyrebound := true))
106 :     handle SE.Unbound => ()
107 :     (* increment counter for a given stamp *)
108 :     fun incr NONE = ()
109 :     | incr (SOME s) =
110 :     case look s
111 :     of NONE => ()
112 :     | SOME r => r := (!r) + 1
113 :    
114 :     fun incC (_, b) = incr (stampOf b)
115 :     (* select the 0s *)
116 :     fun selZero ((s, ref 0), zeros) = s :: zeros
117 :     | selZero (_, zeros) = zeros
118 :     in
119 :     SE.app initC deltaEnv; (* init counter map *)
120 :     if !anyrebound then let (* shortcut if no rebindings *)
121 :     (* count the pids *)
122 :     val _ = SE.app incC baseEnv
123 :     (* pick out the stale ones *)
124 : monnier 411 val stalepids = foldl selZero [] (PersMap.listItemsi (!countM))
125 : monnier 249 in
126 :     stalepids
127 :     end
128 :     else []
129 :     end
130 :    
131 :     fun concatEnv ({ static = newstat, dynamic = newdyn, symbolic = newsym },
132 :     { static = oldstat, dynamic = olddyn, symbolic = oldsym }) =
133 :     let val hidden_pids = stalePids (newstat, oldstat)
134 :     val slimdyn = DE.remove (hidden_pids, olddyn)
135 :     val slimsym = SY.remove (hidden_pids, oldsym)
136 :     in {static=SE.consolidateLazy(SE.atop(newstat, oldstat)),
137 :     dynamic=DE.atop(newdyn, slimdyn),
138 :     symbolic=SY.atop(newsym, slimsym)}
139 :     end
140 :    
141 :     fun getbindings(static: staticEnv, symbols: S.symbol list) :
142 :     (S.symbol * B.binding) list =
143 :     let fun loop([], bindings) = bindings
144 :     | loop(s::rest, bindings) =
145 :     let val bindings' = (s,SE.look(static,s)) :: bindings
146 :     handle SE.Unbound => bindings
147 :     in loop (rest, bindings')
148 :     end
149 :     in loop(symbols,[])
150 :     end
151 :    
152 :     fun copystat([], senv) = senv
153 :     | copystat((s,b)::l, senv) = copystat(l,SE.bind(s, b, senv))
154 :    
155 : blume 905 (*
156 : monnier 249 fun filterStaticEnv(static: staticEnv, symbols: S.symbol list) : staticEnv =
157 :     copystat(getbindings(static, symbols), SE.empty)
158 : blume 905 *)
159 : monnier 249
160 :     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 : blume 902 let val dy = valOf (DE.look dynamic pid)
168 : monnier 249 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 :     end)
175 :     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 :    
186 :     fun trimEnv { static, dynamic, symbolic } = let
187 : blume 905 val syms = BrowseStatEnv.catalog static
188 : monnier 249 val (dynamic, symbolic) =
189 :     copydynsym (getbindings (static, syms), dynamic, symbolic)
190 :     in
191 :     { static = static, dynamic = dynamic, symbolic = symbolic }
192 :     end
193 :     end
194 :    
195 :     fun describe static (s: symbol) : unit =
196 : macqueen 1344 let open PrettyPrint PPUtil
197 : monnier 249 in with_pp (ErrorMsg.defaultConsumer())
198 :     (fn ppstrm =>
199 : macqueen 1344 (openHVBox ppstrm (Rel 0);
200 :     PPModules.ppBinding ppstrm
201 :     (s, SE.look(static,s), static, !Control.Print.printDepth);
202 :     newline ppstrm;
203 :     closeBox ppstrm))
204 : monnier 249 end handle SE.Unbound => print (S.name s ^ " not found\n")
205 :    
206 :     val primEnv = PrimEnv.primEnv
207 :    
208 :     end (* local *)
209 :     end (* structure Environment *)
210 :    
211 :    

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