[commit: ghc] ghc-7.10: Change demand information for foreign calls (86318ff)

[git at git.haskell.org]

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

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/86318ff9572a79819b02f9a79b855fa4d4a41df2/ghc

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

commit 86318ff9572a79819b02f9a79b855fa4d4a41df2
Author: Luite Stegeman <stegeman at gmail.com>
Date:   Thu Nov 12 11:13:54 2015 +0100

    Change demand information for foreign calls
    
    Foreign calls may not be strict for lifted arguments. Fixes Trac #11076.
    
    Test Plan: ./validate
    
    Reviewers: simonpj, bgamari, austin
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1464
    
    GHC Trac Issues: #11076


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

86318ff9572a79819b02f9a79b855fa4d4a41df2
 compiler/basicTypes/MkId.hs                        |  5 ++++-
 testsuite/tests/stranal/should_run/T11076.hs       | 15 +++++++++++++++
 testsuite/tests/stranal/should_run/T11076.stdout   |  1 +
 testsuite/tests/stranal/should_run/T11076A.hs      | 21 +++++++++++++++++++++
 testsuite/tests/stranal/should_run/T11076_prim.cmm | 10 ++++++++++
 testsuite/tests/stranal/should_run/all.T           |  1 +
 testsuite/tests/stranal/sigs/T8598.stderr          |  2 +-
 7 files changed, 53 insertions(+), 2 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index c6161c5..c3a9f9a 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -941,8 +941,11 @@ mkFCallId dflags uniq fcall ty
     (_, tau)        = tcSplitForAllTys ty
     (arg_tys, _)    = tcSplitFunTys tau
     arity           = length arg_tys
-    strict_sig      = mkClosedStrictSig (replicate arity evalDmd) topRes
 
+    strict_sig      = mkClosedStrictSig (replicate arity topDmd) topRes
+    -- the call does not claim to be strict in its arguments, since they
+    -- may be lifted (foreign import prim) and the called code doen't
+    -- necessarily force them. See Trac #11076.
 {-
 ************************************************************************
 *                                                                      *
diff --git a/testsuite/tests/stranal/should_run/T11076.hs b/testsuite/tests/stranal/should_run/T11076.hs
new file mode 100644
index 0000000..f095cc1
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T11076.hs
@@ -0,0 +1,15 @@
+{-
+   Test case for a problem where GHC had incorrect strictness
+   information for foreign calls with lifted arguments
+ -}
+{-# OPTIONS_GHC -O0 #-}
+module Main where
+
+import T11076A
+import Control.Exception
+x :: Bool
+x = error "OK: x has been forced"
+
+main :: IO ()
+main = print (testBool x) `catch`
+          \(ErrorCall e) -> putStrLn e -- x should be forced
diff --git a/testsuite/tests/stranal/should_run/T11076.stdout b/testsuite/tests/stranal/should_run/T11076.stdout
new file mode 100644
index 0000000..8a17d8b
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T11076.stdout
@@ -0,0 +1 @@
+OK: x has been forced
diff --git a/testsuite/tests/stranal/should_run/T11076A.hs b/testsuite/tests/stranal/should_run/T11076A.hs
new file mode 100644
index 0000000..153a887
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T11076A.hs
@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -O #-}
+{-# LANGUAGE MagicHash,
+             ForeignFunctionInterface,
+             UnliftedFFITypes,
+             GHCForeignImportPrim,
+             BangPatterns
+  #-}
+module T11076A where
+
+import GHC.Exts
+import Unsafe.Coerce
+
+{-
+   If the demand type for the foreign call argument is incorrectly strict,
+   the bang pattern can be optimized out
+ -}
+testBool :: Bool -> Int
+testBool !x = I# (cmm_testPrim (unsafeCoerce x))
+{-# INLINE testBool #-}
+
+foreign import prim "testPrim" cmm_testPrim :: Any -> Int#
diff --git a/testsuite/tests/stranal/should_run/T11076_prim.cmm b/testsuite/tests/stranal/should_run/T11076_prim.cmm
new file mode 100644
index 0000000..6e738a7
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T11076_prim.cmm
@@ -0,0 +1,10 @@
+#include "Cmm.h"
+#include "MachDeps.h"
+
+testPrim(gcptr x)
+{
+  W_ a;
+  a = 123;
+  return (a);
+}
+
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index 8a82ce8..efd1afa 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -10,3 +10,4 @@ test('T7649', normal, compile_and_run, [''])
 test('T9254', normal, compile_and_run, [''])
 test('T10148', normal, compile_and_run, [''])
 test('T10218', normal, compile_and_run, [''])
+test('T11076', normal, multimod_compile_and_run, ['T11076.hs', 'T11076_prim.cmm'])
diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr
index 8de5d31..a457cc5 100644
--- a/testsuite/tests/stranal/sigs/T8598.stderr
+++ b/testsuite/tests/stranal/sigs/T8598.stderr
@@ -1,5 +1,5 @@
 
 ==================== Strictness signatures ====================
-T8598.fun: <S(S),1*U(U)>m
+T8598.fun: <S,1*U(U)>m