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