July 2026 - ghc-commits

[Git][ghc/ghc][wip/21101] 5 commits: Strip ticks when desugaring bool guards
by Sasha Bogicevic (＠Bogicevic) 16 Jul '26

16 Jul '26

Sasha Bogicevic pushed to branch wip/21101 at Glasgow Haskell Compiler / GHC Commits: d43a7b7a by Brian McKenna at 2026-07-15T20:10:04+02:00 Strip ticks when desugaring bool guards The special `considerAccessible` pattern was broken when compiling with debug info. Compiling with debug info wraps expressions with `SourceNote` ticks, which broke the internals of the `desugarBoolGuard` function. Ticks are now ignored within this function. Fixes #27360 - - - - - ede4b17b by Ben Gamari at 2026-07-15T22:59:53-04:00 base: Display ExceptionContext in WhileHandling's textual description As originally-implemented the implementation for `WhileHandling(displayExceptionAnnotation)` would display the `ExceptionContext` of the exception which it carries (as this was the behavior of `displayException`, in terms of which `displayExceptionAnnotation` was implemented). However, in 284ffab3 the definition of `SomeException(displayException)` was changed to exclude the `ExceptionContext`. This means that `WhileHandling(displayExceptionAnnotation)` fails to describe the provenance of the exception which it captures, greatly limiting its utility. Return the implementation to its originally-specified behavior by implementing `WhileHandling(displayExceptionAnnotation)` in terms of `displayExceptionWithInfo`. Fixes #27456. - - - - - 63b92a32 by Sasha Bogicevic at 2026-07-16T18:26:01+02:00 21101 Error message text for invalid record wildcard match - - - - - 377dbd90 by Sasha Bogicevic at 2026-07-16T18:26:02+02:00 Improve error message for record wildcards with fieldless constructors TcRnIllegalWildcardsInConstructor now stores a RecordFieldPart, so the message distinguishes record patterns from record constructions, and its suggested fixes are structured GhcHints (SuggestEmptyRecordBraces, SuggestExplicitConstructorArguments) that tools like HLS can turn into code actions. Storing HsRecFieldContext directly is not possible: GHC.Tc.Errors.Types is reachable from the parser via GHC.Types.Error.Codes, while GHC.Rename.Pat depends on the parser — so we reuse the existing RecordFieldPart mirror and toRecordFieldPart. Fixes #21101 - - - - - 90d299eb by Sasha Bogicevic at 2026-07-16T18:26:02+02:00 Record wildcard hints: show them in more contexts, and include arity (#21101) Address review feedback on !8673: * Emit SuggestExplicitConstructorArguments for record patterns as well as record construction, so `f (C {..}) = ...` also suggests rewriting to positional form. SuggestEmptyRecordBraces remains pattern-only, since `C {}` as an expression would construct a value with all fields unset. * Store the constructor's visible arity in ConHasPositionalArgs so the hint can say how many arguments to write, e.g. Apply ‘D’ to its two arguments instead The arity is threaded from the parsed declaration through LConsWithFields: the per-constructor payload changes from Maybe [Located Int] to Either VisArity [Located Int], where Left n means the constructor has n unlabelled arguments. Updates test baselines: T21101, T9815, T9815b, T9815ghci, T9815bghci. - - - - - 30 changed files: - + changelog.d/T27360 - + changelog.d/T27456 - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/GREInfo.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - libraries/base/changelog.md - libraries/base/tests/T15349.stderr - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/tests/backtraces/T14532b.stdout - testsuite/tests/codeGen/should_run/cgrun025.stderr - testsuite/tests/exceptions/T26759.stderr - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/mdo/should_fail/mdofail006.stderr - + testsuite/tests/pmcheck/should_compile/T27360.hs - testsuite/tests/pmcheck/should_compile/all.T - + testsuite/tests/rename/should_fail/T21101.hs - + testsuite/tests/rename/should_fail/T21101.stderr - testsuite/tests/rename/should_fail/T9815.stderr - testsuite/tests/rename/should_fail/T9815b.stderr - testsuite/tests/rename/should_fail/T9815bghci.stderr - testsuite/tests/rename/should_fail/T9815ghci.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/runghc/T7859.stderr-mingw32 Changes: ===================================== changelog.d/T27360 ===================================== @@ -0,0 +1,10 @@ +section: compiler +issues: #27360 +mrs: !16161 +synopsis: + Recognise ``considerAccessible`` under ticks (``-g``, ``-finfo-table-map``, ``-fhpc`` etc) +description: + The pattern-match checker now properly recognises ``considerAccessible`` even + when it is surrounded by ticks (e.g. debug info ticks with ``-g``, with + ``-finfo-table-map``, etc). This ensures it works as advertised, suppressing + redundant pattern-match warnings, even when it occurs under a tick. ===================================== changelog.d/T27456 ===================================== @@ -0,0 +1,8 @@ +section: base +issues: #27456 +mrs: !16275 +synopsis: + Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` +description: + In the past ``displayException`` (in terms of which ``WhileHandling``\'s ``displayExceptionAnnotation` is implemented) was changed to hide ``ExceptionContext``. This regressed the behavior of ``displayExceptionAnnotation`` from that which was originally specified. Restore the intended behavior of showing the ``ExceptionContext`` of the carried exception. + ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -1613,8 +1613,8 @@ hsConDeclsBinders in the following format: with its record fields, in the form of a list of Int indices into... - IntMap FieldOcc, an IntMap of record fields. -(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating -that the constructor has unlabelled fields: see Note [Local constructor info in the renamer] +(In actual fact, we use [(ConRdrName, Either VisArity [Located Int])], with Left n indicating +that the constructor has n unlabelled arguments: see Note [Local constructor info in the renamer] in GHC.Types.GREInfo.) This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc): @@ -1635,7 +1635,7 @@ Other relevant test cases: rnfail015. -- See Note [Collecting record fields in data declarations]. data LConsWithFields p = LConsWithFields - { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])] + { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Either VisArity [Located Int])] , consFields :: IntMap (LFieldOcc (GhcPass p)) } @@ -1675,16 +1675,15 @@ hsConDeclsBinders cons = go emptyFieldIndices cons LConsWithFields ns fs = go seen' rs get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p) - -> (Maybe [Located Int], FieldIndices p) - get_flds_h98 seen (RecCon _ flds) = first Just $ get_flds seen flds - get_flds_h98 seen (PrefixCon _ []) = (Just [], seen) - get_flds_h98 seen _ = (Nothing, seen) + -> (Either VisArity [Located Int], FieldIndices p) + get_flds_h98 seen (RecCon _ flds) = first Right $ get_flds seen flds + get_flds_h98 seen (PrefixCon _ args) = (Left (length args), seen) + get_flds_h98 seen (InfixCon {}) = (Left 2, seen) get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p) - -> (Maybe [Located Int], FieldIndices p) - get_flds_gadt seen (RecConGADT _ flds) = first Just $ get_flds seen flds - get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen) - get_flds_gadt seen _ = (Nothing, seen) + -> (Either VisArity [Located Int], FieldIndices p) + get_flds_gadt seen (RecConGADT _ flds) = first Right $ get_flds seen flds + get_flds_gadt seen (PrefixConGADT _ args) = (Left (length args), seen) get_flds :: FieldIndices p -> LocatedA [LHsConDeclRecField (GhcPass p)] -> ([Located Int], FieldIndices p) ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -12,7 +12,8 @@ import GHC.Prelude import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils -import GHC.Core (Expr(Var,App)) +import GHC.Core (CoreExpr, Expr(Var,App)) +import GHC.Core.Utils (stripTicksTopE) import GHC.Data.FastString (unpackFS, lengthFS, mkFastStringShortText) import GHC.Driver.DynFlags import GHC.Hs @@ -474,24 +475,28 @@ desugarLocalBinds _binds = return GdEnd -- | Desugar a pattern guard -- @pat <- e ==> let x = e; <guards for pat <- x>@ desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM GrdDag -desugarBind p e = dsLExpr e >>= \case - Var y - | Nothing <- isDataConId_maybe y - -- RHS is a variable, so that will allow us to omit the let - -> desugarLPat y p - rhs -> do - (x, grds) <- desugarLPatV p - pure (PmLet x rhs `consGrdDag` grds) +desugarBind p e = + dsLExpr_stripTicks e >>= \case + Var y + | Nothing <- isDataConId_maybe y + -- RHS is a variable, so that will allow us to omit the let + -> desugarLPat y p + rhs -> do + (x, grds) <- desugarLPatV p + pure (PmLet x rhs `consGrdDag` grds) -- | Desugar a boolean guard -- @e ==> let x = e; True <- x@ desugarBoolGuard :: LHsExpr GhcTc -> DsM GrdDag desugarBoolGuard e - | isJust (isTrueLHsExpr e) = return GdEnd + | isJust (isTrueLHsExpr e) -- NB: looks through ticks -- The formal thing to do would be to generate (True <- True) -- but it is trivial to solve so instead we give back an empty -- GrdDag for efficiency - | otherwise = dsLExpr e >>= \case + = return GdEnd + + | otherwise + = dsLExpr_stripTicks e >>= \case Var y | Nothing <- isDataConId_maybe y -- Omit the let by matching on y @@ -500,6 +505,19 @@ desugarBoolGuard e x <- mkPmId boolTy pure $ sequencePmGrds [PmLet x rhs, vanillaConGrd x trueDataCon []] +-- | Desugar an expression, stripping off top-level ticks from the resulting +-- Core expression. +-- +-- This function is used instead of 'dsLExpr' when we are immediately going to +-- inspect the Core (as we do in e.g. 'desugarBoolGuard' or 'desugarBind') to +-- make sure we properly look through intervening ticks (fixing #27360). +-- +-- It's not needed when all we do is stash the resulting 'CoreExpr' into a +-- 'GrdDag', as the rest of the machinery (such as 'GHC.HsToCore.Pmc.Solver.addCoreCt') +-- looks through ticks. +dsLExpr_stripTicks :: LHsExpr GhcTc -> DsM CoreExpr +dsLExpr_stripTicks e = stripTicksTopE (const True) <$> dsLExpr e + {- Note [Field match order for RecCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The order for RecCon field patterns actually determines evaluation order of ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -423,7 +423,10 @@ lookupConstructorInfo qcon@(WithUserRdr _ con_name) = do { info <- lookupGREInfo_GRE con_name ; case info of IAmConLike con_info -> return con_info - UnboundGRE -> return $ ConInfo (ConIsData []) ConHasPositionalArgs + UnboundGRE -> return $ ConInfo (ConIsData []) (ConHasPositionalArgs 0) + -- The arity is a dummy: an unbound constructor never reaches the + -- code that consults it (see the isUnboundName guard in + -- GHC.Rename.Pat.rn_dotdot). IAmTyCon {} -> failIllegalTyCon WL_ConLike qcon _ -> pprPanic "lookupConstructorInfo: not a ConLike" $ vcat [ text "name:" <+> ppr con_name ] ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -71,7 +71,7 @@ import GHC.Types.FieldLabel import GHC.Types.Hint import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( TyConFlavour (..), convImportLevel ) +import GHC.Types.Basic (TyConFlavour (..), convImportLevel, VisArity) import GHC.Types.Id import GHC.Types.PkgQual import GHC.Types.GREInfo (ConInfo(..), ConFieldInfo (..), ConLikeInfo (ConIsData)) @@ -875,15 +875,16 @@ getLocalNonValBinders fixity_env -- -- The information we needed was all set up for us: -- see Note [Collecting record fields in data declarations] in GHC.Hs.Utils. - mk_fld_env :: [(Name, Maybe [Located Int])] -> IntMap FieldLabel + mk_fld_env :: [(Name, Either VisArity [Located Int])] -> IntMap FieldLabel -> [(ConLikeName, ConInfo)] mk_fld_env names flds = [ (DataConName con, ConInfo (ConIsData (map fst names)) fld_info) - | (con, mb_fl_indxs) <- names - , let fld_info = case fmap (map ((flds IntMap.!) . unLoc)) mb_fl_indxs of - Nothing -> ConHasPositionalArgs - Just [] -> ConIsNullary - Just (fld:flds) -> ConHasRecordFields $ fld NE.:| flds ] + | (con, con_fl_indxs) <- names + , let fld_info = case fmap (map ((flds IntMap.!) . unLoc)) con_fl_indxs of + Left 0 -> ConIsNullary + Left arity -> ConHasPositionalArgs arity + Right [] -> ConIsNullary + Right (fld:flds) -> ConHasRecordFields $ fld NE.:| flds ] new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs -> RnM [GlobalRdrElt] @@ -939,10 +940,10 @@ getLocalNonValBinders fixity_env -- Add errors if a constructor has a duplicate record field. add_dup_fld_errs :: IntMap FieldLabel - -> (Name, Maybe [Located Int]) + -> (Name, Either VisArity [Located Int]) -> IOEnv (Env TcGblEnv TcLclEnv) () - add_dup_fld_errs all_flds (con, mb_con_flds) - | Just con_flds <- mb_con_flds + add_dup_fld_errs all_flds (con, con_flds_or_arity) + | Right con_flds <- con_flds_or_arity , let (_, dups) = removeDups (comparing unLoc) con_flds = for_ dups $ \ dup_flds -> -- Report the error at the location of the second occurrence ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -874,7 +874,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; checkErr dd_flag (needFlagDotDot ctxt) ; (rdr_env, lcl_env) <- getRdrEnvs ; conInfo <- lookupConstructorInfo qcon - ; when (conFieldInfo conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con)) + + ; case conFieldInfo conInfo of + ConHasPositionalArgs nbArgs -> + addErr $ TcRnIllegalWildcardsInConstructor (toRecordFieldPart ctxt) con nbArgs + _ -> return () ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldRdrs flds) -- For constructor uses (but not patterns) ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -357,12 +357,12 @@ instance Diagnostic TcRnMessage where -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat] TcRnCharLiteralOutOfRange c -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\'' - TcRnIllegalWildcardsInConstructor con + TcRnIllegalWildcardsInConstructor ctx con _ -> mkSimpleDecorated $ - vcat [ text "Illegal `{..}' notation for constructor" <+> quotes (ppr con) - , nest 2 (text "Record wildcards may not be used for constructors with unlabelled fields.") - , nest 2 (text "Possible fix: Remove the `{..}' and add a match for each field of the constructor.") - ] + text "The data constructor" <+> quotes (ppr con) + <+> text "does not have named record fields, so the record" + <+> pprRecordFieldPart ctx + <+> quotes (ppr con <> text "{..}") <+> text "is invalid." TcRnIgnoringAnnotations anns -> mkSimpleDecorated $ text "Ignoring ANN annotation" <> plural anns <> comma @@ -2791,8 +2791,12 @@ instance Diagnostic TcRnMessage where -> [suggestExtension LangExt.ViewPatterns] TcRnCharLiteralOutOfRange{} -> noHints - TcRnIllegalWildcardsInConstructor{} - -> noHints + TcRnIllegalWildcardsInConstructor ctx con arity + -> case ctx of + RecordFieldPattern{} -> [ SuggestEmptyRecordBraces con + , SuggestExplicitConstructorArguments con arity + ] + _ -> [SuggestExplicitConstructorArguments con arity] TcRnIgnoringAnnotations{} -> noHints TcRnAnnotationInSafeHaskell ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -817,17 +817,34 @@ data TcRnMessage where TcRnNegativeNumTypeLiteral :: IntegralLit GhcRn -> TcRnMessage {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever - the record wildcards '..' are used inside a constructor without labeled fields. + the record wildcards '..' are used with a constructor whose fields are + positional (unlabelled). The 'RecordFieldPart' field records whether + the wildcards occurred in a record construction (an expression) or in + a record pattern, so that the message and its suggested fixes can be + worded accordingly. Constructors with no fields at all do not trigger + this error: since GHC proposal 496 ("Nullary record wildcards"), + @C {..}@ is legal for nullary constructors. + The 'VisArity' field records the constructor's number of positional arguments + which the suggested fix mentions. - Examples(s): None + Example(s): + + data D = D Int Bool + + f :: D -> () + f D{..} = () -- record pattern + + g :: D + g = D{..} -- record construction Test cases: rename/should_fail/T9815.hs rename/should_fail/T9815b.hs rename/should_fail/T9815ghci.hs rename/should_fail/T9815bghci.hs + rename/should_fail/T21101.hs -} - TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage + TcRnIllegalWildcardsInConstructor :: !RecordFieldPart -> !Name -> !VisArity -> TcRnMessage {-| TcRnIgnoringAnnotations is a warning that occurs when the source code contains annotation pragmas but the platform in use does not support an ===================================== compiler/GHC/Types/GREInfo.hs ===================================== @@ -244,14 +244,14 @@ instance NFData ConLikeInfo where -- See Note [Local constructor info in the renamer] data ConFieldInfo = ConHasRecordFields (NonEmpty FieldLabel) - | ConHasPositionalArgs + | ConHasPositionalArgs !VisArity | ConIsNullary deriving stock Eq deriving Data instance NFData ConFieldInfo where rnf ConIsNullary = () - rnf ConHasPositionalArgs = () + rnf (ConHasPositionalArgs arity) = rnf arity rnf (ConHasRecordFields flds) = rnf flds mkConInfo :: ConLikeInfo -> VisArity -> [FieldLabel] -> ConInfo @@ -259,9 +259,9 @@ mkConInfo con_ty n flds = ConInfo { conLikeInfo = con_ty , conFieldInfo = mkConFieldInfo n flds } -mkConFieldInfo :: Arity -> [FieldLabel] -> ConFieldInfo +mkConFieldInfo :: VisArity -> [FieldLabel] -> ConFieldInfo mkConFieldInfo 0 _ = ConIsNullary -mkConFieldInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields +mkConFieldInfo arity fields = maybe (ConHasPositionalArgs arity) ConHasRecordFields $ NonEmpty.nonEmpty fields conInfoFields :: ConInfo -> [FieldLabel] @@ -269,7 +269,7 @@ conInfoFields = conFieldInfoFields . conFieldInfo conFieldInfoFields :: ConFieldInfo -> [FieldLabel] conFieldInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields -conFieldInfoFields ConHasPositionalArgs = [] +conFieldInfoFields (ConHasPositionalArgs _) = [] conFieldInfoFields ConIsNullary = [] instance Outputable ConInfo where @@ -284,7 +284,7 @@ instance Outputable ConLikeInfo where instance Outputable ConFieldInfo where ppr ConIsNullary = text "ConIsNullary" - ppr ConHasPositionalArgs = text "ConHasPositionalArgs" + ppr (ConHasPositionalArgs arity) = text "ConHasPositionalArgs" <+> braces (ppr arity) ppr (ConHasRecordFields fieldLabels) = text "ConHasRecordFields" <+> braces (ppr fieldLabels) ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Types.InlinePragma (ActivationGhc) import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName) import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec, GlobalRdrElt) import GHC.Types.SrcLoc (SrcSpan) -import GHC.Types.Basic (RuleName) +import GHC.Types.Basic (RuleName, VisArity) import GHC.Parser.Errors.Basic import GHC.Utils.Outputable import GHC.Data.FastString (fsLit) @@ -548,6 +548,23 @@ data GhcHint | SuggestUpgradeForSemaphoreVersionMismatch !SemaphoreUpgradeTarget !Int -- ^ The 'Int' is the required protocol version. + {-| Suggest replacing a record wildcard pattern @C {..}@ with @C {}@, + which matches a constructor without binding its fields. + + Triggered by 'GHC.Tc.Errors.Types.TcRnIllegalWildcardsInConstructor' + in a record pattern. + -} + | SuggestEmptyRecordBraces !Name + + {-| Suggest applying a constructor directly to its arguments instead + of record syntax, for constructors without labelled fields. + + Triggered by 'GHC.Tc.Errors.Types.TcRnIllegalWildcardsInConstructor' + in a record construction and record patterns. + The 'VisArity' is the number of positional arguments of the constructor. + -} + | SuggestExplicitConstructorArguments !Name !VisArity + -- | What the user should upgrade to resolve an @-jsem@ semaphore -- protocol version mismatch. data SemaphoreUpgradeTarget ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -345,6 +345,12 @@ instance Outputable GhcHint where text "The jobserver uses a newer semaphore protocol than this GHC." $$ (text "Upgrade GHC to a version that supports semaphore protocol v" <> int required <> text " to resolve this.") + SuggestEmptyRecordBraces con + -> text "Use" <+> quotes (ppr con <> text "{}") <+> text "instead," + <+> text "which matches" <+> quotes (ppr con) <+> text "regardless of its fields" + SuggestExplicitConstructorArguments con nbArgs + -> text "Apply" <+> quotes (ppr con) <+> text "to its" + <+> speakNOf nbArgs (text "argument") <+> text "instead" perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" ===================================== libraries/base/changelog.md ===================================== @@ -33,6 +33,7 @@ * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) * Add a new module `System.IO.OS` with operations for obtaining operating-system handles (file descriptors, Windows handles). ([CLC proposal #369](https://github.com/haskell/core-libraries-committee/issues/369)) * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) + * Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` ([GHC #27456](https://gitlab.haskell.org/ghc/ghc/-/issues/27456)) * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) ===================================== libraries/base/tests/T15349.stderr ===================================== @@ -1,9 +1,11 @@ -T15349: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.NonTermination: +T15349.exe: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.NonTermination: <<loop>> -While handling thread blocked indefinitely in an MVar operation +While handling ghc-internal:GHC.Internal.IO.Exception.BlockedIndefinitelyOnMVar: + | + | thread blocked indefinitely in an MVar operation HasCallStack backtrace: - throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Imp.hs:58:37 in ghc-internal:GHC.Internal.Control.Monad.ST.Imp + throwIO, called at libraries\ghc-internal\src\GHC\Internal\Control\Monad\ST\Imp.hs:59:37 in ghc-internal:GHC.Internal.Control.Monad.ST.Imp ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs ===================================== @@ -84,7 +84,7 @@ data WhileHandling = WhileHandling SomeException deriving Show instance ExceptionAnnotation WhileHandling where displayExceptionAnnotation (WhileHandling e) = - "While handling " ++ case lines $ displayException e of + "While handling " ++ case lines $ displayExceptionWithInfo e of [] -> "" (l1:ls) -> -- Indent lines forward. ===================================== libraries/ghc-internal/tests/backtraces/T14532b.stdout ===================================== @@ -2,7 +2,14 @@ ghc-internal:GHC.Internal.Exception.ErrorCall: Error in Exception Handler -While handling Main Error +While handling ghc-internal:GHC.Internal.Exception.ErrorCall: + | + | Main Error + | + | My custom Backtraces: + | HasCallStack backtrace: + | throwIO, called at T14532b.hs:32:6 in main:Main + | My custom Backtraces: HasCallStack backtrace: @@ -13,7 +20,14 @@ ghc-internal:GHC.Internal.Exception.ErrorCall: Error in Exception Handler -While handling Main Error +While handling ghc-internal:GHC.Internal.Exception.ErrorCall: + | + | Main Error + | + | My custom Backtraces: + | HasCallStack backtrace: + | error, called at T14532b.hs:41:6 in main:Main + | My custom Backtraces: HasCallStack backtrace: ===================================== testsuite/tests/codeGen/should_run/cgrun025.stderr ===================================== @@ -1,4 +1,4 @@ -"cgrun025" +"cgrun025.exe" ["cgrun025.hs"] GOT PATH {-# LANGUAGE ScopedTypeVariables #-} @@ -27,11 +27,16 @@ main = do trace "hello, trace" $ catch (getEnv "__WURBLE__" >> return ()) (\ (e :: SomeException) -> error "hello, error") hello, trace -cgrun025: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: +cgrun025.exe: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: hello, error -While handling __WURBLE__: getEnv: does not exist (no environment variable) +While handling ghc-internal:GHC.Internal.IO.Exception.IOException: + | + | __WURBLE__: getEnv: does not exist (no environment variable) + | + | HasCallStack backtrace: + | ioException, called at libraries\ghc-internal\src\GHC\Internal\System\Environment.hs:204:26 in ghc-internal:GHC.Internal.System.Environment HasCallStack backtrace: error, called at cgrun025.hs:25:75 in main:Main ===================================== testsuite/tests/exceptions/T26759.stderr ===================================== @@ -1,8 +1,13 @@ -T26759: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: +T26759.exe: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure -While handling outer failure +While handling ghc-internal:GHC.Internal.Exception.ErrorCall: + | + | outer failure + | + | HasCallStack backtrace: + | throwIO, called at T26759.hs:6:21 in main:Main HasCallStack backtrace: throwIO, called at T26759.hs:7:22 in main:Main ===================================== testsuite/tests/ghc-e/should_fail/T18441fail7.stderr ===================================== @@ -1,10 +1,12 @@ -<interactive>: Uncaught exception ghc-9.13-inplace:GHC.Utils.Panic.GhcException: +<interactive>: Uncaught exception ghc-10.1-inplace:GHC.Utils.Panic.GhcException: IO error: "Abcde" does not exist -While handling IO error: "Abcde" does not exist +While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException: + | + | IO error: "Abcde" does not exist HasCallStack backtrace: - throwIO, called at compiler/GHC/Utils/Error.hs:512:19 in ghc-9.13-inplace:GHC.Utils.Error + throwIO, called at compiler\GHC\Utils\Error.hs:499:19 in ghc-10.1-inplace:GHC.Utils.Error 1 ===================================== testsuite/tests/mdo/should_fail/mdofail006.stderr ===================================== @@ -1,9 +1,11 @@ -mdofail006: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.FixIOException: +mdofail006.exe: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.FixIOException: cyclic evaluation in fixIO -While handling thread blocked indefinitely in an MVar operation +While handling ghc-internal:GHC.Internal.IO.Exception.BlockedIndefinitelyOnMVar: + | + | thread blocked indefinitely in an MVar operation HasCallStack backtrace: - throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs:167:37 in ghc-internal:GHC.Internal.Control.Monad.Fix + throwIO, called at libraries\ghc-internal\src\GHC\Internal\Control\Monad\Fix.hs:169:37 in ghc-internal:GHC.Internal.Control.Monad.Fix ===================================== testsuite/tests/pmcheck/should_compile/T27360.hs ===================================== @@ -0,0 +1,11 @@ +module T27360 where + +import GHC.Exts + +f :: () +f | False, considerAccessible = () + | otherwise = () + +g :: () +g | False, True <- considerAccessible = () + | otherwise = () ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -182,3 +182,4 @@ test('T24845', [], compile, [overlapping_incomplete]) test('T22652', [], compile, [overlapping_incomplete]) test('T22652a', [], compile, [overlapping_incomplete]) test('T24867', [], compile_fail, [overlapping_incomplete]) +test('T27360', normal, compile, [overlapping_incomplete + '-g3']) ===================================== testsuite/tests/rename/should_fail/T21101.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} +module T21101 where + +data D = D Int Bool + +f :: D -> () +f D{..} = () ===================================== testsuite/tests/rename/should_fail/T21101.stderr ===================================== @@ -0,0 +1,6 @@ +T21101.hs:7:3: error: [GHC-47217] + The data constructor ‘D’ does not have named record fields, so the record pattern ‘D{..}’ is invalid. + Suggested fixes: + • Use ‘D{}’ instead, which matches ‘D’ regardless of its fields + • Apply ‘D’ to its two arguments instead + ===================================== testsuite/tests/rename/should_fail/T9815.stderr ===================================== @@ -1,5 +1,4 @@ - T9815.hs:6:13: error: [GHC-47217] - Illegal `{..}' notation for constructor ‘N’ - Record wildcards may not be used for constructors with unlabelled fields. - Possible fix: Remove the `{..}' and add a match for each field of the constructor. + The data constructor ‘N’ does not have named record fields, so the record construction ‘N{..}’ is invalid. + Suggested fix: Apply ‘N’ to its one argument instead + ===================================== testsuite/tests/rename/should_fail/T9815b.stderr ===================================== @@ -1,5 +1,4 @@ - T9815.hs:6:13: error: [GHC-47217] - Illegal `{..}' notation for constructor ‘N’ - Record wildcards may not be used for constructors with unlabelled fields. - Possible fix: Remove the `{..}' and add a match for each field of the constructor. + The data constructor ‘N’ does not have named record fields, so the record construction ‘N{..}’ is invalid. + Suggested fix: Apply ‘N’ to its one argument instead + ===================================== testsuite/tests/rename/should_fail/T9815bghci.stderr ===================================== @@ -1,5 +1,4 @@ +<interactive>:5:7: error: [GHC-47217] + The data constructor ‘Arg’ does not have named record fields, so the record construction ‘Arg{..}’ is invalid. + Suggested fix: Apply ‘Arg’ to its two arguments instead -<interactive>:5:7: [GHC-47217] - Illegal `{..}' notation for constructor ‘Arg’ - Record wildcards may not be used for constructors with unlabelled fields. - Possible fix: Remove the `{..}' and add a match for each field of the constructor. ===================================== testsuite/tests/rename/should_fail/T9815ghci.stderr ===================================== @@ -1,5 +1,5 @@ +<interactive>:3:7: error: [GHC-47217] + The data constructor ‘Data.Semigroup.Arg’ does not have named record fields, so the record construction ‘Data.Semigroup.Arg{..}’ is invalid. + Suggested fix: + Apply ‘Data.Semigroup.Arg’ to its two arguments instead -<interactive>:3:7: [GHC-47217] - Illegal `{..}' notation for constructor ‘Data.Semigroup.Arg’ - Record wildcards may not be used for constructors with unlabelled fields. - Possible fix: Remove the `{..}' and add a match for each field of the constructor. ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -186,6 +186,7 @@ test('T18138', normal, compile_fail, ['']) test('T20147', normal, compile_fail, ['']) test('RnEmptyStatementGroup1', normal, compile_fail, ['']) test('RnImplicitBindInMdoNotation', normal, compile_fail, ['']) +test('T21101', normal, compile_fail, ['']) test('T21605a', normal, compile_fail, ['']) test('T21605b', normal, compile_fail, ['']) test('T21605c', normal, compile_fail, ['']) ===================================== testsuite/tests/runghc/T7859.stderr-mingw32 ===================================== @@ -2,7 +2,12 @@ runghc-9.13.20241015.exe: Uncaught exception ghc-internal:GHC.Internal.IO.Except defer-type-errors: rawSystem: does not exist (No such file or directory) -While handling rawSystem: does not exist (No such file or directory) +While handling ghc-internal:GHC.Internal.IO.Exception.IOException: + | + | rawSystem: does not exist (No such file or directory) + | + | HasCallStack backtrace: + | ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:<line>:<column> in <package-id>:GHC.Internal.Foreign.C.Error HasCallStack backtrace: ioError, called at libraries\process\System\Process\Common.hs:239:16 in process-1.6.25.0-inplace:System.Process.Common View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/18267348e1e10431508434a9ed2205… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/18267348e1e10431508434a9ed2205… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/ci-make-install-j] 3 commits: ci: fix abi-test job on non full-ci mr pipelines
by Cheng Shao (＠TerrorJack) 16 Jul '26

