compiler/llvmGen/LlvmCodeGen/CodeGen.hs

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