From 7a327c1297615a9498e7117a0017b09ff2458d53 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 1 Nov 2006 16:43:29 +0000 Subject: [PATCH] Major overhaul of the Simplifier This big patch completely overhauls the Simplifier. The simplifier had grown old and crufty, and was hard to understand and maintain. This new version is still quite complicated, because the simplifier does a lot, but it's much easier to understand, for me at least. It does mean that I have touched almost every line of the simplifier, so the diff is a large one. Big changes are these * When simplifying an Expr we generate a simplified Expr plus a bunch of "floats", which are bindings that have floated out of the Expr. Before, this float stuff was returned separately, but not they are embedded in the SimplEnv, which makes the plumbing much easier and more robust. In particular, the SimplEnv already meaintains the "in-scope set", and making that travel with the floats helps to ensure that we always use the right in-scope set. This change has a pervasive effect. * Rather than simplifying the args of a call before trying rules and inlining, we now defer simplifying the args until both rules and inlining have failed, so we're going to leave a call in the result. This avoids the risk of repeatedly simplifying an argument, which was handled by funny ad-hoc flags before. The downside is that we must apply the substitution to the args before rule-matching; and if thep rule doesn't match that is wasted work. But having any rules at all is the exception not the rule, and the substitution is lazy, so we only substitute until a no-match is found. The code is much more elegant though. * A SimplCont is now more zipper-like. It used to have an embedded function, but that was a bit hard to think about, and now it's nice and consistent. The relevant constructors are StrictArg and StrictBind * Each Rule now has an *arity* (gotten by CoreSyn.ruleArity), which tells how many arguments it matches against. This entailed adding a field ru_nargs to a BuiltinRule. And that made me look at PrelRules; I did quite a bit of refactoring in the end, so the diff in PrelRules looks much biggger than it really is. * A little refactoring in OccurAnal. The key change is that in the RHS of x = y `cast` co we regard 'y' as "many", so that it doesn't get inlined into the RHS of x. This allows x to be inlined elsewhere. It's very like the existing situation for x = Just y where we treat 'y' as "many". --- compiler/coreSyn/CoreSyn.lhs | 7 +- compiler/prelude/PrelRules.lhs | 245 ++--- compiler/simplCore/OccurAnal.lhs | 36 +- compiler/simplCore/SimplEnv.lhs | 349 ++++--- compiler/simplCore/SimplUtils.lhs | 377 +++---- compiler/simplCore/Simplify.lhs | 1989 +++++++++++++++--------------------- compiler/specialise/Rules.lhs | 34 +- compiler/specialise/SpecConstr.lhs | 3 +- compiler/typecheck/TcGadt.lhs | 8 +- 9 files changed, 1408 insertions(+), 1640 deletions(-) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 3f74dc5..67245d1 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -42,7 +42,7 @@ module CoreSyn ( -- Core rules CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - RuleName, seqRules, + RuleName, seqRules, ruleArity, isBuiltinRule, ruleName, isLocalRule, ruleIdName ) where @@ -216,11 +216,16 @@ data CoreRule ru_name :: RuleName, -- and suchlike. It has no free variables. ru_fn :: Name, -- Name of the Id at -- the head of this rule + ru_nargs :: Int, -- Number of args that ru_try expects ru_try :: [CoreExpr] -> Maybe CoreExpr } isBuiltinRule (BuiltinRule {}) = True isBuiltinRule _ = False +ruleArity :: CoreRule -> Int +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + ruleName :: CoreRule -> RuleName ruleName = ru_name diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index f179955..8604647 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -30,7 +30,7 @@ import Literal ( Literal(..), mkMachInt, mkMachWord , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit , float2DoubleLit, double2FloatLit ) -import PrimOp ( PrimOp(..), primOpOcc, tagToEnumKey ) +import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) @@ -40,7 +40,7 @@ import OccName ( occNameFS ) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, eqStringName, unpackCStringIdKey, inlineIdName ) import Maybes ( orElse ) -import Name ( Name ) +import Name ( Name, nameOccName ) import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) @@ -77,122 +77,115 @@ example: primOpRules :: PrimOp -> Name -> [CoreRule] primOpRules op op_name = primop_rule op where - rule_name = occNameFS (primOpOcc op) - rule_name_case = rule_name `appendFS` FSLIT("->case") - -- A useful shorthand - one_rule rule_fn = [BuiltinRule { ru_name = rule_name, - ru_fn = op_name, - ru_try = rule_fn }] - case_rule rule_fn = [BuiltinRule { ru_name = rule_name_case, - ru_fn = op_name, - ru_try = rule_fn }] + one_lit = oneLit op_name + two_lits = twoLits op_name + relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ)) + -- Cunning. cmpOp compares the values to give an Ordering. + -- It applies its argument to that ordering value to turn + -- the ordering into a boolean value. (`cmp` EQ) is just the job. -- ToDo: something for integer-shift ops? -- NotOp - primop_rule TagToEnumOp = one_rule tagToEnumRule - primop_rule DataToTagOp = one_rule dataToTagRule + primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule + primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule -- Int operations - primop_rule IntAddOp = one_rule (twoLits (intOp2 (+))) - primop_rule IntSubOp = one_rule (twoLits (intOp2 (-))) - primop_rule IntMulOp = one_rule (twoLits (intOp2 (*))) - primop_rule IntQuotOp = one_rule (twoLits (intOp2Z quot)) - primop_rule IntRemOp = one_rule (twoLits (intOp2Z rem)) - primop_rule IntNegOp = one_rule (oneLit negOp) + primop_rule IntAddOp = two_lits (intOp2 (+)) + primop_rule IntSubOp = two_lits (intOp2 (-)) + primop_rule IntMulOp = two_lits (intOp2 (*)) + primop_rule IntQuotOp = two_lits (intOp2Z quot) + primop_rule IntRemOp = two_lits (intOp2Z rem) + primop_rule IntNegOp = one_lit negOp -- Word operations #if __GLASGOW_HASKELL__ >= 500 - primop_rule WordAddOp = one_rule (twoLits (wordOp2 (+))) - primop_rule WordSubOp = one_rule (twoLits (wordOp2 (-))) - primop_rule WordMulOp = one_rule (twoLits (wordOp2 (*))) + primop_rule WordAddOp = two_lits (wordOp2 (+)) + primop_rule WordSubOp = two_lits (wordOp2 (-)) + primop_rule WordMulOp = two_lits (wordOp2 (*)) #endif - primop_rule WordQuotOp = one_rule (twoLits (wordOp2Z quot)) - primop_rule WordRemOp = one_rule (twoLits (wordOp2Z rem)) + primop_rule WordQuotOp = two_lits (wordOp2Z quot) + primop_rule WordRemOp = two_lits (wordOp2Z rem) #if __GLASGOW_HASKELL__ >= 407 - primop_rule AndOp = one_rule (twoLits (wordBitOp2 (.&.))) - primop_rule OrOp = one_rule (twoLits (wordBitOp2 (.|.))) - primop_rule XorOp = one_rule (twoLits (wordBitOp2 xor)) + primop_rule AndOp = two_lits (wordBitOp2 (.&.)) + primop_rule OrOp = two_lits (wordBitOp2 (.|.)) + primop_rule XorOp = two_lits (wordBitOp2 xor) #endif -- coercions - primop_rule Word2IntOp = one_rule (oneLit (litCoerce word2IntLit)) - primop_rule Int2WordOp = one_rule (oneLit (litCoerce int2WordLit)) - primop_rule Narrow8IntOp = one_rule (oneLit (litCoerce narrow8IntLit)) - primop_rule Narrow16IntOp = one_rule (oneLit (litCoerce narrow16IntLit)) - primop_rule Narrow32IntOp = one_rule (oneLit (litCoerce narrow32IntLit)) - primop_rule Narrow8WordOp = one_rule (oneLit (litCoerce narrow8WordLit)) - primop_rule Narrow16WordOp = one_rule (oneLit (litCoerce narrow16WordLit)) - primop_rule Narrow32WordOp = one_rule (oneLit (litCoerce narrow32WordLit)) - primop_rule OrdOp = one_rule (oneLit (litCoerce char2IntLit)) - primop_rule ChrOp = one_rule (oneLit (litCoerce int2CharLit)) - primop_rule Float2IntOp = one_rule (oneLit (litCoerce float2IntLit)) - primop_rule Int2FloatOp = one_rule (oneLit (litCoerce int2FloatLit)) - primop_rule Double2IntOp = one_rule (oneLit (litCoerce double2IntLit)) - primop_rule Int2DoubleOp = one_rule (oneLit (litCoerce int2DoubleLit)) + primop_rule Word2IntOp = one_lit (litCoerce word2IntLit) + primop_rule Int2WordOp = one_lit (litCoerce int2WordLit) + primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit) + primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit) + primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit) + primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit) + primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit) + primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit) + primop_rule OrdOp = one_lit (litCoerce char2IntLit) + primop_rule ChrOp = one_lit (litCoerce int2CharLit) + primop_rule Float2IntOp = one_lit (litCoerce float2IntLit) + primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit) + primop_rule Double2IntOp = one_lit (litCoerce double2IntLit) + primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit) -- SUP: Not sure what the standard says about precision in the following 2 cases - primop_rule Float2DoubleOp = one_rule (oneLit (litCoerce float2DoubleLit)) - primop_rule Double2FloatOp = one_rule (oneLit (litCoerce double2FloatLit)) + primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit) + primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit) -- Float - primop_rule FloatAddOp = one_rule (twoLits (floatOp2 (+))) - primop_rule FloatSubOp = one_rule (twoLits (floatOp2 (-))) - primop_rule FloatMulOp = one_rule (twoLits (floatOp2 (*))) - primop_rule FloatDivOp = one_rule (twoLits (floatOp2Z (/))) - primop_rule FloatNegOp = one_rule (oneLit negOp) + primop_rule FloatAddOp = two_lits (floatOp2 (+)) + primop_rule FloatSubOp = two_lits (floatOp2 (-)) + primop_rule FloatMulOp = two_lits (floatOp2 (*)) + primop_rule FloatDivOp = two_lits (floatOp2Z (/)) + primop_rule FloatNegOp = one_lit negOp -- Double - primop_rule DoubleAddOp = one_rule (twoLits (doubleOp2 (+))) - primop_rule DoubleSubOp = one_rule (twoLits (doubleOp2 (-))) - primop_rule DoubleMulOp = one_rule (twoLits (doubleOp2 (*))) - primop_rule DoubleDivOp = one_rule (twoLits (doubleOp2Z (/))) - primop_rule DoubleNegOp = one_rule (oneLit negOp) + primop_rule DoubleAddOp = two_lits (doubleOp2 (+)) + primop_rule DoubleSubOp = two_lits (doubleOp2 (-)) + primop_rule DoubleMulOp = two_lits (doubleOp2 (*)) + primop_rule DoubleDivOp = two_lits (doubleOp2Z (/)) + primop_rule DoubleNegOp = one_lit negOp -- Relational operators - primop_rule IntEqOp = one_rule (relop (==)) ++ case_rule (litEq True) - primop_rule IntNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) - primop_rule CharEqOp = one_rule (relop (==)) ++ case_rule (litEq True) - primop_rule CharNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) - - primop_rule IntGtOp = one_rule (relop (>)) - primop_rule IntGeOp = one_rule (relop (>=)) - primop_rule IntLeOp = one_rule (relop (<=)) - primop_rule IntLtOp = one_rule (relop (<)) - - primop_rule CharGtOp = one_rule (relop (>)) - primop_rule CharGeOp = one_rule (relop (>=)) - primop_rule CharLeOp = one_rule (relop (<=)) - primop_rule CharLtOp = one_rule (relop (<)) - - primop_rule FloatGtOp = one_rule (relop (>)) - primop_rule FloatGeOp = one_rule (relop (>=)) - primop_rule FloatLeOp = one_rule (relop (<=)) - primop_rule FloatLtOp = one_rule (relop (<)) - primop_rule FloatEqOp = one_rule (relop (==)) - primop_rule FloatNeOp = one_rule (relop (/=)) - - primop_rule DoubleGtOp = one_rule (relop (>)) - primop_rule DoubleGeOp = one_rule (relop (>=)) - primop_rule DoubleLeOp = one_rule (relop (<=)) - primop_rule DoubleLtOp = one_rule (relop (<)) - primop_rule DoubleEqOp = one_rule (relop (==)) - primop_rule DoubleNeOp = one_rule (relop (/=)) - - primop_rule WordGtOp = one_rule (relop (>)) - primop_rule WordGeOp = one_rule (relop (>=)) - primop_rule WordLeOp = one_rule (relop (<=)) - primop_rule WordLtOp = one_rule (relop (<)) - primop_rule WordEqOp = one_rule (relop (==)) - primop_rule WordNeOp = one_rule (relop (/=)) + primop_rule IntEqOp = relop (==) ++ litEq op_name True + primop_rule IntNeOp = relop (/=) ++ litEq op_name False + primop_rule CharEqOp = relop (==) ++ litEq op_name True + primop_rule CharNeOp = relop (/=) ++ litEq op_name False + + primop_rule IntGtOp = relop (>) + primop_rule IntGeOp = relop (>=) + primop_rule IntLeOp = relop (<=) + primop_rule IntLtOp = relop (<) + + primop_rule CharGtOp = relop (>) + primop_rule CharGeOp = relop (>=) + primop_rule CharLeOp = relop (<=) + primop_rule CharLtOp = relop (<) + + primop_rule FloatGtOp = relop (>) + primop_rule FloatGeOp = relop (>=) + primop_rule FloatLeOp = relop (<=) + primop_rule FloatLtOp = relop (<) + primop_rule FloatEqOp = relop (==) + primop_rule FloatNeOp = relop (/=) + + primop_rule DoubleGtOp = relop (>) + primop_rule DoubleGeOp = relop (>=) + primop_rule DoubleLeOp = relop (<=) + primop_rule DoubleLtOp = relop (<) + primop_rule DoubleEqOp = relop (==) + primop_rule DoubleNeOp = relop (/=) + + primop_rule WordGtOp = relop (>) + primop_rule WordGeOp = relop (>=) + primop_rule WordLeOp = relop (<=) + primop_rule WordLtOp = relop (<) + primop_rule WordEqOp = relop (==) + primop_rule WordNeOp = relop (/=) primop_rule other = [] - relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ)) - -- Cunning. cmpOp compares the values to give an Ordering. - -- It applies its argument to that ordering value to turn - -- the ordering into a boolean value. (`cmp` EQ) is just the job. \end{code} %************************************************************************ @@ -305,19 +298,25 @@ doubleOp2Z op l1 l2 = Nothing -- m -> e2 -- (modulo the usual precautions to avoid duplicating e1) -litEq :: Bool -- True <=> equality, False <=> inequality - -> RuleFun -litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr -litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr -litEq is_eq other = Nothing - -do_lit_eq is_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) boolTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) +litEq :: Name + -> Bool -- True <=> equality, False <=> inequality + -> [CoreRule] +litEq op_name is_eq + = [BuiltinRule { ru_name = occNameFS (nameOccName op_name) + `appendFS` FSLIT("->case"), + ru_fn = op_name, + ru_nargs = 2, ru_try = rule_fn }] where + rule_fn [Lit lit, expr] = do_lit_eq lit expr + rule_fn [expr, Lit lit] = do_lit_eq lit expr + rule_fn other = Nothing + + do_lit_eq lit expr + = Just (Case expr (mkWildId (literalType lit)) boolTy + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) val_if_eq | is_eq = trueVal - | otherwise = falseVal + | otherwise = falseVal val_if_neq | is_eq = falseVal | otherwise = trueVal @@ -345,15 +344,28 @@ wordResult result %************************************************************************ \begin{code} -type RuleFun = [CoreExpr] -> Maybe CoreExpr - -twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun -twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2) -twoLits rule _ = Nothing +mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule] +-- Gives the Rule the same name as the primop itself +mkBasicRule op_name n_args rule_fn + = [BuiltinRule { ru_name = occNameFS (nameOccName op_name), + ru_fn = op_name, + ru_nargs = n_args, ru_try = rule_fn }] + +oneLit :: Name -> (Literal -> Maybe CoreExpr) + -> [CoreRule] +oneLit op_name test + = mkBasicRule op_name 1 rule_fn + where + rule_fn [Lit l1] = test (convFloating l1) + rule_fn _ = Nothing -oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun -oneLit rule [Lit l1] = rule (convFloating l1) -oneLit rule _ = Nothing +twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr) + -> [CoreRule] +twoLits op_name test + = mkBasicRule op_name 2 rule_fn + where + rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) + rule_fn _ = Nothing -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture @@ -365,7 +377,6 @@ convFloating (MachDouble d) | not opt_SimplExcessPrecision = MachDouble (toRational ((fromRational d) :: Double)) convFloating l = l - trueVal = Var trueDataConId falseVal = Var falseDataConId mkIntVal i = Lit (mkMachInt i) @@ -427,9 +438,9 @@ dataToTagRule other = Nothing builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit, - BuiltinRule FSLIT("EqString") eqStringName match_eq_string, - BuiltinRule FSLIT("Inline") inlineIdName match_inline + = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName 4 match_append_lit, + BuiltinRule FSLIT("EqString") eqStringName 2 match_eq_string, + BuiltinRule FSLIT("Inline") inlineIdName 1 match_inline ] @@ -472,10 +483,10 @@ match_eq_string other = Nothing -- The rule is this: -- inline (f a b c) = a b c -- (if f has an unfolding) -match_inline (e:args2) +match_inline (e:_) | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (idUnfolding f) - = Just (mkApps (mkApps unf args1) args2) + = Just (mkApps unf args1) match_inline other = Nothing \end{code} diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index d13fa3b..5bfb4b9 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -482,7 +482,10 @@ occAnal env (Note note body) occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> - (usage, Cast expr' co) + (markRhsUds env True usage, Cast expr' co) + -- If we see let x = y `cast` co + -- then mark y as 'Many' so that we don't + -- immediately inline y again. } \end{code} @@ -581,23 +584,13 @@ the "build hack" to work. occAnalApp env (Var fun, args) is_rhs = case args_stuff of { (args_uds, args') -> let - -- We mark the free vars of the argument of a constructor or PAP - -- as "many", if it is the RHS of a let(rec). - -- This means that nothing gets inlined into a constructor argument - -- position, which is what we want. Typically those constructor - -- arguments are just variables, or trivial expressions. - -- - -- This is the *whole point* of the isRhsEnv predicate - final_args_uds - | isRhsEnv env, - isDataConWorkId fun || valArgCount args < idArity fun - = mapVarEnv markMany args_uds - | otherwise = args_uds + final_args_uds = markRhsUds env is_pap args_uds in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) + is_pap = isDataConWorkId fun || valArgCount args < idArity fun -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args @@ -628,6 +621,23 @@ occAnalApp env (fun, args) is_rhs in (final_uds, mkApps fun' args') }} + +markRhsUds :: OccEnv -- Check if this is a RhsEnv + -> Bool -- and this is true + -> UsageDetails -- The do markMany on this + -> UsageDetails +-- We mark the free vars of the argument of a constructor or PAP +-- as "many", if it is the RHS of a let(rec). +-- This means that nothing gets inlined into a constructor argument +-- position, which is what we want. Typically those constructor +-- arguments are just variables, or trivial expressions. +-- +-- This is the *whole point* of the isRhsEnv predicate +markRhsUds env is_pap arg_uds + | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds + | otherwise = arg_uds + + appSpecial :: OccEnv -> Int -> CtxtTy -- Argument number, and context to use for it -> [CoreExpr] diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index fca0d61..f9e0484 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -5,10 +5,12 @@ \begin{code} module SimplEnv ( - InId, InBind, InExpr, InAlt, InArg, InType, InBinder, - OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, + InId, InBind, InExpr, InAlt, InArg, InType, InBndr, + OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, InCoercion, OutCoercion, + isStrictBndr, + -- The simplifier mode setMode, getMode, @@ -19,51 +21,47 @@ module SimplEnv ( setEnclosingCC, getEnclosingCC, -- Environments - SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, + SimplEnv(..), -- Temp not abstract + mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, getRules, - SimplSR(..), mkContEx, substId, + SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, simplBinder, simplBinders, addLetIdInfo, - substExpr, substTy, + substExpr, substTy, -- Floats - FloatsWith, FloatsWithExpr, - Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats, - allLifted, wrapFloats, floatBinds, - addAuxiliaryBind, + Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, + wrapFloats, floatBinds, setFloats, canFloat, zapFloats, addRecFloats, + getFloats ) where #include "HsVersions.h" import SimplMonad -import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding ) -import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo, - arityInfo, workerInfo, setWorkerInfo, - unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo, - workerExists - ) +import IdInfo import CoreSyn -import Rules ( RuleBase ) -import CoreUtils ( needsCaseBinding ) -import CostCentre ( CostCentreStack, subsumedCCS ) -import Var +import Rules +import CoreUtils +import CoreFVs +import CostCentre +import Var import VarEnv -import VarSet ( isEmptyVarSet ) +import VarSet import OrdList - +import Id +import NewDemand import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) import qualified Type ( substTy, substTyVarBndr ) - -import Type ( Type, TvSubst(..), TvSubstEnv, - isUnLiftedType, seqType, tyVarsOfType ) -import Coercion ( Coercion ) -import BasicTypes ( OccInfo(..), isFragileOcc ) -import DynFlags ( SimplifierMode(..) ) -import Util ( mapAccumL ) +import Type hiding ( substTy, substTyVarBndr ) +import Coercion +import BasicTypes +import DynFlags +import Util +import UniqFM import Outputable \end{code} @@ -74,7 +72,7 @@ import Outputable %************************************************************************ \begin{code} -type InBinder = CoreBndr +type InBndr = CoreBndr type InId = Id -- Not yet cloned type InType = Type -- Ditto type InBind = CoreBind @@ -83,7 +81,7 @@ type InAlt = CoreAlt type InArg = CoreArg type InCoercion = Coercion -type OutBinder = CoreBndr +type OutBndr = CoreBndr type OutId = Id -- Cloned type OutTyVar = TyVar -- Cloned type OutType = Type -- Cloned @@ -94,6 +92,13 @@ type OutAlt = CoreAlt type OutArg = CoreArg \end{code} +\begin{code} +isStrictBndr :: Id -> Bool +isStrictBndr bndr + = ASSERT2( isId bndr, ppr bndr ) + isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) +\end{code} + %************************************************************************ %* * \subsubsection{The @SimplEnv@ type} @@ -114,10 +119,14 @@ data SimplEnv -- The current set of in-scope variables -- They are all OutVars, and all bound in this module seInScope :: InScopeSet, -- OutVars only + -- Includes all variables bound by seFloats + seFloats :: Floats, + -- See Note [Simplifier floats] -- The current substitution seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType seIdSubst :: SimplIdSubst -- InId |--> OutExpr + } type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr @@ -128,6 +137,15 @@ data SimplSR | ContEx TvSubstEnv -- A suspended substitution SimplIdSubst InExpr +instance Outputable SimplSR where + ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e + ppr (DoneId v) = ptext SLIT("DoneId") <+> ppr v + ppr (ContEx tv id e) = vcat [ptext SLIT("ContEx") <+> ppr e {-, + ppr (filter_env tv), ppr (filter_env id) -}] + where + fvs = exprFreeVars e + filter_env env = filterVarEnv_Directly keep env + keep uniq _ = uniq `elemUFM_Directly` fvs \end{code} @@ -197,7 +215,7 @@ mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv mkSimplEnv mode switches rules = SimplEnv { seChkr = switches, seCC = subsumedCCS, seMode = mode, seInScope = emptyInScopeSet, - seExtRules = rules, + seExtRules = rules, seFloats = emptyFloats, seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv } -- The top level "enclosing CC" is "SUBSUMED". @@ -236,7 +254,16 @@ setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv setInScopeSet env in_scope = env {seInScope = in_scope} setInScope :: SimplEnv -> SimplEnv -> SimplEnv -setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope) +-- Set the in-scope set, and *zap* the floats +setInScope env env_with_scope + = env { seInScope = seInScope env_with_scope, + seFloats = emptyFloats } + +setFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Set the in-scope set *and* the floats +setFloats env env_with_floats + = env { seInScope = seInScope env_with_floats, + seFloats = seFloats env_with_floats } addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv -- The new Ids are guaranteed to be freshly allocated @@ -273,6 +300,142 @@ getRules = seExtRules \end{code} + +%************************************************************************ +%* * +\subsection{Floats} +%* * +%************************************************************************ + +Note [Simplifier floats] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The Floats is a bunch of bindings, classified by a FloatFlag. + + NonRec x (y:ys) FltLifted + Rec [(x,rhs)] FltLifted + NonRec x# (y +# 3) FltOkSpec + NonRec x# (a /# b) FltCareful + NonRec x* (f y) FltCareful -- Might fail or diverge + NonRec x# (f y) FltCareful -- Might fail or diverge + (where f :: Int -> Int#) + +\begin{code} +data Floats = Floats (OrdList OutBind) FloatFlag + -- See Note [Simplifier floats] + +data FloatFlag + = FltLifted -- All bindings are lifted and lazy + -- Hence ok to float to top level, or recursive + + | FltOkSpec -- All bindings are FltLifted *or* + -- strict (perhaps because unlifted, + -- perhaps because of a strict binder), + -- *and* ok-for-speculation + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + + | FltCareful -- At least one binding is strict (or unlifted) + -- and not guaranteed cheap + -- Do not float these bindings out of a lazy let + +instance Outputable Floats where + ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) + +instance Outputable FloatFlag where + ppr FltLifted = ptext SLIT("FltLifted") + ppr FltOkSpec = ptext SLIT("FltOkSpec") + ppr FltCareful = ptext SLIT("FltCareful") + +andFF :: FloatFlag -> FloatFlag -> FloatFlag +andFF FltCareful _ = FltCareful +andFF FltOkSpec FltCareful = FltCareful +andFF FltOkSpec flt = FltOkSpec +andFF FltLifted flt = flt + +classifyFF :: CoreBind -> FloatFlag +classifyFF (Rec _) = FltLifted +classifyFF (NonRec bndr rhs) + | not (isStrictBndr bndr) = FltLifted + | exprOkForSpeculation rhs = FltOkSpec + | otherwise = FltCareful + +canFloat :: TopLevelFlag -> RecFlag -> Bool -> SimplEnv -> Bool +canFloat lvl rec str (SimplEnv {seFloats = Floats _ ff}) + = canFloatFlt lvl rec str ff + +canFloatFlt :: TopLevelFlag -> RecFlag -> Bool -> FloatFlag -> Bool +canFloatFlt lvl rec str FltLifted = True +canFloatFlt lvl rec str FltOkSpec = isNotTopLevel lvl && isNonRec rec +canFloatFlt lvl rec str FltCareful = str && isNotTopLevel lvl && isNonRec rec +\end{code} + + +\begin{code} +emptyFloats :: Floats +emptyFloats = Floats nilOL FltLifted + +unitFloat :: OutBind -> Floats +-- A single-binding float +unitFloat bind = Floats (unitOL bind) (classifyFF bind) + +addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv +-- Add a non-recursive binding and extend the in-scope set +-- The latter is important; the binder may already be in the +-- in-scope set (although it might also have been created with newId) +-- but it may now have more IdInfo +addNonRec env id rhs + = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), + seInScope = extendInScopeSet (seInScope env) id } + +addFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Add the floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addFloats env1 env2 + = env1 {seFloats = seFloats env1 `addFlts` seFloats env2, + seInScope = seInScope env2 } + +addFlts :: Floats -> Floats -> Floats +addFlts (Floats bs1 l1) (Floats bs2 l2) + = Floats (bs1 `appOL` bs2) (l1 `andFF` l2) + +zapFloats :: SimplEnv -> SimplEnv +zapFloats env = env { seFloats = emptyFloats } + +addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Flattens the floats from env2 into a single Rec group, +-- prepends the floats from env1, and puts the result back in env2 +-- This is all very specific to the way recursive bindings are +-- handled; see Simplify.simplRecBind +addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) + = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) ) + env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} + +wrapFloats :: SimplEnv -> OutExpr -> OutExpr +wrapFloats env expr = wrapFlts (seFloats env) expr + +wrapFlts :: Floats -> OutExpr -> OutExpr +-- Wrap the floats around the expression, using case-binding where necessary +wrapFlts (Floats bs _) body = foldrOL wrap body bs + where + wrap (Rec prs) body = Let (Rec prs) body + wrap (NonRec b r) body = bindNonRec b r body + +getFloats :: SimplEnv -> [CoreBind] +getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs + +isEmptyFloats :: SimplEnv -> Bool +isEmptyFloats env = isEmptyFlts (seFloats env) + +isEmptyFlts :: Floats -> Bool +isEmptyFlts (Floats bs _) = isNilOL bs + +floatBinds :: Floats -> [OutBind] +floatBinds (Floats bs _) = fromOL bs +\end{code} + + %************************************************************************ %* * Substitution of Vars @@ -287,16 +450,26 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v = DoneId v | otherwise -- A local Id = case lookupVarEnv ids v of - Just (DoneId v) -> DoneId (refine v) + Just (DoneId v) -> DoneId (refine in_scope v) Just res -> res - Nothing -> DoneId (refine v) + Nothing -> DoneId (refine in_scope v) where + -- Get the most up-to-date thing from the in-scope set -- Even though it isn't in the substitution, it may be in -- the in-scope set with better IdInfo - refine v = case lookupInScope in_scope v of - Just v' -> v' - Nothing -> WARN( True, ppr v ) v -- This is an error! +refine in_scope v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> WARN( True, ppr v ) v -- This is an error! + +lookupRecBndr :: SimplEnv -> Id -> Id +-- Look up an Id which has been put into the envt by simplRecBndrs, +-- but where we have not yet done its RHS +lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of + Just (DoneId v) -> v + Just res -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refine in_scope v \end{code} @@ -311,12 +484,12 @@ These functions are in the monad only so that they can be made strict via seq. \begin{code} simplBinders, simplLamBndrs - :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) + :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs ------------- -simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) +simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- Used for lambda and case-bound variables -- Clone Id if necessary, substitute type -- Return with IdInfo already substituted, but (fragile) occurrence info zapped @@ -382,8 +555,8 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) = delVarEnv id_subst old_id \end{code} - \begin{code} +------------------------------------ seqTyVar :: TyVar -> () seqTyVar b = b `seq` () @@ -397,7 +570,6 @@ seqIds [] = () seqIds (id:ids) = seqId id `seq` seqIds ids \end{code} - %************************************************************************ %* * Let bindings @@ -409,21 +581,21 @@ Simplifying let binders Rename the binders if necessary, \begin{code} -simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) +simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) simplNonRecBndr env id = do { let (env1, id1) = substLetIdBndr env id ; seqId id1 `seq` return (env1, id1) } --------------- -simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) +simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids - ; seqIds ids1 `seq` return (env1, ids1) } + ; seqIds ids1 `seq` return env1 } --------------- -substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform - -> (SimplEnv, OutBinder) --- C.f. CoreSubst.substIdBndr +substLetIdBndr :: SimplEnv -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) +-- C.f. substIdBndr above -- Clone Id if necessary, substitute its type -- Return an Id with completely zapped IdInfo -- [addLetIdInfo, below, will restore its IdInfo] @@ -442,7 +614,6 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old -- Extend the substitution if the unique has changed, -- or there's some useful occurrence information -- See the notes with substTyVarBndr for the delSubstEnv - occ_info = occInfo (idInfo old_id) new_subst | new_id /= old_id = extendVarEnv id_subst old_id (DoneId new_id) | otherwise @@ -505,7 +676,7 @@ Here, we'll do postInlineUnconditionally on f, and we must "see" that when substituting in h's RULE. \begin{code} -addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder) +addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr) addLetIdInfo env in_id out_id = (modifyInScope env out_id final_id, final_id) where @@ -550,7 +721,7 @@ substIdInfo subst info substIdType :: SimplEnv -> Id -> Id substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id - | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) + | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) -- The tyVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself @@ -603,81 +774,3 @@ substExpr env expr | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr \end{code} - -%************************************************************************ -%* * -\subsection{Floats} -%* * -%************************************************************************ - -\begin{code} -type FloatsWithExpr = FloatsWith OutExpr -type FloatsWith a = (Floats, a) - -- We return something equivalent to (let b in e), but - -- in pieces to avoid the quadratic blowup when floating - -- incrementally. Comments just before simplExprB in Simplify.lhs - -data Floats = Floats (OrdList OutBind) - InScopeSet -- Environment "inside" all the floats - Bool -- True <=> All bindings are lifted - -allLifted :: Floats -> Bool -allLifted (Floats _ _ is_lifted) = is_lifted - -wrapFloats :: Floats -> OutExpr -> OutExpr -wrapFloats (Floats bs _ _) body = foldrOL Let body bs - -isEmptyFloats :: Floats -> Bool -isEmptyFloats (Floats bs _ _) = isNilOL bs - -floatBinds :: Floats -> [OutBind] -floatBinds (Floats bs _ _) = fromOL bs - -flattenFloats :: Floats -> Floats --- Flattens into a single Rec group -flattenFloats (Floats bs is is_lifted) - = ASSERT2( is_lifted, ppr (fromOL bs) ) - Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted -\end{code} - -\begin{code} -emptyFloats :: SimplEnv -> Floats -emptyFloats env = Floats nilOL (getInScope env) True - -unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats --- A single non-rec float; extend the in-scope set -unitFloat env var rhs = Floats (unitOL (NonRec var rhs)) - (extendInScopeSet (getInScope env) var) - (not (isUnLiftedType (idType var))) - -addFloats :: SimplEnv -> Floats - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) -addFloats env (Floats b1 is1 l1) thing_inside - | isNilOL b1 - = thing_inside env - | otherwise - = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) -> - returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res) - -addLetBind :: OutBind -> Floats -> Floats -addLetBind bind (Floats binds in_scope lifted) - = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind) - -is_lifted_bind (Rec _) = True -is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b)) - --- addAuxiliaryBind * takes already-simplified things (bndr and rhs) --- * extends the in-scope env --- * assumes it's a let-bindable thing -addAuxiliaryBind :: SimplEnv -> OutBind - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) - -- Extends the in-scope environment as well as wrapping the bindings -addAuxiliaryBind env bind thing_inside - = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } ) - thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) -> - returnSmpl (addLetBind bind floats, x) -\end{code} - - diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index fa244c4..60d5eb2 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -5,72 +5,79 @@ \begin{code} module SimplUtils ( + -- Rebuilding mkLam, mkCase, -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule, - inlineMode, + preInlineUnconditionally, postInlineUnconditionally, + activeInline, activeRule, inlineMode, -- The continuation type SimplCont(..), DupFlag(..), LetRhsFlag(..), - contIsDupable, contResultType, - countValArgs, countArgs, pushContArgs, - mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhs, contIsRhsOrArg, - getContArgs, interestingCallContext, interestingArgContext, - interestingArg, isStrictType + contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, + countValArgs, countArgs, + mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg, + interestingCallContext, interestingArgContext, + interestingArg, isStrictBndr, mkArgInfo ) where #include "HsVersions.h" import SimplEnv -import DynFlags ( SimplifierSwitch(..), SimplifierMode(..), - DynFlags, DynFlag(..), dopt ) -import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining, - opt_RulesOff ) +import DynFlags +import StaticFlags import CoreSyn -import CoreFVs ( exprFreeVars ) -import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, - etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce, - findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts, - applyTypeToArgs - ) -import Literal ( mkStringLit ) -import CoreUnfold ( smallEnoughToInline ) -import MkId ( eRROR_ID, wrapNewTypeBody ) -import Id ( Id, idType, isDataConWorkId, idOccInfo, isDictId, - isDeadBinder, idNewDemandInfo, isExportedId, mkSysLocal, - idUnfolding, idNewStrictness, idInlinePragma, idHasRules - ) -import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) +import CoreFVs +import CoreUtils +import Literal +import CoreUnfold +import MkId +import Id +import NewDemand import SimplMonad -import Name ( mkSysTvName ) -import Type ( Type, splitFunTys, dropForAlls, isStrictType, - splitTyConApp_maybe, tyConAppArgs, mkTyVarTys ) -import Coercion ( isEqPredTy - ) -import Coercion ( Coercion, mkUnsafeCoercion, coercionKind ) -import TyCon ( tyConDataCons_maybe, isClosedNewTyCon ) -import DataCon ( DataCon, dataConRepArity, dataConInstArgTys, dataConTyCon ) +import Type +import TyCon +import DataCon import VarSet -import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc, - Activation, isAlwaysActive, isActive ) -import Util ( lengthExceeds ) +import BasicTypes +import Util import Outputable \end{code} %************************************************************************ %* * -\subsection{The continuation data type} + The SimplCont type %* * %************************************************************************ +A SimplCont allows the simplifier to traverse the expression in a +zipper-like fashion. The SimplCont represents the rest of the expression, +"above" the point of interest. + +You can also think of a SimplCont as an "evaluation context", using +that term in the way it is used for operational semantics. This is the +way I usually think of it, For example you'll often see a syntax for +evaluation context looking like + C ::= [] | C e | case C of alts | C `cast` co +That's the kind of thing we are doing here, and I use that syntax in +the comments. + + +Key points: + * A SimplCont describes a *strict* context (just like + evaluation contexts do). E.g. Just [] is not a SimplCont + + * A SimplCont describes a context that *does not* bind + any variables. E.g. \x. [] is not a SimplCont + \begin{code} -data SimplCont -- Strict contexts - = Stop OutType -- Type of the result - LetRhsFlag - Bool -- True <=> There is something interesting about +data SimplCont + = Stop -- An empty context, or hole, [] + OutType -- Type of the result + LetRhsFlag + Bool -- True <=> There is something interesting about -- the context, and hence the inliner -- should be a bit keener (see interestingCallContext) -- Two cases: @@ -79,31 +86,30 @@ data SimplCont -- Strict contexts -- (b) This is an argument of a function that has RULES -- Inlining the call might allow the rule to fire - | CoerceIt OutCoercion -- The coercion simplified - SimplCont + | CoerceIt -- C `cast` co + OutCoercion -- The coercion simplified + SimplCont - | ApplyTo DupFlag - CoreExpr -- The argument - (Maybe SimplEnv) -- (Just se) => the arg is un-simplified and this is its subst-env - -- Nothing => the arg is already simplified; don't repeatedly simplify it! - SimplCont -- and its environment + | ApplyTo -- C arg + DupFlag + InExpr SimplEnv -- The argument and its static env + SimplCont - | Select DupFlag - InId [InAlt] SimplEnv -- The case binder, alts, and subst-env - SimplCont + | Select -- case C of alts + DupFlag + InId [InAlt] SimplEnv -- The case binder, alts, and subst-env + SimplCont - | ArgOf LetRhsFlag -- An arbitrary strict context: the argument - -- of a strict function, or a primitive-arg fn - -- or a PrimOp - -- No DupFlag, because we never duplicate it - OutType -- arg_ty: type of the argument itself - OutType -- cont_ty: the type of the expression being sought by the context - -- f (error "foo") ==> coerce t (error "foo") - -- when f is strict - -- We need to know the type t, to which to coerce. + -- The two strict forms have no DupFlag, because we never duplicate them + | StrictBind -- (\x* \xs. e) C + InId [InBndr] -- let x* = [] in e + InExpr SimplEnv -- is a special case + SimplCont - (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result - -- The result expression in the OutExprStuff has type cont_ty + | StrictArg -- e C + OutExpr OutType -- e and its type + (Bool,[Bool]) -- Whether the function at the head of e has rules, + SimplCont -- plus strictness flags for further args data LetRhsFlag = AnArg -- It's just an argument not a let RHS | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas) @@ -115,9 +121,10 @@ instance Outputable LetRhsFlag where instance Outputable SimplCont where ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont - ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...") + ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont + ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ - (nest 4 (ppr alts)) $$ ppr cont + (nest 4 (ppr alts $$ ppr (seIdSubst se))) $$ ppr cont ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont data DupFlag = OkToDup | NoDup @@ -138,13 +145,9 @@ mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules) mkRhsStop :: OutType -> SimplCont mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty) -contIsRhs :: SimplCont -> Bool -contIsRhs (Stop _ AnRhs _) = True -contIsRhs (ArgOf AnRhs _ _ _) = True -contIsRhs other = False - contIsRhsOrArg (Stop _ _ _) = True -contIsRhsOrArg (ArgOf _ _ _ _) = True +contIsRhsOrArg (StrictBind {}) = True +contIsRhsOrArg (StrictArg {}) = True contIsRhsOrArg other = False ------------------- @@ -156,28 +159,20 @@ contIsDupable (CoerceIt _ cont) = contIsDupable cont contIsDupable other = False ------------------- -discardableCont :: SimplCont -> Bool -discardableCont (Stop _ _ _) = False -discardableCont (CoerceIt _ cont) = discardableCont cont -discardableCont other = True - -discardCont :: Type -- The type expected - -> SimplCont -- A continuation, expecting the previous type - -> SimplCont -- Replace the continuation with a suitable coerce -discardCont from_ty cont = case cont of - Stop to_ty is_rhs _ -> cont - other -> CoerceIt co (mkBoringStop to_ty) - where - co = mkUnsafeCoercion from_ty to_ty - to_ty = contResultType cont +contIsTrivial :: SimplCont -> Bool +contIsTrivial (Stop _ _ _) = True +contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont +contIsTrivial (CoerceIt _ cont) = contIsTrivial cont +contIsTrivial other = False ------------------- contResultType :: SimplCont -> OutType -contResultType (Stop to_ty _ _) = to_ty -contResultType (ArgOf _ _ to_ty _) = to_ty -contResultType (ApplyTo _ _ _ cont) = contResultType cont -contResultType (CoerceIt _ cont) = contResultType cont -contResultType (Select _ _ _ _ cont) = contResultType cont +contResultType (Stop to_ty _ _) = to_ty +contResultType (StrictArg _ _ _ cont) = contResultType cont +contResultType (StrictBind _ _ _ _ cont) = contResultType cont +contResultType (ApplyTo _ _ _ cont) = contResultType cont +contResultType (CoerceIt _ cont) = contResultType cont +contResultType (Select _ _ _ _ cont) = contResultType cont ------------------- countValArgs :: SimplCont -> Int @@ -189,103 +184,21 @@ countArgs :: SimplCont -> Int countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont countArgs other = 0 -------------------- -pushContArgs ::[OutArg] -> SimplCont -> SimplCont --- Pushes args with the specified environment -pushContArgs [] cont = cont -pushContArgs (arg : args) cont = ApplyTo NoDup arg Nothing (pushContArgs args cont) +contArgs :: SimplCont -> ([OutExpr], SimplCont) +-- Uses substitution to turn each arg into an OutExpr +contArgs cont = go [] cont + where + go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont + go args cont = (reverse args, cont) + +dropArgs :: Int -> SimplCont -> SimplCont +dropArgs 0 cont = cont +dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont +dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other) \end{code} \begin{code} -getContArgs :: SwitchChecker - -> OutId -> SimplCont - -> ([(InExpr, Maybe SimplEnv, Bool)], -- Arguments; the Bool is true for strict args - SimplCont) -- Remaining continuation --- getContArgs id k = (args, k', inl) --- args are the leading ApplyTo items in k --- (i.e. outermost comes first) --- augmented with demand info from the functionn -getContArgs chkr fun orig_cont - = let - -- Ignore strictness info if the no-case-of-case - -- flag is on. Strictness changes evaluation order - -- and that can change full laziness - stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts - | otherwise = computed_stricts - in - go [] stricts orig_cont - where - ---------------------------- - - -- Type argument - go acc ss (ApplyTo _ arg@(Type _) se cont) - = go ((arg,se,False) : acc) ss cont - -- NB: don't bother to instantiate the function type - - -- Value argument - go acc (s:ss) (ApplyTo _ arg se cont) - = go ((arg,se,s) : acc) ss cont - - -- We're run out of arguments, or else we've run out of demands - -- The latter only happens if the result is guaranteed bottom - -- This is the case for - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - - go acc ss cont - | null ss && discardableCont cont = (args, discardCont hole_ty cont) - | otherwise = (args, cont) - where - args = reverse acc - hole_ty = applyTypeToArgs (Var fun) (idType fun) - [substExpr_mb se arg | (arg,se,_) <- args] - substExpr_mb Nothing arg = arg - substExpr_mb (Just se) arg = substExpr se arg - - ---------------------------- - vanilla_stricts, computed_stricts :: [Bool] - vanilla_stricts = repeat False - computed_stricts = zipWith (||) fun_stricts arg_stricts - - ---------------------------- - (val_arg_tys, res_ty) = splitFunTys (dropForAlls (idType fun)) - arg_stricts = map isStrictType val_arg_tys ++ repeat False - -- These argument types are used as a cheap and cheerful way to find - -- unboxed arguments, which must be strict. But it's an InType - -- and so there might be a type variable where we expect a function - -- type (the substitution hasn't happened yet). And we don't bother - -- doing the type applications for a polymorphic function. - -- Hence the splitFunTys*IgnoringForAlls* - - ---------------------------- - -- If fun_stricts is finite, it means the function returns bottom - -- after that number of value args have been consumed - -- Otherwise it's infinite, extended with False - fun_stricts - = case splitStrictSig (idNewStrictness fun) of - (demands, result_info) - | not (demands `lengthExceeds` countValArgs orig_cont) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok (see SimplUtils.analyseCont) - if isBotRes result_info then - map isStrictDmd demands -- Finite => result is bottom - else - map isStrictDmd demands ++ vanilla_stricts - - other -> vanilla_stricts -- Not enough args, or no strictness - -------------------- interestingArg :: OutExpr -> Bool -- An argument is interesting if it has *some* structure -- We are here trying to avoid unfolding a function that @@ -310,6 +223,7 @@ interestingArg other = True -- that x is not interesting (assuming y has no unfolding) \end{code} + Comment about interestingCallContext ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to avoid inlining an expression where there can't possibly be @@ -395,7 +309,8 @@ interestingCallContext some_args some_val_args cont -- Perhaps True is a bit over-keen, but I've -- seen (coerce f) x, where f has an INLINE prag, -- So we have to give some motivaiton for inlining it - interesting (ArgOf {}) = some_val_args + interesting (StrictArg {}) = some_val_args + interesting (StrictBind {}) = some_val_args -- ?? interesting (Stop ty _ interesting) = some_val_args && interesting interesting (CoerceIt _ cont) = interesting cont -- If this call is the arg of a strict function, the context @@ -415,6 +330,41 @@ interestingCallContext some_args some_val_args cont ------------------- +mkArgInfo :: Id + -> Int -- Number of value args + -> SimplCont -- Context of the cal + -> (Bool, [Bool]) -- Arg info +-- The arg info consists of +-- * A Bool indicating if the function has rules (recursively) +-- * A [Bool] indicating strictness for each arg +-- The [Bool] is usually infinite, but if it is finite it +-- guarantees that the function diverges after being given +-- that number of args + +mkArgInfo fun n_val_args call_cont + = (interestingArgContext fun call_cont, fun_stricts) + where + vanilla_stricts, fun_stricts :: [Bool] + vanilla_stricts = repeat False + + fun_stricts + = case splitStrictSig (idNewStrictness fun) of + (demands, result_info) + | not (demands `lengthExceeds` n_val_args) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so its ok (see SimplUtils.analyseCont) + if isBotRes result_info then + map isStrictDmd demands -- Finite => result is bottom + else + map isStrictDmd demands ++ vanilla_stricts + + other -> vanilla_stricts -- Not enough args, or no strictness + interestingArgContext :: Id -> SimplCont -> Bool -- If the argument has form (f x y), where x,y are boring, -- and f is marked INLINE, then we don't want to inline f. @@ -436,7 +386,8 @@ interestingArgContext fn cont where go (Select {}) = False go (ApplyTo {}) = False - go (ArgOf {}) = True + go (StrictArg {}) = True + go (StrictBind {}) = False -- ?? go (CoerceIt _ c) = go c go (Stop _ _ interesting) = interesting @@ -737,7 +688,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding -- True -> case x of ... -- False -> case x of ... -- I'm not sure how important this is in practice - OneOcc in_lam one_br int_cxt -- OneOcc => no work-duplication issue + OneOcc in_lam one_br int_cxt -- OneOcc => no code-duplication issue -> smallEnoughToInline unfolding -- Small enough to dup -- ToDo: consider discount on smallEnoughToInline if int_cxt is true -- @@ -829,36 +780,38 @@ activeRule env %************************************************************************ %* * -\subsection{Rebuilding a lambda} + Rebuilding a lambda %* * %************************************************************************ \begin{code} -mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr +mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr +-- mkLam tries three things +-- a) eta reduction, if that gives a trivial expression +-- b) eta expansion [only if there are some value lambdas] + +mkLam bndrs body + = do { dflags <- getDOptsSmpl + ; mkLam' dflags bndrs body } + where + mkLam' dflags bndrs body + | dopt Opt_DoEtaReduction dflags, + Just etad_lam <- tryEtaReduce bndrs body + = do { tick (EtaReduction (head bndrs)) + ; return etad_lam } + + | dopt Opt_DoLambdaEtaExpansion dflags, + any isRuntimeVar bndrs + = do { body' <- tryEtaExpansion dflags body + ; return (mkLams bndrs body') } + + | otherwise + = returnSmpl (mkLams bndrs body) \end{code} -Try three things - a) eta reduction, if that gives a trivial expression - b) eta expansion [only if there are some value lambdas] - c) floating lets out through big lambdas - [only if all tyvar lambdas, and only if this lambda - is the RHS of a let] - -\begin{code} -mkLam env bndrs body cont - = getDOptsSmpl `thenSmpl` \dflags -> - mkLam' dflags env bndrs body cont - where - mkLam' dflags env bndrs body cont - | dopt Opt_DoEtaReduction dflags, - Just etad_lam <- tryEtaReduce bndrs body - = tick (EtaReduction (head bndrs)) `thenSmpl_` - returnSmpl (emptyFloats env, etad_lam) - - | dopt Opt_DoLambdaEtaExpansion dflags, - any isRuntimeVar bndrs - = tryEtaExpansion dflags body `thenSmpl` \ body' -> - returnSmpl (emptyFloats env, mkLams bndrs body') +-- c) floating lets out through big lambdas +-- [only if all tyvar lambdas, and only if this lambda +-- is the RHS of a let] {- Sept 01: I'm experimenting with getting the full laziness pass to float out past big lambdsa @@ -871,10 +824,6 @@ mkLam env bndrs body cont returnSmpl (floats, mkLams bndrs body') -} - | otherwise - = returnSmpl (emptyFloats env, mkLams bndrs body) -\end{code} - %************************************************************************ %* * @@ -888,7 +837,7 @@ We don't want to remove extra lambdas unless we are going to avoid allocating this thing altogether \begin{code} -tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr +tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr tryEtaReduce bndrs body -- We don't use CoreUtils.etaReduce, because we can be more -- efficient here: diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index b3e6bf7..1be1ae3 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -12,57 +12,30 @@ import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad +import Type hiding ( substTy, extendTvSubst ) import SimplEnv -import SimplUtils ( mkCase, mkLam, - SimplCont(..), DupFlag(..), LetRhsFlag(..), - mkRhsStop, mkBoringStop, mkLazyArgStop, pushContArgs, - contResultType, countArgs, contIsDupable, contIsRhsOrArg, - getContArgs, interestingCallContext, interestingArg, isStrictType, - preInlineUnconditionally, postInlineUnconditionally, - interestingArgContext, inlineMode, activeInline, activeRule - ) -import Id ( Id, idType, idInfo, idArity, isDataConWorkId, - idUnfolding, setIdUnfolding, isDeadBinder, - idNewDemandInfo, setIdInfo, - setIdOccInfo, zapLamIdInfo, setOneShotLambda - ) -import IdInfo ( OccInfo(..), setArityInfo, zapDemandInfo, - setUnfoldingInfo, occInfo - ) -import NewDemand ( isStrictDmd ) +import SimplUtils +import Id +import IdInfo +import Coercion import TcGadt ( dataConCanMatch ) import DataCon ( dataConTyCon, dataConRepStrictness ) import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe ) import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkUnfolding, callSiteInline ) -import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, - exprIsConApp_maybe, mkPiTypes, findAlt, - exprType, exprIsHNF, findDefault, mergeAlts, - exprOkForSpeculation, exprArity, - mkCoerce, mkSCC, mkInlineMe, applyTypeToArg, - dataConRepInstPat - ) +import CoreUtils import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) -import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy, - coreEqType, splitTyConApp_maybe, - isTyVarTy, isFunTy, tcEqType - ) -import Coercion ( Coercion, coercionKind, - mkTransCoercion, mkSymCoercion, splitCoercionKind_maybe, decomposeCo ) -import VarEnv ( elemVarEnv, emptyVarEnv ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRec, isNonRuleLoopBreaker - ) -import OrdList + RecFlag(..), isNonRuleLoopBreaker ) import List ( nub ) import Maybes ( orElse ) import Outputable -import Util ( notNull, filterOut ) +import Util \end{code} @@ -148,17 +121,17 @@ simplLazyBind: [binder already simplified, RHS not] - simplify rhs - mkAtomicArgs - float if exposes constructor or PAP - - completeLazyBind + - completeBind completeNonRecX: [binder and rhs both simplified] - if the the thing needs case binding (unlifted and not ok-for-spec) build a Case else - completeLazyBind + completeBind addFloats -completeLazyBind: [given a simplified RHS] +completeBind: [given a simplified RHS] [used for both rec and non-rec bindings, top level and not] - try PostInlineUnconditionally - add unfolding [this is the only place we add an unfolding] @@ -229,169 +202,31 @@ expansion at a let RHS can concentrate solely on the PAP case. simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] simplTopBinds env binds - = -- Put all the top-level binders into scope at the start - -- so that if a transformation rule has unexpectedly brought - -- anything into scope, then we don't get a complaint about that. - -- It's rather as if the top-level binders were imported. - simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> - simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> - freeTick SimplifierDone `thenSmpl_` - returnSmpl (floatBinds floats) + = do { -- Put all the top-level binders into scope at the start + -- so that if a transformation rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + ; env <- simplRecBndrs env (bindersOfBinds binds) + ; dflags <- getDOptsSmpl + ; let dump_flag = dopt Opt_D_dump_inlinings dflags + ; env' <- simpl_binds dump_flag env binds + ; freeTick SimplifierDone + ; return (getFloats env') } where -- We need to track the zapped top-level binders, because -- they should have their fragile IdInfo zapped (notably occurrence info) -- That's why we run down binds and bndrs' simultaneously. - simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ()) - simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ()) - simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) -> - addFloats env floats $ \env -> - simpl_binds env binds (drop_bs bind bs) - - drop_bs (NonRec _ _) (_ : bs) = bs - drop_bs (Rec prs) bs = drop (length prs) bs - - simpl_bind env bind bs - = getDOptsSmpl `thenSmpl` \ dflags -> - if dopt Opt_D_dump_inlinings dflags then - pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs - else - simpl_bind1 env bind bs - - simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r - simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' -\end{code} - - -%************************************************************************ -%* * -\subsection{simplNonRec} -%* * -%************************************************************************ - -simplNonRecBind is used for - * non-top-level non-recursive lets in expressions - * beta reduction - -It takes - * An unsimplified (binder, rhs) pair - * The env for the RHS. It may not be the same as the - current env because the bind might occur via (\x.E) arg - -It uses the CPS form because the binding might be strict, in which -case we might discard the continuation: - let x* = error "foo" in (...x...) - -It needs to turn unlifted bindings into a @case@. They can arise -from, say: (\x -> e) (4# + 3#) - -\begin{code} -simplNonRecBind :: SimplEnv - -> InId -- Binder - -> InExpr -> SimplEnv -- Arg, with its subst-env - -> OutType -- Type of thing computed by the context - -> (SimplEnv -> SimplM FloatsWithExpr) -- The body - -> SimplM FloatsWithExpr -#ifdef DEBUG -simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside - | isTyVar bndr - = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs) -#endif - -simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside - = simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside - -simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside - | preInlineUnconditionally env NotTopLevel bndr rhs - = tick (PreInlineUnconditionally bndr) `thenSmpl_` - thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs)) - - | isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let - = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence info in the substitution - simplNonRecBndr env bndr `thenSmpl` \ (env, bndr1) -> - simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 -> - - -- Now complete the binding and simplify the body - let - (env2,bndr2) = addLetIdInfo env1 bndr bndr1 - in - completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside - - | otherwise -- Normal, lazy case - = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence info in the substitution - simplNonRecBndr env bndr `thenSmpl` \ (env, bndr') -> - simplLazyBind env NotTopLevel NonRecursive - bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> - addFloats env floats thing_inside - - where - bndr_ty = idType bndr -\end{code} - -A specialised variant of simplNonRec used when the RHS is already simplified, notably -in knownCon. It uses case-binding where necessary. + simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv + simpl_binds dump env [] = return env + simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $ + simpl_bind env bind + ; simpl_binds dump env' binds } -\begin{code} -simplNonRecX :: SimplEnv - -> InId -- Old binder - -> OutExpr -- Simplified RHS - -> (SimplEnv -> SimplM FloatsWithExpr) - -> SimplM FloatsWithExpr - -simplNonRecX env bndr new_rhs thing_inside - = do { (env, bndr') <- simplBinder env bndr - ; completeNonRecX env False {- Non-strict; pessimistic -} - bndr bndr' new_rhs thing_inside } - - -completeNonRecX :: SimplEnv - -> Bool -- Strict binding - -> InId -- Old binder - -> OutId -- New binder - -> OutExpr -- Simplified RHS - -> (SimplEnv -> SimplM FloatsWithExpr) - -> SimplM FloatsWithExpr - -completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside - | needsCaseBinding (idType new_bndr) new_rhs - -- Make this test *before* the preInlineUnconditionally - -- Consider case I# (quotInt# x y) of - -- I# v -> let w = J# v in ... - -- If we gaily inline (quotInt# x y) for v, we end up building an - -- extra thunk: - -- let w = J# (quotInt# x y) in ... - -- because quotInt# can fail. - = do { (floats, body) <- thing_inside env - ; let body' = wrapFloats floats body - ; return (emptyFloats env, Case new_rhs new_bndr (exprType body) - [(DEFAULT, [], body')]) } - - | otherwise - = -- Make the arguments atomic if necessary, - -- adding suitable bindings - mkAtomicArgsE env is_strict new_rhs $ \ env new_rhs -> - completeLazyBind env NotTopLevel - old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) -> - addFloats env floats thing_inside - -{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX - Doing so risks exponential behaviour, because new_rhs has been simplified once already - In the cases described by the folowing commment, postInlineUnconditionally will - catch many of the relevant cases. - -- This happens; for example, the case_bndr during case of - -- known constructor: case (a,b) of x { (p,q) -> ... } - -- Here x isn't mentioned in the RHS, so we don't want to - -- create the (dead) let-binding let x = (a,b) in ... - -- - -- Similarly, single occurrences can be inlined vigourously - -- e.g. case (f x, g y) of (a,b) -> .... - -- If a,b occur once we can avoid constructing the let binding for them. - | preInlineUnconditionally env NotTopLevel bndr new_rhs - = thing_inside (extendIdSubst env bndr (DoneEx new_rhs)) + trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind)) + trace False bind = \x -> x - -- NB: completeLazyBind uses postInlineUnconditionally; no need to do that here --} + simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r + simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs \end{code} @@ -406,21 +241,22 @@ simplRecBind is used for \begin{code} simplRecBind :: SimplEnv -> TopLevelFlag - -> [(InId, InExpr)] -> [OutId] - -> SimplM (FloatsWith SimplEnv) -simplRecBind env top_lvl pairs bndrs' - = go env pairs bndrs' `thenSmpl` \ (floats, env) -> - returnSmpl (flattenFloats floats, env) + -> [(InId, InExpr)] + -> SimplM SimplEnv +simplRecBind env top_lvl pairs + = do { env' <- go (zapFloats env) pairs + ; return (env `addRecFloats` env') } + -- addFloats adds the floats from env', + -- *and* updates env with the in-scope set from env' where - go env [] _ = returnSmpl (emptyFloats env, env) + go env [] = return env - go env ((bndr, rhs) : pairs) (bndr' : bndrs') - = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) -> - addFloats env floats (\env -> go env pairs bndrs') + go env ((bndr, rhs) : pairs) + = do { env <- simplRecOrTopPair env top_lvl bndr rhs + ; go env pairs } \end{code} - -simplRecOrTopPair is used for +simplOrTopPair is used for * recursive bindings (whether top level or not) * top-level non-recursive bindings @@ -429,32 +265,30 @@ It assumes the binder has already been simplified, but not its IdInfo. \begin{code} simplRecOrTopPair :: SimplEnv -> TopLevelFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -> InExpr -- The RHS and its environment - -> SimplM (FloatsWith SimplEnv) + -> InId -> InExpr -- Binder and rhs + -> SimplM SimplEnv -- Returns an env that includes the binding -simplRecOrTopPair env top_lvl bndr bndr' rhs +simplRecOrTopPair env top_lvl bndr rhs | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline - = tick (PreInlineUnconditionally bndr) `thenSmpl_` - returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs)) + = do { tick (PreInlineUnconditionally bndr) + ; return (extendIdSubst env bndr (mkContEx env rhs)) } | otherwise - = simplLazyBind env top_lvl Recursive bndr bndr' rhs env + = do { let bndr' = lookupRecBndr env bndr + (env', bndr'') = addLetIdInfo env bndr bndr' + ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' } -- May not actually be recursive, but it doesn't matter \end{code} simplLazyBind is used for - * recursive bindings (whether top level or not) - * top-level non-recursive bindings - * non-top-level *lazy* non-recursive bindings - -[Thus it deals with the lazy cases from simplNonRecBind, and all cases -from SimplRecOrTopBind] + * [simplRecOrTopPair] recursive bindings (whether top level or not) + * [simplRecOrTopPair] top-level non-recursive bindings + * [simplNonRecE] non-top-level *lazy* non-recursive bindings Nota bene: 1. It assumes that the binder is *already* simplified, - and is in scope, but not its IdInfo + and is in scope, and its IdInfo too, except unfolding 2. It assumes that the binder type is lifted. @@ -465,87 +299,170 @@ Nota bene: simplLazyBind :: SimplEnv -> TopLevelFlag -> RecFlag -> InId -> OutId -- Binder, both pre-and post simpl + -- The OutId has IdInfo, except arity, unfolding -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM (FloatsWith SimplEnv) + -> SimplM SimplEnv simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = let - (env1,bndr2) = addLetIdInfo env bndr bndr1 - rhs_env = setInScope rhs_se env1 - is_top_level = isTopLevel top_lvl - ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkRhsStop (idType bndr2) - in + = do { let rhs_env = rhs_se `setInScope` env + rhs_cont = mkRhsStop (idType bndr1) + -- Simplify the RHS; note the mkRhsStop, which tells -- the simplifier that this is the RHS of a let. - simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) -> + ; (rhs_env1, rhs1) <- simplExprF rhs_env rhs rhs_cont -- If any of the floats can't be floated, give up now - -- (The allLifted predicate says True for empty floats.) - if (not ok_float_unlifted && not (allLifted floats)) then - completeLazyBind env1 top_lvl bndr bndr2 - (wrapFloats floats rhs1) - else - + -- (The canFloat predicate says True for empty floats.) + ; if (not (canFloat top_lvl is_rec False rhs_env1)) + then completeBind env top_lvl bndr bndr1 + (wrapFloats rhs_env1 rhs1) + else do -- ANF-ise a constructor or PAP rhs - mkAtomicArgs ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) -> - - -- If the result is a PAP, float the floats out, else wrap them - -- By this time it's already been ANF-ised (if necessary) - if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case - completeLazyBind env1 top_lvl bndr bndr2 rhs2 - - else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then - -- WARNING: long dodgy argument coming up - -- WANTED: a better way to do this - -- - -- We can't use "exprIsCheap" instead of exprIsHNF, - -- because that causes a strictness bug. - -- x = let y* = E in case (scc y) of { T -> F; F -> T} - -- The case expression is 'cheap', but it's wrong to transform to - -- y* = E; x = case (scc y) of {...} - -- Either we must be careful not to float demanded non-values, or - -- we must use exprIsHNF for the test, which ensures that the - -- thing is non-strict. So exprIsHNF => bindings are non-strict - -- I think. The WARN below tests for this. - -- - -- We use exprIsTrivial here because we want to reveal lone variables. - -- E.g. let { x = letrec { y = E } in y } in ... - -- Here we definitely want to float the y=E defn. - -- exprIsHNF definitely isn't right for that. - -- - -- Again, the floated binding can't be strict; if it's recursive it'll - -- be non-strict; if it's non-recursive it'd be inlined. + { (rhs_env2, rhs2) <- prepareRhs rhs_env1 rhs1 + ; (env', rhs3) <- chooseRhsFloats top_lvl is_rec False env rhs_env2 rhs2 + ; completeBind env' top_lvl bndr bndr1 rhs3 } } + +chooseRhsFloats :: TopLevelFlag -> RecFlag -> Bool + -> SimplEnv -- Env for the let + -> SimplEnv -- Env for the RHS, with RHS floats in it + -> OutExpr -- ..and the RHS itself + -> SimplM (SimplEnv, OutExpr) -- New env for let, and RHS + +chooseRhsFloats top_lvl is_rec is_strict env rhs_env rhs + | not (isEmptyFloats rhs_env) -- Something to float + , canFloat top_lvl is_rec is_strict rhs_env -- ...that can float + , (isTopLevel top_lvl || exprIsCheap rhs) -- ...and we want to float + = do { tick LetFloatFromLet -- Float + ; return (addFloats env rhs_env, rhs) } -- Add the floats to the main env + | otherwise -- Don't float + = return (env, wrapFloats rhs_env rhs) -- Wrap the floats around the RHS +\end{code} + + +%************************************************************************ +%* * +\subsection{simplNonRec} +%* * +%************************************************************************ + +A specialised variant of simplNonRec used when the RHS is already simplified, +notably in knownCon. It uses case-binding where necessary. + +\begin{code} +simplNonRecX :: SimplEnv + -> InId -- Old binder + -> OutExpr -- Simplified RHS + -> SimplM SimplEnv + +simplNonRecX env bndr new_rhs + = do { (env, bndr') <- simplBinder env bndr + ; completeNonRecX env NotTopLevel NonRecursive + (isStrictBndr bndr) bndr bndr' new_rhs } + +completeNonRecX :: SimplEnv + -> TopLevelFlag -> RecFlag -> Bool + -> InId -- Old binder + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM SimplEnv + +completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs + = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs + ; (env2, rhs2) <- chooseRhsFloats top_lvl is_rec is_strict env env1 rhs1 + ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 } +\end{code} + +{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX + Doing so risks exponential behaviour, because new_rhs has been simplified once already + In the cases described by the folowing commment, postInlineUnconditionally will + catch many of the relevant cases. + -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... -- - -- Note [SCC-and-exprIsTrivial] - -- If we have - -- y = let { x* = E } in scc "foo" x - -- then we do *not* want to float out the x binding, because - -- it's strict! Fortunately, exprIsTrivial replies False to - -- (scc "foo" x). - - -- There's a subtlety here. There may be a binding (x* = e) in the - -- floats, where the '*' means 'will be demanded'. So is it safe - -- to float it out? Answer no, but it won't matter because - -- we only float if (a) arg' is a WHNF, or (b) it's going to top level - -- and so there can't be any 'will be demanded' bindings in the floats. - -- Hence the warning - WARN( not (is_top_level || not (any demanded_float (floatBinds floats))), - ppr (filter demanded_float (floatBinds floats)) ) - - tick LetFloatFromLet `thenSmpl_` ( - addFloats env1 floats $ \ env2 -> - addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> - completeLazyBind env3 top_lvl bndr bndr2 rhs2) + -- Similarly, single occurrences can be inlined vigourously + -- e.g. case (f x, g y) of (a,b) -> .... + -- If a,b occur once we can avoid constructing the let binding for them. - else - completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) + Furthermore in the case-binding case preInlineUnconditionally risks extra thunks + -- Consider case I# (quotInt# x y) of + -- I# v -> let w = J# v in ... + -- If we gaily inline (quotInt# x y) for v, we end up building an + -- extra thunk: + -- let w = J# (quotInt# x y) in ... + -- because quotInt# can fail. -#ifdef DEBUG -demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) - -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them -demanded_float (Rec _) = False -#endif + | preInlineUnconditionally env NotTopLevel bndr new_rhs + = thing_inside (extendIdSubst env bndr (DoneEx new_rhs)) +-} + +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +\begin{code} +prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Adds new floats to the env iff that allows us to return a good RHS + +prepareRhs env (Cast rhs co) -- Note [Float coersions] + = do { (env', rhs') <- makeTrivial env rhs + ; return (env', Cast rhs' co) } + +prepareRhs env rhs + | (Var fun, args) <- collectArgs rhs -- It's an application + , let n_args = valArgCount args + , n_args > 0 -- ...but not a trivial one + , isDataConWorkId fun || n_args < idArity fun -- ...and it's a constructor or PAP + = go env (Var fun) args + where + go env fun [] = return (env, fun) + go env fun (arg : args) = do { (env', arg') <- makeTrivial env arg + ; go env' (App fun arg') args } + +prepareRhs env rhs -- The default case + = return (env, rhs) +\end{code} + +Note [Float coercions] +~~~~~~~~~~~~~~~~~~~~~~ +When we find the binding + x = e `cast` co +we'd like to transform it to + x' = e + x = x `cast` co -- A trivial binding +There's a chance that e will be a constructor application or function, or something +like that, so moving the coerion to the usage site may well cancel the coersions +and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + x = T m + go 0 = 0 + go n = case x of { T m -> go (n-m) } + -- This case should optimise + + +\begin{code} +makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +makeTrivial env expr + | exprIsTrivial expr + = return (env, expr) + | otherwise -- See Note [Take care] below + = do { var <- newId FSLIT("a") (exprType expr) + ; env <- completeNonRecX env NotTopLevel NonRecursive + False var var expr + ; return (env, substExpr env (Var var)) } \end{code} @@ -555,11 +472,11 @@ demanded_float (Rec _) = False %* * %************************************************************************ -completeLazyBind - * deals only with Ids, not TyVars - * takes an already-simplified binder and RHS - * is used for both recursive and non-recursive bindings - * is used for both top-level and non-top-level bindings +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings It does the following: - tries discarding a dead binding @@ -568,31 +485,30 @@ It does the following: - add arity It does *not* attempt to do let-to-case. Why? Because it is used for - - top-level bindings (when let-to-case is impossible) - - many situations where the "rhs" is known to be a WHNF + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF (so let-to-case is inappropriate). +Nor does it do the atomic-argument thing + \begin{code} -completeLazyBind :: SimplEnv - -> TopLevelFlag -- Flag stuck into unfolding - -> InId -- Old binder - -> OutId -- New binder - -> OutExpr -- Simplified RHS - -> SimplM (FloatsWith SimplEnv) --- We return a new SimplEnv, because completeLazyBind may choose to do its work --- by extending the substitution (e.g. let x = y in ...) --- The new binding (if any) is returned as part of the floats. --- NB: the returned SimplEnv has the right SubstEnv, but you should --- (as usual) use the in-scope-env from the floats - -completeLazyBind env top_lvl old_bndr new_bndr new_rhs +completeBind :: SimplEnv + -> TopLevelFlag -- Flag stuck into unfolding + -> InId -- Old binder + -> OutId -> OutExpr -- New binder and RHS + -> SimplM SimplEnv +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt + +completeBind env top_lvl old_bndr new_bndr new_rhs | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding - = -- Drop the binding - tick (PostInlineUnconditionally old_bndr) `thenSmpl_` - -- pprTrace "Inline unconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $ - returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs)) - -- Use the substitution to make quite, quite sure that the substitution - -- will happen, since we are going to discard the binding + -- Inline and discard the binding + = do { tick (PostInlineUnconditionally old_bndr) + ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $ + return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding | otherwise = let @@ -631,7 +547,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- and hence any inner substitutions final_id `seq` -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ - returnSmpl (unitFloat env final_id new_rhs, env) + return (addNonRec env final_id new_rhs) where unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs loop_breaker = isNonRuleLoopBreaker occ_info @@ -699,26 +615,51 @@ simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty') simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr -- Simplify an expression, given a continuation simplExprC env expr cont - = simplExprF env expr cont `thenSmpl` \ (floats, expr) -> - returnSmpl (wrapFloats floats expr) - -simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr - -- Simplify an expression, returning floated binds - -simplExprF env (Var v) cont = simplVar env v cont -simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont -simplExprF env expr@(Lam _ _) cont = simplLam env expr cont -simplExprF env (Note note expr) cont = simplNote env note expr cont -simplExprF env (Cast body co) cont = simplCast env body co cont -simplExprF env (App fun arg) cont = simplExprF env fun - (ApplyTo NoDup arg (Just env) cont) + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $ + do { (env', expr') <- simplExprF (zapFloats env) expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $ + return (wrapFloats env' expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +simplExprF env e cont = -- pprTrace "simplExprF" (ppr e $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $ + simplExprF' env e cont + +simplExprF' env (Var v) cont = simplVar env v cont +simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont +simplExprF' env (Note n expr) cont = simplNote env n expr cont +simplExprF' env (Cast body co) cont = simplCast env body co cont +simplExprF' env (App fun arg) cont = simplExprF env fun $ + ApplyTo NoDup arg env cont + +simplExprF' env expr@(Lam _ _) cont + = simplLam env (map zap bndrs) body cont + -- The main issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info. + where + n_args = countArgs cont + n_params = length bndrs + (bndrs, body) = collectBinders expr + zap | n_args >= n_params = \b -> b + | otherwise = \b -> if isTyVar b then b + else zapLamIdInfo b + -- NB: we count all the args incl type args + -- so we must count all the binders (incl type lambdas) -simplExprF env (Type ty) cont +simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) - simplType env ty `thenSmpl` \ ty' -> - rebuild env (Type ty') cont + do { ty' <- simplType env ty + ; rebuild env (Type ty') cont } -simplExprF env (Case scrut bndr case_ty alts) cont +simplExprF' env (Case scrut bndr case_ty alts) cont | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -726,32 +667,29 @@ simplExprF env (Case scrut bndr case_ty alts) cont | otherwise = -- If case-of-case is off, simply simplify the case expression -- in a vanilla Stop context, and rebuild the result around it - simplExprC env scrut case_cont `thenSmpl` \ case_expr' -> - rebuild env case_expr' cont + do { case_expr' <- simplExprC env scrut case_cont + ; rebuild env case_expr' cont } where case_cont = Select NoDup bndr alts env (mkBoringStop case_ty') case_ty' = substTy env case_ty -- c.f. defn of simplExpr -simplExprF env (Let (Rec pairs) body) cont - = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down +simplExprF' env (Let (Rec pairs) body) cont + = do { env <- simplRecBndrs env (map fst pairs) + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down - simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> - addFloats env floats $ \ env -> - simplExprF env body cont - --- A non-recursive let is dealt with by simplNonRecBind -simplExprF env (Let (NonRec bndr rhs) body) cont - = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env -> - simplExprF env body cont + ; env <- simplRecBind env NotTopLevel pairs + ; simplExprF env body cont } +simplExprF' env (Let (NonRec bndr rhs) body) cont + = simplNonRecE env bndr (rhs, env) ([], body) cont --------------------------------- simplType :: SimplEnv -> InType -> SimplM OutType -- Kept monadic just so we can do the seqType simplType env ty - = seqType new_ty `seq` returnSmpl new_ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` returnSmpl new_ty where new_ty = substTy env ty \end{code} @@ -759,17 +697,44 @@ simplType env ty %************************************************************************ %* * +\subsection{The main rebuilder} +%* * +%************************************************************************ + +\begin{code} +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) +-- At this point the substitution in the SimplEnv should be irrelevant +-- only the in-scope set and floats should matter +rebuild env expr cont + = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $ + case cont of + Stop {} -> return (env, expr) + CoerceIt co cont -> rebuild env (mkCoerce co expr) cont + Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont + StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont + StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr + ; simplLam env' bs body cont } + ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg + ; rebuild env (App expr arg') cont } +\end{code} + + +%************************************************************************ +%* * \subsection{Lambdas} %* * %************************************************************************ \begin{code} -simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM FloatsWithExpr +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) simplCast env body co cont - = let + = do { co' <- simplType env co + ; simplExprF env body (addCoerce co' cont) } + where addCoerce co cont | (s1, k1) <- coercionKind co - , s1 `tcEqType` k1 = cont + , s1 `coreEqType` k1 = cont addCoerce co1 (CoerceIt co2 cont) | (s1, k1) <- coercionKind co1 , (l1, t1) <- coercionKind co2 @@ -802,24 +767,19 @@ simplCast env body co cont -- with the InExpr in the argument, so we simply substitute -- to make it all consistent. It's a bit messy. -- But it isn't a common case. - = result + = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont) where -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and -- t2 :=: s2 with left and right on the curried form: -- (->) t1 t2 :=: (->) s1 s2 [co1, co2] = decomposeCo 2 co new_arg = mkCoerce (mkSymCoercion co1) arg' - arg' = case arg_se of - Nothing -> arg - Just arg_se -> substExpr (setInScope arg_se env) arg - result = ApplyTo dup new_arg (Just $ zapSubstEnv env) - (addCoerce co2 cont) + arg' = substExpr arg_se arg + addCoerce co cont = CoerceIt co cont - in - simplType env co `thenSmpl` \ co' -> - simplExprF env body (addCoerce co' cont) \end{code} + %************************************************************************ %* * \subsection{Lambdas} @@ -827,57 +787,64 @@ simplCast env body co cont %************************************************************************ \begin{code} -simplLam env fun cont - = go env fun cont - where - zap_it = mkLamBndrZapper fun (countArgs cont) - cont_ty = contResultType cont +simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +simplLam env [] body cont = simplExprF env body cont -- Type-beta reduction - go env (Lam bndr body) (ApplyTo _ (Type ty_arg) mb_arg_se body_cont) - = ASSERT( isTyVar bndr ) - do { tick (BetaReduction bndr) - ; ty_arg' <- case mb_arg_se of - Just arg_se -> simplType (setInScope arg_se env) ty_arg - Nothing -> return ty_arg - ; go (extendTvSubst env bndr ty_arg') body body_cont } +simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont) + = ASSERT( isTyVar bndr ) + do { tick (BetaReduction bndr) + ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg + ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } -- Ordinary beta reduction - go env (Lam bndr body) cont@(ApplyTo _ arg (Just arg_se) body_cont) - = do { tick (BetaReduction bndr) - ; simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env -> - go env body body_cont } - - go env (Lam bndr body) cont@(ApplyTo _ arg Nothing body_cont) - = do { tick (BetaReduction bndr) - ; simplNonRecX env (zap_it bndr) arg $ \ env -> - go env body body_cont } +simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont) + = do { tick (BetaReduction bndr) + ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } -- Not enough args, so there are real lambdas left to put in the result - go env lam@(Lam _ _) cont - = do { (env, bndrs') <- simplLamBndrs env bndrs - ; body' <- simplExpr env body - ; (floats, new_lam) <- mkLam env bndrs' body' cont - ; addFloats env floats $ \ env -> - rebuild env new_lam cont } - where - (bndrs,body) = collectBinders lam - - -- Exactly enough args - go env expr cont = simplExprF env expr cont - -mkLamBndrZapper :: CoreExpr -- Function - -> Int -- Number of args supplied, *including* type args - -> Id -> Id -- Use this to zap the binders -mkLamBndrZapper fun n_args - | n_args >= n_params fun = \b -> b -- Enough args - | otherwise = \b -> zapLamIdInfo b - where - -- NB: we count all the args incl type args - -- so we must count all the binders (incl type lambdas) - n_params (Note _ e) = n_params e - n_params (Lam b e) = 1 + n_params e - n_params other = 0::Int +simplLam env bndrs body cont + = do { (env, bndrs') <- simplLamBndrs env bndrs + ; body' <- simplExpr env body + ; new_lam <- mkLam bndrs' body' + ; rebuild env new_lam cont } + +------------------ +simplNonRecE :: SimplEnv + -> InId -- The binder + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> ([InId], InExpr) -- Body of the let/lambda + -- \xs.e + -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +-- simplNonRecE is used for +-- * non-top-level non-recursive lets in expressions +-- * beta reduction +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process +-- +-- The "body" of the binding comes as a pair of ([InId],InExpr) +-- representing a lambda; so we recurse back to simplLam +-- Why? Because of the binder-occ-info-zapping done before +-- the call to simplLam in simplExprF (Lam ...) + +simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont + | preInlineUnconditionally env NotTopLevel bndr rhs + = do { tick (PreInlineUnconditionally bndr) + ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } + + | isStrictBndr bndr + = do { simplExprF (rhs_se `setFloats` env) rhs + (StrictBind bndr bndrs body env cont) } + + | otherwise + = do { (env, bndr') <- simplBinder env bndr + ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se + ; simplLam env bndrs body cont } \end{code} @@ -888,20 +855,18 @@ mkLamBndrZapper fun n_args %************************************************************************ \begin{code} - - --- Hack: we only distinguish subsumed cost centre stacks for the purposes of --- inlining. All other CCCSs are mapped to currentCCS. +-- Hack alert: we only distinguish subsumed cost centre stacks for the +-- purposes of inlining. All other CCCSs are mapped to currentCCS. simplNote env (SCC cc) e cont - = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' -> - rebuild env (mkSCC cc e') cont + = do { e' <- simplExpr (setEnclosingCC env currentCCS) e + ; rebuild env (mkSCC cc e') cont } -- See notes with SimplMonad.inlineMode simplNote env InlineMe e cont | contIsRhsOrArg cont -- Totally boring continuation; see notes above - = -- Don't inline inside an INLINE expression - simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' -> - rebuild env (mkInlineMe e') cont + = do { -- Don't inline inside an INLINE expression + e' <- simplExpr (setMode inlineMode env) e + ; rebuild env (mkInlineMe e') cont } | otherwise -- Dissolve the InlineMe note if there's -- an interesting context of any kind to combine with @@ -909,16 +874,16 @@ simplNote env InlineMe e cont = simplExprF env e cont simplNote env (CoreNote s) e cont - = simplExpr env e `thenSmpl` \ e' -> - rebuild env (Note (CoreNote s) e') cont + = do { e' <- simplExpr env e + ; rebuild env (Note (CoreNote s) e') cont } simplNote env note@(TickBox {}) e cont - = simplExpr env e `thenSmpl` \ e' -> - rebuild env (Note note e') cont + = do { e' <- simplExpr env e + ; rebuild env (Note note e') cont } simplNote env note@(BinaryTickBox {}) e cont - = simplExpr env e `thenSmpl` \ e' -> - rebuild env (Note note e') cont + = do { e' <- simplExpr env e + ; rebuild env (Note note e') cont } \end{code} @@ -948,26 +913,20 @@ simplVar env var cont -- Dealing with a call site completeCall env var cont - = -- Simplify the arguments - getDOptsSmpl `thenSmpl` \ dflags -> - let - chkr = getSwitchChecker env - (args, call_cont) = getContArgs chkr var cont - fn_ty = idType var - in - simplifyArgs env fn_ty (interestingArgContext var call_cont) args - (contResultType call_cont) $ \ env args -> - - -- Next, look for rules or specialisations that match - -- - -- It's important to simplify the args first, because the rule-matcher - -- doesn't do substitution as it goes. We don't want to use subst_args - -- (defined in the 'where') because that throws away useful occurrence info, - -- and perhaps-very-important specialisations. - -- - -- Some functions have specialisations *and* are strict; in this case, - -- we don't want to inline the wrapper of the non-specialised thing; better + = do { dflags <- getDOptsSmpl + ; let (args,call_cont) = contArgs cont + -- The args are OutExprs, obtained by *lazily* substituting + -- in the args found in cont. These args are only examined + -- to limited depth (unless a rule fires). But we must do + -- the substitution; rule matching on un-simplified args would + -- be bogus + + ------------- First try rules ---------------- + -- Do this before trying inlining. Some functions have + -- rules *and* are strict; in this case, we don't want to + -- inline the wrapper of the non-specialised thing; better -- to call the specialised thing instead. + -- -- We used to use the black-listing mechanism to ensure that inlining of -- the wrapper didn't occur for things that have specialisations till a -- later phase, so but now we just try RULES first @@ -983,354 +942,135 @@ completeCall env var cont -- is recursive, and hence a loop breaker: -- foldr k z (build g) = g k z -- So it's up to the programmer: rules can cause divergence - - let - in_scope = getInScope env - rules = getRules env - maybe_rule = case activeRule env of - Nothing -> Nothing -- No rules apply - Just act_fn -> lookupRule act_fn in_scope rules var args - in - case maybe_rule of { - Just (rule_name, rule_rhs) -> - tick (RuleFired rule_name) `thenSmpl_` + ; let in_scope = getInScope env + rules = getRules env + maybe_rule = case activeRule env of + Nothing -> Nothing -- No rules apply + Just act_fn -> lookupRule act_fn in_scope + rules var args + ; case maybe_rule of { + Just (rule, rule_rhs) -> + tick (RuleFired (ru_name rule)) `thenSmpl_` (if dopt Opt_D_dump_inlinings dflags then pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ftext rule_name, + text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> ppr var <+> sep (map pprParendExpr args), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) else id) $ - simplExprF env rule_rhs call_cont ; + simplExprF env rule_rhs (dropArgs (ruleArity rule) cont) + -- The ruleArity says how many args the rule consumed - Nothing -> -- No rules - - -- Next, look for an inlining - let - arg_infos = [ interestingArg arg | arg <- args, isValArg arg] - interesting_cont = interestingCallContext (notNull args) - (notNull arg_infos) - call_cont - active_inline = activeInline env var - maybe_inline = callSiteInline dflags active_inline + ; Nothing -> do -- No rules + + ------------- Next try inlining ---------------- + { let arg_infos = [interestingArg arg | arg <- args, isValArg arg] + n_val_args = length arg_infos + interesting_cont = interestingCallContext (notNull args) + (notNull arg_infos) + call_cont + active_inline = activeInline env var + maybe_inline = callSiteInline dflags active_inline var arg_infos interesting_cont - in - case maybe_inline of { - Just unfolding -- There is an inlining! - -> tick (UnfoldingDone var) `thenSmpl_` - (if dopt Opt_D_dump_inlinings dflags then - pprTrace "Inlining done" (vcat [ - text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " $$ nest 2 (ppr unfolding), - text "Cont: " <+> ppr call_cont]) - else - id) $ - simplExprF env unfolding (pushContArgs args call_cont) - - ; - Nothing -> -- No inlining! - - -- Done - rebuild env (mkApps (Var var) args) call_cont - }} -\end{code} - -%************************************************************************ -%* * -\subsection{Arguments} -%* * -%************************************************************************ - -\begin{code} ---------------------------------------------------------- --- Simplifying the arguments of a call - -simplifyArgs :: SimplEnv - -> OutType -- Type of the function - -> Bool -- True if the fn has RULES - -> [(InExpr, Maybe SimplEnv, Bool)] -- Details of the arguments - -> OutType -- Type of the continuation - -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr) - -> SimplM FloatsWithExpr - --- [CPS-like because of strict arguments] - --- Simplify the arguments to a call. --- This part of the simplifier may break the no-shadowing invariant --- Consider --- f (...(\a -> e)...) (case y of (a,b) -> e') --- where f is strict in its second arg --- If we simplify the innermost one first we get (...(\a -> e)...) --- Simplifying the second arg makes us float the case out, so we end up with --- case y of (a,b) -> f (...(\a -> e)...) e' --- So the output does not have the no-shadowing invariant. However, there is --- no danger of getting name-capture, because when the first arg was simplified --- we used an in-scope set that at least mentioned all the variables free in its --- static environment, and that is enough. --- --- We can't just do innermost first, or we'd end up with a dual problem: --- case x of (a,b) -> f e (...(\a -> e')...) --- --- I spent hours trying to recover the no-shadowing invariant, but I just could --- not think of an elegant way to do it. The simplifier is already knee-deep in --- continuations. We have to keep the right in-scope set around; AND we have --- to get the effect that finding (error "foo") in a strict arg position will --- discard the entire application and replace it with (error "foo"). Getting --- all this at once is TOO HARD! - -simplifyArgs env fn_ty has_rules args cont_ty thing_inside - = go env fn_ty args thing_inside - where - go env fn_ty [] thing_inside = thing_inside env [] - go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty has_rules arg cont_ty $ \ env arg' -> - go env (applyTypeToArg fn_ty arg') args $ \ env args' -> - thing_inside env (arg':args') - -simplifyArg env fn_ty has_rules (arg, Nothing, _) cont_ty thing_inside - = thing_inside env arg -- Already simplified - -simplifyArg env fn_ty has_rules (Type ty_arg, Just se, _) cont_ty thing_inside - = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg -> - thing_inside env (Type new_ty_arg) - -simplifyArg env fn_ty has_rules (val_arg, Just arg_se, is_strict) cont_ty thing_inside - | is_strict - = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside - - | otherwise -- Lazy argument - -- DO NOT float anything outside, hence simplExprC - -- There is no benefit (unlike in a let-binding), and we'd - -- have to be very careful about bogus strictness through - -- floating a demanded let. - = simplExprC (setInScope arg_se env) val_arg - (mkLazyArgStop arg_ty has_rules) `thenSmpl` \ arg1 -> - thing_inside env arg1 - where - arg_ty = funArgTy fn_ty - - -simplStrictArg :: LetRhsFlag - -> SimplEnv -- The env of the call - -> InExpr -> SimplEnv -- The arg plus its env - -> OutType -- arg_ty: type of the argument - -> OutType -- cont_ty: Type of thing computed by the context - -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) - -- Takes an expression of type rhs_ty, - -- returns an expression of type cont_ty - -- The env passed to this continuation is the - -- env of the call, plus any new in-scope variables - -> SimplM FloatsWithExpr -- An expression of type cont_ty - -simplStrictArg is_rhs call_env arg arg_env arg_ty cont_ty thing_inside - = simplExprF (setInScope arg_env call_env) arg - (ArgOf is_rhs arg_ty cont_ty (\ new_env -> thing_inside (setInScope call_env new_env))) - -- Notice the way we use arg_env (augmented with in-scope vars from call_env) - -- to simplify the argument - -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation -\end{code} - - -%************************************************************************ -%* * -\subsection{mkAtomicArgs} -%* * -%************************************************************************ - -mkAtomicArgs takes a putative RHS, checks whether it's a PAP or -constructor application and, if so, converts it to ANF, so that the -resulting thing can be inlined more easily. Thus - x = (f a, g b) -becomes - t1 = f a - t2 = g b - x = (t1,t2) - -There are three sorts of binding context, specified by the two -boolean arguments - -Strict - OK-unlifted - -N N Top-level or recursive Only bind args of lifted type - -N Y Non-top-level and non-recursive, Bind args of lifted type, or - but lazy unlifted-and-ok-for-speculation - -Y Y Non-top-level, non-recursive, Bind all args - and strict (demanded) - -For example, given - - x = MkC (y div# z) - -there is no point in transforming to - - x = case (y div# z) of r -> MkC r - -because the (y div# z) can't float out of the let. But if it was -a *strict* let, then it would be a good thing to do. Hence the -context information. - -Note [Float coercions] -~~~~~~~~~~~~~~~~~~~~~~ -When we find the binding - x = e `cast` co -we'd like to transform it to - x' = e - x = x `cast` co -- A trivial binding -There's a chance that e will be a constructor application or function, or something -like that, so moving the coerion to the usage site may well cancel the coersions -and lead to further optimisation. Example: - - data family T a :: * - data instance T Int = T Int - - foo :: Int -> Int -> Int - foo m n = ... - where - x = T m - go 0 = 0 - go n = case x of { T m -> go (n-m) } - -- This case should optimise - -\begin{code} -mkAtomicArgsE :: SimplEnv - -> Bool -- A strict binding - -> OutExpr -- The rhs - -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) - -- Consumer for the simpler rhs - -> SimplM FloatsWithExpr - -mkAtomicArgsE env is_strict (Cast rhs co) thing_inside - | not (exprIsTrivial rhs) - -- Note [Float coersions] - -- See also Note [Take care] below - = do { id <- newId FSLIT("a") (exprType rhs) - ; completeNonRecX env False id id rhs $ \ env -> - thing_inside env (Cast (substExpr env (Var id)) co) } - -mkAtomicArgsE env is_strict rhs thing_inside - | (Var fun, args) <- collectArgs rhs, -- It's an application - isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP - = go env (Var fun) args - - | otherwise = thing_inside env rhs - - where - go env fun [] = thing_inside env fun - - go env fun (arg : args) - | exprIsTrivial arg -- Easy case - || no_float_arg -- Can't make it atomic - = go env (App fun arg) args - - | otherwise - = do { arg_id <- newId FSLIT("a") arg_ty - ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env -> - go env (App fun (substExpr env (Var arg_id))) args } - -- Note [Take care]: - -- If completeNonRecX was to do a postInlineUnconditionally - -- (undoing the effect of introducing the let-binding), we'd find arg_id had - -- no binding; hence the substExpr. This happens if we see - -- C (D x `cast` g) - -- Then we start by making a variable a1, thus - -- let a1 = D x `cast` g in C a1 - -- But then we deal with the rhs of a1, getting - -- let a2 = D x, a1 = a1 `cast` g in C a1 - -- And now the preInlineUnconditionally kicks in, and we substitute for a1 - - where - arg_ty = exprType arg - no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg) - - --- Old code: consider rewriting to be more like mkAtomicArgsE - -mkAtomicArgs :: Bool -- OK to float unlifted args - -> OutExpr - -> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include - OutExpr) -- things that need case-binding, - -- if the strict-binding flag is on - -mkAtomicArgs ok_float_unlifted (Cast rhs co) - | not (exprIsTrivial rhs) - -- Note [Float coersions] - = do { id <- newId FSLIT("a") (exprType rhs) - ; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs - ; return (binds `snocOL` (id, rhs'), Cast (Var id) co) } - -mkAtomicArgs ok_float_unlifted rhs - | (Var fun, args) <- collectArgs rhs, -- It's an application - isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP - = go fun nilOL [] args -- Have a go - - | otherwise = bale_out -- Give up + ; case maybe_inline of { + Just unfolding -- There is an inlining! + -> do { tick (UnfoldingDone var) + ; (if dopt Opt_D_dump_inlinings dflags then + pprTrace "Inlining done" (vcat [ + text "Before:" <+> ppr var <+> sep (map pprParendExpr args), + text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr call_cont]) + else + id) + simplExprF env unfolding cont } + + ; Nothing -> -- No inlining! + + ------------- No inlining! ---------------- + -- Next, look for rules or specialisations that match + -- + rebuildCall env (Var var) (idType var) + (mkArgInfo var n_val_args call_cont) cont + }}}} +rebuildCall :: SimplEnv + -> OutExpr -> OutType -- Function and its type + -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo + -> SimplCont + -> SimplM (SimplEnv, OutExpr) +rebuildCall env fun fun_ty (has_rules, []) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see SimplUtils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do thia if there is a non-trivial + = return (env, mk_coerce fun) -- contination to discard, else we do it + where -- again and again! + cont_ty = contResultType cont + co = mkUnsafeCoercion fun_ty cont_ty + mk_coerce expr | cont_ty `coreEqType` fun_ty = fun + | otherwise = mkCoerce co fun + +rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont) + = do { ty' <- simplType (se `setInScope` env) arg_ty + ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont } + +rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont) + | str || isStrictType arg_ty -- Strict argument + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setFloats` env) arg + (StrictArg fun fun_ty (has_rules, strs) cont) + -- Note [Shadowing] + + | otherwise -- Lazy argument + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { arg' <- simplExprC (arg_se `setInScope` env) arg + (mkLazyArgStop arg_ty has_rules) + ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont } where - bale_out = returnSmpl (nilOL, rhs) - - go fun binds rev_args [] - = returnSmpl (binds, mkApps (Var fun) (reverse rev_args)) - - go fun binds rev_args (arg : args) - | exprIsTrivial arg -- Easy case - = go fun binds (arg:rev_args) args - - | not can_float_arg -- Can't make this arg atomic - = bale_out -- ... so give up - - | otherwise -- Don't forget to do it recursively - -- E.g. x = a:b:c:[] - = mkAtomicArgs ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> - newId FSLIT("a") arg_ty `thenSmpl` \ arg_id -> - go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) - (Var arg_id : rev_args) args - where - arg_ty = exprType arg - can_float_arg = not (isUnLiftedType arg_ty) - || (ok_float_unlifted && exprOkForSpeculation arg) - - -addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)] - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) -addAtomicBinds env [] thing_inside = thing_inside env -addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env -> - addAtomicBinds env bs thing_inside -\end{code} - - -%************************************************************************ -%* * -\subsection{The main rebuilder} -%* * -%************************************************************************ - -\begin{code} -rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr - -rebuild env expr (Stop _ _ _) = rebuildDone env expr -rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr -rebuild env expr (CoerceIt co cont) = rebuild env (mkCoerce co expr) cont -rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont -rebuild env expr (ApplyTo _ arg mb_se cont) = rebuildApp env expr arg mb_se cont - -rebuildApp env fun arg mb_se cont - = do { arg' <- simplArg env arg mb_se - ; rebuild env (App fun arg') cont } + (arg_ty, res_ty) = splitFunTy fun_ty -simplArg :: SimplEnv -> CoreExpr -> Maybe SimplEnv -> SimplM CoreExpr -simplArg env arg Nothing = return arg -- The arg is already simplified -simplArg env arg (Just arg_env) = simplExpr (setInScope arg_env env) arg - -rebuildDone env expr = returnSmpl (emptyFloats env, expr) +rebuildCall env fun fun_ty info cont + = rebuild env fun cont \end{code} +Note [Shadowing] +~~~~~~~~~~~~~~~~ +This part of the simplifier may break the no-shadowing invariant +Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! %************************************************************************ %* * -\subsection{Functions dealing with a case} + Rebuilding a cse expression %* * %************************************************************************ @@ -1345,7 +1085,7 @@ rebuildCase :: SimplEnv -> InId -- Case binder -> [InAlt] -- Alternatives (inceasing order) -> SimplCont - -> SimplM FloatsWithExpr + -> SimplM (SimplEnv, OutExpr) rebuildCase env scrut case_bndr alts cont | Just (con,args) <- exprIsConApp_maybe scrut @@ -1358,35 +1098,18 @@ rebuildCase env scrut case_bndr alts cont = knownCon env scrut (LitAlt lit) [] case_bndr alts cont | otherwise - = -- Prepare the continuation; - -- The new subst_env is in place - prepareCaseCont env alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> - addFloats env floats $ \ env -> - - let - -- The case expression is annotated with the result type of the continuation - -- This may differ from the type originally on the case. For example - -- case(T) (case(Int#) a of { True -> 1#; False -> 0# }) of - -- a# -> - -- ===> - -- let j a# = - -- in case(T) a of { True -> j 1#; False -> j 0# } - -- Note that the case that scrutinises a now returns a T not an Int# - res_ty' = contResultType dup_cont - in + = do { -- Prepare the continuation; + -- The new subst_env is in place + (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont - -- Deal with case binder - simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') -> - - -- Deal with the case alternatives - simplAlts alt_env scrut case_bndr' alts dup_cont `thenSmpl` \ alts' -> - - -- Put the case back together - mkCase scrut case_bndr' res_ty' alts' `thenSmpl` \ case_expr -> + -- Simplify the alternatives + ; (case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont + ; let res_ty' = contResultType dup_cont + ; case_expr <- mkCase scrut case_bndr' res_ty' alts' -- Notice that rebuildDone returns the in-scope set from env, not alt_env -- The case binder *not* scope over the whole returned case-expression - rebuild env case_expr nondup_cont + ; rebuild env case_expr nodup_cont } \end{code} simplCaseBinder checks whether the scrutinee is a variable, v. If so, @@ -1480,6 +1203,7 @@ after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. \begin{code} +simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId) simplCaseBinder env scrut case_bndr | switchIsOn (getSwitchChecker env) NoCaseOfCase -- See Note [no-case-of-case] @@ -1552,16 +1276,27 @@ of the inner case y, which give us nowhere to go! \begin{code} simplAlts :: SimplEnv -> OutExpr - -> OutId -- Case binder + -> InId -- Case binder -> [InAlt] -> SimplCont - -> SimplM [OutAlt] -- Includes the continuation - -simplAlts env scrut case_bndr' alts cont' - = do { mb_alts <- mapSmpl (simplAlt env imposs_cons case_bndr' cont') alts_wo_default - ; default_alts <- simplDefault env case_bndr' imposs_deflt_cons cont' maybe_deflt - ; return (mergeAlts default_alts [alt' | Just (_, alt') <- mb_alts]) } - -- We need the mergeAlts in case the new default_alt - -- has turned into a constructor alternative. + -> SimplM (OutId, [OutAlt]) -- Includes the continuation +-- Like simplExpr, this just returns the simplified alternatives; +-- it not return an environment + +simplAlts env scrut case_bndr alts cont' + = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ + do { let alt_env = zapFloats env + ; (alt_env, case_bndr') <- simplCaseBinder alt_env scrut case_bndr + + ; default_alts <- prepareDefault alt_env case_bndr' imposs_deflt_cons cont' maybe_deflt + + ; let inst_tys = tyConAppArgs (idType case_bndr') + trimmed_alts = filter (is_possible inst_tys) alts_wo_default + in_alts = mergeAlts default_alts trimmed_alts + -- We need the mergeAlts in case the new default_alt + -- has turned into a constructor alternative. + + ; alts' <- mapM (simplAlt alt_env imposs_cons case_bndr' cont') in_alts + ; return (case_bndr', alts') } where (alts_wo_default, maybe_deflt) = findDefault alts imposs_cons = case scrut of @@ -1572,21 +1307,26 @@ simplAlts env scrut case_bndr' alts cont' -- OR by a branch in this case expression. (Don't include DEFAULT!!) imposs_deflt_cons = nub (imposs_cons ++ [con | (con,_,_) <- alts_wo_default]) -simplDefault :: SimplEnv - -> OutId -- Case binder; need just for its type. Note that as an + is_possible :: [Type] -> CoreAlt -> Bool + is_possible tys (con, _, _) | con `elem` imposs_cons = False + is_possible tys (DataAlt con, _, _) = dataConCanMatch tys con + is_possible tys alt = True + +------------------------------------ +prepareDefault :: SimplEnv + -> OutId -- Case binder; need just for its type. Note that as an -- OutId, it has maximum information; this is important. -- Test simpl013 is an example -> [AltCon] -- These cons can't happen when matching the default -> SimplCont -> Maybe InExpr - -> SimplM [OutAlt] -- One branch or none; we use a list because it's what - -- mergeAlts expects + -> SimplM [InAlt] -- One branch or none; still unsimplified + -- We use a list because it's what mergeAlts expects - -simplDefault env case_bndr' imposs_cons cont Nothing +prepareDefault env case_bndr' imposs_cons cont Nothing = return [] -- No default branch -simplDefault env case_bndr' imposs_cons cont (Just rhs) +prepareDefault env case_bndr' imposs_cons cont (Just rhs) | -- This branch handles the case where we are -- scrutinisng an algebraic data type Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr'), @@ -1607,13 +1347,10 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs) -- not worth wasting code on. let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type - poss_data_cons = filterOut (`elem` imposs_data_cons) all_cons - gadt_imposs | all isTyVarTy inst_tys = [] - | otherwise = filter (cant_match inst_tys) poss_data_cons - final_poss = filterOut (`elem` gadt_imposs) poss_data_cons - - = case final_poss of - [] -> returnSmpl [] -- Eliminate the default alternative + is_possible con = not (con `elem` imposs_data_cons) + && dataConCanMatch inst_tys con + = case filter is_possible all_cons of + [] -> return [] -- Eliminate the default alternative -- altogether if it can't match [con] -> -- It matches exactly one constructor, so fill it in @@ -1621,74 +1358,54 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs) ; us <- getUniquesSmpl ; let (ex_tvs, co_tvs, arg_ids) = dataConRepInstPat us con inst_tys - ; let con_alt = (DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs) - ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt - -- The simplAlt must succeed with Just because we have - -- already filtered out construtors that can't match - ; return [alt'] } + ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)] } - two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons) + two_or_more -> return [(DEFAULT, [], rhs)] | otherwise - = simplify_default imposs_cons - where - cant_match tys data_con = not (dataConCanMatch data_con tys) - - simplify_default imposs_cons - = do { let env' = addBinderOtherCon env case_bndr' imposs_cons - -- Record the constructors that the case-binder *can't* be. - ; rhs' <- simplExprC env' rhs cont - ; return [(DEFAULT, [], rhs')] } + = return [(DEFAULT, [], rhs)] +------------------------------------ simplAlt :: SimplEnv -> [AltCon] -- These constructors can't be present when -- matching this alternative -> OutId -- The case binder -> SimplCont -> InAlt - -> SimplM (Maybe (TvSubstEnv, OutAlt)) + -> SimplM (OutAlt) -- Simplify an alternative, returning the type refinement for the -- alternative, if the alternative does any refinement at all --- Nothing => the alternative is inaccessible - -simplAlt env imposs_cons case_bndr' cont' (con, bndrs, rhs) - | con `elem` imposs_cons -- This case can't match - = return Nothing simplAlt env handled_cons case_bndr' cont' (DEFAULT, bndrs, rhs) - -- TURGID DUPLICATION, needed only for the simplAlt call - -- in mkDupableAlt. Clean this up when moving to FC = ASSERT( null bndrs ) - simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs'))) - where - env' = addBinderOtherCon env case_bndr' handled_cons - -- Record the constructors that the case-binder *can't* be. + do { let env' = addBinderOtherCon env case_bndr' handled_cons + -- Record the constructors that the case-binder *can't* be. + ; rhs' <- simplExprC env' rhs cont' + ; return (DEFAULT, [], rhs') } simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs) = ASSERT( null bndrs ) - simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs'))) - where - env' = addBinderUnfolding env case_bndr' (Lit lit) + do { let env' = addBinderUnfolding env case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (LitAlt lit, [], rhs') } simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) - = -- Deal with the pattern-bound variables - -- Mark the ones that are in ! positions in the data constructor - -- as certainly-evaluated. - -- NB: it happens that simplBinders does *not* erase the OtherCon - -- form of unfolding, so it's ok to add this info before - -- doing simplBinders - simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') -> + = do { -- Deal with the pattern-bound variables + -- Mark the ones that are in ! positions in the data constructor + -- as certainly-evaluated. + -- NB: it happens that simplBinders does *not* erase the OtherCon + -- form of unfolding, so it's ok to add this info before + -- doing simplBinders + (env, vs') <- simplBinders env (add_evals con vs) -- Bind the case-binder to (con args) - let inst_tys' = tyConAppArgs (idType case_bndr') - con_args = map Type inst_tys' ++ varsToCoreExprs vs' - env' = addBinderUnfolding env case_bndr' (mkConApp con con_args) - in - simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs'))) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_args = map Type inst_tys' ++ varsToCoreExprs vs' + env' = addBinderUnfolding env case_bndr' (mkConApp con con_args) + + ; rhs' <- simplExprC env' rhs cont' + ; return (DataAlt con, vs', rhs') } where -- add_evals records the evaluated-ness of the bound variables of -- a case pattern. This is *important*. Consider @@ -1698,6 +1415,7 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) -- -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. + -- See Note [Data-con worker strictness] in MkId.lhs add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc) cat_evals dc vs strs @@ -1752,64 +1470,66 @@ All this should happen in one sweep. \begin{code} knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr] -> InId -> [InAlt] -> SimplCont - -> SimplM FloatsWithExpr + -> SimplM (SimplEnv, OutExpr) knownCon env scrut con args bndr alts cont - = tick (KnownBranch bndr) `thenSmpl_` - case findAlt con alts of - (DEFAULT, bs, rhs) -> ASSERT( null bs ) - simplNonRecX env bndr scrut $ \ env -> - -- This might give rise to a binding with non-atomic args - -- like x = Node (f x) (g x) - -- but simplNonRecX will atomic-ify it - simplExprF env rhs cont - - (LitAlt lit, bs, rhs) -> ASSERT( null bs ) - simplNonRecX env bndr scrut $ \ env -> - simplExprF env rhs cont - - (DataAlt dc, bs, rhs) - -> -- ASSERT( n_drop_tys + length bs == length args ) - bind_args env dead_bndr bs (drop n_drop_tys args) $ \ env -> - let - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bndr_rhs = case scrut of - Var v -> scrut - other -> con_app - con_app = mkConApp dc (take n_drop_tys args ++ con_args) - con_args = [substExpr env (varToCoreExpr b) | b <- bs] - -- args are aready OutExprs, but bs are InIds - in - simplNonRecX env bndr bndr_rhs $ \ env -> - simplExprF env rhs cont - where - dead_bndr = isDeadBinder bndr - n_drop_tys = tyConArity (dataConTyCon dc) + = do { tick (KnownBranch bndr) + ; knownAlt env scrut args bndr (findAlt con alts) cont } + +knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont + = ASSERT( null bs ) + do { env <- simplNonRecX env bndr scrut + -- This might give rise to a binding with non-atomic args + -- like x = Node (f x) (g x) + -- but simplNonRecX will atomic-ify it + ; simplExprF env rhs cont } + +knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont + = ASSERT( null bs ) + do { env <- simplNonRecX env bndr scrut + ; simplExprF env rhs cont } + +knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont + = do { let dead_bndr = isDeadBinder bndr + n_drop_tys = tyConArity (dataConTyCon dc) + ; env <- bind_args env dead_bndr bs (drop n_drop_tys args) + ; let + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bndr_rhs = case scrut of + Var v -> scrut + other -> con_app + con_app = mkConApp dc (take n_drop_tys args ++ con_args) + con_args = [substExpr env (varToCoreExpr b) | b <- bs] + -- args are aready OutExprs, but bs are InIds + + ; env <- simplNonRecX env bndr bndr_rhs + ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $ + simplExprF env rhs cont } -- Ugh! -bind_args env dead_bndr [] _ thing_inside = thing_inside env +bind_args env dead_bndr [] _ = return env -bind_args env dead_bndr (b:bs) (Type ty : args) thing_inside +bind_args env dead_bndr (b:bs) (Type ty : args) = ASSERT( isTyVar b ) - bind_args (extendTvSubst env b ty) dead_bndr bs args thing_inside + bind_args (extendTvSubst env b ty) dead_bndr bs args -bind_args env dead_bndr (b:bs) (arg : args) thing_inside +bind_args env dead_bndr (b:bs) (arg : args) = ASSERT( isId b ) - let - b' = if dead_bndr then b else zapOccInfo b + do { let b' = if dead_bndr then b else zapOccInfo b -- Note that the binder might be "dead", because it doesn't occur -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally -- Nevertheless we must keep it if the case-binder is alive, because it may -- be used in the con_app. See Note [zapOccInfo] - in - simplNonRecX env b' arg $ \ env -> - bind_args env dead_bndr bs args thing_inside + ; env <- simplNonRecX env b' arg + ; bind_args env dead_bndr bs args } + +bind_args _ _ _ _ = panic "bind_args" \end{code} @@ -1822,77 +1542,245 @@ bind_args env dead_bndr (b:bs) (arg : args) thing_inside \begin{code} prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (FloatsWith (SimplCont,SimplCont)) + -> SimplM (SimplEnv, SimplCont,SimplCont) -- Return a duplicatable continuation, a non-duplicable part -- plus some extra bindings (that scope over the entire -- continunation) -- No need to make it duplicatable if there's only one alternative -prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) +prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont)) prepareCaseCont env alts cont = mkDupableCont env cont \end{code} \begin{code} mkDupableCont :: SimplEnv -> SimplCont - -> SimplM (FloatsWith (SimplCont, SimplCont)) + -> SimplM (SimplEnv, SimplCont, SimplCont) mkDupableCont env cont | contIsDupable cont - = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) + = returnSmpl (env, cont, mkBoringStop (contResultType cont)) + +mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn mkDupableCont env (CoerceIt ty cont) - = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> - returnSmpl (floats, (CoerceIt ty dup_cont, nondup_cont)) - -mkDupableCont env cont@(ArgOf _ arg_ty _ _) - = returnSmpl (emptyFloats env, (mkBoringStop arg_ty, cont)) - -- Do *not* duplicate an ArgOf continuation - -- Because ArgOf continuations are opaque, we gain nothing by - -- propagating them into the expressions, and we do lose a lot. - -- Here's an example: - -- && (case x of { T -> F; F -> T }) E - -- Now, && is strict so we end up simplifying the case with - -- an ArgOf continuation. If we let-bind it, we get - -- - -- let $j = \v -> && v E - -- in simplExpr (case x of { T -> F; F -> T }) - -- (ArgOf (\r -> $j r) - -- And after simplifying more we get - -- - -- let $j = \v -> && v E - -- in case of { T -> $j F; F -> $j T } - -- Which is a Very Bad Thing - -- - -- The desire not to duplicate is the entire reason that - -- mkDupableCont returns a pair of continuations. - -- - -- The original plan had: - -- e.g. (...strict-fn...) [...hole...] - -- ==> - -- let $j = \a -> ...strict-fn... - -- in $j [...hole...] + = do { (env, dup, nodup) <- mkDupableCont env cont + ; return (env, CoerceIt ty dup, nodup) } + +mkDupableCont env cont@(StrictBind bndr _ _ se _) + = return (env, mkBoringStop (substTy se (idType bndr)), cont) + -- See Note [Duplicating strict continuations] -mkDupableCont env (ApplyTo _ arg mb_se cont) +mkDupableCont env cont@(StrictArg _ fun_ty _ _) + = return (env, mkBoringStop (funArgTy fun_ty), cont) + -- See Note [Duplicating strict continuations] + +mkDupableCont env (ApplyTo _ arg se cont) = -- e.g. [...hole...] (...arg...) -- ==> -- let a = ...arg... -- in [...hole...] a - do { (floats, (dup_cont, nondup_cont)) <- mkDupableCont env cont - ; addFloats env floats $ \ env -> do - { arg1 <- simplArg env arg mb_se - ; (floats2, arg2) <- mkDupableArg env arg1 - ; return (floats2, (ApplyTo OkToDup arg2 Nothing dup_cont, nondup_cont)) }} + do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont + ; arg <- simplExpr (se `setInScope` env) arg + ; (env, arg) <- makeTrivial env arg + ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont + ; return (env, app_cont, nodup_cont) } mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont) --- | not (exprIsDupable rhs && contIsDupable case_cont) -- See notes below +-- See Note [Single-alternative case] +-- | not (exprIsDupable rhs && contIsDupable case_cont) -- | not (isDeadBinder case_bndr) | all isDeadBinder bs - = returnSmpl (emptyFloats env, (mkBoringStop scrut_ty, cont)) + = return (env, mkBoringStop scrut_ty, cont) where scrut_ty = substTy se (idType case_bndr) -{- Note [Single-alternative cases] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +mkDupableCont env (Select _ case_bndr alts se cont) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + do { tick (CaseOfCase case_bndr) + ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont + -- NB: call mkDupableCont here, *not* prepareCaseCont + -- We must make a duplicable continuation, whereas prepareCaseCont + -- doesn't when there is a single case branch + + ; let alt_env = se `setInScope` env + ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr + ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# a,b #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# a,b #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; (env, alts') <- mkDupableAlts env case_bndr' alts' + ; return (env, -- Note [Duplicated env] + Select OkToDup case_bndr' alts' (zapSubstEnv env) + (mkBoringStop (contResultType dup_cont)), + nodup_cont) } + + +mkDupableAlts :: SimplEnv -> OutId -> [InAlt] + -> SimplM (SimplEnv, [InAlt]) +-- Absorbs the continuation into the new alternatives + +mkDupableAlts env case_bndr' alts + = go env alts + where + go env [] = return (env, []) + go env (alt:alts) + = do { (env, alt') <- mkDupableAlt env case_bndr' alt + ; (env, alts') <- go env alts + ; return (env, alt' : alts' ) } + +mkDupableAlt env case_bndr' (con, bndrs', rhs') + | exprIsDupable rhs' -- Note [Small alternative rhs] + = return (env, (con, bndrs', rhs')) + | otherwise + = do { let rhs_ty' = exprType rhs' + used_bndrs' = filter abstract_over (case_bndr' : bndrs') + abstract_over bndr + | isTyVar bndr = True -- Abstract over all type variables just in case + | otherwise = not (isDeadBinder bndr) + -- The deadness info on the new Ids is preserved by simplBinders + + ; (final_bndrs', final_args) -- Note [Join point abstraction] + <- if (any isId used_bndrs') + then return (used_bndrs', varsToCoreExprs used_bndrs') + else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy + ; return ([rw_id], [Var realWorldPrimId]) } + + ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') + -- Note [Funky mkPiTypes] + + ; let -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + join_rhs = mkLams really_final_bndrs rhs' + join_call = mkApps (Var join_bndr) final_args + + ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) } + -- See Note [Duplicated env] +\end{code} + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have an zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Small alterantive rhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is worth checking for a small RHS because otherwise we +get extra let bindings that may cause an extra iteration of the simplifier to +inline back in place. Quite often the rhs is just a variable or constructor. +The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra +iterations because the version with the let bindings looked big, and so wasn't +inlined, but after the join points had been inlined it looked smaller, and so +was inlined. + +NB: we have to check the size of rhs', not rhs. +Duplicating a small InAlt might invalidate occurrence information +However, if it *is* dupable, we return the *un* simplified alternative, +because otherwise we'd need to pair it up with an empty subst-env.... +but we only have one env shared between all the alts. +(Remember we must zap the subst-env before re-simplifying something). +Rather than do this we simply agree to re-simplify the original (small) thing later. + +Note [Funky mkPiTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkPiTypes. If the contructor has existentials +it's possible that the join point will be abstracted over +type varaibles as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Join point abstaction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we try to lift a primitive-typed something out +for let-binding-purposes, we will *caseify* it (!), +with potentially-disastrous strictness results. So +instead we turn it into a function: \v -> e +where v::State# RealWorld#. The value passed to this function +is realworld#, which generates (almost) no code. + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + +We used to say "&& isUnLiftedType rhs_ty'" here, but now +we make the join point into a function whenever used_bndrs' +is empty. This makes the join-point more CPR friendly. +Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + +Now CPR doesn't w/w j because it's a thunk, so +that means that the enclosing function can't w/w either, +which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +Note [Duplicating strict continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* duplicate StrictBind and StritArg continuations. We gain +nothing by propagating them into the expressions, and we do lose a +lot. Here's an example: + && (case x of { T -> F; F -> T }) E +Now, && is strict so we end up simplifying the case with +an ArgOf continuation. If we let-bind it, we get + + let $j = \v -> && v E + in simplExpr (case x of { T -> F; F -> T }) + (ArgOf (\r -> $j r) +And after simplifying more we get + + let $j = \v -> && v E + in case x of { T -> $j F; F -> $j T } +Which is a Very Bad Thing + +The desire not to duplicate is the entire reason that +mkDupableCont returns a pair of continuations. + +The original plan had: +e.g. (...strict-fn...) [...hole...] + ==> + let $j = \a -> ...strict-fn... + in $j [...hole...] + +Note [Single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This case is just like the ArgOf case. Here's an example: data T a = MkT !a ...(MkT (abs x))... @@ -1950,195 +1838,4 @@ Other choices: we can get let x = case (...) of { small } in ...case x... When x is inlined into its full context, we find that it was a bad idea to have pushed the outer case inside the (...) case. --} - -mkDupableCont env (Select _ case_bndr alts se cont) - = -- e.g. (case [...hole...] of { pi -> ei }) - -- ===> - -- let ji = \xij -> ei - -- in case [...hole...] of { pi -> ji xij } - do { tick (CaseOfCase case_bndr) - ; let alt_env = setInScope se env - ; (floats1, (dup_cont, nondup_cont)) <- mkDupableCont alt_env cont - -- NB: call mkDupableCont here, *not* prepareCaseCont - -- We must make a duplicable continuation, whereas prepareCaseCont - -- doesn't when there is a single case branch - ; addFloats alt_env floats1 $ \ alt_env -> do - - { (alt_env, case_bndr') <- simplBinder alt_env case_bndr - -- NB: simplBinder does not zap deadness occ-info, so - -- a dead case_bndr' will still advertise its deadness - -- This is really important because in - -- case e of b { (# a,b #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# a,b #), - -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. - -- In the new alts we build, we have the new case binder, so it must retain - -- its deadness. - - ; (floats2, alts') <- mkDupableAlts alt_env case_bndr' alts dup_cont - ; return (floats2, (Select OkToDup case_bndr' alts' (zapSubstEnv se) - (mkBoringStop (contResultType dup_cont)), - nondup_cont)) - }} - -mkDupableArg :: SimplEnv -> OutExpr -> SimplM (FloatsWith OutExpr) --- Let-bind the thing if necessary -mkDupableArg env arg - | exprIsDupable arg - = return (emptyFloats env, arg) - | otherwise - = do { arg_id <- newId FSLIT("a") (exprType arg) - ; tick (CaseOfCase arg_id) - -- Want to tick here so that we go round again, - -- and maybe copy or inline the code. - -- Not strictly CaseOfCase, but never mind - ; return (unitFloat env arg_id arg, Var arg_id) } - -- What if the arg should be case-bound? - -- This has been this way for a long time, so I'll leave it, - -- but I can't convince myself that it's right. - -mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont - -> SimplM (FloatsWith [InAlt]) --- Absorbs the continuation into the new alternatives - -mkDupableAlts env case_bndr' alts dupable_cont - = go env alts - where - go env [] = returnSmpl (emptyFloats env, []) - go env (alt:alts) - = do { (floats1, mb_alt') <- mkDupableAlt env case_bndr' dupable_cont alt - ; addFloats env floats1 $ \ env -> do - { (floats2, alts') <- go env alts - ; returnSmpl (floats2, case mb_alt' of - Just alt' -> alt' : alts' - Nothing -> alts' - )}} - -mkDupableAlt env case_bndr' cont alt - = simplAlt env [] case_bndr' cont alt `thenSmpl` \ mb_stuff -> - case mb_stuff of { - Nothing -> returnSmpl (emptyFloats env, Nothing) ; - - Just (reft, (con, bndrs', rhs')) -> - -- Safe to say that there are no handled-cons for the DEFAULT case - - if exprIsDupable rhs' then - returnSmpl (emptyFloats env, Just (con, bndrs', rhs')) - -- It is worth checking for a small RHS because otherwise we - -- get extra let bindings that may cause an extra iteration of the simplifier to - -- inline back in place. Quite often the rhs is just a variable or constructor. - -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra - -- iterations because the version with the let bindings looked big, and so wasn't - -- inlined, but after the join points had been inlined it looked smaller, and so - -- was inlined. - -- - -- NB: we have to check the size of rhs', not rhs. - -- Duplicating a small InAlt might invalidate occurrence information - -- However, if it *is* dupable, we return the *un* simplified alternative, - -- because otherwise we'd need to pair it up with an empty subst-env.... - -- but we only have one env shared between all the alts. - -- (Remember we must zap the subst-env before re-simplifying something). - -- Rather than do this we simply agree to re-simplify the original (small) thing later. - - else - let - rhs_ty' = exprType rhs' - used_bndrs' = filter abstract_over (case_bndr' : bndrs') - abstract_over bndr - | isTyVar bndr = not (bndr `elemVarEnv` reft) - -- Don't abstract over tyvar binders which are refined away - -- See Note [Refinement] below - | otherwise = not (isDeadBinder bndr) - -- The deadness info on the new Ids is preserved by simplBinders - in - -- If we try to lift a primitive-typed something out - -- for let-binding-purposes, we will *caseify* it (!), - -- with potentially-disastrous strictness results. So - -- instead we turn it into a function: \v -> e - -- where v::State# RealWorld#. The value passed to this function - -- is realworld#, which generates (almost) no code. - - -- There's a slight infelicity here: we pass the overall - -- case_bndr to all the join points if it's used in *any* RHS, - -- because we don't know its usage in each RHS separately - - -- We used to say "&& isUnLiftedType rhs_ty'" here, but now - -- we make the join point into a function whenever used_bndrs' - -- is empty. This makes the join-point more CPR friendly. - -- Consider: let j = if .. then I# 3 else I# 4 - -- in case .. of { A -> j; B -> j; C -> ... } - -- - -- Now CPR doesn't w/w j because it's a thunk, so - -- that means that the enclosing function can't w/w either, - -- which is a lose. Here's the example that happened in practice: - -- kgmod :: Int -> Int -> Int - -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 - -- then 78 - -- else 5 - -- - -- I have seen a case alternative like this: - -- True -> \v -> ... - -- It's a bit silly to add the realWorld dummy arg in this case, making - -- $j = \s v -> ... - -- True -> $j s - -- (the \v alone is enough to make CPR happy) but I think it's rare - - ( if not (any isId used_bndrs') - then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> - returnSmpl ([rw_id], [Var realWorldPrimId]) - else - returnSmpl (used_bndrs', varsToCoreExprs used_bndrs') - ) `thenSmpl` \ (final_bndrs', final_args) -> - - -- See comment about "$j" name above - newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> - -- Notice the funky mkPiTypes. If the contructor has existentials - -- it's possible that the join point will be abstracted over - -- type varaibles as well as term variables. - -- Example: Suppose we have - -- data T = forall t. C [t] - -- Then faced with - -- case (case e of ...) of - -- C t xs::[t] -> rhs - -- We get the join point - -- let j :: forall t. [t] -> ... - -- j = /\t \xs::[t] -> rhs - -- in - -- case (case e of ...) of - -- C t xs::[t] -> j t xs - let - -- We make the lambdas into one-shot-lambdas. The - -- join point is sure to be applied at most once, and doing so - -- prevents the body of the join point being floated out by - -- the full laziness pass - really_final_bndrs = map one_shot final_bndrs' - one_shot v | isId v = setOneShotLambda v - | otherwise = v - join_rhs = mkLams really_final_bndrs rhs' - join_call = mkApps (Var join_bndr) final_args - in - returnSmpl (unitFloat env join_bndr join_rhs, Just (con, bndrs', join_call)) } -\end{code} - -Note [Refinement] -~~~~~~~~~~~~~~~~~ -Consider - data T a where - MkT :: a -> b -> T a - - f = /\a. \(w::a). - case (case ...) of - MkT a' b (p::a') (q::b) -> [p,w] - -The danger is that we'll make a join point - - j a' p = [p,w] - -and that's ill-typed, because (p::a') but (w::a). - -Solution so far: don't abstract over a', because the type refinement -maps [a' -> a] . Ultimately that won't work when real refinement goes on. -Then we must abstract over any refined free variables. Hmm. Maybe we -could just abstract over *all* free variables, thereby lambda-lifting -the join point? We should try this. diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 4f62115..0a06854 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -203,7 +203,7 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) \begin{code} lookupRule :: (Activation -> Bool) -> InScopeSet -> RuleBase -- Imported rules - -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) + -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr) lookupRule is_active in_scope rule_base fn args = matchRules is_active in_scope fn args rules where @@ -217,13 +217,13 @@ lookupRule is_active in_scope rule_base fn args matchRules :: (Activation -> Bool) -> InScopeSet -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (RuleName, CoreExpr) + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -- See comments on matchRule matchRules is_active in_scope fn args rules - = case go [] rules of + = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $ + case go [] rules of [] -> Nothing - (m:ms) -> Just (case findBest (fn,args) m ms of - (rule, ans) -> (ru_name rule, ans)) + (m:ms) -> Just (findBest (fn,args) m ms) where rough_args = map roughTopName args @@ -231,7 +231,8 @@ matchRules is_active in_scope fn args rules go ms [] = ms go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of Just e -> go ((r,e):ms) rs - Nothing -> go ms rs + Nothing -> -- pprTrace "Failed match" ((ppr r) $$ (ppr args)) $ + go ms rs findBest :: (Id, [CoreExpr]) -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) @@ -309,11 +310,9 @@ matchRule is_active in_scope args rough_args | ruleCantMatch tpl_tops rough_args = Nothing | otherwise = case matchN in_scope tpl_vars tpl_args args of - Nothing -> Nothing - Just (binds, tpl_vals, leftovers) -> Just (mkLets binds $ - rule_fn - `mkApps` tpl_vals - `mkApps` leftovers) + Nothing -> Nothing + Just (binds, tpl_vals) -> Just (mkLets binds $ + rule_fn `mkApps` tpl_vals) where rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs) -- We could do this when putting things into the rulebase, I guess @@ -325,20 +324,18 @@ matchN :: InScopeSet -> [CoreExpr] -- Template -> [CoreExpr] -- Target; can have more elts than template -> Maybe ([CoreBind], -- Bindings to wrap around the entire result - [CoreExpr], -- What is substituted for each template var - [CoreExpr]) -- Leftover target exprs + [CoreExpr]) -- What is substituted for each template var matchN in_scope tmpl_vars tmpl_es target_es - = do { ((tv_subst, id_subst, binds), leftover_es) + = do { (tv_subst, id_subst, binds) <- go init_menv emptySubstEnv tmpl_es target_es ; return (fromOL binds, - map (lookup_tmpl tv_subst id_subst) tmpl_vars, - leftover_es) } + map (lookup_tmpl tv_subst id_subst) tmpl_vars) } where init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env } init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars) - go menv subst [] es = Just (subst, es) + go menv subst [] es = Just subst go menv subst ts [] = Nothing -- Fail if too few actual args go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e ; go menv subst1 ts es } @@ -538,7 +535,8 @@ match menv subst e1 (Let bind e2) -} -- Everything else fails -match menv subst e1 e2 = Nothing +match menv subst e1 e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $ + Nothing ------------------------------------------ match_var :: MatchEnv diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 88da692..abf5360 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -787,7 +787,8 @@ callToPats in_scope bndr_occs (con_env, args) -- Quantify over variables that are not in sccpe -- See Note [Shadowing] at the top - ; if or good_pats + ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $ + if or good_pats then return (Just (qvars, pats)) else return Nothing } diff --git a/compiler/typecheck/TcGadt.lhs b/compiler/typecheck/TcGadt.lhs index 5bad13e..4c1f70e 100644 --- a/compiler/typecheck/TcGadt.lhs +++ b/compiler/typecheck/TcGadt.lhs @@ -21,6 +21,7 @@ module TcGadt ( import HsSyn import Coercion +import Type import TypeRep import DataCon import Var @@ -226,12 +227,15 @@ fixTvSubstEnv in_scope env fixpt = mapVarEnv (substTy (mkTvSubst in_scope fixpt)) env ---------------------------- -dataConCanMatch :: DataCon -> [Type] -> Bool +dataConCanMatch :: [Type] -> DataCon -> Bool -- Returns True iff the data con can match a scrutinee of type (T tys) -- where T is the type constructor for the data con -- -- Instantiate the equations and try to unify them -dataConCanMatch con tys +dataConCanMatch tys con + | null eq_spec = True -- Common + | all isTyVarTy tys = True -- Also common + | otherwise = isJust (tcUnifyTys (\tv -> BindMe) (map (substTyVar subst . fst) eq_spec) (map snd eq_spec)) -- 1.7.10.4