Commit 0e760174 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Simplify OutputableBndr

This replaces three methods in OutputableBndr with one,
and adds comments.

There's also a tiny change in the placement of equals signs in
debug-prints.  I like it better that way, but if it complicates
life for anyone we can put it back.
parent e55986a9
...@@ -524,7 +524,6 @@ instance OutputableBndr Name where ...@@ -524,7 +524,6 @@ instance OutputableBndr Name where
pprInfixOcc = pprInfixName pprInfixOcc = pprInfixName
pprPrefixOcc = pprPrefixName pprPrefixOcc = pprPrefixName
pprName :: Name -> SDoc pprName :: Name -> SDoc
pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ})
= getPprStyle $ \ sty -> = getPprStyle $ \ sty ->
......
...@@ -1724,9 +1724,7 @@ instance (OutputableBndr Var, Outputable b) => ...@@ -1724,9 +1724,7 @@ instance (OutputableBndr Var, Outputable b) =>
pprBndr _ b = ppr b -- Simple pprBndr _ b = ppr b -- Simple
pprInfixOcc b = ppr b pprInfixOcc b = ppr b
pprPrefixOcc b = ppr b pprPrefixOcc b = ppr b
pprNonRecBndrKeyword (TB b _) = pprNonRecBndrKeyword b bndrIsJoin_maybe (TB b _) = isJoinId_maybe b
pprRecBndrKeyword (TB b _) = pprRecBndrKeyword b
pprLamsOnLhs (TB b _) = pprLamsOnLhs b
deTagExpr :: TaggedExpr t -> CoreExpr deTagExpr :: TaggedExpr t -> CoreExpr
deTagExpr (Var v) = Var v deTagExpr (Var v) = Var v
......
...@@ -113,15 +113,23 @@ ppr_bind ann (Rec binds) = vcat (map pp binds) ...@@ -113,15 +113,23 @@ ppr_bind ann (Rec binds) = vcat (map pp binds)
ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding ann (val_bdr, expr) ppr_binding ann (val_bdr, expr)
= ann expr $$ pprBndr LetBind val_bdr $$ = ann expr $$ pprBndr LetBind val_bdr $$ pp_bind
hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs) <+> equals) 2
(pprCoreExpr rhs)
where where
(bndrs, body) = collectBinders expr pp_bind = case bndrIsJoin_maybe val_bdr of
(lhs_bndrs, rhs_bndrs) = splitAt (pprLamsOnLhs val_bdr) bndrs Nothing -> pp_normal_bind
rhs = mkLams rhs_bndrs body Just ar -> pp_join_bind ar
-- Returns ([], expr) unless it's a join point, in which
-- case we want the args before the = pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr)
-- For a join point of join arity n, we want to print j = \x1 ... xn -> e
-- as "j x1 ... xn = e" to differentiate when a join point returns a
-- lambda (the first rendering looks like a nullary join point returning
-- an n-argument function).
pp_join_bind join_arity
= hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
2 (equals <+> pprCoreExpr rhs)
where
(lhs_bndrs, rhs) = collectNBinders join_arity expr
pprParendExpr expr = ppr_expr parens expr pprParendExpr expr = ppr_expr parens expr
pprCoreExpr expr = ppr_expr noParens expr pprCoreExpr expr = ppr_expr noParens expr
...@@ -249,17 +257,20 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) ...@@ -249,17 +257,20 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
pprCoreExpr expr) pprCoreExpr expr)
-} -}
-- General case (recursive case, too) -- General case (recursive case, too)
ppr_expr add_par (Let bind expr) ppr_expr add_par (Let bind expr)
= add_par $ = add_par $
sep [hang (keyword <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"),
pprCoreExpr expr] pprCoreExpr expr]
where where
keyword = case bind of keyword (NonRec b _)
NonRec b _ -> pprNonRecBndrKeyword b | isJust (bndrIsJoin_maybe b) = text "join"
Rec ((b,_):_) -> pprRecBndrKeyword b | otherwise = text "let"
Rec [] -> text "let" -- This *shouldn't* happen, but keyword (Rec pairs)
-- let's be tolerant here | ((b,_):_) <- pairs
, isJust (bndrIsJoin_maybe b) = text "joinrec"
| otherwise = text "letrec"
ppr_expr add_par (Tick tickish expr) ppr_expr add_par (Tick tickish expr)
= sdocWithDynFlags $ \dflags -> = sdocWithDynFlags $ \dflags ->
...@@ -330,11 +341,7 @@ instance OutputableBndr Var where ...@@ -330,11 +341,7 @@ instance OutputableBndr Var where
pprBndr = pprCoreBinder pprBndr = pprCoreBinder
pprInfixOcc = pprInfixName . varName pprInfixOcc = pprInfixName . varName
pprPrefixOcc = pprPrefixName . varName pprPrefixOcc = pprPrefixName . varName
pprNonRecBndrKeyword bndr | isJoinId bndr = text "join" bndrIsJoin_maybe = isJoinId_maybe
| otherwise = text "let"
pprRecBndrKeyword bndr | isJoinId bndr = text "joinrec"
| otherwise = text "letrec"
pprLamsOnLhs bndr = isJoinId_maybe bndr `orElse` 0
pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder pprCoreBinder LetBind binder
......
...@@ -962,18 +962,12 @@ class Outputable a => OutputableBndr a where ...@@ -962,18 +962,12 @@ class Outputable a => OutputableBndr a where
-- prefix position of an application, thus (f a b) or ((+) x) -- prefix position of an application, thus (f a b) or ((+) x)
-- or infix position, thus (a `f` b) or (x + y) -- or infix position, thus (a `f` b) or (x + y)
pprNonRecBndrKeyword, pprRecBndrKeyword :: a -> SDoc bndrIsJoin_maybe :: a -> Maybe Int
-- Print which keyword introduces the binder in Core code. This should be bndrIsJoin_maybe _ = Nothing
-- "let" or "letrec" for a value but "join" or "joinrec" for a join point. -- When pretty-printing we sometimes want to find
pprNonRecBndrKeyword _ = text "let" -- whether the binder is a join point. You might think
pprRecBndrKeyword _ = text "letrec" -- we could have a function of type (a->Var), but Var
-- isn't available yet, alas
pprLamsOnLhs :: a -> Int
-- For a join point of join arity n, we want to print j = \x1 ... xn -> e
-- as "j x1 ... xn = e" to differentiate when a join point returns a
-- lambda (the first rendering looks like a nullary join point returning
-- an n-argument function).
pprLamsOnLhs _ = 0
{- {-
************************************************************************ ************************************************************************
......
...@@ -44,8 +44,8 @@ T7116.$trModule :: GHC.Types.Module ...@@ -44,8 +44,8 @@ T7116.$trModule :: GHC.Types.Module
Str=m, Str=m,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
T7116.$trModule = T7116.$trModule
GHC.Types.Module T7116.$trModule3 T7116.$trModule1 = GHC.Types.Module T7116.$trModule3 T7116.$trModule1
-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
dr :: Double -> Double dr :: Double -> Double
...@@ -60,9 +60,9 @@ dr :: Double -> Double ...@@ -60,9 +60,9 @@ dr :: Double -> Double
case x of { GHC.Types.D# x1 -> case x of { GHC.Types.D# x1 ->
GHC.Types.D# (GHC.Prim.+## x1 x1) GHC.Types.D# (GHC.Prim.+## x1 x1)
}}] }}]
dr = dr
\ (x :: Double) -> = \ (x :: Double) ->
case x of { GHC.Types.D# x1 -> GHC.Types.D# (GHC.Prim.+## x1 x1) } case x of { GHC.Types.D# x1 -> GHC.Types.D# (GHC.Prim.+## x1 x1) }
-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
dl :: Double -> Double dl :: Double -> Double
...@@ -75,9 +75,9 @@ dl :: Double -> Double ...@@ -75,9 +75,9 @@ dl :: Double -> Double
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: Double) -> Tmpl= \ (x [Occ=Once!] :: Double) ->
case x of { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) }}] case x of { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) }}]
dl = dl
\ (x :: Double) -> = \ (x :: Double) ->
case x of { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) } case x of { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) }
-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
fr :: Float -> Float fr :: Float -> Float
...@@ -92,11 +92,11 @@ fr :: Float -> Float ...@@ -92,11 +92,11 @@ fr :: Float -> Float
case x of { GHC.Types.F# x1 -> case x of { GHC.Types.F# x1 ->
GHC.Types.F# (GHC.Prim.plusFloat# x1 x1) GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
}}] }}]
fr = fr
\ (x :: Float) -> = \ (x :: Float) ->
case x of { GHC.Types.F# x1 -> case x of { GHC.Types.F# x1 ->
GHC.Types.F# (GHC.Prim.plusFloat# x1 x1) GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
} }
-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
fl :: Float -> Float fl :: Float -> Float
...@@ -111,11 +111,11 @@ fl :: Float -> Float ...@@ -111,11 +111,11 @@ fl :: Float -> Float
case x of { GHC.Types.F# y -> case x of { GHC.Types.F# y ->
GHC.Types.F# (GHC.Prim.plusFloat# y y) GHC.Types.F# (GHC.Prim.plusFloat# y y)
}}] }}]
fl = fl
\ (x :: Float) -> = \ (x :: Float) ->
case x of { GHC.Types.F# y -> case x of { GHC.Types.F# y ->
GHC.Types.F# (GHC.Prim.plusFloat# y y) GHC.Types.F# (GHC.Prim.plusFloat# y y)
} }
case GHC.List.reverse @ a x of sat { __DEFAULT -> case GHC.List.reverse @ a x of sat { __DEFAULT ->
case \ (@ a1) -> case \ (@ a1) ->
case g x of { case g x of {
case r @ GHC.Types.Any of { __DEFAULT -> r @ a } case r @ GHC.Types.Any of { __DEFAULT -> r @ a }
...@@ -7,23 +7,23 @@ Rec { ...@@ -7,23 +7,23 @@ Rec {
-- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0}
$wxs :: GHC.Prim.Int# -> () $wxs :: GHC.Prim.Int# -> ()
[GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>] [GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>]
$wxs = $wxs
\ (ww :: GHC.Prim.Int#) -> = \ (ww :: GHC.Prim.Int#) ->
case ww of ds1 { case ww of ds1 {
__DEFAULT -> $wxs (GHC.Prim.-# ds1 1#); __DEFAULT -> $wxs (GHC.Prim.-# ds1 1#);
1# -> GHC.Tuple.() 1# -> GHC.Tuple.()
} }
end Rec } end Rec }
-- RHS size: {terms: 11, types: 3, coercions: 0, joins: 0/0} -- RHS size: {terms: 11, types: 3, coercions: 0, joins: 0/0}
T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> () T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> ()
[GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>] [GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>]
T3772.$wfoo = T3772.$wfoo
\ (ww :: GHC.Prim.Int#) -> = \ (ww :: GHC.Prim.Int#) ->
case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# ww) of { case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# ww) of {
False -> GHC.Tuple.(); False -> GHC.Tuple.();
True -> $wxs ww True -> $wxs ww
} }
-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
foo [InlPrag=INLINE[0]] :: Int -> () foo [InlPrag=INLINE[0]] :: Int -> ()
...@@ -36,8 +36,8 @@ foo [InlPrag=INLINE[0]] :: Int -> () ...@@ -36,8 +36,8 @@ foo [InlPrag=INLINE[0]] :: Int -> ()
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: Int) -> Tmpl= \ (w [Occ=Once!] :: Int) ->
case w of { GHC.Types.I# ww1 [Occ=Once] -> T3772.$wfoo ww1 }}] case w of { GHC.Types.I# ww1 [Occ=Once] -> T3772.$wfoo ww1 }}]
foo = foo
\ (w :: Int) -> case w of { GHC.Types.I# ww1 -> T3772.$wfoo ww1 } = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> T3772.$wfoo ww1 }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T3772.$trModule2 :: GHC.Prim.Addr# T3772.$trModule2 :: GHC.Prim.Addr#
...@@ -80,8 +80,8 @@ T3772.$trModule :: GHC.Types.Module ...@@ -80,8 +80,8 @@ T3772.$trModule :: GHC.Types.Module
Str=m, Str=m,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
T3772.$trModule = T3772.$trModule
GHC.Types.Module T3772.$trModule3 T3772.$trModule1 = GHC.Types.Module T3772.$trModule3 T3772.$trModule1
T7865.$wexpensive [InlPrag=NOINLINE] T7865.$wexpensive [InlPrag=NOINLINE]
T7865.$wexpensive = T7865.$wexpensive
expensive [InlPrag=INLINE[0]] :: Int -> Int expensive [InlPrag=INLINE[0]] :: Int -> Int
case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
expensive = expensive
case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->
case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment