compiler/llvmGen/LlvmCodeGen/CodeGen.hs

   1 {-# OPTIONS -fno-warn-type-defaults #-}
   2 -- ----------------------------------------------------------------------------
   3 -- | Handle conversion of CmmProc to LLVM code.
   4 --
   5
   6 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
   7
   8 #include "HsVersions.h"
   9
  10 import Llvm
  11 import LlvmCodeGen.Base
  12 import LlvmCodeGen.Regs
  13
  14 import BlockId
  15 import CgUtils ( activeStgRegs, callerSaves )
  16 import CLabel
  17 import OldCmm
  18 import qualified OldPprCmm as PprCmm
  19 import OrdList
  20
  21 import FastString
  22 import ForeignCall
  23 import Outputable hiding ( panic, pprPanic )
  24 import qualified Outputable
  25 import UniqSupply
  26 import Unique
  27 import Util
  28
  29 import Data.List ( partition )
  30 import Control.Monad ( liftM )
  31
  32 type LlvmStatements = OrdList LlvmStatement
  33
  34
  35 -- -----------------------------------------------------------------------------
  36 -- | Top-level of the LLVM proc Code generator
  37 --
  38 genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
  39 genLlvmProc env (CmmData _ _)
  40   = return (env, [])
  41
  42 genLlvmProc env (CmmProc _ _ (ListGraph []))
  43   = return (env, [])
  44
  45 genLlvmProc env (CmmProc info lbl (ListGraph blocks))
  46   = do
  47         (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
  48
  49         let proc    = CmmProc info lbl (ListGraph lmblocks)
  50         let tops    = lmdata ++ [proc]
  51
  52         return (env', tops)
  53
  54
  55 -- -----------------------------------------------------------------------------
  56 -- * Block code generation
  57 --
  58
  59 -- | Generate code for a list of blocks that make up a complete procedure.
  60 basicBlocksCodeGen :: LlvmEnv
  61                    -> [CmmBasicBlock]
  62                    -> ( [LlvmBasicBlock] , [LlvmCmmTop] )
  63                    -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmTop] )
  64 basicBlocksCodeGen env ([]) (blocks, tops)
  65   = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
  66        let allocs' = concat allocs
  67        let ((BasicBlock id fstmts):rblks) = blocks'
  68        fplog <- funPrologue
  69        let fblocks = (BasicBlock id (fplog ++  allocs' ++ fstmts)):rblks
  70        return (env, fblocks, tops)
  71
  72 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
  73   = do (env', lb, lt) <- basicBlockCodeGen env block
  74        let lblocks = lblocks' ++ lb
  75        let ltops   = ltops' ++ lt
  76        basicBlocksCodeGen env' blocks (lblocks, ltops)
  77
  78
  79 -- | Allocations need to be extracted so they can be moved to the entry
  80 -- of a function to make sure they dominate all possible paths in the CFG.
  81 dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
  82 dominateAllocs (BasicBlock id stmts)
  83   = let (allocs, stmts') = partition isAlloc stmts
  84         isAlloc (Assignment _ (Alloca _ _)) = True
  85         isAlloc _other                      = False
  86     in (BasicBlock id stmts', allocs)
  87
  88
  89 -- | Generate code for one block
  90 basicBlockCodeGen ::  LlvmEnv
  91                   -> CmmBasicBlock
  92                   -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] )
  93 basicBlockCodeGen env (BasicBlock id stmts)
  94   = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
  95        return (env', [BasicBlock id (fromOL instrs)], top)
  96
  97
  98 -- -----------------------------------------------------------------------------
  99 -- * CmmStmt code generation
 100 --
 101
 102 -- A statement conversion return data.
 103 --   * LlvmEnv: The new environment
 104 --   * LlvmStatements: The compiled LLVM statements.
 105 --   * LlvmCmmTop: Any global data needed.
 106 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmTop])
 107
 108
 109 -- | Convert a list of CmmStmt's to LlvmStatement's
 110 stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmTop])
 111               -> UniqSM StmtData
 112 stmtsToInstrs env [] (llvm, top)
 113   = return (env, llvm, top)
 114
 115 stmtsToInstrs env (stmt : stmts) (llvm, top)
 116    = do (env', instrs, tops) <- stmtToInstrs env stmt
 117         stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
 118
 119
 120 -- | Convert a CmmStmt to a list of LlvmStatement's
 121 stmtToInstrs :: LlvmEnv -> CmmStmt
 122              -> UniqSM StmtData
 123 stmtToInstrs env stmt = case stmt of
 124
 125     CmmNop               -> return (env, nilOL, [])
 126     CmmComment _         -> return (env, nilOL, []) -- nuke comments
 127
 128     CmmAssign reg src    -> genAssign env reg src
 129     CmmStore addr src    -> genStore env addr src
 130
 131     CmmBranch id         -> genBranch env id
 132     CmmCondBranch arg id -> genCondBranch env arg id
 133     CmmSwitch arg ids    -> genSwitch env arg ids
 134
 135     -- Foreign Call
 136     CmmCall target res args _ ret
 137         -> genCall env target res args ret
 138
 139     -- Tail call
 140     CmmJump arg _ -> genJump env arg
 141
 142     -- CPS, only tail calls, no return's
 143     -- Actually, there are a few return statements that occur because of hand
 144     -- written Cmm code.
 145     CmmReturn _
 146         -> return (env, unitOL $ Return Nothing, [])
 147
 148
 149 -- | Foreign Calls
 150 genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals
 151               -> CmmReturnInfo -> UniqSM StmtData
 152
 153 -- Write barrier needs to be handled specially as it is implemented as an LLVM
 154 -- intrinsic function.
 155 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
 156 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = return (env, nilOL, [])
 157
 158 #else
 159 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
 160     let fname = fsLit "llvm.memory.barrier"
 161     let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
 162                     FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
 163     let fty = LMFunction funSig
 164
 165     let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
 166     let tops = case funLookup fname env of
 167                     Just _  -> []
 168                     Nothing -> [CmmData Data [([],[fty])]]
 169
 170     let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
 171     let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
 172     let env' = funInsert fname fty env
 173
 174     return (env', unitOL s1, tops)
 175
 176     where
 177         lmTrue :: LlvmVar
 178         lmTrue  = mkIntLit i1 (-1)
 179 #endif
 180
 181 -- Handle memcpy function specifically since llvm's intrinsic version takes
 182 -- some extra parameters.
 183 genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
 184                                                   op == MO_Memset ||
 185                                                   op == MO_Memmove = do
 186     let (isVolTy, isVolVal) = if getLlvmVer env >= 28
 187                                  then ([i1], [mkIntLit i1 0]) else ([], [])
 188         argTy | op == MO_Memset = [i8Ptr, i8,    llvmWord, i32] ++ isVolTy
 189               | otherwise       = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
 190         funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
 191                              CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
 192
 193     (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
 194     (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy t
 195     (argVars', stmts3)            <- castVars $ zip argVars argTy
 196
 197     let arguments = argVars' ++ isVolVal
 198         call = Expr $ Call StdCall fptr arguments []
 199         stmts = stmts1 `appOL` stmts2 `appOL` stmts3
 200                 `appOL` trashStmts `snocOL` call
 201     return (env2, stmts, top1 ++ top2)
 202
 203 -- Handle all other foreign calls and prim ops.
 204 genCall env target res args ret = do
 205
 206     -- parameter types
 207     let arg_type (CmmHinted _ AddrHint) = i8Ptr
 208         -- cast pointers to i8*. Llvm equivalent of void*
 209         arg_type (CmmHinted expr _    ) = cmmToLlvmType $ cmmExprType expr
 210
 211     -- ret type
 212     let ret_type ([]) = LMVoid
 213         ret_type ([CmmHinted _ AddrHint]) = i8Ptr
 214         ret_type ([CmmHinted reg _])      = cmmToLlvmType $ localRegType reg
 215         ret_type t = panic $ "genCall: Too many return values! Can only handle"
 216                         ++ " 0 or 1, given " ++ show (length t) ++ "."
 217
 218     -- extract Cmm call convention
 219     let cconv = case target of
 220             CmmCallee _ conv -> conv
 221             CmmPrim   _      -> PrimCallConv
 222
 223     -- translate to LLVM call convention
 224     let lmconv = case cconv of
 225 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 226             StdCallConv  -> CC_X86_Stdcc
 227 #else
 228             StdCallConv  -> CC_Ccc
 229 #endif
 230             CCallConv    -> CC_Ccc
 231             PrimCallConv -> CC_Ccc
 232             CmmCallConv  -> panic "CmmCallConv not supported here!"
 233
 234     {-
 235         Some of the possibilities here are a worry with the use of a custom
 236         calling convention for passing STG args. In practice the more
 237         dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
 238
 239         The native code generator only handles StdCall and CCallConv.
 240     -}
 241
 242     -- call attributes
 243     let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
 244                 | otherwise              = llvmStdFunAttrs
 245
 246     -- fun type
 247     let ccTy  = StdCall -- tail calls should be done through CmmJump
 248     let retTy = ret_type res
 249     let argTy = tysToParams $ map arg_type args
 250     let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
 251                              lmconv retTy FixedArgs argTy llvmFunAlign
 252
 253
 254     (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
 255     (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy target
 256
 257     let retStmt | ccTy == TailCall       = unitOL $ Return Nothing
 258                 | ret == CmmNeverReturns = unitOL $ Unreachable
 259                 | otherwise              = nilOL
 260
 261     let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
 262
 263     -- make the actual call
 264     case retTy of
 265         LMVoid -> do
 266             let s1 = Expr $ Call ccTy fptr argVars fnAttrs
 267             let allStmts = stmts `snocOL` s1 `appOL` retStmt
 268             return (env2, allStmts, top1 ++ top2)
 269
 270         _ -> do
 271             (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
 272             -- get the return register
 273             let ret_reg ([CmmHinted reg hint]) = (reg, hint)
 274                 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
 275                                 ++ " 1, given " ++ show (length t) ++ "."
 276             let (creg, _) = ret_reg res
 277             let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
 278             let allStmts = stmts `snocOL` s1 `appOL` stmts3
 279             if retTy == pLower (getVarType vreg)
 280                 then do
 281                     let s2 = Store v1 vreg
 282                     return (env3, allStmts `snocOL` s2 `appOL` retStmt,
 283                                 top1 ++ top2 ++ top3)
 284                 else do
 285                     let ty = pLower $ getVarType vreg
 286                     let op = case ty of
 287                             vt | isPointer vt -> LM_Bitcast
 288                                | isInt     vt -> LM_Ptrtoint
 289                                | otherwise    ->
 290                                    panic $ "genCall: CmmReg bad match for"
 291                                         ++ " returned type!"
 292
 293                     (v2, s2) <- doExpr ty $ Cast op v1 ty
 294                     let s3 = Store v2 vreg
 295                     return (env3, allStmts `snocOL` s2 `snocOL` s3
 296                                 `appOL` retStmt, top1 ++ top2 ++ top3)
 297
 298
 299 -- | Create a function pointer from a target.
 300 getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
 301           -> UniqSM ExprData
 302 getFunPtr env funTy targ = case targ of
 303     CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm lbl
 304
 305     CmmCallee expr _ -> do
 306         (env', v1, stmts, top) <- exprToVar env expr
 307         let fty = funTy $ fsLit "dynamic"
 308             cast = case getVarType v1 of
 309                 ty | isPointer ty -> LM_Bitcast
 310                 ty | isInt ty     -> LM_Inttoptr
 311
 312                 ty -> panic $ "genCall: Expr is of bad type for function"
 313                               ++ " call! (" ++ show (ty) ++ ")"
 314
 315         (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
 316         return (env', v2, stmts `snocOL` s1, top)
 317
 318     CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop
 319
 320     where
 321         litCase name = do
 322             case funLookup name env of
 323                 Just ty'@(LMFunction sig) -> do
 324                     -- Function in module in right form
 325                     let fun = LMGlobalVar name ty' (funcLinkage sig)
 326                                     Nothing Nothing False
 327                     return (env, fun, nilOL, [])
 328
 329                 Just ty' -> do
 330                     -- label in module but not function pointer, convert
 331                     let fty@(LMFunction sig) = funTy name
 332                         fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
 333                                     Nothing Nothing False
 334                     (v1, s1) <- doExpr (pLift fty)
 335                                     $ Cast LM_Bitcast fun (pLift fty)
 336                     return  (env, v1, unitOL s1, [])
 337
 338                 Nothing -> do
 339                     -- label not in module, create external reference
 340                     let fty@(LMFunction sig) = funTy name
 341                         fun = LMGlobalVar name fty (funcLinkage sig)
 342                                     Nothing Nothing False
 343                         top = [CmmData Data [([],[fty])]]
 344                         env' = funInsert name fty env
 345                     return (env', fun, nilOL, top)
 346
 347
 348 -- | Conversion of call arguments.
 349 arg_vars :: LlvmEnv
 350          -> HintedCmmActuals
 351          -> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
 352          -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
 353
 354 arg_vars env [] (vars, stmts, tops)
 355   = return (env, vars, stmts, tops)
 356
 357 arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
 358   = do (env', v1, stmts', top') <- exprToVar env e
 359        let op = case getVarType v1 of
 360                ty | isPointer ty -> LM_Bitcast
 361                ty | isInt ty     -> LM_Inttoptr
 362
 363                a  -> panic $ "genCall: Can't cast llvmType to i8*! ("
 364                            ++ show a ++ ")"
 365
 366        (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
 367        arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
 368                                tops ++ top')
 369
 370 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
 371   = do (env', v1, stmts', top') <- exprToVar env e
 372        arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
 373
 374
 375 -- | Cast a collection of LLVM variables to specific types.
 376 castVars :: [(LlvmVar, LlvmType)]
 377          -> UniqSM ([LlvmVar], LlvmStatements)
 378 castVars vars = do
 379                 done <- mapM (uncurry castVar) vars
 380                 let (vars', stmts) = unzip done
 381                 return (vars', toOL stmts)
 382
 383 -- | Cast an LLVM variable to a specific type, panicing if it can't be done.
 384 castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
 385 castVar v t | getVarType v == t
 386             = return (v, Nop)
 387
 388             | otherwise
 389             = let op = case (getVarType v, t) of
 390                       (LMInt n, LMInt m)
 391                           -> if n < m then LM_Sext else LM_Trunc
 392                       (vt, _) | isFloat vt && isFloat t
 393                           -> if llvmWidthInBits vt < llvmWidthInBits t
 394                                 then LM_Fpext else LM_Fptrunc
 395                       (vt, _) | isInt vt && isFloat t       -> LM_Sitofp
 396                       (vt, _) | isFloat vt && isInt t       -> LM_Fptosi
 397                       (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr
 398                       (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint
 399                       (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
 400
 401                       (vt, _) -> panic $ "castVars: Can't cast this type ("
 402                                   ++ show vt ++ ") to (" ++ show t ++ ")"
 403               in doExpr t $ Cast op v t
 404
 405
 406 -- | Decide what C function to use to implement a CallishMachOp
 407 cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
 408 cmmPrimOpFunctions env mop
 409  = case mop of
 410     MO_F32_Exp    -> fsLit "expf"
 411     MO_F32_Log    -> fsLit "logf"
 412     MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
 413     MO_F32_Pwr    -> fsLit "llvm.pow.f32"
 414
 415     MO_F32_Sin    -> fsLit "llvm.sin.f32"
 416     MO_F32_Cos    -> fsLit "llvm.cos.f32"
 417     MO_F32_Tan    -> fsLit "tanf"
 418
 419     MO_F32_Asin   -> fsLit "asinf"
 420     MO_F32_Acos   -> fsLit "acosf"
 421     MO_F32_Atan   -> fsLit "atanf"
 422
 423     MO_F32_Sinh   -> fsLit "sinhf"
 424     MO_F32_Cosh   -> fsLit "coshf"
 425     MO_F32_Tanh   -> fsLit "tanhf"
 426
 427     MO_F64_Exp    -> fsLit "exp"
 428     MO_F64_Log    -> fsLit "log"
 429     MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
 430     MO_F64_Pwr    -> fsLit "llvm.pow.f64"
 431
 432     MO_F64_Sin    -> fsLit "llvm.sin.f64"
 433     MO_F64_Cos    -> fsLit "llvm.cos.f64"
 434     MO_F64_Tan    -> fsLit "tan"
 435
 436     MO_F64_Asin   -> fsLit "asin"
 437     MO_F64_Acos   -> fsLit "acos"
 438     MO_F64_Atan   -> fsLit "atan"
 439
 440     MO_F64_Sinh   -> fsLit "sinh"
 441     MO_F64_Cosh   -> fsLit "cosh"
 442     MO_F64_Tanh   -> fsLit "tanh"
 443
 444     MO_Memcpy     -> fsLit $ "llvm.memcpy."  ++ intrinTy1
 445     MO_Memmove    -> fsLit $ "llvm.memmove." ++ intrinTy1
 446     MO_Memset     -> fsLit $ "llvm.memset."  ++ intrinTy2
 447
 448     a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
 449
 450     where
 451         intrinTy1 = (if getLlvmVer env >= 28
 452                        then "p0i8.p0i8." else "") ++ show llvmWord
 453         intrinTy2 = (if getLlvmVer env >= 28
 454                        then "p0i8." else "") ++ show llvmWord
 455
 456
 457 -- | Tail function calls
 458 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
 459
 460 -- Call to known function
 461 genJump env (CmmLit (CmmLabel lbl)) = do
 462     (env', vf, stmts, top) <- getHsFunc env lbl
 463     (stgRegs, stgStmts) <- funEpilogue
 464     let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
 465     let s2  = Return Nothing
 466     return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
 467
 468
 469 -- Call to unknown function / address
 470 genJump env expr = do
 471     let fty = llvmFunTy
 472     (env', vf, stmts, top) <- exprToVar env expr
 473
 474     let cast = case getVarType vf of
 475          ty | isPointer ty -> LM_Bitcast
 476          ty | isInt ty     -> LM_Inttoptr
 477
 478          ty -> panic $ "genJump: Expr is of bad type for function call! ("
 479                      ++ show (ty) ++ ")"
 480
 481     (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
 482     (stgRegs, stgStmts) <- funEpilogue
 483     let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
 484     let s3 = Return Nothing
 485     return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
 486             top)
 487
 488
 489 -- | CmmAssign operation
 490 --
 491 -- We use stack allocated variables for CmmReg. The optimiser will replace
 492 -- these with registers when possible.
 493 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
 494 genAssign env reg val = do
 495     let (env1, vreg, stmts1, top1) = getCmmReg env reg
 496     (env2, vval, stmts2, top2) <- exprToVar env1 val
 497     let stmts = stmts1 `appOL` stmts2
 498
 499     let ty = (pLower . getVarType) vreg
 500     case isPointer ty && getVarType vval == llvmWord of
 501          -- Some registers are pointer types, so need to cast value to pointer
 502          True -> do
 503              (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
 504              let s2 = Store v vreg
 505              return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
 506
 507          False -> do
 508              let s1 = Store vval vreg
 509              return (env2, stmts `snocOL` s1, top1 ++ top2)
 510
 511
 512 -- | CmmStore operation
 513 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
 514
 515 -- First we try to detect a few common cases and produce better code for
 516 -- these then the default case. We are mostly trying to detect Cmm code
 517 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
 518 -- generic case that uses casts and pointer arithmetic
 519 genStore env addr@(CmmReg (CmmGlobal r)) val
 520     = genStore_fast env addr r 0 val
 521
 522 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
 523     = genStore_fast env addr r n val
 524
 525 genStore env addr@(CmmMachOp (MO_Add _) [
 526                             (CmmReg (CmmGlobal r)),
 527                             (CmmLit (CmmInt n _))])
 528                 val
 529     = genStore_fast env addr r (fromInteger n) val
 530
 531 genStore env addr@(CmmMachOp (MO_Sub _) [
 532                             (CmmReg (CmmGlobal r)),
 533                             (CmmLit (CmmInt n _))])
 534                 val
 535     = genStore_fast env addr r (negate $ fromInteger n) val
 536
 537 -- generic case
 538 genStore env addr val = genStore_slow env addr val
 539
 540 -- | CmmStore operation
 541 -- This is a special case for storing to a global register pointer
 542 -- offset such as I32[Sp+8].
 543 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
 544               -> UniqSM StmtData
 545 genStore_fast env addr r n val
 546   = let gr  = lmGlobalRegVar r
 547         grt = (pLower . getVarType) gr
 548         (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
 549     in case isPointer grt && rem == 0 of
 550             True -> do
 551                 (env', vval,  stmts, top) <- exprToVar env val
 552                 (gv,  s1) <- doExpr grt $ Load gr
 553                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
 554                 -- We might need a different pointer type, so check
 555                 case pLower grt == getVarType vval of
 556                      -- were fine
 557                      True  -> do
 558                          let s3 = Store vval ptr
 559                          return (env',  stmts `snocOL` s1 `snocOL` s2
 560                                  `snocOL` s3, top)
 561
 562                      -- cast to pointer type needed
 563                      False -> do
 564                          let ty = (pLift . getVarType) vval
 565                          (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
 566                          let s4 = Store vval ptr'
 567                          return (env',  stmts `snocOL` s1 `snocOL` s2
 568                                  `snocOL` s3 `snocOL` s4, top)
 569
 570             -- If its a bit type then we use the slow method since
 571             -- we can't avoid casting anyway.
 572             False -> genStore_slow env addr val
 573
 574
 575 -- | CmmStore operation
 576 -- Generic case. Uses casts and pointer arithmetic if needed.
 577 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
 578 genStore_slow env addr val = do
 579     (env1, vaddr, stmts1, top1) <- exprToVar env addr
 580     (env2, vval,  stmts2, top2) <- exprToVar env1 val
 581
 582     let stmts = stmts1 `appOL` stmts2
 583     case getVarType vaddr of
 584         -- sometimes we need to cast an int to a pointer before storing
 585         LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
 586             (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
 587             let s2 = Store v vaddr
 588             return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
 589
 590         LMPointer _ -> do
 591             let s1 = Store vval vaddr
 592             return (env2, stmts `snocOL` s1, top1 ++ top2)
 593
 594         i@(LMInt _) | i == llvmWord -> do
 595             let vty = pLift $ getVarType vval
 596             (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
 597             let s2 = Store vval vptr
 598             return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
 599
 600         other ->
 601             pprPanic "genStore: ptr not right type!"
 602                     (PprCmm.pprExpr addr <+> text (
 603                         "Size of Ptr: " ++ show llvmPtrBits ++
 604                         ", Size of var: " ++ show (llvmWidthInBits other) ++
 605                         ", Var: " ++ show vaddr))
 606
 607
 608 -- | Unconditional branch
 609 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
 610 genBranch env id =
 611     let label = blockIdToLlvm id
 612     in return (env, unitOL $ Branch label, [])
 613
 614
 615 -- | Conditional branch
 616 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
 617 genCondBranch env cond idT = do
 618     idF <- getUniqueUs
 619     let labelT = blockIdToLlvm idT
 620     let labelF = LMLocalVar idF LMLabel
 621     (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
 622     if getVarType vc == i1
 623         then do
 624             let s1 = BranchIf vc labelT labelF
 625             let s2 = MkLabel idF
 626             return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
 627         else
 628             panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
 629
 630
 631 -- | Switch branch
 632 --
 633 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
 634 -- However, they may be defined one day, so we better document this behaviour.
 635 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
 636 genSwitch env cond maybe_ids = do
 637     (env', vc, stmts, top) <- exprToVar env cond
 638     let ty = getVarType vc
 639
 640     let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
 641     let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
 642     -- out of range is undefied, so lets just branch to first label
 643     let (_, defLbl) = head labels
 644
 645     let s1 = Switch vc defLbl labels
 646     return $ (env', stmts `snocOL` s1, top)
 647
 648
 649 -- -----------------------------------------------------------------------------
 650 -- * CmmExpr code generation
 651 --
 652
 653 -- | An expression conversion return data:
 654 --   * LlvmEnv: The new enviornment
 655 --   * LlvmVar: The var holding the result of the expression
 656 --   * LlvmStatements: Any statements needed to evaluate the expression
 657 --   * LlvmCmmTop: Any global data needed for this expression
 658 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
 659
 660 -- | Values which can be passed to 'exprToVar' to configure its
 661 -- behaviour in certain circumstances.
 662 data EOption = EOption {
 663         -- | The expected LlvmType for the returned variable.
 664         --
 665         -- Currently just used for determining if a comparison should return
 666         -- a boolean (i1) or a int (i32/i64).
 667         eoExpectedType :: Maybe LlvmType
 668   }
 669
 670 i1Option :: EOption
 671 i1Option = EOption (Just i1)
 672
 673 wordOption :: EOption
 674 wordOption = EOption (Just llvmWord)
 675
 676
 677 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
 678 -- expression being stored in the returned LlvmVar.
 679 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
 680 exprToVar env = exprToVarOpt env wordOption
 681
 682 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
 683 exprToVarOpt env opt e = case e of
 684
 685     CmmLit lit
 686         -> genLit env lit
 687
 688     CmmLoad e' ty
 689         -> genLoad env e' ty
 690
 691     -- Cmmreg in expression is the value, so must load. If you want actual
 692     -- reg pointer, call getCmmReg directly.
 693     CmmReg r -> do
 694         let (env', vreg, stmts, top) = getCmmReg env r
 695         (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
 696         case (isPointer . getVarType) v1 of
 697              True  -> do
 698                  -- Cmm wants the value, so pointer types must be cast to ints
 699                  (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
 700                  return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
 701
 702              False -> return (env', v1, stmts `snocOL` s1, top)
 703
 704     CmmMachOp op exprs
 705         -> genMachOp env opt op exprs
 706
 707     CmmRegOff r i
 708         -> exprToVar env $ expandCmmReg (r, i)
 709
 710     CmmStackSlot _ _
 711         -> panic "exprToVar: CmmStackSlot not supported!"
 712
 713
 714 -- | Handle CmmMachOp expressions
 715 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
 716
 717 -- Unary Machop
 718 genMachOp env _ op [x] = case op of
 719
 720     MO_Not w ->
 721         let all1 = mkIntLit (widthToLlvmInt w) (-1)
 722         in negate (widthToLlvmInt w) all1 LM_MO_Xor
 723
 724     MO_S_Neg w ->
 725         let all0 = mkIntLit (widthToLlvmInt w) 0
 726         in negate (widthToLlvmInt w) all0 LM_MO_Sub
 727
 728     MO_F_Neg w ->
 729         let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
 730         in negate (widthToLlvmFloat w) all0 LM_MO_FSub
 731
 732     MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
 733     MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
 734
 735     MO_SS_Conv from to
 736         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
 737
 738     MO_UU_Conv from to
 739         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
 740
 741     MO_FF_Conv from to
 742         -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
 743
 744     a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
 745
 746     where
 747         negate ty v2 negOp = do
 748             (env', vx, stmts, top) <- exprToVar env x
 749             (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
 750             return (env', v1, stmts `snocOL` s1, top)
 751
 752         fiConv ty convOp = do
 753             (env', vx, stmts, top) <- exprToVar env x
 754             (v1, s1) <- doExpr ty $ Cast convOp vx ty
 755             return (env', v1, stmts `snocOL` s1, top)
 756
 757         sameConv from ty reduce expand = do
 758             x'@(env', vx, stmts, top) <- exprToVar env x
 759             let sameConv' op = do
 760                 (v1, s1) <- doExpr ty $ Cast op vx ty
 761                 return (env', v1, stmts `snocOL` s1, top)
 762             let toWidth = llvmWidthInBits ty
 763             -- LLVM doesn't like trying to convert to same width, so
 764             -- need to check for that as we do get Cmm code doing it.
 765             case widthInBits from  of
 766                  w | w < toWidth -> sameConv' expand
 767                  w | w > toWidth -> sameConv' reduce
 768                  _w              -> return x'
 769
 770 -- Handle GlobalRegs pointers
 771 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
 772     = genMachOp_fast env opt o r (fromInteger n) e
 773
 774 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
 775     = genMachOp_fast env opt o r (negate . fromInteger $ n) e
 776
 777 -- Generic case
 778 genMachOp env opt op e = genMachOp_slow env opt op e
 779
 780
 781 -- | Handle CmmMachOp expressions
 782 -- This is a specialised method that handles Global register manipulations like
 783 -- 'Sp - 16', using the getelementptr instruction.
 784 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
 785                -> UniqSM ExprData
 786 genMachOp_fast env opt op r n e
 787   = let gr  = lmGlobalRegVar r
 788         grt = (pLower . getVarType) gr
 789         (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
 790     in case isPointer grt && rem == 0 of
 791             True -> do
 792                 (gv,  s1) <- doExpr grt $ Load gr
 793                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
 794                 (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
 795                 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
 796
 797             False -> genMachOp_slow env opt op e
 798
 799
 800 -- | Handle CmmMachOp expressions
 801 -- This handles all the cases not handle by the specialised genMachOp_fast.
 802 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
 803
 804 -- Binary MachOp
 805 genMachOp_slow env opt op [x, y] = case op of
 806
 807     MO_Eq _   -> genBinComp opt LM_CMP_Eq
 808     MO_Ne _   -> genBinComp opt LM_CMP_Ne
 809
 810     MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
 811     MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
 812     MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
 813     MO_S_Le _ -> genBinComp opt LM_CMP_Sle
 814
 815     MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
 816     MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
 817     MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
 818     MO_U_Le _ -> genBinComp opt LM_CMP_Ule
 819
 820     MO_Add _ -> genBinMach LM_MO_Add
 821     MO_Sub _ -> genBinMach LM_MO_Sub
 822     MO_Mul _ -> genBinMach LM_MO_Mul
 823
 824     MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
 825
 826     MO_S_MulMayOflo w -> isSMulOK w x y
 827
 828     MO_S_Quot _ -> genBinMach LM_MO_SDiv
 829     MO_S_Rem  _ -> genBinMach LM_MO_SRem
 830
 831     MO_U_Quot _ -> genBinMach LM_MO_UDiv
 832     MO_U_Rem  _ -> genBinMach LM_MO_URem
 833
 834     MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
 835     MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
 836     MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
 837     MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
 838     MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
 839     MO_F_Le _ -> genBinComp opt LM_CMP_Fle
 840
 841     MO_F_Add  _ -> genBinMach LM_MO_FAdd
 842     MO_F_Sub  _ -> genBinMach LM_MO_FSub
 843     MO_F_Mul  _ -> genBinMach LM_MO_FMul
 844     MO_F_Quot _ -> genBinMach LM_MO_FDiv
 845
 846     MO_And _   -> genBinMach LM_MO_And
 847     MO_Or  _   -> genBinMach LM_MO_Or
 848     MO_Xor _   -> genBinMach LM_MO_Xor
 849     MO_Shl _   -> genBinMach LM_MO_Shl
 850     MO_U_Shr _ -> genBinMach LM_MO_LShr
 851     MO_S_Shr _ -> genBinMach LM_MO_AShr
 852
 853     a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
 854
 855     where
 856         binLlvmOp ty binOp = do
 857             (env1, vx, stmts1, top1) <- exprToVar env x
 858             (env2, vy, stmts2, top2) <- exprToVar env1 y
 859             if getVarType vx == getVarType vy
 860                 then do
 861                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy
 862                     return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
 863                             top1 ++ top2)
 864
 865                 else do
 866                     -- XXX: Error. Continue anyway so we can debug the generated
 867                     -- ll file.
 868                     let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
 869                     let dx = Comment $ map fsLit $ cmmToStr x
 870                     let dy = Comment $ map fsLit $ cmmToStr y
 871                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy
 872                     let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
 873                                     `snocOL` dy `snocOL` s1
 874                     return (env2, v1, allStmts, top1 ++ top2)
 875
 876                     -- let o = case binOp vx vy of
 877                     --         Compare op _ _ -> show op
 878                     --         LlvmOp  op _ _ -> show op
 879                     --         _              -> "unknown"
 880                     -- panic $ "genMachOp: comparison between different types ("
 881                     --         ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
 882                     --         ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
 883                     --         ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
 884
 885         -- | Need to use EOption here as Cmm expects word size results from
 886         -- comparisons while LLVM return i1. Need to extend to llvmWord type
 887         -- if expected
 888         genBinComp opt cmp = do
 889             ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
 890
 891             if getVarType v1 == i1
 892                 then
 893                     case eoExpectedType opt of
 894                          Nothing ->
 895                              return ed
 896
 897                          Just t | t == i1 ->
 898                                     return ed
 899
 900                                 | isInt t -> do
 901                                     (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
 902                                     return (env', v2, stmts `snocOL` s1, top)
 903
 904                                 | otherwise ->
 905                                     panic $ "genBinComp: Can't case i1 compare"
 906                                         ++ "res to non int type " ++ show (t)
 907                 else
 908                     panic $ "genBinComp: Compare returned type other then i1! "
 909                         ++ (show $ getVarType v1)
 910
 911         genBinMach op = binLlvmOp getVarType (LlvmOp op)
 912
 913         -- | Detect if overflow will occur in signed multiply of the two
 914         -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
 915         -- implementation. Its much longer due to type information/safety.
 916         -- This should actually compile to only about 3 asm instructions.
 917         isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
 918         isSMulOK _ x y = do
 919             (env1, vx, stmts1, top1) <- exprToVar env x
 920             (env2, vy, stmts2, top2) <- exprToVar env1 y
 921
 922             let word  = getVarType vx
 923             let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
 924             let shift = llvmWidthInBits word
 925             let shift1 = toIWord (shift - 1)
 926             let shift2 = toIWord shift
 927
 928             if isInt word
 929                 then do
 930                     (x1, s1)     <- doExpr word2 $ Cast LM_Sext vx word2
 931                     (y1, s2)     <- doExpr word2 $ Cast LM_Sext vy word2
 932                     (r1, s3)     <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
 933                     (rlow1, s4)  <- doExpr word $ Cast LM_Trunc r1 word
 934                     (rlow2, s5)  <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
 935                     (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
 936                     (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
 937                     (dst, s8)    <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
 938                     let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
 939                             `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
 940                     return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
 941                         top1 ++ top2)
 942
 943                 else
 944                     panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
 945
 946 -- More then two expression, invalid!
 947 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
 948
 949
 950 -- | Handle CmmLoad expression.
 951 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
 952
 953 -- First we try to detect a few common cases and produce better code for
 954 -- these then the default case. We are mostly trying to detect Cmm code
 955 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
 956 -- generic case that uses casts and pointer arithmetic
 957 genLoad env e@(CmmReg (CmmGlobal r)) ty
 958     = genLoad_fast env e r 0 ty
 959
 960 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
 961     = genLoad_fast env e r n ty
 962
 963 genLoad env e@(CmmMachOp (MO_Add _) [
 964                             (CmmReg (CmmGlobal r)),
 965                             (CmmLit (CmmInt n _))])
 966                 ty
 967     = genLoad_fast env e r (fromInteger n) ty
 968
 969 genLoad env e@(CmmMachOp (MO_Sub _) [
 970                             (CmmReg (CmmGlobal r)),
 971                             (CmmLit (CmmInt n _))])
 972                 ty
 973     = genLoad_fast env e r (negate $ fromInteger n) ty
 974
 975 -- generic case
 976 genLoad env e ty = genLoad_slow env e ty
 977
 978 -- | Handle CmmLoad expression.
 979 -- This is a special case for loading from a global register pointer
 980 -- offset such as I32[Sp+8].
 981 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
 982                 -> UniqSM ExprData
 983 genLoad_fast env e r n ty =
 984     let gr  = lmGlobalRegVar r
 985         grt = (pLower . getVarType) gr
 986         ty' = cmmToLlvmType ty
 987         (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
 988     in case isPointer grt && rem == 0 of
 989             True  -> do
 990                 (gv,  s1) <- doExpr grt $ Load gr
 991                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
 992                 -- We might need a different pointer type, so check
 993                 case grt == ty' of
 994                      -- were fine
 995                      True -> do
 996                          (var, s3) <- doExpr ty' $ Load ptr
 997                          return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
 998                                      [])
 999
1000                      -- cast to pointer type needed
1001                      False -> do
1002                          let pty = pLift ty'
1003                          (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
1004                          (var, s4) <- doExpr ty' $ Load ptr'
1005                          return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
1006                                     `snocOL` s4, [])
1007
1008             -- If its a bit type then we use the slow method since
1009             -- we can't avoid casting anyway.
1010             False -> genLoad_slow env e ty
1011
1012
1013 -- | Handle Cmm load expression.
1014 -- Generic case. Uses casts and pointer arithmetic if needed.
1015 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
1016 genLoad_slow env e ty = do
1017     (env', iptr, stmts, tops) <- exprToVar env e
1018     case getVarType iptr of
1019          LMPointer _ -> do
1020                     (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
1021                     return (env', dvar, stmts `snocOL` load, tops)
1022
1023          i@(LMInt _) | i == llvmWord -> do
1024                     let pty = LMPointer $ cmmToLlvmType ty
1025                     (ptr, cast)  <- doExpr pty $ Cast LM_Inttoptr iptr pty
1026                     (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
1027                     return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
1028
1029          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
1030                         (PprCmm.pprExpr e <+> text (
1031                             "Size of Ptr: " ++ show llvmPtrBits ++
1032                             ", Size of var: " ++ show (llvmWidthInBits other) ++
1033                             ", Var: " ++ show iptr))
1034
1035
1036 -- | Handle CmmReg expression
1037 --
1038 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
1039 -- equivalent SSA form and avoids having to deal with Phi node insertion.
1040 -- This is also the approach recommended by LLVM developers.
1041 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
1042 getCmmReg env r@(CmmLocal (LocalReg un _))
1043   = let exists = varLookup un env
1044
1045         (newv, stmts) = allocReg r
1046         nenv = varInsert un (pLower $ getVarType newv) env
1047     in case exists of
1048             Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1049             Nothing  -> (nenv, newv, stmts, [])
1050
1051 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
1052
1053
1054 -- | Allocate a CmmReg on the stack
1055 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1056 allocReg (CmmLocal (LocalReg un ty))
1057   = let ty' = cmmToLlvmType ty
1058         var = LMLocalVar un (LMPointer ty')
1059         alc = Alloca ty' 1
1060     in (var, unitOL $ Assignment var alc)
1061
1062 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1063                     ++ " have been handled elsewhere!"
1064
1065
1066 -- | Generate code for a literal
1067 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
1068 genLit env (CmmInt i w)
1069   = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
1070
1071 genLit env (CmmFloat r w)
1072   = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1073               nilOL, [])
1074
1075 genLit env cmm@(CmmLabel l)
1076   = let label = strCLabel_llvm l
1077         ty = funLookup label env
1078         lmty = cmmToLlvmType $ cmmLitType cmm
1079     in case ty of
1080             -- Make generic external label definition and then pointer to it
1081             Nothing -> do
1082                 let glob@(var, _) = genStringLabelRef label
1083                 let ldata = [CmmData Data [([glob], [])]]
1084                 let env' = funInsert label (pLower $ getVarType var) env
1085                 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1086                 return (env', v1, unitOL s1, ldata)
1087
1088             -- Referenced data exists in this module, retrieve type and make
1089             -- pointer to it.
1090             Just ty' -> do
1091                 let var = LMGlobalVar label (LMPointer ty')
1092                             ExternallyVisible Nothing Nothing False
1093                 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1094                 return (env, v1, unitOL s1, [])
1095
1096 genLit env (CmmLabelOff label off) = do
1097     (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
1098     let voff = toIWord off
1099     (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1100     return (env', v1, stmts `snocOL` s1, stat)
1101
1102 genLit env (CmmLabelDiffOff l1 l2 off) = do
1103     (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
1104     (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
1105     let voff = toIWord off
1106     let ty1 = getVarType vl1
1107     let ty2 = getVarType vl2
1108     if (isInt ty1) && (isInt ty2)
1109        && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
1110
1111        then do
1112             (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1113             (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1114             return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1115                         stat1 ++ stat2)
1116
1117         else
1118             panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1119
1120 genLit env (CmmBlock b)
1121   = genLit env (CmmLabel $ infoTblLbl b)
1122
1123 genLit _ CmmHighStackMark
1124   = panic "genStaticLit - CmmHighStackMark unsupported!"
1125
1126
1127 -- -----------------------------------------------------------------------------
1128 -- * Misc
1129 --
1130
1131 -- | Function prologue. Load STG arguments into variables for function.
1132 funPrologue :: UniqSM [LlvmStatement]
1133 funPrologue = liftM concat $ mapM getReg activeStgRegs
1134     where getReg rr =
1135             let reg = lmGlobalRegVar rr
1136                 arg = lmGlobalRegArg rr
1137                 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1138             in return [alloc, Store arg reg]
1139
1140
1141 -- | Function epilogue. Load STG variables to use as argument for call.
1142 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
1143 funEpilogue = do
1144     let loadExpr r = do
1145         let reg = lmGlobalRegVar r
1146         (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1147         return (v, unitOL s)
1148     loads <- mapM loadExpr activeStgRegs
1149     let (vars, stmts) = unzip loads
1150     return (vars, concatOL stmts)
1151
1152
1153 -- | A serries of statements to trash all the STG registers.
1154 --
1155 -- In LLVM we pass the STG registers around everywhere in function calls.
1156 -- So this means LLVM considers them live across the entire function, when
1157 -- in reality they usually aren't. For Caller save registers across C calls
1158 -- the saving and restoring of them is done by the Cmm code generator,
1159 -- using Cmm local vars. So to stop LLVM saving them as well (and saving
1160 -- all of them since it thinks they're always live, we trash them just
1161 -- before the call by assigning the 'undef' value to them. The ones we
1162 -- need are restored from the Cmm local var and the ones we don't need
1163 -- are fine to be trashed.
1164 trashStmts :: LlvmStatements
1165 trashStmts = concatOL $ map trashReg activeStgRegs
1166     where trashReg r =
1167             let reg   = lmGlobalRegVar r
1168                 ty    = (pLower . getVarType) reg
1169                 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
1170             in case callerSaves r of
1171                       True  -> trash
1172                       False -> nilOL
1173
1174
1175 -- | Get a function pointer to the CLabel specified.
1176 --
1177 -- This is for Haskell functions, function type is assumed, so doesn't work
1178 -- with foreign functions.
1179 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
1180 getHsFunc env lbl
1181   = let fn = strCLabel_llvm lbl
1182         ty    = funLookup fn env
1183     in case ty of
1184         -- Function in module in right form
1185         Just ty'@(LMFunction sig) -> do
1186             let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1187             return (env, fun, nilOL, [])
1188
1189         -- label in module but not function pointer, convert
1190         Just ty' -> do
1191             let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1192                             Nothing Nothing False
1193             (v1, s1) <- doExpr (pLift llvmFunTy) $
1194                             Cast LM_Bitcast fun (pLift llvmFunTy)
1195             return (env, v1, unitOL s1, [])
1196
1197         -- label not in module, create external reference
1198         Nothing  -> do
1199             let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
1200             let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1201             let top = CmmData Data [([],[ty'])]
1202             let env' = funInsert fn ty' env
1203             return (env', fun, nilOL, [top])
1204
1205
1206 -- | Create a new local var
1207 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1208 mkLocalVar ty = do
1209     un <- getUniqueUs
1210     return $ LMLocalVar un ty
1211
1212
1213 -- | Execute an expression, assigning result to a var
1214 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1215 doExpr ty expr = do
1216     v <- mkLocalVar ty
1217     return (v, Assignment v expr)
1218
1219
1220 -- | Expand CmmRegOff
1221 expandCmmReg :: (CmmReg, Int) -> CmmExpr
1222 expandCmmReg (reg, off)
1223   = let width = typeWidth (cmmRegType reg)
1224         voff  = CmmLit $ CmmInt (fromIntegral off) width
1225     in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1226
1227
1228 -- | Convert a block id into a appropriate Llvm label
1229 blockIdToLlvm :: BlockId -> LlvmVar
1230 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1231
1232 -- | Create Llvm int Literal
1233 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1234 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1235
1236 -- | Convert int type to a LLvmVar of word or i32 size
1237 toI32, toIWord :: Integral a => a -> LlvmVar
1238 toI32 = mkIntLit i32
1239 toIWord = mkIntLit llvmWord
1240
1241
1242 -- | Error functions
1243 panic :: String -> a
1244 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1245
1246 pprPanic :: String -> SDoc -> a
1247 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
1248