Tag pointers in interpreted constructors

Instead of stg_interp_constr_entry there are now 7 functions (one for
each value of the tag bits) that tag the constructor pointer before
returning. This is consistent with compiled constructors' entry code,
and expectations that compiled code places on compiled constructors. The
iserv protocol is extended with an extra field that explains what
pointer tag the constructor should use.

Test Plan: Added tests for #12523

Reviewers: erikd, bgamari, hvr, austin, simonmar

Reviewed By: simonmar

Subscribers: osa1, thomie, rwbarton

Differential Revision: https://phabricator.haskell.org/D2473

GHC Trac Issues: #12523

11 files changed, 105 insertions, 16 deletions

diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 25d4f4a257..8e30234c4f 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -19,6 +19,7 @@ import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import RepType          ( typePrimRep, repTypeArgs )
 import StgCmmLayout     ( mkVirtHeapOffsets )
+import StgCmmClosure    ( tagForCon )
 import Util
 import Panic
 
@@ -68,5 +69,6 @@ make_constr_itbls hsc_env cons =
 
          descr = dataConIdentity dcon
 
-     r <- iservCmd hsc_env (MkConInfoTable  ptrs' nptrs_really conNo descr)
+     r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
+                              conNo (tagForCon dflags dcon) descr)
      return (getName dcon, ItblPtr r)
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 3f5e403d49..07a7752ed2 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -64,7 +64,13 @@ RTS_RET(stg_maskAsyncExceptionszh_ret);
 RTS_RET(stg_stack_underflow_frame);
 RTS_RET(stg_restore_cccs);
 
-// RTS_FUN(stg_interp_constr_entry);
+// RTS_FUN(stg_interp_constr1_entry);
+// RTS_FUN(stg_interp_constr2_entry);
+// RTS_FUN(stg_interp_constr3_entry);
+// RTS_FUN(stg_interp_constr4_entry);
+// RTS_FUN(stg_interp_constr5_entry);
+// RTS_FUN(stg_interp_constr6_entry);
+// RTS_FUN(stg_interp_constr7_entry);
 //
 // This is referenced using the FFI in the compiler (ByteCodeItbls),
 // so we can't give it the correct type here because the prototypes
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
index 7e1f8bcf71..e4deb3b6ff 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -24,15 +24,16 @@ mkConInfoTable
    :: Int     -- ptr words
    -> Int     -- non-ptr words
    -> Int     -- constr tag
+   -> Int     -- pointer tag
    -> [Word8]  -- con desc
    -> IO (Ptr StgInfoTable)
       -- resulting info table is allocated with allocateExec(), and
       -- should be freed with freeExec().
 
-mkConInfoTable ptr_words nonptr_words tag con_desc =
+mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =
   castFunPtrToPtr <$> newExecConItbl itbl con_desc
   where
-     entry_addr = stg_interp_constr_entry
+     entry_addr = interpConstrEntry !! ptrtag
      code' = mkJumpToAddr entry_addr
      itbl  = StgInfoTable {
                  entry = if ghciTablesNextToCode
@@ -283,8 +284,23 @@ byte7 w = fromIntegral (w `shiftR` 56)
 #include "Rts.h"
 
 -- entry point for direct returns for created constr itbls
-foreign import ccall "&stg_interp_constr_entry"
-    stg_interp_constr_entry :: EntryFunPtr
+foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr
+foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr
+foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr
+foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr
+foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr
+foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr
+foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr
+
+interpConstrEntry :: [EntryFunPtr]
+interpConstrEntry = [ error "pointer tag 0"
+                    , stg_interp_constr1_entry
+                    , stg_interp_constr2_entry
+                    , stg_interp_constr3_entry
+                    , stg_interp_constr4_entry
+                    , stg_interp_constr5_entry
+                    , stg_interp_constr6_entry
+                    , stg_interp_constr7_entry ]
 
 -- Ultra-minimalist version specially for constructors
 #if SIZEOF_VOID_P == 8
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 01fd7f0e3c..4d0417e2da 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -94,6 +94,7 @@ data Message a where
    :: Int     -- ptr words
    -> Int     -- non-ptr words
    -> Int     -- constr tag
+   -> Int     -- pointer tag
    -> [Word8] -- constructor desccription
    -> Message (RemotePtr StgInfoTable)
 
@@ -403,7 +404,7 @@ getMessage = do
       15 -> Msg <$> MallocStrings <$> get
       16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
       17 -> Msg <$> FreeFFI <$> get
-      18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get)
+      18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get)
       19 -> Msg <$> (EvalStmt <$> get <*> get)
       20 -> Msg <$> (ResumeStmt <$> get <*> get)
       21 -> Msg <$> (AbandonStmt <$> get)
