[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Scrub some partiality in `GHC.Cmm.Info.Build`: `doSRTs` takes a `[(CAFSet,...
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Dec 21 03:18:02 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
703a4665 by M Farkas-Dyck at 2022-12-20T21:14:46-05:00
Scrub some partiality in `GHC.Cmm.Info.Build`: `doSRTs` takes a `[(CAFSet, CmmDecl)]` but truly wants a `[(CAFSet, CmmStatics)]`.
- - - - -
9736ab74 by Matthew Pickering at 2022-12-20T21:15:22-05:00
packaging: Fix upload_ghc_libs.py script
This change reflects the changes where .cabal files are now generated by
hadrian rather than ./configure.
Fixes #22518
- - - - -
7c6de18d by Ben Gamari at 2022-12-20T21:15:57-05:00
configure: Drop uses of AC_PROG_CC_C99
As noted in #22566, this macro is deprecated as of autoconf-2.70
`AC_PROG_CC` now sets `ac_cv_prog_cc_c99` itself.
Closes #22566.
- - - - -
36c5d98e by Ben Gamari at 2022-12-20T21:15:57-05:00
configure: Use AS_HELP_STRING instead of AC_HELP_STRING
The latter has been deprecated.
See #22566.
- - - - -
befe6ff8 by Bodigrim at 2022-12-20T21:16:37-05:00
GHCi.UI: fix various usages of head and tail
- - - - -
666d0ba7 by Bodigrim at 2022-12-20T21:16:37-05:00
GHCi.UI: avoid head and tail in parseCallEscape and around
- - - - -
5d96fd50 by Bodigrim at 2022-12-20T21:16:37-05:00
Make GHC.Driver.Main.hscTcRnLookupRdrName to return NonEmpty
- - - - -
b721ddf9 by Bodigrim at 2022-12-20T22:17:42-05:00
Allow transformers-0.6 in ghc, ghci, ghc-bin and hadrian
- - - - -
dcf1e7e3 by Bodigrim at 2022-12-20T22:17:42-05:00
Update submodule haskeline to HEAD (to allow transformers-0.6)
- - - - -
d019ede0 by Bodigrim at 2022-12-20T22:17:42-05:00
Update submodule transformers to 0.6.0.4
- - - - -
abf73af6 by Bodigrim at 2022-12-20T22:17:42-05:00
Fix tests
T13253 imports MonadTrans, which acquired a quantified constraint in transformers-0.6, thus increase in allocations
Metric Increase:
T13253
- - - - -
4aaee208 by Simon Peyton Jones at 2022-12-20T22:17:44-05:00
Abstract over the right free vars
Fix #22459, in two ways:
(1) Make the Specialiser not create a bogus specialisation if
it is presented by strangely polymorphic dictionary.
See Note [Weird special case in SpecDict] in
GHC.Core.Opt.Specialise
(2) Be more careful in abstractFloats
See Note [Which type variables to abstract over]
in GHC.Core.Opt.Simplify.Utils.
So (2) stops creating the excessively polymorphic dictionary in
abstractFloats, while (1) stops crashing if some other pass should
nevertheless create a weirdly polymorphic dictionary.
- - - - -
24 changed files:
- .gitlab/upload_ghc_libs.py
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/ghc.cabal.in
- configure.ac
- distrib/configure.ac.in
- ghc/GHCi/UI.hs
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/transformers
- − m4/fp_set_cflags_c99.m4
- testsuite/tests/ghci/scripts/T5979.stderr
- + testsuite/tests/simplCore/should_compile/T22459.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitlab/upload_ghc_libs.py
=====================================
@@ -51,15 +51,19 @@ def prep_base():
def build_copy_file(pkg: Package, f: Path):
target = Path('_build') / 'stage1' / pkg.path / 'build' / f
dest = pkg.path / f
- print(f'Building {target} for {dest}...')
+ build_file_hadrian(target)
+ print(f'Copying {target} to {dest}...')
+ dest.parent.mkdir(exist_ok=True, parents=True)
+ shutil.copyfile(target, dest)
+
+def build_file_hadrian(target: Path):
build_cabal = Path('hadrian') / 'build-cabal'
if not build_cabal.is_file():
build_cabal = Path('hadrian') / 'build.cabal.sh'
+ print(f'Building {target}...')
run([build_cabal, target], check=True)
- dest.parent.mkdir(exist_ok=True, parents=True)
- shutil.copyfile(target, dest)
def modify_file(pkg: Package, fname: Path, f: Callable[[str], str]):
target = pkg.path / fname
@@ -116,6 +120,7 @@ def prepare_sdist(pkg: Package):
print(f'Preparing package {pkg.name}...')
shutil.rmtree(pkg.path / 'dist-newstyle', ignore_errors=True)
+ build_file_hadrian(pkg.path / '{}.cabal'.format(pkg.name))
pkg.prepare_sdist()
# Upload source tarball
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -7,11 +7,14 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE EmptyCase #-}
module GHC.Cmm (
-- * Cmm top-level datatypes
CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
+ CmmDataDecl, cmmDataDeclCmmDecl,
CmmGraph, GenCmmGraph(..),
toBlockMap, revPostorder, toBlockList,
CmmBlock, RawCmmDecl,
@@ -52,6 +55,7 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Utils.Outputable
+import Data.Void (Void)
import Data.List (intersperse)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
@@ -116,6 +120,14 @@ instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platfor
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
+type CmmDataDecl = GenCmmDataDecl CmmStatics
+type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded
+
+cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g
+cmmDataDeclCmmDecl = \ case
+ CmmProc void _ _ _ -> case void of
+ CmmData section d -> CmmData section d
+{-# INLINE cmmDataDeclCmmDecl #-}
type RawCmmDecl
= GenCmmDecl
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
- ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
+ ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -884,7 +884,7 @@ doSRTs
:: CmmConfig
-> ModuleSRTInfo
-> [(CAFEnv, [CmmDecl])] -- ^ 'CAFEnv's and 'CmmDecl's for code blocks
- -> [(CAFSet, CmmDecl)] -- ^ static data decls and their 'CAFSet's
+ -> [(CAFSet, CmmDataDecl)] -- ^ static data decls and their 'CAFSet's
-> IO (ModuleSRTInfo, [CmmDeclSRTs])
doSRTs cfg moduleSRTInfo procs data_ = do
@@ -900,8 +900,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
flip map data_ $
\(set, decl) ->
case decl of
- CmmProc{} ->
- pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
+ CmmProc void _ _ _ -> case void of
CmmData _ static ->
case static of
CmmStatics lbl _ _ _ _ -> (lbl, set)
@@ -909,7 +908,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
(proc_envs, procss) = unzip procs
cafEnv = mapUnions proc_envs
- decls = map snd data_ ++ concat procss
+ decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss
staticFuns = mapFromList (getStaticFuns decls)
platform = cmmPlatform cfg
@@ -980,8 +979,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
| otherwise ->
-- Not an IdLabel, ignore
srtMap
- CmmProc{} ->
- pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))
+ CmmProc void _ _ _ -> case void of)
(moduleSRTMap moduleSRTInfo') data_
return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -67,8 +67,8 @@ cmmPipeline logger cmm_config srtInfo prog = do
-- [SRTs].
--
-- - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing
-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
-cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))
+cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))
+cpsTop _logger platform _ (CmmData section statics) = return (Right (cafAnalData platform statics, CmmData section statics))
cpsTop logger platform cfg proc =
do
----------- Control-flow optimisations ----------------------------------
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2063,34 +2063,51 @@ it is guarded by the doFloatFromRhs call in simplLazyBind.
Note [Which type variables to abstract over]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Abstract only over the type variables free in the rhs wrt which the
-new binding is abstracted. Note that
-
- * The naive approach of abstracting wrt the
- tyvars free in the Id's /type/ fails. Consider:
- /\ a b -> let t :: (a,b) = (e1, e2)
- x :: a = fst t
- in ...
- Here, b isn't free in x's type, but we must nevertheless
- abstract wrt b as well, because t's type mentions b.
- Since t is floated too, we'd end up with the bogus:
- poly_t = /\ a b -> (e1, e2)
- poly_x = /\ a -> fst (poly_t a *b*)
-
- * We must do closeOverKinds. Example (#10934):
+new binding is abstracted. Several points worth noting
+
+(AB1) The naive approach of abstracting wrt the
+ tyvars free in the Id's /type/ fails. Consider:
+ /\ a b -> let t :: (a,b) = (e1, e2)
+ x :: a = fst t
+ in ...
+ Here, b isn't free in x's type, but we must nevertheless
+ abstract wrt b as well, because t's type mentions b.
+ Since t is floated too, we'd end up with the bogus:
+ poly_t = /\ a b -> (e1, e2)
+ poly_x = /\ a -> fst (poly_t a *b*)
+
+(AB2) We must do closeOverKinds. Example (#10934):
f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...
- Here we want to float 't', but we must remember to abstract over
- 'k' as well, even though it is not explicitly mentioned in the RHS,
- otherwise we get
- t = /\ (f:k->*) (a:k). AccFailure @ (f a)
- which is obviously bogus.
-
- * We get the variables to abstract over by filtering down the
- the main_tvs for the original function, picking only ones
- mentioned in the abstracted body. This means:
- - they are automatically in dependency order, because main_tvs is
- - there is no issue about non-determinism
- - we don't gratuitously change order, which may help (in a tiny
- way) with CSE and/or the compiler-debugging experience
+ Here we want to float 't', but we must remember to abstract over
+ 'k' as well, even though it is not explicitly mentioned in the RHS,
+ otherwise we get
+ t = /\ (f:k->*) (a:k). AccFailure @ (f a)
+ which is obviously bogus.
+
+(AB3) We get the variables to abstract over by filtering down the
+ the main_tvs for the original function, picking only ones
+ mentioned in the abstracted body. This means:
+ - they are automatically in dependency order, because main_tvs is
+ - there is no issue about non-determinism
+ - we don't gratuitously change order, which may help (in a tiny
+ way) with CSE and/or the compiler-debugging experience
+
+(AB4) For a recursive group, it's a bit of a pain to work out the minimal
+ set of tyvars over which to abstract:
+ /\ a b c. let x = ...a... in
+ letrec { p = ...x...q...
+ q = .....p...b... } in
+ ...
+ Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
+ over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
+ Remember this bizarre case too:
+ x::a = x
+ Here, we must abstract 'x' over 'a'.
+
+ Why is it worth doing this? Partly tidiness; and partly #22459
+ which showed that it's harder to do polymorphic specialisation well
+ if there are dictionaries abstracted over unnecessary type variables.
+ See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise
-}
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
@@ -2115,33 +2132,40 @@ abstractFloats uf_opts top_lvl main_tvs floats body
rhs' = GHC.Core.Subst.substExpr subst rhs
-- tvs_here: see Note [Which type variables to abstract over]
- tvs_here = filter (`elemVarSet` free_tvs) main_tvs
- free_tvs = closeOverKinds $
- exprSomeFreeVars isTyVar rhs'
+ tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')
abstract subst (Rec prs)
- = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
- ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
- poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
- | (poly_id, rhs) <- poly_ids `zip` rhss
- , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
- ; return (subst', Rec poly_pairs) }
+ = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
+ ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
+ poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
+ | (poly_id, rhs) <- poly_ids `zip` rhss
+ , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
+ ; return (subst', Rec poly_pairs) }
+ where
+ (ids,rhss) = unzip prs
+
+
+ -- tvs_here: see Note [Which type variables to abstract over]
+ tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)
+
+ -- See wrinkle (AB4) in Note [Which type variables to abstract over]
+ get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs
+ get_rec_rhs_tvs rhs = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)
+
+ get_tvs :: Var -> VarSet -> VarSet
+ get_tvs var free_tvs
+ | isTyVar var -- CoVars have been substituted away
+ = extendVarSet free_tvs var
+ | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var
+ = -- 'var' is like 'x' in (AB4)
+ exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs
+ | otherwise
+ = free_tvs
+
+ choose_tvs free_tvs
+ = filter (`elemVarSet` all_free_tvs) main_tvs -- (AB3)
where
- (ids,rhss) = unzip prs
- -- For a recursive group, it's a bit of a pain to work out the minimal
- -- set of tyvars over which to abstract:
- -- /\ a b c. let x = ...a... in
- -- letrec { p = ...x...q...
- -- q = .....p...b... } in
- -- ...
- -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
- -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
- -- Since it's a pain, we just use the whole set, which is always safe
- --
- -- If you ever want to be more selective, remember this bizarre case too:
- -- x::a = x
- -- Here, we must abstract 'x' over 'a'.
- tvs_here = scopedSort main_tvs
+ all_free_tvs = closeOverKinds free_tvs -- (AB2)
mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
mk_poly1 tvs_here var
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -2516,6 +2516,8 @@ specHeader env (bndr : bndrs) (UnspecType : args)
-- the nitty-gritty), as a LHS rule and unfolding details.
specHeader env (bndr : bndrs) (SpecDict d : args)
| not (isDeadBinder bndr)
+ , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
+ -- See Note [Weird special case for SpecDict]
= do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
@@ -2531,6 +2533,8 @@ specHeader env (bndr : bndrs) (SpecDict d : args)
, spec_dict : spec_args
)
}
+ where
+ in_scope = Core.getSubstInScope (se_subst env)
-- Finally, we don't want to specialise on this argument 'i':
-- - It's an UnSpecArg, or
@@ -2752,6 +2756,8 @@ monomorpic, and specialised in one go.
Wrinkles.
+* See Note [Weird special case for SpecDict]
+
* With -XOverlappingInstances you might worry about this:
class C a where ...
instance C (Maybe Int) where ... -- $df1 :: C (Maybe Int)
@@ -2777,6 +2783,33 @@ Wrinkles.
it's a hard test to make.)
But see Note [Specialisation and overlapping instances].
+
+Note [Weird special case for SpecDict]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are trying to specialise for this this call:
+ $wsplit @T (mkD @k @(a::k) :: C T)
+where
+ mkD :: forall k (a::k). C T
+is a top-level dictionary-former. This actually happened in #22459,
+because of (MP1) of Note [Specialising polymorphic dictionaries].
+
+How can we speicalise $wsplit? We might try
+
+ RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit
+
+but then in the body of $s$wsplit what will we use for the dictionary
+evidence? We can't use (mkD @k @(a::k)) because k and a aren't in scope.
+We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that
+is a lot of hard work for a very strange case.
+
+So we simply refrain from specialising in this case; hence the guard
+ allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
+in the SpecDict cased of specHeader.
+
+How did this strange polymorphic mkD arise in the first place?
+From GHC.Core.Opt.Utils.abstractFloats, which was abstracting
+over too many type variables. But that too is now fixed;
+see Note [Which type variables to abstract over] in that module.
-}
instance Outputable DictBind where
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.Core.Subst (
deShadowBinds, substRuleInfo, substRulesForImportedIds,
substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
- lookupIdSubst, substIdType, substIdOcc,
+ lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,
substTickish, substDVarSet, substIdInfo,
-- ** Operations on substitutions
@@ -184,9 +184,11 @@ extendSubstList subst [] = subst
extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
-- | Find the substitution for an 'Id' in the 'Subst'
+-- The Id should not be a CoVar
lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr
lookupIdSubst (Subst in_scope ids _ _) v
- | not (isLocalId v) = Var v
+ | assertPpr (isId v && not (isCoVar v)) (ppr v)
+ not (isLocalId v) = Var v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the IdSubstEnv]
@@ -194,6 +196,12 @@ lookupIdSubst (Subst in_scope ids _ _) v
-- it's a bad bug and we really want to know
| otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope)
+lookupIdSubst_maybe :: HasDebugCallStack => Subst -> Id -> Maybe CoreExpr
+-- Just look up in the substitution; do not check the in-scope set
+lookupIdSubst_maybe (Subst _ ids _ _) v
+ = assertPpr (isId v && not (isCoVar v)) (ppr v) $
+ lookupVarEnv ids v
+
delBndr :: Subst -> Var -> Subst
delBndr (Subst in_scope ids tvs cvs) v
| isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -266,6 +266,7 @@ import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
import Data.List ( nub, isPrefixOf, partition )
+import qualified Data.List.NonEmpty as NE
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
@@ -445,11 +446,15 @@ ioMsgMaybe' ioA = do
-- -----------------------------------------------------------------------------
-- | Lookup things in the compiler's environment
-hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
+hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
hscTcRnLookupRdrName hsc_env0 rdr_name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
- ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
+ -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage.
+ -- Once errors has been dealt with in hoistTcRnMessage, we can enforce
+ -- this invariant in types by converting to NonEmpty.
+ ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $
+ tcRnLookupRdrName hsc_env rdr_name }
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
=====================================
compiler/GHC/Runtime/Debugger.hs
=====================================
@@ -49,6 +49,7 @@ import GHC.Types.TyThing
import Control.Monad
import Control.Monad.Catch as MC
import Data.List ( (\\), partition )
+import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.IORef
@@ -57,7 +58,7 @@ import Data.IORef
-------------------------------------
pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
pprintClosureCommand bindThings force str = do
- tythings <- (catMaybes . concat) `liftM`
+ tythings <- (catMaybes . concatMap NE.toList) `liftM`
mapM (\w -> GHC.parseName w >>=
mapM GHC.lookupName)
(words str)
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -121,6 +121,7 @@ import Data.Either
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
+import Data.List.NonEmpty (NonEmpty)
import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
@@ -903,7 +904,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do
-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
-parseName :: GhcMonad m => String -> m [Name]
+parseName :: GhcMonad m => String -> m (NonEmpty Name)
parseName str = withSession $ \hsc_env -> liftIO $
do { lrdr_name <- hscParseIdentifier hsc_env str
; hscTcRnLookupRdrName hsc_env lrdr_name }
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -151,6 +152,7 @@ import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Time
import Data.Time.Format.ISO8601
+import Data.Void
import GHC.Fingerprint
import GHC.Show ( showMultiLineString )
@@ -1173,6 +1175,8 @@ instance OutputableP env SDoc where
instance (OutputableP env a) => OutputableP env (Set a) where
pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s))))
+instance OutputableP env Void where
+ pdoc _ = \ case
{-
************************************************************************
=====================================
compiler/ghc.cabal.in
=====================================
@@ -88,7 +88,7 @@ Library
filepath >= 1 && < 1.5,
template-haskell == 2.19.*,
hpc == 0.6.*,
- transformers == 0.5.*,
+ transformers >= 0.5 && < 0.7,
exceptions == 0.10.*,
stm,
ghc-boot == @ProjectVersionMunged@,
=====================================
configure.ac
=====================================
@@ -143,7 +143,7 @@ if test "$EnableDistroToolchain" = "YES"; then
fi
AC_ARG_ENABLE(asserts-all-ways,
-[AC_HELP_STRING([--enable-asserts-all-ways],
+[AS_HELP_STRING([--enable-asserts-all-ways],
[Usually ASSERTs are only compiled in the DEBUG way,
this will enable them in all ways.])],
[FP_CAPITALIZE_YES_NO(["$enableval"], [EnableAssertsAllWays])],
@@ -485,11 +485,6 @@ FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs)
AC_SUBST([HaskellCPPCmd])
AC_SUBST([HaskellCPPArgs])
-FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS])
-FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
-
dnl ** Which ld to use
dnl --------------------------------------------------------------
AC_ARG_VAR(LD,[Use as the path to ld. See also --disable-ld-override.])
=====================================
distrib/configure.ac.in
=====================================
@@ -111,11 +111,6 @@ FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs)
AC_SUBST([HaskellCPPCmd])
AC_SUBST([HaskellCPPArgs])
-FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS])
-dnl FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
-
dnl ** Which ld to use?
dnl --------------------------------------------------------------
FIND_LD([$target],[GccUseLdOpt])
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -122,7 +122,7 @@ import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( elemIndices, find, intercalate, intersperse,
+import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
@@ -941,23 +941,26 @@ getInfoForPrompt = do
return (dots <> context_bit, modules_names, line)
-parseCallEscape :: String -> (String, String)
-parseCallEscape s
- | not (all isSpace beforeOpen) = ("", "")
- | null sinceOpen = ("", "")
- | null sinceClosed = ("", "")
- | null cmd = ("", "")
- | otherwise = (cmd, tail sinceClosed)
- where
- (beforeOpen, sinceOpen) = span (/='(') s
- (cmd, sinceClosed) = span (/=')') (tail sinceOpen)
+-- | Takes a string, presumably following "%call", and tries to parse
+-- a command and arguments in parentheses:
+--
+-- > parseCallEscape " (cmd arg1 arg2)rest" = Just ("cmd" :| ["arg1", "arg2"], "rest")
+-- > parseCallEscape "( )rest" = Nothing
+--
+parseCallEscape :: String -> Maybe (NE.NonEmpty String, String)
+parseCallEscape s = case dropWhile isSpace s of
+ '(' : sinceOpen -> case span (/= ')') sinceOpen of
+ (call, ')' : sinceClosed)
+ | cmd : args <- words call -> Just (cmd NE.:| args, sinceClosed)
+ _ -> Nothing
+ _ -> Nothing
checkPromptStringForErrors :: String -> Maybe String
checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
case parseCallEscape xs of
- ("", "") -> Just ("Incorrect %call syntax. " ++
+ Nothing -> Just ("Incorrect %call syntax. " ++
"Should be %call(a command and arguments).")
- (_, afterClosed) -> checkPromptStringForErrors afterClosed
+ Just (_, afterClosed) -> checkPromptStringForErrors afterClosed
checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
checkPromptStringForErrors "" = Nothing
@@ -1010,10 +1013,12 @@ generatePromptFunctionFromString promptS modules_names line =
processString ('%':'V':xs) =
liftM ((text $ showVersion compilerVersion) <>) (processString xs)
processString ('%':'c':'a':'l':'l':xs) = do
+ -- Input has just been validated by parseCallEscape
+ let (cmd NE.:| args, afterClosed) = fromJust $ parseCallEscape xs
respond <- liftIO $ do
(code, out, err) <-
readProcessWithExitCode
- (head list_words) (tail list_words) ""
+ cmd args ""
`catchIO` \e -> return (ExitFailure 1, "", show e)
case code of
ExitSuccess -> return out
@@ -1021,9 +1026,6 @@ generatePromptFunctionFromString promptS modules_names line =
hPutStrLn stderr err
return ""
liftM ((text respond) <>) (processString afterClosed)
- where
- (cmd, afterClosed) = parseCallEscape xs
- list_words = words cmd
processString ('%':'%':xs) =
liftM ((char '%') <>) (processString xs)
processString (x:xs) =
@@ -1055,10 +1057,7 @@ installInteractivePrint :: GhciMonad m => Maybe String -> Bool -> m ()
installInteractivePrint Nothing _ = return ()
installInteractivePrint (Just ipFun) exprmode = do
ok <- trySuccess $ do
- names <- GHC.parseName ipFun
- let name = case names of
- name':_ -> name'
- [] -> panic "installInteractivePrint"
+ name NE.:| _ <- GHC.parseName ipFun
modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
in he{hsc_IC = new_ic})
return Succeeded
@@ -1374,12 +1373,13 @@ afterRunStmt step_here run_result = do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
GHC.ExecBreak names mb_info
- | isNothing mb_info ||
- step_here (GHC.resumeSpan $ head resumes) -> do
+ | first_resume : _ <- resumes
+ , isNothing mb_info ||
+ step_here (GHC.resumeSpan first_resume) -> do
mb_id_loc <- toBreakIdAndLocation mb_info
let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
if (null bCmd)
- then printStoppedAtBreakInfo (head resumes) names
+ then printStoppedAtBreakInfo first_resume names
else enqueueCommands [bCmd]
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
@@ -1596,7 +1596,7 @@ infoThing allInfo str = do
names <- GHC.parseName str
mb_stuffs <- mapM (GHC.getInfo allInfo) names
let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
- (catMaybes mb_stuffs)
+ (catMaybes (NE.toList mb_stuffs))
return $ vcat (intersperse (text "") $ map pprInfo filtered)
-- Filter out names whose parent is also there. Good
@@ -1917,7 +1917,7 @@ docCmd s = do
docs <- traverse (buildDocComponents s) names
- let sdocs = pprDocs docs
+ let sdocs = pprDocs (NE.toList docs)
sdocs' = vcat (intersperse (text "") sdocs)
sdoc <- showSDocForUser' sdocs'
liftIO (putStrLn sdoc)
@@ -2607,15 +2607,14 @@ guessCurrentModule :: GHC.GhcMonad m => String -> m Module
-- Guess which module the user wants to browse. Pick
-- modules that are interpreted first. The most
-- recently-added module occurs last, it seems.
-guessCurrentModule cmd
- = do imports <- GHC.getContext
- when (null imports) $ throwGhcException $
- CmdLineError (':' : cmd ++ ": no current module")
- case (head imports) of
- IIModule m -> GHC.findQualifiedModule NoPkgQual m
- IIDecl d -> do
- pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
- GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
+guessCurrentModule cmd = do
+ imports <- GHC.getContext
+ case imports of
+ [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")
+ IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m
+ IIDecl d : _ -> do
+ pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
+ GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
-- without bang, show items in context of their parents and omit children
-- with bang, show class methods and data constructors separately, and
@@ -3507,18 +3506,15 @@ completeCmd argLine0 = case parseLine argLine0 of
liftIO $ print r
_ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
where
- parseLine argLine
- | null argLine = Nothing
- | null rest1 = Nothing
- | otherwise = (,,) dom <$> resRange <*> s
- where
- (dom, rest1) = breakSpace argLine
- (rng, rest2) = breakSpace rest1
- resRange | head rest1 == '"' = parseRange ""
- | otherwise = parseRange rng
- s | head rest1 == '"' = readMaybe rest1 :: Maybe String
- | otherwise = readMaybe rest2
- breakSpace = fmap (dropWhile isSpace) . break isSpace
+ parseLine [] = Nothing
+ parseLine argLine = case breakSpace argLine of
+ (_, []) -> Nothing
+ (dom, rest1@('"' : _)) -> (dom,,) <$> parseRange "" <*> (readMaybe rest1 :: Maybe String)
+ (dom, rest1) -> (dom,,) <$> parseRange rng <*> readMaybe rest2
+ where
+ (rng, rest2) = breakSpace rest1
+
+ breakSpace = fmap (dropWhile isSpace) . break isSpace
takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
@@ -3658,7 +3654,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
createInscope :: GhciMonad m => String -> m [(String, Module)]
createInscope str_rdr = do
names <- GHC.parseName str_rdr
- pure $ zip (repeat str_rdr) $ GHC.nameModule <$> names
+ pure $ map (str_rdr, ) $ NE.toList $ GHC.nameModule <$> names
-- For every top-level identifier in scope, add the bids of the nested
-- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types
@@ -3666,7 +3662,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
addNestedDecls (ident, mod) = do
(_, decls) <- getModBreak mod
let (mod_str, topLvl, _) = splitIdent ident
- ident_decls = filter ((topLvl ==) . head) $ elems decls
+ ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ]
bids = nub $ declPath <$> ident_decls
pure $ map (combineModIdent mod_str) bids
@@ -3843,7 +3839,7 @@ enclosingTickSpan md (RealSrcSpan src _) = do
massert (inRange (bounds ticks) line)
let enclosing_spans = [ pan | (_,pan) <- ticks ! line
, realSrcSpanEnd pan >= realSrcSpanEnd src]
- return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
+ return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans
where
leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
@@ -4110,9 +4106,7 @@ breakById inp = do
lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)
lookupModuleInscope mod_top_lvl = do
names <- GHC.parseName mod_top_lvl
- pure $ Just $ head $ GHC.nameModule <$> names
- -- if GHC.parseName succeeds `names` is not empty!
- -- if it fails, the last line will not be evaluated.
+ pure $ Just $ NE.head $ GHC.nameModule <$> names
-- Lookup the Module of a module name in the module graph
lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)
@@ -4645,20 +4639,17 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m
-> m ()
wantNameFromInterpretedModule noCanDo str and_then =
handleSourceError GHC.printException $ do
- names <- GHC.parseName str
- case names of
- [] -> return ()
- (n:_) -> do
- let modl = assert (isExternalName n) $ GHC.nameModule n
- if not (GHC.isExternalName n)
- then noCanDo n $ ppr n <>
- text " is not defined in an interpreted module"
- else do
- is_interpreted <- GHC.moduleIsInterpreted modl
- if not is_interpreted
- then noCanDo n $ text "module " <> ppr modl <>
- text " is not interpreted"
- else and_then n
+ n NE.:| _ <- GHC.parseName str
+ let modl = assert (isExternalName n) $ GHC.nameModule n
+ if not (GHC.isExternalName n)
+ then noCanDo n $ ppr n <>
+ text " is not defined in an interpreted module"
+ else do
+ is_interpreted <- GHC.moduleIsInterpreted modl
+ if not is_interpreted
+ then noCanDo n $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else and_then n
clearCaches :: GhciMonad m => m ()
clearCaches = discardActiveBreakPoints
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -38,7 +38,7 @@ Executable ghc
process >= 1 && < 1.7,
filepath >= 1 && < 1.5,
containers >= 0.5 && < 0.7,
- transformers == 0.5.*,
+ transformers >= 0.5 && < 0.7,
ghc-boot == @ProjectVersionMunged@,
ghc == @ProjectVersionMunged@
=====================================
hadrian/hadrian.cabal
=====================================
@@ -158,7 +158,7 @@ executable hadrian
, mtl >= 2.2 && < 2.4
, parsec >= 3.1 && < 3.2
, shake >= 0.18.3 && < 0.20
- , transformers >= 0.4 && < 0.6
+ , transformers >= 0.4 && < 0.7
, unordered-containers >= 0.2.1 && < 0.3
, text >= 1.2 && < 3
ghc-options: -Wall
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -80,7 +80,7 @@ library
ghc-boot == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,
template-haskell == 2.19.*,
- transformers == 0.5.*
+ transformers >= 0.5 && < 0.7
if !os(windows)
Build-Depends: unix >= 2.7 && < 2.9
=====================================
libraries/haskeline
=====================================
@@ -1 +1 @@
-Subproject commit d4f343509e905a717ea463ad84462c126d8990d8
+Subproject commit ad40faf532ca86ae6d0839a299234db2ce4fc424
=====================================
libraries/transformers
=====================================
@@ -1 +1 @@
-Subproject commit def8c55d0c47c1c40de985d83f052f3659b40cfd
+Subproject commit 2745db6c374c7e830a0f8fdeb8cc39bd8f054f36
=====================================
m4/fp_set_cflags_c99.m4 deleted
=====================================
@@ -1,38 +0,0 @@
-# FP_SET_CFLAGS_C99
-# ----------------------------------
-# figure out which CFLAGS are needed to place the compiler into C99 mode
-# $1 is name of CC variable (unmodified)
-# $2 is name of CC flags variable (augmented if needed)
-# $3 is name of CPP flags variable (augmented if needed)
-AC_DEFUN([FP_SET_CFLAGS_C99],
-[
- dnl save current state of AC_PROG_CC_C99
- FP_COPY_SHELLVAR([CC],[fp_save_CC])
- FP_COPY_SHELLVAR([CFLAGS],[fp_save_CFLAGS])
- FP_COPY_SHELLVAR([CPPFLAGS],[fp_save_CPPFLAGS])
- FP_COPY_SHELLVAR([ac_cv_prog_cc_c99],[fp_save_cc_c99])
- dnl set local state
- CC="$$1"
- CFLAGS="$$2"
- CPPFLAGS="$$3"
- unset ac_cv_prog_cc_c99
- dnl perform detection
- AC_PROG_CC_C99
- fp_cc_c99="$ac_cv_prog_cc_c99"
- case "x$ac_cv_prog_cc_c99" in
- x) ;; # noop
- xno) AC_MSG_ERROR([C99-compatible compiler needed]) ;;
- *) $2="$$2 $ac_cv_prog_cc_c99"
- $3="$$3 $ac_cv_prog_cc_c99"
- ;;
- esac
- dnl restore saved state
- FP_COPY_SHELLVAR([fp_save_CC],[CC])
- FP_COPY_SHELLVAR([fp_save_CFLAGS],[CFLAGS])
- FP_COPY_SHELLVAR([fp_save_CPPFLAGS],[CPPFLAGS])
- FP_COPY_SHELLVAR([fp_save_cc_c99],[ac_cv_prog_cc_c99])
- dnl cleanup
- unset fp_save_CC
- unset fp_save_CFLAGS
- unset fp_save_cc_c99
-])
=====================================
testsuite/tests/ghci/scripts/T5979.stderr
=====================================
@@ -4,4 +4,4 @@
Perhaps you meant
Control.Monad.Trans.State (from transformers-0.5.6.2)
Control.Monad.Trans.Cont (from transformers-0.5.6.2)
- Control.Monad.Trans.List (from transformers-0.5.6.2)
+ Control.Monad.Trans.Class (from transformers-0.5.6.2)
=====================================
testsuite/tests/simplCore/should_compile/T22459.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -O #-}
+
+module Lib (foo) where
+
+import qualified Data.Map as M
+
+newtype Fix f = Fix (f (Fix f))
+
+instance Eq (f (Fix f)) => Eq (Fix f) where
+ Fix a == Fix b = a == b
+
+instance Ord (f (Fix f)) => Ord (Fix f) where
+ Fix a `compare` Fix b = a `compare` b
+
+data Foo i r = Foo i r
+ deriving (Eq, Ord)
+
+newtype Bar a = Bar (M.Map Char (M.Map (Fix (Foo ())) Word))
+
+foo :: Bar a -> Bar a -> Bar a
+foo (Bar a) (Bar b) = Bar (M.unionWith M.union a b)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -458,3 +458,4 @@ test('T22494', [grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-un
test('T22491', normal, compile, ['-O2'])
test('T21476', normal, compile, [''])
test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings -fno-omit-interface-pragmas -fno-ignore-interface-pragmas'])
+test('T22459', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8965610f0aa2b1366012c60b03766eb1edbbcf34...4aaee2087ce5d3a63b1d8352ce1a15e096f777e8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8965610f0aa2b1366012c60b03766eb1edbbcf34...4aaee2087ce5d3a63b1d8352ce1a15e096f777e8
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/20221220/626e7a95/attachment-0001.html>
More information about the ghc-commits
mailing list