AsmCodeGen.lhs 39.2 KB
Newer Older
1
2
3
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
4
--
5
6
7
-- This is the top-level module in the native code generator.
--
-- -----------------------------------------------------------------------------
8
9

\begin{code}
10
module AsmCodeGen ( nativeCodeGen ) where
11

12
#include "HsVersions.h"
13
#include "nativeGen/NCG.h"
14

15

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
import qualified X86.CodeGen
import qualified X86.Regs
import qualified X86.Instr
import qualified X86.Ppr

import qualified SPARC.CodeGen
import qualified SPARC.Regs
import qualified SPARC.Instr
import qualified SPARC.Ppr
import qualified SPARC.ShortcutJump
import qualified SPARC.CodeGen.Expand

import qualified PPC.CodeGen
import qualified PPC.Cond
import qualified PPC.Regs
import qualified PPC.RegInfo
import qualified PPC.Instr
import qualified PPC.Ppr
34
35

import RegAlloc.Liveness
36
import qualified RegAlloc.Linear.Main           as Linear
37

38
39
40
41
import qualified GraphColor                     as Color
import qualified RegAlloc.Graph.Main            as Color
import qualified RegAlloc.Graph.Stats           as Color
import qualified RegAlloc.Graph.TrivColorable   as Color
42

43
import TargetReg
44
import Platform
45
import Config
46
47
48
49
import Instruction
import PIC
import Reg
import NCGMonad
50

51
import BlockId
52
import CgUtils          ( fixStgRegisters )
53
import OldCmm
54
import CmmOpt           ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
55
import OldPprCmm
56
import CLabel
57

58
import UniqFM
59
import Unique           ( Unique, getUnique )
60
import UniqSupply
61
import DynFlags
62
import StaticFlags
63
import Util
64

65
import BasicTypes       ( Alignment )
66
import Digraph
67
import qualified Pretty
68
import BufWrite
69
import Outputable
70
import FastString
71
import UniqSet
72
import ErrUtils
73
import Module
74

75
76
-- DEBUGGING ONLY
--import OrdList
77

78
import Data.List
79
import Data.Maybe
80
import Control.Monad
81
import System.IO
82

83
84
85
{-
The native-code generator has machine-independent and
machine-dependent modules.
86

87
88
89
90
This module ("AsmCodeGen") is the top-level machine-independent
module.  Before entering machine-dependent land, we do some
machine-independent optimisations (defined below) on the
'CmmStmts's.
91

92
93
94
95
96
97
98
99
100
We convert to the machine-specific 'Instr' datatype with
'cmmCodeGen', assuming an infinite supply of registers.  We then use
a machine-independent register allocator ('regAlloc') to rejoin
reality.  Obviously, 'regAlloc' has machine-specific helper
functions (see about "RegAllocInfo" below).

Finally, we order the basic blocks of the function so as to minimise
the number of jumps between blocks, by utilising fallthrough wherever
possible.
101
102

The machine-dependent bits break down as follows:
103
104

  * ["MachRegs"]  Everything about the target platform's machine
105
106
107
    registers (and immediate operands, and addresses, which tend to
    intermingle/interact with registers).

108
  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
109
    have a module of its own), plus a miscellany of other things
110
    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
111

112
  * ["MachCodeGen"]  is where 'Cmm' stuff turns into
113
    machine instructions.
114

115
  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
116
    a 'SDoc').
117

118
119
  * ["RegAllocInfo"] In the register allocator, we manipulate
    'MRegsState's, which are 'BitSet's, one bit per machine register.
120
121
    When we want to say something about a specific machine register
    (e.g., ``it gets clobbered by this instruction''), we set/unset
122
    its bit.  Obviously, we do this 'BitSet' thing for efficiency
123
124
    reasons.

125
    The 'RegAllocInfo' module collects together the machine-specific
126
127
    info needed to do register allocation.

128
129
   * ["RegisterAlloc"] The (machine-independent) register allocator.
-}
130

131
132
-- -----------------------------------------------------------------------------
-- Top-level of the native codegen
133

134
data NcgImpl statics instr jumpDest = NcgImpl {
Simon Peyton Jones's avatar
Simon Peyton Jones committed
135
136
    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
137
138
    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
    canShortcut               :: instr -> Maybe jumpDest,
139
    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
140
    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
141
    pprNatCmmDecl              :: Platform -> NatCmmDecl statics instr -> SDoc,
142
143
    maxSpillSlots             :: Int,
    allocatableRegs           :: [RealReg],
Simon Peyton Jones's avatar
Simon Peyton Jones committed
144
145
    ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
146
147
148
    ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
    }

