-- Don't touch scrutinees that are already simple
scrutsimpl expr@(Case (Var _) _ _ _) = return expr
-- Replace all other cases with a let that binds the scrutinee and a new
--- simple scrutinee, but not when the scrutinee is applicable (to prevent
--- loops with inlinefun, though I don't think a scrutinee can be
--- applicable...)
-scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do
- id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
- change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+-- simple scrutinee, but only when the scrutinee is representable (to prevent
+-- loops with inlinenonrep, though I don't think a non-representable scrutinee
+-- will be supported anyway...)
+scrutsimpl expr@(Case scrut b ty alts) = do
+ repr <- isRepr scrut
+ if repr
+ then do
+ id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
+ change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+ else
+ return expr
-- Leave all other expressions unchanged
scrutsimpl expr = return expr
-- Perform this transform everywhere
--------------------------------
-- Case binder wildening
--------------------------------
-casewild, casewildtop :: Transform
-casewild expr@(Case scrut b ty alts) = do
+casesimpl, casesimpltop :: Transform
+-- This is already a selector case (or, if x does not appear in bndrs, a very
+-- simple case statement that will be removed by caseremove below). Just leave
+-- it be.
+casesimpl expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr
+-- Make sure that all case alternatives have only wild binders and simple
+-- expressions.
+-- This is done by creating a new let binding for each non-wild binder, which
+-- is bound to a new simple selector case statement and for each complex
+-- expression. We do this only for representable types, to prevent loops with
+-- inlinenonrep.
+casesimpl expr@(Case scrut b ty alts) = do
(bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
let bindings = concat bindingss
-- Replace the case with a let with bindings and a case
-- selector (i.e., a single alt with exactly one binding), already a simple
-- selector altan no bindings (i.e., no wild binders in the original case),
-- don't change anything, otherwise, replace the case.
- if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet
+ if null bindings then return expr else change newlet
where
-- Generate a single wild binder, since they are all the same
wild = MkCore.mkWildBinder
-- sideeffect.
doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
doalt (con, bndrs, expr) = do
- bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..]
- let bindings = Maybe.catMaybes bindings_maybe
- -- We replace the binders with wild binders only. We can leave expr
- -- unchanged, since the new bindings bind the same vars as the original
- -- did.
- let newalt = (con, wildbndrs, expr)
+ -- Make each binder wild, if possible
+ bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
+ let (newbndrs, bindings_maybe) = unzip bndrs_res
+ -- Extract a complex expression, if possible. For this we check if any of
+ -- the new list of bndrs are used by expr. We can't use free_vars here,
+ -- since that looks at the old bndrs.
+ let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) $ expr
+ (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
+ -- Create a new alternative
+ let newalt = (con, newbndrs, expr')
+ let bindings = Maybe.catMaybes (exprbinding_maybe : bindings_maybe)
return (bindings, newalt)
where
- -- Make all binders wild
+ -- Make wild alternatives for each binder
wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs
-- A set of all the binders that are used by the expression
free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr
- -- Creates a case statement to retrieve the ith element from the scrutinee
- -- and binds that to b.
- mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
- mkextracts b i =
- if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b)
- -- Don't create extra bindings for binders that are already wild
- -- (e.g. not in the free variables of expr, so unused), or for
- -- binders that bind function types (to prevent loops with
- -- inlinefun).
- then return Nothing
- else do
+ -- Look at the ith binder in the case alternative. Return a new binder
+ -- for it (either the same one, or a wild one) and optionally a let
+ -- binding containing a case expression.
+ dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
+ dobndr b i = do
+ repr <- isRepr (Var b)
+ -- Is b wild (e.g., not a free var of expr. Since b is only in scope
+ -- in expr, this means that b is unused if expr does not use it.)
+ let wild = not (VarSet.elemVarSet b free_vars)
+ -- Create a new binding for any representable binder that is not
+ -- already wild and is representable (to prevent loops with
+ -- inlinenonrep).
+ if (not wild) && repr
+ then do
-- Create on new binder that will actually capture a value in this
- -- case statement, and return it
+ -- case statement, and return it.
let bty = (Id.idType b)
id <- mkInternalVar "sel" bty
let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
- return $ Just (b, Case scrut b bty [(con, binders, Var id)])
--- Leave all other expressions unchanged
-casewild expr = return expr
--- Perform this transform everywhere
-casewildtop = everywhere ("casewild", casewild)
-
---------------------------------
--- Case value simplification
---------------------------------
-casevalsimpl, casevalsimpltop :: Transform
-casevalsimpl expr@(Case scrut b ty alts) = do
- -- Try to simplify each alternative, resulting in an optional binding and a
- -- new alternative.
- (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts
- let bindings = Maybe.catMaybes bindings_maybe
- -- Create a new let around the case, that binds of the cases values.
- let newlet = Let (Rec bindings) (Case scrut b ty alts')
- -- If there were no values that needed and allowed simplification, don't
- -- change the case.
- if null bindings then return expr else change newlet
- where
- doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt)
- -- Don't simplify values that are already simple
- doalt alt@(con, bndrs, Var _) = return (Nothing, alt)
- -- Simplify each alt by creating a new id, binding the case value to it and
- -- replacing the case value with that id. Only do this when the case value
- -- does not use any of the binders bound by this alternative, for that would
- -- cause those binders to become unbound when moving the value outside of
- -- the case statement. Also, don't create a binding for applicable
- -- expressions, to prevent loops with inlinefun.
- doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do
- id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
- -- We don't flag a change here, since casevalsimpl will do that above
- -- based on Just we return here.
- return $ (Just (id, expr), (con, bndrs, Var id))
- -- Find if any of the binders are used by expr
- where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
- -- Don't simplify anything else
- doalt alt = return (Nothing, alt)
+ let caseexpr = Case scrut b bty [(con, binders, Var id)]
+ return (wildbndrs!!i, Just (b, caseexpr))
+ else
+ -- Just leave the original binder in place, and don't generate an
+ -- extra selector case.
+ return (b, Nothing)
+ -- Process the expression of a case alternative. Accepts an expression
+ -- and whether this expression uses any of the binders in the
+ -- alternative. Returns an optional new binding and a new expression.
+ doexpr :: CoreExpr -> Bool -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreExpr)
+ doexpr expr uses_bndrs = do
+ local_var <- Trans.lift $ is_local_var expr
+ repr <- isRepr expr
+ -- Extract any expressions that do not use any binders from this
+ -- alternative, is not a local var already and is representable (to
+ -- prevent loops with inlinenonrep).
+ if (not uses_bndrs) && (not local_var) && repr
+ then do
+ id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
+ -- We don't flag a change here, since casevalsimpl will do that above
+ -- based on Just we return here.
+ return $ (Just (id, expr), Var id)
+ else
+ -- Don't simplify anything else
+ return (Nothing, expr)
-- Leave all other expressions unchanged
-casevalsimpl expr = return expr
+casesimpl expr = return expr
-- Perform this transform everywhere
-casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl)
+casesimpltop = everywhere ("casesimpl", casesimpl)
--------------------------------
-- Case removal
-- This transform takes any function-typed argument that cannot be propagated
-- (because the function that is applied to it is a builtin function), and
-- puts it in a brand new top level binder. This allows us to for example
--- apply map to a lambda expression This will not conflict with inlinefun,
+-- apply map to a lambda expression This will not conflict with inlinenonrep,
-- since that only inlines local let bindings, not top level bindings.
funextract, funextracttop :: Transform
funextract expr@(App _ _) | is_var fexpr = do
-- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop]
-- Turns the given bind into VHDL
normalizeModule ::
projects / matthijs / master-project / cλash.git / commitdiff