diff options
| author | Patrick Dougherty <patrick.doc@ameritech.net> | 2018-05-16 16:50:13 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-05-20 11:41:04 -0400 |
| commit | ec22f7ddc81b40a9dbcf140e5cf44730cb776d00 (patch) | |
| tree | ff014a39b87f4d0069cfa4eed28afaf124e552b8 | |
| parent | 12deb9a97c05ad462ef04e8d2062c3d11c52c6ff (diff) | |
| download | haskell-ec22f7ddc81b40a9dbcf140e5cf44730cb776d00.tar.gz | |
Add HeapView functionality
This pulls parts of Joachim Breitner's ghc-heap-view library inside GHC.
The bits added are the C hooks into the RTS and a basic Haskell wrapper
to these C hooks. The main reason for these to be added to GHC proper
is that the code needs to be kept in sync with the closure types
defined by the RTS. It is expected that the version of HeapView shipped
with GHC will always work with that version of GHC and that extra
functionality can be layered on top with a library like ghc-heap-view
distributed via Hackage.
Test Plan: validate
Reviewers: simonmar, hvr, nomeata, austin, Phyx, bgamari, erikd
Reviewed By: bgamari
Subscribers: carter, patrickdoc, tmcgilchrist, rwbarton, thomie
Differential Revision: https://phabricator.haskell.org/D3055
35 files changed, 1948 insertions, 483 deletions
diff --git a/.gitignore b/.gitignore index 631d12f8fc..44ee794abc 100644 --- a/.gitignore +++ b/.gitignore @@ -145,6 +145,7 @@ _darcs/ /libraries/ghc-boot-th/GNUmakefile /libraries/ghc-boot-th/ghc-boot-th.cabal /libraries/ghc-boot-th/ghc.mk +/libraries/ghc-heap/ghc-heap.cabal /libraries/ghci/GNUmakefile /libraries/ghci/ghci.cabal /libraries/ghci/ghc.mk diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index d2137f4c69..9b96fc5a83 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -64,6 +64,7 @@ Library transformers == 0.5.*, ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, + ghc-heap == @ProjectVersionMunged@, ghci == @ProjectVersionMunged@ if os(windows) @@ -643,5 +644,4 @@ Library Debugger Linker RtClosureInspect - DebuggerUtils GHCi diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs index bea431185c..e7eb7108f9 100644 --- a/compiler/ghci/ByteCodeLink.hs +++ b/compiler/ghci/ByteCodeLink.hs @@ -23,7 +23,6 @@ import GhcPrelude import GHCi.RemoteTypes import GHCi.ResolvedBCO -import GHCi.InfoTable import GHCi.BreakArray import SizedSeq @@ -99,7 +98,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ()) lookupIE hsc_env ie con_nm = case lookupNameEnv ie con_nm of - Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a))) + Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" m <- lookupSymbol hsc_env sym_to_find1 diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs index ecb9d2212f..628b576ca0 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -27,7 +27,6 @@ import SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes import GHCi.FFI -import GHCi.InfoTable import Control.DeepSeq import Foreign @@ -36,6 +35,7 @@ import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import GHC.Exts.Heap import GHC.Stack.CCS -- ----------------------------------------------------------------------------- diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs deleted file mode 100644 index 9af98c1bcf..0000000000 --- a/compiler/ghci/DebuggerUtils.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE CPP #-} - -module DebuggerUtils ( - dataConInfoPtrToName, - ) where - -import GhcPrelude - -import GHCi.InfoTable -import CmmInfo ( stdInfoTableSizeB ) -import DynFlags -import HscTypes -import FastString -import IfaceEnv -import Module -import OccName -import Name -import Outputable -import Util - -import Data.Char -import Foreign -import Data.List - -#include "HsVersions.h" - --- | Given a data constructor in the heap, find its Name. --- The info tables for data constructors have a field which records --- the source name of the constructor as a Ptr Word8 (UTF-8 encoded --- string). The format is: --- --- > Package:Module.Name --- --- We use this string to lookup the interpreter's internal representation of the name --- using the lookupOrig. --- -dataConInfoPtrToName :: HscEnv -> Ptr () -> IO Name -dataConInfoPtrToName hsc_env x = do - let dflags = hsc_dflags hsc_env - theString <- do - let ptr = castPtr x :: Ptr StgInfoTable - conDescAddress <- getConDescAddress dflags ptr - peekArray0 0 conDescAddress - let (pkg, mod, occ) = parse theString - pkgFS = mkFastStringByteList pkg - modFS = mkFastStringByteList mod - occFS = mkFastStringByteList occ - occName = mkOccNameFS OccName.dataName occFS - modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS) - lookupOrigIO hsc_env modName occName - - where - - {- To find the string in the constructor's info table we need to consider - the layout of info tables relative to the entry code for a closure. - - An info table can be next to the entry code for the closure, or it can - be separate. The former (faster) is used in registerised versions of ghc, - and the latter (portable) is for non-registerised versions. - - The diagrams below show where the string is to be found relative to - the normal info table of the closure. - - 1) Code next to table: - - -------------- - | | <- pointer to the start of the string - -------------- - | | <- the (start of the) info table structure - | | - | | - -------------- - | entry code | - | .... | - - In this case the pointer to the start of the string can be found in - the memory location _one word before_ the first entry in the normal info - table. - - 2) Code NOT next to table: - - -------------- - info table structure -> | *------------------> -------------- - | | | entry code | - | | | .... | - -------------- - ptr to start of str -> | | - -------------- - - In this case the pointer to the start of the string can be found - in the memory location: info_table_ptr + info_table_size - -} - - getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress dflags ptr - | ghciTablesNextToCode = do - let ptr' = ptr `plusPtr` (- wORD_SIZE dflags) - -- NB. the offset must be read as an Int32 not a Word32, so - -- that the sign is preserved when converting to an Int. - offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32) - return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString - | otherwise = - peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) - -- parsing names is a little bit fiddly because we have a string in the form: - -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). - -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. - -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas - -- this is not the conventional way of writing Haskell names. We stick with - -- convention, even though it makes the parsing code more troublesome. - -- Warning: this code assumes that the string is well formed. - parse :: [Word8] -> ([Word8], [Word8], [Word8]) - parse input - = ASSERT(all (`lengthExceeds` 0) ([pkg, mod, occ])) (pkg, mod, occ) - where - dot = fromIntegral (ord '.') - (pkg, rest1) = break (== fromIntegral (ord ':')) input - (mod, occ) - = (concat $ intersperse [dot] $ reverse modWords, occWord) - where - (modWords, occWord) = ASSERT(rest1 `lengthExceeds` 0) (parseModOcc [] (tail rest1)) - parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) - -- We only look for dots if str could start with a module name, - -- i.e. if it starts with an upper case character. - -- Otherwise we might think that "X.:->" is the module name in - -- "X.:->.+", whereas actually "X" is the module name and - -- ":->.+" is a constructor name. - parseModOcc acc str@(c : _) - | isUpper $ chr $ fromIntegral c - = case break (== dot) str of - (top, []) -> (acc, top) - (top, _ : bot) -> parseModOcc (top : acc) bot - parseModOcc acc str = (acc, str) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index d7e1267d97..025efe8cb2 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -21,17 +21,14 @@ module RtClosureInspect( -- unsafeDeepSeq, - Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection + constrClosToName, isConstr, isIndirection ) where #include "HsVersions.h" import GhcPrelude -import DebuggerUtils -import GHCi.RemoteTypes ( HValue ) -import qualified GHCi.InfoTable as InfoTable -import GHCi.InfoTable (StgInfoTable, peekItbl) +import GHCi.RemoteTypes import HscTypes import DataCon @@ -48,6 +45,9 @@ import TcEnv import TyCon import Name +import OccName +import Module +import IfaceEnv import Util import VarSet import BasicTypes ( Boxity(..) ) @@ -56,16 +56,14 @@ import PrelNames import TysWiredIn import DynFlags import Outputable as Ppr -import GHC.Arr ( Array(..) ) import GHC.Char import GHC.Exts +import GHC.Exts.Heap import GHC.IO ( IO(..) ) import SMRep ( roundUpTo ) import Control.Monad import Data.Maybe -import Data.Array.Base -import Data.Ix import Data.List import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..)) @@ -86,7 +84,7 @@ data Term = Term { ty :: RttiType , subTerms :: [Term] } | Prim { ty :: RttiType - , value :: [Word] } + , valRaw :: [Word] } | Suspension { ctype :: ClosureType , ty :: RttiType @@ -114,7 +112,13 @@ isPrim _ = False isNewtypeWrap NewtypeWrap{} = True isNewtypeWrap _ = False -isFun Suspension{ctype=Fun} = True +isFun Suspension{ctype=FUN} = True +isFun Suspension{ctype=FUN_1_0} = True +isFun Suspension{ctype=FUN_0_1} = True +isFun Suspension{ctype=FUN_2_0} = True +isFun Suspension{ctype=FUN_1_1} = True +isFun Suspension{ctype=FUN_0_2} = True +isFun Suspension{ctype=FUN_STATIC} = True isFun _ = False isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty @@ -134,101 +138,30 @@ instance Outputable (Term) where ppr t | Just doc <- cPprTerm cPprTermBase t = doc | otherwise = panic "Outputable Term instance" -------------------------------------------------------------------------- --- Runtime Closure Datatype and functions for retrieving closure related stuff -------------------------------------------------------------------------- -data ClosureType = Constr - | Fun - | Thunk Int - | ThunkSelector - | Blackhole - | AP - | PAP - | Indirection Int - | MutVar Int - | MVar Int - | Other Int - deriving (Show, Eq) - -data ClosureNonPtrs = ClosureNonPtrs ByteArray# - -data Closure = Closure { tipe :: ClosureType - , infoPtr :: Ptr () - , infoTable :: StgInfoTable - , ptrs :: Array Int HValue - , nonPtrs :: ClosureNonPtrs - } +---------------------------------------- +-- Runtime Closure information functions +---------------------------------------- -instance Outputable ClosureType where - ppr = text . show - -#include "../includes/rts/storage/ClosureTypes.h" - -aP_CODE, pAP_CODE :: Int -aP_CODE = AP -pAP_CODE = PAP -#undef AP -#undef PAP - -getClosureData :: DynFlags -> a -> IO Closure -getClosureData dflags a = - case unpackClosure# a of - (# iptr, ptrs, nptrs #) -> do - let iptr0 = Ptr iptr - let iptr1 - | ghciTablesNextToCode = iptr0 - | otherwise = - -- the info pointer we get back from unpackClosure# - -- is to the beginning of the standard info table, - -- but the Storable instance for info tables takes - -- into account the extra entry pointer when - -- !ghciTablesNextToCode, so we must adjust here: - iptr0 `plusPtr` negate (wORD_SIZE dflags) - itbl <- peekItbl iptr1 - let tipe = readCType (InfoTable.tipe itbl) - elems = fromIntegral (InfoTable.ptrs itbl) - ptrsList = Array 0 (elems - 1) elems ptrs - nptrs_data = ClosureNonPtrs nptrs - ASSERT(elems >= 0) return () - ptrsList `seq` - return (Closure tipe iptr0 itbl ptrsList nptrs_data) - -readCType :: Integral a => a -> ClosureType -readCType i - | i >= CONSTR && i <= CONSTR_NOCAF = Constr - | i >= FUN && i <= FUN_STATIC = Fun - | i >= THUNK && i < THUNK_SELECTOR = Thunk i' - | i == THUNK_SELECTOR = ThunkSelector - | i == BLACKHOLE = Blackhole - | i >= IND && i <= IND_STATIC = Indirection i' - | i' == aP_CODE = AP - | i == AP_STACK = AP - | i' == pAP_CODE = PAP - | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i' - | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i' - | otherwise = Other i' - where i' = fromIntegral i - -isConstr, isIndirection, isThunk :: ClosureType -> Bool -isConstr Constr = True +isConstr, isIndirection, isThunk :: GenClosure a -> Bool +isConstr ConstrClosure{} = True isConstr _ = False -isIndirection (Indirection _) = True +isIndirection IndClosure{} = True isIndirection _ = False -isThunk (Thunk _) = True -isThunk ThunkSelector = True -isThunk AP = True +isThunk ThunkClosure{} = True +isThunk APClosure{} = True +isThunk APStackClosure{} = True isThunk _ = False -isFullyEvaluated :: DynFlags -> a -> IO Bool -isFullyEvaluated dflags a = do - closure <- getClosureData dflags a - case tipe closure of - Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure) - return$ and are_subs_evaluated - _ -> return False - where amapM f = sequence . amap' f +isFullyEvaluated :: a -> IO Bool +isFullyEvaluated a = do + closure <- getClosureData a + if isConstr closure + then do are_subs_evaluated <- amapM isFullyEvaluated (ptrArgs closure) + return$ and are_subs_evaluated + else return False + where amapM f = sequence . map (\(Box x) -> f x) -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it {- @@ -243,6 +176,15 @@ unsafeDeepSeq = unsafeDeepSeq1 2 where tipe = unsafePerformIO (getClosureType a) -} +-- Lookup the name in a constructor closure +constrClosToName :: HscEnv -> Closure -> IO (Either String Name) +constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do + let occName = mkOccName OccName.dataName occ + modName = mkModule (stringToUnitId pkg) (mkModuleName mod) + Right `fmap` lookupOrigIO hsc_env modName occName +constrClosToName _hsc_env clos = + return (Left ("conClosToName: Expected ConstrClosure, got " ++ show clos)) + ----------------------------------- -- * Traversals for Terms ----------------------------------- @@ -374,7 +316,7 @@ ppr_termM _ _ t = ppr_termM1 t ppr_termM1 :: Monad m => Term -> m SDoc -ppr_termM1 Prim{value=words, ty=ty} = +ppr_termM1 Prim{valRaw=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = return (char '_' <+> whenPprDebug (text "::" <> ppr ty)) @@ -696,8 +638,6 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do text "Type obtained: " <> ppr (termType term)) return term where - dflags = hsc_dflags hsc_env - go :: Int -> Type -> Type -> HValue -> TcM Term -- I believe that my_ty should not have any enclosing -- foralls, nor any free RuntimeUnk skolems; @@ -708,27 +648,30 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do go 0 my_ty _old_ty a = do traceTR (text "Gave up reconstructing a term after" <> int max_depth <> text " steps") - clos <- trIO $ getClosureData dflags a - return (Suspension (tipe clos) my_ty a Nothing) + clos <- trIO $ getClosureData a + return (Suspension (tipe (info clos)) my_ty a Nothing) go !max_depth my_ty old_ty a = do let monomorphic = not(isTyVarTy my_ty) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv - clos <- trIO $ getClosureData dflags a - case tipe clos of + clos <- trIO $ getClosureData a + case clos of -- Thunks we may want to force t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> seq a (go (pred max_depth) my_ty old_ty a) -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up -- showing '_' which is what we want. - Blackhole -> do traceTR (text "Following a BLACKHOLE") - appArr (go max_depth my_ty old_ty) (ptrs clos) 0 + BlackholeClosure{indirectee=ind} -> do + traceTR (text "Following a BLACKHOLE") + (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind -- We always follow indirections - Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) ) - go max_depth my_ty old_ty $! (ptrs clos ! 0) + IndClosure{indirectee=ind} -> do + traceTR (text "Following an indirection" ) + (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind -- We also follow references - MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + MutVarClosure{} + | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty -> do -- Deal with the MutVar# primitive -- It does not have a constructor at all, @@ -745,13 +688,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return (RefWrap my_ty x) -- The interesting case - Constr -> do + ConstrClosure{ptrArgs=pArgs} -> do traceTR (text "entering a constructor " <> if monomorphic then parens (text "already monomorphic: " <> ppr my_ty) else Ppr.empty) - dcname <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos) - (_,mb_dc) <- tryTc (tcLookupDataCon dcname) + Right dcname <- liftIO $ constrClosToName hsc_env clos + (_,mb_dc) <- tryTc (tcLookupDataCon dcname) case mb_dc of Nothing -> do -- This can happen for private constructors compiled -O0 -- where the .hi descriptor does not export them @@ -761,10 +704,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do traceTR (text "Not constructor" <+> ppr dcname) let dflags = hsc_dflags hsc_env tag = showPpr dflags dcname - vars <- replicateM (length$ elems$ ptrs clos) + vars <- replicateM (length pArgs) (newVar liftedTypeKind) - subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i - | (i, tv) <- zip [0..] vars] + subTerms <- sequence $ zipWith (\(Box x) tv -> + go (pred max_depth) tv tv (HValue x)) pArgs vars return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) @@ -773,9 +716,9 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return (Term my_ty (Right dc) a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. - tipe_clos -> do - traceTR (text "Unknown closure:" <+> ppr tipe_clos) - return (Suspension tipe_clos my_ty a Nothing) + _ -> do + traceTR (text "Unknown closure:" <+> text (show clos)) + return (Suspension (tipe (info clos)) my_ty a Nothing) -- insert NewtypeWraps around newtypes expandNewtypes = foldTerm idTermFold { fTerm = worker } where @@ -798,7 +741,7 @@ extractSubTerms :: (Type -> HValue -> TcM Term) -> Closure -> [Type] -> TcM [Term] extractSubTerms recurse clos = liftM thdOf3 . go 0 0 where - !(ClosureNonPtrs array) = nonPtrs clos + array = dataArgs clos go ptr_i arr_i [] = return (ptr_i, arr_i, []) go ptr_i arr_i (ty:tys) @@ -829,7 +772,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 go_rep ptr_i arr_i ty rep | isGcPtrRep rep = do - t <- appArr (recurse ty) (ptrs clos) ptr_i + t <- (\(Box x) -> recurse ty (HValue x)) $ (ptrArgs clos)!!ptr_i return (ptr_i + 1, arr_i, t) | otherwise = do -- This is a bit involved since we allow packing multiple fields @@ -841,29 +784,34 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 -- Fields are always aligned. !aligned_idx = roundUpTo arr_i size_b !new_arr_i = aligned_idx + size_b - ws - | size_b < word_size = [index size_b array aligned_idx] - | otherwise = - let (q, r) = size_b `quotRem` word_size - in ASSERT( r == 0 ) - [ W# (indexWordArray# array i) - | o <- [0.. q - 1] - , let !(I# i) = (aligned_idx + o) `quot` word_size - ] + ws | size_b < word_size = + [index size_b array aligned_idx word_size] + | otherwise = + let (q, r) = size_b `quotRem` word_size + in ASSERT( r == 0 ) + [ array!!i + | o <- [0.. q - 1] + , let i = (aligned_idx `quot` word_size) + o + ] return (ptr_i, new_arr_i, Prim ty ws) unboxedTupleTerm ty terms = Term ty (Right (tupleDataCon Unboxed (length terms))) (error "unboxedTupleTerm: no HValue for unboxed tuple") terms - index item_size_b array (I# index_b) = - case item_size_b of - -- indexWord*Array# functions take offsets dependent not in bytes, - -- but in multiples of an element's size. - 1 -> W# (indexWord8Array# array index_b) - 2 -> W# (indexWord16Array# array (index_b `quotInt#` 2#)) - 4 -> W# (indexWord32Array# array (index_b `quotInt#` 4#)) - _ -> panic ("Weird byte-index: " ++ show (I# index_b)) + -- Extract a sub-word sized field from a word + index item_size_b array index_b word_size = + (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes + where + mask :: Word + mask = case item_size_b of + 1 -> 0xFF + 2 -> 0xFFFF + 4 -> 0xFFFFFFFF + _ -> panic ("Weird byte-index: " ++ show index_b) + (q,r) = index_b `quotRem` word_size + word = array!!q + moveBytes = r * 8 -- Fast, breadth-first Type reconstruction @@ -896,8 +844,6 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) return new_ty where - dflags = hsc_dflags hsc_env - -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> int max_depth <> text " steps") @@ -912,32 +858,31 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do go :: Type -> HValue -> TR [(Type, HValue)] go my_ty a = do traceTR (text "go" <+> ppr my_ty) - clos <- trIO $ getClosureData dflags a - case tipe clos of - Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO - Indirection _ -> go my_ty $! (ptrs clos ! 0) - MutVar _ -> do + clos <- trIO $ getClosureData a + case clos of + BlackholeClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind + IndClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind + MutVarClosure{} -> do contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w tv' <- newVar liftedTypeKind world <- newVar liftedTypeKind addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) return [(tv', contents)] - Constr -> do - dcname <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos) + ConstrClosure{ptrArgs=pArgs} -> do + Right dcname <- liftIO $ constrClosToName hsc_env clos traceTR (text "Constr1" <+> ppr dcname) (_,mb_dc) <- tryTc (tcLookupDataCon dcname) case mb_dc of Nothing-> do - forM (elems $ ptrs clos) $ \a -> do + forM pArgs $ \(Box x) -> do tv <- newVar liftedTypeKind - return (tv, a) + return (tv, HValue x) Just dc -> do arg_tys <- getDataConArgTys dc my_ty (_, itys) <- findPtrTyss 0 arg_tys traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) - return $ [ appArr (\e-> (ty,e)) (ptrs clos) i - | (i,ty) <- itys] + return $ zipWith (\(_,ty) (Box x) -> (ty, HValue x)) itys pArgs _ -> return [] findPtrTys :: Int -- Current pointer index @@ -1303,15 +1248,3 @@ quantifyType ty = ( filter isTyVar $ , rho) where (_tvs, rho) = tcSplitForAllTys ty - --- Strict application of f at index i -appArr :: Ix i => (e -> a) -> Array i e -> Int -> a -appArr f a@(Array _ _ _ ptrs#) i@(I# i#) - = ASSERT2(i < length(elems a), ppr(length$ elems a, i)) - case indexArray# ptrs# i# of - (# e #) -> f e - -amap' :: (t -> b) -> Array Int t -> [b] -amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] - where g (I# i#) = case indexArray# arr# i# of - (# e #) -> f e diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 763a2ca37d..9165c6f4f9 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -3024,12 +3024,11 @@ primop NewBCOOp "newBCO#" GenPrimOp out_of_line = True primop UnpackClosureOp "unpackClosure#" GenPrimOp - a -> (# Addr#, Array# b, ByteArray# #) - { {\tt unpackClosure\# closure} copies non-pointers and pointers in the + a -> (# Addr#, ByteArray#, Array# b #) + { {\tt unpackClosure\# closure} copies the closure and pointers in the payload of the given closure into two new arrays, and returns a pointer to - the first word of the closure's info table, a pointer array for the - pointers in the payload, and a non-pointer array for the non-pointers in - the payload. } + the first word of the closure's info table, a non-pointer array for the raw + bytes of the closure, and a pointer array for the pointers in the payload. } with out_of_line = True diff --git a/configure.ac b/configure.ac index 1f4912855a..57d0943a07 100644 --- a/configure.ac +++ b/configure.ac @@ -1323,7 +1323,7 @@ checkMake380() { checkMake380 make checkMake380 gmake -AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk rts/rts.cabal compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal utils/gen-dll/gen-dll.cabal libraries/ghc-boot/ghc-boot.cabal libraries/ghc-boot-th/ghc-boot-th.cabal libraries/ghci/ghci.cabal settings docs/users_guide/ghc_config.py docs/index.html libraries/prologue.txt distrib/configure.ac]) +AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk rts/rts.cabal compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal utils/gen-dll/gen-dll.cabal libraries/ghc-boot/ghc-boot.cabal libraries/ghc-boot-th/ghc-boot-th.cabal libraries/ghci/ghci.cabal libraries/ghc-heap/ghc-heap.cabal settings docs/users_guide/ghc_config.py docs/index.html libraries/prologue.txt distrib/configure.ac]) AC_OUTPUT [ if test "$print_make_warning" = "true"; then @@ -420,7 +420,7 @@ else # CLEANING # programs such as GHC and ghc-pkg, that we do not assume the stage0 # compiler already has installed (or up-to-date enough). -PACKAGES_STAGE0 = binary text transformers mtl parsec Cabal/Cabal hpc ghc-boot-th ghc-boot template-haskell ghci +PACKAGES_STAGE0 = binary text transformers mtl parsec Cabal/Cabal hpc ghc-boot-th ghc-boot template-haskell ghc-heap ghci ifeq "$(Windows_Host)" "NO" PACKAGES_STAGE0 += terminfo endif @@ -459,6 +459,7 @@ PACKAGES_STAGE1 += ghc-boot-th PACKAGES_STAGE1 += ghc-boot PACKAGES_STAGE1 += template-haskell PACKAGES_STAGE1 += ghc-compact +PACKAGES_STAGE1 += ghc-heap ifeq "$(HADDOCK_DOCS)" "YES" PACKAGES_STAGE1 += xhtml diff --git a/includes/Rts.h b/includes/Rts.h index dd81033603..fc70479eb6 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -175,6 +175,7 @@ void _assertFail(const char *filename, unsigned int linenum) #include "rts/storage/FunTypes.h" #include "rts/storage/InfoTables.h" #include "rts/storage/Closures.h" +#include "rts/storage/Heap.h" #include "rts/storage/ClosureTypes.h" #include "rts/storage/TSO.h" #include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */ diff --git a/includes/rts/storage/Heap.h b/includes/rts/storage/Heap.h new file mode 100644 index 0000000000..2e908279bf --- /dev/null +++ b/includes/rts/storage/Heap.h @@ -0,0 +1,18 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2006-2017 + * + * Introspection into GHC's heap representation + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#include "rts/storage/Closures.h" + +StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure); + +void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs + , StgClosure *fun, StgClosure **payload, StgWord size); + +StgWord heap_view_closureSize(StgClosure *closure); diff --git a/libraries/ghc-heap/.gitignore b/libraries/ghc-heap/.gitignore new file mode 100644 index 0000000000..7eba14b857 --- /dev/null +++ b/libraries/ghc-heap/.gitignore @@ -0,0 +1,5 @@ +GNUmakefile +/dist-install/ +/dist/ +ghc.mk +heapview.cabal diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs new file mode 100644 index 0000000000..3dd204d3c5 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : GHC.Exts.Heap +Copyright : (c) 2012 Joachim Breitner +License : BSD3 +Maintainer : Joachim Breitner <mail@joachim-breitner.de> + +With this module, you can investigate the heap representation of Haskell +values, i.e. to investigate sharing and lazy evaluation. +-} + +module GHC.Exts.Heap ( + -- * Closure types + Closure + , GenClosure(..) + , ClosureType(..) + , PrimType(..) + , HasHeapRep(getClosureData) + + -- * Info Table types + , StgInfoTable(..) + , EntryFunPtr + , HalfWord + , ItblCodes + , itblSize + , peekItbl + , pokeItbl + + -- * Closure inspection + , getBoxedClosureData + , allClosures + + -- * Boxes + , Box(..) + , asBox + , areBoxesEqual + ) where + +import GHC.Exts.Heap.Closures +import GHC.Exts.Heap.ClosureTypes +import GHC.Exts.Heap.Constants +#if defined(PROFILING) +import GHC.Exts.Heap.InfoTableProf +#else +import GHC.Exts.Heap.InfoTable +#endif +import GHC.Exts.Heap.Utils + +import Control.Monad +import Data.Bits +import GHC.Arr +import GHC.Exts +import GHC.Int +import GHC.Word + +class HasHeapRep (a :: TYPE rep) where + getClosureData :: a -> IO Closure + +instance HasHeapRep (a :: TYPE 'LiftedRep) where + getClosureData = getClosure + +instance HasHeapRep (a :: TYPE 'UnliftedRep) where + getClosureData x = getClosure (unsafeCoerce# x) + +instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where + getClosureData x = return $ + IntClosure { ptipe = PInt, intVal = I# x } + +instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where + getClosureData x = return $ + WordClosure { ptipe = PWord, wordVal = W# x } + +instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where + getClosureData x = return $ + Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) } + +instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where + getClosureData x = return $ + Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) } + +instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where + getClosureData x = return $ + AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) } + +instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where + getClosureData x = return $ + FloatClosure { ptipe = PFloat, floatVal = F# x } + +instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where + getClosureData x = return $ + DoubleClosure { ptipe = PDouble, doubleVal = D# x } + +-- | This returns the raw representation of the given argument. The second +-- component of the triple is the raw words of the closure on the heap, and the +-- third component is those words that are actually pointers. Once back in the +-- Haskell world, the raw words that hold pointers may be outdated after a +-- garbage collector run, but the corresponding values in 'Box's will still +-- point to the correct value. +getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box]) +getClosureRaw x = do + case unpackClosure# x of +-- This is a hack to cover the bootstrap compiler using the old version of +-- 'unpackClosure'. The new 'unpackClosure' return values are not merely +-- a reordering, so using the old version would not work. +#if MIN_VERSION_ghc_prim(0,5,2) + (# iptr, dat, pointers #) -> do +#else + (# iptr, pointers, dat #) -> do +#endif + let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE + end = fromIntegral nelems - 1 + rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ] + pelems = I# (sizeofArray# pointers) + ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers + pure (Ptr iptr, rawWds, ptrList) + +-- From compiler/ghci/RtClosureInspect.hs +amap' :: (t -> b) -> Array Int t -> [b] +amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] + where g (I# i#) = case indexArray# arr# i# of + (# e #) -> f e + +-- | This function returns a parsed heap representation of the argument _at +-- this moment_, even if it is unevaluated or an indirection or other exotic +-- stuff. Beware when passing something to this function, the same caveats as +-- for 'asBox' apply. +getClosure :: a -> IO Closure +getClosure x = do + (iptr, wds, pts) <- getClosureRaw x + itbl <- peekItbl iptr + -- The remaining words after the header + let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds + -- For data args in a pointers then non-pointers closure + -- This is incorrect in non pointers-first setups + -- not sure if that happens + npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds + case tipe itbl of + t | t >= CONSTR && t <= CONSTR_NOCAF -> do + (p, m, n) <- dataConNames iptr + if m == "ByteCodeInstr" && n == "BreakInfo" + then pure $ UnsupportedClosure itbl + else pure $ ConstrClosure itbl pts npts p m n + + t | t >= THUNK && t <= THUNK_STATIC -> do + pure $ ThunkClosure itbl pts npts + + THUNK_SELECTOR -> do + unless (length pts >= 1) $ + fail "Expected at least 1 ptr argument to THUNK_SELECTOR" + pure $ SelectorClosure itbl (head pts) + + t | t >= FUN && t <= FUN_STATIC -> do + pure $ FunClosure itbl pts npts + + AP -> do + unless (length pts >= 1) $ + fail "Expected at least 1 ptr argument to AP" + -- We expect at least the arity, n_args, and fun fields + unless (length rawWds >= 2) $ + fail $ "Expected at least 2 raw words to AP" + let splitWord = rawWds !! 0 + pure $ APClosure itbl + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (head pts) (tail pts) + + PAP -> do + unless (length pts >= 1) $ + fail "Expected at least 1 ptr argument to PAP" + -- We expect at least the arity, n_args, and fun fields + unless (length rawWds >= 2) $ + fail "Expected at least 2 raw words to PAP" + let splitWord = rawWds !! 0 + pure $ PAPClosure itbl + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (head pts) (tail pts) + + AP_STACK -> do + unless (length pts >= 1) $ + fail "Expected at least 1 ptr argument to AP_STACK" + pure $ APStackClosure itbl (head pts) (tail pts) + + IND -> do + unless (length pts >= 1) $ + fail "Expected at least 1 ptr argument to IND" + pure $ IndClosure itbl (head pts) + + IND_STATIC -> do + unless (length pts >= 1) $ + fail "Expected at least 1 ptr argument to IND_STATIC" + pure $ IndClosure itbl (head pts) + + BLACKHOLE -> do + unless (length pts >= 1) $ + fail "Expected at least 1 ptr argument to BLACKHOLE" + pure $ BlackholeClosure itbl (head pts) + + BCO -> do + unless (length pts >= 3) $ + fail $ "Expected at least 3 ptr argument to BCO, found " + ++ show (length pts) + unless (length rawWds >= 4) $ + fail $ "Expected at least 4 words to BCO, found " + ++ show (length rawWds) + let splitWord = rawWds !! 3 + pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (drop 4 rawWds) + + ARR_WORDS -> do + unless (length rawWds >= 1) $ + fail $ "Expected at least 1 words to ARR_WORDS, found " + ++ show (length rawWds) + pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds) + + t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN -> do + unless (length rawWds >= 2) $ + fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " + ++ "found " ++ show (length rawWds) + pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts + + t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> + pure $ MutVarClosure itbl (head pts) + + t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do + unless (length pts >= 3) $ + fail $ "Expected at least 3 ptrs to MVAR, found " + ++ show (length pts) + pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) + + BLOCKING_QUEUE -> + pure $ OtherClosure itbl pts wds + -- pure $ BlockingQueueClosure itbl + -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3) + + -- pure $ OtherClosure itbl pts wds + -- + _ -> + pure $ UnsupportedClosure itbl + +-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with. +getBoxedClosureData :: Box -> IO Closure +getBoxedClosureData (Box a) = getClosureData a diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs new file mode 100644 index 0000000000..507561fbee --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.ClosureTypes + ( ClosureType(..) + , closureTypeHeaderSize + ) where + +{- --------------------------------------------- +-- Enum representing closure types +-- This is a mirror of: +-- includes/rts/storage/ClosureTypes.h +-- ---------------------------------------------} + +data ClosureType + = INVALID_OBJECT + | CONSTR + | CONSTR_1_0 + | CONSTR_0_1 + | CONSTR_2_0 + | CONSTR_1_1 + | CONSTR_0_2 + | CONSTR_NOCAF + | FUN + | FUN_1_0 + | FUN_0_1 + | FUN_2_0 + | FUN_1_1 + | FUN_0_2 + | FUN_STATIC + | THUNK + | THUNK_1_0 + | THUNK_0_1 + | THUNK_2_0 + | THUNK_1_1 + | THUNK_0_2 + | THUNK_STATIC + | THUNK_SELECTOR + | BCO + | AP + | PAP + | AP_STACK + | IND + | IND_STATIC + | RET_BCO + | RET_SMALL + | RET_BIG + | RET_FUN + | UPDATE_FRAME + | CATCH_FRAME + | UNDERFLOW_FRAME + | STOP_FRAME + | BLOCKING_QUEUE + | BLACKHOLE + | MVAR_CLEAN + | MVAR_DIRTY + | TVAR + | ARR_WORDS + | MUT_ARR_PTRS_CLEAN + | MUT_ARR_PTRS_DIRTY + | MUT_ARR_PTRS_FROZEN0 + | MUT_ARR_PTRS_FROZEN + | MUT_VAR_CLEAN + | MUT_VAR_DIRTY + | WEAK + | PRIM + | MUT_PRIM + | TSO + | STACK + | TREC_CHUNK + | ATOMICALLY_FRAME + | CATCH_RETRY_FRAME + | CATCH_STM_FRAME + | WHITEHOLE + | SMALL_MUT_ARR_PTRS_CLEAN + | SMALL_MUT_ARR_PTRS_DIRTY + | SMALL_MUT_ARR_PTRS_FROZEN0 + | SMALL_MUT_ARR_PTRS_FROZEN + | COMPACT_NFDATA + | N_CLOSURE_TYPES + deriving (Enum, Eq, Ord, Show) + +-- | Return the size of the closures header in words +closureTypeHeaderSize :: ClosureType -> Int +closureTypeHeaderSize closType = + case closType of + ct | THUNK <= ct && ct <= THUNK_0_2 -> thunkHeader + ct | ct == THUNK_SELECTOR -> thunkHeader + ct | ct == AP -> thunkHeader + ct | ct == AP_STACK -> thunkHeader + _ -> header + where + header = 1 + prof + thunkHeader = 2 + prof +#if defined(PROFILING) + prof = 2 +#else + prof = 0 +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs new file mode 100644 index 0000000000..f355a62510 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module GHC.Exts.Heap.Closures ( + -- * Closures + Closure + , GenClosure(..) + , PrimType(..) + , allClosures + + -- * Boxes + , Box(..) + , areBoxesEqual + , asBox + ) where + +import GHC.Exts.Heap.Constants +#if defined(PROFILING) +import GHC.Exts.Heap.InfoTableProf +#else +import GHC.Exts.Heap.InfoTable +#endif + +import Data.Bits +import Data.Int +import Data.Word +import GHC.Exts +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 + -- want 0s prefixed to pad it out to a fixed length. + pad_out ls = + '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ 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 +-- <http://hackage.haskell.org/trac/ghc/browser/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://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects> +-- 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 + } + + -- | 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 closure + } + + -- | 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 -- ^ ?? + } + + ------------------------------------------------------------ + -- 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) + + +data PrimType + = PInt + | PWord + | PInt64 + | PWord64 + | PAddr + | PFloat + | PDouble + deriving (Eq, Show) + +-- | 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 (MutVarClosure {..}) = [var] +allClosures (MVarClosure {..}) = [queueHead,queueTail,value] +allClosures (FunClosure {..}) = ptrArgs +allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue] +allClosures (OtherClosure {..}) = hvalues +allClosures _ = [] diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc b/libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc new file mode 100644 index 0000000000..757e76ce23 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.Constants + ( wORD_SIZE + , tAG_MASK + , wORD_SIZE_IN_BITS + ) where + +#include "MachDeps.h" + +import Data.Bits + +wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int +wORD_SIZE = #const SIZEOF_HSWORD +wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS +tAG_MASK = (1 `shift` #const TAG_BITS) - 1 diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc new file mode 100644 index 0000000000..d6f1ab0e95 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc @@ -0,0 +1,77 @@ +module GHC.Exts.Heap.InfoTable + ( module GHC.Exts.Heap.InfoTable.Types + , itblSize + , peekItbl + , pokeItbl + ) where + +#include "Rts.h" + +import GHC.Exts.Heap.InfoTable.Types +#if !defined(TABLES_NEXT_TO_CODE) +import GHC.Exts.Heap.Constants +import Data.Maybe +#endif +import Foreign + +------------------------------------------------------------------------- +-- Profiling specific code +-- +-- The functions that follow all rely on PROFILING. They are duplicated in +-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This +-- allows hsc2hs to generate values for both profiling and non-profiling builds. + +-- | Read an InfoTable from the heap into a haskell type. +-- WARNING: This code assumes it is passed a pointer to a "standard" info +-- table. If tables_next_to_code is enabled, it will look 1 byte before the +-- start for the entry field. +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if !defined(TABLES_NEXT_TO_CODE) + let ptr = a0 `plusPtr` (negate wORD_SIZE) + entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr +#else + let ptr = a0 + entry' = Nothing +#endif + ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr + nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr + tipe' <- (#peek struct StgInfoTable_, type) ptr +#if __GLASGOW_HASKELL__ > 804 + srtlen' <- (#peek struct StgInfoTable_, srt) a0 +#else + srtlen' <- (#peek struct StgInfoTable_, srt_bitmap) ptr +#endif + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) + , srtlen = srtlen' + , code = Nothing + } + +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () +pokeItbl a0 itbl = do +#if !defined(TABLES_NEXT_TO_CODE) + (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) +#endif + (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) + (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) + (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl)) +#if __GLASGOW_HASKELL__ > 804 + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#else + (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl) +#endif +#if defined(TABLES_NEXT_TO_CODE) + let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) + case code itbl of + Nothing -> return () + Just (Left xs) -> pokeArray code_offset xs + Just (Right xs) -> pokeArray code_offset xs +#endif + +-- | Size in bytes of a standard InfoTable +itblSize :: Int +itblSize = (#size struct StgInfoTable_) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc new file mode 100644 index 0000000000..d8666d6b1d --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc @@ -0,0 +1,37 @@ +module GHC.Exts.Heap.InfoTable.Types + ( StgInfoTable(..) + , EntryFunPtr + , HalfWord + , ItblCodes + ) where + +#include "Rts.h" + +import GHC.Exts.Heap.ClosureTypes +import Foreign + +type ItblCodes = Either [Word8] [Word32] + +#include "ghcautoconf.h" +-- Ultra-minimalist version specially for constructors +#if SIZEOF_VOID_P == 8 +type HalfWord = Word32 +#elif SIZEOF_VOID_P == 4 +type HalfWord = Word16 +#else +#error Unknown SIZEOF_VOID_P +#endif + +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) + +-- | This is a somewhat faithful representation of an info table. See +-- <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h> +-- for more details on this data structure. +data StgInfoTable = StgInfoTable { + entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: ClosureType, + srtlen :: HalfWord, + code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode + } deriving (Show) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc new file mode 100644 index 0000000000..cd030bfa1a --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc @@ -0,0 +1,73 @@ +module GHC.Exts.Heap.InfoTableProf + ( module GHC.Exts.Heap.InfoTable.Types + , itblSize + , peekItbl + , pokeItbl + ) where + +-- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl. +-- Manually defining PROFILING gives the #peek and #poke macros an accurate +-- representation of StgInfoTable_ when hsc2hs runs. +#define PROFILING +#include "Rts.h" + +import GHC.Exts.Heap.InfoTable.Types +#if !defined(TABLES_NEXT_TO_CODE) +import GHC.Exts.Heap.Constants +import Data.Maybe +#endif +import Foreign + +-- | Read an InfoTable from the heap into a haskell type. +-- WARNING: This code assumes it is passed a pointer to a "standard" info +-- table. If tables_next_to_code is enabled, it will look 1 byte before the +-- start for the entry field. +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if !defined(TABLES_NEXT_TO_CODE) + let ptr = a0 `plusPtr` (negate wORD_SIZE) + entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr +#else + let ptr = a0 + entry' = Nothing +#endif + ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr + nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr + tipe' <- (#peek struct StgInfoTable_, type) ptr +#if __GLASGOW_HASKELL__ > 804 + srtlen' <- (#peek struct StgInfoTable_, srt) a0 +#else + srtlen' <- (#peek struct StgInfoTable_, srt_bitmap) ptr +#endif + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) + , srtlen = srtlen' + , code = Nothing + } + +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () +pokeItbl a0 itbl = do +#if !defined(TABLES_NEXT_TO_CODE) + (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) +#endif + (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) + (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) + (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl)) +#if __GLASGOW_HASKELL__ > 804 + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#else + (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl) +#endif +#if defined(TABLES_NEXT_TO_CODE) + let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) + case code itbl of + Nothing -> return () + Just (Left xs) -> pokeArray code_offset xs + Just (Right xs) -> pokeArray code_offset xs +#endif + +itblSize :: Int +itblSize = (#size struct StgInfoTable_) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc new file mode 100644 index 0000000000..3f09700225 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP, MagicHash #-} + +module GHC.Exts.Heap.Utils ( + dataConNames + ) where + +#include "Rts.h" + +import GHC.Exts.Heap.Constants +import GHC.Exts.Heap.InfoTable + +import Data.Char +import Data.List +import Foreign +import GHC.CString +import GHC.Exts + +{- To find the string in the constructor's info table we need to consider + the layout of info tables relative to the entry code for a closure. + + An info table can be next to the entry code for the closure, or it can + be separate. The former (faster) is used in registerised versions of ghc, + and the latter (portable) is for non-registerised versions. + + The diagrams below show where the string is to be found relative to + the normal info table of the closure. + + 1) Tables next to code: + + -------------- + | | <- pointer to the start of the string + -------------- + | | <- the (start of the) info table structure + | | + | | + -------------- + | entry code | + | .... | + + In this case the pointer to the start of the string can be found in + the memory location _one word before_ the first entry in the normal info + table. + + 2) Tables NOT next to code: + + -------------- + info table structure -> | *------------------> -------------- + | | | entry code | + | | | .... | + -------------- + ptr to start of str -> | | + -------------- + + In this case the pointer to the start of the string can be found + in the memory location: info_table_ptr + info_table_size +-} + +-- Given a ptr to an 'StgInfoTable' for a data constructor +-- return (Package, Module, Name) +dataConNames :: Ptr StgInfoTable -> IO (String, String, String) +dataConNames ptr = do + conDescAddress <- getConDescAddress + pure $ parse conDescAddress + where + -- Retrieve the con_desc field address pointing to + -- 'Package:Module.Name' string + getConDescAddress :: IO (Ptr Word8) + getConDescAddress +#if defined(TABLES_NEXT_TO_CODE) + = do + offsetToString <- peek (ptr `plusPtr` negate wORD_SIZE) + pure $ (ptr `plusPtr` stdInfoTableSizeB) + `plusPtr` fromIntegral (offsetToString :: Int32) +#else + = peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral stdInfoTableSizeB +#endif + + stdInfoTableSizeW :: Int + -- The size of a standard info table varies with profiling/ticky etc, + -- so we can't get it from Constants + -- It must vary in sync with mkStdInfoTable + stdInfoTableSizeW + = size_fixed + size_prof + where + size_fixed = 2 -- layout, type +##if defined(PROFILING) + size_prof = 2 +##else + size_prof = 0 +##endif + + stdInfoTableSizeB :: Int + stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE + +-- parsing names is a little bit fiddly because we have a string in the form: +-- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). +-- Thus we split at the leftmost colon and the rightmost occurrence of the dot. +-- It would be easier if the string was in the form pkg:A.B.C:foo, but alas +-- this is not the conventional way of writing Haskell names. We stick with +-- convention, even though it makes the parsing code more troublesome. +-- Warning: this code assumes that the string is well formed. +parse :: Ptr Word8 -> (String, String, String) +parse (Ptr addr) = if not . all (>0) . fmap length $ [p,m,occ] + then ([], [], input) + else (p, m, occ) + where + input = unpackCStringUtf8## addr + (p, rest1) = break (== ':') input + (m, occ) + = (intercalate "." $ reverse modWords, occWord) + where + (modWords, occWord) = + if length rest1 < 1 -- XXXXXXXXx YUKX + --then error "getConDescAddress:parse:length rest1 < 1" + then parseModOcc [] [] + else parseModOcc [] (tail rest1) + -- We only look for dots if str could start with a module name, + -- i.e. if it starts with an upper case character. + -- Otherwise we might think that "X.:->" is the module name in + -- "X.:->.+", whereas actually "X" is the module name and + -- ":->.+" is a constructor name. + parseModOcc :: [String] -> String -> ([String], String) + parseModOcc acc str@(c : _) + | isUpper c = + case break (== '.') str of + (top, []) -> (acc, top) + (top, _:bot) -> parseModOcc (top : acc) bot + parseModOcc acc str = (acc, str) diff --git a/libraries/ghc-heap/LICENSE b/libraries/ghc-heap/LICENSE new file mode 100644 index 0000000000..682cb5ac5c --- /dev/null +++ b/libraries/ghc-heap/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012-2013, Joachim Breitner + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Joachim Breitner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/libraries/ghc-heap/Setup.hs b/libraries/ghc-heap/Setup.hs new file mode 100644 index 0000000000..6fa548caf7 --- /dev/null +++ b/libraries/ghc-heap/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/libraries/ghc-heap/cbits/HeapPrim.cmm b/libraries/ghc-heap/cbits/HeapPrim.cmm new file mode 100644 index 0000000000..915786de28 --- /dev/null +++ b/libraries/ghc-heap/cbits/HeapPrim.cmm @@ -0,0 +1,13 @@ +#include "Cmm.h" + +aToWordzh (P_ clos) +{ + return (clos); +} + +reallyUnsafePtrEqualityUpToTag (W_ clos1, W_ clos2) +{ + clos1 = UNTAG(clos1); + clos2 = UNTAG(clos2); + return (clos1 == clos2); +} diff --git a/libraries/ghc-heap/ghc-heap.cabal.in b/libraries/ghc-heap/ghc-heap.cabal.in new file mode 100644 index 0000000000..780dda3fd0 --- /dev/null +++ b/libraries/ghc-heap/ghc-heap.cabal.in @@ -0,0 +1,38 @@ +cabal-version: 2.1 +name: ghc-heap +version: @ProjectVersionMunged@ +license: BSD-3-Clause +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://ghc.haskell.org/trac/ghc/newticket +synopsis: Functions for walking GHC's heap +category: GHC +description: + This package provides functions for walking the GHC heap data structures + and retrieving information about those data structures. + +build-type: Simple +tested-with: GHC==7.11 + +source-repository head + type: git + location: http://git.haskell.org/ghc.git + subdir: libraries/heapview + +library + default-language: Haskell2010 + + build-depends: base >= 4.9.0 && < 5.0 + , ghc-prim > 0.2 && < 0.6 + , rts == 1.0.* + + ghc-options: -Wall + cmm-sources: cbits/HeapPrim.cmm + exposed-modules: GHC.Exts.Heap + GHC.Exts.Heap.Closures + GHC.Exts.Heap.ClosureTypes + GHC.Exts.Heap.Constants + GHC.Exts.Heap.InfoTable + GHC.Exts.Heap.InfoTable.Types + GHC.Exts.Heap.InfoTableProf + GHC.Exts.Heap.Utils diff --git a/libraries/ghc-heap/tests/Makefile b/libraries/ghc-heap/tests/Makefile new file mode 100644 index 0000000000..6a0abcf1cf --- /dev/null +++ b/libraries/ghc-heap/tests/Makefile @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T new file mode 100644 index 0000000000..a676b4971a --- /dev/null +++ b/libraries/ghc-heap/tests/all.T @@ -0,0 +1,8 @@ +test('heap_all', + [when(have_profiling(), + extra_ways(['prof'])), + # These ways produce slightly different heap representations. + # Currently we don't test them. + omit_ways(['ghci', 'hpc']) + ], + compile_and_run, ['']) diff --git a/libraries/ghc-heap/tests/heap_all.hs b/libraries/ghc-heap/tests/heap_all.hs new file mode 100644 index 0000000000..76da037034 --- /dev/null +++ b/libraries/ghc-heap/tests/heap_all.hs @@ -0,0 +1,421 @@ +-- The simplifier changes the shapes of closures that we expect. +{-# OPTIONS_GHC -O0 #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} + +import GHC.Exts.Heap + +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Monad +import GHC.Exts +import GHC.Int +import GHC.IO +import GHC.IORef +import GHC.MVar +import GHC.Stack +import GHC.STRef +import GHC.Word +import System.Environment +import System.Mem + +exData :: (Int,Int) +exData = (1,2) + +exItbl :: StgInfoTable +exItbl = StgInfoTable + { entry = Nothing + , ptrs = 0 + , nptrs = 0 + , tipe = toEnum 0 + , srtlen = 0 + , code = Nothing + } + +exConstrClosure :: Closure +exConstrClosure = ConstrClosure + { info = exItbl{tipe=CONSTR_1_0, ptrs=1, nptrs=0} + , ptrArgs = [] + , dataArgs = [] + , pkg = "base" + , modl = "GHC.Base" + , name = "Just" + } + +exFunClosure :: Closure +exFunClosure = FunClosure + { info = exItbl{tipe=FUN_0_1, ptrs=0, nptrs=1} + , ptrArgs = [] + , dataArgs = [0] + } + +exThunkClosure :: Closure +exThunkClosure = ThunkClosure + { info = exItbl{tipe=THUNK} + , ptrArgs = [] + , dataArgs = [] + } + +exSelectClosure :: Closure +exSelectClosure = SelectorClosure + { info = exItbl + , selectee = asBox exData + } + +exPAPClosure :: Closure +exPAPClosure = PAPClosure + { info = exItbl{tipe=PAP} + , arity = 1 + , n_args = 1 + , fun = asBox id + , payload = [] + } + +exAPClosure :: Closure +exAPClosure = APClosure + { info = exItbl{tipe=AP} + , arity = 0 + , n_args = 0 + , fun = asBox id + , payload = [] + } + +exAPStackClosure :: Closure +exAPStackClosure = APStackClosure + { info = exItbl{tipe=AP_STACK} + , fun = asBox id + , payload = [] + } + +exIndClosure :: Closure +exIndClosure = IndClosure + { info = exItbl{tipe=IND} + , indirectee = asBox [] + } + +exBCOClosure :: Closure +exBCOClosure = BCOClosure + { info = exItbl{tipe=BCO, ptrs=4} + , instrs = asBox [] + , literals = asBox [] + , bcoptrs = asBox [] + , arity = 0 + , size = 5 + , bitmap = [] + } + +exBlackholeClosure :: Closure +exBlackholeClosure = BlackholeClosure + { info = exItbl{tipe=BLACKHOLE} + , indirectee = asBox [] + } + +exArrWordsClosure :: Closure +exArrWordsClosure = ArrWordsClosure + { info = exItbl{tipe=ARR_WORDS} + , bytes = 0 + , arrWords = [] + } + +exMutArrClosure :: Closure +exMutArrClosure = MutArrClosure + { info = exItbl{tipe=MUT_ARR_PTRS_DIRTY} + , mccPtrs = 0 + , mccSize = 0 + , mccPayload = [] + } + +exMVarClosure :: Closure +exMVarClosure = MVarClosure + { info = exItbl{tipe=MVAR_DIRTY} + , queueHead = asBox [] + , queueTail = asBox [] + , value = asBox 0 + } + +exMutVarClosure :: Closure +exMutVarClosure = MutVarClosure + { info = exItbl{tipe=MUT_VAR_DIRTY} + , var = asBox [] + } + +exBlockingQClosure :: Closure +exBlockingQClosure = BlockingQueueClosure + { info = exItbl{tipe=BLOCKING_QUEUE} + , link = asBox [] + , blackHole = asBox [] + , owner = asBox [] + , queue = asBox [] + } + +exIntClosure :: Closure +exIntClosure = IntClosure + { ptipe = PInt, intVal = 42 } + +exWordClosure :: Closure +exWordClosure = WordClosure + { ptipe = PWord, wordVal = 42 } + +exInt64Closure :: Closure +exInt64Closure = Int64Closure + { ptipe = PInt64, int64Val = 42 } + +exWord64Closure :: Closure +exWord64Closure = Word64Closure + { ptipe = PWord64, word64Val = 42 } + +exAddrClosure :: Closure +exAddrClosure = AddrClosure + { ptipe = PAddr, addrVal = 42 } + +exFloatClosure :: Closure +exFloatClosure = FloatClosure + { ptipe = PFloat, floatVal = 42.0 } + +exDoubleClosure :: Closure +exDoubleClosure = DoubleClosure + { ptipe = PDouble, doubleVal = 42.0 } + +exOtherClosure :: Closure +exOtherClosure = OtherClosure + { info = exItbl + , hvalues = [] + , rawWords = [] + } + +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 () +main = do + + -------------------------------------------- + -- Objects to inspect + + MA ma <- IO $ \s -> + case newArray# 0# 0 s of + (# s1, x #) -> (# s1, MA x #) + A a <- IO $ \s -> + case freezeArray# ma 0# 0# s of + (# s1, x #) -> (# s1, A x #) + MBA mba <- IO $ \s -> + case newByteArray# 0# s of + (# s1, x #) -> (# s1, MBA x #) + BA ba <- IO $ \s -> + case newByteArray# 0# s of + (# 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 #) + APC apc <- IO $ \s -> + case mkApUpd0# bco of + (# x #) -> (# s, APC x #) + + -------------------------------------------- + -- Closures + + -- Constructor + let !con = Just 1 + getClosureData con >>= + assertClosuresEq exConstrClosure + + -- Function + let !fun = \x -> x + 1 + getClosureData fun >>= + assertClosuresEq exFunClosure + + -- Thunk + let thunk = map (+2) [1,2,3] + getClosureData thunk >>= + assertClosuresEq exThunkClosure + + -- Selector + -- FAILING: Getting THUNK not THUNK_SELECTOR + -- let sel = case exData of (a,_) -> a + -- getClosureData sel >>= + -- assertClosuresEq exSelectClosure + + -- Partial application + let !f = map (+2) + getClosureData f >>= + assertClosuresEq exPAPClosure + + -- Applied function + getClosureData apc >>= + assertClosuresEq exAPClosure + + -- Suspended thunk evaluation + -- getClosureData (Just 1) >>= + -- assertClosuresEq exAPStackClosure + + -- Indirection + -- getClosureData (Just 1) >>= + -- assertClosuresEq exIndClosure + + -- ByteCode object + getClosureData bco >>= + assertClosuresEq exBCOClosure + + -- Blackhole + -- getClosureData (Just 1) >>= + -- assertClosuresEq exBlackholeClosure + + -- Byte array + getClosureData ba >>= + assertClosuresEq exArrWordsClosure + + -- Mutable pointer array + getClosureData ma >>= + assertClosuresEq exMutArrClosure + + -- MVar + (MVar v) <- newMVar 1 + getClosureData (unsafeCoerce# v) >>= + assertClosuresEq exMVarClosure + + -- MutVar + (IORef (STRef v)) <- newIORef 1 + getClosureData v >>= + assertClosuresEq exMutVarClosure + + -- Blocking queue + -- getClosureData (Just 1) >>= + -- assertClosuresEq exBlockingQClosure + + ----------------------------------------------------- + -- Unboxed unlifted types + + -- Primitive Int + let (I# v) = 42 + getClosureData v >>= + assertClosuresEq exIntClosure + + -- Primitive Word + let (W# v) = 42 + getClosureData v >>= + assertClosuresEq exWordClosure + + -- Primitive Int64 + -- FAILING: On 64-bit platforms, v is a regular Int + -- let (I64# v) = 42 + -- getClosureData v >>= + -- assertClosuresEq exInt64Closure + + -- Primitive Word64 + -- FAILING: On 64-bit platforms, v is a regular Word + -- let (W64# v) = 42 + -- getClosureData v >>= + -- assertClosuresEq exWord64Closure + + -- Primitive Addr + let v = unsafeCoerce# 42# :: Addr# + getClosureData v >>= + assertClosuresEq exAddrClosure + + -- Primitive Float + let (F# v) = 42.0 + getClosureData v >>= + assertClosuresEq exFloatClosure + + -- Primitive Double + let (D# v) = 42.0 + getClosureData v >>= + assertClosuresEq exDoubleClosure + + ------------------------------------------------------ + -- Catch-all type + + -- Other + -- getClosureData (Just 1) >>= + -- assertClosuresEq exOtherClosure + + putStrLn "Done. No errors." + + +-- | Attempt to compare two closures +compareClosures :: Closure -> Closure -> Bool +compareClosures expected actual = + -- Determine which fields to compare based + -- upon expected closure type + let funcs = case expected of + ConstrClosure{} -> [ sEq (tipe . info) + , sEq (ptrs . info) + , sEq (nptrs . info) + , sEq dataArgs + , sEq name ] + FunClosure{} -> [ sEq (tipe . info) + , sEq (ptrs . info) + , sEq (nptrs . info) + , sEq dataArgs ] + ThunkClosure{} -> [ sEq (tipe . info) + , sEq (ptrs . info) + , sEq (nptrs . info) + , sEq dataArgs ] + SelectorClosure{} -> [ sEq (tipe . info) ] + PAPClosure{} -> [ sEq (tipe . info) + , sEq arity + , sEq n_args ] + APClosure{} -> [ sEq (tipe . info) + , sEq arity + , sEq n_args ] + APStackClosure{} -> [ sEq (tipe . info) ] + IndClosure{} -> [ sEq (tipe . info) ] + BCOClosure{} -> [ sEq (tipe . info) + , sEq arity + , sEq bitmap ] + BlackholeClosure{} -> [ sEq (tipe . info) ] + ArrWordsClosure{} -> [ sEq (tipe . info) + , sEq bytes + , sEq arrWords ] + MutArrClosure{} -> [ sEq (tipe . info) + , sEq mccPtrs + , sEq mccSize ] + MVarClosure{} -> [ sEq (tipe . info) ] + MutVarClosure{} -> [ sEq (tipe . info) ] + BlockingQueueClosure{} -> [ sEq (tipe . info) ] + IntClosure{} -> [ sEq ptipe + , sEq intVal ] + WordClosure{} -> [ sEq ptipe + , sEq wordVal ] + Int64Closure{} -> [ sEq ptipe + , sEq int64Val ] + Word64Closure{} -> [ sEq ptipe + , sEq word64Val ] + AddrClosure{} -> [ sEq ptipe + , sEq addrVal ] + FloatClosure{} -> [ sEq ptipe + , sEq floatVal ] + DoubleClosure{} -> [ sEq ptipe + , sEq doubleVal ] + _ -> error $ "Don't know how to compare expected closure: " + ++ show expected + in compareWith funcs expected actual + where + -- Take a list of closure comparisons and check all + compareWith :: [Closure -> Closure -> Bool] -> Closure -> Closure -> Bool + compareWith funcs c1 c2 = all (\f -> f c1 c2) funcs + + -- Create a comparison function from a selector + sEq :: Eq a => (Closure -> a) -> Closure -> Closure -> Bool + sEq select c1 c2 = select c1 == select c2 + +-- | Assert two closures are equal, checking depending on closure type +assertClosuresEq :: HasCallStack => Closure -> Closure -> IO () +assertClosuresEq _ c@UnsupportedClosure{} = + fail $ unlines [ "Unsupported closure returned: " ++ show c + , "" + , prettyCallStack callStack + ] +assertClosuresEq expected actual = + unless (compareClosures expected actual) $ fail $ unlines + [ "assertClosuresEq: Closures do not match" + , "Expected: " ++ show expected + , "Actual: " ++ show actual + , "" + , prettyCallStack callStack + ] diff --git a/libraries/ghc-heap/tests/heap_all.stdout b/libraries/ghc-heap/tests/heap_all.stdout new file mode 100644 index 0000000000..b747b9bd7b --- /dev/null +++ b/libraries/ghc-heap/tests/heap_all.stdout @@ -0,0 +1 @@ +Done. No errors. diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index afcfefc7fa..cd712ba925 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -9,75 +9,20 @@ -- We use the RTS data structures directly via hsc2hs. -- module GHCi.InfoTable - ( peekItbl, StgInfoTable(..) - , conInfoPtr + ( #ifdef GHCI - , mkConInfoTable + mkConInfoTable #endif ) where -#if !defined(TABLES_NEXT_TO_CODE) -import Data.Maybe (fromJust) -#endif +#ifdef GHCI import Foreign -import Foreign.C -- needed for 2nd stage -import GHC.Ptr -- needed for 2nd stage -import GHC.Exts -- needed for 2nd stage -import System.IO.Unsafe -- needed for 2nd stage - -type ItblCodes = Either [Word8] [Word32] - --- Ultra-minimalist version specially for constructors -#if SIZEOF_VOID_P == 8 -type HalfWord = Word32 -#elif SIZEOF_VOID_P == 4 -type HalfWord = Word16 -#else -#error Unknown SIZEOF_VOID_P +import Foreign.C +import GHC.Ptr +import GHC.Exts +import GHC.Exts.Heap #endif -type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) - -data StgInfoTable = StgInfoTable { - entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode - ptrs :: HalfWord, - nptrs :: HalfWord, - tipe :: HalfWord, - srtlen :: HalfWord, - code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode - } - -peekItbl :: Ptr StgInfoTable -> IO StgInfoTable -peekItbl a0 = do -#if defined(TABLES_NEXT_TO_CODE) - let entry' = Nothing -#else - entry' <- Just <$> (#peek StgInfoTable, entry) a0 -#endif - ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0 - nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0 - tipe' <- (#peek StgInfoTable, type) a0 -#if __GLASGOW_HASKELL__ > 804 - srtlen' <- (#peek StgInfoTable, srt) a0 -#else - srtlen' <- (#peek StgInfoTable, srt_bitmap) a0 -#endif - return StgInfoTable - { entry = entry' - , ptrs = ptrs' - , nptrs = nptrs' - , tipe = tipe' - , srtlen = srtlen' - , code = Nothing - } - --- | Convert a pointer to an StgConInfo into an info pointer that can be --- used in the header of a closure. -conInfoPtr :: Ptr () -> Ptr () -conInfoPtr ptr - | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable) - | otherwise = ptr - ghciTablesNextToCode :: Bool #ifdef TABLES_NEXT_TO_CODE ghciTablesNextToCode = True @@ -86,6 +31,9 @@ ghciTablesNextToCode = False #endif #ifdef GHCI /* To end */ +-- NOTE: Must return a pointer acceptable for use in the header of a closure. +-- If tables_next_to_code is enabled, then it must point the the 'code' field. +-- Otherwise, it should point to the start of the StgInfoTable. mkConInfoTable :: Int -- ptr words -> Int -- non-ptr words @@ -107,7 +55,7 @@ mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc = else Just entry_addr, ptrs = fromIntegral ptr_words, nptrs = fromIntegral nonptr_words, - tipe = fromIntegral cONSTR, + tipe = CONSTR, srtlen = fromIntegral tag, code = if ghciTablesNextToCode then Just code' @@ -373,11 +321,16 @@ pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable -> IO () pokeConItbl wr_ptr ex_ptr itbl = do - let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB) #if defined(TABLES_NEXT_TO_CODE) - (#poke StgConInfoTable, con_desc) wr_ptr _con_desc + -- Write the offset to the con_desc from the end of the standard InfoTable + -- at the first byte. + let con_desc_offset = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB) + (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset #else - (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl) + -- Write the con_desc address after the end of the info table. + -- Use itblSize because CPP will not pick up PROFILING when calculating + -- the offset. + pokeByteOff wr_ptr itblSize (conDesc itbl) #endif pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl) @@ -389,32 +342,14 @@ sizeOfEntryCode Left xs -> sizeOf (head xs) * length xs Right xs -> sizeOf (head xs) * length xs -pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () -pokeItbl a0 itbl = do -#if !defined(TABLES_NEXT_TO_CODE) - (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) -#endif - (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) - (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) - (#poke StgInfoTable, type) a0 (tipe itbl) -#if __GLASGOW_HASKELL__ > 804 - (#poke StgInfoTable, srt) a0 (srtlen itbl) -#else - (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl) -#endif -#if defined(TABLES_NEXT_TO_CODE) - let code_offset = (a0 `plusPtr` (#offset StgInfoTable, code)) - case code itbl of - Nothing -> return () - Just (Left xs) -> pokeArray code_offset xs - Just (Right xs) -> pokeArray code_offset xs -#endif - +-- Note: Must return proper pointer for use in a closure newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ()) newExecConItbl obj con_desc = alloca $ \pcode -> do let lcon_desc = length con_desc + 1{- null terminator -} - sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode) + -- SCARY + -- This size represents the number of bytes in an StgConInfoTable. + sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode) -- Note: we need to allocate the conDesc string next to the info -- table, because on a 64-bit platform we reference this string -- with a 32-bit offset relative to the info table, so if we @@ -426,7 +361,11 @@ newExecConItbl obj con_desc pokeConItbl wr_ptr ex_ptr cinfo pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc _flushExec sz ex_ptr -- Cache flush (if needed) +#if defined(TABLES_NEXT_TO_CODE) + return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB)) +#else return (castPtrToFunPtr ex_ptr) +#endif foreign import ccall unsafe "allocateExec" _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) @@ -440,26 +379,6 @@ foreign import ccall unsafe "flushExec" wORD_SIZE :: Int wORD_SIZE = (#const SIZEOF_HSINT) -fixedInfoTableSizeB :: Int -fixedInfoTableSizeB = 2 * wORD_SIZE - -profInfoTableSizeB :: Int -profInfoTableSizeB = (#size StgProfInfo) - -stdInfoTableSizeB :: Int -stdInfoTableSizeB - = (if ghciTablesNextToCode then 0 else wORD_SIZE) - + (if rtsIsProfiled then profInfoTableSizeB else 0) - + fixedInfoTableSizeB - conInfoTableSizeB :: Int -conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE - -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt - -rtsIsProfiled :: Bool -rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 - -cONSTR :: Int -- Defined in ClosureTypes.h -cONSTR = (#const CONSTR) +conInfoTableSizeB = wORD_SIZE + itblSize #endif /* GHCI */ diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index f69fff29ff..3f0bad9888 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -23,12 +23,12 @@ module GHCi.Message ) where import GHCi.RemoteTypes -import GHCi.InfoTable (StgInfoTable) import GHCi.FFI import GHCi.TH.Binary () import GHCi.BreakArray import GHC.LanguageExtensions +import GHC.Exts.Heap import GHC.ForeignSrcLang import GHC.Fingerprint import Control.Concurrent diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index bacc70fa88..47f65afe14 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -77,6 +77,7 @@ library filepath == 1.4.*, ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, + ghc-heap == @ProjectVersionMunged@, template-haskell == 2.14.*, transformers == 0.5.* diff --git a/rts/Heap.c b/rts/Heap.c new file mode 100644 index 0000000000..14289b896f --- /dev/null +++ b/rts/Heap.c @@ -0,0 +1,220 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2006-2017 + * + * Introspection into GHC's heap representation + * + * ---------------------------------------------------------------------------*/ + +#include "Rts.h" +#include "RtsAPI.h" + +#include "Capability.h" +#include "Printer.h" + +StgWord heap_view_closureSize(StgClosure *closure) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); + return closure_sizeW(closure); +} + +static void +heap_view_closure_ptrs_in_large_bitmap(StgClosure *ptrs[], StgWord *nptrs + , StgClosure **p, StgLargeBitmap *large_bitmap + , uint32_t size ) +{ + uint32_t i, j, b; + StgWord bitmap; + + b = 0; + + for (i = 0; i < size; b++) { + bitmap = large_bitmap->bitmap[b]; + j = stg_min(size-i, BITS_IN(W_)); + i += j; + for (; j > 0; j--, p++) { + if ((bitmap & 1) == 0) { + ptrs[(*nptrs)++] = *p; + } + bitmap = bitmap >> 1; + } + } +} + +void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs + , StgClosure *fun, StgClosure **payload, StgWord size) { + StgWord bitmap; + const StgFunInfoTable *fun_info; + + fun_info = get_fun_itbl(UNTAG_CLOSURE(fun)); + // ASSERT(fun_info->i.type != PAP); + StgClosure **p = payload; + + switch (fun_info->f.fun_type) { + case ARG_GEN: + bitmap = BITMAP_BITS(fun_info->f.b.bitmap); + goto small_bitmap; + case ARG_GEN_BIG: + heap_view_closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, + GET_FUN_LARGE_BITMAP(fun_info), size); + break; + case ARG_BCO: + heap_view_closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, + BCO_BITMAP(fun), size); + break; + default: + bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); + small_bitmap: + while (size > 0) { + if ((bitmap & 1) == 0) { + ptrs[(*nptrs)++] = *p; + } + bitmap = bitmap >> 1; + p++; + size--; + } + break; + } +} + +StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); + + StgWord size = heap_view_closureSize(closure); + StgWord nptrs = 0; + StgWord i; + + // First collect all pointers here, with the comfortable memory bound + // of the whole closure. Afterwards we know how many pointers are in + // the closure and then we can allocate space on the heap and copy them + // there + StgClosure *ptrs[size]; + + StgClosure **end; + StgClosure **ptr; + + const StgInfoTable *info = get_itbl(closure); + + switch (info->type) { + case INVALID_OBJECT: + barf("Invalid Object"); + break; + + // No pointers + case ARR_WORDS: + break; + + // Default layout + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR: + + + case PRIM: + + case FUN: + case FUN_1_0: + case FUN_0_1: + case FUN_1_1: + case FUN_2_0: + case FUN_0_2: + case FUN_STATIC: + end = closure->payload + info->layout.payload.ptrs; + for (ptr = closure->payload; ptr < end; ptr++) { + ptrs[nptrs++] = *ptr; + } + break; + + case THUNK: + case THUNK_1_0: + case THUNK_0_1: + case THUNK_1_1: + case THUNK_2_0: + case THUNK_0_2: + case THUNK_STATIC: + end = ((StgThunk *)closure)->payload + info->layout.payload.ptrs; + for (ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) { + ptrs[nptrs++] = *ptr; + } + break; + + case THUNK_SELECTOR: + ptrs[nptrs++] = ((StgSelector *)closure)->selectee; + break; + + case AP: + ptrs[nptrs++] = ((StgAP *)closure)->fun; + heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs, + ((StgAP *)closure)->fun, + ((StgAP *)closure)->payload, + ((StgAP *)closure)->n_args); + break; + + case PAP: + ptrs[nptrs++] = ((StgPAP *)closure)->fun; + heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs, + ((StgPAP *)closure)->fun, + ((StgPAP *)closure)->payload, + ((StgPAP *)closure)->n_args); + break; + + case AP_STACK: + ptrs[nptrs++] = ((StgAP_STACK *)closure)->fun; + for (i = 0; i < ((StgAP_STACK *)closure)->size; ++i) { + ptrs[nptrs++] = ((StgAP_STACK *)closure)->payload[i]; + } + break; + + case BCO: + ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->instrs; + ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->literals; + ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->ptrs; + break; + + case IND: + case IND_STATIC: + case BLACKHOLE: + ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + break; + + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + for (i = 0; i < ((StgMutArrPtrs *)closure)->ptrs; ++i) { + ptrs[nptrs++] = ((StgMutArrPtrs *)closure)->payload[i]; + } + break; + case MUT_VAR_CLEAN: + case MUT_VAR_DIRTY: + ptrs[nptrs++] = ((StgMutVar *)closure)->var; + break; + case MVAR_DIRTY: + case MVAR_CLEAN: + ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->head; + ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->tail; + ptrs[nptrs++] = ((StgMVar *)closure)->value; + break; + + default: + fprintf(stderr,"closurePtrs: Cannot handle type %s yet\n", + closure_type_names[info->type]); + break; + } + + size = nptrs + mutArrPtrsCardTableSize(nptrs); + StgMutArrPtrs *arr = + (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size); + TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), nptrs, 0); + SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_info, cap->r.rCCCS); + arr->ptrs = nptrs; + arr->size = size; + + for (i = 0; i<nptrs; i++) { + arr->payload[i] = ptrs[i]; + } + + return arr; +} diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index e3f6e4cd19..8c2eeb1b98 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -2020,70 +2020,44 @@ stg_mkApUpd0zh ( P_ bco ) stg_unpackClosurezh ( P_ closure ) { - W_ clos, info, ptrs, nptrs, p, ptrs_arr, nptrs_arr; - clos = UNTAG(closure); - info = %GET_STD_INFO(clos); - - // Some closures have non-standard layout, so we omit those here. - W_ type; - type = TO_W_(%INFO_TYPE(info)); - switch [0 .. N_CLOSURE_TYPES] type { - case THUNK_SELECTOR : { - ptrs = 1; - nptrs = 0; - goto out; - } - case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, - THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : { - ptrs = 0; - nptrs = 0; - goto out; - } - default: { - ptrs = TO_W_(%INFO_PTRS(info)); - nptrs = TO_W_(%INFO_NPTRS(info)); - goto out; - }} - -out: - W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz; - nptrs_arr_sz = SIZEOF_StgArrBytes + WDS(nptrs); - ptrs_arr_cards = mutArrPtrsCardWords(ptrs); - ptrs_arr_sz = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards); - - ALLOC_PRIM_P (ptrs_arr_sz + nptrs_arr_sz, stg_unpackClosurezh, closure); - - ptrs_arr = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1); - nptrs_arr = Hp - nptrs_arr_sz + WDS(1); - - SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, CCCS); - StgMutArrPtrs_ptrs(ptrs_arr) = ptrs; - StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards; + W_ info, ptrs, nptrs, p, ptrs_arr, dat_arr; + info = %GET_STD_INFO(UNTAG(closure)); - p = 0; + ptrs = TO_W_(%INFO_PTRS(info)); + nptrs = TO_W_(%INFO_NPTRS(info)); -write_ptrs: - if(p < ptrs) { - W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p); - p = p + 1; - goto write_ptrs; - } - /* We can leave the card table uninitialised, since the array is - allocated in the nursery. The GC will fill it in if/when the array - is promoted. */ + W_ clos; + clos = UNTAG(closure); - SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS); - StgArrBytes_bytes(nptrs_arr) = WDS(nptrs); - p = 0; + W_ len; + // The array returned is the raw data for the entire closure. + // The length is variable based upon the closure type, ptrs, and non-ptrs + (len) = foreign "C" heap_view_closureSize(clos "ptr"); + + W_ ptrs_arr_sz, ptrs_arr_cards, dat_arr_sz; + dat_arr_sz = SIZEOF_StgArrBytes + WDS(len); + + ALLOC_PRIM_P (dat_arr_sz, stg_unpackClosurezh, closure); -write_nptrs: - if(p < nptrs) { - W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs); + dat_arr = Hp - dat_arr_sz + WDS(1); + + + SET_HDR(dat_arr, stg_ARR_WORDS_info, CCCS); + StgArrBytes_bytes(dat_arr) = WDS(len); + p = 0; +for: + if(p < len) { + W_[BYTE_ARR_CTS(dat_arr) + WDS(p)] = W_[clos + WDS(p)]; p = p + 1; - goto write_nptrs; + goto for; } - return (info, ptrs_arr, nptrs_arr); + W_ ptrArray; + + // Follow the pointers + ("ptr" ptrArray) = foreign "C" heap_view_closurePtrs(MyCapability() "ptr", clos "ptr"); + + return (info, dat_arr, ptrArray); } /* ----------------------------------------------------------------------------- diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index aae1dd4334..d41135ddd3 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -143,6 +143,7 @@ library rts/storage/ClosureTypes.h rts/storage/Closures.h rts/storage/FunTypes.h + rts/storage/Heap.h rts/storage/GC.h rts/storage/InfoTables.h rts/storage/MBlock.h @@ -358,6 +359,7 @@ library FileLock.c Globals.c Hash.c + Heap.c Hpc.c HsFFI.c Inlines.c diff --git a/testsuite/tests/ghc-api/T4891/T4891.hs b/testsuite/tests/ghc-api/T4891/T4891.hs index 4aa4842640..62edae0e78 100644 --- a/testsuite/tests/ghc-api/T4891/T4891.hs +++ b/testsuite/tests/ghc-api/T4891/T4891.hs @@ -5,8 +5,8 @@ import ByteCodeLink import CoreMonad import Data.Array import DataCon -import DebuggerUtils import GHC +import GHC.Exts.Heap import HscTypes import Linker import RtClosureInspect @@ -50,14 +50,18 @@ chaseConstructor :: (GhcMonad m) => HValue -> m () chaseConstructor !hv = do dflags <- getDynFlags liftIO $ putStrLn "=====" - closure <- liftIO $ getClosureData dflags hv - case tipe closure of - Indirection _ -> chaseConstructor (ptrs closure ! 0) - Constr -> do + closure <- liftIO $ getClosureData hv + case closure of + IndClosure{indirectee=ind} -> + (\(Box a) -> chaseConstructor (unsafeCoerce a)) ind + ConstrClosure{} -> do withSession $ \hscEnv -> liftIO $ do - dcName <- dataConInfoPtrToName hscEnv (infoPtr closure) - putStrLn $ "Name: " ++ showPpr dflags dcName - putStrLn $ "OccString: " ++ "'" ++ getOccString dcName ++ "'" - dc <- ioLookupDataCon hscEnv dcName - putStrLn $ "DataCon: " ++ showPpr dflags dc + eDcname <- constrClosToName hscEnv closure + case eDcname of + Left _ -> return () + Right dcName -> do + putStrLn $ "Name: " ++ showPpr dflags dcName + putStrLn $ "OccString: " ++ "'" ++ getOccString dcName ++ "'" + dc <- ioLookupDataCon hscEnv dcName + putStrLn $ "DataCon: " ++ showPpr dflags dc _ -> return () |