Make BCO# liftedwip/T17424b

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.

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 076854b4d2..080b7f9b6c 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -3242,7 +3242,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
@@ -3267,14 +3267,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 ()