ByteString: More efficient IO read/write

lib/Data/ByteString.hs

@@ -157,22 +157,34 @@ import Prelude(Bool(..), Int, Char, Ordering, FilePath, IO, Maybe(..), [](..), S
                (.), ($), Enum(..), (||), (&&), not, otherwise, (!!), fst, snd)
 import qualified Prelude as P
 import qualified Data.List as P
-import Data.List.NonEmpty(NonEmpty, fromList)
+import Control.Exception (evaluate)
+import Data.List.NonEmpty (NonEmpty, fromList)
 import Data.Bits
+import Data.Function (($!))
 import Data.Monoid.Internal
 import Data.Semigroup
 import Data.String
-import Data.Word(Word8)
-import Foreign.C.String(CString, CStringLen)
-import System.IO(Handle, IOMode(..), stdin, stdout)
+import Data.Word (Word8)
+import Foreign.C.String (CString, CStringLen)
+import Foreign.Ptr (Ptr)
+import System.IO (Handle, IOMode(..), hClose, openFile, stdin, stdout)
 import qualified System.IO as P
+import System.IO.Internal (BFILE, withHandleRd, withHandleWr)
 import Foreign.ForeignPtr
 import Data.ByteString.Internal
 
+foreign import ccall "readb" c_readb :: CString -> Int -> Ptr BFILE -> IO Int
+foreign import ccall "writeb" c_writeb :: CString -> Int -> Ptr BFILE -> IO Int
+
 type StrictByteString = ByteString
 
-primBS2FPtr   :: ByteString -> ForeignPtr Char
-primBS2FPtr   = _primitive "I"  -- same representation
+primBS2FPtr :: ByteString -> ForeignPtr Char
+primBS2FPtr = _primitive "bs2fp"
+
+-- Warning: This function modifies the `ForeignPtr`,
+-- avoid using the `ForeignPtr` after calling `primFPtr2BS`.
+primFPtr2BS :: ForeignPtr Char -> Int -> ByteString
+primFPtr2BS = _primitive "fp2bs"
 
 bsUnimp :: String -> a
 bsUnimp s = P.error $ "Data.ByteString." P.++ s P.++ " unimplemented"
@@ -344,7 +356,7 @@ takeEnd n bs
   | otherwise = substr bs (l - n) n
   where l = length bs
 
-drop  :: Int -> ByteString -> ByteString
+drop :: Int -> ByteString -> ByteString
 drop n bs
   | n <= 0    = bs
   | n >= l    = empty
@@ -520,7 +532,7 @@ useAsCString bs act =
 
 useAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a
 useAsCStringLen bs act =
-  withForeignPtr (primBS2FPtr bs) $ \ p -> act (p, length bs)
+  withForeignPtr (primBS2FPtr bs) $ \p -> act (p, length bs)
 
 packCString :: CString -> IO ByteString
 packCString cstr = bsUnimp "packCString"
@@ -538,7 +550,11 @@ hGetLine :: Handle -> IO ByteString
 hGetLine = fmap fromString . P.hGetLine
 
 hPut :: Handle -> ByteString -> IO ()
-hPut h = P.hPutStr h . toString
+hPut h bs =
+  withHandleWr h $ \bfile ->
+    useAsCStringLen bs $ \(cstr, len) ->
+      () <$ c_writeb cstr len bfile
+      -- XXX: flush if not BlockBuffering
 
 hPutNonBlocking :: Handle -> ByteString -> IO ByteString
 hPutNonBlocking = bsUnimp "hPutNonBlocking"
@@ -550,7 +566,11 @@ putStr :: ByteString -> IO ()
 putStr = hPut stdout
 
 hGet :: Handle -> Int -> IO ByteString
-hGet h i = bsUnimp "hGet"
+hGet h i =
+  withHandleRd h $ \bfile -> do
+    fp <- mallocForeignPtrBytes i
+    bytesRead <- withForeignPtr fp $ \buf -> c_readb buf i bfile
+    return $! primFPtr2BS fp bytesRead
 
 hGetNonBlocking :: Handle -> Int -> IO ByteString
 hGetNonBlocking h i = bsUnimp "hGetNonBlocking"
@@ -559,7 +579,20 @@ hGetSome :: Handle -> Int -> IO ByteString
 hGetSome h i = bsUnimp "hGetSome"
 
 hGetContents :: Handle -> IO ByteString
