X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=8639a9307b4b8eccf467b1999dcbb04a4f93b9ab;hb=7d841483081735f5f906a6bb5e80249d97f3226b;hp=c57eb667d8f1ee0d2c9e0f3dd21b5824bd32bd4a;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index c57eb66..8639a93 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -9,27 +9,42 @@ \begin{code} module PprCore ( - pprCoreExpr, pprParendExpr, pprIfaceUnfolding, + pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprIdBndr, - pprCoreRules, pprCoreRule + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprIdRules, pprCoreRule ) where #include "HsVersions.h" import CoreSyn import CostCentre ( pprCostCentreCore ) -import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id ) +import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, + idInfo, idInlinePragma, idOccInfo, +#ifdef OLD_STRICTNESS + idDemandInfo, +#endif + globalIdDetails, isGlobalId, isExportedId, + isSpecPragmaId, idNewDemandInfo + ) import Var ( isTyVar ) -import IdInfo ( IdInfo, - arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, - demandInfo, updateInfo, ppUpdateInfo, specInfo, - strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, - cprInfo, ppCprInfo +import IdInfo ( IdInfo, megaSeqIdInfo, + arityInfo, ppArityInfo, + specInfo, ppStrictnessInfo, + workerInfo, ppWorkerInfo, + tyGenInfo, ppTyGenInfo, + newStrictnessInfo, +#ifdef OLD_STRICTNESS + cprInfo, ppCprInfo, + strictnessInfo, +#endif ) -import Const ( Con(..), DataCon ) -import DataCon ( isTupleCon, isUnboxedTupleCon ) +import DataCon ( dataConTyCon ) +import TyCon ( tupleTyConBoxity, isTupleTyCon ) import PprType ( pprParendType, pprTyVarBndr ) +import BasicTypes ( tupleParens ) import PprEnv +import Util ( lengthIs ) import Outputable \end{code} @@ -62,8 +77,10 @@ pprParendExpr :: CoreExpr -> SDoc pprCoreBindings = pprTopBinds pprCoreEnv pprCoreBinding = pprTopBind pprCoreEnv -pprCoreExpr = ppr_expr pprCoreEnv -pprParendExpr = ppr_parend_expr pprCoreEnv +pprCoreExpr = ppr_noparend_expr pprCoreEnv +pprParendExpr = ppr_parend_expr pprCoreEnv +pprArg = ppr_arg pprCoreEnv +pprCoreAlt = ppr_alt pprCoreEnv pprCoreEnv = initCoreEnv pprCoreBinder \end{code} @@ -71,21 +88,11 @@ pprCoreEnv = initCoreEnv pprCoreBinder Printer for unfoldings in interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -pprIfaceUnfolding :: CoreExpr -> SDoc -pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv - -- Notice that it's parenthesised - -pprIfaceArg = ppr_arg pprIfaceEnv - -pprIfaceEnv = initCoreEnv pprIfaceBinder -\end{code} - -\begin{code} instance Outputable b => Outputable (Bind b) where ppr bind = ppr_bind pprGenericEnv bind instance Outputable b => Outputable (Expr b) where - ppr expr = ppr_expr pprGenericEnv expr + ppr expr = ppr_noparend_expr pprGenericEnv expr pprGenericEnv :: Outputable b => PprEnv b pprGenericEnv = initCoreEnv (\site -> ppr) @@ -101,7 +108,6 @@ pprGenericEnv = initCoreEnv (\site -> ppr) \begin{code} initCoreEnv pbdr = initPprEnv - (Just ppr) -- Constants (Just pprCostCentreCore) -- Cost centres (Just ppr) -- tyvar occs @@ -121,7 +127,7 @@ initCoreEnv pbdr pprTopBinds pe binds = vcat (map (pprTopBind pe) binds) pprTopBind pe (NonRec binder expr) - = sep [ppr_binding_pe pe (binder,expr)] $$ text "" + = ppr_binding_pe pe (binder,expr) $$ text "" pprTopBind pe (Rec binds) = vcat [ptext SLIT("Rec {"), @@ -141,154 +147,150 @@ ppr_bind pe (Rec binds) = vcat (map pp binds) ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc ppr_binding_pe pe (val_bdr, expr) = sep [pBndr pe LetBind val_bdr, - nest 2 (equals <+> ppr_expr pe expr)] + nest 2 (equals <+> ppr_noparend_expr pe expr)] \end{code} \begin{code} -ppr_parend_expr pe expr - | no_parens = ppr_expr pe expr - | otherwise = parens (ppr_expr pe expr) - where - no_parens = case expr of - Var _ -> True - Con con [] -> True - Con (DataCon dc) _ -> isTupleCon dc - _ -> False +ppr_parend_expr pe expr = ppr_expr parens pe expr +ppr_noparend_expr pe expr = ppr_expr noParens pe expr + +noParens :: SDoc -> SDoc +noParens pp = pp \end{code} \begin{code} -ppr_expr :: PprEnv b -> Expr b -> SDoc - -ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd - -ppr_expr pe (Var name) = pOcc pe name - -ppr_expr pe (Con con []) - = ppr con -- Nullary constructors too - -ppr_expr pe (Con (DataCon dc) args) - -- Drop the type arguments and print in (a,b,c) notation - | isTupleCon dc - = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args)))) - | isUnboxedTupleCon dc - = text "(# " <> - hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <> - text " #)" +ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) -ppr_expr pe (Con con args) - = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args)) +ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd + +ppr_expr add_par pe (Var name) = pOcc pe name +ppr_expr add_par pe (Lit lit) = ppr lit -ppr_expr pe expr@(Lam _ _) +ppr_expr add_par pe expr@(Lam _ _) = let (bndrs, body) = collectBinders expr in + add_par $ hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow) - 4 (ppr_expr pe body) - -ppr_expr pe expr@(App fun arg) - = let - (final_fun, final_args) = go fun [arg] - go (App fun arg) args_so_far = go fun (arg:args_so_far) - go fun args_so_far = (fun, args_so_far) + 2 (ppr_noparend_expr pe body) + +ppr_expr add_par pe expr@(App fun arg) + = case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map (ppr_arg pe) args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args)) in - hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args)) - -ppr_expr pe (Case expr var [(con,args,rhs)]) - = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr, + case fun of + Var f -> case isDataConId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated && isTupleTyCon tc + -> tupleParens (tupleTyConBoxity tc) pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + other -> add_par (hang (pOcc pe f) 2 pp_args) + + other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args) + } + +ppr_expr add_par pe (Case expr var [(con,args,rhs)]) + = add_par $ + sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, hsep [ptext SLIT("of"), ppr_bndr var, char '{', ppr_case_pat pe con args ]], - ppr_expr pe rhs, + ppr_noparend_expr pe rhs, char '}' ] where ppr_bndr = pBndr pe CaseBind -ppr_expr pe (Case expr var alts) - = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr, +ppr_expr add_par pe (Case expr var alts) + = add_par $ + sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, ptext SLIT("of") <+> ppr_bndr var <+> char '{'], - nest 4 (sep (punctuate semi (map ppr_alt alts))), + nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))), char '}' ] where ppr_bndr = pBndr pe CaseBind - ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args) - 4 (ppr_expr pe rhs) -- special cases: let ... in let ... -- ("disgusting" SLPJ) -ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) - = vcat [ +ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals], - nest 2 (ppr_expr pe rhs), + nest 2 (ppr_noparend_expr pe rhs), ptext SLIT("} in"), - ppr_expr pe body ] + ppr_noparend_expr pe body ] -ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = hang (ptext SLIT("let {")) +ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (ptext SLIT("let {")) 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals]) - 4 (ppr_expr pe rhs), + 2 (ppr_noparend_expr pe rhs), ptext SLIT("} in")]) - $$ - ppr_expr pe expr + $$ + ppr_noparend_expr pe expr) -- general case (recursive case, too) -ppr_expr pe (Let bind expr) - = sep [hang (ptext keyword) 2 (ppr_bind pe bind), - hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)] +ppr_expr add_par pe (Let bind expr) + = add_par $ + sep [hang (ptext keyword) 2 (ppr_bind pe bind), + hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)] where keyword = case bind of Rec _ -> SLIT("__letrec {") NonRec _ _ -> SLIT("let {") -ppr_expr pe (Note (SCC cc) expr) - = sep [pSCC pe cc, ppr_expr pe expr] +ppr_expr add_par pe (Note (SCC cc) expr) + = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr]) #ifdef DEBUG -ppr_expr pe (Note (Coerce to_ty from_ty) expr) - = getPprStyle $ \ sty -> - if debugStyle sty && not (ifaceStyle sty) then +ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) + = add_par $ + getPprStyle $ \ sty -> + if debugStyle sty then sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty], ppr_parend_expr pe expr] else sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty], ppr_parend_expr pe expr] #else -ppr_expr pe (Note (Coerce to_ty from_ty) expr) - = sep [sep [ptext SLIT("__coerce"), nest 4 pTy pe to_ty], +ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) + = add_par $ + sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)], ppr_parend_expr pe expr] #endif -ppr_expr pe (Note InlineCall expr) - = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr - -ppr_expr pe (Note InlineMe expr) - = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr - -ppr_expr pe (Note (TermUsg u) expr) - = \ sty -> - if ifaceStyle sty then - ppr_expr pe expr sty - else - (ppr u <+> ppr_expr pe expr) sty - -ppr_case_pat pe con@(DataCon dc) args - | isTupleCon dc - = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow - | isUnboxedTupleCon dc - = hsep [text "(# " <> - hsep (punctuate comma (map ppr_bndr args)) <> - text " #)", - arrow] +ppr_expr add_par pe (Note InlineCall expr) + = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr) + +ppr_expr add_par pe (Note InlineMe expr) + = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr + +ppr_alt pe (con, args, rhs) + = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs) + +ppr_case_pat pe con@(DataAlt dc) args + | isTupleTyCon tc + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow where ppr_bndr = pBndr pe CaseBind + tc = dataConTyCon dc ppr_case_pat pe con args - = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow + = ppr con <+> hsep (map ppr_bndr args) <+> arrow where ppr_bndr = pBndr pe CaseBind @@ -304,10 +306,10 @@ and @pprCoreExpr@ functions. \begin{code} -- Used for printing dump info pprCoreBinder LetBind binder - = vcat [sig, pragmas, ppr binder] + = vcat [sig, pprIdDetails binder, pragmas, ppr binder] where sig = pprTypedBinder binder - pragmas = ppIdInfo (idInfo binder) + pragmas = ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder LambdaBind bndr = pprTypedBinder bndr @@ -315,12 +317,8 @@ pprCoreBinder LambdaBind bndr = pprTypedBinder bndr -- Case bound things don't get a signature or a herald pprCoreBinder CaseBind bndr = pprUntypedBinder bndr --- Used for printing interface-file unfoldings -pprIfaceBinder CaseBind binder = pprUntypedBinder binder -pprIfaceBinder other binder = pprTypedBinder binder - pprUntypedBinder binder - | isTyVar binder = pprTyVarBndr binder + | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedBinder binder @@ -332,53 +330,69 @@ pprTypedBinder binder -- It's important that the type is parenthesised too, at least when -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ... --- When printing any Id binder in debug mode, we print its inline pragma -pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) +-- pprIdBndr does *not* print the type +-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness +pprIdBndr id = ppr id <+> + (megaSeqIdInfo (idInfo id) `seq` + -- Useful for poking on black holes + ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> +#ifdef OLD_STRICTNESS + ppr (idDemandInfo id) <+> +#endif + ppr (idNewDemandInfo id) <+> + ppr (idLBVarInfo id))) \end{code} \begin{code} -ppIdInfo :: IdInfo -> SDoc -ppIdInfo info - = hsep [ - ppFlavourInfo (flavourInfo info), - ppArityInfo a, - ppUpdateInfo u, +pprIdDetails :: Id -> SDoc +pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) + | isExportedId id = ptext SLIT("[Exported]") + | isSpecPragmaId id = ptext SLIT("[SpecPrag]") + | otherwise = empty + +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo b info + = hsep [ ppArityInfo a, + ppTyGenInfo g, + ppWorkerInfo (workerInfo info), +#ifdef OLD_STRICTNESS ppStrictnessInfo s, - ppr d, - ppCafInfo c, ppCprInfo m, - pprIfaceCoreRules p - -- Inline pragma printed out with all binders; see PprCore.pprIdBndr +#endif + ppr (newStrictnessInfo info), + vcat (map (pprCoreRule (ppr b)) (rulesRules p)) + -- Inline pragma, occ, demand, lbvar info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr ] where a = arityInfo info - d = demandInfo info + g = tyGenInfo info +#ifdef OLD_STRICTNESS s = strictnessInfo info - u = updateInfo info - c = cafInfo info m = cprInfo info +#endif p = specInfo info \end{code} \begin{code} -pprCoreRules :: Id -> CoreRules -> SDoc -pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules) +pprIdRules :: [IdCoreRule] -> SDoc +pprIdRules rules = vcat (map pprIdRule rules) -pprIfaceCoreRules :: CoreRules -> SDoc -pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules) +pprIdRule :: IdCoreRule -> SDoc +pprIdRule (id,rule) = pprCoreRule (ppr id) rule -pprCoreRule :: Maybe Id -> CoreRule -> SDoc -pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs) - = doubleQuotes (ptext name) <+> +pprCoreRule :: SDoc -> CoreRule -> SDoc +pprCoreRule pp_fn (BuiltinRule name _) + = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ptext name)) + +pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs) + = doubleQuotes (ptext name) <+> ppr act <+> sep [ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)), - nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs) - ] - where - pp_fn = case maybe_fn of - Just id -> ppr id - Nothing -> empty -- Interface file + nest 2 (pp_fn <+> sep (map pprArg tpl_args)), + nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs) + ] <+> semi \end{code}