Generate Typeable info at definition sites
[ghc.git] / compiler / utils / Binary.hs
index e075777..5083804 100644 (file)
@@ -1,4 +1,6 @@
-{-# OPTIONS -cpp #-}
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
@@ -20,7 +22,6 @@ module Binary
     {-type-}  BinHandle,
     SymbolTable, Dictionary,
 
-   openBinIO, openBinIO_,
    openBinMem,
 --   closeBin,
 
@@ -47,13 +48,6 @@ module Binary
    lazyGet,
    lazyPut,
 
-#ifdef __GLASGOW_HASKELL__
-   -- GHC only:
-   ByteArray(..),
-   getByteArray,
-   putByteArray,
-#endif
-
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,
    putDictionary, getDictionary, putFS,
@@ -71,6 +65,7 @@ import UniqFM
 import FastMutInt
 import Fingerprint
 import BasicTypes
+import SrcLoc
 
 import Foreign
 import Data.Array
@@ -81,16 +76,11 @@ import Data.IORef
 import Data.Char                ( ord, chr )
 import Data.Time
 import Data.Typeable
-import Data.Typeable.Internal
 import Control.Monad            ( when )
 import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
-import GHC.Exts
-import GHC.Word                 ( Word8(..) )
-
-import GHC.IO ( IO(..) )
 
 type BinArray = ForeignPtr Word8
 
@@ -108,15 +98,6 @@ data BinHandle
         -- XXX: should really store a "high water mark" for dumping out
         -- the binary data to a file.
 
-  | BinIO {                     -- binary data stored in a file
-     bh_usr :: UserData,
-     _off_r :: !FastMutInt,     -- the current offset (cached)
-     _hdl   :: !IO.Handle       -- the file handle (must be seekable)
-   }
-        -- cache the file ptr in BinIO; using hTell is too expensive
-        -- to call repeatedly.  If anyone else is modifying this Handle
-        -- at the same time, we'll be screwed.
-
 getUserData :: BinHandle -> UserData
 getUserData bh = bh_usr bh
 
@@ -155,15 +136,6 @@ putAt bh p x = do seekBin bh p; put_ bh x; return ()
 getAt  :: Binary a => BinHandle -> Bin a -> IO a
 getAt bh p = do seekBin bh p; get bh
 
-openBinIO_ :: IO.Handle -> IO BinHandle
-openBinIO_ h = openBinIO h
-
-openBinIO :: IO.Handle -> IO BinHandle
-openBinIO h = do
-  r <- newFastMutInt
-  writeFastMutInt r 0
-  return (BinIO noUserData r h)
-
 openBinMem :: Int -> IO BinHandle
 openBinMem size
  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
@@ -177,13 +149,9 @@ openBinMem size
    return (BinMem noUserData ix_r sz_r arr_r)
 
 tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
 
 seekBin :: BinHandle -> Bin a -> IO ()
-seekBin (BinIO _ ix_r h) (BinPtr p) = do
-  writeFastMutInt ix_r p
-  hSeek h AbsoluteSeek (fromIntegral p)
 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
   sz <- readFastMutInt sz_r
   if (p >= sz)
@@ -191,11 +159,6 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
         else writeFastMutInt ix_r p
 
 seekBy :: BinHandle -> Int -> IO ()
-seekBy (BinIO _ ix_r h) off = do
-  ix <- readFastMutInt ix_r
-  let ix' = ix + off
-  writeFastMutInt ix_r ix'
-  hSeek h AbsoluteSeek (fromIntegral ix')
 seekBy h@(BinMem _ ix_r sz_r _) off = do
   sz <- readFastMutInt sz_r
   ix <- readFastMutInt ix_r
@@ -209,10 +172,8 @@ isEOFBin (BinMem _ ix_r sz_r _) = do
   ix <- readFastMutInt ix_r
   sz <- readFastMutInt sz_r
   return (ix >= sz)
-isEOFBin (BinIO _ _ h) = hIsEOF h
 
 writeBinMem :: BinHandle -> FilePath -> IO ()
-writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
@@ -239,7 +200,6 @@ readBinMem filename = do
   return (BinMem noUserData ix_r sz_r arr_r)
 
 fingerprintBinMem :: BinHandle -> IO Fingerprint
-fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
   arr <- readIORef arr_r
   ix <- readFastMutInt ix_r
@@ -265,11 +225,9 @@ expandBin (BinMem _ _ sz_r arr_r) off = do
    arr' <- mallocForeignPtrBytes sz'
    withForeignPtr arr $ \old ->
      withForeignPtr arr' $ \new ->
-       copyBytes new old sz 
+       copyBytes new old sz
    writeFastMutInt sz_r sz'
    writeIORef arr_r arr'
-expandBin (BinIO _ _ _) _ = return ()
--- no need to expand a file, we'll assume they expand by themselves.
 
 -- -----------------------------------------------------------------------------
 -- Low-level reading/writing of bytes
@@ -286,11 +244,6 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
                 withForeignPtr arr $ \p -> pokeByteOff p ix w
                 writeFastMutInt ix_r (ix+1)
                 return ()
-putWord8 (BinIO _ ix_r h) w = do
-    ix <- readFastMutInt ix_r
-    hPutChar h (chr (fromIntegral w)) -- XXX not really correct
-    writeFastMutInt ix_r (ix+1)
-    return ()
 
 getWord8 :: BinHandle -> IO Word8
 getWord8 (BinMem _ ix_r sz_r arr_r) = do
@@ -302,11 +255,6 @@ getWord8 (BinMem _ ix_r sz_r arr_r) = do
     w <- withForeignPtr arr $ \p -> peekByteOff p ix
     writeFastMutInt ix_r (ix+1)
     return w
-getWord8 (BinIO _ ix_r h) = do
-    ix <- readFastMutInt ix_r
-    c <- hGetChar h
-    writeFastMutInt ix_r (ix+1)
-    return $! (fromIntegral (ord c)) -- XXX not really correct
 
 putByte :: BinHandle -> Word8 -> IO ()
 putByte bh w = put_ bh w
@@ -504,7 +452,6 @@ instance Binary DiffTime where
     get bh = do r <- get bh
                 return $ fromRational r
 
-#if defined(__GLASGOW_HASKELL__) || 1
 --to quote binary-0.3 on this code idea,
 --
 -- TODO  This instance is not architecture portable.  GMP stores numbers as
@@ -517,7 +464,7 @@ instance Binary DiffTime where
 -- we just change this instance to be portable like the rest of the
 -- instances? (binary package has code to steal for that)
 --
--- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
+-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs
 
 instance Binary Integer where
     -- XXX This is hideous
@@ -528,6 +475,10 @@ instance Binary Integer where
                     _ -> fail ("Binary Integer: got " ++ show str)
 
     {-
+    -- This code is currently commented out.
+    -- See https://ghc.haskell.org/trac/ghc/ticket/3379#comment:10 for
+    -- discussion.
+
     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
     put_ bh (J# s# a#) = do
         putByte bh 1
@@ -545,11 +496,6 @@ instance Binary Integer where
                   sz <- get bh
                   (BA a#) <- getByteArray bh sz
                   return (J# s# a#)
--}
-
--- As for the rest of this code, even though this module
--- exports it, it doesn't seem to be used anywhere else
--- in GHC!
 
 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 putByteArray bh a s# = loop 0#
@@ -570,8 +516,9 @@ getByteArray bh (I# sz) = do
                 loop (n +# 1#)
   loop 0#
   freezeByteArray arr
+    -}
 
-
+{-
 data ByteArray = BA ByteArray#
 data MBA = MBA (MutableByteArray# RealWorld)
 
@@ -593,10 +540,10 @@ writeByteArray arr i (W8# w) = IO $ \s ->
 indexByteArray :: ByteArray# -> Int# -> Word8
 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 
-instance (Integral a, Binary a) => Binary (Ratio a) where
+-}
+instance (Binary a) => Binary (Ratio a) where
     put_ bh (a :% b) = do put_ bh a; put_ bh b
     get bh = do a <- get bh; b <- get bh; return (a :% b)
-#endif
 
 instance Binary (Bin a) where
   put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
@@ -606,10 +553,14 @@ instance Binary (Bin a) where
 -- Instances for Data.Typeable stuff
 
 instance Binary TyCon where
-    put_ bh (TyCon _ p m n) = do
-        put_ bh (p,m,n)
+    put_ bh tc = do
+        put_ bh (tyConPackage tc)
+        put_ bh (tyConModule tc)
+        put_ bh (tyConName tc)
     get bh = do
-        (p,m,n) <- get bh
+        p <- get bh
+        m <- get bh
+        n <- get bh
         return (mkTyCon3 p m n)
 
 instance Binary TypeRep where
@@ -639,7 +590,11 @@ lazyGet :: Binary a => BinHandle -> IO a
 lazyGet bh = do
     p <- get bh -- a BinPtr
     p_a <- tellBin bh
-    a <- unsafeInterleaveIO (getAt bh p_a)
+    a <- unsafeInterleaveIO $ do
+        -- NB: Use a fresh off_r variable in the child thread, for thread
+        -- safety.
+        off_r <- newFastMutInt
+        getAt bh { _off_r = off_r } p_a
     seekBin bh p -- skip over the object for now
     return a
 
@@ -667,8 +622,8 @@ newReadState get_name get_fs
                ud_put_name = undef "put_name",
                ud_put_fs   = undef "put_fs"
              }
-   
-newWriteState :: (BinHandle -> Name       -> IO ()) 
+
+newWriteState :: (BinHandle -> Name       -> IO ())
               -> (BinHandle -> FastString -> IO ())
               -> UserData
 newWriteState put_name put_fs
@@ -720,7 +675,7 @@ putFS bh fs = putBS bh $ fastStringToByteString fs
 
 getFS :: BinHandle -> IO FastString
 getFS bh = do bs <- getBS bh
-              mkFastStringByteString bs
+              return $! mkFastStringByteString bs
 
 putBS :: BinHandle -> ByteString -> IO ()
 putBS bh bs =
@@ -746,14 +701,13 @@ getBS bh = do
   l <- get bh
   fp <- mallocForeignPtrBytes l
   withForeignPtr fp $ \ptr -> do
-  let
-        go n | n == l = return $ BS.fromForeignPtr fp 0 l
+    let go n | n == l = return $ BS.fromForeignPtr fp 0 l
              | otherwise = do
                 b <- getByte bh
                 pokeElemOff ptr n b
                 go (n+1)
-  --
-  go 0
+    --
+    go 0
 
 instance Binary ByteString where
   put_ bh f = putBS bh f
@@ -784,3 +738,206 @@ instance Binary FunctionOrData where
           1 -> return IsData
           _ -> panic "Binary FunctionOrData"
 
+instance Binary TupleSort where
+    put_ bh BoxedTuple      = putByte bh 0
+    put_ bh UnboxedTuple    = putByte bh 1
+    put_ bh ConstraintTuple = putByte bh 2
+    get bh = do
+      h <- getByte bh
+      case h of
+        0 -> do return BoxedTuple
+        1 -> do return UnboxedTuple
+        _ -> do return ConstraintTuple
+
+instance Binary Activation where
+    put_ bh NeverActive = do
+            putByte bh 0
+    put_ bh AlwaysActive = do
+            putByte bh 1
+    put_ bh (ActiveBefore aa) = do
+            putByte bh 2
+            put_ bh aa
+    put_ bh (ActiveAfter ab) = do
+            putByte bh 3
+            put_ bh ab
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return NeverActive
+              1 -> do return AlwaysActive
+              2 -> do aa <- get bh
+                      return (ActiveBefore aa)
+              _ -> do ab <- get bh
+                      return (ActiveAfter ab)
+
+instance Binary InlinePragma where
+    put_ bh (InlinePragma s a b c d) = do
+            put_ bh s
+            put_ bh a
+            put_ bh b
+            put_ bh c
+            put_ bh d
+
+    get bh = do
+           s <- get bh
+           a <- get bh
+           b <- get bh
+           c <- get bh
+           d <- get bh
+           return (InlinePragma s a b c d)
+
+instance Binary RuleMatchInfo where
+    put_ bh FunLike = putByte bh 0
+    put_ bh ConLike = putByte bh 1
+    get bh = do
+            h <- getByte bh
+            if h == 1 then return ConLike
+                      else return FunLike
+
+instance Binary InlineSpec where
+    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh Inline          = putByte bh 1
+    put_ bh Inlinable       = putByte bh 2
+    put_ bh NoInline        = putByte bh 3
+
+    get bh = do h <- getByte bh
+                case h of
+                  0 -> return EmptyInlineSpec
+                  1 -> return Inline
+                  2 -> return Inlinable
+                  _ -> return NoInline
+
+instance Binary DefMethSpec where
+    put_ bh NoDM      = putByte bh 0
+    put_ bh VanillaDM = putByte bh 1
+    put_ bh GenericDM = putByte bh 2
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return NoDM
+              1 -> return VanillaDM
+              _ -> return GenericDM
+
+instance Binary RecFlag where
+    put_ bh Recursive = do
+            putByte bh 0
+    put_ bh NonRecursive = do
+            putByte bh 1
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return Recursive
+              _ -> do return NonRecursive
+
+instance Binary OverlapMode where
+    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
+    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
+    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
+    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
+    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> (get bh) >>= \s -> return $ NoOverlap s
+            1 -> (get bh) >>= \s -> return $ Overlaps s
+            2 -> (get bh) >>= \s -> return $ Incoherent s
+            3 -> (get bh) >>= \s -> return $ Overlapping s
+            4 -> (get bh) >>= \s -> return $ Overlappable s
+            _ -> panic ("get OverlapMode" ++ show h)
+
+
+instance Binary OverlapFlag where
+    put_ bh flag = do put_ bh (overlapMode flag)
+                      put_ bh (isSafeOverlap flag)
+    get bh = do
+        h <- get bh
+        b <- get bh
+        return OverlapFlag { overlapMode = h, isSafeOverlap = b }
+
+instance Binary FixityDirection where
+    put_ bh InfixL = do
+            putByte bh 0
+    put_ bh InfixR = do
+            putByte bh 1
+    put_ bh InfixN = do
+            putByte bh 2
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return InfixL
+              1 -> do return InfixR
+              _ -> do return InfixN
+
+instance Binary Fixity where
+    put_ bh (Fixity aa ab) = do
+            put_ bh aa
+            put_ bh ab
+    get bh = do
+          aa <- get bh
+          ab <- get bh
+          return (Fixity aa ab)
+
+instance Binary WarningTxt where
+    put_ bh (WarningTxt s w) = do
+            putByte bh 0
+            put_ bh s
+            put_ bh w
+    put_ bh (DeprecatedTxt s d) = do
+            putByte bh 1
+            put_ bh s
+            put_ bh d
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do s <- get bh
+                      w <- get bh
+                      return (WarningTxt s w)
+              _ -> do s <- get bh
+                      d <- get bh
+                      return (DeprecatedTxt s d)
+
+instance Binary StringLiteral where
+  put_ bh (StringLiteral st fs) = do
+            put_ bh st
+            put_ bh fs
+  get bh = do
+            st <- get bh
+            fs <- get bh
+            return (StringLiteral st fs)
+
+instance Binary a => Binary (GenLocated SrcSpan a) where
+    put_ bh (L l x) = do
+            put_ bh l
+            put_ bh x
+
+    get bh = do
+            l <- get bh
+            x <- get bh
+            return (L l x)
+
+instance Binary SrcSpan where
+  put_ bh (RealSrcSpan ss) = do
+          putByte bh 0
+          put_ bh (srcSpanFile ss)
+          put_ bh (srcSpanStartLine ss)
+          put_ bh (srcSpanStartCol ss)
+          put_ bh (srcSpanEndLine ss)
+          put_ bh (srcSpanEndCol ss)
+
+  put_ bh (UnhelpfulSpan s) = do
+          putByte bh 1
+          put_ bh s
+
+  get bh = do
+          h <- getByte bh
+          case h of
+            0 -> do f <- get bh
+                    sl <- get bh
+                    sc <- get bh
+                    el <- get bh
+                    ec <- get bh
+                    return (mkSrcSpan (mkSrcLoc f sl sc)
+                                      (mkSrcLoc f el ec))
+            _ -> do s <- get bh
+                    return (UnhelpfulSpan s)