summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/prelude/TysPrim.hs7
-rw-r--r--compiler/prelude/primops.txt.pp6
-rw-r--r--libraries/ghc-heap/tests/closure_size.hs1
-rw-r--r--libraries/ghc-heap/tests/heap_all.hs6
-rw-r--r--libraries/ghci/GHCi/CreateBCO.hs23
-rw-r--r--utils/genprimopcode/Main.hs2
6 files changed, 23 insertions, 22 deletions
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 79a30482b0..a023c430fe 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -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
{-
************************************************************************
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 0faf180061..de7d498da1 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -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
diff --git a/libraries/ghc-heap/tests/closure_size.hs b/libraries/ghc-heap/tests/closure_size.hs
index d760f22efa..85d860fbf4 100644
--- a/libraries/ghc-heap/tests/closure_size.hs
+++ b/libraries/ghc-heap/tests/closure_size.hs
@@ -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
diff --git a/libraries/ghc-heap/tests/heap_all.hs b/libraries/ghc-heap/tests/heap_all.hs
index 1560d4d9e8..fa536a2d30 100644
--- a/libraries/ghc-heap/tests/heap_all.hs
+++ b/libraries/ghc-heap/tests/heap_all.hs
@@ -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 #)
diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs
index 96fc4418ff..7098c27fb8 100644
--- a/libraries/ghci/GHCi/CreateBCO.hs
+++ b/libraries/ghci/GHCi/CreateBCO.hs
@@ -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.
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index b99f36dad2..ef8e284593 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -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 ()
View Lorry Controller Status