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