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