adamc@1180
|
1 (* Copyright (c) 2008-2010, 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
|
adamc@479
|
38 type ord_key = exp list
|
adamc@479
|
39 val compare = Order.joinL U.Exp.compare
|
adamc@443
|
40 end
|
adamc@443
|
41
|
adamc@453
|
42 structure KM = BinaryMapFn(K)
|
adamc@443
|
43 structure IM = IntBinaryMap
|
adamc@482
|
44 structure IS = IntBinarySet
|
adamc@443
|
45
|
adamc@626
|
46 val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs,
|
adamc@488
|
47 con = fn (_, _, xs) => xs,
|
adamc@488
|
48 exp = fn (bound, e, xs) =>
|
adamc@488
|
49 case e of
|
adamc@488
|
50 ERel x =>
|
adamc@488
|
51 if x >= bound then
|
adamc@488
|
52 IS.add (xs, x - bound)
|
adamc@488
|
53 else
|
adamc@488
|
54 xs
|
adamc@488
|
55 | _ => xs,
|
adamc@488
|
56 bind = fn (bound, b) =>
|
adamc@488
|
57 case b of
|
adamc@488
|
58 U.Exp.RelE _ => bound + 1
|
adamc@488
|
59 | _ => bound}
|
adamc@488
|
60 0 IS.empty
|
adamc@479
|
61
|
adamc@1120
|
62 fun isPolyT (t, _) =
|
adamc@1120
|
63 case t of
|
adamc@1120
|
64 TFun (_, ran) => isPolyT ran
|
adamc@1120
|
65 | TCFun _ => true
|
adamc@1120
|
66 | TKFun _ => true
|
adamc@1120
|
67 | _ => false
|
adamc@1120
|
68
|
adamc@1120
|
69 fun isPoly (d, _) =
|
adamc@1120
|
70 case d of
|
adamc@1120
|
71 DVal (_, _, t, _, _) => isPolyT t
|
adamc@1120
|
72 | DValRec vis => List.exists (isPolyT o #3) vis
|
adamc@1120
|
73 | _ => false
|
adamc@522
|
74
|
adamc@488
|
75 fun positionOf (v : int, ls) =
|
adamc@488
|
76 let
|
adamc@488
|
77 fun pof (pos, ls) =
|
adamc@488
|
78 case ls of
|
adamc@488
|
79 [] => raise Fail "Defunc.positionOf"
|
adamc@488
|
80 | v' :: ls' =>
|
adamc@488
|
81 if v = v' then
|
adamc@488
|
82 pos
|
adamc@488
|
83 else
|
adamc@488
|
84 pof (pos + 1, ls')
|
adamc@488
|
85 in
|
adamc@488
|
86 pof (0, ls)
|
adamc@488
|
87 end
|
adamc@488
|
88
|
adamc@1079
|
89 fun squish fvs =
|
adamc@626
|
90 U.Exp.mapB {kind = fn _ => fn k => k,
|
adamc@488
|
91 con = fn _ => fn c => c,
|
adamc@488
|
92 exp = fn bound => fn e =>
|
adamc@479
|
93 case e of
|
adamc@488
|
94 ERel x =>
|
adamc@488
|
95 if x >= bound then
|
adamc@1079
|
96 ERel (positionOf (x - bound, fvs) + bound)
|
adamc@488
|
97 else
|
adamc@488
|
98 e
|
adamc@488
|
99 | _ => e,
|
adamc@488
|
100 bind = fn (bound, b) =>
|
adamc@488
|
101 case b of
|
adamc@488
|
102 U.Exp.RelE _ => bound + 1
|
adamc@488
|
103 | _ => bound}
|
adamc@488
|
104 0
|
adamc@453
|
105
|
adamc@443
|
106 type func = {
|
adamc@443
|
107 name : string,
|
adamc@453
|
108 args : int KM.map,
|
adamc@443
|
109 body : exp,
|
adamc@443
|
110 typ : con,
|
adamc@443
|
111 tag : string
|
adamc@443
|
112 }
|
adamc@443
|
113
|
adamc@443
|
114 type state = {
|
adamc@443
|
115 maxName : int,
|
adamc@443
|
116 funcs : func IM.map,
|
adamc@1079
|
117 decls : (string * int * con * exp * string) list,
|
adamc@1080
|
118 specialized : IS.set
|
adamc@443
|
119 }
|
adamc@443
|
120
|
adamc@488
|
121 fun default (_, x, st) = (x, st)
|
adamc@443
|
122
|
adamc@800
|
123 structure SS = BinarySetFn(struct
|
adamc@800
|
124 type ord_key = string
|
adamc@800
|
125 val compare = String.compare
|
adamc@800
|
126 end)
|
adamc@800
|
127
|
adamc@800
|
128 val mayNotSpec = ref SS.empty
|
adamc@800
|
129
|
adamc@1080
|
130 fun specialize' (funcs, specialized) file =
|
adamc@443
|
131 let
|
adamc@1180
|
132 fun functionInside functiony = U.Con.exists {kind = fn _ => false,
|
adamc@1180
|
133 con = fn TFun _ => true
|
adamc@1180
|
134 | CFfi ("Basis", "transaction") => true
|
adamc@1180
|
135 | CFfi ("Basis", "eq") => true
|
adamc@1180
|
136 | CFfi ("Basis", "num") => true
|
adamc@1180
|
137 | CFfi ("Basis", "ord") => true
|
adamc@1180
|
138 | CFfi ("Basis", "show") => true
|
adamc@1180
|
139 | CFfi ("Basis", "read") => true
|
adamc@1180
|
140 | CFfi ("Basis", "sql_injectable_prim") => true
|
adamc@1180
|
141 | CFfi ("Basis", "sql_injectable") => true
|
adamc@1180
|
142 | CNamed n => IS.member (functiony, n)
|
adamc@1180
|
143 | _ => false}
|
adamc@1180
|
144
|
adamc@1180
|
145 val functiony = foldl (fn ((d, _), functiony) =>
|
adamc@1180
|
146 case d of
|
adamc@1180
|
147 DCon (_, n, _, c) =>
|
adamc@1180
|
148 if functionInside functiony c then
|
adamc@1180
|
149 IS.add (functiony, n)
|
adamc@1180
|
150 else
|
adamc@1180
|
151 functiony
|
adamc@1180
|
152 | DDatatype dts =>
|
adamc@1180
|
153 if List.exists (fn (_, _, _, cs) =>
|
adamc@1180
|
154 List.exists (fn (_, _, SOME c) => functionInside functiony c
|
adamc@1180
|
155 | _ => false) cs) dts then
|
adamc@1180
|
156 IS.addList (functiony, map #2 dts)
|
adamc@1180
|
157 else
|
adamc@1180
|
158 functiony
|
adamc@1180
|
159 | _ => functiony) IS.empty file
|
adamc@1180
|
160
|
adamc@1180
|
161 val functionInside = functionInside functiony
|
adamc@1180
|
162
|
adamc@488
|
163 fun bind (env, b) =
|
adamc@488
|
164 case b of
|
adamc@521
|
165 U.Decl.RelE xt => xt :: env
|
adamc@521
|
166 | _ => env
|
adamc@488
|
167
|
adamc@1080
|
168 fun exp (env, e as (_, loc), st : state) =
|
adamc@482
|
169 let
|
adamc@721
|
170 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty
|
adamc@721
|
171 (e, ErrorMsg.dummySpan))]*)
|
adamc@721
|
172
|
adamc@1080
|
173 fun getApp (e, _) =
|
adamc@482
|
174 case e of
|
adamc@488
|
175 ENamed f => SOME (f, [])
|
adamc@482
|
176 | EApp (e1, e2) =>
|
adamc@1080
|
177 (case getApp e1 of
|
adamc@482
|
178 NONE => NONE
|
adamc@488
|
179 | SOME (f, xs) => SOME (f, xs @ [e2]))
|
adamc@482
|
180 | _ => NONE
|
adamc@1080
|
181
|
adamc@1080
|
182 val getApp = fn e => case getApp e of
|
adamc@1080
|
183 v as SOME (_, _ :: _) => v
|
adamc@1080
|
184 | _ => NONE
|
adamc@1080
|
185
|
adamc@1080
|
186 fun default () =
|
adamc@1080
|
187 case #1 e of
|
adamc@1080
|
188 EPrim _ => (e, st)
|
adamc@1080
|
189 | ERel _ => (e, st)
|
adamc@1080
|
190 | ENamed _ => (e, st)
|
adamc@1080
|
191 | ECon (_, _, _, NONE) => (e, st)
|
adamc@1080
|
192 | ECon (dk, pc, cs, SOME e) =>
|
adamc@1080
|
193 let
|
adamc@1080
|
194 val (e, st) = exp (env, e, st)
|
adamc@1080
|
195 in
|
adamc@1080
|
196 ((ECon (dk, pc, cs, SOME e), loc), st)
|
adamc@1080
|
197 end
|
adamc@1080
|
198 | EFfi _ => (e, st)
|
adamc@1080
|
199 | EFfiApp (m, x, es) =>
|
adamc@1080
|
200 let
|
adamc@1080
|
201 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
|
adamc@1080
|
202 in
|
adamc@1080
|
203 ((EFfiApp (m, x, es), loc), st)
|
adamc@1080
|
204 end
|
adamc@1080
|
205 | EApp (e1, e2) =>
|
adamc@1080
|
206 let
|
adamc@1080
|
207 val (e1, st) = exp (env, e1, st)
|
adamc@1080
|
208 val (e2, st) = exp (env, e2, st)
|
adamc@1080
|
209 in
|
adamc@1080
|
210 ((EApp (e1, e2), loc), st)
|
adamc@1080
|
211 end
|
adamc@1080
|
212 | EAbs (x, d, r, e) =>
|
adamc@1080
|
213 let
|
adamc@1080
|
214 val (e, st) = exp ((x, d) :: env, e, st)
|
adamc@1080
|
215 in
|
adamc@1080
|
216 ((EAbs (x, d, r, e), loc), st)
|
adamc@1080
|
217 end
|
adamc@1080
|
218 | ECApp (e, c) =>
|
adamc@1080
|
219 let
|
adamc@1080
|
220 val (e, st) = exp (env, e, st)
|
adamc@1080
|
221 in
|
adamc@1080
|
222 ((ECApp (e, c), loc), st)
|
adamc@1080
|
223 end
|
adamc@1120
|
224 | ECAbs _ => (e, st)
|
adamc@1120
|
225 | EKAbs _ => (e, st)
|
adamc@1080
|
226 | EKApp (e, k) =>
|
adamc@1080
|
227 let
|
adamc@1080
|
228 val (e, st) = exp (env, e, st)
|
adamc@1080
|
229 in
|
adamc@1080
|
230 ((EKApp (e, k), loc), st)
|
adamc@1080
|
231 end
|
adamc@1080
|
232 | ERecord fs =>
|
adamc@1080
|
233 let
|
adamc@1080
|
234 val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) =>
|
adamc@1080
|
235 let
|
adamc@1080
|
236 val (e, st) = exp (env, e, st)
|
adamc@1080
|
237 in
|
adamc@1080
|
238 ((c1, e, c2), st)
|
adamc@1080
|
239 end) st fs
|
adamc@1080
|
240 in
|
adamc@1080
|
241 ((ERecord fs, loc), st)
|
adamc@1080
|
242 end
|
adamc@1080
|
243 | EField (e, c, cs) =>
|
adamc@1080
|
244 let
|
adamc@1080
|
245 val (e, st) = exp (env, e, st)
|
adamc@1080
|
246 in
|
adamc@1080
|
247 ((EField (e, c, cs), loc), st)
|
adamc@1080
|
248 end
|
adamc@1080
|
249 | EConcat (e1, c1, e2, c2) =>
|
adamc@1080
|
250 let
|
adamc@1080
|
251 val (e1, st) = exp (env, e1, st)
|
adamc@1080
|
252 val (e2, st) = exp (env, e2, st)
|
adamc@1080
|
253 in
|
adamc@1080
|
254 ((EConcat (e1, c1, e2, c2), loc), st)
|
adamc@1080
|
255 end
|
adamc@1080
|
256 | ECut (e, c, cs) =>
|
adamc@1080
|
257 let
|
adamc@1080
|
258 val (e, st) = exp (env, e, st)
|
adamc@1080
|
259 in
|
adamc@1080
|
260 ((ECut (e, c, cs), loc), st)
|
adamc@1080
|
261 end
|
adamc@1080
|
262 | ECutMulti (e, c, cs) =>
|
adamc@1080
|
263 let
|
adamc@1080
|
264 val (e, st) = exp (env, e, st)
|
adamc@1080
|
265 in
|
adamc@1080
|
266 ((ECutMulti (e, c, cs), loc), st)
|
adamc@1080
|
267 end
|
adamc@1080
|
268
|
adamc@1080
|
269 | ECase (e, pes, cs) =>
|
adamc@1080
|
270 let
|
adamc@1080
|
271 val (e, st) = exp (env, e, st)
|
adamc@1080
|
272 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
|
adamc@1080
|
273 let
|
adamc@1080
|
274 val (e, st) = exp (E.patBindsL p @ env, e, st)
|
adamc@1080
|
275 in
|
adamc@1080
|
276 ((p, e), st)
|
adamc@1080
|
277 end) st pes
|
adamc@1080
|
278 in
|
adamc@1080
|
279 ((ECase (e, pes, cs), loc), st)
|
adamc@1080
|
280 end
|
adamc@1080
|
281
|
adamc@1080
|
282 | EWrite e =>
|
adamc@1080
|
283 let
|
adamc@1080
|
284 val (e, st) = exp (env, e, st)
|
adamc@1080
|
285 in
|
adamc@1080
|
286 ((EWrite e, loc), st)
|
adamc@1080
|
287 end
|
adamc@1080
|
288 | EClosure (n, es) =>
|
adamc@1080
|
289 let
|
adamc@1080
|
290 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
|
adamc@1080
|
291 in
|
adamc@1080
|
292 ((EClosure (n, es), loc), st)
|
adamc@1080
|
293 end
|
adamc@1080
|
294 | ELet (x, t, e1, e2) =>
|
adamc@1080
|
295 let
|
adamc@1080
|
296 val (e1, st) = exp (env, e1, st)
|
adamc@1080
|
297 val (e2, st) = exp ((x, t) :: env, e2, st)
|
adamc@1080
|
298 in
|
adamc@1080
|
299 ((ELet (x, t, e1, e2), loc), st)
|
adamc@1080
|
300 end
|
adamc@1080
|
301 | EServerCall (n, es, t) =>
|
adamc@1080
|
302 let
|
adamc@1080
|
303 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
|
adamc@1080
|
304 in
|
adamc@1080
|
305 ((EServerCall (n, es, t), loc), st)
|
adamc@1080
|
306 end
|
adamc@482
|
307 in
|
adamc@482
|
308 case getApp e of
|
adamc@1080
|
309 NONE => default ()
|
adamc@488
|
310 | SOME (f, xs) =>
|
adamc@485
|
311 case IM.find (#funcs st, f) of
|
adamc@1080
|
312 NONE => default ()
|
adamc@485
|
313 | SOME {name, args, body, typ, tag} =>
|
adamc@488
|
314 let
|
adamc@1080
|
315 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
|
adamc@1080
|
316
|
adamc@721
|
317 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
|
adamc@721
|
318 (e, ErrorMsg.dummySpan))]*)
|
adamc@721
|
319
|
adamc@1180
|
320
|
adamc@488
|
321 val loc = ErrorMsg.dummySpan
|
adamc@488
|
322
|
adamc@1080
|
323 fun findSplit av (xs, typ, fxs, fvs, fin) =
|
adamc@488
|
324 case (#1 typ, xs) of
|
adamc@488
|
325 (TFun (dom, ran), e :: xs') =>
|
adamc@1078
|
326 let
|
adamc@1079
|
327 val av = case #1 e of
|
adamc@1079
|
328 ERel _ => av
|
adamc@1079
|
329 | _ => false
|
adamc@1078
|
330 in
|
adamc@1079
|
331 if functionInside dom orelse (av andalso case #1 e of
|
adamc@1079
|
332 ERel _ => true
|
adamc@1079
|
333 | _ => false) then
|
adamc@1079
|
334 findSplit av (xs',
|
adamc@1079
|
335 ran,
|
adamc@1079
|
336 e :: fxs,
|
adamc@1080
|
337 IS.union (fvs, freeVars e),
|
adamc@1080
|
338 fin orelse functionInside dom)
|
adamc@1078
|
339 else
|
adamc@1080
|
340 (rev fxs, xs, fvs, fin)
|
adamc@1078
|
341 end
|
adamc@1080
|
342 | _ => (rev fxs, xs, fvs, fin)
|
adamc@488
|
343
|
adamc@1080
|
344 val (fxs, xs, fvs, fin) = findSplit true (xs, typ, [], IS.empty, false)
|
adamc@1079
|
345
|
adamc@1079
|
346 val fxs' = map (squish (IS.listItems fvs)) fxs
|
adamc@488
|
347 in
|
adamc@800
|
348 (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
|
adamc@1080
|
349 if not fin
|
adamc@1080
|
350 orelse List.all (fn (ERel _, _) => true
|
adamc@1080
|
351 | _ => false) fxs'
|
adamc@1079
|
352 orelse (IS.numItems fvs >= length fxs
|
adamc@1079
|
353 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
|
adamc@1083
|
354 ((*Print.prefaces "No" [("name", Print.PD.string name),
|
adamc@1120
|
355 ("f", Print.PD.string (Int.toString f)),
|
adamc@1180
|
356 ("xs",
|
adamc@1180
|
357 Print.p_list (CorePrint.p_exp CoreEnv.empty) xs),
|
adamc@1083
|
358 ("fxs'",
|
adamc@1083
|
359 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
|
adamc@1083
|
360 default ())
|
adamc@488
|
361 else
|
adamc@1079
|
362 case (KM.find (args, fxs'),
|
adamc@1083
|
363 SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of
|
adamc@800
|
364 (SOME f', _) =>
|
adamc@485
|
365 let
|
adamc@488
|
366 val e = (ENamed f', loc)
|
adamc@488
|
367 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
|
adamc@488
|
368 e fvs
|
adamc@1079
|
369 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
|
adamc@488
|
370 e xs
|
adamc@488
|
371 in
|
adamc@488
|
372 (*Print.prefaces "Brand new (reuse)"
|
adamc@721
|
373 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
|
adamc@1080
|
374 (e, st)
|
adamc@488
|
375 end
|
adamc@1083
|
376 | (_, true) => ((*Print.prefaces ("No!(" ^ name ^ ")")
|
adamc@818
|
377 [("fxs'",
|
adamc@818
|
378 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
|
adamc@1080
|
379 default ())
|
adamc@800
|
380 | (NONE, false) =>
|
adamc@488
|
381 let
|
adamc@800
|
382 (*val () = Print.prefaces "New one"
|
adamc@800
|
383 [("f", Print.PD.string (Int.toString f)),
|
adamc@800
|
384 ("mns", Print.p_list Print.PD.string
|
adamc@800
|
385 (SS.listItems (!mayNotSpec)))]*)
|
adamc@800
|
386
|
adamc@818
|
387 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
|
adamc@818
|
388 [("fxs'",
|
adamc@818
|
389 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
|
adamc@818
|
390
|
adamc@1079
|
391 fun subBody (body, typ, fxs') =
|
adamc@1079
|
392 case (#1 body, #1 typ, fxs') of
|
adamc@488
|
393 (_, _, []) => SOME (body, typ)
|
adamc@1079
|
394 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
|
adamc@488
|
395 let
|
adamc@1079
|
396 val body'' = E.subExpInExp (0, x) body'
|
adamc@488
|
397 in
|
adamc@488
|
398 subBody (body'',
|
adamc@488
|
399 typ',
|
adamc@1079
|
400 fxs'')
|
adamc@488
|
401 end
|
adamc@488
|
402 | _ => NONE
|
adamc@488
|
403 in
|
adamc@1079
|
404 case subBody (body, typ, fxs') of
|
adamc@1080
|
405 NONE => default ()
|
adamc@488
|
406 | SOME (body', typ') =>
|
adamc@488
|
407 let
|
adamc@488
|
408 val f' = #maxName st
|
adamc@488
|
409 val args = KM.insert (args, fxs', f')
|
adamc@488
|
410 val funcs = IM.insert (#funcs st, f, {name = name,
|
adamc@488
|
411 args = args,
|
adamc@488
|
412 body = body,
|
adamc@488
|
413 typ = typ,
|
adamc@488
|
414 tag = tag})
|
adamc@1079
|
415
|
adamc@488
|
416 val st = {
|
adamc@488
|
417 maxName = f' + 1,
|
adamc@488
|
418 funcs = funcs,
|
adamc@1079
|
419 decls = #decls st,
|
adamc@1080
|
420 specialized = IS.add (#specialized st, f')
|
adamc@488
|
421 }
|
adamc@487
|
422
|
adamc@488
|
423 (*val () = Print.prefaces "specExp"
|
adamc@488
|
424 [("f", CorePrint.p_exp env (ENamed f, loc)),
|
adamc@488
|
425 ("f'", CorePrint.p_exp env (ENamed f', loc)),
|
adamc@488
|
426 ("xs", Print.p_list (CorePrint.p_exp env) xs),
|
adamc@488
|
427 ("fxs'", Print.p_list
|
adamc@488
|
428 (CorePrint.p_exp E.empty) fxs'),
|
adamc@488
|
429 ("e", CorePrint.p_exp env (e, loc))]*)
|
adamc@488
|
430 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
|
adamc@488
|
431 let
|
adamc@521
|
432 val (x, xt) = List.nth (env, n)
|
adamc@488
|
433 in
|
adamc@488
|
434 ((EAbs (x, xt, typ', body'),
|
adamc@488
|
435 loc),
|
adamc@488
|
436 (TFun (xt, typ'), loc))
|
adamc@488
|
437 end)
|
adamc@488
|
438 (body', typ') fvs
|
adamc@800
|
439 val mns = !mayNotSpec
|
adamc@1080
|
440 (*val () = mayNotSpec := SS.add (mns, name)*)
|
adamc@1080
|
441 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
|
adamc@1080
|
442 val (body', st) = exp (env, body', st)
|
adamc@800
|
443 val () = mayNotSpec := mns
|
adamc@482
|
444
|
adamc@488
|
445 val e' = (ENamed f', loc)
|
adamc@488
|
446 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
|
adamc@488
|
447 e' fvs
|
adamc@1079
|
448 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
|
adamc@488
|
449 e' xs
|
adamc@1120
|
450 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
|
adamc@488
|
451 (*val () = Print.prefaces "Brand new"
|
adamc@721
|
452 [("e'", CorePrint.p_exp CoreEnv.empty e'),
|
adamc@1080
|
453 ("e", CorePrint.p_exp CoreEnv.empty e),
|
adamc@721
|
454 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
|
adamc@488
|
455 in
|
adamc@1080
|
456 (e',
|
adamc@488
|
457 {maxName = #maxName st,
|
adamc@488
|
458 funcs = #funcs st,
|
adamc@1079
|
459 decls = (name, f', typ', body', tag) :: #decls st,
|
adamc@1079
|
460 specialized = #specialized st})
|
adamc@488
|
461 end
|
adamc@485
|
462 end
|
adamc@488
|
463 end
|
adamc@485
|
464 end
|
adamc@482
|
465
|
adamc@521
|
466 fun doDecl (d, (st : state, changed)) =
|
adamc@488
|
467 let
|
adamc@521
|
468 (*val befor = Time.now ()*)
|
adamc@482
|
469
|
adamc@453
|
470 val funcs = #funcs st
|
adamc@453
|
471 val funcs =
|
adamc@453
|
472 case #1 d of
|
adamc@453
|
473 DValRec vis =>
|
adamc@453
|
474 foldl (fn ((x, n, c, e, tag), funcs) =>
|
adamc@453
|
475 IM.insert (funcs, n, {name = x,
|
adamc@453
|
476 args = KM.empty,
|
adamc@453
|
477 body = e,
|
adamc@453
|
478 typ = c,
|
adamc@453
|
479 tag = tag}))
|
adamc@453
|
480 funcs vis
|
adamc@453
|
481 | _ => funcs
|
adamc@453
|
482
|
adamc@453
|
483 val st = {maxName = #maxName st,
|
adamc@453
|
484 funcs = funcs,
|
adamc@1079
|
485 decls = [],
|
adamc@1079
|
486 specialized = #specialized st}
|
adamc@453
|
487
|
adamc@482
|
488 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
|
adamc@521
|
489
|
adamc@1080
|
490 val () = mayNotSpec := SS.empty
|
adamc@1080
|
491
|
adamc@522
|
492 val (d', st) =
|
adamc@522
|
493 if isPoly d then
|
adamc@522
|
494 (d, st)
|
adamc@522
|
495 else
|
adamc@1080
|
496 case #1 d of
|
adamc@1080
|
497 DVal (x, n, t, e, s) =>
|
adamc@1080
|
498 let
|
adamc@1080
|
499 val (e, st) = exp ([], e, st)
|
adamc@1080
|
500 in
|
adamc@1080
|
501 ((DVal (x, n, t, e, s), #2 d), st)
|
adamc@1080
|
502 end
|
adamc@1080
|
503 | DValRec vis =>
|
adamc@1080
|
504 let
|
adamc@1120
|
505 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
|
adamc@1120
|
506 Print.PD.string (#1 vi ^ "__"
|
adamc@1120
|
507 ^ Int.toString
|
adamc@1120
|
508 (#2 vi)))
|
adamc@1120
|
509 vis)*)
|
adamc@1120
|
510
|
adamc@1080
|
511 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
|
adamc@1080
|
512 let
|
adamc@1120
|
513 val () = mayNotSpec := SS.empty
|
adamc@1080
|
514 val (e, st) = exp ([], e, st)
|
adamc@1080
|
515 in
|
adamc@1080
|
516 ((x, n, t, e, s), st)
|
adamc@1080
|
517 end) st vis
|
adamc@1080
|
518 in
|
adamc@1080
|
519 ((DValRec vis, #2 d), st)
|
adamc@1080
|
520 end
|
adamc@1080
|
521 | DTable (s, n, t, s1, e1, t1, e2, t2) =>
|
adamc@1080
|
522 let
|
adamc@1080
|
523 val (e1, st) = exp ([], e1, st)
|
adamc@1080
|
524 val (e2, st) = exp ([], e2, st)
|
adamc@1080
|
525 in
|
adamc@1080
|
526 ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
|
adamc@1080
|
527 end
|
adamc@1080
|
528 | DView (x, n, s, e, t) =>
|
adamc@1080
|
529 let
|
adamc@1080
|
530 val (e, st) = exp ([], e, st)
|
adamc@1080
|
531 in
|
adamc@1080
|
532 ((DView (x, n, s, e, t), #2 d), st)
|
adamc@1080
|
533 end
|
adamc@1080
|
534 | DTask (e1, e2) =>
|
adamc@1080
|
535 let
|
adamc@1080
|
536 val (e1, st) = exp ([], e1, st)
|
adamc@1080
|
537 val (e2, st) = exp ([], e2, st)
|
adamc@1080
|
538 in
|
adamc@1080
|
539 ((DTask (e1, e2), #2 d), st)
|
adamc@1080
|
540 end
|
adamc@1080
|
541 | _ => (d, st)
|
adamc@1080
|
542
|
adamc@1080
|
543 val () = mayNotSpec := SS.empty
|
adamc@521
|
544
|
adamc@482
|
545 (*val () = print "/decl\n"*)
|
adamc@443
|
546
|
adamc@443
|
547 val funcs = #funcs st
|
adamc@443
|
548 val funcs =
|
adamc@443
|
549 case #1 d of
|
adamc@443
|
550 DVal (x, n, c, e as (EAbs _, _), tag) =>
|
adamc@443
|
551 IM.insert (funcs, n, {name = x,
|
adamc@453
|
552 args = KM.empty,
|
adamc@443
|
553 body = e,
|
adamc@443
|
554 typ = c,
|
adamc@443
|
555 tag = tag})
|
adamc@469
|
556 | DVal (_, n, _, (ENamed n', _), _) =>
|
adamc@469
|
557 (case IM.find (funcs, n') of
|
adamc@469
|
558 NONE => funcs
|
adamc@469
|
559 | SOME v => IM.insert (funcs, n, v))
|
adamc@443
|
560 | _ => funcs
|
adamc@443
|
561
|
adamc@453
|
562 val (changed, ds) =
|
adamc@443
|
563 case #decls st of
|
adamc@453
|
564 [] => (changed, [d'])
|
adamc@453
|
565 | vis =>
|
adamc@453
|
566 (true, case d' of
|
adamc@453
|
567 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
|
adamc@453
|
568 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
|
adamc@443
|
569 in
|
adamc@802
|
570 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
|
adamc@802
|
571 ("d'", CorePrint.p_decl E.empty d')];*)
|
adamc@521
|
572 (ds, ({maxName = #maxName st,
|
adamc@453
|
573 funcs = funcs,
|
adamc@1079
|
574 decls = [],
|
adamc@1079
|
575 specialized = #specialized st}, changed))
|
adamc@443
|
576 end
|
adamc@443
|
577
|
adamc@1120
|
578 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
|
adamc@1079
|
579 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
|
adamc@521
|
580 ({maxName = U.File.maxName file + 1,
|
adamc@1080
|
581 funcs = funcs,
|
adamc@1079
|
582 decls = [],
|
adamc@1079
|
583 specialized = specialized},
|
adamc@488
|
584 false)
|
adamc@488
|
585 file
|
adamc@443
|
586 in
|
adamc@1120
|
587 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
|
adamc@1080
|
588 (changed, ds, #funcs st, #specialized st)
|
adamc@443
|
589 end
|
adamc@443
|
590
|
adamc@1080
|
591 fun specializeL (funcs, specialized) file =
|
adamc@453
|
592 let
|
adamc@721
|
593 val file = ReduceLocal.reduce file
|
adamc@520
|
594 (*val file = ReduceLocal.reduce file*)
|
adamc@1080
|
595 val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
|
adamc@520
|
596 (*val file = ReduceLocal.reduce file
|
adamc@520
|
597 val file = CoreUntangle.untangle file
|
adamc@488
|
598 val file = Shake.shake file*)
|
adamc@453
|
599 in
|
adamc@488
|
600 (*print "Round over\n";*)
|
adamc@453
|
601 if changed then
|
adamc@520
|
602 let
|
adamc@721
|
603 (*val file = ReduceLocal.reduce file*)
|
adamc@802
|
604 (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
|
adamc@520
|
605 val file = CoreUntangle.untangle file
|
adamc@802
|
606 (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
|
adamc@520
|
607 val file = Shake.shake file
|
adamc@520
|
608 in
|
adamc@520
|
609 (*print "Again!\n";*)
|
adamc@1080
|
610 (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
|
adamc@1080
|
611 specializeL (funcs, specialized) file
|
adamc@520
|
612 end
|
adamc@453
|
613 else
|
adamc@453
|
614 file
|
adamc@453
|
615 end
|
adamc@453
|
616
|
adamc@1080
|
617 val specialize = specializeL (IM.empty, IS.empty)
|
adamc@1079
|
618
|
adamc@443
|
619 end
|