compiler/llvmGen/LlvmCodeGen/CodeGen.hs

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