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

3 files changed, 25 insertions, 8 deletions

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"