import qualified Id
import qualified Var
import qualified Name
+import qualified DataCon
import qualified VarSet
import qualified CoreFVs
import qualified Class
-- Perform this transform everywhere
betatop = everywhere ("beta", beta)
+--------------------------------
+-- Case of known constructor simplification
+--------------------------------
+-- If a case expressions scrutinizes a datacon application, we can
+-- determine which alternative to use and remove the case alltogether.
+-- We replace it with a let expression the binds every binder in the
+-- alternative bound to the corresponding argument of the datacon. We do
+-- this instead of substituting the binders, to prevent duplication of
+-- work and preserve sharing wherever appropriate.
+knowncase, knowncasetop :: Transform
+knowncase context expr@(Case scrut@(App _ _) bndr ty alts) | not bndr_used = do
+ case collectArgs scrut of
+ (Var f, args) -> case Id.isDataConId_maybe f of
+ -- Not a dataconstructor? Don't change anything (probably a
+ -- function, then)
+ Nothing -> return expr
+ Just dc -> do
+ let (altcon, bndrs, res) = case List.find (\(altcon, bndrs, res) -> altcon == (DataAlt dc)) alts of
+ Just alt -> alt -- Return the alternative found
+ Nothing -> head alts -- If the datacon is not present, the first must be the default alternative
+ -- Double check if we have either the correct alternative, or
+ -- the default.
+ if altcon /= (DataAlt dc) && altcon /= DEFAULT then error ("Normalize.knowncase: Invalid core, datacon not found in alternatives and DEFAULT alternative is not first? " ++ pprString expr) else return ()
+ -- Find out how many arguments to drop (type variables and
+ -- predicates like dictionaries).
+ let (tvs, preds, _, _) = DataCon.dataConSig dc
+ let count = length tvs + length preds
+ -- Create a let expression that binds each of the binders in
+ -- this alternative to the corresponding argument of the data
+ -- constructor.
+ let binds = zip bndrs (drop count args)
+ change $ Let (Rec binds) res
+ _ -> return expr -- Scrutinee is not an application of a var
+ where
+ is_used (_, _, expr) = expr_uses_binders [bndr] expr
+ bndr_used = or $ map is_used alts
+
+-- Leave all other expressions unchanged
+knowncase c expr = return expr
+-- Perform this transform everywhere
+knowncasetop = everywhere ("knowncase", knowncase)
+
--------------------------------
-- Cast propagation
--------------------------------
castsimpltop = everywhere ("castsimpl", castsimpl)
--------------------------------
--- Ensure that a function that just returns another function (or rather,
--- another top-level binder) is still properly normalized. This is a temporary
--- solution, we should probably integrate this pass with lambdasimpl and
--- letsimpl instead.
+-- Return value simplification
--------------------------------
+-- Ensure the return value of a function follows proper normal form. eta
+-- expansion ensures the body starts with lambda abstractions, this
+-- transformation ensures that the lambda abstractions always contain a
+-- recursive let and that, when the return value is representable, the
+-- let contains a local variable reference in its body.
+retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do
+ local_var <- Trans.lift $ is_local_var expr
+ repr <- isRepr expr
+ if not local_var && repr
+ then do
+ id <- Trans.lift $ mkBinderFor expr "res"
+ change $ Let (Rec [(id, expr)]) (Var id)
+ else
+ return expr
+
retvalsimpl c expr@(Let (Rec binds) body) | all (== LambdaBody) c = do
-- Don't extract values that are already a local variable, to prevent
-- loops with ourselves.
else
return expr
-retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do
- local_var <- Trans.lift $ is_local_var expr
- repr <- isRepr expr
- if not local_var && repr
- then do
- id <- Trans.lift $ mkBinderFor expr "res"
- change $ Let (Rec [(id, expr)]) (Var id)
- else
- return expr
-- Leave all other expressions unchanged
retvalsimpl c expr = return expr
--------------------------------
-- let derecursification
--------------------------------
-letderec, letderectop :: Transform
-letderec c 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 $ mkNonRecLets liftable (Let (Rec nonliftable) 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
- -- 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
+letrec, letrectop :: Transform
+letrec c expr@(Let (NonRec bndr val) res) =
+ change $ Let (Rec [(bndr, val)]) res
+
-- Leave all other expressions unchanged
-letderec c expr = return expr
+letrec c expr = return expr
-- Perform this transform everywhere
-letderectop = everywhere ("letderec", letderec)
+letrectop = everywhere ("letrec", letrec)
--------------------------------
-- let flattening
(Var f, args) -> return $ Just body
-- Body is more complicated, try normalizing it
_ -> do
- norm_maybe <- Trans.lift $ getNormalized_maybe f
+ norm_maybe <- Trans.lift $ getNormalized_maybe False f
case norm_maybe of
-- Noth normalizeable
Nothing -> return Nothing
- Just norm -> case splitNormalized norm of
+ Just norm -> case splitNormalizedNonRep norm of
-- The function has just a single binding, so that's simple
-- enough to inline.
- (args, [bind], res) -> return $ Just norm
+ (args, [bind], Var res) -> return $ Just norm
-- More complicated function, don't inline
_ -> return Nothing
-- inlinenonrep).
if (not wild) && repr
then do
- -- Create on new binder that will actually capture a value in this
+ caseexpr <- Trans.lift $ mkSelCase scrut i
+ -- Create a new binder that will actually capture a value in this
-- case statement, and return it.
- let bty = (Id.idType b)
- id <- Trans.lift $ mkInternalVar "sel" bty
- let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
- 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
-- What transforms to run?
-transforms = [inlinedicttop, inlinetopleveltop, classopresolutiontop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, retvalsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop]
+transforms = [inlinedicttop, inlinetopleveltop, knowncasetop, classopresolutiontop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letrectop, letremovetop, retvalsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop]
-- | Returns the normalized version of the given function, or an error
-- if it is not a known global binder.
getNormalized ::
- CoreBndr -- ^ The function to get
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The function to get
-> TranslatorSession CoreExpr -- The normalized function body
-getNormalized bndr = do
- norm <- getNormalized_maybe bndr
+getNormalized result_nonrep bndr = do
+ norm <- getNormalized_maybe result_nonrep bndr
return $ Maybe.fromMaybe
(error $ "Normalize.getNormalized: Unknown or non-representable function requested: " ++ show bndr)
norm
-- | Returns the normalized version of the given function, or Nothing
-- when the binder is not a known global binder or is not normalizeable.
getNormalized_maybe ::
- CoreBndr -- ^ The function to get
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The function to get
-> TranslatorSession (Maybe CoreExpr) -- The normalized function body
-getNormalized_maybe bndr = do
+getNormalized_maybe result_nonrep bndr = do
expr_maybe <- getGlobalBind bndr
- normalizeable <- isNormalizeable' bndr
+ normalizeable <- isNormalizeable result_nonrep bndr
if not normalizeable || Maybe.isNothing expr_maybe
then
-- Binder not normalizeable or not found
return Nothing
- else if is_poly (Var bndr)
- then
- -- This should really only happen at the top level... TODO: Give
- -- a different error if this happens down in the recursion.
- error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
- else do
- -- Binder found and is monomorphic. Normalize the expression
- -- and cache the result.
- normalized <- Utils.makeCached bndr tsNormalized $
- normalizeExpr (show bndr) (Maybe.fromJust expr_maybe)
- return (Just normalized)
+ else do
+ -- Binder found and is monomorphic. Normalize the expression
+ -- and cache the result.
+ normalized <- Utils.makeCached bndr tsNormalized $
+ normalizeExpr (show bndr) (Maybe.fromJust expr_maybe)
+ return (Just normalized)
-- | Normalize an expression
normalizeExpr ::
trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return ()
expr' <- dotransforms transforms expr_uniqued
endcount <- MonadState.get tsTransformCounter
- trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
- trace ("\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $ return ()
- return expr'
+ trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')
+ ++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
+ return expr'
-- | Split a normalized expression into the argument binders, top level
--- bindings and the result binder.
+-- bindings and the result binder. This function returns an error if
+-- the type of the expression is not representable.
splitNormalized ::
CoreExpr -- ^ The normalized expression
-> ([CoreBndr], [Binding], CoreBndr)
-splitNormalized expr = (args, binds, res)
+splitNormalized expr =
+ case splitNormalizedNonRep expr of
+ (args, binds, Var res) -> (args, binds, res)
+ _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"
+
+-- Split a normalized expression, whose type can be unrepresentable.
+splitNormalizedNonRep::
+ CoreExpr -- ^ The normalized expression
+ -> ([CoreBndr], [Binding], CoreExpr)
+splitNormalizedNonRep expr = (args, binds, resexpr)
where
(args, letexpr) = CoreSyn.collectBinders expr
(binds, resexpr) = flattenLets letexpr
- res = case resexpr of
- (Var x) -> x
- _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"