From 0e069310cec2ef3df1d1928fa7683a87aebd9eed Mon Sep 17 00:00:00 2001
From: Paolo Capriotti <p.capriotti@gmail.com>
Date: Wed, 2 May 2012 15:24:46 +0100
Subject: [PATCH] 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.
MERGED from commit 40c1106c338e209f07023d165f32bff0f75e2e54
---
compiler/cmm/PprC.hs | 43 ++++++++++++++++++++++++++-----------------
1 file changed, 26 insertions(+), 17 deletions(-)
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 21826f82244f..682f71cce818 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,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
+ CmmCall (CmmPrim op _) results args _ret ->
+ 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 <+>
--
GitLab