{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE UnliftedNewtypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE KindSignatures #-}

--
--  (c) The University of Glasgow 2002-2006
--

-- | Create real byte-code objects from 'ResolvedBCO's.
module GHCi.CreateBCO (createBCOs) where

import Prelude -- See note [Why do we import Prelude here?]
import Data.List (sortBy)
import Data.Ord (comparing)
import GHCi.ResolvedBCO
import GHCi.RemoteTypes
import GHCi.BreakArray
import GHC.Data.SmallArray
import Data.List (partition)
import Data.Graph

import System.IO (fixIO)
import Data.Array
import Foreign hiding (newArray)
import Unsafe.Coerce (unsafeCoerce, unsafeCoerceUnlifted)
import GHC.Exts   hiding ( BCO, mkApUpd0#, newBCO# )
import GHC.Internal.Prim ( BCO, mkApUpd0#, newBCO# )
import GHC.IO
import Control.Exception ( ErrorCall(..) )
import Control.Monad

{-
Note [Tying the knot in createBCOs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are two passes for creating the BCOs:

1. Allocate unlifted static cons, which are never mutual recursive, but may refer
   to the array constructed in the second pass.

2. Allocate BCOs and lifted static cons, which may have circular references
   amongst themselves, and also refer to the unlifted cons allocated in the
   first pass.

Notably, it is crucial that all unlifted static cons are eagerly allocated,
returning an evaluated and properly tagged unlifted value, and that all
references to an unlifted static constructor use that unlifted value directly,
rather than a thunk, to preserve the unliftedness invariants. Not doing so
resulted in #25636, which was fixed by the commit introducing this Note.

The unlifted static cons must be allocated in topological order, to ensure a
reference from one to another has already been allocated and can be promptly used.

The BCOs and lifted cons are allocated in 'fixIO', where references to other
BCOs and static cons in the same group are resolved by writing into the
'PtrsArr' a thunk that indexes the recursively constructed array of BCOs.
References to unlifted cons are looked up in the array from the first pass and
must definitely not be thunks.

References from unlifted cons to BCOs are resolved similarly by constructing a
thunk into the second pass array, hence why allocating the unlifted cons must
be inside of the 'fixIO'.
-}

createBCOs :: [ResolvedBCO] -> IO [HValueRef]
createBCOs :: [ResolvedBCO] -> IO [HValueRef]
createBCOs [ResolvedBCO]
objs = do

  let ([(Int, ResolvedBCO)]
unl_objs, [(Int, ResolvedBCO)]
bcos) = ((Int, ResolvedBCO) -> Bool)
-> [(Int, ResolvedBCO)]
-> ([(Int, ResolvedBCO)], [(Int, ResolvedBCO)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (ResolvedBCO -> Bool
isUnliftedObj (ResolvedBCO -> Bool)
-> ((Int, ResolvedBCO) -> ResolvedBCO)
-> (Int, ResolvedBCO)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, ResolvedBCO) -> ResolvedBCO
forall a b. (a, b) -> b
snd) ([Int] -> [ResolvedBCO] -> [(Int, ResolvedBCO)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0::Int)..] [ResolvedBCO]
objs)

      n_bcos :: Int
n_bcos = [(Int, ResolvedBCO)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, ResolvedBCO)]
bcos
      n_objs :: Int
n_objs = [(Int, ResolvedBCO)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, ResolvedBCO)]
unl_objs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_bcos

  -- See Note [Tying the knot in createBCOs]
  (unl_hvals, hvals) <- (([HValue], [HValue]) -> IO ([HValue], [HValue]))
-> IO ([HValue], [HValue])
forall a. (a -> IO a) -> IO a
fixIO ((([HValue], [HValue]) -> IO ([HValue], [HValue]))
 -> IO ([HValue], [HValue]))
-> (([HValue], [HValue]) -> IO ([HValue], [HValue]))
-> IO ([HValue], [HValue])
forall a b. (a -> b) -> a -> b
$ \ ~([HValue]
_, [HValue]
hvs) -> do

    let arr :: Array Int HValue
arr = (Int, Int) -> [HValue] -> Array Int HValue
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
n_bcosInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [HValue]
hvs

    -- First, construct the array of unlifted static cons.
    --
    -- Top-level unlifted constructors are never mutual recursive, so we can do
    -- this by filling the array in topological order.
    --
    -- Lifted fields of unlifted data will store
    -- thunks indexing the `arr` constructed by fixIO.
    (unl_cons, unl_hvals) <- [ResolvedBCO] -> Array Int HValue -> IO (UnlConsArr, [HValue])
createUnliftedStaticCons (((Int, ResolvedBCO) -> ResolvedBCO)
-> [(Int, ResolvedBCO)] -> [ResolvedBCO]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ResolvedBCO) -> ResolvedBCO
forall a b. (a, b) -> b
snd [(Int, ResolvedBCO)]
unl_objs) Array Int HValue
arr

    -- Second, construct the lifted BCOs and static cons which may have
    -- (circular) references to one another in this group. References from this
    -- group to the unlifted static cons will be resolved by looking them up in
    -- the array constructed in the first pass.
    hvals <- mapM (createBCO arr unl_cons) (map snd bcos)
    return (unl_hvals, hvals)

  -- Ensure output hval order matches input obj order
  mapM mkRemoteRef $ elems $ array (0::Int, n_objs - 1) $
    zip (map fst unl_objs) unl_hvals ++
    zip (map fst bcos)     hvals

  where
    isUnliftedObj :: ResolvedBCO -> Bool
    isUnliftedObj :: ResolvedBCO -> Bool
isUnliftedObj = \case
      ResolvedStaticCon{Bool
Word
SmallArray ResolvedBCOPtr
RemotePtr StgInfoTable
BCOByteArray Word
resolvedBCOIsLE :: Bool
resolvedStaticConInfoPtr :: RemotePtr StgInfoTable
resolvedStaticConArity :: Word
resolvedStaticConLits :: BCOByteArray Word
resolvedStaticConPtrs :: SmallArray ResolvedBCOPtr
resolvedStaticConIsUnlifted :: Bool
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedStaticConIsUnlifted :: ResolvedBCO -> Bool
resolvedStaticConPtrs :: ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedStaticConLits :: ResolvedBCO -> BCOByteArray Word
resolvedStaticConArity :: ResolvedBCO -> Word
resolvedStaticConInfoPtr :: ResolvedBCO -> RemotePtr StgInfoTable
..} -> Bool
resolvedStaticConIsUnlifted
      ResolvedBCO
_                     -> Bool
False

createBCO :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO HValue
createBCO :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO HValue
createBCO Array Int HValue
_ UnlConsArr
_ ResolvedBCO
obj | ResolvedBCO -> Bool
resolvedBCOIsLE ResolvedBCO
obj Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
isLittleEndian
  = ErrorCall -> IO HValue
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> ErrorCall
String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$
        [String] -> String
unlines [ String
"The endianness of the ResolvedBCO does not match"
                , String
"the systems endianness. Using ghc and iserv in a"
                , String
"mixed endianness setup is not supported!"
                ])
