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