CodeGen.hs 100 KB
Newer Older
1
{-# LANGUAGE CPP, GADTs #-}
2 3 4 5 6 7 8 9 10 11

-----------------------------------------------------------------------------
--
-- Generating machine code (instruction selection)
--
-- (c) The University of Glasgow 1996-2004
--
-----------------------------------------------------------------------------

-- This is a big module, but, if you pay attention to
12 13
-- (a) the sectioning, and (b) the type signatures,
-- the structure should not be too overwhelming.
14

Sylvain Henry's avatar
Sylvain Henry committed
15
module GHC.CmmToAsm.PPC.CodeGen (
16 17 18 19
        cmmTopCodeGen,
        generateJumpTableForInstr,
        InstrBlock
)
20 21 22 23 24 25

where

#include "HsVersions.h"

-- NCG stuff:
26
import GHC.Prelude
27

28
import GHC.Platform.Regs
Sylvain Henry's avatar
Sylvain Henry committed
29 30 31 32
import GHC.CmmToAsm.PPC.Instr
import GHC.CmmToAsm.PPC.Cond
import GHC.CmmToAsm.PPC.Regs
import GHC.CmmToAsm.CPrim
33 34
import GHC.Cmm.DebugBlock
   ( DebugBlock(..) )
Sylvain Henry's avatar
Sylvain Henry committed
35 36 37
import GHC.CmmToAsm.Monad
   ( NatM, getNewRegNat, getNewLabelNat
   , getBlockIdNat, getPicBaseNat, getNewRegPairNat
38
   , getPicBaseMaybeNat, getPlatform, getConfig
39
   , getDebugBlock, getFileId
Sylvain Henry's avatar
Sylvain Henry committed
40 41 42 43
   )
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Format
44
import GHC.CmmToAsm.Config
Sylvain Henry's avatar
Sylvain Henry committed
45 46 47
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.CmmToAsm.Reg.Target
John Ericson's avatar
John Ericson committed
48
import GHC.Platform
49 50

-- Our intermediate code:
51 52 53 54 55 56 57 58
import GHC.Cmm.BlockId
import GHC.Cmm.Ppr           ( pprExpr )
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
59 60
import GHC.Core              ( Tickish(..) )
import GHC.Types.SrcLoc      ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
61 62

-- The rest:
63 64
import GHC.Data.OrdList
import GHC.Utils.Outputable
65
import GHC.Utils.Panic
66

67
import Control.Monad    ( mapAndUnzipM, when )
68 69 70
import Data.Bits
import Data.Word

Sylvain Henry's avatar
Sylvain Henry committed
71
import GHC.Types.Basic
72 73
import GHC.Data.FastString
import GHC.Utils.Misc
74

75 76 77 78 79 80 81 82
-- -----------------------------------------------------------------------------
-- Top-level of the instruction selector

-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
-- They are really trees of insns to facilitate fast appending, where a
-- left-to-right traversal (pre-order?) yields the insns in the correct
-- order.

83
cmmTopCodeGen
Simon Peyton Jones's avatar
Simon Peyton Jones committed
84
        :: RawCmmDecl
85
        -> NatM [NatCmmDecl RawCmmStatics Instr]
86

87 88
cmmTopCodeGen (CmmProc info lab live graph) = do
  let blocks = toBlockListEntryFirst graph
89
  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
90
  platform <- getPlatform
91
  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
92
      tops = proc : concat statics
93 94
      os   = platformOS platform
      arch = platformArch platform
95
  case arch of
96 97
    ArchPPC | os == OSAIX -> return tops
            | otherwise -> do
98 99 100 101
      picBaseMb <- getPicBaseMaybeNat
      case picBaseMb of
           Just picBase -> initializePicBase_ppc arch os picBase tops
           Nothing -> return tops
102
    ArchPPC_64 ELF_V1 -> fixup_entry tops
103 104
                      -- generating function descriptor is handled in
                      -- pretty printer
105
    ArchPPC_64 ELF_V2 -> fixup_entry tops
106 107 108
                      -- generating function prologue is handled in
                      -- pretty printer
    _          -> panic "PPC.cmmTopCodeGen: unknown arch"
109 110 111 112 113 114 115 116 117 118
    where
      fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
        = do
        let BasicBlock bID insns = entry
        bID' <- if lab == (blockLbl bID)
                then newBlockId
                else return bID
        let b' = BasicBlock bID' insns
        return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
      fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc"
119

Ian Lynagh's avatar
Ian Lynagh committed
120
cmmTopCodeGen (CmmData sec dat) = do
121 122
  return [CmmData sec dat]  -- no translation, we just use CmmStatic

123
basicBlockCodeGen
124
        :: Block CmmNode C C
125
        -> NatM ( [NatBasicBlock Instr]
126
                , [NatCmmDecl RawCmmStatics Instr])
127

128
basicBlockCodeGen block = do
Peter Wortmann's avatar
Peter Wortmann committed
129 130
  let (_, nodes, tail)  = blockSplit block
      id = entryLabel block
131
      stmts = blockToList nodes
132 133 134 135 136 137 138 139
  -- Generate location directive
  dbg <- getDebugBlock (entryLabel block)
  loc_instrs <- case dblSourceTick =<< dbg of
    Just (SourceNote span name)
      -> do fileid <- getFileId (srcSpanFile span)
            let line = srcSpanStartLine span; col =srcSpanStartCol span
            return $ unitOL $ LOCATION fileid line col name
    _ -> return nilOL
140 141
  mid_instrs <- stmtsToInstrs stmts
  tail_instrs <- stmtToInstrs tail
142
  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
143 144 145 146 147
  -- code generation may introduce new basic block boundaries, which
  -- are indicated by the NEWBLOCK instruction.  We must split up the
  -- instruction stream into basic blocks again.  Also, we extract
  -- LDATAs here too.
  let
148 149 150 151 152 153 154 155
        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs

        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
          = ([], BasicBlock id instrs : blocks, statics)
        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
          = (instrs, blocks, CmmData sec dat:statics)
        mkBlocks instr (instrs,blocks,statics)
          = (instr:instrs, blocks, statics)
156 157
  return (BasicBlock id top : other_blocks, statics)

158
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
159 160 161 162
stmtsToInstrs stmts
   = do instrss <- mapM stmtToInstrs stmts
        return (concatOL instrss)

163
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
164
stmtToInstrs stmt = do
165
  config <- getConfig
166
  platform <- getPlatform
167
  case stmt of
168
    CmmComment s   -> return (unitOL (COMMENT s))
Peter Wortmann's avatar
Peter Wortmann committed
169
    CmmTick {}     -> return nilOL
Peter Wortmann's avatar
Peter Wortmann committed
170
    CmmUnwind {}   -> return nilOL
171 172

    CmmAssign reg src
173
      | isFloatType ty -> assignReg_FltCode format reg src
174
      | target32Bit platform &&
175
        isWord64 ty    -> assignReg_I64Code      reg src
176
      | otherwise      -> assignReg_IntCode format reg src
177
        where ty = cmmRegType platform reg
178
              format = cmmTypeFormat ty
179 180

    CmmStore addr src
181
      | isFloatType ty -> assignMem_FltCode format addr src
182
      | target32Bit platform &&
183 184
        isWord64 ty    -> assignMem_I64Code      addr src
      | otherwise      -> assignMem_IntCode format addr src
185
        where ty = cmmExprType platform src
186
              format = cmmTypeFormat ty
187

188
    CmmUnsafeForeignCall target result_regs args
189 190
       -> genCCall target result_regs args

191
    CmmBranch id          -> genBranch id
192 193
    CmmCondBranch arg true false prediction -> do
      b1 <- genCondJump true arg prediction
194 195
      b2 <- genBranch false
      return (b1 `appOL` b2)
196
    CmmSwitch arg ids -> genSwitch config arg ids
197
    CmmCall { cml_target = arg
198
            , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)
199 200
    _ ->
      panic "stmtToInstrs: statement should have been cps'd away"
201

202 203
jumpRegs :: Platform -> [GlobalReg] -> [Reg]
jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
204 205 206

--------------------------------------------------------------------------------
-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
207 208
--      They are really trees of insns to facilitate fast appending, where a
--      left-to-right traversal yields the insns in the correct order.
209
--
210 211
type InstrBlock
        = OrdList Instr
212 213 214


-- | Register's passed up the tree.  If the stix code forces the register
215 216 217
--      to live in a pre-decided machine register, it comes out as @Fixed@;
--      otherwise, it comes out as @Any@, and the parent can decide which
--      register to put it in.
218 219
--
data Register
220 221
        = Fixed Format Reg InstrBlock
        | Any   Format (Reg -> InstrBlock)
222 223


224 225 226
swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
swizzleRegisterRep (Any _ codefn)     format = Any   format codefn
227 228 229


-- | Grab the Reg for a CmmReg
230
getRegisterReg :: Platform -> CmmReg -> Reg
231

232
getRegisterReg _ (CmmLocal (LocalReg u pk))
233
  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
234

235 236
getRegisterReg platform (CmmGlobal mid)
  = case globalRegMaybe platform mid of
237
        Just reg -> RegReal reg
238 239 240 241
        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
        -- By this stage, the only MagicIds remaining should be the
        -- ones which map to a real machine register on this
        -- platform.  Hence ...
242 243

-- | Convert a BlockId to some CmmStatic data
244 245
jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry config Nothing   = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
246
jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
247
    where blockLabel = blockLbl blockid
248 249 250 251 252 253 254 255



-- -----------------------------------------------------------------------------
-- General things for putting together code sequences

-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
256 257
mangleIndexTree :: Platform -> CmmExpr -> CmmExpr
mangleIndexTree platform (CmmRegOff reg off)
258
  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
259
  where width = typeWidth (cmmRegType platform reg)
260

261
mangleIndexTree _ _
262
        = panic "PPC.CodeGen.mangleIndexTree: no match"
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279

-- -----------------------------------------------------------------------------
--  Code gen for 64-bit arithmetic on 32-bit platforms

{-
Simple support for generating 64-bit code (ie, 64 bit values and 64
bit assignments) on 32-bit platforms.  Unlike the main code generator
we merely shoot for generating working code as simply as possible, and
pay little attention to code quality.  Specifically, there is no
attempt to deal cleverly with the fixed-vs-floating register
distinction; all values are generated into (pairs of) floating
registers, even if this would mean some redundant reg-reg moves as a
result.  Only one of the VRegUniques is returned, since it will be
of the VRegUniqueLo form, and the upper-half VReg can be determined
by applying getHiVRegFromLo to it.
-}

280 281 282 283 284 285 286 287
data ChildCode64        -- a.k.a "Register64"
      = ChildCode64
           InstrBlock   -- code
           Reg          -- the lower 32-bit temporary which contains the
                        -- result; use getHiVRegFromLo to find the other
                        -- VRegUnique.  Rules of this simplified insn
                        -- selection game are therefore that the returned
                        -- Reg may be modified
288 289


290
-- | Compute an expression into a register, but
291
--      we don't mind which one it is.
292 293 294 295 296
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg expr = do
  r <- getRegister expr
  case r of
    Any rep code -> do
297 298 299 300
        tmp <- getNewRegNat rep
        return (tmp, code tmp)
    Fixed _ reg code ->
        return (reg, code)
301 302 303

getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes addrTree = do
304
    Amode hi_addr addr_code <- getAmode D addrTree
305 306 307 308 309 310 311 312 313 314 315
    case addrOffset hi_addr 4 of
        Just lo_addr -> return (hi_addr, lo_addr, addr_code)
        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree
                           return (AddrRegImm hi_ptr (ImmInt 0),
                                   AddrRegImm hi_ptr (ImmInt 4),
                                   code)


assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code addrTree valueTree = do
        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
316 317 318
        ChildCode64 vcode rlo <- iselExpr64 valueTree
        let
                rhi = getHiVRegFromLo rlo
319

320 321 322 323
                -- Big-endian store
                mov_hi = ST II32 rhi hi_addr
                mov_lo = ST II32 rlo lo_addr
        return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
324 325 326


assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
327
assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
328
   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
329
   let
330
         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
331 332 333 334 335 336 337 338
         r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = MR r_dst_lo r_src_lo
         mov_hi = MR r_dst_hi r_src_hi
   return (
        vcode `snocOL` mov_lo `snocOL` mov_hi
     )

339
assignReg_I64Code _ _
340 341 342 343 344 345 346 347 348
   = panic "assignReg_I64Code(powerpc): invalid lvalue"


iselExpr64        :: CmmExpr -> NatM ChildCode64
iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
    (rlo, rhi) <- getNewRegPairNat II32
    let mov_hi = LD II32 rhi hi_addr
        mov_lo = LD II32 rlo lo_addr
349
    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
350 351 352
                         rlo

iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
353
   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
354 355 356 357

iselExpr64 (CmmLit (CmmInt i _)) = do
  (rlo,rhi) <- getNewRegPairNat II32
  let
358
        half0 = fromIntegral (fromIntegral i :: Word16)
359 360 361
        half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
        half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
        half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
362 363 364 365 366

        code = toOL [
                LIS rlo (ImmInt half1),
                OR rlo rlo (RIImm $ ImmInt half0),
                LIS rhi (ImmInt half3),
367
                OR rhi rhi (RIImm $ ImmInt half2)
368
                ]
369 370 371 372 373 374 375
  return (ChildCode64 code rlo)

iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
   ChildCode64 code1 r1lo <- iselExpr64 e1
   ChildCode64 code2 r2lo <- iselExpr64 e2
   (rlo,rhi) <- getNewRegPairNat II32
   let
376 377 378 379 380 381
        r1hi = getHiVRegFromLo r1lo
        r2hi = getHiVRegFromLo r2lo
        code =  code1 `appOL`
                code2 `appOL`
                toOL [ ADDC rlo r1lo r2lo,
                       ADDE rhi r1hi r2hi ]
382 383
   return (ChildCode64 code rlo)

384 385 386 387 388 389 390 391 392
iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
   ChildCode64 code1 r1lo <- iselExpr64 e1
   ChildCode64 code2 r2lo <- iselExpr64 e2
   (rlo,rhi) <- getNewRegPairNat II32
   let
        r1hi = getHiVRegFromLo r1lo
        r2hi = getHiVRegFromLo r2lo
        code =  code1 `appOL`
                code2 `appOL`
393
                toOL [ SUBFC rlo r2lo (RIReg r1lo),
394 395 396
                       SUBFE rhi r2hi r1hi ]
   return (ChildCode64 code rlo)

397 398 399 400 401 402 403
iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
    (expr_reg,expr_code) <- getSomeReg expr
    (rlo, rhi) <- getNewRegPairNat II32
    let mov_hi = LI rhi (ImmInt 0)
        mov_lo = MR rlo expr_reg
    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
                         rlo
404 405 406 407 408 409 410 411

iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
    (expr_reg,expr_code) <- getSomeReg expr
    (rlo, rhi) <- getNewRegPairNat II32
    let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))
        mov_lo = MR rlo expr_reg
    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
                         rlo
