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