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