From 93d6c9d532b678a91bafd4bf5f5f10c4f4b6d9b9 Mon Sep 17 00:00:00 2001 From: David Terei Date: Fri, 22 Apr 2011 20:00:15 -0700 Subject: [PATCH] Add new mem{cpy,set,move} cmm prim ops. --- compiler/cmm/CmmMachOp.hs | 8 + compiler/cmm/CmmParse.y | 5 +- compiler/llvmGen/Llvm/AbsSyn.hs | 6 + compiler/llvmGen/Llvm/PpLlvm.hs | 1 + compiler/llvmGen/LlvmCodeGen.hs | 7 +- compiler/llvmGen/LlvmCodeGen/Base.hs | 37 +++-- compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 235 ++++++++++++++++++----------- compiler/nativeGen/PPC/CodeGen.hs | 21 ++- compiler/nativeGen/SPARC/CodeGen/CCall.hs | 30 +++- compiler/nativeGen/X86/CodeGen.hs | 48 ++++-- 10 files changed, 274 insertions(+), 124 deletions(-) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 5e1ac16..6e89035 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -459,7 +459,15 @@ data CallishMachOp | MO_F32_Sqrt | MO_WriteBarrier | 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) pprCallishMachOp :: CallishMachOp -> SDoc pprCallishMachOp mo = text (show mo) + diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 0ee429d..6d14be2 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -735,7 +735,10 @@ machOps = listToUFM $ callishMachOps = listToUFM $ 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 ] diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index e25f5be..93bc62c 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -132,6 +132,12 @@ data LlvmStatement -} | 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) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 1a972e7..82c6bfa 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -161,6 +161,7 @@ ppLlvmStatement stmt Return result -> ppReturn result Expr expr -> ppLlvmExpression expr Unreachable -> text "unreachable" + Nop -> empty -- | Print out an LLVM expression. diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index ba5c1ec..56d8386 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -28,7 +28,9 @@ import Outputable import qualified Pretty as Prt import UniqSupply import Util +import SysTools ( figureLlvmVersion ) +import Data.Maybe ( fromMaybe ) import System.IO -- ----------------------------------------------------------------------------- @@ -48,8 +50,9 @@ llvmCodeGen dflags h us cmms in do bufh <- newBufHandle h Prt.bufLeftRender bufh $ pprLlvmHeader - - env' <- cmmDataLlvmGens dflags bufh env cdata [] + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + + env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] cmmProcLlvmGens dflags bufh us env' cmm 1 [] bFlush bufh diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 80d88e6..221106a 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -9,8 +9,10 @@ module LlvmCodeGen.Base ( LlvmCmmTop, LlvmBasicBlock, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, + LlvmVersion, defaultLlvmVersion, + LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, - funLookup, funInsert, + funLookup, funInsert, getLlvmVer, setLlvmVer, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, @@ -128,33 +130,50 @@ tysToParams = map (\ty -> (ty, [])) llvmPtrBits :: Int 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 -- -type LlvmEnvMap = UniqFM LlvmType -- 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. initLlvmEnv :: LlvmEnv -initLlvmEnv = (emptyUFM, emptyUFM) +initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion) -- | Clear variables from the environment. clearVars :: LlvmEnv -> LlvmEnv -clearVars (e1, _) = (e1, emptyUFM) +clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n) -- | Insert functions into the environment. varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -varInsert s t (e1, e2) = (e1, addToUFM e2 s t) -funInsert s t (e1, e2) = (addToUFM e1 s t, e2) +varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n) +funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n) -- | Lookup functions in the environment. varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -varLookup s (_, e2) = lookupUFM e2 s -funLookup s (e1, _) = lookupUFM e1 s +varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 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 diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index f5dd3bb..c55da14 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-type-defaults #-} -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmProc to LLVM code. -- @@ -17,7 +18,6 @@ import OldCmm import qualified OldPprCmm as PprCmm import OrdList -import BasicTypes import FastString import ForeignCall import Outputable hiding ( panic, pprPanic ) @@ -175,9 +175,31 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do where lmTrue :: LlvmVar - lmTrue = LMLitVar $ LMIntLit (-1) i1 + lmTrue = mkIntLit i1 (-1) #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. 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 retTy = ret_type res let argTy = tysToParams $ map arg_type args - let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible - lmconv retTy FixedArgs argTy llvmFunAlign + let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + lmconv retTy FixedArgs argTy llvmFunAlign - -- get parameter values - (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) - -- 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) ++ "." - - -- 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 + (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target let retStmt | ccTy == TailCall = unitOL $ Return Nothing | ret == CmmNeverReturns = unitOL $ Unreachable | 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 -- make the actual call @@ -321,6 +269,10 @@ genCall env target res args ret = do _ -> do (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 (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) let allStmts = stmts `snocOL` s1 `appOL` stmts3 @@ -344,6 +296,55 @@ genCall env target res args ret = do `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. arg_vars :: LlvmEnv -> HintedCmmActuals @@ -370,9 +371,41 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) = do (env', v1, stmts', top') <- exprToVar env e 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 -cmmPrimOpFunctions :: CallishMachOp -> FastString -cmmPrimOpFunctions mop +cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString +cmmPrimOpFunctions env mop = case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" @@ -408,8 +441,18 @@ cmmPrimOpFunctions mop MO_F64_Cosh -> fsLit "cosh" 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 ++ ")" + 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 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData @@ -594,7 +637,7 @@ genSwitch env cond maybe_ids = do (env', vc, stmts, top) <- exprToVar env cond 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 -- out of range is undefied, so lets just branch to first label let (_, defLbl) = head labels @@ -675,11 +718,11 @@ genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData genMachOp env _ op [x] = case op of MO_Not w -> - let all1 = mkIntLit (widthToLlvmInt w) (-1::Int) + let all1 = mkIntLit (widthToLlvmInt w) (-1) in negate (widthToLlvmInt w) all1 LM_MO_Xor 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 MO_F_Neg w -> @@ -1107,6 +1150,28 @@ funEpilogue = do 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. -- -- This is for Haskell functions, function type is assumed, so doesn't work diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index c96badd..ae8ef40 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -910,7 +910,7 @@ genCCall target dest_regs argsAndHints (labelOrExpr, reduceToFF32) <- case target of CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) CmmCallee expr conv -> return (Right expr, False) - CmmPrim mop -> outOfLineFloatOp mop + CmmPrim mop -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 @@ -937,7 +937,17 @@ genCCall target dest_regs argsAndHints initialStackOffset = 8 stackDelta finalStack = roundTo 16 finalStack #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 roundTo a x | x `mod` a == 0 = x @@ -1062,7 +1072,7 @@ genCCall target dest_regs argsAndHints where rep = cmmRegType (CmmLocal dest) r_dest = getRegisterReg (CmmLocal dest) - outOfLineFloatOp mop = + outOfLineMachOp mop = do dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ @@ -1106,6 +1116,11 @@ genCCall target dest_regs argsAndHints MO_F64_Cosh -> (fsLit "cosh", False) MO_F64_Tanh -> (fsLit "tanh", False) MO_F64_Pwr -> (fsLit "pow", False) + + MO_Memcpy -> (fsLit "memcpy", False) + MO_Memset -> (fsLit "memset", False) + MO_Memmove -> (fsLit "memmove", False) + other -> pprPanic "genCCall(ppc): unknown callish op" (pprCallishMachOp other) diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 106b673..d488168 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -80,9 +80,19 @@ genCCall (CmmPrim (MO_WriteBarrier)) _ _ genCCall target dest_regs argsAndHints = do + -- need to remove alignment information + let argsAndHints' | (CmmPrim mop) <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + -> init argsAndHints + + | otherwise + -> argsAndHints + -- strip hints from the arg regs let args :: [CmmExpr] - args = map hintlessCmm argsAndHints + args = map hintlessCmm argsAndHints' -- work out the arguments, and assign them to integer regs @@ -104,7 +114,7 @@ genCCall target dest_regs argsAndHints return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) CmmPrim mop - -> do res <- outOfLineFloatOp mop + -> do res <- outOfLineMachOp mop lblOrMopExpr <- case res of Left lbl -> do return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) @@ -253,13 +263,13 @@ assign_code _ -- | Generate a call to implement an out-of-line floating point operation -outOfLineFloatOp +outOfLineMachOp :: CallishMachOp -> NatM (Either CLabel CmmExpr) -outOfLineFloatOp mop +outOfLineMachOp mop = do let functionName - = outOfLineFloatOp_table mop + = outOfLineMachOp_table mop dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference @@ -275,11 +285,11 @@ outOfLineFloatOp mop -- | Decide what C function to use to implement a CallishMachOp -- -outOfLineFloatOp_table +outOfLineMachOp_table :: CallishMachOp -> FastString -outOfLineFloatOp_table mop +outOfLineMachOp_table mop = case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" @@ -315,5 +325,9 @@ outOfLineFloatOp_table mop MO_F64_Cosh -> fsLit "cosh" MO_F64_Tanh -> fsLit "tanh" - _ -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op " + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + + _ -> pprPanic "outOfLineMachOp(sparc): Unknown callish mach op " (pprCallishMachOp mop) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index a6cc36f..cc942fb 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -69,7 +69,7 @@ import DynFlags import Debug.Trace ( trace ) import Control.Monad ( mapAndUnzipM ) -import Data.Maybe ( fromJust ) +import Data.Maybe ( fromJust, catMaybes ) import Data.Bits import Data.Word import Data.Int @@ -1519,14 +1519,18 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. +-- void return type prim op +genCCall (CmmPrim op) [] args = + outOfLineCmmOp op Nothing args + -- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [CmmHinted r _] args = do +genCCall (CmmPrim op) [r_hinted@(CmmHinted r _)] args = do l1 <- getNewLabelNat l2 <- getNewLabelNat sse2 <- sse2Enabled if sse2 then - outOfLineFloatOp op r args + outOfLineCmmOp op (Just r_hinted) args else case op of MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args @@ -1540,7 +1544,7 @@ genCCall (CmmPrim op) [CmmHinted r _] args = do MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args - other_op -> outOfLineFloatOp op r args + other_op -> outOfLineCmmOp op (Just r_hinted) args where actuallyInlineFloatOp instr size [CmmHinted x _] @@ -1569,7 +1573,6 @@ genCCall target dest_regs args = do -- deal with static vs dynamic call targets (callinsns,cconv) <- case target of - -- CmmPrim -> ... CmmCallee (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) []), conv) @@ -1578,6 +1581,9 @@ genCCall target dest_regs args = do -> do { (dyn_r, dyn_c) <- getSomeReg expr ; ASSERT( isWord32 (cmmExprType expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." let push_code #if darwin_TARGET_OS @@ -1649,7 +1655,6 @@ genCCall target dest_regs args = do roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) - push_arg :: Bool -> HintedCmmActual {-current argument-} -> NatM InstrBlock -- code @@ -1703,9 +1708,13 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. +-- void return type prim op +genCCall (CmmPrim op) [] args = + outOfLineCmmOp op Nothing args -genCCall (CmmPrim op) [CmmHinted r _] args = - outOfLineFloatOp op r args +-- we only cope with a single result for foreign calls +genCCall (CmmPrim op) [res] args = + outOfLineCmmOp op (Just res) args genCCall target dest_regs args = do @@ -1749,7 +1758,6 @@ genCCall target dest_regs args = do -- deal with static vs dynamic call targets (callinsns,cconv) <- case target of - -- CmmPrim -> ... CmmCallee (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) arg_regs), conv) @@ -1757,6 +1765,9 @@ genCCall target dest_regs args = do CmmCallee expr conv -> do (dyn_r, dyn_c) <- getSomeReg expr return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." let -- The x86_64 ABI requires us to set %al to the number of SSE2 @@ -1867,22 +1878,26 @@ genCCall = panic "X86.genCCAll: not defined" #endif /* x86_64_TARGET_ARCH */ - - -outOfLineFloatOp :: CallishMachOp -> CmmFormal -> HintedCmmActuals -> NatM InstrBlock -outOfLineFloatOp mop res args +outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> HintedCmmActuals -> NatM InstrBlock +outOfLineCmmOp mop res args = do dflags <- getDynFlagsNat targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv - stmtToInstrs (CmmCall target [CmmHinted res NoHint] args CmmUnsafe CmmMayReturn) + stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmUnsafe CmmMayReturn) where -- Assume we can call these functions directly, and that they're not in a dynamic library. -- TODO: Why is this ok? Under linux this code will be in libm.so -- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction + args' = case mop of + MO_Memcpy -> init args + MO_Memset -> init args + MO_Memmove -> init args + _ -> args + fn = case mop of MO_F32_Sqrt -> fsLit "sqrtf" MO_F32_Sin -> fsLit "sinf" @@ -1916,8 +1931,9 @@ outOfLineFloatOp mop res args MO_F64_Tanh -> fsLit "tanh" MO_F64_Pwr -> fsLit "pow" - - + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" -- ----------------------------------------------------------------------------- -- 1.7.10.4