X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FStringBuffer.lhs;h=d5ea832a823525fedf43ba2162215e0e02227c2b;hb=2cc5b907318f97e19b28b2ad8ed9ff8c1f401dcc;hp=d776c5fcd7123507aaebd6dba89de2efb3463c4d;hpb=c271b64780a6504e7ccd4cc422dfc90678ea966f;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index d776c5f..d5ea832 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -6,17 +6,17 @@ Buffers for scanning string input stored in external arrays. \begin{code} -{-# OPTIONS -fno-prune-tydecls #-} + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + module StringBuffer ( StringBuffer, -- creation/destruction hGetStringBuffer, -- :: FilePath -> IO StringBuffer -#ifdef GHCI stringToStringBuffer, -- :: String -> IO StringBuffer freeStringBuffer, -- :: StringBuffer -> IO () -#endif -- Lookup currentChar, -- :: StringBuffer -> Char @@ -69,51 +69,44 @@ module StringBuffer #include "HsVersions.h" -import GlaExts -import PrelAddr ( Addr(..) ) -import Foreign -import Char ( chr ) - --- urk! -#include "../lib/std/cbits/stgerror.h" -#if __GLASGOW_HASKELL__ >= 303 -import IO ( openFile -#if __GLASGOW_HASKELL__ < 407 - , slurpFile -- comes from PrelHandle or IOExts now -#endif - ) -import PrelIOBase -import PrelHandle -import Addr +#if __GLASGOW_HASKELL__ < 411 +import PrelAddr ( Addr(..) ) +import Panic ( panic ) #else -import IO ( openFile, hFileSize, hClose, IOMode(..) ) -import Addr +import Addr ( Addr(..) ) +import Ptr ( Ptr(..) ) #endif -#if __GLASGOW_HASKELL__ < 301 -import IOBase ( Handle, IOError(..), IOErrorType(..), - constructErrorAndFail ) -import IOHandle ( readHandle, writeHandle, filePtr ) -import PackBase ( unpackCStringBA ) +#if __GLASGOW_HASKELL__ < 501 +import Char ( chr ) +#elif __GLASGOW_HASKELL__ < 503 +import PrelIO ( hGetcBuffered ) #else -# if __GLASGOW_HASKELL__ <= 302 -import PrelIOBase ( Handle, IOError(..), IOErrorType(..), - constructErrorAndFail ) -import PrelHandle ( readHandle, writeHandle, filePtr ) -# endif -import PrelPack ( unpackCStringBA ) +import GHC.IO ( hGetcBuffered ) #endif -#if __GLASGOW_HASKELL__ < 402 -import Util ( bracket ) -#else +import PrimPacked +import FastString + +import GlaExts +import Foreign +import IO ( openFile, isEOFError ) +import IOExts ( slurpFile ) +import Addr import Exception ( bracket ) + +import CString ( unpackCStringBA ) + +#if __GLASGOW_HASKELL__ < 503 +import PrelIOBase +import PrelHandle +#else +import GHC.IOBase +import GHC.Handle #endif -import PrimPacked -import FastString -import Char (isDigit) +import Char ( isDigit ) \end{code} \begin{code} @@ -135,40 +128,25 @@ hGetStringBuffer :: Bool -> FilePath -> IO StringBuffer hGetStringBuffer expand_tabs fname = do (a, read) <- if expand_tabs then slurpFileExpandTabs fname +#if __GLASGOW_HASKELL__ < 411 else slurpFile fname +#else + else do + (Ptr a#, read) <- slurpFile fname + return (A# a#, read) +#endif - let (A# a#) = a; (I# read#) = read + -- urk! slurpFile gives us a buffer that doesn't have room for + -- the sentinel. Assume it has a final newline for now, and overwrite + -- that with the sentinel. slurpFileExpandTabs (below) leaves room + -- for the sentinel. + let (A# a#) = a; + (I# read#) = read; + end# = read# -# 1# -- add sentinel '\NUL' - _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' (A# a#) (I# (read# -# 1#)) - return (StringBuffer a# read# 0# 0#) - -#if __GLASGOW_HASKELL__ < 303 -slurpFile fname = - openFile fname ReadMode >>= \ hndl -> - hFileSize hndl >>= \ len -> - let len_i = fromInteger len in - -- Allocate an array for system call to store its bytes into. - -- ToDo: make it robust --- trace (show ((len_i::Int)+1)) $ - _casm_ `` %r=(char *)malloc(sizeof(char)*(int)%0); '' (len_i::Int) >>= \ arr@(A# a#) -> - if addr2Int# a# ==# 0# then - fail (userError ("hGetStringBuffer: Could not allocate "++show len_i ++ " bytes")) - else - readHandle hndl >>= \ hndl_ -> - writeHandle hndl hndl_ >> - let ptr = filePtr hndl_ in -#if __GLASGOW_HASKELL__ <= 302 - _ccall_ fread arr (1::Int) len_i (ptr::ForeignObj) >>= \ (I# read#) -> -#else - _ccall_ fread arr (1::Int) len_i (ptr::Addr) >>= \ (I# read#) -> -#endif - hClose hndl >> - if read# ==# 0# then -- EOF or some other error - fail (userError ("hGetStringBuffer: failed to slurp in interface file "++fname)) - else - return (arr, I# read#) -#endif + _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' (A# a#) (I# end#) + return (StringBuffer a# end# 0# 0#) unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# = @@ -182,13 +160,15 @@ unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# = -- Turn a String into a StringBuffer \begin{code} -#ifdef GHCI stringToStringBuffer :: String -> IO StringBuffer +freeStringBuffer :: StringBuffer -> IO () + +#if __GLASGOW_HASKELL__ >= 411 stringToStringBuffer str = - do let sz@(I# sz#) = length str + 1 - (Ptr a@(A# a#)) <- mallocBytes sz - fill_in str a - writeCharOffAddr a (sz-1) '\0' -- sentinel + do let sz@(I# sz#) = length str + (Ptr a#) <- mallocBytes (sz+1) + fill_in str (A# a#) + writeCharOffAddr (A# a#) sz '\0' -- sentinel return (StringBuffer a# sz# 0# 0#) where fill_in [] _ = return () @@ -196,9 +176,12 @@ stringToStringBuffer str = writeCharOffAddr a 0 c fill_in cs (a `plusAddr` 1) -freeStringBuffer :: StringBuffer -> IO () -freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr (A# a#)) +freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr a#) +#else +stringToStringBuffer = panic "stringToStringBuffer: not implemented" +freeStringBuffer sb = return () #endif + \end{code} ----------------------------------------------------------------------------- @@ -212,20 +195,8 @@ We guess the size of the buffer required as 20% extra for expanded tabs, and enlarge it if necessary. \begin{code} -#if __GLASGOW_HASKELL__ < 303 -mayBlock fo thing = thing - -writeCharOffAddr :: Addr -> Int -> Char -> IO () -writeCharOffAddr addr off c - = _casm_ ``*((char *)%0+(int)%1)=(char)%2;'' addr off c -#endif - getErrType :: IO Int -#if __GLASGOW_HASKELL__ < 303 -getErrType = _casm_ ``%r = ghc_errtype;'' -#else getErrType = _ccall_ getErrType__ -#endif slurpFileExpandTabs :: FilePath -> IO (Addr,Int) slurpFileExpandTabs fname = do @@ -233,25 +204,27 @@ slurpFileExpandTabs fname = do (\ handle -> do sz <- hFileSize handle if sz > toInteger (maxBound::Int) - then IOERROR (userError "slurpFile: file too big") + then ioError (userError "slurpFile: file too big") else do let sz_i = fromInteger sz - sz_i' = (sz_i * 12) `div` 10 -- add 20% for tabs - chunk <- allocMem sz_i' - trySlurp handle sz_i' chunk + if sz_i == 0 + -- empty file: just allocate a buffer containing '\0' + then do chunk <- allocMem 1 + writeCharOffAddr chunk 0 '\0' + return (chunk, 0) + else do let sz_i' = (sz_i * 12) `div` 10 -- add 20% for tabs + chunk <- allocMem sz_i' + trySlurp handle sz_i' chunk ) trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int) trySlurp handle sz_i chunk = -#if __GLASGOW_HASKELL__ == 303 - wantReadableHandle "hGetChar" handle >>= \ handle_ -> - let fo = haFO__ handle_ in -#elif __GLASGOW_HASKELL__ > 303 +#if __GLASGOW_HASKELL__ < 501 wantReadableHandle "hGetChar" handle $ \ handle_ -> let fo = haFO__ handle_ in #else - readHandle handle >>= \ handle_ -> - let fo = filePtr handle_ in + wantReadableHandle "hGetChar" handle $ + \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBufferMode=mode } -> #endif let (I# chunk_sz) = sz_i @@ -268,13 +241,31 @@ trySlurp handle sz_i chunk = chunk' <- reAllocMem chunk (I# new_sz) slurpFile c off chunk' new_sz (new_sz -# (tAB_SIZE +# 1#)) slurp c off = do +#if __GLASGOW_HASKELL__ < 501 intc <- mayBlock fo (_ccall_ fileGetc fo) if intc == ((-1)::Int) then do errtype <- getErrType - if errtype == (ERR_EOF :: Int) + if errtype == (19{-ERR_EOF-} :: Int) then return (chunk, I# off) else constructErrorAndFail "slurpFile" else case chr intc of +#else + buf <- readIORef ref + ch <- (if not (bufferEmpty buf) + then hGetcBuffered fd ref buf + else do +#if __GLASGOW_HASKELL__ >= 503 + new_buf <- fillReadBuffer fd True False buf +#else + new_buf <- fillReadBuffer fd True buf +#endif + hGetcBuffered fd ref new_buf) + `catch` \e -> if isEOFError e + then return '\xFFFF' + else ioError e + case ch of + '\xFFFF' -> return (chunk, I# off) +#endif '\t' -> tabIt c off ch -> do writeCharOffAddr chunk (I# off) ch let c' | ch == '\n' = 0# @@ -301,34 +292,27 @@ trySlurp handle sz_i chunk = #if __GLASGOW_HASKELL__ < 404 writeHandle handle handle_ #endif - if rc < (0::Int) - then constructErrorAndFail "slurpFile" - else return (chunk', rc+1 {-room for sentinel-}) + return (chunk', rc+1 {- room for sentinel -}) reAllocMem :: Addr -> Int -> IO Addr reAllocMem ptr sz = do chunk <- _ccall_ realloc ptr sz if chunk == nullAddr -#if __GLASGOW_HASKELL__ >= 400 then fail "reAllocMem" -#else - then fail (userError "reAllocMem") -#endif else return chunk allocMem :: Int -> IO Addr allocMem sz = do chunk <- _ccall_ malloc sz -#if __GLASGOW_HASKELL__ < 303 - if chunk == nullAddr - then fail (userError "allocMem") - else return chunk -#else if chunk == nullAddr +#if __GLASGOW_HASKELL__ < 501 then constructErrorAndFail "allocMem" - else return chunk +#else + then ioException (IOError Nothing ResourceExhausted "malloc" + "out of memory" Nothing) #endif + else return chunk \end{code} Lookup