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/FLINT/cps/switch.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/cps/switch.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* switch.sml *)
3 :    
4 :     signature SWITCH =
5 :     sig
6 :    
7 :     exception TooBig
8 :    
9 :     val switch:
10 :     {E_int: int -> 'value, (* may raise TooBig; not all ints need
11 :     be representable *)
12 :     E_real: string -> 'value,
13 :     E_switchlimit : int,
14 :     E_neq: 'comparison,
15 :     E_w32neq: 'comparison,
16 :     E_i32neq: 'comparison,
17 :     E_word32: Word32.word -> 'value,
18 :     E_int32: Word32.word -> 'value,
19 :     E_wneq: 'comparison,
20 :     E_word: word -> 'value,
21 :     E_pneq: 'comparison,
22 :     E_fneq: 'comparison,
23 :     E_less: 'comparison,
24 :     E_branch: 'comparison * 'value * 'value * 'cexp * 'cexp -> 'cexp,
25 :     E_strneq: 'value * string * 'cexp * 'cexp -> 'cexp,
26 :     E_switch: 'value * 'cexp list -> 'cexp,
27 :     E_add : 'value * 'value * ('value->'cexp) -> 'cexp,
28 :     E_gettag: 'value * ('value -> 'cexp) -> 'cexp,
29 :     E_getexn: 'value * ('value -> 'cexp) -> 'cexp,
30 :     E_length: 'value * ('value -> 'cexp) -> 'cexp,
31 :     E_unwrap: 'value * ('value -> 'cexp) -> 'cexp,
32 :     E_boxed: 'value * 'cexp * 'cexp -> 'cexp,
33 :     E_path: Access.access * ('value->'cexp) -> 'cexp
34 :     } ->
35 :     {exp: 'value,
36 :     sign: Access.consig,
37 :     cases: (Lambda.con * 'cexp) list,
38 :     default: 'cexp}
39 :     ->
40 :     'cexp
41 :    
42 :     end
43 :    
44 :     structure Switch : SWITCH =
45 :     struct
46 :    
47 :     local
48 :    
49 :     structure L = Lambda
50 :     structure A = Access
51 :    
52 :     in
53 :    
54 :     fun bug s = ErrorMsg.impossible ("Switch: " ^ s)
55 :    
56 :     exception TooBig
57 :    
58 :     fun sublist test =
59 :     let fun subl(a::r) = if test a then a::(subl r) else subl r
60 :     | subl x = x
61 :     in subl
62 :     end
63 :    
64 :     fun nthcdr(l, 0) = l
65 :     | nthcdr(a::r, n) = nthcdr(r, n-1)
66 :     | nthcdr _ = bug "nthcdr in switch"
67 :    
68 :     fun count test =
69 :     let fun subl acc (a::r) = subl(if test a then 1+acc else acc) r
70 :     | subl acc nil = acc
71 :     in subl 0
72 :     end
73 :    
74 :     fun switch
75 :     {E_int: int -> 'value, (* may raise TooBig; not all ints need
76 :     be representable *)
77 :     E_real: string -> 'value,
78 :     E_switchlimit : int,
79 :     E_neq: 'comparison,
80 :     E_w32neq: 'comparison,
81 :     E_i32neq: 'comparison,
82 :     E_word32: Word32.word -> 'value,
83 :     E_int32: Word32.word -> 'value,
84 :     E_wneq: 'comparison,
85 :     E_word: word -> 'value,
86 :     E_pneq: 'comparison,
87 :     E_fneq: 'comparison,
88 :     E_less: 'comparison,
89 :     E_branch: 'comparison * 'value * 'value * 'cexp * 'cexp -> 'cexp,
90 :     E_strneq: 'value * string * 'cexp * 'cexp -> 'cexp,
91 :     E_switch: 'value * 'cexp list -> 'cexp,
92 :     E_add : 'value * 'value * ('value->'cexp) -> 'cexp,
93 :     E_gettag: 'value * ('value -> 'cexp) -> 'cexp,
94 :     E_getexn: 'value * ('value -> 'cexp) -> 'cexp,
95 :     E_length: 'value * ('value -> 'cexp) -> 'cexp,
96 :     E_unwrap: 'value * ('value -> 'cexp) -> 'cexp,
97 :     E_boxed: 'value * 'cexp * 'cexp -> 'cexp,
98 :     E_path: Access.access * ('value->'cexp) -> 'cexp
99 :     } =
100 :     let
101 :    
102 :     fun switch1(e : 'value, cases : (int*'cexp) list, default : 'cexp, (lo,hi)) =
103 :     let val delta = 2
104 :     fun collapse (l as (li,ui,ni,xi)::(lj,uj,nj,xj)::r ) =
105 :     if ((ni+nj) * delta > ui-lj) then collapse((lj,ui,ni+nj,xj)::r)
106 :     else l
107 :     | collapse l = l
108 :     fun f (z, x as (i,_)::r) = f(collapse((i,i,1,x)::z), r)
109 :     | f (z, nil) = z
110 :     fun tackon (stuff as (l,u,n,x)::r) =
111 :     if n*delta > u-l andalso n>E_switchlimit andalso hi>u
112 :     then tackon((l,u+1,n+1,x@[(u+1,default)])::r)
113 :     else stuff
114 :     | tackon nil = bug "switch.3217"
115 :     fun separate((z as (l,u,n,x))::r) =
116 :     if n<E_switchlimit andalso n>1
117 :     then let val ix as (i,_) = List.nth(x, (n-1))
118 :     in (i,i,1,[ix])::separate((l,l,n-1,x)::r)
119 :     end
120 :     else z :: separate r
121 :     | separate nil = nil
122 :     val chunks = rev (separate (tackon (f (nil,cases))))
123 :     fun g(1,(l,h,1,(i,b)::_)::_,(lo,hi)) =
124 :     if lo=i andalso hi=i then b
125 :     else E_branch(E_neq,e,E_int i,default,b)
126 :     | g(1,(l,h,n,x)::_,(lo,hi)) =
127 :     let fun f(0,_,_) = nil
128 :     | f(n,i,l as (j,b)::r) =
129 :     if i+lo = j then b::f(n-1,i+1,r)
130 :     else (default::f(n,i+1,l))
131 :     | f _ = bug "switch.987"
132 :     val list = f(n,0,x)
133 :     val body = if lo=0 then E_switch(e, list)
134 :     else E_add(e, E_int(~lo),fn v =>E_switch(v,list))
135 :     val a = if (lo<l) then E_branch(E_less,e,E_int l,default,body)
136 :     else body
137 :     val b = if (hi > h) then E_branch(E_less,E_int h,e,default,a)
138 :     else a
139 :     in b
140 :     end
141 :     | g(n,cases,(lo,hi)) =
142 :     let val n2 = n div 2
143 :     val c2 = nthcdr(cases, n2)
144 :     val (l,r) = case c2 of (l1,_,_,_)::r1 => (l1,r1)
145 :     | _ => bug "switch.111"
146 :     in E_branch(E_less,e,E_int l, g(n2,cases,(lo,l-1)), g(n-n2,c2,(l,hi)))
147 :     end
148 :     in g (List.length chunks, chunks, (lo, hi))
149 :     end
150 :    
151 :     val sortcases = Sort.sort (fn ((i:int,_),(j,_)) => i>j)
152 :    
153 :     fun int_switch(e: 'value, l, default, inrange) =
154 :     let val len = List.length l
155 :    
156 :     fun isbig i = (E_int i; false) handle TooBig => true
157 :     val anybig = List.exists (isbig o #1) l
158 :     fun construct(i, c) =
159 :     if isbig i
160 :     then let val j = i div 2
161 :     in construct(j,fn j' =>
162 :     construct(i-j, fn k' =>
163 :     E_add(j', k', c)))
164 :     end
165 :     else c(E_int i)
166 :    
167 :     fun ifelse nil = default
168 :     | ifelse ((i,b)::r) =
169 :     construct(i, fn i' => E_branch(E_neq, i', e, ifelse r, b))
170 :    
171 :     fun ifelseN [(i,b)] = b
172 :     | ifelseN ((i,b)::r) = E_branch(E_neq,E_int i, e, ifelseN r, b)
173 :     | ifelseN _ = bug "switch.224"
174 :     val l = sortcases l
175 :     in case (anybig orelse len<E_switchlimit, inrange)
176 :     of (true, NONE) => ifelse l
177 :     | (true, SOME n) => if n+1=len then ifelseN l else ifelse l
178 :     | (false, NONE) =>
179 :     let val (hi,_) = List.last l
180 :     handle List.Empty => bug "switch.last132"
181 :     val (low,r) = case l of (low',_)::r' => (low',r')
182 :     | _ => bug "switch.23"
183 :     in E_branch(E_less,e,E_int low, default,
184 :     E_branch(E_less,E_int hi, e, default,
185 :     switch1(e, l, default, (low,hi))))
186 :     end
187 :     | (false, SOME n) => switch1(e, l, default, (0,n))
188 :     end
189 :    
190 :     fun isboxed (L.DATAcon(_,A.CONSTANT _, _)) = false
191 :     | isboxed (L.DATAcon(_,A.LISTNIL,_)) = false
192 :     | isboxed (L.DATAcon(_,rep,_)) = true
193 :     | isboxed (L.REALcon _) = true
194 :     | isboxed (L.STRINGcon s) = true
195 :     | isboxed _ = false
196 :    
197 :     fun isexn (L.DATAcon(_,A.EXN _,_)) = true
198 :     | isexn _ = false
199 :    
200 :     fun exn_switch(w,l,default) =
201 :     E_getexn(w, fn u =>
202 :     let fun g((L.DATAcon(_,A.EXN p,_),x)::r) =
203 :     E_path(p, fn v => E_branch(E_pneq,u,v, g r, x))
204 :     | g nil = default
205 :     | g _ = bug "switch.21"
206 :     in g l
207 :     end)
208 :    
209 :     fun datacon_switch(w,sign,l: (Lambda.con * 'cexp) list, default) =
210 :     let
211 :     fun tag (L.DATAcon(_,A.CONSTANT i,_)) = i
212 :     | tag (L.DATAcon(_,A.TAGGED i,_)) = i
213 :     (* | tag (L.DATAcon(_,A.TAGGEDREC(i,_),_)) = i *)
214 :     | tag _ = 0
215 :    
216 :     fun tag'(c,e) = (tag c, e)
217 :    
218 :     val boxed = sublist (isboxed o #1) l
219 :     val unboxed = sublist (not o isboxed o #1) l
220 :     val b = map tag' boxed and u = map tag' unboxed
221 :    
222 :     in case sign
223 :     of A.CSIG (0, n) =>
224 :     E_unwrap(w,fn w' => int_switch(w',u,default,SOME(n-1)))
225 :     | A.CSIG (n, 0) =>
226 :     E_gettag(w,fn w' => int_switch(w',b,default,SOME(n-1)))
227 :     | A.CSIG (1, nu) =>
228 :     E_boxed(w, int_switch(E_int 0, b, default,SOME 0),
229 :     E_unwrap(w, fn w' => int_switch(w',u,default,SOME(nu-1))))
230 :     | A.CSIG (nb,nu) =>
231 :     E_boxed(w,
232 :     E_gettag(w, fn w' => int_switch(w',b,default,SOME(nb-1))),
233 :     E_unwrap(w, fn w' => int_switch(w',u,default,SOME(nu-1))))
234 :     | A.CNIL => bug "datacon_switch"
235 :     end
236 :    
237 :     fun coalesce(l:(string * 'a)list) : (int * (string * 'a) list) list = let
238 :     val l' as (s,_)::_ = Sort.sort (fn ((s1,_),(s2,_)) => size s1 > size s2) l
239 :     fun gather(n,[],current,acc) = (n,current)::acc
240 :     | gather(n,(x as (s,a))::rest,current,acc) = let val s1 = size s
241 :     in
242 :     if s1 = n then gather(n,rest,x::current,acc)
243 :     else gather(s1,rest,[x],(n,current)::acc)
244 :     end
245 :     in
246 :     gather(size s,l',[],[])
247 :     end
248 :    
249 :     fun string_switch(w,l,default) =
250 :     let fun strip (L.STRINGcon s, x) = (s,x)
251 :     val b = map strip l
252 :    
253 :     val bylength = coalesce b
254 :    
255 :     fun one_len(0,(_,e)::_) = (0,e)
256 :     | one_len(len,l) =
257 :     let fun try nil = default
258 :     | try ((s,e)::r) = E_strneq(w,s, try r, e)
259 :     in (len,try l)
260 :     end
261 :    
262 :     val genbs =
263 :     E_length(w,fn len =>
264 :     int_switch(len, map one_len bylength, default, NONE))
265 :    
266 :     in genbs
267 :     end
268 :    
269 :     fun real_switch(w,(L.REALcon rval, x)::r, default) =
270 :     E_branch(E_fneq,w,E_real rval, real_switch(w,r,default), x)
271 :     | real_switch(_,nil,default) = default
272 :     | real_switch _ = bug "switch.81"
273 :    
274 :     fun word_switch(w, (L.WORDcon wval,e)::r, default) =
275 :     E_branch(E_wneq, w, E_word wval, word_switch(w,r,default), e)
276 :     | word_switch(_, nil, default) = default
277 :     | word_switch _ = bug "switch.88"
278 :    
279 :     fun word32_switch(w,(L.WORD32con i32val,e)::r,default) =
280 :     E_branch(E_w32neq, w, E_word32 i32val, word32_switch(w,r,default), e)
281 :     | word32_switch(_, nil, default) = default
282 :     | word32_switch _ = bug "switch.78"
283 :    
284 :     fun int32_switch(w, (L.INT32con i32val, e)::r, default) = let
285 :     val int32ToWord32 = Word32.fromLargeInt o Int32.toLarge
286 :     in
287 :     E_branch(E_i32neq, w, E_int32 (int32ToWord32 i32val),
288 :     int32_switch(w, r, default), e)
289 :     end
290 :     | int32_switch(_, nil, default) = default
291 :     | int32_switch _ = bug "switch.77"
292 :    
293 :     in fn {cases=nil,default,...} => default
294 :     | {exp,sign,cases as (c,_)::_,default} =>
295 :     case c
296 :     of L.INTcon _ =>
297 :     let fun un_int(L.INTcon i, e) = (i,e)
298 :     in int_switch(exp,map un_int cases,default,NONE)
299 :     end
300 :     | L.REALcon _ => real_switch(exp,cases,default)
301 :     | L.STRINGcon _ => string_switch(exp,cases,default)
302 :     | L.DATAcon(_,A.EXN _,_) => exn_switch(exp,cases,default)
303 :     | L.DATAcon _ => datacon_switch(exp,sign,cases,default)
304 :     | L.WORDcon _ => word_switch(exp, cases, default)
305 :     | L.WORD32con _ => word32_switch(exp,cases,default)
306 :     | L.INT32con _ => int32_switch(exp,cases,default)
307 :     | _ => bug "unexpected datacon in genswitch"
308 :    
309 :     end
310 :    
311 :     end (* toplevel local *)
312 :     end (* structure Switch *)
313 :    
314 :     (*
315 :     * $Log: switch.sml,v $
316 :     * Revision 1.1.1.1 1997/01/14 01:38:32 george
317 :     * Version 109.24
318 :     *
319 :     *)

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