Name, PrimRep, FieldLabel (loop Type.Type)
then
- Var (loop Const.Con, loop IdInfo.IdInfo,
+ Var (loop CoreSyn.CoreExpr, loop IdInfo.IdInfo,
loop Type.GenType, loop Type.Kind)
then
VarEnv, VarSet, ThinAir
then
PrimOp (PprType, TysWiredIn)
then
- IdInfo (loop CoreSyn.CoreRules, loop CoreUnfold.Unfolding)
+ CoreSyn
then
- Const (PrimOp.PrimOp, TysWiredIn.stringTy)
+ IdInfo (loop CoreSyn.CoreRules etc, loop CoreUnfold.Unfolding)
then
- Id (Const.Con(..)), CoreSyn
+ Id (lots from IdInfo)
then
CoreFVs, PprCore
then
- CoreUtils (PprCore.pprCoreExpr, CoreFVs.exprFreeVars)
+ CoreUtils (PprCore.pprCoreExpr, CoreFVs.exprFreeVars,
+ loop CoreUnfold.isEvaldUnfolding CoreUnfold.maybeUnfoldingTemplate)
then
- OccurAnal (ThinAir.noRepStrs -- an awkward dependency)
+ OccurAnal (CoreUtils.exprIsTrivial)
then
- CoreUnfold (loop OccurAnal.globalOccurAnalyse)
+ CoreUnfold (OccurAnal.occurAnalyseGlobalExpr)
then
Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding)
then
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( Unfolding )
-import {-# SOURCE #-} CoreSyn ( CoreRules )
+import CoreSyn ( Unfolding, CoreRules )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, mkIdVar,
-- Strictness; imported from Demand
StrictnessInfo(..),
mkStrictnessInfo, noStrictnessInfo,
- ppStrictnessInfo,isBottomingStrictness, appIsBottom,
+ ppStrictnessInfo,isBottomingStrictness,
strictnessInfo, setStrictnessInfo,
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding, seqUnfolding )
-import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules, seqRules )
-
+import CoreSyn
import PrimOp ( PrimOp )
import Var ( Id )
import BasicTypes ( OccInfo(..), isFragileOccInfo, seqOccInfo,
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
import CoreFVs ( idFreeVars )
-import CoreUtils ( exprOkForSpeculation )
+import CoreUtils ( exprOkForSpeculation, coreBindsSize )
import Bag
import Literal ( Literal, literalType )
_interface_ CoreSyn 1
_exports_
-CoreSyn CoreExpr CoreRule CoreRules emptyCoreRules isEmptyCoreRules seqRules ;
+CoreSyn CoreExpr ;
_declarations_
--- Needed by IdInfo
+-- Needed by Var.lhs
1 type CoreExpr = Expr Var.Var;
1 data Expr b ;
-
-1 data CoreRule ;
-1 data CoreRules = Rules [CoreRule] VarSet.VarSet ;
-1 emptyCoreRules _:_ CoreRules ;;
-1 seqRules _:_ CoreRules -> PrelBase.() ;;
-1 isEmptyCoreRules _:_ CoreRules -> PrelBase.Bool ;;
__interface CoreSyn 1 0 where
-__export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules seqRules ;
+__export CoreSyn CoreExpr ;
--- Needed by IdInfo
+-- Needed by Var.lhs
1 type CoreExpr = Expr Var.Var;
1 data Expr b ;
-
-1 data CoreRule ;
-1 data CoreRules = Rules [CoreRule] VarSet.VarSet ;
-1 emptyCoreRules :: CoreRules ;
-1 seqRules :: CoreRules -> PrelBase.Z0T ;
-1 isEmptyCoreRules :: CoreRules -> PrelBase.Bool ;
mkApps, mkTyApps, mkValApps, mkVarApps,
mkLit, mkIntLitInt, mkIntLit,
mkStringLit, mkStringLitFS, mkConApp,
- mkAltExpr,
- bindNonRec, mkIfThenElse, varToCoreExpr,
+ varToCoreExpr,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
isValArg, isTypeArg, valArgCount, valBndrCount,
- -- Seq stuff
- seqRules, seqExpr, seqExprs,
+ -- Unfoldings
+ Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs
+ noUnfolding, mkOtherCon,
+ unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
+ isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+ hasUnfolding, hasSomeUnfolding,
- -- Size
- coreBindsSize,
+ -- Seq stuff
+ seqRules, seqExpr, seqExprs, seqUnfolding,
-- Annotated expressions
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate',
#include "HsVersions.h"
-import TysWiredIn ( boolTy, stringTy, nilDataCon )
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId, idType )
import VarEnv
-import Id ( mkWildId, idOccInfo, idInfo )
import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
-import IdInfo ( OccInfo(..), megaSeqIdInfo )
import Literal ( Literal(MachStr), mkMachInt )
import PrimOp ( PrimOp )
import DataCon ( DataCon, dataConId )
-import TysWiredIn ( trueDataCon, falseDataCon )
import ThinAir ( unpackCStringId, unpackCString2Id, addr2IntegerId )
import VarSet
import Outputable
%************************************************************************
%* *
+\subsection{@Unfolding@ type}
+%* *
+%************************************************************************
+
+The @Unfolding@ type is declared here to avoid numerous loops, but it
+should be abstract everywhere except in CoreUnfold.lhs
+
+\begin{code}
+data Unfolding
+ = NoUnfolding
+
+ | OtherCon [AltCon] -- It ain't one of these
+ -- (OtherCon xs) also indicates that something has been evaluated
+ -- and hence there's no point in re-evaluating it.
+ -- OtherCon [] is used even for non-data-type values
+ -- to indicated evaluated-ness. Notably:
+ -- data C = C !(Int -> Int)
+ -- case x of { C f -> ... }
+ -- Here, f gets an OtherCon [] unfolding.
+
+ | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
+ -- so you'd better unfold.
+
+ | CoreUnfolding -- An unfolding with redundant cached information
+ CoreExpr -- Template; binder-info is correct
+ Bool -- This is a top-level binding
+ Bool -- exprIsCheap template (cached); it won't duplicate (much) work
+ -- if you inline this in more than one place
+ Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
+ -- this variable
+ Bool -- exprIsBottom template (cached)
+ UnfoldingGuidance -- Tells about the *size* of the template.
+
+
+data UnfoldingGuidance
+ = UnfoldNever
+ | UnfoldIfGoodArgs Int -- and "n" value args
+
+ [Int] -- Discount if the argument is evaluated.
+ -- (i.e., a simplification will definitely
+ -- be possible). One elt of the list per *value* arg.
+
+ Int -- The "size" of the unfolding; to be elaborated
+ -- later. ToDo
+
+ Int -- Scrutinee discount: the discount to substract if the thing is in
+ -- a context (case (thing args) of ...),
+ -- (where there are the right number of arguments.)
+
+noUnfolding = NoUnfolding
+mkOtherCon = OtherCon
+
+seqUnfolding :: Unfolding -> ()
+seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
+ = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
+seqUnfolding other = ()
+
+seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
+seqGuidance other = ()
+\end{code}
+
+\begin{code}
+unfoldingTemplate :: Unfolding -> CoreExpr
+unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
+unfoldingTemplate (CompulsoryUnfolding expr) = expr
+unfoldingTemplate other = panic "getUnfoldingTemplate"
+
+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
+maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
+maybeUnfoldingTemplate other = Nothing
+
+otherCons :: Unfolding -> [AltCon]
+otherCons (OtherCon cons) = cons
+otherCons other = []
+
+isValueUnfolding :: Unfolding -> Bool
+ -- Returns False for OtherCon
+isValueUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
+isValueUnfolding other = False
+
+isEvaldUnfolding :: Unfolding -> Bool
+ -- Returns True for OtherCon
+isEvaldUnfolding (OtherCon _) = True
+isEvaldUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
+isEvaldUnfolding other = False
+
+isCheapUnfolding :: Unfolding -> Bool
+isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _ _) = is_cheap
+isCheapUnfolding other = False
+
+isCompulsoryUnfolding :: Unfolding -> Bool
+isCompulsoryUnfolding (CompulsoryUnfolding _) = True
+isCompulsoryUnfolding other = False
+
+hasUnfolding :: Unfolding -> Bool
+hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
+hasUnfolding (CompulsoryUnfolding _) = True
+hasUnfolding other = False
+
+hasSomeUnfolding :: Unfolding -> Bool
+hasSomeUnfolding NoUnfolding = False
+hasSomeUnfolding other = True
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{The main data type}
%* *
%************************************************************************
mkStringLit :: String -> Expr b -- Makes a [Char] literal
mkStringLitFS :: FAST_STRING -> Expr b -- Makes a [Char] literal
mkConApp :: DataCon -> [Arg b] -> Expr b
+mkLets :: [Bind b] -> Expr b -> Expr b
+mkLams :: [b] -> Expr b -> Expr b
mkLit lit = Lit lit
mkConApp con args = mkApps (Var (dataConId con)) args
+mkLams binders body = foldr Lam body binders
+mkLets binds body = foldr Let body binds
+
mkIntLit n = Lit (mkMachInt n)
mkIntLitInt n = Lit (mkMachInt (toInteger n))
| otherwise = Type (mkTyVarTy v)
\end{code}
-\begin{code}
-mkLams :: [b] -> Expr b -> Expr b
-mkLams binders body = foldr Lam body binders
-\end{code}
-
-\begin{code}
-mkLets :: [Bind b] -> Expr b -> Expr b
-mkLets binds body = foldr Let body binds
-
-bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
--- (bindNonRec x r b) produces either
--- let x = r in b
--- or
--- case r of x { _DEFAULT_ -> b }
---
--- depending on whether x is unlifted or not
--- It's used by the desugarer to avoid building bindings
--- that give Core Lint a heart attack. Actually the simplifier
--- deals with them perfectly well.
-bindNonRec bndr rhs body
- | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
- | otherwise = Let (NonRec bndr rhs) body
-
-mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
-mkIfThenElse guard then_expr else_expr
- = Case guard (mkWildId boolTy)
- [ (DataAlt trueDataCon, [], then_expr),
- (DataAlt falseDataCon, [], else_expr) ]
-\end{code}
-
-
-\begin{code}
-mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
- -- This guy constructs the value that the scrutinee must have
- -- when you are in one particular branch of a case
-mkAltExpr (DataAlt con) args inst_tys
- = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
-mkAltExpr (LitAlt lit) [] []
- = Lit lit
-\end{code}
-
%************************************************************************
%* *
seq_rules (BuiltinRule _ : rules) = seq_rules rules
\end{code}
-\begin{code}
-coreBindsSize :: [CoreBind] -> Int
-coreBindsSize bs = foldr ((+) . bindSize) 0 bs
-
-exprSize :: CoreExpr -> Int
- -- A measure of the size of the expressions
- -- It also forces the expression pretty drastically as a side effect
-exprSize (Var v) = varSize v
-exprSize (Lit lit) = 1
-exprSize (App f a) = exprSize f + exprSize a
-exprSize (Lam b e) = varSize b + exprSize e
-exprSize (Let b e) = bindSize b + exprSize e
-exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
-exprSize (Note n e) = exprSize e
-exprSize (Type t) = seqType t `seq`
- 1
-
-exprsSize = foldr ((+) . exprSize) 0
-
-varSize :: Var -> Int
-varSize b | isTyVar b = 1
- | otherwise = seqType (idType b) `seq`
- megaSeqIdInfo (idInfo b) `seq`
- 1
-
-varsSize = foldr ((+) . varSize) 0
-
-bindSize (NonRec b e) = varSize b + exprSize e
-bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
-
-pairSize (b,e) = varSize b + exprSize e
-
-altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
-\end{code}
%************************************************************************
+++ /dev/null
-_interface_ CoreUnfold 1
-_exports_
-CoreUnfold Unfolding UnfoldingGuidance noUnfolding hasUnfolding isEvaldUnfolding seqUnfolding ;
-_declarations_
-1 data Unfolding;
-1 data UnfoldingGuidance;
-1 noUnfolding _:_ Unfolding ;;
-1 hasUnfolding _:_ Unfolding -> PrelBase.Bool ;;
-1 seqUnfolding _:_ Unfolding -> PrelBase.() ;;
-1 isEvaldUnfolding _:_ Unfolding -> PrelBase.Bool ;;
+++ /dev/null
-__interface CoreUnfold 1 0 where
-__export CoreUnfold Unfolding UnfoldingGuidance noUnfolding hasUnfolding isEvaldUnfolding seqUnfolding ;
-1 data Unfolding;
-1 data UnfoldingGuidance;
-1 noUnfolding :: Unfolding ;
-1 hasUnfolding :: Unfolding -> PrelBase.Bool ;
-1 seqUnfolding :: Unfolding -> PrelBase.Z0T ;
-1 isEvaldUnfolding :: Unfolding -> PrelBase.Bool ;
\begin{code}
module CoreUnfold (
- Unfolding, UnfoldingGuidance, -- types
+ Unfolding, UnfoldingGuidance, -- Abstract types
noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
mkOtherCon, otherCons,
#endif
\end{code}
+
%************************************************************************
%* *
-\subsection{@Unfolding@ and @UnfoldingGuidance@ types}
+\subsection{Making unfoldings}
%* *
%************************************************************************
\begin{code}
-data Unfolding
- = NoUnfolding
-
- | OtherCon [AltCon] -- It ain't one of these
- -- (OtherCon xs) also indicates that something has been evaluated
- -- and hence there's no point in re-evaluating it.
- -- OtherCon [] is used even for non-data-type values
- -- to indicated evaluated-ness. Notably:
- -- data C = C !(Int -> Int)
- -- case x of { C f -> ... }
- -- Here, f gets an OtherCon [] unfolding.
-
- | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
- -- so you'd better unfold.
-
- | CoreUnfolding -- An unfolding with redundant cached information
- CoreExpr -- Template; binder-info is correct
- Bool -- This is a top-level binding
- Bool -- exprIsCheap template (cached); it won't duplicate (much) work
- -- if you inline this in more than one place
- Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
- -- this variable
- Bool -- exprIsBottom template (cached)
- UnfoldingGuidance -- Tells about the *size* of the template.
-
-seqUnfolding :: Unfolding -> ()
-seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
- = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
-seqUnfolding other = ()
-\end{code}
-
-\begin{code}
-noUnfolding = NoUnfolding
-mkOtherCon = OtherCon
-
mkTopUnfolding cpr_info expr = mkUnfolding True {- Top level -} cpr_info expr
mkUnfolding top_lvl cpr_info expr
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= CompulsoryUnfolding (occurAnalyseGlobalExpr expr)
+\end{code}
-unfoldingTemplate :: Unfolding -> CoreExpr
-unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
-unfoldingTemplate (CompulsoryUnfolding expr) = expr
-unfoldingTemplate other = panic "getUnfoldingTemplate"
-
-maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
-maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
-maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
-maybeUnfoldingTemplate other = Nothing
-
-otherCons (OtherCon cons) = cons
-otherCons other = []
-
-isValueUnfolding :: Unfolding -> Bool
- -- Returns False for OtherCon
-isValueUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
-isValueUnfolding other = False
-
-isEvaldUnfolding :: Unfolding -> Bool
- -- Returns True for OtherCon
-isEvaldUnfolding (OtherCon _) = True
-isEvaldUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
-isEvaldUnfolding other = False
-
-isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _ _) = is_cheap
-isCheapUnfolding other = False
-
-isCompulsoryUnfolding :: Unfolding -> Bool
-isCompulsoryUnfolding (CompulsoryUnfolding _) = True
-isCompulsoryUnfolding other = False
-
-hasUnfolding :: Unfolding -> Bool
-hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
-hasUnfolding (CompulsoryUnfolding _) = True
-hasUnfolding other = False
-
-hasSomeUnfolding :: Unfolding -> Bool
-hasSomeUnfolding NoUnfolding = False
-hasSomeUnfolding other = True
-
-data UnfoldingGuidance
- = UnfoldNever
- | UnfoldIfGoodArgs Int -- and "n" value args
-
- [Int] -- Discount if the argument is evaluated.
- -- (i.e., a simplification will definitely
- -- be possible). One elt of the list per *value* arg.
-
- Int -- The "size" of the unfolding; to be elaborated
- -- later. ToDo
-
- Int -- Scrutinee discount: the discount to substract if the thing is in
- -- a context (case (thing args) of ...),
- -- (where there are the right number of arguments.)
-seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
-seqGuidance other = ()
-\end{code}
+%************************************************************************
+%* *
+\subsection{The UnfoldingGuidance type}
+%* *
+%************************************************************************
\begin{code}
instance Outputable UnfoldingGuidance where
\end{code}
-%************************************************************************
-%* *
-\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
-%* *
-%************************************************************************
-
\begin{code}
calcUnfoldingGuidance
:: Int -- bomb out if size gets bigger than this
module CoreUtils (
exprType, coreAltsType,
+ -- Construction
mkNote, mkInlineMe, mkSCC, mkCoerce,
+ bindNonRec, mkIfThenElse, mkAltExpr,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprArity,
+ exprArity, exprIsConApp_maybe,
idAppIsBottom, idAppIsCheap,
etaReduceExpr, exprEtaExpandArity,
+ -- Size
+ coreBindsSize,
+
+ -- Hashing
hashExpr,
+ -- Equality
cheapEqExpr, eqExpr, applyTypeToArgs
) where
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( isEvaldUnfolding )
-
import GlaExts -- For `xori`
import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( isId, isTyVar )
+import Var ( Var, isId, isTyVar )
import VarSet
import VarEnv
import Name ( isLocallyDefined, hashName )
import Literal ( Literal, hashLiteral, literalType )
+import DataCon ( DataCon, dataConRepArity )
import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
-import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
- idArity, idName, idUnfolding, idInfo
+import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, mkWildId,
+ idArity, idName, idUnfolding, idInfo, isDataConId_maybe
+
)
import IdInfo ( arityLowerBound, InlinePragInfo(..),
LBVarInfo(..),
IdFlavour(..),
- appIsBottom
- )
+ megaSeqIdInfo )
+import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy,
splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
- applyTys, isUnLiftedType
+ applyTys, isUnLiftedType, seqType
)
+import TysWiredIn ( boolTy, stringTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import Unique ( buildIdKey, augmentIdKey )
import Util ( zipWithEqual, mapAccumL )
+import Maybes ( maybeToBool )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
\end{code}
%************************************************************************
%* *
-\subsection{Attaching notes
+\subsection{Attaching notes}
%* *
%************************************************************************
%************************************************************************
%* *
+\subsection{Other expression construction}
+%* *
+%************************************************************************
+
+\begin{code}
+bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- (bindNonRec x r b) produces either
+-- let x = r in b
+-- or
+-- case r of x { _DEFAULT_ -> b }
+--
+-- depending on whether x is unlifted or not
+-- It's used by the desugarer to avoid building bindings
+-- that give Core Lint a heart attack. Actually the simplifier
+-- deals with them perfectly well.
+bindNonRec bndr rhs body
+ | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+ | otherwise = Let (NonRec bndr rhs) body
+\end{code}
+
+\begin{code}
+mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
+ -- This guy constructs the value that the scrutinee must have
+ -- when you are in one particular branch of a case
+mkAltExpr (DataAlt con) args inst_tys
+ = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
+mkAltExpr (LitAlt lit) [] []
+ = Lit lit
+
+mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+mkIfThenElse guard then_expr else_expr
+ = Case guard (mkWildId boolTy)
+ [ (DataAlt trueDataCon, [], then_expr),
+ (DataAlt falseDataCon, [], else_expr) ]
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Figuring out things about expressions}
%* *
%************************************************************************
exprArity other = 0
\end{code}
+\begin{code}
+exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
+exprIsConApp_maybe expr
+ = analyse (collectArgs expr)
+ where
+ analyse (Var fun, args)
+ | maybeToBool maybe_con_app = maybe_con_app
+ where
+ maybe_con_app = case isDataConId_maybe fun of
+ Just con | length args >= dataConRepArity con
+ -- Might be > because the arity excludes type args
+ -> Just (con, args)
+ other -> Nothing
+
+ analyse (Var fun, [])
+ = case maybeUnfoldingTemplate (idUnfolding fun) of
+ Nothing -> Nothing
+ Just unf -> exprIsConApp_maybe unf
+
+ analyse other = Nothing
+\end{code}
+
%************************************************************************
%* *
eq_note env other1 other2 = False
\end{code}
+
+%************************************************************************
+%* *
+\subsection{The size of an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+coreBindsSize :: [CoreBind] -> Int
+coreBindsSize bs = foldr ((+) . bindSize) 0 bs
+
+exprSize :: CoreExpr -> Int
+ -- A measure of the size of the expressions
+ -- It also forces the expression pretty drastically as a side effect
+exprSize (Var v) = varSize v
+exprSize (Lit lit) = 1
+exprSize (App f a) = exprSize f + exprSize a
+exprSize (Lam b e) = varSize b + exprSize e
+exprSize (Let b e) = bindSize b + exprSize e
+exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
+exprSize (Note n e) = exprSize e
+exprSize (Type t) = seqType t `seq`
+ 1
+
+exprsSize = foldr ((+) . exprSize) 0
+
+varSize :: Var -> Int
+varSize b | isTyVar b = 1
+ | otherwise = seqType (idType b) `seq`
+ megaSeqIdInfo (idInfo b) `seq`
+ 1
+
+varsSize = foldr ((+) . varSize) 0
+
+bindSize (NonRec b e) = varSize b + exprSize e
+bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
+
+pairSize (b,e) = varSize b + exprSize e
+
+altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Hashing}
)
import CoreSyn
+import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import DsMonad
import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
import Match ( matchWrapper, matchSimply )
-import CoreUtils ( exprType )
import CostCentre ( mkUserCC )
import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
import HsDecls ( extNameStatic )
import CallConv
import TcHsSyn ( TypecheckedForeignDecl )
-import CoreUtils ( exprType, mkInlineMe )
+import CoreUtils ( exprType, mkInlineMe, bindNonRec )
import DataCon ( DataCon, dataConWrapId )
import Id ( Id, idType, idName, mkWildId, mkVanillaId )
import MkId ( mkCCallOpId, mkWorkerId )
import DsUtils
import CmdLineOpts ( opt_FoldrBuildOn )
-import CoreUtils ( exprType )
+import CoreUtils ( exprType, mkIfThenElse )
import Id ( idType )
import Var ( Id, TyVar )
import PrelInfo ( foldrId, buildId )
import DsMonad
-import CoreUtils ( exprType )
+import CoreUtils ( exprType, mkIfThenElse )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
import Id ( idType, Id, mkWildId )
import Literal ( Literal )
import DsHsSyn ( outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
+import CoreUtils ( bindNonRec )
import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
import Desugar ( deSugar )
import SimplCore ( core2core )
import CoreLint ( endPass )
-import CoreSyn ( coreBindsSize )
+import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg )
import StgSyn ( collectFinalStgBinders, pprStgBindings )
import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon )
import DataCon ( DataCon, dataConTag, dataConRepArity, dataConTyCon, dataConId, fIRST_TAG )
import CoreUnfold ( maybeUnfoldingTemplate )
-import CoreUtils ( exprIsValue, cheapEqExpr )
+import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
import Type ( splitTyConApp_maybe )
import OccName ( occNameUserString)
import ThinAir ( unpackCStringFoldrId )
\begin{code}
dataToTagRule [_, val_arg]
- = case maybeConApp val_arg of
- Just dc -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
- Just (SLIT("DataToTag"),
- mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
+ = case exprIsConApp_maybe val_arg of
+ Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+ Just (SLIT("DataToTag"),
+ mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
- other -> Nothing
+ other -> Nothing
dataToTagRule other = Nothing
-
-maybeConApp :: CoreExpr -> Maybe DataCon
-maybeConApp (Var v)
- = case maybeUnfoldingTemplate (idUnfolding v) of
- Just unf -> maybeConApp unf
- Nothing -> Nothing
-
-maybeConApp expr
- = go expr 0
- where
- go (App f a) n | isTypeArg a = go f n
- | otherwise = go f (n+1)
- go (Var f) n = case isDataConId_maybe f of
- Just dc -> ASSERT( n == dataConRepArity dc )
- Just dc -- Check it's saturated
- other -> Nothing
- go other n = Nothing
\end{code}
%************************************************************************
import CmdLineOpts ( opt_D_dump_cse, opt_D_verbose_core2core )
import Id ( Id, idType )
-import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig )
+import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
import DataCon ( isUnboxedTupleCon )
import Type ( splitTyConApp_maybe )
import CoreSyn
import VarSet
import VarEnv
-import ThinAir ( noRepStrIds, noRepIntegerIds )
import Name ( isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
import CoreSyn
import CoreUnfold ( isValueUnfolding )
import CoreFVs ( exprFreeVars )
-import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity )
+import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
import Id ( Id, idType, isId, idName,
idOccInfo, idUnfolding,
import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate,
callSiteInline, hasSomeUnfolding, noUnfolding
)
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial, exprIsConApp_maybe,
exprType, coreAltsType, exprArity, exprIsValue, idAppIsCheap,
exprOkForSpeculation, etaReduceExpr,
- mkCoerce, mkSCC, mkInlineMe
+ mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
import Rules ( lookupRule )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
= complete_case scrut bndr alts se cont
where
- maybe_con_app = analyse (collectArgs scrut)
+ maybe_con_app = exprIsConApp_maybe scrut
Just (con, args) = maybe_con_app
- analyse (Var fun, args)
- | maybeToBool maybe_con_app = maybe_con_app
- where
- maybe_con_app = case isDataConId_maybe fun of
- Just con | length args >= dataConRepArity con
- -- Might be > because the arity excludes type args
- -> Just (con, args)
- other -> Nothing
-
- analyse (Var fun, [])
- = case maybeUnfoldingTemplate (idUnfolding fun) of
- Nothing -> Nothing
- Just unf -> analyse (collectArgs unf)
-
- analyse other = Nothing
-
-
-- See if we can get rid of the case altogether
-- See the extensive notes on case-elimination above
canEliminateCase scrut bndr alts
which might prevent some full laziness happening. I've seen this
in action in spectral/cichelli/Prog.hs:
[(m,n) | m <- [1..max], n <- [1..max]]
-Hence the add_eval_info argument
+Hence the no_case_of_case argument
If we do this, then we have to nuke any occurrence info (eg IAmDead)
happened. Hence the zap_occ_info function returned by simplCaseBinder
\begin{code}
-simplCaseBinder add_eval_info (Var v) case_bndr thing_inside
- | add_eval_info
+simplCaseBinder no_case_of_case (Var v) case_bndr thing_inside
+ | not no_case_of_case
= simplBinder (zap case_bndr) $ \ case_bndr' ->
modifyInScope v case_bndr' $
-- We could extend the substitution instead, but it would be
projects / ghc-hetmet.git / commitdiff