[commit: ghc] wip/nested-cpr: Strictify the demand on unlifted arguments (ea313b8)
git at git.haskell.org
git at git.haskell.org
Wed Jan 15 18:06:39 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/ea313b831b0d77fb416841c1b246f0570c34e8ca/ghc
>---------------------------------------------------------------
commit ea313b831b0d77fb416841c1b246f0570c34e8ca
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Jan 15 16:52:23 2014 +0000
Strictify the demand on unlifted arguments
because they are trivially strict, and the primitive operations do not
have the strictness demand in their demand signature.
>---------------------------------------------------------------
ea313b831b0d77fb416841c1b246f0570c34e8ca
compiler/basicTypes/Demand.lhs | 6 +++++-
compiler/stranal/DmdAnal.lhs | 16 +++++++++++-----
testsuite/tests/numeric/should_compile/T7116.stdout | 8 ++++----
testsuite/tests/simplCore/should_compile/T3772.stdout | 4 ++--
testsuite/tests/simplCore/should_compile/T4930.stderr | 2 +-
testsuite/tests/stranal/sigs/HyperStrUse.stderr | 2 +-
6 files changed, 24 insertions(+), 14 deletions(-)
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index b857ef5..8a977ff 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -11,7 +11,7 @@ module Demand (
countOnce, countMany, -- cardinality
Demand, CleanDemand,
- mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
+ mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, strictifyDmd,
getUsage, toCleanDmd,
absDmd, topDmd, botDmd, seqDmd,
lubDmd, bothDmd, apply1Dmd, apply2Dmd,
@@ -185,6 +185,10 @@ bothStr (SProd s1) (SProd s2)
| otherwise = HyperStr -- Weird
bothStr (SProd _) (SCall _) = HyperStr
+strictifyDmd :: Demand -> Demand
+strictifyDmd (JD Lazy u) = (JD (Str HeadStr) u)
+strictifyDmd (JD s u) = (JD s u)
+
-- utility functions to deal with memory leaks
seqStrDmd :: StrDmd -> ()
seqStrDmd (SProd ds) = seqStrDmdList ds
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index a942c4e..f6c995c 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -28,7 +28,7 @@ import Id
import CoreUtils ( exprIsHNF, exprType, exprIsTrivial )
-- import PprCore
import TyCon
-import Type ( eqType )
+import Type ( eqType, isUnLiftedType )
-- import Pair
-- import Coercion ( coercionKind )
import Util
@@ -103,12 +103,18 @@ c) The application rule wouldn't be right either
evaluation of f in a C(L) demand!
\begin{code}
--- If e is complicated enough to become a thunk, its contents will be evaluated
--- at most once, so oneify it.
+-- This function modifies the demand on a paramater e in a call f e:
+-- * If e is complicated enough to become a thunk, its contents will be evaluated
+-- at most once, so oneify it.
+-- * If e is of an unlifted type, e will be evaluated before the actual call, so
+-- in that sense, the demand on e is strict.
dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
dmdTransformThunkDmd e
- | exprIsTrivial e = id
- | otherwise = oneifyDmd
+ = when (not (exprIsTrivial e)) oneifyDmd .
+ when (isUnLiftedType (exprType e)) strictifyDmd
+ where
+ when True f = f
+ when False _ = id
-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 549ed48..9b7f7c8 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -6,7 +6,7 @@ T7116.dl :: GHC.Types.Double -> GHC.Types.Double
[GblId,
Arity=1,
Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
@@ -24,7 +24,7 @@ T7116.dr :: GHC.Types.Double -> GHC.Types.Double
[GblId,
Arity=1,
Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
@@ -38,7 +38,7 @@ T7116.fl :: GHC.Types.Float -> GHC.Types.Float
[GblId,
Arity=1,
Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
@@ -56,7 +56,7 @@ T7116.fr :: GHC.Types.Float -> GHC.Types.Float
[GblId,
Arity=1,
Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout
index 6c7735e..6c418fa 100644
--- a/testsuite/tests/simplCore/should_compile/T3772.stdout
+++ b/testsuite/tests/simplCore/should_compile/T3772.stdout
@@ -4,7 +4,7 @@ Result size of Tidy Core = {terms: 29, types: 12, coercions: 0}
Rec {
xs :: GHC.Prim.Int# -> ()
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>]
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,U>]
xs =
\ (m :: GHC.Prim.Int#) ->
case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<=# m 1)
@@ -15,7 +15,7 @@ xs =
end Rec }
T3772.foo [InlPrag=NOINLINE] :: GHC.Types.Int -> ()
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U(U)>]
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S(S),1*U(U)>]
T3772.foo =
\ (n :: GHC.Types.Int) ->
case n of _ [Occ=Dead] { GHC.Types.I# n# ->
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 9570b7b..ee77e0c 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -13,7 +13,7 @@ T4930.foo1 = GHC.Err.error @ GHC.Types.Int lvl
T4930.foo :: GHC.Types.Int -> GHC.Types.Int
[GblId,
Arity=1,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
index 1a0ff33..6c5d487 100644
--- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr
+++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
@@ -1,5 +1,5 @@
==================== Strictness signatures ====================
-HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U>m
+HyperStrUse.f: <S(S(S)L),1*U(1*U(U),A)><S,1*U>m
More information about the ghc-commits
mailing list