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