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