never executed always true always false
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE BangPatterns #-}
3
4 -- -----------------------------------------------------------------------------
5 --
6 -- (c) The University of Glasgow 1993-2004
7 --
8 -- The native code generator's monad.
9 --
10 -- -----------------------------------------------------------------------------
11
12 module GHC.CmmToAsm.Monad (
13 NcgImpl(..),
14 NatM_State(..), mkNatM_State,
15
16 NatM, -- instance Monad
17 initNat,
18 addImportNat,
19 addNodeBetweenNat,
20 addImmediateSuccessorNat,
21 updateCfgNat,
22 getUniqueNat,
23 mapAccumLNat,
24 setDeltaNat,
25 getConfig,
26 getPlatform,
27 getDeltaNat,
28 getThisModuleNat,
29 getBlockIdNat,
30 getNewLabelNat,
31 getNewRegNat,
32 getNewRegPairNat,
33 getPicBaseMaybeNat,
34 getPicBaseNat,
35 getCfgWeights,
36 getModLoc,
37 getFileId,
38 getDebugBlock,
39
40 DwarfFiles
41 )
42
43 where
44
45 import GHC.Prelude
46
47 import GHC.Platform
48 import GHC.Platform.Reg
49 import GHC.CmmToAsm.Format
50 import GHC.CmmToAsm.Reg.Target
51 import GHC.CmmToAsm.Config
52 import GHC.CmmToAsm.Types
53
54 import GHC.Cmm.BlockId
55 import GHC.Cmm.Dataflow.Collections
56 import GHC.Cmm.Dataflow.Label
57 import GHC.Cmm.CLabel ( CLabel )
58 import GHC.Cmm.DebugBlock
59 import GHC.Data.FastString ( FastString )
60 import GHC.Types.Unique.FM
61 import GHC.Types.Unique.Supply
62 import GHC.Types.Unique ( Unique )
63 import GHC.Unit.Module
64
65 import Control.Monad ( ap )
66
67 import GHC.Utils.Outputable (SDoc, ppr)
68 import GHC.Utils.Panic (pprPanic)
69 import GHC.CmmToAsm.CFG
70 import GHC.CmmToAsm.CFG.Weight
71
72 data NcgImpl statics instr jumpDest = NcgImpl {
73 ncgConfig :: !NCGConfig,
74 cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
75 generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
76 getJumpDestBlockId :: jumpDest -> Maybe BlockId,
77 canShortcut :: instr -> Maybe jumpDest,
78 shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
79 shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
80 -- | 'Module' is only for printing internal labels. See Note [Internal proc
81 -- labels] in CLabel.
82 pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc,
83 maxSpillSlots :: Int,
84 allocatableRegs :: [RealReg],
85 ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
86 ncgAllocMoreStack :: Int -> NatCmmDecl statics instr
87 -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
88 -- ^ The list of block ids records the redirected jumps to allow us to update
89 -- the CFG.
90 ncgMakeFarBranches :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
91 extractUnwindPoints :: [instr] -> [UnwindPoint],
92 -- ^ given the instruction sequence of a block, produce a list of
93 -- the block's 'UnwindPoint's
94 -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
95 -- and Note [Unwinding information in the NCG] in this module.
96 invertCondBranches :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
97 -> [NatBasicBlock instr]
98 -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@
99 -- when possible.
100 }
101
102 data NatM_State
103 = NatM_State {
104 natm_us :: UniqSupply,
105 natm_delta :: Int,
106 natm_imports :: [(CLabel)],
107 natm_pic :: Maybe Reg,
108 natm_config :: NCGConfig,
109 natm_modloc :: ModLocation,
110 natm_fileid :: DwarfFiles,
111 natm_debug_map :: LabelMap DebugBlock,
112 natm_cfg :: CFG
113 -- ^ Having a CFG with additional information is essential for some
114 -- operations. However we can't reconstruct all information once we
115 -- generated instructions. So instead we update the CFG as we go.
116 }
117
118 type DwarfFiles = UniqFM FastString (FastString, Int)
119
120 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
121 deriving (Functor)
122
123 unNat :: NatM a -> NatM_State -> (a, NatM_State)
124 unNat (NatM a) = a
125
126 mkNatM_State :: UniqSupply -> Int -> NCGConfig -> ModLocation ->
127 DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
128 mkNatM_State us delta config
129 = \loc dwf dbg cfg ->
130 NatM_State
131 { natm_us = us
132 , natm_delta = delta
133 , natm_imports = []
134 , natm_pic = Nothing
135 , natm_config = config
136 , natm_modloc = loc
137 , natm_fileid = dwf
138 , natm_debug_map = dbg
139 , natm_cfg = cfg
140 }
141
142 initNat :: NatM_State -> NatM a -> (a, NatM_State)
143 initNat init_st m
144 = case unNat m init_st of { (r,st) -> (r,st) }
145
146 instance Applicative NatM where
147 pure = returnNat
148 (<*>) = ap
149
150 instance Monad NatM where
151 (>>=) = thenNat
152
153 instance MonadUnique NatM where
154 getUniqueSupplyM = NatM $ \st ->
155 case splitUniqSupply (natm_us st) of
156 (us1, us2) -> (us1, st {natm_us = us2})
157
158 getUniqueM = NatM $ \st ->
159 case takeUniqFromSupply (natm_us st) of
160 (uniq, us') -> (uniq, st {natm_us = us'})
161
162 thenNat :: NatM a -> (a -> NatM b) -> NatM b
163 thenNat expr cont
164 = NatM $ \st -> case unNat expr st of
165 (result, st') -> unNat (cont result) st'
166
167 returnNat :: a -> NatM a
168 returnNat result
169 = NatM $ \st -> (result, st)
170
171 mapAccumLNat :: (acc -> x -> NatM (acc, y))
172 -> acc
173 -> [x]
174 -> NatM (acc, [y])
175
176 mapAccumLNat _ b []
177 = return (b, [])
178 mapAccumLNat f b (x:xs)
179 = do (b__2, x__2) <- f b x
180 (b__3, xs__2) <- mapAccumLNat f b__2 xs
181 return (b__3, x__2:xs__2)
182
183 getUniqueNat :: NatM Unique
184 getUniqueNat = NatM $ \ st ->
185 case takeUniqFromSupply $ natm_us st of
186 (uniq, us') -> (uniq, st {natm_us = us'})
187
188 getDeltaNat :: NatM Int
189 getDeltaNat = NatM $ \ st -> (natm_delta st, st)
190
191 -- | Get CFG edge weights
192 getCfgWeights :: NatM Weights
193 getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st)
194
195 setDeltaNat :: Int -> NatM ()
196 setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
197
198 getThisModuleNat :: NatM Module
199 getThisModuleNat = NatM $ \ st -> (ncgThisModule $ natm_config st, st)
200
201 instance HasModule NatM where
202 getModule = getThisModuleNat
203
204 addImportNat :: CLabel -> NatM ()
205 addImportNat imp
206 = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
207
208 updateCfgNat :: (CFG -> CFG) -> NatM ()
209 updateCfgNat f
210 = NatM $ \ st -> let !cfg' = f (natm_cfg st)
211 in ((), st { natm_cfg = cfg'})
212
213 -- | Record that we added a block between `from` and `old`.
214 addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
215 addNodeBetweenNat from between to
216 = do weights <- getCfgWeights
217 let jmpWeight = fromIntegral (uncondWeight weights)
218 updateCfgNat (updateCfg jmpWeight from between to)
219 where
220 -- When transforming A -> B to A -> A' -> B
221 -- A -> A' keeps the old edge info while
222 -- A' -> B gets the info for an unconditional
223 -- jump.
224 updateCfg weight from between old m
225 | Just info <- getEdgeInfo from old m
226 = addEdge from between info .
227 addWeightEdge between old weight .
228 delEdge from old $ m
229 | otherwise
230 = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to))
231
232
233 -- | Place `succ` after `block` and change any edges
234 -- block -> X to `succ` -> X
235 addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
236 addImmediateSuccessorNat block succ = do
237 weights <- getCfgWeights
238 updateCfgNat (addImmediateSuccessor weights block succ)
239
240 getBlockIdNat :: NatM BlockId
241 getBlockIdNat
242 = do u <- getUniqueNat
243 return (mkBlockId u)
244
245
246 getNewLabelNat :: NatM CLabel
247 getNewLabelNat
248 = blockLbl <$> getBlockIdNat
249
250
251 getNewRegNat :: Format -> NatM Reg
252 getNewRegNat rep
253 = do u <- getUniqueNat
254 platform <- getPlatform
255 return (RegVirtual $ targetMkVirtualReg platform u rep)
256
257
258 getNewRegPairNat :: Format -> NatM (Reg,Reg)
259 getNewRegPairNat rep
260 = do u <- getUniqueNat
261 platform <- getPlatform
262 let vLo = targetMkVirtualReg platform u rep
263 let lo = RegVirtual $ targetMkVirtualReg platform u rep
264 let hi = RegVirtual $ getHiVirtualRegFromLo vLo
265 return (lo, hi)
266
267
268 getPicBaseMaybeNat :: NatM (Maybe Reg)
269 getPicBaseMaybeNat
270 = NatM (\state -> (natm_pic state, state))
271
272
273 getPicBaseNat :: Format -> NatM Reg
274 getPicBaseNat rep
275 = do mbPicBase <- getPicBaseMaybeNat
276 case mbPicBase of
277 Just picBase -> return picBase
278 Nothing
279 -> do
280 reg <- getNewRegNat rep
281 NatM (\state -> (reg, state { natm_pic = Just reg }))
282
283 getModLoc :: NatM ModLocation
284 getModLoc
285 = NatM $ \ st -> (natm_modloc st, st)
286
287 -- | Get native code generator configuration
288 getConfig :: NatM NCGConfig
289 getConfig = NatM $ \st -> (natm_config st, st)
290
291 -- | Get target platform from native code generator configuration
292 getPlatform :: NatM Platform
293 getPlatform = ncgPlatform <$> getConfig
294
295 getFileId :: FastString -> NatM Int
296 getFileId f = NatM $ \st ->
297 case lookupUFM (natm_fileid st) f of
298 Just (_,n) -> (n, st)
299 Nothing -> let n = 1 + sizeUFM (natm_fileid st)
300 fids = addToUFM (natm_fileid st) f (f,n)
301 in n `seq` fids `seq` (n, st { natm_fileid = fids })
302
303 getDebugBlock :: Label -> NatM (Maybe DebugBlock)
304 getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)