compiler/llvmGen/LlvmCodeGen/CodeGen.hs

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