412
iselExpr64 expr
413 414 415
   = do
     platform <- getPlatform
     pprPanic "iselExpr64(powerpc)" (pprExpr platform expr)
416 417 418 419



getRegister :: CmmExpr -> NatM Register
420 421
getRegister e = do config <- getConfig
                   getRegister' config (ncgPlatform config) e
422

423
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
424

425 426
getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))
  | OSAIX <- platformOS platform = do
427 428 429
        let code dst = toOL [ LD II32 dst tocAddr ]
            tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
        return (Any II32 code)
430 431 432
  | target32Bit platform = do
      reg <- getPicBaseNat $ archWordFormat (target32Bit platform)
      return (Fixed (archWordFormat (target32Bit platform))
433 434
                    reg nilOL)
  | otherwise = return (Fixed II64 toc nilOL)
pho@cielonegro.org's avatar
pho@cielonegro.org committed
435

436 437 438
getRegister' _ platform (CmmReg reg)
  = return (Fixed (cmmTypeFormat (cmmRegType platform reg))
                  (getRegisterReg platform reg) nilOL)
439

440 441
getRegister' config platform tree@(CmmRegOff _ _)
  = getRegister' config platform (mangleIndexTree platform tree)
442

443
    -- for 32-bit architectures, support some 64 -> 32 bit conversions:
