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