16 Jul '26

Cheng Shao pushed to branch wip/ci-make-install-j at Glasgow Haskell Compiler / GHC Commits: 1d0021cb by Cheng Shao at 2026-07-16T15:45:19+00:00 ci: fix abi-test job on non full-ci mr pipelines - - - - - b0ada958 by Cheng Shao at 2026-07-16T15:45:19+00:00 bindist: Fix make install -j race condition on macos/freebsd This patch fixes make install -j race condition on macos/freebsd. BSD install fails with EEXIST when multiple install processes concurrently create the same prefix directory. So we add an `install_dirs` prerequisite job that sequentially creates the directories for subsequent jobs to work with. Fixes #27499. Co-authored-by: Codex <codex(a)openai.com> - - - - - 06850ecf by Cheng Shao at 2026-07-16T15:45:19+00:00 ci: run bindist make install with -j This patch makes the ci scripts run `make install` with `-j` to reduce wall clock time when installing the bindist, see related issue for benchmark numbers. This only affects ghc ci logic, the user-facing default is up to distributors and is still `-j1`. Closes #27029. - - - - - 4 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - + changelog.d/fix-make-install-j - hadrian/bindist/Makefile Changes: ===================================== .gitlab-ci.yml ===================================== @@ -499,7 +499,7 @@ hadrian-multi: || tar -xf ghc-x86_64-linux-deb13-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root - make install + make install -j$CPUS popd rm -Rf tmp - export HC=$root/bin/ghc @@ -1005,7 +1005,7 @@ perf-nofib: tar -xf ../ghc-x86_64-linux-fedora43-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root - make install + make install -j$CPUS popd rm -Rf tmp - export PATH=$root/bin:$PATH @@ -1047,7 +1047,7 @@ perf: || tar -xf ghc-x86_64-linux-deb13-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root - make install + make install -j$CPUS popd rm -Rf tmp - export BOOT_HC=$(which ghc) @@ -1068,7 +1068,7 @@ perf: abi-test: stage: testing needs: - - job: x86_64-linux-deb13-validate + - job: x86_64-linux-deb13-numa-slow-validate optional: true - job: nightly-x86_64-linux-deb13-validate optional: true @@ -1083,11 +1083,12 @@ abi-test: - root=$(pwd)/ghc - | mkdir tmp - tar -xf ghc-x86_64-linux-deb13-validate.tar.xz -C tmp \ + tar -xf ghc-x86_64-linux-deb13-numa-slow-validate.tar.xz -C tmp \ + || tar -xf ghc-x86_64-linux-deb13-validate.tar.xz -C tmp \ || tar -xf ghc-x86_64-linux-deb13-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root - make install + make install -j$CPUS popd rm -Rf tmp - export BOOT_HC=$(which ghc) ===================================== .gitlab/ci.sh ===================================== @@ -605,7 +605,7 @@ function make_install_destdir() { mkdir -p "$destdir" mkdir -p "$instdir" - run "$MAKE" DESTDIR="$destdir" install || fail "make install failed" + run "$MAKE" DESTDIR="$destdir" install -j"$cores" || fail "make install failed" # check for empty dir portably # https://superuser.com/a/667100 if find "$instdir" -mindepth 1 -maxdepth 1 | read; then @@ -899,8 +899,8 @@ function save_cache () { if [[ "${CI_JOB_NAME}" == *"darwin"* ]]; then # -a makes APFS behave like a COW file system # From man CP(1) - # copy files using clonefile(2). - # Note that if clonefile(2) is not supported for the target filesystem, + # copy files using clonefile(2). + # Note that if clonefile(2) is not supported for the target filesystem, # then cp will fallback to using copyfile(2) instead to ensure the copy still succeeds. cp -Rcf "$CABAL_DIR" "$CABAL_CACHE" else ===================================== changelog.d/fix-make-install-j ===================================== @@ -0,0 +1,4 @@ +section: packaging +synopsis: Fix race condition in bindist make install -j on macos/freebsd +issues: #27499 +mrs: !15707 ===================================== hadrian/bindist/Makefile ===================================== @@ -97,12 +97,26 @@ lib/targets/default.target : config.mk default.target @echo "Copying the bindist-configured default.target to lib/targets/default.target" cp default.target $@ +# sequentially create one layer of subdirectories under DESTDIR, then +# subsequent install_* jobs can happen concurrently without bsd +# install race condition. required for make install -j to work on +# macos/freebsd, see #27499. +.PHONY: install_dirs +install_dirs: + $(INSTALL_DIR) "$(DESTDIR)$(prefix)" + $(INSTALL_DIR) "$(DESTDIR)$(ActualBinsDir)" + $(INSTALL_DIR) "$(DESTDIR)$(WrapperBinsDir)" + $(INSTALL_DIR) "$(DESTDIR)$(ActualLibsDir)" + $(INSTALL_DIR) "$(DESTDIR)$(mandir)" + $(INSTALL_DIR) "$(DESTDIR)$(docdir)" + $(INSTALL_DIR) "$(DESTDIR)$(datadir)" + # We need to install binaries relative to libraries. BINARIES = $(wildcard ./bin/*) .PHONY: install_bin_libdir -install_bin_libdir: +install_bin_libdir: install_dirs @echo "Copying binaries to $(DESTDIR)$(ActualBinsDir)" - $(INSTALL_DIR) "$(DESTDIR)$(ActualBinsDir)" + for i in $(BINARIES); do \ if test -L "$$i"; then \ cp -RP "$$i" "$(DESTDIR)$(ActualBinsDir)"; \ @@ -112,15 +126,14 @@ install_bin_libdir: done .PHONY: install_bin_direct -install_bin_direct: +install_bin_direct: install_dirs @echo "Copying binaries to $(DESTDIR)$(WrapperBinsDir)" - $(INSTALL_DIR) "$(DESTDIR)$(WrapperBinsDir)" + $(INSTALL_PROGRAM) ./bin/* "$(DESTDIR)$(WrapperBinsDir)/" .PHONY: install_lib -install_lib: lib/settings lib/targets/default.target +install_lib: install_dirs lib/settings lib/targets/default.target @echo "Copying libraries to $(DESTDIR)$(ActualLibsDir)" - $(INSTALL_DIR) "$(DESTDIR)$(ActualLibsDir)" @dest="$(DESTDIR)$(ActualLibsDir)"; \ cd ./lib; \ @@ -146,9 +159,8 @@ install_lib: lib/settings lib/targets/default.target done; \ .PHONY: install_docs -install_docs: +install_docs: install_dirs @echo "Copying docs to $(DESTDIR)$(docdir)" - $(INSTALL_DIR) "$(DESTDIR)$(docdir)" if [ -d doc ]; then \ cd ./doc; $(FIND) . -type f -exec sh -c \ @@ -163,9 +175,9 @@ install_docs: fi .PHONY: install_data -install_data: +install_data: install_dirs @echo "Copying data to $(DESTDIR)share" - $(INSTALL_DIR) "$(DESTDIR)$(datadir)" + if [ -d share ]; then \ cd ./share; $(FIND) . -type f -exec sh -c \ '$(INSTALL_DIR) "$(DESTDIR)$(datadir)/`dirname $$1`" && \ @@ -177,18 +189,17 @@ MAN_SECTION := 1 MAN_PAGES := manpage/ghc.1 .PHONY: install_man -install_man: +install_man: install_dirs if [ -f $(MAN_PAGES) ]; then \ - $(INSTALL_DIR) "$(DESTDIR)$(mandir)"; \ $(INSTALL_DIR) "$(DESTDIR)$(mandir)/man$(MAN_SECTION)"; \ $(INSTALL_MAN) $(INSTALL_OPTS) $(MAN_PAGES) "$(DESTDIR)$(mandir)/man$(MAN_SECTION)"; \ fi export SHELL .PHONY: install_wrappers -install_wrappers: install_bin_libdir install_hsc2hs_wrapper +install_wrappers: install_dirs install_bin_libdir install_hsc2hs_wrapper @echo "Installing wrapper scripts" - $(INSTALL_DIR) "$(DESTDIR)$(WrapperBinsDir)" + for p in `cd ./wrappers; $(FIND) . ! -type d`; do \ mk/install_script.sh "$$p" "$(DESTDIR)/$(WrapperBinsDir)/$$p" "$(WrapperBinsDir)" "$(ActualBinsDir)" "$(ActualBinsDir)/$$p" "$(ActualLibsDir)" "$(docdir)" "$(includedir)"; \ done View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57ecdb75e2e110634c8a716dd1d986… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57ecdb75e2e110634c8a716dd1d986… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/ci-make-install-j] 14 commits: hadrian: fix HLS support
by Cheng Shao (＠TerrorJack) 16 Jul '26

16 Jul '26

Cheng Shao pushed to branch wip/ci-make-install-j at Glasgow Haskell Compiler / GHC Commits: ed261a7e by Cheng Shao at 2026-07-14T17:59:38-04:00 hadrian: fix HLS support This patch fixes hadrian's HLS support so one can rely on HLS when working on the hadrian codebase. Fixes #27480. Not building/linking shared libraries for hadrian is a severely premature optimization; this top-level setting in `cabal.project` only affects home packages while the dependencies in the cabal store are built with vanilla/dynamic anyway, and even adding dynamic builds to home packages would not be costly due to cabal's usage of `-dynamic-too`. - - - - - eee8ec5b by Cheng Shao at 2026-07-14T18:00:20-04:00 compiler: fix miscompiled %load_relaxed, add missing %store_relaxed This patch fixes the %load_relaxed cmm primop compilation logic to correctly use relaxed memory ordering, and adds the missing %store_relaxed primop. Parsing logic of %load/%store with explicit ordering is covered in the AtomicFetch test case. Fixes #27483. Co-authored-by: Codex <codex(a)openai.com> - - - - - 1718230f by Alan Zimmerman at 2026-07-14T18:01:06-04:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - 6bd1ad2a by Andreas Klebinger at 2026-07-14T18:01:49-04:00 Bump nofib submodule to account for MonoLocalBinds. New versions of GHC enable MonoLocalBinds by default. This breaks some of the benchmarks. I've fixed this and this bump pulls in that fix. - - - - - 7eb0f1c9 by Cheng Shao at 2026-07-14T18:02:31-04:00 testsuite: fix bytecodeIPE test under +ipe flavours This patch fixes the bytecodeIPE test under +ipe flavours. It used to fail under +ipe because the RTS is built with IPE info, then stg_AP_info in RTS carries IPE info, so whereFrom wouldn't return Nothing. Now the test checks IPE info of a datacon in the ghci-loaded module which is not affected by whether the RTS is built with IPE info or not. Fixes #27498. Co-authored-by: Codex <codex(a)openai.com> - - - - - ef038aae by cydparser at 2026-07-15T04:35:41-04:00 Reduce bytes allocated for `capabilities` in RTS (fixes #27487) In rts/Capability.c, `capabilities` is an array of pointers, but it was allocated as if it were an array of Capability's. - - - - - d377e83e by Cheng Shao at 2026-07-15T04:36:27-04:00 rts: fix missing UNTAG in stg_readTVarIOzh This patch fixes missing UNTAG on the current value closure read from StgTVar. UNTAG is a no-op when it's stg_TREC_HEADER_info which is word aligned; it may be a tagged closure, and reading info table from the tagged address is an unaligned load which may cause issues on platforms with strict alignment requirements. Co-authored-by: Codex <codex(a)openai.com> - - - - - 8ed03842 by Cheng Shao at 2026-07-15T04:36:27-04:00 rts: fix missing UNTAG in stg_control0zh_ll This patch fixes missing UNTAG on the cont closure returned by captureContinuationAndAbort. In case it's not NULL, captureContinuationAndAbort returns a tagged StgContinuation closure, in which case it must be untagged before accessing the apply_mask_frame field. In the past it worked out of luck: when apply_mask_frame was NULL then mask_frame_offset is also 0 so the control flow didn't diverge to a wrong path. Still, this is horribly wrong and will crash once StgContinuation struct is refactored and fields are shuffled around. Co-authored-by: Codex <codex(a)openai.com> - - - - - 5aa7000a by Cheng Shao at 2026-07-15T04:37:08-04:00 compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk This patch fixes a double negation confusion in !7525 that results in some redundant AP thunk code generation when not using -ticky-ap-thunk. Now, we use `stgToCmmUseStdApThunk` to indicate whether precomputed AP thunks in the RTS should be used, which defaults to `True`, unless `-ticky-ap-thunk` is passed. `-finfo-table-map` now also implies `-ticky-ap-thunk`, since when doing IPE profiling we want the generated AP thunks to be unique. Fixes #27502. ------------------------- Metric Decrease: T3064 ------------------------- Co-authored-by: Codex <codex(a)openai.com> - - - - - d43a7b7a by Brian McKenna at 2026-07-15T20:10:04+02:00 Strip ticks when desugaring bool guards The special `considerAccessible` pattern was broken when compiling with debug info. Compiling with debug info wraps expressions with `SourceNote` ticks, which broke the internals of the `desugarBoolGuard` function. Ticks are now ignored within this function. Fixes #27360 - - - - - ede4b17b by Ben Gamari at 2026-07-15T22:59:53-04:00 base: Display ExceptionContext in WhileHandling's textual description As originally-implemented the implementation for `WhileHandling(displayExceptionAnnotation)` would display the `ExceptionContext` of the exception which it carries (as this was the behavior of `displayException`, in terms of which `displayExceptionAnnotation` was implemented). However, in 284ffab3 the definition of `SomeException(displayException)` was changed to exclude the `ExceptionContext`. This means that `WhileHandling(displayExceptionAnnotation)` fails to describe the provenance of the exception which it captures, greatly limiting its utility. Return the implementation to its originally-specified behavior by implementing `WhileHandling(displayExceptionAnnotation)` in terms of `displayExceptionWithInfo`. Fixes #27456. - - - - - 0f64f348 by Cheng Shao at 2026-07-16T15:41:08+00:00 ci: add missing docker permission workaround in abi-test job - - - - - b75cae58 by Cheng Shao at 2026-07-16T15:41:08+00:00 bindist: Fix make install -j race condition on macos/freebsd This patch fixes make install -j race condition on macos/freebsd. BSD install fails with EEXIST when multiple install processes concurrently create the same prefix directory. So we add an `install_dirs` prerequisite job that sequentially creates the directories for subsequent jobs to work with. Fixes #27499. Co-authored-by: Codex <codex(a)openai.com> - - - - - 57ecdb75 by Cheng Shao at 2026-07-16T15:41:08+00:00 ci: run bindist make install with -j This patch makes the ci scripts run `make install` with `-j` to reduce wall clock time when installing the bindist, see related issue for benchmark numbers. This only affects ghc ci logic, the user-facing default is up to distributors and is still `-j1`. Closes #27029. - - - - - 58 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - + changelog.d/T27360 - + changelog.d/T27456 - + changelog.d/fix-cmm-atomic-load-store - + changelog.d/fix-make-install-j - + changelog.d/fix-use-std-ap-thunk - compiler/GHC/Cmm/Parser.y - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Extension.hs - ghc/GHCi/UI.hs - hadrian/bindist/Makefile - hadrian/cabal.project - libraries/base/changelog.md - libraries/base/tests/T15349.stderr - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/tests/backtraces/T14532b.stdout - nofib - rts/Capability.c - rts/ContinuationOps.cmm - rts/PrimOps.cmm - testsuite/tests/cmm/should_run/AtomicFetch.hs - testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm - testsuite/tests/codeGen/should_run/cgrun025.stderr - testsuite/tests/exceptions/T26759.stderr - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghci/scripts/bytecodeIPE.hs - testsuite/tests/mdo/should_fail/mdofail006.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - + testsuite/tests/pmcheck/should_compile/T27360.hs - testsuite/tests/pmcheck/should_compile/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/runghc/T7859.stderr-mingw32 - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2fa76a949222366b6cf1b6ba2b2408… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2fa76a949222366b6cf1b6ba2b2408… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/external-unit-db-cache] 4 commits: WIP: Introduce UnitIndex for global data
by Hannes Siebenhandl (＠fendor) 16 Jul '26

16 Jul '26

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: 4b665ceb by fendor at 2026-07-16T16:57:25+02:00 WIP: Introduce UnitIndex for global data ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp MultiComponentModulesRecomp100 mhu-perf ------------------------- - - - - - cf0b6ff9 by fendor at 2026-07-16T16:57:34+02:00 Add ChangeLog - - - - - efdd7150 by fendor at 2026-07-16T16:59:34+02:00 Split State.hs into many more modules - - - - - 353ebdf5 by fendor at 2026-07-16T16:59:34+02:00 Add regression test for #26423 - - - - - 33 changed files: - + changelog.d/unit-index - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/External/Database.hs - + compiler/GHC/Unit/External/Index.hs - + compiler/GHC/Unit/External/ModuleOrigin.hs - + compiler/GHC/Unit/External/Providers.hs - + compiler/GHC/Unit/External/Query.hs - + compiler/GHC/Unit/External/Substitution.hs - + compiler/GHC/Unit/External/Validate.hs - + compiler/GHC/Unit/External/Visibility.hs - + compiler/GHC/Unit/External/Wired.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/State.hs-boot - compiler/GHC/Unit/Types.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - libraries/ghc-boot/GHC/Unit/Database.hs - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/driver/T26423/Hello.hs - + testsuite/tests/driver/T26423/Makefile - + testsuite/tests/driver/T26423/T26423.hs - + testsuite/tests/driver/T26423/T26423.stderr - + testsuite/tests/driver/T26423/T26423.stdout - + testsuite/tests/driver/T26423/all.T - + testsuite/tests/driver/T26423/test/Test.hs - + testsuite/tests/driver/T26423/test/test.pkg - utils/haddock/haddock-api/src/Haddock.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cead91298f53b22cc02e108c4bf947… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cead91298f53b22cc02e108c4bf947… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] Major patch to re-engineer known-key names
by Rodrigo Mesquita (＠alt-romes) 16 Jul '26

16 Jul '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 2ab10b3b by Simon Peyton Jones at 2026-07-16T15:36:14+01:00 Major patch to re-engineer known-key names This big patch implements the New Plan for known-key names, described in #27013. Read the big Note [Overview of known-key names] in GHC.Types.Name Some things had to be reworked slightly to accomodate the new known-keys design. A significant one was the generation of auxiliary KindRep bindings, which was greatly simplified. Note [Grand plan for Typeable] was updated accordingly. Another example: GHC.Internal.CString was merged into GHC.Internal.Types. Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> The couple hundreds of hours spent here by Rodrigo were sponsored by Well-Typed Metrics: compile_time/bytes allocated ------------------------------------- Baseline Test Metric value New value Change ------------------------------------------------------------------------------------------ MultiComponentModules100(normal) ghc/alloc 24,312,779,672 24,990,470,432 +2.8% BAD MultiComponentModulesRecomp(normal) ghc/alloc 601,924,960 621,884,888 +3.3% BAD MultiComponentModulesRecomp100(normal) ghc/alloc 11,884,065,432 12,531,373,704 +5.4% BAD MultiLayerModules(normal) ghc/alloc 3,861,537,072 3,706,919,512 -4.0% GOOD T13701(normal) ghc/alloc 3,517,246,392 3,237,179,616 -8.0% GOOD T13820(normal) ghc/alloc 28,961,056 29,663,208 +2.4% BAD T14697(normal) ghc/alloc 472,044,184 443,550,048 -6.0% GOOD T18140(normal) ghc/alloc 47,905,664 49,115,808 +2.5% BAD T4801(normal) ghc/alloc 269,339,096 263,432,040 -2.2% GOOD T783(normal) ghc/alloc 341,112,672 333,339,952 -2.3% GOOD hard_hole_fits(normal) ghc/alloc 222,164,728 213,433,808 -3.9% GOOD mhu-perf(normal) ghc/alloc 49,011,440 46,706,280 -4.7% GOOD geo. mean +0.1% minimum -8.0% maximum +5.4% All performance regressions were investigated in depth. The surviving ones: - MultiComponentModules100, MultiComponentModulesRecomp100, MultiComponentModulesRecomp regresses because existing bugs that make an additional implicit edge do too much redundant work: #27053 and #27461 - T13820, T18140, T10547, T13035 regress because we load an additional interface and associated Names for GHC.Essentials. ------------------------- Metric Decrease: MultiLayerModules T13701 T14697 T26989 T4801 T783 hard_hole_fits mhu-perf size_hello_obj Metric Increase: LinkableUsage01 MultiComponentModules100 MultiComponentModulesRecomp MultiComponentModulesRecomp100 T10547 T13035 T13820 T18140 T20049 ------------------------- Bumps submodule binary Closes #27013 - - - - - 739 changed files: - + changelog.d/refactor-known-names - compiler/GHC.hs - + compiler/GHC/Builtin.hs - + compiler/GHC/Builtin/KnownKeys.hs - + compiler/GHC/Builtin/KnownOccs.hs - + compiler/GHC/Builtin/Modules.hs - − compiler/GHC/Builtin/Names.hs - − compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Casts.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - + compiler/GHC/Builtin/TH.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - − compiler/GHC/Builtin/Utils.hs - + compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Builtin/Types/Prim.hs → compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Builtin/Types/Literals.hs → compiler/GHC/Builtin/WiredIn/TypeLits.hs - compiler/GHC/Builtin/Types.hs → compiler/GHC/Builtin/WiredIn/Types.hs - compiler/GHC/Builtin/Types.hs-boot → compiler/GHC/Builtin/WiredIn/Types.hs-boot - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/LiberateCase.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/KnotVars.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Check.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Ppr.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Env.hs - − compiler/GHC/Iface/Env.hs-boot - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Plugins.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Foreign.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/RepType.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Unit.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - − compiler/GHC/Utils/Binary/Typeable.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/ghc.cabal.in - docs/users_guide/separate_compilation.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - libraries/base/base.cabal.in - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Concurrent.hs - libraries/base/src/Control/Concurrent/Chan.hs - libraries/base/src/Control/Concurrent/QSem.hs - libraries/base/src/Control/Concurrent/QSemN.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Bifoldable.hs - libraries/base/src/Data/Bifoldable1.hs - libraries/base/src/Data/Bifunctor.hs - libraries/base/src/Data/Bitraversable.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Complex.hs - libraries/base/src/Data/Data.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/Data/Foldable1.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/Data/Functor/Compose.hs - libraries/base/src/Data/Functor/Contravariant.hs - libraries/base/src/Data/Functor/Product.hs - libraries/base/src/Data/Functor/Sum.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/Data/Semigroup.hs - libraries/base/src/Data/Version.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/ByteOrder.hs - + libraries/base/src/GHC/Essentials.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Numeric.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/CPUTime/Posix/ClockGetTime.hsc - libraries/base/src/System/CPUTime/Posix/RUsage.hsc - libraries/base/src/System/CPUTime/Posix/Times.hsc - libraries/base/src/System/CPUTime/Unsupported.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO.hs - libraries/base/src/System/IO/OS.hs - libraries/base/src/System/IO/Unsafe.hs - libraries/base/src/System/Info.hs - libraries/base/src/System/Timeout.hs - libraries/base/src/Text/Printf.hs - libraries/base/src/Text/Read.hs - libraries/base/src/Text/Show/Functions.hs - libraries/binary - libraries/ghc-experimental/src/Data/Sum/Experimental.hs - libraries/ghc-experimental/src/Data/Tuple/Experimental.hs - libraries/ghc-experimental/src/GHC/Profiling/Eras.hs - libraries/ghc-experimental/src/Prelude/Experimental.hs - libraries/ghc-internal/codepages/MakeTable.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Arr.hs - libraries/ghc-internal/src/GHC/Internal/ArrayArray.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/GMP.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Primitives.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/WordArray.hs - libraries/ghc-internal/src/GHC/Internal/Bits.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghc-internal/src/GHC/Internal/Classes.hs - libraries/ghc-internal/src/GHC/Internal/Classes/IP.hs - libraries/ghc-internal/src/GHC/Internal/Clock.hsc - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX/Const.hsc - libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs - libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Category.hs - libraries/ghc-internal/src/GHC/Internal/Control/Concurrent/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/IO/Class.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Data/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Dynamic.hs - libraries/ghc-internal/src/GHC/Internal/Data/Either.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Function.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Data/IORef.hs - libraries/ghc-internal/src/GHC/Internal/Data/List.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs - libraries/ghc-internal/src/GHC/Internal/Data/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs - libraries/ghc-internal/src/GHC/Internal/Data/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Data/Void.hs - libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs - libraries/ghc-internal/src/GHC/Internal/Desugar.hs - libraries/ghc-internal/src/GHC/Internal/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs-boot - libraries/ghc-internal/src/GHC/Internal/Environment.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/src/GHC/Internal/Event/Arr.hs - libraries/ghc-internal/src/GHC/Internal/Event/Array.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/IntTable.hs - libraries/ghc-internal/src/GHC/Internal/Event/IntVar.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs - libraries/ghc-internal/src/GHC/Internal/Event/PSQ.hs - libraries/ghc-internal/src/GHC/Internal/Event/Poll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimeOut.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Clock.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/FFI.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot - libraries/ghc-internal/src/GHC/Internal/ExecutionStack.hs - libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint/Type.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/ConversionUtils.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Types.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/ForeignPtr/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Alloc.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Array.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Pool.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Storable.hs - libraries/ghc-internal/src/GHC/Internal/ForeignPtr.hs - libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - libraries/ghc-internal/src/GHC/Internal/GHCi.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Buffer.hs - libraries/ghc-internal/src/GHC/Internal/IO/BufferedIO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/API.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/Table.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Iconv.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Latin1.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF16.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF32.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Common.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Flock.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/NoOp.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs - libraries/ghc-internal/src/GHC/Internal/IO/SubSystem.hs - libraries/ghc-internal/src/GHC/Internal/IO/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc - libraries/ghc-internal/src/GHC/Internal/IOArray.hs - libraries/ghc-internal/src/GHC/Internal/IORef.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/IsList.hs - libraries/ghc-internal/src/GHC/Internal/Ix.hs - libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs - libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/Lexeme.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Magic/Dict.hs - libraries/ghc-internal/src/GHC/Internal/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs-boot - libraries/ghc-internal/src/GHC/Internal/Numeric.hs - libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs - libraries/ghc-internal/src/GHC/Internal/Pack.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs - libraries/ghc-internal/src/GHC/Internal/Prim/PtrEq.hs - libraries/ghc-internal/src/GHC/Internal/Profiling.hs - libraries/ghc-internal/src/GHC/Internal/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs-boot - libraries/ghc-internal/src/GHC/Internal/Records.hs - libraries/ghc-internal/src/GHC/Internal/ST.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - libraries/ghc-internal/src/GHC/Internal/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Show.hs - libraries/ghc-internal/src/GHC/Internal/Stable.hs - libraries/ghc-internal/src/GHC/Internal/StableName.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs-boot - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - libraries/ghc-internal/src/GHC/Internal/Storable.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - libraries/ghc-internal/src/GHC/Internal/System/Mem.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Types.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadP.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadPrec.hs - libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/TypeError.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits/Internal.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Unicode.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/DerivedCoreProperties.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/GeneralCategory.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleLowerCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleTitleCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleUpperCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Conc.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Conc/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs - libraries/ghc-internal/src/GHC/Internal/Windows.hs - libraries/ghc-internal/src/GHC/Internal/Word.hs - libraries/ghc-internal/tools/ucd2haskell/exe/UCD2Haskell/ModuleGenerators.hs - libraries/ghc-prim/Dummy.hs - libraries/ghc-prim/ghc-prim.cabal - libraries/template-haskell/Language/Haskell/TH/Lib.hs - rts/include/rts/RtsToHsIface.h - testsuite/tests/ado/T13242a.stderr - testsuite/tests/annotations/should_fail/annfail10.stderr - testsuite/tests/backpack/cabal/bkpcabal07/Makefile - testsuite/tests/backpack/should_compile/T20396.stderr - testsuite/tests/backpack/should_fail/bkpfail17.stderr - testsuite/tests/cabal/T12485/Makefile - + testsuite/tests/cabal/T27013a/Makefile - + testsuite/tests/cabal/T27013a/Setup.hs - + testsuite/tests/cabal/T27013a/all.T - + testsuite/tests/cabal/T27013a/composition.cabal - + testsuite/tests/cabal/T27013a/src/Data/Composition.hs - + testsuite/tests/cabal/T27013d/Composition.hs - + testsuite/tests/cabal/T27013d/Makefile - + testsuite/tests/cabal/T27013d/T27013d.stdout - + testsuite/tests/cabal/T27013d/all.T - testsuite/tests/callarity/unittest/CallArity1.hs - testsuite/tests/corelint/LintEtaExpand.hs - testsuite/tests/corelint/T21115b.stderr - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_compile/T13208.stdout - testsuite/tests/deSugar/should_compile/T16615.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/default/DefaultImportFail01.stderr - testsuite/tests/default/DefaultImportFail02.stderr - testsuite/tests/default/DefaultImportFail03.stderr - testsuite/tests/default/DefaultImportFail04.stderr - testsuite/tests/default/DefaultImportFail05.stderr - testsuite/tests/default/DefaultImportFail07.stderr - testsuite/tests/default/T25775.stderr - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/deriving/should_compile/T20496.stderr - testsuite/tests/diagnostic-codes/codes.stdout - + testsuite/tests/driver/T27013b/Makefile - + testsuite/tests/driver/T27013b/T27013b.stdout - + testsuite/tests/driver/T27013b/X.hs - + testsuite/tests/driver/T27013b/all.T - + testsuite/tests/driver/T27013c/Makefile - + testsuite/tests/driver/T27013c/T27013c.stdout - + testsuite/tests/driver/T27013c/X.hs - + testsuite/tests/driver/T27013c/all.T - + testsuite/tests/driver/T27013e/T27013e.hs - + testsuite/tests/driver/T27013e/T27013e.stderr - + testsuite/tests/driver/T27013e/all.T - + testsuite/tests/driver/T27013f/T27013f.hs - + testsuite/tests/driver/T27013f/T27013f.stderr - + testsuite/tests/driver/T27013f/all.T - testsuite/tests/driver/T3007/A/Internal.hs - testsuite/tests/driver/T3007/Makefile - testsuite/tests/driver/make-prim/Makefile - testsuite/tests/driver/recomp24656/Makefile - testsuite/tests/driver/recomp24656/recomp24656.stdout - testsuite/tests/ghc-api/T8628.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghci.debugger/scripts/break006.stderr - testsuite/tests/ghci.debugger/scripts/print019.stderr - testsuite/tests/ghci/scripts/all.T - testsuite/tests/hiefile/should_run/T23120.stdout - testsuite/tests/iface/IfaceSharingIfaceType.hs - testsuite/tests/iface/IfaceSharingName.hs - testsuite/tests/indexed-types/should_fail/T12522a.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/javascript/Makefile - testsuite/tests/javascript/T24495.hs - testsuite/tests/numeric/should_compile/T14170.stdout - testsuite/tests/numeric/should_compile/T14465.stdout - testsuite/tests/numeric/should_compile/T7116.stdout - testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr - testsuite/tests/package/all.T - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/T16270h.hs - testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr - testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/perf/should_run/ByteCodeAsm.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInvalid.hs - testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/simple-plugin/Simple/ReplacePlugin.hs - testsuite/tests/plugins/static-plugins.stdout - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/profiling/should_run/callstack002.stderr - testsuite/tests/profiling/should_run/callstack002.stdout - testsuite/tests/rename/should_compile/T3103/Foreign/Ptr.hs - testsuite/tests/rename/should_compile/T3103/GHC/Base.lhs - testsuite/tests/rename/should_compile/T3103/GHC/Word.hs - testsuite/tests/rename/should_compile/T3103/test.T - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles13.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/simplCore/should_compile/T13543.stderr - testsuite/tests/simplCore/should_compile/T16038/T16038.stdout - testsuite/tests/simplCore/should_compile/T3717.stderr - testsuite/tests/simplCore/should_compile/T3772.stdout - testsuite/tests/simplCore/should_compile/T4908.stderr - testsuite/tests/simplCore/should_compile/T4930.stderr - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplCore/should_compile/T8274.stdout - testsuite/tests/simplCore/should_compile/T9400.stderr - testsuite/tests/simplCore/should_compile/noinline01.stderr - testsuite/tests/simplCore/should_compile/par01.stderr - testsuite/tests/simplCore/should_compile/rule2.stderr - testsuite/tests/simplCore/should_compile/str-rules.hs - testsuite/tests/tcplugins/ArgsPlugin.hs - testsuite/tests/tcplugins/EmitWantedPlugin.hs - testsuite/tests/tcplugins/RewritePlugin.hs - testsuite/tests/tcplugins/T26395_Plugin.hs - testsuite/tests/tcplugins/TyFamPlugin.hs - testsuite/tests/th/T14741.hs - testsuite/tests/th/T21547.stderr - testsuite/tests/th/T26568.stderr - testsuite/tests/th/TH_Roles2.stderr - + testsuite/tests/th/TH_pragmaSpecOld.hs - + testsuite/tests/th/TH_pragmaSpecOld.stderr - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/T13032.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes2.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T12921.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr - testsuite/tests/typecheck/should_fail/T15883b.stderr - testsuite/tests/typecheck/should_fail/T15883c.stderr - testsuite/tests/typecheck/should_fail/T15883d.stderr - testsuite/tests/typecheck/should_fail/T21130.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T5095.stderr - testsuite/tests/typecheck/should_fail/T7279.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_PatternBindingExistential.stderr - testsuite/tests/typecheck/should_fail/tcfail072.stderr - testsuite/tests/typecheck/should_fail/tcfail097.stderr - testsuite/tests/typecheck/should_fail/tcfail133.stderr - testsuite/tests/typecheck/should_run/T22510.stdout - testsuite/tests/unboxedsums/UbxSumLevPoly.hs - testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs - testsuite/tests/warnings/should_compile/DerivingTypeable.stderr - utils/check-exact/Utils.hs - utils/genprimopcode/Main.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ab10b3b96186f053372af7cfffdcb9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ab10b3b96186f053372af7cfffdcb9… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/external-unit-db-cache] 3 commits: Add ChangeLog
by Hannes Siebenhandl (＠fendor) 16 Jul '26