149
--------------------
Simon Peyton Jones's avatar
Simon Peyton Jones committed
150
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
151
nativeCodeGen dflags h us cmms
152
 = let platform = targetPlatform dflags
Ian Lynagh's avatar
Ian Lynagh committed
153
       nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
154
       nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
155
156
157
158
159
       x86NcgImpl = NcgImpl {
                         cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
                        ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
                        ,canShortcut               = X86.Instr.canShortcut
160
                        ,shortcutStatics           = X86.Instr.shortcutStatics
161
                        ,shortcutJump              = X86.Instr.shortcutJump
Simon Peyton Jones's avatar
Simon Peyton Jones committed
162
                        ,pprNatCmmDecl              = X86.Ppr.pprNatCmmDecl
163
                        ,maxSpillSlots             = X86.Instr.maxSpillSlots (target32Bit platform)
164
165
166
167
168
                        ,allocatableRegs           = X86.Regs.allocatableRegs
                        ,ncg_x86fp_kludge          = id
                        ,ncgExpandTop              = id
                        ,ncgMakeFarBranches        = id
                    }
169
   in case platformArch platform of
170
171
172
173
174
175
176
177
                 ArchX86    -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
                 ArchX86_64 -> nCG' x86NcgImpl
                 ArchPPC ->
                     nCG' $ NcgImpl {
                          cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
                         ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
                         ,canShortcut               = PPC.RegInfo.canShortcut
178
                         ,shortcutStatics           = PPC.RegInfo.shortcutStatics
179
                         ,shortcutJump              = PPC.RegInfo.shortcutJump
Simon Peyton Jones's avatar
Simon Peyton Jones committed
180
                         ,pprNatCmmDecl              = PPC.Ppr.pprNatCmmDecl
181
182
183
184
185
186
187
188
189
190
191
192
                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots
                         ,allocatableRegs           = PPC.Regs.allocatableRegs
                         ,ncg_x86fp_kludge          = id
                         ,ncgExpandTop              = id
                         ,ncgMakeFarBranches        = makeFarBranches
                     }
                 ArchSPARC ->
                     nCG' $ NcgImpl {
                          cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
                         ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
                         ,canShortcut               = SPARC.ShortcutJump.canShortcut
193
                         ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
194
                         ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
Simon Peyton Jones's avatar
Simon Peyton Jones committed
195
                         ,pprNatCmmDecl              = SPARC.Ppr.pprNatCmmDecl
196
197
198
199
200
201
                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots
                         ,allocatableRegs           = SPARC.Regs.allocatableRegs
                         ,ncg_x86fp_kludge          = id
                         ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
                         ,ncgMakeFarBranches        = id
                     }
202
                 ArchARM _ _ _ ->
Simon Marlow's avatar
Simon Marlow committed
203
                     panic "nativeCodeGen: No NCG for ARM"
204
205
                 ArchPPC_64 ->
                     panic "nativeCodeGen: No NCG for PPC 64"
Ian Lynagh's avatar
Ian Lynagh committed
206
207
                 ArchUnknown ->
                     panic "nativeCodeGen: No NCG for unknown arch"
208

Ian Lynagh's avatar
Ian Lynagh committed
209
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
210
               => DynFlags
211
               -> NcgImpl statics instr jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
212
               -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
213
nativeCodeGen' dflags ncgImpl h us cmms
214
 = do
215
216
        let platform = targetPlatform dflags
            split_cmms  = concat $ map add_split cmms
217
218
219
220
        -- BufHandle is a performance hack.  We could hide it inside
        -- Pretty if it weren't for the fact that we do lots of little
        -- printDocs here (in order to do codegen in constant space).
        bufh <- newBufHandle h
