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