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