adam@1848
|
1 (* Copyright (c) 2008-2013, Adam Chlipala
|
adamc@443
|
2 * All rights reserved.
|
adamc@443
|
3 *
|
adamc@443
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@443
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@443
|
6 *
|
adamc@443
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@443
|
8 * this list of conditions and the following disclaimer.
|
adamc@443
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@443
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@443
|
11 * and/or other materials provided with the distribution.
|
adamc@443
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@443
|
13 * derived from this software without specific prior written permission.
|
adamc@443
|
14 *
|
adamc@443
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@443
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@443
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@443
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@443
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@443
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@443
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@443
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@443
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@443
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@443
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@443
|
26 *)
|
adamc@443
|
27
|
adamc@443
|
28 structure ESpecialize :> ESPECIALIZE = struct
|
adamc@443
|
29
|
adamc@443
|
30 open Core
|
adamc@443
|
31
|
adamc@443
|
32 structure E = CoreEnv
|
adamc@443
|
33 structure U = CoreUtil
|
adamc@443
|
34
|
adamc@479
|
35 type skey = exp
|
adamc@453
|
36
|
adamc@453
|
37 structure K = struct
|
adam@1314
|
38 type ord_key = con list * exp list
|
adam@1314
|
39 fun compare ((cs1, es1), (cs2, es2)) = Order.join (Order.joinL U.Con.compare (cs1, cs2),
|
adam@1314
|
40 fn () => Order.joinL U.Exp.compare (es1, es2))
|
adamc@443
|
41 end
|
adamc@443
|
42
|
adamc@453
|
43 structure KM = BinaryMapFn(K)
|
adamc@443
|
44 structure IM = IntBinaryMap
|
adamc@482
|
45 structure IS = IntBinarySet
|
adamc@443
|
46
|
adamc@626
|
47 val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs,
|
adamc@488
|
48 con = fn (_, _, xs) => xs,
|
adamc@488
|
49 exp = fn (bound, e, xs) =>
|
adamc@488
|
50 case e of
|
adamc@488
|
51 ERel x =>
|
adamc@488
|
52 if x >= bound then
|
adamc@488
|
53 IS.add (xs, x - bound)
|
adamc@488
|
54 else
|
adamc@488
|
55 xs
|
adamc@488
|
56 | _ => xs,
|
adamc@488
|
57 bind = fn (bound, b) =>
|
adamc@488
|
58 case b of
|
adamc@488
|
59 U.Exp.RelE _ => bound + 1
|
adamc@488
|
60 | _ => bound}
|
adamc@488
|
61 0 IS.empty
|
adamc@479
|
62
|
adamc@1120
|
63 fun isPolyT (t, _) =
|
adamc@1120
|
64 case t of
|
adamc@1120
|
65 TFun (_, ran) => isPolyT ran
|
adamc@1120
|
66 | TCFun _ => true
|
adamc@1120
|
67 | TKFun _ => true
|
adamc@1120
|
68 | _ => false
|
adamc@1120
|
69
|
adamc@1120
|
70 fun isPoly (d, _) =
|
adamc@1120
|
71 case d of
|
adamc@1120
|
72 DVal (_, _, t, _, _) => isPolyT t
|
adamc@1120
|
73 | DValRec vis => List.exists (isPolyT o #3) vis
|
adamc@1120
|
74 | _ => false
|
adamc@522
|
75
|
adamc@488
|
76 fun positionOf (v : int, ls) =
|
adamc@488
|
77 let
|
adamc@488
|
78 fun pof (pos, ls) =
|
adamc@488
|
79 case ls of
|
adamc@488
|
80 [] => raise Fail "Defunc.positionOf"
|
adamc@488
|
81 | v' :: ls' =>
|
adamc@488
|
82 if v = v' then
|
adamc@488
|
83 pos
|
adamc@488
|
84 else
|
adamc@488
|
85 pof (pos + 1, ls')
|
adamc@488
|
86 in
|
adamc@488
|
87 pof (0, ls)
|
adamc@488
|
88 end
|
adamc@488
|
89
|
adamc@1079
|
90 fun squish fvs =
|
adamc@626
|
91 U.Exp.mapB {kind = fn _ => fn k => k,
|
adamc@488
|
92 con = fn _ => fn c => c,
|
adamc@488
|
93 exp = fn bound => fn e =>
|
adamc@479
|
94 case e of
|
adamc@488
|
95 ERel x =>
|
adamc@488
|
96 if x >= bound then
|
adamc@1079
|
97 ERel (positionOf (x - bound, fvs) + bound)
|
adamc@488
|
98 else
|
adamc@488
|
99 e
|
adamc@488
|
100 | _ => e,
|
adamc@488
|
101 bind = fn (bound, b) =>
|
adamc@488
|
102 case b of
|
adamc@488
|
103 U.Exp.RelE _ => bound + 1
|
adamc@488
|
104 | _ => bound}
|
adamc@488
|
105 0
|
adamc@453
|
106
|
adamc@443
|
107 type func = {
|
adamc@443
|
108 name : string,
|
adamc@453
|
109 args : int KM.map,
|
adamc@443
|
110 body : exp,
|
adamc@443
|
111 typ : con,
|
adam@1675
|
112 tag : string,
|
adam@1675
|
113 constArgs : int (* What length prefix of the arguments never vary across recursive calls? *)
|
adamc@443
|
114 }
|
adamc@443
|
115
|
adamc@443
|
116 type state = {
|
adamc@443
|
117 maxName : int,
|
adamc@443
|
118 funcs : func IM.map,
|
adamc@1079
|
119 decls : (string * int * con * exp * string) list,
|
adamc@1080
|
120 specialized : IS.set
|
adamc@443
|
121 }
|
adamc@443
|
122
|
adamc@488
|
123 fun default (_, x, st) = (x, st)
|
adamc@443
|
124
|
adam@1863
|
125 fun functionInside known =
|
adam@1863
|
126 U.Con.exists {kind = fn _ => false,
|
adam@1863
|
127 con = fn TFun _ => true
|
adam@1863
|
128 | TCFun _ => true
|
adam@1863
|
129 | CFfi ("Basis", "transaction") => true
|
adam@1863
|
130 | CFfi ("Basis", "eq") => true
|
adam@1863
|
131 | CFfi ("Basis", "num") => true
|
adam@1863
|
132 | CFfi ("Basis", "ord") => true
|
adam@1863
|
133 | CFfi ("Basis", "show") => true
|
adam@1863
|
134 | CFfi ("Basis", "read") => true
|
adam@1863
|
135 | CFfi ("Basis", "sql_injectable_prim") => true
|
adam@1863
|
136 | CFfi ("Basis", "sql_injectable") => true
|
adam@1863
|
137 | CNamed n => IS.member (known, n)
|
adam@1863
|
138 | _ => false}
|
adam@1289
|
139
|
adam@1675
|
140 fun getApp (e, _) =
|
adam@1675
|
141 case e of
|
adam@1675
|
142 ENamed f => SOME (f, [])
|
adam@1675
|
143 | EApp (e1, e2) =>
|
adam@1675
|
144 (case getApp e1 of
|
adam@1675
|
145 NONE => NONE
|
adam@1675
|
146 | SOME (f, xs) => SOME (f, xs @ [e2]))
|
adam@1675
|
147 | _ => NONE
|
adam@1675
|
148
|
adam@1675
|
149 val getApp = fn e => case getApp e of
|
adam@1675
|
150 v as SOME (_, _ :: _) => v
|
adam@1675
|
151 | _ => NONE
|
adam@1675
|
152
|
adam@1675
|
153 val maxInt = Option.getOpt (Int.maxInt, 9999)
|
adam@1675
|
154
|
adam@1766
|
155 fun calcConstArgs enclosingFunctions e =
|
adam@1675
|
156 let
|
adam@1675
|
157 fun ca depth e =
|
adam@1675
|
158 case #1 e of
|
adam@1675
|
159 EPrim _ => maxInt
|
adam@1675
|
160 | ERel _ => maxInt
|
adam@1766
|
161 | ENamed n => if IS.member (enclosingFunctions, n) then 0 else maxInt
|
adam@1675
|
162 | ECon (_, _, _, NONE) => maxInt
|
adam@1675
|
163 | ECon (_, _, _, SOME e) => ca depth e
|
adam@1675
|
164 | EFfi _ => maxInt
|
adam@1675
|
165 | EFfiApp (_, _, ecs) => foldl (fn ((e, _), d) => Int.min (ca depth e, d)) maxInt ecs
|
adam@1675
|
166 | EApp (e1, e2) =>
|
adam@1675
|
167 let
|
adam@1675
|
168 fun default () = Int.min (ca depth e1, ca depth e2)
|
adam@1675
|
169 in
|
adam@1675
|
170 case getApp e of
|
adam@1675
|
171 NONE => default ()
|
adam@1675
|
172 | SOME (f, args) =>
|
adam@1766
|
173 if not (IS.member (enclosingFunctions, f)) then
|
adam@1675
|
174 default ()
|
adam@1675
|
175 else
|
adam@1675
|
176 let
|
adam@1675
|
177 fun visitArgs (count, args) =
|
adam@1675
|
178 case args of
|
adam@1675
|
179 [] => count
|
adam@1675
|
180 | arg :: args' =>
|
adam@1675
|
181 let
|
adam@1675
|
182 fun default () = foldl (fn (e, d) => Int.min (ca depth e, d)) count args
|
adam@1675
|
183 in
|
adam@1675
|
184 case #1 arg of
|
adam@1675
|
185 ERel n =>
|
adam@1676
|
186 if n = depth - 1 - count then
|
adam@1675
|
187 visitArgs (count + 1, args')
|
adam@1675
|
188 else
|
adam@1675
|
189 default ()
|
adam@1675
|
190 | _ => default ()
|
adam@1675
|
191 end
|
adam@1675
|
192 in
|
adam@1675
|
193 visitArgs (0, args)
|
adam@1675
|
194 end
|
adam@1675
|
195 end
|
adam@1675
|
196 | EAbs (_, _, _, e1) => ca (depth + 1) e1
|
adam@1675
|
197 | ECApp (e1, _) => ca depth e1
|
adam@1675
|
198 | ECAbs (_, _, e1) => ca depth e1
|
adam@1675
|
199 | EKAbs (_, e1) => ca depth e1
|
adam@1675
|
200 | EKApp (e1, _) => ca depth e1
|
adam@1675
|
201 | ERecord xets => foldl (fn ((_, e, _), d) => Int.min (ca depth e, d)) maxInt xets
|
adam@1675
|
202 | EField (e1, _, _) => ca depth e1
|
adam@1675
|
203 | EConcat (e1, _, e2, _) => Int.min (ca depth e1, ca depth e2)
|
adam@1675
|
204 | ECut (e1, _, _) => ca depth e1
|
adam@1675
|
205 | ECutMulti (e1, _, _) => ca depth e1
|
adam@1675
|
206 | ECase (e1, pes, _) => foldl (fn ((p, e), d) => Int.min (ca (depth + E.patBindsN p) e, d)) (ca depth e1) pes
|
adam@1675
|
207 | EWrite e1 => ca depth e1
|
adam@1675
|
208 | EClosure (_, es) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
|
adam@1675
|
209 | ELet (_, _, e1, e2) => Int.min (ca depth e1, ca (depth + 1) e2)
|
adam@1848
|
210 | EServerCall (_, es, _, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
|
adam@1675
|
211
|
adam@1675
|
212 fun enterAbs depth e =
|
adam@1675
|
213 case #1 e of
|
adam@1675
|
214 EAbs (_, _, _, e1) => enterAbs (depth + 1) e1
|
adam@1675
|
215 | _ => ca depth e
|
adam@1675
|
216 in
|
adam@1677
|
217 enterAbs 0 e
|
adam@1675
|
218 end
|
adam@1675
|
219
|
adam@1675
|
220
|
adam@1863
|
221 fun optionExists p opt =
|
adam@1863
|
222 case opt of
|
adam@1863
|
223 NONE => false
|
adam@1863
|
224 | SOME v => p v
|
adam@1863
|
225
|
adamc@1080
|
226 fun specialize' (funcs, specialized) file =
|
adamc@443
|
227 let
|
adam@1863
|
228 val known = foldl (fn (d, known) =>
|
adam@1863
|
229 case #1 d of
|
adam@1863
|
230 DCon (_, n, _, c) =>
|
adam@1863
|
231 if functionInside known c then
|
adam@1863
|
232 IS.add (known, n)
|
adam@1863
|
233 else
|
adam@1863
|
234 known
|
adam@1863
|
235 | DDatatype dts =>
|
adam@1863
|
236 if List.exists (List.exists (optionExists (functionInside known) o #3) o #4) dts then
|
adam@1863
|
237 foldl (fn (dt, known) => IS.add (known, #2 dt)) known dts
|
adam@1863
|
238 else
|
adam@1863
|
239 known
|
adam@1863
|
240 | _ => known)
|
adam@1863
|
241 IS.empty file
|
adam@1863
|
242
|
adamc@488
|
243 fun bind (env, b) =
|
adamc@488
|
244 case b of
|
adamc@521
|
245 U.Decl.RelE xt => xt :: env
|
adamc@521
|
246 | _ => env
|
adamc@488
|
247
|
adamc@1080
|
248 fun exp (env, e as (_, loc), st : state) =
|
adamc@482
|
249 let
|
adamc@721
|
250 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty
|
adamc@721
|
251 (e, ErrorMsg.dummySpan))]*)
|
adamc@721
|
252
|
adamc@1080
|
253 fun default () =
|
adamc@1080
|
254 case #1 e of
|
adamc@1080
|
255 EPrim _ => (e, st)
|
adamc@1080
|
256 | ERel _ => (e, st)
|
adamc@1080
|
257 | ENamed _ => (e, st)
|
adamc@1080
|
258 | ECon (_, _, _, NONE) => (e, st)
|
adamc@1080
|
259 | ECon (dk, pc, cs, SOME e) =>
|
adamc@1080
|
260 let
|
adamc@1080
|
261 val (e, st) = exp (env, e, st)
|
adamc@1080
|
262 in
|
adamc@1080
|
263 ((ECon (dk, pc, cs, SOME e), loc), st)
|
adamc@1080
|
264 end
|
adamc@1080
|
265 | EFfi _ => (e, st)
|
adamc@1080
|
266 | EFfiApp (m, x, es) =>
|
adamc@1080
|
267 let
|
adam@1663
|
268 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
|
adam@1663
|
269 let
|
adam@1663
|
270 val (e, st) = exp (env, e, st)
|
adam@1663
|
271 in
|
adam@1663
|
272 ((e, t), st)
|
adam@1663
|
273 end) st es
|
adamc@1080
|
274 in
|
adamc@1080
|
275 ((EFfiApp (m, x, es), loc), st)
|
adamc@1080
|
276 end
|
adamc@1080
|
277 | EApp (e1, e2) =>
|
adamc@1080
|
278 let
|
adamc@1080
|
279 val (e1, st) = exp (env, e1, st)
|
adamc@1080
|
280 val (e2, st) = exp (env, e2, st)
|
adamc@1080
|
281 in
|
adamc@1080
|
282 ((EApp (e1, e2), loc), st)
|
adamc@1080
|
283 end
|
adamc@1080
|
284 | EAbs (x, d, r, e) =>
|
adamc@1080
|
285 let
|
adamc@1080
|
286 val (e, st) = exp ((x, d) :: env, e, st)
|
adamc@1080
|
287 in
|
adamc@1080
|
288 ((EAbs (x, d, r, e), loc), st)
|
adamc@1080
|
289 end
|
adamc@1080
|
290 | ECApp (e, c) =>
|
adamc@1080
|
291 let
|
adamc@1080
|
292 val (e, st) = exp (env, e, st)
|
adamc@1080
|
293 in
|
adamc@1080
|
294 ((ECApp (e, c), loc), st)
|
adamc@1080
|
295 end
|
adamc@1185
|
296 | ECAbs _ => (e, st)
|
adamc@1120
|
297 | EKAbs _ => (e, st)
|
adamc@1080
|
298 | EKApp (e, k) =>
|
adamc@1080
|
299 let
|
adamc@1080
|
300 val (e, st) = exp (env, e, st)
|
adamc@1080
|
301 in
|
adamc@1080
|
302 ((EKApp (e, k), loc), st)
|
adamc@1080
|
303 end
|
adamc@1080
|
304 | ERecord fs =>
|
adamc@1080
|
305 let
|
adamc@1080
|
306 val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) =>
|
adamc@1080
|
307 let
|
adamc@1080
|
308 val (e, st) = exp (env, e, st)
|
adamc@1080
|
309 in
|
adamc@1080
|
310 ((c1, e, c2), st)
|
adamc@1080
|
311 end) st fs
|
adamc@1080
|
312 in
|
adamc@1080
|
313 ((ERecord fs, loc), st)
|
adamc@1080
|
314 end
|
adamc@1080
|
315 | EField (e, c, cs) =>
|
adamc@1080
|
316 let
|
adamc@1080
|
317 val (e, st) = exp (env, e, st)
|
adamc@1080
|
318 in
|
adamc@1080
|
319 ((EField (e, c, cs), loc), st)
|
adamc@1080
|
320 end
|
adamc@1080
|
321 | EConcat (e1, c1, e2, c2) =>
|
adamc@1080
|
322 let
|
adamc@1080
|
323 val (e1, st) = exp (env, e1, st)
|
adamc@1080
|
324 val (e2, st) = exp (env, e2, st)
|
adamc@1080
|
325 in
|
adamc@1080
|
326 ((EConcat (e1, c1, e2, c2), loc), st)
|
adamc@1080
|
327 end
|
adamc@1080
|
328 | ECut (e, c, cs) =>
|
adamc@1080
|
329 let
|
adamc@1080
|
330 val (e, st) = exp (env, e, st)
|
adamc@1080
|
331 in
|
adamc@1080
|
332 ((ECut (e, c, cs), loc), st)
|
adamc@1080
|
333 end
|
adamc@1080
|
334 | ECutMulti (e, c, cs) =>
|
adamc@1080
|
335 let
|
adamc@1080
|
336 val (e, st) = exp (env, e, st)
|
adamc@1080
|
337 in
|
adamc@1080
|
338 ((ECutMulti (e, c, cs), loc), st)
|
adamc@1080
|
339 end
|
adamc@1080
|
340
|
adamc@1080
|
341 | ECase (e, pes, cs) =>
|
adamc@1080
|
342 let
|
adamc@1080
|
343 val (e, st) = exp (env, e, st)
|
adamc@1080
|
344 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
|
adamc@1080
|
345 let
|
adamc@1080
|
346 val (e, st) = exp (E.patBindsL p @ env, e, st)
|
adamc@1080
|
347 in
|
adamc@1080
|
348 ((p, e), st)
|
adamc@1080
|
349 end) st pes
|
adamc@1080
|
350 in
|
adamc@1080
|
351 ((ECase (e, pes, cs), loc), st)
|
adamc@1080
|
352 end
|
adamc@1080
|
353
|
adamc@1080
|
354 | EWrite e =>
|
adamc@1080
|
355 let
|
adamc@1080
|
356 val (e, st) = exp (env, e, st)
|
adamc@1080
|
357 in
|
adamc@1080
|
358 ((EWrite e, loc), st)
|
adamc@1080
|
359 end
|
adamc@1080
|
360 | EClosure (n, es) =>
|
adamc@1080
|
361 let
|
adamc@1080
|
362 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
|
adamc@1080
|
363 in
|
adamc@1080
|
364 ((EClosure (n, es), loc), st)
|
adamc@1080
|
365 end
|
adamc@1080
|
366 | ELet (x, t, e1, e2) =>
|
adamc@1080
|
367 let
|
adamc@1080
|
368 val (e1, st) = exp (env, e1, st)
|
adamc@1080
|
369 val (e2, st) = exp ((x, t) :: env, e2, st)
|
adamc@1080
|
370 in
|
adamc@1080
|
371 ((ELet (x, t, e1, e2), loc), st)
|
adamc@1080
|
372 end
|
adam@1848
|
373 | EServerCall (n, es, t, fm) =>
|
adamc@1080
|
374 let
|
adamc@1080
|
375 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
|
adamc@1080
|
376 in
|
adam@1848
|
377 ((EServerCall (n, es, t, fm), loc), st)
|
adamc@1080
|
378 end
|
adamc@482
|
379 in
|
adamc@482
|
380 case getApp e of
|
adamc@1080
|
381 NONE => default ()
|
adamc@488
|
382 | SOME (f, xs) =>
|
adamc@485
|
383 case IM.find (#funcs st, f) of
|
adamc@1272
|
384 NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ())
|
adam@1675
|
385 | SOME {name, args, body, typ, tag, constArgs} =>
|
adamc@488
|
386 let
|
adamc@1080
|
387 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
|
adamc@1080
|
388
|
adam@1861
|
389 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty e)]*)
|
adamc@721
|
390
|
adamc@488
|
391 val loc = ErrorMsg.dummySpan
|
adamc@488
|
392
|
adam@1677
|
393 val oldXs = xs
|
adam@1677
|
394
|
adam@1861
|
395 fun findSplit av (initialPart, constArgs, xs, typ, fxs, fvs) =
|
adam@1861
|
396 let
|
adam@1861
|
397 fun default () =
|
adam@1861
|
398 if initialPart then
|
adam@1861
|
399 ([], oldXs, IS.empty)
|
adam@1677
|
400 else
|
adam@1861
|
401 (rev fxs, xs, fvs)
|
adam@1861
|
402 in
|
adam@1861
|
403 case (#1 typ, xs) of
|
adam@1861
|
404 (TFun (dom, ran), e :: xs') =>
|
adam@1861
|
405 if constArgs > 0 then
|
adam@1861
|
406 let
|
adam@1863
|
407 val fi = functionInside known dom
|
adam@1861
|
408 in
|
adam@1861
|
409 if initialPart orelse fi then
|
adam@1861
|
410 findSplit av (not fi andalso initialPart,
|
adam@1861
|
411 constArgs - 1,
|
adam@1861
|
412 xs',
|
adam@1861
|
413 ran,
|
adam@1861
|
414 e :: fxs,
|
adam@1861
|
415 IS.union (fvs, freeVars e))
|
adam@1861
|
416 else
|
adam@1861
|
417 default ()
|
adam@1861
|
418 end
|
adam@1861
|
419 else
|
adam@1861
|
420 default ()
|
adam@1861
|
421 | _ => default ()
|
adam@1861
|
422 end
|
adamc@488
|
423
|
adam@1861
|
424 val (fxs, xs, fvs) = findSplit true (true, constArgs, xs, typ, [], IS.empty)
|
adam@1355
|
425
|
adam@1314
|
426 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
|
adamc@1079
|
427 val fxs' = map (squish (IS.listItems fvs)) fxs
|
adam@1362
|
428
|
adam@1362
|
429 val p_bool = Print.PD.string o Bool.toString
|
adamc@488
|
430 in
|
adam@1355
|
431 (*Print.prefaces "Func" [("name", Print.PD.string name),
|
adam@1355
|
432 ("e", CorePrint.p_exp CoreEnv.empty e),
|
adam@1355
|
433 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
|
adam@1675
|
434 if List.all (fn (ERel _, _) => true
|
adam@1675
|
435 | _ => false) fxs' then
|
adam@1675
|
436 default ()
|
adamc@488
|
437 else
|
adam@1667
|
438 case KM.find (args, (vts, fxs')) of
|
adam@1667
|
439 SOME f' =>
|
adamc@485
|
440 let
|
adamc@488
|
441 val e = (ENamed f', loc)
|
adamc@488
|
442 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
|
adamc@488
|
443 e fvs
|
adamc@1079
|
444 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
|
adamc@488
|
445 e xs
|
adamc@488
|
446 in
|
adamc@488
|
447 (*Print.prefaces "Brand new (reuse)"
|
adamc@721
|
448 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
|
adamc@1080
|
449 (e, st)
|
adamc@488
|
450 end
|
adam@1667
|
451 | NONE =>
|
adamc@488
|
452 let
|
adamc@800
|
453 (*val () = Print.prefaces "New one"
|
adam@1667
|
454 [("name", Print.PD.string name),
|
adam@1667
|
455 ("f", Print.PD.string (Int.toString f)),
|
adam@1667
|
456 ("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))),
|
adam@1667
|
457 ("|fxs|", Print.PD.string (Int.toString (length fxs))),
|
adam@1766
|
458 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs'),
|
adam@1667
|
459 ("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*)
|
adamc@800
|
460
|
adamc@818
|
461 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
|
adamc@818
|
462 [("fxs'",
|
adamc@818
|
463 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
|
adamc@818
|
464
|
adam@1675
|
465 (*val () = Print.prefaces name
|
adam@1675
|
466 [("Available", Print.PD.string (Int.toString constArgs)),
|
adam@1675
|
467 ("Used", Print.PD.string (Int.toString (length fxs'))),
|
adam@1675
|
468 ("fxs'",
|
adam@1675
|
469 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
|
adam@1675
|
470
|
adamc@1079
|
471 fun subBody (body, typ, fxs') =
|
adamc@1079
|
472 case (#1 body, #1 typ, fxs') of
|
adamc@488
|
473 (_, _, []) => SOME (body, typ)
|
adamc@1079
|
474 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
|
adamc@488
|
475 let
|
adamc@1079
|
476 val body'' = E.subExpInExp (0, x) body'
|
adamc@488
|
477 in
|
adamc@488
|
478 subBody (body'',
|
adamc@488
|
479 typ',
|
adamc@1079
|
480 fxs'')
|
adamc@488
|
481 end
|
adamc@488
|
482 | _ => NONE
|
adamc@488
|
483 in
|
adamc@1079
|
484 case subBody (body, typ, fxs') of
|
adamc@1080
|
485 NONE => default ()
|
adamc@488
|
486 | SOME (body', typ') =>
|
adamc@488
|
487 let
|
adamc@488
|
488 val f' = #maxName st
|
adam@1314
|
489 val args = KM.insert (args, (vts, fxs'), f')
|
adamc@488
|
490 val funcs = IM.insert (#funcs st, f, {name = name,
|
adamc@488
|
491 args = args,
|
adamc@488
|
492 body = body,
|
adamc@488
|
493 typ = typ,
|
adam@1675
|
494 tag = tag,
|
adam@1766
|
495 constArgs = calcConstArgs (IS.singleton f) body})
|
adamc@1079
|
496
|
adamc@488
|
497 val st = {
|
adamc@488
|
498 maxName = f' + 1,
|
adamc@488
|
499 funcs = funcs,
|
adamc@1079
|
500 decls = #decls st,
|
adamc@1080
|
501 specialized = IS.add (#specialized st, f')
|
adamc@488
|
502 }
|
adamc@487
|
503
|
adamc@488
|
504 (*val () = Print.prefaces "specExp"
|
adamc@488
|
505 [("f", CorePrint.p_exp env (ENamed f, loc)),
|
adamc@488
|
506 ("f'", CorePrint.p_exp env (ENamed f', loc)),
|
adamc@488
|
507 ("xs", Print.p_list (CorePrint.p_exp env) xs),
|
adamc@488
|
508 ("fxs'", Print.p_list
|
adamc@488
|
509 (CorePrint.p_exp E.empty) fxs'),
|
adamc@488
|
510 ("e", CorePrint.p_exp env (e, loc))]*)
|
adamc@488
|
511 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
|
adamc@488
|
512 let
|
adamc@521
|
513 val (x, xt) = List.nth (env, n)
|
adamc@488
|
514 in
|
adamc@488
|
515 ((EAbs (x, xt, typ', body'),
|
adamc@488
|
516 loc),
|
adamc@488
|
517 (TFun (xt, typ'), loc))
|
adamc@488
|
518 end)
|
adamc@488
|
519 (body', typ') fvs
|
adam@1861
|
520 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n")*)
|
adamc@1272
|
521 val body' = ReduceLocal.reduceExp body'
|
adamc@1080
|
522 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
|
adamc@1080
|
523 val (body', st) = exp (env, body', st)
|
adamc@482
|
524
|
adamc@488
|
525 val e' = (ENamed f', loc)
|
adamc@488
|
526 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
|
adamc@488
|
527 e' fvs
|
adamc@1079
|
528 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
|
adamc@488
|
529 e' xs
|
adam@1362
|
530
|
adamc@488
|
531 (*val () = Print.prefaces "Brand new"
|
adamc@721
|
532 [("e'", CorePrint.p_exp CoreEnv.empty e'),
|
adamc@1080
|
533 ("e", CorePrint.p_exp CoreEnv.empty e),
|
adamc@721
|
534 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
|
adamc@488
|
535 in
|
adamc@1080
|
536 (e',
|
adamc@488
|
537 {maxName = #maxName st,
|
adamc@488
|
538 funcs = #funcs st,
|
adamc@1079
|
539 decls = (name, f', typ', body', tag) :: #decls st,
|
adamc@1079
|
540 specialized = #specialized st})
|
adamc@488
|
541 end
|
adamc@485
|
542 end
|
adamc@488
|
543 end
|
adamc@485
|
544 end
|
adamc@482
|
545
|
adamc@521
|
546 fun doDecl (d, (st : state, changed)) =
|
adamc@488
|
547 let
|
adamc@521
|
548 (*val befor = Time.now ()*)
|
adamc@482
|
549
|
adamc@453
|
550 val funcs = #funcs st
|
adamc@453
|
551 val funcs =
|
adamc@453
|
552 case #1 d of
|
adamc@453
|
553 DValRec vis =>
|
adam@1766
|
554 let
|
adam@1766
|
555 val fs = foldl (fn ((_, n, _, _, _), fs) => IS.add (fs, n)) IS.empty vis
|
adam@1766
|
556 val constArgs = foldl (fn ((_, _, _, e, _), constArgs) =>
|
adam@1766
|
557 Int.min (constArgs, calcConstArgs fs e))
|
adam@1766
|
558 maxInt vis
|
adam@1766
|
559 in
|
adam@1861
|
560 (*Print.prefaces "ConstArgs" [("d", CorePrint.p_decl CoreEnv.empty d),
|
adam@1861
|
561 ("ca", Print.PD.string (Int.toString constArgs))];*)
|
adam@1766
|
562 foldl (fn ((x, n, c, e, tag), funcs) =>
|
adam@1766
|
563 IM.insert (funcs, n, {name = x,
|
adam@1766
|
564 args = KM.empty,
|
adam@1766
|
565 body = e,
|
adam@1766
|
566 typ = c,
|
adam@1766
|
567 tag = tag,
|
adam@1766
|
568 constArgs = constArgs}))
|
adam@1766
|
569 funcs vis
|
adam@1766
|
570 end
|
adamc@453
|
571 | _ => funcs
|
adamc@453
|
572
|
adamc@453
|
573 val st = {maxName = #maxName st,
|
adamc@453
|
574 funcs = funcs,
|
adamc@1079
|
575 decls = [],
|
adamc@1079
|
576 specialized = #specialized st}
|
adamc@453
|
577
|
adamc@482
|
578 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
|
adamc@521
|
579
|
adamc@522
|
580 val (d', st) =
|
adamc@522
|
581 if isPoly d then
|
adamc@522
|
582 (d, st)
|
adamc@522
|
583 else
|
adamc@1080
|
584 case #1 d of
|
adamc@1080
|
585 DVal (x, n, t, e, s) =>
|
adamc@1080
|
586 let
|
adam@1362
|
587 (*val () = Print.preface ("Visiting", Print.box [Print.PD.string (x ^ "__" ^ Int.toString n),
|
adam@1362
|
588 Print.space,
|
adam@1362
|
589 Print.PD.string ":",
|
adam@1362
|
590 Print.space,
|
adam@1362
|
591 CorePrint.p_con CoreEnv.empty t])*)
|
adam@1362
|
592
|
adamc@1080
|
593 val (e, st) = exp ([], e, st)
|
adamc@1080
|
594 in
|
adamc@1080
|
595 ((DVal (x, n, t, e, s), #2 d), st)
|
adamc@1080
|
596 end
|
adamc@1080
|
597 | DValRec vis =>
|
adamc@1080
|
598 let
|
adamc@1120
|
599 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
|
adam@1362
|
600 Print.box [Print.PD.string (#1 vi ^ "__"
|
adam@1362
|
601 ^ Int.toString
|
adam@1362
|
602 (#2 vi)),
|
adam@1362
|
603 Print.space,
|
adam@1362
|
604 Print.PD.string ":",
|
adam@1362
|
605 Print.space,
|
adam@1362
|
606 CorePrint.p_con CoreEnv.empty (#3 vi)])
|
adamc@1120
|
607 vis)*)
|
adamc@1120
|
608
|
adamc@1080
|
609 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
|
adamc@1080
|
610 let
|
adamc@1080
|
611 val (e, st) = exp ([], e, st)
|
adamc@1080
|
612 in
|
adamc@1080
|
613 ((x, n, t, e, s), st)
|
adamc@1080
|
614 end) st vis
|
adamc@1080
|
615 in
|
adamc@1080
|
616 ((DValRec vis, #2 d), st)
|
adamc@1080
|
617 end
|
adamc@1080
|
618 | DTable (s, n, t, s1, e1, t1, e2, t2) =>
|
adamc@1080
|
619 let
|
adamc@1080
|
620 val (e1, st) = exp ([], e1, st)
|
adamc@1080
|
621 val (e2, st) = exp ([], e2, st)
|
adamc@1080
|
622 in
|
adamc@1080
|
623 ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
|
adamc@1080
|
624 end
|
adamc@1080
|
625 | DView (x, n, s, e, t) =>
|
adamc@1080
|
626 let
|
adamc@1080
|
627 val (e, st) = exp ([], e, st)
|
adamc@1080
|
628 in
|
adamc@1080
|
629 ((DView (x, n, s, e, t), #2 d), st)
|
adamc@1080
|
630 end
|
adamc@1080
|
631 | DTask (e1, e2) =>
|
adamc@1080
|
632 let
|
adamc@1080
|
633 val (e1, st) = exp ([], e1, st)
|
adamc@1080
|
634 val (e2, st) = exp ([], e2, st)
|
adamc@1080
|
635 in
|
adamc@1080
|
636 ((DTask (e1, e2), #2 d), st)
|
adamc@1080
|
637 end
|
adamc@1080
|
638 | _ => (d, st)
|
adamc@1080
|
639
|
adamc@482
|
640 (*val () = print "/decl\n"*)
|
adamc@443
|
641
|
adamc@443
|
642 val funcs = #funcs st
|
adamc@443
|
643 val funcs =
|
adamc@443
|
644 case #1 d of
|
adamc@443
|
645 DVal (x, n, c, e as (EAbs _, _), tag) =>
|
adam@1861
|
646 ((*Print.prefaces "ConstArgs[2]" [("d", CorePrint.p_decl CoreEnv.empty d),
|
adam@1861
|
647 ("ca", Print.PD.string (Int.toString (calcConstArgs (IS.singleton n) e)))];*)
|
adamc@443
|
648 IM.insert (funcs, n, {name = x,
|
adamc@453
|
649 args = KM.empty,
|
adamc@443
|
650 body = e,
|
adamc@443
|
651 typ = c,
|
adam@1675
|
652 tag = tag,
|
adam@1861
|
653 constArgs = calcConstArgs (IS.singleton n) e}))
|
adamc@469
|
654 | DVal (_, n, _, (ENamed n', _), _) =>
|
adamc@469
|
655 (case IM.find (funcs, n') of
|
adamc@469
|
656 NONE => funcs
|
adamc@469
|
657 | SOME v => IM.insert (funcs, n, v))
|
adamc@443
|
658 | _ => funcs
|
adamc@443
|
659
|
adamc@453
|
660 val (changed, ds) =
|
adamc@443
|
661 case #decls st of
|
adamc@453
|
662 [] => (changed, [d'])
|
adamc@453
|
663 | vis =>
|
adamc@453
|
664 (true, case d' of
|
adamc@453
|
665 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
|
adamc@453
|
666 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
|
adamc@443
|
667 in
|
adamc@802
|
668 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
|
adamc@802
|
669 ("d'", CorePrint.p_decl E.empty d')];*)
|
adamc@521
|
670 (ds, ({maxName = #maxName st,
|
adamc@453
|
671 funcs = funcs,
|
adamc@1079
|
672 decls = [],
|
adamc@1079
|
673 specialized = #specialized st}, changed))
|
adamc@443
|
674 end
|
adamc@443
|
675
|
adamc@1120
|
676 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
|
adamc@1079
|
677 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
|
adamc@521
|
678 ({maxName = U.File.maxName file + 1,
|
adamc@1080
|
679 funcs = funcs,
|
adamc@1079
|
680 decls = [],
|
adamc@1079
|
681 specialized = specialized},
|
adamc@488
|
682 false)
|
adamc@488
|
683 file
|
adamc@443
|
684 in
|
adamc@1120
|
685 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
|
adamc@1080
|
686 (changed, ds, #funcs st, #specialized st)
|
adamc@443
|
687 end
|
adamc@443
|
688
|
adamc@1080
|
689 fun specializeL (funcs, specialized) file =
|
adamc@453
|
690 let
|
adamc@721
|
691 val file = ReduceLocal.reduce file
|
adamc@520
|
692 (*val file = ReduceLocal.reduce file*)
|
adamc@1080
|
693 val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
|
adamc@520
|
694 (*val file = ReduceLocal.reduce file
|
adamc@520
|
695 val file = CoreUntangle.untangle file
|
adamc@488
|
696 val file = Shake.shake file*)
|
adamc@453
|
697 in
|
adamc@488
|
698 (*print "Round over\n";*)
|
adamc@453
|
699 if changed then
|
adamc@520
|
700 let
|
adamc@721
|
701 (*val file = ReduceLocal.reduce file*)
|
adamc@802
|
702 (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
|
adamc@520
|
703 val file = CoreUntangle.untangle file
|
adamc@802
|
704 (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
|
adamc@520
|
705 val file = Shake.shake file
|
adamc@520
|
706 in
|
adamc@520
|
707 (*print "Again!\n";*)
|
adamc@1080
|
708 (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
|
adamc@1080
|
709 specializeL (funcs, specialized) file
|
adamc@520
|
710 end
|
adamc@453
|
711 else
|
adamc@453
|
712 file
|
adamc@453
|
713 end
|
adamc@453
|
714
|
adamc@1080
|
715 val specialize = specializeL (IM.empty, IS.empty)
|
adamc@1079
|
716
|
adamc@443
|
717 end
|