Fix todo in compiler/nativeGen: Rename Size to Format
[ghc.git] / compiler / nativeGen / SPARC / CodeGen.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Generating machine code (instruction selection)
6 --
7 -- (c) The University of Glasgow 1996-2013
8 --
9 -----------------------------------------------------------------------------
10
11 {-# LANGUAGE GADTs #-}
12 module SPARC.CodeGen (
13 cmmTopCodeGen,
14 generateJumpTableForInstr,
15 InstrBlock
16 )
17
18 where
19
20 #include "HsVersions.h"
21 #include "nativeGen/NCG.h"
22 #include "../includes/MachDeps.h"
23
24 -- NCG stuff:
25 import SPARC.Base
26 import SPARC.CodeGen.Sanity
27 import SPARC.CodeGen.Amode
28 import SPARC.CodeGen.CondCode
29 import SPARC.CodeGen.Gen64
30 import SPARC.CodeGen.Gen32
31 import SPARC.CodeGen.Base
32 import SPARC.Ppr ()
33 import SPARC.Instr
34 import SPARC.Imm
35 import SPARC.AddrMode
36 import SPARC.Regs
37 import SPARC.Stack
38 import Instruction
39 import Format
40 import NCGMonad
41
42 -- Our intermediate code:
43 import BlockId
44 import Cmm
45 import CmmUtils
46 import CmmSwitch
47 import Hoopl
48 import PIC
49 import Reg
50 import CLabel
51 import CPrim
52
53 -- The rest:
54 import BasicTypes
55 import DynFlags
56 import FastString
57 import OrdList
58 import Outputable
59 import Platform
60 import Unique
61
62 import Control.Monad ( mapAndUnzipM )
63
64 -- | Top level code generation
65 cmmTopCodeGen :: RawCmmDecl
66 -> NatM [NatCmmDecl CmmStatics Instr]
67
68 cmmTopCodeGen (CmmProc info lab live graph)
69 = do let blocks = toBlockListEntryFirst graph
70 (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
71
72 let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
73 let tops = proc : concat statics
74
75 return tops
76
77 cmmTopCodeGen (CmmData sec dat) = do
78 return [CmmData sec dat] -- no translation, we just use CmmStatic
79
80
81 -- | Do code generation on a single block of CMM code.
82 -- code generation may introduce new basic block boundaries, which
83 -- are indicated by the NEWBLOCK instruction. We must split up the
84 -- instruction stream into basic blocks again. Also, we extract
85 -- LDATAs here too.
86 basicBlockCodeGen :: CmmBlock
87 -> NatM ( [NatBasicBlock Instr]
88 , [NatCmmDecl CmmStatics Instr])
89
90 basicBlockCodeGen block = do
91 let (_, nodes, tail) = blockSplit block
92 id = entryLabel block
93 stmts = blockToList nodes
94 mid_instrs <- stmtsToInstrs stmts
95 tail_instrs <- stmtToInstrs tail
96 let instrs = mid_instrs `appOL` tail_instrs
97 let
98 (top,other_blocks,statics)
99 = foldrOL mkBlocks ([],[],[]) instrs
100
101 mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
102 = ([], BasicBlock id instrs : blocks, statics)
103
104 mkBlocks (LDATA sec dat) (instrs,blocks,statics)
105 = (instrs, blocks, CmmData sec dat:statics)
106
107 mkBlocks instr (instrs,blocks,statics)
108 = (instr:instrs, blocks, statics)
109
110 -- do intra-block sanity checking
111 blocksChecked
112 = map (checkBlock block)
113 $ BasicBlock id top : other_blocks
114
115 return (blocksChecked, statics)
116
117
118 -- | Convert some Cmm statements to SPARC instructions.
119 stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
120 stmtsToInstrs stmts
121 = do instrss <- mapM stmtToInstrs stmts
122 return (concatOL instrss)
123
124
125 stmtToInstrs :: CmmNode e x -> NatM InstrBlock
126 stmtToInstrs stmt = do
127 dflags <- getDynFlags
128 case stmt of
129 CmmComment s -> return (unitOL (COMMENT s))
130 CmmTick {} -> return nilOL
131 CmmUnwind {} -> return nilOL
132
133 CmmAssign reg src
134 | isFloatType ty -> assignReg_FltCode format reg src
135 | isWord64 ty -> assignReg_I64Code reg src
136 | otherwise -> assignReg_IntCode format reg src
137 where ty = cmmRegType dflags reg
138 format = cmmTypeFormat ty
139
140 CmmStore addr src
141 | isFloatType ty -> assignMem_FltCode format addr src
142 | isWord64 ty -> assignMem_I64Code addr src
143 | otherwise -> assignMem_IntCode format addr src
144 where ty = cmmExprType dflags src
145 format = cmmTypeFormat ty
146
147 CmmUnsafeForeignCall target result_regs args
148 -> genCCall target result_regs args
149
150 CmmBranch id -> genBranch id
151 CmmCondBranch arg true false -> do b1 <- genCondJump true arg
152 b2 <- genBranch false
153 return (b1 `appOL` b2)
154 CmmSwitch arg ids -> do dflags <- getDynFlags
155 genSwitch dflags arg ids
156 CmmCall { cml_target = arg } -> genJump arg
157
158 _
159 -> panic "stmtToInstrs: statement should have been cps'd away"
160
161
162 {-
163 Now, given a tree (the argument to an CmmLoad) that references memory,
164 produce a suitable addressing mode.
165
166 A Rule of the Game (tm) for Amodes: use of the addr bit must
167 immediately follow use of the code part, since the code part puts
168 values in registers which the addr then refers to. So you can't put
169 anything in between, lest it overwrite some of those registers. If
170 you need to do some other computation between the code part and use of
171 the addr bit, first store the effective address from the amode in a
172 temporary, then do the other computation, and then use the temporary:
173
174 code
175 LEA amode, tmp
176 ... other computation ...
177 ... (tmp) ...
178 -}
179
180
181
182 -- | Convert a BlockId to some CmmStatic data
183 jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
184 jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
185 jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
186 where blockLabel = mkAsmTempLabel (getUnique blockid)
187
188
189
190 -- -----------------------------------------------------------------------------
191 -- Generating assignments
192
193 -- Assignments are really at the heart of the whole code generation
194 -- business. Almost all top-level nodes of any real importance are
195 -- assignments, which correspond to loads, stores, or register
196 -- transfers. If we're really lucky, some of the register transfers
197 -- will go away, because we can use the destination register to
198 -- complete the code generation for the right hand side. This only
199 -- fails when the right hand side is forced into a fixed register
200 -- (e.g. the result of a call).
201
202 assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
203 assignMem_IntCode pk addr src = do
204 (srcReg, code) <- getSomeReg src
205 Amode dstAddr addr_code <- getAmode addr
206 return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
207
208
209 assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
210 assignReg_IntCode _ reg src = do
211 dflags <- getDynFlags
212 r <- getRegister src
213 let dst = getRegisterReg (targetPlatform dflags) reg
214 return $ case r of
215 Any _ code -> code dst
216 Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
217
218
219
220 -- Floating point assignment to memory
221 assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
222 assignMem_FltCode pk addr src = do
223 dflags <- getDynFlags
224 Amode dst__2 code1 <- getAmode addr
225 (src__2, code2) <- getSomeReg src
226 tmp1 <- getNewRegNat pk
227 let
228 pk__2 = cmmExprType dflags src
229 code__2 = code1 `appOL` code2 `appOL`
230 if formatToWidth pk == typeWidth pk__2
231 then unitOL (ST pk src__2 dst__2)
232 else toOL [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1
233 , ST pk tmp1 dst__2]
234 return code__2
235
236 -- Floating point assignment to a register/temporary
237 assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
238 assignReg_FltCode pk dstCmmReg srcCmmExpr = do
239 dflags <- getDynFlags
240 let platform = targetPlatform dflags
241 srcRegister <- getRegister srcCmmExpr
242 let dstReg = getRegisterReg platform dstCmmReg
243
244 return $ case srcRegister of
245 Any _ code -> code dstReg
246 Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
247
248
249
250
251 genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
252
253 genJump (CmmLit (CmmLabel lbl))
254 = return (toOL [CALL (Left target) 0 True, NOP])
255 where
256 target = ImmCLbl lbl
257
258 genJump tree
259 = do
260 (target, code) <- getSomeReg tree
261 return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
262
263 -- -----------------------------------------------------------------------------
264 -- Unconditional branches
265
266 genBranch :: BlockId -> NatM InstrBlock
267 genBranch = return . toOL . mkJumpInstr
268
269
270 -- -----------------------------------------------------------------------------
271 -- Conditional jumps
272
273 {-
274 Conditional jumps are always to local labels, so we can use branch
275 instructions. We peek at the arguments to decide what kind of
276 comparison to do.
277
278 SPARC: First, we have to ensure that the condition codes are set
279 according to the supplied comparison operation. We generate slightly
280 different code for floating point comparisons, because a floating
281 point operation cannot directly precede a @BF@. We assume the worst
282 and fill that slot with a @NOP@.
283
284 SPARC: Do not fill the delay slots here; you will confuse the register
285 allocator.
286 -}
287
288
289 genCondJump
290 :: BlockId -- the branch target
291 -> CmmExpr -- the condition on which to branch
292 -> NatM InstrBlock
293
294
295
296 genCondJump bid bool = do
297 CondCode is_float cond code <- getCondCode bool
298 return (
299 code `appOL`
300 toOL (
301 if is_float
302 then [NOP, BF cond False bid, NOP]
303 else [BI cond False bid, NOP]
304 )
305 )
306
307
308
309 -- -----------------------------------------------------------------------------
310 -- Generating a table-branch
311
312 genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
313 genSwitch dflags expr targets
314 | gopt Opt_PIC dflags
315 = error "MachCodeGen: sparc genSwitch PIC not finished\n"
316
317 | otherwise
318 = do (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset)
319
320 base_reg <- getNewRegNat II32
321 offset_reg <- getNewRegNat II32
322 dst <- getNewRegNat II32
323
324 label <- getNewLabelNat
325
326 return $ e_code `appOL`
327 toOL
328 [ -- load base of jump table
329 SETHI (HI (ImmCLbl label)) base_reg
330 , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
331
332 -- the addrs in the table are 32 bits wide..
333 , SLL e_reg (RIImm $ ImmInt 2) offset_reg
334
335 -- load and jump to the destination
336 , LD II32 (AddrRegReg base_reg offset_reg) dst
337 , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
338 , NOP ]
339 where (offset, ids) = switchTargetsToTable targets
340
341 generateJumpTableForInstr :: DynFlags -> Instr
342 -> Maybe (NatCmmDecl CmmStatics Instr)
343 generateJumpTableForInstr dflags (JMP_TBL _ ids label) =
344 let jumpTable = map (jumpTableEntry dflags) ids
345 in Just (CmmData ReadOnlyData (Statics label jumpTable))
346 generateJumpTableForInstr _ _ = Nothing
347
348
349
350 -- -----------------------------------------------------------------------------
351 -- Generating C calls
352
353 {-
354 Now the biggest nightmare---calls. Most of the nastiness is buried in
355 @get_arg@, which moves the arguments to the correct registers/stack
356 locations. Apart from that, the code is easy.
357
358 The SPARC calling convention is an absolute
359 nightmare. The first 6x32 bits of arguments are mapped into
360 %o0 through %o5, and the remaining arguments are dumped to the
361 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
362
363 If we have to put args on the stack, move %o6==%sp down by
364 the number of words to go on the stack, to ensure there's enough space.
365
366 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
367 16 words above the stack pointer is a word for the address of
368 a structure return value. I use this as a temporary location
369 for moving values from float to int regs. Certainly it isn't
370 safe to put anything in the 16 words starting at %sp, since
371 this area can get trashed at any time due to window overflows
372 caused by signal handlers.
373
374 A final complication (if the above isn't enough) is that
375 we can't blithely calculate the arguments one by one into
376 %o0 .. %o5. Consider the following nested calls:
377
378 fff a (fff b c)
379
380 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
381 the inner call will itself use %o0, which trashes the value put there
382 in preparation for the outer call. Upshot: we need to calculate the
383 args into temporary regs, and move those to arg regs or onto the
384 stack only immediately prior to the call proper. Sigh.
385 -}
386
387 genCCall
388 :: ForeignTarget -- function to call
389 -> [CmmFormal] -- where to put the result
390 -> [CmmActual] -- arguments (of mixed type)
391 -> NatM InstrBlock
392
393
394
395 -- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream
396 -- are guaranteed to take place before writes afterwards (unlike on PowerPC).
397 -- Ref: Section 8.4 of the SPARC V9 Architecture manual.
398 --
399 -- In the SPARC case we don't need a barrier.
400 --
401 genCCall (PrimTarget MO_WriteBarrier) _ _
402 = return $ nilOL
403
404 genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
405 = return $ nilOL
406
407 genCCall target dest_regs args
408 = do -- work out the arguments, and assign them to integer regs
409 argcode_and_vregs <- mapM arg_to_int_vregs args
410 let (argcodes, vregss) = unzip argcode_and_vregs
411 let vregs = concat vregss
412
413 let n_argRegs = length allArgRegs
414 let n_argRegs_used = min (length vregs) n_argRegs
415
416
417 -- deal with static vs dynamic call targets
418 callinsns <- case target of
419 ForeignTarget (CmmLit (CmmLabel lbl)) _ ->
420 return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
421
422 ForeignTarget expr _
423 -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
424 return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
425
426 PrimTarget mop
427 -> do res <- outOfLineMachOp mop
428 lblOrMopExpr <- case res of
429 Left lbl -> do
430 return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
431
432 Right mopExpr -> do
433 (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
434 return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
435
436 return lblOrMopExpr
437
438 let argcode = concatOL argcodes
439
440 let (move_sp_down, move_sp_up)
441 = let diff = length vregs - n_argRegs
442 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
443 in if nn <= 0
444 then (nilOL, nilOL)
445 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
446
447 let transfer_code
448 = toOL (move_final vregs allArgRegs extraStackArgsHere)
449
450 dflags <- getDynFlags
451 return
452 $ argcode `appOL`
453 move_sp_down `appOL`
454 transfer_code `appOL`
455 callinsns `appOL`
456 unitOL NOP `appOL`
457 move_sp_up `appOL`
458 assign_code (targetPlatform dflags) dest_regs
459
460
461 -- | Generate code to calculate an argument, and move it into one
462 -- or two integer vregs.
463 arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
464 arg_to_int_vregs arg = do dflags <- getDynFlags
465 arg_to_int_vregs' dflags arg
466
467 arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg])
468 arg_to_int_vregs' dflags arg
469
470 -- If the expr produces a 64 bit int, then we can just use iselExpr64
471 | isWord64 (cmmExprType dflags arg)
472 = do (ChildCode64 code r_lo) <- iselExpr64 arg
473 let r_hi = getHiVRegFromLo r_lo
474 return (code, [r_hi, r_lo])
475
476 | otherwise
477 = do (src, code) <- getSomeReg arg
478 let pk = cmmExprType dflags arg
479
480 case cmmTypeFormat pk of
481
482 -- Load a 64 bit float return value into two integer regs.
483 FF64 -> do
484 v1 <- getNewRegNat II32
485 v2 <- getNewRegNat II32
486
487 let code2 =
488 code `snocOL`
489 FMOV FF64 src f0 `snocOL`
490 ST FF32 f0 (spRel 16) `snocOL`
491 LD II32 (spRel 16) v1 `snocOL`
492 ST FF32 f1 (spRel 16) `snocOL`
493 LD II32 (spRel 16) v2
494
495 return (code2, [v1,v2])
496
497 -- Load a 32 bit float return value into an integer reg
498 FF32 -> do
499 v1 <- getNewRegNat II32
500
501 let code2 =
502 code `snocOL`
503 ST FF32 src (spRel 16) `snocOL`
504 LD II32 (spRel 16) v1
505
506 return (code2, [v1])
507
508 -- Move an integer return value into its destination reg.
509 _ -> do
510 v1 <- getNewRegNat II32
511
512 let code2 =
513 code `snocOL`
514 OR False g0 (RIReg src) v1
515
516 return (code2, [v1])
517
518
519 -- | Move args from the integer vregs into which they have been
520 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
521 --
522 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
523
524 -- all args done
525 move_final [] _ _
526 = []
527
528 -- out of aregs; move to stack
529 move_final (v:vs) [] offset
530 = ST II32 v (spRel offset)
531 : move_final vs [] (offset+1)
532
533 -- move into an arg (%o[0..5]) reg
534 move_final (v:vs) (a:az) offset
535 = OR False g0 (RIReg v) a
536 : move_final vs az offset
537
538
539 -- | Assign results returned from the call into their
540 -- destination regs.
541 --
542 assign_code :: Platform -> [LocalReg] -> OrdList Instr
543
544 assign_code _ [] = nilOL
545
546 assign_code platform [dest]
547 = let rep = localRegType dest
548 width = typeWidth rep
549 r_dest = getRegisterReg platform (CmmLocal dest)
550
551 result
552 | isFloatType rep
553 , W32 <- width
554 = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest
555
556 | isFloatType rep
557 , W64 <- width
558 = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest
559
560 | not $ isFloatType rep
561 , W32 <- width
562 = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest
563
564 | not $ isFloatType rep
565 , W64 <- width
566 , r_dest_hi <- getHiVRegFromLo r_dest
567 = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi
568 , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest]
569
570 | otherwise
571 = panic "SPARC.CodeGen.GenCCall: no match"
572
573 in result
574
575 assign_code _ _
576 = panic "SPARC.CodeGen.GenCCall: no match"
577
578
579
580 -- | Generate a call to implement an out-of-line floating point operation
581 outOfLineMachOp
582 :: CallishMachOp
583 -> NatM (Either CLabel CmmExpr)
584
585 outOfLineMachOp mop
586 = do let functionName
587 = outOfLineMachOp_table mop
588
589 dflags <- getDynFlags
590 mopExpr <- cmmMakeDynamicReference dflags CallReference
591 $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction
592
593 let mopLabelOrExpr
594 = case mopExpr of
595 CmmLit (CmmLabel lbl) -> Left lbl
596 _ -> Right mopExpr
597
598 return mopLabelOrExpr
599
600
601 -- | Decide what C function to use to implement a CallishMachOp
602 --
603 outOfLineMachOp_table
604 :: CallishMachOp
605 -> FastString
606
607 outOfLineMachOp_table mop
608 = case mop of
609 MO_F32_Exp -> fsLit "expf"
610 MO_F32_Log -> fsLit "logf"
611 MO_F32_Sqrt -> fsLit "sqrtf"
612 MO_F32_Pwr -> fsLit "powf"
613
614 MO_F32_Sin -> fsLit "sinf"
615 MO_F32_Cos -> fsLit "cosf"
616 MO_F32_Tan -> fsLit "tanf"
617
618 MO_F32_Asin -> fsLit "asinf"
619 MO_F32_Acos -> fsLit "acosf"
620 MO_F32_Atan -> fsLit "atanf"
621
622 MO_F32_Sinh -> fsLit "sinhf"
623 MO_F32_Cosh -> fsLit "coshf"
624 MO_F32_Tanh -> fsLit "tanhf"
625
626 MO_F64_Exp -> fsLit "exp"
627 MO_F64_Log -> fsLit "log"
628 MO_F64_Sqrt -> fsLit "sqrt"
629 MO_F64_Pwr -> fsLit "pow"
630
631 MO_F64_Sin -> fsLit "sin"
632 MO_F64_Cos -> fsLit "cos"
633 MO_F64_Tan -> fsLit "tan"
634
635 MO_F64_Asin -> fsLit "asin"
636 MO_F64_Acos -> fsLit "acos"
637 MO_F64_Atan -> fsLit "atan"
638
639 MO_F64_Sinh -> fsLit "sinh"
640 MO_F64_Cosh -> fsLit "cosh"
641 MO_F64_Tanh -> fsLit "tanh"
642
643 MO_UF_Conv w -> fsLit $ word2FloatLabel w
644
645 MO_Memcpy _ -> fsLit "memcpy"
646 MO_Memset _ -> fsLit "memset"
647 MO_Memmove _ -> fsLit "memmove"
648
649 MO_BSwap w -> fsLit $ bSwapLabel w
650 MO_PopCnt w -> fsLit $ popCntLabel w
651 MO_Clz w -> fsLit $ clzLabel w
652 MO_Ctz w -> fsLit $ ctzLabel w
653 MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
654 MO_Cmpxchg w -> fsLit $ cmpxchgLabel w
655 MO_AtomicRead w -> fsLit $ atomicReadLabel w
656 MO_AtomicWrite w -> fsLit $ atomicWriteLabel w
657
658 MO_S_QuotRem {} -> unsupported
659 MO_U_QuotRem {} -> unsupported
660 MO_U_QuotRem2 {} -> unsupported
661 MO_Add2 {} -> unsupported
662 MO_AddIntC {} -> unsupported
663 MO_SubIntC {} -> unsupported
664 MO_U_Mul2 {} -> unsupported
665 MO_WriteBarrier -> unsupported
666 MO_Touch -> unsupported
667 (MO_Prefetch_Data _) -> unsupported
668 where unsupported = panic ("outOfLineCmmOp: " ++ show mop
669 ++ " not supported here")
670