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

Annotation of /sml/trunk/src/compiler/Semant/basics/env.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 249 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/Semant/basics/env.sml

1 : monnier 249 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* env.sml *)
3 :    
4 :     signature INTSTRMAPV =
5 :     sig
6 :     type 'a intstrmap
7 :     val new : (int * 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 -> int * string -> 'a
14 :     val app : (int * string * 'a -> unit) -> 'a intstrmap -> unit
15 :     val transform : ('a -> 'b) -> 'a intstrmap -> 'b intstrmap
16 :     val fold : ((int*string*'a)*'b->'b)->'b->'a intstrmap->'b
17 :    
18 :     end (* signature INTSTRMAP *)
19 :    
20 :     structure Env : ENV =
21 :     struct
22 :    
23 :     (* debugging *)
24 :     val say = Control.Print.say
25 :     val debugging = ref false
26 :     fun debugmsg (msg: string) =
27 :     if !debugging then (say msg; say "\n") else ()
28 :    
29 :    
30 :     structure Symbol =
31 :     struct
32 :     val varInt = 0 and sigInt = 1 and strInt = 2 and fsigInt = 3 and
33 :     fctInt = 4 and tycInt = 5 and labInt = 6 and tyvInt = 7 and
34 :     fixInt = 8
35 :    
36 :     datatype symbol = SYMBOL of int * string
37 :     datatype namespace =
38 :     VALspace | TYCspace | SIGspace | STRspace | FCTspace | FIXspace |
39 :     LABspace | TYVspace | FSIGspace
40 :    
41 :     fun eq(SYMBOL(a1,b1),SYMBOL(a2,b2)) = a1=a2 andalso b1=b2
42 :     fun symbolGt(SYMBOL(_,s1), SYMBOL(_,s2)) = s1 > s2
43 :     fun symbolCMLt (SYMBOL (a1, s1), SYMBOL (a2, s2)) =
44 :     a1 < a2 orelse a1 = a2 andalso s1 < s2
45 :    
46 :     fun varSymbol (name: string) =
47 :     SYMBOL(StrgHash.hashString name + varInt,name)
48 :     fun tycSymbol (name: string) =
49 :     SYMBOL(StrgHash.hashString name + tycInt, name)
50 :     fun fixSymbol (name: string) =
51 :     SYMBOL(StrgHash.hashString name + fixInt, name)
52 :     fun labSymbol (name: string) =
53 :     SYMBOL(StrgHash.hashString name + labInt, name)
54 :     fun tyvSymbol (name: string) =
55 :     SYMBOL(StrgHash.hashString name + tyvInt, name)
56 :     fun sigSymbol (name: string) =
57 :     SYMBOL(StrgHash.hashString name + sigInt, name)
58 :     fun strSymbol (name: string) =
59 :     SYMBOL(StrgHash.hashString name + strInt, name)
60 :     fun fctSymbol (name: string) =
61 :     SYMBOL(StrgHash.hashString name + fctInt, name)
62 :     fun fsigSymbol (name: string) =
63 :     SYMBOL(StrgHash.hashString name + fsigInt, name)
64 :    
65 :     fun var'n'fix name =
66 :     let val h = StrgHash.hashString name
67 :     in (SYMBOL(h+varInt,name),SYMBOL(h+fixInt,name))
68 :     end
69 :    
70 :     fun name (SYMBOL(_,name)) = name
71 :     fun number (SYMBOL(number,_)) = number
72 :     fun nameSpace (SYMBOL(number,name)) : namespace =
73 :     case number - StrgHash.hashString name
74 :     of 0 => VALspace
75 :     | 5 => TYCspace
76 :     | 1 => SIGspace
77 :     | 2 => STRspace
78 :     | 4 => FCTspace
79 :     | 8 => FIXspace
80 :     | 6 => LABspace
81 :     | 7 => TYVspace
82 :     | 3 => FSIGspace
83 :     | _ => ErrorMsg.impossible "Symbol.nameSpace"
84 :    
85 :     fun nameSpaceToString (n : namespace) : string =
86 :     case n
87 :     of VALspace => "variable or constructor"
88 :     | TYCspace => "type constructor"
89 :     | SIGspace => "signature"
90 :     | STRspace => "structure"
91 :     | FCTspace => "functor"
92 :     | FIXspace => "fixity"
93 :     | LABspace => "label"
94 :     | TYVspace => "type variable"
95 :     | FSIGspace => "functor signature"
96 :    
97 :     fun symbolToString(SYMBOL(number,name)) : string =
98 :     case number - StrgHash.hashString name
99 :     of 0 => "VAL$"^name
100 :     | 1 => "SIG$"^name
101 :     | 2 => "STR$"^name
102 :     | 3 => "FSIG$"^name
103 :     | 4 => "FCT$"^name
104 :     | 5 => "TYC$"^name
105 :     | 6 => "LAB$"^name
106 :     | 7 => "TYV$"^name
107 :     | 8 => "FIX$"^name
108 :     | _ => ErrorMsg.impossible "Symbol.toString"
109 :    
110 :     end (* structure Symbol *)
111 :    
112 :     structure FastSymbol =
113 :     struct
114 :     local open Symbol
115 :     in
116 :    
117 :     type symbol = symbol
118 :    
119 :     (* Another version of symbols but hash numbers have no increments
120 :     * according to their nameSpace *)
121 :     datatype raw_symbol = RAWSYM of int * string
122 :    
123 :     (* builds a raw symbol from a pair name, hash number *)
124 :     fun rawSymbol hash_name = RAWSYM hash_name
125 :    
126 :     (* builds a symbol from a raw symbol belonging to the same space as
127 :     * a reference symbol *)
128 :     fun sameSpaceSymbol (SYMBOL(i,s)) (RAWSYM(i',s')) =
129 :     SYMBOL(i' + (i - StrgHash.hashString s), s')
130 :    
131 :     (* build symbols in various name space from raw symbols *)
132 :     fun varSymbol (RAWSYM (hash,name)) =
133 :     SYMBOL(hash + varInt,name)
134 :     fun tycSymbol (RAWSYM (hash,name)) =
135 :     SYMBOL(hash + tycInt, name)
136 :     fun fixSymbol (RAWSYM (hash,name)) =
137 :     SYMBOL(hash + fixInt, name)
138 :     fun labSymbol (RAWSYM (hash,name)) =
139 :     SYMBOL(hash + labInt, name)
140 :     fun tyvSymbol (RAWSYM (hash,name)) =
141 :     SYMBOL(hash + tyvInt, name)
142 :     fun sigSymbol (RAWSYM (hash,name)) =
143 :     SYMBOL(hash + sigInt, name)
144 :     fun strSymbol (RAWSYM (hash,name)) =
145 :     SYMBOL(hash + strInt, name)
146 :     fun fctSymbol (RAWSYM (hash,name)) =
147 :     SYMBOL(hash + fctInt, name)
148 :     fun fsigSymbol (RAWSYM (hash,name)) =
149 :     SYMBOL(hash + fsigInt, name)
150 :     fun var'n'fix (RAWSYM (h,name)) =
151 :     (SYMBOL(h+varInt,name),SYMBOL(h+fixInt,name))
152 :    
153 :     end (* local FastSymbol *)
154 :     end (* structure FastSymbol *)
155 :    
156 :     exception Unbound
157 :    
158 :     structure IntStrMapV :> INTSTRMAPV =
159 :     struct
160 :    
161 :     structure V = Vector
162 :     datatype 'a bucket = NIL | B of (int * string * 'a * 'a bucket)
163 :     type 'a intstrmap = 'a bucket V.vector
164 :    
165 :     val elems = V.length
166 :     fun bucketmap f =
167 :     let fun loop NIL = NIL
168 :     | loop(B(i,s,j,r)) = B(i,s,f(j),loop r)
169 :     in loop
170 :     end
171 :    
172 :     fun bucketapp f =
173 :     let fun loop NIL = ()
174 :     | loop(B(i,s,j,r)) = (f(i,s,j); loop r)
175 :     in loop
176 :     end
177 :    
178 :     fun transform f v = V.tabulate(V.length v, fn i => bucketmap f (V.sub(v,i)))
179 :    
180 :     fun map v (i,s) =
181 :     let fun find NIL = raise Unbound
182 :     | find (B(i',s',j,r)) = if i=i' andalso s=s' then j else find r
183 :     in (find (V.sub(v,Int.rem(i,V.length v)))) handle Div => raise Unbound
184 :     end
185 :    
186 :     fun app f v =
187 :     let val n = V.length v
188 :     val bapp = bucketapp f
189 :     fun f i = if i=n then () else (bapp(V.sub(v,i)); f(i+1))
190 :     in f 0
191 :     end
192 :    
193 :     fun fold f zero v =
194 :     let val n = V.length v
195 :     fun bucketfold (NIL,x) = x
196 :     | bucketfold (B(i,s,j,r), x) = bucketfold(r, f((i,s,j),x))
197 :    
198 :     fun g(i,x) = if i=n then x else g(i+1,bucketfold(V.sub(v,i),x))
199 :     in g(0,zero)
200 :     end
201 :    
202 :     fun new (bindings: (int*string*'b) list) =
203 :     let val n = List.length bindings
204 :     val a0 = Array.array(n,NIL: 'b bucket)
205 :     val dups = ref 0
206 :    
207 :     fun add a (i,s,b) =
208 :     let val index = i mod (Array.length a)
209 :     fun f NIL = B(i,s,b,NIL)
210 :     | f (B(i',s',b',r)) =
211 :     if i'=i andalso s'=s
212 :     then (dups := !dups+1; B(i,s,b,r))
213 :     else B(i',s',b',f r)
214 :     in Array.update(a,index,f(Array.sub(a,index)))
215 :     end
216 :    
217 :     val _ = List.app (add a0) bindings
218 :     val a1 = case !dups
219 :     of 0 => a0
220 :     | d => let val a = Array.array(n-d, NIL: 'b bucket)
221 :     in List.app (add a) bindings; a
222 :     end
223 :    
224 :     in Vector.tabulate(Array.length a1, fn i => Array.sub(a1,i))
225 :     end
226 :     handle Div => (ErrorMsg.impossible "IntStrMapV.new raises Div";
227 :     raise Div)
228 :    
229 :     end (* structure IntStrMapV *)
230 :    
231 :     (* representation of environments *)
232 :     (* 'b will always be instantiated to Basics.binding *)
233 :    
234 :     datatype 'b env
235 :     = EMPTY
236 :     | BIND of int * string * 'b * 'b env
237 :     | TABLE of 'b IntStrMapV.intstrmap * 'b env
238 :     | SPECIAL of (Symbol.symbol -> 'b) * (unit -> Symbol.symbol list) * 'b env
239 :     (* for, e.g., debugger *)
240 :    
241 :     exception SpecialEnv
242 :     (* raised by app when it encounters a SPECIAL env *)
243 :    
244 :     val empty = EMPTY
245 :    
246 :     fun look (env,sym as Symbol.SYMBOL(is as (i,s))) =
247 :     let fun f EMPTY = (debugmsg("$Env.look "^s); raise Unbound)
248 :     | f (BIND(i',s',b,n)) =
249 :     if i = i' andalso s = s' then b else f n
250 :     | f (TABLE(t,n)) = (IntStrMapV.map t is handle Unbound => f n)
251 :     | f (SPECIAL(g,_,n)) = (g sym handle Unbound => f n)
252 :     in f env
253 :     end
254 :    
255 :     fun bind (Symbol.SYMBOL(i,s),binding,env) = BIND (i,s,binding,env)
256 :    
257 :     exception NoSymbolList
258 :    
259 :     fun special (look', getSyms) =
260 :     let val memo_env = ref empty
261 :     fun lookMem sym =
262 :     look(!memo_env, sym)
263 :     handle Unbound =>
264 :     let val binding = look' sym
265 :     in memo_env := bind(sym,binding,!memo_env);
266 :     binding
267 :     end
268 :    
269 :     val memo_syms = ref(NONE: Symbol.symbol list option)
270 :     fun getsymsMem() =
271 :     case !memo_syms
272 :     of NONE => let val syms = getSyms()
273 :     in memo_syms := SOME syms; syms
274 :     end
275 :     | SOME syms => syms
276 :     in SPECIAL(lookMem,getsymsMem,empty)
277 :     end
278 :    
279 :     infix atop
280 :    
281 :     fun EMPTY atop e = e
282 :     | (BIND(i,s,b,n)) atop e = BIND(i,s,b,n atop e)
283 :     | (TABLE(t,n)) atop e = TABLE(t,n atop e)
284 :     | (SPECIAL(g,syms,n)) atop e = SPECIAL(g, syms, n atop e)
285 :    
286 :     fun app f =
287 :     let fun g (BIND(i,s,b,n)) = (g n; f (Symbol.SYMBOL(i,s),b))
288 :     | g (TABLE(t,n)) =
289 :     (g n; IntStrMapV.app (fn (i,s,b) => f(Symbol.SYMBOL(i,s),b)) t)
290 :     | g (SPECIAL(looker,syms,n)) =
291 :     (g n; List.app (fn sym=>f(sym,looker sym)) (syms()))
292 :     | g (EMPTY) = ()
293 :     in g
294 :     end
295 :    
296 :     fun symbols env =
297 :     let fun f(syms,BIND(i,s,b,n)) = f(Symbol.SYMBOL(i,s)::syms,n)
298 :     | f(syms,TABLE(t,n)) =
299 :     let val r = ref syms
300 :     fun add(i,s,_) = r := Symbol.SYMBOL(i,s):: !r
301 :     in IntStrMapV.app add t; f(!r,n)
302 :     end
303 :     | f(syms,SPECIAL(_,syms',n)) = f(syms'()@syms, n)
304 :     | f(syms,EMPTY) = syms
305 :     in f(nil,env)
306 :     end
307 :    
308 :     fun map func (TABLE(t,EMPTY)) = (* optimized case *)
309 :     TABLE(IntStrMapV.transform func t, EMPTY)
310 :     | map func env =
311 :     let fun f(syms,BIND(i,s,b,n)) = f((i,s,func b)::syms,n)
312 :     | f(syms,TABLE(t,n)) =
313 :     let val r = ref syms
314 :     fun add(i,s,b) = r := (i,s,func b) :: !r
315 :     in IntStrMapV.app add t;
316 :     f(!r,n)
317 :     end
318 :     | f(syms,SPECIAL(look',syms',n)) =
319 :     f(List.map (fn (sym as Symbol.SYMBOL(i,s)) =>
320 :     (i,s,func(look' sym))) (syms'())@syms,
321 :     n)
322 :     | f(syms,EMPTY) = syms
323 :    
324 :     in TABLE(IntStrMapV.new(f(nil,env)), EMPTY)
325 :     end
326 :    
327 :     fun fold f base e =
328 :     let fun g (BIND(i,s,b,n),x) =
329 :     let val y = g(n,x)
330 :     in f((Symbol.SYMBOL(i,s),b),y)
331 :     end
332 :     | g (e as TABLE(t,n),x) =
333 :     let val y = g(n,x)
334 :     in IntStrMapV.fold
335 :     (fn ((i,s,b),z) => f((Symbol.SYMBOL(i,s),b),z)) y t
336 :     end
337 :     | g (SPECIAL(looker,syms,n),x) =
338 :     let val y = g(n,x)
339 :     val symbols = (syms())
340 :     in List.foldr (fn (sym,z) =>f((sym,looker sym),z)) y symbols
341 :     end
342 :     | g (EMPTY,x) = x
343 :     in g(e,base)
344 :     end
345 :    
346 :     fun consolidate (env as TABLE(_,EMPTY)) = env
347 :     | consolidate (env as EMPTY) = env
348 :     | consolidate env = map (fn x => x) env handle NoSymbolList => env
349 :    
350 :     fun shouldConsolidate env =
351 :     let fun f(depth,size, BIND(_,_,_,n)) = f(depth+1,size+1,n)
352 :     | f(depth,size, TABLE(t,n)) = f(depth+1, size+IntStrMapV.elems t, n)
353 :     | f(depth,size, SPECIAL(_,_,n)) = f(depth+1,size+100,n)
354 :     | f(depth,size, EMPTY) = depth*10 > size
355 :     in f(0,0,env)
356 :     end
357 :    
358 :     (*
359 :     fun tooDeep env =
360 :     let fun f(depth,env) = if depth > 30 then true
361 :     else case env
362 :     of BIND(_,_,_,n) => f(depth+1,n)
363 :     | TABLE(_,n) => f(depth+1,n)
364 :     | SPECIAL(_,_,n) => f(depth+1,n)
365 :     | EMPTY => false
366 :     in f(0,env)
367 :     end
368 :     *)
369 :    
370 :     fun consolidateLazy (env as TABLE(_,EMPTY)) = env
371 :     | consolidateLazy (env as EMPTY) = env
372 :     | consolidateLazy env =
373 :     if shouldConsolidate env
374 :     then map (fn x => x) env handle NoSymbolList => env
375 :     else env
376 :    
377 :     end (* structure Env *)
378 :    
379 :     (*
380 :     * $Log: env.sml,v $
381 :     * Revision 1.1.1.1 1998/04/08 18:39:34 george
382 :     * Version 110.5
383 :     *
384 :     *)

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