diff options
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 () |