-- Cmm stuff
import Cmm
+import PprCmm () -- Instances only
import CLabel
import MachOp
import ForeignCall
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 ->
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
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 <math.h>
+ -- see #1861
+
CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl
CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
CmmLabelDiffOff clbl1 clbl2 i
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)
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
| 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) }
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
projects / ghc-hetmet.git / blobdiff