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

[git at git.haskell.org]

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

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

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

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

    Break recursive loop in serialization


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

bab42dd75c453979360640db10b56dd8984eec4e
 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 c5fc8cb..366fb26 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
@@ -590,12 +591,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"
@@ -604,13 +612,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 573a9e4..bcf58bb 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
@@ -82,12 +83,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"
@@ -96,13 +104,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 _ ->