-hGetContents = fmap fromString . P.hGetContents
+hGetContents h =
+  withHandleRd h $ \bfile -> do
+    let
+      readChunks chunkSize chunks = do
+        fp <- mallocForeignPtrBytes chunkSize
+        bytesRead <- withForeignPtr fp $ \buf -> c_readb buf chunkSize bfile
+        if bytesRead < chunkSize then
+          -- EOF
+          evaluate $ chunks `append` primFPtr2BS fp bytesRead
+        else
+          readChunks (chunkSize * 2) (chunks `append` primFPtr2BS fp bytesRead)
+    bs <- readChunks 1024 empty
+    hClose h
+    return bs
 
 getContents :: IO ByteString
 getContents = hGetContents stdin
@@ -568,10 +601,18 @@ interact :: (ByteString -> ByteString) -> IO ()
 interact transformer = getContents >>= putStr . transformer
 
 readFile :: FilePath -> IO ByteString
-readFile = fmap fromString . P.readFile
+readFile f = do
+  h <- openFile f ReadMode
+  hGetContents h
 
 writeFile :: FilePath -> ByteString -> IO ()
-writeFile f = P.writeFile f . toString
+writeFile f bs = do
+  h <- openFile f WriteMode
+  hPut h bs
+  hClose h
 
 appendFile :: FilePath -> ByteString -> IO ()
-appendFile f = P.appendFile f . toString
+appendFile f bs = do
+  h <- openFile f AppendMode
+  hPut h bs
+  hClose h

src/MicroHs/FFI.hs

