From a127213c1890584702075d732d7bb9887113e4ff Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 27 Mar 2000 13:24:14 +0000 Subject: [PATCH] [project @ 2000-03-27 13:24:12 by simonpj] a) Move Unfolding and UnfoldingGuidance to CoreSyn As a result, remove several SOURCE imports Shrink CoreSyn.hi-boot considerably Delete CoreUnfold.hi-boot altogether b) Add CoreUtils.exprIsConApp_maybe Use in PrelRules to fix a bug in the dataToTag rule c) Fix boolean polarity error in Simplify.lhs --- ghc/compiler/DEPEND-NOTES | 15 ++- ghc/compiler/basicTypes/Id.lhs | 3 +- ghc/compiler/basicTypes/IdInfo.lhs | 6 +- ghc/compiler/coreSyn/CoreLint.lhs | 2 +- ghc/compiler/coreSyn/CoreSyn.hi-boot | 10 +- ghc/compiler/coreSyn/CoreSyn.hi-boot-5 | 10 +- ghc/compiler/coreSyn/CoreSyn.lhs | 207 +++++++++++++++++------------ ghc/compiler/coreSyn/CoreUnfold.hi-boot | 10 -- ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 | 8 -- ghc/compiler/coreSyn/CoreUnfold.lhs | 110 ++------------- ghc/compiler/coreSyn/CoreUtils.lhs | 132 ++++++++++++++++-- ghc/compiler/deSugar/DsExpr.lhs | 2 +- ghc/compiler/deSugar/DsForeign.lhs | 2 +- ghc/compiler/deSugar/DsListComp.lhs | 2 +- ghc/compiler/deSugar/DsUtils.lhs | 2 +- ghc/compiler/deSugar/Match.lhs | 1 + ghc/compiler/main/Main.lhs | 2 +- ghc/compiler/prelude/PrelRules.lhs | 29 +--- ghc/compiler/simplCore/CSE.lhs | 2 +- ghc/compiler/simplCore/OccurAnal.lhs | 1 - ghc/compiler/simplCore/SimplUtils.lhs | 2 +- ghc/compiler/simplCore/Simplify.lhs | 29 +--- 22 files changed, 289 insertions(+), 298 deletions(-) delete mode 100644 ghc/compiler/coreSyn/CoreUnfold.hi-boot delete mode 100644 ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index 859d1a2..3e67308 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -7,7 +7,7 @@ A 'loop' indicates a use from a module compiled later 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 @@ -30,19 +30,20 @@ then 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 diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 389631a..26bd799 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -70,9 +70,8 @@ module Id ( #include "HsVersions.h" -import {-# SOURCE #-} CoreUnfold ( Unfolding ) -import {-# SOURCE #-} CoreSyn ( CoreRules ) +import CoreSyn ( Unfolding, CoreRules ) import BasicTypes ( Arity ) import Var ( Id, DictId, isId, mkIdVar, diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 8546357..e7056de 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -28,7 +28,7 @@ module IdInfo ( -- Strictness; imported from Demand StrictnessInfo(..), mkStrictnessInfo, noStrictnessInfo, - ppStrictnessInfo,isBottomingStrictness, appIsBottom, + ppStrictnessInfo,isBottomingStrictness, strictnessInfo, setStrictnessInfo, @@ -71,9 +71,7 @@ module IdInfo ( #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, diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index c1e66ac..002d829 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -17,7 +17,7 @@ import IO ( hPutStr, hPutStrLn, stderr, stdout ) 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 ) diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot b/ghc/compiler/coreSyn/CoreSyn.hi-boot index 5002208..96be6dd 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot @@ -1,14 +1,8 @@ _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 ;; diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 index 49830e8..6031131 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 @@ -1,12 +1,6 @@ __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 ; diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 526fee5..febe178 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -13,8 +13,7 @@ module CoreSyn ( 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, @@ -24,11 +23,15 @@ module CoreSyn ( 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', @@ -42,17 +45,13 @@ module CoreSyn ( #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 @@ -153,6 +152,114 @@ rulesRules (Rules rules _) = rules %************************************************************************ %* * +\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} %* * %************************************************************************ @@ -225,10 +332,15 @@ mkIntLitInt :: Int -> Expr b 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)) @@ -253,47 +365,6 @@ varToCoreExpr v | isId v = Var v | 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} - %************************************************************************ %* * @@ -465,40 +536,6 @@ seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` se 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} %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot b/ghc/compiler/coreSyn/CoreUnfold.hi-boot deleted file mode 100644 index 149d225..0000000 --- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot +++ /dev/null @@ -1,10 +0,0 @@ -_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 ;; diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 b/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 deleted file mode 100644 index 319191e..0000000 --- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 +++ /dev/null @@ -1,8 +0,0 @@ -__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 ; diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 7df3b66..80f9a06 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -14,7 +14,7 @@ find, unsurprisingly, a Core expression. \begin{code} module CoreUnfold ( - Unfolding, UnfoldingGuidance, -- types + Unfolding, UnfoldingGuidance, -- Abstract types noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding, mkOtherCon, otherCons, @@ -69,48 +69,14 @@ import GlaExts ( fromInt ) #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 @@ -131,66 +97,14 @@ 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 @@ -203,12 +117,6 @@ 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 diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index c30c17b..131bd47 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -7,53 +7,62 @@ 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} @@ -118,7 +127,7 @@ applyTypeToArgs e op_ty (other_arg : args) %************************************************************************ %* * -\subsection{Attaching notes +\subsection{Attaching notes} %* * %************************************************************************ @@ -176,6 +185,44 @@ mkSCC cc expr = Note (SCC cc) expr %************************************************************************ %* * +\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} %* * %************************************************************************ @@ -435,6 +482,28 @@ exprArity (Note note e) | ok_note note = exprArity e 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} + %************************************************************************ %* * @@ -609,6 +678,49 @@ eqExpr e1 e2 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} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index a4c50c0..5e78e8e 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -20,6 +20,7 @@ import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, ) import CoreSyn +import CoreUtils ( exprType, mkIfThenElse, bindNonRec ) import DsMonad import DsBinds ( dsMonoBinds, AutoScc(..) ) @@ -29,7 +30,6 @@ import DsListComp ( dsListComp ) import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr ) import Match ( matchWrapper, matchSimply ) -import CoreUtils ( exprType ) import CostCentre ( mkUserCC ) import FieldLabel ( FieldLabel ) import Id ( Id, idType, recordSelectorFieldLabel ) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index f156660..4f03dbc 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -20,7 +20,7 @@ import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) ) 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 ) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index fd38e62..df05dd4 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -19,7 +19,7 @@ import DsMonad -- the monadery used in the desugarer import DsUtils import CmdLineOpts ( opt_FoldrBuildOn ) -import CoreUtils ( exprType ) +import CoreUtils ( exprType, mkIfThenElse ) import Id ( idType ) import Var ( Id, TyVar ) import PrelInfo ( foldrId, buildId ) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 81aaf42..3c95d90 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -38,7 +38,7 @@ import CoreSyn import DsMonad -import CoreUtils ( exprType ) +import CoreUtils ( exprType, mkIfThenElse ) import PrelInfo ( iRREFUT_PAT_ERROR_ID ) import Id ( idType, Id, mkWildId ) import Literal ( Literal ) diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 91bfde2..e69c50a 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -18,6 +18,7 @@ import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) import DsHsSyn ( outPatType ) import Check ( check, ExhaustivePat ) import CoreSyn +import CoreUtils ( bindNonRec ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index e252d73..3efd09c 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -27,7 +27,7 @@ import TcModule ( TcResults(..), typecheckModule ) 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 ) diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index c22f572..c7d5e1a 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -23,7 +23,7 @@ import TysWiredIn ( trueDataConId, falseDataConId ) 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 ) @@ -370,31 +370,14 @@ For dataToTag#, we can reduce if either \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} %************************************************************************ diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index 651165d..91cb81c 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -12,7 +12,7 @@ module CSE ( 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 diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 5a7fd19..2aefb2b 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -36,7 +36,6 @@ import IdInfo ( OccInfo(..), insideLam, copyIdInfo ) import VarSet import VarEnv -import ThinAir ( noRepStrIds, noRepIntegerIds ) import Name ( isLocallyDefined ) import Type ( splitFunTy_maybe, splitForAllTys ) import Maybes ( maybeToBool ) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 4f8e25c..58062d2 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -23,7 +23,7 @@ import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge ) 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, diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 2f88b17..9febaa7 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -48,10 +48,10 @@ import CoreFVs ( exprFreeVars ) 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 ) @@ -1141,26 +1141,9 @@ rebuild_case scrut bndr alts se cont = 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 @@ -1297,7 +1280,7 @@ If we eliminate the inner case, we trap it inside the I# v -> arm, 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) @@ -1316,8 +1299,8 @@ Urk! b is alive! Reason: the scrutinee was a variable, and case elimination 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 -- 1.7.10.4