X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=4478dfd966d72cf3d222b6c0f1d934969c1c8696;hp=e801aeee26c423598e9752869acf551eba567be6;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=e06951a75a1f519e8f015880c363a8dedc08ff9c diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index e801aee..4478dfd 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -33,16 +33,17 @@ -- module PprCmm - ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic, pprLit + ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, + pprSection, pprStatic, pprLit ) where import BlockId import Cmm import CmmUtils -import MachOp import CLabel + import ForeignCall import Unique import Outputable @@ -52,6 +53,12 @@ import Data.List import System.IO import Data.Maybe +-- Temp Jan08 +import SMRep +import ClosureInfo +#include "../includes/StgFun.h" + + pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where @@ -167,11 +174,13 @@ pprTypeInfo (ConstrInfo layout constr descr) = ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), ptext (sLit "constructor: ") <> integer (toInteger constr), pprLit descr] -pprTypeInfo (FunInfo layout srt fun_type arity _args slow_entry) = +pprTypeInfo (FunInfo layout srt arity _args slow_entry) = vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), ptext (sLit "srt: ") <> ppr srt, - ptext (sLit "fun_type: ") <> integer (toInteger fun_type), +-- Temp Jan08 + ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)), + ptext (sLit "arity: ") <> integer (toInteger arity), --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed ptext (sLit "slow: ") <> pprLit slow_entry @@ -187,6 +196,20 @@ pprTypeInfo (ContInfo stack srt) = vcat [ptext (sLit "stack: ") <> ppr stack, ptext (sLit "srt: ") <> ppr srt] +-- Temp Jan08 +argDescrType :: ArgDescr -> StgHalfWord +-- The "argument type" RTS field type +argDescrType (ArgSpec n) = n +argDescrType (ArgGen liveness) + | isBigLiveness liveness = ARG_GEN_BIG + | otherwise = ARG_GEN + +-- Temp Jan08 +isBigLiveness :: Liveness -> Bool +isBigLiveness (BigLiveness _) = True +isBigLiveness (SmallLiveness _) = False + + pprUpdateFrame :: UpdateFrame -> SDoc pprUpdateFrame (UpdateFrame expr args) = hcat [ ptext (sLit "jump") @@ -225,39 +248,28 @@ pprStmt stmt = case stmt of -- rep[lv] = expr; CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where - rep = ppr ( cmmExprRep expr ) + rep = ppr ( cmmExprType expr ) -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile CmmCall (CmmCallee fn cconv) results args safety ret -> - hcat [ if null results - then empty - else parens (commafy $ map ppr results) <> - ptext (sLit " = "), - ptext (sLit "foreign"), space, - doubleQuotes(ppr cconv), space, - target fn, parens ( commafy $ map ppr args ), - brackets (ppr safety), - case ret of CmmMayReturn -> empty - CmmNeverReturns -> ptext (sLit " never returns"), - semi ] + sep [ pp_lhs <+> pp_conv + , nest 2 (pprExpr9 fn <> + parens (commafy (map ppr_ar args))) + <> brackets (ppr safety) + , case ret of CmmMayReturn -> empty + CmmNeverReturns -> ptext $ sLit (" never returns") + ] <> semi where - ---- With the following three functions, I was going somewhere - ---- useful, but I don't remember where. Probably making - ---- emitted Cmm output look better. ---NR, 2 May 2008 - _pp_lhs | null results = empty - | otherwise = commafy (map ppr_ar results) <+> equals + pp_lhs | null results = empty + | otherwise = commafy (map ppr_ar results) <+> equals -- Don't print the hints on a native C-- call - ppr_ar arg = case cconv of - CmmCallConv -> ppr (kindlessCmm arg) - _ -> doubleQuotes (ppr $ cmmKind arg) <+> - ppr (kindlessCmm arg) - _pp_conv = case cconv of + ppr_ar (CmmHinted ar k) = case cconv of + CmmCallConv -> ppr ar + _ -> ppr (ar,k) + pp_conv = case cconv of CmmCallConv -> empty - _ -> ptext (sLit "foreign") <+> doubleQuotes (ppr cconv) - - target (CmmLit lit) = pprLit lit - target fn' = parens (ppr fn') + _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) CmmCall (CmmPrim op) results args safety ret -> pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) @@ -271,6 +283,18 @@ pprStmt stmt = case stmt of CmmReturn params -> genReturn params CmmSwitch arg ids -> genSwitch arg ids +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + +-- Just look like a tuple, since it was a tuple before +-- ... is that a good idea? --Isaac Dupree +instance (Outputable a) => Outputable (CmmHinted a) where + ppr (CmmHinted a k) = ppr (a, k) + -- -------------------------------------------------------------------------- -- goto local label. [1], section 6.6 -- @@ -297,9 +321,8 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> [CmmKinded CmmExpr] -> SDoc +genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc genJump expr args = - hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr @@ -308,23 +331,17 @@ genJump expr args = CmmLoad (CmmReg _) _ -> pprExpr expr _ -> parens (pprExpr expr) , space - , parens ( commafy $ map pprKinded args ) + , parens ( commafy $ map ppr args ) , semi ] -pprKinded :: Outputable a => (CmmKinded a) -> SDoc -pprKinded (CmmKinded a NoHint) = ppr a -pprKinded (CmmKinded a PtrHint) = quotes(text "address") <+> ppr a -pprKinded (CmmKinded a SignedHint) = quotes(text "signed") <+> ppr a -pprKinded (CmmKinded a FloatHint) = quotes(text "float") <+> ppr a -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 -- -- return (a, b, c); -- -genReturn :: [CmmKinded CmmExpr] -> SDoc +genReturn :: [CmmHinted CmmExpr] -> SDoc genReturn args = - hcat [ ptext (sLit "return") , space , parens ( commafy $ map ppr args ) @@ -376,7 +393,7 @@ pprExpr e CmmRegOff reg i -> pprExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = cmmRegRep reg + where rep = typeWidth (cmmRegType reg) CmmLit lit -> pprLit lit _other -> pprExpr1 e @@ -488,7 +505,7 @@ pprLit :: CmmLit -> SDoc pprLit lit = case lit of CmmInt i rep -> hcat [ (if i < 0 then parens else id)(integer i) - , (if rep == wordRep + , (if rep == wordWidth then empty else space <> dcolon <+> ppr rep) ] @@ -534,27 +551,37 @@ pprReg r -- We only print the type of the local reg if it isn't wordRep -- pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep follow) - = hcat [ char '_', ppr uniq, ty ] where - ty = if rep == wordRep && follow == GCKindNonPtr - then empty - else dcolon <> ptr <> ppr rep - ptr = if follow == GCKindNonPtr - then empty - else doubleQuotes (text "ptr") +pprLocalReg (LocalReg uniq rep) +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + = char '_' <> ppr uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty -- Stack areas pprArea :: Area -> SDoc -pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ] -pprArea (CallArea id n n') = - hcat [ text "callslot<", ppr id, char '+', ppr n, char '/', ppr n', text ">" ] +pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ] +pprArea (CallArea id) = pprAreaId id + +pprAreaId :: AreaId -> SDoc +pprAreaId Old = text "old" +pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ] -- needs to be kept in syn with Cmm.hs.GlobalReg -- pprGlobalReg :: GlobalReg -> SDoc pprGlobalReg gr = case gr of - VanillaReg n -> char 'R' <> int n + VanillaReg n _ -> char 'R' <> int n +-- Temp Jan08 +-- VanillaReg n VNonGcPtr -> char 'R' <> int n +-- VanillaReg n VGcPtr -> char 'P' <> int n FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n