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