16 Jul '26

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: 97447bdf by fendor at 2026-07-16T16:27:29+02:00 Add ChangeLog - - - - - aa5d8115 by fendor at 2026-07-16T16:27:29+02:00 Split State.hs into many more modules - - - - - cead9129 by fendor at 2026-07-16T16:27:29+02:00 Add regression test for #26423 - - - - - 21 changed files: - + changelog.d/unit-index - compiler/GHC/Unit/External/Database.hs - + compiler/GHC/Unit/External/Index.hs - + compiler/GHC/Unit/External/ModuleOrigin.hs - + compiler/GHC/Unit/External/Providers.hs - + compiler/GHC/Unit/External/Query.hs - + compiler/GHC/Unit/External/Substitution.hs - + compiler/GHC/Unit/External/Validate.hs - + compiler/GHC/Unit/External/Visibility.hs - + compiler/GHC/Unit/External/Wired.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/State.hs-boot - compiler/GHC/Unit/Types.hs - compiler/ghc.cabal.in - + testsuite/tests/driver/T26423/Hello.hs - + testsuite/tests/driver/T26423/Makefile - + testsuite/tests/driver/T26423/T26423.hs - + testsuite/tests/driver/T26423/all.T - + testsuite/tests/driver/T26423/test/Test.hs - + testsuite/tests/driver/T26423/test/test.pkg Changes: ===================================== changelog.d/unit-index ===================================== @@ -0,0 +1,14 @@ +section: compiler +synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units +issues: #27500 #26423 +mrs: !16115 + +description: { + The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. + This can lead to excessive memory usage with multiple home units and large package databases. + + Our solution to this problem is deduplicating ``UnitInfo``s globally across the whole ``UnitEnv``. + We store this information in the ``UnitIndex`` which contains data global to all ``UnitState``s. + All processed ``UnitInfo``s and the ``WiredMap`` are stored in there, and in the future, we might + move more fields from ``UnitState`` to ``UnitIndex``. +} ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -14,18 +14,52 @@ module GHC.Unit.External.Database ( lookupExternalUnitDatabases, -- * UnitDatabase (..), + -- * + mergeDatabases, + UnitPrecedenceMap, + sortByPreference, + compareByPreference, + -- * + UnitDbConfig(..), + readOrGetUnitDatabase, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, ) where import GHC.Prelude -import GHC.Data.OsPath -import GHC.Unit.Info -import GHC.Utils.Outputable +import GHC.Driver.DynFlags -import Data.IORef (IORef) +import Control.Monad +import Data.Char +import Data.IORef import Data.IORef qualified as IORef -import Data.Map.Strict +import Data.List (partition, sortBy) +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Ord +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST +import GHC.Platform.ArchOS +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import System.Directory +import System.Environment (getEnv) +import System.FilePath as FilePath -- ---------------------------------------------------------------------------- -- ExternalUnitDatabaseCache @@ -102,3 +136,274 @@ data UnitDatabase unit = UnitDatabase instance (Outputable u) => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each unit, a mapping from uid -> i indicates that this +-- unit was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- units that were defined later on the command line, if there +-- is an ambiguity. +type UnitPrecedenceMap = UniqMap UnitId Int + +-- | Given a list of databases, merge them together, where +-- units with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: Logger -> [UnitDatabase UnitId] + -> IO (UnitInfoMap, UnitPrecedenceMap) +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] + where + merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do + debugTraceMsg logger 2 $ + text "loading package database" <+> ppr db_path + when (logVerbAtLeast logger 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set UnitId + override_set = Set.intersection (nonDetUniqMapToKeySet db_map) + (nonDetUniqMapToKeySet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: UnitInfoMap + pkg_map' = pkg_map `plusUniqMap` db_map + + prec_map' :: UnitPrecedenceMap + prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +data UnitDbConfig = UnitDbConfig + { unitDbConfigFlagsDB :: [PackageDBFlag] + , unitDbConfigProgramName :: String + , unitDbConfigDBName :: FilePath + , unitDbConfigPlatformArchOS :: ArchOS + , unitDbConfigGlobalDB :: FilePath + , unitDbConfigGHCDir :: FilePath + , unitDbConfigDBCache :: ExternalUnitDatabaseCache UnitId + } + +readUnitDatabases :: Logger -> UnitDbConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readOrGetUnitDatabase logger cfg) confs + + +getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg) + let pkgconf = dir </> unitDbConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. +readOrGetUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger cfg conf_file = + readExternalUnitDatabase (unitDbConfigDBCache cfg) conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase (unitDbConfigDBCache cfg) new_db + pure new_db + Just db -> + pure db + +-- | Read the 'UnitDatabase' at the given location. +readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do + isdir <- OsPath.doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- OsPath.doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ show conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ show conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) + pkgroot = OsPath.takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) + proto_pkg_configs + -- + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 + where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename + if cache_exists + then do + debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg logger 2 $ text "There is no package.cache in" + <+> ppr conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg logger 3 $ text "There are no .conf files in" + <+> ppr conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ show conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +mungeUnitInfo :: OsPath -> OsPath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeBytecodeLibFields + . mungeLibDirFields + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) + +mungeLibDirFields :: UnitInfo -> UnitInfo +mungeLibDirFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -0,0 +1,198 @@ +module GHC.Unit.External.Index ( + -- * + UnitIndex, + initUnitIndex, + wiringMap, + unwiringMap, + globalUnits, + setWireMap, + isWireMapEmpty, + addUnitInfoMap, + + -- * + GlobalUnitInfoMap, + lookupGlobalUnitInfoMap, + mkGlobalUnitKey, + + -- * + GlobalUnitKey, + globalUnitKeyFromUnitInfo, + + -- * + updateWiredInUnits, + updateWiredInUnitsInUnitInfo, + upd_wired_in_mod, + -- * + unwireUnit, +) where + +import GHC.Prelude + +import GHC.Data.ShortText qualified as ST +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Wired +import GHC.Unit.Info +import GHC.Unit.Types + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Utils.Outputable + +-- ---------------------------------------------------------------------------- +-- UnitIndex +-- ---------------------------------------------------------------------------- + +data UnitIndex = UnitIndex + { ui_wireMap :: !WiringMap + -- ^ A mapping from database unit keys to wired in unit ids. + , ui_unwireMap :: !UnwiringMap + -- ^ A mapping from wired in unit ids to unit keys from the database. + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: document + } + +wiringMap :: UnitIndex -> UnwiringMap +wiringMap = ui_wireMap + +unwiringMap :: UnitIndex -> WiringMap +unwiringMap = ui_unwireMap + +globalUnits :: UnitIndex -> GlobalUnitInfoMap +globalUnits = ui_unitInfoMap + +initUnitIndex :: UnitIndex +initUnitIndex = UnitIndex + { ui_wireMap = emptyUniqMap + , ui_unwireMap = emptyUniqMap + , ui_unitInfoMap = emptyUniqMap + } + +setWireMap :: WiringMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + } + +isWireMapEmpty :: UnitIndex -> Bool +isWireMapEmpty unit_index = + isNullUniqMap (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) + } + where + globalMap :: GlobalUnitInfoMap + globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map + +-- ---------------------------------------------------------------------------- +-- GlobalUnitInfoMap +-- ---------------------------------------------------------------------------- + +type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) + +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = + case lookupUniqMap globalMap uid of + Nothing -> Nothing + Just sameUnitId -> Map.lookup abiHash sameUnitId + +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap +mkGlobalUnitInfoMap unitInfos = + listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos + +-- ---------------------------------------------------------------------------- +-- GlobalUnitKey +-- ---------------------------------------------------------------------------- + +data GlobalUnitKey = + GlobalUnitKey + !UnitId -- ^ Unit Id of the 'UnitInfo' + !ST.ShortText + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) + +mkGlobalUnitKey :: UnitId -> ST.ShortText -> GlobalUnitKey +mkGlobalUnitKey = GlobalUnitKey + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit' +-- that it was recorded as in the package database. +unwireUnit :: UnitIndex -> Unit -> Unit +unwireUnit state uid@(RealUnit (Definite def_uid)) = + maybe uid (RealUnit . Definite) (lookupUniqMap (unwiringMap state) def_uid) +unwireUnit _ uid = uid + +updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_wired_in_pkg wiredInUnitId pkg = + pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupUniqMap wiredInMap (unitId pkg) of + Just wiredIn -> + case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +upd_wired_in_mod :: WiringMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiringMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WiringMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupUniqMap wiredInMap key = key' + | otherwise = key ===================================== compiler/GHC/Unit/External/ModuleOrigin.hs ===================================== @@ -0,0 +1,110 @@ +module GHC.Unit.External.ModuleOrigin ( + ModuleOrigin(..), + fromExposedModules, + fromReexportedModules, + fromFlag, + originVisible, + originEmpty, +) where + +import GHC.Prelude +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Data.Semigroup as Semigroup + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) rhs)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + g Nothing x = x + g x Nothing = x + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False ===================================== compiler/GHC/Unit/External/Providers.hs ===================================== @@ -0,0 +1,186 @@ +module GHC.Unit.External.Providers ( + ModuleNameProvidersMap, + pprModuleMap, + mkModuleNameProvidersMap, + mkUnusableModuleNameProvidersMap, +) where + +import GHC.Prelude + +import GHC.Data.Maybe +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Query +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.Info +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' + +type ModuleNameProvidersMap = + UniqMap ModuleName (UniqMap Module ModuleOrigin) + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (nonDetUniqMapToList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from ModuleName to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: Logger + -> Bool + -> UnitInfoMap + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap logger allowVirtualUnits pkg_map vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_map is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_map multiple times to the actual + -- ModuleNameProvidersMap. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended + where + vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map + + default_vis = listToUniqMap + [ (mkUnit pkg, mempty) + | (_, pkg) <- nonDetUniqMapToList pkg_map + -- Exclude specific instantiations of an indefinite + -- package + , unitIsIndefinite pkg || null (unitInstantiations pkg) + ] + + emptyMap = emptyUniqMap + setOrigins m os = fmap (const os) m + extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, UniqMap Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, UniqMap Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (renderWithContext + (log_default_user_context (logFlags logger)) + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + (pk', m', fromReexportedModules e pkg) + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = mkUnit pkg + unit_lookup uid = lookupUnit' allowVirtualUnits pkg_map uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = unitExposedModules pkg + hidden_mods = unitHiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap unusables = + nonDetFoldUniqMap extend_modmap emptyUniqMap unusables + where + extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings + where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin_reexport = ModUnusable (UnusableUnit unit reason True) + origin_normal = ModUnusable (UnusableUnit unit reason False) + unit = mkUnit unit_info + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] + + -- with re-exports, c:Foo can be reexported from two (or more) + -- unusable packages: + -- Foo -> a:Foo (unusable reason A) -> c:Foo + -- -> b:Foo (unusable reason B) -> c:Foo + -- + -- We must be careful to not record the following (#21097): + -- Foo -> c:Foo (unusable reason A) + -- -> c:Foo (unusable reason B) + -- But: + -- Foo -> a:Foo (unusable reason A) + -- -> b:Foo (unusable reason B) + -- + get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) + get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) + -- in the reexport case, we create a virtual module that doesn't + -- exist but we don't care as it's only used as a key in the map. + + exposed_mods = unitExposedModules unit_info + hidden_mods = unitHiddenModules unit_info + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) + => UniqMap k1 (UniqMap k2 a) + -> [(k1, UniqMap k2 a)] + -> UniqMap k1 (UniqMap k2 a) +addListTo = foldl' merge + where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v + +-- | Create a singleton module mapping +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin +mkModMap pkg mod = unitUniqMap (mkModule pkg mod) ===================================== compiler/GHC/Unit/External/Query.hs ===================================== @@ -0,0 +1,41 @@ +module GHC.Unit.External.Query ( + -- * + lookupUnit', + lookupUnitId', +) where + +import GHC.Prelude + +import GHC.Types.Unique.Map +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Module + +-- | A more specialized interface, which doesn't require a 'UnitState' (so it +-- can be used while we're initializing 'DynFlags') +-- +-- Parameters: +-- * a boolean specifying whether or not to look for on-the-fly renamed interfaces +-- * a 'UnitInfoMap' +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map u = case u of + HoleUnit -> error "Hole unit" + RealUnit i -> lookupUniqMap pkg_map (unDefinite i) + VirtUnit i + | allowOnTheFlyInst + -> -- lookup UnitInfo of the indefinite unit to be instantiated and + -- instantiate it on-the-fly + fmap (renameUnitInfo pkg_map (instUnitInsts i)) + (lookupUniqMap pkg_map (instUnitInstanceOf i)) + + | otherwise + -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite + -- units. Even if they are real, installed units, they can't use the + -- `RealUnit` constructor (it is reserved for definite units) so we use + -- the `VirtUnit` constructor. + lookupUniqMap pkg_map (virtualUnitId i) + + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnitId' db uid = lookupUniqMap db uid ===================================== compiler/GHC/Unit/External/Substitution.hs ===================================== @@ -0,0 +1,61 @@ +module GHC.Unit.External.Substitution ( + -- * + ShHoleSubst, + renameHoleModule', + renameHoleUnit', + renameUnitInfo, +) where + +import GHC.Prelude + +import GHC.Unit.Module +import GHC.Unit.Info +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.DSet + +-- ----------------------------------------------------------------------------- +-- Module renaming + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Rename a 'UnitInfo' according to some module instantiation. +renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) + in conf { + unitInstantiations = new_insts, + unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (unitExposedModules conf) + } + + +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnit' pkg_map env (moduleUnit m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = <Blah>, that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map env uid = + case uid of + (VirtUnit + InstantiatedUnit{ instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + else mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid ===================================== compiler/GHC/Unit/External/Validate.hs ===================================== @@ -0,0 +1,384 @@ +module GHC.Unit.External.Validate ( + validateDatabase, + + findPackages, + selectPackages, + + UnusableUnits, + reportUnusable, + + UnusableUnit(..), + + UnusableUnitReason(..), + pprReason, + + UnitErr(..), + mayThrowUnitErr, + closeUnitDeps, + closeUnitDeps', + ignoreUnits, + pprFlag, +) where + +import GHC.Prelude + +import Control.Monad +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (partition) +import GHC.Data.Maybe +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.External.Database +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Outputable qualified as Outputable +import GHC.Utils.Panic + +-- ----------------------------------------------------------------------------- +-- Database validation + +-- | Validates a database, removing unusable units from it +-- (this includes removing units that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken units (dangling dependencies) +-- 2. Remove all units that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all units which have deps with mismatching ABIs +-- +validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap + -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) +validateDatabase flagsIgnored pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse flagsIgnored -- (unitConfigFlagsIgnored cfg) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids + ] + + -- Find broken units + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (nonDetEltsUniqMap pkg_map1) + (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive units + sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) + | pkg <- nonDetEltsUniqMap pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) + (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out units whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (nonDetEltsUniqMap pkg_map4) + (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + -- combine all unusables. The order is important for shadowing. + -- plusUniqMapList folds using plusUFM which is right biased (opposite of + -- Data.Map.union) so the head of the list should be the least preferred + unusable = plusUniqMapList [ unusable_shadowed + , unusable_cyclic + , unusable_broken + , unusable_ignored + , directly_ignored + ] + + +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) + +-- | A unusable unit module origin +data UnusableUnit = UnusableUnit + { uuUnit :: !Unit -- ^ Unusable unit + , uuReason :: !UnusableUnitReason -- ^ Reason + , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? + } + +-- | The reason why a unit is unusable. +data UnusableUnitReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This unit transitively depends on a unit that was never present + -- in any of the provided databases. + | BrokenDependencies [UnitId] + -- | This unit transitively depends on a unit involved in a cycle. + -- Note that the list of 'UnitId' reports the direct dependencies + -- of this unit that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [UnitId] + -- | This unit transitively depends on a unit which was ignored. + | IgnoredDependencies [UnitId] + -- | This unit transitively depends on a unit which was + -- shadowed by an ABI-incompatible unit. + | ShadowedDependencies [UnitId] + +instance Outputable UnusableUnitReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +pprReason :: SDoc -> UnusableUnitReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportUnusable :: Logger -> UnusableUnits -> IO () +reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg logger 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ----------------------------------------------------------------------------- +-- Package Finding + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: UnitPrecedenceMap + -> UnitInfoMap + -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + [UnitInfo] +findPackages prec_map pkg_map arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if matchingStr str p + then Just p + else Nothing + finder (UnitIdArg uid) p + = case uid of + RealUnit (Definite iuid) + | iuid == unitId p + -> Just p + VirtUnit inst + | instUnitInstanceOf inst == unitId p + -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) + _ -> Nothing + +selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- ----------------------------------------------------------------------------- +-- Ignore units + +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing unit is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- ---------------------------------------------------------------------------- +-- +-- Closures +-- + + +-- | Takes a list of UnitIds (and their "parent" dependency, used for error +-- messages), and returns the list with dependencies included, in reverse +-- dependency order (a units appears before those it depends on). +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps + +-- | Similar to closeUnitDeps but takes a list of already loaded units as an +-- additional argument. +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps + +-- | Add a UnitId and those it depends on (recursively) to the given list of +-- UnitIds if they are not already in it. Return a list in reverse dependency +-- order (a unit appears before those it depends on). +-- +-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). +-- It it's not found, the optional parent unit is used to return a more precise +-- error message ("dependency of <PARENT>"). +add_unit :: UnitInfoMap + -> [UnitId] + -> UnitId + -> Maybe UnitId + -> MaybeErr UnitErr [UnitId] +add_unit pkg_map ps p mb_parent + | p `elem` ps = return ps -- Check if we've already added this unit + | otherwise = case lookupUnitId' pkg_map p of + Nothing -> Failed (CloseUnitErr p mb_parent) + Just info -> do + -- Add the unit's dependents also + ps' <- foldM add_unit_key ps (unitDepends info) + return (p : ps') + where + add_unit_key xs key + = add_unit pkg_map xs key (Just p) +data UnitErr + = CloseUnitErr !UnitId !(Maybe UnitId) + | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] + | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] + +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a +mayThrowUnitErr = \case + Failed e -> throwGhcExceptionIO + $ CmdLineError + $ renderWithContext defaultSDocContext + $ withPprStyle defaultUserStyle + $ ppr e + Succeeded a -> return a + +instance Outputable UnitErr where + ppr = \case + CloseUnitErr p mb_parent + -> (text "unknown unit:" <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + PackageFlagErr flag reasons + -> flag_err (pprFlag flag) reasons + + TrustFlagErr flag reasons + -> flag_err (pprTrustFlag flag) reasons + where + flag_err flag_doc reasons = + text "cannot satisfy " + <> flag_doc + <> (if null reasons then Outputable.empty else text ": ") + $$ nest 4 (vcat (map ppr_reason reasons) $$ + text "(use -v for more information)") + + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = UniqMap UnitId [UnitId] + +-- | Compute the reverse dependency index of a unit database. +reverseDeps :: UnitInfoMap -> RevIndex +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db + where + go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex + go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = addToUniqMap_C (++) r to [from] + +-- | Given a list of 'UnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those units, plus any units which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removeUnits :: [UnitId] -> RevIndex + -> UnitInfoMap + -> (UnitInfoMap, [UnitInfo]) +removeUnits uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- lookupUniqMap m uid + = case lookupUniqMap index uid of + Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' +-- which correspond to units that do not exist in the index. +depsNotAvailable :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in +-- 'unitAbiDepends' which correspond to units that do not exist, OR have +-- mismatching ABIs. +depsAbiMismatch :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- lookupUniqMap pkg_map dep_uid + = unitAbiHash dep_pkg == abi + | otherwise + = False ===================================== compiler/GHC/Unit/External/Visibility.hs ===================================== @@ -0,0 +1,72 @@ +module GHC.Unit.External.Visibility ( + VisibilityMap, + UnitVisibility(..), +) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.Module +import GHC.Utils.Outputable as Outputable + +import Control.Applicative +import Data.Monoid (First (..)) +import Data.Semigroup qualified as Semigroup +import Data.Set (Set) +import Data.Set qualified as Set + +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = UniqMap Unit UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'Unit'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name associated with the 'Unit'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Maybe PackageArg + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) + , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = emptyUniqMap + , uv_explicit = Nothing + } + mappend = (Semigroup.<>) + ===================================== compiler/GHC/Unit/External/Wired.hs ===================================== @@ -0,0 +1,100 @@ +module GHC.Unit.External.Wired ( + WiringMap, + UnwiringMap, + findWiredInUnits, +) where + +import GHC.Prelude + +import GHC.Data.Maybe +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Database +import GHC.Unit.External.Visibility +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable as Outputable + +type WiringMap = + UniqMap UnitId UnitId + +type UnwiringMap = + UniqMap UnitId UnitId + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +findWiredInUnits + :: Logger + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO WiringMap -- map from unit id to wired identity +findWiredInUnits logger prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Types + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] + where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + + notfound = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (UnitId, UnitInfo) + pick pkg = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (wired_pkg, pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + return wiredInMap ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -5,11 +5,14 @@ module GHC.Unit.Info ( GenericUnitInfo (..) , GenUnitInfo , UnitInfo + , UnitInfoMap , UnitKey (..) , UnitKeyInfo , mkUnitKeyInfo , mapUnitInfo , mkUnitPprInfo + , evaluateUnitInfo + , seqUnitInfo , mkUnit @@ -53,6 +56,8 @@ import Data.Containers.ListUtils (nubOrd) import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix) +import GHC.Types.Unique.Map +import Control.Exception (evaluate) -- | Information about an installed unit @@ -73,6 +78,9 @@ type UnitKeyInfo = GenUnitInfo UnitKey -- UnitId) type UnitInfo = GenUnitInfo UnitId +-- TODO @fendor +type UnitInfoMap = UniqMap UnitId UnitInfo + -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo @@ -250,3 +258,21 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar expandTag t | null t = "" | otherwise = '_':t + +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) + +seqUnitInfo :: UnitInfo -> b -> b +seqUnitInfo ui b = + unitImportDirs ui `seqList` + unitIncludeDirs ui `seqList` + unitLibraryDirs ui `seqList` + unitLibraryBytecodeDirs ui `seqList` + unitExtDepFrameworkDirs ui `seq` + unitHaddockInterfaces ui `seq` + unitHaddockHTMLs ui `seqList` + unitLibraryDynDirs ui `seqList` + unitLibraryDirsStatic ui `seqList` + unitDepends ui `seqList` + unitExposedModules ui `seqList` + b ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Unit.State ( module GHC.Unit.Info, - UnitIndex(..), + UnitIndex, initUnitIndex, setWireMap, isWireMapEmpty, @@ -26,7 +26,6 @@ module GHC.Unit.State ( listUnitInfo, -- * Querying the package config - UnitInfoMap, lookupUnit, lookupUnit', unsafeLookupUnit, @@ -90,50 +89,45 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Unit.Database +import GHC.Unit.Home import GHC.Unit.Info -import GHC.Unit.Ppr -import GHC.Unit.Types import GHC.Unit.Module -import GHC.Unit.Home +import GHC.Unit.Ppr -import GHC.Types.Unique.FM +import GHC.Unit.External.Database +import GHC.Unit.External.Index +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Providers +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.External.Wired + +import GHC.Types.PkgQual import GHC.Types.Unique.DFM -import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM import GHC.Types.Unique.Map -import GHC.Types.Unique -import GHC.Types.PkgQual -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Outputable as Outputable -import GHC.Data.Maybe - -import System.Environment ( getEnv ) import GHC.Data.FastString -import GHC.Data.OsPath ( OsPath ) -import qualified GHC.Data.OsPath as OsPath -import qualified GHC.Data.ShortText as ST -import GHC.Utils.Logger +import GHC.Data.Maybe +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST import GHC.Utils.Error -import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic -import System.Directory -import System.FilePath as FilePath import Control.Monad import Data.Containers.ListUtils (nubOrd) -import Data.Graph (stronglyConnComp, SCC(..)) -import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, sortOn, sort ) -import Data.Set (Set) -import Data.Monoid (First(..)) -import qualified Data.Semigroup as Semigroup -import qualified Data.Set as Set -import Control.Applicative -import GHC.Unit.External.Database -import Data.IORef import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Graph (SCC (..)) +import Data.IORef +import Data.List (intersperse, partition, sort, sortOn) +import Data.Monoid (First (..)) +import Data.Set (Set) +import Data.Set qualified as Set -- --------------------------------------------------------------------------- -- The Unit state @@ -179,162 +173,6 @@ import qualified Data.Map.Strict as Map -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. --- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! -data ModuleOrigin = - -- | Module is hidden, and thus never will be available for import. - -- (But maybe the user didn't realize), so we'll still keep track - -- of these modules.) - ModHidden - - -- | Module is unavailable because the unit is unusable. - | ModUnusable !UnusableUnit - - -- | Module is public, and could have come from some places. - | ModOrigin { - -- | @Just False@ means that this module is in - -- someone's @exported-modules@ list, but that package is hidden; - -- @Just True@ means that it is available; @Nothing@ means neither - -- applies. - fromOrigUnit :: Maybe Bool - -- | Is the module available from a reexport of an exposed package? - -- There could be multiple. - , fromExposedReexport :: [UnitInfo] - -- | Is the module available from a reexport of a hidden package? - , fromHiddenReexport :: [UnitInfo] - -- | Did the module export come from a package flag? (ToDo: track - -- more information. - , fromPackageFlag :: Bool - } - --- | A unusable unit module origin -data UnusableUnit = UnusableUnit - { uuUnit :: !Unit -- ^ Unusable unit - , uuReason :: !UnusableUnitReason -- ^ Reason - , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? - } - -instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" - ppr (ModUnusable _) = text "unusable module" - ppr (ModOrigin e res rhs f) = sep (punctuate comma ( - (case e of - Nothing -> [] - Just False -> [text "hidden package"] - Just True -> [text "exposed package"]) ++ - (if null res - then [] - else [text "reexport by" <+> - sep (map (ppr . mkUnit) res)]) ++ - (if null rhs - then [] - else [text "hidden reexport by" <+> - sep (map (ppr . mkUnit) rhs)]) ++ - (if f then [text "package flag"] else []) - )) - --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False - --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is exposed, and --- also its 'UnitInfo'. -fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False - --- | Smart constructor for a module which was bound by a package flag. -fromFlag :: ModuleOrigin -fromFlag = ModOrigin Nothing [] [] True - -instance Semigroup ModuleOrigin where - x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - g Nothing x = x - g x Nothing = x - - x <> y = pprPanic "ModOrigin: module origin mismatch" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - -instance Monoid ModuleOrigin where - mempty = ModOrigin Nothing [] [] False - mappend = (Semigroup.<>) - --- | Is the name from the import actually visible? (i.e. does it cause --- ambiguity, or is it only relevant when we're making suggestions?) -originVisible :: ModuleOrigin -> Bool -originVisible ModHidden = False -originVisible (ModUnusable _) = False -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f - --- | Are there actually no providers for this module? This will never occur --- except when we're filtering based on package imports. -originEmpty :: ModuleOrigin -> Bool -originEmpty (ModOrigin Nothing [] [] False) = True -originEmpty _ = False - --- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. -type VisibilityMap = UniqMap Unit UnitVisibility - --- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'Unit'. -data UnitVisibility = UnitVisibility - { uv_expose_all :: Bool - -- ^ Should all modules in exposed-modules should be dumped into scope? - , uv_renamings :: [(ModuleName, ModuleName)] - -- ^ Any custom renamings that should bring extra 'ModuleName's into - -- scope. - , uv_package_name :: First FastString - -- ^ The package name associated with the 'Unit'. This is used - -- to implement legacy behavior where @-package foo-0.1@ implicitly - -- hides any packages named @foo@ - , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) - -- ^ The signatures which are contributed to the requirements context - -- from this unit ID. - , uv_explicit :: Maybe PackageArg - -- ^ Whether or not this unit was explicitly brought into scope, - -- as opposed to implicitly via the 'exposed' fields in the - -- package database (when @-hide-all-packages@ is not passed.) - } - -instance Outputable UnitVisibility where - ppr (UnitVisibility { - uv_expose_all = b, - uv_renamings = rns, - uv_package_name = First mb_pn, - uv_requirements = reqs, - uv_explicit = explicit - }) = ppr (b, rns, mb_pn, reqs, explicit) - -instance Semigroup UnitVisibility where - uv1 <> uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) - , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 - } - -instance Monoid UnitVisibility where - mempty = UnitVisibility - { uv_expose_all = False - , uv_renamings = [] - , uv_package_name = First Nothing - , uv_requirements = emptyUniqMap - , uv_explicit = Nothing - } - mappend = (Semigroup.<>) - - -- | Unit configuration data UnitConfig = UnitConfig { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS @@ -422,77 +260,6 @@ initUnitConfig dflags cached_dbs home_units = offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p)) offsetPackageDb _ p = p - --- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and --- its 'ModuleOrigin'). --- --- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one --- origin for a given 'Module' - -type ModuleNameProvidersMap = - UniqMap ModuleName (UniqMap Module ModuleOrigin) - -data GlobalUnitKey = - GlobalUnitKey - !UnitId -- ^ Unit Id of the 'UnitInfo' - !ST.ShortText - -globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey -globalUnitKeyFromUnitInfo ui = GlobalUnitKey (unitId ui) (unitAbiHash ui) - -type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) - -lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo -lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = - case lookupUniqMap globalMap uid of - Nothing -> Nothing - Just sameUnitId -> Map.lookup abiHash sameUnitId - -mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap -mkGlobalUnitInfoMap unitInfos = - listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos - - -data UnitIndex = UnitIndex - { ui_wireMap :: !WiringMap - -- ^ TODO @fendor: document global property - , ui_unwireMap :: !UnwiringMap - -- ^ TODO @fendor: document global property - , ui_unitInfoMap :: !GlobalUnitInfoMap - -- ^ TODO @fendor: document - } - -initUnitIndex :: UnitIndex -initUnitIndex = UnitIndex - { ui_wireMap = emptyUniqMap - , ui_unwireMap = emptyUniqMap - , ui_unitInfoMap = emptyUniqMap - } - -setWireMap :: WiringMap -> UnitIndex -> UnitIndex -setWireMap wired_map unit_index = - unit_index - { ui_wireMap = wired_map - , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] - } - -isWireMapEmpty :: UnitIndex -> Bool -isWireMapEmpty unit_index = - isNullUniqMap (ui_wireMap unit_index) - -addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex -addUnitInfoMap unit_info_map unit_index = - unit_index - { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) - } - where - globalMap :: GlobalUnitInfoMap - globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map - --- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo --- lookupUnitInfoMap unit_index unit_id = --- lookupUniqMap (ui_unitInfoMap unit_index) unit_id - data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid units are here. 'UnitInfo' reflects @@ -513,12 +280,6 @@ data UnitState = UnitState { -- And also to resolve package qualifiers with the PackageImports extension. packageNameMap :: UniqFM PackageName UnitId, - -- -- | A mapping from database unit keys to wired in unit ids. - -- wireMap :: WiringMap, - - -- -- | A mapping from wired in unit ids to unit keys from the database. - -- unwireMap :: UnwiringMap, - -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit -- is always mentioned before the units it depends on. @@ -573,45 +334,14 @@ emptyUnitState = UnitState { allowVirtualUnits = False } -type UnitInfoMap = UniqMap UnitId UnitInfo - -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) --- | A more specialized interface, which doesn't require a 'UnitState' (so it --- can be used while we're initializing 'DynFlags') --- --- Parameters: --- * a boolean specifying whether or not to look for on-the-fly renamed interfaces --- * a 'UnitInfoMap' -lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo -lookupUnit' allowOnTheFlyInst pkg_map u = case u of - HoleUnit -> error "Hole unit" - RealUnit i -> lookupUniqMap pkg_map (unDefinite i) - VirtUnit i - | allowOnTheFlyInst - -> -- lookup UnitInfo of the indefinite unit to be instantiated and - -- instantiate it on-the-fly - fmap (renameUnitInfo pkg_map (instUnitInsts i)) - (lookupUniqMap pkg_map (instUnitInstanceOf i)) - - | otherwise - -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite - -- units. Even if they are real, installed units, they can't use the - -- `RealUnit` constructor (it is reserved for definite units) so we use - -- the `VirtUnit` constructor. - lookupUniqMap pkg_map (virtualUnitId i) - -- | Find the unit we know about with the given unit id, if any lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid --- | Find the unit we know about with the given unit id, if any -lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo -lookupUnitId' db uid = lookupUniqMap db uid - - -- | Looks up the given unit in the unit state, panicking if it is not found unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo unsafeLookupUnit state u = case lookupUnit state u of @@ -729,7 +459,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - wireMap <- ui_wireMap <$> readIORef unit_index + wireMap <- wiringMap <$> readIORef unit_index let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) @@ -782,205 +512,6 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = | otherwise -> DefiniteHomeUnit hu_id (Just (u, is)) --- ----------------------------------------------------------------------------- --- Reading the unit database(s) - -readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] -readUnitDatabases logger cfg = do - conf_refs <- getUnitDbRefs cfg - confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs - mapM (readOrGetUnitDatabase logger cfg) confs - - -getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] -getUnitDbRefs cfg = do - let system_conf_refs = [UserPkgDb, GlobalPkgDb] - - e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH") - let base_conf_refs = case e_pkg_path of - Left _ -> system_conf_refs - Right path - | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs - | otherwise - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) - - -- Apply the package DB-related flags from the command line to get the - -- final list of package DBs. - -- - -- Notes on ordering: - -- * The list of flags is reversed (later ones first) - -- * We work with the package DB list in "left shadows right" order - -- * and finally reverse it at the end, to get "right shadows left" - -- - return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg)) - where - doFlag (PackageDB p) dbs = p : dbs - doFlag NoUserPackageDB dbs = filter isNotUser dbs - doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs - doFlag ClearPackageDBs _ = [] - - isNotUser UserPkgDb = False - isNotUser _ = True - - isNotGlobal GlobalPkgDb = False - isNotGlobal _ = True - --- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' --- when the user database filepath is expected but the latter doesn't exist. --- --- NB: This logic is reimplemented in Cabal, so if you change it, --- make sure you update Cabal. (Or, better yet, dump it in the --- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg -resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do - dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) - let pkgconf = dir </> unitConfigDBName cfg - exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero -resolveUnitDatabase _ (PkgDbPath name) = return $ Just name - --- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. -readOrGetUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readOrGetUnitDatabase logger cfg conf_file = - readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case - Nothing -> do - new_db <- readUnitDatabase logger cfg conf_file - cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db - pure new_db - Just db -> - pure db - --- | Read the 'UnitDatabase' at the given location. -readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readUnitDatabase logger cfg conf_file = do - isdir <- OsPath.doesDirectoryExist conf_file - - proto_pkg_configs <- - if isdir - then readDirStyleUnitInfo conf_file - else do - isfile <- OsPath.doesFileExist conf_file - if isfile - then do - mpkgs <- tryReadOldFileStyleUnitInfo - case mpkgs of - Just pkgs -> return pkgs - Nothing -> throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package " ++ - "databases (" ++ show conf_file ++ - ") use 'ghc-pkg init' to create the database with " ++ - "the correct format." - else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ show conf_file - - let - -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = OsPath.dropTrailingPathSeparator conf_file - top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) - pkgroot = OsPath.takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) - proto_pkg_configs - -- - pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 - return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 - where - readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] - readDirStyleUnitInfo conf_dir = do - let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") - cache_exists <- OsPath.doesFileExist filename - if cache_exists - then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc filename - else do - -- If there is no package.cache file, we check if the database is not - -- empty by inspecting if the directory contains any .conf file. If it - -- does, something is wrong and we fail. Otherwise we assume that the - -- database is empty. - debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> ppr conf_dir - <> text ", checking if the database is empty" - db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) - <$> OsPath.getDirectoryContents conf_dir - if db_empty - then do - debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> ppr conf_dir <> text ", treating" - <+> text "package database as empty" - return [] - else - throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ show conf_dir ++ - " even though package database is not empty" - - - -- Single-file style package dbs have been deprecated for some time, but - -- it turns out that Cabal was using them in one place. So this is a - -- workaround to allow older Cabal versions to use this newer ghc. - -- We check if the file db contains just "[]" and if so, we look for a new - -- dir-style db in conf_file.d/, ie in a dir next to the given file. - -- We cannot just replace the file with a new dir style since Cabal still - -- assumes it's a file and tries to overwrite with 'writeFile'. - -- ghc-pkg also cooperates with this workaround. - tryReadOldFileStyleUnitInfo = do - content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" - direxists <- OsPath.doesDirectoryExist conf_dir - if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) - liftM Just (readDirStyleUnitInfo conf_dir) - else return (Just []) -- ghc-pkg will create it when it's updated - else return Nothing - -mungeUnitInfo :: OsPath -> OsPath - -> UnitInfo -> UnitInfo -mungeUnitInfo top_dir pkgroot = - mungeBytecodeLibFields - . mungeLibDirFields - . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) - -mungeLibDirFields :: UnitInfo -> UnitInfo -mungeLibDirFields pkg = - pkg { - unitLibraryDynDirs = case unitLibraryDynDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - --- | Default to using library-dirs if bytecode library dirs is not explicitly set. -mungeBytecodeLibFields :: UnitInfo -> UnitInfo -mungeBytecodeLibFields pkg = - pkg { - unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - -seqUnitInfo :: UnitInfo -> b -> b -seqUnitInfo ui b = - unitImportDirs ui `seqList` - unitIncludeDirs ui `seqList` - unitLibraryDirs ui `seqList` - unitLibraryBytecodeDirs ui `seqList` - unitExtDepFrameworkDirs ui `seq` - unitHaddockInterfaces ui `seq` - unitHaddockHTMLs ui `seqList` - unitLibraryDynDirs ui `seqList` - unitLibraryDirsStatic ui `seqList` - unitDepends ui `seqList` - unitExposedModules ui `seqList` - b - -evaluateUnitInfo :: UnitInfo -> IO UnitInfo -evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) - -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -1094,265 +625,6 @@ applyPackageFlag prec_map pkg_map unusable no_hide_others pkgs vm flag = Left ps -> Failed (PackageFlagErr flag ps) Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) --- | Like 'selectPackages', but doesn't return a list of unmatched --- packages. Furthermore, any packages it returns are *renamed* --- if the 'UnitArg' has a renaming associated with it. -findPackages :: UnitPrecedenceMap - -> UnitInfoMap - -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - [UnitInfo] -findPackages prec_map pkg_map arg pkgs unusable - = let ps = mapMaybe (finder arg) pkgs - in if null ps - then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) - (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps) - where - finder (PackageArg str) p - = if matchingStr str p - then Just p - else Nothing - finder (UnitIdArg uid) p - = case uid of - RealUnit (Definite iuid) - | iuid == unitId p - -> Just p - VirtUnit inst - | instUnitInstanceOf inst == unitId p - -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) - _ -> Nothing - -selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - ([UnitInfo], [UnitInfo]) -selectPackages prec_map arg pkgs unusable - = let matches = matching arg - (ps,rest) = partition matches pkgs - in if null ps - then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps, rest) - --- | Rename a 'UnitInfo' according to some module instantiation. -renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo -renameUnitInfo pkg_map insts conf = - let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map hsubst - new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) - in conf { - unitInstantiations = new_insts, - unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) - (unitExposedModules conf) - } - - --- A package named on the command line can either include the --- version, or just the name if it is unambiguous. -matchingStr :: String -> UnitInfo -> Bool -matchingStr str p - = str == unitPackageIdString p - || str == unitPackageNameString p - -matchingId :: UnitId -> UnitInfo -> Bool -matchingId uid p = uid == unitId p - -matching :: PackageArg -> UnitInfo -> Bool -matching (PackageArg str) = matchingStr str -matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid -matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case - --- | This sorts a list of packages, putting "preferred" packages first. --- See 'compareByPreference' for the semantics of "preference". -sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) - --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking --- which should be "active". Here is the order of preference: --- --- 1. First, prefer the latest version --- 2. If the versions are the same, prefer the package that --- came in the latest package database. --- --- Pursuant to #12518, we could change this policy to, for example, remove --- the version preference, meaning that we would always prefer the units --- in later unit database. -compareByPreference - :: UnitPrecedenceMap - -> UnitInfo - -> UnitInfo - -> Ordering -compareByPreference prec_map pkg pkg' - = case comparing unitPackageVersion pkg pkg' of - GT -> GT - EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) - , Just prec' <- lookupUniqMap prec_map (unitId pkg') - -- Prefer the unit from the later DB flag (i.e., higher - -- precedence) - -> compare prec prec' - | otherwise - -> EQ - LT -> LT - -comparing :: Ord a => (t -> a) -> t -> t -> Ordering -comparing f a b = f a `compare` f b - -pprFlag :: PackageFlag -> SDoc -pprFlag flag = case flag of - HidePackage p -> text "-hide-package " <> text p - ExposePackage doc _ _ -> text doc - -pprTrustFlag :: TrustFlag -> SDoc -pprTrustFlag flag = case flag of - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p - --- ----------------------------------------------------------------------------- --- Wired-in units --- --- See Note [Wired-in units] in GHC.Unit.Types - -type WiringMap = UniqMap UnitId UnitId -type UnwiringMap = UniqMap UnitId UnitId - -findWiredInUnits - :: Logger - -> UnitPrecedenceMap - -> [UnitInfo] -- database - -> VisibilityMap -- info on what units are visible - -- for wired in selection - -> IO WiringMap -- map from unit id to wired identity -findWiredInUnits logger prec_map pkgs vis_map = do - -- Now we must find our wired-in units, and rename them to - -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in units] in GHC.Unit.Types - let - matches :: UnitInfo -> UnitId -> Bool - pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) - - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. - -- - -- When choosing which package to map to a wired-in package - -- name, we try to pick the latest version of exposed packages. - -- However, if there are no exposed wired in packages available - -- (e.g. -hide-all-packages was used), we can't bail: we *have* - -- to assign a package for the wired-in package: so we try again - -- with hidden packages included to (and pick the latest - -- version). - -- - -- You can also override the default choice by using -ignore-package: - -- this works even when there is no exposed wired in package - -- available. - -- - findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) - findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] - where - all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] - - try ps = case sortByPreference prec_map ps of - p:_ -> Just <$> pick p - _ -> pure Nothing - - notfound = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " not found." - return Nothing - pick :: UnitInfo -> IO (UnitId, UnitInfo) - pick pkg = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " mapped to " - <> ppr (unitId pkg) - return (wired_pkg, pkg) - - - mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds - let - wired_in_pkgs = catMaybes mb_wired_in_pkgs - - wiredInMap :: UniqMap UnitId UnitId - wiredInMap = listToUniqMap - [ (unitId realUnitInfo, wiredInUnitId) - | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs - , not (unitIsIndefinite realUnitInfo) - ] - - return wiredInMap - -updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] -updateWiredInUnits wiredInMap knownInfos pkgs = - map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs - -updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo -updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = - let - upd_wired_in_pkg wiredInUnitId pkg = - pkg { unitId = wiredInUnitId - , unitInstanceOf = wiredInUnitId - -- every non instantiated unit is an instance of - -- itself (required by Backpack...) - -- - -- See Note [About units] in GHC.Unit - } - - upd_deps pkg = pkg { - unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), - unitExposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (unitExposedModules pkg) - } - in - case lookupUniqMap wiredInMap (unitId pkg) of - Just wiredIn -> - case lookupGlobalUnitInfoMap (GlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - --- Helper functions for rewiring Module and Unit. These --- rewrite Units of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. --- --- For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in GHC.Builtin.Names. - -upd_wired_in_mod :: WiringMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiringMap -> Unit -> Unit -upd_wired_in_uid wiredInMap u = case u of - HoleUnit -> HoleUnit - RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) - VirtUnit indef_uid -> - VirtUnit $ mkInstantiatedUnit - (instUnitInstanceOf indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) - -upd_wired_in :: WiringMap -> UnitId -> UnitId -upd_wired_in wiredInMap key - | Just key' <- lookupUniqMap wiredInMap key = key' - | otherwise = key - updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of @@ -1362,51 +634,6 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList w -- ---------------------------------------------------------------------------- --- | The reason why a unit is unusable. -data UnusableUnitReason - = -- | We ignored it explicitly using @-ignore-package@. - IgnoredWithFlag - -- | This unit transitively depends on a unit that was never present - -- in any of the provided databases. - | BrokenDependencies [UnitId] - -- | This unit transitively depends on a unit involved in a cycle. - -- Note that the list of 'UnitId' reports the direct dependencies - -- of this unit that (transitively) depended on the cycle, and not - -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [UnitId] - -- | This unit transitively depends on a unit which was ignored. - | IgnoredDependencies [UnitId] - -- | This unit transitively depends on a unit which was - -- shadowed by an ABI-incompatible unit. - | ShadowedDependencies [UnitId] - -instance Outputable UnusableUnitReason where - ppr IgnoredWithFlag = text "[ignored with flag]" - ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) - ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) - ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) - ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) - -type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) - -pprReason :: SDoc -> UnusableUnitReason -> SDoc -pprReason pref reason = case reason of - IgnoredWithFlag -> - pref <+> text "ignored due to an -ignore-package flag" - BrokenDependencies deps -> - pref <+> text "unusable due to missing dependencies:" $$ - nest 2 (hsep (map ppr deps)) - CyclicDependencies deps -> - pref <+> text "unusable due to cyclic dependencies:" $$ - nest 2 (hsep (map ppr deps)) - IgnoredDependencies deps -> - pref <+> text ("unusable because the -ignore-package flag was used to " ++ - "ignore at least one of its dependencies:") $$ - nest 2 (hsep (map ppr deps)) - ShadowedDependencies deps -> - pref <+> text "unusable due to shadowed dependencies:" $$ - nest 2 (hsep (map ppr deps)) - reportCycles :: Logger -> [SCC UnitInfo] -> IO () reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs where @@ -1416,193 +643,6 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs text "these packages are involved in a cycle:" $$ nest 2 (hsep (map (ppr . unitId) vs)) -reportUnusable :: Logger -> UnusableUnits -> IO () -reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) - where - report (ipid, (_, reason)) = - debugTraceMsg logger 2 $ - pprReason - (text "package" <+> ppr ipid <+> text "is") reason - --- ---------------------------------------------------------------------------- --- --- Utilities on the database --- - --- | A reverse dependency index, mapping an 'UnitId' to --- the 'UnitId's which have a dependency on it. -type RevIndex = UniqMap UnitId [UnitId] - --- | Compute the reverse dependency index of a unit database. -reverseDeps :: UnitInfoMap -> RevIndex -reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db - where - go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex - go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) - go' from r to = addToUniqMap_C (++) r to [from] - --- | Given a list of 'UnitId's to remove, a database, --- and a reverse dependency index (as computed by 'reverseDeps'), --- remove those units, plus any units which depend on them. --- Returns the pruned database, as well as a list of 'UnitInfo's --- that was removed. -removeUnits :: [UnitId] -> RevIndex - -> UnitInfoMap - -> (UnitInfoMap, [UnitInfo]) -removeUnits uids index m = go uids (m,[]) - where - go [] (m,pkgs) = (m,pkgs) - go (uid:uids) (m,pkgs) - | Just pkg <- lookupUniqMap m uid - = case lookupUniqMap index uid of - Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) - | otherwise - = go uids (m,pkgs) - --- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' --- which correspond to units that do not exist in the index. -depsNotAvailable :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) - --- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in --- 'unitAbiDepends' which correspond to units that do not exist, OR have --- mismatching ABIs. -depsAbiMismatch :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg - where - abiMatch (dep_uid, abi) - | Just dep_pkg <- lookupUniqMap pkg_map dep_uid - = unitAbiHash dep_pkg == abi - | otherwise - = False - --- ----------------------------------------------------------------------------- --- Ignore units - -ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits -ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) - where - doit (IgnorePackage str) = - case partition (matchingStr str) pkgs of - (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) - | p <- ps ] - -- missing unit is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. - --- ---------------------------------------------------------------------------- --- --- Merging databases --- - --- | For each unit, a mapping from uid -> i indicates that this --- unit was brought into GHC by the ith @-package-db@ flag on --- the command line. We use this mapping to make sure we prefer --- units that were defined later on the command line, if there --- is an ambiguity. -type UnitPrecedenceMap = UniqMap UnitId Int - --- | Given a list of databases, merge them together, where --- units with the same unit id in later databases override --- earlier ones. This does NOT check if the resulting database --- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: Logger -> [UnitDatabase UnitId] - -> IO (UnitInfoMap, UnitPrecedenceMap) -mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] - where - merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do - debugTraceMsg logger 2 $ - text "loading package database" <+> ppr db_path - when (logVerbAtLeast logger 2) $ - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" - return (pkg_map', prec_map') - where - db_map = mk_pkg_map db - mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) - - -- The set of UnitIds which appear in both db and pkgs. These are the - -- ones that get overridden. Compute this just to give some - -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) - - -- Now merge the sets together (NB: in case of duplicate, - -- first argument preferred) - pkg_map' :: UnitInfoMap - pkg_map' = pkg_map `plusUniqMap` db_map - - prec_map' :: UnitPrecedenceMap - prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) - --- | Validates a database, removing unusable units from it --- (this includes removing units that the user has explicitly --- ignored.) Our general strategy: --- --- 1. Remove all broken units (dangling dependencies) --- 2. Remove all units that are cyclic --- 3. Apply ignore flags --- 4. Remove all units which have deps with mismatching ABIs --- -validateDatabase :: UnitConfig -> UnitInfoMap - -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) -validateDatabase cfg pkg_map1 = - (pkg_map5, unusable, sccs) - where - ignore_flags = reverse (unitConfigFlagsIgnored cfg) - - -- Compute the reverse dependency index - index = reverseDeps pkg_map1 - - -- Helper function - mk_unusable mk_err dep_matcher m uids = - listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids - ] - - -- Find broken units - directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (nonDetEltsUniqMap pkg_map1) - (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 - unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken - - -- Find recursive units - sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) - | pkg <- nonDetEltsUniqMap pkg_map2 ] - getCyclicSCC (CyclicSCC vs) = map unitId vs - getCyclicSCC (AcyclicSCC _) = [] - (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 - unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic - - -- Apply ignore flags - directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) - (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 - unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored - - -- Knock out units whose dependencies don't agree with ABI - -- (i.e., got invalidated due to shadowing) - directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (nonDetEltsUniqMap pkg_map4) - (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 - unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - - -- combine all unusables. The order is important for shadowing. - -- plusUniqMapList folds using plusUFM which is right biased (opposite of - -- Data.Map.union) so the head of the list should be the least preferred - unusable = plusUniqMapList [ unusable_shadowed - , unusable_cyclic - , unusable_broken - , unusable_ignored - , directly_ignored - ] -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our unit @@ -1667,7 +707,7 @@ mkUnitState logger unit_index cfg = do we build a mapping saying what every in scope module name points to. -} - raw_dbs <- readUnitDatabases logger cfg + raw_dbs <- readUnitDatabases logger (initUnitDbConfig cfg) -- distrust all units if the flag is set let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) @@ -1697,7 +737,7 @@ mkUnitState logger unit_index cfg = do -- Now that we've merged everything together, prune out unusable -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + let (pkg_map2, unusable, sccs) = validateDatabase (unitConfigFlagsIgnored cfg) pkg_map1 reportCycles logger sccs reportUnusable logger unusable @@ -1781,9 +821,9 @@ mkUnitState logger unit_index cfg = do modifyIORef' unit_index (setWireMap wmap) pure wmap else do - pure $ ui_wireMap ui + pure $ wiringMap ui - let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + let all_pkgs = updateWiredInUnits wireMap (globalUnits ui) pkgs1 (new_pkgs, _pkgs_set) = partitionEithers all_pkgs modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (wireMap, map (either id id) all_pkgs) @@ -1859,7 +899,7 @@ mkUnitState logger unit_index cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db vis_map + let mod_map1 = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable mod_map = mod_map2 `plusUniqMap` mod_map1 @@ -1872,15 +912,24 @@ mkUnitState logger unit_index cfg = do , trustedUnits = trusted , distrustedUnits = distrusted , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db plugin_vis_map , packageNameMap = pkgname_map - -- , wireMap = wired_map - -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } return state +initUnitDbConfig :: UnitConfig -> UnitDbConfig +initUnitDbConfig uc = UnitDbConfig + { unitDbConfigFlagsDB = unitConfigFlagsDB uc + , unitDbConfigProgramName = unitConfigProgramName uc + , unitDbConfigDBName = unitConfigDBName uc + , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc + , unitDbConfigGlobalDB = unitConfigGlobalDB uc + , unitDbConfigGHCDir = unitConfigGHCDir uc + , unitDbConfigDBCache = unitConfigDBCache uc + } + selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True selectHptFlag _ _ = False @@ -1893,158 +942,6 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags -- MP: This does not yet support thinning/renaming go cur _ = cur - --- | Given a wired-in 'Unit', "unwire" it into the 'Unit' --- that it was recorded as in the package database. -unwireUnit :: UnitIndex -> Unit -> Unit -unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid) -unwireUnit _ uid = uid - --- ----------------------------------------------------------------------------- --- | Makes the mapping from ModuleName to package info - --- Slight irritation: we proceed by leafing through everything --- in the installed package database, which makes handling indefinite --- packages a bit bothersome. - -mkModuleNameProvidersMap - :: Logger - -> UnitConfig - -> UnitInfoMap - -> VisibilityMap - -> ModuleNameProvidersMap -mkModuleNameProvidersMap logger cfg pkg_map vis_map = - -- What should we fold on? Both situations are awkward: - -- - -- * Folding on the visibility map means that we won't create - -- entries for packages that aren't mentioned in vis_map - -- (e.g., hidden packages, causing #14717) - -- - -- * Folding on pkg_map is awkward because if we have an - -- Backpack instantiation, we need to possibly add a - -- package from pkg_map multiple times to the actual - -- ModuleNameProvidersMap. Also, we don't really want - -- definite package instantiations to show up in the - -- list of possibilities. - -- - -- So what will we do instead? We'll extend vis_map with - -- entries for every definite (for non-Backpack) and - -- indefinite (for Backpack) package, so that we get the - -- hidden entries we need. - nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended - where - vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map - - default_vis = listToUniqMap - [ (mkUnit pkg, mempty) - | (_, pkg) <- nonDetUniqMapToList pkg_map - -- Exclude specific instantiations of an indefinite - -- package - , unitIsIndefinite pkg || null (unitInstantiations pkg) - ] - - emptyMap = emptyUniqMap - setOrigins m os = fmap (const os) m - extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap - = addListTo modmap theBindings - where - pkg = unit_lookup uid - - theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - theBindings = newBindings b rns - - newBindings :: Bool - -> [(ModuleName, ModuleName)] - -> [(ModuleName, UniqMap Module ModuleOrigin)] - newBindings e rns = es e ++ hiddens ++ map rnBinding rns - - rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, UniqMap Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) - where origEntry = case lookupUFM esmap orig of - Just r -> r - Nothing -> throwGhcException (CmdLineError (renderWithContext - (log_default_user_context (logFlags logger)) - (text "package flag: could not find module name" <+> - ppr orig <+> text "in package" <+> ppr pk))) - - es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] - es e = do - (m, exposedReexport) <- exposed_mods - let (pk', m', origin') = - case exposedReexport of - Nothing -> (pk, m, fromExposedModules e) - Just (Module pk' m') -> - (pk', m', fromReexportedModules e pkg) - return (m, mkModMap pk' m' origin') - - esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) - esmap = listToUFM (es False) -- parameter here doesn't matter, orig will - -- be overwritten - - hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] - - pk = mkUnit pkg - unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map uid - `orElse` pprPanic "unit_lookup" (ppr uid) - - exposed_mods = unitExposedModules pkg - hidden_mods = unitHiddenModules pkg - --- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. -mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap -mkUnusableModuleNameProvidersMap unusables = - nonDetFoldUniqMap extend_modmap emptyUniqMap unusables - where - extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings - where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - bindings = exposed ++ hidden - - origin_reexport = ModUnusable (UnusableUnit unit reason True) - origin_normal = ModUnusable (UnusableUnit unit reason False) - unit = mkUnit unit_info - - exposed = map get_exposed exposed_mods - hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] - - -- with re-exports, c:Foo can be reexported from two (or more) - -- unusable packages: - -- Foo -> a:Foo (unusable reason A) -> c:Foo - -- -> b:Foo (unusable reason B) -> c:Foo - -- - -- We must be careful to not record the following (#21097): - -- Foo -> c:Foo (unusable reason A) - -- -> c:Foo (unusable reason B) - -- But: - -- Foo -> a:Foo (unusable reason A) - -- -> b:Foo (unusable reason B) - -- - get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) - get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) - -- in the reexport case, we create a virtual module that doesn't - -- exist but we don't care as it's only used as a key in the map. - - exposed_mods = unitExposedModules unit_info - hidden_mods = unitHiddenModules unit_info - --- | Add a list of key/value pairs to a nested map. --- --- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks --- when reloading modules in GHCi (see #4029). This ensures that each --- value is forced before installing into the map. -addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) - => UniqMap k1 (UniqMap k2 a) - -> [(k1, UniqMap k2 a)] - -> UniqMap k1 (UniqMap k2 a) -addListTo = foldl' merge - where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v - --- | Create a singleton module mapping -mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin -mkModMap pkg mod = unitUniqMap (mkModule pkg mod) - - -- ----------------------------------------------------------------------------- -- Package Utils @@ -2185,7 +1082,7 @@ lookupModuleWithSuggestions' pkgs mod_map name mb_pn suggestions = fuzzyLookup (moduleNameString name) all_mods all_mods :: [(String, ModuleSuggestion)] -- All modules - all_mods = sortBy (comparing fst) $ + all_mods = sortOn fst $ [ (moduleNameString m, suggestion) | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) @@ -2199,78 +1096,7 @@ listVisibleModuleNames state = map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) where visible (_, ms) = anyUniqMap originVisible ms --- | Takes a list of UnitIds (and their "parent" dependency, used for error --- messages), and returns the list with dependencies included, in reverse --- dependency order (a units appears before those it depends on). -closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps - --- | Similar to closeUnitDeps but takes a list of already loaded units as an --- additional argument. -closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps --- | Add a UnitId and those it depends on (recursively) to the given list of --- UnitIds if they are not already in it. Return a list in reverse dependency --- order (a unit appears before those it depends on). --- --- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). --- It it's not found, the optional parent unit is used to return a more precise --- error message ("dependency of <PARENT>"). -add_unit :: UnitInfoMap - -> [UnitId] - -> UnitId - -> Maybe UnitId - -> MaybeErr UnitErr [UnitId] -add_unit pkg_map ps p mb_parent - | p `elem` ps = return ps -- Check if we've already added this unit - | otherwise = case lookupUnitId' pkg_map p of - Nothing -> Failed (CloseUnitErr p mb_parent) - Just info -> do - -- Add the unit's dependents also - ps' <- foldM add_unit_key ps (unitDepends info) - return (p : ps') - where - add_unit_key xs key - = add_unit pkg_map xs key (Just p) - -data UnitErr - = CloseUnitErr !UnitId !(Maybe UnitId) - | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] - | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] - -mayThrowUnitErr :: MaybeErr UnitErr a -> IO a -mayThrowUnitErr = \case - Failed e -> throwGhcExceptionIO - $ CmdLineError - $ renderWithContext defaultSDocContext - $ withPprStyle defaultUserStyle - $ ppr e - Succeeded a -> return a - -instance Outputable UnitErr where - ppr = \case - CloseUnitErr p mb_parent - -> (text "unknown unit:" <+> ppr p) - <> case mb_parent of - Nothing -> Outputable.empty - Just parent -> space <> parens (text "dependency of" - <+> ftext (unitIdFS parent)) - PackageFlagErr flag reasons - -> flag_err (pprFlag flag) reasons - - TrustFlagErr flag reasons - -> flag_err (pprTrustFlag flag) reasons - where - flag_err flag_doc reasons = - text "cannot satisfy " - <> flag_doc - <> (if null reasons then Outputable.empty else text ": ") - $$ nest 4 (vcat (map ppr_reason reasons) $$ - text "(use -v for more information)") - - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement. @@ -2328,37 +1154,23 @@ pprUnitsSimple ue = pprUnitsWith pprIPI ue t = if isUnitInfoTrusted ue ipi then text "T" else text " " in e <> t <> text " " <> ftext i --- | Show the mapping of modules to where they come from. -pprModuleMap :: ModuleNameProvidersMap -> SDoc -pprModuleMap mod_map = - vcat (map pprLine (nonDetUniqMapToList mod_map)) - where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) - pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc - pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) - | otherwise = ppr m' <+> parens (ppr o) +-- | Print unit-ids with UnitInfo found in the given UnitState +pprWithUnitState :: UnitState -> SDoc -> SDoc +pprWithUnitState state = updSDocContext (\ctx -> ctx + { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) + }) + +-- | Print raw unit-ids, without removing the hash +pprRawUnitIds :: SDoc -> SDoc +pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) fsPackageName :: UnitInfo -> FastString fsPackageName info = fs where PackageName fs = unitPackageName info --- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. -instUnitToUnit :: InstantiatedUnit -> Unit -instUnitToUnit iuid = - -- NB: suppose that we want to compare the instantiated - -- unit p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- VirtUnit, they won't compare equal; only - -- after improvement will the equality hold. - VirtUnit iuid - - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module +-- ----------------------------------------------------------------------------- +-- Module renaming -- | Substitutes holes in a 'Module'. NOT suitable for being called -- directly on a 'nameModule', see Note [Representation of module/name variables]. @@ -2374,44 +1186,19 @@ renameHoleModule state = renameHoleModule' (unitInfoMap state) renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit renameHoleUnit state = renameHoleUnit' (unitInfoMap state) --- | Like 'renameHoleModule', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnit' pkg_map env (moduleUnit m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = <Blah>, that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit -renameHoleUnit' pkg_map env uid = - case uid of - (VirtUnit - InstantiatedUnit{ instUnitInstanceOf = cid - , instUnitInsts = insts - , instUnitHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) - then uid - else mkVirtUnit cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - -- | Injects an 'InstantiatedModule' to 'Module' (see also -- 'instUnitToUnit'. instModuleToModule :: InstantiatedModule -> Module instModuleToModule (Module iuid mod_name) = mkModule (instUnitToUnit iuid) mod_name --- | Print unit-ids with UnitInfo found in the given UnitState -pprWithUnitState :: UnitState -> SDoc -> SDoc -pprWithUnitState state = updSDocContext (\ctx -> ctx - { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) - }) - --- | Print raw unit-ids, without removing the hash -pprRawUnitIds :: SDoc -> SDoc -pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) +-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. +instUnitToUnit :: InstantiatedUnit -> Unit +instUnitToUnit iuid = + -- NB: suppose that we want to compare the instantiated + -- unit p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- VirtUnit, they won't compare equal; only + -- after improvement will the equality hold. + VirtUnit iuid ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -1,6 +1,3 @@ module GHC.Unit.State where data UnitState -data ModuleSuggestion -data ModuleOrigin -data UnusableUnit ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -578,7 +578,7 @@ had used @-ignore-package@). The affected packages are compiled with, e.g., @-this-unit-id base@, so that the symbols in the object files have the unversioned unit id in their name. -Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. +Make sure you change 'wiredInUnitIds' if you add an entry here. -} ===================================== compiler/ghc.cabal.in ===================================== @@ -968,6 +968,14 @@ Library GHC.Unit.Env GHC.Unit.External GHC.Unit.External.Database + GHC.Unit.External.Index + GHC.Unit.External.Substitution + GHC.Unit.External.Query + GHC.Unit.External.ModuleOrigin + GHC.Unit.External.Providers + GHC.Unit.External.Validate + GHC.Unit.External.Visibility + GHC.Unit.External.Wired GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== testsuite/tests/driver/T26423/Hello.hs ===================================== @@ -0,0 +1,6 @@ +module Hello where + +import Tes + +hello :: String +hello = "Imported from dependency 'test':" <> show test ===================================== testsuite/tests/driver/T26423/Makefile ===================================== @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +LOCAL_PKGCONF=test.package.conf.d + +clean: + rm -f test/*.o test/*.hi *.o *.hi + rm -rf $(LOCAL_PKGCONF) + +.PHONY: T26423 +T26423: + @rm -rf $(LOCAL_PKGCONF) + "$(TEST_HC)" $(TEST_HC_OPTS) -this-unit-id test-1.0 -c test/Test.hs + "$(GHC_PKG)" init $(LOCAL_PKGCONF) + "$(GHC_PKG)" --no-user-package-db -f $(LOCAL_PKGCONF) register test/test.pkg -v0 + "$(TEST_HC)" $(TEST_HC_OPTS) -package-db $(LOCAL_PKGCONF)/ -package ghc T26423.hs + ./T26423 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" ===================================== testsuite/tests/driver/T26423/T26423.hs ===================================== @@ -0,0 +1,38 @@ +import GHC +import GHC.Data.OsPath +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Unit.Env +import GHC.Plugins +import GHC.Prelude + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import System.Environment + +-- No sign of new db in output: +-- "Just [DB: <libdir>/package.conf.d]" +bad :: IO () +bad = do + libdir:_ <- getArgs + runGhcT (Just libdir) $ do + df <- getSessionDynFlags + -- The first call simulates having modified the DynFlags once before + setSessionDynFlags df + setSessionDynFlags $ + df { packageDBFlags = PackageDB (PkgDbPath $ os "test.package.conf.d") : (packageDBFlags df) + , packageFlags = [ExposePackage "testpkg" (PackageArg "testpkg") (ModRenaming True [])] + } + + hsc_env <- getSession + t <- guessTarget "Heo.hs" Nothing Nothing + setTargets [t] + r <- load LoadAllTargets + when (failed r) $ do + liftIO $ throwIO $ ErrorCall "Failed to load the target" + + execStmt "hello" execOptions + liftIO $ putStrLn "Successfully compiled Hello.hs" + +main = bad >>= print ===================================== testsuite/tests/driver/T26423/all.T ===================================== @@ -0,0 +1 @@ +test('T26423', [extra_files(['Hello.hs', 'test/'])], makefile_test, []) ===================================== testsuite/tests/driver/T26423/test/Test.hs ===================================== @@ -0,0 +1,4 @@ +module Test where + +test :: Int +test = 42 ===================================== testsuite/tests/driver/T26423/test/test.pkg ===================================== @@ -0,0 +1,8 @@ +name: test +version: 1.0 +id: test-1.0 +key: test-1.0 +exposed-modules: Test +import-dirs: ${pkgroot}/test +library-dirs: ${pkgroot}/test +exposed: True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cffe0d451d67c72c2b1cfc62e36f70… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cffe0d451d67c72c2b1cfc62e36f70… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/external-unit-db-cache] 2 commits: Split State.hs into many more modules
by Hannes Siebenhandl (＠fendor) 16 Jul '26

