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