[commit: ghc] ghc-7.8: Fix demand analyser for unboxed types (642d599)

git at git.haskell.org git at git.haskell.org
Wed Jul 2 16:11:39 UTC 2014


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

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/642d5992ba89788bd2b488f60bbc1f0c990dae43/ghc

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

commit 642d5992ba89788bd2b488f60bbc1f0c990dae43
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Jul 1 13:31:18 2014 +0100

    Fix demand analyser for unboxed types
    
    This is a tricky case exposed by Trac #9254.  I'm surprised it hasn't
    shown up before, because it's happens when you use unsafePerformIO in
    the right way.
    
    Anyway, fixed now.  See Note [Analysing with absent demand]
    in Demand.lhs
    
    (cherry picked from commit d6ee82b29598dcc1028773dd987b7a2fb17519b7)


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

642d5992ba89788bd2b488f60bbc1f0c990dae43
 compiler/basicTypes/Demand.lhs                     | 59 +++++++++++++++++++---
 compiler/stranal/DmdAnal.lhs                       |  2 +-
 testsuite/tests/stranal/should_run/T9254.hs        | 20 ++++++++
 .../should_run/T9254.stdout}                       |  0
 testsuite/tests/stranal/should_run/all.T           |  1 +
 5 files changed, 74 insertions(+), 8 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index db5ac5c..fcef7a6 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
@@ -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 31996cb..972d830 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 0000000..279eb5c
--- /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/codeGen/should_run/T3207.stdout b/testsuite/tests/stranal/should_run/T9254.stdout
similarity index 100%
copy from testsuite/tests/codeGen/should_run/T3207.stdout
copy to testsuite/tests/stranal/should_run/T9254.stdout
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index 0c43aac..2ca65b5 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, [''])



More information about the ghc-commits mailing list