blob: 306413573f322f0c9bbcf80a71d0d0b03bf4ebe9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
-----------------------------------------------------------------------------
--
-- Fast write-buffered Handles
--
-- (c) The University of Glasgow 2005-2006
--
-- This is a simple abstraction over Handles that offers very fast write
-- buffering, but without the thread safety that Handles provide. It's used
-- to save time in Pretty.printDoc.
--
-----------------------------------------------------------------------------
module BufWrite (
BufHandle(..),
newBufHandle,
bPutChar,
bPutStr,
bPutFS,
bPutLitString,
bFlush,
) where
#include "HsVersions.h"
import FastString
import FastTypes
import FastMutInt
import Control.Monad ( when )
import Data.Char ( ord )
import Foreign
import System.IO
-- -----------------------------------------------------------------------------
data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
{-#UNPACK#-}!FastMutInt
Handle
newBufHandle :: Handle -> IO BufHandle
newBufHandle hdl = do
ptr <- mallocBytes buf_size
r <- newFastMutInt
writeFastMutInt r 0
return (BufHandle ptr r hdl)
buf_size :: Int
buf_size = 8192
#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
bPutChar :: BufHandle -> Char -> IO ()
STRICT2(bPutChar)
bPutChar b@(BufHandle buf r hdl) c = do
i <- readFastMutInt r
if (i >= buf_size)
then do hPutBuf hdl buf buf_size
writeFastMutInt r 0
bPutChar b c
else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
writeFastMutInt r (i+1)
bPutStr :: BufHandle -> String -> IO ()
STRICT2(bPutStr)
bPutStr (BufHandle buf r hdl) str = do
i <- readFastMutInt r
loop str i
where loop _ i | i `seq` False = undefined
loop "" i = do writeFastMutInt r i; return ()
loop (c:cs) i
| i >= buf_size = do
hPutBuf hdl buf buf_size
loop (c:cs) 0
| otherwise = do
pokeElemOff buf i (fromIntegral (ord c))
loop cs (i+1)
bPutFS :: BufHandle -> FastString -> IO ()
bPutFS b@(BufHandle buf r hdl) fs@(FastString _ len _ fp _) =
withForeignPtr fp $ \ptr -> do
i <- readFastMutInt r
if (i + len) >= buf_size
then do hPutBuf hdl buf i
writeFastMutInt r 0
if (len >= buf_size)
then hPutBuf hdl ptr len
else bPutFS b fs
else do
copyBytes (buf `plusPtr` i) ptr len
writeFastMutInt r (i+len)
bPutLitString :: BufHandle -> LitString -> FastInt -> IO ()
bPutLitString b@(BufHandle buf r hdl) a len_ = a `seq` do
let len = iBox len_
i <- readFastMutInt r
if (i+len) >= buf_size
then do hPutBuf hdl buf i
writeFastMutInt r 0
if (len >= buf_size)
then hPutBuf hdl a len
else bPutLitString b a len_
else do
copyBytes (buf `plusPtr` i) a len
writeFastMutInt r (i+len)
bFlush :: BufHandle -> IO ()
bFlush (BufHandle buf r hdl) = do
i <- readFastMutInt r
when (i > 0) $ hPutBuf hdl buf i
free buf
return ()
#if 0
myPutBuf s hdl buf i =
modifyIOError (\e -> ioeSetErrorString e (ioeGetErrorString e ++ ':':s ++ " (" ++ show buf ++ "," ++ show i ++ ")")) $
hPutBuf hdl buf i
#endif
|
