X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=a0661cdd529263883342076c6ad6f84c7bc6d152;hp=a07d2b9f532e92431ea9982ecec985d112a3d4e2;hb=bca74f3e6bde807d688e39e6de28112ebcb4fa49;hpb=bb66ce578f2ef5cbeb35de9719f0839a32fbeb35 diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index a07d2b9..a0661cd 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -1,3 +1,10 @@ +{-# 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 @@ -9,6 +16,8 @@ -- -- 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. @@ -25,6 +34,7 @@ module PprC ( -- Cmm stuff import Cmm +import PprCmm () -- Instances only import CLabel import MachOp import ForeignCall @@ -47,11 +57,6 @@ import Data.Char import System.IO import Data.Word -#ifdef DEBUG -import PprCmm () -- instances only --- import Debug.Trace -#endif - import Data.Array.ST import Control.Monad.ST @@ -71,7 +76,7 @@ pprCs dflags cmms = 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 () @@ -91,7 +96,7 @@ pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops -- 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 @@ -121,13 +126,13 @@ pprTop (CmmProc info clbl _params blocks) = 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 ] @@ -138,7 +143,6 @@ pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = -- 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. -- @@ -161,16 +165,16 @@ pprBBlock (BasicBlock lbl stmts) = 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 -- -------------------------------------------------------------------------- @@ -181,17 +185,17 @@ pprStmt :: CmmStmt -> SDoc 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 @@ -199,26 +203,45 @@ pprStmt stmt = case stmt of 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 @@ -230,31 +253,29 @@ pprStmt stmt = case stmt of 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 ] -- --------------------------------------------------------------------- @@ -271,7 +292,7 @@ pprSwitch e maybe_ids = 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 @@ -282,12 +303,12 @@ pprSwitch e maybe_ids 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. @@ -308,10 +329,10 @@ pprExpr e = case e of 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 @@ -354,7 +375,7 @@ pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc 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 @@ -393,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 @@ -419,7 +449,13 @@ pprLit1 other = pprLit other 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) @@ -445,7 +481,7 @@ pprStatic :: CmmStatic -> SDoc 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)) @@ -470,8 +506,8 @@ pprMachOp_for_C mop = case mop of -- 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 '/' @@ -483,13 +519,13 @@ pprMachOp_for_C mop = case mop of -- 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 '<' @@ -499,9 +535,9 @@ pprMachOp_for_C mop = case mop of 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. @@ -544,33 +580,33 @@ pprCallishMachOp_for_C :: CallishMachOp -> SDoc 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 @@ -578,32 +614,32 @@ pprCallishMachOp_for_C mop 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 -- --------------------------------------------------------------------- @@ -637,8 +673,8 @@ pprAssign r1 r2 | 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 @@ -681,9 +717,9 @@ isStrangeTypeGlobal BaseReg = True 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. @@ -694,25 +730,25 @@ pprReg r = case r of 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 @@ -720,7 +756,7 @@ 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 _ @@ -737,24 +773,23 @@ 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) @@ -776,7 +811,7 @@ is_cish StdCallConv = True -- 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) @@ -793,17 +828,25 @@ 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 - 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) } @@ -837,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.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 @@ -865,11 +908,11 @@ cCast ty expr = parens ty <> pprExpr1 expr 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 @@ -878,36 +921,36 @@ cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr) -- 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" -- --------------------------------------------------------------------- @@ -991,10 +1034,10 @@ commafy xs = hsep $ punctuate comma xs -- 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 @@ -1003,9 +1046,9 @@ pprHexVal w rep -- 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