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