@@ -440,7 +441,7 @@ putMessage m = case m of
   MallocStrings bss           -> putWord8 15 >> put bss
   PrepFFI conv args res       -> putWord8 16 >> put conv >> put args >> put res
   FreeFFI p                   -> putWord8 17 >> put p
-  MkConInfoTable p n t d      -> putWord8 18 >> put p >> put n >> put t >> put d
+  MkConInfoTable p n t pt d   -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d
   EvalStmt opts val           -> putWord8 19 >> put opts >> put val
   ResumeStmt opts val         -> putWord8 20 >> put opts >> put val
   AbandonStmt val             -> putWord8 21 >> put val
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 542fe551cd..a5774804ac 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -83,8 +83,8 @@ run m = case m of
   MallocStrings bss -> mapM mkString0 bss
   PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
   FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
-  MkConInfoTable ptrs nptrs tag desc ->
-    toRemotePtr <$> mkConInfoTable ptrs nptrs tag desc
+  MkConInfoTable ptrs nptrs tag ptrtag desc ->
+    toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc
   StartTH -> startTH
   _other -> error "GHCi.Run.run"
 
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index cc26ecbddf..605a669c21 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -714,7 +714,13 @@
       SymI_HasProto(stg_waitWritezh)                                    \
       SymI_HasProto(stg_writeTVarzh)                                    \
       SymI_HasProto(stg_yieldzh)                                        \
-      SymI_NeedsProto(stg_interp_constr_entry)                          \
+      SymI_NeedsProto(stg_interp_constr1_entry)                         \
+      SymI_NeedsProto(stg_interp_constr2_entry)                         \
+      SymI_NeedsProto(stg_interp_constr3_entry)                         \
+      SymI_NeedsProto(stg_interp_constr4_entry)                         \
+      SymI_NeedsProto(stg_interp_constr5_entry)                         \
+      SymI_NeedsProto(stg_interp_constr6_entry)                         \
+      SymI_NeedsProto(stg_interp_constr7_entry)                         \
       SymI_HasProto(stg_arg_bitmaps)                                    \
       SymI_HasProto(large_alloc_lim)                                    \
       SymI_HasProto(g0)                                                 \
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 6c1edf70b5..320816bfbf 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -59,11 +59,14 @@ INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ info_ptr, W_ cccs)
    Support for the bytecode interpreter.
    ------------------------------------------------------------------------- */
 