444 445
    -- TO_W_(x), TO_W_(x >> 32)

446
getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32)
447
                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
448
 | target32Bit platform = do
449 450 451
  ChildCode64 code rlo <- iselExpr64 x
  return $ Fixed II32 (getHiVRegFromLo rlo) code

452
getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32)
453
                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
454
 | target32Bit platform = do
455 456 457
  ChildCode64 code rlo <- iselExpr64 x
  return $ Fixed II32 (getHiVRegFromLo rlo) code

458 459
getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x])
 | target32Bit platform = do
460 461 462
  ChildCode64 code rlo <- iselExpr64 x
  return $ Fixed II32 rlo code

463 464
getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])
 | target32Bit platform = do
465
  ChildCode64 code rlo <- iselExpr64 x
466
  return $ Fixed II32 rlo code
467

468
getRegister' _ platform (CmmLoad mem pk)
469 470
 | not (isWord64 pk) = do
        Amode addr addr_code <- getAmode D mem
471
        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
472 473
                       addr_code `snocOL` LD format dst addr
        return (Any format code)
474
 | not (target32Bit platform) = do
475 476 477 478
        Amode addr addr_code <- getAmode DS mem
        let code dst = addr_code `snocOL` LD II64 dst addr
        return (Any II64 code)

479
          where format = cmmTypeFormat pk
