[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Fix minimal imports dump for boot files (fix #18497)
Marge Bot
gitlab at gitlab.haskell.org
Thu Jul 30 21:04:45 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9fa080e9 by Sylvain Henry at 2020-07-30T17:04:37-04:00
Fix minimal imports dump for boot files (fix #18497)
- - - - -
f412d075 by Sylvain Henry at 2020-07-30T17:04:39-04:00
DynFlags: don't use sdocWithDynFlags in datacon ppr
We don't need to use `sdocWithDynFlags` to know whether we should
display linear types for datacon types, we already have
`sdocLinearTypes` field in `SDocContext`. Moreover we want to remove
`sdocWithDynFlags` (#10143, #17957)).
- - - - -
6a1853af by Sylvain Henry at 2020-07-30T17:04:40-04:00
Bignum: fix powMod for gmp backend (#18515)
Also reenable integerPowMod test which had never been reenabled by
mistake.
- - - - -
21 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/Ppr/TyThing.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Types/Origin.hs
- libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs
- testsuite/tests/lib/integer/all.T
- testsuite/tests/lib/integer/integerPowMod.hs
- testsuite/tests/lib/integer/integerPowMod.stdout
- + testsuite/tests/numeric/should_run/T18515.hs
- + testsuite/tests/numeric/should_run/T18515.stdout
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/rename/should_compile/Makefile
- + testsuite/tests/rename/should_compile/T18497.stdout
- + testsuite/tests/rename/should_compile/T18497_Bar.hs
- + testsuite/tests/rename/should_compile/T18497_Bar.hs-boot
- + testsuite/tests/rename/should_compile/T18497_Foo.hs
- + testsuite/tests/rename/should_compile/T18497_Foo.hs-boot
- testsuite/tests/rename/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -87,9 +87,6 @@ import GHC.Utils.Binary
import GHC.Types.Unique.Set
import GHC.Types.Unique( mkAlphaTyVarUnique )
-import GHC.Driver.Session
-import GHC.LanguageExtensions as LangExt
-
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as LBS
@@ -1337,7 +1334,7 @@ The type of the constructor, with linear arrows replaced by unrestricted ones.
Used when we don't want to introduce linear types to user (in holes
and in types in hie used by haddock).
-3. dataConDisplayType (depends on DynFlags):
+3. dataConDisplayType (take a boolean indicating if -XLinearTypes is enabled):
The type we'd like to show in error messages, :info and -ddump-types.
Ideally, it should reflect the type written by the user;
the function returns a type with arrows that would be required
@@ -1384,9 +1381,9 @@ dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs,
mkVisFunTys arg_tys' $
res_ty
-dataConDisplayType :: DynFlags -> DataCon -> Type
-dataConDisplayType dflags dc
- = if xopt LangExt.LinearTypes dflags
+dataConDisplayType :: Bool -> DataCon -> Type
+dataConDisplayType show_linear_types dc
+ = if show_linear_types
then dataConWrapperType dc
else dataConNonlinearType dc
=====================================
compiler/GHC/Core/Ppr/TyThing.hs
=====================================
@@ -166,7 +166,8 @@ pprTyThing :: ShowSub -> TyThing -> SDoc
-- We pretty-print 'TyThing' via 'IfaceDecl'
-- See Note [Pretty-printing TyThings]
pprTyThing ss ty_thing
- = sdocWithDynFlags (\dflags -> pprIfaceDecl ss' (tyThingToIfaceDecl dflags ty_thing))
+ = sdocOption sdocLinearTypes $ \show_linear_types ->
+ pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)
where
ss' = case ss_how_much ss of
ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' }
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -28,6 +28,7 @@ import GHC.Iface.Recomp
import GHC.Iface.Load
import GHC.CoreToIface
+import qualified GHC.LanguageExtensions as LangExt
import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )
import GHC.Types.Id
import GHC.Types.Annotations
@@ -225,7 +226,8 @@ mkIface_ hsc_env
= do
let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
entities = typeEnvElts type_env
- decls = [ tyThingToIfaceDecl (hsc_dflags hsc_env) entity
+ show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)
+ decls = [ tyThingToIfaceDecl show_linear_types entity
| entity <- entities,
let name = getName entity,
not (isImplicitTyThing entity),
@@ -376,12 +378,12 @@ so we may need to split up a single Avail into multiple ones.
************************************************************************
-}
-tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl
+tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl
tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id
tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax
-tyThingToIfaceDecl dflags (AConLike cl) = case cl of
- RealDataCon dc -> dataConToIfaceDecl dflags dc -- for ppr purposes only
+tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of
+ RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only
PatSynCon ps -> patSynToIfaceDecl ps
--------------------------
@@ -397,10 +399,10 @@ idToIfaceDecl id
ifIdInfo = toIfaceIdInfo (idInfo id) }
--------------------------
-dataConToIfaceDecl :: DynFlags -> DataCon -> IfaceDecl
-dataConToIfaceDecl dflags dataCon
+dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl
+dataConToIfaceDecl show_linear_types dataCon
= IfaceId { ifName = getName dataCon,
- ifType = toIfaceType (dataConDisplayType dflags dataCon),
+ ifType = toIfaceType (dataConDisplayType show_linear_types dataCon),
ifIdDetails = IfVanillaId,
ifIdInfo = [] }
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -1234,11 +1234,11 @@ lookupChildren all_kids rdr_items
*********************************************************
-}
-reportUnusedNames :: TcGblEnv -> RnM ()
-reportUnusedNames gbl_env
+reportUnusedNames :: TcGblEnv -> HscSource -> RnM ()
+reportUnusedNames gbl_env hsc_src
= do { keep <- readTcRef (tcg_keep gbl_env)
; traceRn "RUN" (ppr (tcg_dus gbl_env))
- ; warnUnusedImportDecls gbl_env
+ ; warnUnusedImportDecls gbl_env hsc_src
; warnUnusedTopBinds $ unused_locals keep
; warnMissingSignatures gbl_env }
where
@@ -1360,8 +1360,8 @@ type ImportDeclUsage
, [GlobalRdrElt] -- What *is* used (normalised)
, [Name] ) -- What is imported but *not* used
-warnUnusedImportDecls :: TcGblEnv -> RnM ()
-warnUnusedImportDecls gbl_env
+warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM ()
+warnUnusedImportDecls gbl_env hsc_src
= do { uses <- readMutVar (tcg_used_gres gbl_env)
; let user_imports = filterOut
(ideclImplicit . unLoc)
@@ -1383,7 +1383,7 @@ warnUnusedImportDecls gbl_env
mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage
; whenGOptM Opt_D_dump_minimal_imports $
- printMinimalImports usage }
+ printMinimalImports hsc_src usage }
findImportUsage :: [LImportDecl GhcRn]
-> [GlobalRdrElt]
@@ -1619,9 +1619,9 @@ getMinimalImports = mapM mk_minimal
all_non_overloaded = all (not . flIsOverloaded)
-printMinimalImports :: [ImportDeclUsage] -> RnM ()
+printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM ()
-- See Note [Printing minimal imports]
-printMinimalImports imports_w_usage
+printMinimalImports hsc_src imports_w_usage
= do { imports' <- getMinimalImports imports_w_usage
; this_mod <- getModule
; dflags <- getDynFlags
@@ -1638,7 +1638,11 @@ printMinimalImports imports_w_usage
| Just d <- dumpDir dflags = d </> basefn
| otherwise = basefn
where
- basefn = moduleNameString (moduleName this_mod) ++ ".imports"
+ suffix = case hsc_src of
+ HsBootFile -> ".imports-boot"
+ HsSrcFile -> ".imports"
+ HsigFile -> ".imports"
+ basefn = moduleNameString (moduleName this_mod) ++ suffix
to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -301,7 +301,7 @@ tcRnModuleTcRnM hsc_env mod_sum
-- Do this /after/ typeinference, so that when reporting
-- a function with no type signature we can give the
-- inferred type
- reportUnusedNames tcg_env
+ reportUnusedNames tcg_env hsc_src
; -- add extra source files to tcg_dependent_files
addDependentFiles src_files
; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env
@@ -2973,8 +2973,8 @@ ppr_datacons debug type_env
= ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
-- The filter gets rid of class data constructors
where
- ppr_dc dc = sdocWithDynFlags (\dflags ->
- ppr dc <+> dcolon <+> ppr (dataConDisplayType dflags dc))
+ ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types ->
+ ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc))
all_dcs = typeEnvDataCons type_env
wanted_dcs | debug = all_dcs
| otherwise = filterOut is_cls_dc all_dcs
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -4136,7 +4136,8 @@ checkValidDataCon dflags existential_ok tc con
= hang herald 2 (text "on the" <+> speakNth n
<+> text "argument of" <+> quotes (ppr con))
- data_con_display_type = dataConDisplayType dflags con
+ show_linear_types = xopt LangExt.LinearTypes dflags
+ data_con_display_type = dataConDisplayType show_linear_types con
-------------------------------
checkNewDataCon :: DataCon -> TcM ()
@@ -4152,10 +4153,10 @@ checkNewDataCon con
[ text "A newtype cannot have an unlifted argument type"
, text "Perhaps you intended to use UnliftedNewtypes"
]
- ; dflags <- getDynFlags
+ ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags
; let check_con what msg =
- checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con))
+ checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))
; checkTc (ok_mult (scaledMult arg_ty1)) $
text "A newtype constructor must be linear"
@@ -4843,10 +4844,10 @@ badGadtDecl tc_name
badExistential :: DataCon -> SDoc
badExistential con
- = sdocWithDynFlags (\dflags ->
+ = sdocOption sdocLinearTypes (\show_linear_types ->
hang (text "Data constructor" <+> quotes (ppr con) <+>
text "has existential type variables, a context, or a specialised result type")
- 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)
+ 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)
, parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]))
badStupidTheta :: Name -> SDoc
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -286,10 +286,10 @@ pprSigSkolInfo ctxt ty
pprPatSkolInfo :: ConLike -> SDoc
pprPatSkolInfo (RealDataCon dc)
- = sdocWithDynFlags (\dflags ->
+ = sdocOption sdocLinearTypes (\show_linear_types ->
sep [ text "a pattern with constructor:"
, nest 2 $ ppr dc <+> dcolon
- <+> pprType (dataConDisplayType dflags dc) <> comma ])
+ <+> pprType (dataConDisplayType show_linear_types dc) <> comma ])
-- pprType prints forall's regardless of -fprint-explicit-foralls
-- which is what we want here, since we might be saying
-- type variable 't' is bound by ...
=====================================
libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs
=====================================
@@ -349,7 +349,8 @@ bignat_powmod
-> State# RealWorld
-> State# RealWorld
bignat_powmod r b e m s =
- ioVoid (integer_gmp_powm# r b (wordArraySize# b) e (wordArraySize# e) m (wordArraySize# m)) s
+ case ioInt# (integer_gmp_powm# r b (wordArraySize# b) e (wordArraySize# e) m (wordArraySize# m)) s of
+ (# s', n #) -> mwaSetSize# r (narrowGmpSize# n) s'
----------------------------------------------------------------------
=====================================
testsuite/tests/lib/integer/all.T
=====================================
@@ -5,11 +5,11 @@ test('integerConstantFolding', normal, makefile_test, ['integerConstantFolding']
test('fromToInteger', [], makefile_test, ['fromToInteger'])
test('IntegerConversionRules', [], makefile_test, ['IntegerConversionRules'])
test('gcdInteger', normal, compile_and_run, [''])
+test('integerPowMod', [], compile_and_run, [''])
# skip ghci as it doesn't support unboxed tuples
test('integerImportExport', [omit_ways(['ghci'])], compile_and_run, [''])
# Disable GMP only tests
#test('integerGcdExt', [omit_ways(['ghci'])], compile_and_run, [''])
-#test('integerPowMod', [], compile_and_run, [''])
#test('integerGmpInternals', [], compile_and_run, [''])
=====================================
testsuite/tests/lib/integer/integerPowMod.hs
=====================================
@@ -7,19 +7,12 @@ import Control.Monad
import GHC.Word
import GHC.Base
-import qualified GHC.Integer.GMP.Internals as I
-
-powModSecInteger :: Integer -> Integer -> Integer -> Integer
-powModSecInteger = I.powModSecInteger
-
-powModInteger :: Integer -> Integer -> Integer -> Integer
-powModInteger = I.powModInteger
+import GHC.Natural
main :: IO ()
main = do
- print $ powModInteger b e m
- print $ powModInteger b e (m-1)
- print $ powModSecInteger b e (m-1)
+ print $ powModNatural b e m
+ print $ powModNatural b e (m-1)
where
b = 2988348162058574136915891421498819466320163312926952423791023078876139
=====================================
testsuite/tests/lib/integer/integerPowMod.stdout
=====================================
@@ -1,3 +1,2 @@
1527229998585248450016808958343740453059
682382427572745901624116300491295556924
-682382427572745901624116300491295556924
=====================================
testsuite/tests/numeric/should_run/T18515.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Num.BigNat
+import GHC.Num.Integer
+
+main :: IO ()
+main =
+ let b = integerToBigNatClamp# 251943445928310882947152017889649234
+ e = integerToBigNatClamp# 503886891856621765894304035779298468
+ m = integerToBigNatClamp# 503886891856621765894304035779298469
+ r = integerFromBigNat# (bigNatPowMod b e m)
+ in print r
=====================================
testsuite/tests/numeric/should_run/T18515.stdout
=====================================
@@ -0,0 +1 @@
+1
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -72,3 +72,4 @@ test('T17303', normal, compile_and_run, [''])
test('T18359', normal, compile_and_run, [''])
test('T18499', normal, compile_and_run, [''])
test('T18509', normal, compile_and_run, [''])
+test('T18515', normal, compile_and_run, [''])
=====================================
testsuite/tests/rename/should_compile/Makefile
=====================================
@@ -56,3 +56,7 @@ T7969:
'$(TEST_HC)' $(TEST_HC_OPTS) -c T7969a.hs
'$(TEST_HC)' $(TEST_HC_OPTS) -c T7969.hs -ddump-minimal-imports
cat T7969.imports
+
+T18497:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code T18497_Foo.hs T18497_Bar.hs -ddump-minimal-imports
+ cat T18497_Bar.imports-boot
=====================================
testsuite/tests/rename/should_compile/T18497.stdout
=====================================
@@ -0,0 +1,5 @@
+[1 of 4] Compiling T18497_Foo[boot] ( T18497_Foo.hs-boot, nothing )
+[2 of 4] Compiling T18497_Bar[boot] ( T18497_Bar.hs-boot, nothing )
+[3 of 4] Compiling T18497_Foo ( T18497_Foo.hs, nothing )
+[4 of 4] Compiling T18497_Bar ( T18497_Bar.hs, nothing )
+import {-# SOURCE #-} T18497_Foo ( X )
=====================================
testsuite/tests/rename/should_compile/T18497_Bar.hs
=====================================
@@ -0,0 +1,14 @@
+module T18497_Bar where
+
+import T18497_Foo
+
+data Y = SomeY X | NoY
+
+blah :: Y
+blah = NoY
+
+blip :: Y
+blip = SomeY foo
+
+woop NoX = NoY
+woop (SomeX y _) = y
=====================================
testsuite/tests/rename/should_compile/T18497_Bar.hs-boot
=====================================
@@ -0,0 +1,9 @@
+module T18497_Bar where
+
+import {-# SOURCE #-} T18497_Foo
+
+data Y
+
+blah :: Y
+
+woop :: X -> Y
=====================================
testsuite/tests/rename/should_compile/T18497_Foo.hs
=====================================
@@ -0,0 +1,8 @@
+module T18497_Foo where
+
+import {-# SOURCE #-} T18497_Bar
+
+data X = SomeX Y Y | NoX
+
+foo :: X
+foo = SomeX blah (woop NoX)
=====================================
testsuite/tests/rename/should_compile/T18497_Foo.hs-boot
=====================================
@@ -0,0 +1,5 @@
+module T18497_Foo where
+
+data X
+
+foo :: X
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -174,3 +174,4 @@ test('T17244B', normal, compile, [''])
test('T17244C', normal, compile, [''])
test('T17832', [], multimod_compile, ['T17832M1', 'T17832M2'])
test('T17837', normal, compile, [''])
+test('T18497', [], makefile_test, ['T18497'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/062234fdaaa06b2de77095032cf4e7948b5a1a95...6a1853aff6f8b74cead5ed67262458c5c74b0ff2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/062234fdaaa06b2de77095032cf4e7948b5a1a95...6a1853aff6f8b74cead5ed67262458c5c74b0ff2
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/20200730/841d2da5/attachment-0001.html>
More information about the ghc-commits
mailing list