summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorIan Lynagh <igloo@earth.li>2012-07-19 00:28:32 +0100
committerIan Lynagh <igloo@earth.li>2012-07-19 00:28:32 +0100
commitfb0769b62e3ea4392ad970f8913a76187fead79f (patch)
tree96e6005348934097ac78b3d59717ddc0e128022d /compiler
parente0d54c7d432f3309336e3ed912ea14f06f8c9872 (diff)
downloadhaskell-fb0769b62e3ea4392ad970f8913a76187fead79f.tar.gz
Remove redundant Platform arguments in cmm/PprC.hs
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/PprC.hs277
1 files changed, 137 insertions, 140 deletions
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index bd7b35310c..6260cfe463 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -63,7 +63,7 @@ import Data.Array.ST
pprCs :: DynFlags -> [RawCmmGroup] -> SDoc
pprCs dflags cmms
- = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC (targetPlatform dflags) c) cmms)
+ = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
where
split_marker
| dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER")
@@ -79,57 +79,57 @@ writeCs dflags handle cmms
-- for fun, we could call cmmToCmm over the tops...
--
-pprC :: Platform -> RawCmmGroup -> SDoc
-pprC platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops
+pprC :: RawCmmGroup -> SDoc
+pprC tops = vcat $ intersperse blankLine $ map pprTop tops
--
-- top level procs
--
-pprTop :: Platform -> RawCmmDecl -> SDoc
-pprTop platform (CmmProc mb_info clbl (ListGraph blocks)) =
+pprTop :: RawCmmDecl -> SDoc
+pprTop (CmmProc mb_info clbl (ListGraph blocks)) =
(case mb_info of
Nothing -> empty
- Just (Statics info_clbl info_dat) -> pprDataExterns platform info_dat $$
- pprWordArray platform info_clbl info_dat) $$
+ Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
+ pprWordArray info_clbl info_dat) $$
(vcat [
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
- then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,
+ then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
nest 8 temp_decls,
nest 8 mkFB_,
case blocks of
[] -> empty
-- the first block doesn't get a label:
(BasicBlock _ stmts : rest) ->
- nest 8 (vcat (map (pprStmt platform) stmts)) $$
- vcat (map (pprBBlock platform) rest),
+ nest 8 (vcat (map pprStmt stmts)) $$
+ vcat (map pprBBlock rest),
nest 8 mkFE_,
rbrace ]
)
where
- (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks
+ (temp_decls, extern_decls) = pprTempAndExternDecls blocks
-- Chunks of static data.
-- We only handle (a) arrays of word-sized things and (b) strings.
-pprTop platform (CmmData _section (Statics lbl [CmmString str])) =
+pprTop (CmmData _section (Statics lbl [CmmString str])) =
hcat [
- pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
+ pprLocalness lbl, ptext (sLit "char "), ppr lbl,
ptext (sLit "[] = "), pprStringInCStyle str, semi
]
-pprTop platform (CmmData _section (Statics lbl [CmmUninitialised size])) =
+pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =
hcat [
- pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
+ pprLocalness lbl, ptext (sLit "char "), ppr lbl,
brackets (int size), semi
]
-pprTop platform (CmmData _section (Statics lbl lits)) =
- pprDataExterns platform lits $$
- pprWordArray platform lbl lits
+pprTop (CmmData _section (Statics lbl lits)) =
+ pprDataExterns lits $$
+ pprWordArray lbl lits
-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
@@ -138,24 +138,24 @@ pprTop platform (CmmData _section (Statics lbl lits)) =
-- as many jumps as possible into fall throughs.
--
-pprBBlock :: Platform -> CmmBasicBlock -> SDoc
-pprBBlock platform (BasicBlock lbl stmts) =
+pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock (BasicBlock lbl stmts) =
if null stmts then
pprTrace "pprC.pprBBlock: curious empty code block for"
(pprBlockId lbl) empty
else
nest 4 (pprBlockId lbl <> colon) $$
- nest 8 (vcat (map (pprStmt platform) stmts))
+ nest 8 (vcat (map pprStmt stmts))
-- --------------------------------------------------------------------------
-- Info tables. Just arrays of words.
-- See codeGen/ClosureInfo, and nativeGen/PprMach
-pprWordArray :: Platform -> CLabel -> [CmmStatic] -> SDoc
-pprWordArray platform lbl ds
+pprWordArray :: CLabel -> [CmmStatic] -> SDoc
+pprWordArray lbl ds
= hcat [ pprLocalness lbl, ptext (sLit "StgWord")
- , space, pprCLabel platform lbl, ptext (sLit "[] = {") ]
- $$ nest 8 (commafy (pprStatics platform ds))
+ , space, ppr lbl, ptext (sLit "[] = {") ]
+ $$ nest 8 (commafy (pprStatics ds))
$$ ptext (sLit "};")
--
@@ -169,9 +169,9 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
-- Statements.
--
-pprStmt :: Platform -> CmmStmt -> SDoc
+pprStmt :: CmmStmt -> SDoc
-pprStmt platform stmt = case stmt of
+pprStmt stmt = case stmt of
CmmReturn -> panic "pprStmt: return statement should have been cps'd away"
CmmNop -> empty
CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
@@ -180,16 +180,16 @@ pprStmt platform stmt = case stmt of
-- some debugging option is on. They can get quite
-- large.
- CmmAssign dest src -> pprAssign platform dest src
+ CmmAssign dest src -> pprAssign dest src
CmmStore dest src
| typeWidth rep == W64 && wordWidth /= W64
-> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
else ptext (sLit ("ASSIGN_Word64"))) <>
- parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi
+ parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
| otherwise
- -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ]
+ -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
where
rep = cmmExprType src
@@ -197,10 +197,10 @@ pprStmt platform stmt = case stmt of
maybe_proto $$
fnCall
where
- cast_fn = parens (cCast platform (pprCFunType (char '*') cconv results args) fn)
+ cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
real_fun_proto lbl = char ';' <>
- pprCFunType (pprCLabel platform lbl) cconv results args <>
+ pprCFunType (ppr lbl) cconv results args <>
noreturn_attr <> semi
noreturn_attr = case ret of
@@ -212,7 +212,7 @@ pprStmt platform stmt = case stmt of
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
- let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
+ let myCall = pprCall (ppr lbl) cconv results args
in (real_fun_proto lbl, myCall)
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
@@ -220,17 +220,17 @@ pprStmt platform stmt = case stmt of
-- can't add the @n suffix ourselves, because
-- it isn't valid C.
| CmmNeverReturns <- ret ->
- let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
+ let myCall = pprCall (ppr lbl) cconv results args
in (real_fun_proto lbl, myCall)
| not (isMathFun lbl) ->
- pprForeignCall platform (pprCLabel platform lbl) cconv results args
+ pprForeignCall (ppr lbl) cconv results args
_ ->
(empty {- no proto -},
- pprCall platform cast_fn cconv results args <> semi)
+ pprCall cast_fn cconv results args <> semi)
-- for a dynamic call, no declaration is necessary.
CmmCall (CmmPrim _ (Just stmts)) _ _ _ ->
- vcat $ map (pprStmt platform) stmts
+ vcat $ map pprStmt stmts
CmmCall (CmmPrim op _) results args _ret ->
proto $$ fn_call
@@ -243,22 +243,23 @@ pprStmt platform stmt = case stmt of
-- 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)
+ = pprForeignCall fn cconv results (init args)
| otherwise
- = (empty, pprCall platform fn cconv results args)
+ = (empty, pprCall 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
+ CmmCondBranch expr ident -> pprCondBranch expr ident
+ CmmJump lbl _ -> mkJMP_(pprExpr lbl) <> semi
+ CmmSwitch arg ids -> pprSwitch arg ids
-pprForeignCall :: Platform -> SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc)
-pprForeignCall platform fn cconv results args = (proto, fn_call)
+pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual]
+ -> (SDoc, SDoc)
+pprForeignCall 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
+ $$ pprCall (text "ghcFunPtr") cconv results args <> semi
)
cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
@@ -283,9 +284,9 @@ pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
-- ---------------------------------------------------------------------
-- conditional branches to local labels
-pprCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc
-pprCondBranch platform expr ident
- = hsep [ ptext (sLit "if") , parens(pprExpr platform expr) ,
+pprCondBranch :: CmmExpr -> BlockId -> SDoc
+pprCondBranch expr ident
+ = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
ptext (sLit "goto") , (pprBlockId ident) <> semi ]
@@ -298,12 +299,12 @@ pprCondBranch platform expr ident
-- 'undefined'. However, they may be defined one day, so we better
-- document this behaviour.
--
-pprSwitch :: Platform -> CmmExpr -> [ Maybe BlockId ] -> SDoc
-pprSwitch platform e maybe_ids
+pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
+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 platform e ) <+> lbrace)
+ (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace)
4 (vcat ( map caseify pairs2 )))
$$ rbrace
@@ -337,12 +338,12 @@ pprSwitch platform e maybe_ids
--
-- (similar invariants apply to the rest of the pretty printer).
-pprExpr :: Platform -> CmmExpr -> SDoc
-pprExpr platform e = case e of
- CmmLit lit -> pprLit platform lit
+pprExpr :: CmmExpr -> SDoc
+pprExpr e = case e of
+ CmmLit lit -> pprLit lit
- CmmLoad e ty -> pprLoad platform e ty
+ CmmLoad e ty -> pprLoad e ty
CmmReg reg -> pprCastReg reg
CmmRegOff reg 0 -> pprCastReg reg
@@ -352,17 +353,17 @@ pprExpr platform e = case e of
where
pprRegOff op i' = pprCastReg reg <> op <> int i'
- CmmMachOp mop args -> pprMachOpApp platform mop args
+ CmmMachOp mop args -> pprMachOpApp mop args
CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!"
-pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc
-pprLoad platform e ty
+pprLoad :: CmmExpr -> CmmType -> SDoc
+pprLoad e ty
| width == W64, wordWidth /= W64
= (if isFloatType ty then ptext (sLit "PK_DBL")
else ptext (sLit "PK_Word64"))
- <> parens (mkP_ <> pprExpr1 platform e)
+ <> parens (mkP_ <> pprExpr1 e)
| otherwise
= case e of
@@ -378,32 +379,32 @@ pprLoad platform e ty
-- (For tagging to work, I had to avoid unaligned loads. --ARY)
-> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
- _other -> cLoad platform e ty
+ _other -> cLoad e ty
where
width = typeWidth ty
-pprExpr1 :: Platform -> CmmExpr -> SDoc
-pprExpr1 platform (CmmLit lit) = pprLit1 platform lit
-pprExpr1 platform e@(CmmReg _reg) = pprExpr platform e
-pprExpr1 platform other = parens (pprExpr platform other)
+pprExpr1 :: CmmExpr -> SDoc
+pprExpr1 (CmmLit lit) = pprLit1 lit
+pprExpr1 e@(CmmReg _reg) = pprExpr e
+pprExpr1 other = parens (pprExpr other)
-- --------------------------------------------------------------------------
-- MachOp applications
-pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
-pprMachOpApp platform op args
+pprMachOpApp op args
| isMulMayOfloOp op
- = ptext (sLit "mulIntMayOflo") <> parens (commafy (map (pprExpr platform) args))
+ = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args))
where isMulMayOfloOp (MO_U_MulMayOflo _) = True
isMulMayOfloOp (MO_S_MulMayOflo _) = True
isMulMayOfloOp _ = False
-pprMachOpApp platform mop args
+pprMachOpApp mop args
| Just ty <- machOpNeedsCast mop
- = ty <> parens (pprMachOpApp' platform mop args)
+ = ty <> parens (pprMachOpApp' mop args)
| otherwise
- = pprMachOpApp' platform mop args
+ = pprMachOpApp' mop args
-- Comparisons in C have type 'int', but we want type W_ (this is what
-- resultRepOfMachOp says). The other C operations inherit their type
@@ -413,8 +414,8 @@ machOpNeedsCast mop
| isComparisonMachOp mop = Just mkW_
| otherwise = Nothing
-pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
-pprMachOpApp' platform mop args
+pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp' mop args
= case args of
-- dyadic
[x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
@@ -426,9 +427,9 @@ pprMachOpApp' platform mop args
where
-- Cast needed for signed integer ops
- pprArg e | signedOp mop = cCast platform (machRep_S_CType (typeWidth (cmmExprType e))) e
- | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType e))) e
- | otherwise = pprExpr1 platform e
+ pprArg e | signedOp mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e
+ | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e
+ | otherwise = pprExpr1 e
needsFCasts (MO_F_Eq _) = False
needsFCasts (MO_F_Ne _) = False
needsFCasts (MO_F_Neg _) = True
@@ -438,8 +439,8 @@ pprMachOpApp' platform mop args
-- --------------------------------------------------------------------------
-- Literals
-pprLit :: Platform -> CmmLit -> SDoc
-pprLit platform lit = case lit of
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
CmmInt i rep -> pprHexVal i rep
CmmFloat f w -> parens (machRep_F_CType w) <> str
@@ -462,54 +463,54 @@ pprLit platform lit = case lit of
-> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
where
- pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl
+ pprCLabelAddr lbl = char '&' <> ppr lbl
-pprLit1 :: Platform -> CmmLit -> SDoc
-pprLit1 platform lit@(CmmLabelOff _ _) = parens (pprLit platform lit)
-pprLit1 platform lit@(CmmLabelDiffOff _ _ _) = parens (pprLit platform lit)
-pprLit1 platform lit@(CmmFloat _ _) = parens (pprLit platform lit)
-pprLit1 platform other = pprLit platform other
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
+pprLit1 other = pprLit other
-- ---------------------------------------------------------------------------
-- Static data
-pprStatics :: Platform -> [CmmStatic] -> [SDoc]
-pprStatics _ [] = []
-pprStatics platform (CmmStaticLit (CmmFloat f W32) : rest)
+pprStatics :: [CmmStatic] -> [SDoc]
+pprStatics [] = []
+pprStatics (CmmStaticLit (CmmFloat f W32) : rest)
-- floats are padded to a word, see #1852
| wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
- = pprLit1 platform (floatToWord f) : pprStatics platform rest'
+ = pprLit1 (floatToWord f) : pprStatics rest'
| wORD_SIZE == 4
- = pprLit1 platform (floatToWord f) : pprStatics platform rest
+ = pprLit1 (floatToWord f) : pprStatics rest
| otherwise
= pprPanic "pprStatics: float" (vcat (map ppr' rest))
where ppr' (CmmStaticLit l) = ppr (cmmLitType l)
ppr' _other = ptext (sLit "bad static!")
-pprStatics platform (CmmStaticLit (CmmFloat f W64) : rest)
- = map (pprLit1 platform) (doubleToWords f) ++ pprStatics platform rest
-pprStatics platform (CmmStaticLit (CmmInt i W64) : rest)
+pprStatics (CmmStaticLit (CmmFloat f W64) : rest)
+ = map pprLit1 (doubleToWords f) ++ pprStatics rest
+pprStatics (CmmStaticLit (CmmInt i W64) : rest)
| wordWidth == W32
#ifdef WORDS_BIGENDIAN
- = pprStatics platform (CmmStaticLit (CmmInt q W32) :
+ = pprStatics (CmmStaticLit (CmmInt q W32) :
CmmStaticLit (CmmInt r W32) : rest)
#else
- = pprStatics platform (CmmStaticLit (CmmInt r W32) :
+ = pprStatics (CmmStaticLit (CmmInt r W32) :
CmmStaticLit (CmmInt q W32) : rest)
#endif
where r = i .&. 0xffffffff
q = i `shiftR` 32
-pprStatics _ (CmmStaticLit (CmmInt _ w) : _)
+pprStatics (CmmStaticLit (CmmInt _ w) : _)
| w /= wordWidth
= panic "pprStatics: cannot emit a non-word-sized static literal"
-pprStatics platform (CmmStaticLit lit : rest)
- = pprLit1 platform lit : pprStatics platform rest
-pprStatics platform (other : _)
- = pprPanic "pprWord" (pprStatic platform other)
+pprStatics (CmmStaticLit lit : rest)
+ = pprLit1 lit : pprStatics rest
+pprStatics (other : _)
+ = pprPanic "pprWord" (pprStatic other)
-pprStatic :: Platform -> CmmStatic -> SDoc
-pprStatic platform s = case s of
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
- CmmStaticLit lit -> nest 4 (pprLit platform lit)
+ CmmStaticLit lit -> nest 4 (pprLit lit)
CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
-- these should be inlined, like the old .hc
@@ -708,15 +709,15 @@ mkP_ = ptext (sLit "(P_)") -- StgWord*
--
-- Generating assignments is what we're all about, here
--
-pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc
+pprAssign :: CmmReg -> CmmExpr -> SDoc
-- dest is a reg, rhs is a reg
-pprAssign _ r1 (CmmReg r2)
+pprAssign r1 (CmmReg r2)
| isPtrReg r1 && isPtrReg r2
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
-- dest is a reg, rhs is a CmmRegOff
-pprAssign _ r1 (CmmRegOff r2 off)
+pprAssign r1 (CmmRegOff r2 off)
| isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
where
@@ -728,10 +729,10 @@ pprAssign _ r1 (CmmRegOff r2 off)
-- dest is a reg, rhs is anything.
-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
-- the lvalue elicits a warning from new GCC versions (3.4+).
-pprAssign platform r1 r2
- | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2)
- | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2)
- | otherwise = mkAssign (pprExpr platform r2)
+pprAssign r1 r2
+ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 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
@@ -830,11 +831,8 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: Platform -> SDoc -> CCallConv
- -> [HintedCmmFormal] -> [HintedCmmActual]
- -> SDoc
-
-pprCall platform ppr_fn cconv results args
+pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
+pprCall ppr_fn cconv results args
| not (is_cishCC cconv)
= panic $ "pprCall: unknown calling convention"
@@ -849,12 +847,12 @@ pprCall platform ppr_fn cconv results args
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (CmmHinted expr AddrHint)
- = cCast platform (ptext (sLit "void *")) expr
+ = cCast (ptext (sLit "void *")) expr
-- see comment by machRepHintCType below
pprArg (CmmHinted expr SignedHint)
- = cCast platform (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
+ = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
pprArg (CmmHinted expr _other)
- = pprExpr platform expr
+ = pprExpr expr
pprUnHint AddrHint rep = parens (machRepCType rep)
pprUnHint SignedHint rep = parens (machRepCType rep)
@@ -873,30 +871,29 @@ is_cishCC PrimCallConv = False
-- Find and print local and external declarations for a list of
-- Cmm statements.
--
-pprTempAndExternDecls :: Platform -> [CmmBasicBlock]
- -> (SDoc{-temps-}, SDoc{-externs-})
-pprTempAndExternDecls platform stmts
+pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls stmts
= (vcat (map pprTempDecl (uniqSetToList temps)),
- vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls)))
+ vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
where (temps, lbls) = runTE (mapM_ te_BB stmts)
-pprDataExterns :: Platform -> [CmmStatic] -> SDoc
-pprDataExterns platform statics
- = vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls))
+pprDataExterns :: [CmmStatic] -> SDoc
+pprDataExterns statics
+ = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
pprTempDecl l@(LocalReg _ rep)
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
-pprExternDecl :: Platform -> Bool -> CLabel -> SDoc
-pprExternDecl platform _in_srt lbl
+pprExternDecl :: Bool -> CLabel -> SDoc
+pprExternDecl _in_srt lbl
-- do not print anything for "known external" things
| not (needsCDecl lbl) = empty
| Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
| otherwise =
hcat [ visibility, label_type lbl,
- lparen, pprCLabel platform lbl, text ");" ]
+ lparen, ppr lbl, text ");" ]
where
label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
| otherwise = ptext (sLit "I_")
@@ -909,7 +906,7 @@ pprExternDecl platform _in_srt lbl
-- 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 platform lbl
+ ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl
<> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
<> semi
@@ -974,19 +971,19 @@ te_Reg _ = return ()
-- ---------------------------------------------------------------------
-- C types for MachReps
-cCast :: Platform -> SDoc -> CmmExpr -> SDoc
-cCast platform ty expr = parens ty <> pprExpr1 platform expr
-
-cLoad :: Platform -> CmmExpr -> CmmType -> SDoc
-cLoad platform expr rep
- | bewareLoadStoreAlignment (platformArch platform)
- = 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 platform expr) <> ptext (sLit "->x")
- | otherwise
- = char '*' <> parens (cCast platform (machRepPtrCType rep) expr)
+cCast :: SDoc -> CmmExpr -> SDoc
+cCast ty expr = parens ty <> pprExpr1 expr
+
+cLoad :: CmmExpr -> CmmType -> SDoc
+cLoad expr rep
+ = sdocWithPlatform $ \platform ->
+ if bewareLoadStoreAlignment (platformArch platform)
+ then 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")
+ else char '*' <> parens (cCast (machRepPtrCType rep) expr)
where -- On these platforms, unaligned loads are known to cause problems
bewareLoadStoreAlignment (ArchARM {}) = True
bewareLoadStoreAlignment _ = False