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