16 Jul '26

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: b454642c by fendor at 2026-07-16T16:07:01+02:00 Split State.hs into many more modules - - - - - cffe0d45 by fendor at 2026-07-16T16:07:29+02:00 Add regression test for #26423 - - - - - 20 changed files: - compiler/GHC/Unit/External/Database.hs - + compiler/GHC/Unit/External/Index.hs - + compiler/GHC/Unit/External/ModuleOrigin.hs - + compiler/GHC/Unit/External/Providers.hs - + compiler/GHC/Unit/External/Query.hs - + compiler/GHC/Unit/External/Substitution.hs - + compiler/GHC/Unit/External/Validate.hs - + compiler/GHC/Unit/External/Visibility.hs - + compiler/GHC/Unit/External/Wired.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/State.hs-boot - compiler/GHC/Unit/Types.hs - compiler/ghc.cabal.in - + testsuite/tests/driver/T26423/Hello.hs - + testsuite/tests/driver/T26423/Makefile - + testsuite/tests/driver/T26423/T26423.hs - + testsuite/tests/driver/T26423/all.T - + testsuite/tests/driver/T26423/test/Test.hs - + testsuite/tests/driver/T26423/test/test.pkg Changes: ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -14,18 +14,52 @@ module GHC.Unit.External.Database ( lookupExternalUnitDatabases, -- * UnitDatabase (..), + -- * + mergeDatabases, + UnitPrecedenceMap, + sortByPreference, + compareByPreference, + -- * + UnitDbConfig(..), + readOrGetUnitDatabase, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, ) where import GHC.Prelude -import GHC.Data.OsPath -import GHC.Unit.Info -import GHC.Utils.Outputable +import GHC.Driver.DynFlags -import Data.IORef (IORef) +import Control.Monad +import Data.Char +import Data.IORef import Data.IORef qualified as IORef -import Data.Map.Strict +import Data.List (partition, sortBy) +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Ord +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST +import GHC.Platform.ArchOS +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import System.Directory +import System.Environment (getEnv) +import System.FilePath as FilePath -- ---------------------------------------------------------------------------- -- ExternalUnitDatabaseCache @@ -102,3 +136,274 @@ data UnitDatabase unit = UnitDatabase instance (Outputable u) => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each unit, a mapping from uid -> i indicates that this +-- unit was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- units that were defined later on the command line, if there +-- is an ambiguity. +type UnitPrecedenceMap = UniqMap UnitId Int + +-- | Given a list of databases, merge them together, where +-- units with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: Logger -> [UnitDatabase UnitId] + -> IO (UnitInfoMap, UnitPrecedenceMap) +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] + where + merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do + debugTraceMsg logger 2 $ + text "loading package database" <+> ppr db_path + when (logVerbAtLeast logger 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set UnitId + override_set = Set.intersection (nonDetUniqMapToKeySet db_map) + (nonDetUniqMapToKeySet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: UnitInfoMap + pkg_map' = pkg_map `plusUniqMap` db_map + + prec_map' :: UnitPrecedenceMap + prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +data UnitDbConfig = UnitDbConfig + { unitDbConfigFlagsDB :: [PackageDBFlag] + , unitDbConfigProgramName :: String + , unitDbConfigDBName :: FilePath + , unitDbConfigPlatformArchOS :: ArchOS + , unitDbConfigGlobalDB :: FilePath + , unitDbConfigGHCDir :: FilePath + , unitDbConfigDBCache :: ExternalUnitDatabaseCache UnitId + } + +readUnitDatabases :: Logger -> UnitDbConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readOrGetUnitDatabase logger cfg) confs + + +getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg) + let pkgconf = dir </> unitDbConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. +readOrGetUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger cfg conf_file = + readExternalUnitDatabase (unitDbConfigDBCache cfg) conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase (unitDbConfigDBCache cfg) new_db + pure new_db + Just db -> + pure db + +-- | Read the 'UnitDatabase' at the given location. +readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do + isdir <- OsPath.doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- OsPath.doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ show conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ show conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) + pkgroot = OsPath.takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) + proto_pkg_configs + -- + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 + where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename + if cache_exists + then do + debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg logger 2 $ text "There is no package.cache in" + <+> ppr conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg logger 3 $ text "There are no .conf files in" + <+> ppr conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ show conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +mungeUnitInfo :: OsPath -> OsPath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeBytecodeLibFields + . mungeLibDirFields + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) + +mungeLibDirFields :: UnitInfo -> UnitInfo +mungeLibDirFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -0,0 +1,198 @@ +module GHC.Unit.External.Index ( + -- * + UnitIndex, + initUnitIndex, + wiringMap, + unwiringMap, + globalUnits, + setWireMap, + isWireMapEmpty, + addUnitInfoMap, + + -- * + GlobalUnitInfoMap, + lookupGlobalUnitInfoMap, + mkGlobalUnitKey, + + -- * + GlobalUnitKey, + globalUnitKeyFromUnitInfo, + + -- * + updateWiredInUnits, + updateWiredInUnitsInUnitInfo, + upd_wired_in_mod, + -- * + unwireUnit, +) where + +import GHC.Prelude + +import GHC.Data.ShortText qualified as ST +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Wired +import GHC.Unit.Info +import GHC.Unit.Types + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Utils.Outputable + +-- ---------------------------------------------------------------------------- +-- UnitIndex +-- ---------------------------------------------------------------------------- + +data UnitIndex = UnitIndex + { ui_wireMap :: !WiringMap + -- ^ A mapping from database unit keys to wired in unit ids. + , ui_unwireMap :: !UnwiringMap + -- ^ A mapping from wired in unit ids to unit keys from the database. + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: document + } + +wiringMap :: UnitIndex -> UnwiringMap +wiringMap = ui_wireMap + +unwiringMap :: UnitIndex -> WiringMap +unwiringMap = ui_unwireMap + +globalUnits :: UnitIndex -> GlobalUnitInfoMap +globalUnits = ui_unitInfoMap + +initUnitIndex :: UnitIndex +initUnitIndex = UnitIndex + { ui_wireMap = emptyUniqMap + , ui_unwireMap = emptyUniqMap + , ui_unitInfoMap = emptyUniqMap + } + +setWireMap :: WiringMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + } + +isWireMapEmpty :: UnitIndex -> Bool +isWireMapEmpty unit_index = + isNullUniqMap (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) + } + where + globalMap :: GlobalUnitInfoMap + globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map + +-- ---------------------------------------------------------------------------- +-- GlobalUnitInfoMap +-- ---------------------------------------------------------------------------- + +type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) + +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = + case lookupUniqMap globalMap uid of + Nothing -> Nothing + Just sameUnitId -> Map.lookup abiHash sameUnitId + +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap +mkGlobalUnitInfoMap unitInfos = + listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos + +-- ---------------------------------------------------------------------------- +-- GlobalUnitKey +-- ---------------------------------------------------------------------------- + +data GlobalUnitKey = + GlobalUnitKey + !UnitId -- ^ Unit Id of the 'UnitInfo' + !ST.ShortText + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) + +mkGlobalUnitKey :: UnitId -> ST.ShortText -> GlobalUnitKey +mkGlobalUnitKey = GlobalUnitKey + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit' +-- that it was recorded as in the package database. +unwireUnit :: UnitIndex -> Unit -> Unit +unwireUnit state uid@(RealUnit (Definite def_uid)) = + maybe uid (RealUnit . Definite) (lookupUniqMap (unwiringMap state) def_uid) +unwireUnit _ uid = uid + +updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_wired_in_pkg wiredInUnitId pkg = + pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupUniqMap wiredInMap (unitId pkg) of + Just wiredIn -> + case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +upd_wired_in_mod :: WiringMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiringMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WiringMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupUniqMap wiredInMap key = key' + | otherwise = key ===================================== compiler/GHC/Unit/External/ModuleOrigin.hs ===================================== @@ -0,0 +1,110 @@ +module GHC.Unit.External.ModuleOrigin ( + ModuleOrigin(..), + fromExposedModules, + fromReexportedModules, + fromFlag, + originVisible, + originEmpty, +) where + +import GHC.Prelude +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Data.Semigroup as Semigroup + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) rhs)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + g Nothing x = x + g x Nothing = x + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False ===================================== compiler/GHC/Unit/External/Providers.hs ===================================== @@ -0,0 +1,186 @@ +module GHC.Unit.External.Providers ( + ModuleNameProvidersMap, + pprModuleMap, + mkModuleNameProvidersMap, + mkUnusableModuleNameProvidersMap, +) where + +import GHC.Prelude + +import GHC.Data.Maybe +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Query +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.Info +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' + +type ModuleNameProvidersMap = + UniqMap ModuleName (UniqMap Module ModuleOrigin) + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (nonDetUniqMapToList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from ModuleName to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: Logger + -> Bool + -> UnitInfoMap + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap logger allowVirtualUnits pkg_map vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_map is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_map multiple times to the actual + -- ModuleNameProvidersMap. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended + where + vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map + + default_vis = listToUniqMap + [ (mkUnit pkg, mempty) + | (_, pkg) <- nonDetUniqMapToList pkg_map + -- Exclude specific instantiations of an indefinite + -- package + , unitIsIndefinite pkg || null (unitInstantiations pkg) + ] + + emptyMap = emptyUniqMap + setOrigins m os = fmap (const os) m + extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, UniqMap Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, UniqMap Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (renderWithContext + (log_default_user_context (logFlags logger)) + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + (pk', m', fromReexportedModules e pkg) + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = mkUnit pkg + unit_lookup uid = lookupUnit' allowVirtualUnits pkg_map uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = unitExposedModules pkg + hidden_mods = unitHiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap unusables = + nonDetFoldUniqMap extend_modmap emptyUniqMap unusables + where + extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings + where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin_reexport = ModUnusable (UnusableUnit unit reason True) + origin_normal = ModUnusable (UnusableUnit unit reason False) + unit = mkUnit unit_info + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] + + -- with re-exports, c:Foo can be reexported from two (or more) + -- unusable packages: + -- Foo -> a:Foo (unusable reason A) -> c:Foo + -- -> b:Foo (unusable reason B) -> c:Foo + -- + -- We must be careful to not record the following (#21097): + -- Foo -> c:Foo (unusable reason A) + -- -> c:Foo (unusable reason B) + -- But: + -- Foo -> a:Foo (unusable reason A) + -- -> b:Foo (unusable reason B) + -- + get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) + get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) + -- in the reexport case, we create a virtual module that doesn't + -- exist but we don't care as it's only used as a key in the map. + + exposed_mods = unitExposedModules unit_info + hidden_mods = unitHiddenModules unit_info + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) + => UniqMap k1 (UniqMap k2 a) + -> [(k1, UniqMap k2 a)] + -> UniqMap k1 (UniqMap k2 a) +addListTo = foldl' merge + where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v + +-- | Create a singleton module mapping +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin +mkModMap pkg mod = unitUniqMap (mkModule pkg mod) ===================================== compiler/GHC/Unit/External/Query.hs ===================================== @@ -0,0 +1,41 @@ +module GHC.Unit.External.Query ( + -- * + lookupUnit', + lookupUnitId', +) where + +import GHC.Prelude + +import GHC.Types.Unique.Map +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Module + +-- | A more specialized interface, which doesn't require a 'UnitState' (so it +-- can be used while we're initializing 'DynFlags') +-- +-- Parameters: +-- * a boolean specifying whether or not to look for on-the-fly renamed interfaces +-- * a 'UnitInfoMap' +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map u = case u of + HoleUnit -> error "Hole unit" + RealUnit i -> lookupUniqMap pkg_map (unDefinite i) + VirtUnit i + | allowOnTheFlyInst + -> -- lookup UnitInfo of the indefinite unit to be instantiated and + -- instantiate it on-the-fly + fmap (renameUnitInfo pkg_map (instUnitInsts i)) + (lookupUniqMap pkg_map (instUnitInstanceOf i)) + + | otherwise + -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite + -- units. Even if they are real, installed units, they can't use the + -- `RealUnit` constructor (it is reserved for definite units) so we use + -- the `VirtUnit` constructor. + lookupUniqMap pkg_map (virtualUnitId i) + + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnitId' db uid = lookupUniqMap db uid ===================================== compiler/GHC/Unit/External/Substitution.hs ===================================== @@ -0,0 +1,61 @@ +module GHC.Unit.External.Substitution ( + -- * + ShHoleSubst, + renameHoleModule', + renameHoleUnit', + renameUnitInfo, +) where + +import GHC.Prelude + +import GHC.Unit.Module +import GHC.Unit.Info +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.DSet + +-- ----------------------------------------------------------------------------- +-- Module renaming + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Rename a 'UnitInfo' according to some module instantiation. +renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) + in conf { + unitInstantiations = new_insts, + unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (unitExposedModules conf) + } + + +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnit' pkg_map env (moduleUnit m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = <Blah>, that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map env uid = + case uid of + (VirtUnit + InstantiatedUnit{ instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + else mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid ===================================== compiler/GHC/Unit/External/Validate.hs ===================================== @@ -0,0 +1,384 @@ +module GHC.Unit.External.Validate ( + validateDatabase, + + findPackages, + selectPackages, + + UnusableUnits, + reportUnusable, + + UnusableUnit(..), + + UnusableUnitReason(..), + pprReason, + + UnitErr(..), + mayThrowUnitErr, + closeUnitDeps, + closeUnitDeps', + ignoreUnits, + pprFlag, +) where + +import GHC.Prelude + +import Control.Monad +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (partition) +import GHC.Data.Maybe +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.External.Database +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Outputable qualified as Outputable +import GHC.Utils.Panic + +-- ----------------------------------------------------------------------------- +-- Database validation + +-- | Validates a database, removing unusable units from it +-- (this includes removing units that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken units (dangling dependencies) +-- 2. Remove all units that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all units which have deps with mismatching ABIs +-- +validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap + -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) +validateDatabase flagsIgnored pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse flagsIgnored -- (unitConfigFlagsIgnored cfg) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids + ] + + -- Find broken units + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (nonDetEltsUniqMap pkg_map1) + (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive units + sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) + | pkg <- nonDetEltsUniqMap pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) + (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out units whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (nonDetEltsUniqMap pkg_map4) + (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + -- combine all unusables. The order is important for shadowing. + -- plusUniqMapList folds using plusUFM which is right biased (opposite of + -- Data.Map.union) so the head of the list should be the least preferred + unusable = plusUniqMapList [ unusable_shadowed + , unusable_cyclic + , unusable_broken + , unusable_ignored + , directly_ignored + ] + + +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) + +-- | A unusable unit module origin +data UnusableUnit = UnusableUnit + { uuUnit :: !Unit -- ^ Unusable unit + , uuReason :: !UnusableUnitReason -- ^ Reason + , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? + } + +-- | The reason why a unit is unusable. +data UnusableUnitReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This unit transitively depends on a unit that was never present + -- in any of the provided databases. + | BrokenDependencies [UnitId] + -- | This unit transitively depends on a unit involved in a cycle. + -- Note that the list of 'UnitId' reports the direct dependencies + -- of this unit that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [UnitId] + -- | This unit transitively depends on a unit which was ignored. + | IgnoredDependencies [UnitId] + -- | This unit transitively depends on a unit which was + -- shadowed by an ABI-incompatible unit. + | ShadowedDependencies [UnitId] + +instance Outputable UnusableUnitReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +pprReason :: SDoc -> UnusableUnitReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportUnusable :: Logger -> UnusableUnits -> IO () +reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg logger 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ----------------------------------------------------------------------------- +-- Package Finding + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: UnitPrecedenceMap + -> UnitInfoMap + -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + [UnitInfo] +findPackages prec_map pkg_map arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if matchingStr str p + then Just p + else Nothing + finder (UnitIdArg uid) p + = case uid of + RealUnit (Definite iuid) + | iuid == unitId p + -> Just p + VirtUnit inst + | instUnitInstanceOf inst == unitId p + -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) + _ -> Nothing + +selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- ----------------------------------------------------------------------------- +-- Ignore units + +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing unit is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- ---------------------------------------------------------------------------- +-- +-- Closures +-- + + +-- | Takes a list of UnitIds (and their "parent" dependency, used for error +-- messages), and returns the list with dependencies included, in reverse +-- dependency order (a units appears before those it depends on). +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps + +-- | Similar to closeUnitDeps but takes a list of already loaded units as an +-- additional argument. +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps + +-- | Add a UnitId and those it depends on (recursively) to the given list of +-- UnitIds if they are not already in it. Return a list in reverse dependency +-- order (a unit appears before those it depends on). +-- +-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). +-- It it's not found, the optional parent unit is used to return a more precise +-- error message ("dependency of <PARENT>"). +add_unit :: UnitInfoMap + -> [UnitId] + -> UnitId + -> Maybe UnitId + -> MaybeErr UnitErr [UnitId] +add_unit pkg_map ps p mb_parent + | p `elem` ps = return ps -- Check if we've already added this unit + | otherwise = case lookupUnitId' pkg_map p of + Nothing -> Failed (CloseUnitErr p mb_parent) + Just info -> do + -- Add the unit's dependents also + ps' <- foldM add_unit_key ps (unitDepends info) + return (p : ps') + where + add_unit_key xs key + = add_unit pkg_map xs key (Just p) +data UnitErr + = CloseUnitErr !UnitId !(Maybe UnitId) + | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] + | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] + +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a +mayThrowUnitErr = \case + Failed e -> throwGhcExceptionIO + $ CmdLineError + $ renderWithContext defaultSDocContext + $ withPprStyle defaultUserStyle + $ ppr e + Succeeded a -> return a + +instance Outputable UnitErr where + ppr = \case + CloseUnitErr p mb_parent + -> (text "unknown unit:" <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + PackageFlagErr flag reasons + -> flag_err (pprFlag flag) reasons + + TrustFlagErr flag reasons + -> flag_err (pprTrustFlag flag) reasons + where + flag_err flag_doc reasons = + text "cannot satisfy " + <> flag_doc + <> (if null reasons then Outputable.empty else text ": ") + $$ nest 4 (vcat (map ppr_reason reasons) $$ + text "(use -v for more information)") + + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = UniqMap UnitId [UnitId] + +-- | Compute the reverse dependency index of a unit database. +reverseDeps :: UnitInfoMap -> RevIndex +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db + where + go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex + go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = addToUniqMap_C (++) r to [from] + +-- | Given a list of 'UnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those units, plus any units which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removeUnits :: [UnitId] -> RevIndex + -> UnitInfoMap + -> (UnitInfoMap, [UnitInfo]) +removeUnits uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- lookupUniqMap m uid + = case lookupUniqMap index uid of + Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' +-- which correspond to units that do not exist in the index. +depsNotAvailable :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in +-- 'unitAbiDepends' which correspond to units that do not exist, OR have +-- mismatching ABIs. +depsAbiMismatch :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- lookupUniqMap pkg_map dep_uid + = unitAbiHash dep_pkg == abi + | otherwise + = False ===================================== compiler/GHC/Unit/External/Visibility.hs ===================================== @@ -0,0 +1,72 @@ +module GHC.Unit.External.Visibility ( + VisibilityMap, + UnitVisibility(..), +) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.Module +import GHC.Utils.Outputable as Outputable + +import Control.Applicative +import Data.Monoid (First (..)) +import Data.Semigroup qualified as Semigroup +import Data.Set (Set) +import Data.Set qualified as Set + +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = UniqMap Unit UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'Unit'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name associated with the 'Unit'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Maybe PackageArg + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) + , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = emptyUniqMap + , uv_explicit = Nothing + } + mappend = (Semigroup.<>) + ===================================== compiler/GHC/Unit/External/Wired.hs ===================================== @@ -0,0 +1,100 @@ +module GHC.Unit.External.Wired ( + WiringMap, + UnwiringMap, + findWiredInUnits, +) where + +import GHC.Prelude + +import GHC.Data.Maybe +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Database +import GHC.Unit.External.Visibility +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable as Outputable + +type WiringMap = + UniqMap UnitId UnitId + +type UnwiringMap = + UniqMap UnitId UnitId + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +findWiredInUnits + :: Logger + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO WiringMap -- map from unit id to wired identity +findWiredInUnits logger prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Types + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] + where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + + notfound = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (UnitId, UnitInfo) + pick pkg = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (wired_pkg, pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + return wiredInMap ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -5,11 +5,14 @@ module GHC.Unit.Info ( GenericUnitInfo (..) , GenUnitInfo , UnitInfo + , UnitInfoMap , UnitKey (..) , UnitKeyInfo , mkUnitKeyInfo , mapUnitInfo , mkUnitPprInfo + , evaluateUnitInfo + , seqUnitInfo , mkUnit @@ -53,6 +56,8 @@ import Data.Containers.ListUtils (nubOrd) import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix) +import GHC.Types.Unique.Map +import Control.Exception (evaluate) -- | Information about an installed unit @@ -73,6 +78,9 @@ type UnitKeyInfo = GenUnitInfo UnitKey -- UnitId) type UnitInfo = GenUnitInfo UnitId +-- TODO @fendor +type UnitInfoMap = UniqMap UnitId UnitInfo + -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo @@ -250,3 +258,21 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar expandTag t | null t = "" | otherwise = '_':t + +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) + +seqUnitInfo :: UnitInfo -> b -> b +seqUnitInfo ui b = + unitImportDirs ui `seqList` + unitIncludeDirs ui `seqList` + unitLibraryDirs ui `seqList` + unitLibraryBytecodeDirs ui `seqList` + unitExtDepFrameworkDirs ui `seq` + unitHaddockInterfaces ui `seq` + unitHaddockHTMLs ui `seqList` + unitLibraryDynDirs ui `seqList` + unitLibraryDirsStatic ui `seqList` + unitDepends ui `seqList` + unitExposedModules ui `seqList` + b ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Unit.State ( module GHC.Unit.Info, - UnitIndex(..), + UnitIndex, initUnitIndex, setWireMap, isWireMapEmpty, @@ -26,7 +26,6 @@ module GHC.Unit.State ( listUnitInfo, -- * Querying the package config - UnitInfoMap, lookupUnit, lookupUnit', unsafeLookupUnit, @@ -90,50 +89,45 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Unit.Database +import GHC.Unit.Home import GHC.Unit.Info -import GHC.Unit.Ppr -import GHC.Unit.Types import GHC.Unit.Module -import GHC.Unit.Home +import GHC.Unit.Ppr -import GHC.Types.Unique.FM +import GHC.Unit.External.Database +import GHC.Unit.External.Index +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Providers +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.External.Wired + +import GHC.Types.PkgQual import GHC.Types.Unique.DFM -import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM import GHC.Types.Unique.Map -import GHC.Types.Unique -import GHC.Types.PkgQual -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Outputable as Outputable -import GHC.Data.Maybe - -import System.Environment ( getEnv ) import GHC.Data.FastString -import GHC.Data.OsPath ( OsPath ) -import qualified GHC.Data.OsPath as OsPath -import qualified GHC.Data.ShortText as ST -import GHC.Utils.Logger +import GHC.Data.Maybe +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST import GHC.Utils.Error -import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic -import System.Directory -import System.FilePath as FilePath import Control.Monad import Data.Containers.ListUtils (nubOrd) -import Data.Graph (stronglyConnComp, SCC(..)) -import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, sortOn, sort ) -import Data.Set (Set) -import Data.Monoid (First(..)) -import qualified Data.Semigroup as Semigroup -import qualified Data.Set as Set -import Control.Applicative -import GHC.Unit.External.Database -import Data.IORef import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Graph (SCC (..)) +import Data.IORef +import Data.List (intersperse, partition, sort, sortOn) +import Data.Monoid (First (..)) +import Data.Set (Set) +import Data.Set qualified as Set -- --------------------------------------------------------------------------- -- The Unit state @@ -179,162 +173,6 @@ import qualified Data.Map.Strict as Map -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. --- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! -data ModuleOrigin = - -- | Module is hidden, and thus never will be available for import. - -- (But maybe the user didn't realize), so we'll still keep track - -- of these modules.) - ModHidden - - -- | Module is unavailable because the unit is unusable. - | ModUnusable !UnusableUnit - - -- | Module is public, and could have come from some places. - | ModOrigin { - -- | @Just False@ means that this module is in - -- someone's @exported-modules@ list, but that package is hidden; - -- @Just True@ means that it is available; @Nothing@ means neither - -- applies. - fromOrigUnit :: Maybe Bool - -- | Is the module available from a reexport of an exposed package? - -- There could be multiple. - , fromExposedReexport :: [UnitInfo] - -- | Is the module available from a reexport of a hidden package? - , fromHiddenReexport :: [UnitInfo] - -- | Did the module export come from a package flag? (ToDo: track - -- more information. - , fromPackageFlag :: Bool - } - --- | A unusable unit module origin -data UnusableUnit = UnusableUnit - { uuUnit :: !Unit -- ^ Unusable unit - , uuReason :: !UnusableUnitReason -- ^ Reason - , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? - } - -instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" - ppr (ModUnusable _) = text "unusable module" - ppr (ModOrigin e res rhs f) = sep (punctuate comma ( - (case e of - Nothing -> [] - Just False -> [text "hidden package"] - Just True -> [text "exposed package"]) ++ - (if null res - then [] - else [text "reexport by" <+> - sep (map (ppr . mkUnit) res)]) ++ - (if null rhs - then [] - else [text "hidden reexport by" <+> - sep (map (ppr . mkUnit) rhs)]) ++ - (if f then [text "package flag"] else []) - )) - --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False - --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is exposed, and --- also its 'UnitInfo'. -fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False - --- | Smart constructor for a module which was bound by a package flag. -fromFlag :: ModuleOrigin -fromFlag = ModOrigin Nothing [] [] True - -instance Semigroup ModuleOrigin where - x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - g Nothing x = x - g x Nothing = x - - x <> y = pprPanic "ModOrigin: module origin mismatch" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - -instance Monoid ModuleOrigin where - mempty = ModOrigin Nothing [] [] False - mappend = (Semigroup.<>) - --- | Is the name from the import actually visible? (i.e. does it cause --- ambiguity, or is it only relevant when we're making suggestions?) -originVisible :: ModuleOrigin -> Bool -originVisible ModHidden = False -originVisible (ModUnusable _) = False -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f - --- | Are there actually no providers for this module? This will never occur --- except when we're filtering based on package imports. -originEmpty :: ModuleOrigin -> Bool -originEmpty (ModOrigin Nothing [] [] False) = True -originEmpty _ = False - --- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. -type VisibilityMap = UniqMap Unit UnitVisibility - --- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'Unit'. -data UnitVisibility = UnitVisibility - { uv_expose_all :: Bool - -- ^ Should all modules in exposed-modules should be dumped into scope? - , uv_renamings :: [(ModuleName, ModuleName)] - -- ^ Any custom renamings that should bring extra 'ModuleName's into - -- scope. - , uv_package_name :: First FastString - -- ^ The package name associated with the 'Unit'. This is used - -- to implement legacy behavior where @-package foo-0.1@ implicitly - -- hides any packages named @foo@ - , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) - -- ^ The signatures which are contributed to the requirements context - -- from this unit ID. - , uv_explicit :: Maybe PackageArg - -- ^ Whether or not this unit was explicitly brought into scope, - -- as opposed to implicitly via the 'exposed' fields in the - -- package database (when @-hide-all-packages@ is not passed.) - } - -instance Outputable UnitVisibility where - ppr (UnitVisibility { - uv_expose_all = b, - uv_renamings = rns, - uv_package_name = First mb_pn, - uv_requirements = reqs, - uv_explicit = explicit - }) = ppr (b, rns, mb_pn, reqs, explicit) - -instance Semigroup UnitVisibility where - uv1 <> uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) - , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 - } - -instance Monoid UnitVisibility where - mempty = UnitVisibility - { uv_expose_all = False - , uv_renamings = [] - , uv_package_name = First Nothing - , uv_requirements = emptyUniqMap - , uv_explicit = Nothing - } - mappend = (Semigroup.<>) - - -- | Unit configuration data UnitConfig = UnitConfig { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS @@ -422,77 +260,6 @@ initUnitConfig dflags cached_dbs home_units = offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p)) offsetPackageDb _ p = p - --- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and --- its 'ModuleOrigin'). --- --- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one --- origin for a given 'Module' - -type ModuleNameProvidersMap = - UniqMap ModuleName (UniqMap Module ModuleOrigin) - -data GlobalUnitKey = - GlobalUnitKey - !UnitId -- ^ Unit Id of the 'UnitInfo' - !ST.ShortText - -globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey -globalUnitKeyFromUnitInfo ui = GlobalUnitKey (unitId ui) (unitAbiHash ui) - -type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) - -lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo -lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = - case lookupUniqMap globalMap uid of - Nothing -> Nothing - Just sameUnitId -> Map.lookup abiHash sameUnitId - -mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap -mkGlobalUnitInfoMap unitInfos = - listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos - - -data UnitIndex = UnitIndex - { ui_wireMap :: !WiringMap - -- ^ TODO @fendor: document global property - , ui_unwireMap :: !UnwiringMap - -- ^ TODO @fendor: document global property - , ui_unitInfoMap :: !GlobalUnitInfoMap - -- ^ TODO @fendor: document - } - -initUnitIndex :: UnitIndex -initUnitIndex = UnitIndex - { ui_wireMap = emptyUniqMap - , ui_unwireMap = emptyUniqMap - , ui_unitInfoMap = emptyUniqMap - } - -setWireMap :: WiringMap -> UnitIndex -> UnitIndex -setWireMap wired_map unit_index = - unit_index - { ui_wireMap = wired_map - , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] - } - -isWireMapEmpty :: UnitIndex -> Bool -isWireMapEmpty unit_index = - isNullUniqMap (ui_wireMap unit_index) - -addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex -addUnitInfoMap unit_info_map unit_index = - unit_index - { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) - } - where - globalMap :: GlobalUnitInfoMap - globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map - --- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo --- lookupUnitInfoMap unit_index unit_id = --- lookupUniqMap (ui_unitInfoMap unit_index) unit_id - data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid units are here. 'UnitInfo' reflects @@ -513,12 +280,6 @@ data UnitState = UnitState { -- And also to resolve package qualifiers with the PackageImports extension. packageNameMap :: UniqFM PackageName UnitId, - -- -- | A mapping from database unit keys to wired in unit ids. - -- wireMap :: WiringMap, - - -- -- | A mapping from wired in unit ids to unit keys from the database. - -- unwireMap :: UnwiringMap, - -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit -- is always mentioned before the units it depends on. @@ -573,45 +334,14 @@ emptyUnitState = UnitState { allowVirtualUnits = False } -type UnitInfoMap = UniqMap UnitId UnitInfo - -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) --- | A more specialized interface, which doesn't require a 'UnitState' (so it --- can be used while we're initializing 'DynFlags') --- --- Parameters: --- * a boolean specifying whether or not to look for on-the-fly renamed interfaces --- * a 'UnitInfoMap' -lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo -lookupUnit' allowOnTheFlyInst pkg_map u = case u of - HoleUnit -> error "Hole unit" - RealUnit i -> lookupUniqMap pkg_map (unDefinite i) - VirtUnit i - | allowOnTheFlyInst - -> -- lookup UnitInfo of the indefinite unit to be instantiated and - -- instantiate it on-the-fly - fmap (renameUnitInfo pkg_map (instUnitInsts i)) - (lookupUniqMap pkg_map (instUnitInstanceOf i)) - - | otherwise - -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite - -- units. Even if they are real, installed units, they can't use the - -- `RealUnit` constructor (it is reserved for definite units) so we use - -- the `VirtUnit` constructor. - lookupUniqMap pkg_map (virtualUnitId i) - -- | Find the unit we know about with the given unit id, if any lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid --- | Find the unit we know about with the given unit id, if any -lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo -lookupUnitId' db uid = lookupUniqMap db uid - - -- | Looks up the given unit in the unit state, panicking if it is not found unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo unsafeLookupUnit state u = case lookupUnit state u of @@ -729,7 +459,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - wireMap <- ui_wireMap <$> readIORef unit_index + wireMap <- wiringMap <$> readIORef unit_index let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) @@ -782,205 +512,6 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = | otherwise -> DefiniteHomeUnit hu_id (Just (u, is)) --- ----------------------------------------------------------------------------- --- Reading the unit database(s) - -readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] -readUnitDatabases logger cfg = do - conf_refs <- getUnitDbRefs cfg - confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs - mapM (readOrGetUnitDatabase logger cfg) confs - - -getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] -getUnitDbRefs cfg = do - let system_conf_refs = [UserPkgDb, GlobalPkgDb] - - e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH") - let base_conf_refs = case e_pkg_path of - Left _ -> system_conf_refs - Right path - | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs - | otherwise - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) - - -- Apply the package DB-related flags from the command line to get the - -- final list of package DBs. - -- - -- Notes on ordering: - -- * The list of flags is reversed (later ones first) - -- * We work with the package DB list in "left shadows right" order - -- * and finally reverse it at the end, to get "right shadows left" - -- - return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg)) - where - doFlag (PackageDB p) dbs = p : dbs - doFlag NoUserPackageDB dbs = filter isNotUser dbs - doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs - doFlag ClearPackageDBs _ = [] - - isNotUser UserPkgDb = False - isNotUser _ = True - - isNotGlobal GlobalPkgDb = False - isNotGlobal _ = True - --- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' --- when the user database filepath is expected but the latter doesn't exist. --- --- NB: This logic is reimplemented in Cabal, so if you change it, --- make sure you update Cabal. (Or, better yet, dump it in the --- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg -resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do - dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) - let pkgconf = dir </> unitConfigDBName cfg - exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero -resolveUnitDatabase _ (PkgDbPath name) = return $ Just name - --- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. -readOrGetUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readOrGetUnitDatabase logger cfg conf_file = - readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case - Nothing -> do - new_db <- readUnitDatabase logger cfg conf_file - cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db - pure new_db - Just db -> - pure db - --- | Read the 'UnitDatabase' at the given location. -readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readUnitDatabase logger cfg conf_file = do - isdir <- OsPath.doesDirectoryExist conf_file - - proto_pkg_configs <- - if isdir - then readDirStyleUnitInfo conf_file - else do - isfile <- OsPath.doesFileExist conf_file - if isfile - then do - mpkgs <- tryReadOldFileStyleUnitInfo - case mpkgs of - Just pkgs -> return pkgs - Nothing -> throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package " ++ - "databases (" ++ show conf_file ++ - ") use 'ghc-pkg init' to create the database with " ++ - "the correct format." - else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ show conf_file - - let - -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = OsPath.dropTrailingPathSeparator conf_file - top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) - pkgroot = OsPath.takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) - proto_pkg_configs - -- - pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 - return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 - where - readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] - readDirStyleUnitInfo conf_dir = do - let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") - cache_exists <- OsPath.doesFileExist filename - if cache_exists - then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc filename - else do - -- If there is no package.cache file, we check if the database is not - -- empty by inspecting if the directory contains any .conf file. If it - -- does, something is wrong and we fail. Otherwise we assume that the - -- database is empty. - debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> ppr conf_dir - <> text ", checking if the database is empty" - db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) - <$> OsPath.getDirectoryContents conf_dir - if db_empty - then do - debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> ppr conf_dir <> text ", treating" - <+> text "package database as empty" - return [] - else - throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ show conf_dir ++ - " even though package database is not empty" - - - -- Single-file style package dbs have been deprecated for some time, but - -- it turns out that Cabal was using them in one place. So this is a - -- workaround to allow older Cabal versions to use this newer ghc. - -- We check if the file db contains just "[]" and if so, we look for a new - -- dir-style db in conf_file.d/, ie in a dir next to the given file. - -- We cannot just replace the file with a new dir style since Cabal still - -- assumes it's a file and tries to overwrite with 'writeFile'. - -- ghc-pkg also cooperates with this workaround. - tryReadOldFileStyleUnitInfo = do - content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" - direxists <- OsPath.doesDirectoryExist conf_dir - if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) - liftM Just (readDirStyleUnitInfo conf_dir) - else return (Just []) -- ghc-pkg will create it when it's updated - else return Nothing - -mungeUnitInfo :: OsPath -> OsPath - -> UnitInfo -> UnitInfo -mungeUnitInfo top_dir pkgroot = - mungeBytecodeLibFields - . mungeLibDirFields - . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) - -mungeLibDirFields :: UnitInfo -> UnitInfo -mungeLibDirFields pkg = - pkg { - unitLibraryDynDirs = case unitLibraryDynDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - --- | Default to using library-dirs if bytecode library dirs is not explicitly set. -mungeBytecodeLibFields :: UnitInfo -> UnitInfo -mungeBytecodeLibFields pkg = - pkg { - unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - -seqUnitInfo :: UnitInfo -> b -> b -seqUnitInfo ui b = - unitImportDirs ui `seqList` - unitIncludeDirs ui `seqList` - unitLibraryDirs ui `seqList` - unitLibraryBytecodeDirs ui `seqList` - unitExtDepFrameworkDirs ui `seq` - unitHaddockInterfaces ui `seq` - unitHaddockHTMLs ui `seqList` - unitLibraryDynDirs ui `seqList` - unitLibraryDirsStatic ui `seqList` - unitDepends ui `seqList` - unitExposedModules ui `seqList` - b - -evaluateUnitInfo :: UnitInfo -> IO UnitInfo -evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) - -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -1094,265 +625,6 @@ applyPackageFlag prec_map pkg_map unusable no_hide_others pkgs vm flag = Left ps -> Failed (PackageFlagErr flag ps) Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) --- | Like 'selectPackages', but doesn't return a list of unmatched --- packages. Furthermore, any packages it returns are *renamed* --- if the 'UnitArg' has a renaming associated with it. -findPackages :: UnitPrecedenceMap - -> UnitInfoMap - -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - [UnitInfo] -findPackages prec_map pkg_map arg pkgs unusable - = let ps = mapMaybe (finder arg) pkgs - in if null ps - then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) - (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps) - where - finder (PackageArg str) p - = if matchingStr str p - then Just p - else Nothing - finder (UnitIdArg uid) p - = case uid of - RealUnit (Definite iuid) - | iuid == unitId p - -> Just p - VirtUnit inst - | instUnitInstanceOf inst == unitId p - -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) - _ -> Nothing - -selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - ([UnitInfo], [UnitInfo]) -selectPackages prec_map arg pkgs unusable - = let matches = matching arg - (ps,rest) = partition matches pkgs - in if null ps - then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps, rest) - --- | Rename a 'UnitInfo' according to some module instantiation. -renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo -renameUnitInfo pkg_map insts conf = - let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map hsubst - new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) - in conf { - unitInstantiations = new_insts, - unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) - (unitExposedModules conf) - } - - --- A package named on the command line can either include the --- version, or just the name if it is unambiguous. -matchingStr :: String -> UnitInfo -> Bool -matchingStr str p - = str == unitPackageIdString p - || str == unitPackageNameString p - -matchingId :: UnitId -> UnitInfo -> Bool -matchingId uid p = uid == unitId p - -matching :: PackageArg -> UnitInfo -> Bool -matching (PackageArg str) = matchingStr str -matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid -matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case - --- | This sorts a list of packages, putting "preferred" packages first. --- See 'compareByPreference' for the semantics of "preference". -sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) - --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking --- which should be "active". Here is the order of preference: --- --- 1. First, prefer the latest version --- 2. If the versions are the same, prefer the package that --- came in the latest package database. --- --- Pursuant to #12518, we could change this policy to, for example, remove --- the version preference, meaning that we would always prefer the units --- in later unit database. -compareByPreference - :: UnitPrecedenceMap - -> UnitInfo - -> UnitInfo - -> Ordering -compareByPreference prec_map pkg pkg' - = case comparing unitPackageVersion pkg pkg' of - GT -> GT - EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) - , Just prec' <- lookupUniqMap prec_map (unitId pkg') - -- Prefer the unit from the later DB flag (i.e., higher - -- precedence) - -> compare prec prec' - | otherwise - -> EQ - LT -> LT - -comparing :: Ord a => (t -> a) -> t -> t -> Ordering -comparing f a b = f a `compare` f b - -pprFlag :: PackageFlag -> SDoc -pprFlag flag = case flag of - HidePackage p -> text "-hide-package " <> text p - ExposePackage doc _ _ -> text doc - -pprTrustFlag :: TrustFlag -> SDoc -pprTrustFlag flag = case flag of - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p - --- ----------------------------------------------------------------------------- --- Wired-in units --- --- See Note [Wired-in units] in GHC.Unit.Types - -type WiringMap = UniqMap UnitId UnitId -type UnwiringMap = UniqMap UnitId UnitId - -findWiredInUnits - :: Logger - -> UnitPrecedenceMap - -> [UnitInfo] -- database - -> VisibilityMap -- info on what units are visible - -- for wired in selection - -> IO WiringMap -- map from unit id to wired identity -findWiredInUnits logger prec_map pkgs vis_map = do - -- Now we must find our wired-in units, and rename them to - -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in units] in GHC.Unit.Types - let - matches :: UnitInfo -> UnitId -> Bool - pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) - - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. - -- - -- When choosing which package to map to a wired-in package - -- name, we try to pick the latest version of exposed packages. - -- However, if there are no exposed wired in packages available - -- (e.g. -hide-all-packages was used), we can't bail: we *have* - -- to assign a package for the wired-in package: so we try again - -- with hidden packages included to (and pick the latest - -- version). - -- - -- You can also override the default choice by using -ignore-package: - -- this works even when there is no exposed wired in package - -- available. - -- - findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) - findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] - where - all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] - - try ps = case sortByPreference prec_map ps of - p:_ -> Just <$> pick p - _ -> pure Nothing - - notfound = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " not found." - return Nothing - pick :: UnitInfo -> IO (UnitId, UnitInfo) - pick pkg = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " mapped to " - <> ppr (unitId pkg) - return (wired_pkg, pkg) - - - mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds - let - wired_in_pkgs = catMaybes mb_wired_in_pkgs - - wiredInMap :: UniqMap UnitId UnitId - wiredInMap = listToUniqMap - [ (unitId realUnitInfo, wiredInUnitId) - | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs - , not (unitIsIndefinite realUnitInfo) - ] - - return wiredInMap - -updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] -updateWiredInUnits wiredInMap knownInfos pkgs = - map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs - -updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo -updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = - let - upd_wired_in_pkg wiredInUnitId pkg = - pkg { unitId = wiredInUnitId - , unitInstanceOf = wiredInUnitId - -- every non instantiated unit is an instance of - -- itself (required by Backpack...) - -- - -- See Note [About units] in GHC.Unit - } - - upd_deps pkg = pkg { - unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), - unitExposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (unitExposedModules pkg) - } - in - case lookupUniqMap wiredInMap (unitId pkg) of - Just wiredIn -> - case lookupGlobalUnitInfoMap (GlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - --- Helper functions for rewiring Module and Unit. These --- rewrite Units of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. --- --- For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in GHC.Builtin.Names. - -upd_wired_in_mod :: WiringMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiringMap -> Unit -> Unit -upd_wired_in_uid wiredInMap u = case u of - HoleUnit -> HoleUnit - RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) - VirtUnit indef_uid -> - VirtUnit $ mkInstantiatedUnit - (instUnitInstanceOf indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) - -upd_wired_in :: WiringMap -> UnitId -> UnitId -upd_wired_in wiredInMap key - | Just key' <- lookupUniqMap wiredInMap key = key' - | otherwise = key - updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of @@ -1362,51 +634,6 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList w -- ---------------------------------------------------------------------------- --- | The reason why a unit is unusable. -data UnusableUnitReason - = -- | We ignored it explicitly using @-ignore-package@. - IgnoredWithFlag - -- | This unit transitively depends on a unit that was never present - -- in any of the provided databases. - | BrokenDependencies [UnitId] - -- | This unit transitively depends on a unit involved in a cycle. - -- Note that the list of 'UnitId' reports the direct dependencies - -- of this unit that (transitively) depended on the cycle, and not - -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [UnitId] - -- | This unit transitively depends on a unit which was ignored. - | IgnoredDependencies [UnitId] - -- | This unit transitively depends on a unit which was - -- shadowed by an ABI-incompatible unit. - | ShadowedDependencies [UnitId] - -instance Outputable UnusableUnitReason where - ppr IgnoredWithFlag = text "[ignored with flag]" - ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) - ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) - ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) - ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) - -type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) - -pprReason :: SDoc -> UnusableUnitReason -> SDoc -pprReason pref reason = case reason of - IgnoredWithFlag -> - pref <+> text "ignored due to an -ignore-package flag" - BrokenDependencies deps -> - pref <+> text "unusable due to missing dependencies:" $$ - nest 2 (hsep (map ppr deps)) - CyclicDependencies deps -> - pref <+> text "unusable due to cyclic dependencies:" $$ - nest 2 (hsep (map ppr deps)) - IgnoredDependencies deps -> - pref <+> text ("unusable because the -ignore-package flag was used to " ++ - "ignore at least one of its dependencies:") $$ - nest 2 (hsep (map ppr deps)) - ShadowedDependencies deps -> - pref <+> text "unusable due to shadowed dependencies:" $$ - nest 2 (hsep (map ppr deps)) - reportCycles :: Logger -> [SCC UnitInfo] -> IO () reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs where @@ -1416,193 +643,6 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs text "these packages are involved in a cycle:" $$ nest 2 (hsep (map (ppr . unitId) vs)) -reportUnusable :: Logger -> UnusableUnits -> IO () -reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) - where - report (ipid, (_, reason)) = - debugTraceMsg logger 2 $ - pprReason - (text "package" <+> ppr ipid <+> text "is") reason - --- ---------------------------------------------------------------------------- --- --- Utilities on the database --- - --- | A reverse dependency index, mapping an 'UnitId' to --- the 'UnitId's which have a dependency on it. -type RevIndex = UniqMap UnitId [UnitId] - --- | Compute the reverse dependency index of a unit database. -reverseDeps :: UnitInfoMap -> RevIndex -reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db - where - go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex - go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) - go' from r to = addToUniqMap_C (++) r to [from] - --- | Given a list of 'UnitId's to remove, a database, --- and a reverse dependency index (as computed by 'reverseDeps'), --- remove those units, plus any units which depend on them. --- Returns the pruned database, as well as a list of 'UnitInfo's --- that was removed. -removeUnits :: [UnitId] -> RevIndex - -> UnitInfoMap - -> (UnitInfoMap, [UnitInfo]) -removeUnits uids index m = go uids (m,[]) - where - go [] (m,pkgs) = (m,pkgs) - go (uid:uids) (m,pkgs) - | Just pkg <- lookupUniqMap m uid - = case lookupUniqMap index uid of - Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) - | otherwise - = go uids (m,pkgs) - --- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' --- which correspond to units that do not exist in the index. -depsNotAvailable :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) - --- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in --- 'unitAbiDepends' which correspond to units that do not exist, OR have --- mismatching ABIs. -depsAbiMismatch :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg - where - abiMatch (dep_uid, abi) - | Just dep_pkg <- lookupUniqMap pkg_map dep_uid - = unitAbiHash dep_pkg == abi - | otherwise - = False - --- ----------------------------------------------------------------------------- --- Ignore units - -ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits -ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) - where - doit (IgnorePackage str) = - case partition (matchingStr str) pkgs of - (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) - | p <- ps ] - -- missing unit is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. - --- ---------------------------------------------------------------------------- --- --- Merging databases --- - --- | For each unit, a mapping from uid -> i indicates that this --- unit was brought into GHC by the ith @-package-db@ flag on --- the command line. We use this mapping to make sure we prefer --- units that were defined later on the command line, if there --- is an ambiguity. -type UnitPrecedenceMap = UniqMap UnitId Int - --- | Given a list of databases, merge them together, where --- units with the same unit id in later databases override --- earlier ones. This does NOT check if the resulting database --- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: Logger -> [UnitDatabase UnitId] - -> IO (UnitInfoMap, UnitPrecedenceMap) -mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] - where - merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do - debugTraceMsg logger 2 $ - text "loading package database" <+> ppr db_path - when (logVerbAtLeast logger 2) $ - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" - return (pkg_map', prec_map') - where - db_map = mk_pkg_map db - mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) - - -- The set of UnitIds which appear in both db and pkgs. These are the - -- ones that get overridden. Compute this just to give some - -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) - - -- Now merge the sets together (NB: in case of duplicate, - -- first argument preferred) - pkg_map' :: UnitInfoMap - pkg_map' = pkg_map `plusUniqMap` db_map - - prec_map' :: UnitPrecedenceMap - prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) - --- | Validates a database, removing unusable units from it --- (this includes removing units that the user has explicitly --- ignored.) Our general strategy: --- --- 1. Remove all broken units (dangling dependencies) --- 2. Remove all units that are cyclic --- 3. Apply ignore flags --- 4. Remove all units which have deps with mismatching ABIs --- -validateDatabase :: UnitConfig -> UnitInfoMap - -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) -validateDatabase cfg pkg_map1 = - (pkg_map5, unusable, sccs) - where - ignore_flags = reverse (unitConfigFlagsIgnored cfg) - - -- Compute the reverse dependency index - index = reverseDeps pkg_map1 - - -- Helper function - mk_unusable mk_err dep_matcher m uids = - listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids - ] - - -- Find broken units - directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (nonDetEltsUniqMap pkg_map1) - (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 - unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken - - -- Find recursive units - sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) - | pkg <- nonDetEltsUniqMap pkg_map2 ] - getCyclicSCC (CyclicSCC vs) = map unitId vs - getCyclicSCC (AcyclicSCC _) = [] - (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 - unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic - - -- Apply ignore flags - directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) - (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 - unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored - - -- Knock out units whose dependencies don't agree with ABI - -- (i.e., got invalidated due to shadowing) - directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (nonDetEltsUniqMap pkg_map4) - (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 - unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - - -- combine all unusables. The order is important for shadowing. - -- plusUniqMapList folds using plusUFM which is right biased (opposite of - -- Data.Map.union) so the head of the list should be the least preferred - unusable = plusUniqMapList [ unusable_shadowed - , unusable_cyclic - , unusable_broken - , unusable_ignored - , directly_ignored - ] -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our unit @@ -1667,7 +707,7 @@ mkUnitState logger unit_index cfg = do we build a mapping saying what every in scope module name points to. -} - raw_dbs <- readUnitDatabases logger cfg + raw_dbs <- readUnitDatabases logger (initUnitDbConfig cfg) -- distrust all units if the flag is set let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) @@ -1697,7 +737,7 @@ mkUnitState logger unit_index cfg = do -- Now that we've merged everything together, prune out unusable -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + let (pkg_map2, unusable, sccs) = validateDatabase (unitConfigFlagsIgnored cfg) pkg_map1 reportCycles logger sccs reportUnusable logger unusable @@ -1781,9 +821,9 @@ mkUnitState logger unit_index cfg = do modifyIORef' unit_index (setWireMap wmap) pure wmap else do - pure $ ui_wireMap ui + pure $ wiringMap ui - let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + let all_pkgs = updateWiredInUnits wireMap (globalUnits ui) pkgs1 (new_pkgs, _pkgs_set) = partitionEithers all_pkgs modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (wireMap, map (either id id) all_pkgs) @@ -1859,7 +899,7 @@ mkUnitState logger unit_index cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db vis_map + let mod_map1 = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable mod_map = mod_map2 `plusUniqMap` mod_map1 @@ -1872,15 +912,24 @@ mkUnitState logger unit_index cfg = do , trustedUnits = trusted , distrustedUnits = distrusted , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db plugin_vis_map , packageNameMap = pkgname_map - -- , wireMap = wired_map - -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } return state +initUnitDbConfig :: UnitConfig -> UnitDbConfig +initUnitDbConfig uc = UnitDbConfig + { unitDbConfigFlagsDB = unitConfigFlagsDB uc + , unitDbConfigProgramName = unitConfigProgramName uc + , unitDbConfigDBName = unitConfigDBName uc + , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc + , unitDbConfigGlobalDB = unitConfigGlobalDB uc + , unitDbConfigGHCDir = unitConfigGHCDir uc + , unitDbConfigDBCache = unitConfigDBCache uc + } + selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True selectHptFlag _ _ = False @@ -1893,158 +942,6 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags -- MP: This does not yet support thinning/renaming go cur _ = cur - --- | Given a wired-in 'Unit', "unwire" it into the 'Unit' --- that it was recorded as in the package database. -unwireUnit :: UnitIndex -> Unit -> Unit -unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid) -unwireUnit _ uid = uid - --- ----------------------------------------------------------------------------- --- | Makes the mapping from ModuleName to package info - --- Slight irritation: we proceed by leafing through everything --- in the installed package database, which makes handling indefinite --- packages a bit bothersome. - -mkModuleNameProvidersMap - :: Logger - -> UnitConfig - -> UnitInfoMap - -> VisibilityMap - -> ModuleNameProvidersMap -mkModuleNameProvidersMap logger cfg pkg_map vis_map = - -- What should we fold on? Both situations are awkward: - -- - -- * Folding on the visibility map means that we won't create - -- entries for packages that aren't mentioned in vis_map - -- (e.g., hidden packages, causing #14717) - -- - -- * Folding on pkg_map is awkward because if we have an - -- Backpack instantiation, we need to possibly add a - -- package from pkg_map multiple times to the actual - -- ModuleNameProvidersMap. Also, we don't really want - -- definite package instantiations to show up in the - -- list of possibilities. - -- - -- So what will we do instead? We'll extend vis_map with - -- entries for every definite (for non-Backpack) and - -- indefinite (for Backpack) package, so that we get the - -- hidden entries we need. - nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended - where - vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map - - default_vis = listToUniqMap - [ (mkUnit pkg, mempty) - | (_, pkg) <- nonDetUniqMapToList pkg_map - -- Exclude specific instantiations of an indefinite - -- package - , unitIsIndefinite pkg || null (unitInstantiations pkg) - ] - - emptyMap = emptyUniqMap - setOrigins m os = fmap (const os) m - extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap - = addListTo modmap theBindings - where - pkg = unit_lookup uid - - theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - theBindings = newBindings b rns - - newBindings :: Bool - -> [(ModuleName, ModuleName)] - -> [(ModuleName, UniqMap Module ModuleOrigin)] - newBindings e rns = es e ++ hiddens ++ map rnBinding rns - - rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, UniqMap Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) - where origEntry = case lookupUFM esmap orig of - Just r -> r - Nothing -> throwGhcException (CmdLineError (renderWithContext - (log_default_user_context (logFlags logger)) - (text "package flag: could not find module name" <+> - ppr orig <+> text "in package" <+> ppr pk))) - - es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] - es e = do - (m, exposedReexport) <- exposed_mods - let (pk', m', origin') = - case exposedReexport of - Nothing -> (pk, m, fromExposedModules e) - Just (Module pk' m') -> - (pk', m', fromReexportedModules e pkg) - return (m, mkModMap pk' m' origin') - - esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) - esmap = listToUFM (es False) -- parameter here doesn't matter, orig will - -- be overwritten - - hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] - - pk = mkUnit pkg - unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map uid - `orElse` pprPanic "unit_lookup" (ppr uid) - - exposed_mods = unitExposedModules pkg - hidden_mods = unitHiddenModules pkg - --- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. -mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap -mkUnusableModuleNameProvidersMap unusables = - nonDetFoldUniqMap extend_modmap emptyUniqMap unusables - where - extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings - where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - bindings = exposed ++ hidden - - origin_reexport = ModUnusable (UnusableUnit unit reason True) - origin_normal = ModUnusable (UnusableUnit unit reason False) - unit = mkUnit unit_info - - exposed = map get_exposed exposed_mods - hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] - - -- with re-exports, c:Foo can be reexported from two (or more) - -- unusable packages: - -- Foo -> a:Foo (unusable reason A) -> c:Foo - -- -> b:Foo (unusable reason B) -> c:Foo - -- - -- We must be careful to not record the following (#21097): - -- Foo -> c:Foo (unusable reason A) - -- -> c:Foo (unusable reason B) - -- But: - -- Foo -> a:Foo (unusable reason A) - -- -> b:Foo (unusable reason B) - -- - get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) - get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) - -- in the reexport case, we create a virtual module that doesn't - -- exist but we don't care as it's only used as a key in the map. - - exposed_mods = unitExposedModules unit_info - hidden_mods = unitHiddenModules unit_info - --- | Add a list of key/value pairs to a nested map. --- --- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks --- when reloading modules in GHCi (see #4029). This ensures that each --- value is forced before installing into the map. -addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) - => UniqMap k1 (UniqMap k2 a) - -> [(k1, UniqMap k2 a)] - -> UniqMap k1 (UniqMap k2 a) -addListTo = foldl' merge - where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v - --- | Create a singleton module mapping -mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin -mkModMap pkg mod = unitUniqMap (mkModule pkg mod) - - -- ----------------------------------------------------------------------------- -- Package Utils @@ -2185,7 +1082,7 @@ lookupModuleWithSuggestions' pkgs mod_map name mb_pn suggestions = fuzzyLookup (moduleNameString name) all_mods all_mods :: [(String, ModuleSuggestion)] -- All modules - all_mods = sortBy (comparing fst) $ + all_mods = sortOn fst $ [ (moduleNameString m, suggestion) | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) @@ -2199,78 +1096,7 @@ listVisibleModuleNames state = map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) where visible (_, ms) = anyUniqMap originVisible ms --- | Takes a list of UnitIds (and their "parent" dependency, used for error --- messages), and returns the list with dependencies included, in reverse --- dependency order (a units appears before those it depends on). -closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps - --- | Similar to closeUnitDeps but takes a list of already loaded units as an --- additional argument. -closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps --- | Add a UnitId and those it depends on (recursively) to the given list of --- UnitIds if they are not already in it. Return a list in reverse dependency --- order (a unit appears before those it depends on). --- --- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). --- It it's not found, the optional parent unit is used to return a more precise --- error message ("dependency of <PARENT>"). -add_unit :: UnitInfoMap - -> [UnitId] - -> UnitId - -> Maybe UnitId - -> MaybeErr UnitErr [UnitId] -add_unit pkg_map ps p mb_parent - | p `elem` ps = return ps -- Check if we've already added this unit - | otherwise = case lookupUnitId' pkg_map p of - Nothing -> Failed (CloseUnitErr p mb_parent) - Just info -> do - -- Add the unit's dependents also - ps' <- foldM add_unit_key ps (unitDepends info) - return (p : ps') - where - add_unit_key xs key - = add_unit pkg_map xs key (Just p) - -data UnitErr - = CloseUnitErr !UnitId !(Maybe UnitId) - | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] - | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] - -mayThrowUnitErr :: MaybeErr UnitErr a -> IO a -mayThrowUnitErr = \case - Failed e -> throwGhcExceptionIO - $ CmdLineError - $ renderWithContext defaultSDocContext - $ withPprStyle defaultUserStyle - $ ppr e - Succeeded a -> return a - -instance Outputable UnitErr where - ppr = \case - CloseUnitErr p mb_parent - -> (text "unknown unit:" <+> ppr p) - <> case mb_parent of - Nothing -> Outputable.empty - Just parent -> space <> parens (text "dependency of" - <+> ftext (unitIdFS parent)) - PackageFlagErr flag reasons - -> flag_err (pprFlag flag) reasons - - TrustFlagErr flag reasons - -> flag_err (pprTrustFlag flag) reasons - where - flag_err flag_doc reasons = - text "cannot satisfy " - <> flag_doc - <> (if null reasons then Outputable.empty else text ": ") - $$ nest 4 (vcat (map ppr_reason reasons) $$ - text "(use -v for more information)") - - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement. @@ -2328,37 +1154,23 @@ pprUnitsSimple ue = pprUnitsWith pprIPI ue t = if isUnitInfoTrusted ue ipi then text "T" else text " " in e <> t <> text " " <> ftext i --- | Show the mapping of modules to where they come from. -pprModuleMap :: ModuleNameProvidersMap -> SDoc -pprModuleMap mod_map = - vcat (map pprLine (nonDetUniqMapToList mod_map)) - where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) - pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc - pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) - | otherwise = ppr m' <+> parens (ppr o) +-- | Print unit-ids with UnitInfo found in the given UnitState +pprWithUnitState :: UnitState -> SDoc -> SDoc +pprWithUnitState state = updSDocContext (\ctx -> ctx + { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) + }) + +-- | Print raw unit-ids, without removing the hash +pprRawUnitIds :: SDoc -> SDoc +pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) fsPackageName :: UnitInfo -> FastString fsPackageName info = fs where PackageName fs = unitPackageName info --- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. -instUnitToUnit :: InstantiatedUnit -> Unit -instUnitToUnit iuid = - -- NB: suppose that we want to compare the instantiated - -- unit p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- VirtUnit, they won't compare equal; only - -- after improvement will the equality hold. - VirtUnit iuid - - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module +-- ----------------------------------------------------------------------------- +-- Module renaming -- | Substitutes holes in a 'Module'. NOT suitable for being called -- directly on a 'nameModule', see Note [Representation of module/name variables]. @@ -2374,44 +1186,19 @@ renameHoleModule state = renameHoleModule' (unitInfoMap state) renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit renameHoleUnit state = renameHoleUnit' (unitInfoMap state) --- | Like 'renameHoleModule', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnit' pkg_map env (moduleUnit m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = <Blah>, that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit -renameHoleUnit' pkg_map env uid = - case uid of - (VirtUnit - InstantiatedUnit{ instUnitInstanceOf = cid - , instUnitInsts = insts - , instUnitHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) - then uid - else mkVirtUnit cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - -- | Injects an 'InstantiatedModule' to 'Module' (see also -- 'instUnitToUnit'. instModuleToModule :: InstantiatedModule -> Module instModuleToModule (Module iuid mod_name) = mkModule (instUnitToUnit iuid) mod_name --- | Print unit-ids with UnitInfo found in the given UnitState -pprWithUnitState :: UnitState -> SDoc -> SDoc -pprWithUnitState state = updSDocContext (\ctx -> ctx - { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) - }) - --- | Print raw unit-ids, without removing the hash -pprRawUnitIds :: SDoc -> SDoc -pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) +-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. +instUnitToUnit :: InstantiatedUnit -> Unit +instUnitToUnit iuid = + -- NB: suppose that we want to compare the instantiated + -- unit p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- VirtUnit, they won't compare equal; only + -- after improvement will the equality hold. + VirtUnit iuid ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -1,6 +1,3 @@ module GHC.Unit.State where data UnitState -data ModuleSuggestion -data ModuleOrigin -data UnusableUnit ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -578,7 +578,7 @@ had used @-ignore-package@). The affected packages are compiled with, e.g., @-this-unit-id base@, so that the symbols in the object files have the unversioned unit id in their name. -Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. +Make sure you change 'wiredInUnitIds' if you add an entry here. -} ===================================== compiler/ghc.cabal.in ===================================== @@ -968,6 +968,14 @@ Library GHC.Unit.Env GHC.Unit.External GHC.Unit.External.Database + GHC.Unit.External.Index + GHC.Unit.External.Substitution + GHC.Unit.External.Query + GHC.Unit.External.ModuleOrigin + GHC.Unit.External.Providers + GHC.Unit.External.Validate + GHC.Unit.External.Visibility + GHC.Unit.External.Wired GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== testsuite/tests/driver/T26423/Hello.hs ===================================== @@ -0,0 +1,6 @@ +module Hello where + +import Tes + +hello :: String +hello = "Imported from dependency 'test':" <> show test ===================================== testsuite/tests/driver/T26423/Makefile ===================================== @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +LOCAL_PKGCONF=test.package.conf.d + +clean: + rm -f test/*.o test/*.hi *.o *.hi + rm -rf $(LOCAL_PKGCONF) + +.PHONY: T26423 +T26423: + @rm -rf $(LOCAL_PKGCONF) + "$(TEST_HC)" $(TEST_HC_OPTS) -this-unit-id test-1.0 -c test/Test.hs + "$(GHC_PKG)" init $(LOCAL_PKGCONF) + "$(GHC_PKG)" --no-user-package-db -f $(LOCAL_PKGCONF) register test/test.pkg -v0 + "$(TEST_HC)" $(TEST_HC_OPTS) -package-db $(LOCAL_PKGCONF)/ -package ghc T26423.hs + ./T26423 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" ===================================== testsuite/tests/driver/T26423/T26423.hs ===================================== @@ -0,0 +1,38 @@ +import GHC +import GHC.Data.OsPath +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Unit.Env +import GHC.Plugins +import GHC.Prelude + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import System.Environment + +-- No sign of new db in output: +-- "Just [DB: <libdir>/package.conf.d]" +bad :: IO () +bad = do + libdir:_ <- getArgs + runGhcT (Just libdir) $ do + df <- getSessionDynFlags + -- The first call simulates having modified the DynFlags once before + setSessionDynFlags df + setSessionDynFlags $ + df { packageDBFlags = PackageDB (PkgDbPath $ os "test.package.conf.d") : (packageDBFlags df) + , packageFlags = [ExposePackage "testpkg" (PackageArg "testpkg") (ModRenaming True [])] + } + + hsc_env <- getSession + t <- guessTarget "Heo.hs" Nothing Nothing + setTargets [t] + r <- load LoadAllTargets + when (failed r) $ do + liftIO $ throwIO $ ErrorCall "Failed to load the target" + + execStmt "hello" execOptions + liftIO $ putStrLn "Successfully compiled Hello.hs" + +main = bad >>= print ===================================== testsuite/tests/driver/T26423/all.T ===================================== @@ -0,0 +1 @@ +test('T26423', [extra_files(['Hello.hs', 'test/'])], makefile_test, []) ===================================== testsuite/tests/driver/T26423/test/Test.hs ===================================== @@ -0,0 +1,4 @@ +module Test where + +test :: Int +test = 42 ===================================== testsuite/tests/driver/T26423/test/test.pkg ===================================== @@ -0,0 +1,8 @@ +name: test +version: 1.0 +id: test-1.0 +key: test-1.0 +exposed-modules: Test +import-dirs: ${pkgroot}/test +library-dirs: ${pkgroot}/test +exposed: True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ffa36d774e5d4216ef12639d92bba… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ffa36d774e5d4216ef12639d92bba… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] Major patch to re-engineer known-key names
by Rodrigo Mesquita (＠alt-romes) 16 Jul '26

