patch from #1782; fixes check-packages target on Solaris
[ghc-hetmet.git] / compiler / utils / BufWrite.hs
1 {-# OPTIONS -w #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
6 -- for details
7
8 -----------------------------------------------------------------------------
9 --
10 -- Fast write-buffered Handles
11 --
12 -- (c) The University of Glasgow 2005-2006
13 --
14 -- This is a simple abstraction over Handles that offers very fast write
15 -- buffering, but without the thread safety that Handles provide.  It's used
16 -- to save time in Pretty.printDoc.
17 --
18 -----------------------------------------------------------------------------
19
20 module BufWrite (
21         BufHandle(..),
22         newBufHandle,
23         bPutChar,
24         bPutStr,
25         bPutFS,
26         bPutLitString,
27         bFlush,
28   ) where
29
30 #include "HsVersions.h"
31
32 import FastString
33 import FastMutInt
34
35 import Control.Monad    ( when )
36 import Data.Char        ( ord )
37 import Foreign
38 import System.IO
39
40 import GHC.IOBase       ( IO(..) )
41 import GHC.Ptr          ( Ptr(..) )
42
43 import GHC.Exts         ( Int(..), Int#, Addr# )
44
45 -- -----------------------------------------------------------------------------
46
47 data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
48                            {-#UNPACK#-}!FastMutInt
49                            Handle
50
51 newBufHandle :: Handle -> IO BufHandle
52 newBufHandle hdl = do
53   ptr <- mallocBytes buf_size
54   r <- newFastMutInt
55   writeFastMutInt r 0
56   return (BufHandle ptr r hdl)
57
58 buf_size = 8192 :: Int
59
60 #define STRICT2(f) f a b | a `seq` b `seq` False = undefined
61 #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
62
63 bPutChar :: BufHandle -> Char -> IO ()
64 STRICT2(bPutChar)
65 bPutChar b@(BufHandle buf r hdl) c = do
66   i <- readFastMutInt r
67   if (i >= buf_size)
68         then do hPutBuf hdl buf buf_size
69                 writeFastMutInt r 0
70                 bPutChar b c
71         else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
72                 writeFastMutInt r (i+1)
73
74 bPutStr :: BufHandle -> String -> IO ()
75 STRICT2(bPutStr)
76 bPutStr b@(BufHandle buf r hdl) str = do
77   i <- readFastMutInt r
78   loop str i
79   where loop _ i | i `seq` False = undefined
80         loop "" i = do writeFastMutInt r i; return ()
81         loop (c:cs) i
82            | i >= buf_size = do
83                 hPutBuf hdl buf buf_size
84                 loop (c:cs) 0
85            | otherwise = do
86                 pokeElemOff buf i (fromIntegral (ord c))
87                 loop cs (i+1)
88   
89 bPutFS :: BufHandle -> FastString -> IO ()
90 bPutFS b@(BufHandle buf r hdl) fs@(FastString _ len _ fp _) =
91  withForeignPtr fp $ \ptr -> do
92   i <- readFastMutInt r
93   if (i + len) >= buf_size
94         then do hPutBuf hdl buf i
95                 writeFastMutInt r 0
96                 if (len >= buf_size) 
97                     then hPutBuf hdl ptr len
98                     else bPutFS b fs
99         else do
100                 copyBytes (buf `plusPtr` i) ptr len
101                 writeFastMutInt r (i+len)
102
103 bPutLitString :: BufHandle -> Addr# -> Int# -> IO ()
104 bPutLitString b@(BufHandle buf r hdl) a# len# = do
105   let len = I# len#
106   i <- readFastMutInt r
107   if (i+len) >= buf_size
108         then do hPutBuf hdl buf i
109                 writeFastMutInt r 0
110                 if (len >= buf_size) 
111                     then hPutBuf hdl (Ptr a#) len
112                     else bPutLitString b a# len#
113         else do
114                 copyBytes (buf `plusPtr` i) (Ptr a#) len
115                 writeFastMutInt r (i+len)
116
117 bFlush :: BufHandle -> IO ()
118 bFlush b@(BufHandle buf r hdl) = do
119   i <- readFastMutInt r
120   when (i > 0) $ hPutBuf hdl buf i
121   free buf
122   return ()
123
124 #if 0
125 myPutBuf s hdl buf i = 
126   modifyIOError (\e -> ioeSetErrorString e (ioeGetErrorString e ++ ':':s ++ " (" ++ show buf ++ "," ++ show i ++ ")")) $
127
128   hPutBuf hdl buf i
129 #endif