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
stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon
compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon
bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon
bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon
weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
......@@ -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 = mkTyConTy bcoPrimTyCon
bcoPrimTyCon :: TyCon
bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep
bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep
{-
************************************************************************
......
......@@ -3249,7 +3249,7 @@ section "Bytecode operations"
contain a list of instructions and data needed by these instructions.}
------------------------------------------------------------------------
primtype BCO#
primtype BCO
{ Primitive bytecode type. }
primop AddrToAnyOp "addrToAny#" GenPrimOp
......@@ -3274,14 +3274,14 @@ primop AnyToAddrOp "anyToAddr#" GenPrimOp
code_size = 0
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
the BCO when evaluated. }
with
out_of_line = True
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
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
......
......@@ -12,7 +12,6 @@ data A = A (Array# Int)
data MA = MA (MutableArray# RealWorld Int)
data BA = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)
data B = B BCO#
data APC a = APC a
......
......@@ -197,7 +197,6 @@ data A = A (Array# Int)
data MA = MA (MutableArray# RealWorld Int)
data BA = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)
data B = B BCO#
data APC a = APC a
main :: IO ()
......@@ -220,9 +219,8 @@ main = do
(# s1, x #) ->
case unsafeFreezeByteArray# x s1 of
(# s2, y #) -> (# s2, BA y #)
B bco <- IO $ \s ->
case newBCO# ba ba a 0# ba s of
(# s1, x #) -> (# s1, B x #)
bco <- IO $ \s ->
newBCO# ba ba a 0# ba s
APC apc <- IO $ \s ->
case mkApUpd0# bco of
(# x #) -> (# s, APC x #)
......
......@@ -23,6 +23,7 @@ import System.IO (fixIO)
import Control.Monad
import Data.Array.Base
import Foreign hiding (newArray)
import Unsafe.Coerce (unsafeCoerce)
import GHC.Arr ( Array(..) )
import GHC.Exts
import GHC.IO
......@@ -44,7 +45,9 @@ createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian
, "mixed endianness setup is not supported!"
])
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
-- interpreted CAFs don't get updated after evaluation. A
-- top-level BCO will evaluate itself and return its value
......@@ -57,9 +60,10 @@ createBCO arr bco
-- (c) An AP is always fully saturated, so we *can't* wrap
-- non-zero arity BCOs in an AP thunk.
--
-- See #17424.
if (resolvedBCOArity bco > 0)
then return (HValue (unsafeCoerce# bco#))
else case mkApUpd0# bco# of { (# final_bco #) ->
then return (HValue (unsafeCoerce linked_bco))
else case mkApUpd0# linked_bco of { (# final_bco #) ->
return (HValue final_bco) }
......@@ -102,8 +106,8 @@ mkPtrsArray arr n_ptrs ptrs = do
fill (ResolvedBCOStaticPtr r) i = do
writePtrsArrayPtr i (fromRemotePtr r) marr
fill (ResolvedBCOPtrBCO bco) i = do
BCO bco# <- linkBCO' arr bco
writePtrsArrayBCO i bco# marr
bco <- linkBCO' arr bco
writePtrsArrayBCO i bco marr
fill (ResolvedBCOPtrBreakArray r) i = do
BA mba <- localRef r
writePtrsArrayMBA i mba marr
......@@ -130,23 +134,20 @@ writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# 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 ->
case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
data BCO = BCO BCO#
writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO instrs lits ptrs arity bitmap = IO $ \s ->
case newBCO# instrs lits ptrs arity bitmap s of
(# s1, bco #) -> (# s1, BCO bco #)
newBCO# instrs lits ptrs arity bitmap s
{- Note [BCO empty array]
~~~~~~~~~~~~~~~~~~~~~~
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
share it between all BCOs.
......
......@@ -857,7 +857,7 @@ ppType (TyApp (TyCon "ByteArray#") []) = "byteArrayPrimTy"
ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy"
ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy"
ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
ppType (TyApp (TyCon "BCO#") []) = "bcoPrimTy"
ppType (TyApp (TyCon "BCO") []) = "bcoPrimTy"
ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy"
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