480 481

-- catch simple cases of zero- or sign-extended load
482
getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
483
    Amode addr addr_code <- getAmode D mem
484 485
    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))

486
getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do
487 488 489
    Amode addr addr_code <- getAmode D mem
    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))

490
getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do
491 492 493
    Amode addr addr_code <- getAmode D mem
    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))

494
getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do
495 496 497
    Amode addr addr_code <- getAmode D mem
    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))

498 499
-- Note: there is no Load Byte Arithmetic instruction, so no signed case here

500
getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
501
    Amode addr addr_code <- getAmode D mem
502 503
    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))

504
getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
505
    Amode addr addr_code <- getAmode D mem
506 507
    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))

508
getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do
509 510 511
    Amode addr addr_code <- getAmode D mem
    return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))

512
getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do
513 514 515
    Amode addr addr_code <- getAmode D mem
    return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))

516
getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do
517 518 519
    Amode addr addr_code <- getAmode D mem
    return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))

520
getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do
521 522
    -- lwa is DS-form. See Note [Power instruction format]
    Amode addr addr_code <- getAmode DS mem
523 524
    return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))

525
getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps
526 527 528 529 530 531 532 533 534 535 536 537 538
  = case mop of
      MO_Not rep   -> triv_ucode_int rep NOT

      MO_F_Neg w   -> triv_ucode_float w FNEG
      MO_S_Neg w   -> triv_ucode_int   w NEG

      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x
      MO_FF_Conv W32 W64 -> conversionNop FF64 x

      MO_FS_Conv from to -> coerceFP2Int from to x
      MO_SF_Conv from to -> coerceInt2FP from to x

      MO_SS_Conv from to