createBCO Array Int HValue
arr UnlConsArr
unl_arr ResolvedBCO
bco
   = do linked_thing <- Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO
linkBCO' Array Int HValue
arr UnlConsArr
unl_arr ResolvedBCO
bco
        case linked_thing of
          LinkedBCO Int
bco_arity BCO
linked_bco -> do
            -- 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
            -- when entered, but it won't update itself.  Wrapping the BCO
            -- in an AP_UPD thunk will take care of the update for us.
            --
            -- Furthermore:
            --   (a) An AP thunk *must* point directly to a BCO
            --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
            --   (c) An AP is always fully saturated, so we *can't* wrap
            --       non-zero arity BCOs in an AP thunk.
            --
            -- See #17424.
            if (Int
bco_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
               then HValue -> IO HValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> HValue
HValue (BCO -> Any
forall a b. a -> b
unsafeCoerce BCO
linked_bco))
               else case BCO -> (# Any #)
forall a. BCO -> (# a #)
mkApUpd0# BCO
linked_bco of { (# Any
final_bco #) ->
                      HValue -> IO HValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> HValue
HValue Any
final_bco) }
          LinkedStaticCon HValue
linked_static_con -> do
            HValue -> IO HValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HValue
linked_static_con
          LinkedUnliftedStaticCon UnliftedHValue
linked_static_con -> do
            HValue -> IO HValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HValue -> IO HValue) -> HValue -> IO HValue
forall a b. (a -> b) -> a -> b
$! UnliftedHValue -> HValue
forgetUnliftedHValue UnliftedHValue
linked_static_con

-- | The resulting of linking a BCO or static constructor
data LinkedBCO
  = LinkedBCO !Int{-BCO arity-} BCO
  | LinkedStaticCon HValue
  | LinkedUnliftedStaticCon UnliftedHValue

-- | Construct an array of unlifted constructor closures given a list of 'UnliftedStaticCons'.
--
-- INVARIANT: Top-level unlifted constructors are never mutual recursive, so we
-- can do this by filling the array in topological order.
--
-- Lifted fields of unlifted data will be filled by looking them up in the
-- given array of lifted resolved objs.
createUnliftedStaticCons
  :: [ResolvedBCO]    -- ^ 'UnliftedStaticCon's ONLY.
  -> Array Int HValue -- ^ Lifted resolved objects
  -> IO (UnlConsArr, [HValue])
  -- ^ Return both the array to look up the unlifted static constrs by 'BCOIx',
  -- and a list with the same unlifted objects, albeit the unliftedness is
  -- forgotten using 'forgetUnliftedHValue' (allowing them to be put into a
  -- list and later combined with the heap values of lifted objects).
createUnliftedStaticCons :: [ResolvedBCO] -> Array Int HValue -> IO (UnlConsArr, [HValue])
createUnliftedStaticCons [ResolvedBCO]
objs Array Int HValue
lif_arr = do

  -- Get topologically sorted objs with their original indices
  let topoSortedObjs :: [(Int, ResolvedBCO)]
topoSortedObjs = [ResolvedBCO] -> [(Int, ResolvedBCO)]
topSortObjs [ResolvedBCO]
objs
  unl_arr <- Int -> IO UnlConsArr
newUnlConsArr ([(Int, ResolvedBCO)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, ResolvedBCO)]
topoSortedObjs)

  -- Process objs in topological order, but write them at their original indexes
  indexed_vs <- forM topoSortedObjs $ \(Int
origIdx, ResolvedBCO
obj) -> case ResolvedBCO
obj of
    ResolvedStaticCon{Bool
Word
SmallArray ResolvedBCOPtr
RemotePtr StgInfoTable
BCOByteArray Word
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedStaticConIsUnlifted :: ResolvedBCO -> Bool
resolvedStaticConPtrs :: ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedStaticConLits :: ResolvedBCO -> BCOByteArray Word
resolvedStaticConArity :: ResolvedBCO -> Word
resolvedStaticConInfoPtr :: ResolvedBCO -> RemotePtr StgInfoTable
resolvedBCOIsLE :: Bool
resolvedStaticConInfoPtr :: RemotePtr StgInfoTable
resolvedStaticConArity :: Word
resolvedStaticConLits :: BCOByteArray Word
resolvedStaticConPtrs :: SmallArray ResolvedBCOPtr
resolvedStaticConIsUnlifted :: Bool
..}
      | Bool
