summaryrefslogtreecommitdiff
path: root/compiler/GHC/Utils/Binary.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Utils/Binary.hs')
-rw-r--r--compiler/GHC/Utils/Binary.hs404
1 files changed, 0 insertions, 404 deletions
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 2975ab2d0d..dbc2cdc195 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -77,7 +77,6 @@ import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
import GHC.Utils.Fingerprint
-import GHC.Types.Basic
import GHC.Types.SrcLoc
import Control.DeepSeq
@@ -90,16 +89,11 @@ import Data.IORef
import Data.Char ( ord, chr )
import Data.Time
import Data.List (unfoldr)
-import Type.Reflection
-import Type.Reflection.Unsafe
-import Data.Kind (Type)
-import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
import Control.Monad ( when, (<$!>), unless )
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
import GHC.Real ( Ratio(..) )
-import GHC.Serialized
type BinArray = ForeignPtr Word8
@@ -870,184 +864,7 @@ instance Binary (Bin a) where
put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)
get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))
--- -----------------------------------------------------------------------------
--- Instances for Data.Typeable stuff
-
-instance Binary TyCon where
- put_ bh tc = do
- put_ bh (tyConPackage tc)
- put_ bh (tyConModule tc)
- put_ bh (tyConName tc)
- put_ bh (tyConKindArgs tc)
- put_ bh (tyConKindRep tc)
- get bh =
- mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-
-instance Binary VecCount where
- put_ bh = putByte bh . fromIntegral . fromEnum
- get bh = toEnum . fromIntegral <$> getByte bh
-
-instance Binary VecElem where
- put_ bh = putByte bh . fromIntegral . fromEnum
- get bh = toEnum . fromIntegral <$> getByte bh
-
-instance Binary RuntimeRep where
- put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b
- put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
- put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps
- put_ bh LiftedRep = putByte bh 3
- put_ bh UnliftedRep = putByte bh 4
- put_ bh IntRep = putByte bh 5
- put_ bh WordRep = putByte bh 6
- put_ bh Int64Rep = putByte bh 7
- put_ bh Word64Rep = putByte bh 8
- put_ bh AddrRep = putByte bh 9
- put_ bh FloatRep = putByte bh 10
- put_ bh DoubleRep = putByte bh 11
- put_ bh Int8Rep = putByte bh 12
- put_ bh Word8Rep = putByte bh 13
- put_ bh Int16Rep = putByte bh 14
- put_ bh Word16Rep = putByte bh 15
-#if __GLASGOW_HASKELL__ >= 809
- put_ bh Int32Rep = putByte bh 16
- put_ bh Word32Rep = putByte bh 17
-#endif
-
- get bh = do
- tag <- getByte bh
- case tag of
- 0 -> VecRep <$> get bh <*> get bh
- 1 -> TupleRep <$> get bh
- 2 -> SumRep <$> get bh
- 3 -> pure LiftedRep
- 4 -> pure UnliftedRep
- 5 -> pure IntRep
- 6 -> pure WordRep
- 7 -> pure Int64Rep
- 8 -> pure Word64Rep
- 9 -> pure AddrRep
- 10 -> pure FloatRep
- 11 -> pure DoubleRep
- 12 -> pure Int8Rep
- 13 -> pure Word8Rep
- 14 -> pure Int16Rep
- 15 -> pure Word16Rep
-#if __GLASGOW_HASKELL__ >= 809
- 16 -> pure Int32Rep
- 17 -> pure Word32Rep
-#endif
- _ -> fail "Binary.putRuntimeRep: invalid tag"
-
-instance Binary KindRep where
- put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k
- put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr
- put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b
- put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
- put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
- put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r
-
- get bh = do
- tag <- getByte bh
- case tag of
- 0 -> KindRepTyConApp <$> get bh <*> get bh
- 1 -> KindRepVar <$> get bh
- 2 -> KindRepApp <$> get bh <*> get bh
- 3 -> KindRepFun <$> get bh <*> get bh
- 4 -> KindRepTYPE <$> get bh
- 5 -> KindRepTypeLit <$> get bh <*> get bh
- _ -> fail "Binary.putKindRep: invalid tag"
-
-instance Binary TypeLitSort where
- put_ bh TypeLitSymbol = putByte bh 0
- put_ bh TypeLitNat = putByte bh 1
- get bh = do
- tag <- getByte bh
- case tag of
- 0 -> pure TypeLitSymbol
- 1 -> pure TypeLitNat
- _ -> fail "Binary.putTypeLitSort: invalid tag"
-
-putTypeRep :: BinHandle -> TypeRep a -> IO ()
--- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
--- relations.
--- See Note [Mutually recursive representations of primitive types]
-putTypeRep bh rep
- | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
- = put_ bh (0 :: Word8)
-putTypeRep bh (Con' con ks) = do
- put_ bh (1 :: Word8)
- put_ bh con
- put_ bh ks
-putTypeRep bh (App f x) = do
- put_ bh (2 :: Word8)
- putTypeRep bh f
- putTypeRep bh x
-putTypeRep bh (Fun arg res) = do
- put_ bh (3 :: Word8)
- putTypeRep bh arg
- putTypeRep bh res
-
-getSomeTypeRep :: BinHandle -> IO SomeTypeRep
-getSomeTypeRep bh = do
- tag <- get bh :: IO Word8
- case tag of
- 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
- 1 -> do con <- get bh :: IO TyCon
- ks <- get bh :: IO [SomeTypeRep]
- return $ SomeTypeRep $ mkTrCon con ks
-
- 2 -> do SomeTypeRep f <- getSomeTypeRep bh
- SomeTypeRep x <- getSomeTypeRep bh
- case typeRepKind f of
- Fun arg res ->
- case arg `eqTypeRep` typeRepKind x of
- Just HRefl ->
- case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
- Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
- _ -> failure "Kind mismatch in type application" []
- _ -> failure "Kind mismatch in type application"
- [ " Found argument of kind: " ++ show (typeRepKind x)
- , " Where the constructor: " ++ show f
- , " Expects kind: " ++ show arg
- ]
- _ -> failure "Applied non-arrow"
- [ " Applied type: " ++ show f
- , " To argument: " ++ show x
- ]
- 3 -> do SomeTypeRep arg <- getSomeTypeRep bh
- SomeTypeRep res <- getSomeTypeRep bh
- if
- | App argkcon _ <- typeRepKind arg
- , App reskcon _ <- typeRepKind res
- , Just HRefl <- argkcon `eqTypeRep` tYPErep
- , Just HRefl <- reskcon `eqTypeRep` tYPErep
- -> return $ SomeTypeRep $ Fun arg res
- | otherwise -> failure "Kind mismatch" []
- _ -> failure "Invalid SomeTypeRep" []
- where
- tYPErep :: TypeRep TYPE
- tYPErep = typeRep
- failure description info =
- fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
- ++ map (" "++) info
-
-instance Typeable a => Binary (TypeRep (a :: k)) where
- put_ = putTypeRep
- get bh = do
- SomeTypeRep rep <- getSomeTypeRep bh
- case rep `eqTypeRep` expected of
- Just HRefl -> pure rep
- Nothing -> fail $ unlines
- [ "Binary: Type mismatch"
- , " Deserialized type: " ++ show rep
- , " Expected type: " ++ show expected
- ]
- where expected = typeRep :: TypeRep a
-
-instance Binary SomeTypeRep where
- put_ bh (SomeTypeRep rep) = putTypeRep bh rep
- get = getSomeTypeRep
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
@@ -1212,207 +1029,10 @@ instance Binary FastString where
deriving instance Binary NonDetFastString
deriving instance Binary LexicalFastString
--- Here to avoid loop
-instance Binary LeftOrRight where
- put_ bh CLeft = putByte bh 0
- put_ bh CRight = putByte bh 1
-
- get bh = do { h <- getByte bh
- ; case h of
- 0 -> return CLeft
- _ -> return CRight }
-
-instance Binary PromotionFlag where
- put_ bh NotPromoted = putByte bh 0
- put_ bh IsPromoted = putByte bh 1
-
- get bh = do
- n <- getByte bh
- case n of
- 0 -> return NotPromoted
- 1 -> return IsPromoted
- _ -> fail "Binary(IsPromoted): fail)"
-
instance Binary Fingerprint where
put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
-instance Binary FunctionOrData where
- put_ bh IsFunction = putByte bh 0
- put_ bh IsData = putByte bh 1
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return IsFunction
- 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 FinalActive = do
- putByte bh 1
- put_ bh AlwaysActive = do
- putByte bh 2
- put_ bh (ActiveBefore src aa) = do
- putByte bh 3
- put_ bh src
- put_ bh aa
- put_ bh (ActiveAfter src ab) = do
- putByte bh 4
- put_ bh src
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return NeverActive
- 1 -> do return FinalActive
- 2 -> do return AlwaysActive
- 3 -> do src <- get bh
- aa <- get bh
- return (ActiveBefore src aa)
- _ -> do src <- get bh
- ab <- get bh
- return (ActiveAfter src 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 NoUserInlinePrag = 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 NoUserInlinePrag
- 1 -> return Inline
- 2 -> return Inlinable
- _ -> return NoInline
-
-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 src aa ab) = do
- put_ bh src
- put_ bh aa
- put_ bh ab
- get bh = do
- src <- get bh
- aa <- get bh
- ab <- get bh
- return (Fixity src 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 (Located a) where
put_ bh (L l x) = do
put_ bh l
@@ -1488,27 +1108,3 @@ instance Binary SrcSpan where
return (RealSrcSpan ss sb)
_ -> do s <- get bh
return (UnhelpfulSpan s)
-
-instance Binary Serialized where
- put_ bh (Serialized the_type bytes) = do
- put_ bh the_type
- put_ bh bytes
- get bh = do
- the_type <- get bh
- bytes <- get bh
- return (Serialized the_type bytes)
-
-instance Binary SourceText where
- put_ bh NoSourceText = putByte bh 0
- put_ bh (SourceText s) = do
- putByte bh 1
- put_ bh s
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoSourceText
- 1 -> do
- s <- get bh
- return (SourceText s)
- _ -> panic $ "Binary SourceText:" ++ show h
View Lorry Controller Status