221
        (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
222
        bFlush bufh
223

224
225
226
227
228
229
        let (native, colorStats, linearStats)
                = unzip3 prof

        -- dump native code
        dumpIfSet_dyn dflags
                Opt_D_dump_asm "Asm code"
230
                (vcat $ map (pprNatCmmDecl ncgImpl platform) $ concat native)
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262

        -- dump global NCG stats for graph coloring allocator
        (case concat $ catMaybes colorStats of
          []    -> return ()
          stats -> do
                -- build the global register conflict graph
                let graphGlobal
                        = foldl Color.union Color.initGraph
                        $ [ Color.raGraph stat
                                | stat@Color.RegAllocStatsStart{} <- stats]

                dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
                        $ Color.pprStats stats graphGlobal

                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_conflicts "Register conflict graph"
                        $ Color.dotGraph
                                (targetRegDotColor platform)
                                (Color.trivColorable platform
                                        (targetVirtualRegSqueeze platform)
                                        (targetRealRegSqueeze platform))
                        $ graphGlobal)


        -- dump global NCG stats for linear allocator
        (case concat $ catMaybes linearStats of
                []      -> return ()
                stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
                                $ Linear.pprStats (concat native) stats)

        -- write out the imports
        Pretty.printDoc Pretty.LeftMode h
Ian Lynagh's avatar
Ian Lynagh committed
263
                $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
264
265
266
                $ makeImportsDoc dflags (concat imports)

        return  ()
267

268
 where  add_split tops
269
270
                | dopt Opt_SplitObjs dflags = split_marker : tops
                | otherwise                 = tops
271

272
        split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
273
274
275
276


-- | Do native code generation on all these cmms.
--
Ian Lynagh's avatar
Ian Lynagh committed
277
cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
278
              => DynFlags
279
              -> NcgImpl statics instr jumpDest
dterei's avatar
dterei committed
280
281
              -> BufHandle
              -> UniqSupply
Simon Peyton Jones's avatar
Simon Peyton Jones committed
282
              -> [RawCmmDecl]
dterei's avatar
dterei committed
283
              -> [[CLabel]]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
284
              -> [ ([NatCmmDecl statics instr],
285
                   Maybe [Color.RegAllocStats statics instr],
dterei's avatar
dterei committed
286
287
288
                   Maybe [Linear.RegAllocStats]) ]
              -> Int
              -> IO ( [[CLabel]],
Simon Peyton Jones's avatar
Simon Peyton Jones committed
289
                      [([NatCmmDecl statics instr],
290
                      Maybe [Color.RegAllocStats statics instr],
dterei's avatar
dterei committed
291
292
                      Maybe [Linear.RegAllocStats])] )

293
cmmNativeGens _ _ _ _ [] impAcc profAcc _
294
        = return (reverse impAcc, reverse profAcc)
295

296
cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
297
 = do
298
299
        let platform = targetPlatform dflags

300
        (us', native, imports, colorStats, linearStats)
Simon Marlow's avatar
Simon Marlow committed
301
                <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
302

Simon Marlow's avatar
Simon Marlow committed
303
        {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
Ian Lynagh's avatar
Ian Lynagh committed
304
                $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
305
                $ vcat $ map (pprNatCmmDecl ncgImpl platform) native
306

307
308
309
           -- carefully evaluate this strictly.  Binding it with 'let'
           -- and then using 'seq' doesn't work, because the let
           -- apparently gets inlined first.
310
311
312
313
314
        lsPprNative <- return $!
                if  dopt Opt_D_dump_asm       dflags
                 || dopt Opt_D_dump_asm_stats dflags
                        then native
                        else []
315

316
        count' <- return $! count + 1;
317

318
        -- force evaulation all this stuff to avoid space leaks
Ian Lynagh's avatar
Ian Lynagh committed
319
        {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return ()
320

321
        cmmNativeGens dflags ncgImpl
322
            h us' cmms
323
324
325
                        (imports : impAcc)
                        ((lsPprNative, colorStats, linearStats) : profAcc)
                        count'
326

327
328
 where  seqString []            = ()
        seqString (x:xs)        = x `seq` seqString xs `seq` ()
329
330


331
-- | Complete native code generation phase for a single top-level chunk of Cmm.
332
333
--      Dumping the output of each stage along the way.
--      Global conflict graph and NGC stats
334
cmmNativeGen
Ian Lynagh's avatar
Ian Lynagh committed
335
        :: (Outputable statics, Outputable instr, Instruction instr)
336
    => DynFlags
337
    -> NcgImpl statics instr jumpDest
338
339
340
341
342
343
344
345
        -> UniqSupply
        -> RawCmmDecl                                   -- ^ the cmm to generate code for
        -> Int                                          -- ^ sequence number of this top thing
        -> IO   ( UniqSupply
                , [NatCmmDecl statics instr]                -- native code
                , [CLabel]                                  -- things imported by this cmm
                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
                , Maybe [Linear.RegAllocStats])             -- stats for the linear register allocators
346

347
cmmNativeGen dflags ncgImpl us cmm count
348
 = do
349
        let platform = targetPlatform dflags
350

351
352
353
354
        -- rewrite assignments to global regs
        let fixed_cmm =
                {-# SCC "fixStgRegisters" #-}
                fixStgRegisters cmm
355

356
357
358
359
        -- cmm to cmm optimisations
        let (opt_cmm, imports) =
                {-# SCC "cmmToCmm" #-}
                cmmToCmm dflags fixed_cmm
360

361
362
        dumpIfSet_dyn dflags
                Opt_D_dump_opt_cmm "Optimised Cmm"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
363
                (pprCmmGroup platform [opt_cmm])
364

365
366
367
368
369
370
371
        -- generate native code from cmm
        let ((native, lastMinuteImports), usGen) =
                {-# SCC "genMachCode" #-}
                initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm

        dumpIfSet_dyn dflags
                Opt_D_dump_asm_native "Native code"
372
                (vcat $ map (pprNatCmmDecl ncgImpl platform) native)
373
374
375
376
377

        -- tag instructions with register liveness information
        let (withLiveness, usLive) =
                {-# SCC "regLiveness" #-}
                initUs usGen
378
                        $ mapM regLiveness
379
380
381
382
                        $ map natCmmTopToLive native

        dumpIfSet_dyn dflags
                Opt_D_dump_asm_liveness "Liveness annotations added"
Ian Lynagh's avatar
Ian Lynagh committed
383
                (vcat $ map ppr withLiveness)
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409

        -- allocate registers
        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
         if ( dopt Opt_RegsGraph dflags
           || dopt Opt_RegsIterative dflags)
          then do
                -- the regs usable for allocation
                let (alloc_regs :: UniqFM (UniqSet RealReg))
                        = foldr (\r -> plusUFM_C unionUniqSets
                                        $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
                                emptyUFM
                        $ allocatableRegs ncgImpl

                -- do the graph coloring register allocation
                let ((alloced, regAllocStats), usAlloc)
                        = {-# SCC "RegAlloc" #-}
                          initUs usLive
                          $ Color.regAlloc
                                dflags
                                alloc_regs
                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])
                                withLiveness

                -- dump out what happened during register allocation
                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc "Registers allocated"
410
                        (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
411
412
413
414
415
416

                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"
                        (vcat   $ map (\(stage, stats)
                                        -> text "# --------------------------"
                                        $$ text "#  cmm " <> int count <> text " Stage " <> int stage
Ian Lynagh's avatar
Ian Lynagh committed
417
                                        $$ ppr stats)
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
                                $ zip [0..] regAllocStats)

                let mPprStats =
                        if dopt Opt_D_dump_asm_stats dflags
                         then Just regAllocStats else Nothing

                -- force evaluation of the Maybe to avoid space leak
                mPprStats `seq` return ()

                return  ( alloced, usAlloc
                        , mPprStats
                        , Nothing)

          else do
                -- do linear register allocation
                let ((alloced, regAllocStats), usAlloc)
                        = {-# SCC "RegAlloc" #-}
                          initUs usLive
                          $ liftM unzip
437
                          $ mapM (Linear.regAlloc dflags) withLiveness
438
439
440

                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc "Registers allocated"
441
                        (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
442
443
444
445
446
447
448
449
450
451
452

                let mPprStats =
                        if dopt Opt_D_dump_asm_stats dflags
                         then Just (catMaybes regAllocStats) else Nothing

                -- force evaluation of the Maybe to avoid space leak
                mPprStats `seq` return ()

                return  ( alloced, usAlloc
                        , Nothing
                        , mPprStats)
453

454
455
456
457
458
459
460
        ---- x86fp_kludge.  This pass inserts ffree instructions to clear
        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
        ---- is clear, and library functions can return odd results if it
        ---- isn't.
        ----
        ---- NB. must happen before shortcutBranches, because that
        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
461
        let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
462
463

        ---- generate jump tables
464
465
        let tabled      =
                {-# SCC "generateJumpTables" #-}
466
                generateJumpTables ncgImpl kludged
467

468
469
470
471
        ---- shortcut branches
        let shorted     =
                {-# SCC "shortcutBranches" #-}
                shortcutBranches dflags ncgImpl tabled
472

473
474
475
476
        ---- sequence blocks
        let sequenced   =
                {-# SCC "sequenceBlocks" #-}
                map (sequenceTop ncgImpl) shorted
477

478
        ---- expansion of SPARC synthetic instrs
479
480
        let expanded =
                {-# SCC "sparc_expand" #-}
481
                ncgExpandTop ncgImpl sequenced
482

483
484
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_expanded "Synthetic instructions expanded"
485
                (vcat $ map (pprNatCmmDecl ncgImpl platform) expanded)
486

487
488
489
490
491
        return  ( usAlloc
                , expanded
                , lastMinuteImports ++ imports
                , ppr_raStatsColor
                , ppr_raStatsLinear)
492

493

Simon Peyton Jones's avatar
Simon Peyton Jones committed
494
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
495
x86fp_kludge top@(CmmData _ _) = top
496
497
x86fp_kludge (CmmProc info lbl (ListGraph code)) =
        CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
498

499

500
-- | Build a doc for all the imports.
501
--
502
makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
503
makeImportsDoc dflags imports
504
 = dyld_stubs imports
505
            $$
506
507
508
509
            -- On recent versions of Darwin, the linker supports
            -- dead-stripping of code and data on a per-symbol basis.
            -- There's a hack to make this work in PprMach.pprNatCmmDecl.
            (if platformHasSubsectionsViaSymbols (targetPlatform dflags)
510
511
512
             then text ".subsections_via_symbols"
             else empty)
            $$
513
514
515
516
517
518
                -- On recent GNU ELF systems one can mark an object file
                -- as not requiring an executable stack. If all objects
                -- linked into a program have this note then the program
                -- will not use an executable stack, which is good for
                -- security. GHC generated code does not need an executable
                -- stack so add the note in:
519
            (if platformHasGnuNonexecStack (targetPlatform dflags)
520
521
522
             then text ".section .note.GNU-stack,\"\",@progbits"
             else empty)
            $$
523
                -- And just because every other compiler does, lets stick in
524
                -- an identifier directive: .ident "GHC x.y.z"
525
            (if platformHasIdentDirective (targetPlatform dflags)
526
527
528
             then let compilerIdent = text "GHC" <+> text cProjectVersion
                   in text ".ident" <+> doubleQuotes compilerIdent
             else empty)
529

530
 where
531
532
        -- Generate "symbol stubs" for all external symbols that might
        -- come from a dynamic library.
533
534
        dyld_stubs :: [CLabel] -> SDoc
{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
535
536
537
538
539
540
541
542
543
544
                                    map head $ group $ sort imps-}

        platform = targetPlatform dflags
        arch = platformArch platform
        os   = platformOS   platform

        -- (Hack) sometimes two Labels pretty-print the same, but have
        -- different uniques; so we compare their text versions...
        dyld_stubs imps
                | needImportedSymbols arch os
545
                = vcat $
546
547
548
549
550
551
552
                        (pprGotDeclaration arch os :) $
                        map ( pprImportedSymbol platform . fst . head) $
                        groupBy (\(_,a) (_,b) -> a == b) $
                        sortBy (\(_,a) (_,b) -> compare a b) $
                        map doPpr $
                        imps
                | otherwise
553
                = empty
554

Ian Lynagh's avatar
Ian Lynagh committed
555
        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
556
        astyle = mkCodeStyle AsmStyle
557
558


559
560
561
562
563
564
565
566
567
-- -----------------------------------------------------------------------------
-- Sequencing the basic blocks

-- Cmm BasicBlocks are self-contained entities: they always end in a
-- jump, either non-local or to another basic block in the same proc.
-- In this phase, we attempt to place the basic blocks in a sequence
-- such that as many of the local jumps as possible turn into
-- fallthroughs.

568
569
sequenceTop
        :: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
570
    => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
571

572
sequenceTop _       top@(CmmData _ _) = top
573
sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
574
  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
575
576
577
578
579
580
581
582

-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
-- first block ends by jumping to the second.  Then we topologically
-- sort this graph.  Then traverse the list: for each block, we first
-- output the block, then if it has an out edge, we move the
-- destination of the out edge to the front of the list, and continue.

583
-- FYI, the classic layout for basic blocks uses postorder DFS; this
584
-- algorithm is implemented in Hoopl.
585

586
587
588
589
sequenceBlocks
        :: Instruction instr
        => [NatBasicBlock instr]
        -> [NatBasicBlock instr]
590

591
sequenceBlocks [] = []
592
sequenceBlocks (entry:blocks) =
593
594
595
  seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
  -- the first block is the entry point ==> it must remain at the start.

596

597
598
599
600
601
602
sccBlocks
        :: Instruction instr
        => [NatBasicBlock instr]
        -> [SCC ( NatBasicBlock instr
                , Unique
                , [Unique])]
603

604
sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
605

606
607
-- we're only interested in the last instruction of
-- the block, and only if it has a single destination.
608
609
610
getOutEdges
        :: Instruction instr
        => [instr] -> [Unique]
611

612
613
614
615
getOutEdges instrs
        = case jumpDestsOfInstr (last instrs) of
                [one] -> [getUnique one]
                _many -> []
616

dterei's avatar
dterei committed
617
618
619
mkNode :: (Instruction t)
       => GenBasicBlock t
       -> (GenBasicBlock t, Unique, [Unique])
620
621
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)

dterei's avatar
dterei committed
622
seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
623
624
625
626
627
628
629
seqBlocks [] = []
seqBlocks ((block,_,[]) : rest)
  = block : seqBlocks rest
seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
  | otherwise       = block : seqBlocks rest'
  where
630
631
632
        (can_fallthrough, rest') = reorder next [] rest
          -- TODO: we should do a better job for cycles; try to maximise the
          -- fallthroughs within a loop.
633
634
seqBlocks _ = panic "AsmCodegen:seqBlocks"

dterei's avatar
dterei committed
635
636
reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
reorder  _ accum [] = (False, reverse accum)
637
638
639
640
reorder id accum (b@(block,id',out) : rest)
  | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
  | otherwise  = reorder id (b:accum) rest

641
642
643
644
645
646
647

-- -----------------------------------------------------------------------------
-- Making far branches

-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
-- big, we have to work around this limitation.

648
makeFarBranches
649
650
        :: [NatBasicBlock PPC.Instr.Instr]
        -> [NatBasicBlock PPC.Instr.Instr]
651
652
653
654
655
656
makeFarBranches blocks
    | last blockAddresses < nearLimit = blocks
    | otherwise = zipWith handleBlock blockAddresses blocks
    where
        blockAddresses = scanl (+) 0 $ map blockLen blocks
        blockLen (BasicBlock _ instrs) = length instrs
657

658
659
        handleBlock addr (BasicBlock id instrs)
                = BasicBlock id (zipWith makeFar [addr..] instrs)
660

661
662
        makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
        makeFar addr (PPC.Instr.BCC cond tgt)
663
            | abs (addr - targetAddr) >= nearLimit
664
            = PPC.Instr.BCCFAR cond tgt
665
            | otherwise
666
            = PPC.Instr.BCC cond tgt
667
            where Just targetAddr = lookupUFM blockAddressMap tgt
668
        makeFar _ other            = other
669

670
671
672
673
674
        nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
                         -- distance, as we have a few pseudo-insns that are
                         -- pretty-printed as multiple instructions,
                         -- and it's just not worth the effort to calculate
                         -- things exactly
675

676
677
        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses

678
679
680
681
682
683
-- -----------------------------------------------------------------------------
-- Generate jump tables

-- Analyzes all native code and generates data sections for all jump
-- table instructions.
generateJumpTables
684
        :: NcgImpl statics instr jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
685
    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
686
generateJumpTables ncgImpl xs = concatMap f xs
687
688
    where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
          f p = [p]
689
          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
690

691
692
693
-- -----------------------------------------------------------------------------
-- Shortcut branches

694
shortcutBranches
695
        :: DynFlags
696
    -> NcgImpl statics instr jumpDest
697
698
        -> [NatCmmDecl statics instr]
        -> [NatCmmDecl statics instr]
699

700
shortcutBranches dflags ncgImpl tops
701
  | optLevel dflags < 1 = tops    -- only with -O or higher
702
  | otherwise           = map (apply_mapping ncgImpl mapping) tops'
703
  where
704
    (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
705
706
    mapping = foldr plusUFM emptyUFM mappings

707
build_mapping :: NcgImpl statics instr jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
708
709
              -> GenCmmDecl d t (ListGraph instr)
              -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
710
711
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
build_mapping _ (CmmProc info lbl (ListGraph []))
712
  = (CmmProc info lbl (ListGraph []), emptyUFM)
713
build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
714
  = (CmmProc info lbl (ListGraph (head:others)), mapping)
715
716
717
718
719
        -- drop the shorted blocks, but don't ever drop the first one,
        -- because it is pointed to by a global label.
  where
    -- find all the blocks that just consist of a jump that can be
    -- shorted.
720
721
722
    -- Don't completely eliminate loops here -- that can leave a dangling jump!
    (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
723
724
        | Just jd <- canShortcut ncgImpl insn,
          Just dest <- getJumpDestBlockId ncgImpl jd,
725
          (setMember dest s) || dest == id -- loop checks
726
727
        = (s, shortcut_blocks, b : others)
    split (s, shortcut_blocks, others) (BasicBlock id [insn])
728
        | Just dest <- canShortcut ncgImpl insn
729
        = (setInsert id s, (id,dest) : shortcut_blocks, others)
730
731
    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)

732
733
734
735

    -- build a mapping from BlockId to JumpDest for shorting branches
    mapping = foldl add emptyUFM shortcut_blocks
    add ufm (id,dest) = addToUFM ufm id dest
736

737
apply_mapping :: NcgImpl statics instr jumpDest
738
              -> UniqFM jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
739
740
              -> GenCmmDecl statics h (ListGraph instr)
              -> GenCmmDecl statics h (ListGraph instr)
741
apply_mapping ncgImpl ufm (CmmData sec statics)
742
  = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
743
apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
744
  = CmmProc info lbl (ListGraph $ map short_bb blocks)
745
746
  where
    short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
747
    short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
748
749
750
                 -- shortcutJump should apply the mapping repeatedly,
                 -- just in case we can short multiple branches.

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
-- -----------------------------------------------------------------------------
-- Instruction selection

-- Native code instruction selection for a chunk of stix code.  For
-- this part of the computation, we switch from the UniqSM monad to
-- the NatM monad.  The latter carries not only a Unique, but also an
-- Int denoting the current C stack pointer offset in the generated
-- code; this is needed for creating correct spill offsets on
-- architectures which don't offer, or for which it would be
-- prohibitively expensive to employ, a frame pointer register.  Viz,
-- x86.

-- The offset is measured in bytes, and indicates the difference
-- between the current (simulated) C stack-ptr and the value it was at
-- the beginning of the block.  For stacks which grow down, this value
-- should be either zero or negative.

-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction.  Is that bad?

771
772
genMachCode
        :: DynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
773
        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
774
775
776
777
        -> RawCmmDecl
        -> UniqSM
                ( [NatCmmDecl statics instr]
                , [CLabel])
778

779
genMachCode dflags cmmTopCodeGen cmm_top
780
781
782
783
784
785
  = do  { initial_us <- getUs
        ; let initial_st           = mkNatM_State initial_us 0 dflags
              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
              final_delta          = natm_delta final_st
              final_imports        = natm_imports final_st
        ; if   final_delta == 0
786
787
788
          then return (new_tops, final_imports)
          else pprPanic "genMachCode: nonzero final delta" (int final_delta)
    }
789

790
791
792
793
794
795
796
797
798
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser

{-
Here we do:

  (a) Constant folding
  (b) Simple inlining: a temporary which is assigned to and then
      used, once, can be shorted.
799
  (c) Position independent code and dynamic linking
800
801
802
        (i)  introduce the appropriate indirections
             and position independent refs
        (ii) compile a list of imported symbols
803
  (d) Some arch-specific optimizations
804

805
806
807
808
809
(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
(d) are only needed by the native backend and will continue to live
here.

Ideas for other things we could do (put these in Hoopl please!):
810
811

  - shortcut jumps-to-jumps
812
813
814
  - simple CSE: if an expr is assigned to a temp, then replace later occs of
    that expr with the temp, until the expr is no longer valid (can push through
    temp assignments, and certain assigns to mem...)
815
816
-}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
817
cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
818
cmmToCmm _ top@(CmmData _ _) = (top, [])
819
cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
Ian Lynagh's avatar
Ian Lynagh committed
820
  blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags (cmmEliminateDeadBlocks blocks))
821
  return $ CmmProc info lbl (ListGraph blocks')
822

823
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
824
825

instance Monad CmmOptM where
826
  return x = CmmOptM $ \(imports, _) -> (# x,imports #)
827
  (CmmOptM f) >>= g =
828
829
    CmmOptM $ \(imports, dflags) ->
                case f (imports, dflags) of
830
831
                  (# x, imports' #) ->
                    case g x of
832
                      CmmOptM g' -> g' (imports', dflags)
833
834

addImportCmmOpt :: CLabel -> CmmOptM ()
dterei's avatar
dterei committed
835
addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
836

837
838
instance HasDynFlags CmmOptM where
    getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
839
840
841

runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
842
843
844
845
846
847
                        (# result, imports #) -> (result, imports)

cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
cmmBlockConFold (BasicBlock id stmts) = do
  stmts' <- mapM cmmStmtConFold stmts
  return $ BasicBlock id stmts'
848

849
850
851
852
853
854
855
856
857
-- This does three optimizations, but they're very quick to check, so we don't
-- bother turning them off even when the Hoopl code is active.  Since
-- this is on the old Cmm representation, we can't reuse the code either:
--  * reg = reg      --> nop
--  * if 0 then jump --> nop
--  * if 1 then jump --> jump
-- We might be tempted to skip this step entirely of not opt_PIC, but
-- there is some PowerPC code for the non-PIC case, which would also
-- have to be separated.
dterei's avatar
dterei committed
858
cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
859
860
861
cmmStmtConFold stmt
   = case stmt of
        CmmAssign reg src
862
           -> do src' <- cmmExprConFold DataReference src
863
                 return $ case src' of
864
865
                   CmmReg reg' | reg == reg' -> CmmNop
                   new_src -> CmmAssign reg new_src
866
867

        CmmStore addr src
868
869
           -> do addr' <- cmmExprConFold DataReference addr
                 src'  <- cmmExprConFold DataReference src
870
                 return $ CmmStore addr' src'
871

872
        CmmJump addr live
873
           -> do addr' <- cmmExprConFold JumpReference addr
874
                 return $ CmmJump addr' live
875

876
        CmmCall target regs args returns
877
878
879
880
           -> do target' <- case target of
                              CmmCallee e conv -> do
                                e' <- cmmExprConFold CallReference e
                                return $ CmmCallee e' conv
881
882
883
884
885
                              op@(CmmPrim _ Nothing) ->
                                return op
                              CmmPrim op (Just stmts) ->
                                do stmts' <- mapM cmmStmtConFold stmts
                                   return $ CmmPrim op (Just stmts')
886
                 args' <- mapM (\(CmmHinted arg hint) -> do
887
                                  arg' <- cmmExprConFold DataReference arg
888
                                  return (CmmHinted arg' hint)) args
889
                 return $ CmmCall target' regs args' returns
890
891

        CmmCondBranch test dest
892
           -> do test' <- cmmExprConFold DataReference test
893
                 dflags <- getDynFlags
894
                 let platform = targetPlatform dflags
895
896
897
                 return $ case test' of
                   CmmLit (CmmInt 0 _) ->
                     CmmComment (mkFastString ("deleted: " ++
Ian Lynagh's avatar
Ian Lynagh committed
898
                                        showSDoc dflags (pprStmt platform stmt)))
899

900
901
                   CmmLit (CmmInt _ _) -> CmmBranch dest
                   _other -> CmmCondBranch test' dest
902

903
904
905
        CmmSwitch expr ids
           -> do expr' <- cmmExprConFold DataReference expr
                 return $ CmmSwitch expr' ids
906
907

        other
908
           -> return other
909

dterei's avatar
dterei committed
910
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
911
cmmExprConFold referenceKind expr = do
912
    dflags <- getDynFlags
913
914
915
916
    -- Skip constant folding if new code generator is running
    -- (this optimization is done in Hoopl)
    let expr' = if dopt Opt_TryNewCodeGen dflags
                    then expr
Ian Lynagh's avatar
Ian Lynagh committed
917
                    else cmmExprCon (targetPlatform dflags) expr
918
    cmmExprNative referenceKind expr'
919

Ian Lynagh's avatar
Ian Lynagh committed
920
921
922
923
924
cmmExprCon :: Platform -> CmmExpr -> CmmExpr
cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
cmmExprCon platform (CmmMachOp mop args)
    = cmmMachOpFold platform mop (map (cmmExprCon platform) args)
cmmExprCon _ other = other
925
926
927
928
929

-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind expr = do
930
     dflags <- getDynFlags
Ian Lynagh's avatar
Ian Lynagh committed
931
932
     let platform = targetPlatform dflags
         arch = platformArch platform
933
     case expr of
934
        CmmLoad addr rep
935
           -> do addr' <- cmmExprNative DataReference addr
936
                 return $ CmmLoad addr' rep
937
938

        CmmMachOp mop args
939
940
           -> do args' <- mapM (cmmExprNative DataReference) args
                 return $ CmmMachOp mop args'
941
942

        CmmLit (CmmLabel lbl)
943
           -> do
944
                cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
945
        CmmLit (CmmLabelOff lbl off)
946
           -> do
947
948
                 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
                 -- need to optimize here, since it's late
Ian Lynagh's avatar
Ian Lynagh committed
949
                 return $ cmmMachOpFold platform (MO_Add wordWidth) [
950
                     dynRef,
951
                     (CmmLit $ CmmInt (fromIntegral off) wordWidth)
952
                   ]
953

954
955
956
        -- On powerpc (non-PIC), it's easier to jump directly to a label than
        -- to use the register table, so we replace these registers
        -- with the corresponding labels:
957
        CmmReg (CmmGlobal EagerBlackholeInfo)
958
          | arch == ArchPPC && not opt_PIC
959
          -> cmmExprNative referenceKind $
960
             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
961
        CmmReg (CmmGlobal GCEnter1)
962
          | arch == ArchPPC && not opt_PIC
963
          -> cmmExprNative referenceKind $
964
             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
965
        CmmReg (CmmGlobal GCFun)
966
          | arch == ArchPPC && not opt_PIC
967
          -> cmmExprNative referenceKind $
968
             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
969

970
        other
971
           -> return other
972
973
974

\end{code}