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