CodeGen.hs 60.1 KB
Newer Older
1
{-# OPTIONS -fno-warn-type-defaults #-}
2 3 4 5
-- ----------------------------------------------------------------------------
-- | Handle conversion of CmmProc to LLVM code.
--

6
{-# LANGUAGE GADTs #-}
7 8 9 10 11 12 13 14 15
module LlvmCodeGen.CodeGen ( genLlvmProc ) where

#include "HsVersions.h"

import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Regs

import BlockId
Simon Marlow's avatar
Simon Marlow committed
16
import CodeGen.Platform ( activeStgRegs, callerSaves )
17
import CLabel
18 19 20 21
import Cmm
import PprCmm
import CmmUtils
import Hoopl
22

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

Peter Wortmann's avatar
Peter Wortmann committed
33 34
import Data.List ( nub )
import Data.Maybe ( catMaybes )
35

36
type LlvmStatements = OrdList LlvmStatement
37

38
-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
39
-- | Top-level of the LLVM proc Code generator
40
--
Peter Wortmann's avatar
Peter Wortmann committed
41 42
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc (CmmProc infos lbl live graph) = do
43
    let blocks = toBlockListEntryFirstFalseFallthrough graph
Peter Wortmann's avatar
Peter Wortmann committed
44
    (lmblocks, lmdata) <- basicBlocksCodeGen live blocks
45
    let info = mapLookup (g_entry graph) infos
46
        proc = CmmProc info lbl live (ListGraph lmblocks)
Peter Wortmann's avatar
Peter Wortmann committed
47
    return (proc:lmdata)
48

Peter Wortmann's avatar
Peter Wortmann committed
49
genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
50 51 52 53 54

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

Peter Wortmann's avatar
Peter Wortmann committed
55 56 57 58 59 60 61 62
-- | Generate code for a list of blocks that make up a complete
-- procedure. The first block in the list is exepected to be the entry
-- point and will get the prologue.
basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
basicBlocksCodeGen _    []                     = panic "no entry block!"
basicBlocksCodeGen live (entryBlock:cmmBlocks)
  = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)
63

Peter Wortmann's avatar
Peter Wortmann committed
64 65 66
       -- Generate code
       (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock
       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
67

Peter Wortmann's avatar
Peter Wortmann committed
68 69 70
       -- Compose
       let entryBlock = BasicBlock bid (fromOL prologue ++ entry)
       return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)
71 72 73


-- | Generate code for one block
Peter Wortmann's avatar
Peter Wortmann committed
74 75
basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
basicBlockCodeGen block
76
  = do let (CmmEntry id, nodes, tail)  = blockSplit block
Peter Wortmann's avatar
Peter Wortmann committed
77 78
       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
       (tail_instrs, top')  <- stmtToInstrs tail
79
       let instrs = fromOL (mid_instrs `appOL` tail_instrs)
Peter Wortmann's avatar
Peter Wortmann committed
80
       return (BasicBlock id instrs, top' ++ top)
81 82

-- -----------------------------------------------------------------------------
83
-- * CmmNode code generation
84 85 86
--

-- A statement conversion return data.
dterei's avatar
dterei committed
87
--   * LlvmStatements: The compiled LLVM statements.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
88
--   * LlvmCmmDecl: Any global data needed.
Peter Wortmann's avatar
Peter Wortmann committed
89
type StmtData = (LlvmStatements, [LlvmCmmDecl])
90 91


92
-- | Convert a list of CmmNode's to LlvmStatement's
Peter Wortmann's avatar
Peter Wortmann committed
93 94 95 96
stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
stmtsToInstrs stmts
   = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
        return (concatOL instrss, concat topss)
97 98


Peter Wortmann's avatar
Peter Wortmann committed
99 100 101
-- | Convert a CmmStmt to a list of LlvmStatement's
stmtToInstrs :: CmmNode e x -> LlvmM StmtData
stmtToInstrs stmt = case stmt of
102

Peter Wortmann's avatar
Peter Wortmann committed
103
    CmmComment _         -> return (nilOL, []) -- nuke comments
104

Peter Wortmann's avatar
Peter Wortmann committed
105 106
    CmmAssign reg src    -> genAssign reg src
    CmmStore addr src    -> genStore addr src
107

Peter Wortmann's avatar
Peter Wortmann committed
108 109 110 111
    CmmBranch id         -> genBranch id
    CmmCondBranch arg true false
                         -> genCondBranch arg true false
    CmmSwitch arg ids    -> genSwitch arg ids
112 113

    -- Foreign Call
Peter Wortmann's avatar
Peter Wortmann committed
114 115
    CmmUnsafeForeignCall target res args
        -> genCall target res args
116 117

    -- Tail call
118
    CmmCall { cml_target = arg,
Peter Wortmann's avatar
Peter Wortmann committed
119
              cml_args_regs = live } -> genJump arg live
120

121
    _ -> panic "Llvm.CodeGen.stmtToInstrs"
122

Peter Wortmann's avatar
Peter Wortmann committed
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
-- | Wrapper function to declare an instrinct function by function type
getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
getInstrinct2 fname fty@(LMFunction funSig) = do

    let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant

    fn <- funLookup fname
    tops <- case fn of
      Just _  ->
        return []
      Nothing -> do
        funInsert fname fty
        return [CmmData Data [([],[fty])]]

    return (fv, nilOL, tops)

getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"

-- | Declares an instrinct function by return and parameter types
getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
getInstrinct fname retTy parTys =
    let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy
                    FixedArgs (tysToParams parTys) Nothing
        fty = LMFunction funSig
    in getInstrinct2 fname fty

149
-- | Memory barrier instruction for LLVM >= 3.0
Peter Wortmann's avatar
Peter Wortmann committed
150 151
barrier :: LlvmM StmtData
barrier = do
152
    let s = Fence False SyncSeqCst
Peter Wortmann's avatar
Peter Wortmann committed
153
    return (unitOL s, [])
154

155
-- | Memory barrier instruction for LLVM < 3.0
Peter Wortmann's avatar
Peter Wortmann committed
156 157 158 159
oldBarrier :: LlvmM StmtData
oldBarrier = do

    (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1]
160 161 162 163

    let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
    let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs

Peter Wortmann's avatar
Peter Wortmann committed
164
    return (unitOL s1, tops)
165 166 167

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

170
-- | Foreign Calls
Peter Wortmann's avatar
Peter Wortmann committed
171 172
genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
              -> LlvmM StmtData
173 174 175

-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
Peter Wortmann's avatar
Peter Wortmann committed
176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
genCall (PrimTarget MO_WriteBarrier) _ _ = do
    platform <- getLlvmPlatform
    ver <- getLlvmVer
    case () of
     _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]
                    -> return (nilOL, [])
       | ver > 29   -> barrier
       | otherwise  -> oldBarrier

genCall (PrimTarget MO_Touch) _ _
 = return (nilOL, [])

genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
    dstV <- getCmmReg (CmmLocal dst)
    let ty = cmmToLlvmType $ localRegType dst
tibbe's avatar
tibbe committed
191
        width = widthToLlvmFloat w
192
    castV <- mkLocalVar ty
Peter Wortmann's avatar
Peter Wortmann committed
193
    (ve, stmts, top) <- exprToVar e
194 195
    let stmt3 = Assignment castV $ Cast LM_Uitofp ve width
        stmt4 = Store castV dstV
Peter Wortmann's avatar
Peter Wortmann committed
196
    return (stmts `snocOL` stmt3 `snocOL` stmt4, top)
197

Peter Wortmann's avatar
Peter Wortmann committed
198
genCall (PrimTarget (MO_UF_Conv _)) [_] args =
tibbe's avatar
tibbe committed
199 200 201
    panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
    "Can only handle 1, given" ++ show (length args) ++ "."

gmainland's avatar
gmainland committed
202
-- Handle prefetching data
Peter Wortmann's avatar
Peter Wortmann committed
203
genCall t@(PrimTarget MO_Prefetch_Data) [] args = do
204 205 206
    ver <- getLlvmVer
    let argTy | ver <= 29  = [i8Ptr, i32, i32]
              | otherwise  = [i8Ptr, i32, i32, i32]
gmainland's avatar
gmainland committed
207 208 209 210 211
        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing

    let (_, arg_hints) = foreignTargetHints t
    let args_hints' = zip args arg_hints
Peter Wortmann's avatar
Peter Wortmann committed
212 213 214
    (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, [])
    (fptr, stmts2, top2)    <- getFunPtr funTy t
    (argVars', stmts3)      <- castVars $ zip argVars argTy
gmainland's avatar
gmainland committed
215

Peter Wortmann's avatar
Peter Wortmann committed
216
    trash <- getTrashStmts
217 218 219
    let argSuffix | ver <= 29  = [mkIntLit i32 0, mkIntLit i32 3]
                  | otherwise  = [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1]
        call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
gmainland's avatar
gmainland committed
220
        stmts = stmts1 `appOL` stmts2 `appOL` stmts3
Peter Wortmann's avatar
Peter Wortmann committed
221 222
                `appOL` trash `snocOL` call
    return (stmts, top1 ++ top2)
gmainland's avatar
gmainland committed
223

224 225 226 227 228
-- Handle PopCnt and BSwap that need to only convert arg and return types
genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
    genCallSimpleCast w t dsts args
genCall t@(PrimTarget (MO_BSwap w)) dsts args =
    genCallSimpleCast w t dsts args
dterei's avatar
dterei committed
229

230 231
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
Peter Wortmann's avatar
Peter Wortmann committed
232
genCall t@(PrimTarget op) [] args'
233 234 235
 | op == MO_Memcpy ||
   op == MO_Memset ||
   op == MO_Memmove = do
Peter Wortmann's avatar
Peter Wortmann committed
236 237 238 239 240 241
    ver <- getLlvmVer
    dflags <- getDynFlags
    let (args, alignVal) = splitAlignVal args'
        (isVolTy, isVolVal)
              | ver >= 28       = ([i1], [mkIntLit i1 0])
              | otherwise       = ([], [])
242 243
        argTy | op == MO_Memset = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy
              | otherwise       = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
244 245 246
        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing

247 248
    let (_, arg_hints) = foreignTargetHints t
    let args_hints = zip args arg_hints
Peter Wortmann's avatar
Peter Wortmann committed
249 250 251
    (argVars, stmts1, top1)       <- arg_vars args_hints ([], nilOL, [])
    (fptr, stmts2, top2)          <- getFunPtr funTy t
    (argVars', stmts3)            <- castVars $ zip argVars argTy
252

Peter Wortmann's avatar
Peter Wortmann committed
253
    stmts4 <- getTrashStmts
254
    let arguments = argVars' ++ (alignVal:isVolVal)
255 256
        call = Expr $ Call StdCall fptr arguments []
        stmts = stmts1 `appOL` stmts2 `appOL` stmts3
Peter Wortmann's avatar
Peter Wortmann committed
257 258
                `appOL` stmts4 `snocOL` call
    return (stmts, top1 ++ top2)
259 260 261 262 263 264
  where
    splitAlignVal xs = (init xs, extractLit $ last xs)

    -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
    -- than a direct constant (i.e. 'i32 8') as the alignment argument for the
    -- memcpy & co llvm intrinsic functions. So we handle this directly now.
265
    extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i
266 267 268
    extractLit _other = trace ("WARNING: Non constant alignment value given" ++ 
                               " for memcpy! Please report to GHC developers")
                        mkIntLit i32 0
269

270
-- Handle all other foreign calls and prim ops.
Peter Wortmann's avatar
Peter Wortmann committed
271
genCall target res args = do
272

Peter Wortmann's avatar
Peter Wortmann committed
273
    dflags <- getDynFlags
274

dterei's avatar
dterei committed
275
    -- parameter types
276
    let arg_type (_, AddrHint) = i8Ptr
277
        -- cast pointers to i8*. Llvm equivalent of void*
278
        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
279 280

    -- ret type
281 282 283
    let ret_type [] = LMVoid
        ret_type [(_, AddrHint)] = i8Ptr
        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
284 285 286
        ret_type t = panic $ "genCall: Too many return values! Can only handle"
                        ++ " 0 or 1, given " ++ show (length t) ++ "."

287
    -- extract Cmm call convention, and translate to LLVM call convention
Peter Wortmann's avatar
Peter Wortmann committed
288
    platform <- getLlvmPlatform
289 290 291
    let lmconv = case target of
            ForeignTarget _ (ForeignConvention conv _ _ _) ->
              case conv of
Peter Wortmann's avatar
Peter Wortmann committed
292
                 StdCallConv  -> case platformArch platform of
293 294 295 296 297
                                 ArchX86    -> CC_X86_Stdcc
                                 ArchX86_64 -> CC_X86_Stdcc
                                 _          -> CC_Ccc
                 CCallConv    -> CC_Ccc
                 CApiConv     -> CC_Ccc
Simon Marlow's avatar
Simon Marlow committed
298
                 PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv"
thoughtpolice's avatar
thoughtpolice committed
299
                 JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv"
300 301

            PrimTarget   _ -> CC_Ccc
302 303

    {-
304
        CC_Ccc of the possibilities here are a worry with the use of a custom
305 306 307 308 309 310 311
        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
312 313 314 315 316 317
    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
                | otherwise     = llvmStdFunAttrs

        never_returns = case target of
             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
             _ -> False
318 319

    -- fun type
320 321 322
    let (res_hints, arg_hints) = foreignTargetHints target
    let args_hints = zip args arg_hints
    let ress_hints = zip res  res_hints
323
    let ccTy  = StdCall -- tail calls should be done through CmmJump
324 325
    let retTy = ret_type ress_hints
    let argTy = tysToParams $ map arg_type args_hints
326
    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
327
                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
328 329


Peter Wortmann's avatar
Peter Wortmann committed
330 331
    (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, [])
    (fptr, stmts2, top2)    <- getFunPtr funTy target
332

333 334 335
    let retStmt | ccTy == TailCall  = unitOL $ Return Nothing
                | never_returns     = unitOL $ Unreachable
                | otherwise         = nilOL
336

Peter Wortmann's avatar
Peter Wortmann committed
337 338
    stmts3 <- getTrashStmts
    let stmts = stmts1 `appOL` stmts2 `appOL` stmts3
339

340 341 342 343
    -- make the actual call
    case retTy of
        LMVoid -> do
            let s1 = Expr $ Call ccTy fptr argVars fnAttrs
344
            let allStmts = stmts `snocOL` s1 `appOL` retStmt
Peter Wortmann's avatar
Peter Wortmann committed
345
            return (allStmts, top1 ++ top2)
346 347

        _ -> do
348
            (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
349
            -- get the return register
350
            let ret_reg [reg] = reg
351 352
                ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
                                ++ " 1, given " ++ show (length t) ++ "."
353
            let creg = ret_reg res
Peter Wortmann's avatar
Peter Wortmann committed
354 355
            vreg <- getCmmReg (CmmLocal creg)
            let allStmts = stmts `snocOL` s1
356 357 358
            if retTy == pLower (getVarType vreg)
                then do
                    let s2 = Store v1 vreg
Peter Wortmann's avatar
Peter Wortmann committed
359 360
                    return (allStmts `snocOL` s2 `appOL` retStmt,
                                top1 ++ top2)
361 362 363 364 365 366 367 368 369 370 371
                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
Peter Wortmann's avatar
Peter Wortmann committed
372 373
                    return (allStmts `snocOL` s2 `snocOL` s3
                                `appOL` retStmt, top1 ++ top2)
374

375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390
-- Handle simple function call that only need simple type casting, of the form:
--   truncate arg >>= \a -> call(a) >>= zext
--
-- 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.
genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
              -> LlvmM StmtData
genCallSimpleCast w t@(PrimTarget op) [dst] args = do
    let width = widthToLlvmInt w
        dstTy = cmmToLlvmType $ localRegType dst

    fname                       <- cmmPrimOpFunctions op
    (fptr, _, top3)             <- getInstrinct fname width [width]

    dstV                        <- getCmmReg (CmmLocal dst)
391

392 393 394 395 396 397 398 399 400 401 402 403 404
    let (_, arg_hints) = foreignTargetHints t
    let args_hints = zip args arg_hints
    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
    (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 = stmts2 `appOL` stmts4 `snocOL`
                s1 `appOL` stmts5 `snocOL` s2
    return (stmts, top2 ++ top3)
genCallSimpleCast _ _ dsts _ =
    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
ian@well-typed.com's avatar
ian@well-typed.com committed
405

406
-- | Create a function pointer from a target.
Peter Wortmann's avatar
Peter Wortmann committed
407 408 409 410 411 412
getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
          -> LlvmM ExprData
getFunPtr funTy targ = case targ of
    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
        name <- strCLabel_llvm lbl
        getHsFunc' name (funTy name)
413

414
    ForeignTarget expr _ -> do
Peter Wortmann's avatar
Peter Wortmann committed
415 416
        (v1, stmts, top) <- exprToVar expr
        dflags <- getDynFlags
417 418 419 420 421 422
        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"
Peter Wortmann's avatar
Peter Wortmann committed
423
                              ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
424 425

        (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
Peter Wortmann's avatar
Peter Wortmann committed
426
        return (v2, stmts `snocOL` s1, top)
427

Peter Wortmann's avatar
Peter Wortmann committed
428 429 430 431
    PrimTarget mop -> do
        name <- cmmPrimOpFunctions mop
        let fty = funTy name
        getInstrinct2 name fty
432

433
-- | Conversion of call arguments.
Peter Wortmann's avatar
Peter Wortmann committed
434
arg_vars :: [(CmmActual, ForeignHint)]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
435
         -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
Peter Wortmann's avatar
Peter Wortmann committed
436
         -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
437

Peter Wortmann's avatar
Peter Wortmann committed
438 439
arg_vars [] (vars, stmts, tops)
  = return (vars, stmts, tops)
440

Peter Wortmann's avatar
Peter Wortmann committed
441 442 443
arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
  = do (v1, stmts', top') <- exprToVar e
       dflags <- getDynFlags
444 445 446 447 448
       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*! ("
Peter Wortmann's avatar
Peter Wortmann committed
449
                           ++ showSDoc dflags (ppr a) ++ ")"
450

dterei's avatar
dterei committed
451
       (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
Peter Wortmann's avatar
Peter Wortmann committed
452
       arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
453
                               tops ++ top')
454

Peter Wortmann's avatar
Peter Wortmann committed
455 456 457
arg_vars ((e, _):rest) (vars, stmts, tops)
  = do (v1, stmts', top') <- exprToVar e
       arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
458

459 460

-- | Cast a collection of LLVM variables to specific types.
Peter Wortmann's avatar
Peter Wortmann committed
461 462 463 464
castVars :: [(LlvmVar, LlvmType)]
         -> LlvmM ([LlvmVar], LlvmStatements)
castVars vars = do
                done <- mapM (uncurry castVar) vars
465 466 467 468
                let (vars', stmts) = unzip done
                return (vars', toOL stmts)

-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
Peter Wortmann's avatar
Peter Wortmann committed
469 470
castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
castVar v t | getVarType v == t
471 472 473
            = return (v, Nop)

            | otherwise
Peter Wortmann's avatar
Peter Wortmann committed
474 475
            = do dflags <- getDynFlags
                 let op = case (getVarType v, t) of
476 477 478
                      (LMInt n, LMInt m)
                          -> if n < m then LM_Sext else LM_Trunc
                      (vt, _) | isFloat vt && isFloat t
479
                          -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
480 481 482 483 484 485
                                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
486
                      (vt, _) | isVector vt && isVector t   -> LM_Bitcast
487 488

                      (vt, _) -> panic $ "castVars: Can't cast this type ("
489
                                  ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
Peter Wortmann's avatar
Peter Wortmann committed
490
                 doExpr t $ Cast op v t
491 492


493
-- | Decide what C function to use to implement a CallishMachOp
Peter Wortmann's avatar
Peter Wortmann committed
494 495 496 497 498 499 500 501 502 503 504 505 506
cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions mop = do

  ver <- getLlvmVer
  dflags <- getDynFlags
  let intrinTy1 = (if ver >= 28
                       then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
      intrinTy2 = (if ver >= 28
                       then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
      unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
                        ++ " not supported here")

  return $ case mop of
507 508
    MO_F32_Exp    -> fsLit "expf"
    MO_F32_Log    -> fsLit "logf"
509 510
    MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
    MO_F32_Pwr    -> fsLit "llvm.pow.f32"
511

512 513
    MO_F32_Sin    -> fsLit "llvm.sin.f32"
    MO_F32_Cos    -> fsLit "llvm.cos.f32"
514 515 516 517 518 519 520 521 522 523 524 525
    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"
526 527
    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
    MO_F64_Pwr    -> fsLit "llvm.pow.f64"
528

529 530
    MO_F64_Sin    -> fsLit "llvm.sin.f64"
    MO_F64_Cos    -> fsLit "llvm.cos.f64"
531 532 533 534 535 536 537 538 539 540
    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"

541 542 543 544
    MO_Memcpy     -> fsLit $ "llvm.memcpy."  ++ intrinTy1
    MO_Memmove    -> fsLit $ "llvm.memmove." ++ intrinTy1
    MO_Memset     -> fsLit $ "llvm.memset."  ++ intrinTy2

545
    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
546
    (MO_BSwap w)  -> fsLit $ "llvm.bswap."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
dterei's avatar
dterei committed
547

gmainland's avatar
gmainland committed
548 549
    MO_Prefetch_Data -> fsLit "llvm.prefetch"

Ian Lynagh's avatar
Ian Lynagh committed
550 551 552 553 554 555 556
    MO_S_QuotRem {}  -> unsupported
    MO_U_QuotRem {}  -> unsupported
    MO_U_QuotRem2 {} -> unsupported
    MO_Add2 {}       -> unsupported
    MO_U_Mul2 {}     -> unsupported
    MO_WriteBarrier  -> unsupported
    MO_Touch         -> unsupported
tibbe's avatar
tibbe committed
557
    MO_UF_Conv _     -> unsupported
558 559

-- | Tail function calls
Peter Wortmann's avatar
Peter Wortmann committed
560
genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
561 562

-- Call to known function
Peter Wortmann's avatar
Peter Wortmann committed
563 564 565
genJump (CmmLit (CmmLabel lbl)) live = do
    (vf, stmts, top) <- getHsFunc live lbl
    (stgRegs, stgStmts) <- funEpilogue live
566 567
    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
    let s2  = Return Nothing
Peter Wortmann's avatar
Peter Wortmann committed
568
    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
569 570 571


-- Call to unknown function / address
Peter Wortmann's avatar
Peter Wortmann committed
572 573 574 575
genJump expr live = do
    fty <- llvmFunTy live
    (vf, stmts, top) <- exprToVar expr
    dflags <- getDynFlags
576 577 578 579 580 581

    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! ("
Peter Wortmann's avatar
Peter Wortmann committed
582
                     ++ showSDoc dflags (ppr ty) ++ ")"
583 584

    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
Peter Wortmann's avatar
Peter Wortmann committed
585
    (stgRegs, stgStmts) <- funEpilogue live
586 587
    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
    let s3 = Return Nothing
Peter Wortmann's avatar
Peter Wortmann committed
588
    return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
589 590 591 592 593 594 595
            top)


-- | CmmAssign operation
--
-- We use stack allocated variables for CmmReg. The optimiser will replace
-- these with registers when possible.
Peter Wortmann's avatar
Peter Wortmann committed
596 597 598 599 600
genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
genAssign reg val = do
    vreg <- getCmmReg reg
    (vval, stmts2, top2) <- exprToVar val
    let stmts = stmts2
601 602

    let ty = (pLower . getVarType) vreg
Peter Wortmann's avatar
Peter Wortmann committed
603
    dflags <- getDynFlags
604 605 606 607 608
    case ty of
      -- Some registers are pointer types, so need to cast value to pointer
      LMPointer _ | getVarType vval == llvmWord dflags -> do
          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
          let s2 = Store v vreg
Peter Wortmann's avatar
Peter Wortmann committed
609
          return (stmts `snocOL` s1 `snocOL` s2, top2)
610

611 612 613
      LMVector _ _ -> do
          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
          let s2 = Store v vreg
Peter Wortmann's avatar
Peter Wortmann committed
614
          return (stmts `snocOL` s1 `snocOL` s2, top2)
615 616 617

      _ -> do
          let s1 = Store vval vreg
Peter Wortmann's avatar
Peter Wortmann committed
618
          return (stmts `snocOL` s1, top2)
619 620 621


-- | CmmStore operation
Peter Wortmann's avatar
Peter Wortmann committed
622
genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
623 624 625 626 627

-- 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
Peter Wortmann's avatar
Peter Wortmann committed
628 629
genStore addr@(CmmReg (CmmGlobal r)) val
    = genStore_fast addr r 0 val
630

Peter Wortmann's avatar
Peter Wortmann committed
631 632
genStore addr@(CmmRegOff (CmmGlobal r) n) val
    = genStore_fast addr r n val
633

Peter Wortmann's avatar
Peter Wortmann committed
634
genStore addr@(CmmMachOp (MO_Add _) [
635 636 637
                            (CmmReg (CmmGlobal r)),
                            (CmmLit (CmmInt n _))])
                val
Peter Wortmann's avatar
Peter Wortmann committed
638
    = genStore_fast addr r (fromInteger n) val
639

Peter Wortmann's avatar
Peter Wortmann committed
640
genStore addr@(CmmMachOp (MO_Sub _) [
641 642 643
                            (CmmReg (CmmGlobal r)),
                            (CmmLit (CmmInt n _))])
                val
Peter Wortmann's avatar
Peter Wortmann committed
644
    = genStore_fast addr r (negate $ fromInteger n) val
645 646

-- generic case
Peter Wortmann's avatar
Peter Wortmann committed
647 648 649
genStore addr val
    = do other <- getTBAAMeta otherN
         genStore_slow addr val other
650 651 652 653

-- | CmmStore operation
-- This is a special case for storing to a global register pointer
-- offset such as I32[Sp+8].
Peter Wortmann's avatar
Peter Wortmann committed
654 655 656 657 658 659 660 661
genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
              -> LlvmM StmtData
genStore_fast addr r n val
  = do dflags <- getDynFlags
       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
       meta          <- getTBAARegMeta r
       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
       case isPointer grt && rem == 0 of
662
            True -> do
Peter Wortmann's avatar
Peter Wortmann committed
663
                (vval,  stmts, top) <- exprToVar val
664
                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
665 666 667 668
                -- We might need a different pointer type, so check
                case pLower grt == getVarType vval of
                     -- were fine
                     True  -> do
669
                         let s3 = MetaStmt meta $ Store vval ptr
Peter Wortmann's avatar
Peter Wortmann committed
670
                         return (stmts `appOL` s1 `snocOL` s2
671 672 673 674 675 676
                                 `snocOL` s3, top)

                     -- cast to pointer type needed
                     False -> do
                         let ty = (pLift . getVarType) vval
                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
677
                         let s4 = MetaStmt meta $ Store vval ptr'
Peter Wortmann's avatar
Peter Wortmann committed
678
                         return (stmts `appOL` s1 `snocOL` s2
679 680 681 682
                                 `snocOL` s3 `snocOL` s4, top)

            -- If its a bit type then we use the slow method since
            -- we can't avoid casting anyway.
Peter Wortmann's avatar
Peter Wortmann committed
683
            False -> genStore_slow addr val meta
684 685 686 687


-- | CmmStore operation
-- Generic case. Uses casts and pointer arithmetic if needed.
Peter Wortmann's avatar
Peter Wortmann committed
688 689 690 691
genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
genStore_slow addr val meta = do
    (vaddr, stmts1, top1) <- exprToVar addr
    (vval,  stmts2, top2) <- exprToVar val
692 693

    let stmts = stmts1 `appOL` stmts2
Peter Wortmann's avatar
Peter Wortmann committed
694
    dflags <- getDynFlags
695
    case getVarType vaddr of
696
        -- sometimes we need to cast an int to a pointer before storing
697
        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
698
            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
699
            let s2 = MetaStmt meta $ Store v vaddr
Peter Wortmann's avatar
Peter Wortmann committed
700
            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
701

702
        LMPointer _ -> do
703
            let s1 = MetaStmt meta $ Store vval vaddr
Peter Wortmann's avatar
Peter Wortmann committed
704
            return (stmts `snocOL` s1, top1 ++ top2)
705

706
        i@(LMInt _) | i == llvmWord dflags -> do
707 708
            let vty = pLift $ getVarType vval
            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
709
            let s2 = MetaStmt meta $ Store vval vptr
Peter Wortmann's avatar
Peter Wortmann committed
710
            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
711

712 713
        other ->
            pprPanic "genStore: ptr not right type!"
714
                    (PprCmm.pprExpr addr <+> text (
715
                        "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
716
                        ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
717
                        ", Var: " ++ showSDoc dflags (ppr vaddr)))
718 719 720


-- | Unconditional branch
Peter Wortmann's avatar
Peter Wortmann committed
721 722
genBranch :: BlockId -> LlvmM StmtData
genBranch id =
723
    let label = blockIdToLlvm id
Peter Wortmann's avatar
Peter Wortmann committed
724
    in return (unitOL $ Branch label, [])
725 726 727


-- | Conditional branch
Peter Wortmann's avatar
Peter Wortmann committed
728 729
genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData
genCondBranch cond idT idF = do
730
    let labelT = blockIdToLlvm idT
731
    let labelF = blockIdToLlvm idF
732
    -- See Note [Literals and branch conditions].
Peter Wortmann's avatar
Peter Wortmann committed
733
    (vc, stmts, top) <- exprToVarOpt i1Option cond
734 735 736
    if getVarType vc == i1
        then do
            let s1 = BranchIf vc labelT labelF
Peter Wortmann's avatar
Peter Wortmann committed
737
            return (stmts `snocOL` s1, top)
738
        else do
Peter Wortmann's avatar
Peter Wortmann committed
739
            dflags <- getDynFlags
740
            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
741

742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792
{- Note [Literals and branch conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It is important that whenever we generate branch conditions for
literals like '1', they are properly narrowed to an LLVM expression of
type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
must be certain to return a properly narrowed type. genLit is
responsible for this, in the case of literal integers.

Often, we won't see direct statements like:

    if(1) {
      ...
    } else {
      ...
    }

at this point in the pipeline, because the Glorious Code Generator
will do trivial branch elimination in the sinking pass (among others,)
which will eliminate the expression entirely.

However, it's certainly possible and reasonable for this to occur in
hand-written C-- code. Consider something like:

    #ifndef SOME_CONDITIONAL
    #define CHECK_THING(x) 1
    #else
    #define CHECK_THING(x) some_operation((x))
    #endif

    f() {

      if (CHECK_THING(xyz)) {
        ...
      } else {
        ...
      }

    }

In such an instance, CHECK_THING might result in an *expression* in
one case, and a *literal* in the other, depending on what in
particular was #define'd. So we must be sure to properly narrow the
literal in this case to i1 as it won't be eliminated beforehand.

For a real example of this, see ./rts/StgStdThunks.cmm

-}


793 794 795

-- | Switch branch
--
dterei's avatar
dterei committed
796
-- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
797
-- However, they may be defined one day, so we better document this behaviour.
Peter Wortmann's avatar
Peter Wortmann committed
798 799 800
genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData
genSwitch cond maybe_ids = do
    (vc, stmts, top) <- exprToVar cond
801 802
    let ty = getVarType vc

803
    let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
804
    let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
805 806 807 808
    -- out of range is undefied, so lets just branch to first label
    let (_, defLbl) = head labels

    let s1 = Switch vc defLbl labels
Peter Wortmann's avatar
Peter Wortmann committed
809
    return $ (stmts `snocOL` s1, top)
810 811 812 813 814 815 816 817 818


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

-- | An expression conversion return data:
--   * 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
819
--   * LlvmCmmDecl: Any global data needed for this expression
Peter Wortmann's avatar
Peter Wortmann committed
820
type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
821 822 823

-- | Values which can be passed to 'exprToVar' to configure its
-- behaviour in certain circumstances.
824 825 826 827 828
--
-- Currently just used for determining if a comparison should return
-- a boolean (i1) or a word. See Note [Literals and branch conditions].
newtype EOption = EOption { i1Expected :: Bool }
-- XXX: EOption is an ugly and inefficient solution to this problem.
829

830
-- | i1 type expected (condition scrutinee).
831
i1Option :: EOption
832
i1Option = EOption True
833

834 835 836
-- | Word type expected (usual).
wordOption :: EOption
wordOption = EOption False
837 838 839

-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
-- expression being stored in the returned LlvmVar.
Peter Wortmann's avatar
Peter Wortmann committed
840 841
exprToVar :: CmmExpr -> LlvmM ExprData
exprToVar = exprToVarOpt wordOption
842

Peter Wortmann's avatar
Peter Wortmann committed
843 844
exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
exprToVarOpt opt e = case e of
845 846

    CmmLit lit
Peter Wortmann's avatar
Peter Wortmann committed
847
        -> genLit opt lit
848 849

    CmmLoad e' ty
Peter Wortmann's avatar
Peter Wortmann committed
850
        -> genLoad e' ty
851 852 853 854

    -- Cmmreg in expression is the value, so must load. If you want actual
    -- reg pointer, call getCmmReg directly.
    CmmReg r -> do
Peter Wortmann's avatar
Peter Wortmann committed
855 856
        (v1, ty, s1) <- getCmmRegVal r
        case isPointer ty of
857 858
             True  -> do
                 -- Cmm wants the value, so pointer types must be cast to ints
Peter Wortmann's avatar
Peter Wortmann committed
859
                 dflags <- getDynFlags
860
                 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
Peter Wortmann's avatar
Peter Wortmann committed
861
                 return (v2, s1 `snocOL` s2, [])
862

Peter Wortmann's avatar
Peter Wortmann committed
863
             False -> return (v1, s1, [])
864 865

    CmmMachOp op exprs
Peter Wortmann's avatar
Peter Wortmann committed
866
        -> genMachOp opt op exprs
867 868

    CmmRegOff r i
Peter Wortmann's avatar
Peter Wortmann committed
869 870
        -> do dflags <- getDynFlags
              exprToVar $ expandCmmReg dflags (r, i)
871 872 873 874 875