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/compiler/ElabData/basics/env.sml
ViewVC logotype

Annotation of /sml/trunk/compiler/ElabData/basics/env.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 902 - (view) (download)
Original Path: sml/trunk/src/compiler/ElabData/basics/env.sml

1 : blume 902 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* env.sml *)
3 :    
4 :     signature INTSTRMAPV =
5 :     sig
6 :     type 'a intstrmap
7 :     val new : (word * string * 'a) list -> 'a intstrmap
8 :    
9 :     (* in case of duplicates, the element towards the head of the
10 :     * list is discarded,and the one towards the tail is kept.
11 :     *)
12 :     val elems : 'a intstrmap -> int
13 :     val map : 'a intstrmap -> word * string -> 'a
14 :     val app : (word * string * 'a -> unit) -> 'a intstrmap -> unit
15 :     val transform : ('a -> 'b) -> 'a intstrmap -> 'b intstrmap
16 :     val fold : ((word*string*'a)*'b->'b)->'b->'a intstrmap->'b
17 :    
18 :     end (* signature INTSTRMAP *)
19 :    
20 :     structure Env : ENV = struct
21 :    
22 :     (* debugging *)
23 :     val say = Control_Print.say
24 :     val debugging = ref false
25 :     fun debugmsg (msg: string) =
26 :     if !debugging then (say msg; say "\n") else ()
27 :    
28 :     exception Unbound
29 :    
30 :     structure IntStrMapV :> INTSTRMAPV =
31 :     struct
32 :    
33 :     structure V = Vector
34 :     datatype 'a bucket = NIL | B of (word * string * 'a * 'a bucket)
35 :     type 'a intstrmap = 'a bucket V.vector
36 :    
37 :     val elems = V.length
38 :     fun bucketmap f =
39 :     let fun loop NIL = NIL
40 :     | loop(B(i,s,j,r)) = B(i,s,f(j),loop r)
41 :     in loop
42 :     end
43 :    
44 :     fun bucketapp f =
45 :     let fun loop NIL = ()
46 :     | loop(B(i,s,j,r)) = (f(i,s,j); loop r)
47 :     in loop
48 :     end
49 :    
50 :     fun transform f v = V.tabulate(V.length v, fn i => bucketmap f (V.sub(v,i)))
51 :    
52 :     fun index(len, i) = Word.toInt(Word.mod(i, Word.fromInt len))
53 :     fun map v (i,s) =
54 :     let fun find NIL = raise Unbound
55 :     | find (B(i',s',j,r)) = if i=i' andalso s=s' then j else find r
56 :    
57 :     in (find (V.sub(v, index(V.length v, i))))
58 :     handle Div => raise Unbound
59 :     end
60 :    
61 :     fun app f v =
62 :     let val n = V.length v
63 :     val bapp = bucketapp f
64 :     fun f i = if i=n then () else (bapp(V.sub(v,i)); f(i+1))
65 :     in f 0
66 :     end
67 :    
68 :     fun fold f zero v =
69 :     let val n = V.length v
70 :     fun bucketfold (NIL,x) = x
71 :     | bucketfold (B(i,s,j,r), x) = bucketfold(r, f((i,s,j),x))
72 :    
73 :     fun g(i,x) = if i=n then x else g(i+1,bucketfold(V.sub(v,i),x))
74 :     in g(0,zero)
75 :     end
76 :    
77 :     fun new (bindings: (word*string*'b) list) =
78 :     let val n = List.length bindings
79 :     val a0 = Array.array(n,NIL: 'b bucket)
80 :     val dups = ref 0
81 :    
82 :     fun add a (i,s,b) =
83 :     let val indx = index(Array.length a, i)
84 :     fun f NIL = B(i,s,b,NIL)
85 :     | f (B(i',s',b',r)) =
86 :     if i'=i andalso s'=s
87 :     then (dups := !dups+1; B(i,s,b,r))
88 :     else B(i',s',b',f r)
89 :     in Array.update(a,indx,f(Array.sub(a,indx)))
90 :     end
91 :    
92 :     val _ = List.app (add a0) bindings
93 :     val a1 = case !dups
94 :     of 0 => a0
95 :     | d => let val a = Array.array(n-d, NIL: 'b bucket)
96 :     in List.app (add a) bindings; a
97 :     end
98 :    
99 :     in Vector.tabulate(Array.length a1, fn i => Array.sub(a1,i))
100 :     end
101 :     handle Div => (ErrorMsg.impossible "IntStrMapV.new raises Div";
102 :     raise Div)
103 :    
104 :     end (* structure IntStrMapV *)
105 :    
106 :     (* representation of environments *)
107 :     (* 'b will always be instantiated to Basics.binding *)
108 :    
109 :     datatype 'b env
110 :     = EMPTY
111 :     | BIND of word * string * 'b * 'b env
112 :     | TABLE of 'b IntStrMapV.intstrmap * 'b env
113 :     | SPECIAL of (Symbol.symbol -> 'b) * (unit -> Symbol.symbol list) * 'b env
114 :     (* for, e.g., debugger *)
115 :    
116 :     exception SpecialEnv
117 :     (* raised by app when it encounters a SPECIAL env *)
118 :    
119 :     val empty = EMPTY
120 :    
121 :     fun look (env,sym as Symbol.SYMBOL(is as (i,s))) =
122 :     let fun f EMPTY = (debugmsg("$Env.look "^s); raise Unbound)
123 :     | f (BIND(i',s',b,n)) =
124 :     if i = i' andalso s = s' then b else f n
125 :     | f (TABLE(t,n)) = (IntStrMapV.map t is handle Unbound => f n)
126 :     | f (SPECIAL(g,_,n)) = (g sym handle Unbound => f n)
127 :     in f env
128 :     end
129 :    
130 :     fun bind (Symbol.SYMBOL(i,s),binding,env) = BIND (i,s,binding,env)
131 :    
132 :     exception NoSymbolList
133 :    
134 :     fun special (look', getSyms) =
135 :     let val memo_env = ref empty
136 :     fun lookMem sym =
137 :     look(!memo_env, sym)
138 :     handle Unbound =>
139 :     let val binding = look' sym
140 :     in memo_env := bind(sym,binding,!memo_env);
141 :     binding
142 :     end
143 :    
144 :     val memo_syms = ref(NONE: Symbol.symbol list option)
145 :     fun getsymsMem() =
146 :     case !memo_syms
147 :     of NONE => let val syms = getSyms()
148 :     in memo_syms := SOME syms; syms
149 :     end
150 :     | SOME syms => syms
151 :     in SPECIAL(lookMem,getsymsMem,empty)
152 :     end
153 :    
154 :     infix atop
155 :    
156 :     fun EMPTY atop e = e
157 :     | (BIND(i,s,b,n)) atop e = BIND(i,s,b,n atop e)
158 :     | (TABLE(t,n)) atop e = TABLE(t,n atop e)
159 :     | (SPECIAL(g,syms,n)) atop e = SPECIAL(g, syms, n atop e)
160 :    
161 :     fun app f =
162 :     let fun g (BIND(i,s,b,n)) = (g n; f (Symbol.SYMBOL(i,s),b))
163 :     | g (TABLE(t,n)) =
164 :     (g n; IntStrMapV.app (fn (i,s,b) => f(Symbol.SYMBOL(i,s),b)) t)
165 :     | g (SPECIAL(looker,syms,n)) =
166 :     (g n; List.app (fn sym=>f(sym,looker sym)) (syms()))
167 :     | g (EMPTY) = ()
168 :     in g
169 :     end
170 :    
171 :     fun symbols env =
172 :     let fun f(syms,BIND(i,s,b,n)) = f(Symbol.SYMBOL(i,s)::syms,n)
173 :     | f(syms,TABLE(t,n)) =
174 :     let val r = ref syms
175 :     fun add(i,s,_) = r := Symbol.SYMBOL(i,s):: !r
176 :     in IntStrMapV.app add t; f(!r,n)
177 :     end
178 :     | f(syms,SPECIAL(_,syms',n)) = f(syms'()@syms, n)
179 :     | f(syms,EMPTY) = syms
180 :     in f(nil,env)
181 :     end
182 :    
183 :     fun map func (TABLE(t,EMPTY)) = (* optimized case *)
184 :     TABLE(IntStrMapV.transform func t, EMPTY)
185 :     | map func env =
186 :     let fun f(syms,BIND(i,s,b,n)) = f((i,s,func b)::syms,n)
187 :     | f(syms,TABLE(t,n)) =
188 :     let val r = ref syms
189 :     fun add(i,s,b) = r := (i,s,func b) :: !r
190 :     in IntStrMapV.app add t;
191 :     f(!r,n)
192 :     end
193 :     | f(syms,SPECIAL(look',syms',n)) =
194 :     f(List.map (fn (sym as Symbol.SYMBOL(i,s)) =>
195 :     (i,s,func(look' sym))) (syms'())@syms,
196 :     n)
197 :     | f(syms,EMPTY) = syms
198 :    
199 :     in TABLE(IntStrMapV.new(f(nil,env)), EMPTY)
200 :     end
201 :    
202 :     fun fold f base e =
203 :     let fun g (BIND(i,s,b,n),x) =
204 :     let val y = g(n,x)
205 :     in f((Symbol.SYMBOL(i,s),b),y)
206 :     end
207 :     | g (e as TABLE(t,n),x) =
208 :     let val y = g(n,x)
209 :     in IntStrMapV.fold
210 :     (fn ((i,s,b),z) => f((Symbol.SYMBOL(i,s),b),z)) y t
211 :     end
212 :     | g (SPECIAL(looker,syms,n),x) =
213 :     let val y = g(n,x)
214 :     val symbols = (syms())
215 :     in List.foldr (fn (sym,z) =>f((sym,looker sym),z)) y symbols
216 :     end
217 :     | g (EMPTY,x) = x
218 :     in g(e,base)
219 :     end
220 :    
221 :     fun consolidate (env as TABLE(_,EMPTY)) = env
222 :     | consolidate (env as EMPTY) = env
223 :     | consolidate env = map (fn x => x) env handle NoSymbolList => env
224 :    
225 :     fun shouldConsolidate env =
226 :     let fun f(depth,size, BIND(_,_,_,n)) = f(depth+1,size+1,n)
227 :     | f(depth,size, TABLE(t,n)) = f(depth+1, size+IntStrMapV.elems t, n)
228 :     | f(depth,size, SPECIAL(_,_,n)) = f(depth+1,size+100,n)
229 :     | f(depth,size, EMPTY) = depth*10 > size
230 :     in f(0,0,env)
231 :     end
232 :    
233 :     (*
234 :     fun tooDeep env =
235 :     let fun f(depth,env) = if depth > 30 then true
236 :     else case env
237 :     of BIND(_,_,_,n) => f(depth+1,n)
238 :     | TABLE(_,n) => f(depth+1,n)
239 :     | SPECIAL(_,_,n) => f(depth+1,n)
240 :     | EMPTY => false
241 :     in f(0,env)
242 :     end
243 :     *)
244 :    
245 :     fun consolidateLazy (env as TABLE(_,EMPTY)) = env
246 :     | consolidateLazy (env as EMPTY) = env
247 :     | consolidateLazy env =
248 :     if shouldConsolidate env
249 :     then map (fn x => x) env handle NoSymbolList => env
250 :     else env
251 :    
252 :     end (* structure Env *)

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