[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Build a threaded stage 1 if the bootstrapping GHC supports it.
Marge Bot
gitlab at gitlab.haskell.org
Fri May 29 18:07:11 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
67738db1 by Travis Whitaker at 2020-05-29T13:34:48-04:00
Build a threaded stage 1 if the bootstrapping GHC supports it.
- - - - -
aac19e6c by Peter Trommler at 2020-05-29T13:35:24-04:00
PPC NCG: No per-symbol .section ".toc" directives
All position independent symbols are collected during code generation
and emitted in one go. Prepending each symbol with a .section ".toc"
directive is redundant. This patch drops the per-symbol directives
leading to smaller assembler files.
Fixes #18250
- - - - -
6f1b09c6 by Ben Gamari at 2020-05-29T14:06:51-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.
- - - - -
a59304d7 by Ben Gamari at 2020-05-29T14:06:51-04:00
users-guide: Note change in getNumProcessors in users guide
- - - - -
e45e0516 by Ben Gamari at 2020-05-29T14:06:51-04:00
rts: Drop compatibility shims for Windows Vista
We can now assume that the thread and processor group interfaces are
available.
- - - - -
2999c4dc by Peter Trommler at 2020-05-29T14:06:51-04:00
PPC NCG: Fix .size directive on powerpc64 ELF v1
Thanks to Sergei Trofimovich for pointing out the issue.
Fixes #18237
- - - - -
d9eab84f by Andreas Klebinger at 2020-05-29T14:06:52-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
-------------------------
- - - - -
1b722f0b by Ben Gamari at 2020-05-29T14:06:52-04:00
Windows: Bump Windows toolchain to 0.2
- - - - -
4448ba12 by Zubin Duggal at 2020-05-29T14:07:01-04:00
Simplify contexts in GHC.Iface.Ext.Ast
- - - - -
18 changed files:
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Utils/Monad.hs
- compiler/ghc.mk
- configure.ac
- docs/users_guide/8.12.1-notes.rst
- docs/users_guide/using-concurrent.rst
- ghc/ghc.mk
- hadrian/cfg/system.config.in
- hadrian/src/Expression.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Settings/Packages.hs
- mk/config.mk.in
- mk/get-win32-tarballs.py
- rts/ghc.mk
- rts/posix/OSThreads.c
- rts/win32/OSThreads.c
Changes:
=====================================
compiler/GHC/CmmToAsm/PIC.hs
=====================================
@@ -682,7 +682,6 @@ pprImportedSymbol dflags config importedLbl = case (arch,os) of
-> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
-> vcat [
- text ".section \".toc\", \"aw\"",
text ".LC_" <> pprCLabel dflags lbl <> char ':',
text "\t.quad" <+> pprCLabel dflags lbl ]
_ -> empty
@@ -845,4 +844,3 @@ initializePicBase_x86 ArchX86 OSDarwin picReg
initializePicBase_x86 _ _ _ _
= panic "initializePicBase_x86: not needed"
-
=====================================
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/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
=====================================
compiler/ghc.mk
=====================================
@@ -194,6 +194,12 @@ ifeq "$(GhcThreaded)" "YES"
compiler_stage2_CONFIGURE_OPTS += --ghc-option=-optc-DTHREADED_RTS
endif
+# If the bootstrapping GHC supplies the threaded RTS, then we can have a
+# threaded stage 1 too.
+ifeq "$(GhcThreadedRts)" "YES"
+compiler_stage1_CONFIGURE_OPTS += --ghc-option=-optc-DTHREADED_RTS
+endif
+
ifeq "$(GhcWithNativeCodeGen)" "YES"
compiler_stage1_CONFIGURE_OPTS += --flags=ncg
compiler_stage2_CONFIGURE_OPTS += --flags=ncg
=====================================
configure.ac
=====================================
@@ -124,6 +124,9 @@ AC_ARG_VAR(CC_STAGE0, [C compiler command (bootstrap)])
AC_ARG_VAR(LD_STAGE0, [Linker command (bootstrap)])
AC_ARG_VAR(AR_STAGE0, [Archive command (bootstrap)])
+dnl RTS ways supplied by the bootstrapping compiler.
+AC_ARG_VAR(RTS_WAYS_STAGE0, [RTS ways])
+
if test "$WithGhc" != ""; then
FPTOOLS_GHC_VERSION([GhcVersion], [GhcMajVersion], [GhcMinVersion], [GhcPatchLevel])dnl
@@ -151,6 +154,17 @@ if test "$WithGhc" != ""; then
fi
BOOTSTRAPPING_GHC_INFO_FIELD([AR_OPTS_STAGE0],[ar flags])
BOOTSTRAPPING_GHC_INFO_FIELD([ArSupportsAtFile_STAGE0],[ar supports at file])
+ BOOTSTRAPPING_GHC_INFO_FIELD([RTS_WAYS_STAGE0],[RTS ways])
+
+ dnl Check whether or not the bootstrapping GHC has a threaded RTS. This
+ dnl determines whether or not we can have a threaded stage 1.
+ dnl See Note [Linking ghc-bin against threaded stage0 RTS] in
+ dnl hadrian/src/Settings/Packages.hs for details.
+ if echo ${RTS_WAYS_STAGE0} | grep '.*thr.*' 2>&1 >/dev/null; then
+ AC_SUBST(GhcThreadedRts, YES)
+ else
+ AC_SUBST(GhcThreadedRts, NO)
+ fi
fi
dnl ** Must have GHC to build GHC
@@ -964,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
@@ -1454,6 +1468,7 @@ Configure completed successfully.
echo "\
Bootstrapping using : $WithGhc
which is version : $GhcVersion
+ with threaded RTS? : $GhcThreadedRts
"
if test "x$CcLlvmBackend" = "xYES"; then
=====================================
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/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.
=====================================
ghc/ghc.mk
=====================================
@@ -66,8 +66,15 @@ else
ghc_stage2_CONFIGURE_OPTS += -f-threaded
ghc_stage3_CONFIGURE_OPTS += -f-threaded
endif
-# Stage-0 compiler isn't guaranteed to have a threaded RTS.
+
+# If stage 0 supplies a threaded RTS, we can use it for stage 1.
+# See Note [Linking ghc-bin against threaded stage0 RTS] in
+# hadrian/src/Settings/Packages.hs for details.
+ifeq "$(GhcThreadedRts)" "YES"
+ghc_stage1_MORE_HC_OPTS += -threaded
+else
ghc_stage1_CONFIGURE_OPTS += -f-threaded
+endif
ifeq "$(GhcProfiled)" "YES"
ghc_stage2_PROGRAM_WAY = p
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -79,6 +79,8 @@ ghc-major-version = @GhcMajVersion@
ghc-minor-version = @GhcMinVersion@
ghc-patch-level = @GhcPatchLevel@
+bootstrap-threaded-rts = @GhcThreadedRts@
+
supports-this-unit-id = @SUPPORTS_THIS_UNIT_ID@
project-name = @ProjectName@
=====================================
hadrian/src/Expression.hs
=====================================
@@ -6,8 +6,9 @@ module Expression (
expr, exprIO, arg, remove,
-- ** Predicates
- (?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
- packageOneOf, libraryPackage, builder, way, input, inputs, output, outputs,
+ (?), stage, stage0, stage1, stage2, notStage0, threadedBootstrapper,
+ package, notPackage, packageOneOf, libraryPackage, builder, way, input,
+ inputs, output, outputs,
-- ** Evaluation
interpret, interpretInContext,
@@ -26,6 +27,7 @@ import Base
import Builder
import Context hiding (stage, package, way)
import Expression.Type
+import Oracles.Flag
import Hadrian.Expression hiding (Expr, Predicate, Args)
import Hadrian.Haskell.Cabal.Type
import Hadrian.Oracles.Cabal
@@ -86,6 +88,19 @@ instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
way :: Way -> Predicate
way w = (w ==) <$> getWay
+{-
+Note [Stage Names]
+~~~~~~~~~~~~~~~~~~
+
+Code referring to specific stages can be a bit tricky. In Hadrian, the stages
+have the same names they carried in the autoconf build system, but they are
+often referred to by the stage used to construct them. For example, the stage 1
+artifacts will be placed in _build/stage0, because they are constructed by the
+stage 0 compiler. The stage predicates in this module behave the same way,
+'stage0' will return 'True' while stage 0 is being used to build the stage 1
+compiler.
+-}
+
-- | Is the build currently in stage 0?
stage0 :: Predicate
stage0 = stage Stage0
@@ -102,6 +117,13 @@ stage2 = stage Stage2
notStage0 :: Predicate
notStage0 = notM stage0
+-- | Whether or not the bootstrapping compiler provides a threaded RTS. We need
+-- to know this when building stage 1, since stage 1 links against the
+-- compiler's RTS ways. See Note [Linking ghc-bin against threaded stage0 RTS]
+-- in Settings.Packages for details.
+threadedBootstrapper :: Predicate
+threadedBootstrapper = expr (flag BootstrapThreadedRts)
+
-- | Is a certain package /not/ built right now?
notPackage :: Package -> Predicate
notPackage = notM . package
=====================================
hadrian/src/Oracles/Flag.hs
=====================================
@@ -24,25 +24,27 @@ data Flag = ArSupportsAtFile
| WithLibnuma
| HaveLibMingwEx
| UseSystemFfi
+ | BootstrapThreadedRts
-- Note, if a flag is set to empty string we treat it as set to NO. This seems
-- fragile, but some flags do behave like this.
flag :: Flag -> Action Bool
flag f = do
let key = case f of
- ArSupportsAtFile -> "ar-supports-at-file"
- CrossCompiling -> "cross-compiling"
- CcLlvmBackend -> "cc-llvm-backend"
- GhcUnregisterised -> "ghc-unregisterised"
- TablesNextToCode -> "tables-next-to-code"
- GmpInTree -> "intree-gmp"
- GmpFrameworkPref -> "gmp-framework-preferred"
- LeadingUnderscore -> "leading-underscore"
- SolarisBrokenShld -> "solaris-broken-shld"
- WithLibdw -> "with-libdw"
- WithLibnuma -> "with-libnuma"
- HaveLibMingwEx -> "have-lib-mingw-ex"
- UseSystemFfi -> "use-system-ffi"
+ ArSupportsAtFile -> "ar-supports-at-file"
+ CrossCompiling -> "cross-compiling"
+ CcLlvmBackend -> "cc-llvm-backend"
+ GhcUnregisterised -> "ghc-unregisterised"
+ TablesNextToCode -> "tables-next-to-code"
+ GmpInTree -> "intree-gmp"
+ GmpFrameworkPref -> "gmp-framework-preferred"
+ LeadingUnderscore -> "leading-underscore"
+ SolarisBrokenShld -> "solaris-broken-shld"
+ WithLibdw -> "with-libdw"
+ WithLibnuma -> "with-libnuma"
+ HaveLibMingwEx -> "have-lib-mingw-ex"
+ UseSystemFfi -> "use-system-ffi"
+ BootstrapThreadedRts -> "bootstrap-threaded-rts"
value <- lookupValueOrError configFile key
when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
++ quote (key ++ " = " ++ value) ++ " cannot be parsed."
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -64,8 +64,13 @@ packageArgs = do
, flag GhcUnregisterised ? arg "--ghc-option=-DNO_REGS"
, notM targetSupportsSMP ? arg "--ghc-option=-DNOSMP"
, notM targetSupportsSMP ? arg "--ghc-option=-optc-DNOSMP"
+ -- When building stage 1 or later, use thread-safe RTS functions if
+ -- the configuration calls for a threaded GHC.
, (any (wayUnit Threaded) rtsWays) ?
notStage0 ? arg "--ghc-option=-optc-DTHREADED_RTS"
+ -- When building stage 1, use thread-safe RTS functions if the
+ -- bootstrapping (stage 0) compiler provides a threaded RTS way.
+ , stage0 ? threadedBootstrapper ? arg "--ghc-option=-optc-DTHREADED_RTS"
, ghcWithInterpreter ?
ghciWithDebugger <$> flavour ?
notStage0 ? arg "--ghc-option=-DDEBUGGER"
@@ -90,11 +95,26 @@ packageArgs = do
, builder (Cabal Flags) ? mconcat
[ ghcWithInterpreter ? notStage0 ? arg "ghci"
, cross ? arg "-terminfo"
- -- the 'threaded' flag is True by default, but
- -- let's record explicitly that we link all ghc
- -- executables with the threaded runtime.
- , stage0 ? arg "-threaded"
- , notStage0 ? ifM (ghcThreaded <$> expr flavour) (arg "threaded") (arg "-threaded") ]
+ -- Note [Linking ghc-bin against threaded stage0 RTS]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- We must maintain the invariant that GHCs linked with '-threaded'
+ -- are built with '-optc=-DTHREADED_RTS', otherwise we'll end up
+ -- with a GHC that can use the threaded runtime, but contains some
+ -- non-thread-safe functions. See
+ -- https://gitlab.haskell.org/ghc/ghc/issues/18024 for an example of
+ -- the sort of issues this can cause.
+ , ifM stage0
+ -- We build a threaded stage 1 if the bootstrapping compiler
+ -- supports it.
+ (ifM threadedBootstrapper
+ (arg "threaded")
+ (arg "-threaded"))
+ -- We build a threaded stage N, N>1 if the configuration calls
+ -- for it.
+ (ifM (ghcThreaded <$> expr flavour)
+ (arg "threaded")
+ (arg "-threaded"))
+ ]
]
-------------------------------- ghcPkg --------------------------------
@@ -442,4 +462,4 @@ rtsWarnings = mconcat
-- and also centralizes the versioning.
-- | Minimum supported Windows version.
windowsVersion :: String
-windowsVersion = "0x06000100"
+windowsVersion = "0x06010000"
=====================================
mk/config.mk.in
=====================================
@@ -199,6 +199,9 @@ endif
# `GhcUnregisterised` mode doesn't allow that.
GhcWithSMP := $(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)),YES,NO))
+# Whether or not the bootstrapping GHC supplies a threaded RTS.
+GhcThreadedRts = @GhcThreadedRts@
+
# Whether to include GHCi in the compiler. Depends on whether the RTS linker
# has support for this OS/ARCH combination.
=====================================
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));
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1532b5cf64b99ffdef2730878a08a252ca12a76d...4448ba12bf76cc0dd7c3cee66916bbc428f968c5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1532b5cf64b99ffdef2730878a08a252ca12a76d...4448ba12bf76cc0dd7c3cee66916bbc428f968c5
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/20200529/475a4ba2/attachment-0001.html>
More information about the ghc-commits
mailing list