Commit 705a16df authored by Ben Gamari's avatar Ben Gamari 🐢 Committed by Marge Bot

Make BCO# lifted

In #17424 Simon PJ noted that there is a potentially unsafe occurrence
of unsafeCoerce#, coercing from an unlifted to lifted type. However,
nowhere in the compiler do we assume that a BCO# is not a thunk.
Moreover, in the case of a CAF the result returned by `createBCO` *will*
be a thunk (as noted in [Updatable CAF BCOs]).  Consequently it seems
better to rather make BCO# a lifted type and rename it to BCO.
parent 5a4b8d0c
Pipeline #13443 passed with stages
in 321 minutes and 34 seconds
...@@ -239,7 +239,7 @@ tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPr ...@@ -239,7 +239,7 @@ tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPr
stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon
compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon
bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon
weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
...@@ -1052,10 +1052,13 @@ compactPrimTy = mkTyConTy compactPrimTyCon ...@@ -1052,10 +1052,13 @@ compactPrimTy = mkTyConTy compactPrimTyCon
************************************************************************ ************************************************************************
-} -}
-- Unlike most other primitive types, BCO is lifted. This is because in
-- general a BCO may be a thunk for the reasons given in Note [Updatable CAF
-- BCOs] in GHCi.CreateBCO.
bcoPrimTy :: Type bcoPrimTy :: Type
bcoPrimTy = mkTyConTy bcoPrimTyCon bcoPrimTy = mkTyConTy bcoPrimTyCon
bcoPrimTyCon :: TyCon bcoPrimTyCon :: TyCon
bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep
{- {-
************************************************************************ ************************************************************************
......
...@@ -3249,7 +3249,7 @@ section "Bytecode operations" ...@@ -3249,7 +3249,7 @@ section "Bytecode operations"
contain a list of instructions and data needed by these instructions.} contain a list of instructions and data needed by these instructions.}
------------------------------------------------------------------------ ------------------------------------------------------------------------
primtype BCO# primtype BCO
{ Primitive bytecode type. } { Primitive bytecode type. }
primop AddrToAnyOp "addrToAny#" GenPrimOp primop AddrToAnyOp "addrToAny#" GenPrimOp
...@@ -3274,14 +3274,14 @@ primop AnyToAddrOp "anyToAddr#" GenPrimOp ...@@ -3274,14 +3274,14 @@ primop AnyToAddrOp "anyToAddr#" GenPrimOp
code_size = 0 code_size = 0
primop MkApUpd0_Op "mkApUpd0#" GenPrimOp primop MkApUpd0_Op "mkApUpd0#" GenPrimOp
BCO# -> (# a #) BCO -> (# a #)
{ Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of
the BCO when evaluated. } the BCO when evaluated. }
with with
out_of_line = True out_of_line = True
primop NewBCOOp "newBCO#" GenPrimOp primop NewBCOOp "newBCO#" GenPrimOp
ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO# #) ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #)
{ {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The { {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The
resulting object encodes a function of the given arity with the instructions resulting object encodes a function of the given arity with the instructions
encoded in {\tt instrs}, and a static reference table usage bitmap given by encoded in {\tt instrs}, and a static reference table usage bitmap given by
......
...@@ -12,7 +12,6 @@ data A = A (Array# Int) ...@@ -12,7 +12,6 @@ data A = A (Array# Int)
data MA = MA (MutableArray# RealWorld Int) data MA = MA (MutableArray# RealWorld Int)
data BA = BA ByteArray# data BA = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld) data MBA = MBA (MutableByteArray# RealWorld)
data B = B BCO#
data APC a = APC a data APC a = APC a
......
...@@ -197,7 +197,6 @@ data A = A (Array# Int) ...@@ -197,7 +197,6 @@ data A = A (Array# Int)
data MA = MA (MutableArray# RealWorld Int) data MA = MA (MutableArray# RealWorld Int)
data BA = BA ByteArray# data BA = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld) data MBA = MBA (MutableByteArray# RealWorld)
data B = B BCO#
data APC a = APC a data APC a = APC a
main :: IO () main :: IO ()
...@@ -220,9 +219,8 @@ main = do ...@@ -220,9 +219,8 @@ main = do
(# s1, x #) -> (# s1, x #) ->
case unsafeFreezeByteArray# x s1 of case unsafeFreezeByteArray# x s1 of
(# s2, y #) -> (# s2, BA y #) (# s2, y #) -> (# s2, BA y #)
B bco <- IO $ \s -> bco <- IO $ \s ->
case newBCO# ba ba a 0# ba s of newBCO# ba ba a 0# ba s
(# s1, x #) -> (# s1, B x #)
APC apc <- IO $ \s -> APC apc <- IO $ \s ->
case mkApUpd0# bco of case mkApUpd0# bco of
(# x #) -> (# s, APC x #) (# x #) -> (# s, APC x #)
......
...@@ -23,6 +23,7 @@ import System.IO (fixIO) ...@@ -23,6 +23,7 @@ import System.IO (fixIO)
import Control.Monad import Control.Monad
import Data.Array.Base import Data.Array.Base
import Foreign hiding (newArray) import Foreign hiding (newArray)
import Unsafe.Coerce (unsafeCoerce)
import GHC.Arr ( Array(..) ) import GHC.Arr ( Array(..) )
import GHC.Exts import GHC.Exts
import GHC.IO import GHC.IO
...@@ -44,7 +45,9 @@ createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian ...@@ -44,7 +45,9 @@ createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian
, "mixed endianness setup is not supported!" , "mixed endianness setup is not supported!"
]) ])
createBCO arr bco createBCO arr bco
= do BCO bco# <- linkBCO' arr bco = do linked_bco <- linkBCO' arr bco
-- Note [Updatable CAF BCOs]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- Why do we need mkApUpd0 here? Otherwise top-level -- Why do we need mkApUpd0 here? Otherwise top-level
-- interpreted CAFs don't get updated after evaluation. A -- interpreted CAFs don't get updated after evaluation. A
-- top-level BCO will evaluate itself and return its value -- top-level BCO will evaluate itself and return its value
...@@ -57,9 +60,10 @@ createBCO arr bco ...@@ -57,9 +60,10 @@ createBCO arr bco
-- (c) An AP is always fully saturated, so we *can't* wrap -- (c) An AP is always fully saturated, so we *can't* wrap
-- non-zero arity BCOs in an AP thunk. -- non-zero arity BCOs in an AP thunk.
-- --
-- See #17424.
if (resolvedBCOArity bco > 0) if (resolvedBCOArity bco > 0)
then return (HValue (unsafeCoerce# bco#)) then return (HValue (unsafeCoerce linked_bco))
else case mkApUpd0# bco# of { (# final_bco #) -> else case mkApUpd0# linked_bco of { (# final_bco #) ->
return (HValue final_bco) } return (HValue final_bco) }
...@@ -102,8 +106,8 @@ mkPtrsArray arr n_ptrs ptrs = do ...@@ -102,8 +106,8 @@ mkPtrsArray arr n_ptrs ptrs = do
fill (ResolvedBCOStaticPtr r) i = do fill (ResolvedBCOStaticPtr r) i = do
writePtrsArrayPtr i (fromRemotePtr r) marr writePtrsArrayPtr i (fromRemotePtr r) marr
fill (ResolvedBCOPtrBCO bco) i = do fill (ResolvedBCOPtrBCO bco) i = do
BCO bco# <- linkBCO' arr bco bco <- linkBCO' arr bco
writePtrsArrayBCO i bco# marr writePtrsArrayBCO i bco marr
fill (ResolvedBCOPtrBreakArray r) i = do fill (ResolvedBCOPtrBreakArray r) i = do
BA mba <- localRef r BA mba <- localRef r
writePtrsArrayMBA i mba marr writePtrsArrayMBA i mba marr
...@@ -130,23 +134,20 @@ writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s -> ...@@ -130,23 +134,20 @@ writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO () writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s -> writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #) case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
data BCO = BCO BCO#
writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s -> writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #) case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO instrs lits ptrs arity bitmap = IO $ \s -> newBCO instrs lits ptrs arity bitmap = IO $ \s ->
case newBCO# instrs lits ptrs arity bitmap s of newBCO# instrs lits ptrs arity bitmap s
(# s1, bco #) -> (# s1, BCO bco #)
{- Note [BCO empty array] {- Note [BCO empty array]
~~~~~~~~~~~~~~~~~~~~~~
Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free: Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
they are 2-word heap objects. So let's make a single empty array and they are 2-word heap objects. So let's make a single empty array and
share it between all BCOs. share it between all BCOs.
......
...@@ -857,7 +857,7 @@ ppType (TyApp (TyCon "ByteArray#") []) = "byteArrayPrimTy" ...@@ -857,7 +857,7 @@ ppType (TyApp (TyCon "ByteArray#") []) = "byteArrayPrimTy"
ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy" ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy"
ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy" ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy"
ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy" ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
ppType (TyApp (TyCon "BCO#") []) = "bcoPrimTy" ppType (TyApp (TyCon "BCO") []) = "bcoPrimTy"
ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy" ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy"
ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for () ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for ()
......
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