1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 1993-2004
5 -- This is the top-level module in the native code generator.
7 -- -----------------------------------------------------------------------------
10 module AsmCodeGen ( nativeCodeGen ) where
12 #include "HsVersions.h"
13 #include "nativeGen/NCG.h"
16 import qualified X86.CodeGen
17 import qualified X86.Regs
18 import qualified X86.Instr
19 import qualified X86.Ppr
21 import qualified SPARC.CodeGen
22 import qualified SPARC.Regs
23 import qualified SPARC.Instr
24 import qualified SPARC.Ppr
25 import qualified SPARC.ShortcutJump
26 import qualified SPARC.CodeGen.Expand
28 import qualified PPC.CodeGen
29 import qualified PPC.Cond
30 import qualified PPC.Regs
31 import qualified PPC.RegInfo
32 import qualified PPC.Instr
33 import qualified PPC.Ppr
35 import RegAlloc.Liveness
36 import qualified RegAlloc.Linear.Main as Linear
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
52 import CgUtils ( fixStgRegisters )
54 import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
59 import Unique ( Unique, getUnique )
67 import qualified Pretty
84 The native-code generator has machine-independent and
85 machine-dependent modules.
87 This module ("AsmCodeGen") is the top-level machine-independent
88 module. Before entering machine-dependent land, we do some
89 machine-independent optimisations (defined below) on the
92 We convert to the machine-specific 'Instr' datatype with
93 'cmmCodeGen', assuming an infinite supply of registers. We then use
94 a machine-independent register allocator ('regAlloc') to rejoin
95 reality. Obviously, 'regAlloc' has machine-specific helper
96 functions (see about "RegAllocInfo" below).
98 Finally, we order the basic blocks of the function so as to minimise
99 the number of jumps between blocks, by utilising fallthrough wherever
102 The machine-dependent bits break down as follows:
104 * ["MachRegs"] Everything about the target platform's machine
105 registers (and immediate operands, and addresses, which tend to
106 intermingle/interact with registers).
108 * ["MachInstrs"] Includes the 'Instr' datatype (possibly should
109 have a module of its own), plus a miscellany of other things
110 (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
112 * ["MachCodeGen"] is where 'Cmm' stuff turns into
113 machine instructions.
115 * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
118 * ["RegAllocInfo"] In the register allocator, we manipulate
119 'MRegsState's, which are 'BitSet's, one bit per machine register.
120 When we want to say something about a specific machine register
121 (e.g., ``it gets clobbered by this instruction''), we set/unset
122 its bit. Obviously, we do this 'BitSet' thing for efficiency
125 The 'RegAllocInfo' module collects together the machine-specific
126 info needed to do register allocation.
128 * ["RegisterAlloc"] The (machine-independent) register allocator.
131 -- -----------------------------------------------------------------------------
132 -- Top-level of the native codegen
134 data NcgImpl instr jumpDest = NcgImpl {
135 cmmTopCodeGen :: DynFlags -> RawCmmTop -> NatM [NatCmmTop instr],
136 generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr),
137 getJumpDestBlockId :: jumpDest -> Maybe BlockId,
138 canShortcut :: instr -> Maybe jumpDest,
139 shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic,
140 shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
141 pprNatCmmTop :: NatCmmTop instr -> Doc,
142 maxSpillSlots :: Int,
143 allocatableRegs :: [RealReg],
144 ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr],
145 ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr],
146 ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
150 nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
151 nativeCodeGen dflags h us cmms
152 = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
153 x86NcgImpl = NcgImpl {
154 cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
155 ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
156 ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
157 ,canShortcut = X86.Instr.canShortcut
158 ,shortcutStatic = X86.Instr.shortcutStatic
159 ,shortcutJump = X86.Instr.shortcutJump
160 ,pprNatCmmTop = X86.Ppr.pprNatCmmTop
161 ,maxSpillSlots = X86.Instr.maxSpillSlots
162 ,allocatableRegs = X86.Regs.allocatableRegs
163 ,ncg_x86fp_kludge = id
165 ,ncgMakeFarBranches = id
167 in case platformArch $ targetPlatform dflags of
168 ArchX86 -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
169 ArchX86_64 -> nCG' x86NcgImpl
172 cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
173 ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
174 ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
175 ,canShortcut = PPC.RegInfo.canShortcut
176 ,shortcutStatic = PPC.RegInfo.shortcutStatic
177 ,shortcutJump = PPC.RegInfo.shortcutJump
178 ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop
179 ,maxSpillSlots = PPC.Instr.maxSpillSlots
180 ,allocatableRegs = PPC.Regs.allocatableRegs
181 ,ncg_x86fp_kludge = id
183 ,ncgMakeFarBranches = makeFarBranches
187 cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
188 ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
189 ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
190 ,canShortcut = SPARC.ShortcutJump.canShortcut
191 ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic
192 ,shortcutJump = SPARC.ShortcutJump.shortcutJump
193 ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop
194 ,maxSpillSlots = SPARC.Instr.maxSpillSlots
195 ,allocatableRegs = SPARC.Regs.allocatableRegs
196 ,ncg_x86fp_kludge = id
197 ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
198 ,ncgMakeFarBranches = id
201 panic "nativeCodeGen: No NCG for PPC 64"
203 nativeCodeGen' :: (Instruction instr, Outputable instr)
205 -> NcgImpl instr jumpDest
206 -> Handle -> UniqSupply -> [RawCmm] -> IO ()
207 nativeCodeGen' dflags ncgImpl h us cmms
209 let split_cmms = concat $ map add_split cmms
210 -- BufHandle is a performance hack. We could hide it inside
211 -- Pretty if it weren't for the fact that we do lots of little
212 -- printDocs here (in order to do codegen in constant space).
213 bufh <- newBufHandle h
214 (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
217 let (native, colorStats, linearStats)
222 Opt_D_dump_asm "Asm code"
223 (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native)
225 -- dump global NCG stats for graph coloring allocator
226 (case concat $ catMaybes colorStats of
229 -- build the global register conflict graph
231 = foldl Color.union Color.initGraph
232 $ [ Color.raGraph stat
233 | stat@Color.RegAllocStatsStart{} <- stats]
235 dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
236 $ Color.pprStats stats graphGlobal
239 Opt_D_dump_asm_conflicts "Register conflict graph"
243 targetVirtualRegSqueeze
244 targetRealRegSqueeze)
248 -- dump global NCG stats for linear allocator
249 (case concat $ catMaybes linearStats of
251 stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
252 $ Linear.pprStats (concat native) stats)
254 -- write out the imports
255 Pretty.printDoc Pretty.LeftMode h
256 $ makeImportsDoc dflags (concat imports)
260 where add_split (Cmm tops)
261 | dopt Opt_SplitObjs dflags = split_marker : tops
264 split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph [])
267 -- | Do native code generation on all these cmms.
269 cmmNativeGens :: (Instruction instr, Outputable instr)
271 -> NcgImpl instr jumpDest
276 -> [ ([NatCmmTop instr],
277 Maybe [Color.RegAllocStats instr],
278 Maybe [Linear.RegAllocStats]) ]
282 Maybe [Color.RegAllocStats instr],
283 Maybe [Linear.RegAllocStats])] )
285 cmmNativeGens _ _ _ _ [] impAcc profAcc _
286 = return (reverse impAcc, reverse profAcc)
288 cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
290 (us', native, imports, colorStats, linearStats)
291 <- cmmNativeGen dflags ncgImpl us cmm count
293 Pretty.bufLeftRender h
294 $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native
296 -- carefully evaluate this strictly. Binding it with 'let'
297 -- and then using 'seq' doesn't work, because the let
298 -- apparently gets inlined first.
299 lsPprNative <- return $!
300 if dopt Opt_D_dump_asm dflags
301 || dopt Opt_D_dump_asm_stats dflags
305 count' <- return $! count + 1;
307 -- force evaulation all this stuff to avoid space leaks
308 seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
310 cmmNativeGens dflags ncgImpl
313 ((lsPprNative, colorStats, linearStats) : profAcc)
316 where seqString [] = ()
317 seqString (x:xs) = x `seq` seqString xs `seq` ()
320 -- | Complete native code generation phase for a single top-level chunk of Cmm.
321 -- Dumping the output of each stage along the way.
322 -- Global conflict graph and NGC stats
324 :: (Instruction instr, Outputable instr)
326 -> NcgImpl instr jumpDest
328 -> RawCmmTop -- ^ the cmm to generate code for
329 -> Int -- ^ sequence number of this top thing
331 , [NatCmmTop instr] -- native code
332 , [CLabel] -- things imported by this cmm
333 , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator
334 , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
336 cmmNativeGen dflags ncgImpl us cmm count
339 -- rewrite assignments to global regs
341 {-# SCC "fixStgRegisters" #-}
344 -- cmm to cmm optimisations
345 let (opt_cmm, imports) =
346 {-# SCC "cmmToCmm" #-}
347 cmmToCmm dflags fixed_cmm
350 Opt_D_dump_opt_cmm "Optimised Cmm"
351 (pprCmm $ Cmm [opt_cmm])
353 -- generate native code from cmm
354 let ((native, lastMinuteImports), usGen) =
355 {-# SCC "genMachCode" #-}
356 initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
359 Opt_D_dump_asm_native "Native code"
360 (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native)
362 -- tag instructions with register liveness information
363 let (withLiveness, usLive) =
364 {-# SCC "regLiveness" #-}
367 $ map natCmmTopToLive native
370 Opt_D_dump_asm_liveness "Liveness annotations added"
371 (vcat $ map ppr withLiveness)
373 -- allocate registers
374 (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
375 if ( dopt Opt_RegsGraph dflags
376 || dopt Opt_RegsIterative dflags)
378 -- the regs usable for allocation
379 let (alloc_regs :: UniqFM (UniqSet RealReg))
380 = foldr (\r -> plusUFM_C unionUniqSets
381 $ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
383 $ allocatableRegs ncgImpl
385 -- do the graph coloring register allocation
386 let ((alloced, regAllocStats), usAlloc)
387 = {-# SCC "RegAlloc" #-}
392 (mkUniqSet [0 .. maxSpillSlots ncgImpl])
395 -- dump out what happened during register allocation
397 Opt_D_dump_asm_regalloc "Registers allocated"
398 (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
401 Opt_D_dump_asm_regalloc_stages "Build/spill stages"
402 (vcat $ map (\(stage, stats)
403 -> text "# --------------------------"
404 $$ text "# cmm " <> int count <> text " Stage " <> int stage
406 $ zip [0..] regAllocStats)
409 if dopt Opt_D_dump_asm_stats dflags
410 then Just regAllocStats else Nothing
412 -- force evaluation of the Maybe to avoid space leak
413 mPprStats `seq` return ()
415 return ( alloced, usAlloc
420 -- do linear register allocation
421 let ((alloced, regAllocStats), usAlloc)
422 = {-# SCC "RegAlloc" #-}
425 $ mapUs Linear.regAlloc withLiveness
428 Opt_D_dump_asm_regalloc "Registers allocated"
429 (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
432 if dopt Opt_D_dump_asm_stats dflags
433 then Just (catMaybes regAllocStats) else Nothing
435 -- force evaluation of the Maybe to avoid space leak
436 mPprStats `seq` return ()
438 return ( alloced, usAlloc
442 ---- x86fp_kludge. This pass inserts ffree instructions to clear
443 ---- the FPU stack on x86. The x86 ABI requires that the FPU stack
444 ---- is clear, and library functions can return odd results if it
447 ---- NB. must happen before shortcutBranches, because that
448 ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
449 let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
451 ---- generate jump tables
453 {-# SCC "generateJumpTables" #-}
454 generateJumpTables ncgImpl kludged
456 ---- shortcut branches
458 {-# SCC "shortcutBranches" #-}
459 shortcutBranches dflags ncgImpl tabled
463 {-# SCC "sequenceBlocks" #-}
464 map (sequenceTop ncgImpl) shorted
466 ---- expansion of SPARC synthetic instrs
468 {-# SCC "sparc_expand" #-}
469 ncgExpandTop ncgImpl sequenced
472 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
473 (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded)
477 , lastMinuteImports ++ imports
482 x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr
483 x86fp_kludge top@(CmmData _ _) = top
484 x86fp_kludge (CmmProc info lbl (ListGraph code)) =
485 CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
488 -- | Build a doc for all the imports.
490 makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
491 makeImportsDoc dflags imports
494 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
495 -- On recent versions of Darwin, the linker supports
496 -- dead-stripping of code and data on a per-symbol basis.
497 -- There's a hack to make this work in PprMach.pprNatCmmTop.
498 Pretty.$$ Pretty.text ".subsections_via_symbols"
500 #if HAVE_GNU_NONEXEC_STACK
501 -- On recent GNU ELF systems one can mark an object file
502 -- as not requiring an executable stack. If all objects
503 -- linked into a program have this note then the program
504 -- will not use an executable stack, which is good for
505 -- security. GHC generated code does not need an executable
506 -- stack so add the note in:
507 Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
509 -- And just because every other compiler does, lets stick in
510 -- an identifier directive: .ident "GHC x.y.z"
511 Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
512 Pretty.text cProjectVersion
513 in Pretty.text ".ident" Pretty.<+>
514 Pretty.doubleQuotes compilerIdent
517 -- Generate "symbol stubs" for all external symbols that might
518 -- come from a dynamic library.
519 dyld_stubs :: [CLabel] -> Pretty.Doc
520 {- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
521 map head $ group $ sort imps-}
523 arch = platformArch $ targetPlatform dflags
524 os = platformOS $ targetPlatform dflags
526 -- (Hack) sometimes two Labels pretty-print the same, but have
527 -- different uniques; so we compare their text versions...
529 | needImportedSymbols arch os
531 (pprGotDeclaration arch os :) $
532 map ( pprImportedSymbol arch os . fst . head) $
533 groupBy (\(_,a) (_,b) -> a == b) $
534 sortBy (\(_,a) (_,b) -> compare a b) $
540 doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
541 astyle = mkCodeStyle AsmStyle
544 -- -----------------------------------------------------------------------------
545 -- Sequencing the basic blocks
547 -- Cmm BasicBlocks are self-contained entities: they always end in a
548 -- jump, either non-local or to another basic block in the same proc.
549 -- In this phase, we attempt to place the basic blocks in a sequence
550 -- such that as many of the local jumps as possible turn into
555 => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr
557 sequenceTop _ top@(CmmData _ _) = top
558 sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
559 CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
561 -- The algorithm is very simple (and stupid): we make a graph out of
562 -- the blocks where there is an edge from one block to another iff the
563 -- first block ends by jumping to the second. Then we topologically
564 -- sort this graph. Then traverse the list: for each block, we first
565 -- output the block, then if it has an out edge, we move the
566 -- destination of the out edge to the front of the list, and continue.
568 -- FYI, the classic layout for basic blocks uses postorder DFS; this
569 -- algorithm is implemented in Hoopl.
573 => [NatBasicBlock instr]
574 -> [NatBasicBlock instr]
576 sequenceBlocks [] = []
577 sequenceBlocks (entry:blocks) =
578 seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
579 -- the first block is the entry point ==> it must remain at the start.
584 => [NatBasicBlock instr]
585 -> [SCC ( NatBasicBlock instr
589 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
591 -- we're only interested in the last instruction of
592 -- the block, and only if it has a single destination.
595 => [instr] -> [Unique]
598 = case jumpDestsOfInstr (last instrs) of
599 [one] -> [getUnique one]
602 mkNode :: (Instruction t)
604 -> (GenBasicBlock t, Unique, [Unique])
605 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
607 seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
609 seqBlocks ((block,_,[]) : rest)
610 = block : seqBlocks rest
611 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
612 | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
613 | otherwise = block : seqBlocks rest'
615 (can_fallthrough, rest') = reorder next [] rest
616 -- TODO: we should do a better job for cycles; try to maximise the
617 -- fallthroughs within a loop.
618 seqBlocks _ = panic "AsmCodegen:seqBlocks"
620 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
621 reorder _ accum [] = (False, reverse accum)
622 reorder id accum (b@(block,id',out) : rest)
623 | id == id' = (True, (block,id,out) : reverse accum ++ rest)
624 | otherwise = reorder id (b:accum) rest
627 -- -----------------------------------------------------------------------------
628 -- Making far branches
630 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
631 -- big, we have to work around this limitation.
634 :: [NatBasicBlock PPC.Instr.Instr]
635 -> [NatBasicBlock PPC.Instr.Instr]
636 makeFarBranches blocks
637 | last blockAddresses < nearLimit = blocks
638 | otherwise = zipWith handleBlock blockAddresses blocks
640 blockAddresses = scanl (+) 0 $ map blockLen blocks
641 blockLen (BasicBlock _ instrs) = length instrs
643 handleBlock addr (BasicBlock id instrs)
644 = BasicBlock id (zipWith makeFar [addr..] instrs)
646 makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
647 makeFar addr (PPC.Instr.BCC cond tgt)
648 | abs (addr - targetAddr) >= nearLimit
649 = PPC.Instr.BCCFAR cond tgt
651 = PPC.Instr.BCC cond tgt
652 where Just targetAddr = lookupUFM blockAddressMap tgt
653 makeFar _ other = other
655 nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
656 -- distance, as we have a few pseudo-insns that are
657 -- pretty-printed as multiple instructions,
658 -- and it's just not worth the effort to calculate
661 blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
663 -- -----------------------------------------------------------------------------
664 -- Generate jump tables
666 -- Analyzes all native code and generates data sections for all jump
667 -- table instructions.
669 :: NcgImpl instr jumpDest
670 -> [NatCmmTop instr] -> [NatCmmTop instr]
671 generateJumpTables ncgImpl xs = concatMap f xs
672 where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
674 g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
676 -- -----------------------------------------------------------------------------
681 -> NcgImpl instr jumpDest
685 shortcutBranches dflags ncgImpl tops
686 | optLevel dflags < 1 = tops -- only with -O or higher
687 | otherwise = map (apply_mapping ncgImpl mapping) tops'
689 (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
690 mapping = foldr plusUFM emptyUFM mappings
692 build_mapping :: NcgImpl instr jumpDest
693 -> GenCmmTop d t (ListGraph instr)
694 -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest)
695 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
696 build_mapping _ (CmmProc info lbl (ListGraph []))
697 = (CmmProc info lbl (ListGraph []), emptyUFM)
698 build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
699 = (CmmProc info lbl (ListGraph (head:others)), mapping)
700 -- drop the shorted blocks, but don't ever drop the first one,
701 -- because it is pointed to by a global label.
703 -- find all the blocks that just consist of a jump that can be
705 -- Don't completely eliminate loops here -- that can leave a dangling jump!
706 (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
707 split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
708 | Just jd <- canShortcut ncgImpl insn,
709 Just dest <- getJumpDestBlockId ncgImpl jd,
710 (setMember dest s) || dest == id -- loop checks
711 = (s, shortcut_blocks, b : others)
712 split (s, shortcut_blocks, others) (BasicBlock id [insn])
713 | Just dest <- canShortcut ncgImpl insn
714 = (setInsert id s, (id,dest) : shortcut_blocks, others)
715 split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
718 -- build a mapping from BlockId to JumpDest for shorting branches
719 mapping = foldl add emptyUFM shortcut_blocks
720 add ufm (id,dest) = addToUFM ufm id dest
722 apply_mapping :: NcgImpl instr jumpDest
724 -> GenCmmTop CmmStatic h (ListGraph instr)
725 -> GenCmmTop CmmStatic h (ListGraph instr)
726 apply_mapping ncgImpl ufm (CmmData sec statics)
727 = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics)
728 -- we need to get the jump tables, so apply the mapping to the entries
730 apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
731 = CmmProc info lbl (ListGraph $ map short_bb blocks)
733 short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
734 short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
735 -- shortcutJump should apply the mapping repeatedly,
736 -- just in case we can short multiple branches.
738 -- -----------------------------------------------------------------------------
739 -- Instruction selection
741 -- Native code instruction selection for a chunk of stix code. For
742 -- this part of the computation, we switch from the UniqSM monad to
743 -- the NatM monad. The latter carries not only a Unique, but also an
744 -- Int denoting the current C stack pointer offset in the generated
745 -- code; this is needed for creating correct spill offsets on
746 -- architectures which don't offer, or for which it would be
747 -- prohibitively expensive to employ, a frame pointer register. Viz,
750 -- The offset is measured in bytes, and indicates the difference
751 -- between the current (simulated) C stack-ptr and the value it was at
752 -- the beginning of the block. For stacks which grow down, this value
753 -- should be either zero or negative.
755 -- Switching between the two monads whilst carrying along the same
756 -- Unique supply breaks abstraction. Is that bad?
760 -> (DynFlags -> RawCmmTop -> NatM [NatCmmTop instr])
766 genMachCode dflags cmmTopCodeGen cmm_top
767 = do { initial_us <- getUs
768 ; let initial_st = mkNatM_State initial_us 0 dflags
769 (new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
770 final_delta = natm_delta final_st
771 final_imports = natm_imports final_st
772 ; if final_delta == 0
773 then return (new_tops, final_imports)
774 else pprPanic "genMachCode: nonzero final delta" (int final_delta)
777 -- -----------------------------------------------------------------------------
778 -- Generic Cmm optimiser
784 (b) Simple inlining: a temporary which is assigned to and then
785 used, once, can be shorted.
786 (c) Position independent code and dynamic linking
787 (i) introduce the appropriate indirections
788 and position independent refs
789 (ii) compile a list of imported symbols
791 Ideas for other things we could do:
793 - shortcut jumps-to-jumps
794 - simple CSE: if an expr is assigned to a temp, then replace later occs of
795 that expr with the temp, until the expr is no longer valid (can push through
796 temp assignments, and certain assigns to mem...)
799 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
800 cmmToCmm _ top@(CmmData _ _) = (top, [])
801 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
802 blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks))
803 return $ CmmProc info lbl (ListGraph blocks')
805 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
807 instance Monad CmmOptM where
808 return x = CmmOptM $ \(imports, _) -> (# x,imports #)
810 CmmOptM $ \(imports, dflags) ->
811 case f (imports, dflags) of
814 CmmOptM g' -> g' (imports', dflags)
816 addImportCmmOpt :: CLabel -> CmmOptM ()
817 addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
819 getDynFlagsCmmOpt :: CmmOptM DynFlags
820 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
822 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
823 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
824 (# result, imports #) -> (result, imports)
826 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
827 cmmBlockConFold (BasicBlock id stmts) = do
828 stmts' <- mapM cmmStmtConFold stmts
829 return $ BasicBlock id stmts'
831 cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
835 -> do src' <- cmmExprConFold DataReference src
836 return $ case src' of
837 CmmReg reg' | reg == reg' -> CmmNop
838 new_src -> CmmAssign reg new_src
841 -> do addr' <- cmmExprConFold DataReference addr
842 src' <- cmmExprConFold DataReference src
843 return $ CmmStore addr' src'
846 -> do addr' <- cmmExprConFold JumpReference addr
847 return $ CmmJump addr' regs
849 CmmCall target regs args srt returns
850 -> do target' <- case target of
851 CmmCallee e conv -> do
852 e' <- cmmExprConFold CallReference e
853 return $ CmmCallee e' conv
854 other -> return other
855 args' <- mapM (\(CmmHinted arg hint) -> do
856 arg' <- cmmExprConFold DataReference arg
857 return (CmmHinted arg' hint)) args
858 return $ CmmCall target' regs args' srt returns
860 CmmCondBranch test dest
861 -> do test' <- cmmExprConFold DataReference test
862 return $ case test' of
863 CmmLit (CmmInt 0 _) ->
864 CmmComment (mkFastString ("deleted: " ++
865 showSDoc (pprStmt stmt)))
867 CmmLit (CmmInt _ _) -> CmmBranch dest
868 _other -> CmmCondBranch test' dest
871 -> do expr' <- cmmExprConFold DataReference expr
872 return $ CmmSwitch expr' ids
878 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
879 cmmExprConFold referenceKind expr = do
880 dflags <- getDynFlagsCmmOpt
881 let arch = platformArch (targetPlatform dflags)
884 -> do addr' <- cmmExprConFold DataReference addr
885 return $ CmmLoad addr' rep
888 -- For MachOps, we first optimize the children, and then we try
889 -- our hand at some constant-folding.
890 -> do args' <- mapM (cmmExprConFold DataReference) args
891 return $ cmmMachOpFold mop args'
893 CmmLit (CmmLabel lbl)
895 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
896 CmmLit (CmmLabelOff lbl off)
898 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
899 return $ cmmMachOpFold (MO_Add wordWidth) [
901 (CmmLit $ CmmInt (fromIntegral off) wordWidth)
904 -- On powerpc (non-PIC), it's easier to jump directly to a label than
905 -- to use the register table, so we replace these registers
906 -- with the corresponding labels:
907 CmmReg (CmmGlobal EagerBlackholeInfo)
908 | arch == ArchPPC && not opt_PIC
909 -> cmmExprConFold referenceKind $
910 CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
911 CmmReg (CmmGlobal GCEnter1)
912 | arch == ArchPPC && not opt_PIC
913 -> cmmExprConFold referenceKind $
914 CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
915 CmmReg (CmmGlobal GCFun)
916 | arch == ArchPPC && not opt_PIC
917 -> cmmExprConFold referenceKind $
918 CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))