diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index c6161c52cda79c0346b72a4f9a14d6bdd775d11b..c3a9f9a7c82f03783fc7d6c63bb05dbf1e2ff740 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 0000000000000000000000000000000000000000..f095cc1ff886dbd9b774a31ef8d95f90cabf67de --- /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 0000000000000000000000000000000000000000..8a17d8b29b6dda4a0b1cb3254960513ec620bec8 --- /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 0000000000000000000000000000000000000000..153a887ef6c8e891684ab79e6d0b46e93a7103b1 --- /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 0000000000000000000000000000000000000000..6e738a78a17880f60e2d4e6f482d2fcfc5580acf --- /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 8a82ce86a5a15759f457a03a888d3daf03f7feea..efd1afaa353a941d5c68f758b5415ff51f4fd65e 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 8de5d31a01db8fa8be08d005bd1b7518bcce268c..a457cc5f507e15b79d8d1dd2d74478a832bba1bd 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