1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DataKinds #-} 3{-# LANGUAGE PolyKinds #-} 4{-# LANGUAGE MagicHash #-} 5{-# LANGUAGE UnboxedTuples #-} 6 7{-# LANGUAGE FlexibleInstances #-} 8{-# LANGUAGE TypeInType #-} 9{-# LANGUAGE TypeFamilies #-} 10 11{-| 12Module : GHC.Exts.Heap 13Copyright : (c) 2012 Joachim Breitner 14License : BSD3 15Maintainer : Joachim Breitner <mail@joachim-breitner.de> 16 17With this module, you can investigate the heap representation of Haskell 18values, i.e. to investigate sharing and lazy evaluation. 19-} 20 21module GHC.Exts.Heap ( 22 -- * Closure types 23 Closure 24 , GenClosure(..) 25 , ClosureType(..) 26 , PrimType(..) 27 , HasHeapRep(getClosureData) 28 29 -- * Info Table types 30 , StgInfoTable(..) 31 , EntryFunPtr 32 , HalfWord 33 , ItblCodes 34 , itblSize 35 , peekItbl 36 , pokeItbl 37 38 -- * Closure inspection 39 , getBoxedClosureData 40 , allClosures 41 42 -- * Boxes 43 , Box(..) 44 , asBox 45 , areBoxesEqual 46 ) where 47 48import Prelude 49import GHC.Exts.Heap.Closures 50import GHC.Exts.Heap.ClosureTypes 51import GHC.Exts.Heap.Constants 52#if defined(PROFILING) 53import GHC.Exts.Heap.InfoTableProf 54#else 55import GHC.Exts.Heap.InfoTable 56#endif 57import GHC.Exts.Heap.Utils 58 59import Control.Monad 60import Data.Bits 61import GHC.Arr 62import GHC.Exts 63import GHC.Int 64import GHC.Word 65 66#include "ghcconfig.h" 67 68class HasHeapRep (a :: TYPE rep) where 69 getClosureData :: a -> IO Closure 70 71instance HasHeapRep (a :: TYPE 'LiftedRep) where 72 getClosureData = getClosure 73 74instance HasHeapRep (a :: TYPE 'UnliftedRep) where 75 getClosureData x = getClosure (unsafeCoerce# x) 76 77instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where 78 getClosureData x = return $ 79 IntClosure { ptipe = PInt, intVal = I# x } 80 81instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where 82 getClosureData x = return $ 83 WordClosure { ptipe = PWord, wordVal = W# x } 84 85instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where 86 getClosureData x = return $ 87 Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) } 88 89instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where 90 getClosureData x = return $ 91 Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) } 92 93instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where 94 getClosureData x = return $ 95 AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) } 96 97instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where 98 getClosureData x = return $ 99 FloatClosure { ptipe = PFloat, floatVal = F# x } 100 101instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where 102 getClosureData x = return $ 103 DoubleClosure { ptipe = PDouble, doubleVal = D# x } 104 105-- | This returns the raw representation of the given argument. The second 106-- component of the triple is the raw words of the closure on the heap, and the 107-- third component is those words that are actually pointers. Once back in the 108-- Haskell world, the raw words that hold pointers may be outdated after a 109-- garbage collector run, but the corresponding values in 'Box's will still 110-- point to the correct value. 111getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box]) 112getClosureRaw x = do 113 case unpackClosure# x of 114-- This is a hack to cover the bootstrap compiler using the old version of 115-- 'unpackClosure'. The new 'unpackClosure' return values are not merely 116-- a reordering, so using the old version would not work. 117 (# iptr, dat, pointers #) -> do 118 let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE 119 end = fromIntegral nelems - 1 120 rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ] 121 pelems = I# (sizeofArray# pointers) 122 ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers 123 pure (Ptr iptr, rawWds, ptrList) 124 125-- From compiler/ghci/RtClosureInspect.hs 126amap' :: (t -> b) -> Array Int t -> [b] 127amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] 128 where g (I# i#) = case indexArray# arr# i# of 129 (# e #) -> f e 130 131-- | This function returns a parsed heap representation of the argument _at 132-- this moment_, even if it is unevaluated or an indirection or other exotic 133-- stuff. Beware when passing something to this function, the same caveats as 134-- for 'asBox' apply. 135getClosure :: a -> IO Closure 136getClosure x = do 137 (iptr, wds, pts) <- getClosureRaw x 138 itbl <- peekItbl iptr 139 -- The remaining words after the header 140 let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds 141 -- For data args in a pointers then non-pointers closure 142 -- This is incorrect in non pointers-first setups 143 -- not sure if that happens 144 npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds 145 case tipe itbl of 146 t | t >= CONSTR && t <= CONSTR_NOCAF -> do 147 (p, m, n) <- dataConNames iptr 148 if m == "ByteCodeInstr" && n == "BreakInfo" 149 then pure $ UnsupportedClosure itbl 150 else pure $ ConstrClosure itbl pts npts p m n 151 152 t | t >= THUNK && t <= THUNK_STATIC -> do 153 pure $ ThunkClosure itbl pts npts 154 155 THUNK_SELECTOR -> do 156 unless (length pts >= 1) $ 157 fail "Expected at least 1 ptr argument to THUNK_SELECTOR" 158 pure $ SelectorClosure itbl (head pts) 159 160 t | t >= FUN && t <= FUN_STATIC -> do 161 pure $ FunClosure itbl pts npts 162 163 AP -> do 164 unless (length pts >= 1) $ 165 fail "Expected at least 1 ptr argument to AP" 166 -- We expect at least the arity, n_args, and fun fields 167 unless (length rawWds >= 2) $ 168 fail $ "Expected at least 2 raw words to AP" 169 let splitWord = rawWds !! 0 170 pure $ APClosure itbl 171#if defined(WORDS_BIGENDIAN) 172 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) 173 (fromIntegral splitWord) 174#else 175 (fromIntegral splitWord) 176 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) 177#endif 178 (head pts) (tail pts) 179 180 PAP -> do 181 unless (length pts >= 1) $ 182 fail "Expected at least 1 ptr argument to PAP" 183 -- We expect at least the arity, n_args, and fun fields 184 unless (length rawWds >= 2) $ 185 fail "Expected at least 2 raw words to PAP" 186 let splitWord = rawWds !! 0 187 pure $ PAPClosure itbl 188#if defined(WORDS_BIGENDIAN) 189 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) 190 (fromIntegral splitWord) 191#else 192 (fromIntegral splitWord) 193 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) 194#endif 195 (head pts) (tail pts) 196 197 AP_STACK -> do 198 unless (length pts >= 1) $ 199 fail "Expected at least 1 ptr argument to AP_STACK" 200 pure $ APStackClosure itbl (head pts) (tail pts) 201 202 IND -> do 203 unless (length pts >= 1) $ 204 fail "Expected at least 1 ptr argument to IND" 205 pure $ IndClosure itbl (head pts) 206 207 IND_STATIC -> do 208 unless (length pts >= 1) $ 209 fail "Expected at least 1 ptr argument to IND_STATIC" 210 pure $ IndClosure itbl (head pts) 211 212 BLACKHOLE -> do 213 unless (length pts >= 1) $ 214 fail "Expected at least 1 ptr argument to BLACKHOLE" 215 pure $ BlackholeClosure itbl (head pts) 216 217 BCO -> do 218 unless (length pts >= 3) $ 219 fail $ "Expected at least 3 ptr argument to BCO, found " 220 ++ show (length pts) 221 unless (length rawWds >= 4) $ 222 fail $ "Expected at least 4 words to BCO, found " 223 ++ show (length rawWds) 224 let splitWord = rawWds !! 3 225 pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) 226#if defined(WORDS_BIGENDIAN) 227 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) 228 (fromIntegral splitWord) 229#else 230 (fromIntegral splitWord) 231 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) 232#endif 233 (drop 4 rawWds) 234 235 ARR_WORDS -> do 236 unless (length rawWds >= 1) $ 237 fail $ "Expected at least 1 words to ARR_WORDS, found " 238 ++ show (length rawWds) 239 pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds) 240 241 t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do 242 unless (length rawWds >= 2) $ 243 fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " 244 ++ "found " ++ show (length rawWds) 245 pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts 246 247 t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do 248 unless (length rawWds >= 1) $ 249 fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* " 250 ++ "found " ++ show (length rawWds) 251 pure $ SmallMutArrClosure itbl (rawWds !! 0) pts 252 253 t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> 254 pure $ MutVarClosure itbl (head pts) 255 256 t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do 257 unless (length pts >= 3) $ 258 fail $ "Expected at least 3 ptrs to MVAR, found " 259 ++ show (length pts) 260 pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) 261 262 BLOCKING_QUEUE -> 263 pure $ OtherClosure itbl pts wds 264 -- pure $ BlockingQueueClosure itbl 265 -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3) 266 267 -- pure $ OtherClosure itbl pts wds 268 -- 269 270 WEAK -> 271 pure $ WeakClosure 272 { info = itbl 273 , cfinalizers = pts !! 0 274 , key = pts !! 1 275 , value = pts !! 2 276 , finalizer = pts !! 3 277 , link = pts !! 4 278 } 279 280 _ -> 281 pure $ UnsupportedClosure itbl 282 283-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with. 284getBoxedClosureData :: Box -> IO Closure 285getBoxedClosureData (Box a) = getClosureData a 286