module GHC.Exts.Heap.Closures (
Closure
, GenClosure(..)
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
, TsoFlags(..)
, allClosures
, closureSize
, Box(..)
, areBoxesEqual
, asBox
) where
import Prelude
import GHC.Exts.Heap.Constants
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
import GHC.Exts.Heap.InfoTableProf ()
#endif
import GHC.Exts.Heap.ProfInfo.Types
import Data.Bits
import Data.Int
import Data.Word
import GHC.Exts
import GHC.Generics
import Numeric
foreign import prim "aToWordzh" aToWord# :: Any -> Word#
foreign import prim "reallyUnsafePtrEqualityUpToTag"
reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
data Box = Box Any
instance Show Box where
showsPrec _ (Box a) rs =
pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
where
ptr = W# (aToWord# a)
tag = ptr .&. fromIntegral tAG_MASK
addr = ptr tag
pad_out ls = '0':'x':ls
asBox :: a -> Box
asBox x = Box (unsafeCoerce# x)
areBoxesEqual :: Box -> Box -> IO Bool
areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
0# -> pure False
_ -> pure True
type Closure = GenClosure Box
data GenClosure b
=
ConstrClosure
{ info :: !StgInfoTable
, ptrArgs :: ![b]
, dataArgs :: ![Word]
, pkg :: !String
, modl :: !String
, name :: !String
}
| FunClosure
{ info :: !StgInfoTable
, ptrArgs :: ![b]
, dataArgs :: ![Word]
}
| ThunkClosure
{ info :: !StgInfoTable
, ptrArgs :: ![b]
, dataArgs :: ![Word]
}
| SelectorClosure
{ info :: !StgInfoTable
, selectee :: !b
}
| PAPClosure
{ info :: !StgInfoTable
, arity :: !HalfWord
, n_args :: !HalfWord
, fun :: !b
, payload :: ![b]
}
| APClosure
{ info :: !StgInfoTable
, arity :: !HalfWord
, n_args :: !HalfWord
, fun :: !b
, payload :: ![b]
}
| APStackClosure
{ info :: !StgInfoTable
, fun :: !b
, payload :: ![b]
}
| IndClosure
{ info :: !StgInfoTable
, indirectee :: !b
}
| BCOClosure
{ info :: !StgInfoTable
, instrs :: !b
, literals :: !b
, bcoptrs :: !b
, arity :: !HalfWord
, size :: !HalfWord
, bitmap :: ![Word]
}
| BlackholeClosure
{ info :: !StgInfoTable
, indirectee :: !b
}
| ArrWordsClosure
{ info :: !StgInfoTable
, bytes :: !Word
, arrWords :: ![Word]
}
| MutArrClosure
{ info :: !StgInfoTable
, mccPtrs :: !Word
, mccSize :: !Word
, mccPayload :: ![b]
}
| SmallMutArrClosure
{ info :: !StgInfoTable
, mccPtrs :: !Word
, mccPayload :: ![b]
}
| MVarClosure
{ info :: !StgInfoTable
, queueHead :: !b
, queueTail :: !b
, value :: !b
}
| IOPortClosure
{ info :: !StgInfoTable
, queueHead :: !b
, queueTail :: !b
, value :: !b
}
| MutVarClosure
{ info :: !StgInfoTable
, var :: !b
}
| BlockingQueueClosure
{ info :: !StgInfoTable
, link :: !b
, blackHole :: !b
, owner :: !b
, queue :: !b
}
| WeakClosure
{ info :: !StgInfoTable
, cfinalizers :: !b
, key :: !b
, value :: !b
, finalizer :: !b
, link :: !b
}
| TSOClosure
{ info :: !StgInfoTable
, link :: !b
, global_link :: !b
, tsoStack :: !b
, trec :: !b
, blocked_exceptions :: !b
, bq :: !b
, what_next :: !WhatNext
, why_blocked :: !WhyBlocked
, flags :: ![TsoFlags]
, threadId :: !Word64
, saved_errno :: !Word32
, tso_dirty :: !Word32
, alloc_limit :: !Int64
, tot_stack_size :: !Word32
, prof :: !(Maybe StgTSOProfInfo)
}
| StackClosure
{ info :: !StgInfoTable
, stack_size :: !Word32
, stack_dirty :: !Word8
#if __GLASGOW_HASKELL__ >= 811
, stack_marking :: !Word8
#endif
}
| IntClosure
{ ptipe :: PrimType
, intVal :: !Int }
| WordClosure
{ ptipe :: PrimType
, wordVal :: !Word }
| Int64Closure
{ ptipe :: PrimType
, int64Val :: !Int64 }
| Word64Closure
{ ptipe :: PrimType
, word64Val :: !Word64 }
| AddrClosure
{ ptipe :: PrimType
, addrVal :: !Int }
| FloatClosure
{ ptipe :: PrimType
, floatVal :: !Float }
| DoubleClosure
{ ptipe :: PrimType
, doubleVal :: !Double }
| 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, Ord)
data WhatNext
= ThreadRunGHC
| ThreadInterpret
| ThreadKilled
| ThreadComplete
| WhatNextUnknownValue Word16
deriving (Eq, Show, Generic, Ord)
data WhyBlocked
= NotBlocked
| BlockedOnMVar
| BlockedOnMVarRead
| BlockedOnBlackHole
| BlockedOnRead
| BlockedOnWrite
| BlockedOnDelay
| BlockedOnSTM
| BlockedOnDoProc
| BlockedOnCCall
| BlockedOnCCall_Interruptible
| BlockedOnMsgThrowTo
| ThreadMigrating
| BlockedOnIOCompletion
| WhyBlockedUnknownValue Word16
deriving (Eq, Show, Generic, Ord)
data TsoFlags
= TsoLocked
| TsoBlockx
| TsoInterruptible
| TsoStoppedOnBreakpoint
| TsoMarked
| TsoSqueezed
| TsoAllocLimit
| TsoFlagsUnknownValue Word32
deriving (Eq, Show, Generic, Ord)
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 (IOPortClosure {..}) = [queueHead,queueTail,value]
allClosures (FunClosure {..}) = ptrArgs
allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer, link]
allClosures (OtherClosure {..}) = hvalues
allClosures _ = []
closureSize :: Box -> Int
closureSize (Box x) = I# (closureSize# x)