1 -----------------------------------------------------------------------------
3 -- Generating machine code (instruction selection)
5 -- (c) The University of Glasgow 1996-2004
7 -----------------------------------------------------------------------------
16 #include "HsVersions.h"
17 #include "nativeGen/NCG.h"
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
35 -- Our intermediate code:
41 import StaticFlags ( opt_PIC )
43 import qualified Outputable as O
46 import Control.Monad ( mapAndUnzipM )
49 -- | Top level code generation
53 -> NatM [NatCmmTop Instr]
56 (CmmProc info lab params (ListGraph blocks))
58 (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
60 -- picBaseMb <- getPicBaseMaybeNat
61 let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
62 let tops = proc : concat statics
65 -- Just picBase -> initializePicBase picBase tops
66 -- Nothing -> return tops
71 cmmTopCodeGen _ (CmmData sec dat) = do
72 return [CmmData sec dat] -- no translation, we just use CmmStatic
78 -> NatM ( [NatBasicBlock Instr]
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
88 (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
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)
97 return (BasicBlock id top : other_blocks, statics)
100 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
102 = do instrss <- mapM stmtToInstrs stmts
103 return (concatOL instrss)
106 stmtToInstrs :: CmmStmt -> NatM InstrBlock
107 stmtToInstrs stmt = case stmt of
108 CmmNop -> return nilOL
109 CmmComment s -> return (unitOL (COMMENT s))
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
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
125 CmmCall target result_regs args _ _
126 -> genCCall target result_regs args
128 CmmBranch id -> genBranch id
129 CmmCondBranch arg id -> genCondJump id arg
130 CmmSwitch arg ids -> genSwitch arg ids
131 CmmJump arg _ -> genJump arg
134 -> panic "stmtToInstrs: return statement should have been cps'd away"
138 Now, given a tree (the argument to an CmmLoad) that references memory,
139 produce a suitable addressing mode.
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:
151 ... other computation ...
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
165 -- -----------------------------------------------------------------------------
166 -- Generating assignments
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).
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
184 assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
185 assignReg_IntCode _ reg src = do
188 Any _ code -> code dst
189 Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
191 dst = getRegisterReg reg
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
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
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
216 return $ case srcRegister of
217 Any _ code -> code dstReg
218 Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
223 genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
225 genJump (CmmLit (CmmLabel lbl))
226 = return (toOL [CALL (Left target) 0 True, NOP])
232 (target, code) <- getSomeReg tree
233 return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
235 -- -----------------------------------------------------------------------------
236 -- Unconditional branches
238 genBranch :: BlockId -> NatM InstrBlock
239 genBranch = return . toOL . mkJumpInstr
242 -- -----------------------------------------------------------------------------
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
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@.
256 SPARC: Do not fill the delay slots here; you will confuse the register
262 :: BlockId -- the branch target
263 -> CmmExpr -- the condition on which to branch
268 genCondJump bid bool = do
269 CondCode is_float cond code <- getCondCode bool
274 then [NOP, BF cond False bid, NOP]
275 else [BI cond False bid, NOP]
281 -- -----------------------------------------------------------------------------
282 -- Generating a table-branch
284 genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
287 = error "MachCodeGen: sparc genSwitch PIC not finished\n"
290 = do (e_reg, e_code) <- getSomeReg expr
292 base_reg <- getNewRegNat II32
293 offset_reg <- getNewRegNat II32
294 dst <- getNewRegNat II32
296 label <- getNewLabelNat
297 let jumpTable = map jumpTableEntry ids
299 return $ e_code `appOL`
302 [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
304 -- load base of jump table
305 , SETHI (HI (ImmCLbl label)) base_reg
306 , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
308 -- the addrs in the table are 32 bits wide..
309 , SLL e_reg (RIImm $ ImmInt 2) offset_reg
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]