[commit: ghc] wip/nested-cpr: Strictify the demand on unlifted arguments (889e02f)
git at git.haskell.org
git at git.haskell.org
Tue Feb 4 18:26:40 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/889e02f3e1681d4270d8047cbcc72a09ab45064d/ghc
>---------------------------------------------------------------
commit 889e02f3e1681d4270d8047cbcc72a09ab45064d
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.
>---------------------------------------------------------------
889e02f3e1681d4270d8047cbcc72a09ab45064d
compiler/basicTypes/Demand.lhs | 6 +++++-
compiler/stranal/DmdAnal.lhs | 16 +++++++++++-----
testsuite/tests/numeric/should_compile/T7116.stdout | 8 ++++----
testsuite/tests/perf/compiler/all.T | 8 ++++++--
testsuite/tests/simplCore/should_compile/T3772.stdout | 4 ++--
testsuite/tests/simplCore/should_compile/T4930.stderr | 2 +-
testsuite/tests/stranal/sigs/HyperStrUse.stderr | 2 +-
7 files changed, 30 insertions(+), 16 deletions(-)
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index e415c6d..3c410c0 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,
@@ -183,6 +183,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 e9a7ab4..d578a3f 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 FamInstEnv
@@ -104,12 +104,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/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index c77655b..46eec23 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -69,7 +69,7 @@ test('T1969',
# 2012-10-08 303930948 (x86/Linux, new codegen)
# 2013-02-10 322937684 (x86/OSX)
# 2014-01-22 316103268 (x86/Linux)
- (wordsize(64), 698612512, 5)]),
+ (wordsize(64), 663200424, 5)]),
# 17/11/2009 434845560 (amd64/Linux)
# 08/12/2009 459776680 (amd64/Linux)
# 17/05/2010 519377728 (amd64/Linux)
@@ -90,6 +90,8 @@ test('T1969',
# (^ new demand analyser)
# 18/10/2013 698612512 (x86_64/Linux)
# (fix for #8456)
+ # 2014-01-17 663200424 (amd64/Linux)
+ # (^ strictify demand on unlifted arguments)
only_ways(['normal']),
extra_hc_opts('-dcore-lint -static')
@@ -395,8 +397,10 @@ test('T6048',
[(wordsize(32), 48887164, 10),
# prev: 38000000 (x86/Linux)
# 2012-10-08: 48887164 (x86/Linux)
- (wordsize(64), 108578664, 10)])
+ (wordsize(64), 95762056, 10)])
# 18/09/2012 97247032 amd64/Linux
# 16/01/2014 108578664 amd64/Linux (unknown)
+ # 2014-01-17 95762056 (amd64/Linux)
+ # (^ strictify demand on unlifted arguments)
],
compile,[''])
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