@@ -176,6 +176,7 @@ runtimeFFI = [
   "cos", "exp", "flushb", "fopen", "free", "getb", "getenv", "iswindows", "log", "malloc",
   "md5Array", "md5BFILE", "md5String", "memcpy", "memmove",
   "putb", "sin", "sqrt", "system", "tan", "tmpname", "ungetb", "unlink",
+  "readb", "writeb",
   "peekPtr", "pokePtr", "pokeWord", "peekWord",
   "add_lz77_compressor", "add_lz77_decompressor",
   "add_rle_compressor", "add_rle_decompressor",

src/MicroHs/Translate.hs

@@ -164,5 +164,7 @@ primTable = [
   ("fp+", _primitive "fp+"),
   ("fp2p", _primitive "fp2p"),
   ("fpnew", _primitive "fpnew"),
-  ("fpfin", _primitive "fpfin")
+  ("fpfin", _primitive "fpfin"),
+  ("fp2bs", _primitive "fp2bs"),
+  ("bs2fp", _primitive "bs2fp")
   ]

src/runtime/bfile.c

@@ -64,15 +64,11 @@ size_t
 bfbuffer_read(struct bfbuffer *bf, uint8_t *buf, size_t size)
 {
   if (bf->pos + size > bf->size) {
-    size_t max_size = bf->size - bf->pos;
-    memcpy(buf, bf->buf + bf->pos, max_size);
-    bf->pos = bf->size;
-    return max_size;
-  } else {
-    memcpy(buf, bf->buf + bf->pos, size);
-    bf->pos += size;
-    return size;
+    size = bf->size - bf->pos;
   }
+  memcpy(buf, bf->buf + bf->pos, size);
+  bf->pos += size;
+  return size;
 }
 
 size_t

src/runtime/eval.c

@@ -247,6 +247,7 @@ enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_DBL, T_PTR, T_FUNPTR, T_FORPTR, T_
                 T_POPCOUNT, T_CLZ, T_CTZ,
                 T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE, T_ICMP, T_UCMP,
                 T_FPADD, T_FP2P, T_FPNEW, T_FPFIN, // T_FPSTR,
+                T_FP2BS, T_BS2FP,
                 T_TOPTR, T_TOINT, T_TODBL, T_TOFUNPTR,
                 T_BININT2, T_BININT1, T_UNINT1,
                 T_BINDBL2, T_BINDBL1, T_UNDBL1,
@@ -806,6 +807,8 @@ struct {
   { "fpnew", T_FPNEW },
   { "fpfin", T_FPFIN },
   //  { "fpstr", T_FPSTR },
+  { "fp2bs", T_FP2BS },
+  { "bs2fp", T_BS2FP },
   { "seq", T_SEQ },
   { "equal", T_EQUAL, T_EQUAL },
   { "sequal", T_EQUAL, T_EQUAL },
@@ -2317,6 +2320,8 @@ printrec(BFILE *f, struct print_bits *pb, NODEPTR n, int prefix)
   case T_FPNEW: putsb("fpnew", f); break;
   case T_FPFIN: putsb("fpfin", f); break;
     //  case T_FPSTR: putsb("fpstr", f); break;
+  case T_FP2BS: putsb("fp2bs", f); break;
+  case T_BS2FP: putsb("bs2fp", f); break;
   case T_EQUAL: putsb("equal", f); break;
   case T_COMPARE: putsb("compare", f); break;
   case T_RNF: putsb("rnf", f); break;
@@ -2740,7 +2745,7 @@ evalforptr(NODEPTR n)
   return FORPTR(n);
 }
 
-/* Evaluate to a T_BSTR */
+/* Evaluate to a bytestring */
 struct forptr *
 evalbstr(NODEPTR n)
 {
@@ -3399,11 +3404,31 @@ evali(NODEPTR an)
 #undef CONV
 
   case T_FPADD: CHECK(2); xfp = evalforptr(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); POP(2); n = TOP(-1); SETFORPTR(n, addForPtr(xfp, yi)); RET;
-  case T_FP2P:  CHECK(1);
-    //printf("T_FP2P\n");
-    xfp = evalforptr(ARG(TOP(0))); POP(1); n = TOP(-1);
-    //printf("T_FP2P xfp=%p, payload=%p\n", xfp, xfp->payload);
-    SETPTR(n, xfp->payload.string); RET;
+  case T_FP2P:
+    CHECK(1);
+    xfp = evalforptr(ARG(TOP(0)));
+    POP(1);
+    n = TOP(-1);
+    SETPTR(n, xfp->payload.string);
+    RET;
+
+  case T_FP2BS:
+    CHECK(2);
+    xfp = evalforptr(ARG(TOP(0)));
+    xi = evalint(ARG(TOP(1)));
+    POP(2);
+    n = TOP(-1);
+    xfp->payload.size = xi;
+    SETBSTR(n, xfp);
+    RET;
+
+  case T_BS2FP:
+    CHECK(1);
+    xfp = evalbstr(ARG(TOP(0)));
+    POP(1);
+    n = TOP(-1);
+    SETFORPTR(n, xfp);
+    RET;
 
   case T_ARR_EQ:
     {
@@ -4537,6 +4562,7 @@ void mhs_getbuf(int s) { get_buf(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(
 void mhs_system(int s) { mhs_from_Int(s, 1, system(mhs_to_Ptr(s, 0))); }
 void mhs_tmpname(int s) { mhs_from_Ptr(s, 2, TMPNAME(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1))); }
 void mhs_unlink(int s) { mhs_from_Int(s, 1, unlink(mhs_to_Ptr(s, 0))); }
+void mhs_readb(int s) { mhs_from_Int(s, 3, readb(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1), mhs_to_Ptr(s, 2))); }
 void mhs_writeb(int s) { mhs_from_Int(s, 3, writeb(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1), mhs_to_Ptr(s, 2))); }
 #endif  /* WANT_STDIO */
 
@@ -4740,6 +4766,7 @@ struct ffi_entry ffi_table[] = {
 { "system", mhs_system},
 { "tmpname", mhs_tmpname},
 { "unlink", mhs_unlink},
+{ "readb", mhs_readb},
 { "writeb", mhs_writeb},
 #endif  /* WANT_STDIO */
 

tests/ByteStringIO.hs

@@ -0,0 +1,15 @@
+module ByteStringIO where
+
+import Data.ByteString as BS hiding (map)
+import Data.Char
+import System.IO (stdout)
+
+text :: ByteString
+text = BS.pack $ map (fromIntegral . ord) "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
+
+main :: IO ()
+main = do
+  BS.writeFile "test.tmp" text
+  bs <- BS.readFile "test.tmp"
+  print $ bs == text
+  BS.hPut stdout (BS.pack [72, 101, 108, 108, 111, 33, 10]) -- "Hello!\n"

tests/ByteStringIO.ref

@@ -0,0 +1,2 @@
+True
+Hello!

tests/Makefile

@@ -87,6 +87,7 @@ test:
 	$(TMHS) TypeApp    && $(EVAL) > TypeApp.out    && diff TypeApp.ref TypeApp.out
 	$(TMHS) Do         && $(EVAL) > Do.out         && diff Do.ref Do.out
 	$(TMHS) Via        && $(EVAL) > Via.out        && diff Via.ref Via.out
+	$(TMHS) ByteStringIO && $(EVAL) > ByteStringIO.out && diff ByteStringIO.ref ByteStringIO.out
 
 errtest:
 	sh errtester.sh $(MHS) < errmsg.test