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