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

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)
+

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
     ]
 

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)
 
 

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.

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

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

compiler/llvmGen/LlvmCodeGen/CodeGen.hs

+{-# 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

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)