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.

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

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

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)

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,[''])

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# ->

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)

testsuite/tests/stranal/sigs/HyperStrUse.stderr

 
 ==================== 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