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