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