Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/40c1106c338e209f07023d165f32bff0f75e2e54 >--------------------------------------------------------------- commit 40c1106c338e209f07023d165f32bff0f75e2e54 Author: Paolo Capriotti <[email protected]> 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. >--------------------------------------------------------------- compiler/cmm/PprC.hs | 41 +++++++++++++++++++++++++---------------- 1 files changed, 25 insertions(+), 16 deletions(-) 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 <+> _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
