diff options
| -rw-r--r-- | compiler/cmm/PprC.hs | 277 |
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 |