16 Jul '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 07644404 by Simon Peyton Jones at 2026-07-16T14:17:11+01:00 Major patch to re-engineer known-key names This big patch implements the New Plan for known-key names, described in #27013. Read the big Note [Overview of known-key names] in GHC.Types.Name Some things had to be reworked slightly to accomodate the new known-keys design. A significant one was the generation of auxiliary KindRep bindings, which was greatly simplified. Note [Grand plan for Typeable] was updated accordingly. Another example: GHC.Internal.CString was merged into GHC.Internal.Types. Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> The couple hundreds of hours spent here by Rodrigo were sponsored by Well-Typed Metrics: compile_time/bytes allocated ------------------------------------- Baseline Test Metric value New value Change ------------------------------------------------------------------------------------------ MultiComponentModules100(normal) ghc/alloc 24,312,779,672 24,990,470,432 +2.8% BAD MultiComponentModulesRecomp(normal) ghc/alloc 601,924,960 621,884,888 +3.3% BAD MultiComponentModulesRecomp100(normal) ghc/alloc 11,884,065,432 12,531,373,704 +5.4% BAD MultiLayerModules(normal) ghc/alloc 3,861,537,072 3,706,919,512 -4.0% GOOD T13701(normal) ghc/alloc 3,517,246,392 3,237,179,616 -8.0% GOOD T13820(normal) ghc/alloc 28,961,056 29,663,208 +2.4% BAD T14697(normal) ghc/alloc 472,044,184 443,550,048 -6.0% GOOD T18140(normal) ghc/alloc 47,905,664 49,115,808 +2.5% BAD T4801(normal) ghc/alloc 269,339,096 263,432,040 -2.2% GOOD T783(normal) ghc/alloc 341,112,672 333,339,952 -2.3% GOOD hard_hole_fits(normal) ghc/alloc 222,164,728 213,433,808 -3.9% GOOD mhu-perf(normal) ghc/alloc 49,011,440 46,706,280 -4.7% GOOD geo. mean +0.1% minimum -8.0% maximum +5.4% All performance regressions were investigated in depth. The surviving ones: - MultiComponentModules100, MultiComponentModulesRecomp100, MultiComponentModulesRecomp regresses because existing bugs that make an additional implicit edge do too much redundant work: #27053 and #27461 - T13820, T18140, T10547, T13035 regress because we load an additional interface and associated Names for GHC.Essentials. ------------------------- Metric Decrease: MultiLayerModules T13701 T14697 T26989 T4801 T783 hard_hole_fits mhu-perf size_hello_obj Metric Increase: LinkableUsage01 MultiComponentModules100 MultiComponentModulesRecomp MultiComponentModulesRecomp100 T10547 T13035 T13820 T18140 T20049 ------------------------- - - - - - 739 changed files: - + changelog.d/refactor-known-names - compiler/GHC.hs - + compiler/GHC/Builtin.hs - + compiler/GHC/Builtin/KnownKeys.hs - + compiler/GHC/Builtin/KnownOccs.hs - + compiler/GHC/Builtin/Modules.hs - − compiler/GHC/Builtin/Names.hs - − compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Casts.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - + compiler/GHC/Builtin/TH.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - − compiler/GHC/Builtin/Utils.hs - + compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Builtin/Types/Prim.hs → compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Builtin/Types/Literals.hs → compiler/GHC/Builtin/WiredIn/TypeLits.hs - compiler/GHC/Builtin/Types.hs → compiler/GHC/Builtin/WiredIn/Types.hs - compiler/GHC/Builtin/Types.hs-boot → compiler/GHC/Builtin/WiredIn/Types.hs-boot - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/LiberateCase.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/KnotVars.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Check.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Ppr.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Env.hs - − compiler/GHC/Iface/Env.hs-boot - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Plugins.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Foreign.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/RepType.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Unit.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - − compiler/GHC/Utils/Binary/Typeable.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/ghc.cabal.in - docs/users_guide/separate_compilation.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - libraries/base/base.cabal.in - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Concurrent.hs - libraries/base/src/Control/Concurrent/Chan.hs - libraries/base/src/Control/Concurrent/QSem.hs - libraries/base/src/Control/Concurrent/QSemN.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Bifoldable.hs - libraries/base/src/Data/Bifoldable1.hs - libraries/base/src/Data/Bifunctor.hs - libraries/base/src/Data/Bitraversable.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Complex.hs - libraries/base/src/Data/Data.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/Data/Foldable1.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/Data/Functor/Compose.hs - libraries/base/src/Data/Functor/Contravariant.hs - libraries/base/src/Data/Functor/Product.hs - libraries/base/src/Data/Functor/Sum.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/Data/Semigroup.hs - libraries/base/src/Data/Version.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/ByteOrder.hs - + libraries/base/src/GHC/Essentials.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Numeric.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/CPUTime/Posix/ClockGetTime.hsc - libraries/base/src/System/CPUTime/Posix/RUsage.hsc - libraries/base/src/System/CPUTime/Posix/Times.hsc - libraries/base/src/System/CPUTime/Unsupported.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO.hs - libraries/base/src/System/IO/OS.hs - libraries/base/src/System/IO/Unsafe.hs - libraries/base/src/System/Info.hs - libraries/base/src/System/Timeout.hs - libraries/base/src/Text/Printf.hs - libraries/base/src/Text/Read.hs - libraries/base/src/Text/Show/Functions.hs - libraries/binary - libraries/ghc-experimental/src/Data/Sum/Experimental.hs - libraries/ghc-experimental/src/Data/Tuple/Experimental.hs - libraries/ghc-experimental/src/GHC/Profiling/Eras.hs - libraries/ghc-experimental/src/Prelude/Experimental.hs - libraries/ghc-internal/codepages/MakeTable.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Arr.hs - libraries/ghc-internal/src/GHC/Internal/ArrayArray.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/GMP.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Primitives.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/WordArray.hs - libraries/ghc-internal/src/GHC/Internal/Bits.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghc-internal/src/GHC/Internal/Classes.hs - libraries/ghc-internal/src/GHC/Internal/Classes/IP.hs - libraries/ghc-internal/src/GHC/Internal/Clock.hsc - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX/Const.hsc - libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs - libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Category.hs - libraries/ghc-internal/src/GHC/Internal/Control/Concurrent/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/IO/Class.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Data/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Dynamic.hs - libraries/ghc-internal/src/GHC/Internal/Data/Either.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Function.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Data/IORef.hs - libraries/ghc-internal/src/GHC/Internal/Data/List.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs - libraries/ghc-internal/src/GHC/Internal/Data/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs - libraries/ghc-internal/src/GHC/Internal/Data/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Data/Void.hs - libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs - libraries/ghc-internal/src/GHC/Internal/Desugar.hs - libraries/ghc-internal/src/GHC/Internal/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs-boot - libraries/ghc-internal/src/GHC/Internal/Environment.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/src/GHC/Internal/Event/Arr.hs - libraries/ghc-internal/src/GHC/Internal/Event/Array.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/IntTable.hs - libraries/ghc-internal/src/GHC/Internal/Event/IntVar.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs - libraries/ghc-internal/src/GHC/Internal/Event/PSQ.hs - libraries/ghc-internal/src/GHC/Internal/Event/Poll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimeOut.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Clock.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/FFI.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot - libraries/ghc-internal/src/GHC/Internal/ExecutionStack.hs - libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint/Type.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/ConversionUtils.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Types.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/ForeignPtr/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Alloc.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Array.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Pool.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Storable.hs - libraries/ghc-internal/src/GHC/Internal/ForeignPtr.hs - libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - libraries/ghc-internal/src/GHC/Internal/GHCi.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Buffer.hs - libraries/ghc-internal/src/GHC/Internal/IO/BufferedIO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/API.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/Table.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Iconv.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Latin1.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF16.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF32.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Common.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Flock.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/NoOp.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs - libraries/ghc-internal/src/GHC/Internal/IO/SubSystem.hs - libraries/ghc-internal/src/GHC/Internal/IO/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc - libraries/ghc-internal/src/GHC/Internal/IOArray.hs - libraries/ghc-internal/src/GHC/Internal/IORef.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/IsList.hs - libraries/ghc-internal/src/GHC/Internal/Ix.hs - libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs - libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/Lexeme.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Magic/Dict.hs - libraries/ghc-internal/src/GHC/Internal/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs-boot - libraries/ghc-internal/src/GHC/Internal/Numeric.hs - libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs - libraries/ghc-internal/src/GHC/Internal/Pack.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs - libraries/ghc-internal/src/GHC/Internal/Prim/PtrEq.hs - libraries/ghc-internal/src/GHC/Internal/Profiling.hs - libraries/ghc-internal/src/GHC/Internal/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs-boot - libraries/ghc-internal/src/GHC/Internal/Records.hs - libraries/ghc-internal/src/GHC/Internal/ST.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - libraries/ghc-internal/src/GHC/Internal/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Show.hs - libraries/ghc-internal/src/GHC/Internal/Stable.hs - libraries/ghc-internal/src/GHC/Internal/StableName.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs-boot - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - libraries/ghc-internal/src/GHC/Internal/Storable.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - libraries/ghc-internal/src/GHC/Internal/System/Mem.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Types.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadP.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadPrec.hs - libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/TypeError.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits/Internal.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Unicode.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/DerivedCoreProperties.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/GeneralCategory.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleLowerCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleTitleCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleUpperCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Conc.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Conc/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs - libraries/ghc-internal/src/GHC/Internal/Windows.hs - libraries/ghc-internal/src/GHC/Internal/Word.hs - libraries/ghc-internal/tools/ucd2haskell/exe/UCD2Haskell/ModuleGenerators.hs - libraries/ghc-prim/Dummy.hs - libraries/ghc-prim/ghc-prim.cabal - libraries/template-haskell/Language/Haskell/TH/Lib.hs - rts/include/rts/RtsToHsIface.h - testsuite/tests/ado/T13242a.stderr - testsuite/tests/annotations/should_fail/annfail10.stderr - testsuite/tests/backpack/cabal/bkpcabal07/Makefile - testsuite/tests/backpack/should_compile/T20396.stderr - testsuite/tests/backpack/should_fail/bkpfail17.stderr - testsuite/tests/cabal/T12485/Makefile - + testsuite/tests/cabal/T27013a/Makefile - + testsuite/tests/cabal/T27013a/Setup.hs - + testsuite/tests/cabal/T27013a/all.T - + testsuite/tests/cabal/T27013a/composition.cabal - + testsuite/tests/cabal/T27013a/src/Data/Composition.hs - + testsuite/tests/cabal/T27013d/Composition.hs - + testsuite/tests/cabal/T27013d/Makefile - + testsuite/tests/cabal/T27013d/T27013d.stdout - + testsuite/tests/cabal/T27013d/all.T - testsuite/tests/callarity/unittest/CallArity1.hs - testsuite/tests/corelint/LintEtaExpand.hs - testsuite/tests/corelint/T21115b.stderr - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_compile/T13208.stdout - testsuite/tests/deSugar/should_compile/T16615.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/default/DefaultImportFail01.stderr - testsuite/tests/default/DefaultImportFail02.stderr - testsuite/tests/default/DefaultImportFail03.stderr - testsuite/tests/default/DefaultImportFail04.stderr - testsuite/tests/default/DefaultImportFail05.stderr - testsuite/tests/default/DefaultImportFail07.stderr - testsuite/tests/default/T25775.stderr - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/deriving/should_compile/T20496.stderr - testsuite/tests/diagnostic-codes/codes.stdout - + testsuite/tests/driver/T27013b/Makefile - + testsuite/tests/driver/T27013b/T27013b.stdout - + testsuite/tests/driver/T27013b/X.hs - + testsuite/tests/driver/T27013b/all.T - + testsuite/tests/driver/T27013c/Makefile - + testsuite/tests/driver/T27013c/T27013c.stdout - + testsuite/tests/driver/T27013c/X.hs - + testsuite/tests/driver/T27013c/all.T - + testsuite/tests/driver/T27013e/T27013e.hs - + testsuite/tests/driver/T27013e/T27013e.stderr - + testsuite/tests/driver/T27013e/all.T - + testsuite/tests/driver/T27013f/T27013f.hs - + testsuite/tests/driver/T27013f/T27013f.stderr - + testsuite/tests/driver/T27013f/all.T - testsuite/tests/driver/T3007/A/Internal.hs - testsuite/tests/driver/T3007/Makefile - testsuite/tests/driver/make-prim/Makefile - testsuite/tests/driver/recomp24656/Makefile - testsuite/tests/driver/recomp24656/recomp24656.stdout - testsuite/tests/ghc-api/T8628.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghci.debugger/scripts/break006.stderr - testsuite/tests/ghci.debugger/scripts/print019.stderr - testsuite/tests/ghci/scripts/all.T - testsuite/tests/hiefile/should_run/T23120.stdout - testsuite/tests/iface/IfaceSharingIfaceType.hs - testsuite/tests/iface/IfaceSharingName.hs - testsuite/tests/indexed-types/should_fail/T12522a.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/javascript/Makefile - testsuite/tests/javascript/T24495.hs - testsuite/tests/numeric/should_compile/T14170.stdout - testsuite/tests/numeric/should_compile/T14465.stdout - testsuite/tests/numeric/should_compile/T7116.stdout - testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr - testsuite/tests/package/all.T - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/T16270h.hs - testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr - testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/perf/should_run/ByteCodeAsm.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInvalid.hs - testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/simple-plugin/Simple/ReplacePlugin.hs - testsuite/tests/plugins/static-plugins.stdout - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/profiling/should_run/callstack002.stderr - testsuite/tests/profiling/should_run/callstack002.stdout - testsuite/tests/rename/should_compile/T3103/Foreign/Ptr.hs - testsuite/tests/rename/should_compile/T3103/GHC/Base.lhs - testsuite/tests/rename/should_compile/T3103/GHC/Word.hs - testsuite/tests/rename/should_compile/T3103/test.T - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles13.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/simplCore/should_compile/T13543.stderr - testsuite/tests/simplCore/should_compile/T16038/T16038.stdout - testsuite/tests/simplCore/should_compile/T3717.stderr - testsuite/tests/simplCore/should_compile/T3772.stdout - testsuite/tests/simplCore/should_compile/T4908.stderr - testsuite/tests/simplCore/should_compile/T4930.stderr - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplCore/should_compile/T8274.stdout - testsuite/tests/simplCore/should_compile/T9400.stderr - testsuite/tests/simplCore/should_compile/noinline01.stderr - testsuite/tests/simplCore/should_compile/par01.stderr - testsuite/tests/simplCore/should_compile/rule2.stderr - testsuite/tests/simplCore/should_compile/str-rules.hs - testsuite/tests/tcplugins/ArgsPlugin.hs - testsuite/tests/tcplugins/EmitWantedPlugin.hs - testsuite/tests/tcplugins/RewritePlugin.hs - testsuite/tests/tcplugins/T26395_Plugin.hs - testsuite/tests/tcplugins/TyFamPlugin.hs - testsuite/tests/th/T14741.hs - testsuite/tests/th/T21547.stderr - testsuite/tests/th/T26568.stderr - testsuite/tests/th/TH_Roles2.stderr - + testsuite/tests/th/TH_pragmaSpecOld.hs - + testsuite/tests/th/TH_pragmaSpecOld.stderr - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/T13032.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes2.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T12921.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr - testsuite/tests/typecheck/should_fail/T15883b.stderr - testsuite/tests/typecheck/should_fail/T15883c.stderr - testsuite/tests/typecheck/should_fail/T15883d.stderr - testsuite/tests/typecheck/should_fail/T21130.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T5095.stderr - testsuite/tests/typecheck/should_fail/T7279.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_PatternBindingExistential.stderr - testsuite/tests/typecheck/should_fail/tcfail072.stderr - testsuite/tests/typecheck/should_fail/tcfail097.stderr - testsuite/tests/typecheck/should_fail/tcfail133.stderr - testsuite/tests/typecheck/should_run/T22510.stdout - testsuite/tests/unboxedsums/UbxSumLevPoly.hs - testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs - testsuite/tests/warnings/should_compile/DerivingTypeable.stderr - utils/check-exact/Utils.hs - utils/genprimopcode/Main.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/076444047b72876d01a3fd336f800ec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/076444047b72876d01a3fd336f800ec… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: base: Display ExceptionContext in WhileHandling's textual description
by Marge Bot (＠marge-bot) 16 Jul '26

