Snapshot of codegen refactoring to share with simonpj
[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             :: RawCmmTop -> NatM [NatCmmTop statics instr],
137     generateJumpTableForInstr :: instr -> Maybe (NatCmmTop 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     pprNatCmmTop              :: Platform -> NatCmmTop statics instr -> Doc,
143     maxSpillSlots             :: Int,
144     allocatableRegs           :: [RealReg],
145     ncg_x86fp_kludge          :: [NatCmmTop statics instr] -> [NatCmmTop statics instr],
146     ncgExpandTop              :: [NatCmmTop statics instr] -> [NatCmmTop statics instr],
147     ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
148     }
149
150 --------------------
151 nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmPgm] -> IO ()
152 nativeCodeGen dflags h us cmms
153  = let nCG' :: (Outputable 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                         ,pprNatCmmTop              = X86.Ppr.pprNatCmmTop
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                          ,pprNatCmmTop              = PPC.Ppr.pprNatCmmTop
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                          ,pprNatCmmTop              = SPARC.Ppr.pprNatCmmTop
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                  ArchUnknown ->
207                      panic "nativeCodeGen: No NCG for unknown arch"
208
209 nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr)
210                => DynFlags
211                -> NcgImpl statics instr jumpDest
212                -> Handle -> UniqSupply -> [RawCmmPgm] -> IO ()
213 nativeCodeGen' dflags ncgImpl h us cmms
214  = do
215         let platform = targetPlatform dflags
216             split_cmms  = concat $ map add_split cmms
217         -- BufHandle is a performance hack.  We could hide it inside
218         -- Pretty if it weren't for the fact that we do lots of little
219         -- printDocs here (in order to do codegen in constant space).
220         bufh <- newBufHandle h
221         (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
222         bFlush bufh
223
224         let (native, colorStats, linearStats)
225                 = unzip3 prof
226
227         -- dump native code
228         dumpIfSet_dyn dflags
229                 Opt_D_dump_asm "Asm code"
230                 (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) $ concat native)
231
232         -- dump global NCG stats for graph coloring allocator
233         (case concat $ catMaybes colorStats of
234           []    -> return ()
235           stats -> do   
236                 -- build the global register conflict graph
237                 let graphGlobal 
238                         = foldl Color.union Color.initGraph
239                         $ [ Color.raGraph stat
240                                 | stat@Color.RegAllocStatsStart{} <- stats]
241            
242                 dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
243                         $ Color.pprStats stats graphGlobal
244
245                 dumpIfSet_dyn dflags
246                         Opt_D_dump_asm_conflicts "Register conflict graph"
247                         $ Color.dotGraph 
248                                 (targetRegDotColor platform)
249                                 (Color.trivColorable platform
250                                         (targetVirtualRegSqueeze platform)
251                                         (targetRealRegSqueeze platform))
252                         $ graphGlobal)
253
254
255         -- dump global NCG stats for linear allocator
256         (case concat $ catMaybes linearStats of
257                 []      -> return ()
258                 stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
259                                 $ Linear.pprStats (concat native) stats)
260
261         -- write out the imports
262         Pretty.printDoc Pretty.LeftMode h
263                 $ makeImportsDoc dflags (concat imports)
264
265         return  ()
266
267  where  add_split tops
268                 | dopt Opt_SplitObjs dflags = split_marker : tops
269                 | otherwise                 = tops
270
271         split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
272
273
274 -- | Do native code generation on all these cmms.
275 --
276 cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr)
277               => DynFlags
278               -> NcgImpl statics instr jumpDest
279               -> BufHandle
280               -> UniqSupply
281               -> [RawCmmTop]
282               -> [[CLabel]]
283               -> [ ([NatCmmTop statics instr],
284                    Maybe [Color.RegAllocStats statics instr],
285                    Maybe [Linear.RegAllocStats]) ]
286               -> Int
287               -> IO ( [[CLabel]],
288                       [([NatCmmTop statics instr],
289                       Maybe [Color.RegAllocStats statics instr],
290                       Maybe [Linear.RegAllocStats])] )
291
292 cmmNativeGens _ _ _ _ [] impAcc profAcc _
293         = return (reverse impAcc, reverse profAcc)
294
295 cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
296  = do
297         (us', native, imports, colorStats, linearStats)
298                 <- cmmNativeGen dflags ncgImpl us cmm count
299
300         Pretty.bufLeftRender h
301                 $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl (targetPlatform dflags)) 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 ppr 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         :: (Outputable statics, PlatformOutputable instr, Instruction instr)
332     => DynFlags
333     -> NcgImpl statics instr jumpDest
334         -> UniqSupply
335         -> RawCmmTop                                    -- ^ the cmm to generate code for
336         -> Int                                          -- ^ sequence number of this top thing
337         -> IO   ( UniqSupply
338                 , [NatCmmTop 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                 (pprCmmPgm 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 . pprNatCmmTop 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 . pprNatCmmTop 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 . pprNatCmmTop 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 . pprNatCmmTop ncgImpl platform) expanded)
482
483         return  ( usAlloc
484                 , expanded
485                 , lastMinuteImports ++ imports
486                 , ppr_raStatsColor
487                 , ppr_raStatsLinear)
488
489
490 x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (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.pprNatCmmTop.
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         arch    = platformArch  $ targetPlatform dflags
532         os      = platformOS    $ targetPlatform dflags
533         
534         -- (Hack) sometimes two Labels pretty-print the same, but have
535         -- different uniques; so we compare their text versions...
536         dyld_stubs imps
537                 | needImportedSymbols arch os
538                 = Pretty.vcat $
539                         (pprGotDeclaration arch os :) $
540                         map ( pprImportedSymbol arch os . fst . head) $
541                         groupBy (\(_,a) (_,b) -> a == b) $
542                         sortBy (\(_,a) (_,b) -> compare a b) $
543                         map doPpr $
544                         imps
545                 | otherwise
546                 = Pretty.empty
547
548         doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
549         astyle = mkCodeStyle AsmStyle
550
551
552 -- -----------------------------------------------------------------------------
553 -- Sequencing the basic blocks
554
555 -- Cmm BasicBlocks are self-contained entities: they always end in a
556 -- jump, either non-local or to another basic block in the same proc.
557 -- In this phase, we attempt to place the basic blocks in a sequence
558 -- such that as many of the local jumps as possible turn into
559 -- fallthroughs.
560
561 sequenceTop 
562         :: Instruction instr
563     => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr
564
565 sequenceTop _       top@(CmmData _ _) = top
566 sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = 
567   CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
568
569 -- The algorithm is very simple (and stupid): we make a graph out of
570 -- the blocks where there is an edge from one block to another iff the
571 -- first block ends by jumping to the second.  Then we topologically
572 -- sort this graph.  Then traverse the list: for each block, we first
573 -- output the block, then if it has an out edge, we move the
574 -- destination of the out edge to the front of the list, and continue.
575
576 -- FYI, the classic layout for basic blocks uses postorder DFS; this
577 -- algorithm is implemented in Hoopl.
578
579 sequenceBlocks 
580         :: Instruction instr
581         => [NatBasicBlock instr] 
582         -> [NatBasicBlock instr]
583
584 sequenceBlocks [] = []
585 sequenceBlocks (entry:blocks) = 
586   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
587   -- the first block is the entry point ==> it must remain at the start.
588
589
590 sccBlocks 
591         :: Instruction instr
592         => [NatBasicBlock instr] 
593         -> [SCC ( NatBasicBlock instr
594                 , Unique
595                 , [Unique])]
596
597 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
598
599 -- we're only interested in the last instruction of
600 -- the block, and only if it has a single destination.
601 getOutEdges 
602         :: Instruction instr
603         => [instr] -> [Unique]
604
605 getOutEdges instrs 
606         = case jumpDestsOfInstr (last instrs) of
607                 [one] -> [getUnique one]
608                 _many -> []
609
610 mkNode :: (Instruction t)
611        => GenBasicBlock t
612        -> (GenBasicBlock t, Unique, [Unique])
613 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
614
615 seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
616 seqBlocks [] = []
617 seqBlocks ((block,_,[]) : rest)
618   = block : seqBlocks rest
619 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
620   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
621   | otherwise       = block : seqBlocks rest'
622   where
623         (can_fallthrough, rest') = reorder next [] rest
624           -- TODO: we should do a better job for cycles; try to maximise the
625           -- fallthroughs within a loop.
626 seqBlocks _ = panic "AsmCodegen:seqBlocks"
627
628 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
629 reorder  _ accum [] = (False, reverse accum)
630 reorder id accum (b@(block,id',out) : rest)
631   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
632   | otherwise  = reorder id (b:accum) rest
633
634
635 -- -----------------------------------------------------------------------------
636 -- Making far branches
637
638 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
639 -- big, we have to work around this limitation.
640
641 makeFarBranches
642         :: [NatBasicBlock PPC.Instr.Instr] 
643         -> [NatBasicBlock PPC.Instr.Instr]
644 makeFarBranches blocks
645     | last blockAddresses < nearLimit = blocks
646     | otherwise = zipWith handleBlock blockAddresses blocks
647     where
648         blockAddresses = scanl (+) 0 $ map blockLen blocks
649         blockLen (BasicBlock _ instrs) = length instrs
650         
651         handleBlock addr (BasicBlock id instrs)
652                 = BasicBlock id (zipWith makeFar [addr..] instrs)
653         
654         makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
655         makeFar addr (PPC.Instr.BCC cond tgt)
656             | abs (addr - targetAddr) >= nearLimit
657             = PPC.Instr.BCCFAR cond tgt
658             | otherwise
659             = PPC.Instr.BCC cond tgt
660             where Just targetAddr = lookupUFM blockAddressMap tgt
661         makeFar _ other            = other
662         
663         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
664                          -- distance, as we have a few pseudo-insns that are
665                          -- pretty-printed as multiple instructions,
666                          -- and it's just not worth the effort to calculate
667                          -- things exactly
668         
669         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
670
671 -- -----------------------------------------------------------------------------
672 -- Generate jump tables
673
674 -- Analyzes all native code and generates data sections for all jump
675 -- table instructions.
676 generateJumpTables
677         :: NcgImpl statics instr jumpDest
678     -> [NatCmmTop statics instr] -> [NatCmmTop statics instr]
679 generateJumpTables ncgImpl xs = concatMap f xs
680     where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
681           f p = [p]
682           g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
683
684 -- -----------------------------------------------------------------------------
685 -- Shortcut branches
686
687 shortcutBranches
688         :: DynFlags
689     -> NcgImpl statics instr jumpDest
690         -> [NatCmmTop statics instr] 
691         -> [NatCmmTop statics instr]
692
693 shortcutBranches dflags ncgImpl tops
694   | optLevel dflags < 1 = tops    -- only with -O or higher
695   | otherwise           = map (apply_mapping ncgImpl mapping) tops'
696   where
697     (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
698     mapping = foldr plusUFM emptyUFM mappings
699
700 build_mapping :: NcgImpl statics instr jumpDest
701               -> GenCmmTop d t (ListGraph instr)
702               -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest)
703 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
704 build_mapping _ (CmmProc info lbl (ListGraph []))
705   = (CmmProc info lbl (ListGraph []), emptyUFM)
706 build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
707   = (CmmProc info lbl (ListGraph (head:others)), mapping)
708         -- drop the shorted blocks, but don't ever drop the first one,
709         -- because it is pointed to by a global label.
710   where
711     -- find all the blocks that just consist of a jump that can be
712     -- shorted.
713     -- Don't completely eliminate loops here -- that can leave a dangling jump!
714     (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
715     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
716         | Just jd <- canShortcut ncgImpl insn,
717           Just dest <- getJumpDestBlockId ncgImpl jd,
718           (setMember dest s) || dest == id -- loop checks
719         = (s, shortcut_blocks, b : others)
720     split (s, shortcut_blocks, others) (BasicBlock id [insn])
721         | Just dest <- canShortcut ncgImpl insn
722         = (setInsert id s, (id,dest) : shortcut_blocks, others)
723     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
724
725
726     -- build a mapping from BlockId to JumpDest for shorting branches
727     mapping = foldl add emptyUFM shortcut_blocks
728     add ufm (id,dest) = addToUFM ufm id dest
729     
730 apply_mapping :: NcgImpl statics instr jumpDest
731               -> UniqFM jumpDest
732               -> GenCmmTop statics h (ListGraph instr)
733               -> GenCmmTop statics h (ListGraph instr)
734 apply_mapping ncgImpl ufm (CmmData sec statics)
735   = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
736 apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
737   = CmmProc info lbl (ListGraph $ map short_bb blocks)
738   where
739     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
740     short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
741                  -- shortcutJump should apply the mapping repeatedly,
742                  -- just in case we can short multiple branches.
743
744 -- -----------------------------------------------------------------------------
745 -- Instruction selection
746
747 -- Native code instruction selection for a chunk of stix code.  For
748 -- this part of the computation, we switch from the UniqSM monad to
749 -- the NatM monad.  The latter carries not only a Unique, but also an
750 -- Int denoting the current C stack pointer offset in the generated
751 -- code; this is needed for creating correct spill offsets on
752 -- architectures which don't offer, or for which it would be
753 -- prohibitively expensive to employ, a frame pointer register.  Viz,
754 -- x86.
755
756 -- The offset is measured in bytes, and indicates the difference
757 -- between the current (simulated) C stack-ptr and the value it was at
758 -- the beginning of the block.  For stacks which grow down, this value
759 -- should be either zero or negative.
760
761 -- Switching between the two monads whilst carrying along the same
762 -- Unique supply breaks abstraction.  Is that bad?
763
764 genMachCode 
765         :: DynFlags 
766         -> (RawCmmTop -> NatM [NatCmmTop statics instr])
767         -> RawCmmTop 
768         -> UniqSM 
769                 ( [NatCmmTop statics instr]
770                 , [CLabel])
771
772 genMachCode dflags cmmTopCodeGen cmm_top
773   = do  { initial_us <- getUs
774         ; let initial_st           = mkNatM_State initial_us 0 dflags
775               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
776               final_delta          = natm_delta final_st
777               final_imports        = natm_imports final_st
778         ; if   final_delta == 0
779           then return (new_tops, final_imports)
780           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
781     }
782
783 -- -----------------------------------------------------------------------------
784 -- Generic Cmm optimiser
785
786 {-
787 Here we do:
788
789   (a) Constant folding
790   (b) Simple inlining: a temporary which is assigned to and then
791       used, once, can be shorted.
792   (c) Position independent code and dynamic linking
793         (i)  introduce the appropriate indirections
794              and position independent refs
795         (ii) compile a list of imported symbols
796   (d) Some arch-specific optimizations
797
798 (a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
799 (d) are only needed by the native backend and will continue to live
800 here.
801
802 Ideas for other things we could do (put these in Hoopl please!):
803
804   - shortcut jumps-to-jumps
805   - simple CSE: if an expr is assigned to a temp, then replace later occs of
806     that expr with the temp, until the expr is no longer valid (can push through
807     temp assignments, and certain assigns to mem...)
808 -}
809
810 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
811 cmmToCmm _ top@(CmmData _ _) = (top, [])
812 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
813   blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks))
814   return $ CmmProc info lbl (ListGraph blocks')
815
816 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
817
818 instance Monad CmmOptM where
819   return x = CmmOptM $ \(imports, _) -> (# x,imports #)
820   (CmmOptM f) >>= g =
821     CmmOptM $ \(imports, dflags) ->
822                 case f (imports, dflags) of
823                   (# x, imports' #) ->
824                     case g x of
825                       CmmOptM g' -> g' (imports', dflags)
826
827 addImportCmmOpt :: CLabel -> CmmOptM ()
828 addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
829
830 getDynFlagsCmmOpt :: CmmOptM DynFlags
831 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
832
833 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
834 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
835                         (# result, imports #) -> (result, imports)
836
837 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
838 cmmBlockConFold (BasicBlock id stmts) = do
839   stmts' <- mapM cmmStmtConFold stmts
840   return $ BasicBlock id stmts'
841
842 -- This does three optimizations, but they're very quick to check, so we don't
843 -- bother turning them off even when the Hoopl code is active.  Since
844 -- this is on the old Cmm representation, we can't reuse the code either:
845 --  * reg = reg      --> nop
846 --  * if 0 then jump --> nop
847 --  * if 1 then jump --> jump
848 -- We might be tempted to skip this step entirely of not opt_PIC, but
849 -- there is some PowerPC code for the non-PIC case, which would also
850 -- have to be separated.
851 cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
852 cmmStmtConFold stmt
853    = case stmt of
854         CmmAssign reg src
855            -> do src' <- cmmExprConFold DataReference src
856                  return $ case src' of
857                    CmmReg reg' | reg == reg' -> CmmNop
858                    new_src -> CmmAssign reg new_src
859
860         CmmStore addr src
861            -> do addr' <- cmmExprConFold DataReference addr
862                  src'  <- cmmExprConFold DataReference src
863                  return $ CmmStore addr' src'
864
865         CmmJump addr regs
866            -> do addr' <- cmmExprConFold JumpReference addr
867                  return $ CmmJump addr' regs
868
869         CmmCall target regs args srt returns
870            -> do target' <- case target of
871                               CmmCallee e conv -> do
872                                 e' <- cmmExprConFold CallReference e
873                                 return $ CmmCallee e' conv
874                               other -> return other
875                  args' <- mapM (\(CmmHinted arg hint) -> do
876                                   arg' <- cmmExprConFold DataReference arg
877                                   return (CmmHinted arg' hint)) args
878                  return $ CmmCall target' regs args' srt returns
879
880         CmmCondBranch test dest
881            -> do test' <- cmmExprConFold DataReference test
882                  return $ case test' of
883                    CmmLit (CmmInt 0 _) -> 
884                      CmmComment (mkFastString ("deleted: " ++ 
885                                         showSDoc (pprStmt stmt)))
886
887                    CmmLit (CmmInt _ _) -> CmmBranch dest
888                    _other -> CmmCondBranch test' dest
889
890         CmmSwitch expr ids
891            -> do expr' <- cmmExprConFold DataReference expr
892                  return $ CmmSwitch expr' ids
893
894         other
895            -> return other
896
897 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
898 cmmExprConFold referenceKind expr = do
899     dflags <- getDynFlagsCmmOpt
900     -- Skip constant folding if new code generator is running
901     -- (this optimization is done in Hoopl)
902     let expr' = if dopt Opt_TryNewCodeGen dflags
903                     then expr
904                     else cmmExprCon expr
905     cmmExprNative referenceKind expr'
906
907 cmmExprCon :: CmmExpr -> CmmExpr
908 cmmExprCon (CmmLoad addr rep) = CmmLoad (cmmExprCon addr) rep
909 cmmExprCon (CmmMachOp mop args) = cmmMachOpFold mop (map cmmExprCon args)
910 cmmExprCon other = other
911
912 -- handles both PIC and non-PIC cases... a very strange mixture
913 -- of things to do.
914 cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
915 cmmExprNative referenceKind expr = do
916      dflags <- getDynFlagsCmmOpt
917      let arch = platformArch (targetPlatform dflags)
918      case expr of
919         CmmLoad addr rep
920            -> do addr' <- cmmExprNative DataReference addr
921                  return $ CmmLoad addr' rep
922
923         CmmMachOp mop args
924            -> do args' <- mapM (cmmExprNative DataReference) args
925                  return $ CmmMachOp mop args'
926
927         CmmLit (CmmLabel lbl)
928            -> do
929                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
930         CmmLit (CmmLabelOff lbl off)
931            -> do
932                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
933                  -- need to optimize here, since it's late
934                  return $ cmmMachOpFold (MO_Add wordWidth) [
935                      dynRef,
936                      (CmmLit $ CmmInt (fromIntegral off) wordWidth)
937                    ]
938
939         -- On powerpc (non-PIC), it's easier to jump directly to a label than
940         -- to use the register table, so we replace these registers
941         -- with the corresponding labels:
942         CmmReg (CmmGlobal EagerBlackholeInfo)
943           | arch == ArchPPC && not opt_PIC
944           -> cmmExprNative referenceKind $
945              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
946         CmmReg (CmmGlobal GCEnter1)
947           | arch == ArchPPC && not opt_PIC
948           -> cmmExprNative referenceKind $
949              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
950         CmmReg (CmmGlobal GCFun)
951           | arch == ArchPPC && not opt_PIC
952           -> cmmExprNative referenceKind $
953              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
954
955         other
956            -> return other
957
958 \end{code}
959