Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[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 Util
63
64 import BasicTypes       ( Alignment )
65 import Digraph
66 import qualified Pretty
67 import BufWrite
68 import Outputable
69 import FastString
70 import UniqSet
71 import ErrUtils
72 import Module
73 import Stream (Stream)
74 import qualified Stream
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 'SDoc').
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 :: DynFlags -> 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 -> SDoc,
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 -> Stream IO RawCmmGroup () -> IO ()
152 nativeCodeGen dflags h us cmms
153  = let platform = targetPlatform dflags
154        nCG' :: (Outputable statics, Outputable 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' :: (Outputable statics, Outputable instr, Instruction instr)
211                => DynFlags
212                -> NcgImpl statics instr jumpDest
213                -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
214 nativeCodeGen' dflags ncgImpl h us cmms
215  = do
216         let platform = targetPlatform dflags
217             split_cmms  = Stream.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) <- cmmNativeGenStream 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 (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 (pprCols dflags) h
264                 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
265                 $ makeImportsDoc dflags (concat imports)
266
267         return  ()
268
269  where  add_split tops
270                 | dopt Opt_SplitObjs dflags = split_marker : tops
271                 | otherwise                 = tops
272
273         split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
274
275
276 cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
277               => DynFlags
278               -> NcgImpl statics instr jumpDest
279               -> BufHandle
280               -> UniqSupply
281               -> Stream IO RawCmmGroup ()
282               -> [[CLabel]]
283               -> [ ([NatCmmDecl statics instr],
284                    Maybe [Color.RegAllocStats statics instr],
285                    Maybe [Linear.RegAllocStats]) ]
286               -> Int
287               -> IO ( [[CLabel]],
288                       [([NatCmmDecl statics instr],
289                       Maybe [Color.RegAllocStats statics instr],
290                       Maybe [Linear.RegAllocStats])] )
291
292 cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count
293  = do
294         r <- Stream.runStream cmm_stream
295         case r of
296           Left () -> return (reverse impAcc, reverse profAcc)
297           Right (cmms, cmm_stream') -> do
298             (impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms
299                                               impAcc profAcc count
300             cmmNativeGenStream dflags ncgImpl h us' cmm_stream'
301                                               impAcc profAcc count
302
303
304 -- | Do native code generation on all these cmms.
305 --
306 cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
307               => DynFlags
308               -> NcgImpl statics instr jumpDest
309               -> BufHandle
310               -> UniqSupply
311               -> [RawCmmDecl]
312               -> [[CLabel]]
313               -> [ ([NatCmmDecl statics instr],
314                    Maybe [Color.RegAllocStats statics instr],
315                    Maybe [Linear.RegAllocStats]) ]
316               -> Int
317               -> IO ( [[CLabel]],
318                       [([NatCmmDecl statics instr],
319                        Maybe [Color.RegAllocStats statics instr],
320                        Maybe [Linear.RegAllocStats])],
321                       UniqSupply )
322
323 cmmNativeGens _ _ _ us [] impAcc profAcc _
324         = return (impAcc,profAcc,us)
325
326 cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
327  = do
328         let platform = targetPlatform dflags
329
330         (us', native, imports, colorStats, linearStats)
331                 <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
332
333         {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
334                 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
335                 $ vcat $ map (pprNatCmmDecl ncgImpl platform) native
336
337            -- carefully evaluate this strictly.  Binding it with 'let'
338            -- and then using 'seq' doesn't work, because the let
339            -- apparently gets inlined first.
340         lsPprNative <- return $!
341                 if  dopt Opt_D_dump_asm       dflags
342                  || dopt Opt_D_dump_asm_stats dflags
343                         then native
344                         else []
345
346         count' <- return $! count + 1;
347
348         -- force evaulation all this stuff to avoid space leaks
349         {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return ()
350
351         cmmNativeGens dflags ncgImpl
352             h us' cmms
353                         (imports : impAcc)
354                         ((lsPprNative, colorStats, linearStats) : profAcc)
355                         count'
356
357  where  seqString []            = ()
358         seqString (x:xs)        = x `seq` seqString xs `seq` ()
359
360
361 -- | Complete native code generation phase for a single top-level chunk of Cmm.
362 --      Dumping the output of each stage along the way.
363 --      Global conflict graph and NGC stats
364 cmmNativeGen
365         :: (Outputable statics, Outputable instr, Instruction instr)
366     => DynFlags
367     -> NcgImpl statics instr jumpDest
368         -> UniqSupply
369         -> RawCmmDecl                                   -- ^ the cmm to generate code for
370         -> Int                                          -- ^ sequence number of this top thing
371         -> IO   ( UniqSupply
372                 , [NatCmmDecl statics instr]                -- native code
373                 , [CLabel]                                  -- things imported by this cmm
374                 , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
375                 , Maybe [Linear.RegAllocStats])             -- stats for the linear register allocators
376
377 cmmNativeGen dflags ncgImpl us cmm count
378  = do
379         let platform = targetPlatform dflags
380
381         -- rewrite assignments to global regs
382         let fixed_cmm =
383                 {-# SCC "fixStgRegisters" #-}
384                 fixStgRegisters cmm
385
386         -- cmm to cmm optimisations
387         let (opt_cmm, imports) =
388                 {-# SCC "cmmToCmm" #-}
389                 cmmToCmm dflags fixed_cmm
390
391         dumpIfSet_dyn dflags
392                 Opt_D_dump_opt_cmm "Optimised Cmm"
393                 (pprCmmGroup [opt_cmm])
394
395         -- generate native code from cmm
396         let ((native, lastMinuteImports), usGen) =
397                 {-# SCC "genMachCode" #-}
398                 initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
399
400         dumpIfSet_dyn dflags
401                 Opt_D_dump_asm_native "Native code"
402                 (vcat $ map (pprNatCmmDecl ncgImpl platform) native)
403
404         -- tag instructions with register liveness information
405         let (withLiveness, usLive) =
406                 {-# SCC "regLiveness" #-}
407                 initUs usGen
408                         $ mapM regLiveness
409                         $ map natCmmTopToLive native
410
411         dumpIfSet_dyn dflags
412                 Opt_D_dump_asm_liveness "Liveness annotations added"
413                 (vcat $ map ppr withLiveness)
414
415         -- allocate registers
416         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
417          if ( dopt Opt_RegsGraph dflags
418            || dopt Opt_RegsIterative dflags)
419           then do
420                 -- the regs usable for allocation
421                 let (alloc_regs :: UniqFM (UniqSet RealReg))
422                         = foldr (\r -> plusUFM_C unionUniqSets
423                                         $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
424                                 emptyUFM
425                         $ allocatableRegs ncgImpl
426
427                 -- do the graph coloring register allocation
428                 let ((alloced, regAllocStats), usAlloc)
429                         = {-# SCC "RegAlloc" #-}
430                           initUs usLive
431                           $ Color.regAlloc
432                                 dflags
433                                 alloc_regs
434                                 (mkUniqSet [0 .. maxSpillSlots ncgImpl])
435                                 withLiveness
436
437                 -- dump out what happened during register allocation
438                 dumpIfSet_dyn dflags
439                         Opt_D_dump_asm_regalloc "Registers allocated"
440                         (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
441
442                 dumpIfSet_dyn dflags
443                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"
444                         (vcat   $ map (\(stage, stats)
445                                         -> text "# --------------------------"
446                                         $$ text "#  cmm " <> int count <> text " Stage " <> int stage
447                                         $$ ppr stats)
448                                 $ zip [0..] regAllocStats)
449
450                 let mPprStats =
451                         if dopt Opt_D_dump_asm_stats dflags
452                          then Just regAllocStats else Nothing
453
454                 -- force evaluation of the Maybe to avoid space leak
455                 mPprStats `seq` return ()
456
457                 return  ( alloced, usAlloc
458                         , mPprStats
459                         , Nothing)
460
461           else do
462                 -- do linear register allocation
463                 let ((alloced, regAllocStats), usAlloc)
464                         = {-# SCC "RegAlloc" #-}
465                           initUs usLive
466                           $ liftM unzip
467                           $ mapM (Linear.regAlloc dflags) withLiveness
468
469                 dumpIfSet_dyn dflags
470                         Opt_D_dump_asm_regalloc "Registers allocated"
471                         (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
472
473                 let mPprStats =
474                         if dopt Opt_D_dump_asm_stats dflags
475                          then Just (catMaybes regAllocStats) else Nothing
476
477                 -- force evaluation of the Maybe to avoid space leak
478                 mPprStats `seq` return ()
479
480                 return  ( alloced, usAlloc
481                         , Nothing
482                         , mPprStats)
483
484         ---- x86fp_kludge.  This pass inserts ffree instructions to clear
485         ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
486         ---- is clear, and library functions can return odd results if it
487         ---- isn't.
488         ----
489         ---- NB. must happen before shortcutBranches, because that
490         ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
491         let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
492
493         ---- generate jump tables
494         let tabled      =
495                 {-# SCC "generateJumpTables" #-}
496                 generateJumpTables dflags ncgImpl kludged
497
498         ---- shortcut branches
499         let shorted     =
500                 {-# SCC "shortcutBranches" #-}
501                 shortcutBranches dflags ncgImpl tabled
502
503         ---- sequence blocks
504         let sequenced   =
505                 {-# SCC "sequenceBlocks" #-}
506                 map (sequenceTop ncgImpl) shorted
507
508         ---- expansion of SPARC synthetic instrs
509         let expanded =
510                 {-# SCC "sparc_expand" #-}
511                 ncgExpandTop ncgImpl sequenced
512
513         dumpIfSet_dyn dflags
514                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
515                 (vcat $ map (pprNatCmmDecl ncgImpl platform) expanded)
516
517         return  ( usAlloc
518                 , expanded
519                 , lastMinuteImports ++ imports
520                 , ppr_raStatsColor
521                 , ppr_raStatsLinear)
522
523
524 x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
525 x86fp_kludge top@(CmmData _ _) = top
526 x86fp_kludge (CmmProc info lbl (ListGraph code)) =
527         CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
528
529
530 -- | Build a doc for all the imports.
531 --
532 makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
533 makeImportsDoc dflags imports
534  = dyld_stubs imports
535             $$
536             -- On recent versions of Darwin, the linker supports
537             -- dead-stripping of code and data on a per-symbol basis.
538             -- There's a hack to make this work in PprMach.pprNatCmmDecl.
539             (if platformHasSubsectionsViaSymbols (targetPlatform dflags)
540              then text ".subsections_via_symbols"
541              else empty)
542             $$
543                 -- On recent GNU ELF systems one can mark an object file
544                 -- as not requiring an executable stack. If all objects
545                 -- linked into a program have this note then the program
546                 -- will not use an executable stack, which is good for
547                 -- security. GHC generated code does not need an executable
548                 -- stack so add the note in:
549             (if platformHasGnuNonexecStack (targetPlatform dflags)
550              then text ".section .note.GNU-stack,\"\",@progbits"
551              else empty)
552             $$
553                 -- And just because every other compiler does, lets stick in
554                 -- an identifier directive: .ident "GHC x.y.z"
555             (if platformHasIdentDirective (targetPlatform dflags)
556              then let compilerIdent = text "GHC" <+> text cProjectVersion
557                    in text ".ident" <+> doubleQuotes compilerIdent
558              else empty)
559
560  where
561         -- Generate "symbol stubs" for all external symbols that might
562         -- come from a dynamic library.
563         dyld_stubs :: [CLabel] -> SDoc
564 {-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
565                                     map head $ group $ sort imps-}
566
567         platform = targetPlatform dflags
568         arch = platformArch platform
569         os   = platformOS   platform
570
571         -- (Hack) sometimes two Labels pretty-print the same, but have
572         -- different uniques; so we compare their text versions...
573         dyld_stubs imps
574                 | needImportedSymbols dflags arch os
575                 = vcat $
576                         (pprGotDeclaration dflags arch os :) $
577                         map ( pprImportedSymbol dflags platform . fst . head) $
578                         groupBy (\(_,a) (_,b) -> a == b) $
579                         sortBy (\(_,a) (_,b) -> compare a b) $
580                         map doPpr $
581                         imps
582                 | otherwise
583                 = empty
584
585         doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
586         astyle = mkCodeStyle AsmStyle
587
588
589 -- -----------------------------------------------------------------------------
590 -- Sequencing the basic blocks
591
592 -- Cmm BasicBlocks are self-contained entities: they always end in a
593 -- jump, either non-local or to another basic block in the same proc.
594 -- In this phase, we attempt to place the basic blocks in a sequence
595 -- such that as many of the local jumps as possible turn into
596 -- fallthroughs.
597
598 sequenceTop
599         :: Instruction instr
600     => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
601
602 sequenceTop _       top@(CmmData _ _) = top
603 sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
604   CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
605
606 -- The algorithm is very simple (and stupid): we make a graph out of
607 -- the blocks where there is an edge from one block to another iff the
608 -- first block ends by jumping to the second.  Then we topologically
609 -- sort this graph.  Then traverse the list: for each block, we first
610 -- output the block, then if it has an out edge, we move the
611 -- destination of the out edge to the front of the list, and continue.
612
613 -- FYI, the classic layout for basic blocks uses postorder DFS; this
614 -- algorithm is implemented in Hoopl.
615
616 sequenceBlocks
617         :: Instruction instr
618         => [NatBasicBlock instr]
619         -> [NatBasicBlock instr]
620
621 sequenceBlocks [] = []
622 sequenceBlocks (entry:blocks) =
623   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
624   -- the first block is the entry point ==> it must remain at the start.
625
626
627 sccBlocks
628         :: Instruction instr
629         => [NatBasicBlock instr]
630         -> [SCC ( NatBasicBlock instr
631                 , Unique
632                 , [Unique])]
633
634 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
635
636 -- we're only interested in the last instruction of
637 -- the block, and only if it has a single destination.
638 getOutEdges
639         :: Instruction instr
640         => [instr] -> [Unique]
641
642 getOutEdges instrs
643         = case jumpDestsOfInstr (last instrs) of
644                 [one] -> [getUnique one]
645                 _many -> []
646
647 mkNode :: (Instruction t)
648        => GenBasicBlock t
649        -> (GenBasicBlock t, Unique, [Unique])
650 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
651
652 seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
653 seqBlocks [] = []
654 seqBlocks ((block,_,[]) : rest)
655   = block : seqBlocks rest
656 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
657   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
658   | otherwise       = block : seqBlocks rest'
659   where
660         (can_fallthrough, rest') = reorder next [] rest
661           -- TODO: we should do a better job for cycles; try to maximise the
662           -- fallthroughs within a loop.
663 seqBlocks _ = panic "AsmCodegen:seqBlocks"
664
665 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
666 reorder  _ accum [] = (False, reverse accum)
667 reorder id accum (b@(block,id',out) : rest)
668   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
669   | otherwise  = reorder id (b:accum) rest
670
671
672 -- -----------------------------------------------------------------------------
673 -- Making far branches
674
675 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
676 -- big, we have to work around this limitation.
677
678 makeFarBranches
679         :: [NatBasicBlock PPC.Instr.Instr]
680         -> [NatBasicBlock PPC.Instr.Instr]
681 makeFarBranches blocks
682     | last blockAddresses < nearLimit = blocks
683     | otherwise = zipWith handleBlock blockAddresses blocks
684     where
685         blockAddresses = scanl (+) 0 $ map blockLen blocks
686         blockLen (BasicBlock _ instrs) = length instrs
687
688         handleBlock addr (BasicBlock id instrs)
689                 = BasicBlock id (zipWith makeFar [addr..] instrs)
690
691         makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
692         makeFar addr (PPC.Instr.BCC cond tgt)
693             | abs (addr - targetAddr) >= nearLimit
694             = PPC.Instr.BCCFAR cond tgt
695             | otherwise
696             = PPC.Instr.BCC cond tgt
697             where Just targetAddr = lookupUFM blockAddressMap tgt
698         makeFar _ other            = other
699
700         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
701                          -- distance, as we have a few pseudo-insns that are
702                          -- pretty-printed as multiple instructions,
703                          -- and it's just not worth the effort to calculate
704                          -- things exactly
705
706         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
707
708 -- -----------------------------------------------------------------------------
709 -- Generate jump tables
710
711 -- Analyzes all native code and generates data sections for all jump
712 -- table instructions.
713 generateJumpTables
714         :: DynFlags -> NcgImpl statics instr jumpDest
715     -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
716 generateJumpTables dflags ncgImpl xs = concatMap f xs
717     where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
718           f p = [p]
719           g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl dflags) xs)
720
721 -- -----------------------------------------------------------------------------
722 -- Shortcut branches
723
724 shortcutBranches
725         :: DynFlags
726     -> NcgImpl statics instr jumpDest
727         -> [NatCmmDecl statics instr]
728         -> [NatCmmDecl statics instr]
729
730 shortcutBranches dflags ncgImpl tops
731   | optLevel dflags < 1 = tops    -- only with -O or higher
732   | otherwise           = map (apply_mapping ncgImpl mapping) tops'
733   where
734     (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
735     mapping = foldr plusUFM emptyUFM mappings
736
737 build_mapping :: NcgImpl statics instr jumpDest
738               -> GenCmmDecl d t (ListGraph instr)
739               -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
740 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
741 build_mapping _ (CmmProc info lbl (ListGraph []))
742   = (CmmProc info lbl (ListGraph []), emptyUFM)
743 build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
744   = (CmmProc info lbl (ListGraph (head:others)), mapping)
745         -- drop the shorted blocks, but don't ever drop the first one,
746         -- because it is pointed to by a global label.
747   where
748     -- find all the blocks that just consist of a jump that can be
749     -- shorted.
750     -- Don't completely eliminate loops here -- that can leave a dangling jump!
751     (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
752     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
753         | Just jd <- canShortcut ncgImpl insn,
754           Just dest <- getJumpDestBlockId ncgImpl jd,
755           (setMember dest s) || dest == id -- loop checks
756         = (s, shortcut_blocks, b : others)
757     split (s, shortcut_blocks, others) (BasicBlock id [insn])
758         | Just dest <- canShortcut ncgImpl insn
759         = (setInsert id s, (id,dest) : shortcut_blocks, others)
760     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
761
762
763     -- build a mapping from BlockId to JumpDest for shorting branches
764     mapping = foldl add emptyUFM shortcut_blocks
765     add ufm (id,dest) = addToUFM ufm id dest
766
767 apply_mapping :: NcgImpl statics instr jumpDest
768               -> UniqFM jumpDest
769               -> GenCmmDecl statics h (ListGraph instr)
770               -> GenCmmDecl statics h (ListGraph instr)
771 apply_mapping ncgImpl ufm (CmmData sec statics)
772   = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
773 apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
774   = CmmProc info lbl (ListGraph $ map short_bb blocks)
775   where
776     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
777     short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
778                  -- shortcutJump should apply the mapping repeatedly,
779                  -- just in case we can short multiple branches.
780
781 -- -----------------------------------------------------------------------------
782 -- Instruction selection
783
784 -- Native code instruction selection for a chunk of stix code.  For
785 -- this part of the computation, we switch from the UniqSM monad to
786 -- the NatM monad.  The latter carries not only a Unique, but also an
787 -- Int denoting the current C stack pointer offset in the generated
788 -- code; this is needed for creating correct spill offsets on
789 -- architectures which don't offer, or for which it would be
790 -- prohibitively expensive to employ, a frame pointer register.  Viz,
791 -- x86.
792
793 -- The offset is measured in bytes, and indicates the difference
794 -- between the current (simulated) C stack-ptr and the value it was at
795 -- the beginning of the block.  For stacks which grow down, this value
796 -- should be either zero or negative.
797
798 -- Switching between the two monads whilst carrying along the same
799 -- Unique supply breaks abstraction.  Is that bad?
800
801 genMachCode
802         :: DynFlags
803         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
804         -> RawCmmDecl
805         -> UniqSM
806                 ( [NatCmmDecl statics instr]
807                 , [CLabel])
808
809 genMachCode dflags cmmTopCodeGen cmm_top
810   = do  { initial_us <- getUs
811         ; let initial_st           = mkNatM_State initial_us 0 dflags
812               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
813               final_delta          = natm_delta final_st
814               final_imports        = natm_imports final_st
815         ; if   final_delta == 0
816           then return (new_tops, final_imports)
817           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
818     }
819
820 -- -----------------------------------------------------------------------------
821 -- Generic Cmm optimiser
822
823 {-
824 Here we do:
825
826   (a) Constant folding
827   (b) Simple inlining: a temporary which is assigned to and then
828       used, once, can be shorted.
829   (c) Position independent code and dynamic linking
830         (i)  introduce the appropriate indirections
831              and position independent refs
832         (ii) compile a list of imported symbols
833   (d) Some arch-specific optimizations
834
835 (a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
836 (d) are only needed by the native backend and will continue to live
837 here.
838
839 Ideas for other things we could do (put these in Hoopl please!):
840
841   - shortcut jumps-to-jumps
842   - simple CSE: if an expr is assigned to a temp, then replace later occs of
843     that expr with the temp, until the expr is no longer valid (can push through
844     temp assignments, and certain assigns to mem...)
845 -}
846
847 cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
848 cmmToCmm _ top@(CmmData _ _) = (top, [])
849 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
850   let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks
851                        | otherwise = cmmEliminateDeadBlocks blocks
852       -- The new codegen path has already eliminated unreachable blocks by now
853
854   blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags reachable_blocks)
855   return $ CmmProc info lbl (ListGraph blocks')
856
857 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
858
859 instance Monad CmmOptM where
860   return x = CmmOptM $ \(imports, _) -> (# x,imports #)
861   (CmmOptM f) >>= g =
862     CmmOptM $ \(imports, dflags) ->
863                 case f (imports, dflags) of
864                   (# x, imports' #) ->
865                     case g x of
866                       CmmOptM g' -> g' (imports', dflags)
867
868 addImportCmmOpt :: CLabel -> CmmOptM ()
869 addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
870
871 instance HasDynFlags CmmOptM where
872     getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
873
874 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
875 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
876                         (# result, imports #) -> (result, imports)
877
878 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
879 cmmBlockConFold (BasicBlock id stmts) = do
880   stmts' <- mapM cmmStmtConFold stmts
881   return $ BasicBlock id stmts'
882
883 -- This does three optimizations, but they're very quick to check, so we don't
884 -- bother turning them off even when the Hoopl code is active.  Since
885 -- this is on the old Cmm representation, we can't reuse the code either:
886 --  * reg = reg      --> nop
887 --  * if 0 then jump --> nop
888 --  * if 1 then jump --> jump
889 -- We might be tempted to skip this step entirely of not Opt_PIC, but
890 -- there is some PowerPC code for the non-PIC case, which would also
891 -- have to be separated.
892 cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
893 cmmStmtConFold stmt
894    = case stmt of
895         CmmAssign reg src
896            -> do src' <- cmmExprConFold DataReference src
897                  return $ case src' of
898                    CmmReg reg' | reg == reg' -> CmmNop
899                    new_src -> CmmAssign reg new_src
900
901         CmmStore addr src
902            -> do addr' <- cmmExprConFold DataReference addr
903                  src'  <- cmmExprConFold DataReference src
904                  return $ CmmStore addr' src'
905
906         CmmJump addr live
907            -> do addr' <- cmmExprConFold JumpReference addr
908                  return $ CmmJump addr' live
909
910         CmmCall target regs args returns
911            -> do target' <- case target of
912                               CmmCallee e conv -> do
913                                 e' <- cmmExprConFold CallReference e
914                                 return $ CmmCallee e' conv
915                               op@(CmmPrim _ Nothing) ->
916                                 return op
917                               CmmPrim op (Just stmts) ->
918                                 do stmts' <- mapM cmmStmtConFold stmts
919                                    return $ CmmPrim op (Just stmts')
920                  args' <- mapM (\(CmmHinted arg hint) -> do
921                                   arg' <- cmmExprConFold DataReference arg
922                                   return (CmmHinted arg' hint)) args
923                  return $ CmmCall target' regs args' returns
924
925         CmmCondBranch test dest
926            -> do test' <- cmmExprConFold DataReference test
927                  dflags <- getDynFlags
928                  return $ case test' of
929                    CmmLit (CmmInt 0 _) ->
930                      CmmComment (mkFastString ("deleted: " ++
931                                         showSDoc dflags (pprStmt stmt)))
932
933                    CmmLit (CmmInt _ _) -> CmmBranch dest
934                    _other -> CmmCondBranch test' dest
935
936         CmmSwitch expr ids
937            -> do expr' <- cmmExprConFold DataReference expr
938                  return $ CmmSwitch expr' ids
939
940         other
941            -> return other
942
943 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
944 cmmExprConFold referenceKind expr = do
945     dflags <- getDynFlags
946     -- Skip constant folding if new code generator is running
947     -- (this optimization is done in Hoopl)
948     -- SDM: re-enabled for now, while cmmRewriteAssignments is turned off
949     let expr' = if False -- dopt Opt_TryNewCodeGen dflags
950                     then expr
951                     else cmmExprCon (targetPlatform dflags) expr
952     cmmExprNative referenceKind expr'
953
954 cmmExprCon :: Platform -> CmmExpr -> CmmExpr
955 cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
956 cmmExprCon platform (CmmMachOp mop args)
957     = cmmMachOpFold platform mop (map (cmmExprCon platform) args)
958 cmmExprCon _ other = other
959
960 -- handles both PIC and non-PIC cases... a very strange mixture
961 -- of things to do.
962 cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
963 cmmExprNative referenceKind expr = do
964      dflags <- getDynFlags
965      let platform = targetPlatform dflags
966          arch = platformArch platform
967      case expr of
968         CmmLoad addr rep
969            -> do addr' <- cmmExprNative DataReference addr
970                  return $ CmmLoad addr' rep
971
972         CmmMachOp mop args
973            -> do args' <- mapM (cmmExprNative DataReference) args
974                  return $ CmmMachOp mop args'
975
976         CmmLit (CmmLabel lbl)
977            -> do
978                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
979         CmmLit (CmmLabelOff lbl off)
980            -> do
981                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
982                  -- need to optimize here, since it's late
983                  return $ cmmMachOpFold platform (MO_Add wordWidth) [
984                      dynRef,
985                      (CmmLit $ CmmInt (fromIntegral off) wordWidth)
986                    ]
987
988         -- On powerpc (non-PIC), it's easier to jump directly to a label than
989         -- to use the register table, so we replace these registers
990         -- with the corresponding labels:
991         CmmReg (CmmGlobal EagerBlackholeInfo)
992           | arch == ArchPPC && not (dopt Opt_PIC dflags)
993           -> cmmExprNative referenceKind $
994              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
995         CmmReg (CmmGlobal GCEnter1)
996           | arch == ArchPPC && not (dopt Opt_PIC dflags)
997           -> cmmExprNative referenceKind $
998              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
999         CmmReg (CmmGlobal GCFun)
1000           | arch == ArchPPC && not (dopt Opt_PIC dflags)
1001           -> cmmExprNative referenceKind $
1002              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
1003
1004         other
1005            -> return other
1006
1007 \end{code}
1008