X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fcmm%2FPprC.hs;h=51a3f07233b81c28eb98a68de264afdc44ce14f3;hb=7aede9b10573d1c652bf6f18e9fcaf65c2b6f656;hp=51e429b0aeb9cf0b7662faa56f1f4979c3ecdab0;hpb=69cb15e2f6853435602f00ecbccd2598a9e7eea9;p=ghc-hetmet.git diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs index 51e429b..51a3f07 100644 --- a/ghc/compiler/cmm/PprC.hs +++ b/ghc/compiler/cmm/PprC.hs @@ -30,6 +30,7 @@ import MachOp import ForeignCall -- Utils +import DynFlags ( DynFlags, DynFlag(..), dopt ) import Unique ( getUnique ) import UniqSet import FiniteMap @@ -37,7 +38,6 @@ import UniqFM ( eltsUFM ) import FastString import Outputable import Constants -import CmdLineOpts ( opt_EnsureSplittableC ) -- The rest import Data.List ( intersperse, groupBy ) @@ -45,6 +45,7 @@ import Data.Bits ( shiftR ) import Char ( ord, chr ) import IO ( Handle ) import DATA_BITS +import Data.Word ( Word8 ) #ifdef DEBUG import PprCmm () -- instances only @@ -59,16 +60,17 @@ import MONAD_ST -- -------------------------------------------------------------------------- -- Top level -pprCs :: [Cmm] -> SDoc -pprCs cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) - -writeCs :: Handle -> [Cmm] -> IO () -writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms) - -- ToDo: should be printForC +pprCs :: DynFlags -> [Cmm] -> SDoc +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") + | otherwise = empty -split_marker - | opt_EnsureSplittableC = ptext SLIT("__STG_SPLIT_MARKER") - | otherwise = empty +writeCs :: DynFlags -> Handle -> [Cmm] -> IO () +writeCs dflags handle cmms + = printForC handle (pprCs dflags cmms) -- -------------------------------------------------------------------------- -- Now do some real work @@ -85,7 +87,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 @@ -177,10 +180,14 @@ pprStmt stmt = case stmt of CmmAssign dest src -> pprAssign dest src CmmStore dest src - | rep == I64 + | rep == I64 && wordRep /= I64 -> ptext SLIT("ASSIGN_Word64") <> parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi + | rep == F64 && wordRep /= I64 + -> ptext SLIT("ASSIGN_DBL") <> + parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi + | otherwise -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] where @@ -194,7 +201,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 +224,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 @@ -265,11 +276,11 @@ 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 <> colon , + hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon , ptext SLIT("/* fall through */") ] final_branch ix = - hsep [ ptext SLIT("case") , pprHexVal ix <> colon , + hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon , ptext SLIT("goto") , (pprBlockId ident) <> semi ] -- --------------------------------------------------------------------- @@ -290,9 +301,12 @@ pprExpr :: CmmExpr -> SDoc pprExpr e = case e of CmmLit lit -> pprLit lit - CmmLoad e I64 + CmmLoad e I64 | wordRep /= I64 -> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e) + CmmLoad e F64 | wordRep /= I64 + -> ptext SLIT("PK_DBL") <> parens (mkP_ <> pprExpr1 e) + CmmLoad (CmmReg r) rep | isPtrReg r && rep == wordRep -> char '*' <> pprAsPtrReg r @@ -357,13 +371,24 @@ pprMachOpApp mop args pprLit :: CmmLit -> SDoc pprLit lit = case lit of - CmmInt i _rep -> pprHexVal i + CmmInt i rep -> pprHexVal i rep CmmFloat f rep -> parens (machRepCType rep) <> (rational f) - CmmLabel clbl -> mkW_ <> pprCLabel clbl - CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i + CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl + CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr 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_ <> pprCLabelAddr clbl1 <> char '+' <> int i + +pprCLabelAddr lbl = char '&' <> pprCLabel lbl 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 @@ -503,24 +528,24 @@ 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") MO_F64_Sqrt -> ptext SLIT("sqrt") - MO_F32_Pwr -> ptext SLIT("pow") - MO_F32_Sin -> ptext SLIT("sin") - MO_F32_Cos -> ptext SLIT("cos") - MO_F32_Tan -> ptext SLIT("tan") - MO_F32_Sinh -> ptext SLIT("sinh") - MO_F32_Cosh -> ptext SLIT("cosh") - MO_F32_Tanh -> ptext SLIT("tanh") - MO_F32_Asin -> ptext SLIT("asin") - MO_F32_Acos -> ptext SLIT("acos") - MO_F32_Atan -> ptext SLIT("atan") - MO_F32_Log -> ptext SLIT("log") - MO_F32_Exp -> ptext SLIT("exp") - MO_F32_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") -- --------------------------------------------------------------------- -- Useful #defines @@ -624,11 +649,13 @@ isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g isStrangeTypeGlobal :: GlobalReg -> Bool isStrangeTypeGlobal CurrentTSO = True isStrangeTypeGlobal CurrentNursery = True +isStrangeTypeGlobal BaseReg = True isStrangeTypeGlobal r = isPtrGlobalReg 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 _ = Nothing -- pprReg just prints the register name. @@ -670,21 +697,37 @@ pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] pprCall ppr_fn cconv results args vols | not (is_cish cconv) - = panic "pprForeignCall: unknown calling convention" + = panic "pprCall: unknown calling convention" | otherwise = save vols $$ ptext SLIT("CALLER_SAVE_SYSTEM") $$ - hcat [ ppr_results results, ppr_fn, - parens (commafy (map pprArg args)), semi ] $$ +#if x86_64_TARGET_ARCH + -- HACK around gcc optimisations. + -- x86_64 needs a __DISCARD__() here, to create a barrier between + -- putting the arguments into temporaries and passing the arguments + -- to the callee, because the argument expressions may refer to + -- machine registers that are also used for passing arguments in the + -- C calling convention. + ptext SLIT("__DISCARD__();") $$ +#endif + ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi $$ ptext SLIT("CALLER_RESTORE_SYSTEM") $$ restore vols where - ppr_results [] = empty - ppr_results [(one,hint)] - = pprExpr (CmmReg one) <> ptext SLIT(" = ") - <> pprUnHint hint (cmmRegRep one) - ppr_results _other = panic "pprCall: multiple results" + ppr_assign [] rhs = rhs + ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs + | Just ty <- strangeRegType reg + = ptext SLIT("ASSIGN_BaseReg") <> parens (parens ty <> rhs) + -- BaseReg is special, sometimes it isn't an lvalue and we + -- can't assign to it. + ppr_assign [(one,hint)] rhs + | Just ty <- strangeRegType one + = pprReg one <> ptext SLIT(" = ") <> parens ty <> rhs + | otherwise + = pprReg one <> ptext SLIT(" = ") + <> pprUnHint hint (cmmRegRep one) <> rhs + ppr_assign _other _rhs = panic "pprCall: multiple results" pprArg (expr, PtrHint) = cCast (ptext SLIT("void *")) expr @@ -712,9 +755,10 @@ pprGlobalRegName gr = case gr of VanillaReg n -> char 'R' <> int n -- without the .w suffix _ -> pprGlobalReg gr +-- Currently we only have these two calling conventions, but this might +-- change in the future... is_cish CCallConv = True is_cish StdCallConv = True -is_cish _ = False -- --------------------------------------------------------------------- -- Find and print local and external declarations for a list of @@ -780,6 +824,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 () @@ -794,11 +840,10 @@ te_Stmt _ = return () te_Expr :: CmmExpr -> TE () te_Expr (CmmLit lit) = te_Lit lit -te_Expr (CmmReg r) = te_Reg r te_Expr (CmmLoad e _) = te_Expr e +te_Expr (CmmReg r) = te_Reg r te_Expr (CmmMachOp _ es) = mapM_ te_Expr es te_Expr (CmmRegOff r _) = te_Reg r -te_Expr _ = return () te_Reg :: CmmReg -> TE () te_Reg (CmmLocal l) = te_temp l @@ -850,25 +895,21 @@ machRepSignedCType r | r == wordRep = ptext SLIT("I_") -- --------------------------------------------------------------------- -- print strings as valid C strings --- Assumes it contains only characters '\0'..'\xFF'! -pprFSInCStyle :: FastString -> SDoc -pprFSInCStyle fs = pprStringInCStyle (unpackFS fs) - -pprStringInCStyle :: String -> SDoc +pprStringInCStyle :: [Word8] -> SDoc pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -charToC :: Char -> String -charToC '\"' = "\\\"" -charToC '\'' = "\\\'" -charToC '\\' = "\\\\" -charToC c | c >= ' ' && c <= '~' = [c] - | c > '\xFF' = panic ("charToC "++show c) - | otherwise = ['\\', +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', chr (ord '0' + ord c `div` 64), chr (ord '0' + ord c `div` 8 `mod` 8), chr (ord '0' + ord c `mod` 8)] - -- --------------------------------------------------------------------------- -- Initialising static objects with floating-point numbers. We can't -- just emit the floating point number, because C will cast it to an int @@ -957,12 +998,24 @@ commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs -- Print in C hex format: 0x13fa -pprHexVal :: Integer -> SDoc -pprHexVal 0 = ptext SLIT("0x0") -pprHexVal w - | w < 0 = parens (char '-' <> ptext SLIT("0x") <> go (-w)) - | otherwise = ptext SLIT("0x") <> go w +pprHexVal :: Integer -> MachRep -> SDoc +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 where + -- type suffix for literals: + -- Integer literals are unsigned in Cmm/C. We explicitly cast to + -- signed values for doing signed operations, but at all other + -- times values are unsigned. This also helps eliminate occasional + -- warnings about integer overflow from gcc. + + -- on 32-bit platforms, add "ULL" to 64-bit literals + 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 _ = char 'U' + go 0 = empty go w' = go q <> dig where