[Pkg-haskell-commits] darcs: ghc: Import patch from ticket #5967

[Joachim Breitner]

Sun May  6 19:38:48 UTC 2012  Joachim Breitner <mail at joachim-breitner.de>
  * Import patch from ticket #5967
  Ignore-this: 2196a58802f45abf084dab5f2c2b09ef

    A ./patches/memcpy-ffi.patch
    M ./patches/series +1

Sun May  6 19:38:48 UTC 2012  Joachim Breitner <mail at joachim-breitner.de>
  * Import patch from ticket #5967
  Ignore-this: 2196a58802f45abf084dab5f2c2b09ef
diff -rN -u old-ghc//patches/memcpy-ffi.patch new-ghc//patches/memcpy-ffi.patch
--- old-ghc//patches/memcpy-ffi.patch	1970-01-01 00:00:00.000000000 +0000
+++ new-ghc//patches/memcpy-ffi.patch	2012-05-06 19:47:16.123904974 +0000
@@ -0,0 +1,83 @@
+commit 40c1106c338e209f07023d165f32bff0f75e2e54
+Author: Paolo Capriotti <p.capriotti at gmail.com>
+Date:   Wed May 2 15:24:46 2012 +0100
+
+    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.
+
+diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
+index 9515612..39d5a84 100644
+--- 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,12 +223,7 @@ 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)
+@@ -241,19 +233,36 @@ pprStmt platform stmt = case stmt of
+         vcat $ map (pprStmt platform) stmts
+ 
+     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 _            -> 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 <+>
diff -rN -u old-ghc//patches/series new-ghc//patches/series
--- old-ghc//patches/series	2012-05-06 19:47:15.931906274 +0000
+++ new-ghc//patches/series	2012-05-06 19:47:16.055906366 +0000
@@ -10,3 +10,4 @@
 ARM-VFPv3D16
 hurd-is-ELF
 no-missing-haddock-file-warning
+memcpy-ffi.patch