[Git][ghc/ghc][wip/T25272] Fix Lift Bytes and Lift ByteArray when using RebindableSyntax

[Teo Camarasu (@teo)]

Teo Camarasu pushed to branch wip/T25272 at Glasgow Haskell Compiler / GHC


Commits:
ecdaedac by Teo Camarasu at 2024-09-18T14:08:12+01:00
Fix Lift Bytes and Lift ByteArray when using RebindableSyntax

Previously these Lift instances could not be used with a custom
fromInteger introduced by RebindableSyntax.

We implement the same workaround as: https://github.com/haskell/text/pull/534
to fix this.

Resolves #25272

- - - - -


6 changed files:

- docs/users_guide/9.12.1-notes.rst
- libraries/base/src/Data/Array/Byte.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- + testsuite/tests/th/T25272.hs
- testsuite/tests/th/TH_Lift.stderr
- testsuite/tests/th/all.T


Changes:

=====================================
docs/users_guide/9.12.1-notes.rst
=====================================
@@ -159,6 +159,8 @@ Runtime system
 
 - The `deprecation process of GHC.Pack <https://gitlab.haskell.org/ghc/ghc/-/issues/21461>` has come its term. The module has now been removed from ``base``.
 
+- Fix `Lift ByteArray` instance when using a user overriden `fromInteger` function through `RebindableSyntax`.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 


=====================================
libraries/base/src/Data/Array/Byte.hs
=====================================
@@ -203,7 +203,7 @@ instance Show ByteArray where
 instance Lift ByteArray where
   liftTyped = unsafeCodeCoerce . lift
   lift (ByteArray b) =
-    [| addrToByteArray $(lift len)
+    [| addrToByteArray $(pure . LitE . IntPrimL $ fromIntegral len)
                        $(pure . LitE . BytesPrimL $ Bytes ptr 0 (fromIntegral len))
     |]
     where
@@ -221,8 +221,8 @@ instance Lift ByteArray where
       ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb))
 
 {-# NOINLINE addrToByteArray #-}
-addrToByteArray :: Int -> Addr# -> ByteArray
-addrToByteArray (I# len) addr = runST $ ST $
+addrToByteArray :: Int# -> Addr# -> ByteArray
+addrToByteArray len addr = runST $ ST $
   \s -> case newByteArray# len s of
     (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of
       s'' -> case unsafeFreezeByteArray# mb s'' of


=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -350,8 +350,9 @@ instance Lift Bytes where
   lift bytes at Bytes{} = -- See Note [Why FinalPtr]
     [| Bytes
       { bytesPtr = ForeignPtr $(Lib.litE (BytesPrimL bytes)) FinalPtr
-      , bytesOffset = 0
-      , bytesSize = $(lift (bytesSize bytes))
+      -- we cannot use Lift Word here because of #25267 and #25272
+      , bytesOffset = W# 0##
+      , bytesSize = W# $(Lib.litE . WordPrimL . fromIntegral $ bytesSize bytes)
       }
     |]
 -- | @since template-haskell-2.22.1.0


=====================================
testsuite/tests/th/T25272.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+module T25272 where
+import Prelude (Integer, String, ($), (>>=), mempty)
+import qualified Prelude
+import GHC.Exts (ByteArray#)
+import GHC.IO (IO(..))
+import Language.Haskell.TH.Syntax (lift, Bytes(..), runIO)
+import Foreign.Ptr (nullPtr)
+import Foreign.ForeignPtr (newForeignPtr_)
+import Data.Array.Byte
+
+fromInteger :: Integer -> String
+fromInteger _ = "yikes"
+
+x :: Bytes
+x = $(do
+  let fromInteger = Prelude.fromInteger
+  b <- runIO $ newForeignPtr_ nullPtr
+  lift $ Bytes b 0 0
+  )
+
+y :: ByteArray
+y = $(lift (mempty :: ByteArray))


=====================================
testsuite/tests/th/TH_Lift.stderr
=====================================
@@ -182,7 +182,7 @@ TH_Lift.hs:(93,10)-(99,13): Splicing expression
     Bytes
       {bytesPtr = GHC.Internal.ForeignPtr.ForeignPtr
                     "Hello"# GHC.Internal.ForeignPtr.FinalPtr,
-       bytesOffset = 0, bytesSize = 5}
+       bytesOffset = GHC.Types.W# 0##, bytesSize = GHC.Types.W# 5##}
 TH_Lift.hs:90:10-59: Splicing expression
     examineCode [|| 3 + 4 ||] `bindCode` liftTyped
   ======>


=====================================
testsuite/tests/th/all.T
=====================================
@@ -630,3 +630,4 @@ test('T25252',
    req_th,
    req_c],
   compile_and_run, ['-fPIC T25252_c.c'])
+test('T25272', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ecdaedac2e240741ac36aff277422b0c9edb4653

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ecdaedac2e240741ac36aff277422b0c9edb4653
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/20240918/6eefd0a2/attachment-0001.html>