Commit 93d6c9d5 authored by dterei's avatar dterei

Add new mem{cpy,set,move} cmm prim ops.

parent 5fb59c02
...@@ -459,7 +459,15 @@ data CallishMachOp ...@@ -459,7 +459,15 @@ data CallishMachOp
| MO_F32_Sqrt | MO_F32_Sqrt
| MO_WriteBarrier | MO_WriteBarrier
| MO_Touch -- Keep variables live (when using interior pointers) | MO_Touch -- Keep variables live (when using interior pointers)
-- Note that these three MachOps all take 1 extra parameter than the
-- standard C lib versions. The extra (last) parameter contains
-- alignment of the pointers. Used for optimisation in backends.
| MO_Memcpy
| MO_Memset
| MO_Memmove
deriving (Eq, Show) deriving (Eq, Show)
pprCallishMachOp :: CallishMachOp -> SDoc pprCallishMachOp :: CallishMachOp -> SDoc
pprCallishMachOp mo = text (show mo) pprCallishMachOp mo = text (show mo)
...@@ -735,7 +735,10 @@ machOps = listToUFM $ ...@@ -735,7 +735,10 @@ machOps = listToUFM $
callishMachOps = listToUFM $ callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [ map (\(x, y) -> (mkFastString x, y)) [
( "write_barrier", MO_WriteBarrier ) ( "write_barrier", MO_WriteBarrier ),
( "memcpy", MO_Memcpy ),
( "memset", MO_Memset ),
( "memmove", MO_Memmove )
-- ToDo: the rest, maybe -- ToDo: the rest, maybe
] ]
......
...@@ -132,6 +132,12 @@ data LlvmStatement ...@@ -132,6 +132,12 @@ data LlvmStatement
-} -}
| Expr LlvmExpression | Expr LlvmExpression
{- |
A nop LLVM statement. Useful as its often more efficient to use this
then to wrap LLvmStatement in a Just or [].
-}
| Nop
deriving (Show, Eq) deriving (Show, Eq)
......
...@@ -161,6 +161,7 @@ ppLlvmStatement stmt ...@@ -161,6 +161,7 @@ ppLlvmStatement stmt
Return result -> ppReturn result Return result -> ppReturn result
Expr expr -> ppLlvmExpression expr Expr expr -> ppLlvmExpression expr
Unreachable -> text "unreachable" Unreachable -> text "unreachable"
Nop -> empty
-- | Print out an LLVM expression. -- | Print out an LLVM expression.
......
...@@ -28,7 +28,9 @@ import Outputable ...@@ -28,7 +28,9 @@ import Outputable
import qualified Pretty as Prt import qualified Pretty as Prt
import UniqSupply import UniqSupply
import Util import Util
import SysTools ( figureLlvmVersion )
import Data.Maybe ( fromMaybe )
import System.IO import System.IO
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
...@@ -48,8 +50,9 @@ llvmCodeGen dflags h us cmms ...@@ -48,8 +50,9 @@ llvmCodeGen dflags h us cmms
in do in do
bufh <- newBufHandle h bufh <- newBufHandle h
Prt.bufLeftRender bufh $ pprLlvmHeader Prt.bufLeftRender bufh $ pprLlvmHeader
ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
env' <- cmmDataLlvmGens dflags bufh env cdata []
env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
cmmProcLlvmGens dflags bufh us env' cmm 1 [] cmmProcLlvmGens dflags bufh us env' cmm 1 []
bFlush bufh bFlush bufh
......
...@@ -9,8 +9,10 @@ module LlvmCodeGen.Base ( ...@@ -9,8 +9,10 @@ module LlvmCodeGen.Base (
LlvmCmmTop, LlvmBasicBlock, LlvmCmmTop, LlvmBasicBlock,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic, LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmVersion, defaultLlvmVersion,
LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
funLookup, funInsert, funLookup, funInsert, getLlvmVer, setLlvmVer,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
...@@ -128,33 +130,50 @@ tysToParams = map (\ty -> (ty, [])) ...@@ -128,33 +130,50 @@ tysToParams = map (\ty -> (ty, []))
llvmPtrBits :: Int llvmPtrBits :: Int
llvmPtrBits = widthInBits $ typeWidth gcWord llvmPtrBits = widthInBits $ typeWidth gcWord
-- ----------------------------------------------------------------------------
-- * Llvm Version
--
-- | LLVM Version Number
type LlvmVersion = Int
-- | The LLVM Version we assume if we don't know
defaultLlvmVersion :: LlvmVersion
defaultLlvmVersion = 28
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- * Environment Handling -- * Environment Handling
-- --
type LlvmEnvMap = UniqFM LlvmType
-- two maps, one for functions and one for local vars. -- two maps, one for functions and one for local vars.
type LlvmEnv = (LlvmEnvMap, LlvmEnvMap) newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion)
type LlvmEnvMap = UniqFM LlvmType
-- | Get initial Llvm environment. -- | Get initial Llvm environment.
initLlvmEnv :: LlvmEnv initLlvmEnv :: LlvmEnv
initLlvmEnv = (emptyUFM, emptyUFM) initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion)
-- | Clear variables from the environment. -- | Clear variables from the environment.
clearVars :: LlvmEnv -> LlvmEnv clearVars :: LlvmEnv -> LlvmEnv
clearVars (e1, _) = (e1, emptyUFM) clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n)
-- | Insert functions into the environment. -- | Insert functions into the environment.
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
varInsert s t (e1, e2) = (e1, addToUFM e2 s t) varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n)
funInsert s t (e1, e2) = (addToUFM e1 s t, e2) funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n)
-- | Lookup functions in the environment. -- | Lookup functions in the environment.
varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
varLookup s (_, e2) = lookupUFM e2 s varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 s
funLookup s (e1, _) = lookupUFM e1 s funLookup s (LlvmEnv (e1, _, _)) = lookupUFM e1 s
-- | Get the LLVM version we are generating code for
getLlvmVer :: LlvmEnv -> LlvmVersion
getLlvmVer (LlvmEnv (_, _, n)) = n
-- | Set the LLVM version we are generating code for
setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
setLlvmVer n (LlvmEnv (e1, e2, _)) = LlvmEnv (e1, e2, n)
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- * Label handling -- * Label handling
......
{-# OPTIONS -fno-warn-type-defaults #-}
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- | Handle conversion of CmmProc to LLVM code. -- | Handle conversion of CmmProc to LLVM code.
-- --
...@@ -17,7 +18,6 @@ import OldCmm ...@@ -17,7 +18,6 @@ import OldCmm
import qualified OldPprCmm as PprCmm import qualified OldPprCmm as PprCmm
import OrdList import OrdList
import BasicTypes
import FastString import FastString
import ForeignCall import ForeignCall
import Outputable hiding ( panic, pprPanic ) import Outputable hiding ( panic, pprPanic )
...@@ -175,9 +175,31 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do ...@@ -175,9 +175,31 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
where where
lmTrue :: LlvmVar lmTrue :: LlvmVar
lmTrue = LMLitVar $ LMIntLit (-1) i1 lmTrue = mkIntLit i1 (-1)
#endif #endif
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
op == MO_Memset ||
op == MO_Memmove = do
let (isVolTy, isVolVal) = if getLlvmVer env >= 28
then ([i1], [mkIntLit i1 0]) else ([], [])
argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy
| otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
(env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
(env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
(argVars', stmts3) <- castVars $ zip argVars argTy
let arguments = argVars' ++ isVolVal
call = Expr $ Call StdCall fptr arguments []
stmts = stmts1 `appOL` stmts2 `appOL` stmts3
`appOL` trashStmts `snocOL` call
return (env2, stmts, top1 ++ top2)
-- Handle all other foreign calls and prim ops. -- Handle all other foreign calls and prim ops.
genCall env target res args ret = do genCall env target res args ret = do
...@@ -225,91 +247,17 @@ genCall env target res args ret = do ...@@ -225,91 +247,17 @@ genCall env target res args ret = do
let ccTy = StdCall -- tail calls should be done through CmmJump let ccTy = StdCall -- tail calls should be done through CmmJump
let retTy = ret_type res let retTy = ret_type res
let argTy = tysToParams $ map arg_type args let argTy = tysToParams $ map arg_type args
let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
lmconv retTy FixedArgs argTy llvmFunAlign lmconv retTy FixedArgs argTy llvmFunAlign
-- get parameter values
(env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
-- get the return register (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
let ret_reg ([CmmHinted reg hint]) = (reg, hint) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target
ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
++ " 1, given " ++ show (length t) ++ "."
-- deal with call types
let getFunPtr :: CmmCallTarget -> UniqSM ExprData
getFunPtr targ = case targ of
CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
let name = strCLabel_llvm lbl
case funLookup name env1 of
Just ty'@(LMFunction sig) -> do
-- Function in module in right form
let fun = LMGlobalVar name ty' (funcLinkage sig)
Nothing Nothing False
return (env1, fun, nilOL, [])
Just ty' -> do
-- label in module but not function pointer, convert
let fty@(LMFunction sig) = funTy name
let fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
Nothing Nothing False
(v1, s1) <- doExpr (pLift fty)
$ Cast LM_Bitcast fun (pLift fty)
return (env1, v1, unitOL s1, [])
Nothing -> do
-- label not in module, create external reference
let fty@(LMFunction sig) = funTy name
let fun = LMGlobalVar name fty (funcLinkage sig)
Nothing Nothing False
let top = CmmData Data [([],[fty])]
let env' = funInsert name fty env1
return (env', fun, nilOL, [top])
CmmCallee expr _ -> do
(env', v1, stmts, top) <- exprToVar env1 expr
let fty = funTy $ fsLit "dynamic"
let cast = case getVarType v1 of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
ty -> panic $ "genCall: Expr is of bad type for function"
++ " call! (" ++ show (ty) ++ ")"
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
return (env', v2, stmts `snocOL` s1, top)
CmmPrim mop -> do
let name = cmmPrimOpFunctions mop
let lbl = mkForeignLabel name Nothing
ForeignLabelInExternalPackage IsFunction
getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
(env2, fptr, stmts2, top2) <- getFunPtr target
let retStmt | ccTy == TailCall = unitOL $ Return Nothing let retStmt | ccTy == TailCall = unitOL $ Return Nothing
| ret == CmmNeverReturns = unitOL $ Unreachable | ret == CmmNeverReturns = unitOL $ Unreachable
| otherwise = nilOL | otherwise = nilOL
{- In LLVM we pass the STG registers around everywhere in function calls.
So this means LLVM considers them live across the entire function, when
in reality they usually aren't. For Caller save registers across C calls
the saving and restoring of them is done by the Cmm code generator,
using Cmm local vars. So to stop LLVM saving them as well (and saving
all of them since it thinks they're always live, we trash them just
before the call by assigning the 'undef' value to them. The ones we
need are restored from the Cmm local var and the ones we don't need
are fine to be trashed.
-}
let trashStmts = concatOL $ map trashReg activeStgRegs
where trashReg r =
let reg = lmGlobalRegVar r
ty = (pLower . getVarType) reg
trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
in case callerSaves r of
True -> trash
False -> nilOL
let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
-- make the actual call -- make the actual call
...@@ -321,6 +269,10 @@ genCall env target res args ret = do ...@@ -321,6 +269,10 @@ genCall env target res args ret = do
_ -> do _ -> do
(v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
-- get the return register
let ret_reg ([CmmHinted reg hint]) = (reg, hint)
ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
++ " 1, given " ++ show (length t) ++ "."
let (creg, _) = ret_reg res let (creg, _) = ret_reg res
let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
let allStmts = stmts `snocOL` s1 `appOL` stmts3 let allStmts = stmts `snocOL` s1 `appOL` stmts3
...@@ -344,6 +296,55 @@ genCall env target res args ret = do ...@@ -344,6 +296,55 @@ genCall env target res args ret = do
`appOL` retStmt, top1 ++ top2 ++ top3) `appOL` retStmt, top1 ++ top2 ++ top3)
-- | Create a function pointer from a target.
getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
-> UniqSM ExprData
getFunPtr env funTy targ = case targ of
CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm lbl
CmmCallee expr _ -> do
(env', v1, stmts, top) <- exprToVar env expr
let fty = funTy $ fsLit "dynamic"
cast = case getVarType v1 of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
ty -> panic $ "genCall: Expr is of bad type for function"
++ " call! (" ++ show (ty) ++ ")"
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
return (env', v2, stmts `snocOL` s1, top)
CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop
where
litCase name = do
case funLookup name env of
Just ty'@(LMFunction sig) -> do
-- Function in module in right form
let fun = LMGlobalVar name ty' (funcLinkage sig)
Nothing Nothing False
return (env, fun, nilOL, [])
Just ty' -> do
-- label in module but not function pointer, convert
let fty@(LMFunction sig) = funTy name
fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
Nothing Nothing False
(v1, s1) <- doExpr (pLift fty)
$ Cast LM_Bitcast fun (pLift fty)
return (env, v1, unitOL s1, [])
Nothing -> do
-- label not in module, create external reference
let fty@(LMFunction sig) = funTy name
fun = LMGlobalVar name fty (funcLinkage sig)
Nothing Nothing False
top = [CmmData Data [([],[fty])]]
env' = funInsert name fty env
return (env', fun, nilOL, top)
-- | Conversion of call arguments. -- | Conversion of call arguments.
arg_vars :: LlvmEnv arg_vars :: LlvmEnv
-> HintedCmmActuals -> HintedCmmActuals
...@@ -370,9 +371,41 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) ...@@ -370,9 +371,41 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
= do (env', v1, stmts', top') <- exprToVar env e = do (env', v1, stmts', top') <- exprToVar env e
arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
-- | Cast a collection of LLVM variables to specific types.
castVars :: [(LlvmVar, LlvmType)]
-> UniqSM ([LlvmVar], LlvmStatements)
castVars vars = do
done <- mapM (uncurry castVar) vars
let (vars', stmts) = unzip done
return (vars', toOL stmts)
-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
castVar v t | getVarType v == t
= return (v, Nop)
| otherwise
= let op = case (getVarType v, t) of
(LMInt n, LMInt m)
-> if n < m then LM_Sext else LM_Trunc
(vt, _) | isFloat vt && isFloat t
-> if llvmWidthInBits vt < llvmWidthInBits t
then LM_Fpext else LM_Fptrunc
(vt, _) | isInt vt && isFloat t -> LM_Sitofp
(vt, _) | isFloat vt && isInt t -> LM_Fptosi
(vt, _) | isInt vt && isPointer t -> LM_Inttoptr
(vt, _) | isPointer vt && isInt t -> LM_Ptrtoint
(vt, _) | isPointer vt && isPointer t -> LM_Bitcast
(vt, _) -> panic $ "castVars: Can't cast this type ("
++ show vt ++ ") to (" ++ show t ++ ")"
in doExpr t $ Cast op v t
-- | Decide what C function to use to implement a CallishMachOp -- | Decide what C function to use to implement a CallishMachOp
cmmPrimOpFunctions :: CallishMachOp -> FastString cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
cmmPrimOpFunctions mop cmmPrimOpFunctions env mop
= case mop of = case mop of
MO_F32_Exp -> fsLit "expf" MO_F32_Exp -> fsLit "expf"
MO_F32_Log -> fsLit "logf" MO_F32_Log -> fsLit "logf"
...@@ -408,8 +441,18 @@ cmmPrimOpFunctions mop ...@@ -408,8 +441,18 @@ cmmPrimOpFunctions mop
MO_F64_Cosh -> fsLit "cosh" MO_F64_Cosh -> fsLit "cosh"
MO_F64_Tanh -> fsLit "tanh" MO_F64_Tanh -> fsLit "tanh"
MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1
MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")" a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
where
intrinTy1 = (if getLlvmVer env >= 28
then "p0i8.p0i8." else "") ++ show llvmWord
intrinTy2 = (if getLlvmVer env >= 28
then "p0i8." else "") ++ show llvmWord
-- | Tail function calls -- | Tail function calls
genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
...@@ -594,7 +637,7 @@ genSwitch env cond maybe_ids = do ...@@ -594,7 +637,7 @@ genSwitch env cond maybe_ids = do
(env', vc, stmts, top) <- exprToVar env cond (env', vc, stmts, top) <- exprToVar env cond
let ty = getVarType vc let ty = getVarType vc
let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ] let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
-- out of range is undefied, so lets just branch to first label -- out of range is undefied, so lets just branch to first label
let (_, defLbl) = head labels let (_, defLbl) = head labels
...@@ -675,11 +718,11 @@ genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData ...@@ -675,11 +718,11 @@ genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
genMachOp env _ op [x] = case op of genMachOp env _ op [x] = case op of
MO_Not w -> MO_Not w ->
let all1 = mkIntLit (widthToLlvmInt w) (-1::Int) let all1 = mkIntLit (widthToLlvmInt w) (-1)
in negate (widthToLlvmInt w) all1 LM_MO_Xor in negate (widthToLlvmInt w) all1 LM_MO_Xor
MO_S_Neg w -> MO_S_Neg w ->
let all0 = mkIntLit (widthToLlvmInt w) (0::Int) let all0 = mkIntLit (widthToLlvmInt w) 0
in negate (widthToLlvmInt w) all0 LM_MO_Sub in negate (widthToLlvmInt w) all0 LM_MO_Sub
MO_F_Neg w -> MO_F_Neg w ->
...@@ -1107,6 +1150,28 @@ funEpilogue = do ...@@ -1107,6 +1150,28 @@ funEpilogue = do
return (vars, concatOL stmts) return (vars, concatOL stmts)
-- | A serries of statements to trash all the STG registers.
--
-- In LLVM we pass the STG registers around everywhere in function calls.
-- So this means LLVM considers them live across the entire function, when
-- in reality they usually aren't. For Caller save registers across C calls
-- the saving and restoring of them is done by the Cmm code generator,
-- using Cmm local vars. So to stop LLVM saving them as well (and saving
-- all of them since it thinks they're always live, we trash them just
-- before the call by assigning the 'undef' value to them. The ones we
-- need are restored from the Cmm local var and the ones we don't need
-- are fine to be trashed.
trashStmts :: LlvmStatements
trashStmts = concatOL $ map trashReg activeStgRegs
where trashReg r =
let reg = lmGlobalRegVar r
ty = (pLower . getVarType) reg
trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
in case callerSaves r of
True -> trash
False -> nilOL
-- | Get a function pointer to the CLabel specified. -- | Get a function pointer to the CLabel specified.
-- --
-- This is for Haskell functions, function type is assumed, so doesn't work -- This is for Haskell functions, function type is assumed, so doesn't work
......
...@@ -910,7 +910,7 @@ genCCall target dest_regs argsAndHints ...@@ -910,7 +910,7 @@ genCCall target dest_regs argsAndHints
(labelOrExpr, reduceToFF32) <- case target of (labelOrExpr, reduceToFF32) <- case target of
CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
CmmCallee expr conv -> return (Right expr, False) CmmCallee expr conv -> return (Right expr, False)
CmmPrim mop -> outOfLineFloatOp mop CmmPrim mop -> outOfLineMachOp mop
let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
...@@ -937,7 +937,17 @@ genCCall target dest_regs argsAndHints ...@@ -937,7 +937,17 @@ genCCall target dest_regs argsAndHints
initialStackOffset = 8 initialStackOffset = 8
stackDelta finalStack = roundTo 16 finalStack stackDelta finalStack = roundTo 16 finalStack
#endif #endif
args = map hintlessCmm argsAndHints -- need to remove alignment information
argsAndHints' | (CmmPrim mop) <- target,
(mop == MO_Memcpy ||
mop == MO_Memset ||
mop == MO_Memmove)
-> init argsAndHints
| otherwise
-> argsAndHints
args = map hintlessCmm argsAndHints'
argReps = map cmmExprType args argReps = map cmmExprType args
roundTo a x | x `mod` a == 0 = x roundTo a x | x `mod` a == 0 = x
...@@ -1062,7 +1072,7 @@ genCCall target dest_regs argsAndHints ...@@ -1062,7 +1072,7 @@ genCCall target dest_regs argsAndHints
where rep = cmmRegType (CmmLocal dest) where rep = cmmRegType (CmmLocal dest)