[commit: ghc] wip/nested-cpr: Strictify the demand on unlifted arguments (8c41989)

git at git.haskell.org git at git.haskell.org
Fri Jan 17 23:49:42 UTC 2014


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nested-cpr
Link       : http://ghc.haskell.org/trac/ghc/changeset/8c4198971ea529ab6e8e5e605dfaab5872db1550/ghc

>---------------------------------------------------------------

commit 8c4198971ea529ab6e8e5e605dfaab5872db1550
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.


>---------------------------------------------------------------

8c4198971ea529ab6e8e5e605dfaab5872db1550
 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 e7b8753..1b2aa4e 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 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/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 3b4b62b..3a7f56f 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -67,7 +67,7 @@ test('T1969',
              #            274932264 (x86/Linux)
              # 2012-10-08 303930948 (x86/Linux, new codegen)
              # 2013-02-10 322937684 (x86/OSX)
-           (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)
@@ -88,6 +88,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')
@@ -392,8 +394,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