[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Silence x-partial in Haddock.Backends.Xhtml
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Sep 6 16:10:39 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
59906975 by Hécate Kleidukos at 2024-09-05T10:57:15-04:00
Silence x-partial in Haddock.Backends.Xhtml
This is an unfortunate consequence of two mechanisms:
* GHC provides (possibly-empty) lists of names
* The functions that retrieve those names are not equipped to do error
reporting, and thus accept these lists at face value. They will have
to be attached an effect for error reporting in a later refactoring
- - - - -
8afbab62 by Hécate Kleidukos at 2024-09-05T10:57:15-04:00
hadrian: Support loading haddock in ghci
There is one tricky aspect with wired-in packages where the boot package
is built with `-this-unit-id ghc` but the dependency is reported as
`-package-id ghc-9.6...`. This has never been fixed in GHC as the
situation of loading wired-in packages into the multi-repl seems like
quite a niche feature that is always just easier to workaround.
- - - - -
6cac9eb8 by Matthew Pickering at 2024-09-05T10:57:15-04:00
hadrian/multi: Load all targets when ./hadrian/ghci-multi is called
This seems to make a bit more sense than just loading `ghc` component
(and dependencies).
- - - - -
7d84df86 by Matthew Pickering at 2024-09-05T10:57:51-04:00
ci: Beef up determinism interface test
There have recently been some determinism issues with the simplifier and
documentation. We enable more things to test in the ABI test to check
that we produce interface files deterministically.
- - - - -
5456e02e by Sylvain Henry at 2024-09-06T11:57:01+02:00
Transform some StgRhsClosure into StgRhsCon after unarisation (#25166)
Before unarisation we may have code like:
Test.foo :: Test.D
[GblId, Unf=OtherCon []] =
\u []
case (# |_| #) [GHC.Types.(##)] of sat_sAw [Occ=Once1] {
__DEFAULT -> Test.D [GHC.Types.True sat_sAw];
};
After unarisation we get:
Test.foo :: Test.D
[GblId, Unf=OtherCon []] =
{} \u [] Test.D [GHC.Types.True 2#];
Notice that it's still an Updatable closure for no reason anymore. This
patch transforms appropriate StgRhsClosures into StgRhsCons after
unarisation, allowing these closures to be statically allocated. Now we
get the expected:
Test.foo :: Test.D
[GblId, Unf=OtherCon []] =
Test.D! [GHC.Types.True 2#];
Fix #25166
To avoid duplicating code, this patch refactors the mk(Top)StgRhs
functions and put them in a GHC.Stg.Make module alongside the new
mk(Top)StgRhsCon_maybe functions.
- - - - -
5bba677e by Hécate Kleidukos at 2024-09-06T12:10:04-04:00
haddock: Add missing requirements.txt for the online manual
- - - - -
24 changed files:
- .gitlab/ci.sh
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/Config/Stg/Pipeline.hs
- + compiler/GHC/Stg/Make.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/Stg/Stats.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/Stg/Utils.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/ghc.cabal.in
- hadrian/ghci-multi-cabal.in
- hadrian/src/Rules/ToolArgs.hs
- testsuite/tests/codeGen/should_compile/Makefile
- + testsuite/tests/codeGen/should_compile/T25166.hs
- + testsuite/tests/codeGen/should_compile/T25166.stdout
- testsuite/tests/codeGen/should_compile/all.T
- + utils/haddock/doc/requirements.txt
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
- utils/haddock/haddock-api/src/Haddock/Utils/Json.hs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -753,7 +753,7 @@ function check_interfaces(){
}
function abi_test() {
- for i in {1..20}; do info "iteration $i"; run_abi_test; done
+ for i in {1..10}; do info "iteration $i"; run_abi_test; done
}
function run_abi_test() {
@@ -761,8 +761,8 @@ function run_abi_test() {
fail "HC not set"
fi
mkdir -p out
- OUT="$PWD/out/run1" DIR=$(mktemp -d XXXX-looooooooong) cabal_abi_test -O0
- OUT="$PWD/out/run2" DIR=$(mktemp -d XXXX-short) cabal_abi_test -O0
+ OUT="$PWD/out/run1" DIR=$(mktemp -d XXXX-looooooooong) cabal_abi_test -O1 -haddock
+ OUT="$PWD/out/run2" DIR=$(mktemp -d XXXX-short) cabal_abi_test -O1 -haddock -dunique-increment=-1 -dinitial-unique=16777215
check_interfaces out/run1 out/run2 abis "Mismatched ABI hash"
check_interfaces out/run1 out/run2 interfaces "Mismatched interface hashes"
}
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -27,7 +27,8 @@ import GHC.Core.DataCon
import GHC.Stg.Syntax
import GHC.Stg.Debug
-import GHC.Stg.Utils
+import GHC.Stg.Make
+import GHC.Stg.Utils (allowTopLevelConApp)
import GHC.Types.RepType
import GHC.Types.Id.Make ( coercionTokenId )
@@ -36,16 +37,13 @@ import GHC.Types.Id.Info
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Env
-import GHC.Types.Name ( isExternalName, nameModule_maybe )
+import GHC.Types.Name ( isExternalName )
import GHC.Types.Basic ( Arity, TypeOrConstraint(..) )
import GHC.Types.Literal
import GHC.Types.ForeignCall
import GHC.Types.IPE
-import GHC.Types.Demand ( isAtMostOnceDmd )
-import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import GHC.Unit.Module
-import GHC.Data.FastString
import GHC.Platform ( Platform )
import GHC.Platform.Ways
import GHC.Builtin.PrimOps
@@ -338,10 +336,12 @@ coreToTopStgRhs
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs opts this_mod ccs (bndr, rhs)
- = do { new_rhs <- coreToPreStgRhs rhs
+ = do { new_rhs <- coreToMkStgRhs bndr rhs
; let (stg_rhs, ccs') =
- mkTopStgRhs opts this_mod ccs bndr new_rhs
+ mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))
+ (coreToStg_AutoSccsOnIndividualCafs opts)
+ this_mod ccs bndr new_rhs
stg_arity =
stgRhsArity stg_rhs
@@ -372,7 +372,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs)
-- coreToStgExpr panics if the input expression is a value lambda. CorePrep
-- ensures that value lambdas only exist as the RHS of bindings, which we
--- handle with the function coreToPreStgRhs.
+-- handle with the function coreToMkStgRhs.
coreToStgExpr
:: HasDebugCallStack => CoreExpr
@@ -685,166 +685,24 @@ coreToStgRhs :: (Id,CoreExpr)
-> CtsM StgRhs
coreToStgRhs (bndr, rhs) = do
- new_rhs <- coreToPreStgRhs rhs
+ new_rhs <- coreToMkStgRhs bndr rhs
return (mkStgRhs bndr new_rhs)
--- Represents the RHS of a binding for use with mk(Top)StgRhs.
-data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks
-
-- Convert the RHS of a binding from Core to STG. This is a wrapper around
-- coreToStgExpr that can handle value lambdas.
-coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
-coreToPreStgRhs expr
- = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
- do { body' <- coreToStgExpr body
- ; return (PreStgRhs args' body' (exprType body)) }
- where
- (args, body) = myCollectBinders expr
- args' = filterStgBinders args
-
--- Generate a top-level RHS. Any new cost centres generated for CAFs will be
--- appended to `CollectedCCs` argument.
-mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs
- -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
-
-mkTopStgRhs CoreToStgOpts
- { coreToStg_platform = platform
- , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs
- , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
- } this_mod ccs bndr (PreStgRhs bndrs rhs typ)
- | not (null bndrs)
- = -- The list of arguments is non-empty, so not CAF
- ( StgRhsClosure noExtFieldSilent
- dontCareCCS
- ReEntrant
- bndrs rhs typ
- , ccs )
-
- -- After this point we know that `bndrs` is empty,
- -- so this is not a function binding
- | StgConApp con mn args _ <- unticked_rhs
- , -- Dynamic StgConApps are updatable
- not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)
- = -- CorePrep does this right, but just to make sure
- assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
- (ppr bndr $$ ppr con $$ ppr args)
- ( StgRhsCon dontCareCCS con mn ticks args typ, ccs )
-
- -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
- | opt_AutoSccsOnIndividualCafs
- = ( StgRhsClosure noExtFieldSilent
- caf_ccs
- upd_flag [] rhs typ
- , collectCC caf_cc caf_ccs ccs )
-
- | otherwise
- = ( StgRhsClosure noExtFieldSilent
- all_cafs_ccs
- upd_flag [] rhs typ
- , ccs )
-
- where
- (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
- upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
- | otherwise = Updatable
-
- -- CAF cost centres generated for -fcaf-all
- caf_cc = mkAutoCC bndr modl
- caf_ccs = mkSingletonCCS caf_cc
- -- careful: the binder might be :Main.main,
- -- which doesn't belong to module mod_name.
- -- bug #249, tests prof001, prof002
- modl | Just m <- nameModule_maybe (idName bndr) = m
- | otherwise = this_mod
-
- -- default CAF cost centre
- (_, all_cafs_ccs) = getAllCAFsCC this_mod
-
--- Generate a non-top-level RHS. Cost-centre is always currentCCS,
--- see Note [Cost-centre initialization plan].
-mkStgRhs :: Id -> PreStgRhs -> StgRhs
-mkStgRhs bndr (PreStgRhs bndrs rhs typ)
- | not (null bndrs)
- = StgRhsClosure noExtFieldSilent
- currentCCS
- ReEntrant
- bndrs rhs typ
-
- -- After this point we know that `bndrs` is empty,
- -- so this is not a function binding
-
- | isJoinId bndr -- Must be a nullary join point
- = -- It might have /type/ arguments (T18328),
- -- so its JoinArity might be >0
- StgRhsClosure noExtFieldSilent
- currentCCS
- ReEntrant -- ignored for LNE
- [] rhs typ
-
- | StgConApp con mn args _ <- unticked_rhs
- = StgRhsCon currentCCS con mn ticks args typ
-
- | otherwise
- = StgRhsClosure noExtFieldSilent
- currentCCS
- upd_flag [] rhs typ
- where
- (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
- upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
- | otherwise = Updatable
-
- {-
- SDM: disabled. Eval/Apply can't handle functions with arity zero very
- well; and making these into simple non-updatable thunks breaks other
- assumptions (namely that they will be entered only once).
-
- upd_flag | isPAP env rhs = ReEntrant
- | otherwise = Updatable
-
--- Detect thunks which will reduce immediately to PAPs, and make them
--- non-updatable. This has several advantages:
---
--- - the non-updatable thunk behaves exactly like the PAP,
---
--- - the thunk is more efficient to enter, because it is
--- specialised to the task.
---
--- - we save one update frame, one stg_update_PAP, one update
--- and lots of PAP_enters.
---
--- - in the case where the thunk is top-level, we save building
--- a black hole and furthermore the thunk isn't considered to
--- be a CAF any more, so it doesn't appear in any SRTs.
---
--- We do it here, because the arity information is accurate, and we need
--- to do it before the SRT pass to save the SRT entries associated with
--- any top-level PAPs.
-
-isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
- where
- arity = stgArity f (lookupBinding env f)
-isPAP env _ = False
-
--}
-
-{- ToDo:
- upd = if isOnceDem dem
- then (if isNotTop toplev
- then SingleEntry -- HA! Paydirt for "dem"
- else
- (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
- Updatable)
- else Updatable
- -- For now we forbid SingleEntry CAFs; they tickle the
- -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
- -- and I don't understand why. There's only one SE_CAF (well,
- -- only one that tickled a great gaping bug in an earlier attempt
- -- at ClosureInfo.getEntryConvention) in the whole of nofib,
- -- specifically Main.lvl6 in spectral/cryptarithm2.
- -- So no great loss. KSW 2000-07.
--}
+coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs
+coreToMkStgRhs bndr expr = do
+ let (args, body) = myCollectBinders expr
+ let args' = filterStgBinders args
+ extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
+ body' <- coreToStgExpr body
+ let mk_rhs = MkStgRhs
+ { rhs_args = args'
+ , rhs_expr = body'
+ , rhs_type = exprType body
+ , rhs_is_join = isJoinId bndr
+ }
+ pure mk_rhs
-- ---------------------------------------------------------------------------
-- A monad for the core-to-STG pass
@@ -933,15 +791,6 @@ lookupBinding env v = case lookupVarEnv env v of
Just xx -> xx
Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound
-getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
-getAllCAFsCC this_mod =
- let
- span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
- all_cafs_cc = mkAllCafsCC this_mod span
- all_cafs_ccs = mkSingletonCCS all_cafs_cc
- in
- (all_cafs_cc, all_cafs_ccs)
-
-- Misc.
filterStgBinders :: [Var] -> [Var]
=====================================
compiler/GHC/Driver/Config/Stg/Pipeline.hs
=====================================
@@ -7,6 +7,7 @@ import GHC.Prelude
import Control.Monad (guard)
import GHC.Stg.Pipeline
+import GHC.Stg.Utils
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Stg.Lift
@@ -15,15 +16,19 @@ import GHC.Driver.DynFlags
-- | Initialize STG pretty-printing options from DynFlags
initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts
-initStgPipelineOpts dflags for_bytecode = StgPipelineOpts
- { stgPipeline_lint = do
- guard $ gopt Opt_DoStgLinting dflags
- Just $ initDiagOpts dflags
- , stgPipeline_pprOpts = initStgPprOpts dflags
- , stgPipeline_phases = getStgToDo for_bytecode dflags
- , stgPlatform = targetPlatform dflags
- , stgPipeline_forBytecode = for_bytecode
- }
+initStgPipelineOpts dflags for_bytecode =
+ let !platform = targetPlatform dflags
+ !ext_dyn_refs = gopt Opt_ExternalDynamicRefs dflags
+ in StgPipelineOpts
+ { stgPipeline_lint = do
+ guard $ gopt Opt_DoStgLinting dflags
+ Just $ initDiagOpts dflags
+ , stgPipeline_pprOpts = initStgPprOpts dflags
+ , stgPipeline_phases = getStgToDo for_bytecode dflags
+ , stgPlatform = platform
+ , stgPipeline_forBytecode = for_bytecode
+ , stgPipeline_allowTopLevelConApp = allowTopLevelConApp platform ext_dyn_refs
+ }
-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo
=====================================
compiler/GHC/Stg/Make.hs
=====================================
@@ -0,0 +1,172 @@
+module GHC.Stg.Make
+ ( MkStgRhs (..)
+ , mkTopStgRhs
+ , mkStgRhs
+ , mkStgRhsCon_maybe
+ , mkTopStgRhsCon_maybe
+ )
+where
+
+import GHC.Prelude
+import GHC.Unit.Module
+
+import GHC.Core.DataCon
+import GHC.Core.Type (Type)
+
+import GHC.Stg.Syntax
+import GHC.Stg.Utils (stripStgTicksTop)
+
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.CostCentre
+import GHC.Types.Demand ( isAtMostOnceDmd )
+import GHC.Types.Tickish
+
+-- Represents the RHS of a binding for use with mk(Top)StgRhs and
+-- mk(Top)StgRhsCon_maybe.
+data MkStgRhs = MkStgRhs
+ { rhs_args :: [Id] -- ^ Empty for thunks
+ , rhs_expr :: StgExpr -- ^ RHS expression
+ , rhs_type :: Type -- ^ RHS type (only used in the JS backend: layering violation)
+ , rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point?
+ }
+
+
+-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
+-- appended to `CollectedCCs` argument.
+mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
+ -> Bool -> Module -> CollectedCCs
+ -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
+mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _)
+ -- try to make a StgRhsCon first
+ | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs
+ = ( rhs_con, ccs )
+
+ | not (null bndrs)
+ = -- The list of arguments is non-empty, so not CAF
+ ( StgRhsClosure noExtFieldSilent
+ dontCareCCS
+ ReEntrant
+ bndrs rhs typ
+ , ccs )
+
+ -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
+ | opt_AutoSccsOnIndividualCafs
+ = ( StgRhsClosure noExtFieldSilent
+ caf_ccs
+ upd_flag [] rhs typ
+ , collectCC caf_cc caf_ccs ccs )
+
+ | otherwise
+ = ( StgRhsClosure noExtFieldSilent
+ all_cafs_ccs
+ upd_flag [] rhs typ
+ , ccs )
+
+ where
+ upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
+ | otherwise = Updatable
+
+ -- CAF cost centres generated for -fcaf-all
+ caf_cc = mkAutoCC bndr modl
+ caf_ccs = mkSingletonCCS caf_cc
+ -- careful: the binder might be :Main.main,
+ -- which doesn't belong to module mod_name.
+ -- bug #249, tests prof001, prof002
+ modl | Just m <- nameModule_maybe (idName bndr) = m
+ | otherwise = this_mod
+
+ -- default CAF cost centre
+ (_, all_cafs_ccs) = getAllCAFsCC this_mod
+
+-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
+-- see Note [Cost-centre initialization plan].
+mkStgRhs :: Id -> MkStgRhs -> StgRhs
+mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)
+ -- try to make a StgRhsCon first
+ | Just rhs_con <- mkStgRhsCon_maybe mk_rhs
+ = rhs_con
+
+ | otherwise
+ = StgRhsClosure noExtFieldSilent
+ currentCCS
+ upd_flag bndrs rhs typ
+ where
+ upd_flag | is_join = JumpedTo
+ | not (null bndrs) = ReEntrant
+ | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
+ | otherwise = Updatable
+
+ {-
+ SDM: disabled. Eval/Apply can't handle functions with arity zero very
+ well; and making these into simple non-updatable thunks breaks other
+ assumptions (namely that they will be entered only once).
+
+ upd_flag | isPAP env rhs = ReEntrant
+ | otherwise = Updatable
+
+-- Detect thunks which will reduce immediately to PAPs, and make them
+-- non-updatable. This has several advantages:
+--
+-- - the non-updatable thunk behaves exactly like the PAP,
+--
+-- - the thunk is more efficient to enter, because it is
+-- specialised to the task.
+--
+-- - we save one update frame, one stg_update_PAP, one update
+-- and lots of PAP_enters.
+--
+-- - in the case where the thunk is top-level, we save building
+-- a black hole and furthermore the thunk isn't considered to
+-- be a CAF any more, so it doesn't appear in any SRTs.
+--
+-- We do it here, because the arity information is accurate, and we need
+-- to do it before the SRT pass to save the SRT entries associated with
+-- any top-level PAPs.
+
+isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
+ where
+ arity = stgArity f (lookupBinding env f)
+isPAP env _ = False
+
+-}
+
+{- ToDo:
+ upd = if isOnceDem dem
+ then (if isNotTop toplev
+ then SingleEntry -- HA! Paydirt for "dem"
+ else
+ (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
+ Updatable)
+ else Updatable
+ -- For now we forbid SingleEntry CAFs; they tickle the
+ -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+ -- and I don't understand why. There's only one SE_CAF (well,
+ -- only one that tickled a great gaping bug in an earlier attempt
+ -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+ -- specifically Main.lvl6 in spectral/cryptarithm2.
+ -- So no great loss. KSW 2000-07.
+-}
+
+
+-- | Try to make a non top-level StgRhsCon if appropriate
+mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs
+mkStgRhsCon_maybe (MkStgRhs bndrs rhs typ is_join)
+ | [] <- bndrs
+ , not is_join
+ , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs
+ = Just (StgRhsCon currentCCS con mn ticks args typ)
+
+ | otherwise = Nothing
+
+
+-- | Try to make a top-level StgRhsCon if appropriate
+mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
+mkTopStgRhsCon_maybe allow_static_con_app (MkStgRhs bndrs rhs typ is_join)
+ | [] <- bndrs
+ , not is_join -- shouldn't happen at top-level
+ , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs
+ , allow_static_con_app con args
+ = Just (StgRhsCon dontCareCCS con mn ticks args typ)
+
+ | otherwise = Nothing
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Stg.CSE ( stgCse )
import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams )
import GHC.Unit.Module ( Module )
+import GHC.Core.DataCon (DataCon)
+
import GHC.Utils.Error
import GHC.Types.Var
import GHC.Types.Var.Set
@@ -52,6 +54,12 @@ data StgPipelineOpts = StgPipelineOpts
, stgPipeline_pprOpts :: !StgPprOpts
, stgPlatform :: !Platform
, stgPipeline_forBytecode :: !Bool
+
+ , stgPipeline_allowTopLevelConApp :: Module -> DataCon -> [StgArg] -> Bool
+ -- ^ Is a top-level (static) StgConApp allowed or not. If not, use dynamic allocation.
+ --
+ -- This is typically used to support dynamic linking on Windows and the
+ -- -fexternal-dynamic-refs flag. See GHC.Stg.Utils.allowTopLevelConApp.
}
newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
@@ -136,7 +144,7 @@ stg2stg logger extra_vars opts this_mod binds
StgUnarise -> do
us <- getUniqueSupplyM
liftIO (stg_linter False "Pre-unarise" binds)
- let binds' = {-# SCC "StgUnarise" #-} unarise us binds
+ let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds
liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
liftIO (stg_linter True "Unarise" binds')
return binds'
=====================================
compiler/GHC/Stg/Stats.hs
=====================================
@@ -46,6 +46,7 @@ data CounterType
| ReEntrantBinds Bool{-ditto-}
| SingleEntryBinds Bool{-ditto-}
| UpdatableBinds Bool{-ditto-}
+ | JoinPointBinds Bool{-ditto-}
deriving (Eq, Ord)
type Count = Int
@@ -94,6 +95,7 @@ showStgStats prog
s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested "
s (SingleEntryBinds _) = "SingleEntryBinds_Nested "
s (UpdatableBinds _) = "UpdatableBinds_Nested "
+ s (JoinPointBinds _) = "JoinPointBinds_Nested "
gatherStgStats :: [StgTopBinding] -> StatEnv
gatherStgStats binds = combineSEs (map statTopBinding binds)
@@ -132,6 +134,7 @@ statRhs top (_, StgRhsClosure _ _ u _ body _)
ReEntrant -> ReEntrantBinds top
Updatable -> UpdatableBinds top
SingleEntry -> SingleEntryBinds top
+ JumpedTo -> JoinPointBinds top
)
{-
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -54,7 +54,6 @@ module GHC.Stg.Syntax (
-- utils
stgRhsArity, freeVarsOfRhs,
- isDllConApp,
stgArgType,
stgArgRep,
stgArgRep1,
@@ -87,17 +86,14 @@ import GHC.Core.Ppr( {- instances -} )
import GHC.Types.ForeignCall ( ForeignCall )
import GHC.Types.Id
-import GHC.Types.Name ( isDynLinkName )
import GHC.Types.Tickish ( StgTickish )
import GHC.Types.Var.Set
import GHC.Types.Literal ( Literal, literalType )
import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe )
-import GHC.Unit.Module ( Module )
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
-import GHC.Platform
import GHC.Builtin.PrimOps ( PrimOp, PrimCall )
import Data.ByteString ( ByteString )
@@ -138,51 +134,6 @@ data StgArg
= StgVarArg Id
| StgLitArg Literal
--- | Does this constructor application refer to anything in a different
--- *Windows* DLL?
--- If so, we can't allocate it statically
-isDllConApp
- :: Platform
- -> Bool -- is Opt_ExternalDynamicRefs enabled?
- -> Module
- -> DataCon
- -> [StgArg]
- -> Bool
-isDllConApp platform ext_dyn_refs this_mod con args
- | not ext_dyn_refs = False
- | platformOS platform == OSMinGW32
- = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args
- | otherwise = False
- where
- -- NB: typePrimRep1 is legit because any free variables won't have
- -- unlifted type (there are no unlifted things at top level)
- is_dll_arg :: StgArg -> Bool
- is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v))
- && isDynLinkName platform this_mod (idName v)
- is_dll_arg _ = False
-
--- True of machine addresses; these are the things that don't work across DLLs.
--- The key point here is that VoidRep comes out False, so that a top level
--- nullary GADT constructor is False for isDllConApp
---
--- data T a where
--- T1 :: T Int
---
--- gives
---
--- T1 :: forall a. (a~Int) -> T a
---
--- and hence the top-level binding
---
--- $WT1 :: T Int
--- $WT1 = T1 Int (Coercion (Refl Int))
---
--- The coercion argument here gets VoidRep
-isAddrRep :: PrimOrVoidRep -> Bool
-isAddrRep (NVRep AddrRep) = True
-isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript
-isAddrRep _ = False
-
-- | Type of an @StgArg@
--
-- Very half baked because we have lost the type arguments.
@@ -721,24 +672,35 @@ UpdateFlag
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
-A @ReEntrant@ closure may be entered multiple times, but should not be updated
-or blackholed. An @Updatable@ closure should be updated after evaluation (and
-may be blackholed during evaluation). A @SingleEntry@ closure will only be
-entered once, and so need not be updated but may safely be blackholed.
-}
-data UpdateFlag = ReEntrant | Updatable | SingleEntry
+data UpdateFlag
+ = ReEntrant
+ -- ^ A @ReEntrant@ closure may be entered multiple times, but should not
+ -- be updated or blackholed.
+ | Updatable
+ -- ^ An @Updatable@ closure should be updated after evaluation (and may be
+ -- blackholed during evaluation).
+ | SingleEntry
+ -- ^ A @SingleEntry@ closure will only be entered once, and so need not be
+ -- updated but may safely be blackholed.
+ | JumpedTo
+ -- ^ A @JumpedTo@ (join-point) closure is entered once or multiple times
+ -- but has no heap-allocated associated closure.
+ deriving (Show,Eq)
instance Outputable UpdateFlag where
ppr u = char $ case u of
ReEntrant -> 'r'
Updatable -> 'u'
SingleEntry -> 's'
+ JumpedTo -> 'j'
isUpdatable :: UpdateFlag -> Bool
isUpdatable ReEntrant = False
isUpdatable SingleEntry = False
isUpdatable Updatable = True
+isUpdatable JumpedTo = False
{-
************************************************************************
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE MultiWayIf #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-2012
@@ -401,6 +402,7 @@ import GHC.Utils.Panic
import GHC.Types.RepType
import GHC.Stg.Syntax
import GHC.Stg.Utils
+import GHC.Stg.Make
import GHC.Core.Type
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.Types
@@ -442,10 +444,14 @@ import Data.List (mapAccumL)
-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
-- (i.e. no unboxed tuples, sums or voids)
--
-newtype UnariseEnv = UnariseEnv { ue_rho :: (VarEnv UnariseVal) }
+data UnariseEnv = UnariseEnv
+ { ue_rho :: (VarEnv UnariseVal)
+ , ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool
+ }
-initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv
+initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv
initUnariseEnv = UnariseEnv
+
data UnariseVal
= MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
| UnaryVal OutStgArg -- See Note [Renaming during unarisation].
@@ -477,27 +483,57 @@ lookupRho env v = lookupVarEnv (ue_rho env) v
--------------------------------------------------------------------------------
-unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
-unarise us binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv)) binds)
+unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding]
+unarise us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv is_dll_con_app)) binds)
unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding rho (StgTopLifted bind)
- = StgTopLifted <$> unariseBinding rho bind
+ = StgTopLifted <$> unariseBinding rho True bind
unariseTopBinding _ bind at StgTopStringLit{} = return bind
-unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
-unariseBinding rho (StgNonRec x rhs)
- = StgNonRec x <$> unariseRhs rho rhs
-unariseBinding rho (StgRec xrhss)
- = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
+unariseBinding :: UnariseEnv -> Bool -> StgBinding -> UniqSM StgBinding
+unariseBinding rho top_level (StgNonRec x rhs)
+ = StgNonRec x <$> unariseRhs rho top_level rhs
+unariseBinding rho top_level (StgRec xrhss)
+ = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho top_level rhs) xrhss
-unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
-unariseRhs rho (StgRhsClosure ext ccs update_flag args expr typ)
+unariseRhs :: UnariseEnv -> Bool -> StgRhs -> UniqSM StgRhs
+unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr typ)
= do (rho', args1) <- unariseFunArgBinders rho args
expr' <- unariseExpr rho' expr
- return (StgRhsClosure ext ccs update_flag args1 expr' typ)
-
-unariseRhs rho (StgRhsCon ccs con mu ts args typ)
+ -- Unarisation can lead to a StgRhsClosure becoming a StgRhsCon.
+ -- Hence, we call `mk(Top)StgRhsCon_maybe` rather than just building
+ -- another `StgRhsClosure`.
+ --
+ -- For example with unboxed sums (#25166):
+ --
+ -- foo = \u [] case (# | _ | #) [(##)] of tag { __DEFAULT -> D [True tag] }
+ --
+ -- ====> {unarisation}
+ --
+ -- foo = D [True 2#]
+ --
+ -- Transforming an appropriate StgRhsClosure into a StgRhsCon is
+ -- important as top-level StgRhsCon are statically allocated.
+ --
+ let mk_rhs = MkStgRhs
+ { rhs_args = args1
+ , rhs_expr = expr'
+ , rhs_type = typ
+ , rhs_is_join = update_flag == JumpedTo
+ }
+ if | top_level
+ , Just rhs_con <- mkTopStgRhsCon_maybe (ue_allow_static_conapp rho) mk_rhs
+ -> pure rhs_con
+
+ | not top_level
+ , Just rhs_con <- mkStgRhsCon_maybe mk_rhs
+ -> pure rhs_con
+
+ | otherwise
+ -> pure (StgRhsClosure ext ccs update_flag args1 expr' typ)
+
+unariseRhs rho _top (StgRhsCon ccs con mu ts args typ)
= assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
return (StgRhsCon ccs con mu ts (unariseConArgs rho args) typ)
@@ -576,10 +612,10 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
-- dead after unarise (checked in GHC.Stg.Lint)
unariseExpr rho (StgLet ext bind e)
- = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
+ = StgLet ext <$> unariseBinding rho False bind <*> unariseExpr rho e
unariseExpr rho (StgLetNoEscape ext bind e)
- = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
+ = StgLetNoEscape ext <$> unariseBinding rho False bind <*> unariseExpr rho e
unariseExpr rho (StgTick tick e)
= StgTick tick <$> unariseExpr rho e
=====================================
compiler/GHC/Stg/Utils.hs
=====================================
@@ -9,9 +9,12 @@ module GHC.Stg.Utils
, idArgs
, mkUnarisedId, mkUnarisedIds
+
+ , allowTopLevelConApp
) where
import GHC.Prelude
+import GHC.Platform
import GHC.Types.Id
import GHC.Core.Type
@@ -22,6 +25,8 @@ import GHC.Types.Tickish
import GHC.Types.Unique.Supply
import GHC.Types.RepType
+import GHC.Types.Name ( isDynLinkName )
+import GHC.Unit.Module ( Module )
import GHC.Stg.Syntax
import GHC.Utils.Outputable
@@ -122,3 +127,54 @@ stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE p = go
where go (StgTick t e) | p t = go e
go other = other
+
+-- | Do we allow the given top-level (static) ConApp?
+allowTopLevelConApp
+ :: Platform
+ -> Bool -- is Opt_ExternalDynamicRefs enabled?
+ -> Module
+ -> DataCon
+ -> [StgArg]
+ -> Bool
+allowTopLevelConApp platform ext_dyn_refs this_mod con args
+ -- we're not using dynamic linking
+ | not ext_dyn_refs = True
+ -- if the target OS is Windows, we only allow top-level ConApps if they don't
+ -- reference external names (Windows DLLs have a problem with static cross-DLL
+ -- refs)
+ | platformOS platform == OSMinGW32 = not is_external_con_app
+ -- otherwise, allowed
+ -- Sylvain: shouldn't this be False when (ext_dyn_refs && is_external_con_app)?
+ | otherwise = True
+ where
+ is_external_con_app = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args
+
+ -- NB: typePrimRep1 is legit because any free variables won't have
+ -- unlifted type (there are no unlifted things at top level)
+ is_dll_arg :: StgArg -> Bool
+ is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v))
+ && isDynLinkName platform this_mod (idName v)
+ is_dll_arg _ = False
+
+-- True of machine addresses; these are the things that don't work across DLLs.
+-- The key point here is that VoidRep comes out False, so that a top level
+-- nullary GADT constructor is True for allowTopLevelConApp
+--
+-- data T a where
+-- T1 :: T Int
+--
+-- gives
+--
+-- T1 :: forall a. (a~Int) -> T a
+--
+-- and hence the top-level binding
+--
+-- $WT1 :: T Int
+-- $WT1 = T1 Int (Coercion (Refl Int))
+--
+-- The coercion argument here gets VoidRep
+isAddrRep :: PrimOrVoidRep -> Bool
+isAddrRep (NVRep AddrRep) = True
+isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript
+isAddrRep _ = False
+
=====================================
compiler/GHC/StgToCmm/DataCon.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Prelude
import GHC.Platform
+import GHC.Stg.Utils (allowTopLevelConApp)
import GHC.Stg.Syntax
import GHC.Core ( AltCon(..) )
@@ -48,7 +49,6 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad (mapMaybeM)
-import Control.Monad
import Data.Char
import GHC.StgToCmm.Config (stgToCmmPlatform)
import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)
@@ -90,10 +90,8 @@ cgTopRhsCon cfg id con mn args
gen_code =
do { profile <- getProfile
; this_mod <- getModuleName
- ; when (platformOS platform == OSMinGW32) $
- -- Windows DLLs have a problem with static cross-DLL refs.
- massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)))
- ; assert (args `lengthIs` countConRepArgs con ) return ()
+ ; massert (allowTopLevelConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args))
+ ; massert (args `lengthIs` countConRepArgs con )
; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args)
-- LAY IT OUT
; let
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -4,6 +4,7 @@ module GHC.Types.CostCentre (
CostCentre(..), CcName, CCFlavour,
mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour,
mkLateCCFlavour, mkCallerCCFlavour,
+ getAllCAFsCC,
pprCostCentre,
CostCentreStack,
@@ -393,3 +394,13 @@ instance Binary CostCentre where
-- ok, because we only need the SrcSpan when declaring the
-- CostCentre in the original module, it is not used by importing
-- modules.
+
+getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
+getAllCAFsCC this_mod =
+ let
+ span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
+ all_cafs_cc = mkAllCafsCC this_mod span
+ all_cafs_ccs = mkSingletonCCS all_cafs_cc
+ in
+ (all_cafs_cc, all_cafs_ccs)
+
=====================================
compiler/ghc.cabal.in
=====================================
@@ -702,6 +702,7 @@ Library
GHC.Stg.InferTags.Rewrite
GHC.Stg.InferTags.TagSig
GHC.Stg.InferTags.Types
+ GHC.Stg.Make
GHC.Stg.Pipeline
GHC.Stg.Stats
GHC.Stg.Subst
=====================================
hadrian/ghci-multi-cabal.in
=====================================
@@ -8,6 +8,6 @@ if [[ $(printf "9.4.0\n%s\n" $($RUN_GHC --numeric-version) | sort -uV | head -n
set -e
export TOOL_OUTPUT=.hadrian_ghci_multi/ghci_args
# Replace newlines with spaces, as these otherwise break the ghci invocation on windows.
-CABFLAGS=-v0 "hadrian/build-cabal" multi:ghc --build-root=.hadrian_ghci_multi --flavour=ghc-in-ghci $HADRIAN_ARGS
+CABFLAGS=-v0 "hadrian/build-cabal" multi --build-root=.hadrian_ghci_multi --flavour=ghc-in-ghci $HADRIAN_ARGS
GHC_FLAGS="$GHC_FLAGS $(cat $TOOL_OUTPUT | tr '\n\r' ' ')"
$RUN_GHC --interactive $GHC_FLAGS $@ -fno-code -fwrite-interface -O0 +RTS -A128m
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -16,7 +16,9 @@ import System.Directory (canonicalizePath)
import System.Environment (lookupEnv)
import qualified Data.Set as Set
import Oracles.ModuleFiles
+import Oracles.Setting
import Utilities
+import Data.Version.Extra
-- | @tool:@ is used by tooling in order to get the arguments necessary
-- to set up a GHC API session which can compile modules from GHC. When
@@ -85,7 +87,16 @@ multiSetup pkg_s = do
need (srcs ++ gens)
let rexp m = ["-reexported-module", m]
let hidir = root </> "interfaces" </> pkgPath p
- writeFile' (resp_file root p) (intercalate "\n" (arg_list
+ ghcVersion <- ghcVersionStage stage0InTree
+ let ghc_wired_in = readVersion ghcVersion < makeVersion [9,8,1]
+ ghc_package_id = "-package-id ghc-" ++ ghcVersion
+ normalise_ghc = if ghc_wired_in then normalisePackageIds else id
+ normalisePackageIds :: [String] -> [String]
+ normalisePackageIds ((isPrefixOf ghc_package_id -> True) : xs) = "-package-id" : "ghc" : xs
+ normalisePackageIds (x:xs) = x : normalisePackageIds xs
+ normalisePackageIds [] = []
+
+ writeFile' (resp_file root p) (intercalate "\n" (normalise_ghc arg_list
++ modules cd
++ concatMap rexp (reexportModules cd)
++ ["-outputdir", hidir]))
@@ -150,7 +161,9 @@ toolTargets = [ cabalSyntax
, ghcHeap
, ghci
, ghcPkg -- # executable
- -- , haddock -- # depends on ghc library
+ , haddock -- # depends on ghc library
+ , haddockApi
+ , haddockLibrary
, hsc2hs -- # executable
, hpc
, hpcBin -- # executable
=====================================
testsuite/tests/codeGen/should_compile/Makefile
=====================================
@@ -77,3 +77,6 @@ T17648:
-fcatch-nonexhaustive-cases T17648.hs -v0 -fforce-recomp
'$(TEST_HC)' --show-iface T17648.hi | tr -d '\n\r' | \
grep -F 'f :: T GHC.Types.Int -> () [TagSig' >/dev/null
+
+T25166:
+ '$(TEST_HC)' -O2 -dno-typeable-binds -ddump-cmm T25166.hs | awk '/foo_closure/{flag=1}/}]/{flag=0}flag'
=====================================
testsuite/tests/codeGen/should_compile/T25166.hs
=====================================
@@ -0,0 +1,7 @@
+module Test where
+
+data A = A | B | C
+
+data D = D !Bool {-# UNPACK #-} !A
+
+foo = D True B
=====================================
testsuite/tests/codeGen/should_compile/T25166.stdout
=====================================
@@ -0,0 +1,6 @@
+[section ""data" . Test.foo_closure" {
+ Test.foo_closure:
+ const Test.D_con_info;
+ const GHC.Types.True_closure+2;
+ const 2;
+ const 3;
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -139,5 +139,7 @@ test('callee-no-local', [
['-ddump-cmm-raw']
)
+test('T25166', [req_cmm], makefile_test, [])
+
# dump Core to ensure that d is defined as: d = D 10## RUBBISH(IntRep)
test('T25177', normal, compile, ['-O2 -dno-typeable-binds -ddump-simpl -dsuppress-all -dsuppress-uniques -v0'])
=====================================
utils/haddock/doc/requirements.txt
=====================================
@@ -0,0 +1 @@
+sphinxcontrib-applehelp ==2.0.0
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -26,20 +26,20 @@ import Data.Foldable (toList)
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
-import Data.Maybe
+import qualified Data.Maybe as Maybe
import GHC hiding (fromMaybeContext)
import GHC.Core.Type (Specificity (..))
import GHC.Data.FastString (unpackFS)
import GHC.Types.Name (getOccString, nameOccName, tidyNameOcc)
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader (rdrNameOcc)
+import GHC.Utils.Ppr hiding (Doc, quote)
+import qualified GHC.Utils.Ppr as Pretty
import System.Directory
import System.FilePath
import Prelude hiding ((<>))
import Documentation.Haddock.Markup
-import GHC.Utils.Ppr hiding (Doc, quote)
-import qualified GHC.Utils.Ppr as Pretty
import Haddock.Doc (combineDocumentation)
import Haddock.GhcUtils
import Haddock.Types
@@ -90,7 +90,7 @@ ppLaTeX
ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir =
do
createDirectoryIfMissing True odir
- when (isNothing maybe_style) $
+ when (Maybe.isNothing maybe_style) $
copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)
ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces
mapM_ (ppLaTeXModule title odir) visible_ifaces
@@ -139,7 +139,7 @@ ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
mods = sort (map (moduleBasename . ifaceMod) ifaces)
- filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
+ filename = odir </> (Maybe.fromMaybe "haddock" packageStr <.> "tex")
writeUtf8File filename (show tex)
@@ -174,7 +174,7 @@ ppLaTeXModule _title odir iface = do
]
description =
- (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
+ (Maybe.fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
body = processExports exports
--
@@ -201,7 +201,7 @@ exportListItem
in sep (punctuate comma [leader <+> ppDocBinder name | name <- names])
<> case subdocs of
[] -> empty
- _ -> parens (sep (punctuate comma (mapMaybe go subdocs)))
+ _ -> parens (sep (punctuate comma (Maybe.mapMaybe go subdocs)))
exportListItem (ExportNoDecl y []) =
ppDocBinder y
exportListItem (ExportNoDecl y subs) =
@@ -368,7 +368,7 @@ ppFamDecl associated doc instances decl unicode =
(if null body then Nothing else Just (vcat body))
$$ instancesBit
where
- body = catMaybes [familyEqns, documentationToLaTeX doc]
+ body = Maybe.catMaybes [familyEqns, documentationToLaTeX doc]
whereBit = case fdInfo (tcdFam decl) of
ClosedTypeFamily _ -> keyword "where"
@@ -544,7 +544,7 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
text "\\haddockbeginargs"
$$ vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0))
$$ text "\\end{tabulary}\\par"
- $$ fromMaybe empty (documentationToLaTeX doc)
+ $$ Maybe.fromMaybe empty (documentationToLaTeX doc)
-- | This splits up a type signature along @->@ and adds docs (when they exist)
-- to the arguments. The output is a list of (leader/seperator, argument and
@@ -741,7 +741,7 @@ ppClassDecl
hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
- body = catMaybes [documentationToLaTeX doc, body_]
+ body = Maybe.catMaybes [documentationToLaTeX doc, body_]
body_
| null lsigs, null ats, null at_defs = Nothing
@@ -764,9 +764,13 @@ ppClassDecl
| L _ (ClassOpSig _ is_def lnames typ) <- lsigs
, let doc
| is_def = noDocForDecl
- | otherwise = lookupAnySubdoc (head names) subdocs
+ | otherwise = lookupAnySubdoc firstName subdocs
names = map (cleanName . unLoc) lnames
leader = if is_def then Just (keyword "default") else Nothing
+ firstName =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
]
-- N.B. taking just the first name is ok. Signatures with multiple
-- names are expanded so that each name gets its own signature.
@@ -853,7 +857,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
where
cons = dd_cons (tcdDataDefn dataDecl)
- body = catMaybes [doc >>= documentationToLaTeX, constrBit, patternBit]
+ body = Maybe.catMaybes [doc >>= documentationToLaTeX, constrBit, patternBit]
(whereBit, leaders)
| null cons
@@ -1031,7 +1035,11 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+ mbDoc = lookup (foExt $ unLoc name) subdocs >>= fmap _doc . combineDocumentation . fst
+ name =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
-- | Pretty-print a bundled pattern synonym
ppSideBySidePat
@@ -1157,7 +1165,7 @@ ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX
ppContextNoArrow cxt unicode =
- fromMaybe empty $
+ Maybe.fromMaybe empty $
ppContextNoLocsMaybe (map unLoc cxt) unicode
ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wwarn=x-partial #-}
-- |
-- Module : Haddock.Backends.Html
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -10,7 +10,7 @@
-----------------------------------------------------------------------------
-- |
--- Module : Haddock.Backends.Html.Decl
+-- Module : Haddock.Backends.Xhtml.Decl
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2009,
-- Mark Lentczner 2010
@@ -28,7 +28,7 @@ import Data.Foldable (toList)
import Data.List (intersperse, sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
-import Data.Maybe
+import qualified Data.Maybe as Maybe
import GHC hiding (LexicalFixity (..), fromMaybeContext)
import GHC.Core.Type (Specificity (..))
import GHC.Data.BooleanFormula
@@ -279,13 +279,17 @@ ppTypeOrFunSig
qual
emptyCtxts
| summary = pref1
- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curname pkg qual doc
+ | Map.null argDocs = topDeclElem links loc splice docName pref1 +++ docSection curname pkg qual doc
| otherwise =
- topDeclElem links loc splice docnames pref2
+ topDeclElem links loc splice docName pref2
+++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)
+++ docSection curname pkg qual doc
where
- curname = getName <$> listToMaybe docnames
+ curname = getName <$> Maybe.listToMaybe docnames
+ docName =
+ case Maybe.listToMaybe docnames of
+ Nothing -> error "No docnames. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
-- | This splits up a type signature along @->@ and adds docs (when they exist)
-- to the arguments.
@@ -489,11 +493,15 @@ ppSimpleSig
-> HsSigType DocNameI
-> Html
ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
- topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
+ topDeclElem' docName $ ppTypeSig True occNames ppTyp unicode
where
topDeclElem' = topDeclElem links loc splice
ppTyp = ppSigType unicode qual emptyCtxts typ
occNames = map getOccName names
+ docName =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
--------------------------------------------------------------------------------
@@ -530,13 +538,13 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
curname = Just $ getName docname
header_ =
- topDeclElem links loc splice [docname] $
+ topDeclElem links loc splice docname $
ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
instancesBit
| FamilyDecl{fdInfo = ClosedTypeFamily mb_eqns} <- decl
, not summary =
- subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns
+ subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ Maybe.fromMaybe [] mb_eqns
| otherwise =
ppInstances links (OriginFamily docname) instances splice unicode pkg qual
@@ -706,7 +714,7 @@ ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h
ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoArrow cxt unicode qual emptyCtxts =
- fromMaybe noHtml $
+ Maybe.fromMaybe noHtml $
ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts
ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html
@@ -790,9 +798,9 @@ ppShortClassDecl
pkg
qual =
if not (any isUserLSig sigs) && null ats
- then (if summary then id else topDeclElem links loc splice [nm]) hdr
+ then (if summary then id else topDeclElem links loc splice nm) hdr
else
- (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+ (if summary then id else topDeclElem links loc splice nm) (hdr <+> keyword "where")
+++ shortSubDecls
False
( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats, let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
@@ -814,8 +822,12 @@ ppShortClassDecl
pkg
qual
| L _ (ClassOpSig _ False lnames typ) <- sigs
- , let doc = lookupAnySubdoc (head names) subdocs
- names = map unLoc lnames
+ , let names = map unLoc lnames
+ subdocName =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
+ doc = lookupAnySubdoc subdocName subdocs
]
-- FIXME: is taking just the first name ok? Is it possible that
-- there are different subdocs for different names in a single
@@ -876,8 +888,8 @@ ppClassDecl
sigs = map unLoc lsigs
classheader
- | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
- | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
+ | any isUserLSig lsigs = topDeclElem links loc splice nm (hdr unicode qual <+> keyword "where" <+> fixs)
+ | otherwise = topDeclElem links loc splice nm (hdr unicode qual <+> fixs)
-- Only the fixity relevant to the class header
fixs = ppFixities [f | f@(n, _) <- fixities, n == unLoc lname] qual
@@ -890,7 +902,7 @@ ppClassDecl
atBit =
subAssociatedTypes
[ ppAssocType summary links doc at subfixs splice unicode pkg qual
- <+> subDefaults (maybeToList defTys)
+ <+> subDefaults (Maybe.maybeToList defTys)
| at <- ats
, let name = unLoc . fdLName $ unLoc at
doc = lookupAnySubdoc name subdocs
@@ -941,7 +953,7 @@ ppClassDecl
unicode
pkg
qual
- <+> subDefaults (maybeToList defSigs)
+ <+> subDefaults (Maybe.maybeToList defSigs)
| ClassOpSig _ False lnames typ <- sigs
, name <- map unLoc lnames
, let doc = lookupAnySubdoc name subdocs
@@ -1111,7 +1123,7 @@ ppInstanceAssocTys
-> [DocInstance DocNameI]
-> [Html]
ppInstanceAssocTys links splice unicode qual orphan insts =
- maybeToList $
+ Maybe.maybeToList $
subTableSrc Nothing qual links True $
zipWith
mkInstHead
@@ -1137,10 +1149,14 @@ ppInstanceSigs links splice unicode qual sigs = do
L _ rtyp = dropWildCards typ
-- Instance methods signatures are synified and thus don't have a useful
-- SrcSpan value. Use the methods name location instead.
- return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp
+ let lname =
+ case Maybe.listToMaybe lnames of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA lname) names rtyp
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
-lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
+lookupAnySubdoc n = Maybe.fromMaybe noDocForDecl . lookup n
instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String
instanceId origin no orphan ihd =
@@ -1256,7 +1272,7 @@ ppDataDecl
ConDeclGADT{} -> False
header_ =
- topDeclElem links loc splice [docname] $
+ topDeclElem links loc splice docname $
ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
fix = ppFixities (filter (\(n, _) -> n == docname) fixities) qual
@@ -1531,7 +1547,10 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (foExt $ unLoc declName) subdocs >>= combineDocumentation . fst
+ declName = case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField _ names ltype _) =
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
=====================================
@@ -311,9 +311,9 @@ declElem = paragraph ! [theclass "src"]
-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
-topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
-topDeclElem lnks loc splice names html =
- declElem << (html <+> (links lnks loc splice Nothing $ head names))
+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html -> Html
+topDeclElem lnks loc splice name html =
+ declElem << (html <+> links lnks loc splice Nothing name)
-- FIXME: is it ok to simply take the first name?
=====================================
utils/haddock/haddock-api/src/Haddock/Utils/Json.hs
=====================================
@@ -371,10 +371,9 @@ instance FromJSON Char where
parseJSONList v = typeMismatch "String" v
parseChar :: String -> Parser Char
-parseChar t =
- if length t == 1
- then pure $ head t
- else prependContext "Char" $ fail "expected a string of length 1"
+parseChar [c] = pure c
+parseChar [] = prependContext "Char" $ fail "expected a string of length 1, got an empty string"
+parseChar (_ : _) = prependContext "Char" $ fail "expected a string of length 1, got a longer string"
parseRealFloat :: RealFloat a => String -> Value -> Parser a
parseRealFloat _ (Number s) = pure $ realToFrac s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/07ba0d216f0a91353db2125b7c44a19219c80213...5bba677e1bd93fc514b66283b87fd281fc620402
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/07ba0d216f0a91353db2125b7c44a19219c80213...5bba677e1bd93fc514b66283b87fd281fc620402
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/20240906/2805ed12/attachment-0001.html>
More information about the ghc-commits
mailing list