X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=a0661cdd529263883342076c6ad6f84c7bc6d152;hp=3673e7cdbd32ccab1b981ad6f62e344820801f84;hb=bca74f3e6bde807d688e39e6de28112ebcb4fa49;hpb=78bbce57e04a29541b7343f0b188a20cef956187 diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 3673e7c..a0661cd 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -34,6 +34,7 @@ module PprC ( -- Cmm stuff import Cmm +import PprCmm () -- Instances only import CLabel import MachOp import ForeignCall @@ -202,25 +203,44 @@ pprStmt stmt = case stmt of where rep = cmmExprRep src - CmmCall (CmmCallee fn cconv) results args safety _ret -> + CmmCall (CmmCallee fn cconv) results args safety ret -> maybe_proto $$ pprCall ppr_fn cconv results args safety where - ppr_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) + cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) + + real_fun_proto lbl = char ';' <> + pprCFunType (pprCLabel lbl) cconv results args <> + noreturn_attr <> semi + + data_proto lbl = ptext (sLit ";EI_(") <> + pprCLabel lbl <> char ')' <> semi + + noreturn_attr = case ret of + CmmNeverReturns -> text "__attribute__ ((noreturn))" + CmmMayReturn -> empty -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes - maybe_proto = + (maybe_proto, ppr_fn) = case fn of - CmmLit (CmmLabel lbl) | not (isMathFun lbl) -> - ptext (sLit ";EI_(") <+> pprCLabel lbl <> char ')' <> semi - -- we declare all called functions as data labels, - -- and then cast them to the right type when calling. - -- This is because the label might already have a - -- declaration as a data label in the same file, - -- e.g. Foreign.Marshal.Alloc declares 'free' as - -- both a data label and a function label. + CmmLit (CmmLabel lbl) + | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl) + -- stdcall functions must be declared with + -- a function type, otherwise the C compiler + -- doesn't add the @n suffix to the label. We + -- can't add the @n suffix ourselves, because + -- it isn't valid C. + | CmmNeverReturns <- ret -> (real_fun_proto lbl, pprCLabel lbl) + | not (isMathFun lbl) -> (data_proto lbl, cast_fn) + -- we declare all other called functions as + -- data labels, and then cast them to the + -- right type when calling. This is because + -- the label might already have a declaration + -- as a data label in the same file, + -- e.g. Foreign.Marshal.Alloc declares 'free' + -- as both a data label and a function label. _ -> - empty {- no proto -} + (empty {- no proto -}, cast_fn) -- for a dynamic call, no declaration is necessary. CmmCall (CmmPrim op) results args safety _ret -> @@ -240,9 +260,9 @@ pprCFunType ppr_fn cconv ress args parens (commafy (map arg_type args)) where res_type [] = ptext (sLit "void") - res_type [CmmHinted one hint] = machRepHintCType (localRegRep one) hint + res_type [CmmKinded one hint] = machRepHintCType (localRegRep one) hint - arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprRep expr) hint + arg_type (CmmKinded expr hint) = machRepHintCType (cmmExprRep expr) hint -- --------------------------------------------------------------------- -- unconditional branches @@ -394,7 +414,16 @@ pprMachOpApp' mop args pprLit :: CmmLit -> SDoc pprLit lit = case lit of CmmInt i rep -> pprHexVal i rep - CmmFloat f rep -> parens (machRepCType rep) <> (rational f) + + CmmFloat f rep -> parens (machRepCType rep) <> str + where d = fromRational f :: Double + str | isInfinite d && d < 0 = ptext (sLit "-INFINITY") + | isInfinite d = ptext (sLit "INFINITY") + | isNaN d = ptext (sLit "NAN") + | otherwise = text (show d) + -- these constants come from + -- see #1861 + CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i CmmLabelDiffOff clbl1 clbl2 i @@ -750,16 +779,16 @@ pprCall ppr_fn cconv results args _ ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where ppr_assign [] rhs = rhs - ppr_assign [CmmHinted one hint] rhs + ppr_assign [CmmKinded one hint] rhs = pprLocalReg one <> ptext (sLit " = ") <> pprUnHint hint (localRegRep one) <> rhs ppr_assign _other _rhs = panic "pprCall: multiple results" - pprArg (CmmHinted expr hint) + pprArg (CmmKinded expr hint) | hint `elem` [PtrHint,SignedHint] = cCast (machRepHintCType (cmmExprRep expr) hint) expr -- see comment by machRepHintCType below - pprArg (CmmHinted expr _other) + pprArg (CmmKinded expr _other) = pprExpr expr pprUnHint PtrHint rep = parens (machRepCType rep) @@ -799,7 +828,8 @@ pprExternDecl :: Bool -> CLabel -> SDoc pprExternDecl in_srt lbl -- do not print anything for "known external" things | not (needsCDecl lbl) = empty - | otherwise = + | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz + | otherwise = hcat [ visibility, label_type (labelType lbl), lparen, pprCLabel lbl, text ");" ] where @@ -810,6 +840,13 @@ pprExternDecl in_srt lbl | externallyVisibleCLabel lbl = char 'E' | otherwise = char 'I' + -- If the label we want to refer to is a stdcall function (on Windows) then + -- we must generate an appropriate prototype for it, so that the C compiler will + -- add the @n suffix to the label (#2276) + stdcall_decl sz = + ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl + <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRepCType wordRep))) + <> semi type TEState = (UniqSet LocalReg, FiniteMap CLabel ()) newtype TE a = TE { unTE :: TEState -> (a, TEState) } @@ -843,8 +880,8 @@ te_Lit _ = return () te_Stmt :: CmmStmt -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmCall _ rs es _ _) = mapM_ (te_temp.hintlessCmm) rs >> - mapM_ (te_Expr.hintlessCmm) es +te_Stmt (CmmCall _ rs es _ _) = mapM_ (te_temp.kindlessCmm) rs >> + mapM_ (te_Expr.kindlessCmm) es te_Stmt (CmmCondBranch e _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e te_Stmt (CmmJump e _) = te_Expr e