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