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 "sqrtf"
 355     MO_F32_Pwr    -> fsLit "powf"
 356
 357     MO_F32_Sin    -> fsLit "sinf"
 358     MO_F32_Cos    -> fsLit "cosf"
 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 "sqrt"
 372     MO_F64_Pwr    -> fsLit "pow"
 373
 374     MO_F64_Sin    -> fsLit "sin"
 375     MO_F64_Cos    -> fsLit "cos"
 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 s1 = Store vval vreg
 430     return (env2, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
 431
 432
 433 -- | CmmStore operation
 434 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
 435 genStore env addr val = do
 436     (env1, vaddr, stmts1, top1) <- exprToVar env addr
 437     (env2, vval,  stmts2, top2) <- exprToVar env1 val
 438     case getVarType vaddr of
 439         LMPointer _ -> do
 440             let s1 = Store vval vaddr
 441             return (env2, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
 442
 443         i@(LMInt _) | i == llvmWord -> do
 444             let vty = pLift $ getVarType vval
 445             (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
 446             let s2 = Store vval vptr
 447             return (env2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
 448                     top1 ++ top2)
 449
 450         other ->
 451             pprPanic "genStore: ptr not right type!"
 452                     (PprCmm.pprExpr addr <+> text (
 453                         "Size of Ptr: " ++ show llvmPtrBits ++
 454                         ", Size of var: " ++ show (llvmWidthInBits other) ++
 455                         ", Var: " ++ show vaddr))
 456
 457
 458 -- | Unconditional branch
 459 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
 460 genBranch env id =
 461     let label = blockIdToLlvm id
 462     in return (env, unitOL $ Branch label, [])
 463
 464
 465 -- | Conditional branch
 466 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
 467 genCondBranch env cond idT = do
 468     idF <- getUniqueUs
 469     let labelT = blockIdToLlvm idT
 470     let labelF = LMLocalVar idF LMLabel
 471     (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
 472     if getVarType vc == i1
 473         then do
 474             let s1 = BranchIf vc labelT labelF
 475             let s2 = MkLabel idF
 476             return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
 477         else
 478             panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
 479
 480
 481 -- | Switch branch
 482 --
 483 -- N.B. we remove Nothing's from the list of branches, as they are 'undefined'.
 484 -- However, they may be defined one day, so we better document this behaviour.
 485 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
 486 genSwitch env cond maybe_ids = do
 487     (env', vc, stmts, top) <- exprToVar env cond
 488     let ty = getVarType vc
 489
 490     let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
 491     let labels = map (\(ix, b) -> (mkIntLit ix ty, blockIdToLlvm b)) pairs
 492     -- out of range is undefied, so lets just branch to first label
 493     let (_, defLbl) = head labels
 494
 495     let s1 = Switch vc defLbl labels
 496     return $ (env', stmts `snocOL` s1, top)
 497
 498
 499 -- -----------------------------------------------------------------------------
 500 -- * CmmExpr code generation
 501 --
 502
 503 -- | An expression conversion return data:
 504 --   * LlvmEnv: The new enviornment
 505 --   * LlvmVar: The var holding the result of the expression
 506 --   * LlvmStatements: Any statements needed to evaluate the expression
 507 --   * LlvmCmmTop: Any global data needed for this expression
 508 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
 509
 510 -- | Values which can be passed to 'exprToVar' to configure its
 511 -- behaviour in certain circumstances.
 512 data EOption = EOption {
 513         -- | The expected LlvmType for the returned variable.
 514         --
 515         -- Currently just used for determining if a comparison should return
 516         -- a boolean (i1) or a int (i32/i64).
 517         eoExpectedType :: Maybe LlvmType
 518   }
 519
 520 i1Option :: EOption
 521 i1Option = EOption (Just i1)
 522
 523 wordOption :: EOption
 524 wordOption = EOption (Just llvmWord)
 525
 526
 527 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
 528 -- expression being stored in the returned LlvmVar.
 529 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
 530 exprToVar env = exprToVarOpt env wordOption
 531
 532 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
 533 exprToVarOpt env opt e = case e of
 534
 535     CmmLit lit
 536         -> genLit env lit
 537
 538     CmmLoad e' ty
 539         -> genCmmLoad env e' ty
 540
 541     -- Cmmreg in expression is the value, so must load. If you want actual
 542     -- reg pointer, call getCmmReg directly.
 543     CmmReg r -> do
 544         let (env', vreg, stmts, top) = getCmmReg env r
 545         (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
 546         return (env', v1, stmts `snocOL` s1 , top)
 547
 548     CmmMachOp op exprs
 549         -> genMachOp env opt op exprs
 550
 551     CmmRegOff r i
 552         -> exprToVar env $ expandCmmReg (r, i)
 553
 554     CmmStackSlot _ _
 555         -> panic "exprToVar: CmmStackSlot not supported!"
 556
 557
 558 -- | Handle CmmMachOp expressions
 559 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
 560
 561 -- Unary Machop
 562 genMachOp env _ op [x] = case op of
 563
 564     MO_Not w ->
 565         let all1 = mkIntLit (-1::Int) (widthToLlvmInt w)
 566         in negate (widthToLlvmInt w) all1 LM_MO_Xor
 567
 568     MO_S_Neg w ->
 569         let all0 = mkIntLit (0::Int) (widthToLlvmInt w)
 570         in negate (widthToLlvmInt w) all0 LM_MO_Sub
 571
 572     MO_F_Neg w ->
 573         let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
 574         in negate (widthToLlvmFloat w) all0 LM_MO_FSub
 575
 576     MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
 577     MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
 578
 579     MO_SS_Conv from to
 580         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
 581
 582     MO_UU_Conv from to
 583         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
 584
 585     MO_FF_Conv from to
 586         -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
 587
 588     a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
 589
 590     where
 591         negate ty v2 negOp = do
 592             (env', vx, stmts, top) <- exprToVar env x
 593             (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
 594             return (env', v1, stmts `snocOL` s1, top)
 595
 596         fiConv ty convOp = do
 597             (env', vx, stmts, top) <- exprToVar env x
 598             (v1, s1) <- doExpr ty $ Cast convOp vx ty
 599             return (env', v1, stmts `snocOL` s1, top)
 600
 601         sameConv from ty reduce expand = do
 602             x'@(env', vx, stmts, top) <- exprToVar env x
 603             let sameConv' op = do
 604                 (v1, s1) <- doExpr ty $ Cast op vx ty
 605                 return (env', v1, stmts `snocOL` s1, top)
 606             let toWidth = llvmWidthInBits ty
 607             -- LLVM doesn't like trying to convert to same width, so
 608             -- need to check for that as we do get cmm code doing it.
 609             case widthInBits from  of
 610                  w | w < toWidth -> sameConv' expand
 611                  w | w > toWidth -> sameConv' reduce
 612                  _w              -> return x'
 613
 614
 615 -- Binary MachOp
 616 genMachOp env opt op [x, y] = case op of
 617
 618     MO_Eq _   -> genBinComp opt LM_CMP_Eq
 619     MO_Ne _   -> genBinComp opt LM_CMP_Ne
 620
 621     MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
 622     MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
 623     MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
 624     MO_S_Le _ -> genBinComp opt LM_CMP_Sle
 625
 626     MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
 627     MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
 628     MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
 629     MO_U_Le _ -> genBinComp opt LM_CMP_Ule
 630
 631     MO_Add _ -> genBinMach LM_MO_Add
 632     MO_Sub _ -> genBinMach LM_MO_Sub
 633     MO_Mul _ -> genBinMach LM_MO_Mul
 634
 635     MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
 636
 637     MO_S_MulMayOflo w -> isSMulOK w x y
 638
 639     MO_S_Quot _ -> genBinMach LM_MO_SDiv
 640     MO_S_Rem  _ -> genBinMach LM_MO_SRem
 641
 642     MO_U_Quot _ -> genBinMach LM_MO_UDiv
 643     MO_U_Rem  _ -> genBinMach LM_MO_URem
 644
 645     MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
 646     MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
 647     MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
 648     MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
 649     MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
 650     MO_F_Le _ -> genBinComp opt LM_CMP_Fle
 651
 652     MO_F_Add  _ -> genBinMach LM_MO_FAdd
 653     MO_F_Sub  _ -> genBinMach LM_MO_FSub
 654     MO_F_Mul  _ -> genBinMach LM_MO_FMul
 655     MO_F_Quot _ -> genBinMach LM_MO_FDiv
 656
 657     MO_And _   -> genBinMach LM_MO_And
 658     MO_Or  _   -> genBinMach LM_MO_Or
 659     MO_Xor _   -> genBinMach LM_MO_Xor
 660     MO_Shl _   -> genBinMach LM_MO_Shl
 661     MO_U_Shr _ -> genBinMach LM_MO_LShr
 662     MO_S_Shr _ -> genBinMach LM_MO_AShr
 663
 664     a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
 665
 666     where
 667         binLlvmOp ty binOp = do
 668             (env1, vx, stmts1, top1) <- exprToVar env x
 669             (env2, vy, stmts2, top2) <- exprToVar env1 y
 670             if getVarType vx == getVarType vy
 671                 then do
 672                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy
 673                     return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
 674                             top1 ++ top2)
 675
 676                 else do
 677                     -- XXX: Error. Continue anyway so we can debug the generated
 678                     -- ll file.
 679                     let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
 680                     let dx = Comment $ map fsLit $ cmmToStr x
 681                     let dy = Comment $ map fsLit $ cmmToStr y
 682                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy
 683                     let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
 684                                     `snocOL` dy `snocOL` s1
 685                     return (env2, v1, allStmts, top1 ++ top2)
 686
 687                     -- let o = case binOp vx vy of
 688                     --         Compare op _ _ -> show op
 689                     --         LlvmOp  op _ _ -> show op
 690                     --         _              -> "unknown"
 691                     -- panic $ "genMachOp: comparison between different types ("
 692                     --         ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
 693                     --         ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
 694                     --         ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
 695
 696         -- | Need to use EOption here as Cmm expects word size results from
 697         -- comparisons while llvm return i1. Need to extend to llvmWord type
 698         -- if expected
 699         genBinComp opt cmp = do
 700             ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
 701
 702             if getVarType v1 == i1
 703                 then
 704                     case eoExpectedType opt of
 705                          Nothing ->
 706                              return ed
 707
 708                          Just t | t == i1 ->
 709                                     return ed
 710
 711                                 | isInt t -> do
 712                                     (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
 713                                     return (env', v2, stmts `snocOL` s1, top)
 714
 715                                 | otherwise ->
 716                                     panic $ "genBinComp: Can't case i1 compare"
 717                                         ++ "res to non int type " ++ show (t)
 718                 else
 719                     panic $ "genBinComp: Compare returned type other then i1! "
 720                         ++ (show $ getVarType v1)
 721
 722         genBinMach op = binLlvmOp getVarType (LlvmOp op)
 723
 724         -- | Detect if overflow will occur in signed multiply of the two
 725         -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
 726         -- implementation. Its much longer due to type information/safety.
 727         -- This should actually compile to only about 3 asm instructions.
 728         isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
 729         isSMulOK _ x y = do
 730             (env1, vx, stmts1, top1) <- exprToVar env x
 731             (env2, vy, stmts2, top2) <- exprToVar env1 y
 732
 733             let word  = getVarType vx
 734             let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
 735             let shift = llvmWidthInBits word
 736             let shift1 = mkIntLit (shift - 1) llvmWord
 737             let shift2 = mkIntLit shift llvmWord
 738
 739             if isInt word
 740                 then do
 741                     (x1, s1)     <- doExpr word2 $ Cast LM_Sext vx word2
 742                     (y1, s2)     <- doExpr word2 $ Cast LM_Sext vy word2
 743                     (r1, s3)     <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
 744                     (rlow1, s4)  <- doExpr word $ Cast LM_Trunc r1 word
 745                     (rlow2, s5)  <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
 746                     (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
 747                     (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
 748                     (dst, s8)    <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
 749                     let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
 750                             `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
 751                     return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
 752                         top1 ++ top2)
 753
 754                 else
 755                     panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
 756
 757
 758 -- More then two expression, invalid!
 759 genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
 760
 761
 762 -- | Handle CmmLoad expression
 763 genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
 764 genCmmLoad env e ty = do
 765     (env', iptr, stmts, tops) <- exprToVar env e
 766     case getVarType iptr of
 767          LMPointer _ -> do
 768                     (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
 769                     return (env', dvar, stmts `snocOL` load, tops)
 770
 771          i@(LMInt _) | i == llvmWord -> do
 772                     let pty = LMPointer $ cmmToLlvmType ty
 773                     (ptr, cast)  <- doExpr pty $ Cast LM_Inttoptr iptr pty
 774                     (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
 775                     return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
 776
 777          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
 778                         (PprCmm.pprExpr e <+> text (
 779                             "Size of Ptr: " ++ show llvmPtrBits ++
 780                             ", Size of var: " ++ show (llvmWidthInBits other) ++
 781                             ", Var: " ++ show iptr))
 782
 783
 784 -- | Handle CmmReg expression
 785 --
 786 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
 787 -- equivalent SSA form and avoids having to deal with Phi node insertion.
 788 -- This is also the approach recommended by llvm developers.
 789 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
 790 getCmmReg env r@(CmmLocal (LocalReg un _))
 791   = let exists = varLookup un env
 792
 793         (newv, stmts) = allocReg r
 794         nenv = varInsert un (pLower $ getVarType newv) env
 795     in case exists of
 796             Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
 797             Nothing  -> (nenv, newv, stmts, [])
 798
 799 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
 800
 801
 802 -- | Allocate a CmmReg on the stack
 803 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
 804 allocReg (CmmLocal (LocalReg un ty))
 805   = let ty' = cmmToLlvmType ty
 806         var = LMLocalVar un (LMPointer ty')
 807         alc = Alloca ty' 1
 808     in (var, unitOL $ Assignment var alc)
 809
 810 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
 811                     ++ " have been handled elsewhere!"
 812
 813
 814 -- | Generate code for a literal
 815 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
 816 genLit env (CmmInt i w)
 817   = return (env, mkIntLit i (LMInt $ widthInBits w), nilOL, [])
 818
 819 genLit env (CmmFloat r w)
 820   = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
 821               nilOL, [])
 822
 823 genLit env cmm@(CmmLabel l)
 824   = let label = strCLabel_llvm l
 825         ty = funLookup label env
 826         lmty = cmmToLlvmType $ cmmLitType cmm
 827     in case ty of
 828             -- Make generic external label defenition and then pointer to it
 829             Nothing -> do
 830                 let glob@(var, _) = genStringLabelRef label
 831                 let ldata = [CmmData Data [([glob], [])]]
 832                 let env' = funInsert label (pLower $ getVarType var) env
 833                 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
 834                 return (env', v1, unitOL s1, ldata)
 835             -- Referenced data exists in this module, retrieve type and make
 836             -- pointer to it.
 837             Just ty' -> do
 838                 let var = LMGlobalVar label (LMPointer ty')
 839                             ExternallyVisible Nothing Nothing False
 840                 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
 841                 return (env, v1, unitOL s1, [])
 842
 843 genLit env (CmmLabelOff label off) = do
 844     (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
 845     let voff = mkIntLit off llvmWord
 846     (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
 847     return (env', v1, stmts `snocOL` s1, stat)
 848
 849 genLit env (CmmLabelDiffOff l1 l2 off) = do
 850     (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
 851     (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
 852     let voff = mkIntLit off llvmWord
 853     let ty1 = getVarType vl1
 854     let ty2 = getVarType vl2
 855     if (isInt ty1) && (isInt ty2)
 856        && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
 857
 858        then do
 859             (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
 860             (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
 861             return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
 862                         stat1 ++ stat2)
 863
 864         else
 865             panic "genLit: CmmLabelDiffOff encountered with different label ty!"
 866
 867 genLit env (CmmBlock b)
 868   = genLit env (CmmLabel $ infoTblLbl b)
 869
 870 genLit _ CmmHighStackMark
 871   = panic "genStaticLit - CmmHighStackMark unsupported!"
 872
 873
 874 -- -----------------------------------------------------------------------------
 875 -- * Misc
 876 --
 877
 878 -- | Function prologue. Load STG arguments into variables for function.
 879 funPrologue :: UniqSM [LlvmStatement]
 880 funPrologue = liftM concat $ mapM getReg activeStgRegs
 881     where getReg rr =
 882             let reg = lmGlobalRegVar rr
 883                 arg = lmGlobalRegArg rr
 884                 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
 885             in if (isPointer . getVarType) arg
 886                   then do
 887                       (v, c) <- doExpr llvmWord (Cast LM_Ptrtoint arg llvmWord)
 888                       let store = Store v reg
 889                       return [alloc, c, store]
 890                   else do
 891                       let store = Store arg reg
 892                       return [alloc, store]
 893
 894
 895 -- | Function epilogue. Load STG variables to use as argument for call.
 896 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
 897 funEpilogue = do
 898     let loadExpr r = do
 899         let reg = lmGlobalRegVar r
 900         let arg = lmGlobalRegArg r
 901         (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
 902         case (isPointer . getVarType) arg of
 903              True  -> do
 904                  (v2, s2) <- doExpr llvmWordPtr $ Cast LM_Inttoptr v llvmWordPtr
 905                  return (v2, unitOL s `snocOL` s2)
 906              False -> return (v, unitOL s)
 907     loads <- mapM loadExpr activeStgRegs
 908     let (vars, stmts) = unzip loads
 909     return (vars, concatOL stmts)
 910
 911
 912 -- | Get a function pointer to the CLabel specified.
 913 --
 914 -- This is for Haskell functions, function type is assumed, so doesn't work
 915 -- with foreign functions.
 916 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
 917 getHsFunc env lbl
 918   = let fn = strCLabel_llvm lbl
 919         ty    = funLookup fn env
 920     in case ty of
 921         Just ty'@(LMFunction sig) -> do
 922         -- Function in module in right form
 923             let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
 924             return (env, fun, nilOL, [])
 925         Just ty' -> do
 926         -- label in module but not function pointer, convert
 927             let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
 928                             Nothing Nothing False
 929             (v1, s1) <- doExpr (pLift llvmFunTy) $
 930                             Cast LM_Bitcast fun (pLift llvmFunTy)
 931             return (env, v1, unitOL s1, [])
 932         Nothing  -> do
 933         -- label not in module, create external reference
 934             let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
 935             let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
 936             let top = CmmData Data [([],[ty'])]
 937             let env' = funInsert fn ty' env
 938             return (env', fun, nilOL, [top])
 939
 940
 941 -- | Create a new local var
 942 mkLocalVar :: LlvmType -> UniqSM LlvmVar
 943 mkLocalVar ty = do
 944     un <- getUniqueUs
 945     return $ LMLocalVar un ty
 946
 947
 948 -- | Execute an expression, assigning result to a var
 949 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
 950 doExpr ty expr = do
 951     v <- mkLocalVar ty
 952     return (v, Assignment v expr)
 953
 954
 955 -- | Expand CmmRegOff
 956 expandCmmReg :: (CmmReg, Int) -> CmmExpr
 957 expandCmmReg (reg, off)
 958   = let width = typeWidth (cmmRegType reg)
 959         voff  = CmmLit $ CmmInt (fromIntegral off) width
 960     in CmmMachOp (MO_Add width) [CmmReg reg, voff]
 961
 962
 963 -- | Convert a block id into a appropriate Llvm label
 964 blockIdToLlvm :: BlockId -> LlvmVar
 965 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
 966
 967
 968 -- | Create Llvm int Literal
 969 mkIntLit :: Integral a => a -> LlvmType -> LlvmVar
 970 mkIntLit i ty = LMLitVar $ LMIntLit (toInteger i) ty
 971
 972
 973 -- | Error functions
 974 panic :: String -> a
 975 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
 976
 977 pprPanic :: String -> SDoc -> a
 978 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
 979