summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/PprCore.hs43
-rw-r--r--compiler/hsSyn/HsBinds.hs2
-rw-r--r--compiler/stgSyn/StgSyn.hs2
-rw-r--r--compiler/utils/Outputable.hs7
-rw-r--r--testsuite/tests/deSugar/should_compile/T2431.stderr2
-rw-r--r--testsuite/tests/numeric/should_compile/T7116.stdout16
-rw-r--r--testsuite/tests/simplCore/should_compile/T3717.stderr4
-rw-r--r--testsuite/tests/simplCore/should_compile/T3772.stdout5
-rw-r--r--testsuite/tests/simplCore/should_compile/T4908.stderr8
-rw-r--r--testsuite/tests/simplCore/should_compile/T4930.stderr10
-rw-r--r--testsuite/tests/simplCore/should_compile/T5366.stdout3
-rw-r--r--testsuite/tests/simplCore/should_compile/T7360.stderr12
-rw-r--r--testsuite/tests/simplCore/should_compile/T7865.stdout4
-rw-r--r--testsuite/tests/simplCore/should_compile/spec-inline.stderr28
14 files changed, 79 insertions, 67 deletions
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 0c62e4fb06..75e91a4408 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -189,14 +189,15 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)])
, pprCoreExpr rhs
]
else add_par $
- sep [sep [text "case" <+> pprCoreExpr expr,
- ifPprDebug (text "return" <+> ppr ty),
- sep [text "of" <+> ppr_bndr var,
- char '{' <+> ppr_case_pat con args <+> arrow]
- ],
- pprCoreExpr rhs,
- char '}'
- ]
+ sep [sep [sep [ text "case" <+> pprCoreExpr expr
+ , ifPprDebug (text "return" <+> ppr ty)
+ , text "of" <+> ppr_bndr var
+ ]
+ , char '{' <+> ppr_case_pat con args <+> arrow
+ ]
+ , pprCoreExpr rhs
+ , char '}'
+ ]
where
ppr_bndr = pprBndr CaseBind
@@ -259,13 +260,13 @@ ppr_case_pat (DataAlt dc) args
| Just sort <- tyConTuple_maybe tc
= tupleParens sort (pprWithCommas ppr_bndr args)
where
- ppr_bndr = pprBndr CaseBind
+ ppr_bndr = pprBndr CasePatBind
tc = dataConTyCon dc
ppr_case_pat con args
= ppr con <+> (fsep (map ppr_bndr args))
where
- ppr_bndr = pprBndr CaseBind
+ ppr_bndr = pprBndr CasePatBind
-- | Pretty print the argument in a function application.
@@ -292,6 +293,21 @@ With -dppr-case-as-let we print them as such:
Other printing bits-and-bobs used with the general @pprCoreBinding@
and @pprCoreExpr@ functions.
+
+
+Note [Binding-site specific printing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust
+the information printed.
+
+Let-bound binders are printed with their full type and idInfo.
+
+Case-bound variables (both the case binder and pattern variables) are printed
+without a type and without their unfolding.
+
+Furthermore, a dead case-binder is completely ignored, while otherwise, dead
+binders are printed as "_".
-}
instance OutputableBndr Var where
@@ -321,6 +337,10 @@ pprTypedLamBinder bind_site debug_on var
= sdocWithDynFlags $ \dflags ->
case () of
_
+ | not debug_on -- Show case-bound wild bilders only if debug is on
+ , CaseBind <- bind_site
+ , isDeadBinder var -> empty
+
| not debug_on -- Even dead binders can be one-shot
, isDeadBinder var -> char '_' <+> ppWhen (isId var)
(pprIdBndrInfo (idInfo var))
@@ -328,6 +348,9 @@ pprTypedLamBinder bind_site debug_on var
| not debug_on -- No parens, no kind info
, CaseBind <- bind_site -> pprUntypedBinder var
+ | not debug_on
+ , CasePatBind <- bind_site -> pprUntypedBinder var
+
| suppress_sigs dflags -> pprUntypedBinder var
| isTyVar var -> parens (pprKindedTyVarBndr var)
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 4d5e72cc56..2799c0e68d 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -525,7 +525,7 @@ ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR ->
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
- = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
+ = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
ppr_monobind (FunBind { fun_id = fun,
fun_co_fn = wrap,
fun_matches = matches,
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 4145d9e974..87bbb94166 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -740,7 +740,7 @@ pprStgExpr (StgCase expr bndr alt_type alts)
pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
=> GenStgAlt bndr occ -> SDoc
pprStgAlt (con, params, expr)
- = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), text "->"])
+ = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
4 (ppr expr <> semi)
pprStgOp :: StgOp -> SDoc
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 64b3542706..d61b1ec802 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -837,7 +837,12 @@ instance Outputable Extension where
-- | 'BindingSite' is used to tell the thing that prints binder what
-- language construct is binding the identifier. This can be used
-- to decide how much info to print.
-data BindingSite = LambdaBind | CaseBind | LetBind
+-- Also see Note [Binding-site specific printing] in PprCore
+data BindingSite
+ = LambdaBind -- ^ The x in (\x. e)
+ | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... }
+ | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }
+ | LetBind -- ^ The x in (let x = rhs in e)
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 04069c7198..43ffb06033 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -19,7 +19,7 @@ T2431.$WRefl =
-- RHS size: {terms: 4, types: 8, coercions: 0}
absurd :: forall a. Int :~: Bool -> a
[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x]
-absurd = \ (@ a) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
+absurd = \ (@ a) (x :: Int :~: Bool) -> case x of { }
-- RHS size: {terms: 2, types: 0, coercions: 0}
$trModule1 :: GHC.Types.TrName
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 4bbd50e716..ea9fb3eb86 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -40,14 +40,12 @@ dr :: Double -> Double
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: Double) ->
- case x of _ [Occ=Dead] { GHC.Types.D# x1 ->
+ case x of { GHC.Types.D# x1 ->
GHC.Types.D# (GHC.Prim.+## x1 x1)
}}]
dr =
\ (x :: Double) ->
- case x of _ [Occ=Dead] { 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: 1, types: 0, coercions: 0}
dl :: Double -> Double
@@ -59,9 +57,7 @@ dl :: Double -> Double
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: Double) ->
- case x of _ [Occ=Dead] { 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 = dr
-- RHS size: {terms: 8, types: 3, coercions: 0}
@@ -74,12 +70,12 @@ fr :: Float -> Float
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: Float) ->
- case x of _ [Occ=Dead] { GHC.Types.F# x1 ->
+ case x of { GHC.Types.F# x1 ->
GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
}}]
fr =
\ (x :: Float) ->
- case x of _ [Occ=Dead] { GHC.Types.F# x1 ->
+ case x of { GHC.Types.F# x1 ->
GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
}
@@ -93,7 +89,7 @@ fl :: Float -> Float
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: Float) ->
- case x of _ [Occ=Dead] { GHC.Types.F# y ->
+ case x of { GHC.Types.F# y ->
GHC.Types.F# (GHC.Prim.plusFloat# y y)
}}]
fl = fr
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index 66a14f1c9b..a7c1e55c52 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -53,12 +53,12 @@ foo [InlPrag=INLINE[0]] :: Int -> Int
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: Int) ->
- case w of _ [Occ=Dead] { GHC.Types.I# ww1 [Occ=Once] ->
+ case w of { GHC.Types.I# ww1 [Occ=Once] ->
case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
}}]
foo =
\ (w :: Int) ->
- case w of _ [Occ=Dead] { GHC.Types.I# ww1 ->
+ case w of { GHC.Types.I# ww1 ->
case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
}
diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout
index fdbcc88bae..d70c0eee55 100644
--- a/testsuite/tests/simplCore/should_compile/T3772.stdout
+++ b/testsuite/tests/simplCore/should_compile/T3772.stdout
@@ -19,9 +19,8 @@ foo [InlPrag=NOINLINE] :: Int -> ()
[GblId, Arity=1, Caf=NoCafRefs, Str=<S(S),1*U(U)>]
foo =
\ (n :: Int) ->
- case n of _ [Occ=Dead] { GHC.Types.I# y ->
- case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# y)
- of _ [Occ=Dead] {
+ case n of { GHC.Types.I# y ->
+ case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# y) of {
False -> GHC.Tuple.();
True -> $wxs y
}
diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr
index 2137dd8942..947d16a206 100644
--- a/testsuite/tests/simplCore/should_compile/T4908.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4908.stderr
@@ -58,8 +58,8 @@ T4908.$wf =
\ (ww :: Int#) (w :: (Int, Int)) ->
case ww of ds {
__DEFAULT ->
- case w of _ [Occ=Dead] { (a, b) ->
- case b of _ [Occ=Dead] { I# ds1 ->
+ case w of { (a, b) ->
+ case b of { I# ds1 ->
case ds1 of ds2 {
__DEFAULT -> T4908.f_$s$wf a ds2 (-# ds 1#);
0# -> GHC.Types.True
@@ -79,10 +79,10 @@ f [InlPrag=INLINE[0]] :: Int -> (Int, Int) -> Bool
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: Int) (w1 [Occ=Once] :: (Int, Int)) ->
- case w of _ [Occ=Dead] { I# ww1 [Occ=Once] -> T4908.$wf ww1 w1 }}]
+ case w of { I# ww1 [Occ=Once] -> T4908.$wf ww1 w1 }}]
f =
\ (w :: Int) (w1 :: (Int, Int)) ->
- case w of _ [Occ=Dead] { I# ww1 -> T4908.$wf ww1 w1 }
+ case w of { I# ww1 -> T4908.$wf ww1 w1 }
------ Local rules for imported ids --------
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index e6045a31ab..7e51aa68be 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -37,13 +37,13 @@ T4930.$wfoo [InlPrag=[0], Occ=LoopBreaker]
[GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>]
T4930.$wfoo =
\ (ww :: GHC.Prim.Int#) ->
- case case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# ww 5#)
- of _ [Occ=Dead] {
+ case case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# ww 5#) of {
False -> GHC.Types.I# (GHC.Prim.+# ww 2#);
True ->
case T4930.$wfoo ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 }
}
- of _ [Occ=Dead] { GHC.Types.I# ipv ->
+ of
+ { GHC.Types.I# ipv ->
GHC.Prim.+# ww 5#
}
end Rec }
@@ -58,12 +58,12 @@ foo [InlPrag=INLINE[0]] :: Int -> Int
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: Int) ->
- case w of _ [Occ=Dead] { GHC.Types.I# ww1 [Occ=Once] ->
+ case w of { GHC.Types.I# ww1 [Occ=Once] ->
case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
}}]
foo =
\ (w :: Int) ->
- case w of _ [Occ=Dead] { GHC.Types.I# ww1 ->
+ case w of { GHC.Types.I# ww1 ->
case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
}
diff --git a/testsuite/tests/simplCore/should_compile/T5366.stdout b/testsuite/tests/simplCore/should_compile/T5366.stdout
index df0f9ba05d..735d059fb5 100644
--- a/testsuite/tests/simplCore/should_compile/T5366.stdout
+++ b/testsuite/tests/simplCore/should_compile/T5366.stdout
@@ -1 +1,2 @@
- case ds of _ [Occ=Dead] { Bar dt dt1 -> GHC.Types.I# dt }
+ case ds of { Bar dt [Occ=Once] _ [Occ=Dead] -> GHC.Types.I# dt }}]
+f = \ (ds :: Bar) -> case ds of { Bar dt dt1 -> GHC.Types.I# dt }
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index f9c0215130..4598b3e8d1 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -12,21 +12,15 @@ T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False)
Tmpl= \ (dt [Occ=Once!] :: Int) ->
- case dt of _ [Occ=Dead] { GHC.Types.I# dt [Occ=Once] ->
- T7360.Foo3 dt
- }}]
+ case dt of { GHC.Types.I# dt [Occ=Once] -> T7360.Foo3 dt }}]
T7360.$WFoo3 =
\ (dt [Occ=Once!] :: Int) ->
- case dt of _ [Occ=Dead] { GHC.Types.I# dt [Occ=Once] ->
- T7360.Foo3 dt
- }
+ case dt of { GHC.Types.I# dt [Occ=Once] -> T7360.Foo3 dt }
-- RHS size: {terms: 5, types: 2, coercions: 0}
fun1 [InlPrag=NOINLINE] :: Foo -> ()
[GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>]
-fun1 =
- \ (x :: Foo) ->
- case x of _ [Occ=Dead] { __DEFAULT -> GHC.Tuple.() }
+fun1 = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Tuple.() }
-- RHS size: {terms: 2, types: 0, coercions: 0}
T7360.fun5 :: ()
diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout
index b06e47d4b9..7cad614b6d 100644
--- a/testsuite/tests/simplCore/should_compile/T7865.stdout
+++ b/testsuite/tests/simplCore/should_compile/T7865.stdout
@@ -1,4 +1,4 @@
expensive [InlPrag=NOINLINE] :: Int -> Int
expensive =
- case expensive sc1 of _ [Occ=Dead] { GHC.Types.I# x ->
- (case expensive x of _ [Occ=Dead] { GHC.Types.I# x1 ->
+ case expensive sc1 of { GHC.Types.I# x ->
+ (case expensive x of { GHC.Types.I# x1 ->
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index a1dc5144a7..441b4ed391 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -56,14 +56,11 @@ Roman.foo_$s$wgo =
(GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# sc sc) sc) sc) sc)
sc)
sc } in
- case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# sc1 0#)
- of _ [Occ=Dead] {
+ case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# sc1 0#) of {
False ->
- case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 100#)
- of _ [Occ=Dead] {
+ case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 100#) of {
False ->
- case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 500#)
- of _ [Occ=Dead] {
+ case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 500#) of {
False -> Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# sc1 1#);
True -> Roman.foo_$s$wgo m (GHC.Prim.-# sc1 3#)
};
@@ -82,10 +79,10 @@ Roman.$wgo [InlPrag=[0]] :: Maybe Int -> Maybe Int -> GHC.Prim.Int#
WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 30] 256 0}]
Roman.$wgo =
\ (w :: Maybe Int) (w1 :: Maybe Int) ->
- case w1 of _ [Occ=Dead] {
+ case w1 of {
Nothing -> case Roman.foo3 of wild1 { };
Just x ->
- case x of _ [Occ=Dead] { GHC.Types.I# ipv ->
+ case x of { GHC.Types.I# ipv ->
let {
m :: GHC.Prim.Int#
[LclId]
@@ -96,18 +93,15 @@ Roman.$wgo =
(GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# ipv ipv) ipv) ipv) ipv)
ipv)
ipv } in
- case w of _ [Occ=Dead] {
+ case w of {
Nothing -> Roman.foo_$s$wgo m 10#;
Just n ->
- case n of _ [Occ=Dead] { GHC.Types.I# x2 ->
- case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# x2 0#)
- of _ [Occ=Dead] {
+ case n of { GHC.Types.I# x2 ->
+ case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# x2 0#) of {
False ->
- case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 100#)
- of _ [Occ=Dead] {
+ case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 100#) of {
False ->
- case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 500#)
- of _ [Occ=Dead] {
+ case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 500#) of {
False -> Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# x2 1#);
True -> Roman.foo_$s$wgo m (GHC.Prim.-# x2 3#)
};
@@ -167,7 +161,7 @@ foo :: Int -> Int
}}]
foo =
\ (n :: Int) ->
- case n of _ [Occ=Dead] { GHC.Types.I# ipv ->
+ case n of { GHC.Types.I# ipv ->
case Roman.foo_$s$wgo 6# ipv of ww { __DEFAULT -> GHC.Types.I# ww }
}
View Lorry Controller Status