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