+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
-- Print Cmm as real C, for -fvia-C
--
+-- See wiki:Commentary/Compiler/Backends/PprC
+--
-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
-- relative to the old AbstractC, and many oddities/decorations have
-- disappeared from the data type.
#include "HsVersions.h"
-- Cmm stuff
+import BlockId
import Cmm
+import PprCmm () -- Instances only
import CLabel
import MachOp
import ForeignCall
import System.IO
import Data.Word
-#ifdef DEBUG
-import PprCmm () -- instances only
--- import Debug.Trace
-#endif
-
import Data.Array.ST
import Control.Monad.ST
= pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
where
split_marker
- | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
+ | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER")
| otherwise = empty
writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()
-- top level procs
--
pprTop :: RawCmmTop -> SDoc
-pprTop (CmmProc info clbl _params blocks) =
+pprTop (CmmProc info clbl _params (ListGraph blocks)) =
(if not (null info)
then pprDataExterns info $$
pprWordArray (entryLblToInfoLbl clbl) info
pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) =
hcat [
- pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
- ptext SLIT("[] = "), pprStringInCStyle str, semi
+ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
+ ptext (sLit "[] = "), pprStringInCStyle str, semi
]
pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) =
hcat [
- pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
+ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
brackets (int size), semi
]
-- these shouldn't appear?
pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
-
-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
--
pprWordArray :: CLabel -> [CmmStatic] -> SDoc
pprWordArray lbl ds
- = hcat [ pprLocalness lbl, ptext SLIT("StgWord")
- , space, pprCLabel lbl, ptext SLIT("[] = {") ]
+ = hcat [ pprLocalness lbl, ptext (sLit "StgWord")
+ , space, pprCLabel lbl, ptext (sLit "[] = {") ]
$$ nest 8 (commafy (pprStatics ds))
- $$ ptext SLIT("};")
+ $$ ptext (sLit "};")
--
-- has to be static, if it isn't globally visible
--
pprLocalness :: CLabel -> SDoc
-pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext SLIT("static ")
+pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
| otherwise = empty
-- --------------------------------------------------------------------------
pprStmt stmt = case stmt of
CmmNop -> empty
- CmmComment s -> (hang (ptext SLIT("/*")) 3 (ftext s)) $$ ptext SLIT("*/")
+ CmmComment s -> (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
CmmAssign dest src -> pprAssign dest src
CmmStore dest src
| rep == I64 && wordRep /= I64
- -> ptext SLIT("ASSIGN_Word64") <>
+ -> ptext (sLit "ASSIGN_Word64") <>
parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
| rep == F64 && wordRep /= I64
- -> ptext SLIT("ASSIGN_DBL") <>
+ -> ptext (sLit "ASSIGN_DBL") <>
parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
| otherwise
where
rep = cmmExprRep src
- CmmCall (CmmCallee fn cconv) results args safety _ret ->
- -- Controversial: leave this out for now.
- -- pprUndef fn $$
-
+ CmmCall (CmmCallee fn cconv) results args safety ret ->
+ maybe_proto $$
pprCall ppr_fn cconv results args safety
where
- ppr_fn = case fn of
- CmmLit (CmmLabel lbl) -> pprCLabel lbl
- _ -> parens (cCast (pprCFunType cconv results args) fn)
- -- for a dynamic call, cast the expression to
- -- a function of the right type (we hope).
-
- -- we #undef a function before calling it: the FFI is supposed to be
- -- an interface specifically to C, not to C+CPP. For one thing, this
- -- makes the via-C route more compatible with the NCG. If macros
- -- are being used for optimisation, then inline functions are probably
- -- better anyway.
- pprUndef (CmmLit (CmmLabel lbl)) =
- ptext SLIT("#undef") <+> pprCLabel lbl
- pprUndef _ = empty
+ 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, ppr_fn) =
+ case fn of
+ 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 -}, cast_fn)
+ -- for a dynamic call, no declaration is necessary.
CmmCall (CmmPrim op) results args safety _ret ->
pprCall ppr_fn CCallConv results args safety
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
-pprCFunType :: CCallConv -> CmmHintFormals -> CmmActuals -> SDoc
-pprCFunType cconv ress args
- = hcat [
- res_type ress,
- parens (text (ccallConvAttribute cconv) <> char '*'),
- parens (commafy (map arg_type args))
- ]
+pprCFunType :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> SDoc
+pprCFunType ppr_fn cconv ress args
+ = res_type ress <+>
+ parens (text (ccallConvAttribute cconv) <> ppr_fn) <>
+ parens (commafy (map arg_type args))
where
- res_type [] = ptext SLIT("void")
- res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
+ res_type [] = ptext (sLit "void")
+ res_type [CmmKinded one hint] = machRepHintCType (localRegRep one) hint
- arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
+ arg_type (CmmKinded expr hint) = machRepHintCType (cmmExprRep expr) hint
-- ---------------------------------------------------------------------
-- unconditional branches
pprBranch :: BlockId -> SDoc
-pprBranch ident = ptext SLIT("goto") <+> pprBlockId ident <> semi
+pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
-- ---------------------------------------------------------------------
-- conditional branches to local labels
pprCondBranch :: CmmExpr -> BlockId -> SDoc
pprCondBranch expr ident
- = hsep [ ptext SLIT("if") , parens(pprExpr expr) ,
- ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+ = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
+ ptext (sLit "goto") , (pprBlockId ident) <> semi ]
-- ---------------------------------------------------------------------
= let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
in
- (hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace)
+ (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace)
4 (vcat ( map caseify pairs2 )))
$$ rbrace
caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
where
do_fallthrough ix =
- hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
- ptext SLIT("/* fall through */") ]
+ hsep [ ptext (sLit "case") , pprHexVal ix wordRep <> colon ,
+ ptext (sLit "/* fall through */") ]
final_branch ix =
- hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
- ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+ hsep [ ptext (sLit "case") , pprHexVal ix wordRep <> colon ,
+ ptext (sLit "goto") , (pprBlockId ident) <> semi ]
-- ---------------------------------------------------------------------
-- Expressions.
CmmLit lit -> pprLit lit
CmmLoad e I64 | wordRep /= I64
- -> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e)
+ -> ptext (sLit "PK_Word64") <> parens (mkP_ <> pprExpr1 e)
CmmLoad e F64 | wordRep /= I64
- -> ptext SLIT("PK_DBL") <> parens (mkP_ <> pprExpr1 e)
+ -> ptext (sLit "PK_DBL") <> parens (mkP_ <> pprExpr1 e)
CmmLoad (CmmReg r) rep
| isPtrReg r && rep == wordRep
pprMachOpApp op args
| isMulMayOfloOp op
- = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args))
+ = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args))
where isMulMayOfloOp (MO_U_MulMayOflo _) = True
isMulMayOfloOp (MO_S_MulMayOflo _) = True
isMulMayOfloOp _ = False
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
pprStatics :: [CmmStatic] -> [SDoc]
pprStatics [] = []
pprStatics (CmmStaticLit (CmmFloat f F32) : rest)
+ -- floats are padded to a word, see #1852
+ | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 I32) : rest' <- rest
+ = pprLit1 (floatToWord f) : pprStatics rest'
+ | wORD_SIZE == 4
= pprLit1 (floatToWord f) : pprStatics rest
+ | otherwise
+ = pprPanic "pprStatics: float" (vcat (map (\(CmmStaticLit l) -> ppr (cmmLitRep l)) rest))
pprStatics (CmmStaticLit (CmmFloat f F64) : rest)
= map pprLit1 (doubleToWords f) ++ pprStatics rest
pprStatics (CmmStaticLit (CmmInt i I64) : rest)
pprStatic s = case s of
CmmStaticLit lit -> nest 4 (pprLit lit)
- CmmAlign i -> nest 4 (ptext SLIT("/* align */") <+> int i)
+ CmmAlign i -> nest 4 (ptext (sLit "/* align */") <+> int i)
CmmDataLabel clbl -> pprCLabel clbl <> colon
CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
-- Integer operations
MO_Add _ -> char '+'
MO_Sub _ -> char '-'
- MO_Eq _ -> ptext SLIT("==")
- MO_Ne _ -> ptext SLIT("!=")
+ MO_Eq _ -> ptext (sLit "==")
+ MO_Ne _ -> ptext (sLit "!=")
MO_Mul _ -> char '*'
MO_S_Quot _ -> char '/'
-- Signed comparisons (floating-point comparisons also use these)
-- & Unsigned comparisons
- MO_S_Ge _ -> ptext SLIT(">=")
- MO_S_Le _ -> ptext SLIT("<=")
+ MO_S_Ge _ -> ptext (sLit ">=")
+ MO_S_Le _ -> ptext (sLit "<=")
MO_S_Gt _ -> char '>'
MO_S_Lt _ -> char '<'
- MO_U_Ge _ -> ptext SLIT(">=")
- MO_U_Le _ -> ptext SLIT("<=")
+ MO_U_Ge _ -> ptext (sLit ">=")
+ MO_U_Le _ -> ptext (sLit "<=")
MO_U_Gt _ -> char '>'
MO_U_Lt _ -> char '<'
MO_Or _ -> char '|'
MO_Xor _ -> char '^'
MO_Not _ -> char '~'
- MO_Shl _ -> ptext SLIT("<<")
- MO_U_Shr _ -> ptext SLIT(">>") -- unsigned shift right
- MO_S_Shr _ -> ptext SLIT(">>") -- signed shift right
+ MO_Shl _ -> ptext (sLit "<<")
+ MO_U_Shr _ -> ptext (sLit ">>") -- unsigned shift right
+ MO_S_Shr _ -> ptext (sLit ">>") -- signed shift right
-- Conversions. Some of these will be NOPs.
-- Floating-point conversions use the signed variant.
pprCallishMachOp_for_C mop
= case mop of
- MO_F64_Pwr -> ptext SLIT("pow")
- MO_F64_Sin -> ptext SLIT("sin")
- MO_F64_Cos -> ptext SLIT("cos")
- MO_F64_Tan -> ptext SLIT("tan")
- MO_F64_Sinh -> ptext SLIT("sinh")
- MO_F64_Cosh -> ptext SLIT("cosh")
- MO_F64_Tanh -> ptext SLIT("tanh")
- MO_F64_Asin -> ptext SLIT("asin")
- MO_F64_Acos -> ptext SLIT("acos")
- MO_F64_Atan -> ptext SLIT("atan")
- MO_F64_Log -> ptext SLIT("log")
- MO_F64_Exp -> ptext SLIT("exp")
- MO_F64_Sqrt -> ptext SLIT("sqrt")
- MO_F32_Pwr -> ptext SLIT("powf")
- MO_F32_Sin -> ptext SLIT("sinf")
- MO_F32_Cos -> ptext SLIT("cosf")
- MO_F32_Tan -> ptext SLIT("tanf")
- MO_F32_Sinh -> ptext SLIT("sinhf")
- MO_F32_Cosh -> ptext SLIT("coshf")
- MO_F32_Tanh -> ptext SLIT("tanhf")
- MO_F32_Asin -> ptext SLIT("asinf")
- MO_F32_Acos -> ptext SLIT("acosf")
- MO_F32_Atan -> ptext SLIT("atanf")
- MO_F32_Log -> ptext SLIT("logf")
- MO_F32_Exp -> ptext SLIT("expf")
- MO_F32_Sqrt -> ptext SLIT("sqrtf")
- MO_WriteBarrier -> ptext SLIT("write_barrier")
+ MO_F64_Pwr -> ptext (sLit "pow")
+ MO_F64_Sin -> ptext (sLit "sin")
+ MO_F64_Cos -> ptext (sLit "cos")
+ MO_F64_Tan -> ptext (sLit "tan")
+ MO_F64_Sinh -> ptext (sLit "sinh")
+ MO_F64_Cosh -> ptext (sLit "cosh")
+ MO_F64_Tanh -> ptext (sLit "tanh")
+ MO_F64_Asin -> ptext (sLit "asin")
+ MO_F64_Acos -> ptext (sLit "acos")
+ MO_F64_Atan -> ptext (sLit "atan")
+ MO_F64_Log -> ptext (sLit "log")
+ MO_F64_Exp -> ptext (sLit "exp")
+ MO_F64_Sqrt -> ptext (sLit "sqrt")
+ MO_F32_Pwr -> ptext (sLit "powf")
+ MO_F32_Sin -> ptext (sLit "sinf")
+ MO_F32_Cos -> ptext (sLit "cosf")
+ MO_F32_Tan -> ptext (sLit "tanf")
+ MO_F32_Sinh -> ptext (sLit "sinhf")
+ MO_F32_Cosh -> ptext (sLit "coshf")
+ MO_F32_Tanh -> ptext (sLit "tanhf")
+ MO_F32_Asin -> ptext (sLit "asinf")
+ MO_F32_Acos -> ptext (sLit "acosf")
+ MO_F32_Atan -> ptext (sLit "atanf")
+ MO_F32_Log -> ptext (sLit "logf")
+ MO_F32_Exp -> ptext (sLit "expf")
+ MO_F32_Sqrt -> ptext (sLit "sqrtf")
+ MO_WriteBarrier -> ptext (sLit "write_barrier")
-- ---------------------------------------------------------------------
-- Useful #defines
mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
-mkJMP_ i = ptext SLIT("JMP_") <> parens i
-mkFN_ i = ptext SLIT("FN_") <> parens i -- externally visible function
-mkIF_ i = ptext SLIT("IF_") <> parens i -- locally visible
+mkJMP_ i = ptext (sLit "JMP_") <> parens i
+mkFN_ i = ptext (sLit "FN_") <> parens i -- externally visible function
+mkIF_ i = ptext (sLit "IF_") <> parens i -- locally visible
mkFB_, mkFE_ :: SDoc
-mkFB_ = ptext SLIT("FB_") -- function code begin
-mkFE_ = ptext SLIT("FE_") -- function code end
+mkFB_ = ptext (sLit "FB_") -- function code begin
+mkFE_ = ptext (sLit "FE_") -- function code end
-- from includes/Stg.h
--
mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc
-mkC_ = ptext SLIT("(C_)") -- StgChar
-mkW_ = ptext SLIT("(W_)") -- StgWord
-mkP_ = ptext SLIT("(P_)") -- StgWord*
-mkPP_ = ptext SLIT("(PP_)") -- P_*
-mkI_ = ptext SLIT("(I_)") -- StgInt
-mkA_ = ptext SLIT("(A_)") -- StgAddr
-mkD_ = ptext SLIT("(D_)") -- const StgWord*
-mkF_ = ptext SLIT("(F_)") -- StgFunPtr
-mkB_ = ptext SLIT("(B_)") -- StgByteArray
-mkL_ = ptext SLIT("(L_)") -- StgClosurePtr
+mkC_ = ptext (sLit "(C_)") -- StgChar
+mkW_ = ptext (sLit "(W_)") -- StgWord
+mkP_ = ptext (sLit "(P_)") -- StgWord*
+mkPP_ = ptext (sLit "(PP_)") -- P_*
+mkI_ = ptext (sLit "(I_)") -- StgInt
+mkA_ = ptext (sLit "(A_)") -- StgAddr
+mkD_ = ptext (sLit "(D_)") -- const StgWord*
+mkF_ = ptext (sLit "(F_)") -- StgFunPtr
+mkB_ = ptext (sLit "(B_)") -- StgByteArray
+mkL_ = ptext (sLit "(L_)") -- StgClosurePtr
-mkLI_ = ptext SLIT("(LI_)") -- StgInt64
-mkLW_ = ptext SLIT("(LW_)") -- StgWord64
+mkLI_ = ptext (sLit "(LI_)") -- StgInt64
+mkLW_ = ptext (sLit "(LW_)") -- StgWord64
-- ---------------------------------------------------------------------
| Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
| otherwise = mkAssign (pprExpr r2)
where mkAssign x = if r1 == CmmGlobal BaseReg
- then ptext SLIT("ASSIGN_BaseReg") <> parens x <> semi
- else pprReg r1 <> ptext SLIT(" = ") <> x <> semi
+ then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
+ else pprReg r1 <> ptext (sLit " = ") <> x <> semi
-- ---------------------------------------------------------------------
-- Registers
isStrangeTypeGlobal r = isFixedPtrGlobalReg r
strangeRegType :: CmmReg -> Maybe SDoc
-strangeRegType (CmmGlobal CurrentTSO) = Just (ptext SLIT("struct StgTSO_ *"))
-strangeRegType (CmmGlobal CurrentNursery) = Just (ptext SLIT("struct bdescr_ *"))
-strangeRegType (CmmGlobal BaseReg) = Just (ptext SLIT("struct StgRegTable_ *"))
+strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
+strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
+strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
strangeRegType _ = Nothing
-- pprReg just prints the register name.
CmmGlobal global -> pprGlobalReg global
pprAsPtrReg :: CmmReg -> SDoc
-pprAsPtrReg (CmmGlobal (VanillaReg n)) = char 'R' <> int n <> ptext SLIT(".p")
+pprAsPtrReg (CmmGlobal (VanillaReg n)) = char 'R' <> int n <> ptext (sLit ".p")
pprAsPtrReg other_reg = pprReg other_reg
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr = case gr of
- VanillaReg n -> char 'R' <> int n <> ptext SLIT(".w")
+ VanillaReg n -> char 'R' <> int n <> ptext (sLit ".w")
FloatReg n -> char 'F' <> int n
DoubleReg n -> char 'D' <> int n
LongReg n -> char 'L' <> int n
- Sp -> ptext SLIT("Sp")
- SpLim -> ptext SLIT("SpLim")
- Hp -> ptext SLIT("Hp")
- HpLim -> ptext SLIT("HpLim")
- CurrentTSO -> ptext SLIT("CurrentTSO")
- CurrentNursery -> ptext SLIT("CurrentNursery")
- HpAlloc -> ptext SLIT("HpAlloc")
- BaseReg -> ptext SLIT("BaseReg")
- GCEnter1 -> ptext SLIT("stg_gc_enter_1")
- GCFun -> ptext SLIT("stg_gc_fun")
+ Sp -> ptext (sLit "Sp")
+ SpLim -> ptext (sLit "SpLim")
+ Hp -> ptext (sLit "Hp")
+ HpLim -> ptext (sLit "HpLim")
+ CurrentTSO -> ptext (sLit "CurrentTSO")
+ CurrentNursery -> ptext (sLit "CurrentNursery")
+ HpAlloc -> ptext (sLit "HpAlloc")
+ BaseReg -> ptext (sLit "BaseReg")
+ GCEnter1 -> ptext (sLit "stg_gc_enter_1")
+ GCFun -> ptext (sLit "stg_gc_fun")
pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
+pprCall :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> CmmSafety
-> SDoc
pprCall ppr_fn cconv results args _
-- machine registers that are also used for passing arguments in the
-- C calling convention.
(if (not opt_Unregisterised)
- then ptext SLIT("__DISCARD__();")
+ then ptext (sLit "__DISCARD__();")
else empty) $$
#endif
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
- ppr_assign [(one,hint)] rhs
- = pprLocalReg one <> ptext SLIT(" = ")
+ ppr_assign [CmmKinded one hint] rhs
+ = pprLocalReg one <> ptext (sLit " = ")
<> pprUnHint hint (localRegRep one) <> rhs
ppr_assign _other _rhs = panic "pprCall: multiple results"
- pprArg (expr, PtrHint)
- = cCast (ptext SLIT("void *")) expr
+ pprArg (CmmKinded expr hint)
+ | hint `elem` [PtrHint,SignedHint]
+ = cCast (machRepHintCType (cmmExprRep expr) hint) expr
-- see comment by machRepHintCType below
- pprArg (expr, SignedHint)
- = cCast (machRepSignedCType (cmmExprRep expr)) expr
- pprArg (expr, _other)
- = pprExpr expr
+ pprArg (CmmKinded expr _other)
+ = pprExpr expr
pprUnHint PtrHint rep = parens (machRepCType rep)
pprUnHint SignedHint rep = parens (machRepCType rep)
--
pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
pprTempAndExternDecls stmts
- = (vcat (map pprTempDecl (eltsUFM temps)),
+ = (vcat (map pprTempDecl (uniqSetToList temps)),
vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)))
where (temps, lbls) = runTE (mapM_ te_BB stmts)
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
- label_type CodeLabel = ptext SLIT("F_")
- label_type DataLabel = ptext SLIT("I_")
+ label_type CodeLabel = ptext (sLit "F_")
+ label_type DataLabel = ptext (sLit "I_")
visibility
| 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.fst) rs >>
- mapM_ (te_Expr.fst) 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
cLoad :: CmmExpr -> MachRep -> SDoc
#ifdef BEWARE_LOAD_STORE_ALIGNMENT
cLoad expr rep =
- let decl = machRepCType rep <+> ptext SLIT("x") <> semi
- struct = ptext SLIT("struct") <+> braces (decl)
- packed_attr = ptext SLIT("__attribute__((packed))")
+ let decl = machRepCType rep <+> ptext (sLit "x") <> semi
+ struct = ptext (sLit "struct") <+> braces (decl)
+ packed_attr = ptext (sLit "__attribute__((packed))")
cast = parens (struct <+> packed_attr <> char '*')
- in parens (cast <+> pprExpr1 expr) <> ptext SLIT("->x")
+ in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x")
#else
cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr)
#endif
-- argument, we always cast the argument to (void *), to avoid warnings from
-- the C compiler.
machRepHintCType :: MachRep -> MachHint -> SDoc
-machRepHintCType rep PtrHint = ptext SLIT("void *")
+machRepHintCType rep PtrHint = ptext (sLit "void *")
machRepHintCType rep SignedHint = machRepSignedCType rep
machRepHintCType rep _other = machRepCType rep
machRepPtrCType :: MachRep -> SDoc
-machRepPtrCType r | r == wordRep = ptext SLIT("P_")
+machRepPtrCType r | r == wordRep = ptext (sLit "P_")
| otherwise = machRepCType r <> char '*'
machRepCType :: MachRep -> SDoc
-machRepCType r | r == wordRep = ptext SLIT("W_")
+machRepCType r | r == wordRep = ptext (sLit "W_")
| otherwise = sized_type
where sized_type = case r of
- I8 -> ptext SLIT("StgWord8")
- I16 -> ptext SLIT("StgWord16")
- I32 -> ptext SLIT("StgWord32")
- I64 -> ptext SLIT("StgWord64")
- F32 -> ptext SLIT("StgFloat") -- ToDo: correct?
- F64 -> ptext SLIT("StgDouble")
+ I8 -> ptext (sLit "StgWord8")
+ I16 -> ptext (sLit "StgWord16")
+ I32 -> ptext (sLit "StgWord32")
+ I64 -> ptext (sLit "StgWord64")
+ F32 -> ptext (sLit "StgFloat") -- ToDo: correct?
+ F64 -> ptext (sLit "StgDouble")
_ -> panic "machRepCType"
machRepSignedCType :: MachRep -> SDoc
-machRepSignedCType r | r == wordRep = ptext SLIT("I_")
+machRepSignedCType r | r == wordRep = ptext (sLit "I_")
| otherwise = sized_type
where sized_type = case r of
- I8 -> ptext SLIT("StgInt8")
- I16 -> ptext SLIT("StgInt16")
- I32 -> ptext SLIT("StgInt32")
- I64 -> ptext SLIT("StgInt64")
- F32 -> ptext SLIT("StgFloat") -- ToDo: correct?
- F64 -> ptext SLIT("StgDouble")
+ I8 -> ptext (sLit "StgInt8")
+ I16 -> ptext (sLit "StgInt16")
+ I32 -> ptext (sLit "StgInt32")
+ I64 -> ptext (sLit "StgInt64")
+ F32 -> ptext (sLit "StgFloat") -- ToDo: correct?
+ F64 -> ptext (sLit "StgDouble")
_ -> panic "machRepCType"
-- ---------------------------------------------------------------------
-- Print in C hex format: 0x13fa
pprHexVal :: Integer -> MachRep -> SDoc
-pprHexVal 0 _ = ptext SLIT("0x0")
+pprHexVal 0 _ = ptext (sLit "0x0")
pprHexVal w rep
- | w < 0 = parens (char '-' <> ptext SLIT("0x") <> go (-w) <> repsuffix rep)
- | otherwise = ptext SLIT("0x") <> go w <> repsuffix rep
+ | w < 0 = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
+ | otherwise = ptext (sLit "0x") <> go w <> repsuffix rep
where
-- type suffix for literals:
-- Integer literals are unsigned in Cmm/C. We explicitly cast to
-- warnings about integer overflow from gcc.
-- on 32-bit platforms, add "ULL" to 64-bit literals
- repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("ULL")
+ repsuffix I64 | wORD_SIZE == 4 = ptext (sLit "ULL")
-- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
- repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("UL")
+ repsuffix I64 | cINT_SIZE == 4 = ptext (sLit "UL")
repsuffix _ = char 'U'
go 0 = empty