Tag pointers in interpreted constructors
authormniip <mniip@mniip.com>
Tue, 30 Aug 2016 20:57:47 +0000 (16:57 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 1 Sep 2016 05:02:21 +0000 (01:02 -0400)
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

(cherry picked from commit a25bf2673d0f6db5f454619ddf91f974cace4e8b)

compiler/ghci/ByteCodeItbls.hs
includes/stg/MiscClosures.h
libraries/ghci/GHCi/InfoTable.hsc
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/Run.hs
rts/RtsSymbols.c
rts/StgMiscClosures.cmm
testsuite/tests/ghci/scripts/T12523.hs [new file with mode: 0644]
testsuite/tests/ghci/scripts/T12523.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T12523.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T

index 4e1c828..a18f720 100644 (file)
@@ -19,6 +19,7 @@ import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import Type             ( flattenRepType, repType, typePrimRep )
 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)
index 75e59ce..4f72e9f 100644 (file)
@@ -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
index 7e1f8bc..e4deb3b 100644 (file)
@@ -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
index 4e96f26..ccc85d7 100644 (file)
@@ -85,6 +85,7 @@ data Message a where
    :: Int     -- ptr words
    -> Int     -- non-ptr words
    -> Int     -- constr tag
+   -> Int     -- pointer tag
    -> [Word8] -- constructor desccription
    -> Message (RemotePtr StgInfoTable)
 
@@ -327,7 +328,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)
@@ -385,7 +386,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
index a2ea4e2..7e552e9 100644 (file)
@@ -80,8 +80,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"
 
index 11bc0e6..a531708 100644 (file)
       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)                                                 \
index 871199c..6e36bfd 100644 (file)
@@ -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 (file)
index 0000000..3730c6b
--- /dev/null
@@ -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 (file)
index 0000000..290a410
--- /dev/null
@@ -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 (file)
index 0000000..e940475
--- /dev/null
@@ -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\""]
index a0b5f1b..c0b8fc0 100755 (executable)
@@ -249,3 +249,4 @@ test('T11456', normal, ghci_script, ['T11456.script'])
 test('TypeAppData', normal, ghci_script, ['TypeAppData.script'])
 test('T11376', normal, ghci_script, ['T11376.script'])
 test('T12007', normal, ghci_script, ['T12007.script'])
+test('T12523', normal, ghci_script, ['T12523.script'])