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 651 - (view) (download)

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

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