1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
module GHC.Exts.Heap.Closures (
-- * Closures
Closure
, GenClosure(..)
, PrimType(..)
, allClosures
#if __GLASGOW_HASKELL__ >= 809
-- The closureSize# primop is unsupported on earlier GHC releases but we
-- build ghc-heap as a boot library so it must be buildable. Drop this once
-- we are guaranteed to bootstsrap with GHC >= 8.9.
, closureSize
#endif
-- * Boxes
, Box(..)
, areBoxesEqual
, asBox
) where
import Prelude -- See note [Why do we import Prelude here?]
import GHC.Exts.Heap.Constants
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
-- `ghc -M` currently doesn't properly account for ways when generating
-- dependencies (#15197). This import ensures correct build-ordering between
-- this module and GHC.Exts.Heap.InfoTableProf. It should be removed when #15197
-- is fixed.
import GHC.Exts.Heap.InfoTableProf ()
#endif
import Data.Bits
import Data.Int
import Data.Word
import GHC.Exts
import GHC.Generics
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://ghc.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://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>
-- 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 contents
}
-- | 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, Generic, Functor, Foldable, Traversable)
data PrimType
= PInt
| PWord
| PInt64
| PWord64
| PAddr
| PFloat
| PDouble
deriving (Eq, Show, Generic)
-- | 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 _ = []
#if __GLASGOW_HASKELL__ >= 809
-- | Get the size of a closure in words.
--
-- @since 8.10.1
closureSize :: Box -> Int
closureSize (Box x) = I# (closureSize# x)
#endif
|