X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcprAnalysis%2FCprAnalyse.lhs;h=cbc28442ea2faf5dc132170e6c17c7a95a87520c;hb=ba2843abdfe6f055777e4e66e8add769fce31d29;hp=a3901791292c403bd10f1d17ab0352b99acc1615;hpb=9aa6d18bd696e8861fb8c3e065e49a989d2d67ac;p=ghc-hetmet.git diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index a390179..cbc2844 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -2,16 +2,21 @@ constructed product result} \begin{code} +#ifndef OLD_STRICTNESS +module CprAnalyse ( ) where + +#else + module CprAnalyse ( cprAnalyse ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import CoreLint ( beginPass, endPass ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import CoreLint ( showPass, endPass ) import CoreSyn import CoreUtils ( exprIsValue ) import Id ( Id, setIdCprInfo, idCprInfo, idArity, - isBottomingId, idDemandInfo ) + isBottomingId, idDemandInfo, isImplicitId ) import IdInfo ( CprInfo(..) ) import Demand ( isStrict ) import VarEnv @@ -91,10 +96,6 @@ data AbsVal = Top -- Not a constructed product -- we could use appropriate Tuple Vals deriving (Eq,Show) -isFun :: AbsVal -> Bool -isFun (Fun _) = True -isFun _ = False - -- For pretty debugging instance Outputable AbsVal where ppr Top = ptext SLIT("Top") @@ -137,11 +138,10 @@ ids decorated with their CprInfo pragmas. cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind] cprAnalyse dflags binds = do { - beginPass dflags "Constructed Product analysis" ; + showPass dflags "Constructed Product analysis" ; let { binds_plus_cpr = do_prog binds } ; endPass dflags "Constructed Product analysis" - (dopt Opt_D_dump_cpranal dflags || dopt Opt_D_verbose_core2core dflags) - binds_plus_cpr + Opt_D_dump_cpranal binds_plus_cpr } where do_prog :: [CoreBind] -> [CoreBind] @@ -156,6 +156,9 @@ with ids decorated with their CPR info. -- Return environment extended with info from this binding cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind) cprAnalBind rho (NonRec b e) + | isImplicitId b -- Don't touch the CPR info on constructors, selectors etc + = (rho, NonRec b e) + | otherwise = (extendVarEnv rho b absval, NonRec b' e') where (e', absval) = cprAnalExpr rho e @@ -308,4 +311,5 @@ getCprAbsVal v = case idCprInfo v of arity = idArity v -- Imported (non-nullary) constructors will have the CPR property -- in their IdInfo, so no need to look at their unfolding +#endif /* OLD_STRICTNESS */ \end{code}