16 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: ede4b17b by Ben Gamari at 2026-07-15T22:59:53-04:00 base: Display ExceptionContext in WhileHandling's textual description As originally-implemented the implementation for `WhileHandling(displayExceptionAnnotation)` would display the `ExceptionContext` of the exception which it carries (as this was the behavior of `displayException`, in terms of which `displayExceptionAnnotation` was implemented). However, in 284ffab3 the definition of `SomeException(displayException)` was changed to exclude the `ExceptionContext`. This means that `WhileHandling(displayExceptionAnnotation)` fails to describe the provenance of the exception which it captures, greatly limiting its utility. Return the implementation to its originally-specified behavior by implementing `WhileHandling(displayExceptionAnnotation)` in terms of `displayExceptionWithInfo`. Fixes #27456. - - - - - 318426f9 by Cheng Shao at 2026-07-16T09:16:34-04:00 bindist: Fix make install -j race condition on macos/freebsd This patch fixes make install -j race condition on macos/freebsd. BSD install fails with EEXIST when multiple install processes concurrently create the same prefix directory. So we add an `install_dirs` prerequisite job that sequentially creates the directories for subsequent jobs to work with. Fixes #27499. Co-authored-by: Codex <codex(a)openai.com> - - - - - 98239515 by Cheng Shao at 2026-07-16T09:16:34-04:00 ci: run bindist make install with -j This patch makes the ci scripts run `make install` with `-j` to reduce wall clock time when installing the bindist, see related issue for benchmark numbers. This only affects ghc ci logic, the user-facing default is up to distributors and is still `-j1`. Closes #27029. - - - - - 3e7b9a20 by Adam Gundry at 2026-07-16T09:16:37-04:00 Mark various language extension flags as deprecated (see #27329) The following language extensions are now deprecated: - AlternativeLayoutRule - AlternativeLayoutRuleTransitional - ParallelArrays - PolymorphicComponents - Rank2Types In addition, the warning `-Walternative-layout-rule-transitional` has been marked as deprecated, as it is emitted only under the deprecated extension `XAlternativeLayoutRuleTransitional`. - - - - - 63 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - + changelog.d/T27329 - + changelog.d/T27456 - + changelog.d/fix-make-install-j - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Types/Rank.hs - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/static_pointers.rst - hadrian/bindist/Makefile - libraries/base/changelog.md - libraries/base/tests/T15349.stderr - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/tests/backtraces/T14532b.stdout - testsuite/tests/backpack/should_compile/T13149.bkp - testsuite/tests/codeGen/should_run/cgrun025.stderr - testsuite/tests/determinism/determ017/A.hs - testsuite/tests/exceptions/T26759.stderr - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghci/scripts/T12005.script - testsuite/tests/haddock/perf/Fold.hs - testsuite/tests/indexed-types/should_fail/T7354.hs - testsuite/tests/layout/layout001.stdout - testsuite/tests/layout/layout002.stdout - testsuite/tests/layout/layout003.stdout - testsuite/tests/layout/layout004.stdout - testsuite/tests/layout/layout005.stdout - testsuite/tests/layout/layout006.stdout - testsuite/tests/layout/layout007.stdout - testsuite/tests/layout/layout008.stdout - testsuite/tests/layout/layout009.stdout - testsuite/tests/linear/should_compile/T1735Min.hs - testsuite/tests/mdo/should_fail/mdofail006.stderr - + testsuite/tests/parser/should_compile/T13087.stderr - testsuite/tests/parser/should_fail/T8431.stderr - testsuite/tests/parser/should_fail/readFail038.stderr - testsuite/tests/perf/compiler/T3064.hs - testsuite/tests/polykinds/T7594.hs - testsuite/tests/programs/thurston-modular-arith/Main.hs - testsuite/tests/rts/ipe/IpeStats/Fold.hs - testsuite/tests/runghc/T7859.stderr-mingw32 - testsuite/tests/simplCore/should_compile/T11562.hs - testsuite/tests/simplCore/should_run/T3591.hs - testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs - testsuite/tests/typecheck/should_compile/T12507.hs - testsuite/tests/typecheck/should_compile/T13951.hs - testsuite/tests/typecheck/should_compile/T18920.hs - testsuite/tests/typecheck/should_compile/T2595.hs - testsuite/tests/typecheck/should_compile/T7541.hs - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7368a.hs - testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs - testsuite/tests/typecheck/should_run/T3731-short.hs - testsuite/tests/typecheck/should_run/T3731.hs - testsuite/tests/typecheck/should_run/church.hs - testsuite/tests/typecheck/should_run/tcrun008.hs - testsuite/tests/typecheck/should_run/tcrun017.hs - testsuite/tests/typecheck/should_run/tcrun026.hs - testsuite/tests/typecheck/should_run/tcrun035.hs - testsuite/tests/typecheck/should_run/tcrun036.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/19e4b6309defad6637d0e36d01c498… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/19e4b6309defad6637d0e36d01c498… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27461] Organize and clean-up GHC.Driver.Downsweep
by Rodrigo Mesquita (＠alt-romes) 16 Jul '26

