diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index db5ac5c72aad0e2b9db4f5f6c54e658b1f2b6279..fcef7a61b2dcc21320654e4e92243d30145593b6 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -64,7 +64,7 @@ import BasicTypes
import Binary
import Maybes ( orElse )
-import Type ( Type )
+import Type ( Type, isUnLiftedType )
import TyCon ( isNewTyCon, isClassTyCon )
import DataCon ( splitDataProductType_maybe )
\end{code}
@@ -1139,13 +1139,18 @@ type DeferAndUse -- Describes how to degrade a result type
type DeferAndUseM = Maybe DeferAndUse
-- Nothing <=> absent-ify the result type; it will never be used
-toCleanDmd :: Demand -> (CleanDemand, DeferAndUseM)
--- See Note [Analyzing with lazy demand and lambdas]
-toCleanDmd (JD { strd = s, absd = u })
+toCleanDmd :: Demand -> Type -> (CleanDemand, DeferAndUseM)
+toCleanDmd (JD { strd = s, absd = u }) expr_ty
= case (s,u) of
- (Str s', Use c u') -> (CD { sd = s', ud = u' }, Just (False, c))
- (Lazy, Use c u') -> (CD { sd = HeadStr, ud = u' }, Just (True, c))
- (_, Abs) -> (CD { sd = HeadStr, ud = Used }, Nothing)
+ (Str s', Use c u') -> -- The normal case
+ (CD { sd = s', ud = u' }, Just (False, c))
+
+ (Lazy, Use c u') -> -- See Note [Analyzing with lazy demand and lambdas]
+ (CD { sd = HeadStr, ud = u' }, Just (True, c))
+
+ (_, Abs) -- See Note [Analysing with absent demand]
+ | isUnLiftedType expr_ty -> (CD { sd = HeadStr, ud = Used }, Just (False, One))
+ | otherwise -> (CD { sd = HeadStr, ud = Used }, Nothing)
-- This is used in dmdAnalStar when post-processing
-- a function's argument demand. So we only care about what
@@ -1320,13 +1325,13 @@ cardinality analysis of the following example:
{-# NOINLINE build #-}
build g = (g (:) [], g (:) [])
-h c z = build (\x ->
- let z1 = z ++ z
+h c z = build (\x ->
+ let z1 = z ++ z
in if c
then \y -> x (y ++ z1)
else \y -> x (z1 ++ y))
-One can see that `build` assigns to `g` demand <L,C(C1(U))>.
+One can see that `build` assigns to `g` demand <L,C(C1(U))>.
Therefore, when analyzing the lambda `(\x -> ...)`, we
expect each lambda \y -> ... to be annotated as "one-shot"
one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a
@@ -1335,6 +1340,46 @@ demand <C(C(..), C(C1(U))>.
This is achieved by, first, converting the lazy demand L into the
strict S by the second clause of the analysis.
+Note [Analysing with absent demand]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we analyse an expression with demand <L,A>. The "A" means
+"absent", so this expression will never be needed. What should happen?
+There are several wrinkles:
+
+* We *do* want to analyse the expression regardless.
+ Reason: Note [Always analyse in virgin pass]
+
+ But we can post-process the results to ignore all the usage
+ demands coming back. This is done by postProcessDmdTypeM.
+
+* But in the case of an *unlifted type* we must be extra careful,
+ because unlifted values are evaluated even if they are not used.
+ Example (see Trac #9254):
+ f :: (() -> (# Int#, () #)) -> ()
+ -- Strictness signature is
+ -- <C(S(LS)), 1*C1(U(A,1*U()))>
+ -- I.e. calls k, but discards first component of result
+ f k = case k () of (# _, r #) -> r
+
+ g :: Int -> ()
+ g y = f (\n -> (# case y of I# y2 -> y2, n #))
+
+ Here f's strictness signature says (correctly) that it calls its
+ argument function and ignores the first component of its result.
+ This is correct in the sense that it'd be fine to (say) modify the
+ function so that always returned 0# in the first component.
+
+ But in function g, we *will* evaluate the 'case y of ...', because
+ it has type Int#. So 'y' will be evaluated. So we must record this
+ usage of 'y', else 'g' will say 'y' is absent, and will w/w so that
+ 'y' is bound to an aBSENT_ERROR thunk.
+
+ An alternative would be to replace the 'case y of ...' with (say) 0#,
+ but I have not tried that. It's not a common situation, but it is
+ not theoretical: unsafePerformIO's implementation is very very like
+ 'f' above.
+
+
%************************************************************************
%* *
Demand signatures
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 31996cb99a4d1a39c7a1b32ba2951ccfa09084c2..972d83096b10576e21d576d5e016af089a80e8db 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -118,7 +118,7 @@ dmdAnalStar :: AnalEnv
-> Demand -- This one takes a *Demand*
-> CoreExpr -> (BothDmdArg, CoreExpr)
dmdAnalStar env dmd e
- | (cd, defer_and_use) <- toCleanDmd dmd
+ | (cd, defer_and_use) <- toCleanDmd dmd (exprType e)
, (dmd_ty, e') <- dmdAnal env cd e
= (postProcessDmdTypeM defer_and_use dmd_ty, e')
diff --git a/testsuite/tests/stranal/should_run/T9254.hs b/testsuite/tests/stranal/should_run/T9254.hs
new file mode 100644
index 0000000000000000000000000000000000000000..279eb5c1ec15e9990d47732929288fe3b68defe6
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T9254.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+module Main where
+import GHC.Exts
+
+f :: (() -> (# Int#, () #)) -> ()
+{-# NOINLINE f #-}
+-- Strictness signature was (7.8.2)
+-- <C(S(LS)), 1*C1(U(A,1*U()))>
+-- I.e. calls k, but discards first component of result
+f k = case k () of (# _, r #) -> r
+
+g :: Int -> ()
+g y = f (\n -> (# case y of I# y2 -> h (h (h (h (h (h (h y2)))))), n #))
+ -- RHS is big enough to force worker/wrapper
+
+{-# NOINLINE h #-}
+h :: Int# -> Int#
+h n = n +# 1#
+
+main = print (g 1)
diff --git a/testsuite/tests/stranal/should_run/T9254.stdout b/testsuite/tests/stranal/should_run/T9254.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..6a452c185a8c94a4e4835a6f6999fe3f78957951
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T9254.stdout
@@ -0,0 +1 @@
+()
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index 0c43aac8c4add6c5897beefb99d885cf2eee91b7..2ca65b511038d6d6bcb08e431498b22b097fd05a 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -7,3 +7,4 @@ test('strun003', normal, compile_and_run, [''])
test('strun004', normal, compile_and_run, [''])
test('T2756b', normal, compile_and_run, [''])
test('T7649', normal, compile_and_run, [''])
+test('T9254', normal, compile_and_run, [''])