1 -----------------------------------------------------------------------------
3 -- Generating machine code (instruction selection)
5 -- (c) The University of Glasgow 1996-2004
7 -----------------------------------------------------------------------------
11 generateJumpTableForInstr,
17 #include "HsVersions.h"
18 #include "nativeGen/NCG.h"
19 #include "../includes/MachDeps.h"
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
38 -- Our intermediate code:
44 import StaticFlags ( opt_PIC )
49 import Control.Monad ( mapAndUnzipM )
52 -- | Top level code generation
56 -> NatM [NatCmmTop Instr]
59 (CmmProc info lab (ListGraph blocks))
61 (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
63 let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
64 let tops = proc : concat statics
68 cmmTopCodeGen _ (CmmData sec dat) = do
69 return [CmmData sec dat] -- no translation, we just use CmmStatic
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
79 -> NatM ( [NatBasicBlock Instr]
82 basicBlockCodeGen cmm@(BasicBlock id stmts) = do
83 instrs <- stmtsToInstrs stmts
85 (top,other_blocks,statics)
86 = foldrOL mkBlocks ([],[],[]) instrs
88 mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
89 = ([], BasicBlock id instrs : blocks, statics)
91 mkBlocks (LDATA sec dat) (instrs,blocks,statics)
92 = (instrs, blocks, CmmData sec dat:statics)
94 mkBlocks instr (instrs,blocks,statics)
95 = (instr:instrs, blocks, statics)
97 -- do intra-block sanity checking
99 = map (checkBlock cmm)
100 $ BasicBlock id top : other_blocks
102 return (blocksChecked, statics)
105 -- | Convert some Cmm statements to SPARC instructions.
106 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
108 = do instrss <- mapM stmtToInstrs stmts
109 return (concatOL instrss)
112 stmtToInstrs :: CmmStmt -> NatM InstrBlock
113 stmtToInstrs stmt = case stmt of
114 CmmNop -> return nilOL
115 CmmComment s -> return (unitOL (COMMENT s))
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
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
131 CmmCall target result_regs args _ _
132 -> genCCall target result_regs args
134 CmmBranch id -> genBranch id
135 CmmCondBranch arg id -> genCondJump id arg
136 CmmSwitch arg ids -> genSwitch arg ids
137 CmmJump arg _ -> genJump arg
140 -> panic "stmtToInstrs: return statement should have been cps'd away"
144 Now, given a tree (the argument to an CmmLoad) that references memory,
145 produce a suitable addressing mode.
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:
157 ... other computation ...
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)
171 -- -----------------------------------------------------------------------------
172 -- Generating assignments
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).
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
190 assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
191 assignReg_IntCode _ reg src = do
194 Any _ code -> code dst
195 Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
197 dst = getRegisterReg reg
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
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
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
222 return $ case srcRegister of
223 Any _ code -> code dstReg
224 Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
229 genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
231 genJump (CmmLit (CmmLabel lbl))
232 = return (toOL [CALL (Left target) 0 True, NOP])
238 (target, code) <- getSomeReg tree
239 return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
241 -- -----------------------------------------------------------------------------
242 -- Unconditional branches
244 genBranch :: BlockId -> NatM InstrBlock
245 genBranch = return . toOL . mkJumpInstr
248 -- -----------------------------------------------------------------------------
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
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@.
262 SPARC: Do not fill the delay slots here; you will confuse the register
268 :: BlockId -- the branch target
269 -> CmmExpr -- the condition on which to branch
274 genCondJump bid bool = do
275 CondCode is_float cond code <- getCondCode bool
280 then [NOP, BF cond False bid, NOP]
281 else [BI cond False bid, NOP]
287 -- -----------------------------------------------------------------------------
288 -- Generating a table-branch
290 genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
293 = error "MachCodeGen: sparc genSwitch PIC not finished\n"
296 = do (e_reg, e_code) <- getSomeReg expr
298 base_reg <- getNewRegNat II32
299 offset_reg <- getNewRegNat II32
300 dst <- getNewRegNat II32
302 label <- getNewLabelNat
304 return $ e_code `appOL`
306 [ -- load base of jump table
307 SETHI (HI (ImmCLbl label)) base_reg
308 , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
310 -- the addrs in the table are 32 bits wide..
311 , SLL e_reg (RIImm $ ImmInt 2) offset_reg
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
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