539 540
        | from >= to -> conversionNop (intFormat to) x
        | otherwise  -> triv_ucode_int to (EXTS (intFormat from))
541 542

      MO_UU_Conv from to
543 544 545 546 547
        | from >= to -> conversionNop (intFormat to) x
        | otherwise  -> clearLeft from to

      MO_XX_Conv _ to -> conversionNop (intFormat to) x

548
      _ -> panic "PPC.CodeGen.getRegister: no match"
549 550

    where
551 552
        triv_ucode_int   width instr = trivialUCode (intFormat    width) instr x
        triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x
553

554
        conversionNop new_format expr
555
            = do e_code <- getRegister' config platform expr
556
                 return (swizzleRegisterRep e_code new_format)
557

558 559
        clearLeft from to
            = do (src1, code1) <- getSomeReg x
560 561
                 let arch_fmt  = intFormat (wordWidth platform)
                     arch_bits = widthInBits (wordWidth platform)
562 563 564 565 566
                     size      = widthInBits from
                     code dst  = code1 `snocOL`
                                 CLRLI arch_fmt dst src1 (arch_bits - size)
                 return (Any (intFormat to) code)

567
getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
568
  = case mop of
569 570 571 572 573 574
      MO_F_Eq _ -> condFltReg EQQ x y
      MO_F_Ne _ -> condFltReg NE  x y
      MO_F_Gt _ -> condFltReg GTT x y
      MO_F_Ge _ -> condFltReg GE  x y
      MO_F_Lt _ -> condFltReg LTT x y
      MO_F_Le _ -> condFltReg LE  x y
575

576 577 578 579 580 581 582 583 584 585 586 587
      MO_Eq rep -> condIntReg EQQ rep x y
      MO_Ne rep -> condIntReg NE  rep x y

      MO_S_Gt rep -> condIntReg GTT rep x y
      MO_S_Ge rep -> condIntReg GE  rep x y
      MO_S_Lt rep -> condIntReg LTT rep x y
      MO_S_Le rep -> condIntReg LE  rep x y

      MO_U_Gt rep -> condIntReg GU  rep x y
      MO_U_Ge rep -> condIntReg GEU rep x y
      MO_U_Lt rep -> condIntReg LU  rep x y
      MO_U_Le rep -> condIntReg LEU rep x y
588 589 590 591 592

      MO_F_Add w  -> triv_float w FADD
      MO_F_Sub w  -> triv_float w FSUB
      MO_F_Mul w  -> triv_float w FMUL
      MO_F_Quot w -> triv_float w FDIV
593

594 595 596 597
         -- optimize addition with 32-bit immediate
         -- (needed for PIC)
      MO_Add W32 ->
        case y of
598
          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm
599 600 601 602 603 604 605 606 607 608 609 610 611 612
            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
          CmmLit lit
            -> do
                (src, srcCode) <- getSomeReg x
                let imm = litToImm lit
                    code dst = srcCode `appOL` toOL [
                                    ADDIS dst src (HA imm),
                                    ADD dst dst (RIImm (LO imm))
                                ]
                return (Any II32 code)
          _ -> trivialCode W32 True ADD x y

      MO_Add rep -> trivialCode rep True ADD x y
      MO_Sub rep ->
613
        case y of
614 615
          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
616 617 618
          _ -> case x of
                 CmmLit (CmmInt imm _)
                   | Just _ <- makeImmediate rep True imm
Brian Wignall's avatar
Brian Wignall committed
619
                   -- subfi ('subtract from' with immediate) doesn't exist
620 621 622 623 624 625 626 627 628 629 630 631 632 633
                   -> trivialCode rep True SUBFC y x
                 _ -> trivialCodeNoImm' (intFormat rep) SUBF y x

      MO_Mul rep -> shiftMulCode rep True MULL x y
      MO_S_MulMayOflo rep -> do
        (src1, code1) <- getSomeReg x
        (src2, code2) <- getSomeReg y
        let
          format = intFormat rep
          code dst = code1 `appOL` code2
                       `appOL` toOL [ MULLO format dst src1 src2
                                    , MFOV  format dst
                                    ]
        return (Any format code)
