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
|
{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}
--
-- (c) The University of Glasgow 2002-2006
--
-- | Bytecode assembler types
module ByteCodeTypes
( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
, CgBreakInfo(..)
, ModBreaks (..), BreakIndex, emptyModBreaks
, CCostCentre
) where
import GhcPrelude
import FastString
import Id
import Name
import NameEnv
import Outputable
import PrimOp
import SizedSeq
import Type
import SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.FFI
import Control.DeepSeq
import Foreign
import Data.Array
import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.ByteString.Short (ShortByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Maybe (catMaybes)
import GHC.Exts.Heap
import GHC.Stack.CCS
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
data CompiledByteCode = CompiledByteCode
{ bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings
, bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls
, bc_ffis :: [FFIInfo] -- ffi blocks we allocated
, bc_strs :: [RemotePtr ()] -- malloc'd strings
, bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
-- creating breakpoints, for some reason)
}
-- ToDo: we're not tracking strings that we malloc'd
newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
deriving (Show, NFData)
instance Outputable CompiledByteCode where
ppr CompiledByteCode{..} = ppr bc_bcos
-- Not a real NFData instance, because ModBreaks contains some things
-- we can't rnf
seqCompiledByteCode :: CompiledByteCode -> ()
seqCompiledByteCode CompiledByteCode{..} =
rnf bc_bcos `seq`
rnf (nameEnvElts bc_itbls) `seq`
rnf bc_ffis `seq`
rnf bc_strs `seq`
rnf (fmap seqModBreaks bc_breaks)
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)
deriving (Show, NFData)
data UnlinkedBCO
= UnlinkedBCO {
unlinkedBCOName :: !Name,
unlinkedBCOArity :: {-# UNPACK #-} !Int,
unlinkedBCOInstrs :: !(UArray Int Word16), -- insns
unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap
unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs
unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs
}
instance NFData UnlinkedBCO where
rnf UnlinkedBCO{..} =
rnf unlinkedBCOLits `seq`
rnf unlinkedBCOPtrs
data BCOPtr
= BCOPtrName !Name
| BCOPtrPrimOp !PrimOp
| BCOPtrBCO !UnlinkedBCO
| BCOPtrBreakArray -- a pointer to this module's BreakArray
instance NFData BCOPtr where
rnf (BCOPtrBCO bco) = rnf bco
rnf x = x `seq` ()
data BCONPtr
= BCONPtrWord {-# UNPACK #-} !Word
| BCONPtrLbl !FastString
| BCONPtrItbl !Name
| BCONPtrStr !ShortByteString
instance NFData BCONPtr where
rnf x = x `seq` ()
-- | Information about a breakpoint that we know at code-generation time
data CgBreakInfo
= CgBreakInfo
{ cgb_vars :: [Maybe (Id,Word16)]
, cgb_resty :: Type
}
-- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs
-- Not a real NFData instance because we can't rnf Id or Type
seqCgBreakInfo :: CgBreakInfo -> ()
seqCgBreakInfo CgBreakInfo{..} =
rnf (map snd (catMaybes (cgb_vars))) `seq`
seqType cgb_resty
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
= sep [text "BCO", ppr nm, text "with",
ppr (sizeSS lits), text "lits",
ppr (sizeSS ptrs), text "ptrs" ]
instance Outputable CgBreakInfo where
ppr info = text "CgBreakInfo" <+>
parens (ppr (cgb_vars info) <+>
ppr (cgb_resty info))
-- -----------------------------------------------------------------------------
-- Breakpoints
-- | Breakpoint index
type BreakIndex = Int
-- | C CostCentre type
data CCostCentre
-- | All the information about the breakpoints for a module
data ModBreaks
= ModBreaks
{ modBreaks_flags :: ForeignRef BreakArray
-- ^ The array of flags, one per breakpoint,
-- indicating which breakpoints are enabled.
, modBreaks_locs :: !(Array BreakIndex SrcSpan)
-- ^ An array giving the source span of each breakpoint.
, modBreaks_vars :: !(Array BreakIndex [OccName])
-- ^ An array giving the names of the free variables at each breakpoint.
, modBreaks_decls :: !(Array BreakIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
, modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre))
-- ^ Array pointing to cost centre for each breakpoint
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
}
seqModBreaks :: ModBreaks -> ()
seqModBreaks ModBreaks{..} =
rnf modBreaks_flags `seq`
rnf modBreaks_locs `seq`
rnf modBreaks_vars `seq`
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo)
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
emptyModBreaks = ModBreaks
{ modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
-- ToDo: can we avoid this?
, modBreaks_locs = array (0,-1) []
, modBreaks_vars = array (0,-1) []
, modBreaks_decls = array (0,-1) []
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
}
|
