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

diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index 5e1ac16..6e89035 100644 (file)
--- 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)
   | 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)
   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 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -735,7 +735,10 @@ machOps = listToUFM $
 
 callishMachOps = listToUFM $
        map (\(x, y) -> (mkFastString x, y)) [
 
 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
     ]
 
         -- ToDo: the rest, maybe
     ]
 

diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index e25f5be..93bc62c 100644 (file)
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -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)
 
 

diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 1a972e7..82c6bfa 100644 (file)
--- 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"
         Return      result        -> ppReturn result
         Expr        expr          -> ppLlvmExpression expr
         Unreachable               -> text "unreachable"

+        Nop                       -> empty

 
 
 -- | Print out an LLVM expression.
 
 
 -- | Print out an LLVM expression.

diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index ba5c1ec..56d8386 100644 (file)
--- 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 qualified Pretty as Prt
 import UniqSupply
 import Util

+import SysTools ( figureLlvmVersion )

 
 

+import Data.Maybe ( fromMaybe )

 import System.IO
 
 -- -----------------------------------------------------------------------------
 import System.IO
 
 -- -----------------------------------------------------------------------------

@@ -48,8 +50,9 @@ llvmCodeGen dflags h us cmms
     in do
         bufh <- newBufHandle h
         Prt.bufLeftRender bufh $ pprLlvmHeader
     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
         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 (file)
--- 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,
 
         LlvmCmmTop, LlvmBasicBlock,
         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,
         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,

@@ -128,33 +130,50 @@ tysToParams = map (\ty -> (ty, []))
 llvmPtrBits :: Int
 llvmPtrBits = widthInBits $ typeWidth gcWord
 
 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
 --
 
 
 -- ----------------------------------------------------------------------------
 -- * 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.
 initLlvmEnv :: LlvmEnv
 
 -- | Get initial Llvm environment.
 initLlvmEnv :: LlvmEnv

-initLlvmEnv = (emptyUFM, emptyUFM)
+initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion)

 
 -- | Clear variables from the environment.
 clearVars :: LlvmEnv -> LlvmEnv
 
 -- | 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
 
 -- | 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
 
 -- | 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
 
 -- ----------------------------------------------------------------------------
 -- * Label handling

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index f5dd3bb..c55da14 100644 (file)
--- 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.
 --
 -- ----------------------------------------------------------------------------
 -- | Handle conversion of CmmProc to LLVM code.
 --

@@ -17,7 +18,6 @@ import OldCmm
 import qualified OldPprCmm as PprCmm
 import OrdList
 
 import qualified OldPprCmm as PprCmm
 import OrdList
 

-import BasicTypes

 import FastString
 import ForeignCall
 import Outputable hiding ( panic, pprPanic )
 import FastString
 import ForeignCall
 import Outputable hiding ( panic, pprPanic )

@@ -175,9 +175,31 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
 
     where
         lmTrue :: LlvmVar
 
     where
         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.
 genCall env target res args ret = do
 
 -- 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 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
 
 
     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
     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
 
         _ -> 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
             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)
 
 
                                 `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
 -- | 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')
 
   = 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
 -- | 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"
  = 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_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 ++ ")"
 
     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
 
 -- | 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
 
     (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
     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 ->
 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 ->
         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 ->
         in negate (widthToLlvmInt w) all0 LM_MO_Sub
 
     MO_F_Neg w ->

@@ -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.
 --
 -- This is for Haskell functions, function type is assumed, so doesn't work
 -- | 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 (file)
--- 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)
         (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
                                                         
         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
         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
        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)
                           
                     where rep = cmmRegType (CmmLocal dest)
                           r_dest = getRegisterReg (CmmLocal dest)
                           

-        outOfLineFloatOp mop =
+        outOfLineMachOp mop =

             do
                 dflags <- getDynFlagsNat
                 mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
             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_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)
 
                     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 (file)
--- 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          
 
 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]
        -- 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
 
 
        -- 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 
                        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))
                        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
 
 
 -- | Generate a call to implement an out-of-line floating point operation

-outOfLineFloatOp 
+outOfLineMachOp

        :: CallishMachOp 
        -> NatM (Either CLabel CmmExpr)
 
        :: CallishMachOp 
        -> NatM (Either CLabel CmmExpr)
 

-outOfLineFloatOp mop 
+outOfLineMachOp mop 

  = do  let functionName
  = do  let functionName

-               = outOfLineFloatOp_table mop
+               = outOfLineMachOp_table mop

        
        dflags  <- getDynFlagsNat
        mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference 
        
        dflags  <- getDynFlagsNat
        mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference 

@@ -275,11 +285,11 @@ outOfLineFloatOp mop
 
 -- | Decide what C function to use to implement a CallishMachOp
 --
 
 -- | Decide what C function to use to implement a CallishMachOp
 --

-outOfLineFloatOp_table 
+outOfLineMachOp_table 

        :: CallishMachOp
        -> FastString
        
        :: CallishMachOp
        -> FastString
        

-outOfLineFloatOp_table mop
+outOfLineMachOp_table mop

  = case mop of
        MO_F32_Exp    -> fsLit "expf"
        MO_F32_Log    -> fsLit "logf"
  = 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"
 
        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)
                        (pprCallishMachOp mop)

diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index a6cc36f..cc942fb 100644 (file)
--- 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 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
 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.
 
        -- 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
 -- 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
   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
     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
        
        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 _]
 
  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
     -- 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)
         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) }
            -> 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
 
     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)
 
     roundTo a x | x `mod` a == 0 = x
                 | otherwise = x + a - (x `mod` a)
 

-

     push_arg :: Bool -> HintedCmmActual {-current argument-}
                     -> NatM InstrBlock  -- code
 
     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.
 
        -- 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
 
 
 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
     -- 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)
         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)
         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
 
     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 */
 
 
 #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
      
   = 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
 
   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"
        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_F64_Tanh  -> fsLit "tanh"
              MO_F64_Pwr   -> fsLit "pow"
 

-
-
+             MO_Memcpy    -> fsLit "memcpy"
+             MO_Memset    -> fsLit "memset"
+             MO_Memmove   -> fsLit "memmove"

 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------