resolvedStaticConIsUnlifted
      -> do
        -- Because we topologically sort the objs, all unlifted references we
        -- care about when linking this BCO will already be filled in.
        -- The lifted ones are resolved by knot tying (see the fixIO above).
        lbc <- Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO
linkBCO' Array Int HValue
lif_arr UnlConsArr
unl_arr ResolvedBCO
obj
        case lbc of
          LinkedUnliftedStaticCon UnliftedHValue
linked_static_con -> do
            Int -> UnliftedHValue -> UnlConsArr -> IO ()
writeUnlConsArr Int
origIdx UnliftedHValue
linked_static_con UnlConsArr
unl_arr -- Write it to its original index position
            (Int, HValue) -> IO (Int, HValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
origIdx, UnliftedHValue -> HValue
forgetUnliftedHValue UnliftedHValue
linked_static_con)
          LinkedBCO
_ -> String -> IO (Int, HValue)
forall a. HasCallStack => String -> a
error String
"createUnliftedStaticCons: unexpected lifted ResolvedBCO"
    ResolvedBCO
_ ->
      String -> IO (Int, HValue)
forall a. HasCallStack => String -> a
error String
"createUnliftedStaticCons: unexpected lifted ResolvedBCO"

  -- Return them in the original order
  let vs = ((Int, HValue) -> HValue) -> [(Int, HValue)] -> [HValue]
forall a b. (a -> b) -> [a] -> [b]
map (Int, HValue) -> HValue
forall a b. (a, b) -> b
snd ([(Int, HValue)] -> [HValue]) -> [(Int, HValue)] -> [HValue]
forall a b. (a -> b) -> a -> b
$ ((Int, HValue) -> (Int, HValue) -> Ordering)
-> [(Int, HValue)] -> [(Int, HValue)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, HValue) -> Int)
-> (Int, HValue) -> (Int, HValue) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, HValue) -> Int
forall a b. (a, b) -> a
fst) [(Int, HValue)]
indexed_vs
  return (unl_arr, vs)
  where
    -- Return the topologically sorted objects with their original index.
    topSortObjs :: [ResolvedBCO] -> [(Int, ResolvedBCO)]
    topSortObjs :: [ResolvedBCO] -> [(Int, ResolvedBCO)]
