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

Parent Directory | 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