compiler/nativeGen/SPARC/CodeGen.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Generating machine code (instruction selection)
   4 --
   5 -- (c) The University of Glasgow 1996-2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module SPARC.CodeGen (
  10         cmmTopCodeGen,
  11         InstrBlock
  12 )
  13
  14 where
  15
  16 #include "HsVersions.h"
  17 #include "nativeGen/NCG.h"
  18 #include "MachDeps.h"
  19
  20 -- NCG stuff:
  21 import SPARC.CodeGen.Amode
  22 import SPARC.CodeGen.CondCode
  23 import SPARC.CodeGen.Gen64
  24 import SPARC.CodeGen.Gen32
  25 import SPARC.CodeGen.CCall
  26 import SPARC.CodeGen.Base
  27 import SPARC.Ppr        ()
  28 import SPARC.Instr
  29 import SPARC.Imm
  30 import SPARC.AddrMode
  31 import SPARC.Regs
  32 import Instruction
  33 import Size
  34 import NCGMonad
  35
  36 -- Our intermediate code:
  37 import BlockId
  38 import Cmm
  39 import CLabel
  40
  41 -- The rest:
  42 import StaticFlags      ( opt_PIC )
  43 import OrdList
  44 import qualified Outputable as O
  45 import Outputable
  46
  47 import Control.Monad    ( mapAndUnzipM )
  48 import DynFlags
  49
  50 -- | Top level code generation
  51 cmmTopCodeGen
  52         :: DynFlags
  53         -> RawCmmTop
  54         -> NatM [NatCmmTop Instr]
  55
  56 cmmTopCodeGen _
  57         (CmmProc info lab params (ListGraph blocks))
  58  = do
  59         (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
  60
  61         let proc        = CmmProc info lab params (ListGraph $ concat nat_blocks)
  62         let tops        = proc : concat statics
  63
  64         return tops
  65
  66 cmmTopCodeGen _ (CmmData sec dat) = do
  67   return [CmmData sec dat]  -- no translation, we just use CmmStatic
  68
  69
  70 -- | Do code generation on a single block of CMM code.
  71 --      code generation may introduce new basic block boundaries, which
  72 --      are indicated by the NEWBLOCK instruction.  We must split up the
  73 --      instruction stream into basic blocks again.  Also, we extract
  74 --      LDATAs here too.
  75 basicBlockCodeGen
  76         :: CmmBasicBlock
  77         -> NatM ( [NatBasicBlock Instr]
  78                 , [NatCmmTop Instr])
  79
  80 basicBlockCodeGen (BasicBlock id stmts) = do
  81   instrs <- stmtsToInstrs stmts
  82   let
  83         (top,other_blocks,statics)
  84                 = foldrOL mkBlocks ([],[],[]) instrs
  85
  86         mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
  87           = ([], BasicBlock id instrs : blocks, statics)
  88
  89         mkBlocks (LDATA sec dat) (instrs,blocks,statics)
  90           = (instrs, blocks, CmmData sec dat:statics)
  91
  92         mkBlocks instr (instrs,blocks,statics)
  93           = (instr:instrs, blocks, statics)
  94
  95         blocksChecked
  96                 = map checkBlockEnd
  97                 $ BasicBlock id top : other_blocks
  98
  99   return (blocksChecked, statics)
 100
 101
 102 -- | Enforce the invariant that all basic blocks must end with a jump.
 103 --      For SPARC this is a jump, then a nop for the branch delay slot.
 104 --
 105 --      If the branch isn't there then the register liveness determinator
 106 --      will get the liveness information wrong. This will cause a bad
 107 --      allocation, which is seriously difficult to debug.
 108 --
 109 --      If there is an instr in the branch delay slot, then the allocator
 110 --      will also get confused and give a bad allocation.
 111 --
 112 checkBlockEnd
 113         :: NatBasicBlock Instr -> NatBasicBlock Instr
 114
 115 checkBlockEnd block@(BasicBlock _ instrs)
 116         | Just (i1, i2) <- takeLast2 instrs
 117         , isJumpishInstr i1
 118         , NOP           <- i2
 119         = block
 120
 121         | otherwise
 122         = pprPanic
 123                 ("SPARC.CodeGen: bad instrs at end of block\n")
 124                 (text "block:\n" <> ppr block)
 125
 126 takeLast2 :: [a] -> Maybe (a, a)
 127 takeLast2 xx
 128  = case xx of
 129         []              -> Nothing
 130         _:[]            -> Nothing
 131         x1:x2:[]        -> Just (x1, x2)
 132         _:xs            -> takeLast2 xs
 133
 134
 135 -- | Convert some Cmm statements to SPARC instructions.
 136 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
 137 stmtsToInstrs stmts
 138    = do instrss <- mapM stmtToInstrs stmts
 139         return (concatOL instrss)
 140
 141
 142 stmtToInstrs :: CmmStmt -> NatM InstrBlock
 143 stmtToInstrs stmt = case stmt of
 144     CmmNop         -> return nilOL
 145     CmmComment s   -> return (unitOL (COMMENT s))
 146
 147     CmmAssign reg src
 148       | isFloatType ty  -> assignReg_FltCode size reg src
 149       | isWord64 ty     -> assignReg_I64Code      reg src
 150       | otherwise       -> assignReg_IntCode size reg src
 151         where ty = cmmRegType reg
 152               size = cmmTypeSize ty
 153
 154     CmmStore addr src
 155       | isFloatType ty  -> assignMem_FltCode size addr src
 156       | isWord64 ty     -> assignMem_I64Code      addr src
 157       | otherwise       -> assignMem_IntCode size addr src
 158         where ty = cmmExprType src
 159               size = cmmTypeSize ty
 160
 161     CmmCall target result_regs args _ _
 162        -> genCCall target result_regs args
 163
 164     CmmBranch   id              -> genBranch id
 165     CmmCondBranch arg id        -> genCondJump id arg
 166     CmmSwitch   arg ids         -> genSwitch arg ids
 167     CmmJump     arg _           -> genJump arg
 168
 169     CmmReturn   _
 170      -> panic "stmtToInstrs: return statement should have been cps'd away"
 171
 172
 173 {-
 174 Now, given a tree (the argument to an CmmLoad) that references memory,
 175 produce a suitable addressing mode.
 176
 177 A Rule of the Game (tm) for Amodes: use of the addr bit must
 178 immediately follow use of the code part, since the code part puts
 179 values in registers which the addr then refers to.  So you can't put
 180 anything in between, lest it overwrite some of those registers.  If
 181 you need to do some other computation between the code part and use of
 182 the addr bit, first store the effective address from the amode in a
 183 temporary, then do the other computation, and then use the temporary:
 184
 185     code
 186     LEA amode, tmp
 187     ... other computation ...
 188     ... (tmp) ...
 189 -}
 190
 191
 192
 193 -- | Convert a BlockId to some CmmStatic data
 194 jumpTableEntry :: Maybe BlockId -> CmmStatic
 195 jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
 196 jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
 197     where blockLabel = mkAsmTempLabel id
 198
 199
 200
 201 -- -----------------------------------------------------------------------------
 202 -- Generating assignments
 203
 204 -- Assignments are really at the heart of the whole code generation
 205 -- business.  Almost all top-level nodes of any real importance are
 206 -- assignments, which correspond to loads, stores, or register
 207 -- transfers.  If we're really lucky, some of the register transfers
 208 -- will go away, because we can use the destination register to
 209 -- complete the code generation for the right hand side.  This only
 210 -- fails when the right hand side is forced into a fixed register
 211 -- (e.g. the result of a call).
 212
 213 assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 214 assignMem_IntCode pk addr src = do
 215     (srcReg, code) <- getSomeReg src
 216     Amode dstAddr addr_code <- getAmode addr
 217     return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
 218
 219
 220 assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 221 assignReg_IntCode _ reg src = do
 222     r <- getRegister src
 223     return $ case r of
 224         Any _ code         -> code dst
 225         Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
 226     where
 227       dst = getRegisterReg reg
 228
 229
 230
 231 -- Floating point assignment to memory
 232 assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 233 assignMem_FltCode pk addr src = do
 234     Amode dst__2 code1 <- getAmode addr
 235     (src__2, code2) <- getSomeReg src
 236     tmp1 <- getNewRegNat pk
 237     let
 238         pk__2   = cmmExprType src
 239         code__2 = code1 `appOL` code2 `appOL`
 240             if   sizeToWidth pk == typeWidth pk__2
 241             then unitOL (ST pk src__2 dst__2)
 242             else toOL   [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1
 243                         , ST    pk tmp1 dst__2]
 244     return code__2
 245
 246 -- Floating point assignment to a register/temporary
 247 assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 248 assignReg_FltCode pk dstCmmReg srcCmmExpr = do
 249     srcRegister <- getRegister srcCmmExpr
 250     let dstReg  = getRegisterReg dstCmmReg
 251
 252     return $ case srcRegister of
 253         Any _ code                  -> code dstReg
 254         Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
 255
 256
 257
 258
 259 genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
 260
 261 genJump (CmmLit (CmmLabel lbl))
 262   = return (toOL [CALL (Left target) 0 True, NOP])
 263   where
 264     target = ImmCLbl lbl
 265
 266 genJump tree
 267   = do
 268         (target, code) <- getSomeReg tree
 269         return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)
 270
 271 -- -----------------------------------------------------------------------------
 272 --  Unconditional branches
 273
 274 genBranch :: BlockId -> NatM InstrBlock
 275 genBranch = return . toOL . mkJumpInstr
 276
 277
 278 -- -----------------------------------------------------------------------------
 279 --  Conditional jumps
 280
 281 {-
 282 Conditional jumps are always to local labels, so we can use branch
 283 instructions.  We peek at the arguments to decide what kind of
 284 comparison to do.
 285
 286 SPARC: First, we have to ensure that the condition codes are set
 287 according to the supplied comparison operation.  We generate slightly
 288 different code for floating point comparisons, because a floating
 289 point operation cannot directly precede a @BF@.  We assume the worst
 290 and fill that slot with a @NOP@.
 291
 292 SPARC: Do not fill the delay slots here; you will confuse the register
 293 allocator.
 294 -}
 295
 296
 297 genCondJump
 298     :: BlockId      -- the branch target
 299     -> CmmExpr      -- the condition on which to branch
 300     -> NatM InstrBlock
 301
 302
 303
 304 genCondJump bid bool = do
 305   CondCode is_float cond code <- getCondCode bool
 306   return (
 307        code `appOL`
 308        toOL (
 309          if   is_float
 310          then [NOP, BF cond False bid, NOP]
 311          else [BI cond False bid, NOP]
 312        )
 313     )
 314
 315
 316
 317 -- -----------------------------------------------------------------------------
 318 -- Generating a table-branch
 319
 320 genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
 321 genSwitch expr ids
 322         | opt_PIC
 323         = error "MachCodeGen: sparc genSwitch PIC not finished\n"
 324
 325         | otherwise
 326         = do    (e_reg, e_code) <- getSomeReg expr
 327
 328                 base_reg        <- getNewRegNat II32
 329                 offset_reg      <- getNewRegNat II32
 330                 dst             <- getNewRegNat II32
 331
 332                 label           <- getNewLabelNat
 333                 let jumpTable   = map jumpTableEntry ids
 334
 335                 return $ e_code `appOL`
 336                  toOL
 337                         -- the jump table
 338                         [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
 339
 340                         -- load base of jump table
 341                         , SETHI (HI (ImmCLbl label)) base_reg
 342                         , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
 343
 344                         -- the addrs in the table are 32 bits wide..
 345                         , SLL   e_reg (RIImm $ ImmInt 2) offset_reg
 346
 347                         -- load and jump to the destination
 348                         , LD      II32 (AddrRegReg base_reg offset_reg) dst
 349                         , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
 350                         , NOP ]
 351