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 411 - (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 : monnier 411 val new : (word * string * 'a) list -> 'a intstrmap
8 : monnier 249
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 : monnier 411 val map : 'a intstrmap -> word * string -> 'a
14 :     val app : (word * string * 'a -> unit) -> 'a intstrmap -> unit
15 : monnier 249 val transform : ('a -> 'b) -> 'a intstrmap -> 'b intstrmap
16 : monnier 411 val fold : ((word*string*'a)*'b->'b)->'b->'a intstrmap->'b
17 : monnier 249
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 : monnier 411 val varInt = 0w0 and sigInt = 0w1 and strInt = 0w2 and fsigInt = 0w3 and
33 :     fctInt = 0w4 and tycInt = 0w5 and labInt = 0w6 and tyvInt = 0w7 and
34 :     fixInt = 0w8
35 : monnier 249
36 : monnier 411 datatype symbol = SYMBOL of word * string
37 : monnier 249 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 : monnier 411 SYMBOL(HashString.hashString name + varInt,name)
48 : monnier 249 fun tycSymbol (name: string) =
49 : monnier 411 SYMBOL(HashString.hashString name + tycInt, name)
50 : monnier 249 fun fixSymbol (name: string) =
51 : monnier 411 SYMBOL(HashString.hashString name + fixInt, name)
52 : monnier 249 fun labSymbol (name: string) =
53 : monnier 411 SYMBOL(HashString.hashString name + labInt, name)
54 : monnier 249 fun tyvSymbol (name: string) =
55 : monnier 411 SYMBOL(HashString.hashString name + tyvInt, name)
56 : monnier 249 fun sigSymbol (name: string) =
57 : monnier 411 SYMBOL(HashString.hashString name + sigInt, name)
58 : monnier 249 fun strSymbol (name: string) =
59 : monnier 411 SYMBOL(HashString.hashString name + strInt, name)
60 : monnier 249 fun fctSymbol (name: string) =
61 : monnier 411 SYMBOL(HashString.hashString name + fctInt, name)
62 : monnier 249 fun fsigSymbol (name: string) =
63 : monnier 411 SYMBOL(HashString.hashString name + fsigInt, name)
64 : monnier 249
65 :     fun var'n'fix name =
66 : monnier 411 let val h = HashString.hashString name
67 : monnier 249 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 : monnier 411 case number - HashString.hashString name
74 :     of 0w0 => VALspace
75 :     | 0w5 => TYCspace
76 :     | 0w1 => SIGspace
77 :     | 0w2 => STRspace
78 :     | 0w4 => FCTspace
79 :     | 0w8 => FIXspace
80 :     | 0w6 => LABspace
81 :     | 0w7 => TYVspace
82 :     | 0w3 => FSIGspace
83 : monnier 249 | _ => 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 : monnier 411 case number - HashString.hashString name
99 :     of 0w0 => "VAL$"^name
100 :     | 0w1 => "SIG$"^name
101 :     | 0w2 => "STR$"^name
102 :     | 0w3 => "FSIG$"^name
103 :     | 0w4 => "FCT$"^name
104 :     | 0w5 => "TYC$"^name
105 :     | 0w6 => "LAB$"^name
106 :     | 0w7 => "TYV$"^name
107 :     | 0w8 => "FIX$"^name
108 : monnier 249 | _ => 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 : monnier 411 datatype raw_symbol = RAWSYM of word * string
122 : monnier 249
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 : monnier 411 SYMBOL(i' + (i - HashString.hashString s), s')
130 : monnier 249
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 : monnier 411 datatype 'a bucket = NIL | B of (word * string * 'a * 'a bucket)
163 : monnier 249 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 : monnier 411 fun index(len, i) = Word.toInt(Word.mod(i, Word.fromInt len))
181 : monnier 249 fun map v (i,s) =
182 :     let fun find NIL = raise Unbound
183 :     | find (B(i',s',j,r)) = if i=i' andalso s=s' then j else find r
184 : monnier 411
185 :     in (find (V.sub(v, index(V.length v, i))))
186 :     handle Div => raise Unbound
187 : monnier 249 end
188 :    
189 :     fun app f v =
190 :     let val n = V.length v
191 :     val bapp = bucketapp f
192 :     fun f i = if i=n then () else (bapp(V.sub(v,i)); f(i+1))
193 :     in f 0
194 :     end
195 :    
196 :     fun fold f zero v =
197 :     let val n = V.length v
198 :     fun bucketfold (NIL,x) = x
199 :     | bucketfold (B(i,s,j,r), x) = bucketfold(r, f((i,s,j),x))
200 :    
201 :     fun g(i,x) = if i=n then x else g(i+1,bucketfold(V.sub(v,i),x))
202 :     in g(0,zero)
203 :     end
204 :    
205 : monnier 411 fun new (bindings: (word*string*'b) list) =
206 : monnier 249 let val n = List.length bindings
207 :     val a0 = Array.array(n,NIL: 'b bucket)
208 :     val dups = ref 0
209 :    
210 :     fun add a (i,s,b) =
211 : monnier 411 let val indx = index(Array.length a, i)
212 : monnier 249 fun f NIL = B(i,s,b,NIL)
213 :     | f (B(i',s',b',r)) =
214 :     if i'=i andalso s'=s
215 :     then (dups := !dups+1; B(i,s,b,r))
216 :     else B(i',s',b',f r)
217 : monnier 411 in Array.update(a,indx,f(Array.sub(a,indx)))
218 : monnier 249 end
219 :    
220 :     val _ = List.app (add a0) bindings
221 :     val a1 = case !dups
222 :     of 0 => a0
223 :     | d => let val a = Array.array(n-d, NIL: 'b bucket)
224 :     in List.app (add a) bindings; a
225 :     end
226 :    
227 :     in Vector.tabulate(Array.length a1, fn i => Array.sub(a1,i))
228 :     end
229 :     handle Div => (ErrorMsg.impossible "IntStrMapV.new raises Div";
230 : monnier 411 raise Div)
231 : monnier 249
232 :     end (* structure IntStrMapV *)
233 :    
234 :     (* representation of environments *)
235 :     (* 'b will always be instantiated to Basics.binding *)
236 :    
237 :     datatype 'b env
238 :     = EMPTY
239 : monnier 411 | BIND of word * string * 'b * 'b env
240 : monnier 249 | TABLE of 'b IntStrMapV.intstrmap * 'b env
241 :     | SPECIAL of (Symbol.symbol -> 'b) * (unit -> Symbol.symbol list) * 'b env
242 :     (* for, e.g., debugger *)
243 :    
244 :     exception SpecialEnv
245 :     (* raised by app when it encounters a SPECIAL env *)
246 :    
247 :     val empty = EMPTY
248 :    
249 :     fun look (env,sym as Symbol.SYMBOL(is as (i,s))) =
250 :     let fun f EMPTY = (debugmsg("$Env.look "^s); raise Unbound)
251 :     | f (BIND(i',s',b,n)) =
252 :     if i = i' andalso s = s' then b else f n
253 :     | f (TABLE(t,n)) = (IntStrMapV.map t is handle Unbound => f n)
254 :     | f (SPECIAL(g,_,n)) = (g sym handle Unbound => f n)
255 :     in f env
256 :     end
257 :    
258 :     fun bind (Symbol.SYMBOL(i,s),binding,env) = BIND (i,s,binding,env)
259 :    
260 :     exception NoSymbolList
261 :    
262 :     fun special (look', getSyms) =
263 :     let val memo_env = ref empty
264 :     fun lookMem sym =
265 :     look(!memo_env, sym)
266 :     handle Unbound =>
267 :     let val binding = look' sym
268 :     in memo_env := bind(sym,binding,!memo_env);
269 :     binding
270 :     end
271 :    
272 :     val memo_syms = ref(NONE: Symbol.symbol list option)
273 :     fun getsymsMem() =
274 :     case !memo_syms
275 :     of NONE => let val syms = getSyms()
276 :     in memo_syms := SOME syms; syms
277 :     end
278 :     | SOME syms => syms
279 :     in SPECIAL(lookMem,getsymsMem,empty)
280 :     end
281 :    
282 :     infix atop
283 :    
284 :     fun EMPTY atop e = e
285 :     | (BIND(i,s,b,n)) atop e = BIND(i,s,b,n atop e)
286 :     | (TABLE(t,n)) atop e = TABLE(t,n atop e)
287 :     | (SPECIAL(g,syms,n)) atop e = SPECIAL(g, syms, n atop e)
288 :    
289 :     fun app f =
290 :     let fun g (BIND(i,s,b,n)) = (g n; f (Symbol.SYMBOL(i,s),b))
291 :     | g (TABLE(t,n)) =
292 :     (g n; IntStrMapV.app (fn (i,s,b) => f(Symbol.SYMBOL(i,s),b)) t)
293 :     | g (SPECIAL(looker,syms,n)) =
294 :     (g n; List.app (fn sym=>f(sym,looker sym)) (syms()))
295 :     | g (EMPTY) = ()
296 :     in g
297 :     end
298 :    
299 :     fun symbols env =
300 :     let fun f(syms,BIND(i,s,b,n)) = f(Symbol.SYMBOL(i,s)::syms,n)
301 :     | f(syms,TABLE(t,n)) =
302 :     let val r = ref syms
303 :     fun add(i,s,_) = r := Symbol.SYMBOL(i,s):: !r
304 :     in IntStrMapV.app add t; f(!r,n)
305 :     end
306 :     | f(syms,SPECIAL(_,syms',n)) = f(syms'()@syms, n)
307 :     | f(syms,EMPTY) = syms
308 :     in f(nil,env)
309 :     end
310 :    
311 :     fun map func (TABLE(t,EMPTY)) = (* optimized case *)
312 :     TABLE(IntStrMapV.transform func t, EMPTY)
313 :     | map func env =
314 :     let fun f(syms,BIND(i,s,b,n)) = f((i,s,func b)::syms,n)
315 :     | f(syms,TABLE(t,n)) =
316 :     let val r = ref syms
317 :     fun add(i,s,b) = r := (i,s,func b) :: !r
318 :     in IntStrMapV.app add t;
319 :     f(!r,n)
320 :     end
321 :     | f(syms,SPECIAL(look',syms',n)) =
322 :     f(List.map (fn (sym as Symbol.SYMBOL(i,s)) =>
323 :     (i,s,func(look' sym))) (syms'())@syms,
324 :     n)
325 :     | f(syms,EMPTY) = syms
326 :    
327 :     in TABLE(IntStrMapV.new(f(nil,env)), EMPTY)
328 :     end
329 :    
330 :     fun fold f base e =
331 :     let fun g (BIND(i,s,b,n),x) =
332 :     let val y = g(n,x)
333 :     in f((Symbol.SYMBOL(i,s),b),y)
334 :     end
335 :     | g (e as TABLE(t,n),x) =
336 :     let val y = g(n,x)
337 :     in IntStrMapV.fold
338 :     (fn ((i,s,b),z) => f((Symbol.SYMBOL(i,s),b),z)) y t
339 :     end
340 :     | g (SPECIAL(looker,syms,n),x) =
341 :     let val y = g(n,x)
342 :     val symbols = (syms())
343 :     in List.foldr (fn (sym,z) =>f((sym,looker sym),z)) y symbols
344 :     end
345 :     | g (EMPTY,x) = x
346 :     in g(e,base)
347 :     end
348 :    
349 :     fun consolidate (env as TABLE(_,EMPTY)) = env
350 :     | consolidate (env as EMPTY) = env
351 :     | consolidate env = map (fn x => x) env handle NoSymbolList => env
352 :    
353 :     fun shouldConsolidate env =
354 :     let fun f(depth,size, BIND(_,_,_,n)) = f(depth+1,size+1,n)
355 :     | f(depth,size, TABLE(t,n)) = f(depth+1, size+IntStrMapV.elems t, n)
356 :     | f(depth,size, SPECIAL(_,_,n)) = f(depth+1,size+100,n)
357 :     | f(depth,size, EMPTY) = depth*10 > size
358 :     in f(0,0,env)
359 :     end
360 :    
361 :     (*
362 :     fun tooDeep env =
363 :     let fun f(depth,env) = if depth > 30 then true
364 :     else case env
365 :     of BIND(_,_,_,n) => f(depth+1,n)
366 :     | TABLE(_,n) => f(depth+1,n)
367 :     | SPECIAL(_,_,n) => f(depth+1,n)
368 :     | EMPTY => false
369 :     in f(0,env)
370 :     end
371 :     *)
372 :    
373 :     fun consolidateLazy (env as TABLE(_,EMPTY)) = env
374 :     | consolidateLazy (env as EMPTY) = env
375 :     | consolidateLazy env =
376 :     if shouldConsolidate env
377 :     then map (fn x => x) env handle NoSymbolList => env
378 :     else env
379 :    
380 :     end (* structure Env *)
381 :    
382 :     (*
383 :     * $Log: env.sml,v $
384 : monnier 411 * Revision 1.2 1998/08/05 15:29:37 dbm
385 :     * clean out old imperative type variables
386 :     *
387 : monnier 249 * Revision 1.1.1.1 1998/04/08 18:39:34 george
388 :     * Version 110.5
389 :     *
390 :     *)

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