[commit: ghc] wip/ttypeable: Break recursive loop in serialization (228dbdb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/ttypeable
Link       : http://ghc.haskell.org/trac/ghc/changeset/228dbdb9a7b6d454fe92d4861299c936f265f0ef/ghc

>---------------------------------------------------------------

commit 228dbdb9a7b6d454fe92d4861299c936f265f0ef
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Mar 16 13:01:45 2016 +0100

    Break recursive loop in serialization


>---------------------------------------------------------------

228dbdb9a7b6d454fe92d4861299c936f265f0ef
 compiler/utils/Binary.hs         | 18 ++++++++++++++----
 libraries/ghci/GHCi/TH/Binary.hs | 18 ++++++++++++++----
 2 files changed, 28 insertions(+), 8 deletions(-)

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index a346e0d..b26778e 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -82,6 +82,7 @@ import Data.Time
 import Type.Reflection
 import Type.Reflection.Unsafe
 import Data.Kind (Type)
+import GHC.Exts (RuntimeRep)
 #else
 import Data.Typeable
 #endif
@@ -579,12 +580,19 @@ instance Binary TyCon where
 
 #if MIN_VERSION_base(4,9,0)
 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)
+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep RuntimeRep)
+  = put_ bh (1 :: Word8)
 putTypeRep bh rep@(TRCon con) = do
-    put_ bh (0 :: Word8)
+    put_ bh (2 :: Word8)
     put_ bh con
     putTypeRep bh (typeRepKind rep)
 putTypeRep bh (TRApp f x) = do
-    put_ bh (1 :: Word8)
+    put_ bh (3 :: Word8)
     putTypeRep bh f
     putTypeRep bh x
 putTypeRep _ _ = fail "putTypeRep: Impossible"
@@ -593,13 +601,15 @@ getTypeRepX :: BinHandle -> IO TypeRepX
 getTypeRepX bh = do
     tag <- get bh :: IO Word8
     case tag of
-        0 -> do con <- get bh :: IO TyCon
+        0 -> return $ TypeRepX (typeRep :: TypeRep Type)
+        1 -> return $ TypeRepX (typeRep :: TypeRep RuntimeRep)
+        2 -> do con <- get bh :: IO TyCon
                 TypeRepX rep_k <- getTypeRepX bh
                 case rep_k `eqTypeRep` (typeRep :: TypeRep Type) of
                     Just HRefl -> pure $ TypeRepX $ mkTrCon con rep_k
                     Nothing    -> fail "getTypeRepX: Kind mismatch"
 
-        1 -> do TypeRepX f <- getTypeRepX bh
+        3 -> do TypeRepX f <- getTypeRepX bh
                 TypeRepX x <- getTypeRepX bh
                 case typeRepKind f of
                     TRFun arg _ ->
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 2f41645..fcd81d3 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -14,6 +14,7 @@ import qualified Data.ByteString as B
 import Type.Reflection
 import Type.Reflection.Unsafe
 import Data.Kind (Type)
+import GHC.Exts (RuntimeRep)
 #else
 import Data.Typeable
 #endif
@@ -79,12 +80,19 @@ instance Binary TyCon where
     get = mkTyCon <$> get <*> get <*> get
 
 putTypeRep :: TypeRep a -> Put
+-- Special handling for Type and RuntimeRep due to recursive kind relations.
+-- See Note [Mutually recursive representations of primitive types]
+putTypeRep rep
+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
+  = put (0 :: Word8)
+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep RuntimeRep)
+  = put (1 :: Word8)
 putTypeRep rep@(TRCon con) = do
-    put (0 :: Word8)
+    put (2 :: Word8)
     put con
     putTypeRep (typeRepKind rep)
 putTypeRep (TRApp f x) = do
-    put (1 :: Word8)
+    put (3 :: Word8)
     putTypeRep f
     putTypeRep x
 putTypeRep _ = fail "putTypeRep: Impossible"
@@ -93,13 +101,15 @@ getTypeRepX :: Get TypeRepX
 getTypeRepX = do
     tag <- get :: Get Word8
     case tag of
-        0 -> do con <- get :: Get TyCon
+        0 -> return $ TypeRepX (typeRep :: TypeRep Type)
+        1 -> return $ TypeRepX (typeRep :: TypeRep RuntimeRep)
+        2 -> do con <- get :: Get TyCon
                 TypeRepX rep_k <- getTypeRepX
                 case rep_k `eqTypeRep` (typeRep :: TypeRep Type) of
                     Just HRefl -> pure $ TypeRepX $ mkTrCon con rep_k
                     Nothing    -> fail "getTypeRepX: Kind mismatch"
 
-        1 -> do TypeRepX f <- getTypeRepX
+        3 -> do TypeRepX f <- getTypeRepX
                 TypeRepX x <- getTypeRepX
                 case typeRepKind f of
                     TRFun arg _ ->