never executed always true always false
1
2
3 -----------------------------------------------------------------------------
4 --
5 -- Code generator utilities; mostly monadic
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10
11 module GHC.StgToCmm.Utils (
12 emitDataLits, emitRODataLits,
13 emitDataCon,
14 emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
15 assignTemp,
16
17 newUnboxedTupleRegs,
18
19 emitMultiAssign, emitCmmLitSwitch, emitSwitch,
20
21 tagToClosure, mkTaggedObjectLoad,
22
23 callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
24 callerSaveGlobalReg, callerRestoreGlobalReg,
25
26 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
27 cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
28 cmmOffsetExprW, cmmOffsetExprB,
29 cmmRegOffW, cmmRegOffB,
30 cmmLabelOffW, cmmLabelOffB,
31 cmmOffsetW, cmmOffsetB,
32 cmmOffsetLitW, cmmOffsetLitB,
33 cmmLoadIndexW,
34 cmmConstrTag1,
35
36 cmmUntag, cmmIsTagged,
37
38 addToMem, addToMemE, addToMemLblE, addToMemLbl,
39
40 -- * Update remembered set operations
41 whenUpdRemSetEnabled,
42 emitUpdRemSetPush,
43 emitUpdRemSetPushThunk,
44
45 convertInfoProvMap, cmmInfoTableToInfoProvEnt
46 ) where
47
48 import GHC.Prelude
49
50 import GHC.Platform
51 import GHC.StgToCmm.Monad
52 import GHC.StgToCmm.Closure
53 import GHC.StgToCmm.Lit (mkSimpleLit)
54 import GHC.Cmm
55 import GHC.Cmm.BlockId
56 import GHC.Cmm.Graph as CmmGraph
57 import GHC.Platform.Regs
58 import GHC.Cmm.CLabel
59 import GHC.Cmm.Utils
60 import GHC.Cmm.Switch
61 import GHC.StgToCmm.CgUtils
62
63 import GHC.Types.ForeignCall
64 import GHC.Types.Id.Info
65 import GHC.Core.Type
66 import GHC.Core.TyCon
67 import GHC.Runtime.Heap.Layout
68 import GHC.Unit
69 import GHC.Types.Literal
70 import GHC.Data.Graph.Directed
71 import GHC.Utils.Misc
72 import GHC.Types.Unique
73 import GHC.Driver.Session
74 import GHC.Data.FastString
75 import GHC.Utils.Outputable
76 import GHC.Utils.Panic
77 import GHC.Utils.Panic.Plain
78 import GHC.Types.RepType
79 import GHC.Types.CostCentre
80 import GHC.Types.IPE
81
82 import qualified Data.Map as M
83 import Data.List (sortBy)
84 import Data.Ord
85 import GHC.Types.Unique.Map
86 import Data.Maybe
87 import GHC.Driver.Ppr
88 import qualified Data.List.NonEmpty as NE
89 import GHC.Core.DataCon
90 import GHC.Types.Unique.FM
91 import GHC.Data.Maybe
92 import Control.Monad
93 import qualified Data.Map.Strict as Map
94
95 --------------------------------------------------------------------------
96 --
97 -- Incrementing a memory location
98 --
99 --------------------------------------------------------------------------
100
101 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
102 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
103
104 addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
105 addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
106
107 addToMem :: CmmType -- rep of the counter
108 -> CmmExpr -- Address
109 -> Int -- What to add (a word)
110 -> CmmAGraph
111 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
112
113 addToMemE :: CmmType -- rep of the counter
114 -> CmmExpr -- Address
115 -> CmmExpr -- What to add (a word-typed expression)
116 -> CmmAGraph
117 addToMemE rep ptr n
118 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
119
120
121 -------------------------------------------------------------------------
122 --
123 -- Loading a field from an object,
124 -- where the object pointer is itself tagged
125 --
126 -------------------------------------------------------------------------
127
128 mkTaggedObjectLoad
129 :: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
130 -- (loadTaggedObjectField reg base off tag) generates assignment
131 -- reg = bitsK[ base + off - tag ]
132 -- where K is fixed by 'reg'
133 mkTaggedObjectLoad platform reg base offset tag
134 = mkAssign (CmmLocal reg)
135 (CmmLoad (cmmOffsetB platform
136 (CmmReg (CmmLocal base))
137 (offset - tag))
138 (localRegType reg))
139
140 -------------------------------------------------------------------------
141 --
142 -- Converting a closure tag to a closure for enumeration types
143 -- (this is the implementation of tagToEnum#).
144 --
145 -------------------------------------------------------------------------
146
147 tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
148 tagToClosure platform tycon tag
149 = CmmLoad (cmmOffsetExprW platform closure_tbl tag) (bWord platform)
150 where closure_tbl = CmmLit (CmmLabel lbl)
151 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
152
153 -------------------------------------------------------------------------
154 --
155 -- Conditionals and rts calls
156 --
157 -------------------------------------------------------------------------
158
159 emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
160 emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
161
162 emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
163 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
164 emitRtsCallWithResult res hint pkg fun args safe
165 = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
166
167 -- Make a call to an RTS C procedure
168 emitRtsCallGen
169 :: [(LocalReg,ForeignHint)]
170 -> CLabel
171 -> [(CmmExpr,ForeignHint)]
172 -> Bool -- True <=> CmmSafe call
173 -> FCode ()
174 emitRtsCallGen res lbl args safe
175 = do { platform <- targetPlatform <$> getDynFlags
176 ; updfr_off <- getUpdFrameOff
177 ; let (caller_save, caller_load) = callerSaveVolatileRegs platform
178 ; emit caller_save
179 ; call updfr_off
180 ; emit caller_load }
181 where
182 call updfr_off =
183 if safe then
184 emit =<< mkCmmCall fun_expr res' args' updfr_off
185 else do
186 let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
187 emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
188 (args', arg_hints) = unzip args
189 (res', res_hints) = unzip res
190 fun_expr = mkLblExpr lbl
191
192
193 -----------------------------------------------------------------------------
194 --
195 -- Caller-Save Registers
196 --
197 -----------------------------------------------------------------------------
198
199 -- Here we generate the sequence of saves/restores required around a
200 -- foreign call instruction.
201
202 -- TODO: reconcile with rts/include/Regs.h
203 -- * Regs.h claims that BaseReg should be saved last and loaded first
204 -- * This might not have been tickled before since BaseReg is callee save
205 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
206 --
207 -- This code isn't actually used right now, because callerSaves
208 -- only ever returns true in the current universe for registers NOT in
209 -- system_regs (just do a grep for CALLER_SAVES in
210 -- rts/include/stg/MachRegs.h). It's all one giant no-op, and for
211 -- good reason: having to save system registers on every foreign call
212 -- would be very expensive, so we avoid assigning them to those
213 -- registers when we add support for an architecture.
214 --
215 -- Note that the old code generator actually does more work here: it
216 -- also saves other global registers. We can't (nor want) to do that
217 -- here, as we don't have liveness information. And really, we
218 -- shouldn't be doing the workaround at this point in the pipeline, see
219 -- Note [Register parameter passing] and the ToDo on CmmCall in
220 -- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across
221 -- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly
222 -- temporary.
223 callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
224 callerSaveVolatileRegs platform = (caller_save, caller_load)
225 where
226 caller_save = catAGraphs (map (callerSaveGlobalReg platform) regs_to_save)
227 caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save)
228
229 system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
230 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
231 , BaseReg ]
232
233 regs_to_save = filter (callerSaves platform) system_regs
234
235 callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph
236 callerSaveGlobalReg platform reg
237 = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg))
238
239 callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
240 callerRestoreGlobalReg platform reg
241 = mkAssign (CmmGlobal reg)
242 (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType platform reg))
243
244
245 -------------------------------------------------------------------------
246 --
247 -- Strings generate a top-level data block
248 --
249 -------------------------------------------------------------------------
250
251 -- | Emit a data-segment data block
252 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
253 emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
254
255 -- | Emit a read-only data block
256 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
257 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
258
259 emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
260 emitDataCon lbl itbl ccs payload =
261 emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
262
263 -------------------------------------------------------------------------
264 --
265 -- Assigning expressions to temporaries
266 --
267 -------------------------------------------------------------------------
268
269 assignTemp :: CmmExpr -> FCode LocalReg
270 -- Make sure the argument is in a local register.
271 -- We don't bother being particularly aggressive with avoiding
272 -- unnecessary local registers, since we can rely on a later
273 -- optimization pass to inline as necessary (and skipping out
274 -- on things like global registers can be a little dangerous
275 -- due to them being trashed on foreign calls--though it means
276 -- the optimization pass doesn't have to do as much work)
277 assignTemp (CmmReg (CmmLocal reg)) = return reg
278 assignTemp e = do { platform <- getPlatform
279 ; reg <- newTemp (cmmExprType platform e)
280 ; emitAssign (CmmLocal reg) e
281 ; return reg }
282
283 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
284 -- Choose suitable local regs to use for the components
285 -- of an unboxed tuple that we are about to return to
286 -- the Sequel. If the Sequel is a join point, using the
287 -- regs it wants will save later assignments.
288 newUnboxedTupleRegs res_ty
289 = assert (isUnboxedTupleType res_ty) $
290 do { platform <- getPlatform
291 ; sequel <- getSequel
292 ; regs <- choose_regs platform sequel
293 ; massert (regs `equalLength` reps)
294 ; return (regs, map primRepForeignHint reps) }
295 where
296 reps = typePrimRep res_ty
297 choose_regs _ (AssignTo regs _) = return regs
298 choose_regs platform _ = mapM (newTemp . primRepCmmType platform) reps
299
300
301
302 -------------------------------------------------------------------------
303 -- emitMultiAssign
304 -------------------------------------------------------------------------
305
306 emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
307 -- Emit code to perform the assignments in the
308 -- input simultaneously, using temporary variables when necessary.
309
310 type Key = Int
311 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
312 -- for fast comparison
313 type Stmt = (LocalReg, CmmExpr) -- r := e
314
315 -- We use the strongly-connected component algorithm, in which
316 -- * the vertices are the statements
317 -- * an edge goes from s1 to s2 iff
318 -- s1 assigns to something s2 uses
319 -- that is, if s1 should *follow* s2 in the final order
320
321 emitMultiAssign [] [] = return ()
322 emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
323 emitMultiAssign regs rhss = do
324 platform <- getPlatform
325 assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $
326 unscramble platform ([1..] `zip` (regs `zip` rhss))
327
328 unscramble :: Platform -> [Vrtx] -> FCode ()
329 unscramble platform vertices = mapM_ do_component components
330 where
331 edges :: [ Node Key Vrtx ]
332 edges = [ DigraphNode vertex key1 (edges_from stmt1)
333 | vertex@(key1, stmt1) <- vertices ]
334
335 edges_from :: Stmt -> [Key]
336 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
337 stmt1 `mustFollow` stmt2 ]
338
339 components :: [SCC Vrtx]
340 components = stronglyConnCompFromEdgedVerticesUniq edges
341
342 -- do_components deal with one strongly-connected component
343 -- Not cyclic, or singleton? Just do it
344 do_component :: SCC Vrtx -> FCode ()
345 do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
346 do_component (CyclicSCC []) = panic "do_component"
347 do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
348
349 -- Cyclic? Then go via temporaries. Pick one to
350 -- break the loop and try again with the rest.
351 do_component (CyclicSCC ((_,first_stmt) : rest)) = do
352 u <- newUnique
353 let (to_tmp, from_tmp) = split u first_stmt
354 mk_graph to_tmp
355 unscramble platform rest
356 mk_graph from_tmp
357
358 split :: Unique -> Stmt -> (Stmt, Stmt)
359 split uniq (reg, rhs)
360 = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
361 where
362 rep = cmmExprType platform rhs
363 tmp = LocalReg uniq rep
364
365 mk_graph :: Stmt -> FCode ()
366 mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
367
368 mustFollow :: Stmt -> Stmt -> Bool
369 (reg, _) `mustFollow` (_, rhs) = regUsedIn platform (CmmLocal reg) rhs
370
371 -------------------------------------------------------------------------
372 -- mkSwitch
373 -------------------------------------------------------------------------
374
375
376 emitSwitch :: CmmExpr -- Tag to switch on
377 -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
378 -> Maybe CmmAGraphScoped -- Default branch (if any)
379 -> ConTagZ -> ConTagZ -- Min and Max possible values;
380 -- behaviour outside this range is
381 -- undefined
382 -> FCode ()
383
384 -- First, two rather common cases in which there is no work to do
385 emitSwitch _ [] (Just code) _ _ = emit (fst code)
386 emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code)
387
388 -- Right, off we go
389 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
390 join_lbl <- newBlockId
391 mb_deflt_lbl <- label_default join_lbl mb_deflt
392 branches_lbls <- label_branches join_lbl branches
393 tag_expr' <- assignTemp' tag_expr
394
395 -- Sort the branches before calling mk_discrete_switch
396 let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
397 let range = (fromIntegral lo_tag, fromIntegral hi_tag)
398
399 emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
400
401 emitLabel join_lbl
402
403 mk_discrete_switch :: Bool -- ^ Use signed comparisons
404 -> CmmExpr
405 -> [(Integer, BlockId)]
406 -> Maybe BlockId
407 -> (Integer, Integer)
408 -> CmmAGraph
409
410 -- SINGLETON TAG RANGE: no case analysis to do
411 mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
412 | lo_tag == hi_tag
413 = assert (tag == lo_tag) $
414 mkBranch lbl
415
416 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
417 mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
418 = mkBranch lbl
419 -- The simplifier might have eliminated a case
420 -- so we may have e.g. case xs of
421 -- [] -> e
422 -- In that situation we can be sure the (:) case
423 -- can't happen, so no need to test
424
425 -- SOMETHING MORE COMPLICATED: defer to GHC.Cmm.Switch.Implement
426 -- See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch
427 mk_discrete_switch signed tag_expr branches mb_deflt range
428 = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
429
430 divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
431 divideBranches branches = (lo_branches, mid, hi_branches)
432 where
433 -- 2 branches => n_branches `div` 2 = 1
434 -- => branches !! 1 give the *second* tag
435 -- There are always at least 2 branches here
436 (mid,_) = branches !! (length branches `div` 2)
437 (lo_branches, hi_branches) = span is_lo branches
438 is_lo (t,_) = t < mid
439
440 --------------
441 emitCmmLitSwitch :: CmmExpr -- Tag to switch on
442 -> [(Literal, CmmAGraphScoped)] -- Tagged branches
443 -> CmmAGraphScoped -- Default branch (always)
444 -> FCode () -- Emit the code
445 emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
446 emitCmmLitSwitch scrut branches deflt = do
447 scrut' <- assignTemp' scrut
448 join_lbl <- newBlockId
449 deflt_lbl <- label_code join_lbl deflt
450 branches_lbls <- label_branches join_lbl branches
451
452 platform <- getPlatform
453 let cmm_ty = cmmExprType platform scrut
454 rep = typeWidth cmm_ty
455
456 -- We find the necessary type information in the literals in the branches
457 let (signed,range) = case head branches of
458 (LitNumber nt _, _) -> (signed,range)
459 where
460 signed = litNumIsSigned nt
461 range = case litNumRange platform nt of
462 (Just mi, Just ma) -> (mi,ma)
463 -- unbounded literals (Natural and
464 -- Integer) must have been
465 -- lowered at this point
466 partial_bounds -> pprPanic "Unexpected unbounded literal range"
467 (ppr partial_bounds)
468 -- assuming native word range
469 _ -> (False, (0, platformMaxWord platform))
470
471 if isFloatType cmm_ty
472 then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
473 else emit $ mk_discrete_switch
474 signed
475 scrut'
476 [(litValue lit,l) | (lit,l) <- branches_lbls]
477 (Just deflt_lbl)
478 range
479 emitLabel join_lbl
480
481 -- | lower bound (inclusive), upper bound (exclusive)
482 type LitBound = (Maybe Literal, Maybe Literal)
483
484 noBound :: LitBound
485 noBound = (Nothing, Nothing)
486
487 mk_float_switch :: Width -> CmmExpr -> BlockId
488 -> LitBound
489 -> [(Literal,BlockId)]
490 -> FCode CmmAGraph
491 mk_float_switch rep scrut deflt _bounds [(lit,blk)]
492 = do platform <- getPlatform
493 return $ mkCbranch (cond platform) deflt blk Nothing
494 where
495 cond platform = CmmMachOp ne [scrut, CmmLit cmm_lit]
496 where
497 cmm_lit = mkSimpleLit platform lit
498 ne = MO_F_Ne rep
499
500 mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
501 = do platform <- getPlatform
502 lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
503 hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
504 mkCmmIfThenElse (cond platform) lo_blk hi_blk
505 where
506 (lo_branches, mid_lit, hi_branches) = divideBranches branches
507
508 bounds_lo = (lo_bound, Just mid_lit)
509 bounds_hi = (Just mid_lit, hi_bound)
510
511 cond platform = CmmMachOp lt [scrut, CmmLit cmm_lit]
512 where
513 cmm_lit = mkSimpleLit platform mid_lit
514 lt = MO_F_Lt rep
515
516
517 --------------
518 label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
519 label_default _ Nothing
520 = return Nothing
521 label_default join_lbl (Just code)
522 = do lbl <- label_code join_lbl code
523 return (Just lbl)
524
525 --------------
526 label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
527 label_branches _join_lbl []
528 = return []
529 label_branches join_lbl ((tag,code):branches)
530 = do lbl <- label_code join_lbl code
531 branches' <- label_branches join_lbl branches
532 return ((tag,lbl):branches')
533
534 --------------
535 label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
536 -- label_code J code
537 -- generates
538 -- [L: code; goto J]
539 -- and returns L
540 label_code join_lbl (code,tsc) = do
541 lbl <- newBlockId
542 emitOutOfLine lbl (code CmmGraph.<*> mkBranch join_lbl, tsc)
543 return lbl
544
545 --------------
546 assignTemp' :: CmmExpr -> FCode CmmExpr
547 assignTemp' e
548 | isTrivialCmmExpr e = return e
549 | otherwise = do
550 platform <- getPlatform
551 lreg <- newTemp (cmmExprType platform e)
552 let reg = CmmLocal lreg
553 emitAssign reg e
554 return (CmmReg reg)
555
556 ---------------------------------------------------------------------------
557 -- Pushing to the update remembered set
558 ---------------------------------------------------------------------------
559
560 whenUpdRemSetEnabled :: FCode a -> FCode ()
561 whenUpdRemSetEnabled code = do
562 platform <- getPlatform
563 do_it <- getCode code
564 let
565 enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord platform)
566 zero = zeroExpr platform
567 is_enabled = cmmNeWord platform enabled zero
568 the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
569 emit the_if
570
571 -- | Emit code to add an entry to a now-overwritten pointer to the update
572 -- remembered set.
573 emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten
574 -> FCode ()
575 emitUpdRemSetPush ptr =
576 emitRtsCall
577 rtsUnitId
578 (fsLit "updateRemembSetPushClosure_")
579 [(CmmReg (CmmGlobal BaseReg), AddrHint),
580 (ptr, AddrHint)]
581 False
582
583 emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
584 -> FCode ()
585 emitUpdRemSetPushThunk ptr =
586 emitRtsCall
587 rtsUnitId
588 (fsLit "updateRemembSetPushThunk_")
589 [(CmmReg (CmmGlobal BaseReg), AddrHint),
590 (ptr, AddrHint)]
591 False
592
593 -- | A bare bones InfoProvEnt for things which don't have a good source location
594 cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt
595 cmmInfoTableToInfoProvEnt this_mod cmit =
596 let cl = cit_lbl cmit
597 cn = rtsClosureType (cit_rep cmit)
598 in InfoProvEnt cl cn "" this_mod Nothing
599
600 -- | Convert source information collected about identifiers in 'GHC.STG.Debug'
601 -- to entries suitable for placing into the info table provenenance table.
602 convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]
603 convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) =
604 map (\cmit ->
605 let cl = cit_lbl cmit
606 cn = rtsClosureType (cit_rep cmit)
607
608 tyString :: Outputable a => a -> String
609 tyString t = showPpr dflags t
610
611 lookupClosureMap :: Maybe InfoProvEnt
612 lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of
613 Just (ty, mbspan) -> Just (InfoProvEnt cl cn (tyString ty) this_mod mbspan)
614 Nothing -> Nothing
615
616 lookupDataConMap = do
617 UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation
618 -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do
619 (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique)
620 -- Lookup is linear but lists will be small (< 100)
621 return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))
622
623 lookupInfoTableToSourceLocation = do
624 sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap
625 return $ InfoProvEnt cl cn "" this_mod sourceNote
626
627 -- This catches things like prim closure types and anything else which doesn't have a
628 -- source location
629 simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit
630
631 in
632 if (isStackRep . cit_rep) cmit then
633 fromMaybe simpleFallback lookupInfoTableToSourceLocation
634 else
635 fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns