remove empty dir

[ghc-hetmet.git] / ghc / compiler / utils / Binary.hs

diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs
index 962531f..7a1ca51 100644 (file)
--- a/ghc/compiler/utils/Binary.hs
+++ b/ghc/compiler/utils/Binary.hs
@@ -58,26 +58,7 @@ import UniqFM
 import FastMutInt
 import PackageConfig           ( PackageId, packageIdFS, fsToPackageId )
 
-#if __GLASGOW_HASKELL__ < 503
-import DATA_IOREF
-import DATA_BITS
-import DATA_INT
-import DATA_WORD
-import Char
-import Monad
-import Exception
-import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
-import Array
-import IO
-import PrelIOBase              ( IOError(..), IOErrorType(..)
-#if __GLASGOW_HASKELL__ > 411
-                               , IOException(..)
-#endif
-                               )
-import PrelReal                        ( Ratio(..) )
-import PrelIOBase              ( IO(..) )
-import IOExts                  ( openFileEx, IOModeEx(..) )
-#else
+import Foreign
 import Data.Array.IO
 import Data.Array
 import Data.Bits
@@ -102,44 +83,12 @@ import GHC.Handle          ( openFileEx, IOModeEx(..) )
 #else
 import System.IO               ( openBinaryFile )
 #endif
-#endif
 
 #if __GLASGOW_HASKELL__ < 601
 openBinaryFile f mode = openFileEx f (BinaryMode mode)
 #endif
 
-#if __GLASGOW_HASKELL__ < 503
-type BinArray = MutableByteArray RealWorld Int
-newArray_ bounds     = stToIO (newCharArray bounds)
-unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
-unsafeRead  arr ix   = stToIO (readWord8Array arr ix)
-#if __GLASGOW_HASKELL__ < 411
-newByteArray#        = newCharArray#
-#endif
-hPutArray h arr sz   = hPutBufBAFull h arr sz
-hGetArray h sz       = hGetBufBAFull h sz
-
-mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
-mkIOError t location maybe_hdl maybe_filename
-  = IOException (IOError maybe_hdl t location ""
-#if __GLASGOW_HASKELL__ > 411
-                        maybe_filename
-#endif
-               )
-
-eofErrorType = EOF
-
-#ifndef SIZEOF_HSINT
-#define SIZEOF_HSINT  INT_SIZE_IN_BYTES
-#endif
-
-#ifndef SIZEOF_HSWORD
-#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
-#endif
-
-#else
 type BinArray = IOUArray Int Word8
-#endif
 
 ---------------------------------------------------------------
 --             BinHandle
@@ -458,14 +407,20 @@ instance Binary Int where
 --    getF bh   = getBitsF bh 32
 
 instance Binary a => Binary [a] where
-    put_ bh []     = putByte bh 0
-    put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs
-    get bh         = do h <- getWord8 bh
-                        case h of
-                          0 -> return []
-                          _ -> do x  <- get bh
-                                  xs <- get bh
-                                  return (x:xs)
+    put_ bh l = do 
+       let len = length l
+       if (len < 0xff) 
+         then putByte bh (fromIntegral len :: Word8)
+         else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
+       mapM_ (put_ bh) l
+    get bh = do
+       b <- getByte bh
+       len <- if b == 0xff 
+                 then get bh
+                 else return (fromIntegral b :: Word32)
+       let loop 0 = return []
+           loop n = do a <- get bh; as <- loop (n-1); return (a:as)
+       loop len
 
 instance (Binary a, Binary b) => Binary (a,b) where
     put_ bh (a,b) = do put_ bh a; put_ bh b
@@ -615,7 +570,12 @@ lazyGet bh = do
 -- --------------------------------------------------------------
 
 initBinMemSize       = (1024*1024) :: Int
+
+#if   WORD_SIZE_IN_BITS == 32
 binaryInterfaceMagic = 0x1face :: Word32
+#elif WORD_SIZE_IN_BITS == 64
+binaryInterfaceMagic = 0x1face64 :: Word32
+#endif
 
 getBinFileWithDict :: Binary a => FilePath -> IO a
 getBinFileWithDict file_path = do
@@ -730,13 +690,17 @@ constructDictionary j fm = array (0,j-1) (eltsUFM fm)
 --             Reading and writing FastStrings
 ---------------------------------------------------------
 
-putFS bh (FastString id l ba) = do
-  put_ bh (I# l)
-  putByteArray bh ba l
-putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
-       -- Note: the length of the FastString is *not* the same as
-       -- the size of the ByteArray: the latter is rounded up to a
-       -- multiple of the word size.
+putFS bh (FastString id l _ buf _) = do
+  put_ bh l
+  withForeignPtr buf $ \ptr -> 
+    let 
+       go n | n == l    = return ()
+            | otherwise = do
+               b <- peekElemOff ptr n
+               putByte bh b
+               go (n+1)
+   in 
+   go 0
   
 {- -- possible faster version, not quite there yet:
 getFS bh@BinMem{} = do
@@ -746,16 +710,34 @@ getFS bh@BinMem{} = do
   return $! (mkFastSubStringBA# arr off l)
 -}
 getFS bh = do
-  (I# l) <- get bh
-  (BA ba) <- getByteArray bh (I# l)
-  return $! (mkFastSubStringBA# ba 0# l)
+  l <- get bh
+  fp <- mallocForeignPtrBytes l
+  withForeignPtr fp $ \ptr -> do
+  let 
+       go n | n == l = mkFastStringForeignPtr ptr fp l
+            | otherwise = do
+               b <- getByte bh
+               pokeElemOff ptr n b
+               go (n+1)
+  --
+  go 0
+
+#if __GLASGOW_HASKELL__ < 600
+mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
+mallocForeignPtrBytes n = do
+  r <- mallocBytes n
+  newForeignPtr r (finalizerFree r)
+
+foreign import ccall unsafe "stdlib.h free" 
+  finalizerFree :: Ptr a -> IO ()
+#endif
 
 instance Binary PackageId where
   put_ bh pid = put_ bh (packageIdFS pid)
   get bh = do { fs <- get bh; return (fsToPackageId fs) }
 
 instance Binary FastString where
-  put_ bh f@(FastString id l ba) =
+  put_ bh f@(FastString id l _ fp _) =
     case getUserData bh of { 
        UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do
     out <- readIORef out_r
@@ -768,7 +750,6 @@ instance Binary FastString where
           writeIORef j_r (j+1)
           writeIORef out_r (addToUFM out uniq (j,f))
     }
-  put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))
 
   get bh = do 
        j <- get bh