summaryrefslogtreecommitdiff
path: root/compiler/utils/Binary.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/utils/Binary.hs')
-rw-r--r--compiler/utils/Binary.hs177
1 files changed, 173 insertions, 4 deletions
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index ffd1eb25fa..b10ab1d5f2 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -1,5 +1,8 @@
{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -O -funbox-strict-fields #-}
-- We always optimise this, otherwise performance of a non-optimised
@@ -73,7 +76,14 @@ import qualified Data.ByteString.Unsafe as BS
import Data.IORef
import Data.Char ( ord, chr )
import Data.Time
+#if MIN_VERSION_base(4,10,0)
+import Type.Reflection
+import Type.Reflection.Unsafe
+import Data.Kind (Type)
+import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))
+#else
import Data.Typeable
+#endif
import Control.Monad ( when )
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
@@ -597,17 +607,175 @@ instance Binary (Bin a) where
-- -----------------------------------------------------------------------------
-- Instances for Data.Typeable stuff
+#if MIN_VERSION_base(4,10,0)
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
+#else
+instance Binary TyCon where
+ put_ bh tc = do
+ put_ bh (tyConPackage tc)
+ put_ bh (tyConModule tc)
+ put_ bh (tyConName tc)
+ get bh =
+ mkTyCon3 <$> get bh <*> get bh <*> get bh
+#endif
+
+#if MIN_VERSION_base(4,10,0)
+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
+
get bh = do
- p <- get bh
- m <- get bh
- n <- get bh
- return (mkTyCon3 p m n)
+ 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
+ _ -> 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
+ put_ _ _ = fail "Binary.putKindRep: impossible"
+ 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
+putTypeRep _ _ = fail "Binary.putTypeRep: Impossible"
+
+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
+ case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
+ Just HRefl ->
+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
+ Just HRefl -> return $ SomeTypeRep $ Fun arg res
+ Nothing -> failure "Kind mismatch" []
+ _ -> failure "Kind mismatch" []
+ _ -> failure "Invalid SomeTypeRep" []
+ where
+ 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
+#else
instance Binary TypeRep where
put_ bh type_rep = do
let (ty_con, child_type_reps) = splitTyConApp type_rep
@@ -617,6 +785,7 @@ instance Binary TypeRep where
ty_con <- get bh
child_type_reps <- get bh
return (mkTyConApp ty_con child_type_reps)
+#endif
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
View Lorry Controller Status