[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: codeGen: Don't discard live case binders in unsafeEqualityProof logic
Marge Bot
gitlab at gitlab.haskell.org
Sun Jun 14 21:09:02 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9a7462fb by Ben Gamari at 2020-06-14T15:35:23-04:00
codeGen: Don't discard live case binders in unsafeEqualityProof logic
Previously CoreToStg would unconditionally discard cases of the form:
case unsafeEqualityProof of wild { _ -> rhs }
and rather replace the whole thing with `rhs`. However, in some cases
(see #18227) the case binder is still live, resulting in unbound
occurrences in `rhs`. Fix this by only discarding the case if the case
binder is dead.
Fixes #18227.
- - - - -
e4137c48 by Ben Gamari at 2020-06-14T15:35:23-04:00
testsuite: Add tests for #18227
T18227A is the original issue which gave rise to the ticket and depends
upon bytestring. T18227B is a minimized reproducer.
- - - - -
8bab9ff1 by Ben Gamari at 2020-06-14T15:35:59-04:00
hadrian: Fix rts include and library paths
Fixes two bugs:
* (?) and (<>) associated in a surprising way
* We neglected to include libdw paths in the rts configure flags
- - - - -
bd761185 by Ben Gamari at 2020-06-14T15:35:59-04:00
hadrian: Drop redundant GHC arguments
Cabal should already be passing this arguments to GHC.
- - - - -
01f7052c by Peter Trommler at 2020-06-14T15:36:38-04:00
FFI: Fix pass small ints in foreign call wrappers
The Haskell calling convention requires integer parameters smaller
than wordsize to be promoted to wordsize (where the upper bits are
don't care). To access such small integer parameter read a word from
the parameter array and then cast that word to the small integer
target type.
Fixes #15933
- - - - -
502647f7 by Krzysztof Gogolewski at 2020-06-14T15:37:14-04:00
Fix "ndecreasingIndentation" in manual (#18116)
- - - - -
9b4e9f34 by Moritz Angermann at 2020-06-14T17:08:54-04:00
Load .lo as well.
Some archives contain so called linker objects, with the affectionate
.lo suffic. For example the musl libc.a will come in that form. We
still want to load those objects, hence we should not discard them and
look for .lo as well. Ultimately we might want to fix this proerly by
looking at the file magic.
- - - - -
28c46663 by Vladislav Zavialov at 2020-06-14T17:08:54-04:00
User's Guide: KnownNat evidence is Natural
This bit of documentation got outdated after commit
1fcede43d2b30f33b7505e25eb6b1f321be0407f
- - - - -
18 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/HsToCore/Foreign/Decl.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/Tc/Instance/Class.hs
- docs/users_guide/exts/type_literals.rst
- docs/users_guide/flags.py
- hadrian/src/Settings/Packages.hs
- libraries/base/Unsafe/Coerce.hs
- rts/linker/LoadArchive.c
- + testsuite/tests/codeGen/should_compile/T18227A.hs
- + testsuite/tests/codeGen/should_compile/T18227B.hs
- testsuite/tests/codeGen/should_compile/all.T
- testsuite/tests/ffi/should_run/Makefile
- + testsuite/tests/ffi/should_run/T15933.h
- + testsuite/tests/ffi/should_run/T15933.hs
- + testsuite/tests/ffi/should_run/T15933.stdout
- + testsuite/tests/ffi/should_run/T15933_c.c
- testsuite/tests/ffi/should_run/all.T
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -435,7 +435,10 @@ coreToStgExpr e0@(Case scrut bndr _ alts) = do
let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2
-- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
case scrut2 of
- StgApp id [] | idName id == unsafeEqualityProofName ->
+ StgApp id [] | idName id == unsafeEqualityProofName
+ , isDeadBinder bndr ->
+ -- We can only discard the case if the case-binder is dead
+ -- It usually is, but see #18227
case alts2 of
[(_, [_co], rhs)] ->
return rhs
=====================================
compiler/GHC/HsToCore/Foreign/Decl.hs
=====================================
@@ -533,15 +533,36 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
SDoc, -- C type
Type, -- Haskell type
CmmType)] -- the CmmType
- arg_info = [ let stg_type = showStgType ty in
- (arg_cname n stg_type,
+ arg_info = [ let stg_type = showStgType ty
+ cmm_type = typeCmmType platform (getPrimTyOf ty)
+ stack_type
+ = if int_promote (typeTyCon ty)
+ then text "HsWord"
+ else stg_type
+ in
+ (arg_cname n stg_type stack_type,
stg_type,
ty,
- typeCmmType platform (getPrimTyOf ty))
+ cmm_type)
| (ty,n) <- zip arg_htys [1::Int ..] ]
- arg_cname n stg_ty
- | libffi = char '*' <> parens (stg_ty <> char '*') <>
+ int_promote ty_con
+ | ty_con `hasKey` int8TyConKey = True
+ | ty_con `hasKey` int16TyConKey = True
+ | ty_con `hasKey` int32TyConKey
+ , platformWordSizeInBytes platform > 4
+ = True
+ | ty_con `hasKey` word8TyConKey = True
+ | ty_con `hasKey` word16TyConKey = True
+ | ty_con `hasKey` word32TyConKey
+ , platformWordSizeInBytes platform > 4
+ = True
+ | otherwise = False
+
+
+ arg_cname n stg_ty stack_ty
+ | libffi = parens (stg_ty) <> char '*' <>
+ parens (stack_ty <> char '*') <>
text "args" <> brackets (int (n-1))
| otherwise = text ('a':show n)
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -74,6 +74,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
| otherwise = Nothing
-- ToDo: this might not be correct for 64-bit API
+ -- This is correct for the PowerPC ELF ABI version 1 and 2.
arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)
(platformWordSizeInBytes platform)
; cmm_args <- getFCallArgs stg_args typ
@@ -634,4 +635,3 @@ typeToStgFArgType typ
-- a type in a foreign function signature with a representationally
-- equivalent newtype.
tycon = tyConAppTyCon (unwrapType typ)
-
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -259,12 +259,12 @@ Note [KnownNat & KnownSymbol and EvLit]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A part of the type-level literals implementation are the classes
"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
-defining singleton values. Here is the key stuff from GHC.TypeLits
+defining singleton values. Here is the key stuff from GHC.TypeNats
class KnownNat (n :: Nat) where
natSing :: SNat n
- newtype SNat (n :: Nat) = SNat Integer
+ newtype SNat (n :: Nat) = SNat Natural
Conceptually, this class has infinitely many instances:
@@ -291,10 +291,10 @@ Also note that `natSing` and `SNat` are never actually exposed from the
library---they are just an implementation detail. Instead, users see
a more convenient function, defined in terms of `natSing`:
- natVal :: KnownNat n => proxy n -> Integer
+ natVal :: KnownNat n => proxy n -> Natural
The reason we don't use this directly in the class is that it is simpler
-and more efficient to pass around an integer rather than an entire function,
+and more efficient to pass around a Natural rather than an entire function,
especially when the `KnowNat` evidence is packaged up in an existential.
The story for kind `Symbol` is analogous:
=====================================
docs/users_guide/exts/type_literals.rst
=====================================
@@ -10,10 +10,10 @@ Numeric literals are of kind ``Nat``, while string literals are of kind
extension.
The kinds of the literals and all other low-level operations for this
-feature are defined in module ``GHC.TypeLits``. Note that the module
-defines some type-level operators that clash with their value-level
-counterparts (e.g. ``(+)``). Import and export declarations referring to
-these operators require an explicit namespace annotation (see
+feature are defined in modules ``GHC.TypeLits`` and ``GHC.TypeNats``.
+Note that these modules define some type-level operators that clash with their
+value-level counterparts (e.g. ``(+)``). Import and export declarations
+referring to these operators require an explicit namespace annotation (see
:ref:`explicit-namespaces`).
Here is an example of using type-level numeric literals to provide a
@@ -59,7 +59,8 @@ a type-level literal. This is done with the functions ``natVal`` and
These functions are overloaded because they need to return a different
result, depending on the type at which they are instantiated. ::
- natVal :: KnownNat n => proxy n -> Integer
+ natVal :: KnownNat n => proxy n -> Natural -- from GHC.TypeNats
+ natVal :: KnownNat n => proxy n -> Integer -- from GHC.TypeLits
-- instance KnownNat 0
-- instance KnownNat 1
@@ -79,7 +80,9 @@ will be unknown at compile-time, so it is hidden in an existential type.
The conversion may be performed using ``someNatVal`` for integers and
``someSymbolVal`` for strings: ::
- someNatVal :: Integer -> Maybe SomeNat
+ someNatVal :: Natural -> Maybe SomeNat -- from GHC.TypeNats
+ someNatVal :: Integer -> Maybe SomeNat -- from GHC.TypeLits
+
SomeNat :: KnownNat n => Proxy n -> SomeNat
The operations on strings are similar.
=====================================
docs/users_guide/flags.py
=====================================
@@ -255,14 +255,16 @@ class LanguageExtension(GenericFlag):
# Invert the flag
@staticmethod
def _noname(name):
- if name[:2] == "No":
+ # We check isupper() so that NondecreasingIndentation
+ # is not counted as "No-decreasingIndentation"
+ if name[:2] == "No" and name[2].isupper():
return name[2:]
else:
return "No%s" % name
@staticmethod
def _onname(name):
- if name[:2] == "No":
+ if name[:2] == "No" and name[2].isupper():
return name[2:]
else:
return name
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -273,10 +273,6 @@ rtsPackageArgs = package rts ? do
let ghcArgs = mconcat
[ arg "-Irts"
, arg $ "-I" ++ path
- , flag WithLibdw ? if not (null libdwIncludeDir) then arg ("-I" ++ libdwIncludeDir) else mempty
- , flag WithLibdw ? if not (null libdwLibraryDir) then arg ("-L" ++ libdwLibraryDir) else mempty
- , flag WithLibnuma ? if not (null libnumaIncludeDir) then arg ("-I" ++ libnumaIncludeDir) else mempty
- , flag WithLibnuma ? if not (null libnumaLibraryDir) then arg ("-L" ++ libnumaLibraryDir) else mempty
, arg $ "-DRtsWay=\"rts_" ++ show way ++ "\""
-- Set the namespace for the rts fs functions
, arg $ "-DFS_NAMESPACE=rts"
@@ -386,9 +382,12 @@ rtsPackageArgs = package rts ? do
, any (wayUnit Dynamic) rtsWays ? arg "dynamic"
, Debug `wayUnit` way ? arg "find-ptr"
]
- , builder (Cabal Setup) ?
- if not (null libnumaLibraryDir) then arg ("--extra-lib-dirs="++libnumaLibraryDir) else mempty
- <> if not (null libnumaIncludeDir) then arg ("--extra-include-dirs="++libnumaIncludeDir) else mempty
+ , builder (Cabal Setup) ? mconcat
+ [ if not (null libdwLibraryDir) then arg ("--extra-lib-dirs="++libdwLibraryDir) else mempty
+ , if not (null libdwIncludeDir) then arg ("--extra-include-dirs="++libdwIncludeDir) else mempty
+ , if not (null libnumaLibraryDir) then arg ("--extra-lib-dirs="++libnumaLibraryDir) else mempty
+ , if not (null libnumaIncludeDir) then arg ("--extra-include-dirs="++libnumaIncludeDir) else mempty
+ ]
, builder (Cc FindCDependencies) ? cArgs
, builder (Ghc CompileCWithGhc) ? map ("-optc" ++) <$> cArgs
, builder Ghc ? ghcArgs
=====================================
libraries/base/Unsafe/Coerce.hs
=====================================
@@ -106,6 +106,11 @@ several ways
unsafeEqualityProof to f. As (U5) says, it is implemented as
UnsafeRefl so all is good.
+ NB: Don't discard the case if the case-binder is used
+ case unsafeEqualityProof of wild_xx { UnsafeRefl ->
+ ...wild_xx...
+ That rarely happens, but see #18227.
+
(U3) In GHC.CoreToStg.Prep.cpeRhsE, if we see
let x = case unsafeEqualityProof ... of
UnsafeRefl -> K e
=====================================
rts/linker/LoadArchive.c
=====================================
@@ -461,6 +461,7 @@ static HsInt loadArchive_ (pathchar *path)
/* TODO: Stop relying on file extensions to determine input formats.
Instead try to match file headers. See #13103. */
isObject = (thisFileNameSize >= 2 && strncmp(fileName + thisFileNameSize - 2, ".o" , 2) == 0)
+ || (thisFileNameSize >= 3 && strncmp(fileName + thisFileNameSize - 3, ".lo" , 3) == 0)
|| (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".p_o", 4) == 0)
|| (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".obj", 4) == 0);
=====================================
testsuite/tests/codeGen/should_compile/T18227A.hs
=====================================
@@ -0,0 +1,6 @@
+module T18227A (kilter) where
+import Data.ByteString.Internal
+
+kilter :: ByteString -> IO ByteString
+kilter ps@(PS x _ _) = createAndTrim 1 $ const $ pure 1
+
=====================================
testsuite/tests/codeGen/should_compile/T18227B.hs
=====================================
@@ -0,0 +1,16 @@
+-- N.B. These warnings only cause noise in stderr.
+{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-inaccessible-code #-}
+{-# LANGUAGE GADTs #-}
+
+module T18227B where
+
+import Unsafe.Coerce
+
+test1 :: UnsafeEquality Int Char -> IO ()
+test1 hi = print "hello"
+{-# NOINLINE test1 #-}
+
+test2 :: IO ()
+test2 =
+ case unsafeEqualityProof :: UnsafeEquality Int Char of
+ proof at UnsafeRefl -> test1 proof
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -89,3 +89,5 @@ test('T14373d', [],
test('T17648', normal, makefile_test, [])
test('T17904', normal, compile, ['-O'])
+test('T18227A', normal, compile, [''])
+test('T18227B', normal, compile, [''])
=====================================
testsuite/tests/ffi/should_run/Makefile
=====================================
@@ -43,3 +43,9 @@ Capi_Ctype_002:
'$(TEST_HC)' $(TEST_HC_OPTS) Capi_Ctype_A_002.o Capi_Ctype_002.o -o Capi_Ctype_002
./Capi_Ctype_002
+.PHONY: T15933
+T15933:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T15933_c.c
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T15933.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) T15933_c.o T15933.o -o T15933
+ ./T15933
=====================================
testsuite/tests/ffi/should_run/T15933.h
=====================================
@@ -0,0 +1,2 @@
+typedef void(*hs_callback)(int x);
+extern void function_in_c(hs_callback cb);
=====================================
testsuite/tests/ffi/should_run/T15933.hs
=====================================
@@ -0,0 +1,17 @@
+module Main(main) where
+
+import Foreign
+import Foreign.C
+
+type HsCallback = CInt -> IO ()
+
+foreign import ccall "T15933.h function_in_c"
+ functionInC :: FunPtr HsCallback -> IO ()
+
+foreign import ccall "wrapper"
+ wrap :: HsCallback -> IO (FunPtr HsCallback)
+
+main = do
+ f <- wrap $ \x -> print x
+ functionInC f
+ freeHaskellFunPtr f
=====================================
testsuite/tests/ffi/should_run/T15933.stdout
=====================================
@@ -0,0 +1 @@
+10
=====================================
testsuite/tests/ffi/should_run/T15933_c.c
=====================================
@@ -0,0 +1,7 @@
+#include "T15933.h"
+
+void function_in_c(hs_callback cb)
+{
+ int x = 10;
+ cb(x);
+}
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -194,6 +194,8 @@ test('T12134', [omit_ways(['ghci'])], compile_and_run, ['T12134_c.c'])
test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c'])
+test('T15933', extra_files(['T15933_c.c', 'T15933.h']), makefile_test, ['T15933'])
+
test('T16650a', [omit_ways(['ghci'])], compile_and_run, ['T16650a_c.c'])
test('T16650b', [omit_ways(['ghci'])], compile_and_run, ['T16650b_c.c'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a568464e724702282eeebdfb0085285ce64cc49e...28c466637ef9a068117059d558615a0e5c5876ca
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a568464e724702282eeebdfb0085285ce64cc49e...28c466637ef9a068117059d558615a0e5c5876ca
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/20200614/56fd4e8e/attachment-0001.html>
More information about the ghc-commits
mailing list