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>
Tue, 30 Aug 2016 21:50:51 +0000 (17:50 -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

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 25d4f4a..8e30234 100644 (file)
@@ -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)
index 3f5e403..07a7752 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 01fd7f0..4d0417e 100644 (file)
@@ -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
index 542fe55..a577480 100644 (file)
@@ -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"
 
index cc26ecb..605a669 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 6c1edf7..320816b 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 70422dc..9c791e3 100755 (executable)
@@ -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'])