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 1393 - (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 :    
102 :     end (* structure IntStrMapV *)
103 :    
104 :     (* representation of environments *)
105 :     (* 'b will always be instantiated to Basics.binding *)
106 :    
107 :     datatype 'b env
108 :     = EMPTY
109 :     | BIND of word * string * 'b * 'b env
110 :     | TABLE of 'b IntStrMapV.intstrmap * 'b env
111 :     | SPECIAL of (Symbol.symbol -> 'b) * (unit -> Symbol.symbol list) * 'b env
112 :     (* for, e.g., debugger *)
113 :    
114 :     val empty = EMPTY
115 :    
116 :     fun look (env,sym as Symbol.SYMBOL(is as (i,s))) =
117 :     let fun f EMPTY = (debugmsg("$Env.look "^s); raise Unbound)
118 :     | f (BIND(i',s',b,n)) =
119 :     if i = i' andalso s = s' then b else f n
120 :     | f (TABLE(t,n)) = (IntStrMapV.map t is handle Unbound => f n)
121 :     | f (SPECIAL(g,_,n)) = (g sym handle Unbound => f n)
122 :     in f env
123 :     end
124 :    
125 :     fun bind (Symbol.SYMBOL(i,s),binding,env) = BIND (i,s,binding,env)
126 :    
127 :     fun special (look', getSyms) =
128 :     let val memo_env = ref empty
129 :     fun lookMem sym =
130 :     look(!memo_env, sym)
131 :     handle Unbound =>
132 :     let val binding = look' sym
133 :     in memo_env := bind(sym,binding,!memo_env);
134 :     binding
135 :     end
136 :    
137 :     val memo_syms = ref(NONE: Symbol.symbol list option)
138 :     fun getsymsMem() =
139 :     case !memo_syms
140 :     of NONE => let val syms = getSyms()
141 :     in memo_syms := SOME syms; syms
142 :     end
143 :     | SOME syms => syms
144 :     in SPECIAL(lookMem,getsymsMem,empty)
145 :     end
146 :    
147 :     infix atop
148 :    
149 :     fun EMPTY atop e = e
150 :     | (BIND(i,s,b,n)) atop e = BIND(i,s,b,n atop e)
151 :     | (TABLE(t,n)) atop e = TABLE(t,n atop e)
152 :     | (SPECIAL(g,syms,n)) atop e = SPECIAL(g, syms, n atop e)
153 :    
154 :     fun app f =
155 :     let fun g (BIND(i,s,b,n)) = (g n; f (Symbol.SYMBOL(i,s),b))
156 :     | g (TABLE(t,n)) =
157 :     (g n; IntStrMapV.app (fn (i,s,b) => f(Symbol.SYMBOL(i,s),b)) t)
158 :     | g (SPECIAL(looker,syms,n)) =
159 :     (g n; List.app (fn sym=>f(sym,looker sym)) (syms()))
160 :     | g (EMPTY) = ()
161 :     in g
162 :     end
163 :    
164 :     fun symbols env =
165 :     let fun f(syms,BIND(i,s,b,n)) = f(Symbol.SYMBOL(i,s)::syms,n)
166 :     | f(syms,TABLE(t,n)) =
167 :     let val r = ref syms
168 :     fun add(i,s,_) = r := Symbol.SYMBOL(i,s):: !r
169 :     in IntStrMapV.app add t; f(!r,n)
170 :     end
171 :     | f(syms,SPECIAL(_,syms',n)) = f(syms'()@syms, n)
172 :     | f(syms,EMPTY) = syms
173 :     in f(nil,env)
174 :     end
175 :    
176 :     fun map func (TABLE(t,EMPTY)) = (* optimized case *)
177 :     TABLE(IntStrMapV.transform func t, EMPTY)
178 :     | map func env =
179 :     let fun f(syms,BIND(i,s,b,n)) = f((i,s,func b)::syms,n)
180 :     | f(syms,TABLE(t,n)) =
181 :     let val r = ref syms
182 :     fun add(i,s,b) = r := (i,s,func b) :: !r
183 :     in IntStrMapV.app add t;
184 :     f(!r,n)
185 :     end
186 :     | f(syms,SPECIAL(look',syms',n)) =
187 :     f(List.map (fn (sym as Symbol.SYMBOL(i,s)) =>
188 :     (i,s,func(look' sym))) (syms'())@syms,
189 :     n)
190 :     | f(syms,EMPTY) = syms
191 :    
192 :     in TABLE(IntStrMapV.new(f(nil,env)), EMPTY)
193 :     end
194 :    
195 :     fun fold f base e =
196 :     let fun g (BIND(i,s,b,n),x) =
197 :     let val y = g(n,x)
198 :     in f((Symbol.SYMBOL(i,s),b),y)
199 :     end
200 :     | g (e as TABLE(t,n),x) =
201 :     let val y = g(n,x)
202 :     in IntStrMapV.fold
203 :     (fn ((i,s,b),z) => f((Symbol.SYMBOL(i,s),b),z)) y t
204 :     end
205 :     | g (SPECIAL(looker,syms,n),x) =
206 :     let val y = g(n,x)
207 :     val symbols = (syms())
208 :     in List.foldr (fn (sym,z) =>f((sym,looker sym),z)) y symbols
209 :     end
210 :     | g (EMPTY,x) = x
211 :     in g(e,base)
212 :     end
213 :    
214 :     fun consolidate (env as TABLE(_,EMPTY)) = env
215 :     | consolidate (env as EMPTY) = env
216 :     | consolidate env = map (fn x => x) env handle NoSymbolList => env
217 :    
218 :     fun shouldConsolidate env =
219 :     let fun f(depth,size, BIND(_,_,_,n)) = f(depth+1,size+1,n)
220 :     | f(depth,size, TABLE(t,n)) = f(depth+1, size+IntStrMapV.elems t, n)
221 :     | f(depth,size, SPECIAL(_,_,n)) = f(depth+1,size+100,n)
222 :     | f(depth,size, EMPTY) = depth*10 > size
223 :     in f(0,0,env)
224 :     end
225 :    
226 :     (*
227 :     fun tooDeep env =
228 :     let fun f(depth,env) = if depth > 30 then true
229 :     else case env
230 :     of BIND(_,_,_,n) => f(depth+1,n)
231 :     | TABLE(_,n) => f(depth+1,n)
232 :     | SPECIAL(_,_,n) => f(depth+1,n)
233 :     | EMPTY => false
234 :     in f(0,env)
235 :     end
236 :     *)
237 :    
238 :     fun consolidateLazy (env as TABLE(_,EMPTY)) = env
239 :     | consolidateLazy (env as EMPTY) = env
240 :     | consolidateLazy env =
241 :     if shouldConsolidate env
242 :     then map (fn x => x) env handle NoSymbolList => env
243 :     else env
244 :    
245 :     end (* structure Env *)

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