CodeGen.hs 50.7 KB
Newer Older
1
{-# OPTIONS -fno-warn-type-defaults #-}
2 3 4 5 6 7 8 9 10 11 12 13 14
-- ----------------------------------------------------------------------------
-- | Handle conversion of CmmProc to LLVM code.
--

module LlvmCodeGen.CodeGen ( genLlvmProc ) where

#include "HsVersions.h"

import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Regs

import BlockId
15
import CgUtils ( activeStgRegs, callerSaves )
16
import CLabel
17 18
import OldCmm
import qualified OldPprCmm as PprCmm
19

20
import DynFlags
21 22 23 24
import FastString
import ForeignCall
import Outputable hiding ( panic, pprPanic )
import qualified Outputable
25
import Platform
26
import OrdList
27 28 29 30
import UniqSupply
import Unique
import Util

31
import Data.List ( partition )
32

33

34
type LlvmStatements = OrdList LlvmStatement
35

36
-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
37
-- | Top-level of the LLVM proc Code generator
38
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
39
genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
40 41 42 43
genLlvmProc env (CmmProc info lbl (ListGraph blocks)) = do
    (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
    let proc = CmmProc info lbl (ListGraph lmblocks)
    return (env', proc:lmdata)
44

45
genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
46 47 48 49 50 51 52 53

-- -----------------------------------------------------------------------------
-- * Block code generation
--

-- | Generate code for a list of blocks that make up a complete procedure.
basicBlocksCodeGen :: LlvmEnv
                   -> [CmmBasicBlock]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
54 55
                   -> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
                   -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
56 57 58
basicBlocksCodeGen env ([]) (blocks, tops)
  = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
       let allocs' = concat allocs
59
       let ((BasicBlock id fstmts):rblks) = blocks'
60
       let fblocks = (BasicBlock id $ funPrologue ++  allocs' ++ fstmts):rblks
61 62 63 64 65 66 67 68 69 70
       return (env, fblocks, tops)

basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
  = do (env', lb, lt) <- basicBlockCodeGen env block
       let lblocks = lblocks' ++ lb
       let ltops   = ltops' ++ lt
       basicBlocksCodeGen env' blocks (lblocks, ltops)


-- | Allocations need to be extracted so they can be moved to the entry
dterei's avatar
dterei committed
71
-- of a function to make sure they dominate all possible paths in the CFG.
72 73
dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
dominateAllocs (BasicBlock id stmts)
74 75 76 77
  = let (allocs, stmts') = partition isAlloc stmts
        isAlloc (Assignment _ (Alloca _ _)) = True
        isAlloc _other                      = False
    in (BasicBlock id stmts', allocs)
78 79 80 81 82


-- | Generate code for one block
basicBlockCodeGen ::  LlvmEnv
                  -> CmmBasicBlock
Simon Peyton Jones's avatar
Simon Peyton Jones committed
83
                  -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmDecl] )
84 85 86
basicBlockCodeGen env (BasicBlock id stmts)
  = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
       return (env', [BasicBlock id (fromOL instrs)], top)
87 88 89 90 91 92 93


-- -----------------------------------------------------------------------------
-- * CmmStmt code generation
--

-- A statement conversion return data.
dterei's avatar
dterei committed
94 95
--   * LlvmEnv: The new environment
--   * LlvmStatements: The compiled LLVM statements.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
96 97
--   * LlvmCmmDecl: Any global data needed.
type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl])
98 99 100


-- | Convert a list of CmmStmt's to LlvmStatement's
Simon Peyton Jones's avatar
Simon Peyton Jones committed
101
stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmDecl])
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
              -> UniqSM StmtData
stmtsToInstrs env [] (llvm, top)
  = return (env, llvm, top)

stmtsToInstrs env (stmt : stmts) (llvm, top)
   = do (env', instrs, tops) <- stmtToInstrs env stmt
        stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)


-- | Convert a CmmStmt to a list of LlvmStatement's
stmtToInstrs :: LlvmEnv -> CmmStmt
             -> UniqSM StmtData
stmtToInstrs env stmt = case stmt of

    CmmNop               -> return (env, nilOL, [])
    CmmComment _         -> return (env, nilOL, []) -- nuke comments

    CmmAssign reg src    -> genAssign env reg src
    CmmStore addr src    -> genStore env addr src

    CmmBranch id         -> genBranch env id
    CmmCondBranch arg id -> genCondBranch env arg id
    CmmSwitch arg ids    -> genSwitch env arg ids

    -- Foreign Call
127
    CmmCall target res args ret
128 129 130
        -> genCall env target res args ret

    -- Tail call
131
    CmmJump arg live     -> genJump env arg live
132 133 134

    -- CPS, only tail calls, no return's
    -- Actually, there are a few return statements that occur because of hand
dterei's avatar
dterei committed
135
    -- written Cmm code.
dterei's avatar
dterei committed
136
    CmmReturn
137 138 139
        -> return (env, unitOL $ Return Nothing, [])


140
-- | Memory barrier instruction for LLVM >= 3.0
141 142
barrier :: LlvmEnv -> UniqSM StmtData
barrier env = do
143
    let s = Fence False SyncSeqCst
144
    return (env, unitOL s, [])
145

146
-- | Memory barrier instruction for LLVM < 3.0
147 148
oldBarrier :: LlvmEnv -> UniqSM StmtData
oldBarrier env = do
149
    let fname = fsLit "llvm.memory.barrier"
dterei's avatar
dterei committed
150
    let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
151
                    FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
152 153
    let fty = LMFunction funSig

154
    let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
155 156 157 158 159 160 161 162 163 164 165 166
    let tops = case funLookup fname env of
                    Just _  -> []
                    Nothing -> [CmmData Data [([],[fty])]]

    let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
    let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
    let env' = funInsert fname fty env

    return (env', unitOL s1, tops)

    where
        lmTrue :: LlvmVar
167
        lmTrue  = mkIntLit i1 (-1)
168

169 170 171 172 173 174
-- | Foreign Calls
genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
              -> CmmReturnInfo -> UniqSM StmtData

-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
Ian Lynagh's avatar
Ian Lynagh committed
175
genCall env (CmmPrim MO_WriteBarrier _) _ _ _
176 177
 | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
    = return (env, nilOL, [])
178 179
 | getLlvmVer env > 29 = barrier env
 | otherwise           = oldBarrier env
180

dterei's avatar
dterei committed
181 182 183 184
-- Handle popcnt function specifically since GHC only really has i32 and i64
-- types and things like Word8 are backed by an i32 and just present a logical
-- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
-- is strict about types.
Ian Lynagh's avatar
Ian Lynagh committed
185
genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
dterei's avatar
dterei committed
186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
    let width = widthToLlvmInt w
        dstTy = cmmToLlvmType $ localRegType dst
        funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible
                          CC_Ccc width FixedArgs (tysToParams [width]) Nothing
        (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)

    (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, [])
    (env3, fptr, stmts3, top3)  <- getFunPtr env2 funTy t
    (argsV', stmts4)            <- castVars $ zip argsV [width]
    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
    ([retV'], stmts5)           <- castVars [(retV,dstTy)]
    let s2                       = Store retV' dstV

    let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL`
                s1 `appOL` stmts5 `snocOL` s2
    return (env3, stmts, top1 ++ top2 ++ top3)

203 204
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
Ian Lynagh's avatar
Ian Lynagh committed
205 206 207
genCall env t@(CmmPrim op _) [] args CmmMayReturn | op == MO_Memcpy ||
                                                    op == MO_Memset ||
                                                    op == MO_Memmove = do
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
    let (isVolTy, isVolVal) = if getLlvmVer env >= 28
                                 then ([i1], [mkIntLit i1 0]) else ([], [])
        argTy | op == MO_Memset = [i8Ptr, i8,    llvmWord, i32] ++ isVolTy
              | otherwise       = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing

    (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
    (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy t
    (argVars', stmts3)            <- castVars $ zip argVars argTy

    let arguments = argVars' ++ isVolVal
        call = Expr $ Call StdCall fptr arguments []
        stmts = stmts1 `appOL` stmts2 `appOL` stmts3
                `appOL` trashStmts `snocOL` call
    return (env2, stmts, top1 ++ top2)

Ian Lynagh's avatar
Ian Lynagh committed
225 226
genCall env (CmmPrim _ (Just mkStmts)) results args _
    = stmtsToInstrs env (mkStmts results args) (nilOL, [])
227

228 229 230
-- Handle all other foreign calls and prim ops.
genCall env target res args ret = do

dterei's avatar
dterei committed
231
    -- parameter types
dterei's avatar
dterei committed
232
    let arg_type (CmmHinted _ AddrHint) = i8Ptr
233 234 235 236 237
        -- cast pointers to i8*. Llvm equivalent of void*
        arg_type (CmmHinted expr _    ) = cmmToLlvmType $ cmmExprType expr

    -- ret type
    let ret_type ([]) = LMVoid
dterei's avatar
dterei committed
238 239
        ret_type ([CmmHinted _ AddrHint]) = i8Ptr
        ret_type ([CmmHinted reg _])      = cmmToLlvmType $ localRegType reg
240 241 242
        ret_type t = panic $ "genCall: Too many return values! Can only handle"
                        ++ " 0 or 1, given " ++ show (length t) ++ "."

dterei's avatar
dterei committed
243
    -- extract Cmm call convention
244 245
    let cconv = case target of
            CmmCallee _ conv -> conv
Ian Lynagh's avatar
Ian Lynagh committed
246
            CmmPrim   _ _    -> PrimCallConv
247

dterei's avatar
dterei committed
248
    -- translate to LLVM call convention
249
    let lmconv = case cconv of
250 251 252 253
            StdCallConv  -> case platformArch (getLlvmPlatform env) of
                            ArchX86    -> CC_X86_Stdcc
                            ArchX86_64 -> CC_X86_Stdcc
                            _          -> CC_Ccc
254
            CCallConv    -> CC_Ccc
255
            CApiConv     -> CC_Ccc
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
            PrimCallConv -> CC_Ccc
            CmmCallConv  -> panic "CmmCallConv not supported here!"

    {-
        Some of the possibilities here are a worry with the use of a custom
        calling convention for passing STG args. In practice the more
        dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.

        The native code generator only handles StdCall and CCallConv.
    -}

    -- call attributes
    let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
                | otherwise              = llvmStdFunAttrs

    -- fun type
    let ccTy  = StdCall -- tail calls should be done through CmmJump
    let retTy = ret_type res
274
    let argTy = tysToParams $ map arg_type args
275 276
    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                             lmconv retTy FixedArgs argTy llvmFunAlign
277 278


279 280
    (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
    (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy target
281 282 283 284 285

    let retStmt | ccTy == TailCall       = unitOL $ Return Nothing
                | ret == CmmNeverReturns = unitOL $ Unreachable
                | otherwise              = nilOL

286 287
    let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts

288 289 290 291
    -- make the actual call
    case retTy of
        LMVoid -> do
            let s1 = Expr $ Call ccTy fptr argVars fnAttrs
292
            let allStmts = stmts `snocOL` s1 `appOL` retStmt
293 294 295
            return (env2, allStmts, top1 ++ top2)

        _ -> do
296
            (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
297 298 299 300
            -- get the return register
            let ret_reg ([CmmHinted reg hint]) = (reg, hint)
                ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
                                ++ " 1, given " ++ show (length t) ++ "."
301 302
            let (creg, _) = ret_reg res
            let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
303
            let allStmts = stmts `snocOL` s1 `appOL` stmts3
304 305 306
            if retTy == pLower (getVarType vreg)
                then do
                    let s2 = Store v1 vreg
307 308
                    return (env3, allStmts `snocOL` s2 `appOL` retStmt,
                                top1 ++ top2 ++ top3)
309 310 311 312 313 314 315 316 317 318 319
                else do
                    let ty = pLower $ getVarType vreg
                    let op = case ty of
                            vt | isPointer vt -> LM_Bitcast
                               | isInt     vt -> LM_Ptrtoint
                               | otherwise    ->
                                   panic $ "genCall: CmmReg bad match for"
                                        ++ " returned type!"

                    (v2, s2) <- doExpr ty $ Cast op v1 ty
                    let s3 = Store v2 vreg
320 321
                    return (env3, allStmts `snocOL` s2 `snocOL` s3
                                `appOL` retStmt, top1 ++ top2 ++ top3)
322 323


324 325 326 327
-- | Create a function pointer from a target.
getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
          -> UniqSM ExprData
getFunPtr env funTy targ = case targ of
328
    CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
329 330 331 332 333 334 335 336 337 338 339 340 341 342

    CmmCallee expr _ -> do
        (env', v1, stmts, top) <- exprToVar env expr
        let fty = funTy $ fsLit "dynamic"
            cast = case getVarType v1 of
                ty | isPointer ty -> LM_Bitcast
                ty | isInt ty     -> LM_Inttoptr

                ty -> panic $ "genCall: Expr is of bad type for function"
                              ++ " call! (" ++ show (ty) ++ ")"

        (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
        return (env', v2, stmts `snocOL` s1, top)

Ian Lynagh's avatar
Ian Lynagh committed
343
    CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372

    where
        litCase name = do
            case funLookup name env of
                Just ty'@(LMFunction sig) -> do
                    -- Function in module in right form
                    let fun = LMGlobalVar name ty' (funcLinkage sig)
                                    Nothing Nothing False
                    return (env, fun, nilOL, [])

                Just ty' -> do
                    -- label in module but not function pointer, convert
                    let fty@(LMFunction sig) = funTy name
                        fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
                                    Nothing Nothing False
                    (v1, s1) <- doExpr (pLift fty)
                                    $ Cast LM_Bitcast fun (pLift fty)
                    return  (env, v1, unitOL s1, [])

                Nothing -> do
                    -- label not in module, create external reference
                    let fty@(LMFunction sig) = funTy name
                        fun = LMGlobalVar name fty (funcLinkage sig)
                                    Nothing Nothing False
                        top = [CmmData Data [([],[fty])]]
                        env' = funInsert name fty env
                    return (env', fun, nilOL, top)


373 374
-- | Conversion of call arguments.
arg_vars :: LlvmEnv
375
         -> [HintedCmmActual]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
376 377
         -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
         -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl])
378 379 380 381 382 383 384 385 386 387 388 389 390

arg_vars env [] (vars, stmts, tops)
  = return (env, vars, stmts, tops)

arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
  = do (env', v1, stmts', top') <- exprToVar env e
       let op = case getVarType v1 of
               ty | isPointer ty -> LM_Bitcast
               ty | isInt ty     -> LM_Inttoptr

               a  -> panic $ "genCall: Can't cast llvmType to i8*! ("
                           ++ show a ++ ")"

dterei's avatar
dterei committed
391
       (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
392 393
       arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
                               tops ++ top')
394 395 396 397 398

arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
  = do (env', v1, stmts', top') <- exprToVar env e
       arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')

399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430

-- | Cast a collection of LLVM variables to specific types.
castVars :: [(LlvmVar, LlvmType)]
         -> UniqSM ([LlvmVar], LlvmStatements)
castVars vars = do
                done <- mapM (uncurry castVar) vars
                let (vars', stmts) = unzip done
                return (vars', toOL stmts)

-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
castVar v t | getVarType v == t
            = return (v, Nop)

            | otherwise
            = let op = case (getVarType v, t) of
                      (LMInt n, LMInt m)
                          -> if n < m then LM_Sext else LM_Trunc
                      (vt, _) | isFloat vt && isFloat t
                          -> if llvmWidthInBits vt < llvmWidthInBits t
                                then LM_Fpext else LM_Fptrunc
                      (vt, _) | isInt vt && isFloat t       -> LM_Sitofp
                      (vt, _) | isFloat vt && isInt t       -> LM_Fptosi
                      (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr
                      (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint
                      (vt, _) | isPointer vt && isPointer t -> LM_Bitcast

                      (vt, _) -> panic $ "castVars: Can't cast this type ("
                                  ++ show vt ++ ") to (" ++ show t ++ ")"
              in doExpr t $ Cast op v t


431
-- | Decide what C function to use to implement a CallishMachOp
432 433
cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
cmmPrimOpFunctions env mop
434 435 436
 = case mop of
    MO_F32_Exp    -> fsLit "expf"
    MO_F32_Log    -> fsLit "logf"
437 438
    MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
    MO_F32_Pwr    -> fsLit "llvm.pow.f32"
439

440 441
    MO_F32_Sin    -> fsLit "llvm.sin.f32"
    MO_F32_Cos    -> fsLit "llvm.cos.f32"
442 443 444 445 446 447 448 449 450 451 452 453
    MO_F32_Tan    -> fsLit "tanf"

    MO_F32_Asin   -> fsLit "asinf"
    MO_F32_Acos   -> fsLit "acosf"
    MO_F32_Atan   -> fsLit "atanf"

    MO_F32_Sinh   -> fsLit "sinhf"
    MO_F32_Cosh   -> fsLit "coshf"
    MO_F32_Tanh   -> fsLit "tanhf"

    MO_F64_Exp    -> fsLit "exp"
    MO_F64_Log    -> fsLit "log"
454 455
    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
    MO_F64_Pwr    -> fsLit "llvm.pow.f64"
456

457 458
    MO_F64_Sin    -> fsLit "llvm.sin.f64"
    MO_F64_Cos    -> fsLit "llvm.cos.f64"
459 460 461 462 463 464 465 466 467 468
    MO_F64_Tan    -> fsLit "tan"

    MO_F64_Asin   -> fsLit "asin"
    MO_F64_Acos   -> fsLit "acos"
    MO_F64_Atan   -> fsLit "atan"

    MO_F64_Sinh   -> fsLit "sinh"
    MO_F64_Cosh   -> fsLit "cosh"
    MO_F64_Tanh   -> fsLit "tanh"

469 470 471 472
    MO_Memcpy     -> fsLit $ "llvm.memcpy."  ++ intrinTy1
    MO_Memmove    -> fsLit $ "llvm.memmove." ++ intrinTy1
    MO_Memset     -> fsLit $ "llvm.memset."  ++ intrinTy2

dterei's avatar
dterei committed
473 474
    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ show (widthToLlvmInt w)

475
    MO_S_QuotRem {} -> unsupported
476
    MO_U_QuotRem {} -> unsupported
Ian Lynagh's avatar
Ian Lynagh committed
477
    MO_Add2 {}      -> unsupported
Ian Lynagh's avatar
Ian Lynagh committed
478
    MO_U_Mul2 {}    -> unsupported
479 480
    MO_WriteBarrier -> unsupported
    MO_Touch        -> unsupported
481

482 483 484 485 486
    where
        intrinTy1 = (if getLlvmVer env >= 28
                       then "p0i8.p0i8." else "") ++ show llvmWord
        intrinTy2 = (if getLlvmVer env >= 28
                       then "p0i8." else "") ++ show llvmWord
487 488
        unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
                          ++ " not supported here")
489 490

-- | Tail function calls
491
genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData
492 493

-- Call to known function
494
genJump env (CmmLit (CmmLabel lbl)) live = do
495
    (env', vf, stmts, top) <- getHsFunc env lbl
496
    (stgRegs, stgStmts) <- funEpilogue env live
497 498 499 500 501 502
    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
    let s2  = Return Nothing
    return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)


-- Call to unknown function / address
503
genJump env expr live = do
504 505 506 507 508 509 510 511 512 513 514
    let fty = llvmFunTy
    (env', vf, stmts, top) <- exprToVar env expr

    let cast = case getVarType vf of
         ty | isPointer ty -> LM_Bitcast
         ty | isInt ty     -> LM_Inttoptr

         ty -> panic $ "genJump: Expr is of bad type for function call! ("
                     ++ show (ty) ++ ")"

    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
515
    (stgRegs, stgStmts) <- funEpilogue env live
516 517 518 519 520 521 522 523 524 525 526 527 528 529
    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
    let s3 = Return Nothing
    return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
            top)


-- | CmmAssign operation
--
-- We use stack allocated variables for CmmReg. The optimiser will replace
-- these with registers when possible.
genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
genAssign env reg val = do
    let (env1, vreg, stmts1, top1) = getCmmReg env reg
    (env2, vval, stmts2, top2) <- exprToVar env1 val
530 531 532 533 534 535 536 537 538 539 540 541 542
    let stmts = stmts1 `appOL` stmts2

    let ty = (pLower . getVarType) vreg
    case isPointer ty && getVarType vval == llvmWord of
         -- Some registers are pointer types, so need to cast value to pointer
         True -> do
             (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
             let s2 = Store v vreg
             return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)

         False -> do
             let s1 = Store vval vreg
             return (env2, stmts `snocOL` s1, top1 ++ top2)
543 544 545 546


-- | CmmStore operation
genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570

-- First we try to detect a few common cases and produce better code for
-- these then the default case. We are mostly trying to detect Cmm code
-- like I32[Sp + n] and use 'getelementptr' operations instead of the
-- generic case that uses casts and pointer arithmetic
genStore env addr@(CmmReg (CmmGlobal r)) val
    = genStore_fast env addr r 0 val

genStore env addr@(CmmRegOff (CmmGlobal r) n) val
    = genStore_fast env addr r n val

genStore env addr@(CmmMachOp (MO_Add _) [
                            (CmmReg (CmmGlobal r)),
                            (CmmLit (CmmInt n _))])
                val
    = genStore_fast env addr r (fromInteger n) val

genStore env addr@(CmmMachOp (MO_Sub _) [
                            (CmmReg (CmmGlobal r)),
                            (CmmLit (CmmInt n _))])
                val
    = genStore_fast env addr r (negate $ fromInteger n) val

-- generic case
dterei's avatar
dterei committed
571
genStore env addr val = genStore_slow env addr val [other]
572 573 574 575 576 577 578

-- | CmmStore operation
-- This is a special case for storing to a global register pointer
-- offset such as I32[Sp+8].
genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
              -> UniqSM StmtData
genStore_fast env addr r n val
579 580 581
  = let gr   = lmGlobalRegVar r
        meta = [getTBAA r]
        grt  = (pLower . getVarType) gr
582 583
        (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
    in case isPointer grt && rem == 0 of
584 585 586
            True -> do
                (env', vval,  stmts, top) <- exprToVar env val
                (gv,  s1) <- doExpr grt $ Load gr
587
                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
588 589 590 591
                -- We might need a different pointer type, so check
                case pLower grt == getVarType vval of
                     -- were fine
                     True  -> do
592
                         let s3 = MetaStmt meta $ Store vval ptr
593 594 595 596 597 598 599
                         return (env',  stmts `snocOL` s1 `snocOL` s2
                                 `snocOL` s3, top)

                     -- cast to pointer type needed
                     False -> do
                         let ty = (pLift . getVarType) vval
                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
600
                         let s4 = MetaStmt meta $ Store vval ptr'
601 602 603 604 605
                         return (env',  stmts `snocOL` s1 `snocOL` s2
                                 `snocOL` s3 `snocOL` s4, top)

            -- If its a bit type then we use the slow method since
            -- we can't avoid casting anyway.
606
            False -> genStore_slow env addr val meta
607 608 609 610


-- | CmmStore operation
-- Generic case. Uses casts and pointer arithmetic if needed.
611 612
genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData
genStore_slow env addr val meta = do
613 614
    (env1, vaddr, stmts1, top1) <- exprToVar env addr
    (env2, vval,  stmts2, top2) <- exprToVar env1 val
615 616

    let stmts = stmts1 `appOL` stmts2
617
    case getVarType vaddr of
618 619 620
        -- sometimes we need to cast an int to a pointer before storing
        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
621
            let s2 = MetaStmt meta $ Store v vaddr
622 623
            return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)

624
        LMPointer _ -> do
625
            let s1 = MetaStmt meta $ Store vval vaddr
626
            return (env2, stmts `snocOL` s1, top1 ++ top2)
627 628

        i@(LMInt _) | i == llvmWord -> do
629 630
            let vty = pLift $ getVarType vval
            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
631
            let s2 = MetaStmt meta $ Store vval vptr
632
            return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
633

634 635
        other ->
            pprPanic "genStore: ptr not right type!"
636
                    (PprCmm.pprExpr (getLlvmPlatform env) addr <+> text (
637 638 639
                        "Size of Ptr: " ++ show llvmPtrBits ++
                        ", Size of var: " ++ show (llvmWidthInBits other) ++
                        ", Var: " ++ show vaddr))
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666


-- | Unconditional branch
genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
genBranch env id =
    let label = blockIdToLlvm id
    in return (env, unitOL $ Branch label, [])


-- | Conditional branch
genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
genCondBranch env cond idT = do
    idF <- getUniqueUs
    let labelT = blockIdToLlvm idT
    let labelF = LMLocalVar idF LMLabel
    (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
    if getVarType vc == i1
        then do
            let s1 = BranchIf vc labelT labelF
            let s2 = MkLabel idF
            return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
        else
            panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"


-- | Switch branch
--
dterei's avatar
dterei committed
667
-- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
668 669 670 671 672 673
-- However, they may be defined one day, so we better document this behaviour.
genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
genSwitch env cond maybe_ids = do
    (env', vc, stmts, top) <- exprToVar env cond
    let ty = getVarType vc

674
    let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
675
    let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
676 677 678 679 680 681 682 683 684 685 686 687 688 689 690
    -- out of range is undefied, so lets just branch to first label
    let (_, defLbl) = head labels

    let s1 = Switch vc defLbl labels
    return $ (env', stmts `snocOL` s1, top)


-- -----------------------------------------------------------------------------
-- * CmmExpr code generation
--

-- | An expression conversion return data:
--   * LlvmEnv: The new enviornment
--   * LlvmVar: The var holding the result of the expression
--   * LlvmStatements: Any statements needed to evaluate the expression
Simon Peyton Jones's avatar
Simon Peyton Jones committed
691 692
--   * LlvmCmmDecl: Any global data needed for this expression
type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl])
693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722

-- | Values which can be passed to 'exprToVar' to configure its
-- behaviour in certain circumstances.
data EOption = EOption {
        -- | The expected LlvmType for the returned variable.
        --
        -- Currently just used for determining if a comparison should return
        -- a boolean (i1) or a int (i32/i64).
        eoExpectedType :: Maybe LlvmType
  }

i1Option :: EOption
i1Option = EOption (Just i1)

wordOption :: EOption
wordOption = EOption (Just llvmWord)


-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
-- expression being stored in the returned LlvmVar.
exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
exprToVar env = exprToVarOpt env wordOption

exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
exprToVarOpt env opt e = case e of

    CmmLit lit
        -> genLit env lit

    CmmLoad e' ty
723
        -> genLoad env e' ty
724 725 726 727 728 729

    -- Cmmreg in expression is the value, so must load. If you want actual
    -- reg pointer, call getCmmReg directly.
    CmmReg r -> do
        let (env', vreg, stmts, top) = getCmmReg env r
        (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
730 731 732 733 734 735 736
        case (isPointer . getVarType) v1 of
             True  -> do
                 -- Cmm wants the value, so pointer types must be cast to ints
                 (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
                 return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)

             False -> return (env', v1, stmts `snocOL` s1, top)
737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754

    CmmMachOp op exprs
        -> genMachOp env opt op exprs

    CmmRegOff r i
        -> exprToVar env $ expandCmmReg (r, i)

    CmmStackSlot _ _
        -> panic "exprToVar: CmmStackSlot not supported!"


-- | Handle CmmMachOp expressions
genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData

-- Unary Machop
genMachOp env _ op [x] = case op of

    MO_Not w ->
755
        let all1 = mkIntLit (widthToLlvmInt w) (-1)
756 757 758
        in negate (widthToLlvmInt w) all1 LM_MO_Xor

    MO_S_Neg w ->
759
        let all0 = mkIntLit (widthToLlvmInt w) 0
760 761 762
        in negate (widthToLlvmInt w) all0 LM_MO_Sub

    MO_F_Neg w ->
763
        let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
764
        in negate (widthToLlvmFloat w) all0 LM_MO_FSub
765 766 767 768 769 770 771 772 773 774 775 776 777

    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi

    MO_SS_Conv from to
        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext

    MO_UU_Conv from to
        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext

    MO_FF_Conv from to
        -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext

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 810 811 812 813 814 815 816 817
    -- Handle unsupported cases explicitly so we get a warning
    -- of missing case when new MachOps added
    MO_Add _          -> panicOp
    MO_Mul _          -> panicOp
    MO_Sub _          -> panicOp
    MO_S_MulMayOflo _ -> panicOp
    MO_S_Quot _       -> panicOp
    MO_S_Rem _        -> panicOp
    MO_U_MulMayOflo _ -> panicOp
    MO_U_Quot _       -> panicOp
    MO_U_Rem _        -> panicOp

    MO_Eq  _          -> panicOp
    MO_Ne  _          -> panicOp
    MO_S_Ge _         -> panicOp
    MO_S_Gt _         -> panicOp
    MO_S_Le _         -> panicOp
    MO_S_Lt _         -> panicOp
    MO_U_Ge _         -> panicOp
    MO_U_Gt _         -> panicOp
    MO_U_Le _         -> panicOp
    MO_U_Lt _         -> panicOp

    MO_F_Add        _ -> panicOp
    MO_F_Sub        _ -> panicOp
    MO_F_Mul        _ -> panicOp
    MO_F_Quot       _ -> panicOp
    MO_F_Eq         _ -> panicOp
    MO_F_Ne         _ -> panicOp
    MO_F_Ge         _ -> panicOp
    MO_F_Gt         _ -> panicOp
    MO_F_Le         _ -> panicOp
    MO_F_Lt         _ -> panicOp

    MO_And          _ -> panicOp
    MO_Or           _ -> panicOp
    MO_Xor          _ -> panicOp
    MO_Shl          _ -> panicOp
    MO_U_Shr        _ -> panicOp
    MO_S_Shr        _ -> panicOp
818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836

    where
        negate ty v2 negOp = do
            (env', vx, stmts, top) <- exprToVar env x
            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
            return (env', v1, stmts `snocOL` s1, top)

        fiConv ty convOp = do
            (env', vx, stmts, top) <- exprToVar env x
            (v1, s1) <- doExpr ty $ Cast convOp vx ty
            return (env', v1, stmts `snocOL` s1, top)

        sameConv from ty reduce expand = do
            x'@(env', vx, stmts, top) <- exprToVar env x
            let sameConv' op = do
                (v1, s1) <- doExpr ty $ Cast op vx ty
                return (env', v1, stmts `snocOL` s1, top)
            let toWidth = llvmWidthInBits ty
            -- LLVM doesn't like trying to convert to same width, so
dterei's avatar
dterei committed
837
            -- need to check for that as we do get Cmm code doing it.
838 839 840 841
            case widthInBits from  of
                 w | w < toWidth -> sameConv' expand
                 w | w > toWidth -> sameConv' reduce
                 _w              -> return x'
842 843 844
        
        panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encourntered"
                       ++ "with one argument! (" ++ show op ++ ")"
845

dterei's avatar
dterei committed
846
-- Handle GlobalRegs pointers
847 848 849 850 851 852
genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
    = genMachOp_fast env opt o r (fromInteger n) e

genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
    = genMachOp_fast env opt o r (negate . fromInteger $ n) e

dterei's avatar
dterei committed
853
-- Generic case
854 855 856 857 858 859 860 861 862
genMachOp env opt op e = genMachOp_slow env opt op e


-- | Handle CmmMachOp expressions
-- This is a specialised method that handles Global register manipulations like
-- 'Sp - 16', using the getelementptr instruction.
genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
               -> UniqSM ExprData
genMachOp_fast env opt op r n e
863 864
  = let gr   = lmGlobalRegVar r
        grt  = (pLower . getVarType) gr
865 866 867 868
        (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
    in case isPointer grt && rem == 0 of
            True -> do
                (gv,  s1) <- doExpr grt $ Load gr
869
                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
870 871 872 873 874 875 876 877 878
                (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
                return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])

            False -> genMachOp_slow env opt op e


-- | Handle CmmMachOp expressions
-- This handles all the cases not handle by the specialised genMachOp_fast.
genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
879 880

-- Binary MachOp
881
genMachOp_slow env opt op [x, y] = case op of
882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916

    MO_Eq _   -> genBinComp opt LM_CMP_Eq
    MO_Ne _   -> genBinComp opt LM_CMP_Ne

    MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
    MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
    MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
    MO_S_Le _ -> genBinComp opt LM_CMP_Sle

    MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
    MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
    MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
    MO_U_Le _ -> genBinComp opt LM_CMP_Ule

    MO_Add _ -> genBinMach LM_MO_Add
    MO_Sub _ -> genBinMach LM_MO_Sub
    MO_Mul _ -> genBinMach LM_MO_Mul

    MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"

    MO_S_MulMayOflo w -> isSMulOK w x y

    MO_S_Quot _ -> genBinMach LM_MO_SDiv
    MO_S_Rem  _ -> genBinMach LM_MO_SRem

    MO_U_Quot _ -> genBinMach LM_MO_UDiv
    MO_U_Rem  _ -> genBinMach LM_MO_URem

    MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
    MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
    MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
    MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
    MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
    MO_F_Le _ -> genBinComp opt LM_CMP_Fle

917 918 919
    MO_F_Add  _ -> genBinMach LM_MO_FAdd
    MO_F_Sub  _ -> genBinMach LM_MO_FSub
    MO_F_Mul  _ -> genBinMach LM_MO_FMul
920 921 922 923 924 925 926 927 928
    MO_F_Quot _ -> genBinMach LM_MO_FDiv

    MO_And _   -> genBinMach LM_MO_And
    MO_Or  _   -> genBinMach LM_MO_Or
    MO_Xor _   -> genBinMach LM_MO_Xor
    MO_Shl _   -> genBinMach LM_MO_Shl
    MO_U_Shr _ -> genBinMach LM_MO_LShr
    MO_S_Shr _ -> genBinMach LM_MO_AShr

929 930 931 932 933 934 935 936 937
    MO_Not _       -> panicOp
    MO_S_Neg _     -> panicOp
    MO_F_Neg _     -> panicOp

    MO_SF_Conv _ _ -> panicOp
    MO_FS_Conv _ _ -> panicOp
    MO_SS_Conv _ _ -> panicOp
    MO_UU_Conv _ _ -> panicOp
    MO_FF_Conv _ _ -> panicOp
938 939 940 941 942 943 944 945 946 947 948 949

    where
        binLlvmOp ty binOp = do
            (env1, vx, stmts1, top1) <- exprToVar env x
            (env2, vy, stmts2, top2) <- exprToVar env1 y
            if getVarType vx == getVarType vy
                then do
                    (v1, s1) <- doExpr (ty vx) $ binOp vx vy
                    return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
                            top1 ++ top2)

                else do
950
                    -- Error. Continue anyway so we can debug the generated ll file.
951
                    let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr (getLlvmPlatform env))
952 953 954 955 956 957 958 959
                    let dx = Comment $ map fsLit $ cmmToStr x
                    let dy = Comment $ map fsLit $ cmmToStr y
                    (v1, s1) <- doExpr (ty vx) $ binOp vx vy
                    let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
                                    `snocOL` dy `snocOL` s1
                    return (env2, v1, allStmts, top1 ++ top2)

        -- | Need to use EOption here as Cmm expects word size results from
dterei's avatar
dterei committed
960
        -- comparisons while LLVM return i1. Need to extend to llvmWord type
961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998
        -- if expected
        genBinComp opt cmp = do
            ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp

            if getVarType v1 == i1
                then
                    case eoExpectedType opt of
                         Nothing ->
                             return ed

                         Just t | t == i1 ->
                                    return ed

                                | isInt t -> do
                                    (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
                                    return (env', v2, stmts `snocOL` s1, top)

                                | otherwise ->
                                    panic $ "genBinComp: Can't case i1 compare"
                                        ++ "res to non int type " ++ show (t)
                else
                    panic $ "genBinComp: Compare returned type other then i1! "
                        ++ (show $ getVarType v1)

        genBinMach op = binLlvmOp getVarType (LlvmOp op)

        -- | Detect if overflow will occur in signed multiply of the two
        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
        -- implementation. Its much longer due to type information/safety.
        -- This should actually compile to only about 3 asm instructions.
        isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
        isSMulOK _ x y = do
            (env1, vx, stmts1, top1) <- exprToVar env x
            (env2, vy, stmts2, top2) <- exprToVar env1 y

            let word  = getVarType vx
            let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
            let shift = llvmWidthInBits word
999 1000
            let shift1 = toIWord (shift - 1)
            let shift2 = toIWord shift
1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019

            if isInt word
                then do
                    (x1, s1)     <- doExpr word2 $ Cast LM_Sext vx word2
                    (y1, s2)     <- doExpr word2 $ Cast LM_Sext vy word2
                    (r1, s3)     <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
                    (rlow1, s4)  <- doExpr word $ Cast LM_Trunc r1 word
                    (rlow2, s5)  <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
                    (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
                    (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
                    (dst, s8)    <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
                    let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
                            `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
                    return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
                        top1 ++ top2)

                else
                    panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"

1020 1021 1022
        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encourntered"
                       ++ "with two arguments! (" ++ show op ++ ")"

1023
-- More then two expression, invalid!
1024
genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
1025 1026


1027
-- | Handle CmmLoad expression.
1028
genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
1029 1030 1031 1032 1033

-- First we try to detect a few common cases and produce better code for
-- these then the default case. We are mostly trying to detect Cmm code
-- like I32[Sp + n] and use 'getelementptr' operations instead of the
-- generic case that uses casts and pointer arithmetic
1034 1035
genLoad env e@(CmmReg (CmmGlobal r)) ty
    = genLoad_fast env e r 0 ty
1036

1037 1038
genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
    = genLoad_fast env e r n ty
1039

1040
genLoad env e@(CmmMachOp (MO_Add _) [
1041 1042 1043
                            (CmmReg (CmmGlobal r)),
                            (CmmLit (CmmInt n _))])
                ty
1044
    = genLoad_fast env e r (fromInteger n) ty
1045

1046
genLoad env e@(CmmMachOp (MO_Sub _) [
1047 1048 1049
                            (CmmReg (CmmGlobal r)),
                            (CmmLit (CmmInt n _))])
                ty
1050
    = genLoad_fast env e r (negate $ fromInteger n) ty
1051 1052

-- generic case
dterei's avatar
dterei committed
1053
genLoad env e ty = genLoad_slow env e ty [other]
1054 1055 1056 1057

-- | Handle CmmLoad expression.
-- This is a special case for loading from a global register pointer
-- offset such as I32[Sp+8].
1058
genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
1059
                -> UniqSM ExprData
1060
genLoad_fast env e r n ty =
1061 1062 1063 1064
    let gr   = lmGlobalRegVar r
        meta = [getTBAA r]
        grt  = (pLower . getVarType) gr
        ty'  = cmmToLlvmType ty
1065 1066
        (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
    in case isPointer grt && rem == 0 of
1067 1068
            True  -> do
                (gv,  s1) <- doExpr grt $ Load gr
1069
                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1070 1071 1072 1073
                -- We might need a different pointer type, so check
                case grt == ty' of
                     -- were fine
                     True -> do
1074
                         (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr)
1075 1076 1077 1078 1079 1080 1081
                         return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
                                     [])

                     -- cast to pointer type needed
                     False -> do
                         let pty = pLift ty'
                         (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
1082
                         (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr')
1083 1084 1085 1086 1087
                         return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
                                    `snocOL` s4, [])

            -- If its a bit type then we use the slow method since
            -- we can't avoid casting anyway.
1088
            False -> genLoad_slow env e ty meta
1089 1090 1091 1092


-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
1093 1094
genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData
genLoad_slow env e ty meta = do
1095
    (env', iptr, stmts, tops) <- exprToVar env e
1096 1097
    case getVarType iptr of
         LMPointer _ -> do
1098 1099
                    (dvar, load) <- doExpr (cmmToLlvmType ty)
                                           (MetaExpr meta $ Load iptr)
1100 1101 1102
                    return (env', dvar, stmts `snocOL` load, tops)

         i@(LMInt _) | i == llvmWord -> do