Remove dead generics-related code from OccName
[ghc.git] / compiler / nativeGen / AsmCodeGen.hs
1 -- -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 1993-2004
4 --
5 -- This is the top-level module in the native code generator.
6 --
7 -- -----------------------------------------------------------------------------
8
9 {-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-}
10
11 module AsmCodeGen ( nativeCodeGen ) where
12
13 #include "HsVersions.h"
14 #include "nativeGen/NCG.h"
15
16
17 import qualified X86.CodeGen
18 import qualified X86.Regs
19 import qualified X86.Instr
20 import qualified X86.Ppr
21
22 import qualified SPARC.CodeGen
23 import qualified SPARC.Regs
24 import qualified SPARC.Instr
25 import qualified SPARC.Ppr
26 import qualified SPARC.ShortcutJump
27 import qualified SPARC.CodeGen.Expand
28
29 import qualified PPC.CodeGen
30 import qualified PPC.Regs
31 import qualified PPC.RegInfo
32 import qualified PPC.Instr
33 import qualified PPC.Ppr
34
35 import RegAlloc.Liveness
36 import qualified RegAlloc.Linear.Main as Linear
37
38 import qualified GraphColor as Color
39 import qualified RegAlloc.Graph.Main as Color
40 import qualified RegAlloc.Graph.Stats as Color
41 import qualified RegAlloc.Graph.TrivColorable as Color
42
43 import TargetReg
44 import Platform
45 import Config
46 import Instruction
47 import PIC
48 import Reg
49 import NCGMonad
50 import Dwarf
51 import Debug
52
53 import BlockId
54 import CgUtils ( fixStgRegisters )
55 import Cmm
56 import CmmUtils
57 import Hoopl
58 import CmmOpt ( cmmMachOpFold )
59 import PprCmm
60 import CLabel
61
62 import UniqFM
63 import UniqSupply
64 import DynFlags
65 import Util
66 import Unique
67
68 import BasicTypes ( Alignment )
69 import Digraph
70 import qualified Pretty
71 import BufWrite
72 import Outputable
73 import FastString
74 import UniqSet
75 import ErrUtils
76 import Module
77 import Stream (Stream)
78 import qualified Stream
79
80 -- DEBUGGING ONLY
81 --import OrdList
82
83 import Data.List
84 import Data.Maybe
85 import Data.Ord ( comparing )
86 import Control.Exception
87 import Control.Monad
88 import System.IO
89
90 {-
91 The native-code generator has machine-independent and
92 machine-dependent modules.
93
94 This module ("AsmCodeGen") is the top-level machine-independent
95 module. Before entering machine-dependent land, we do some
96 machine-independent optimisations (defined below) on the
97 'CmmStmts's.
98
99 We convert to the machine-specific 'Instr' datatype with
100 'cmmCodeGen', assuming an infinite supply of registers. We then use
101 a machine-independent register allocator ('regAlloc') to rejoin
102 reality. Obviously, 'regAlloc' has machine-specific helper
103 functions (see about "RegAllocInfo" below).
104
105 Finally, we order the basic blocks of the function so as to minimise
106 the number of jumps between blocks, by utilising fallthrough wherever
107 possible.
108
109 The machine-dependent bits break down as follows:
110
111 * ["MachRegs"] Everything about the target platform's machine
112 registers (and immediate operands, and addresses, which tend to
113 intermingle/interact with registers).
114
115 * ["MachInstrs"] Includes the 'Instr' datatype (possibly should
116 have a module of its own), plus a miscellany of other things
117 (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
118
119 * ["MachCodeGen"] is where 'Cmm' stuff turns into
120 machine instructions.
121
122 * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
123 a 'SDoc').
124
125 * ["RegAllocInfo"] In the register allocator, we manipulate
126 'MRegsState's, which are 'BitSet's, one bit per machine register.
127 When we want to say something about a specific machine register
128 (e.g., ``it gets clobbered by this instruction''), we set/unset
129 its bit. Obviously, we do this 'BitSet' thing for efficiency
130 reasons.
131
132 The 'RegAllocInfo' module collects together the machine-specific
133 info needed to do register allocation.
134
135 * ["RegisterAlloc"] The (machine-independent) register allocator.
136 -}
137
138 -- -----------------------------------------------------------------------------
139 -- Top-level of the native codegen
140
141 data NcgImpl statics instr jumpDest = NcgImpl {
142 cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
143 generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
144 getJumpDestBlockId :: jumpDest -> Maybe BlockId,
145 canShortcut :: instr -> Maybe jumpDest,
146 shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
147 shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
148 pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc,
149 maxSpillSlots :: Int,
150 allocatableRegs :: [RealReg],
151 ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
152 ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
153 ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),
154 ncgMakeFarBranches :: BlockEnv CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr]
155 }
156
157 --------------------
158 nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
159 -> Stream IO RawCmmGroup ()
160 -> IO UniqSupply
161 nativeCodeGen dflags this_mod modLoc h us cmms
162 = let platform = targetPlatform dflags
163 nCG' :: (Outputable statics, Outputable instr, Instruction instr)
164 => NcgImpl statics instr jumpDest -> IO UniqSupply
165 nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
166 in case platformArch platform of
167 ArchX86 -> nCG' (x86NcgImpl dflags)
168 ArchX86_64 -> nCG' (x86_64NcgImpl dflags)
169 ArchPPC -> nCG' (ppcNcgImpl dflags)
170 ArchSPARC -> nCG' (sparcNcgImpl dflags)
171 ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64"
172 ArchARM {} -> panic "nativeCodeGen: No NCG for ARM"
173 ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64"
174 ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags)
175 ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha"
176 ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb"
177 ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel"
178 ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch"
179 ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
180
181 x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest
182 x86NcgImpl dflags
183 = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge }
184
185 x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest
186 x86_64NcgImpl dflags
187 = NcgImpl {
188 cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
189 ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
190 ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
191 ,canShortcut = X86.Instr.canShortcut
192 ,shortcutStatics = X86.Instr.shortcutStatics
193 ,shortcutJump = X86.Instr.shortcutJump
194 ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
195 ,maxSpillSlots = X86.Instr.maxSpillSlots dflags
196 ,allocatableRegs = X86.Regs.allocatableRegs platform
197 ,ncg_x86fp_kludge = id
198 ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
199 ,ncgExpandTop = id
200 ,ncgMakeFarBranches = const id
201 }
202 where platform = targetPlatform dflags
203
204 ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
205 ppcNcgImpl dflags
206 = NcgImpl {
207 cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
208 ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
209 ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
210 ,canShortcut = PPC.RegInfo.canShortcut
211 ,shortcutStatics = PPC.RegInfo.shortcutStatics
212 ,shortcutJump = PPC.RegInfo.shortcutJump
213 ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
214 ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags
215 ,allocatableRegs = PPC.Regs.allocatableRegs platform
216 ,ncg_x86fp_kludge = id
217 ,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform
218 ,ncgExpandTop = id
219 ,ncgMakeFarBranches = PPC.Instr.makeFarBranches
220 }
221 where platform = targetPlatform dflags
222
223 sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
224 sparcNcgImpl dflags
225 = NcgImpl {
226 cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
227 ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
228 ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
229 ,canShortcut = SPARC.ShortcutJump.canShortcut
230 ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
231 ,shortcutJump = SPARC.ShortcutJump.shortcutJump
232 ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl
233 ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags
234 ,allocatableRegs = SPARC.Regs.allocatableRegs
235 ,ncg_x86fp_kludge = id
236 ,ncgAllocMoreStack = noAllocMoreStack
237 ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
238 ,ncgMakeFarBranches = const id
239 }
240
241 --
242 -- Allocating more stack space for spilling is currently only
243 -- supported for the linear register allocator on x86/x86_64, the rest
244 -- default to the panic below. To support allocating extra stack on
245 -- more platforms provide a definition of ncgAllocMoreStack.
246 --
247 noAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr)
248 noAllocMoreStack amount _
249 = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
250 ++ " If you are trying to compile SHA1.hs from the crypto library then this\n"
251 ++ " is a known limitation in the linear allocator.\n"
252 ++ "\n"
253 ++ " Try enabling the graph colouring allocator with -fregs-graph instead."
254 ++ " You can still file a bug report if you like.\n"
255
256
257 -- | Data accumulated during code generation. Mostly about statistics,
258 -- but also collects debug data for DWARF generation.
259 data NativeGenAcc statics instr
260 = NGS { ngs_imports :: ![[CLabel]]
261 , ngs_natives :: ![[NatCmmDecl statics instr]]
262 -- ^ Native code generated, for statistics. This might
263 -- hold a lot of data, so it is important to clear this
264 -- field as early as possible if it isn't actually
265 -- required.
266 , ngs_colorStats :: ![[Color.RegAllocStats statics instr]]
267 , ngs_linearStats :: ![[Linear.RegAllocStats]]
268 , ngs_labels :: ![Label]
269 , ngs_debug :: ![DebugBlock]
270 , ngs_dwarfFiles :: !DwarfFiles
271 }
272
273 nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
274 => DynFlags
275 -> Module -> ModLocation
276 -> NcgImpl statics instr jumpDest
277 -> Handle
278 -> UniqSupply
279 -> Stream IO RawCmmGroup ()
280 -> IO UniqSupply
281 nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
282 = do
283 -- BufHandle is a performance hack. We could hide it inside
284 -- Pretty if it weren't for the fact that we do lots of little
285 -- printDocs here (in order to do codegen in constant space).
286 bufh <- newBufHandle h
287 let ngs0 = NGS [] [] [] [] [] [] emptyUFM
288 (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
289 cmms ngs0
290 finishNativeGen dflags modLoc bufh us' ngs
291
292 finishNativeGen :: Instruction instr
293 => DynFlags
294 -> ModLocation
295 -> BufHandle
296 -> UniqSupply
297 -> NativeGenAcc statics instr
298 -> IO UniqSupply
299 finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
300 = do
301 -- Write debug data and finish
302 let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags)
303 us' <- if not emitDw then return us else do
304 (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
305 emitNativeCode dflags bufh dwarf
306 return us'
307 bFlush bufh
308
309 -- dump global NCG stats for graph coloring allocator
310 let stats = concat (ngs_colorStats ngs)
311 when (not (null stats)) $ do
312
313 -- build the global register conflict graph
314 let graphGlobal
315 = foldl Color.union Color.initGraph
316 $ [ Color.raGraph stat
317 | stat@Color.RegAllocStatsStart{} <- stats]
318
319 dump_stats (Color.pprStats stats graphGlobal)
320
321 let platform = targetPlatform dflags
322 dumpIfSet_dyn dflags
323 Opt_D_dump_asm_conflicts "Register conflict graph"
324 $ Color.dotGraph
325 (targetRegDotColor platform)
326 (Color.trivColorable platform
327 (targetVirtualRegSqueeze platform)
328 (targetRealRegSqueeze platform))
329 $ graphGlobal
330
331
332 -- dump global NCG stats for linear allocator
333 let linearStats = concat (ngs_linearStats ngs)
334 when (not (null linearStats)) $
335 dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
336
337 -- write out the imports
338 Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
339 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
340 $ makeImportsDoc dflags (concat (ngs_imports ngs))
341 return us'
342 where
343 dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
344
345 cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
346 => DynFlags
347 -> Module -> ModLocation
348 -> NcgImpl statics instr jumpDest
349 -> BufHandle
350 -> UniqSupply
351 -> Stream IO RawCmmGroup ()
352 -> NativeGenAcc statics instr
353 -> IO (NativeGenAcc statics instr, UniqSupply)
354
355 cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
356 = do r <- Stream.runStream cmm_stream
357 case r of
358 Left () ->
359 return (ngs { ngs_imports = reverse $ ngs_imports ngs
360 , ngs_natives = reverse $ ngs_natives ngs
361 , ngs_colorStats = reverse $ ngs_colorStats ngs
362 , ngs_linearStats = reverse $ ngs_linearStats ngs
363 },
364 us)
365 Right (cmms, cmm_stream') -> do
366
367 -- Generate debug information
368 let debugFlag = debugLevel dflags > 0
369 !ndbgs | debugFlag = cmmDebugGen modLoc cmms
370 | otherwise = []
371 dbgMap = debugToMap ndbgs
372
373 -- Insert split marker, generate native code
374 let splitObjs = gopt Opt_SplitObjs dflags
375 split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $
376 ofBlockList (panic "split_marker_entry") []
377 cmms' | splitObjs = split_marker : cmms
378 | otherwise = cmms
379 (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
380 cmms' ngs 0
381
382 -- Link native code information into debug blocks
383 let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs
384 dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
385 (vcat $ map ppr ldbgs)
386
387 -- Emit & clear DWARF information when generating split
388 -- object files, as we need it to land in the same object file
389 -- When using split sections, note that we do not split the debug
390 -- info but emit all the info at once in finishNativeGen.
391 (ngs'', us'') <-
392 if debugFlag && splitObjs
393 then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs
394 emitNativeCode dflags h dwarf
395 return (ngs' { ngs_debug = []
396 , ngs_dwarfFiles = emptyUFM
397 , ngs_labels = [] },
398 us'')
399 else return (ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs
400 , ngs_labels = [] },
401 us')
402
403 cmmNativeGenStream dflags this_mod modLoc ncgImpl h us''
404 cmm_stream' ngs''
405
406 -- | Do native code generation on all these cmms.
407 --
408 cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
409 => DynFlags
410 -> Module -> ModLocation
411 -> NcgImpl statics instr jumpDest
412 -> BufHandle
413 -> LabelMap DebugBlock
414 -> UniqSupply
415 -> [RawCmmDecl]
416 -> NativeGenAcc statics instr
417 -> Int
418 -> IO (NativeGenAcc statics instr, UniqSupply)
419
420 cmmNativeGens _ _ _ _ _ _ us [] ngs !_
421 = return (ngs, us)
422
423 cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
424 (cmm : cmms) ngs count
425 = do
426 let fileIds = ngs_dwarfFiles ngs
427 (us', fileIds', native, imports, colorStats, linearStats)
428 <- {-# SCC "cmmNativeGen" #-}
429 cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
430 cmm count
431
432 -- Generate .file directives for every new file that has been
433 -- used. Note that it is important that we generate these in
434 -- ascending order, as Clang's 3.6 assembler complains.
435 let newFileIds = sortBy (comparing snd) $ eltsUFM $ fileIds' `minusUFM` fileIds
436 pprDecl (f,n) = text "\t.file " <> ppr n <+>
437 doubleQuotes (ftext f)
438
439 emitNativeCode dflags h $ vcat $
440 map pprDecl newFileIds ++
441 map (pprNatCmmDecl ncgImpl) native
442
443 -- force evaluation all this stuff to avoid space leaks
444 {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
445
446 let !labels' = if debugLevel dflags > 0
447 then cmmDebugLabels isMetaInstr native else []
448 !natives' = if dopt Opt_D_dump_asm_stats dflags
449 then native : ngs_natives ngs else []
450 mCon = maybe id (:)
451 ngs' = ngs{ ngs_imports = imports : ngs_imports ngs
452 , ngs_natives = natives'
453 , ngs_colorStats = colorStats `mCon` ngs_colorStats ngs
454 , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
455 , ngs_labels = ngs_labels ngs ++ labels'
456 , ngs_dwarfFiles = fileIds'
457 }
458 cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us'
459 cmms ngs' (count + 1)
460
461 where seqString [] = ()
462 seqString (x:xs) = x `seq` seqString xs
463
464
465 emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
466 emitNativeCode dflags h sdoc = do
467
468 {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
469 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) sdoc
470
471 -- dump native code
472 dumpIfSet_dyn dflags
473 Opt_D_dump_asm "Asm code"
474 sdoc
475
476 -- | Complete native code generation phase for a single top-level chunk of Cmm.
477 -- Dumping the output of each stage along the way.
478 -- Global conflict graph and NGC stats
479 cmmNativeGen
480 :: (Outputable statics, Outputable instr, Instruction instr)
481 => DynFlags
482 -> Module -> ModLocation
483 -> NcgImpl statics instr jumpDest
484 -> UniqSupply
485 -> DwarfFiles
486 -> LabelMap DebugBlock
487 -> RawCmmDecl -- ^ the cmm to generate code for
488 -> Int -- ^ sequence number of this top thing
489 -> IO ( UniqSupply
490 , DwarfFiles
491 , [NatCmmDecl statics instr] -- native code
492 , [CLabel] -- things imported by this cmm
493 , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
494 , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
495
496 cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
497 = do
498 let platform = targetPlatform dflags
499
500 -- rewrite assignments to global regs
501 let fixed_cmm =
502 {-# SCC "fixStgRegisters" #-}
503 fixStgRegisters dflags cmm
504
505 -- cmm to cmm optimisations
506 let (opt_cmm, imports) =
507 {-# SCC "cmmToCmm" #-}
508 cmmToCmm dflags this_mod fixed_cmm
509
510 dumpIfSet_dyn dflags
511 Opt_D_dump_opt_cmm "Optimised Cmm"
512 (pprCmmGroup [opt_cmm])
513
514 -- generate native code from cmm
515 let ((native, lastMinuteImports, fileIds'), usGen) =
516 {-# SCC "genMachCode" #-}
517 initUs us $ genMachCode dflags this_mod modLoc
518 (cmmTopCodeGen ncgImpl)
519 fileIds dbgMap opt_cmm
520
521 dumpIfSet_dyn dflags
522 Opt_D_dump_asm_native "Native code"
523 (vcat $ map (pprNatCmmDecl ncgImpl) native)
524
525 -- tag instructions with register liveness information
526 let (withLiveness, usLive) =
527 {-# SCC "regLiveness" #-}
528 initUs usGen
529 $ mapM (regLiveness platform)
530 $ map natCmmTopToLive native
531
532 dumpIfSet_dyn dflags
533 Opt_D_dump_asm_liveness "Liveness annotations added"
534 (vcat $ map ppr withLiveness)
535
536 -- allocate registers
537 (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
538 if False
539 -- Disabled, see #7679, #8657
540 -- ( gopt Opt_RegsGraph dflags
541 -- || gopt Opt_RegsIterative dflags)
542 then do
543 -- the regs usable for allocation
544 let (alloc_regs :: UniqFM (UniqSet RealReg))
545 = foldr (\r -> plusUFM_C unionUniqSets
546 $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
547 emptyUFM
548 $ allocatableRegs ncgImpl
549
550 -- do the graph coloring register allocation
551 let ((alloced, regAllocStats), usAlloc)
552 = {-# SCC "RegAlloc" #-}
553 initUs usLive
554 $ Color.regAlloc
555 dflags
556 alloc_regs
557 (mkUniqSet [0 .. maxSpillSlots ncgImpl])
558 withLiveness
559
560 -- dump out what happened during register allocation
561 dumpIfSet_dyn dflags
562 Opt_D_dump_asm_regalloc "Registers allocated"
563 (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
564
565 dumpIfSet_dyn dflags
566 Opt_D_dump_asm_regalloc_stages "Build/spill stages"
567 (vcat $ map (\(stage, stats)
568 -> text "# --------------------------"
569 $$ text "# cmm " <> int count <> text " Stage " <> int stage
570 $$ ppr stats)
571 $ zip [0..] regAllocStats)
572
573 let mPprStats =
574 if dopt Opt_D_dump_asm_stats dflags
575 then Just regAllocStats else Nothing
576
577 -- force evaluation of the Maybe to avoid space leak
578 mPprStats `seq` return ()
579
580 return ( alloced, usAlloc
581 , mPprStats
582 , Nothing)
583
584 else do
585 -- do linear register allocation
586 let reg_alloc proc = do
587 (alloced, maybe_more_stack, ra_stats) <-
588 Linear.regAlloc dflags proc
589 case maybe_more_stack of
590 Nothing -> return ( alloced, ra_stats )
591 Just amount -> do
592 alloced' <- ncgAllocMoreStack ncgImpl amount alloced
593 return (alloced', ra_stats )
594
595 let ((alloced, regAllocStats), usAlloc)
596 = {-# SCC "RegAlloc" #-}
597 initUs usLive
598 $ liftM unzip
599 $ mapM reg_alloc withLiveness
600
601 dumpIfSet_dyn dflags
602 Opt_D_dump_asm_regalloc "Registers allocated"
603 (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
604
605 let mPprStats =
606 if dopt Opt_D_dump_asm_stats dflags
607 then Just (catMaybes regAllocStats) else Nothing
608
609 -- force evaluation of the Maybe to avoid space leak
610 mPprStats `seq` return ()
611
612 return ( alloced, usAlloc
613 , Nothing
614 , mPprStats)
615
616 ---- x86fp_kludge. This pass inserts ffree instructions to clear
617 ---- the FPU stack on x86. The x86 ABI requires that the FPU stack
618 ---- is clear, and library functions can return odd results if it
619 ---- isn't.
620 ----
621 ---- NB. must happen before shortcutBranches, because that
622 ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
623 let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
624
625 ---- generate jump tables
626 let tabled =
627 {-# SCC "generateJumpTables" #-}
628 generateJumpTables ncgImpl kludged
629
630 ---- shortcut branches
631 let shorted =
632 {-# SCC "shortcutBranches" #-}
633 shortcutBranches dflags ncgImpl tabled
634
635 ---- sequence blocks
636 let sequenced =
637 {-# SCC "sequenceBlocks" #-}
638 map (sequenceTop ncgImpl) shorted
639
640 ---- expansion of SPARC synthetic instrs
641 let expanded =
642 {-# SCC "sparc_expand" #-}
643 ncgExpandTop ncgImpl sequenced
644
645 dumpIfSet_dyn dflags
646 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
647 (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
648
649 return ( usAlloc
650 , fileIds'
651 , expanded
652 , lastMinuteImports ++ imports
653 , ppr_raStatsColor
654 , ppr_raStatsLinear)
655
656
657 x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
658 x86fp_kludge top@(CmmData _ _) = top
659 x86fp_kludge (CmmProc info lbl live (ListGraph code)) =
660 CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)
661
662
663 -- | Build a doc for all the imports.
664 --
665 makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
666 makeImportsDoc dflags imports
667 = dyld_stubs imports
668 $$
669 -- On recent versions of Darwin, the linker supports
670 -- dead-stripping of code and data on a per-symbol basis.
671 -- There's a hack to make this work in PprMach.pprNatCmmDecl.
672 (if platformHasSubsectionsViaSymbols platform
673 then text ".subsections_via_symbols"
674 else Outputable.empty)
675 $$
676 -- On recent GNU ELF systems one can mark an object file
677 -- as not requiring an executable stack. If all objects
678 -- linked into a program have this note then the program
679 -- will not use an executable stack, which is good for
680 -- security. GHC generated code does not need an executable
681 -- stack so add the note in:
682 (if platformHasGnuNonexecStack platform
683 then text ".section .note.GNU-stack,\"\",@progbits"
684 else Outputable.empty)
685 $$
686 -- And just because every other compiler does, let's stick in
687 -- an identifier directive: .ident "GHC x.y.z"
688 (if platformHasIdentDirective platform
689 then let compilerIdent = text "GHC" <+> text cProjectVersion
690 in text ".ident" <+> doubleQuotes compilerIdent
691 else Outputable.empty)
692
693 where
694 platform = targetPlatform dflags
695 arch = platformArch platform
696 os = platformOS platform
697
698 -- Generate "symbol stubs" for all external symbols that might
699 -- come from a dynamic library.
700 dyld_stubs :: [CLabel] -> SDoc
701 {- dyld_stubs imps = vcat $ map pprDyldSymbolStub $
702 map head $ group $ sort imps-}
703 -- (Hack) sometimes two Labels pretty-print the same, but have
704 -- different uniques; so we compare their text versions...
705 dyld_stubs imps
706 | needImportedSymbols dflags arch os
707 = vcat $
708 (pprGotDeclaration dflags arch os :) $
709 map ( pprImportedSymbol dflags platform . fst . head) $
710 groupBy (\(_,a) (_,b) -> a == b) $
711 sortBy (\(_,a) (_,b) -> compare a b) $
712 map doPpr $
713 imps
714 | otherwise
715 = Outputable.empty
716
717 doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
718 astyle = mkCodeStyle AsmStyle
719
720
721 -- -----------------------------------------------------------------------------
722 -- Sequencing the basic blocks
723
724 -- Cmm BasicBlocks are self-contained entities: they always end in a
725 -- jump, either non-local or to another basic block in the same proc.
726 -- In this phase, we attempt to place the basic blocks in a sequence
727 -- such that as many of the local jumps as possible turn into
728 -- fallthroughs.
729
730 sequenceTop
731 :: Instruction instr
732 => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
733
734 sequenceTop _ top@(CmmData _ _) = top
735 sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) =
736 CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl info $ sequenceBlocks info blocks)
737
738 -- The algorithm is very simple (and stupid): we make a graph out of
739 -- the blocks where there is an edge from one block to another iff the
740 -- first block ends by jumping to the second. Then we topologically
741 -- sort this graph. Then traverse the list: for each block, we first
742 -- output the block, then if it has an out edge, we move the
743 -- destination of the out edge to the front of the list, and continue.
744
745 -- FYI, the classic layout for basic blocks uses postorder DFS; this
746 -- algorithm is implemented in Hoopl.
747
748 sequenceBlocks
749 :: Instruction instr
750 => BlockEnv i
751 -> [NatBasicBlock instr]
752 -> [NatBasicBlock instr]
753
754 sequenceBlocks _ [] = []
755 sequenceBlocks infos (entry:blocks) =
756 seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
757 -- the first block is the entry point ==> it must remain at the start.
758
759
760 sccBlocks
761 :: Instruction instr
762 => [NatBasicBlock instr]
763 -> [SCC ( NatBasicBlock instr
764 , BlockId
765 , [BlockId])]
766
767 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
768
769 -- we're only interested in the last instruction of
770 -- the block, and only if it has a single destination.
771 getOutEdges
772 :: Instruction instr
773 => [instr] -> [BlockId]
774
775 getOutEdges instrs
776 = case jumpDestsOfInstr (last instrs) of
777 [one] -> [one]
778 _many -> []
779
780 mkNode :: (Instruction t)
781 => GenBasicBlock t
782 -> (GenBasicBlock t, BlockId, [BlockId])
783 mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
784
785 seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
786 -> [GenBasicBlock t1]
787 seqBlocks infos blocks = placeNext pullable0 todo0
788 where
789 -- pullable: Blocks that are not yet placed
790 -- todo: Original order of blocks, to be followed if we have no good
791 -- reason not to;
792 -- may include blocks that have already been placed, but then
793 -- these are not in pullable
794 pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ]
795 todo0 = [i | (_,i,_) <- blocks ]
796
797 placeNext _ [] = []
798 placeNext pullable (i:rest)
799 | Just (block, pullable') <- lookupDeleteUFM pullable i
800 = place pullable' rest block
801 | otherwise
802 -- We already placed this block, so ignore
803 = placeNext pullable rest
804
805 place pullable todo (block,[])
806 = block : placeNext pullable todo
807 place pullable todo (block@(BasicBlock id instrs),[next])
808 | mapMember next infos
809 = block : placeNext pullable todo
810 | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
811 = BasicBlock id (init instrs) : place pullable' todo nextBlock
812 | otherwise
813 = block : placeNext pullable todo
814 place _ _ (_,tooManyNextNodes)
815 = pprPanic "seqBlocks" (ppr tooManyNextNodes)
816
817
818 lookupDeleteUFM :: Uniquable key => UniqFM elt -> key -> Maybe (elt, UniqFM elt)
819 lookupDeleteUFM m k = do -- Maybe monad
820 v <- lookupUFM m k
821 return (v, delFromUFM m k)
822
823 -- -----------------------------------------------------------------------------
824 -- Generate jump tables
825
826 -- Analyzes all native code and generates data sections for all jump
827 -- table instructions.
828 generateJumpTables
829 :: NcgImpl statics instr jumpDest
830 -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
831 generateJumpTables ncgImpl xs = concatMap f xs
832 where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs
833 f p = [p]
834 g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
835
836 -- -----------------------------------------------------------------------------
837 -- Shortcut branches
838
839 shortcutBranches
840 :: DynFlags
841 -> NcgImpl statics instr jumpDest
842 -> [NatCmmDecl statics instr]
843 -> [NatCmmDecl statics instr]
844
845 shortcutBranches dflags ncgImpl tops
846 | optLevel dflags < 1 = tops -- only with -O or higher
847 | otherwise = map (apply_mapping ncgImpl mapping) tops'
848 where
849 (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
850 mapping = foldr plusUFM emptyUFM mappings
851
852 build_mapping :: NcgImpl statics instr jumpDest
853 -> GenCmmDecl d (BlockEnv t) (ListGraph instr)
854 -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest)
855 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
856 build_mapping _ (CmmProc info lbl live (ListGraph []))
857 = (CmmProc info lbl live (ListGraph []), emptyUFM)
858 build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
859 = (CmmProc info lbl live (ListGraph (head:others)), mapping)
860 -- drop the shorted blocks, but don't ever drop the first one,
861 -- because it is pointed to by a global label.
862 where
863 -- find all the blocks that just consist of a jump that can be
864 -- shorted.
865 -- Don't completely eliminate loops here -- that can leave a dangling jump!
866 (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
867 split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
868 | Just jd <- canShortcut ncgImpl insn,
869 Just dest <- getJumpDestBlockId ncgImpl jd,
870 not (has_info id),
871 (setMember dest s) || dest == id -- loop checks
872 = (s, shortcut_blocks, b : others)
873 split (s, shortcut_blocks, others) (BasicBlock id [insn])
874 | Just dest <- canShortcut ncgImpl insn,
875 not (has_info id)
876 = (setInsert id s, (id,dest) : shortcut_blocks, others)
877 split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
878
879 -- do not eliminate blocks that have an info table
880 has_info l = mapMember l info
881
882 -- build a mapping from BlockId to JumpDest for shorting branches
883 mapping = foldl add emptyUFM shortcut_blocks
884 add ufm (id,dest) = addToUFM ufm id dest
885
886 apply_mapping :: NcgImpl statics instr jumpDest
887 -> UniqFM jumpDest
888 -> GenCmmDecl statics h (ListGraph instr)
889 -> GenCmmDecl statics h (ListGraph instr)
890 apply_mapping ncgImpl ufm (CmmData sec statics)
891 = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
892 apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
893 = CmmProc info lbl live (ListGraph $ map short_bb blocks)
894 where
895 short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
896 short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
897 -- shortcutJump should apply the mapping repeatedly,
898 -- just in case we can short multiple branches.
899
900 -- -----------------------------------------------------------------------------
901 -- Instruction selection
902
903 -- Native code instruction selection for a chunk of stix code. For
904 -- this part of the computation, we switch from the UniqSM monad to
905 -- the NatM monad. The latter carries not only a Unique, but also an
906 -- Int denoting the current C stack pointer offset in the generated
907 -- code; this is needed for creating correct spill offsets on
908 -- architectures which don't offer, or for which it would be
909 -- prohibitively expensive to employ, a frame pointer register. Viz,
910 -- x86.
911
912 -- The offset is measured in bytes, and indicates the difference
913 -- between the current (simulated) C stack-ptr and the value it was at
914 -- the beginning of the block. For stacks which grow down, this value
915 -- should be either zero or negative.
916
917 -- Switching between the two monads whilst carrying along the same
918 -- Unique supply breaks abstraction. Is that bad?
919
920 genMachCode
921 :: DynFlags
922 -> Module -> ModLocation
923 -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
924 -> DwarfFiles
925 -> LabelMap DebugBlock
926 -> RawCmmDecl
927 -> UniqSM
928 ( [NatCmmDecl statics instr]
929 , [CLabel]
930 , DwarfFiles)
931
932 genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top
933 = do { initial_us <- getUniqueSupplyM
934 ; let initial_st = mkNatM_State initial_us 0 dflags this_mod
935 modLoc fileIds dbgMap
936 (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
937 final_delta = natm_delta final_st
938 final_imports = natm_imports final_st
939 ; if final_delta == 0
940 then return (new_tops, final_imports, natm_fileid final_st)
941 else pprPanic "genMachCode: nonzero final delta" (int final_delta)
942 }
943
944 -- -----------------------------------------------------------------------------
945 -- Generic Cmm optimiser
946
947 {-
948 Here we do:
949
950 (a) Constant folding
951 (c) Position independent code and dynamic linking
952 (i) introduce the appropriate indirections
953 and position independent refs
954 (ii) compile a list of imported symbols
955 (d) Some arch-specific optimizations
956
957 (a) will be moving to the new Hoopl pipeline, however, (c) and
958 (d) are only needed by the native backend and will continue to live
959 here.
960
961 Ideas for other things we could do (put these in Hoopl please!):
962
963 - shortcut jumps-to-jumps
964 - simple CSE: if an expr is assigned to a temp, then replace later occs of
965 that expr with the temp, until the expr is no longer valid (can push through
966 temp assignments, and certain assigns to mem...)
967 -}
968
969 cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
970 cmmToCmm _ _ top@(CmmData _ _) = (top, [])
971 cmmToCmm dflags this_mod (CmmProc info lbl live graph)
972 = runCmmOpt dflags this_mod $
973 do blocks' <- mapM cmmBlockConFold (toBlockList graph)
974 return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
975
976 newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))
977
978 instance Functor CmmOptM where
979 fmap = liftM
980
981 instance Applicative CmmOptM where
982 pure x = CmmOptM $ \_ _ imports -> (# x, imports #)
983 (<*>) = ap
984
985 instance Monad CmmOptM where
986 (CmmOptM f) >>= g =
987 CmmOptM $ \dflags this_mod imports ->
988 case f dflags this_mod imports of
989 (# x, imports' #) ->
990 case g x of
991 CmmOptM g' -> g' dflags this_mod imports'
992
993 instance CmmMakeDynamicReferenceM CmmOptM where
994 addImport = addImportCmmOpt
995 getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)
996
997 addImportCmmOpt :: CLabel -> CmmOptM ()
998 addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)
999
1000 instance HasDynFlags CmmOptM where
1001 getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)
1002
1003 runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
1004 runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of
1005 (# result, imports #) -> (result, imports)
1006
1007 cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
1008 cmmBlockConFold block = do
1009 let (entry, middle, last) = blockSplit block
1010 stmts = blockToList middle
1011 stmts' <- mapM cmmStmtConFold stmts
1012 last' <- cmmStmtConFold last
1013 return $ blockJoin entry (blockFromList stmts') last'
1014
1015 -- This does three optimizations, but they're very quick to check, so we don't
1016 -- bother turning them off even when the Hoopl code is active. Since
1017 -- this is on the old Cmm representation, we can't reuse the code either:
1018 -- * reg = reg --> nop
1019 -- * if 0 then jump --> nop
1020 -- * if 1 then jump --> jump
1021 -- We might be tempted to skip this step entirely of not Opt_PIC, but
1022 -- there is some PowerPC code for the non-PIC case, which would also
1023 -- have to be separated.
1024 cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
1025 cmmStmtConFold stmt
1026 = case stmt of
1027 CmmAssign reg src
1028 -> do src' <- cmmExprConFold DataReference src
1029 return $ case src' of
1030 CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")
1031 new_src -> CmmAssign reg new_src
1032
1033 CmmStore addr src
1034 -> do addr' <- cmmExprConFold DataReference addr
1035 src' <- cmmExprConFold DataReference src
1036 return $ CmmStore addr' src'
1037
1038 CmmCall { cml_target = addr }
1039 -> do addr' <- cmmExprConFold JumpReference addr
1040 return $ stmt { cml_target = addr' }
1041
1042 CmmUnsafeForeignCall target regs args
1043 -> do target' <- case target of
1044 ForeignTarget e conv -> do
1045 e' <- cmmExprConFold CallReference e
1046 return $ ForeignTarget e' conv
1047 PrimTarget _ ->
1048 return target
1049 args' <- mapM (cmmExprConFold DataReference) args
1050 return $ CmmUnsafeForeignCall target' regs args'
1051
1052 CmmCondBranch test true false likely
1053 -> do test' <- cmmExprConFold DataReference test
1054 return $ case test' of
1055 CmmLit (CmmInt 0 _) -> CmmBranch false
1056 CmmLit (CmmInt _ _) -> CmmBranch true
1057 _other -> CmmCondBranch test' true false likely
1058
1059 CmmSwitch expr ids
1060 -> do expr' <- cmmExprConFold DataReference expr
1061 return $ CmmSwitch expr' ids
1062
1063 other
1064 -> return other
1065
1066 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
1067 cmmExprConFold referenceKind expr = do
1068 dflags <- getDynFlags
1069
1070 -- With -O1 and greater, the cmmSink pass does constant-folding, so
1071 -- we don't need to do it again here.
1072 let expr' = if optLevel dflags >= 1
1073 then expr
1074 else cmmExprCon dflags expr
1075
1076 cmmExprNative referenceKind expr'
1077
1078 cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
1079 cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
1080 cmmExprCon dflags (CmmMachOp mop args)
1081 = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
1082 cmmExprCon _ other = other
1083
1084 -- handles both PIC and non-PIC cases... a very strange mixture
1085 -- of things to do.
1086 cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
1087 cmmExprNative referenceKind expr = do
1088 dflags <- getDynFlags
1089 let platform = targetPlatform dflags
1090 arch = platformArch platform
1091 case expr of
1092 CmmLoad addr rep
1093 -> do addr' <- cmmExprNative DataReference addr
1094 return $ CmmLoad addr' rep
1095
1096 CmmMachOp mop args
1097 -> do args' <- mapM (cmmExprNative DataReference) args
1098 return $ CmmMachOp mop args'
1099
1100 CmmLit (CmmBlock id)
1101 -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
1102 -- we must convert block Ids to CLabels here, because we
1103 -- might have to do the PIC transformation. Hence we must
1104 -- not modify BlockIds beyond this point.
1105
1106 CmmLit (CmmLabel lbl)
1107 -> do
1108 cmmMakeDynamicReference dflags referenceKind lbl
1109 CmmLit (CmmLabelOff lbl off)
1110 -> do
1111 dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
1112 -- need to optimize here, since it's late
1113 return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
1114 dynRef,
1115 (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
1116 ]
1117
1118 -- On powerpc (non-PIC), it's easier to jump directly to a label than
1119 -- to use the register table, so we replace these registers
1120 -- with the corresponding labels:
1121 CmmReg (CmmGlobal EagerBlackholeInfo)
1122 | arch == ArchPPC && not (gopt Opt_PIC dflags)
1123 -> cmmExprNative referenceKind $
1124 CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
1125 CmmReg (CmmGlobal GCEnter1)
1126 | arch == ArchPPC && not (gopt Opt_PIC dflags)
1127 -> cmmExprNative referenceKind $
1128 CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
1129 CmmReg (CmmGlobal GCFun)
1130 | arch == ArchPPC && not (gopt Opt_PIC dflags)
1131 -> cmmExprNative referenceKind $
1132 CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
1133
1134 other
1135 -> return other