[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Fix irrelevant dodgy-foreign-imports warning on import f-pointers by value
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jan 31 17:19:01 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a557580f by Alexey Radkov at 2024-01-30T19:41:52-05:00
Fix irrelevant dodgy-foreign-imports warning on import f-pointers by value
A test *сс018* is attached (not sure about the naming convention though).
Note that without the fix, the test fails with the *dodgy-foreign-imports*
warning passed to stderr. The warning disappears after the fix.
GHC shouldn't warn on imports of natural function pointers from C by value
(which is feasible with CApiFFI), such as
```haskell
foreign import capi "cc018.h value f" f :: FunPtr (Int -> IO ())
```
where
```c
void (*f)(int);
```
See a related real-world use-case
[here](https://gitlab.com/daniel-casanueva/pcre-light/-/merge_requests/17).
There, GHC warns on import of C function pointer `pcre_free`.
- - - - -
ca99efaf by Alexey Radkov at 2024-01-30T19:41:53-05:00
Rename test cc018 -> T24034
- - - - -
88c38dd5 by Ben Gamari at 2024-01-30T19:42:28-05:00
rts/TraverseHeap.c: Ensure that PosixSource.h is included first
- - - - -
ca2e919e by Simon Peyton Jones at 2024-01-31T09:29:45+00:00
Make decomposeRuleLhs a bit more clever
This fixes #24370 by making decomposeRuleLhs undertand
dictionary /functions/ as well as plain /dictionaries/
- - - - -
64b252d2 by Teo Camarasu at 2024-01-31T12:18:55-05:00
doc: Add -Dn flag to user guide
Resolves #24394
- - - - -
11 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- docs/users_guide/runtime_control.rst
- rts/TraverseHeap.c
- + testsuite/tests/ffi/should_compile/T24034.h
- + testsuite/tests/ffi/should_compile/T24034.hs
- testsuite/tests/ffi/should_compile/all.T
- + testsuite/tests/simplCore/should_compile/T24370.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -1515,9 +1515,7 @@ modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks = minf_modBreaks
isDictonaryId :: Id -> Bool
-isDictonaryId id
- = case tcSplitSigmaTy (idType id) of {
- (_tvs, _theta, tau) -> isDictTy tau }
+isDictonaryId id = isDictTy (idType id)
-- | Looks up a global name: that is, any top-level name in any
-- visible module. Unlike 'lookupName', lookupGlobalName does not use
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -99,7 +99,14 @@ mkClassPred :: Class -> [Type] -> PredType
mkClassPred clas tys = mkTyConApp (classTyCon clas) tys
isDictTy :: Type -> Bool
-isDictTy = isClassPred
+-- True of dictionaries (Eq a) and
+-- dictionary functions (forall a. Eq a => Eq [a])
+-- See Note [Type determines value]
+-- See #24370 (and the isDictId call in GHC.HsToCore.Binds.decomposeRuleLhs)
+-- for why it's important to catch dictionary bindings
+isDictTy ty = isClassPred pred
+ where
+ (_, pred) = splitInvisPiTys ty
typeDeterminesValue :: Type -> Bool
-- See Note [Type determines value]
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -987,7 +987,16 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
= Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]
| otherwise = case decompose fun2 args2 of
- Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2)
+ Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
+ -- , text "orig_lhs:" <+> ppr orig_lhs
+ -- , text "rhs_fvs:" <+> ppr rhs_fvs
+ -- , text "orig_lhs:" <+> ppr orig_lhs
+ -- , text "lhs1:" <+> ppr lhs1
+ -- , text "lhs2:" <+> ppr lhs2
+ -- , text "fun2:" <+> ppr fun2
+ -- , text "args2:" <+> ppr args2
+ -- ]) $
+ Left (DsRuleLhsTooComplicated orig_lhs lhs2)
Just (fn_id, args)
| not (null unbound) ->
-- Check for things unbound on LHS
@@ -1059,7 +1068,9 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
split_lets (Let (NonRec d r) body)
- | isDictId d
+ | isDictId d -- Catches dictionaries, yes, but also catches dictionary
+ -- /functions/ arising from solving a
+ -- quantified contraint (#24370)
= ((d,r):bs, body')
where (bs, body') = split_lets body
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -356,7 +356,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh
dflags <- getDynFlags
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
- checkMissingAmpersand idecl (map scaledThing arg_tys) res_ty
+ checkMissingAmpersand idecl target (map scaledThing arg_tys) res_ty
case target of
StaticTarget _ _ _ False
| not (null arg_tys) ->
@@ -373,8 +373,10 @@ checkCTarget idecl (StaticTarget _ str _ _) = do
checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget"
-checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM ()
-checkMissingAmpersand idecl arg_tys res_ty
+checkMissingAmpersand :: ForeignImport GhcRn -> CCallTarget -> [Type] -> Type -> TcM ()
+checkMissingAmpersand _ (StaticTarget _ _ _ False) _ _ = return ()
+
+checkMissingAmpersand idecl _ arg_tys res_ty
| null arg_tys && isFunPtrTy res_ty
= addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl
| otherwise
=====================================
docs/users_guide/runtime_control.rst
=====================================
@@ -1408,6 +1408,7 @@ recommended for everyday use!
.. rts-flag:: -Dl DEBUG: linker
.. rts-flag:: -DL DEBUG: linker (verbose); implies :rts-flag:`-Dl`
.. rts-flag:: -Dm DEBUG: stm
+.. rts-flag:: -Dn DEBUG: non-moving garbage collector
.. rts-flag:: -Dz DEBUG: stack squeezing
.. rts-flag:: -Dc DEBUG: program coverage
.. rts-flag:: -Dr DEBUG: sparks
=====================================
rts/TraverseHeap.c
=====================================
@@ -9,10 +9,10 @@
#if defined(PROFILING)
-#include <string.h>
#include "rts/PosixSource.h"
#include "Rts.h"
#include "sm/Storage.h"
+#include <string.h>
#include "TraverseHeap.h"
=====================================
testsuite/tests/ffi/should_compile/T24034.h
=====================================
@@ -0,0 +1 @@
+void (*f)(int);
=====================================
testsuite/tests/ffi/should_compile/T24034.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE ForeignFunctionInterface, CApiFFI #-}
+module ShouldCompile where
+
+import Foreign
+foreign import capi "T24034.h value f" f :: FunPtr (Int -> IO ())
=====================================
testsuite/tests/ffi/should_compile/all.T
=====================================
@@ -47,3 +47,5 @@ test('T22043', normal, compile, [''])
test('T22774', unless(js_arch(), expect_fail), compile, [''])
+test('T24034', normal, compile, [''])
+
=====================================
testsuite/tests/simplCore/should_compile/T24370.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
+
+-- This gave "RULE left-hand side too complicated to desugar"
+-- in GHC 9.8
+
+module T24370 where
+
+f :: (Eq a, Eq a) => a -> b -> Int
+f = error "urk"
+
+{-# SPECIALISE f :: T Maybe -> b -> Int #-}
+
+instance (forall a. Eq a => Eq (f a)) => Eq (T f) where
+ a == b = False
+
+data T f = MkT (f Int)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -511,3 +511,4 @@ test('T21917', normal, compile, ['-O -fkeep-auto-rules -ddump-rules'])
test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-v0 -O'])
test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
+test('T24370', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a2ab5a206f1f21cc476d134301933457a1816cf0...64b252d2c907f8ff8541b879598be5a5385a41b3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a2ab5a206f1f21cc476d134301933457a1816cf0...64b252d2c907f8ff8541b879598be5a5385a41b3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240131/dffb2123/attachment-0001.html>
More information about the ghc-commits
mailing list