GHC/Exts/Heap/Closures.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ForeignFunctionInterface #-}
    {-# LANGUAGE GHCForeignImportPrim #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE UnliftedFFITypes #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DeriveTraversable #-}

    module GHC.Exts.Heap.Closures (
        -- * Closures
          Closure
        , GenClosure(..)
        , PrimType(..)
        , allClosures
    #if __GLASGOW_HASKELL__ >= 809
        -- The closureSize# primop is unsupported on earlier GHC releases but we
        -- build ghc-heap as a boot library so it must be buildable. Drop this once
        -- we are guaranteed to bootstsrap with GHC >= 8.9.
        , closureSize
    #endif

        -- * Boxes
        , Box(..)
        , areBoxesEqual
        , asBox
        ) where

    import Prelude -- See note [Why do we import Prelude here?]
    import GHC.Exts.Heap.Constants
    #if defined(PROFILING)
    import GHC.Exts.Heap.InfoTableProf
    #else
    import GHC.Exts.Heap.InfoTable

    -- `ghc -M` currently doesn't properly account for ways when generating
    -- dependencies (#15197). This import ensures correct build-ordering between
    -- this module and GHC.Exts.Heap.InfoTableProf. It should be removed when #15197
    -- is fixed.
    import GHC.Exts.Heap.InfoTableProf ()
    #endif

    import Data.Bits
    import Data.Int
    import Data.Word
    import GHC.Exts
    import GHC.Generics
    import Numeric

    ------------------------------------------------------------------------
    -- Boxes

    foreign import prim "aToWordzh" aToWord# :: Any -> Word#

    foreign import prim "reallyUnsafePtrEqualityUpToTag"
        reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#

    -- | An arbitrary Haskell value in a safe Box. The point is that even
    -- unevaluated thunks can safely be moved around inside the Box, and when
    -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
    -- to evaluate the argument.
    data Box = Box Any

    instance Show Box where
    -- From libraries/base/GHC/Ptr.lhs
       showsPrec _ (Box a) rs =
        -- unsafePerformIO (print "↓" >> pClosure a) `seq`
        pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
         where
           ptr  = W# (aToWord# a)
           tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
           addr = ptr - tag
           pad_out ls = '0':'x':ls

    -- |This takes an arbitrary value and puts it into a box.
    -- Note that calls like
    --
    -- > asBox (head list)
    --
    -- will put the thunk \"head list\" into the box, /not/ the element at the head
    -- of the list. For that, use careful case expressions:
    --
    -- > case list of x:_ -> asBox x
    asBox :: a -> Box
    asBox x = Box (unsafeCoerce# x)

    -- | Boxes can be compared, but this is not pure, as different heap objects can,
    -- after garbage collection, become the same object.
    areBoxesEqual :: Box -> Box -> IO Bool
    areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
        0# -> pure False
        _  -> pure True

    ------------------------------------------------------------------------
    -- Closures

    type Closure = GenClosure Box

    -- | This is the representation of a Haskell value on the heap. It reflects
    -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h>
    --
    -- The data type is parametrized by the type to store references in. Usually
    -- this is a 'Box' with the type synonym 'Closure'.
    --
    -- All Heap objects have the same basic layout. A header containing a pointer
    -- to the info table and a payload with various fields. The @info@ field below
    -- always refers to the info table pointed to by the header. The remaining
    -- fields are the payload.
    --
    -- See
    -- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>
    -- for more information.
    data GenClosure b
      = -- | A data constructor
        ConstrClosure
            { info       :: !StgInfoTable
            , ptrArgs    :: ![b]            -- ^ Pointer arguments
            , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
            , pkg        :: !String         -- ^ Package name
            , modl       :: !String         -- ^ Module name
            , name       :: !String         -- ^ Constructor name
            }

        -- | A function
      | FunClosure
            { info       :: !StgInfoTable
            , ptrArgs    :: ![b]            -- ^ Pointer arguments
            , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
            }

        -- | A thunk, an expression not obviously in head normal form
      | ThunkClosure
            { info       :: !StgInfoTable
            , ptrArgs    :: ![b]            -- ^ Pointer arguments
            , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
            }

        -- | A thunk which performs a simple selection operation
      | SelectorClosure
            { info       :: !StgInfoTable
            , selectee   :: !b              -- ^ Pointer to the object being
                                            --   selected from
            }

        -- | An unsaturated function application
      | PAPClosure
            { info       :: !StgInfoTable
            , arity      :: !HalfWord       -- ^ Arity of the partial application
            , n_args     :: !HalfWord       -- ^ Size of the payload in words
            , fun        :: !b              -- ^ Pointer to a 'FunClosure'
            , payload    :: ![b]            -- ^ Sequence of already applied
                                            --   arguments
            }

        -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported
        -- functions fun actually find the name here.
        -- At least the other direction works via "lookupSymbol
        -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
        -- | A function application
      | APClosure
            { info       :: !StgInfoTable
            , arity      :: !HalfWord       -- ^ Always 0
            , n_args     :: !HalfWord       -- ^ Size of payload in words
            , fun        :: !b              -- ^ Pointer to a 'FunClosure'
            , payload    :: ![b]            -- ^ Sequence of already applied
                                            --   arguments
            }

        -- | A suspended thunk evaluation
      | APStackClosure
            { info       :: !StgInfoTable
            , fun        :: !b              -- ^ Function closure
            , payload    :: ![b]            -- ^ Stack right before suspension
            }

        -- | A pointer to another closure, introduced when a thunk is updated
        -- to point at its value
      | IndClosure
            { info       :: !StgInfoTable
            , indirectee :: !b              -- ^ Target closure
            }

       -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code
       -- interpreter (e.g. as used by GHCi)
      | BCOClosure
            { info       :: !StgInfoTable
            , instrs     :: !b              -- ^ A pointer to an ArrWords
                                            --   of instructions
            , literals   :: !b              -- ^ A pointer to an ArrWords
                                            --   of literals
            , bcoptrs    :: !b              -- ^ A pointer to an ArrWords
                                            --   of byte code objects
            , arity      :: !HalfWord       -- ^ The arity of this BCO
            , size       :: !HalfWord       -- ^ The size of this BCO in words
            , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the
                                            --   pointerhood of its args/free vars
            }

        -- | A thunk under evaluation by another thread
      | BlackholeClosure
            { info       :: !StgInfoTable
            , indirectee :: !b              -- ^ The target closure
            }

        -- | A @ByteArray#@
      | ArrWordsClosure
            { info       :: !StgInfoTable
            , bytes      :: !Word           -- ^ Size of array in bytes
            , arrWords   :: ![Word]         -- ^ Array payload
            }

        -- | A @MutableByteArray#@
      | MutArrClosure
            { info       :: !StgInfoTable
            , mccPtrs    :: !Word           -- ^ Number of pointers
            , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h
            , mccPayload :: ![b]            -- ^ Array payload
            -- Card table ignored
            }

        -- | A @SmallMutableArray#@
        --
        -- @since 8.10.1
      | SmallMutArrClosure
            { info       :: !StgInfoTable
            , mccPtrs    :: !Word           -- ^ Number of pointers
            , mccPayload :: ![b]            -- ^ Array payload
            }

        -- | An @MVar#@, with a queue of thread state objects blocking on them
      | MVarClosure
            { info       :: !StgInfoTable
            , queueHead  :: !b              -- ^ Pointer to head of queue
            , queueTail  :: !b              -- ^ Pointer to tail of queue
            , value      :: !b              -- ^ Pointer to closure
            }

        -- | A @MutVar#@
      | MutVarClosure
            { info       :: !StgInfoTable
            , var        :: !b              -- ^ Pointer to contents
            }

        -- | An STM blocking queue.
      | BlockingQueueClosure
            { info       :: !StgInfoTable
            , link       :: !b              -- ^ ?? Here so it looks like an IND
            , blackHole  :: !b              -- ^ The blackhole closure
            , owner      :: !b              -- ^ The owning thread state object
            , queue      :: !b              -- ^ ??
            }

      | WeakClosure
            { info        :: !StgInfoTable
            , cfinalizers :: !b
            , key         :: !b
            , value       :: !b
            , finalizer   :: !b
            , link        :: !b -- ^ next weak pointer for the capability, can be NULL.
            }

        ------------------------------------------------------------
        -- Unboxed unlifted closures

        -- | Primitive Int
      | IntClosure
            { ptipe      :: PrimType
            , intVal     :: !Int }

        -- | Primitive Word
      | WordClosure
            { ptipe      :: PrimType
            , wordVal    :: !Word }

        -- | Primitive Int64
      | Int64Closure
            { ptipe      :: PrimType
            , int64Val   :: !Int64 }

        -- | Primitive Word64
      | Word64Closure
            { ptipe      :: PrimType
            , word64Val  :: !Word64 }

        -- | Primitive Addr
      | AddrClosure
            { ptipe      :: PrimType
            , addrVal    :: !Int }

        -- | Primitive Float
      | FloatClosure
            { ptipe      :: PrimType
            , floatVal   :: !Float }

        -- | Primitive Double
      | DoubleClosure
            { ptipe      :: PrimType
            , doubleVal  :: !Double }

        -----------------------------------------------------------
        -- Anything else

        -- | Another kind of closure
      | OtherClosure
            { info       :: !StgInfoTable
            , hvalues    :: ![b]
            , rawWords   :: ![Word]
            }

      | UnsupportedClosure
            { info       :: !StgInfoTable
            }
      deriving (Show, Generic, Functor, Foldable, Traversable)

    data PrimType
      = PInt
      | PWord
      | PInt64
      | PWord64
      | PAddr
      | PFloat
      | PDouble
      deriving (Eq, Show, Generic)

    -- | For generic code, this function returns all referenced closures.
    allClosures :: GenClosure b -> [b]
    allClosures (ConstrClosure {..}) = ptrArgs
    allClosures (ThunkClosure {..}) = ptrArgs
    allClosures (SelectorClosure {..}) = [selectee]
    allClosures (IndClosure {..}) = [indirectee]
    allClosures (BlackholeClosure {..}) = [indirectee]
    allClosures (APClosure {..}) = fun:payload
    allClosures (PAPClosure {..}) = fun:payload
    allClosures (APStackClosure {..}) = fun:payload
    allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]
    allClosures (ArrWordsClosure {}) = []
    allClosures (MutArrClosure {..}) = mccPayload
    allClosures (SmallMutArrClosure {..}) = mccPayload
    allClosures (MutVarClosure {..}) = [var]
    allClosures (MVarClosure {..}) = [queueHead,queueTail,value]
    allClosures (FunClosure {..}) = ptrArgs
    allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
    allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer, link]
    allClosures (OtherClosure {..}) = hvalues
    allClosures _ = []

    #if __GLASGOW_HASKELL__ >= 809
    -- | Get the size of a closure in words.
    --
    -- @since 8.10.1
    closureSize :: Box -> Int
    closureSize (Box x) = I# (closureSize# x)
    #endif