Fix the unregisterised build; fixes #5901
[ghc.git] / compiler / nativeGen / AsmCodeGen.lhs
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 \begin{code}
10 module AsmCodeGen ( nativeCodeGen ) where
11
12 #include "HsVersions.h"
13 #include "nativeGen/NCG.h"
14
15
16 import qualified X86.CodeGen
17 import qualified X86.Regs
18 import qualified X86.Instr
19 import qualified X86.Ppr
20
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
27
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
34
35 import RegAlloc.Liveness
36 import qualified RegAlloc.Linear.Main           as Linear
37
38 import qualified GraphColor                     as Color
39 import qualified RegAlloc.Graph.Main            as Color
40 import qualified RegAlloc.Graph.Stats           as Color
41 import qualified RegAlloc.Graph.TrivColorable   as Color
42
43 import TargetReg
44 import Platform
45 import Config
46 import Instruction
47 import PIC
48 import Reg
49 import NCGMonad
50
51 import BlockId
52 import CgUtils          ( fixStgRegisters )
53 import OldCmm
54 import CmmOpt           ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
55 import OldPprCmm
56 import CLabel
57
58 import UniqFM
59 import Unique           ( Unique, getUnique )
60 import UniqSupply
61 import DynFlags
62 import StaticFlags
63 import Util
64
65 import BasicTypes       ( Alignment )
66 import Digraph
67 import Pretty (Doc)
68 import qualified Pretty
69 import BufWrite
70 import Outputable
71 import FastString
72 import UniqSet
73 import ErrUtils
74 import Module
75
76 -- DEBUGGING ONLY
77 --import OrdList
78
79 import Data.List
80 import Data.Maybe
81 import Control.Monad
82 import System.IO
83
84 {-
85 The native-code generator has machine-independent and
86 machine-dependent modules.
87
88 This module ("AsmCodeGen") is the top-level machine-independent
89 module.  Before entering machine-dependent land, we do some
90 machine-independent optimisations (defined below) on the
91 'CmmStmts's.
92
93 We convert to the machine-specific 'Instr' datatype with
94 'cmmCodeGen', assuming an infinite supply of registers.  We then use
95 a machine-independent register allocator ('regAlloc') to rejoin
96 reality.  Obviously, 'regAlloc' has machine-specific helper
97 functions (see about "RegAllocInfo" below).
98
99 Finally, we order the basic blocks of the function so as to minimise
100 the number of jumps between blocks, by utilising fallthrough wherever
101 possible.
102
103 The machine-dependent bits break down as follows:
104
105   * ["MachRegs"]  Everything about the target platform's machine
106     registers (and immediate operands, and addresses, which tend to
107     intermingle/interact with registers).
108
109   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
110     have a module of its own), plus a miscellany of other things
111     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
112
113   * ["MachCodeGen"]  is where 'Cmm' stuff turns into
114     machine instructions.
115
116   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
117     a 'Doc').
118
119   * ["RegAllocInfo"] In the register allocator, we manipulate
120     'MRegsState's, which are 'BitSet's, one bit per machine register.
121     When we want to say something about a specific machine register
122     (e.g., ``it gets clobbered by this instruction''), we set/unset
123     its bit.  Obviously, we do this 'BitSet' thing for efficiency
124     reasons.
125
126     The 'RegAllocInfo' module collects together the machine-specific
127     info needed to do register allocation.
128
129    * ["RegisterAlloc"] The (machine-independent) register allocator.
130 -}
131
132 -- -----------------------------------------------------------------------------
133 -- Top-level of the native codegen
134
135 data NcgImpl statics instr jumpDest = NcgImpl {
136     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
137     generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
138     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
139     canShortcut               :: instr -> Maybe jumpDest,
140     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
141     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
142     pprNatCmmDecl              :: Platform -> NatCmmDecl statics instr -> Doc,
143     maxSpillSlots             :: Int,
144     allocatableRegs           :: [RealReg],
145     ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
146     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
147     ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
148     }
149
150 --------------------
151 nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
152 nativeCodeGen dflags h us cmms
153  = let platform = targetPlatform dflags
154        nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
155        nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
156        x86NcgImpl = NcgImpl {
157                          cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
158                         ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
159                         ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
160                         ,canShortcut               = X86.Instr.canShortcut
161                         ,shortcutStatics           = X86.Instr.shortcutStatics
162                         ,shortcutJump              = X86.Instr.shortcutJump
163                         ,pprNatCmmDecl              = X86.Ppr.pprNatCmmDecl
164                         ,maxSpillSlots             = X86.Instr.maxSpillSlots (target32Bit platform)
165                         ,allocatableRegs           = X86.Regs.allocatableRegs
166                         ,ncg_x86fp_kludge          = id
167                         ,ncgExpandTop              = id
168                         ,ncgMakeFarBranches        = id
169                     }
170    in case platformArch platform of
171                  ArchX86    -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
172                  ArchX86_64 -> nCG' x86NcgImpl
173                  ArchPPC ->
174                      nCG' $ NcgImpl {
175                           cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
176                          ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
177                          ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
178                          ,canShortcut               = PPC.RegInfo.canShortcut
179                          ,shortcutStatics           = PPC.RegInfo.shortcutStatics
180                          ,shortcutJump              = PPC.RegInfo.shortcutJump
181                          ,pprNatCmmDecl              = PPC.Ppr.pprNatCmmDecl
182                          ,maxSpillSlots             = PPC.Instr.maxSpillSlots
183                          ,allocatableRegs           = PPC.Regs.allocatableRegs
184                          ,ncg_x86fp_kludge          = id
185                          ,ncgExpandTop              = id
186                          ,ncgMakeFarBranches        = makeFarBranches
187                      }
188                  ArchSPARC ->
189                      nCG' $ NcgImpl {
190                           cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
191                          ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
192                          ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
193                          ,canShortcut               = SPARC.ShortcutJump.canShortcut
194                          ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
195                          ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
196                          ,pprNatCmmDecl              = SPARC.Ppr.pprNatCmmDecl
197                          ,maxSpillSlots             = SPARC.Instr.maxSpillSlots
198                          ,allocatableRegs           = SPARC.Regs.allocatableRegs
199                          ,ncg_x86fp_kludge          = id
200                          ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
201                          ,ncgMakeFarBranches        = id
202                      }
203                  ArchARM _ _ ->
204                      panic "nativeCodeGen: No NCG for ARM"
205                  ArchPPC_64 ->
206                      panic "nativeCodeGen: No NCG for PPC 64"
207                  ArchUnknown ->
208                      panic "nativeCodeGen: No NCG for unknown arch"
209
210 nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
211                => DynFlags
212                -> NcgImpl statics instr jumpDest
213                -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
214 nativeCodeGen' dflags ncgImpl h us cmms
215  = do
216         let platform = targetPlatform dflags
217             split_cmms  = concat $ map add_split cmms
218         -- BufHandle is a performance hack.  We could hide it inside
219         -- Pretty if it weren't for the fact that we do lots of little
220         -- printDocs here (in order to do codegen in constant space).
221         bufh <- newBufHandle h
222         (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
223         bFlush bufh
224
225         let (native, colorStats, linearStats)
226                 = unzip3 prof
227
228         -- dump native code
229         dumpIfSet_dyn dflags
230                 Opt_D_dump_asm "Asm code"
231                 (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native)
232
233         -- dump global NCG stats for graph coloring allocator
234         (case concat $ catMaybes colorStats of
235           []    -> return ()
236           stats -> do
237                 -- build the global register conflict graph
238                 let graphGlobal
239                         = foldl Color.union Color.initGraph
240                         $ [ Color.raGraph stat
241                                 | stat@Color.RegAllocStatsStart{} <- stats]
242
243                 dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
244                         $ Color.pprStats stats graphGlobal
245
246                 dumpIfSet_dyn dflags
247                         Opt_D_dump_asm_conflicts "Register conflict graph"
248                         $ Color.dotGraph
249                                 (targetRegDotColor platform)
250                                 (Color.trivColorable platform
251                                         (targetVirtualRegSqueeze platform)
252                                         (targetRealRegSqueeze platform))
253                         $ graphGlobal)
254
255
256         -- dump global NCG stats for linear allocator
257         (case concat $ catMaybes linearStats of
258                 []      -> return ()
259                 stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
260                                 $ Linear.pprStats (concat native) stats)
261
262         -- write out the imports
263         Pretty.printDoc Pretty.LeftMode h
264                 $ makeImportsDoc dflags (concat imports)
265
266         return  ()
267
268  where  add_split tops
269                 | dopt Opt_SplitObjs dflags = split_marker : tops
270                 | otherwise                 = tops
271
272         split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
273
274
275 -- | Do native code generation on all these cmms.
276 --
277 cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
278               => DynFlags
279               -> NcgImpl statics instr jumpDest
280               -> BufHandle
281               -> UniqSupply
282               -> [RawCmmDecl]
283               -> [[CLabel]]
284               -> [ ([NatCmmDecl statics instr],
285                    Maybe [Color.RegAllocStats statics instr],
286                    Maybe [Linear.RegAllocStats]) ]
287               -> Int
288               -> IO ( [[CLabel]],
289                       [([NatCmmDecl statics instr],
290                       Maybe [Color.RegAllocStats statics instr],
291                       Maybe [Linear.RegAllocStats])] )
292
293 cmmNativeGens _ _ _ _ [] impAcc profAcc _
294         = return (reverse impAcc, reverse profAcc)
295
296 cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
297  = do
298         let platform = targetPlatform dflags
299
300         (us', native, imports, colorStats, linearStats)
301                 <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
302
303         {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
304                 $ Pretty.vcat $ map (pprNatCmmDecl ncgImpl platform) native
305
306            -- carefully evaluate this strictly.  Binding it with 'let'
307            -- and then using 'seq' doesn't work, because the let
308            -- apparently gets inlined first.
309         lsPprNative <- return $!
310                 if  dopt Opt_D_dump_asm       dflags
311                  || dopt Opt_D_dump_asm_stats dflags
312                         then native
313                         else []
314
315         count' <- return $! count + 1;
316
317         -- force evaulation all this stuff to avoid space leaks
318         {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return ()
319
320         cmmNativeGens dflags ncgImpl
321             h us' cmms
322                         (imports : impAcc)
323                         ((lsPprNative, colorStats, linearStats) : profAcc)
324                         count'
325
326  where  seqString []            = ()
327         seqString (x:xs)        = x `seq` seqString xs `seq` ()
328
329
330 -- | Complete native code generation phase for a single top-level chunk of Cmm.
331 --      Dumping the output of each stage along the way.
332 --      Global conflict graph and NGC stats
333 cmmNativeGen
334         :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
335     => DynFlags
336     -> NcgImpl statics instr jumpDest
337         -> UniqSupply
338         -> RawCmmDecl                                   -- ^ the cmm to generate code for
339         -> Int                                          -- ^ sequence number of this top thing
340         -> IO   ( UniqSupply
341                 , [NatCmmDecl statics instr]                -- native code
342                 , [CLabel]                                  -- things imported by this cmm
343                 , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
344                 , Maybe [Linear.RegAllocStats])             -- stats for the linear register allocators
345
346 cmmNativeGen dflags ncgImpl us cmm count
347  = do
348         let platform = targetPlatform dflags
349
350         -- rewrite assignments to global regs
351         let fixed_cmm =
352                 {-# SCC "fixStgRegisters" #-}
353                 fixStgRegisters cmm
354
355         -- cmm to cmm optimisations
356         let (opt_cmm, imports) =
357                 {-# SCC "cmmToCmm" #-}
358                 cmmToCmm dflags fixed_cmm
359
360         dumpIfSet_dyn dflags
361                 Opt_D_dump_opt_cmm "Optimised Cmm"
362                 (pprCmmGroup platform [opt_cmm])
363
364         -- generate native code from cmm
365         let ((native, lastMinuteImports), usGen) =
366                 {-# SCC "genMachCode" #-}
367                 initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
368
369         dumpIfSet_dyn dflags
370                 Opt_D_dump_asm_native "Native code"
371                 (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native)
372
373         -- tag instructions with register liveness information
374         let (withLiveness, usLive) =
375                 {-# SCC "regLiveness" #-}
376                 initUs usGen
377                         $ mapUs (regLiveness platform)
378                         $ map natCmmTopToLive native
379
380         dumpIfSet_dyn dflags
381                 Opt_D_dump_asm_liveness "Liveness annotations added"
382                 (vcat $ map (pprPlatform platform) withLiveness)
383
384         -- allocate registers
385         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
386          if ( dopt Opt_RegsGraph dflags
387            || dopt Opt_RegsIterative dflags)
388           then do
389                 -- the regs usable for allocation
390                 let (alloc_regs :: UniqFM (UniqSet RealReg))
391                         = foldr (\r -> plusUFM_C unionUniqSets
392                                         $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
393                                 emptyUFM
394                         $ allocatableRegs ncgImpl
395
396                 -- do the graph coloring register allocation
397                 let ((alloced, regAllocStats), usAlloc)
398                         = {-# SCC "RegAlloc" #-}
399                           initUs usLive
400                           $ Color.regAlloc
401                                 dflags
402                                 alloc_regs
403                                 (mkUniqSet [0 .. maxSpillSlots ncgImpl])
404                                 withLiveness
405
406                 -- dump out what happened during register allocation
407                 dumpIfSet_dyn dflags
408                         Opt_D_dump_asm_regalloc "Registers allocated"
409                         (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
410
411                 dumpIfSet_dyn dflags
412                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"
413                         (vcat   $ map (\(stage, stats)
414                                         -> text "# --------------------------"
415                                         $$ text "#  cmm " <> int count <> text " Stage " <> int stage
416                                         $$ pprPlatform platform stats)
417                                 $ zip [0..] regAllocStats)
418
419                 let mPprStats =
420                         if dopt Opt_D_dump_asm_stats dflags
421                          then Just regAllocStats else Nothing
422
423                 -- force evaluation of the Maybe to avoid space leak
424                 mPprStats `seq` return ()
425
426                 return  ( alloced, usAlloc
427                         , mPprStats
428                         , Nothing)
429
430           else do
431                 -- do linear register allocation
432                 let ((alloced, regAllocStats), usAlloc)
433                         = {-# SCC "RegAlloc" #-}
434                           initUs usLive
435                           $ liftM unzip
436                           $ mapUs (Linear.regAlloc dflags) withLiveness
437
438                 dumpIfSet_dyn dflags
439                         Opt_D_dump_asm_regalloc "Registers allocated"
440                         (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
441
442                 let mPprStats =
443                         if dopt Opt_D_dump_asm_stats dflags
444                          then Just (catMaybes regAllocStats) else Nothing
445
446                 -- force evaluation of the Maybe to avoid space leak
447                 mPprStats `seq` return ()
448
449                 return  ( alloced, usAlloc
450                         , Nothing
451                         , mPprStats)
452
453         ---- x86fp_kludge.  This pass inserts ffree instructions to clear
454         ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
455         ---- is clear, and library functions can return odd results if it
456         ---- isn't.
457         ----
458         ---- NB. must happen before shortcutBranches, because that
459         ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
460         let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
461
462         ---- generate jump tables
463         let tabled      =
464                 {-# SCC "generateJumpTables" #-}
465                 generateJumpTables ncgImpl kludged
466
467         ---- shortcut branches
468         let shorted     =
469                 {-# SCC "shortcutBranches" #-}
470                 shortcutBranches dflags ncgImpl tabled
471
472         ---- sequence blocks
473         let sequenced   =
474                 {-# SCC "sequenceBlocks" #-}
475                 map (sequenceTop ncgImpl) shorted
476
477         ---- expansion of SPARC synthetic instrs
478         let expanded =
479                 {-# SCC "sparc_expand" #-}
480                 ncgExpandTop ncgImpl sequenced
481
482         dumpIfSet_dyn dflags
483                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
484                 (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded)
485
486         return  ( usAlloc
487                 , expanded
488                 , lastMinuteImports ++ imports
489                 , ppr_raStatsColor
490                 , ppr_raStatsLinear)
491
492
493 x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
494 x86fp_kludge top@(CmmData _ _) = top
495 x86fp_kludge (CmmProc info lbl (ListGraph code)) =
496         CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
497
498
499 -- | Build a doc for all the imports.
500 --
501 makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
502 makeImportsDoc dflags imports
503  = dyld_stubs imports
504             Pretty.$$
505             -- On recent versions of Darwin, the linker supports
506             -- dead-stripping of code and data on a per-symbol basis.
507             -- There's a hack to make this work in PprMach.pprNatCmmDecl.
508             (if platformHasSubsectionsViaSymbols (targetPlatform dflags)
509              then Pretty.text ".subsections_via_symbols"
510              else Pretty.empty)
511             Pretty.$$
512                 -- On recent GNU ELF systems one can mark an object file
513                 -- as not requiring an executable stack. If all objects
514                 -- linked into a program have this note then the program
515                 -- will not use an executable stack, which is good for
516                 -- security. GHC generated code does not need an executable
517                 -- stack so add the note in:
518             (if platformHasGnuNonexecStack (targetPlatform dflags)
519              then Pretty.text ".section .note.GNU-stack,\"\",@progbits"
520              else Pretty.empty)
521             Pretty.$$
522                 -- And just because every other compiler does, lets stick in
523                 -- an identifier directive: .ident "GHC x.y.z"
524             (if platformHasIdentDirective (targetPlatform dflags)
525              then let compilerIdent = Pretty.text "GHC" Pretty.<+>
526                                       Pretty.text cProjectVersion
527                    in Pretty.text ".ident" Pretty.<+>
528                       Pretty.doubleQuotes compilerIdent
529              else Pretty.empty)
530
531  where
532         -- Generate "symbol stubs" for all external symbols that might
533         -- come from a dynamic library.
534         dyld_stubs :: [CLabel] -> Pretty.Doc
535 {-      dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
536                                     map head $ group $ sort imps-}
537
538         platform = targetPlatform dflags
539         arch = platformArch platform
540         os   = platformOS   platform
541
542         -- (Hack) sometimes two Labels pretty-print the same, but have
543         -- different uniques; so we compare their text versions...
544         dyld_stubs imps
545                 | needImportedSymbols arch os
546                 = Pretty.vcat $
547                         (pprGotDeclaration arch os :) $
548                         map ( pprImportedSymbol platform . fst . head) $
549                         groupBy (\(_,a) (_,b) -> a == b) $
550                         sortBy (\(_,a) (_,b) -> compare a b) $
551                         map doPpr $
552                         imps
553                 | otherwise
554                 = Pretty.empty
555
556         doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle)
557         astyle = mkCodeStyle AsmStyle
558
559
560 -- -----------------------------------------------------------------------------
561 -- Sequencing the basic blocks
562
563 -- Cmm BasicBlocks are self-contained entities: they always end in a
564 -- jump, either non-local or to another basic block in the same proc.
565 -- In this phase, we attempt to place the basic blocks in a sequence
566 -- such that as many of the local jumps as possible turn into
567 -- fallthroughs.
568
569 sequenceTop
570         :: Instruction instr
571     => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
572
573 sequenceTop _       top@(CmmData _ _) = top
574 sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
575   CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
576
577 -- The algorithm is very simple (and stupid): we make a graph out of
578 -- the blocks where there is an edge from one block to another iff the
579 -- first block ends by jumping to the second.  Then we topologically
580 -- sort this graph.  Then traverse the list: for each block, we first
581 -- output the block, then if it has an out edge, we move the
582 -- destination of the out edge to the front of the list, and continue.
583
584 -- FYI, the classic layout for basic blocks uses postorder DFS; this
585 -- algorithm is implemented in Hoopl.
586
587 sequenceBlocks
588         :: Instruction instr
589         => [NatBasicBlock instr]
590         -> [NatBasicBlock instr]
591
592 sequenceBlocks [] = []
593 sequenceBlocks (entry:blocks) =
594   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
595   -- the first block is the entry point ==> it must remain at the start.
596
597
598 sccBlocks
599         :: Instruction instr
600         => [NatBasicBlock instr]
601         -> [SCC ( NatBasicBlock instr
602                 , Unique
603                 , [Unique])]
604
605 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
606
607 -- we're only interested in the last instruction of
608 -- the block, and only if it has a single destination.
609 getOutEdges
610         :: Instruction instr
611         => [instr] -> [Unique]
612
613 getOutEdges instrs
614         = case jumpDestsOfInstr (last instrs) of
615                 [one] -> [getUnique one]
616                 _many -> []
617
618 mkNode :: (Instruction t)
619        => GenBasicBlock t
620        -> (GenBasicBlock t, Unique, [Unique])
621 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
622
623 seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
624 seqBlocks [] = []
625 seqBlocks ((block,_,[]) : rest)
626   = block : seqBlocks rest
627 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
628   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
629   | otherwise       = block : seqBlocks rest'
630   where
631         (can_fallthrough, rest') = reorder next [] rest
632           -- TODO: we should do a better job for cycles; try to maximise the
633           -- fallthroughs within a loop.
634 seqBlocks _ = panic "AsmCodegen:seqBlocks"
635
636 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
637 reorder  _ accum [] = (False, reverse accum)
638 reorder id accum (b@(block,id',out) : rest)
639   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
640   | otherwise  = reorder id (b:accum) rest
641
642
643 -- -----------------------------------------------------------------------------
644 -- Making far branches
645
646 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
647 -- big, we have to work around this limitation.
648
649 makeFarBranches
650         :: [NatBasicBlock PPC.Instr.Instr]
651         -> [NatBasicBlock PPC.Instr.Instr]
652 makeFarBranches blocks
653     | last blockAddresses < nearLimit = blocks
654     | otherwise = zipWith handleBlock blockAddresses blocks
655     where
656         blockAddresses = scanl (+) 0 $ map blockLen blocks
657         blockLen (BasicBlock _ instrs) = length instrs
658
659         handleBlock addr (BasicBlock id instrs)
660                 = BasicBlock id (zipWith makeFar [addr..] instrs)
661
662         makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
663         makeFar addr (PPC.Instr.BCC cond tgt)
664             | abs (addr - targetAddr) >= nearLimit
665             = PPC.Instr.BCCFAR cond tgt
666             | otherwise
667             = PPC.Instr.BCC cond tgt
668             where Just targetAddr = lookupUFM blockAddressMap tgt
669         makeFar _ other            = other
670
671         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
672                          -- distance, as we have a few pseudo-insns that are
673                          -- pretty-printed as multiple instructions,
674                          -- and it's just not worth the effort to calculate
675                          -- things exactly
676
677         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
678
679 -- -----------------------------------------------------------------------------
680 -- Generate jump tables
681
682 -- Analyzes all native code and generates data sections for all jump
683 -- table instructions.
684 generateJumpTables
685         :: NcgImpl statics instr jumpDest
686     -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
687 generateJumpTables ncgImpl xs = concatMap f xs
688     where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
689           f p = [p]
690           g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
691
692 -- -----------------------------------------------------------------------------
693 -- Shortcut branches
694
695 shortcutBranches
696         :: DynFlags
697     -> NcgImpl statics instr jumpDest
698         -> [NatCmmDecl statics instr]
699         -> [NatCmmDecl statics instr]
700
701 shortcutBranches dflags ncgImpl tops
702   | optLevel dflags < 1 = tops    -- only with -O or higher
703   | otherwise           = map (apply_mapping ncgImpl mapping) tops'
704   where
705     (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
706     mapping = foldr plusUFM emptyUFM mappings
707
708 build_mapping :: NcgImpl statics instr jumpDest
709               -> GenCmmDecl d t (ListGraph instr)
710               -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
711 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
712 build_mapping _ (CmmProc info lbl (ListGraph []))
713   = (CmmProc info lbl (ListGraph []), emptyUFM)
714 build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
715   = (CmmProc info lbl (ListGraph (head:others)), mapping)
716         -- drop the shorted blocks, but don't ever drop the first one,
717         -- because it is pointed to by a global label.
718   where
719     -- find all the blocks that just consist of a jump that can be
720     -- shorted.
721     -- Don't completely eliminate loops here -- that can leave a dangling jump!
722     (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
723     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
724         | Just jd <- canShortcut ncgImpl insn,
725           Just dest <- getJumpDestBlockId ncgImpl jd,
726           (setMember dest s) || dest == id -- loop checks
727         = (s, shortcut_blocks, b : others)
728     split (s, shortcut_blocks, others) (BasicBlock id [insn])
729         | Just dest <- canShortcut ncgImpl insn
730         = (setInsert id s, (id,dest) : shortcut_blocks, others)
731     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
732
733
734     -- build a mapping from BlockId to JumpDest for shorting branches
735     mapping = foldl add emptyUFM shortcut_blocks
736     add ufm (id,dest) = addToUFM ufm id dest
737
738 apply_mapping :: NcgImpl statics instr jumpDest
739               -> UniqFM jumpDest
740               -> GenCmmDecl statics h (ListGraph instr)
741               -> GenCmmDecl statics h (ListGraph instr)
742 apply_mapping ncgImpl ufm (CmmData sec statics)
743   = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
744 apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
745   = CmmProc info lbl (ListGraph $ map short_bb blocks)
746   where
747     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
748     short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
749                  -- shortcutJump should apply the mapping repeatedly,
750                  -- just in case we can short multiple branches.
751
752 -- -----------------------------------------------------------------------------
753 -- Instruction selection
754
755 -- Native code instruction selection for a chunk of stix code.  For
756 -- this part of the computation, we switch from the UniqSM monad to
757 -- the NatM monad.  The latter carries not only a Unique, but also an
758 -- Int denoting the current C stack pointer offset in the generated
759 -- code; this is needed for creating correct spill offsets on
760 -- architectures which don't offer, or for which it would be
761 -- prohibitively expensive to employ, a frame pointer register.  Viz,
762 -- x86.
763
764 -- The offset is measured in bytes, and indicates the difference
765 -- between the current (simulated) C stack-ptr and the value it was at
766 -- the beginning of the block.  For stacks which grow down, this value
767 -- should be either zero or negative.
768
769 -- Switching between the two monads whilst carrying along the same
770 -- Unique supply breaks abstraction.  Is that bad?
771
772 genMachCode
773         :: DynFlags
774         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
775         -> RawCmmDecl
776         -> UniqSM
777                 ( [NatCmmDecl statics instr]
778                 , [CLabel])
779
780 genMachCode dflags cmmTopCodeGen cmm_top
781   = do  { initial_us <- getUs
782         ; let initial_st           = mkNatM_State initial_us 0 dflags
783               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
784               final_delta          = natm_delta final_st
785               final_imports        = natm_imports final_st
786         ; if   final_delta == 0
787           then return (new_tops, final_imports)
788           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
789     }
790
791 -- -----------------------------------------------------------------------------
792 -- Generic Cmm optimiser
793
794 {-
795 Here we do:
796
797   (a) Constant folding
798   (b) Simple inlining: a temporary which is assigned to and then
799       used, once, can be shorted.
800   (c) Position independent code and dynamic linking
801         (i)  introduce the appropriate indirections
802              and position independent refs
803         (ii) compile a list of imported symbols
804   (d) Some arch-specific optimizations
805
806 (a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
807 (d) are only needed by the native backend and will continue to live
808 here.
809
810 Ideas for other things we could do (put these in Hoopl please!):
811
812   - shortcut jumps-to-jumps
813   - simple CSE: if an expr is assigned to a temp, then replace later occs of
814     that expr with the temp, until the expr is no longer valid (can push through
815     temp assignments, and certain assigns to mem...)
816 -}
817
818 cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
819 cmmToCmm _ top@(CmmData _ _) = (top, [])
820 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
821   let platform = targetPlatform dflags
822   blocks' <- mapM cmmBlockConFold (cmmMiniInline platform (cmmEliminateDeadBlocks blocks))
823   return $ CmmProc info lbl (ListGraph blocks')
824
825 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
826
827 instance Monad CmmOptM where
828   return x = CmmOptM $ \(imports, _) -> (# x,imports #)
829   (CmmOptM f) >>= g =
830     CmmOptM $ \(imports, dflags) ->
831                 case f (imports, dflags) of
832                   (# x, imports' #) ->
833                     case g x of
834                       CmmOptM g' -> g' (imports', dflags)
835
836 addImportCmmOpt :: CLabel -> CmmOptM ()
837 addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
838
839 instance HasDynFlags CmmOptM where
840     getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
841
842 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
843 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
844                         (# result, imports #) -> (result, imports)
845
846 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
847 cmmBlockConFold (BasicBlock id stmts) = do
848   stmts' <- mapM cmmStmtConFold stmts
849   return $ BasicBlock id stmts'
850
851 -- This does three optimizations, but they're very quick to check, so we don't
852 -- bother turning them off even when the Hoopl code is active.  Since
853 -- this is on the old Cmm representation, we can't reuse the code either:
854 --  * reg = reg      --> nop
855 --  * if 0 then jump --> nop
856 --  * if 1 then jump --> jump
857 -- We might be tempted to skip this step entirely of not opt_PIC, but
858 -- there is some PowerPC code for the non-PIC case, which would also
859 -- have to be separated.
860 cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
861 cmmStmtConFold stmt
862    = case stmt of
863         CmmAssign reg src
864            -> do src' <- cmmExprConFold DataReference src
865                  return $ case src' of
866                    CmmReg reg' | reg == reg' -> CmmNop
867                    new_src -> CmmAssign reg new_src
868
869         CmmStore addr src
870            -> do addr' <- cmmExprConFold DataReference addr
871                  src'  <- cmmExprConFold DataReference src
872                  return $ CmmStore addr' src'
873
874         CmmJump addr live
875            -> do addr' <- cmmExprConFold JumpReference addr
876                  return $ CmmJump addr' live
877
878         CmmCall target regs args returns
879            -> do target' <- case target of
880                               CmmCallee e conv -> do
881                                 e' <- cmmExprConFold CallReference e
882                                 return $ CmmCallee e' conv
883                               op@(CmmPrim _ Nothing) ->
884                                 return op
885                               CmmPrim op (Just stmts) ->
886                                 do stmts' <- mapM cmmStmtConFold stmts
887                                    return $ CmmPrim op (Just stmts')
888                  args' <- mapM (\(CmmHinted arg hint) -> do
889                                   arg' <- cmmExprConFold DataReference arg
890                                   return (CmmHinted arg' hint)) args
891                  return $ CmmCall target' regs args' returns
892
893         CmmCondBranch test dest
894            -> do test' <- cmmExprConFold DataReference test
895                  dflags <- getDynFlags
896                  let platform = targetPlatform dflags
897                  return $ case test' of
898                    CmmLit (CmmInt 0 _) ->
899                      CmmComment (mkFastString ("deleted: " ++
900                                         showSDoc (pprStmt platform stmt)))
901
902                    CmmLit (CmmInt _ _) -> CmmBranch dest
903                    _other -> CmmCondBranch test' dest
904
905         CmmSwitch expr ids
906            -> do expr' <- cmmExprConFold DataReference expr
907                  return $ CmmSwitch expr' ids
908
909         other
910            -> return other
911
912 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
913 cmmExprConFold referenceKind expr = do
914     dflags <- getDynFlags
915     -- Skip constant folding if new code generator is running
916     -- (this optimization is done in Hoopl)
917     let expr' = if dopt Opt_TryNewCodeGen dflags
918                     then expr
919                     else cmmExprCon (targetPlatform dflags) expr
920     cmmExprNative referenceKind expr'
921
922 cmmExprCon :: Platform -> CmmExpr -> CmmExpr
923 cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
924 cmmExprCon platform (CmmMachOp mop args)
925     = cmmMachOpFold platform mop (map (cmmExprCon platform) args)
926 cmmExprCon _ other = other
927
928 -- handles both PIC and non-PIC cases... a very strange mixture
929 -- of things to do.
930 cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
931 cmmExprNative referenceKind expr = do
932      dflags <- getDynFlags
933      let platform = targetPlatform dflags
934          arch = platformArch platform
935      case expr of
936         CmmLoad addr rep
937            -> do addr' <- cmmExprNative DataReference addr
938                  return $ CmmLoad addr' rep
939
940         CmmMachOp mop args
941            -> do args' <- mapM (cmmExprNative DataReference) args
942                  return $ CmmMachOp mop args'
943
944         CmmLit (CmmLabel lbl)
945            -> do
946                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
947         CmmLit (CmmLabelOff lbl off)
948            -> do
949                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
950                  -- need to optimize here, since it's late
951                  return $ cmmMachOpFold platform (MO_Add wordWidth) [
952                      dynRef,
953                      (CmmLit $ CmmInt (fromIntegral off) wordWidth)
954                    ]
955
956         -- On powerpc (non-PIC), it's easier to jump directly to a label than
957         -- to use the register table, so we replace these registers
958         -- with the corresponding labels:
959         CmmReg (CmmGlobal EagerBlackholeInfo)
960           | arch == ArchPPC && not opt_PIC
961           -> cmmExprNative referenceKind $
962              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
963         CmmReg (CmmGlobal GCEnter1)
964           | arch == ArchPPC && not opt_PIC
965           -> cmmExprNative referenceKind $
966              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
967         CmmReg (CmmGlobal GCFun)
968           | arch == ArchPPC && not opt_PIC
969           -> cmmExprNative referenceKind $
970              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
971
972         other
973            -> return other
974
975 \end{code}
976