topSortObjs [ResolvedBCO]
objs =
      let
        edges :: [((Int, ResolvedBCO), Int, [Int])]
edges = [ ((Int
origIdx, ResolvedBCO
obj), Int
origIdx, ResolvedBCO -> [Int]
getUnlDeps ResolvedBCO
obj)
                | (Int
origIdx, ResolvedBCO
obj) <- [Int] -> [ResolvedBCO] -> [(Int, ResolvedBCO)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [ResolvedBCO]
objs ]

        getUnlDeps :: ResolvedBCO -> [Int]
        getUnlDeps :: ResolvedBCO -> [Int]
getUnlDeps (ResolvedStaticCon{Bool
Word
SmallArray ResolvedBCOPtr
RemotePtr StgInfoTable
BCOByteArray Word
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedStaticConIsUnlifted :: ResolvedBCO -> Bool
resolvedStaticConPtrs :: ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedStaticConLits :: ResolvedBCO -> BCOByteArray Word
resolvedStaticConArity :: ResolvedBCO -> Word
resolvedStaticConInfoPtr :: ResolvedBCO -> RemotePtr StgInfoTable
resolvedBCOIsLE :: Bool
resolvedStaticConInfoPtr :: RemotePtr StgInfoTable
resolvedStaticConArity :: Word
resolvedStaticConLits :: BCOByteArray Word
resolvedStaticConPtrs :: SmallArray ResolvedBCOPtr
resolvedStaticConIsUnlifted :: Bool
..}) =
          [ Int
k | ResolvedBCOPtr
ptr <- SmallArray ResolvedBCOPtr -> [ResolvedBCOPtr]
forall a. SmallArray a -> [a]
smallArrayToList SmallArray ResolvedBCOPtr
resolvedStaticConPtrs
              , ResolvedUnliftedStaticConRef Int
k <- [ResolvedBCOPtr
ptr] ]
        getUnlDeps ResolvedBCO
_ = []

        (Graph
graph, Int -> ((Int, ResolvedBCO), Int, [Int])
vertexToNode, Int -> Maybe Int
_keyToVertex) = [((Int, ResolvedBCO), Int, [Int])]
-> (Graph, Int -> ((Int, ResolvedBCO), Int, [Int]),
    Int -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
graphFromEdges [((Int, ResolvedBCO), Int, [Int])]
edges
        sortedVertices :: [Int]
sortedVertices = [Int] -> [Int]
forall a. [a] -> [a]
reverse (Graph -> [Int]
topSort Graph
graph)
      in
        [ (Int, ResolvedBCO)
ix_obj | Int
v <- [Int]
sortedVertices
                 , let ((Int, ResolvedBCO)
ix_obj, Int
_, [Int]
_) = Int -> ((Int, ResolvedBCO), Int, [Int])
vertexToNode Int
v ]

linkBCO' :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO
linkBCO' :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO
linkBCO' Array Int HValue
arr UnlConsArr
unl_arr ResolvedBCO
resolved_obj =
  case ResolvedBCO
resolved_obj of
    ResolvedBCO{Bool
Int
SmallArray ResolvedBCOPtr
BCOByteArray Word
BCOByteArray Word16
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedBCOIsLE :: Bool
resolvedBCOArity :: Int
resolvedBCOInstrs :: BCOByteArray Word16
resolvedBCOBitmap :: BCOByteArray Word
resolvedBCOLits :: BCOByteArray Word
resolvedBCOPtrs :: SmallArray ResolvedBCOPtr
resolvedBCOPtrs :: ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedBCOLits :: ResolvedBCO -> BCOByteArray Word
resolvedBCOBitmap :: ResolvedBCO -> BCOByteArray Word
resolvedBCOInstrs :: ResolvedBCO -> BCOByteArray Word16
resolvedBCOArity :: ResolvedBCO -> Int
..} -> do
      let
          !(I# Int#
arity#)  = Int
resolvedBCOArity

          insns_barr :: ByteArray#
insns_barr = ByteArray# -> ByteArray#
barr (BCOByteArray Word16 -> ByteArray#
forall a. BCOByteArray a -> ByteArray#
getBCOByteArray BCOByteArray Word16
resolvedBCOInstrs)
          bitmap_barr :: ByteArray#
bitmap_barr = ByteArray# -> ByteArray#
barr (BCOByteArray Word -> ByteArray#
forall a. BCOByteArray a -> ByteArray#
getBCOByteArray BCOByteArray Word
resolvedBCOBitmap)
          literals_barr :: ByteArray#
literals_barr = ByteArray# -> ByteArray#
barr (BCOByteArray Word -> ByteArray#
forall a. BCOByteArray a -> ByteArray#
getBCOByteArray BCOByteArray Word
resolvedBCOLits)

      PtrsArr marr <- Array Int HValue
-> UnlConsArr -> SmallArray ResolvedBCOPtr -> IO PtrsArr
mkPtrsArray Array Int HValue
arr UnlConsArr
unl_arr SmallArray ResolvedBCOPtr
resolvedBCOPtrs
      IO $ \State# RealWorld
s ->
        case MutableArray# RealWorld HValue
-> State# RealWorld -> (# State# RealWorld, Array# HValue #)
forall d a.
MutableArray# d a -> State# d -> (# State# d, Array# a #)
unsafeFreezeArray# MutableArray# RealWorld HValue
marr State# RealWorld
s of { (# State# RealWorld
s, Array# HValue
arr #) ->
        case ByteArray#
-> ByteArray#
-> Array# HValue
-> Int#
-> ByteArray#
-> State# RealWorld
-> (# State# RealWorld, BCO #)
forall a d.
ByteArray#
-> ByteArray#
-> Array# a
-> Int#
-> ByteArray#
-> State# d
-> (# State# d, BCO #)
newBCO# ByteArray#
insns_barr ByteArray#
literals_barr Array# HValue
arr Int#
arity# ByteArray#
bitmap_barr State# RealWorld
s of { (# State# RealWorld
s, BCO
bco #) ->
          (# State# RealWorld
s, Int -> BCO -> LinkedBCO
LinkedBCO Int
resolvedBCOArity BCO
bco #)
        }}
    ResolvedStaticCon{Bool
Word
SmallArray ResolvedBCOPtr
RemotePtr StgInfoTable
BCOByteArray Word
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedStaticConIsUnlifted :: ResolvedBCO -> Bool
resolvedStaticConPtrs :: ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedStaticConLits :: ResolvedBCO -> BCOByteArray Word
resolvedStaticConArity :: ResolvedBCO -> Word
resolvedStaticConInfoPtr :: ResolvedBCO -> RemotePtr StgInfoTable
resolvedBCOIsLE :: Bool
resolvedStaticConInfoPtr :: RemotePtr StgInfoTable
resolvedStaticConArity :: Word
resolvedStaticConLits :: BCOByteArray Word
resolvedStaticConPtrs :: SmallArray ResolvedBCOPtr
resolvedStaticConIsUnlifted :: Bool
..} -> do

      let
        !(W# Word#
data_size#) = Word
resolvedStaticConArity

        literals_barr :: ByteArray#
literals_barr = ByteArray# -> ByteArray#
barr (BCOByteArray Word -> ByteArray#
forall a. BCOByteArray a -> ByteArray#
getBCOByteArray BCOByteArray Word
resolvedStaticConLits)

        !(Ptr Addr#
itbl_ptr#) = RemotePtr StgInfoTable -> Ptr StgInfoTable
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr StgInfoTable
resolvedStaticConInfoPtr

      PtrsArr marr <- Array Int HValue
-> UnlConsArr -> SmallArray ResolvedBCOPtr -> IO PtrsArr
mkPtrsArray Array Int HValue
arr UnlConsArr
unl_arr SmallArray ResolvedBCOPtr
resolvedStaticConPtrs

      IO $ \State# RealWorld
s ->
        case MutableArray# RealWorld HValue
-> State# RealWorld -> (# State# RealWorld, Array# HValue #)
forall d a.
MutableArray# d a -> State# d -> (# State# d, Array# a #)
unsafeFreezeArray# MutableArray# RealWorld HValue
marr State# RealWorld
s of { (# State# RealWorld
s, Array# HValue
arr #) ->
        case Addr#
-> ByteArray#
-> Array# HValue
-> Word#
-> State# RealWorld
-> (# State# RealWorld, Any #)
forall a d b.
Addr#
-> ByteArray# -> Array# a -> Word# -> State# d -> (# State# d, b #)
newConAppObj# Addr#
itbl_ptr# ByteArray#
literals_barr Array# HValue
arr Word#
data_size# State# RealWorld
s of
          (# State# RealWorld
s, Any
hval #) ->
            if Bool
resolvedStaticConIsUnlifted then
              (# State# RealWorld
s, UnliftedHValue -> LinkedBCO
LinkedUnliftedStaticCon (Any -> UnliftedHValue
UnliftedHValue (Any -> Any
forall a b. a -> b
unsafeCoerce# Any
hval)) #)
            else
              (# State# RealWorld
s, HValue -> LinkedBCO
LinkedStaticCon (Any -> HValue
HValue Any
hval) #)
        }
  where
    !(EmptyArr ByteArray#
empty#) = EmptyArr
emptyArr -- See Note [BCO empty array]
    barr :: ByteArray# -> ByteArray#
barr ByteArray#
arr# = if Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
arr#) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ByteArray#
empty# else ByteArray#
arr#

-- we recursively link any sub-BCOs while making the ptrs array
mkPtrsArray :: Array Int HValue -> UnlConsArr -> SmallArray ResolvedBCOPtr -> IO PtrsArr
mkPtrsArray :: Array Int HValue
-> UnlConsArr -> SmallArray ResolvedBCOPtr -> IO PtrsArr
mkPtrsArray Array Int HValue
arr UnlConsArr
unl_arr SmallArray ResolvedBCOPtr
ptrs = do
  let n_ptrs :: Int
n_ptrs = SmallArray ResolvedBCOPtr -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray ResolvedBCOPtr
ptrs
  marr <- Int -> IO PtrsArr
newPtrsArray Int
n_ptrs
  let
    fill Int
i (ResolvedBCORef Int
n) =
      Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue Int
i (Array Int HValue
arr Array Int HValue -> Int -> HValue
forall i e. Ix i => Array i e -> i -> e
! Int
n) PtrsArr
marr  -- must be lazy!
    fill Int
i (ResolvedStaticConRef Int
n) = do
      Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue Int
i (Array Int HValue
arr Array Int HValue -> Int -> HValue
forall i e. Ix i => Array i e -> i -> e
! Int
n) PtrsArr
marr  -- must be lazy!
    fill Int
i (ResolvedUnliftedStaticConRef Int
n) = do
      -- must be strict! we want to store the unlifted con,
      -- not the arr indexing thunk.
      !unl_val <- Int -> UnlConsArr -> IO HValue
readUnlConsArr Int
n UnlConsArr
unl_arr
      writePtrsArrayHValue i unl_val marr
    fill Int
i (ResolvedBCOPtr HValueRef
r) = do
      hv <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
      writePtrsArrayHValue i hv marr
    fill Int
i (ResolvedBCOStaticPtr RemotePtr ()
r) = do
      Int -> Ptr () -> PtrsArr -> IO ()
forall a. Int -> Ptr a -> PtrsArr -> IO ()
writePtrsArrayPtr Int
i (RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
r)  PtrsArr
marr
    fill Int
i (ResolvedBCOPtrBCO ResolvedBCO
bco) = do
      obj <- Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO
linkBCO' Array Int HValue
arr UnlConsArr
unl_arr ResolvedBCO
bco
      case obj of
        LinkedBCO Int
_ BCO
bco ->
          Int -> BCO -> PtrsArr -> IO ()
writePtrsArrayBCO Int
i BCO
bco PtrsArr
marr
        LinkedStaticCon HValue
linked_static_con ->
          Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue Int
i HValue
linked_static_con PtrsArr
marr
        LinkedUnliftedStaticCon UnliftedHValue
linked_static_con -> do
          let !unl_val :: HValue
unl_val = UnliftedHValue -> HValue
forgetUnliftedHValue UnliftedHValue
linked_static_con
          Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue Int
i HValue
unl_val PtrsArr
marr
    fill Int
i (ResolvedBCOPtrBreakArray RemoteRef BreakArray
r) = do
      BA mba <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
r
      writePtrsArrayMBA i mba marr
  imapSmallArrayM_ fill ptrs
  return marr

--------------------------------------------------------------------------------
-- * Unlifted static constructors
--------------------------------------------------------------------------------

-- | A heap closure of unlifted type
type UnliftedHValue :: UnliftedType
newtype UnliftedHValue = UnliftedHValue (Any @UnliftedType)

-- | Forget that a heap closure is unlifted, and return it as a lifted heap closure.
-- Note: Going the other way around for an arbitrary heap closure is totally unsafe!
forgetUnliftedHValue :: UnliftedHValue -> HValue
forgetUnliftedHValue :: UnliftedHValue -> HValue
forgetUnliftedHValue (UnliftedHValue Any
a) = Any -> HValue
HValue (Any -> Any
forall a b. a -> b
unsafeCoerce# Any
a)

-- | A lifted array with unlifted static constructor 'UnliftedHValue's
data UnlConsArr = UnlConsArr (MutableArray# RealWorld UnliftedHValue)

-- | Create a 'UnlConsArr' of the given size with all elements initialized to
-- an empty ByteArray#
newUnlConsArr :: Int -> IO UnlConsArr
newUnlConsArr :: Int -> IO UnlConsArr
newUnlConsArr (I# Int#
arr_size#) = (State# RealWorld -> (# State# RealWorld, UnlConsArr #))
-> IO UnlConsArr
(State# RealWorld -> (# State# RealWorld, UnlConsArr #))
-> IO UnlConsArr
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, UnlConsArr #))
 -> IO UnlConsArr)
-> (State# RealWorld -> (# State# RealWorld, UnlConsArr #))
-> IO UnlConsArr
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  -- Zero value to initialize the array.
  -- Would be better to use undefined but can't for unlifted values.
  let !(EmptyArr ByteArray#
emp_arr#) = EmptyArr
emptyArr
  in case Int#
-> UnliftedHValue
-> State# RealWorld
-> (# State# RealWorld, MutableArray# RealWorld UnliftedHValue #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
arr_size# (Any -> UnliftedHValue
UnliftedHValue (ByteArray# -> Any
forall (a :: UnliftedType) (b :: UnliftedType). a -> b
unsafeCoerceUnlifted ByteArray#
emp_arr#)) State# RealWorld
s of
      (# State# RealWorld
s, MutableArray# RealWorld UnliftedHValue
arr #) -> (# State# RealWorld
s, MutableArray# RealWorld UnliftedHValue -> UnlConsArr
UnlConsArr MutableArray# RealWorld UnliftedHValue
arr #)

-- | Write an unlifted contructor closure into a 'UnlConsArr'
writeUnlConsArr :: Int -> UnliftedHValue -> UnlConsArr -> IO ()
writeUnlConsArr :: Int -> UnliftedHValue -> UnlConsArr -> IO ()
writeUnlConsArr (I# Int#
i#) UnliftedHValue
unl_hval (UnlConsArr MutableArray# RealWorld UnliftedHValue
unl_arr#) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
(State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case MutableArray# RealWorld UnliftedHValue
-> Int# -> UnliftedHValue -> State# RealWorld -> State# RealWorld
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# RealWorld UnliftedHValue
unl_arr# Int#
i# UnliftedHValue
unl_hval State# RealWorld
s of
    State# RealWorld
s -> (# State# RealWorld
s, () #)

-- | Read an unlifted constructor closure from an 'UnlConsArr',
-- but forget that the heap closure is unlifted using 'forgetUnliftedHValue'.
-- This allows us to return it in @IO@ and return it in the final resolved objs list.
readUnlConsArr :: Int -> UnlConsArr -> IO HValue
readUnlConsArr :: Int -> UnlConsArr -> IO HValue
readUnlConsArr (I# Int#
n#) (UnlConsArr MutableArray# RealWorld UnliftedHValue
unl_arr#) = (State# RealWorld -> (# State# RealWorld, HValue #)) -> IO HValue
(State# RealWorld -> (# State# RealWorld, HValue #)) -> IO HValue
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, HValue #)) -> IO HValue)
-> (State# RealWorld -> (# State# RealWorld, HValue #))
-> IO HValue
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case MutableArray# RealWorld UnliftedHValue
-> Int#
-> State# RealWorld
-> (# State# RealWorld, UnliftedHValue #)
forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld UnliftedHValue
unl_arr# Int#
n# State# RealWorld
s of
    (# State# RealWorld
s, UnliftedHValue
val #) -> (# State# RealWorld
s, UnliftedHValue -> HValue
forgetUnliftedHValue UnliftedHValue
val #)

--------------------------------------------------------------------------------
-- * PtrsArr
--------------------------------------------------------------------------------

data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)

newPtrsArray :: Int -> IO PtrsArr
newPtrsArray :: Int -> IO PtrsArr
newPtrsArray (I# Int#
i) = (State# RealWorld -> (# State# RealWorld, PtrsArr #)) -> IO PtrsArr
(State# RealWorld -> (# State# RealWorld, PtrsArr #)) -> IO PtrsArr
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, PtrsArr #))
 -> IO PtrsArr)
-> (State# RealWorld -> (# State# RealWorld, PtrsArr #))
-> IO PtrsArr
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case Int#
-> HValue
-> State# RealWorld
-> (# State# RealWorld, MutableArray# RealWorld HValue #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
i HValue
forall a. HasCallStack => a
undefined State# RealWorld
s of (# State# RealWorld
s', MutableArray# RealWorld HValue
arr #) -> (# State# RealWorld
s', MutableArray# RealWorld HValue -> PtrsArr
PtrsArr MutableArray# RealWorld HValue
arr #)

writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue (I# Int#
i) HValue
hv (PtrsArr MutableArray# RealWorld HValue
arr) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
(State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case MutableArray# RealWorld HValue
-> Int# -> HValue -> State# RealWorld -> State# RealWorld
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# RealWorld HValue
arr Int#
i HValue
hv State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
writePtrsArrayPtr :: forall a. Int -> Ptr a -> PtrsArr -> IO ()
writePtrsArrayPtr (I# Int#
i) (Ptr Addr#
a#) (PtrsArr MutableArray# RealWorld HValue
arr) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
(State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case MutableArray# RealWorld HValue
-> Int# -> Addr# -> State# RealWorld -> State# RealWorld
forall s a.
MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
writeArrayAddr# MutableArray# RealWorld HValue
arr Int#
i Addr#
a# State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

-- This is rather delicate: convincing GHC to pass an Addr# as an Any but
-- without making a thunk turns out to be surprisingly tricky.
{-# NOINLINE writeArrayAddr# #-}
writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
#if defined(javascript_HOST_ARCH)
-- Addr# isn't coercible with Any with the JS backend.
writeArrayAddr# = error "writeArrayAddr#: currently unsupported with the JS backend"
#else
writeArrayAddr# :: forall s a.
MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
writeArrayAddr# MutableArray# s a
marr Int#
i Addr#
addr State# s
s = (MutableArray# d_4 a_5 -> Int# -> a_5 -> State# d_4 -> State# d_4)
-> MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
forall a b. a -> b
unsafeCoerce# MutableArray# d_4 a_5 -> Int# -> a_5 -> State# d_4 -> State# d_4
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# s a
marr Int#
i Addr#
addr State# s
s
#endif

writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
writePtrsArrayBCO (I# Int#
i) BCO
bco (PtrsArr MutableArray# RealWorld HValue
arr) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
(State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case ((MutableArray# d_2 a_3 -> Int# -> a_3 -> State# d_2 -> State# d_2)
-> MutableArray# RealWorld HValue
-> Int#
-> BCO
-> State# RealWorld
-> State# RealWorld
forall a b. a -> b
unsafeCoerce# MutableArray# d_2 a_3 -> Int# -> a_3 -> State# d_2 -> State# d_2
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray#) MutableArray# RealWorld HValue
arr Int#
i BCO
bco State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA :: forall s. Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA (I# Int#
i) MutableByteArray# s
mba (PtrsArr MutableArray# RealWorld HValue
arr) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
(State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case ((MutableArray# d_0 a_1 -> Int# -> a_1 -> State# d_0 -> State# d_0)
-> MutableArray# RealWorld HValue
-> Int#
-> MutableByteArray# s
-> State# RealWorld
-> State# RealWorld
forall a b. a -> b
unsafeCoerce# MutableArray# d_0 a_1 -> Int# -> a_1 -> State# d_0 -> State# d_0
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray#) MutableArray# RealWorld HValue
arr Int#
i MutableByteArray# s
mba State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

--------------------------------------------------------------------------------
-- * Empty array
--------------------------------------------------------------------------------
{- 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.
-}

data EmptyArr = EmptyArr ByteArray#

{-# NOINLINE emptyArr #-}
emptyArr :: EmptyArr
emptyArr :: EmptyArr
emptyArr = IO EmptyArr -> EmptyArr
forall a. IO a -> a
unsafeDupablePerformIO (IO EmptyArr -> EmptyArr) -> IO EmptyArr -> EmptyArr
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, EmptyArr #))
-> IO EmptyArr
(State# RealWorld -> (# State# RealWorld, EmptyArr #))
-> IO EmptyArr
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, EmptyArr #))
 -> IO EmptyArr)
-> (State# RealWorld -> (# State# RealWorld, EmptyArr #))
-> IO EmptyArr
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
0# State# RealWorld
s of { (# State# RealWorld
s, MutableByteArray# RealWorld
arr #) ->
  case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
arr State# RealWorld
s of { (# State# RealWorld
s, ByteArray#
farr #) ->
  (# State# RealWorld
s, ByteArray# -> EmptyArr
EmptyArr ByteArray#
farr #)
  }}