Remove remaining uses of FFI under -fpure-haskell (#660)

All of these were standard C functions that GHC's JS backend
actually somewhat supports; their shims can be found in the
compiler source at "rts/js/mem.js".  But it seems simpler to
just get rid of all FFI uses with -fpure-haskell rather than
try to keep track of which functions GHC supports.

The pure Haskell implementation of memcmp runs about 6-7x as fast
as the simple one-byte-at-a-time implementation for long equal
buffers, which makes it...  about the same speed as the
pre-existing shim, even though the latter is also a one-byte-
at-a-time implementation!

Apparently GHC's JS backend is not yet able to produce efficient
code for tight loops like these yet; the biggest problem is that
it does not perform any loopification so each iteration must go
through a generic-call indirection.

Unfortunately that means that this patch probably makes 'strlen'
and 'memchr' much slower with the JS backend.

(cherry picked from commit 305604c)

Author: clyring

.gitignore

@@ -10,3 +10,4 @@ cabal.sandbox.config
 dist-newstyle/
 cabal.project.local*
 .nvimrc
+.ghc.environment*

Data/ByteString/Builder/ASCII.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE Trustworthy #-}
-
 {-# OPTIONS_HADDOCK not-home #-}
 
 -- | Copyright : (c) 2010 - 2011 Simon Meier

Data/ByteString/Builder/Prim/ASCII.hs

@@ -1,5 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-}
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- | Copyright   : (c) 2010 Jasper Van der Jeugt
 --                 (c) 2010 - 2011 Simon Meier
 -- License       : BSD3-style (see LICENSE)
@@ -82,7 +81,7 @@ import Data.ByteString.Builder.Prim.Binary
 import Data.ByteString.Builder.Prim.Internal
 import Data.ByteString.Builder.Prim.Internal.Floating
 import Data.ByteString.Builder.Prim.Internal.Base16
-import Data.ByteString.Utils.UnalignedWrite
+import Data.ByteString.Utils.UnalignedAccess
 
 import Data.Char (ord)
 

Data/ByteString/Builder/Prim/Binary.hs

@@ -57,7 +57,7 @@ module Data.ByteString.Builder.Prim.Binary (
 import Data.ByteString.Builder.Prim.Internal
 import Data.ByteString.Builder.Prim.Internal.Floating
 import Data.ByteString.Utils.ByteOrder
-import Data.ByteString.Utils.UnalignedWrite
+import Data.ByteString.Utils.UnalignedAccess
 
 import Foreign
 

Data/ByteString/Builder/RealFloat/Internal.hs

@@ -73,7 +73,7 @@ import Data.ByteString.Internal (c2w)
 import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim)
 import Data.ByteString.Builder.RealFloat.TableGenerator
 import Data.ByteString.Utils.ByteOrder
-import Data.ByteString.Utils.UnalignedWrite
+import Data.ByteString.Utils.UnalignedAccess
 #if PURE_HASKELL
 import qualified Data.ByteString.Internal.Pure as Pure
 #else

Data/ByteString/Internal/Pure.hs

@@ -7,8 +7,12 @@
 
 -- | Haskell implementation of C bits
 module Data.ByteString.Internal.Pure
-  ( -- * fpstring.c
-    intersperse
+  ( -- * standard string.h functions
+    strlen
+  , memchr
+  , memcmp
+    -- * fpstring.c
+  , intersperse
   , countOcc
   , countOccBA
   , reverseBytes
@@ -38,13 +42,65 @@ import GHC.Int                  (Int8(..))
 
 import Data.Bits                (Bits(..), shiftR, (.&.))
 import Data.Word
-import Foreign.Ptr              (plusPtr)
+import Foreign.Ptr              (plusPtr, nullPtr)
 import Foreign.Storable         (Storable(..))
 import Control.Monad            (when)
 import Control.Exception        (assert)
 
+import Data.ByteString.Utils.ByteOrder
+import Data.ByteString.Utils.UnalignedAccess
+
+----------------------------------------------------------------
+-- Haskell versions of standard functions in string.h
+----------------------------------------------------------------
+
+strlen :: Ptr Word8 -> IO Int
+strlen = go 0 where
+  go :: Int -> Ptr Word8 -> IO Int
+  go !acc !p = do
+    c <- peek p
+    if | c == 0 -> pure acc
+       | nextAcc <- acc + 1
+       , nextAcc >= 0 -> go nextAcc (p `plusPtr` 1)
+       | otherwise -> errorWithoutStackTrace
+           "bytestring: strlen: String length does not fit in a Haskell Int"
+
+memchr :: Ptr Word8 -> Word8 -> Int -> IO (Ptr Word8)
+memchr !p !target !len
+  | len == 0 = pure nullPtr
+  | otherwise = assert (len > 0) $ do
+      c <- peek p
+      if c == target
+        then pure p
+        else memchr (p `plusPtr` 1) target (len - 1)
+
+memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Int
+memcmp !p1 !p2 !len
+  | len >= 8 = do
+      w1 <- unalignedReadU64 p1
+      w2 <- unalignedReadU64 p2
+      let toBigEndian = whenLittleEndian byteSwap64
+      if | w1 == w2
+           -> memcmp (p1 `plusPtr` 8) (p2 `plusPtr` 8) (len - 8)
+         | toBigEndian w1 < toBigEndian w2
+           -> pure (0-1)
+         | otherwise -> pure 1
+  | otherwise = memcmp1 p1 p2 len
+
+-- | Like 'memcmp', but definitely scans one byte at a time
+memcmp1 :: Ptr Word8 -> Ptr Word8 -> Int -> IO Int
+memcmp1 !p1 !p2 !len
+  | len == 0 = pure 0
+  | otherwise = assert (len > 0) $ do
+      c1 <- peek p1
+      c2 <- peek p2
+      if | c1 == c2 -> memcmp1 (p1 `plusPtr` 1) (p2 `plusPtr` 1) (len - 1)
+         | c1 < c2   -> pure (0-1)
+         | otherwise -> pure 1
+
+
 ----------------------------------------------------------------
--- Haskell version of functions in fpstring.c
+-- Haskell versions of functions in fpstring.c
 ----------------------------------------------------------------
 
 -- | duplicate a string, interspersing the character through the elements of the
@@ -232,7 +288,7 @@ isValidUtf8' idx !len = go 0
 
 
 ----------------------------------------------------------------
--- Haskell version of functions in itoa.c
+-- Haskell versions of functions in itoa.c
 ----------------------------------------------------------------
 
 

Data/ByteString/Internal/Type.hs

@@ -1,11 +1,16 @@
-{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-}
-{-# LANGUAGE UnliftedFFITypes, MagicHash,
-            UnboxedTuples #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE Unsafe #-}
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ViewPatterns #-}
+
 {-# OPTIONS_HADDOCK not-home #-}
 
 -- |
@@ -129,11 +134,12 @@ import Prelude hiding (concat, null)
 import qualified Data.List as List
 
 import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr)
-import Foreign.Ptr              (Ptr, FunPtr, plusPtr)
+import Foreign.Ptr
 import Foreign.Storable         (Storable(..))
 import Foreign.C.Types
 import Foreign.C.String         (CString)
 import Foreign.Marshal.Utils
+import Foreign.Marshal.Alloc    (finalizerFree)
 
 #if PURE_HASKELL
 import qualified Data.ByteString.Internal.Pure as Pure
@@ -1104,24 +1110,42 @@ accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
 -- Standard C functions
 --
 
+memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
+memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt
+{-# DEPRECATED memset "Use Foreign.Marshal.Utils.fillBytes instead" #-}
+-- | deprecated since @bytestring-0.11.5.0@
+memset :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
+
+#if !PURE_HASKELL
+
 foreign import ccall unsafe "string.h strlen" c_strlen
     :: CString -> IO CSize
 
-foreign import ccall unsafe "static stdlib.h &free" c_free_finalizer
-    :: FunPtr (Ptr Word8 -> IO ())
-
 foreign import ccall unsafe "string.h memchr" c_memchr
     :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
-
-memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
 memchr p w sz = c_memchr p (fromIntegral w) sz
 
 foreign import ccall unsafe "string.h memcmp" c_memcmp
     :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt
-
-memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt
 memcmp p q s = c_memcmp p q (fromIntegral s)
 
+foreign import ccall unsafe "string.h memset" c_memset
+    :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
+memset p w sz = c_memset p (fromIntegral w) sz
+
+#else
+
+c_strlen :: CString -> IO CSize
+c_strlen p = checkedCast <$!> Pure.strlen (castPtr p)
+
+memchr p w len = Pure.memchr p w (checkedCast len)
+
+memcmp p q s = checkedCast <$!> Pure.memcmp p q s
+
+memset p w len = p <$ fillBytes p w (checkedCast len)
+
+#endif
+
 {-# DEPRECATED memcpy "Use Foreign.Marshal.Utils.copyBytes instead" #-}
 -- | deprecated since @bytestring-0.11.5.0@
 memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
@@ -1131,13 +1155,10 @@ memcpyFp :: ForeignPtr Word8 -> ForeignPtr Word8 -> Int -> IO ()
 memcpyFp fp fq s = unsafeWithForeignPtr fp $ \p ->
                      unsafeWithForeignPtr fq $ \q -> copyBytes p q s
 
-foreign import ccall unsafe "string.h memset" c_memset
-    :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
+c_free_finalizer :: FunPtr (Ptr Word8 -> IO ())
+c_free_finalizer = finalizerFree
+
 
-{-# DEPRECATED memset "Use Foreign.Marshal.Utils.fillBytes instead" #-}
--- | deprecated since @bytestring-0.11.5.0@
-memset :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
-memset p w sz = c_memset p (fromIntegral w) sz
 
 -- ---------------------------------------------------------------------
 --

Data/ByteString/Short/Internal.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE DeriveDataTypeable       #-}
 {-# LANGUAGE DeriveGeneric            #-}
 {-# LANGUAGE DeriveLift               #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE MagicHash                #-}

Data/ByteString/Utils/UnalignedWrite.hs renamed to Data/ByteString/Utils/UnalignedAccess.hs

@@ -1,16 +1,27 @@
+-- |
+-- Module      : Data.ByteString.Utils.UnalignedAccess
+-- Copyright   : (c) Matthew Craven 2023-2024
+-- License     : BSD-style
+-- Maintainer  : [email protected]
+-- Stability   : internal
+-- Portability : non-portable
+--
+-- Primitives for reading and writing at potentially-unaligned memory locations
+
 {-# LANGUAGE CPP #-}
 
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
 
 #include "bytestring-cpp-macros.h"
 
-module Data.ByteString.Utils.UnalignedWrite
+module Data.ByteString.Utils.UnalignedAccess
   ( unalignedWriteU16
   , unalignedWriteU32
   , unalignedWriteU64
   , unalignedWriteFloat
   , unalignedWriteDouble
+  , unalignedReadU64
   ) where
 
 import Foreign.Ptr
@@ -42,6 +53,10 @@ unalignedWriteDouble :: Double -> Ptr Word8 -> IO ()
 unalignedWriteDouble = coerce $ \(D# x#) (Ptr p#) s
   -> (# writeWord8OffAddrAsDouble# p# 0# x# s, () #)
 
+unalignedReadU64 :: Ptr Word8 -> IO Word64
+unalignedReadU64 = coerce $ \(Ptr p#) s
+  -> case readWord8OffAddrAsWord64# p# 0# s of
+       (# s', w64# #) -> (# s', W64# w64# #)
 
 #elif HS_UNALIGNED_POKES_OK
 import Foreign.Storable
@@ -61,6 +76,8 @@ unalignedWriteFloat x p = poke (castPtr p) x
 unalignedWriteDouble :: Double -> Ptr Word8 -> IO ()
 unalignedWriteDouble x p = poke (castPtr p) x
 
+unalignedReadU64 :: Ptr Word8 -> IO Word64
+unalignedReadU64 p = peek (castPtr p)
 
 #else
 foreign import ccall unsafe "static fpstring.h fps_unaligned_write_u16"
@@ -73,5 +90,7 @@ foreign import ccall unsafe "static fpstring.h fps_unaligned_write_HsFloat"
   unalignedWriteFloat :: Float -> Ptr Word8 -> IO ()
 foreign import ccall unsafe "static fpstring.h fps_unaligned_write_HsDouble"
   unalignedWriteDouble :: Double -> Ptr Word8 -> IO ()
+foreign import ccall unsafe "static fpstring.h fps_unaligned_read_u64"
+  unalignedReadU64 :: Ptr Word8 -> IO Word64
 #endif
 

bytestring.cabal

@@ -121,7 +121,7 @@ library
                      Data.ByteString.ReadInt
                      Data.ByteString.ReadNat
                      Data.ByteString.Utils.ByteOrder
-                     Data.ByteString.Utils.UnalignedWrite
+                     Data.ByteString.Utils.UnalignedAccess
 
   default-language:  Haskell2010
   other-extensions:  CPP,