634

635 636
      MO_S_Quot rep -> divCode rep True x y
      MO_U_Quot rep -> divCode rep False x y
637

638 639
      MO_S_Rem rep -> remainder rep True x y
      MO_U_Rem rep -> remainder rep False x y
640

641 642 643 644 645 646 647 648 649 650
      MO_And rep   -> case y of
        (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4
            -> do
                (src, srcCode) <- getSomeReg x
                let clear_mask = if imm == -4 then 2 else 3
                    fmt = intFormat rep
                    code dst = srcCode
                               `appOL` unitOL (CLRRI fmt dst src clear_mask)
                return (Any fmt code)
        _ -> trivialCode rep False AND x y
651 652 653
      MO_Or rep    -> trivialCode rep False OR x y
      MO_Xor rep   -> trivialCode rep False XOR x y

654
      MO_Shl rep   -> shiftMulCode rep False SL x y
655 656
      MO_S_Shr rep -> srCode rep True SRA x y
      MO_U_Shr rep -> srCode rep False SR x y
657
      _         -> panic "PPC.CodeGen.getRegister: no match"
658 659

  where
660 661
    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
    triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y
662

663 664 665 666 667 668 669 670
    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
    remainder rep sgn x y = do
      let fmt = intFormat rep
      tmp <- getNewRegNat fmt
      code <- remainderCode rep sgn tmp x y
      return (Any fmt code)


671
getRegister' _ _ (CmmLit (CmmInt i rep))
672 673
  | Just imm <- makeImmediate rep True i
  = let
674
        code dst = unitOL (LI dst imm)
675
    in
676
        return (Any (intFormat rep) code)
677

678
getRegister' config _ (CmmLit (CmmFloat f frep)) = do
679
    lbl <- getNewLabelNat
680
    dynRef <- cmmMakeDynamicReference config DataReference lbl
681
    Amode addr addr_code <- getAmode D dynRef
682
    let format = floatFormat frep
683
        code dst =
684
            LDATA (Section ReadOnlyData lbl)
Sylvain Henry's avatar
Sylvain Henry committed
685
                  (CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f frep)])
686 687
            `consOL` (addr_code `snocOL` LD format dst addr)
    return (Any format code)
688

689
getRegister' config platform (CmmLit lit)
690 691
  | target32Bit platform
  = let rep = cmmLitType platform lit
692 693 694 695 696
        imm = litToImm lit
        code dst = toOL [
              LIS dst (HA imm),
              ADD dst dst (RIImm (LO imm))
          ]
697
    in return (Any (cmmTypeFormat rep) code)
698 699
  | otherwise
  = do lbl <- getNewLabelNat
700
       dynRef <- cmmMakeDynamicReference config DataReference lbl
701
       Amode addr addr_code <- getAmode D dynRef
702
       let rep = cmmLitType platform lit
703
           format = cmmTypeFormat rep
704
           code dst =
Sylvain Henry's avatar
Sylvain Henry committed
705
            LDATA (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmStaticLit lit])
706 707
            `consOL` (addr_code `snocOL` LD format dst addr)
       return (Any format code)
708

709
getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other)
710

711 712 713 714 715 716 717
    -- extend?Rep: wrap integer expression of type `from`
    -- in a conversion to `to`
extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x]

extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x]
718 719 720 721

-- -----------------------------------------------------------------------------
--  The 'Amode' type: Memory addressing modes passed up the tree.

722 723
data Amode
        = Amode AddrMode InstrBlock
724 725

{-
Gabor Greif's avatar
Gabor Greif committed
726
Now, given a tree (the argument to a CmmLoad) that references memory,
727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742
produce a suitable addressing mode.

A Rule of the Game (tm) for Amodes: use of the addr bit must
immediately follow use of the code part, since the code part puts
values in registers which the addr then refers to.  So you can't put
anything in between, lest it overwrite some of those registers.  If
you need to do some other computation between the code part and use of
the addr bit, first store the effective address from the amode in a
temporary, then do the other computation, and then use the temporary:

    code
    LEA amode, tmp
    ... other computation ...
    ... (tmp) ...
-}

743 744
{- Note [Power instruction format]
In some instructions the 16 bit offset must be a multiple of 4, i.e.
Gabor Greif's avatar
Gabor Greif committed
745
the two least significant bits must be zero. The "Power ISA" specification
746 747 748 749 750
calls these instruction formats "DS-FORM" and the instructions with
arbitrary 16 bit offsets are "D-FORM".

The Power ISA specification document can be obtained from www.power.org.
-}
751
data InstrForm = D | DS
752

