Mercurial > urweb

comparison src/especialize.sml @ 1677:3cfc79f92db7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
-dumpSource flag; Especialize tweak: may specialize any argument sequence ending in a value of function-containing type
author Adam Chlipala <adam@chlipala.net>
date Thu, 12 Jan 2012 20:37:39 -0500
parents 266814b15dd6
children 92cfc69419bd
comparison
equal deleted inserted replaced
1676:266814b15dd6 1677:3cfc79f92db7
1 (* Copyright (c) 2008-2011, Adam Chlipala 1 (* Copyright (c) 2008-2012, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
208 208
209 fun enterAbs depth e = 209 fun enterAbs depth e =
210 case #1 e of 210 case #1 e of
211 EAbs (_, _, _, e1) => enterAbs (depth + 1) e1 211 EAbs (_, _, _, e1) => enterAbs (depth + 1) e1
212 | _ => ca depth e 212 | _ => ca depth e
213
214 val n = enterAbs 0 e
215 in 213 in
216 if n = maxInt then 214 enterAbs 0 e
217 0
218 else
219 n
220 end 215 end
221 216
222 217
223 fun specialize' (funcs, specialized) file = 218 fun specialize' (funcs, specialized) file =
224 let 219 let
371 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty 366 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
372 (e, ErrorMsg.dummySpan))]*) 367 (e, ErrorMsg.dummySpan))]*)
373 368
374 val loc = ErrorMsg.dummySpan 369 val loc = ErrorMsg.dummySpan
375 370
371 val oldXs = xs
372
376 fun findSplit av (constArgs, xs, typ, fxs, fvs) = 373 fun findSplit av (constArgs, xs, typ, fxs, fvs) =
377 case (#1 typ, xs) of 374 case (#1 typ, xs) of
378 (TFun (dom, ran), e :: xs') => 375 (TFun (dom, ran), e :: xs') =>
379 if constArgs > 0 then 376 if constArgs > 0 then
380 findSplit av (constArgs - 1, 377 if functionInside dom then
381 xs', 378 (rev (e :: fxs), xs', IS.union (fvs, freeVars e))
382 ran, 379 else
383 e :: fxs, 380 findSplit av (constArgs - 1,
384 IS.union (fvs, freeVars e)) 381 xs',
382 ran,
383 e :: fxs,
384 IS.union (fvs, freeVars e))
385 else 385 else
386 (rev fxs, xs, fvs) 386 ([], oldXs, IS.empty)
387 | _ => (rev fxs, xs, fvs) 387 | _ => ([], oldXs, IS.empty)
388 388
389 val (fxs, xs, fvs) = findSplit true (constArgs, xs, typ, [], IS.empty) 389 val (fxs, xs, fvs) = findSplit true (constArgs, xs, typ, [], IS.empty)
390 390
391 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs) 391 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
392 val fxs' = map (squish (IS.listItems fvs)) fxs 392 val fxs' = map (squish (IS.listItems fvs)) fxs