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