Allow ByteArray to be marshalled in foreign importswip/marshal-bytearray

This allows you to use the wrapped version of ByteArray as an argument
to a foreign import rather than having to manually unwrap it yourself.

For example, you can now write:

```
foreign import capi  unsafe "string.h strlen"
  c_strlen_capi_lifted :: ByteArray -> IO CSize
```

rather than

```
foreign import capi  unsafe "string.h strlen"
     c_strlen_capi :: ByteArray# -> IO CSize
```

Fixes #20620

6 files changed, 52 insertions, 5 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 905fb6c8dc..6a3316d7ac 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -543,7 +543,7 @@ gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
     aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS,
     cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,
     gHC_TYPENATS, gHC_TYPENATS_INTERNAL,
-    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module
+    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, bYTE_ARRAY :: Module
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
 gHC_PRIM_PANIC  = mkPrimModule (fsLit "GHC.Prim.Panic")
@@ -611,6 +611,7 @@ gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal")
 dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")
 dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")
 uNSAFE_COERCE   = mkBaseModule (fsLit "Unsafe.Coerce")
+bYTE_ARRAY      = mkBaseModule (fsLit "Data.Array.Byte")
 
 gHC_SRCLOC :: Module
 gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
@@ -1782,7 +1783,7 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey,
     ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,
     stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey,
     smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,
-    stringTyConKey :: Unique
+    stringTyConKey, byteArrayTyConKey :: Unique
 addrPrimTyConKey                        = mkPreludeTyConUnique  1
 arrayPrimTyConKey                       = mkPreludeTyConUnique  3
 boolTyConKey                            = mkPreludeTyConUnique  4
@@ -1824,6 +1825,7 @@ stablePtrPrimTyConKey                   = mkPreludeTyConUnique 38
 stablePtrTyConKey                       = mkPreludeTyConUnique 39
 eqTyConKey                              = mkPreludeTyConUnique 40
 heqTyConKey                             = mkPreludeTyConUnique 41
+byteArrayTyConKey                       = mkPreludeTyConUnique 42
 
 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     mutVarPrimTyConKey, ioTyConKey,
@@ -2090,6 +2092,9 @@ ordLTDataConKey                         = mkPreludeDataConUnique 27
 ordEQDataConKey                         = mkPreludeDataConUnique 28
 ordGTDataConKey                         = mkPreludeDataConUnique 29
 
+byteArrayDataConKey :: Unique
+byteArrayDataConKey                     = mkPreludeDataConUnique 30
+
 
 coercibleDataConKey                     = mkPreludeDataConUnique 32
 
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 347afad5c0..9986996723 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -43,6 +43,9 @@ module GHC.Builtin.Types (
         -- * Double
         doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,
 
+        -- * ByteArray
+        byteArrayTyCon, byteArrayDataCon, byteArrayTy, byteArrayTyConName,
+
         -- * Float
         floatTyCon, floatDataCon, floatTy, floatTyConName,
 
@@ -290,6 +293,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
 
                 , anyTyCon
                 , boolTyCon
+                , byteArrayTyCon
                 , charTyCon
                 , stringTyCon
                 , doubleTyCon
@@ -420,6 +424,10 @@ floatDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#")
 doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey   doubleTyCon
 doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")     doubleDataConKey doubleDataCon
 
+byteArrayTyConName, byteArrayDataConName :: Name
+byteArrayTyConName = mkWiredInTyConName   UserSyntax  bYTE_ARRAY (fsLit "ByteArray") byteArrayTyConKey byteArrayTyCon
+byteArrayDataConName = mkWiredInDataConName UserSyntax  bYTE_ARRAY (fsLit "ByteArray") byteArrayDataConKey byteArrayDataCon
+
 -- Any
 
 {-
@@ -1797,7 +1805,18 @@ boxing_constr_env
 For a handful of primitive types (Int, Char, Word, Float, Double),
 we can readily box and an unboxed version (Int#, Char# etc) using
 the corresponding data constructor.  This is useful in a couple
-of places, notably let-floating -}
+of places, notably let-floating.
+
+Note that you have to be quite careful what you put in here because the compiler
+can introduce references to these constructors before they are defined.
+For example, ByteArray wraps a ByteArray# but can't be used as a boxing constructor
+because it is defined in `base`, which depends on `ghc-bignum` which uses ByteArray#
+and so the compiler introduces references to ByteArray too early.
+
+A future improvement might be to guard the use of a boxing constructor to packages
+whose dependencies include the boxing constructor.
+
+-}
 
 
 charTy :: Type
@@ -1876,6 +1895,20 @@ doubleTyCon = pcTyCon doubleTyConName
 doubleDataCon :: DataCon
 doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
 
+-- Byte Array
+
+byteArrayTy :: Type
+byteArrayTy = mkTyConTy byteArrayTyCon
+
+byteArrayTyCon :: TyCon
+byteArrayTyCon = pcTyCon byteArrayTyConName
+                      Nothing []
+                      [byteArrayDataCon]
+
+byteArrayDataCon :: DataCon
+byteArrayDataCon = pcDataCon byteArrayDataConName [] [byteArrayPrimTy] byteArrayTyCon
+
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 6570867898..ab0273abfc 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -59,6 +59,8 @@ module GHC.Builtin.Types.Prim(
         floatPrimTyCon,         floatPrimTy, floatPrimTyConName,
         doublePrimTyCon,        doublePrimTy, doublePrimTyConName,
 
+        byteArrayPrimTyConName,
+
         statePrimTyCon,         mkStatePrimTy,
         realWorldTyCon,         realWorldTy, realWorldStatePrimTy,
 
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 3575dda036..7fe21037bd 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -755,6 +755,8 @@ toCType = f False
            -- (which is marshalled like a Ptr)
            | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
               = (Nothing, text "const void*")
+           | Just byteArrayTyCon        == tyConAppTyConPicky_maybe t
+              = (Nothing, text "const void*")
            | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
               = (Nothing, text "void*")
            -- Otherwise we don't know the C type. If we are allowing
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 807ad0ab56..30b723dcca 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -2246,7 +2246,7 @@ boxedMarshalableTyCon tc
                          , word32TyConKey, word64TyConKey
                          , floatTyConKey, doubleTyConKey
                          , ptrTyConKey, funPtrTyConKey
-                         , charTyConKey
+                         , charTyConKey, byteArrayTyConKey
                          , stablePtrTyConKey
                          , boolTyConKey
                          ]
diff --git a/testsuite/tests/ffi/should_run/T9274.hs b/testsuite/tests/ffi/should_run/T9274.hs
index 814deff093..8b70a1580e 100644
--- a/testsuite/tests/ffi/should_run/T9274.hs
+++ b/testsuite/tests/ffi/should_run/T9274.hs
@@ -9,16 +9,21 @@ module Main where
 import qualified Data.ByteString.Short.Internal as SBS
 import           Foreign.C.Types
 import           GHC.Exts
+import           Data.Array.Byte
 
 foreign import capi  unsafe "string.h strlen"
     c_strlen_capi :: ByteArray# -> IO CSize
 
+foreign import capi  unsafe "string.h strlen"
+    c_strlen_capi_lifted :: ByteArray -> IO CSize
+
 foreign import capi  unsafe "string.h memset"
     c_memset_capi :: MutableByteArray# s -> CInt -> CSize -> IO ()
 
 main :: IO ()
 main = do
     n <- c_strlen_capi ba#
-    print (n == 13)
+    n' <- c_strlen_capi_lifted (ByteArray ba#)
+    print (n == 13 && n == n')
   where
     !(SBS.SBS ba#) = "Hello FFI!!!!\NUL"