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