-- Standard modules
import Debug.Trace
import qualified Maybe
+import qualified List
import qualified "transformers" Control.Monad.Trans as Trans
import qualified Control.Monad as Monad
import qualified Control.Monad.Trans.Writer as Writer
-- Generate a binder for the expression
id <- Trans.lift $ mkBinderFor val "castval"
-- Extract the expression
- change $ Let (Rec [(id, val)]) (Cast (Var id) ty)
+ change $ Let (NonRec id val) (Cast (Var id) ty)
else
return expr
-- Leave all other expressions unchanged
castsimpltop = everywhere ("castsimpl", castsimpl)
--------------------------------
--- let recursification
+-- let derecursification
--------------------------------
-letrec, letrectop :: Transform
-letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res
+letderec, letderectop :: Transform
+letderec expr@(Let (Rec binds) res) = case liftable of
+ -- Nothing is liftable, just return
+ [] -> return expr
+ -- Something can be lifted, generate a new let expression
+ _ -> change $ MkCore.mkCoreLets newbinds res
+ where
+ -- Make a list of all the binders bound in this recursive let
+ bndrs = map fst binds
+ -- See which bindings are liftable
+ (liftable, nonliftable) = List.partition canlift binds
+ -- Create nonrec bindings for each liftable binding and a single recursive
+ -- binding for all others
+ newbinds = (map (uncurry NonRec) liftable) ++ [Rec nonliftable]
+ -- Any expression that does not use any of the binders in this recursive let
+ -- can be lifted into a nonrec let. It can't use its own binder either,
+ -- since that would mean the binding is self-recursive and should be in a
+ -- single bind recursive let.
+ canlift (bndr, e) = not $ expr_uses_binders bndrs e
-- Leave all other expressions unchanged
-letrec expr = return expr
+letderec expr = return expr
-- Perform this transform everywhere
-letrectop = everywhere ("letrec", letrec)
+letderectop = everywhere ("letderec", letderec)
--------------------------------
-- let simplification
if repr
then do
id <- Trans.lift $ mkBinderFor scrut "scrut"
- change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+ change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
else
return expr
-- Leave all other expressions unchanged
if repr && not local_var
then do -- Extract representable arguments
id <- Trans.lift $ mkBinderFor arg "arg"
- change $ Let (Rec [(id, arg)]) (App f (Var id))
+ change $ Let (NonRec id arg) (App f (Var id))
else -- Leave non-representable arguments unchanged
return expr
-- Leave all other expressions unchanged
-- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letderectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop]
-- | Returns the normalized version of the given function.
getNormalized ::
-> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
normalizeExpr what expr = do
- -- Introduce an empty Let at the top level, so there will always be
- -- a let in the expression (none of the transformations will remove
- -- the last let).
- let expr' = Let (Rec []) expr
-- Normalize this expression
- trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
- expr'' <- dotransforms transforms expr'
- trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr'')) $ return ()
- return expr''
+ trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
+ expr' <- dotransforms transforms expr
+ trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ return expr'
-- | Get the value that is bound to the given binder at top level. Fails when
-- there is no such binding.