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 module AsmCodeGen ( nativeCodeGen ) where
  11
  12 #include "HsVersions.h"
  13 #include "NCG.h"
  14
  15 import MachInstrs
  16 import MachRegs
  17 import MachCodeGen
  18 import PprMach
  19 import RegisterAlloc
  20 import RegAllocInfo     ( jumpDests )
  21 import NCGMonad
  22 import PositionIndependentCode
  23
  24 import Cmm
  25 import CmmOpt           ( cmmMiniInline, cmmMachOpFold )
  26 import PprCmm           ( pprStmt, pprCmms )
  27 import MachOp
  28 import CLabel           ( CLabel, mkSplitMarkerLabel, mkAsmTempLabel )
  29 #if powerpc_TARGET_ARCH
  30 import CLabel           ( mkRtsCodeLabel )
  31 #endif
  32
  33 import UniqFM
  34 import Unique           ( Unique, getUnique )
  35 import UniqSupply
  36 import FastTypes
  37 import List             ( groupBy, sortBy )
  38 import CLabel           ( pprCLabel )
  39 import ErrUtils         ( dumpIfSet_dyn )
  40 import DynFlags         ( DynFlags, DynFlag(..), dopt )
  41 import StaticFlags      ( opt_Static, opt_PIC )
  42
  43 import Digraph
  44 import qualified Pretty
  45 import Outputable
  46 import FastString
  47
  48 -- DEBUGGING ONLY
  49 --import OrdList
  50
  51 #ifdef NCG_DEBUG
  52 import List             ( intersperse )
  53 #endif
  54
  55 import DATA_INT
  56 import DATA_WORD
  57 import DATA_BITS
  58 import GLAEXTS
  59
  60 {-
  61 The native-code generator has machine-independent and
  62 machine-dependent modules.
  63
  64 This module ("AsmCodeGen") is the top-level machine-independent
  65 module.  Before entering machine-dependent land, we do some
  66 machine-independent optimisations (defined below) on the
  67 'CmmStmts's.
  68
  69 We convert to the machine-specific 'Instr' datatype with
  70 'cmmCodeGen', assuming an infinite supply of registers.  We then use
  71 a machine-independent register allocator ('regAlloc') to rejoin
  72 reality.  Obviously, 'regAlloc' has machine-specific helper
  73 functions (see about "RegAllocInfo" below).
  74
  75 Finally, we order the basic blocks of the function so as to minimise
  76 the number of jumps between blocks, by utilising fallthrough wherever
  77 possible.
  78
  79 The machine-dependent bits break down as follows:
  80
  81   * ["MachRegs"]  Everything about the target platform's machine
  82     registers (and immediate operands, and addresses, which tend to
  83     intermingle/interact with registers).
  84
  85   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
  86     have a module of its own), plus a miscellany of other things
  87     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
  88
  89   * ["MachCodeGen"]  is where 'Cmm' stuff turns into
  90     machine instructions.
  91
  92   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
  93     a 'Doc').
  94
  95   * ["RegAllocInfo"] In the register allocator, we manipulate
  96     'MRegsState's, which are 'BitSet's, one bit per machine register.
  97     When we want to say something about a specific machine register
  98     (e.g., ``it gets clobbered by this instruction''), we set/unset
  99     its bit.  Obviously, we do this 'BitSet' thing for efficiency
 100     reasons.
 101
 102     The 'RegAllocInfo' module collects together the machine-specific
 103     info needed to do register allocation.
 104
 105    * ["RegisterAlloc"] The (machine-independent) register allocator.
 106 -}
 107
 108 -- -----------------------------------------------------------------------------
 109 -- Top-level of the native codegen
 110
 111 -- NB. We *lazilly* compile each block of code for space reasons.
 112
 113 nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
 114 nativeCodeGen dflags cmms us
 115   = let (res, _) = initUs us $
 116            cgCmm (concat (map add_split cmms))
 117
 118         cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
 119         cgCmm tops =
 120            lazyMapUs (cmmNativeGen dflags) tops  `thenUs` \ results ->
 121            case unzip3 results of { (cmms,docs,imps) ->
 122            returnUs (Cmm cmms, my_vcat docs, concat imps)
 123            }
 124     in
 125     case res of { (ppr_cmms, insn_sdoc, imports) -> do
 126     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms])
 127     return (insn_sdoc Pretty.$$ dyld_stubs imports
 128 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
 129                 -- On recent versions of Darwin, the linker supports
 130                 -- dead-stripping of code and data on a per-symbol basis.
 131                 -- There's a hack to make this work in PprMach.pprNatCmmTop.
 132             Pretty.$$ Pretty.text ".subsections_via_symbols"
 133 #endif
 134             )
 135    }
 136
 137   where
 138
 139     add_split (Cmm tops)
 140         | dopt Opt_SplitObjs dflags = split_marker : tops
 141         | otherwise                 = tops
 142
 143     split_marker = CmmProc [] mkSplitMarkerLabel [] []
 144
 145          -- Generate "symbol stubs" for all external symbols that might
 146          -- come from a dynamic library.
 147 {-    dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
 148                                     map head $ group $ sort imps-}
 149
 150         -- (Hack) sometimes two Labels pretty-print the same, but have
 151         -- different uniques; so we compare their text versions...
 152     dyld_stubs imps
 153         | needImportedSymbols
 154           = Pretty.vcat $
 155             (pprGotDeclaration :) $
 156             map (pprImportedSymbol . fst . head) $
 157             groupBy (\(_,a) (_,b) -> a == b) $
 158             sortBy (\(_,a) (_,b) -> compare a b) $
 159             map doPpr $
 160             imps
 161         | otherwise
 162           = Pretty.empty
 163
 164         where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
 165               astyle = mkCodeStyle AsmStyle
 166
 167 #ifndef NCG_DEBUG
 168     my_vcat sds = Pretty.vcat sds
 169 #else
 170     my_vcat sds = Pretty.vcat (
 171                       intersperse (
 172                          Pretty.char ' '
 173                             Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
 174                             Pretty.$$ Pretty.char ' '
 175                       )
 176                       sds
 177                    )
 178 #endif
 179
 180
 181 -- Complete native code generation phase for a single top-level chunk
 182 -- of Cmm.
 183
 184 cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
 185 cmmNativeGen dflags cmm
 186    = {-# SCC "fixAssigns"       #-}
 187         fixAssignsTop cmm            `thenUs` \ fixed_cmm ->
 188      {-# SCC "genericOpt"       #-}
 189         cmmToCmm fixed_cmm           `bind`   \ (cmm, imports) ->
 190         (if dopt Opt_D_dump_opt_cmm dflags  -- space leak avoidance
 191            then cmm
 192            else CmmData Text [])     `bind`   \ ppr_cmm ->
 193      {-# SCC "genMachCode"      #-}
 194         genMachCode cmm              `thenUs` \ (pre_regalloc, lastMinuteImports) ->
 195      {-# SCC "regAlloc"         #-}
 196         mapUs regAlloc pre_regalloc `thenUs`   \ with_regs ->
 197      {-# SCC "sequenceBlocks"   #-}
 198         map sequenceTop with_regs    `bind`   \ sequenced ->
 199      {-# SCC "x86fp_kludge"     #-}
 200         map x86fp_kludge sequenced   `bind`   \ final_mach_code ->
 201      {-# SCC "vcat"             #-}
 202         Pretty.vcat (map pprNatCmmTop final_mach_code)  `bind`   \ final_sdoc ->
 203
 204         returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
 205      where
 206         x86fp_kludge :: NatCmmTop -> NatCmmTop
 207         x86fp_kludge top@(CmmData _ _) = top
 208 #if i386_TARGET_ARCH
 209         x86fp_kludge top@(CmmProc info lbl params code) =
 210                 CmmProc info lbl params (map bb_i386_insert_ffrees code)
 211                 where
 212                   bb_i386_insert_ffrees (BasicBlock id instrs) =
 213                         BasicBlock id (i386_insert_ffrees instrs)
 214 #else
 215         x86fp_kludge top =  top
 216 #endif
 217
 218 -- -----------------------------------------------------------------------------
 219 -- Sequencing the basic blocks
 220
 221 -- Cmm BasicBlocks are self-contained entities: they always end in a
 222 -- jump, either non-local or to another basic block in the same proc.
 223 -- In this phase, we attempt to place the basic blocks in a sequence
 224 -- such that as many of the local jumps as possible turn into
 225 -- fallthroughs.
 226
 227 sequenceTop :: NatCmmTop -> NatCmmTop
 228 sequenceTop top@(CmmData _ _) = top
 229 sequenceTop (CmmProc info lbl params blocks) =
 230   CmmProc info lbl params (sequenceBlocks blocks)
 231
 232 -- The algorithm is very simple (and stupid): we make a graph out of
 233 -- the blocks where there is an edge from one block to another iff the
 234 -- first block ends by jumping to the second.  Then we topologically
 235 -- sort this graph.  Then traverse the list: for each block, we first
 236 -- output the block, then if it has an out edge, we move the
 237 -- destination of the out edge to the front of the list, and continue.
 238
 239 sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
 240 sequenceBlocks [] = []
 241 sequenceBlocks (entry:blocks) =
 242   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
 243   -- the first block is the entry point ==> it must remain at the start.
 244
 245 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
 246 sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
 247
 248 getOutEdges :: [Instr] -> [Unique]
 249 getOutEdges instrs = case jumpDests (last instrs) [] of
 250                         [one] -> [getUnique one]
 251                         _many -> []
 252                 -- we're only interested in the last instruction of
 253                 -- the block, and only if it has a single destination.
 254
 255 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 256
 257 seqBlocks [] = []
 258 seqBlocks ((block,_,[]) : rest)
 259   = block : seqBlocks rest
 260 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
 261   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
 262   | otherwise       = block : seqBlocks rest'
 263   where
 264         (can_fallthrough, rest') = reorder next [] rest
 265           -- TODO: we should do a better job for cycles; try to maximise the
 266           -- fallthroughs within a loop.
 267 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 268
 269 reorder id accum [] = (False, reverse accum)
 270 reorder id accum (b@(block,id',out) : rest)
 271   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
 272   | otherwise  = reorder id (b:accum) rest
 273
 274 -- -----------------------------------------------------------------------------
 275 -- Instruction selection
 276
 277 -- Native code instruction selection for a chunk of stix code.  For
 278 -- this part of the computation, we switch from the UniqSM monad to
 279 -- the NatM monad.  The latter carries not only a Unique, but also an
 280 -- Int denoting the current C stack pointer offset in the generated
 281 -- code; this is needed for creating correct spill offsets on
 282 -- architectures which don't offer, or for which it would be
 283 -- prohibitively expensive to employ, a frame pointer register.  Viz,
 284 -- x86.
 285
 286 -- The offset is measured in bytes, and indicates the difference
 287 -- between the current (simulated) C stack-ptr and the value it was at
 288 -- the beginning of the block.  For stacks which grow down, this value
 289 -- should be either zero or negative.
 290
 291 -- Switching between the two monads whilst carrying along the same
 292 -- Unique supply breaks abstraction.  Is that bad?
 293
 294 genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
 295
 296 genMachCode cmm_top initial_us
 297   = let initial_st             = mkNatM_State initial_us 0
 298         (new_tops, final_st)   = initNat initial_st (cmmTopCodeGen cmm_top)
 299         final_us               = natm_us final_st
 300         final_delta            = natm_delta final_st
 301         final_imports          = natm_imports final_st
 302     in
 303         if   final_delta == 0
 304         then ((new_tops, final_imports), final_us)
 305         else pprPanic "genMachCode: nonzero final delta"
 306                       (int final_delta)
 307
 308 -- -----------------------------------------------------------------------------
 309 -- Fixup assignments to global registers so that they assign to
 310 -- locations within the RegTable, if appropriate.
 311
 312 -- Note that we currently don't fixup reads here: they're done by
 313 -- the generic optimiser below, to avoid having two separate passes
 314 -- over the Cmm.
 315
 316 fixAssignsTop :: CmmTop -> UniqSM CmmTop
 317 fixAssignsTop top@(CmmData _ _) = returnUs top
 318 fixAssignsTop (CmmProc info lbl params blocks) =
 319   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
 320   returnUs (CmmProc info lbl params blocks')
 321
 322 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 323 fixAssignsBlock (BasicBlock id stmts) =
 324   fixAssigns stmts `thenUs` \ stmts' ->
 325   returnUs (BasicBlock id stmts')
 326
 327 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
 328 fixAssigns stmts =
 329   mapUs fixAssign stmts `thenUs` \ stmtss ->
 330   returnUs (concat stmtss)
 331
 332 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
 333 fixAssign (CmmAssign (CmmGlobal BaseReg) src)
 334    = panic "cmmStmtConFold: assignment to BaseReg";
 335
 336 fixAssign (CmmAssign (CmmGlobal reg) src)
 337   | Left  realreg <- reg_or_addr
 338   = returnUs [CmmAssign (CmmGlobal reg) src]
 339   | Right baseRegAddr <- reg_or_addr
 340   = returnUs [CmmStore baseRegAddr src]
 341            -- Replace register leaves with appropriate StixTrees for
 342            -- the given target. GlobalRegs which map to a reg on this
 343            -- arch are left unchanged.  Assigning to BaseReg is always
 344            -- illegal, so we check for that.
 345   where
 346         reg_or_addr = get_GlobalReg_reg_or_addr reg
 347
 348 fixAssign (CmmCall target results args vols)
 349   = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
 350     returnUs (caller_save ++
 351               CmmCall target results' args vols :
 352               caller_restore ++
 353               concat stores)
 354   where
 355         -- we also save/restore any caller-saves STG registers here
 356         (caller_save, caller_restore) = callerSaveVolatileRegs vols
 357
 358         fixResult g@(CmmGlobal reg,hint) =
 359           case get_GlobalReg_reg_or_addr reg of
 360                 Left realreg -> returnUs (g, [])
 361                 Right baseRegAddr ->
 362                     getUniqueUs `thenUs` \ uq ->
 363                     let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
 364                     returnUs ((local,hint),
 365                               [CmmStore baseRegAddr (CmmReg local)])
 366         fixResult other =
 367           returnUs (other,[])
 368
 369 fixAssign other_stmt = returnUs [other_stmt]
 370
 371 -- -----------------------------------------------------------------------------
 372 -- Generic Cmm optimiser
 373
 374 {-
 375 Here we do:
 376
 377   (a) Constant folding
 378   (b) Simple inlining: a temporary which is assigned to and then
 379       used, once, can be shorted.
 380   (c) Replacement of references to GlobalRegs which do not have
 381       machine registers by the appropriate memory load (eg.
 382       Hp ==>  *(BaseReg + 34) ).
 383   (d) Position independent code and dynamic linking
 384         (i)  introduce the appropriate indirections
 385              and position independent refs
 386         (ii) compile a list of imported symbols
 387
 388 Ideas for other things we could do (ToDo):
 389
 390   - shortcut jumps-to-jumps
 391   - eliminate dead code blocks
 392   - simple CSE: if an expr is assigned to a temp, then replace later occs of
 393     that expr with the temp, until the expr is no longer valid (can push through
 394     temp assignments, and certain assigns to mem...)
 395 -}
 396
 397 cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
 398 cmmToCmm top@(CmmData _ _) = (top, [])
 399 cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
 400   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
 401   return $ CmmProc info lbl params blocks'
 402
 403 newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
 404
 405 instance Monad CmmOptM where
 406   return x = CmmOptM $ \imports -> (# x,imports #)
 407   (CmmOptM f) >>= g =
 408     CmmOptM $ \imports ->
 409                 case f imports of
 410                   (# x, imports' #) ->
 411                     case g x of
 412                       CmmOptM g' -> g' imports'
 413
 414 addImportCmmOpt :: CLabel -> CmmOptM ()
 415 addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
 416
 417 runCmmOpt :: CmmOptM a -> (a, [CLabel])
 418 runCmmOpt (CmmOptM f) = case f [] of
 419                         (# result, imports #) -> (result, imports)
 420
 421 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
 422 cmmBlockConFold (BasicBlock id stmts) = do
 423   stmts' <- mapM cmmStmtConFold stmts
 424   return $ BasicBlock id stmts'
 425
 426 cmmStmtConFold stmt
 427    = case stmt of
 428         CmmAssign reg src
 429            -> do src' <- cmmExprConFold False src
 430                  return $ case src' of
 431                    CmmReg reg' | reg == reg' -> CmmNop
 432                    new_src -> CmmAssign reg new_src
 433
 434         CmmStore addr src
 435            -> do addr' <- cmmExprConFold False addr
 436                  src'  <- cmmExprConFold False src
 437                  return $ CmmStore addr' src'
 438
 439         CmmJump addr regs
 440            -> do addr' <- cmmExprConFold True addr
 441                  return $ CmmJump addr' regs
 442
 443         CmmCall target regs args vols
 444            -> do target' <- case target of
 445                               CmmForeignCall e conv -> do
 446                                 e' <- cmmExprConFold True e
 447                                 return $ CmmForeignCall e' conv
 448                               other -> return other
 449                  args' <- mapM (\(arg, hint) -> do
 450                                   arg' <- cmmExprConFold False arg
 451                                   return (arg', hint)) args
 452                  return $ CmmCall target' regs args' vols
 453
 454         CmmCondBranch test dest
 455            -> do test' <- cmmExprConFold False test
 456                  return $ case test' of
 457                    CmmLit (CmmInt 0 _) ->
 458                      CmmComment (mkFastString ("deleted: " ++
 459                                         showSDoc (pprStmt stmt)))
 460
 461                    CmmLit (CmmInt n _) -> CmmBranch dest
 462                    other -> CmmCondBranch test' dest
 463
 464         CmmSwitch expr ids
 465            -> do expr' <- cmmExprConFold False expr
 466                  return $ CmmSwitch expr' ids
 467
 468         other
 469            -> return other
 470
 471
 472 cmmExprConFold isJumpTarget expr
 473    = case expr of
 474         CmmLoad addr rep
 475            -> do addr' <- cmmExprConFold False addr
 476                  return $ CmmLoad addr' rep
 477
 478         CmmMachOp mop args
 479            -- For MachOps, we first optimize the children, and then we try
 480            -- our hand at some constant-folding.
 481            -> do args' <- mapM (cmmExprConFold False) args
 482                  return $ cmmMachOpFold mop args'
 483
 484         CmmLit (CmmLabel lbl)
 485            -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
 486         CmmLit (CmmLabelOff lbl off)
 487            -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
 488                  return $ cmmMachOpFold (MO_Add wordRep) [
 489                      dynRef,
 490                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
 491                    ]
 492
 493 #if powerpc_TARGET_ARCH
 494            -- On powerpc (non-PIC), it's easier to jump directly to a label than
 495            -- to use the register table, so we replace these registers
 496            -- with the corresponding labels:
 497         CmmReg (CmmGlobal GCEnter1)
 498           | not opt_PIC
 499           -> cmmExprConFold isJumpTarget $
 500              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
 501         CmmReg (CmmGlobal GCFun)
 502           | not opt_PIC
 503           -> cmmExprConFold isJumpTarget $
 504              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
 505 #endif
 506
 507         CmmReg (CmmGlobal mid)
 508            -- Replace register leaves with appropriate StixTrees for
 509            -- the given target.  MagicIds which map to a reg on this
 510            -- arch are left unchanged.  For the rest, BaseReg is taken
 511            -- to mean the address of the reg table in MainCapability,
 512            -- and for all others we generate an indirection to its
 513            -- location in the register table.
 514            -> case get_GlobalReg_reg_or_addr mid of
 515                  Left  realreg -> return expr
 516                  Right baseRegAddr
 517                     -> case mid of
 518                           BaseReg -> cmmExprConFold False baseRegAddr
 519                           other   -> cmmExprConFold False (CmmLoad baseRegAddr
 520                                                         (globalRegRep mid))
 521            -- eliminate zero offsets
 522         CmmRegOff reg 0
 523            -> cmmExprConFold False (CmmReg reg)
 524
 525         CmmRegOff (CmmGlobal mid) offset
 526            -- RegOf leaves are just a shorthand form. If the reg maps
 527            -- to a real reg, we keep the shorthand, otherwise, we just
 528            -- expand it and defer to the above code.
 529            -> case get_GlobalReg_reg_or_addr mid of
 530                 Left  realreg -> return expr
 531                 Right baseRegAddr
 532                    -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
 533                                         CmmReg (CmmGlobal mid),
 534                                         CmmLit (CmmInt (fromIntegral offset)
 535                                                        wordRep)])
 536         other
 537            -> return other
 538
 539 -- -----------------------------------------------------------------------------
 540 -- Utils
 541
 542 bind f x = x $! f
 543
 544 \end{code}
 545