16 Jul '26

Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC Commits: df2fc25c by Rodrigo Mesquita at 2026-07-16T12:21:55+01:00 Organize and clean-up GHC.Driver.Downsweep Simply some cosmetic changes, moving definitions around to structure the module better into its relevant sections (In go (ns ++ ss), it's not a problem to use ++ because it's a good producer and we won't have to append fully before processing the next item in go) - - - - - 1 changed file: - compiler/GHC/Driver/Downsweep.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -5,8 +5,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FunctionalDependencies #-} module GHC.Driver.Downsweep ( downsweep , downsweepThunk @@ -148,6 +146,9 @@ See also Note [Downsweep Control Flow and Caching] -} ----------------------------------------------------------------------------- +-- * Top-level entry to downsweep +----------------------------------------------------------------------------- + -- -- | Downsweep (dependency analysis) for --make mode -- @@ -159,7 +160,7 @@ See also Note [Downsweep Control Flow and Caching] -- cache to avoid recalculating a module summary if the source is -- unchanged. -- --- Downsweeping can start from scratch for from a given module graph. In the +-- Downsweeping can start from scratch or from a given module graph. In the -- latter case, the given graph is fully included in the resulting graph, even -- if parts of it are not reachable from any of the given roots. When an import -- is processed, the source of the imported module is not consulted if this @@ -231,6 +232,35 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo unitModuleNodes summaries uid hue = maybeToList (linkNodes summaries uid hue) + -- The linking plan for each module. If we need to do linking for a home unit + -- then this function returns a graph node which depends on all the modules in the home unit. + + -- At the moment nothing can depend on these LinkNodes. + linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode) + linkNodes summaries uid hue = + let dflags = homeUnitEnv_dflags hue + ofile = outputFile_ dflags + + unit_nodes :: [NodeKey] + unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries) + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + no_hs_main = gopt Opt_NoHsMain dflags + + main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes + + do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib + + in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking -> + Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) + -- This should be an error, not a warning (#10895). + | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) + | otherwise -> Nothing + -- | Calculate the module graph starting from a single ModSummary. The result is a -- thunk, which when forced will perform the downsweep. This is useful in oneshot -- mode where the module graph may never be needed. @@ -322,7 +352,32 @@ downsweepInstalledModules hsc_env mods = do return (mkModuleGraph mg) +----------------------------------------------------------------------------- +-- * Orchestrator: downsweepFromRootNodes +----------------------------------------------------------------------------- +type ModSummaryCache = IORef ModSummaryCacheMap +type ImportsCache = IORef ImportsCacheMap + +-- | A cache from file paths to the already summarised modules. The same file +-- can be used in multiple units so the map is actually also keyed by which +-- unit the file was used in. +-- +-- We want to reuse ModSummaries as far as possible because the most expensive +-- part of downsweep is reading and parsing the headers. +-- +-- See Note [Downsweep Control Flow and Caching] +type ModSummaryCacheMap + -- The cache can't be keyed by 'Module' because that isn't sufficient to + -- distinguish .hs from .hs-boot files. Use path+unit instead. + = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) ) + +data SummProvenance + -- | Constructed during this downsweep: trivially up to date + = SummFresh + -- | Carried over from a previous run: may be stale, must be hash-checked + -- (and considered by -fforce-recomp) + | SummOld -- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used -- by --make mode, and fixed nodes by oneshot mode. @@ -387,14 +442,9 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods sec = initSourceErrorContext (hsc_dflags hsc_env) -calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] -calcDeps ms = - -- Add a dependency on the HsBoot file if it exists - -- This gets passed to the loopImports function which just ignores it if it - -- can't be found. - [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ - [(lvl, b, c) | (lvl, b, c) <- msDeps ms ] - +-------------------------------------------------------------------------------- +-- ** 'DownsweepM' +-------------------------------------------------------------------------------- type DownsweepM a = ReaderT DownsweepEnv IO a data DownsweepEnv = DownsweepEnv { @@ -405,29 +455,6 @@ data DownsweepEnv = DownsweepEnv { , _downsweep_excl_mods :: [ModuleName] } -type ModSummaryCache = IORef ModSummaryCacheMap -type ImportsCache = IORef ImportsCacheMap - --- | A cache from file paths to the already summarised modules. The same file --- can be used in multiple units so the map is actually also keyed by which --- unit the file was used in. --- --- We want to reuse ModSummaries as far as possible because the most expensive --- part of downsweep is reading and parsing the headers. --- --- See Note [Downsweep Control Flow and Caching] -type ModSummaryCacheMap - -- The cache can't be keyed by 'Module' because that isn't sufficient to - -- distinguish .hs from .hs-boot files. Use path+unit instead. - = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) ) - -data SummProvenance - -- | Constructed during this downsweep: trivially up to date - = SummFresh - -- | Carried over from a previous run: may be stale, must be hash-checked - -- (and considered by -fforce-recomp) - | SummOld - mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs @@ -471,6 +498,8 @@ loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit h loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst) loopFromInteractive base_map m = loopDownsweepNodes base_map . (:[]) . DSInteractive m +-------------------------------------------------------------------------------- +-- * Expanding 'DownsweepNode's into payload and node dependencies -------------------------------------------------------------------------------- -- | A 'DownsweepNode' is the basic block of the downsweep algorithm which @@ -530,7 +559,24 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do hsc_env <- asks downsweep_hsc_env let home_uid = ms_unitid ms home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) - (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do + (final_deps, todo) <- unzip <$> mapM (expandModImport home_uid home_unit) (calcDeps ms) + + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + boot_todo <- + if | HsBootFile <- ms_hsc_src ms + -> do + r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing + case r of + FoundHome s -> pure [DSMod s] + _ -> pure [] + | otherwise -> pure [] + + return $ NSuccess + ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms) + , boot_todo ++ concat todo + ) + where + expandModImport home_uid home_unit (imp,mb_pkg,gwib) = do let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib wanted_mod = L loc mod mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing @@ -552,20 +598,13 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do ( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s)) , [DSMod s] ) - -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. - boot_todo <- - if | HsBootFile <- ms_hsc_src ms - -> do - r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing - case r of - FoundHome s -> pure [DSMod s] - _ -> pure [] - | otherwise -> pure [] - - return $ NSuccess - ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms) - , boot_todo ++ concat todo - ) + calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + calcDeps ms = + -- Add a dependency on the HsBoot file if it exists + -- This gets passed to the loopImports function which just ignores it if it + -- can't be found. + [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ + [(lvl, b, c) | (lvl, b, c) <- msDeps ms ] -- | Expand a 'ModuleNodeFixed' node -- NB: If you ever reach a Fixed node, everything under that also must be fixed. @@ -603,7 +642,7 @@ expandFixedModuleNode key loc = do pure $ Just $ DSMod (ModuleNodeFixed key loc) _otherwise -> -- If the finder fails, just keep going, there will be another - -- error later. + -- error later when we try to expand this dependency. pure Nothing mk_dep _ (Right uid_dep) = do -- Set active unit so that looking loopUnit finds the correct @@ -611,6 +650,19 @@ expandFixedModuleNode key loc = do let home_uid = mnkUnitId key pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid}) + mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge + mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) + mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) + + ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] + ifaceDeps deps = + [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) + | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) + ] ++ + [ Right (tcImportLevel lvl, uid) + | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) + ] + -- | Expand a unit id under the context of a certain home unit expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -} -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode])) @@ -686,19 +738,8 @@ expandInteractiveImports imod imps = do node_type = ModuleNodeFixed key ml -------------------------------------------------------------------------------- - -mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge -mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) -mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) - -ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] -ifaceDeps deps = - [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) - | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) - ] ++ - [ Right (tcImportLevel lvl, uid) - | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) - ] +-- * Constructing Module Summaries +-------------------------------------------------------------------------------- downsweepSummarise :: HomeUnit -> IsBootInterface @@ -745,35 +786,6 @@ instantiationNodes uid unit_state = map (uid,) iuids_to_check , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst ] --- The linking plan for each module. If we need to do linking for a home unit --- then this function returns a graph node which depends on all the modules in the home unit. - --- At the moment nothing can depend on these LinkNodes. -linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode) -linkNodes summaries uid hue = - let dflags = homeUnitEnv_dflags hue - ofile = outputFile_ dflags - - unit_nodes :: [NodeKey] - unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries) - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - no_hs_main = gopt Opt_NoHsMain dflags - - main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes - - do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib - - in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking -> - Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) - -- This should be an error, not a warning (#10895). - | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) - | otherwise -> Nothing - getRootSummary :: [ModuleName] -> ModSummaryCache -> @@ -858,6 +870,10 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do throwIO e a -> pure a +-------------------------------------------------------------------------------- +-- * Check/validate properties and error out +-------------------------------------------------------------------------------- + -- | This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -- @@ -905,6 +921,10 @@ checkHomeUnitsClosed ue let todo'' = (depends Set.\\ done) `Set.union` todo' in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' +-------------------------------------------------------------------------------- +-- * Enable Code Gen for Template Haskell +-------------------------------------------------------------------------------- + -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to -- the specified target, disable optimization and change the .hi @@ -1223,7 +1243,8 @@ Potential TODOS: -} ----------------------------------------------------------------------------- --- Summarising modules +-- * Pre-processing and Summarising and modules +----------------------------------------------------------------------------- -- We have two types of summarisation: -- @@ -1639,6 +1660,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do return PreprocessedImports {..} -------------------------------------------------------------------------------- +-- * Generic traversal of iteratively-built graph: dfsBuild +-------------------------------------------------------------------------------- -- | The result of expanding a node in 'dfsBuild'. data MGRes v @@ -1657,8 +1680,8 @@ data MGRes v -- graph by iteratively expanding a node into a payload and a list of children -- nodes to visit next. -- --- A node is NEVER visited/expanded more than once, as long as the the --- node key @k@, computed from the node @n@, uniquely identifies that node. +-- A node is NEVER visited/expanded more than once, as long as the node key +-- @k@, computed from the node @n@, uniquely identifies that node. -- -- The first argument @base_map@ is the starting set of already visited nodes -- (these nodes won't be expanded again!). @@ -1704,7 +1727,7 @@ dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map) go ss (Map.insert k NSkip visited) -- Skip! NSuccess (v,ns) -> - go (ns ++ ss {- todo: not use ++ here? -}) + go (ns ++ ss) (Map.insert k (NSuccess v) visited) where k = key s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df2fc25cecae6aff5820518fb4a6107… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df2fc25cecae6aff5820518fb4a6107… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0