-/* 9 bits of return code for constructors created by the interpreter. */
-stg_interp_constr_entry (P_ ret)
-{
-    return (ret);
-}
+/* 7 bits of return code for constructors created by the interpreter. */
+stg_interp_constr1_entry (P_ ret) { return (ret + 1); }
+stg_interp_constr2_entry (P_ ret) { return (ret + 2); }
+stg_interp_constr3_entry (P_ ret) { return (ret + 3); }
+stg_interp_constr4_entry (P_ ret) { return (ret + 4); }
+stg_interp_constr5_entry (P_ ret) { return (ret + 5); }
+stg_interp_constr6_entry (P_ ret) { return (ret + 6); }
+stg_interp_constr7_entry (P_ ret) { return (ret + 7); }
 
 /* Some info tables to be used when compiled code returns a value to
    the interpreter, i.e. the interpreter pushes one of these onto the
diff --git a/testsuite/tests/ghci/scripts/T12523.hs b/testsuite/tests/ghci/scripts/T12523.hs
new file mode 100644
index 0000000000..3730c6b6d4
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T12523.hs
@@ -0,0 +1,28 @@
+import Unsafe.Coerce
+
+data D1 a = C11 a deriving Show
+data D2 a b = C21 a | C22 b deriving Show
+data D3 a b c = C31 a | C32 b | C33 c deriving Show
+data D4 a b c d = C41 a | C42 b | C43 c | C44 d deriving Show
+data D5 a b c d e = C51 a | C52 b | C53 c | C54 d | C55 e deriving Show
+data D6 a b c d e f = C61 a | C62 b | C63 c | C64 d | C65 e | C66 f deriving Show
+data D7 a b c d e f g = C71 a | C72 b | C73 c | C74 d | C75 e | C76 f | C77 g deriving Show
+data D8 a b c d e f g h = C81 a | C82 b | C83 c | C84 d | C85 e | C86 f | C87 g | C88 h deriving Show
+
+d1 :: (Show a) => p a -> String
+d2 :: (Show a, Show b) => p a b -> String
+d3 :: (Show a, Show b, Show c) => p a b c -> String
+d4 :: (Show a, Show b, Show c, Show d) => p a b c d -> String
+d5 :: (Show a, Show b, Show c, Show d, Show e) => p a b c d e -> String
+d6 :: (Show a, Show b, Show c, Show d, Show e, Show f) => p a b c d e f -> String
+d7 :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g) => p a b c d e f g -> String
+d8 :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h) => p a b c d e f g h -> String
+
+d1 = show . (unsafeCoerce :: p a -> D1 a)
+d2 = show . (unsafeCoerce :: p a b -> D2 a b)
+d3 = show . (unsafeCoerce :: p a b c -> D3 a b c)
+d4 = show . (unsafeCoerce :: p a b c d -> D4 a b c d)
+d5 = show . (unsafeCoerce :: p a b c d e -> D5 a b c d e)
+d6 = show . (unsafeCoerce :: p a b c d e f -> D6 a b c d e f)
+d7 = show . (unsafeCoerce :: p a b c d e f g -> D7 a b c d e f g)
+d8 = show . (unsafeCoerce :: p a b c d e f g h -> D8 a b c d e f g h)
diff --git a/testsuite/tests/ghci/scripts/T12523.script b/testsuite/tests/ghci/scripts/T12523.script
new file mode 100644
index 0000000000..290a410daf
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T12523.script
@@ -0,0 +1,18 @@
+:set -fobject-code
+:load T12523.hs
+data ID1 a = IC11 a
+data ID2 a b = IC21 a | IC22 b
+data ID3 a b c = IC31 a | IC32 b | IC33 c
+data ID4 a b c d = IC41 a | IC42 b | IC43 c | IC44 d
+data ID5 a b c d e = IC51 a | IC52 b | IC53 c | IC54 d | IC55 e
+data ID6 a b c d e f = IC61 a | IC62 b | IC63 c | IC64 d | IC65 e | IC66 f
+data ID7 a b c d e f g = IC71 a | IC72 b | IC73 c | IC74 d | IC75 e | IC76 f | IC77 g
+data ID8 a b c d e f g h = IC81 a | IC82 b | IC83 c | IC84 d | IC85 e | IC86 f | IC87 g | IC88 h
+map d1 [ IC11 "C11" ]
+map d2 [ IC21 "C21", IC22 "C22" ]
+map d3 [ IC31 "C31", IC32 "C32", IC33 "C33" ]
+map d4 [ IC41 "C41", IC42 "C42", IC43 "C43", IC44 "C44" ]
+map d5 [ IC51 "C51", IC52 "C52", IC53 "C53", IC54 "C54", IC55 "C55" ]
+map d6 [ IC61 "C61", IC62 "C62", IC63 "C63", IC64 "C64", IC65 "C65", IC66 "C66" ]
+map d7 [ IC71 "C71", IC72 "C72", IC73 "C73", IC74 "C74", IC75 "C75", IC76 "C76", IC77 "C77" ]
+map d8 [ IC81 "C81", IC82 "C82", IC83 "C83", IC84 "C84", IC85 "C85", IC86 "C86", IC87 "C87", IC88 "C88" ]
diff --git a/testsuite/tests/ghci/scripts/T12523.stdout b/testsuite/tests/ghci/scripts/T12523.stdout
new file mode 100644
index 0000000000..e94047535c
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T12523.stdout
@@ -0,0 +1,8 @@
+["C11 \"C11\""]
+["C21 \"C21\"","C22 \"C22\""]
+["C31 \"C31\"","C32 \"C32\"","C33 \"C33\""]
+["C41 \"C41\"","C42 \"C42\"","C43 \"C43\"","C44 \"C44\""]
+["C51 \"C51\"","C52 \"C52\"","C53 \"C53\"","C54 \"C54\"","C55 \"C55\""]
+["C61 \"C61\"","C62 \"C62\"","C63 \"C63\"","C64 \"C64\"","C65 \"C65\"","C66 \"C66\""]
+["C71 \"C71\"","C72 \"C72\"","C73 \"C73\"","C74 \"C74\"","C75 \"C75\"","C76 \"C76\"","C77 \"C77\""]
+["C81 \"C81\"","C82 \"C82\"","C83 \"C83\"","C84 \"C84\"","C85 \"C85\"","C86 \"C86\"","C87 \"C87\"","C88 \"C88\""]
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 70422dc98b..9c791e33f2 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -259,3 +259,4 @@ test('T12007', normal, ghci_script, ['T12007.script'])
 test('T11975', normal, ghci_script, ['T11975.script'])
 test('T10963', normal, ghci_script, ['T10963.script'])
 test('T12520', normal, ghci_script, ['T12520.script'])
+test('T12523', normal, ghci_script, ['T12523.script'])