[Git][ghc/ghc][wip/t18251-error-messages] 10 commits: rts: Teach getNumProcessors to return available processors
Vladislav Zavialov
gitlab at gitlab.haskell.org
Sat May 30 14:12:58 UTC 2020
Vladislav Zavialov pushed to branch wip/t18251-error-messages at Glasgow Haskell Compiler / GHC
Commits:
4413828b by Ben Gamari at 2020-05-30T06:07:31-04:00
rts: Teach getNumProcessors to return available processors
Previously we would report the number of physical processors, which
can be quite wrong in a containerized setting. Now we rather return how
many processors are in our affinity mask when possible.
I also refactored the code to prefer platform-specific since this will
report logical CPUs instead of physical (using
`machdep.cpu.thread_count` on Darwin and `cpuset_getaffinity` on FreeBSD).
Fixes #14781.
- - - - -
1449435c by Ben Gamari at 2020-05-30T06:07:31-04:00
users-guide: Note change in getNumProcessors in users guide
- - - - -
3d960169 by Ben Gamari at 2020-05-30T06:07:31-04:00
rts: Drop compatibility shims for Windows Vista
We can now assume that the thread and processor group interfaces are
available.
- - - - -
7f8f948c by Peter Trommler at 2020-05-30T06:08:07-04:00
PPC NCG: Fix .size directive on powerpc64 ELF v1
Thanks to Sergei Trofimovich for pointing out the issue.
Fixes #18237
- - - - -
7c555b05 by Andreas Klebinger at 2020-05-30T06:08:43-04:00
Optimize GHC.Utils.Monad.
Many functions in this module are recursive and as such are marked
loop breakers. Which means they are unlikely to get an unfolding.
This is *bad*. We always want to specialize them to specific Monads.
Which requires a visible unfolding at the use site.
I rewrote the recursive ones from:
foo f x = ... foo x' ...
to
foo f x = go x
where
go x = ...
As well as giving some pragmas to make all of them available
for specialization.
The end result is a reduction of allocations of about -1.4% for
nofib/spectral/simple/Main.hs when compiled with `-O`.
-------------------------
Metric Decrease:
T12425
T14683
T5631
T9233
T9675
T9961
WWRec
-------------------------
- - - - -
8b1cb5df by Ben Gamari at 2020-05-30T06:09:20-04:00
Windows: Bump Windows toolchain to 0.2
- - - - -
6947231a by Zubin Duggal at 2020-05-30T06:10:02-04:00
Simplify contexts in GHC.Iface.Ext.Ast
- - - - -
db288f7b by Vladislav Zavialov at 2020-05-30T17:10:43+03:00
Improve parser error messages for the @-operator
Since GHC diverges from the Haskell Report by allowing the user
to define (@) as an infix operator, we better give a good
error message when the user does so unintentionally.
In general, this is rather hard to do, as some failures will be
discovered only in the renamer or the type checker:
x :: (Integer, Integer)
x @ (a, b) = (1, 2)
This patch does *not* address this general case.
However, it gives much better error messages when the binding
is not syntactically valid:
pairs xs @ (_:xs') = zip xs xs'
Before this patch, the error message was rather puzzling:
<interactive>:1:1: error: Parse error in pattern: pairs
After this patch, the error message includes a hint:
<interactive>:1:1: error:
Parse error in pattern: pairs
In a function binding for the ‘@’ operator.
Perhaps you meant an as-pattern, which must not be surrounded by whitespace
- - - - -
db3cdeea by Vladislav Zavialov at 2020-05-30T17:10:44+03:00
Improve parser error messages for TypeApplications
With this patch, we always parse f @t as a type application,
thereby producing better error messages.
This steals two syntactic forms:
* Prefix form of the @-operator in expressions. Since the @-operator is
a divergence from the Haskell Report anyway, this is not a major loss.
* Prefix form of @-patterns. Since we are stealing loose infix form
anyway, might as well sacrifice the prefix form for the sake of much
better error messages.
- - - - -
833faecd by Vladislav Zavialov at 2020-05-30T17:10:44+03:00
Improve parser error messages for TemplateHaskellQuotes
While [e| |], [t| |], [d| |], and so on, steal syntax from list
comprehensions, [| |] and [|| ||] do not steal any syntax.
Thus we can improve error messages by always accepting them in the
lexer. Turns out the renamer already performs necessary validation.
- - - - -
30 changed files:
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Utils/Monad.hs
- configure.ac
- docs/users_guide/8.12.1-notes.rst
- docs/users_guide/bugs.rst
- docs/users_guide/using-concurrent.rst
- hadrian/src/Settings/Packages.hs
- mk/get-win32-tarballs.py
- rts/ghc.mk
- rts/posix/OSThreads.c
- rts/win32/OSThreads.c
- + testsuite/tests/parser/should_fail/T18251a.hs
- + testsuite/tests/parser/should_fail/T18251a.stderr
- + testsuite/tests/parser/should_fail/T18251b.hs
- + testsuite/tests/parser/should_fail/T18251b.stderr
- + testsuite/tests/parser/should_fail/T18251c.hs
- + testsuite/tests/parser/should_fail/T18251c.stderr
- + testsuite/tests/parser/should_fail/T18251d.hs
- + testsuite/tests/parser/should_fail/T18251d.stderr
- + testsuite/tests/parser/should_fail/T18251e.hs
- + testsuite/tests/parser/should_fail/T18251e.stderr
- + testsuite/tests/parser/should_fail/T18251f.hs
- + testsuite/tests/parser/should_fail/T18251f.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/th/T12411.stderr
- testsuite/tests/typecheck/should_fail/T15527.stderr
Changes:
=====================================
compiler/GHC/CmmToAsm/PPC/Ppr.hs
=====================================
@@ -86,8 +86,13 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprSizeDecl :: Platform -> CLabel -> SDoc
pprSizeDecl platform lbl
= if osElfTarget (platformOS platform)
- then text "\t.size" <+> ppr lbl <> text ", .-" <> ppr lbl
+ then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl
else empty
+ where
+ prettyLbl = ppr lbl
+ codeLbl
+ | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl
+ | otherwise = prettyLbl
pprFunctionDescriptor :: CLabel -> SDoc
pprFunctionDescriptor lab = pprGloblDecl lab
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2,9 +2,12 @@
Main functions for .hie file generation
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -572,7 +575,7 @@ class ToHie a where
toHie :: a -> HieM [HieAST Type]
-- | Used to collect type info
-class Data a => HasType a where
+class HasType a where
getTypeNode :: a -> HieM [HieAST Type]
instance (ToHie a) => ToHie [a] where
@@ -584,12 +587,6 @@ instance (ToHie a) => ToHie (Bag a) where
instance (ToHie a) => ToHie (Maybe a) where
toHie = maybe (pure []) toHie
-instance ToHie (Context (Located NoExtField)) where
- toHie _ = pure []
-
-instance ToHie (TScoped NoExtField) where
- toHie _ = pure []
-
instance ToHie (IEContext (Located ModuleName)) where
toHie (IEC c (L (RealSrcSpan span _) mname)) = do
org <- ask
@@ -667,9 +664,6 @@ instance ToHie (EvBindContext (Located TcEvBinds)) where
]
toHie _ = pure []
-instance ToHie (EvBindContext (Located NoExtField)) where
- toHie _ = pure []
-
instance ToHie (Located HsWrapper) where
toHie (L osp wrap)
= case wrap of
@@ -685,32 +679,19 @@ instance ToHie (Located HsWrapper) where
concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
_ -> pure []
--- | Dummy instances - never called
-instance ToHie (TScoped (LHsSigWcType GhcTc)) where
- toHie _ = pure []
-instance ToHie (TScoped (LHsWcType GhcTc)) where
- toHie _ = pure []
-instance ToHie (SigContext (LSig GhcTc)) where
- toHie _ = pure []
-instance ToHie (TScoped Type) where
- toHie _ = pure []
-
-instance HasType (LHsBind GhcRn) where
- getTypeNode (L spn bind) = makeNode bind spn
+instance HiePass p => HasType (LHsBind (GhcPass p)) where
+ getTypeNode (L spn bind) =
+ case hiePass @p of
+ HieRn -> makeNode bind spn
+ HieTc -> case bind of
+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
+ _ -> makeNode bind spn
-instance HasType (LHsBind GhcTc) where
- getTypeNode (L spn bind) = case bind of
- FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
- _ -> makeNode bind spn
-
-instance HasType (Located (Pat GhcRn)) where
- getTypeNode (L spn pat) = makeNode pat spn
-
-instance HasType (Located (Pat GhcTc)) where
- getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat)
-
-instance HasType (LHsExpr GhcRn) where
- getTypeNode (L spn e) = makeNode e spn
+instance HiePass p => HasType (Located (Pat (GhcPass p))) where
+ getTypeNode (L spn pat) =
+ case hiePass @p of
+ HieRn -> makeNode pat spn
+ HieTc -> makeTypeNode pat spn (hsPatType pat)
-- | This instance tries to construct 'HieAST' nodes which include the type of
-- the expression. It is not yet possible to do this efficiently for all
@@ -727,73 +708,99 @@ instance HasType (LHsExpr GhcRn) where
-- expression's type is going to be expensive.
--
-- See #16233
-instance HasType (LHsExpr GhcTc) where
+instance HiePass p => HasType (LHsExpr (GhcPass p)) where
getTypeNode e@(L spn e') =
- -- Some expression forms have their type immediately available
- let tyOpt = case e' of
- HsLit _ l -> Just (hsLitType l)
- HsOverLit _ o -> Just (overLitType o)
-
- HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
- HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
- HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
-
- ExplicitList ty _ _ -> Just (mkListTy ty)
- ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
- HsDo ty _ _ -> Just ty
- HsMultiIf ty _ -> Just ty
-
- _ -> Nothing
-
- in
- case tyOpt of
- Just t -> makeTypeNode e' spn t
- Nothing
- | skipDesugaring e' -> fallback
- | otherwise -> do
- hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w)
- (_,mbe) <- liftIO $ deSugarExpr hs_env e
- maybe fallback (makeTypeNode e' spn . exprType) mbe
- where
- fallback = makeNode e' spn
-
- matchGroupType :: MatchGroupTc -> Type
- matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
-
- -- | Skip desugaring of these expressions for performance reasons.
- --
- -- See impact on Haddock output (esp. missing type annotations or links)
- -- before marking more things here as 'False'. See impact on Haddock
- -- performance before marking more things as 'True'.
- skipDesugaring :: HsExpr GhcTc -> Bool
- skipDesugaring e = case e of
- HsVar{} -> False
- HsUnboundVar{} -> False
- HsConLikeOut{} -> False
- HsRecFld{} -> False
- HsOverLabel{} -> False
- HsIPVar{} -> False
- XExpr (HsWrap{}) -> False
- _ -> True
-
-instance ( ToHie (Context (Located (IdP (GhcPass a))))
- , ToHie (MatchGroup (GhcPass a) (LHsExpr (GhcPass a)))
- , ToHie (PScoped (LPat (GhcPass a)))
- , ToHie (GRHSs (GhcPass a) (LHsExpr (GhcPass a)))
- , ToHie (LHsExpr (GhcPass a))
- , ToHie (Located (PatSynBind (GhcPass a) (GhcPass a)))
- , HasType (LHsBind (GhcPass a))
- , ModifyState (IdP (GhcPass a))
- , Data (HsBind (GhcPass a))
- , IsPass a
- ) => ToHie (BindContext (LHsBind (GhcPass a))) where
+ case hiePass @p of
+ HieRn -> makeNode e' spn
+ HieTc ->
+ -- Some expression forms have their type immediately available
+ let tyOpt = case e' of
+ HsLit _ l -> Just (hsLitType l)
+ HsOverLit _ o -> Just (overLitType o)
+
+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
+
+ ExplicitList ty _ _ -> Just (mkListTy ty)
+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
+ HsDo ty _ _ -> Just ty
+ HsMultiIf ty _ -> Just ty
+
+ _ -> Nothing
+
+ in
+ case tyOpt of
+ Just t -> makeTypeNode e' spn t
+ Nothing
+ | skipDesugaring e' -> fallback
+ | otherwise -> do
+ hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w)
+ (_,mbe) <- liftIO $ deSugarExpr hs_env e
+ maybe fallback (makeTypeNode e' spn . exprType) mbe
+ where
+ fallback = makeNode e' spn
+
+ matchGroupType :: MatchGroupTc -> Type
+ matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
+
+ -- | Skip desugaring of these expressions for performance reasons.
+ --
+ -- See impact on Haddock output (esp. missing type annotations or links)
+ -- before marking more things here as 'False'. See impact on Haddock
+ -- performance before marking more things as 'True'.
+ skipDesugaring :: HsExpr GhcTc -> Bool
+ skipDesugaring e = case e of
+ HsVar{} -> False
+ HsUnboundVar{} -> False
+ HsConLikeOut{} -> False
+ HsRecFld{} -> False
+ HsOverLabel{} -> False
+ HsIPVar{} -> False
+ XExpr (HsWrap{}) -> False
+ _ -> True
+
+data HiePassEv p where
+ HieRn :: HiePassEv 'Renamed
+ HieTc :: HiePassEv 'Typechecked
+
+class ( IsPass p
+ , HiePass (NoGhcTcPass p)
+ , ModifyState (IdGhcP p)
+ , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p))))
+ , Data (HsExpr (GhcPass p))
+ , Data (HsCmd (GhcPass p))
+ , Data (AmbiguousFieldOcc (GhcPass p))
+ , Data (HsCmdTop (GhcPass p))
+ , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p))))
+ , Data (HsSplice (GhcPass p))
+ , Data (HsLocalBinds (GhcPass p))
+ , Data (FieldOcc (GhcPass p))
+ , Data (HsTupArg (GhcPass p))
+ , Data (IPBind (GhcPass p))
+ , ToHie (Context (Located (IdGhcP p)))
+ , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p))))
+ , ToHie (RFContext (Located (FieldOcc (GhcPass p))))
+ , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p))))
+ , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p))))
+ , HasRealDataConName (GhcPass p)
+ )
+ => HiePass p where
+ hiePass :: HiePassEv p
+
+instance HiePass 'Renamed where
+ hiePass = HieRn
+instance HiePass 'Typechecked where
+ hiePass = HieTc
+
+instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where
toHie (BC context scope b@(L span bind)) =
concatM $ getTypeNode b : case bind of
FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
[ toHie $ C (ValBind context scope $ getRealSpan span) name
, toHie matches
- , case ghcPass @a of
- GhcTc -> toHie $ L span wrap
+ , case hiePass @p of
+ HieTc -> toHie $ L span wrap
_ -> pure []
]
PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
@@ -822,25 +829,22 @@ instance ( ToHie (Context (Located (IdP (GhcPass a))))
[ toHie $ L span psb -- PatSynBinds only occur at the top level
]
-instance ( ToHie (LMatch a body)
- ) => ToHie (MatchGroup a body) where
+instance ( HiePass p
+ , ToHie (Located body)
+ , Data body
+ ) => ToHie (MatchGroup (GhcPass p) (Located body)) where
toHie mg = case mg of
MG{ mg_alts = (L span alts) , mg_origin = origin} ->
local (setOrigin origin) $ concatM
[ locOnly span
, toHie alts
]
- XMatchGroup _ -> pure []
setOrigin :: Origin -> NodeOrigin -> NodeOrigin
setOrigin FromSource _ = SourceInfo
setOrigin Generated _ = GeneratedInfo
-instance ( ToHie (Context (Located (IdP a)))
- , ToHie (PScoped (LPat a))
- , ToHie (HsPatSynDir a)
- , (a ~ GhcPass p)
- ) => ToHie (Located (PatSynBind a a)) where
+instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
toHie (L sp psb) = concatM $ case psb of
PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
[ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
@@ -865,50 +869,39 @@ instance ( ToHie (Context (Located (IdP a)))
toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
toBind (RecCon r) = RecCon $ map (PSC detSpan) r
-instance ( ToHie (MatchGroup a (LHsExpr a))
- ) => ToHie (HsPatSynDir a) where
+instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where
toHie dir = case dir of
ExplicitBidirectional mg -> toHie mg
_ -> pure []
-instance ( a ~ GhcPass p
- , ToHie body
- , ToHie (HsMatchContext (NoGhcTc a))
- , ToHie (PScoped (LPat a))
- , ToHie (GRHSs a body)
- , Data (Match a body)
- ) => ToHie (LMatch (GhcPass p) body) where
- toHie (L span m ) = concatM $ makeNode m span : case m of
+instance ( HiePass p
+ , Data body
+ , ToHie (Located body)
+ ) => ToHie (LMatch (GhcPass p) (Located body)) where
+ toHie (L span m ) = concatM $ node : case m of
Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
[ toHie mctx
, let rhsScope = mkScope $ grhss_span grhss
in toHie $ patScopes Nothing rhsScope NoScope pats
, toHie grhss
]
+ where
+ node = case hiePass @p of
+ HieTc -> makeNode m span
+ HieRn -> makeNode m span
-instance ( ToHie (Context (Located (IdP a)))
- ) => ToHie (HsMatchContext a) where
+instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
toHie (StmtCtxt a) = toHie a
toHie _ = pure []
-instance ( ToHie (HsMatchContext a)
- ) => ToHie (HsStmtContext a) where
+instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where
toHie (PatGuard a) = toHie a
toHie (ParStmtCtxt a) = toHie a
toHie (TransStmtCtxt a) = toHie a
toHie _ = pure []
-instance ( a ~ GhcPass p
- , IsPass p
- , ToHie (Context (Located (IdP a)))
- , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
- , ToHie (LHsExpr a)
- , ToHie (TScoped (LHsSigWcType a))
- , HasType (LPat a)
- , Data (HsSplice a)
- , IsPass p
- ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where
+instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where
toHie (PS rsp scope pscope lpat@(L ospan opat)) =
concatM $ getTypeNode lpat : case opat of
WildPat _ ->
@@ -941,25 +934,25 @@ instance ( a ~ GhcPass p
SumPat _ pat _ _ ->
[ toHie $ PS rsp scope pscope pat
]
- ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext}->
- [ case ghcPass @p of
- GhcPs -> toHie $ C Use $ con
- GhcRn -> toHie $ C Use $ con
- GhcTc -> toHie $ C Use $ fmap conLikeName con
- , toHie $ contextify dets
- , case ghcPass @p of
- GhcTc ->
- let ev_binds = cpt_binds ext
+ ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} ->
+ case hiePass @p of
+ HieTc ->
+ [ toHie $ C Use $ fmap conLikeName con
+ , toHie $ contextify dets
+ , let ev_binds = cpt_binds ext
ev_vars = cpt_dicts ext
wrap = cpt_wrap ext
evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope
- in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds
- , toHie $ L ospan wrap
- , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
- . L ospan) ev_vars
- ]
- _ -> pure []
- ]
+ in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds
+ , toHie $ L ospan wrap
+ , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
+ . L ospan) ev_vars
+ ]
+ ]
+ HieRn ->
+ [ toHie $ C Use con
+ , toHie $ contextify dets
+ ]
ViewPat _ expr pat ->
[ toHie expr
, toHie $ PS rsp scope pscope pat
@@ -976,26 +969,26 @@ instance ( a ~ GhcPass p
]
SigPat _ pat sig ->
[ toHie $ PS rsp scope pscope pat
- , let cscope = mkLScope pat in
- case ghcPass @p of
- GhcPs -> pure []
- GhcTc -> pure []
- GhcRn ->
+ , case hiePass @p of
+ HieTc ->
+ let cscope = mkLScope pat in
toHie $ TS (ResolvedScopes [cscope, scope, pscope])
- sig
- ]
- XPat e -> case ghcPass @p of
+ sig
+ HieRn -> pure []
+ ]
+ XPat e ->
+ case hiePass @p of
+ HieTc ->
+ let CoPat wrap pat _ = e
+ in [ toHie $ L ospan wrap
+ , toHie $ PS rsp scope pscope $ (L ospan pat)
+ ]
#if __GLASGOW_HASKELL__ < 811
- GhcPs -> noExtCon e
- GhcRn -> noExtCon e
+ HieRn -> []
#endif
- GhcTc ->
- [ toHie $ L ospan wrap
- , toHie $ PS rsp scope pscope $ (L ospan pat :: LPat a)
- ]
- where
- CoPat wrap pat _ = e
where
+ contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a)
+ -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
contextify (InfixCon a b) = InfixCon a' b'
where [a', b'] = patScopes rsp scope pscope [a,b]
@@ -1006,6 +999,7 @@ instance ( a ~ GhcPass p
L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
scoped_fds = listScopes pscope fds
+
instance ToHie (TScoped (HsPatSigType GhcRn)) where
toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
[ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
@@ -1013,48 +1007,31 @@ instance ToHie (TScoped (HsPatSigType GhcRn)) where
]
-- See Note [Scoping Rules for SigPat]
-instance ( ToHie body
- , ToHie (LGRHS a body)
- , ToHie (RScoped (LHsLocalBinds a))
- ) => ToHie (GRHSs a body) where
+instance ( ToHie (Located body)
+ , HiePass p
+ , Data body
+ ) => ToHie (GRHSs (GhcPass p) (Located body)) where
toHie grhs = concatM $ case grhs of
GRHSs _ grhss binds ->
[ toHie grhss
, toHie $ RS (mkScope $ grhss_span grhs) binds
]
- XGRHSs _ -> []
instance ( ToHie (Located body)
- , ToHie (RScoped (GuardLStmt (GhcPass a)))
- , Data (GRHS (GhcPass a) (Located body))
+ , HiePass a
+ , Data body
) => ToHie (LGRHS (GhcPass a) (Located body)) where
- toHie (L span g) = concatM $ makeNode g span : case g of
+ toHie (L span g) = concatM $ node : case g of
GRHS _ guards body ->
[ toHie $ listScopes (mkLScope body) guards
, toHie body
]
+ where
+ node = case hiePass @a of
+ HieRn -> makeNode g span
+ HieTc -> makeNode g span
-instance ( a ~ GhcPass p
- , ToHie (Context (Located (IdP a)))
- , HasType (LHsExpr a)
- , ToHie (PScoped (LPat a))
- , ToHie (MatchGroup a (LHsExpr a))
- , ToHie (LGRHS a (LHsExpr a))
- , ToHie (RContext (HsRecordBinds a))
- , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
- , ToHie (ArithSeqInfo a)
- , ToHie (LHsCmdTop a)
- , ToHie (RScoped (GuardLStmt a))
- , ToHie (RScoped (LHsLocalBinds a))
- , ToHie (TScoped (LHsWcType (NoGhcTc a)))
- , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
- , Data (HsExpr a)
- , Data (HsSplice a)
- , Data (HsTupArg a)
- , Data (AmbiguousFieldOcc a)
- , (HasRealDataConName a)
- , IsPass p
- ) => ToHie (LHsExpr (GhcPass p)) where
+instance HiePass p => ToHie (LHsExpr (GhcPass p)) where
toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
HsVar _ (L _ var) ->
[ toHie $ C Use (L mspan var)
@@ -1135,7 +1112,7 @@ instance ( a ~ GhcPass p
[ toHie exprs
]
RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->
- [ toHie $ C Use (getRealDataCon @a mrealcon name)
+ [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name)
-- See Note [Real DataCon Name]
, toHie $ RC RecFieldAssign $ binds
]
@@ -1186,30 +1163,20 @@ instance ( a ~ GhcPass p
-> [ toHie $ L mspan a
, toHie (L mspan w)
]
- | otherwise
- -> []
+ | otherwise -> []
-instance ( a ~ GhcPass p
- , ToHie (LHsExpr a)
- , Data (HsTupArg a)
- ) => ToHie (LHsTupArg (GhcPass p)) where
+instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where
toHie (L span arg) = concatM $ makeNode arg span : case arg of
Present _ expr ->
[ toHie expr
]
Missing _ -> []
-instance ( a ~ GhcPass p
- , ToHie (PScoped (LPat a))
- , ToHie (LHsExpr a)
- , ToHie (SigContext (LSig a))
- , ToHie (RScoped (LHsLocalBinds a))
- , ToHie (RScoped (ApplicativeArg a))
- , ToHie (Located body)
- , Data (StmtLR a a (Located body))
- , Data (StmtLR a a (Located (HsExpr a)))
+instance ( ToHie (Located body)
+ , Data body
+ , HiePass p
) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
- toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
+ toHie (RS scope (L span stmt)) = concatM $ node : case stmt of
LastStmt _ body _ _ ->
[ toHie body
]
@@ -1239,47 +1206,36 @@ instance ( a ~ GhcPass p
RecStmt {recS_stmts = stmts} ->
[ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
]
+ where
+ node = case hiePass @p of
+ HieTc -> makeNode stmt span
+ HieRn -> makeNode stmt span
-instance ( ToHie (LHsExpr a)
- , ToHie (PScoped (LPat a))
- , ToHie (BindContext (LHsBind a))
- , ToHie (SigContext (LSig a))
- , ToHie (RScoped (HsValBindsLR a a))
- , ToHie (EvBindContext (Located (XIPBinds a)))
- , ToHie (RScoped (LIPBind a))
- , Data (HsLocalBinds a)
- ) => ToHie (RScoped (LHsLocalBinds a)) where
+instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where
toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
EmptyLocalBinds _ -> []
HsIPBinds _ ipbinds -> case ipbinds of
IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in
- [ toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds
+ [ case hiePass @p of
+ HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds
+ HieRn -> pure []
, toHie $ map (RS sc) xs
]
- XHsIPBinds _ -> []
HsValBinds _ valBinds ->
[ toHie $ RS (combineScopes scope $ mkScope sp)
valBinds
]
- XHsLocalBindsLR _ -> []
-instance ( ToHie (LHsExpr a)
- , ToHie (Context (Located (IdP a)))
- , Data (IPBind a)
- ) => ToHie (RScoped (LIPBind a)) where
+instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where
toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of
IPBind _ (Left _) expr -> [toHie expr]
IPBind _ (Right v) expr ->
[ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp))
- $ L sp v
+ $ L sp v
, toHie expr
]
- XIPBind _ -> []
-instance ( ToHie (BindContext (LHsBind a))
- , ToHie (SigContext (LSig a))
- , ToHie (RScoped (XXValBindsLR a a))
- ) => ToHie (RScoped (HsValBindsLR a a)) where
+instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where
toHie (RS sc v) = concatM $ case v of
ValBinds _ binds sigs ->
[ toHie $ fmap (BC RegularBind sc) binds
@@ -1287,26 +1243,19 @@ instance ( ToHie (BindContext (LHsBind a))
]
XValBindsLR x -> [ toHie $ RS sc x ]
-instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
- toHie (RS sc (NValBinds binds sigs)) = concatM $
- [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
- , toHie $ fmap (SC (SI BindSig Nothing)) sigs
- ]
-instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
+instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where
toHie (RS sc (NValBinds binds sigs)) = concatM $
[ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
, toHie $ fmap (SC (SI BindSig Nothing)) sigs
]
-instance ( ToHie (RContext (LHsRecField a arg))
- ) => ToHie (RContext (HsRecFields a arg)) where
+instance ( ToHie arg , HasLoc arg , Data arg
+ , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where
toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
instance ( ToHie (RFContext (Located label))
- , ToHie arg
- , HasLoc arg
+ , ToHie arg , HasLoc arg , Data arg
, Data label
- , Data arg
) => ToHie (RContext (LHsRecField' label arg)) where
toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
HsRecField label expr _ ->
@@ -1349,16 +1298,7 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
in [ toHie $ C (RecField c rhs) (L nspan var')
]
-instance ( a ~ GhcPass p
- , ToHie (PScoped (LPat a))
- , ToHie (BindContext (LHsBind a))
- , ToHie (LHsExpr a)
- , ToHie (SigContext (LSig a))
- , ToHie (RScoped (HsValBindsLR a a))
- , ToHie (RScoped (ExprLStmt a))
- , Data (StmtLR a a (Located (HsExpr a)))
- , Data (HsLocalBinds a)
- ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
+instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
[ toHie $ PS Nothing sc NoScope pat
, toHie expr
@@ -1373,29 +1313,13 @@ instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
toHie (RecCon rec) = toHie rec
toHie (InfixCon a b) = concatM [ toHie a, toHie b]
-instance ( ToHie (LHsCmd a)
- , Data (HsCmdTop a)
- ) => ToHie (LHsCmdTop a) where
+instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where
toHie (L span top) = concatM $ makeNode top span : case top of
HsCmdTop _ cmd ->
[ toHie cmd
]
- XCmdTop _ -> []
-
-instance ( a ~ GhcPass p
- , ToHie (PScoped (LPat a))
- , ToHie (BindContext (LHsBind a))
- , ToHie (LHsExpr a)
- , ToHie (MatchGroup a (LHsCmd a))
- , ToHie (SigContext (LSig a))
- , ToHie (RScoped (HsValBindsLR a a))
- , ToHie (RScoped (LHsLocalBinds a))
- , Data (HsCmd a)
- , Data (HsCmdTop a)
- , Data (StmtLR a a (Located (HsCmd a)))
- , Data (HsLocalBinds a)
- , Data (StmtLR a a (Located (HsExpr a)))
- ) => ToHie (LHsCmd (GhcPass p)) where
+
+instance HiePass p => ToHie (LHsCmd (GhcPass p)) where
toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
HsCmdArrApp _ a b _ _ ->
[ toHie a
@@ -1658,48 +1582,51 @@ instance ToHie (StandaloneKindSig GhcRn) where
, toHie $ TS (ResolvedScopes []) typ
]
-instance ToHie (SigContext (LSig GhcRn)) where
- toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
- TypeSig _ names typ ->
- [ toHie $ map (C TyDecl) names
- , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
- ]
- PatSynSig _ names typ ->
- [ toHie $ map (C TyDecl) names
- , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
- ]
- ClassOpSig _ _ names typ ->
- [ case styp of
- ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
- _ -> toHie $ map (C $ TyDecl) names
- , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
- ]
- IdSig _ _ -> []
- FixSig _ fsig ->
- [ toHie $ L sp fsig
- ]
- InlineSig _ name _ ->
- [ toHie $ (C Use) name
- ]
- SpecSig _ name typs _ ->
- [ toHie $ (C Use) name
- , toHie $ map (TS (ResolvedScopes [])) typs
- ]
- SpecInstSig _ _ typ ->
- [ toHie $ TS (ResolvedScopes []) typ
- ]
- MinimalSig _ _ form ->
- [ toHie form
- ]
- SCCFunSig _ _ name mtxt ->
- [ toHie $ (C Use) name
- , maybe (pure []) (locOnly . getLoc) mtxt
- ]
- CompleteMatchSig _ _ (L ispan names) typ ->
- [ locOnly ispan
- , toHie $ map (C Use) names
- , toHie $ fmap (C Use) typ
- ]
+instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where
+ toHie (SC (SI styp msp) (L sp sig)) =
+ case hiePass @p of
+ HieTc -> pure []
+ HieRn -> concatM $ makeNode sig sp : case sig of
+ TypeSig _ names typ ->
+ [ toHie $ map (C TyDecl) names
+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+ ]
+ PatSynSig _ names typ ->
+ [ toHie $ map (C TyDecl) names
+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+ ]
+ ClassOpSig _ _ names typ ->
+ [ case styp of
+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
+ _ -> toHie $ map (C $ TyDecl) names
+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
+ ]
+ IdSig _ _ -> []
+ FixSig _ fsig ->
+ [ toHie $ L sp fsig
+ ]
+ InlineSig _ name _ ->
+ [ toHie $ (C Use) name
+ ]
+ SpecSig _ name typs _ ->
+ [ toHie $ (C Use) name
+ , toHie $ map (TS (ResolvedScopes [])) typs
+ ]
+ SpecInstSig _ _ typ ->
+ [ toHie $ TS (ResolvedScopes []) typ
+ ]
+ MinimalSig _ _ form ->
+ [ toHie form
+ ]
+ SCCFunSig _ _ name mtxt ->
+ [ toHie $ (C Use) name
+ , maybe (pure []) (locOnly . getLoc) mtxt
+ ]
+ CompleteMatchSig _ _ (L ispan names) typ ->
+ [ locOnly ispan
+ , toHie $ map (C Use) names
+ , toHie $ fmap (C Use) typ
+ ]
instance ToHie (LHsType GhcRn) where
toHie x = toHie $ TS (ResolvedScopes []) x
@@ -1863,11 +1790,7 @@ instance ToHie (LBooleanFormula (Located Name)) where
instance ToHie (Located HsIPName) where
toHie (L span e) = makeNode e span
-instance ( a ~ GhcPass p
- , ToHie (LHsExpr a)
- , Data (HsSplice a)
- , IsPass p
- ) => ToHie (Located (HsSplice a)) where
+instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where
toHie (L span sp) = concatM $ makeNode sp span : case sp of
HsTypedSplice _ _ _ expr ->
[ toHie expr
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2738,11 +2738,9 @@ fexp :: { ECP }
mkHsAppPV (comb2 $1 $>) $1 $2 }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
- | fexp PREFIX_AT atype {% runECP_P $1 >>= \ $1 ->
- runPV (checkExpBlockArguments $1) >>= \_ ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsAppType noExtField $1 (mkHsWildCardBndrs $3))
- [mj AnnAt $2] }
+ | fexp PREFIX_AT atype { ECP $
+ runECP_PV $1 >>= \ $1 ->
+ amms (mkHsAppTypePV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }
| 'static' aexp {% runECP_P $2 >>= \ $2 ->
fmap ecpFromExp $
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -366,15 +366,20 @@ $tab { warnTab }
-- "special" symbols
<0> {
- "[|" / { ifExtension ThQuotesBit } { token (ITopenExpQuote NoE NormalSyntax) }
- "[||" / { ifExtension ThQuotesBit } { token (ITopenTExpQuote NoE) }
+
+ -- Don't check ThQuotesBit here as the renamer can produce a better
+ -- error message than the lexer (see the thQuotesEnabled check in rnBracket).
+ "[|" { token (ITopenExpQuote NoE NormalSyntax) }
+ "[||" { token (ITopenTExpQuote NoE) }
+ "|]" { token (ITcloseQuote NormalSyntax) }
+ "||]" { token ITcloseTExpQuote }
+
+ -- Check ThQuotesBit here as to not steal syntax.
"[e|" / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) }
"[e||" / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) }
"[p|" / { ifExtension ThQuotesBit } { token ITopenPatQuote }
"[d|" / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote }
"[t|" / { ifExtension ThQuotesBit } { token ITopenTypQuote }
- "|]" / { ifExtension ThQuotesBit } { token (ITcloseQuote NormalSyntax) }
- "||]" / { ifExtension ThQuotesBit } { token ITcloseTExpQuote }
"[" @varid "|" / { ifExtension QqBit } { lex_quasiquote_tok }
@@ -1449,7 +1454,7 @@ qconsym buf len = ITqconsym $! splitQualName buf len False
-- See Note [Whitespace-sensitive operator parsing]
varsym_prefix :: Action
varsym_prefix = sym $ \exts s ->
- if | TypeApplicationsBit `xtest` exts, s == fsLit "@"
+ if | s == fsLit "@" -- regardless of TypeApplications for better error messages
-> return ITtypeApp
| ThQuotesBit `xtest` exts, s == fsLit "$"
-> return ITdollar
@@ -2461,7 +2466,6 @@ data ExtBits
| BinaryLiteralsBit
| NegativeLiteralsBit
| HexFloatLiteralsBit
- | TypeApplicationsBit
| StaticPointersBit
| NumericUnderscoresBit
| StarIsTypeBit
@@ -2548,7 +2552,6 @@ mkParserFlags' warningFlags extensionFlags thisPackage
.|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals
.|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals
.|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms
- .|. TypeApplicationsBit `xoptBit` LangExt.TypeApplications
.|. StaticPointersBit `xoptBit` LangExt.StaticPointers
.|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores
.|. StarIsTypeBit `xoptBit` LangExt.StarIsType
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1137,6 +1137,13 @@ checkAPat loc e0 = do
| nPlusKPatterns && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) (L lloc lit))
+ -- Improve error messages for the @-operator when the user meant an @-pattern
+ PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do
+ addError (getLoc op) $
+ text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$
+ perhaps_as_pat
+ return (WildPat noExtField)
+
PatBuilderOpApp l (L cl c) r
| isRdrDataCon c -> do
l <- checkLPat l
@@ -1171,6 +1178,9 @@ patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
+opIsAt :: RdrName -> Bool
+opIsAt e = e == mkUnqual varName (fsLit "@")
+
---------------------------------------------------------------------------
-- Check Equation Syntax
@@ -1203,7 +1213,7 @@ checkFunBind :: SrcStrictness
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
- = do ps <- mapM checkPattern pats
+ = do ps <- runPV_msg param_hint (mapM checkLPat pats)
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
@@ -1217,6 +1227,15 @@ checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
, m_grhss = grhss })])
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
+ where
+ param_hint
+ | Infix <- is_infix
+ = text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$
+ if opIsAt (unLoc fun) then perhaps_as_pat else empty
+ | otherwise = empty
+
+perhaps_as_pat :: SDoc
+perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
@@ -1792,6 +1811,8 @@ class b ~ (Body b) GhcPs => DisambECP b where
superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b)
-- | Disambiguate "f x" (function application)
mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b)
+ -- | Disambiguate "f @t" (visible type application)
+ mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
-- | Disambiguate "if ... then ... else ..."
mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
@@ -1906,6 +1927,7 @@ instance DisambECP (HsCmd GhcPs) where
checkCmdBlockArguments c
checkExpBlockArguments e
return $ L l (HsCmdApp noExtField c e)
+ mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
return $ L l (mkHsCmdIf c a b)
@@ -1963,6 +1985,9 @@ instance DisambECP (HsExpr GhcPs) where
checkExpBlockArguments e1
checkExpBlockArguments e2
return $ L l (HsApp noExtField e1 e2)
+ mkHsAppTypePV l e t = do
+ checkExpBlockArguments e
+ return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t))
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
return $ L l (mkHsIf c a b)
@@ -2045,6 +2070,8 @@ instance DisambECP (PatBuilder GhcPs) where
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
+ mkHsAppTypePV l _ _ = addFatalError l $
+ text "Type applications in patterns are not yet supported"
mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern"
mkHsParPV l p = return $ L l (PatBuilderPar p)
=====================================
compiler/GHC/Utils/Monad.hs
=====================================
@@ -138,22 +138,31 @@ mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f
-- See Note [Inline @mapAndUnzipNM@ functions] above.
mapAndUnzip5M f xs = unzip5 <$> traverse f xs
+-- TODO: mapAccumLM is used in many places. Surely most of
+-- these don't actually want to be lazy. We should add a strict
+-- variant and use it where appropriate.
+
-- | Monadic version of mapAccumL
mapAccumLM :: Monad m
=> (acc -> x -> m (acc, y)) -- ^ combining function
-> acc -- ^ initial state
-> [x] -- ^ inputs
-> m (acc, [y]) -- ^ final state, outputs
-mapAccumLM _ s [] = return (s, [])
-mapAccumLM f s (x:xs) = do
- (s1, x') <- f s x
- (s2, xs') <- mapAccumLM f s1 xs
- return (s2, x' : xs')
+mapAccumLM f s xs =
+ go s xs
+ where
+ go s (x:xs) = do
+ (s1, x') <- f s x
+ (s2, xs') <- go s1 xs
+ return (s2, x' : xs')
+ go s [] = return (s, [])
-- | Monadic version of mapSnd
mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
-mapSndM _ [] = return []
-mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) }
+mapSndM f xs = go xs
+ where
+ go [] = return []
+ go ((a,b):xs) = do { c <- f b; rs <- go xs; return ((a,c):rs) }
-- | Monadic version of concatMap
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
@@ -176,15 +185,19 @@ fmapEitherM _ fr (Right b) = fr b >>= (return . Right)
-- | Monadic version of 'any', aborts the computation at the first @True@ value
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
-anyM _ [] = return False
-anyM f (x:xs) = do b <- f x
+anyM f xs = go xs
+ where
+ go [] = return False
+ go (x:xs) = do b <- f x
if b then return True
- else anyM f xs
+ else go xs
-- | Monad version of 'all', aborts the computation at the first @False@ value
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
-allM _ [] = return True
-allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False)
+allM f bs = go bs
+ where
+ go [] = return True
+ go (b:bs) = (f b) >>= (\bv -> if bv then go bs else return False)
-- | Monadic version of or
orM :: Monad m => m Bool -> m Bool -> m Bool
=====================================
configure.ac
=====================================
@@ -978,7 +978,7 @@ FP_CHECK_FUNC([GetModuleFileName],
dnl ** check for more functions
dnl ** The following have been verified to be used in ghc/, but might be used somewhere else, too.
-AC_CHECK_FUNCS([getclock getrusage gettimeofday setitimer siginterrupt sysconf times ctime_r sched_setaffinity setlocale])
+AC_CHECK_FUNCS([getclock getrusage gettimeofday setitimer siginterrupt sysconf times ctime_r sched_setaffinity sched_getaffinity setlocale])
dnl ** On OS X 10.4 (at least), time.h doesn't declare ctime_r if
dnl ** _POSIX_C_SOURCE is defined
=====================================
docs/users_guide/8.12.1-notes.rst
=====================================
@@ -17,7 +17,7 @@ Highlights
digit improvements in runtime for inner loops.
In the mean this improved runtime by about 0.8%. For details
- see ticket #17823.
+ see ticket :ghc-ticket:`17823`.
Full details
------------
@@ -95,7 +95,7 @@ Language
effectively allows users to choose which variables can or can't be
instantiated through visible type application. More information can be found
here: :ref:`Manually-defining-inferred-variables`.
-
+
Compiler
~~~~~~~~
@@ -105,11 +105,18 @@ GHCi
- The ``:script`` command now allows for file names that contain spaces to
passed as arguments: either by enclosing the file names in double quotes or by
- escaping spaces in file names with a backslash. (#18027)
+ escaping spaces in file names with a backslash. (:ghc-ticket:`18027`)
Runtime system
~~~~~~~~~~~~~~
+- :rts-flag:`-N` without a count now tries to respect the number of processors
+ in the process's affinity mask, making GHC's behavior more predictable in
+ containerized settings (:ghc-ticket:`14781`).
+
+- Support for Windows Vista has been dropped. GHC-compiled programs now require
+ Windows 7 or later.
+
Template Haskell
~~~~~~~~~~~~~~~~
=====================================
docs/users_guide/bugs.rst
=====================================
@@ -76,13 +76,20 @@ Lexical syntax
See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__
for the precise rules.
-- As-patterns must not be surrounded by whitespace::
+- As-patterns must not be surrounded by whitespace on either side::
f p@(x, y, z) = ... -- accepted by both GHC and the Haskell Report
- f p @ (x, y, z) = ... -- accepted by the Haskell Report but not GHC
- When surrounded by whitespace, ``(@)`` is treated by GHC as a regular infix
- operator.
+ -- accepted by the Haskell Report but not GHC:
+ f p @ (x, y, z) = ...
+ f p @(x, y, z) = ...
+ f p@ (x, y, z) = ...
+
+ When surrounded by whitespace on both sides, ``(@)`` is treated by GHC as a
+ regular infix operator.
+
+ When preceded but not followed by whitespace, ``(@)`` is treated as a
+ visible type application.
See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__
for the precise rules.
=====================================
docs/users_guide/using-concurrent.rst
=====================================
@@ -111,6 +111,7 @@ There are two ways to run a program on multiple processors: call
use the RTS :rts-flag:`-N ⟨x⟩` options.
.. rts-flag:: -N ⟨x⟩
+ -N
-maxN ⟨x⟩
Use ⟨x⟩ simultaneous threads when running the program.
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -462,4 +462,4 @@ rtsWarnings = mconcat
-- and also centralizes the versioning.
-- | Minimum supported Windows version.
windowsVersion :: String
-windowsVersion = "0x06000100"
+windowsVersion = "0x06010000"
=====================================
mk/get-win32-tarballs.py
=====================================
@@ -7,7 +7,7 @@ import subprocess
import argparse
from sys import stderr
-TARBALL_VERSION = '0.1'
+TARBALL_VERSION = '0.2'
BASE_URL = "https://downloads.haskell.org/ghc/mingw/{}".format(TARBALL_VERSION)
DEST = Path('ghc-tarballs/mingw-w64')
ARCHS = ['i686', 'x86_64', 'sources']
=====================================
rts/ghc.mk
=====================================
@@ -25,7 +25,7 @@ rts_VERSION = 1.0
# If we're compiling on windows, enforce that we only support Vista SP1+
# Adding this here means it doesn't have to be done in individual .c files
# and also centralizes the versioning.
-rts_WINVER = 0x06000100
+rts_WINVER = 0x06010000
# merge GhcLibWays and GhcRTSWays but strip out duplicates
rts_WAYS = $(GhcLibWays) $(filter-out $(GhcLibWays),$(GhcRTSWays))
=====================================
rts/posix/OSThreads.c
=====================================
@@ -240,26 +240,50 @@ forkOS_createThread ( HsStablePtr entry )
void freeThreadingResources (void) { /* nothing */ }
+// Get the number of logical CPU cores available to us. Note that this is
+// different from the number of physical cores (see #14781).
uint32_t
getNumberOfProcessors (void)
{
static uint32_t nproc = 0;
if (nproc == 0) {
-#if defined(HAVE_SYSCONF) && defined(_SC_NPROCESSORS_ONLN)
- nproc = sysconf(_SC_NPROCESSORS_ONLN);
-#elif defined(HAVE_SYSCONF) && defined(_SC_NPROCESSORS_CONF)
- nproc = sysconf(_SC_NPROCESSORS_CONF);
-#elif defined(darwin_HOST_OS)
+#if defined(HAVE_SCHED_GETAFFINITY)
+ cpu_set_t mask;
+ CPU_ZERO(&mask);
+ if (sched_getaffinity(0, sizeof(mask), &mask) == 0) {
+ for (int i = 0; i < CPU_SETSIZE; i++) {
+ if (CPU_ISSET(i, &mask))
+ nproc++;
+ }
+ return nproc;
+ }
+#endif
+
+#if defined(darwin_HOST_OS)
size_t size = sizeof(uint32_t);
- if(sysctlbyname("hw.logicalcpu",&nproc,&size,NULL,0) != 0) {
+ if (sysctlbyname("machdep.cpu.thread_count",&nproc,&size,NULL,0) != 0) {
+ if (sysctlbyname("hw.logicalcpu",&nproc,&size,NULL,0) != 0) {
+ if (sysctlbyname("hw.ncpu",&nproc,&size,NULL,0) != 0)
+ nproc = 1;
+ }
+ }
+#elif defined(freebsd_HOST_OS)
+ cpuset_t mask;
+ CPU_ZERO(&mask);
+ if(cpuset_getaffinity(CPU_LEVEL_CPUSET, CPU_WHICH_PID, -1, sizeof(mask), &mask) == 0) {
+ return CPU_COUNT(&mask);
+ } else {
+ size_t size = sizeof(uint32_t);
if(sysctlbyname("hw.ncpu",&nproc,&size,NULL,0) != 0)
nproc = 1;
}
-#elif defined(freebsd_HOST_OS)
- size_t size = sizeof(uint32_t);
- if(sysctlbyname("hw.ncpu",&nproc,&size,NULL,0) != 0)
- nproc = 1;
+#elif defined(HAVE_SYSCONF) && defined(_SC_NPROCESSORS_ONLN)
+ // N.B. This is the number of physical processors.
+ nproc = sysconf(_SC_NPROCESSORS_ONLN);
+#elif defined(HAVE_SYSCONF) && defined(_SC_NPROCESSORS_CONF)
+ // N.B. This is the number of physical processors.
+ nproc = sysconf(_SC_NPROCESSORS_CONF);
#else
nproc = 1;
#endif
=====================================
rts/win32/OSThreads.c
=====================================
@@ -252,17 +252,6 @@ forkOS_createThread ( HsStablePtr entry )
(unsigned*)&pId) == 0);
}
-#if defined(x86_64_HOST_ARCH)
-/* We still support Windows Vista, so we can't depend on it
- and must manually resolve these. */
-typedef DWORD(WINAPI *GetItemCountProc)(WORD);
-typedef DWORD(WINAPI *GetGroupCountProc)(void);
-typedef BOOL(WINAPI *SetThreadGroupAffinityProc)(HANDLE, const GROUP_AFFINITY*, PGROUP_AFFINITY);
-#if !defined(ALL_PROCESSOR_GROUPS)
-#define ALL_PROCESSOR_GROUPS 0xffff
-#endif
-#endif
-
void freeThreadingResources (void)
{
if (cpuGroupCache)
@@ -310,13 +299,6 @@ getNumberOfProcessorsGroups (void)
#if defined(x86_64_HOST_ARCH)
if (!n_groups)
{
- /* We still support Windows Vista. Which means we can't rely
- on the API being available. So we'll have to resolve manually. */
- HMODULE kernel = GetModuleHandleW(L"kernel32");
-
- GetGroupCountProc GetActiveProcessorGroupCount
- = (GetGroupCountProc)(void*)
- GetProcAddress(kernel, "GetActiveProcessorGroupCount");
n_groups = GetActiveProcessorGroupCount();
IF_DEBUG(scheduler, debugBelch("[*] Number of processor groups detected: %u\n", n_groups));
@@ -346,21 +328,10 @@ getProcessorsDistribution (void)
cpuGroupDistCache = malloc(n_groups * sizeof(uint8_t));
memset(cpuGroupDistCache, MAXIMUM_PROCESSORS, n_groups * sizeof(uint8_t));
- /* We still support Windows Vista. Which means we can't rely
- on the API being available. So we'll have to resolve manually. */
- HMODULE kernel = GetModuleHandleW(L"kernel32");
-
- GetItemCountProc GetActiveProcessorCount
- = (GetItemCountProc)(void*)
- GetProcAddress(kernel, "GetActiveProcessorCount");
-
- if (GetActiveProcessorCount)
+ for (int i = 0; i < n_groups; i++)
{
- for (int i = 0; i < n_groups; i++)
- {
- cpuGroupDistCache[i] = GetActiveProcessorCount(i);
- IF_DEBUG(scheduler, debugBelch("[*] Number of active processors in group %u detected: %u\n", i, cpuGroupDistCache[i]));
- }
+ cpuGroupDistCache[i] = GetActiveProcessorCount(i);
+ IF_DEBUG(scheduler, debugBelch("[*] Number of active processors in group %u detected: %u\n", i, cpuGroupDistCache[i]));
}
}
@@ -449,14 +420,7 @@ getNumberOfProcessors (void)
static uint32_t nproc = 0;
#if defined(x86_64_HOST_ARCH)
- /* We still support Windows Vista. Which means we can't rely
- on the API being available. So we'll have to resolve manually. */
- HMODULE kernel = GetModuleHandleW(L"kernel32");
-
- GetItemCountProc GetActiveProcessorCount
- = (GetItemCountProc)(void*)
- GetProcAddress(kernel, "GetActiveProcessorCount");
- if (GetActiveProcessorCount && !nproc)
+ if (!nproc)
{
nproc = GetActiveProcessorCount(ALL_PROCESSOR_GROUPS);
@@ -517,21 +481,11 @@ setThreadAffinity (uint32_t n, uint32_t m) // cap N of M
mask[group] |= 1 << ix;
}
-#if defined(x86_64_HOST_ARCH)
- /* We still support Windows Vista. Which means we can't rely
- on the API being available. So we'll have to resolve manually. */
- HMODULE kernel = GetModuleHandleW(L"kernel32");
-
- SetThreadGroupAffinityProc SetThreadGroupAffinity
- = (SetThreadGroupAffinityProc)(void*)
- GetProcAddress(kernel, "SetThreadGroupAffinity");
-#endif
-
for (i = 0; i < n_groups; i++)
{
#if defined(x86_64_HOST_ARCH)
// If we support the new API, use it.
- if (mask[i] > 0 && SetThreadGroupAffinity)
+ if (mask[i] > 0)
{
GROUP_AFFINITY hGroup;
ZeroMemory(&hGroup, sizeof(hGroup));
=====================================
testsuite/tests/parser/should_fail/T18251a.hs
=====================================
@@ -0,0 +1,3 @@
+module T18251a where
+
+pairs xs @ (_:xs') = zip xs xs'
=====================================
testsuite/tests/parser/should_fail/T18251a.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T18251a.hs:3:1: error:
+ Parse error in pattern: pairs
+ In a function binding for the ‘@’ operator.
+ Perhaps you meant an as-pattern, which must not be surrounded by whitespace
=====================================
testsuite/tests/parser/should_fail/T18251b.hs
=====================================
@@ -0,0 +1,3 @@
+module T18251a where
+
+pairs (xs @ (_:xs')) = zip xs xs'
=====================================
testsuite/tests/parser/should_fail/T18251b.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T18251b.hs:3:11: error:
+ Found a binding for the ‘@’ operator in a pattern position.
+ Perhaps you meant an as-pattern, which must not be surrounded by whitespace
=====================================
testsuite/tests/parser/should_fail/T18251c.hs
=====================================
@@ -0,0 +1,3 @@
+module T18251c where
+
+f = id @Int
=====================================
testsuite/tests/parser/should_fail/T18251c.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T18251c.hs:3:5: error:
+ Illegal visible type application ‘@Int’
+ Perhaps you intended to use TypeApplications
=====================================
testsuite/tests/parser/should_fail/T18251d.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE ExplicitForAll #-}
+
+module T18251d where
+
+f :: forall a. a -> ()
+f @a _ = ()
=====================================
testsuite/tests/parser/should_fail/T18251d.stderr
=====================================
@@ -0,0 +1,3 @@
+
+T18251d.hs:6:1: error:
+ Type applications in patterns are not yet supported
=====================================
testsuite/tests/parser/should_fail/T18251e.hs
=====================================
@@ -0,0 +1,3 @@
+module T18251e where
+
+a = [| id |]
=====================================
testsuite/tests/parser/should_fail/T18251e.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T18251e.hs:3:5: error:
+ • Syntax error on [| id |]
+ Perhaps you intended to use TemplateHaskell or TemplateHaskellQuotes
+ • In the Template Haskell quotation [| id |]
=====================================
testsuite/tests/parser/should_fail/T18251f.hs
=====================================
@@ -0,0 +1,3 @@
+module T18251f where
+
+f ! x y = x + y
=====================================
testsuite/tests/parser/should_fail/T18251f.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T18251f.hs:3:5: error:
+ Parse error in pattern: x
+ In a function binding for the ‘!’ operator.
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -166,4 +166,10 @@ test('T17162', normal, compile_fail, [''])
test('proposal-229c', normal, compile_fail, [''])
test('T15730', normal, compile_fail, [''])
test('T15730b', normal, compile_fail, [''])
-test('T18130Fail', normal, compile_fail, [''])
+test('T18130Fail', normal, compile_fail, [''])
+test('T18251a', normal, compile_fail, [''])
+test('T18251b', normal, compile_fail, [''])
+test('T18251c', normal, compile_fail, [''])
+test('T18251d', normal, compile_fail, [''])
+test('T18251e', normal, compile_fail, [''])
+test('T18251f', normal, compile_fail, [''])
=====================================
testsuite/tests/th/T12411.stderr
=====================================
@@ -1,8 +1,6 @@
-T12411.hs:4:6: error:
- Variable not in scope:
- (@)
- :: (a1 -> f0 a1) -> t0 -> Language.Haskell.TH.Lib.Internal.DecsQ
+T12411.hs:4:1: error:
+ Illegal visible type application ‘@Q’
+ Perhaps you intended to use TypeApplications
-T12411.hs:4:7: error:
- Data constructor not in scope: Q :: [a0] -> t0
+T12411.hs:4:7: error: Not in scope: type constructor or class ‘Q’
=====================================
testsuite/tests/typecheck/should_fail/T15527.stderr
=====================================
@@ -1,8 +1,4 @@
-T15527.hs:4:10: error:
- Variable not in scope:
- (@)
- :: ((b0 -> c0) -> (a0 -> b0) -> a0 -> c0)
- -> t0 -> (Int -> Int) -> (Int -> Int) -> Int -> Int
-
-T15527.hs:4:11: error: Data constructor not in scope: Int
+T15527.hs:4:6: error:
+ Illegal visible type application ‘@Int’
+ Perhaps you intended to use TypeApplications
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13c61680f73c6f103a2da465e55ed98ec5820515...833faecd96df5f9e36831cb196f400c5aeeea4c2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13c61680f73c6f103a2da465e55ed98ec5820515...833faecd96df5f9e36831cb196f400c5aeeea4c2
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/20200530/85ffdd2f/attachment-0001.html>
More information about the ghc-commits
mailing list