X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fcmm%2FPprC.hs;h=421b557a2c8d9e310e232131d2c01b9b67583ad0;hb=eb041e812156e9ac601b8c1f73fa43379fd0a2b4;hp=a09edd11df5b6f46a1307c7c80da30a895628d6c;hpb=36fc368e1d3f7497c789e82c774859855ff57f15;p=ghc-hetmet.git diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs index a09edd1..421b557 100644 --- a/ghc/compiler/cmm/PprC.hs +++ b/ghc/compiler/cmm/PprC.hs @@ -40,7 +40,7 @@ import Constants import CmdLineOpts ( opt_EnsureSplittableC ) -- The rest -import Data.List ( intersperse, group ) +import Data.List ( intersperse, groupBy ) import Data.Bits ( shiftR ) import Char ( ord, chr ) import IO ( Handle ) @@ -85,7 +85,8 @@ pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops pprTop :: CmmTop -> SDoc pprTop (CmmProc info clbl _params blocks) = (if not (null info) - then pprWordArray (entryLblToInfoLbl clbl) info + then pprDataExterns info $$ + pprWordArray (entryLblToInfoLbl clbl) info else empty) $$ (case blocks of [] -> empty @@ -194,7 +195,7 @@ pprStmt stmt = case stmt of where ppr_fn = case fn of CmmLit (CmmLabel lbl) -> pprCLabel lbl - _other -> parens (cCast (pprCFunType results args) fn) + _other -> parens (cCast (pprCFunType cconv results args) fn) -- for a dynamic call, cast the expression to -- a function of the right type (we hope). @@ -217,9 +218,13 @@ pprStmt stmt = case stmt of CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi CmmSwitch arg ids -> pprSwitch arg ids -pprCFunType :: [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc -pprCFunType ress args = - res_type ress <> parens (char '*') <> parens (commafy (map arg_type args)) +pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc +pprCFunType cconv ress args + = hcat [ + res_type ress, + parens (text (ccallConvAttribute cconv) <> char '*'), + parens (commafy (map arg_type args)) + ] where res_type [] = ptext SLIT("void") res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint @@ -251,29 +256,26 @@ pprCondBranch expr ident -- pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc pprSwitch e maybe_ids - = let ids = [ i | Just i <- maybe_ids ] - pairs = zip [ 0 .. ] (concatMap markfalls (group 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) - 4 (vcat ( map caseify pairs ))) + 4 (vcat ( map caseify pairs2 ))) $$ rbrace where - -- fall through case - caseify (i,Left ident) = - hsep [ ptext SLIT("case") , pprHexVal i <> colon , - ptext SLIT("/* fall through for"), - pprBlockId ident, - ptext SLIT("*/") ] - - caseify (i,Right ident) = - hsep [ ptext SLIT("case") , pprHexVal i <> colon , - ptext SLIT("goto") , (pprBlockId ident) <> semi ] + sndEq (_,x) (_,y) = x == y - -- mark the bottom of a fallthough sequence of cases as `Right' - markfalls [a] = [Right a] - markfalls as = map (\a -> Left a) (init as) ++ [Right (last as)] + -- fall through case + caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix + where + do_fallthrough ix = + hsep [ ptext SLIT("case") , pprHexVal ix <> colon , + ptext SLIT("/* fall through */") ] + final_branch ix = + hsep [ ptext SLIT("case") , pprHexVal ix <> colon , + ptext SLIT("goto") , (pprBlockId ident) <> semi ] -- --------------------------------------------------------------------- -- Expressions. @@ -336,7 +338,7 @@ pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc pprMachOpApp op args | isMulMayOfloOp op - = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args)) <> semi + = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args)) where isMulMayOfloOp (MO_U_MulMayOflo _) = True isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False @@ -360,13 +362,28 @@ pprMachOpApp mop args pprLit :: CmmLit -> SDoc pprLit lit = case lit of + CmmInt i I64 | machRepByteWidth I32 == wORD_SIZE + -> pprHexVal i <> ptext SLIT("LL") + -- Append an 'LL' suffix to 64-bit integers on a 32-bit + -- platform. This might not be strictly necessary (the + -- type will always be apparent from the context), but + -- it avoids some warnings from gcc. CmmInt i _rep -> pprHexVal i CmmFloat f rep -> parens (machRepCType rep) <> (rational f) CmmLabel clbl -> mkW_ <> pprCLabel clbl CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i + CmmLabelDiffOff clbl1 clbl2 i + -- WARNING: + -- * the lit must occur in the info table clbl2 + -- * clbl1 must be an SRT, a slow entry point or a large bitmap + -- The Mangler is expected to convert any reference to an SRT, + -- a slow entry point or a large bitmap + -- from an info table to an offset. + -> mkW_ <> pprCLabel clbl1 <> char '+' <> int i 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 @@ -506,7 +523,7 @@ pprCallishMachOp_for_C mop MO_F64_Cosh -> ptext SLIT("cosh") MO_F64_Tanh -> ptext SLIT("tanh") MO_F64_Asin -> ptext SLIT("asin") - MO_F64_Acos -> 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") @@ -685,7 +702,8 @@ pprCall ppr_fn cconv results args vols where ppr_results [] = empty ppr_results [(one,hint)] - = pprExpr (CmmReg one) <> ptext SLIT(" = ") <> pprUnHint hint + = pprExpr (CmmReg one) <> ptext SLIT(" = ") + <> pprUnHint hint (cmmRegRep one) ppr_results _other = panic "pprCall: multiple results" pprArg (expr, PtrHint) @@ -696,10 +714,10 @@ pprCall ppr_fn cconv results args vols pprArg (expr, _other) = pprExpr expr - pprUnHint PtrHint = mkW_ - pprUnHint SignedHint = mkW_ - pprUnHint _ = empty - + pprUnHint PtrHint rep = parens (machRepCType rep) + pprUnHint SignedHint rep = parens (machRepCType rep) + pprUnHint _ _ = empty + save = save_restore SLIT("CALLER_SAVE") restore = save_restore SLIT("CALLER_RESTORE") @@ -782,6 +800,8 @@ te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss te_Lit :: CmmLit -> TE () te_Lit (CmmLabel l) = te_lbl l +te_Lit (CmmLabelOff l _) = te_lbl l +te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1 te_Lit _ = return () te_Stmt :: CmmStmt -> TE ()