Commit a25bf267 authored by mniip's avatar mniip Committed by Ben Gamari

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
parent 83b326cd
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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) \
......
......@@ -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
......
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)
: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" ]
["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\""]
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment