Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/8b88ba07b414349fcdc08bc326cfdbb45fb9d46f >--------------------------------------------------------------- commit 8b88ba07b414349fcdc08bc326cfdbb45fb9d46f Author: Ilya Sergey <[email protected]> Date: Tue Jul 10 21:51:17 2012 +0100 new demand information in IdInfo propagated >--------------------------------------------------------------- compiler/basicTypes/IdInfo.lhs | 1 - compiler/basicTypes/MkId.lhs | 5 +++-- compiler/basicTypes/NewDemand.lhs | 7 +++++++ compiler/coreSyn/CoreTidy.lhs | 2 ++ compiler/coreSyn/MkCore.lhs | 5 +++-- compiler/coreSyn/PprCore.lhs | 2 +- compiler/iface/BinIface.hs | 1 - compiler/iface/TcIface.lhs | 1 - compiler/simplCore/SimplCore.lhs | 3 ++- compiler/simplCore/Simplify.lhs | 1 + 10 files changed, 19 insertions(+), 9 deletions(-) diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 8ba02f7..67e69d8 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -330,7 +330,6 @@ vanillaIdInfo occInfo = NoOccInfo, demandInfo = Nothing, strictnessInfo = Nothing, - nd_demandInfo = Nothing, nd_strictnessInfo = Nothing } diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 8791df5..793c4dc 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -257,6 +257,7 @@ mkDataConIds wrap_name wkr_name data_con wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) nd_wkr_sig = ND.mkStrictSig (ND.mkTopDmdType (replicate wkr_arity ND.top) ND.topRes) + -- Note [Data-con worker strictness] -- Notice that we do *not* say the worker is strict -- even if the data constructor is declared strict @@ -747,7 +748,7 @@ mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op = id where - (tyvars,arg_tys,res_ty, arity, strict_sig, nd_strict_sig) = primOpSig prim_op + (tyvars,arg_tys,res_ty, arity, strict_sig, _nd_strict_sig) = primOpSig prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) @@ -758,7 +759,7 @@ mkPrimOpId prim_op `setSpecInfo` mkSpecInfo (primOpRules prim_op name) `setArityInfo` arity `setStrictnessInfo` Just strict_sig - `nd_setStrictnessInfo` Just nd_strict_sig +-- `nd_setStrictnessInfo` Just nd_strict_sig -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs index 2721900..190386a 100644 --- a/compiler/basicTypes/NewDemand.lhs +++ b/compiler/basicTypes/NewDemand.lhs @@ -34,6 +34,13 @@ import Util import BasicTypes import Binary +{-! for StrDmd derive: Binary !-} +{-! for AbsDmd derive: Binary !-} +{-! for Demand derive: Binary !-} +{-! for DmdResult derive: Binary !-} +{-! for DmdType derive: Binary !-} +{-! for StrictSig derive: Binary !-} + \end{code} %************************************************************************ diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index e29c50c..44393a6 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -172,7 +172,9 @@ tidyLetBndr rec_tidy_env env (id,rhs) new_info = idInfo new_id `setArityInfo` exprArity rhs `setStrictnessInfo` strictnessInfo idinfo + `nd_setStrictnessInfo` nd_strictnessInfo idinfo `setDemandInfo` demandInfo idinfo + `nd_setDemandInfo` nd_demandInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` new_unf diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index b841db3..ab8b709 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -75,7 +75,8 @@ import Coercion import TysPrim import DataCon ( DataCon, dataConWorkId ) import IdInfo ( vanillaIdInfo, setStrictnessInfo, - nd_setStrictnessInfo, setArityInfo ) + nd_setStrictnessInfo, + setArityInfo ) import Demand import qualified NewDemand as ND import Name hiding ( varName ) @@ -750,6 +751,6 @@ pc_bottoming_Id name ty strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes) nd_strict_sig = ND.mkStrictSig (ND.mkTopDmdType [ND.strictlyUsedDmd] ND.botRes) - -- These "bottom" out, no matter what their arguments + -- These "bottom" out, no matter what their arguments \end{code} diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index dad895a..2f77a80 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -379,7 +379,7 @@ ppIdInfo id info has_strictness = isJust str_info nd_str_info = nd_strictnessInfo info - nd_has_strictness = isJust str_info + nd_has_strictness = isJust nd_str_info unf_info = unfoldingInfo info has_unf = hasSomeUnfolding unf_info diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 7bb25ac..55d6300 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -388,7 +388,6 @@ data BinSymbolTable = BinSymbolTable { -- indexed by Name } - putFastString :: BinDictionary -> BinHandle -> FastString -> IO () putFastString dict bh fs = allocateFastString dict fs >>= put_ bh diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c7e292b..0e3d029 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1184,7 +1184,6 @@ tcIdInfo ignore_prags name ty info tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str) - tcPrag info (ND_HsStrictness str) = return (info `nd_setStrictnessInfo` Just str) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 348b12f..edb9aff 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -916,7 +916,8 @@ transferIdInfo exported_id local_id = modifyIdInfo transfer exported_id where local_info = idInfo local_id - transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + `nd_setStrictnessInfo` nd_strictnessInfo local_info `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info `setSpecInfo` addSpecInfo (specInfo exp_info) new_info diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 115dd94..e2a2644 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -459,6 +459,7 @@ prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] ; return (env', Cast rhs' co) } where sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `nd_setStrictnessInfo` nd_strictnessInfo info `setDemandInfo` demandInfo info info = idInfo id _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
