[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Do not print synonyms in :i (->), :i Type (#18594)
Marge Bot
gitlab at gitlab.haskell.org
Sun Aug 23 21:11:52 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8b865092 by Krzysztof Gogolewski at 2020-08-23T14:12:53+02:00
Do not print synonyms in :i (->), :i Type (#18594)
This adds a new printing flag `sdocPrintTypeAbbreviations` that is used
specifically to avoid ghci printing 'type (->) = (->)' and 'type Type = Type'.
- - - - -
d8f61182 by Krzysztof Gogolewski at 2020-08-23T14:12:56+02:00
Move pprTyTcApp' inside pprTyTcApp
No semantic change
- - - - -
d7d36d3c by Krzysztof Gogolewski at 2020-08-23T17:11:39-04:00
Fix types in silly shifts (#18589)
Patch written by Simon. I have only added a testcase.
- - - - -
eecaa756 by Sylvain Henry at 2020-08-23T17:11:43-04:00
Perf: make SDoc monad one-shot (#18202)
With validate-x86_64-linux-deb9-hadrian:
T1969 -3.4% (threshold: +/-1%)
T3294 -3.3% (threshold: +/-1%)
T12707 -1.4% (threshold: +/-1%)
Additionally with validate-x86_64-linux-deb9-unreg-hadrian:
T4801 -2.4% (threshold: +/-2%)
T13035 -1.4% (threshold: +/-1%)
T13379 -2.4% (threshold: +/-2%)
ManyAlternatives -2.5% (threshold: +/-2%)
ManyConstructors -3.0% (threshold: +/-2%)
Metric Decrease:
T12707
T1969
T3294
ManyAlternatives
ManyConstructors
T13035
T13379
T4801
- - - - -
14 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/ghci/T18060/T18060.stdout
- testsuite/tests/ghci/scripts/T8535.stdout
- testsuite/tests/ghci/scripts/ghci020.stdout
- testsuite/tests/ghci/should_run/T10145.stdout
- + testsuite/tests/ghci/should_run/T18594.script
- + testsuite/tests/ghci/should_run/T18594.stdout
- testsuite/tests/ghci/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T18589.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -143,11 +143,11 @@ primOpRules nm = \case
, inversePrimOp NotIOp ]
IntNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp IntNegOp ]
- ISllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)
+ ISllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftL)
, rightIdentityPlatform zeroi ]
- ISraOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)
+ ISraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftR)
, rightIdentityPlatform zeroi ]
- ISrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical
+ ISrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogical
, rightIdentityPlatform zeroi ]
-- Word operations
@@ -189,8 +189,8 @@ primOpRules nm = \case
, equalArgs >> retLit zerow ]
NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
, inversePrimOp NotOp ]
- SllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]
- SrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]
+ SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const Bits.shiftL) ]
+ SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogical ]
-- coercions
Word2IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform word2IntLit
@@ -477,12 +477,14 @@ wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) =
wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)
wordOpC2 _ _ _ _ = Nothing
-shiftRule :: (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr
+shiftRule :: LitNumType -- Type of the result, either LitNumInt or LitNumWord
+ -> (Platform -> Integer -> Int -> Integer)
+ -> RuleM CoreExpr
-- Shifts take an Int; hence third arg of op is Int
-- Used for shift primops
--- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word#
+-- ISllOp, ISraOp, ISrlOp :: Int# -> Int# -> Int#
-- SllOp, SrlOp :: Word# -> Int# -> Word#
-shiftRule shift_op
+shiftRule lit_num_ty shift_op
= do { platform <- getPlatform
; [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs
; case e1 of
@@ -490,7 +492,9 @@ shiftRule shift_op
-> return e1
-- See Note [Guarding against silly shifts]
| shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform)
- -> return $ Lit $ mkLitNumberWrap platform LitNumInt 0
+ -> return $ Lit $ mkLitNumberWrap platform lit_num_ty 0
+ -- Be sure to use lit_num_ty here, so we get a correctly typed zero
+ -- of type Int# or Word# resp. See #18589
-- Do the shift at type Integer, but shift length is Int
Lit (LitNumber nt x)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -5079,6 +5079,7 @@ initSDocContext dflags style = SDC
, sdocStarIsType = xopt LangExt.StarIsType dflags
, sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags
, sdocLinearTypes = xopt LangExt.LinearTypes dflags
+ , sdocPrintTypeAbbreviations = True
, sdocDynFlags = dflags
}
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -45,6 +45,8 @@ module GHC.Iface.Syntax (
import GHC.Prelude
+import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey )
+import GHC.Types.Unique ( hasKey )
import GHC.Iface.Type
import GHC.Iface.Recomp.Binary
import GHC.Core( IsOrphan, isOrphan )
@@ -947,13 +949,19 @@ pprIfaceDecl ss (IfaceSynonym { ifName = tc
, ifResKind = res_kind})
= vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)
, hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals)
- 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
+ 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau
, ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
]
where
(tvs, theta, tau) = splitIfaceSigmaTy mono_ty
name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc)
+ -- See Note [Printing type abbreviations] in GHC.Iface.Type
+ ppr_tau | tc `hasKey` liftedTypeKindTyConKey ||
+ tc `hasKey` unrestrictedFunTyConKey
+ = updSDocContext (\ctx -> ctx { sdocPrintTypeAbbreviations = False }) $ ppr tau
+ | otherwise = ppr tau
+
-- See Note [Suppressing binder signatures] in GHC.Iface.Type
suppress_bndr_sig = SuppressBndrSig True
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -783,6 +783,22 @@ Here we'd like to omit the kind annotation:
type F :: Symbol -> Type
type F s = blah
+
+Note [Printing type abbreviations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) and
+`FUN 'Many` as `(->)`.
+This way, error messages don't refer to levity polymorphism or linearity
+if it is not necessary.
+
+However, when printing the definition of Type or (->) with :info,
+this would give confusing output: `type (->) = (->)` (#18594).
+Solution: detect when we are in :info and disable displaying the synonym
+with the SDoc option sdocPrintTypeAbbreviations.
+
+If there will be a need, in the future we could expose it as a flag
+-fprint-type-abbreviations or even two separate flags controlling
+TYPE 'LiftedRep and FUN 'Many.
-}
-- | Do we want to suppress kind annotations on binders?
@@ -1364,56 +1380,55 @@ pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprTyTcApp ctxt_prec tc tys =
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
+ sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations ->
getPprDebug $ \debug ->
- pprTyTcApp' ctxt_prec tc tys (PrintExplicitKinds print_kinds) debug
-
-pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
- -> PrintExplicitKinds -> Bool -> SDoc
-pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug
- | ifaceTyConName tc `hasKey` ipClassKey
- , IA_Arg (IfaceLitTy (IfaceStrTyLit n))
- Required (IA_Arg ty Required IA_Nil) <- tys
- = maybeParen ctxt_prec funPrec
- $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
-
- | IfaceTupleTyCon arity sort <- ifaceTyConSort info
- , not debug
- , arity == ifaceVisAppArgsLength tys
- = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
-
- | IfaceSumTyCon arity <- ifaceTyConSort info
- = pprSum arity (ifaceTyConIsPromoted info) tys
-
- | tc `ifaceTyConHasKey` consDataConKey
- , PrintExplicitKinds False <- printExplicitKinds
- , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys
- , isInvisibleArgFlag argf
- = pprIfaceTyList ctxt_prec ty1 ty2
-
- | tc `ifaceTyConHasKey` tYPETyConKey
- , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys
- , rep `ifaceTyConHasKey` liftedRepDataConKey
- = ppr_kind_type ctxt_prec
- | tc `ifaceTyConHasKey` funTyConKey
- , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys
- , rep `ifaceTyConHasKey` manyDataConKey
- = pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) (appArgsIfaceTypes $ stripInvisArgs printExplicitKinds args))
-
- | otherwise
- = getPprDebug $ \dbg ->
- if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
+ if | ifaceTyConName tc `hasKey` ipClassKey
+ , IA_Arg (IfaceLitTy (IfaceStrTyLit n))
+ Required (IA_Arg ty Required IA_Nil) <- tys
+ -> maybeParen ctxt_prec funPrec
+ $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
+
+ | IfaceTupleTyCon arity sort <- ifaceTyConSort info
+ , not debug
+ , arity == ifaceVisAppArgsLength tys
+ -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
+
+ | IfaceSumTyCon arity <- ifaceTyConSort info
+ -> pprSum arity (ifaceTyConIsPromoted info) tys
+
+ | tc `ifaceTyConHasKey` consDataConKey
+ , False <- print_kinds
+ , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys
+ , isInvisibleArgFlag argf
+ -> pprIfaceTyList ctxt_prec ty1 ty2
+
+ | tc `ifaceTyConHasKey` tYPETyConKey
+ , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys
+ , rep `ifaceTyConHasKey` liftedRepDataConKey
+ , print_type_abbreviations -- See Note [Printing type abbreviations]
+ -> ppr_kind_type ctxt_prec
+
+ | tc `ifaceTyConHasKey` funTyConKey
+ , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys
+ , rep `ifaceTyConHasKey` manyDataConKey
+ , print_type_abbreviations -- See Note [Printing type abbreviations]
+ -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) $
+ appArgsIfaceTypes $ stripInvisArgs (PrintExplicitKinds print_kinds) args)
+
+ | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
+ , not debug
-- Suppress detail unless you _really_ want to see
- -> text "(TypeError ...)"
+ -> text "(TypeError ...)"
| Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
- -> doc
+ -> doc
| otherwise
- -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds
+ -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $
+ appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys
where
info = ifaceTyConInfo tc
- tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs printExplicitKinds tys
ppr_kind_type :: PprPrec -> SDoc
ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
{-
(c) The University of Glasgow 2006-2012
@@ -121,6 +122,7 @@ import qualified Data.List.NonEmpty as NEL
import GHC.Fingerprint
import GHC.Show ( showMultiLineString )
import GHC.Utils.Exception
+import GHC.Exts (oneShot)
{-
************************************************************************
@@ -304,7 +306,17 @@ code (either C or assembly), or generating interface files.
-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',
-- or 'renderWithContext'. Avoid calling 'runSDoc' directly as it breaks the
-- abstraction layer.
-newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
+newtype SDoc = SDoc' (SDocContext -> Doc)
+
+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
+{-# COMPLETE SDoc #-}
+pattern SDoc :: (SDocContext -> Doc) -> SDoc
+pattern SDoc m <- SDoc' m
+ where
+ SDoc m = SDoc' (oneShot m)
+
+runSDoc :: SDoc -> (SDocContext -> Doc)
+runSDoc (SDoc m) = m
data SDocContext = SDC
{ sdocStyle :: !PprStyle
@@ -344,6 +356,7 @@ data SDocContext = SDC
, sdocStarIsType :: !Bool
, sdocLinearTypes :: !Bool
, sdocImpredicativeTypes :: !Bool
+ , sdocPrintTypeAbbreviations :: !Bool
, sdocDynFlags :: DynFlags -- TODO: remove
}
@@ -390,6 +403,7 @@ defaultSDocContext = SDC
, sdocStarIsType = False
, sdocImpredicativeTypes = False
, sdocLinearTypes = False
+ , sdocPrintTypeAbbreviations = True
, sdocDynFlags = error "defaultSDocContext: DynFlags not available"
}
=====================================
testsuite/tests/ghci/T18060/T18060.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/scripts/T8535.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/scripts/ghci020.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/should_run/T10145.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/should_run/T18594.script
=====================================
@@ -0,0 +1,6 @@
+:m GHC.Types
+:i (->)
+:set -XStarIsType
+:i Type
+:set -XNoStarIsType
+:i Type
=====================================
testsuite/tests/ghci/should_run/T18594.stdout
=====================================
@@ -0,0 +1,15 @@
+type (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
+ -- Defined in ‘GHC.Types’
+infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Base’
+instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
+instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’
+type Type :: *
+type Type = TYPE 'LiftedRep
+ -- Defined in ‘GHC.Types’
+type Type :: Type
+type Type = TYPE 'LiftedRep
+ -- Defined in ‘GHC.Types’
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -75,3 +75,4 @@ test('T18064',
],
ghci_script,
['T18064.script'])
+test('T18594', just_ghci, ghci_script, ['T18594.script'])
=====================================
testsuite/tests/simplCore/should_compile/T18589.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE MagicHash #-}
+module T18589 where
+
+import GHC.Prim
+
+-- See Note [Guarding against silly shifts]
+-- Make sure that a silly shift is optimized correctly
+f1 x = uncheckedIShiftL# x -1#
+f2 x = uncheckedIShiftRA# x -1#
+f3 x = uncheckedIShiftRL# x -1#
+f4 x = uncheckedShiftL# x -1#
+f5 x = uncheckedShiftRL# x -1#
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -332,3 +332,4 @@ test('T18328', [ only_ways(['optasm']), grep_errmsg(r'Arity=') ], compile, ['-dd
test('T18347', normal, compile, ['-dcore-lint -O'])
test('T18355', [ grep_errmsg(r'OneShot') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
test('T18399', normal, compile, ['-dcore-lint -O'])
+test('T18589', normal, compile, ['-dcore-lint -O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bcf959e3f25d948aa48dc26440932ebd8dfbfdf1...eecaa756bb60f151a94a633d20c99993f5e7595a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bcf959e3f25d948aa48dc26440932ebd8dfbfdf1...eecaa756bb60f151a94a633d20c99993f5e7595a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200823/7d5a73cc/attachment-0001.html>
More information about the ghc-commits
mailing list