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