Mercurial > urweb

comparison src/especialize.sml @ 1272:56bd4a4f6e66

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Some serious bug-fix work to get HTML example to compile; this includes fixing a bug with 'val' patterns in Unnest and the need for more local reduction in Especialize
author Adam Chlipala <adamc@hcoop.net>
date Thu, 03 Jun 2010 13:04:37 -0400
parents 338be96f8533
children 3b22c3c67f35
comparison
equal deleted inserted replaced
1271:503d4ec93494 1272:56bd4a4f6e66
1 (* Copyright (c) 2008-2009, Adam Chlipala 1 (* Copyright (c) 2008-2010, 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 *
276 in 276 in
277 case getApp e of 277 case getApp e of
278 NONE => default () 278 NONE => default ()
279 | SOME (f, xs) => 279 | SOME (f, xs) =>
280 case IM.find (#funcs st, f) of 280 case IM.find (#funcs st, f) of
281 NONE => default () 281 NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ())
282 | SOME {name, args, body, typ, tag} => 282 | SOME {name, args, body, typ, tag} =>
283 let 283 let
284 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs 284 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
285 285
286 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty 286 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
413 (TFun (xt, typ'), loc)) 413 (TFun (xt, typ'), loc))
414 end) 414 end)
415 (body', typ') fvs 415 (body', typ') fvs
416 val mns = !mayNotSpec 416 val mns = !mayNotSpec
417 (*val () = mayNotSpec := SS.add (mns, name)*) 417 (*val () = mayNotSpec := SS.add (mns, name)*)
418 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
419 val body' = ReduceLocal.reduceExp body'
418 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*) 420 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
419 val (body', st) = exp (env, body', st) 421 val (body', st) = exp (env, body', st)
420 val () = mayNotSpec := mns 422 val () = mayNotSpec := mns
421 423
422 val e' = (ENamed f', loc) 424 val e' = (ENamed f', loc)
423 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) 425 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
424 e' fvs 426 e' fvs
425 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) 427 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
426 e' xs 428 e' xs
427 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
428 (*val () = Print.prefaces "Brand new" 429 (*val () = Print.prefaces "Brand new"
429 [("e'", CorePrint.p_exp CoreEnv.empty e'), 430 [("e'", CorePrint.p_exp CoreEnv.empty e'),
430 ("e", CorePrint.p_exp CoreEnv.empty e), 431 ("e", CorePrint.p_exp CoreEnv.empty e),
431 ("body'", CorePrint.p_exp CoreEnv.empty body')]*) 432 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
432 in 433 in