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