753 754
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode inf tree@(CmmRegOff _ _)
755 756
  = do platform <- getPlatform
       getAmode inf (mangleIndexTree platform tree)
757 758

getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
759 760 761 762 763 764
  | Just off <- makeImmediate W32 True (-i)
  = do
        (reg, code) <- getSomeReg x
        return (Amode (AddrRegImm reg off) code)


765
getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
766 767 768 769 770
  | Just off <- makeImmediate W32 True i
  = do
        (reg, code) <- getSomeReg x
        return (Amode (AddrRegImm reg off) code)

771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
  | Just off <- makeImmediate W64 True (-i)
  = do
        (reg, code) <- getSomeReg x
        return (Amode (AddrRegImm reg off) code)


getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
  | Just off <- makeImmediate W64 True i
  = do
        (reg, code) <- getSomeReg x
        return (Amode (AddrRegImm reg off) code)

getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
  | Just off <- makeImmediate W64 True (-i)
  = do
        (reg, code) <- getSomeReg x
        (reg', off', code')  <-
                     if i `mod` 4 == 0
                      then do return (reg, off, code)
                      else do
                           tmp <- getNewRegNat II64
                           return (tmp, ImmInt 0,
                                  code `snocOL` ADD tmp reg (RIImm off))
        return (Amode (AddrRegImm reg' off') code')

getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
  | Just off <- makeImmediate W64 True i
  = do
        (reg, code) <- getSomeReg x
        (reg', off', code')  <-
                     if i `mod` 4 == 0
                      then do return (reg, off, code)
                      else do
                           tmp <- getNewRegNat II64
                           return (tmp, ImmInt 0,
                                  code `snocOL` ADD tmp reg (RIImm off))
        return (Amode (AddrRegImm reg' off') code')

810 811
   -- optimize addition with 32-bit immediate
   -- (needed for PIC)
812
getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])
813
  = do
814
        platform <- getPlatform
815 816
        (src, srcCode) <- getSomeReg x
        let imm = litToImm lit
817
        case () of
818
            _ | OSAIX <- platformOS platform
819 820 821 822 823 824 825 826 827 828 829 830
              , isCmmLabelType lit ->
                    -- HA16/LO16 relocations on labels not supported on AIX
                    return (Amode (AddrRegImm src imm) srcCode)
              | otherwise -> do
                    tmp <- getNewRegNat II32
                    let code = srcCode `snocOL` ADDIS tmp src (HA imm)
                    return (Amode (AddrRegImm tmp (LO imm)) code)
  where
      isCmmLabelType (CmmLabel {})        = True
      isCmmLabelType (CmmLabelOff {})     = True
      isCmmLabelType (CmmLabelDiffOff {}) = True
      isCmmLabelType _                    = False
831

832
getAmode _ (CmmLit lit)
833
  = do
834 835
        platform <- getPlatform
        case platformArch platform of
836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857
             ArchPPC -> do
                 tmp <- getNewRegNat II32
                 let imm = litToImm lit
                     code = unitOL (LIS tmp (HA imm))
                 return (Amode (AddrRegImm tmp (LO imm)) code)
             _        -> do -- TODO: Load from TOC,
                            -- see getRegister' _ (CmmLit lit)
                 tmp <- getNewRegNat II64
                 let imm = litToImm lit
                     code =  toOL [
                          LIS tmp (HIGHESTA imm),
                          OR tmp tmp (RIImm (HIGHERA imm)),
                          SL  II64 tmp tmp (RIImm (ImmInt 32)),
                          ORIS tmp tmp (HA imm)
                          ]
                 return (Amode (AddrRegImm tmp (LO imm)) code)

getAmode _ (CmmMachOp (MO_Add W32) [x, y])
  = do
        (regX, codeX) <- getSomeReg x
        (regY, codeY) <- getSomeReg y
        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
858

859
getAmode _ (CmmMachOp (MO_Add W64) [x, y])
860 861 862 863
  = do
        (regX, codeX) <- getSomeReg x
        (regY, codeY) <- getSomeReg y
        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
864

865
getAmode _ other
866 867 868 869 870 871 872 873
  = do
        (reg, code) <- getSomeReg other
        let
            off  = ImmInt 0
        return (Amode (AddrRegImm reg off) code)


--  The 'CondCode' type:  Condition codes passed up the tree.
874 875
data CondCode
        = CondCode Bool Cond InstrBlock
876 877 878 879 880 881

-- Set up a condition code for a conditional branch.

getCondCode :: CmmExpr -> NatM CondCode

-- almost the same as everywhere else - but we need to
882
-- extend small integers to 32 bit or 64 bit first
883 884

getCondCode (CmmMachOp mop [x, y])
885 886
  = do
    case mop of
887 888 889 890 891 892 893 894 895 896 897 898 899 900
      MO_F_Eq W32 -> condFltCode EQQ x y
      MO_F_Ne W32 -> condFltCode NE  x y
      MO_F_Gt W32 -> condFltCode GTT x y
      MO_F_Ge W32 -> condFltCode GE  x y
      MO_F_Lt W32 -> condFltCode LTT x y
      MO_F_Le W32 -> condFltCode LE  x y

      MO_F_Eq W64 -> condFltCode EQQ x y
      MO_F_Ne W64 -> condFltCode NE  x y
      MO_F_Gt W64 -> condFltCode GTT x y
      MO_F_Ge W64 -> condFltCode GE  x y
      MO_F_Lt W64 -> condFltCode LTT x y
      MO_F_Le W64 -> condFltCode LE  x y

901 902 903 904 905 906 907 908 909 910 911 912
      MO_Eq rep -> condIntCode EQQ rep x y
      MO_Ne rep -> condIntCode NE  rep x y

      MO_S_Gt rep -> condIntCode GTT rep x y
      MO_S_Ge rep -> condIntCode GE  rep x y
      MO_S_Lt rep -> condIntCode LTT rep x y
      MO_S_Le rep -> condIntCode LE  rep x y

      MO_U_Gt rep -> condIntCode GU  rep x y
      MO_U_Ge rep -> condIntCode GEU rep x y
      MO_U_Lt rep -> condIntCode LU  rep x y
      MO_U_Le rep -> condIntCode LEU rep x y
913

914
      _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
915

916
getCondCode _ = panic "getCondCode(2)(powerpc)"
917 918 919 920 921


-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
-- passed back up the tree.

922
condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
923
condIntCode cond width x y = do
924 925
  platform <- getPlatform
  condIntCode' (target32Bit platform) cond width x y
926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961

condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode

-- simple code for 64-bit on 32-bit platforms
condIntCode' True cond W64 x y
  | condUnsigned cond
  = do
      ChildCode64 code_x x_lo <- iselExpr64 x
      ChildCode64 code_y y_lo <- iselExpr64 y
      let x_hi = getHiVRegFromLo x_lo
          y_hi = getHiVRegFromLo y_lo
      end_lbl <- getBlockIdNat
      let code = code_x `appOL` code_y `appOL` toOL
                 [ CMPL II32 x_hi (RIReg y_hi)
                 , BCC NE end_lbl Nothing
                 , CMPL II32 x_lo (RIReg y_lo)
                 , BCC ALWAYS end_lbl Nothing

                 , NEWBLOCK end_lbl
                 ]
      return (CondCode False cond code)
  | otherwise
  = do
      ChildCode64 code_x x_lo <- iselExpr64 x
      ChildCode64 code_y y_lo <- iselExpr64 y
      let x_hi = getHiVRegFromLo x_lo
          y_hi = getHiVRegFromLo y_lo
      end_lbl <- getBlockIdNat
      cmp_lo  <- getBlockIdNat
      let code = code_x `appOL` code_y `appOL` toOL
                 [ CMP II32 x_hi (RIReg y_hi)
                 , BCC NE end_lbl Nothing
                 , CMP II32 x_hi (RIImm (ImmInt 0))
                 , BCC LE cmp_lo Nothing
                 , CMPL II32 x_lo (RIReg y_lo)
                 , BCC ALWAYS end_lbl Nothing
962
                 , NEWBLOCK cmp_lo
963 964 965 966 967 968
                 , CMPL II32 y_lo (RIReg x_lo)
                 , BCC ALWAYS end_lbl Nothing

                 , NEWBLOCK end_lbl
                 ]
      return (CondCode False cond code)
969

970 971
-- optimize pointer tag checks. Operation andi. sets condition register
-- so cmpi ..., 0 is redundant.
972
condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)])
973 974 975 976 977 978 979 980
                 (CmmLit (CmmInt 0 _))
  | not $ condUnsigned cond,
    Just src2 <- makeImmediate rep False imm
  = do
      (src1, code) <- getSomeReg x
      let code' = code `snocOL` AND r0 src1 (RIImm src2)
      return (CondCode False cond code')

981
condIntCode' _ cond width x (CmmLit (CmmInt y rep))
982 983
  | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
  = do
984 985 986 987 988 989 990
      let op_len = max W32 width
      let extend = extendSExpr width op_len
      (src1, code) <- getSomeReg (extend x)
      let format = intFormat op_len
          code' = code `snocOL`
            (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)
      return (CondCode False cond code')
991

992
condIntCode' _ cond width x y = do
993 994 995 996 997 998 999 1000 1001 1002 1003
  let op_len = max W32 width
  let extend = if condUnsigned