Commit 7a327c12 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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".
parent 326d5e5a
......@@ -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
......
......@@ -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) = <f's unfolding> 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}
......@@ -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]
......
......@@ -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