memcpy-ffi

commit 40c1106c338e209f07023d165f32bff0f75e2e54
Author: Paolo Capriotti <p.capriotti@gmail.com>
Date:   Wed May 2 15:24:46 2012 +0100
Description:
    Cast memory primops in the C backend (#5976)

    To prevent conflicts with GCC builtins, generate identical code for
    calls to mem primos and FFI calls.

    Based on a patch by Joachim Breitner.
Bug: http://hackage.haskell.org/trac/ghc/ticket/5967
Origin: http://hackage.haskell.org/trac/ghc/changeset/40c1106c338e209f07023d165f32bff0f75e2e54

Gbp-Pq: Name memcpy-ffi.patch

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 21826f82244f55583e3811870715f35fabcb87f8..ba5732a33362d7cc0107fe94686dc591960371c4 100644 (file)
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -203,9 +203,6 @@ pprStmt platform stmt = case stmt of
                         pprCFunType (pprCLabel platform lbl) cconv results args <>
                         noreturn_attr <> semi
 
-        fun_proto lbl = ptext (sLit ";EF_(") <>
-                         pprCLabel platform lbl <> char ')' <> semi
-
         noreturn_attr = case ret of
                           CmmNeverReturns -> text "__attribute__ ((noreturn))"
                           CmmMayReturn    -> empty
@@ -226,31 +223,43 @@ pprStmt platform stmt = case stmt of
                     let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
                     in (real_fun_proto lbl, myCall)
                 | not (isMathFun lbl) ->
-                    let myCall = braces (
-                                     pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
-                                  $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
-                                  $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
-                                 )
-                    in (fun_proto lbl, myCall)
+                    pprForeignCall platform (pprCLabel platform lbl) cconv results args
               _ ->
                    (empty {- no proto -},
                     pprCall platform cast_fn cconv results args <> semi)
                         -- for a dynamic call, no declaration is necessary.
 
     CmmCall (CmmPrim op) results args _ret ->
-        pprCall platform ppr_fn CCallConv results args'
-        where
-        ppr_fn = pprCallishMachOp_for_C op
-        -- The mem primops carry an extra alignment arg, must drop it.
-        -- We could maybe emit an alignment directive using this info.
-        args'  | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args
-               | otherwise = args
+        proto $$ fn_call
+      where
+        cconv = CCallConv
+        fn = pprCallishMachOp_for_C op
+        (proto, fn_call)
+          -- The mem primops carry an extra alignment arg, must drop it.
+          -- We could maybe emit an alignment directive using this info.
+          -- We also need to cast mem primops to prevent conflicts with GCC
+          -- builtins (see bug #5967).
+          | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
+          = pprForeignCall platform fn cconv results (init args)
+          | otherwise
+          = (empty, pprCall platform fn cconv results args)
 
     CmmBranch ident          -> pprBranch ident
     CmmCondBranch expr ident -> pprCondBranch platform expr ident
     CmmJump lbl _params      -> mkJMP_(pprExpr platform lbl) <> semi
     CmmSwitch arg ids        -> pprSwitch platform arg ids
 
+pprForeignCall :: Platform -> SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc)
+pprForeignCall platform fn cconv results args = (proto, fn_call)
+  where
+    fn_call = braces (
+                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
+              $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
+             )
+    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
+    proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
+
 pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
 pprCFunType ppr_fn cconv ress args
   = res_type ress <+>