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