[Git][ghc/ghc][wip/romes/25104] 8 commits: Deriving-via one-shot strict state Monad instances
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu Aug 1 15:15:43 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/25104 at Glasgow Haskell Compiler / GHC
Commits:
72b54c07 by Rodrigo Mesquita at 2024-08-01T00:47:29-04:00
Deriving-via one-shot strict state Monad instances
A small refactor to use deriving via GHC.Utils.Monad.State.Strict
Monad instances for state Monads with unboxed/strict results which all
re-implemented the one-shot trick in the instance and used unboxed
tuples:
* CmmOptM in GHC.Cmm.GenericOpt
* RegM in GHC.CmmToAsm.Reg.Linear.State
* UniqSM in GHC.Types.Unique.Supply
- - - - -
bfe4b3d3 by doyougnu at 2024-08-01T00:48:06-04:00
Rts linker: add case for pc-rel 64 relocation
part of the upstream haskell.nix patches
- - - - -
5843c7e3 by doyougnu at 2024-08-01T00:48:42-04:00
RTS linker: aarch64: better debug information
Dump better debugging information when a symbol address is null.
Part of the haskell.nix patches upstream project
Co-authored-by: Sylvain Henry <sylvain at haskus.fr>
- - - - -
c2e9c581 by Rodrigo Mesquita at 2024-08-01T00:49:18-04:00
base: Add haddocks to HasExceptionContext
Fixes #25091
- - - - -
f954f428 by Sylvain Henry at 2024-08-01T00:49:59-04:00
Only lookup ghcversion.h file in the RTS include-dirs by default.
The code was introduced in 3549c952b535803270872adaf87262f2df0295a4.
It used `getPackageIncludePath` which name doesn't convey that it looks
into all include paths of the preload units too. So this behavior is
probably unintentional and it should be ok to change it.
Fix #25106
- - - - -
951ce3d5 by Matthew Pickering at 2024-08-01T00:50:35-04:00
driver: Fix -Wmissing-home-modules when multiple units have the same module name
It was assumed that module names were unique but that isn't true with
multiple units.
The fix is quite simple, maintain a set of `(ModuleName, UnitId)` and
query that to see whether the module has been specified.
Fixes #25122
- - - - -
bae1fea4 by sheaf at 2024-08-01T00:51:15-04:00
PMC: suggest in-scope COMPLETE sets when possible
This commit modifies GHC.HsToCore.Pmc.Solver.generateInhabitingPatterns
to prioritise reporting COMPLETE sets in which all of the ConLikes
are in scope. This avoids suggesting out of scope constructors
when displaying an incomplete pattern match warning, e.g. in
baz :: Ordering -> Int
baz = \case
EQ -> 5
we prefer:
Patterns of type 'Ordering' not matched:
LT
GT
over:
Patterns of type 'Ordering' not matched:
OutOfScope
Fixes #25115
- - - - -
346ac5c5 by Rodrigo Mesquita at 2024-08-01T16:15:29+01:00
hi: Stable sort avails
Sorting the Avails in DocStructures is required to produce fully
deterministic interface files in presence of re-exported modules.
Fixes #25104
- - - - -
27 changed files:
- compiler/GHC/Cmm/GenericOpt.hs
- compiler/GHC/CmmToAsm/Reg/Linear/State.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Types/Avail.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/GHC/Utils/Monad/State/Strict.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- rts/linker/PEi386.c
- rts/linker/elf_reloc_aarch64.c
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/driver/multipleHomeUnits/T25122/T25122.hs
- testsuite/tests/driver/multipleHomeUnits/all.T
- + testsuite/tests/driver/multipleHomeUnits/unitSame1
- + testsuite/tests/driver/multipleHomeUnits/unitSame2
- + testsuite/tests/pmcheck/complete_sigs/T25115.hs
- + testsuite/tests/pmcheck/complete_sigs/T25115.stderr
- + testsuite/tests/pmcheck/complete_sigs/T25115a.hs
- testsuite/tests/pmcheck/complete_sigs/all.T
- testsuite/tests/showIface/HaddockIssue849.stdout
Changes:
=====================================
compiler/GHC/Cmm/GenericOpt.hs
=====================================
@@ -5,6 +5,7 @@
--
-- -----------------------------------------------------------------------------
+{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -26,7 +27,8 @@ import GHC.Cmm.Opt ( cmmMachOpFold )
import GHC.Cmm.CLabel
import GHC.Data.FastString
import GHC.Unit
-import Control.Monad
+import Control.Monad.Trans.Reader
+import GHC.Utils.Monad.State.Strict as Strict
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser
@@ -67,19 +69,7 @@ pattern OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)
- deriving (Functor)
-
-instance Applicative CmmOptM where
- pure x = CmmOptM $ \_ imports -> OptMResult x imports
- (<*>) = ap
-
-instance Monad CmmOptM where
- (CmmOptM f) >>= g =
- CmmOptM $ \config imports0 ->
- case f config imports0 of
- OptMResult x imports1 ->
- case g x of
- CmmOptM g' -> g' config imports1
+ deriving (Functor, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel]))
instance CmmMakeDynamicReferenceM CmmOptM where
addImport = addImportCmmOpt
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/State.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms, DeriveFunctor #-}
+{-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -52,31 +52,24 @@ import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Exts (oneShot)
-import Control.Monad (ap)
+import GHC.Utils.Monad.State.Strict as Strict
-type RA_Result freeRegs a = (# RA_State freeRegs, a #)
+type RA_Result freeRegs a = (# a, RA_State freeRegs #)
-pattern RA_Result :: a -> b -> (# a, b #)
-pattern RA_Result a b = (# a, b #)
+pattern RA_Result :: a -> b -> (# b, a #)
+pattern RA_Result a b = (# b, a #)
{-# COMPLETE RA_Result #-}
-- | The register allocator monad type.
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
- deriving (Functor)
+ deriving (Functor, Applicative, Monad) via (Strict.State (RA_State freeRegs))
-- | Smart constructor for 'RegM', as described in Note [The one-shot state
-- monad trick] in GHC.Utils.Monad.
mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
mkRegM f = RegM (oneShot f)
-instance Applicative (RegM freeRegs) where
- pure a = mkRegM $ \s -> RA_Result s a
- (<*>) = ap
-
-instance Monad (RegM freeRegs) where
- m >>= k = mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
-
-- | Get native code generator configuration
getConfig :: RegM a NCGConfig
getConfig = mkRegM $ \s -> RA_Result s (ra_config s)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -329,10 +329,12 @@ warnMissingHomeModules dflags targets mod_graph =
-- Note also that we can't always infer the associated module name
-- directly from the filename argument. See #13727.
is_known_module mod =
- (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod))
+ is_module_target mod
||
maybe False is_file_target (ml_hs_file (ms_location mod))
+ is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets
+
is_file_target file = Set.member (withoutExt file) file_targets
file_targets = Set.fromList (mapMaybe file_target targets)
@@ -343,7 +345,7 @@ warnMissingHomeModules dflags targets mod_graph =
TargetFile file _ ->
Just (withoutExt (augmentByWorkingDirectory dflags file))
- mod_targets = Map.fromList (mod_target <$> targets)
+ mod_targets = Set.fromList (mod_target <$> targets)
mod_target Target {targetUnitId, targetId} =
case targetId of
=====================================
compiler/GHC/Hs/Doc.hs
=====================================
@@ -133,7 +133,12 @@ data DocStructureItem
-- > module M (module X) where
-- > import R0 as X
-- > import R1 as X
+ --
+ -- Invariant: This list of ModuleNames must be
+ -- sorted to guarantee interface file determinism.
!Avails
+ -- ^ Invariant: This list of Avails must be sorted
+ -- to guarantee interface file determinism.
instance Binary DocStructureItem where
put_ bh = \case
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -147,7 +147,6 @@ mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env =
-- TODO:
-- * Maybe remove items that export nothing?
-- * Combine sequences of DsiExports?
--- * Check the ordering of avails in DsiModExport
mkDocStructureFromExportList
:: Module -- ^ The current module
-> ImportAvails
@@ -162,13 +161,13 @@ mkDocStructureFromExportList mdl import_avails export_list =
(IEGroup _ level doc, _) -> DsiSectionHeading level (unLoc doc)
(IEDoc _ doc, _) -> DsiDocChunk (unLoc doc)
(IEDocNamed _ name, _) -> DsiNamedChunkRef name
- (_, avails) -> DsiExports (nubAvails avails)
+ (_, avails) -> DsiExports (nubSortAvails avails)
moduleExport :: ModuleName -- Alias
-> Avails
-> DocStructureItem
moduleExport alias avails =
- DsiModExport (nubSortNE orig_names) (nubAvails avails)
+ DsiModExport (nubSortNE orig_names) (nubSortAvails avails)
where
orig_names = M.findWithDefault aliasErr alias aliasMap
aliasErr = error $ "mkDocStructureFromExportList: "
@@ -179,6 +178,8 @@ mkDocStructureFromExportList mdl import_avails export_list =
Set.fromList .
NonEmpty.toList
+ nubSortAvails = sortAvails . nubAvails
+
-- Map from aliases to true module names.
aliasMap :: Map ModuleName (NonEmpty ModuleName)
aliasMap =
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -356,16 +356,16 @@ initTcDsForSolver thing_inside
= do { (gbl, lcl) <- getEnvs
; hsc_env <- getTopEnv
+ -- The DsGblEnv is used to inform the typechecker's solver of a few
+ -- key pieces of information:
+ --
+ -- - ds_fam_inst_env tells it how to reduce type families,
+ -- - ds_gbl_rdr_env tells it which newtypes it can unwrap.
; let DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
- , ds_gbl_rdr_env = rdr_env } = gbl
- -- This is *the* use of ds_gbl_rdr_env:
- -- Make sure the solver (used by the pattern-match overlap checker) has
- -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
- -- knows how to reduce type families, and which newtypes it can unwrap.
-
-
- DsLclEnv { dsl_loc = loc } = lcl
+ , ds_gbl_rdr_env = rdr_env
+ } = gbl
+ DsLclEnv { dsl_loc = loc } = lcl
; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Prelude
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)
+import GHC.HsToCore.Types (DsGblEnv(..))
import GHC.Driver.DynFlags
import GHC.Driver.Config
@@ -51,11 +52,14 @@ import GHC.Types.Unique.DSet
import GHC.Types.Unique.SDFM
import GHC.Types.Id
import GHC.Types.Name
-import GHC.Types.Var (EvVar)
+import GHC.Types.Name.Reader (lookupGRE_Name, GlobalRdrEnv)
+import GHC.Types.Var (EvVar)
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Supply
+import GHC.Tc.Utils.Monad (getGblEnv)
+
import GHC.Core
import GHC.Core.FVs (exprFreeVars)
import GHC.Core.TyCo.Compare( eqType )
@@ -97,6 +101,7 @@ import Data.List (sortBy, find)
import qualified Data.List.NonEmpty as NE
import Data.Ord (comparing)
+
--
-- * Main exports
--
@@ -1959,13 +1964,16 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
-- No COMPLETE sets ==> inhabited
generateInhabitingPatterns mode xs n newty_nabla
Just clss -> do
- -- Try each COMPLETE set, pick the one with the smallest number of
- -- inhabitants
+ -- Try each COMPLETE set.
nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)
- let nablas' = minimumBy (comparing length) nablass'
- if null nablas' && vi_bot vi /= IsNotBot
- then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!
- else pure nablas'
+ if any null nablass' && vi_bot vi /= IsNotBot
+ then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!
+ else do
+ -- Pick the residual COMPLETE set with the smallest cost (see 'completeSetCost').
+ -- See Note [Prefer in-scope COMPLETE matches].
+ DsGblEnv { ds_gbl_rdr_env = rdr_env } <- getGblEnv
+ let bestSet = map snd $ minimumBy (comparing $ completeSetCost rdr_env) nablass'
+ pure bestSet
-- Instantiates a chain of newtypes, beginning at @x at .
-- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact
@@ -1979,13 +1987,13 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y]
instantiate_newtype_chain y nabla' dcs
- instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [Nabla]
+ instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [(Maybe ConLike, Nabla)]
instantiate_cons _ _ _ _ _ [] = pure []
instantiate_cons _ _ _ 0 _ _ = pure []
instantiate_cons _ ty xs n nabla _
-- We don't want to expose users to GHC-specific constructors for Int etc.
| fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True
- = generateInhabitingPatterns mode xs n nabla
+ = map (Nothing,) <$> generateInhabitingPatterns mode xs n nabla
instantiate_cons x ty xs n nabla (cl:cls) = do
-- The following line is where we call out to the inhabitationTest!
mb_nabla <- runMaybeT $ instCon 4 nabla x cl
@@ -2002,7 +2010,54 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
-- inhabited, otherwise the inhabitation test would have refuted.
Just nabla' -> generateInhabitingPatterns mode xs n nabla'
other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls
- pure (con_nablas ++ other_cons_nablas)
+ pure (map (Just cl,) con_nablas ++ other_cons_nablas)
+
+-- | If multiple residual COMPLETE sets apply, pick one as follows:
+--
+-- - prefer COMPLETE sets in which all constructors are in scope,
+-- as per Note [Prefer in-scope COMPLETE matches],
+-- - if there are ties, pick the one with the fewest (residual) ConLikes,
+-- - if there are ties, pick the one with the fewest "trivially inhabited" types,
+-- - if there are ties, pick the one with the fewest PatSyns,
+-- - if there are still ties, pick the one that comes first in the list of
+-- COMPLETE pragmas, which means the one that was brought into scope first.
+completeSetCost :: GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
+completeSetCost _ [] = (False, 0, 0, 0)
+completeSetCost rdr_env ((mb_con, _) : cons) =
+ let con_out_of_scope
+ | Just con <- mb_con
+ = isNothing $ lookupGRE_Name rdr_env (conLikeName con)
+ | otherwise
+ = False
+ (any_out_of_scope, nb_cons, nb_triv, nb_ps) = completeSetCost rdr_env cons
+ in ( any_out_of_scope || con_out_of_scope
+ , nb_cons + 1
+ , nb_triv + case mb_con of { Nothing -> 1; _ -> 0 }
+ , nb_ps + case mb_con of { Just (PatSynCon {}) -> 1; _ -> 0 }
+ )
+
+{- Note [Prefer in-scope COMPLETE matches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prefer using COMPLETE pragmas in which all ConLikes are in scope, as this
+improves error messages. See for example T25115:
+
+ - T25115a defines pattern Foo :: a with {-# COMPLETE Foo #-}
+ - T25115 imports T25115a, but not Foo.
+ (This means it imports the COMPLETE pragma, which behaves like an instance.)
+
+ Then, for the following incomplete pattern match in T25115:
+
+ baz :: Ordering -> Int
+ baz = \case
+ EQ -> 5
+
+ we would prefer reporting that 'LT' and 'GT' are not matched, rather than
+ saying that 'T25115a.Foo' is not matched.
+
+ However, if ALL ConLikes are out of scope, then we should still report
+ something, so we don't want to outright filter out all COMPLETE sets
+ with an out-of-scope ConLike.
+-}
pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM DsCompleteMatches
-- See Note [Implementation of COMPLETE pragmas] on what "applicable" means
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -53,9 +53,9 @@ data DsGblEnv
= DsGblEnv
{ ds_mod :: Module -- For SCC profiling
, ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env
- , ds_gbl_rdr_env :: GlobalRdrEnv -- needed *only* to know what newtype
- -- constructors are in scope during
- -- pattern-match satisfiability checking
+ , ds_gbl_rdr_env :: GlobalRdrEnv -- needed only for the following reasons:
+ -- - to know what newtype constructors are in scope
+ -- - to check whether all members of a COMPLETE pragma are in scope
, ds_name_ppr_ctx :: NamePprCtx
, ds_msgs :: IORef (Messages DsMessage) -- Diagnostic messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -500,18 +500,7 @@ mkIfaceImports = map go
go (ImpUserSpec decl (ImpUserEverythingBut ns)) = IfaceImport decl (ImpIfaceEverythingBut ns)
mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical
-mkIfaceExports exports
- = sortBy stableAvailCmp (map sort_subs exports)
- where
- sort_subs :: AvailInfo -> AvailInfo
- sort_subs (Avail n) = Avail n
- sort_subs (AvailTC n []) = AvailTC n []
- sort_subs (AvailTC n (m:ms))
- | n == m
- = AvailTC n (m:sortBy stableNameCmp ms)
- | otherwise
- = AvailTC n (sortBy stableNameCmp (m:ms))
- -- Maintain the AvailTC Invariant
+mkIfaceExports = sortAvails
{-
Note [Original module]
=====================================
compiler/GHC/SysTools/Cpp.hs
=====================================
@@ -263,11 +263,17 @@ generateMacros prefix name version =
-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
getGhcVersionPathName dflags unit_env = do
- candidates <- case ghcVersionFile dflags of
- Just path -> return [path]
- Nothing -> do
- ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
- return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
+ let candidates = case ghcVersionFile dflags of
+ -- the user has provided an explicit `ghcversion.h` file to use.
+ Just path -> [path]
+ -- otherwise, try to find it in the rts' include-dirs.
+ -- Note: only in the RTS include-dirs! not all preload units less we may
+ -- use a wrong file. See #25106 where a globally installed
+ -- /usr/include/ghcversion.h file was used instead of the one provided
+ -- by the rts.
+ Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of
+ Nothing -> []
+ Just info -> (</> "ghcversion.h") <$> collectIncludeDirs [info]
found <- filterM doesFileExist candidates
case found of
=====================================
compiler/GHC/Types/Avail.hs
=====================================
@@ -19,6 +19,7 @@ module GHC.Types.Avail (
filterAvail,
filterAvails,
nubAvails,
+ sortAvails,
) where
import GHC.Prelude
@@ -36,7 +37,7 @@ import GHC.Utils.Constants (debugIsOn)
import Control.DeepSeq
import Data.Data ( Data )
import Data.Functor.Classes ( liftCompare )
-import Data.List ( find )
+import Data.List ( find, sortBy )
import qualified Data.Semigroup as S
-- -----------------------------------------------------------------------------
@@ -131,6 +132,20 @@ availSubordinateNames avail@(AvailTC _ ns)
| availExportsDecl avail = tail ns
| otherwise = ns
+-- | Sort 'Avails'/'AvailInfo's
+sortAvails :: Avails -> Avails
+sortAvails = sortBy stableAvailCmp . map sort_subs
+ where
+ sort_subs :: AvailInfo -> AvailInfo
+ sort_subs (Avail n) = Avail n
+ sort_subs (AvailTC n []) = AvailTC n []
+ sort_subs (AvailTC n (m:ms))
+ | n == m
+ = AvailTC n (m:sortBy stableNameCmp ms)
+ | otherwise
+ = AvailTC n (sortBy stableNameCmp (m:ms))
+ -- Maintain the AvailTC Invariant
+
-- -----------------------------------------------------------------------------
-- Utility
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -4,6 +4,7 @@
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -41,6 +42,7 @@ import Control.Monad
import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
import Foreign.Storable
+import GHC.Utils.Monad.State.Strict as Strict
#include "MachDeps.h"
@@ -304,6 +306,8 @@ uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
+{-# INLINE splitUniqSupply #-}
+
{-
************************************************************************
* *
@@ -320,12 +324,7 @@ pattern UniqResult x y = (# x, y #)
-- | A monad which just gives the ability to obtain 'Unique's
newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
-
--- See Note [The one-shot state monad trick] for why we don't derive this.
-instance Functor UniqSM where
- fmap f (USM m) = mkUniqSM $ \us ->
- case m us of
- (# r, us' #) -> UniqResult (f r) us'
+ deriving (Functor, Applicative, Monad) via (Strict.State UniqSupply)
-- | Smart constructor for 'UniqSM', as described in Note [The one-shot state
-- monad trick].
@@ -333,17 +332,6 @@ mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM f = USM (oneShot f)
{-# INLINE mkUniqSM #-}
-instance Monad UniqSM where
- (>>=) = thenUs
- (>>) = (*>)
-
-instance Applicative UniqSM where
- pure = returnUs
- (USM f) <*> (USM x) = mkUniqSM $ \us0 -> case f us0 of
- UniqResult ff us1 -> case x us1 of
- UniqResult xx us2 -> UniqResult (ff xx) us2
- (*>) = thenUs_
-
-- TODO: try to get rid of this instance
instance MonadFail UniqSM where
fail = panic
@@ -356,30 +344,12 @@ initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }
-{-# INLINE thenUs #-}
-{-# INLINE returnUs #-}
-{-# INLINE splitUniqSupply #-}
-
--- @thenUs@ is where we split the @UniqSupply at .
-
liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)
instance MonadFix UniqSM where
mfix m = mkUniqSM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)
-thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
-thenUs (USM expr) cont
- = mkUniqSM (\us0 -> case (expr us0) of
- UniqResult result us1 -> unUSM (cont result) us1)
-
-thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
-thenUs_ (USM expr) (USM cont)
- = mkUniqSM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })
-
-returnUs :: a -> UniqSM a
-returnUs result = mkUniqSM (\us -> UniqResult result us)
-
getUs :: UniqSM UniqSupply
getUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)
=====================================
compiler/GHC/Utils/Monad/State/Strict.hs
=====================================
@@ -4,7 +4,7 @@
-- | A state monad which is strict in its state.
module GHC.Utils.Monad.State.Strict
( -- * The State monad
- State(State)
+ State(State, State' {- for deriving via purposes only -})
, state
, evalState
, execState
@@ -78,8 +78,10 @@ pattern State m <- State' m
forceState :: (# a, s #) -> (# a, s #)
forceState (# a, !s #) = (# a, s #)
+-- See Note [The one-shot state monad trick] for why we don't derive this.
instance Functor (State s) where
fmap f m = State $ \s -> case runState' m s of (# x, s' #) -> (# f x, s' #)
+ {-# INLINE fmap #-}
instance Applicative (State s) where
pure x = State $ \s -> (# x, s #)
@@ -87,10 +89,20 @@ instance Applicative (State s) where
case runState' m s of { (# f, s' #) ->
case runState' n s' of { (# x, s'' #) ->
(# f x, s'' #) }}
+ m *> n = State $ \s ->
+ case runState' m s of { (# _, s' #) ->
+ case runState' n s' of { (# x, s'' #) ->
+ (# x, s'' #) }}
+ {-# INLINE pure #-}
+ {-# INLINE (<*>) #-}
+ {-# INLINE (*>) #-}
instance Monad (State s) where
m >>= n = State $ \s -> case runState' m s of
(# r, !s' #) -> runState' (n r) s'
+ (>>) = (*>)
+ {-# INLINE (>>=) #-}
+ {-# INLINE (>>) #-}
state :: (s -> (a, s)) -> State s a
state f = State $ \s -> case f s of (r, s') -> (# r, s' #)
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
=====================================
@@ -52,6 +52,19 @@ import GHC.Internal.Base
import GHC.Internal.Show
import GHC.Internal.Exception.Context
+{- |
+A constraint used to propagate 'ExceptionContext's.
+
+GHC will automatically default any unsolved 'HasExceptionContext' constraints to an
+empty exception context, similarly to 'HasCallStack'.
+
+NOTE: The fact that @HasExceptionContext@ is defined as an implicit parameter is
+an implementation detail and __should not__ be considered a part of the API.
+It does however mean that any implicit parameter `?exceptionContext :: ExceptionContext`
+will be subject to defaulting, as described above.
+
+ at since base-4.20.0.0
+-}
type HasExceptionContext = (?exceptionContext :: ExceptionContext)
{- |
=====================================
rts/linker/PEi386.c
=====================================
@@ -2096,6 +2096,15 @@ ocResolve_PEi386 ( ObjectCode* oc )
*(uint32_t *)pP = (uint32_t)v;
break;
}
+ case 14: /* R_X86_64_PC64 (ELF constant 24) - IMAGE_REL_AMD64_SREL32 (PE constant 14) */
+ {
+ /* mingw will emit this for a pc-rel 64 relocation */
+ uint64_t A;
+ checkProddableBlock(oc, pP, 8);
+ A = *(uint64_t*)pP;
+ *(uint64_t *)pP = S + A - (intptr_t)pP;
+ break;
+ }
case 4: /* R_X86_64_PC32 (ELF constant 2) - IMAGE_REL_AMD64_REL32 (PE constant 4) */
{
intptr_t v;
=====================================
rts/linker/elf_reloc_aarch64.c
=====================================
@@ -326,7 +326,8 @@ relocateObjectCodeAarch64(ObjectCode * oc) {
ELF64_R_SYM((Elf64_Xword)rel->r_info));
CHECK(0x0 != symbol);
- CHECK(0x0 != symbol->addr);
+ if(0x0 == symbol->addr)
+ barf("0x0 address for %s + %ld of type %ld in %s for relocation %d in section %d of kind: %d\n", symbol->name, rel->r_addend, ELF64_R_TYPE((Elf64_Xword)rel->r_info), OC_INFORMATIVE_FILENAME(oc), i, relaTab->targetSectionIndex, oc->sections[relaTab->targetSectionIndex].kind);
/* take explicit addend */
int64_t addend = rel->r_addend;
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -218,6 +218,7 @@ GHC.Utils.Lexeme
GHC.Utils.Logger
GHC.Utils.Misc
GHC.Utils.Monad
+GHC.Utils.Monad.State.Strict
GHC.Utils.Outputable
GHC.Utils.Panic
GHC.Utils.Panic.Plain
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -240,6 +240,7 @@ GHC.Utils.Lexeme
GHC.Utils.Logger
GHC.Utils.Misc
GHC.Utils.Monad
+GHC.Utils.Monad.State.Strict
GHC.Utils.Outputable
GHC.Utils.Panic
GHC.Utils.Panic.Plain
=====================================
testsuite/tests/driver/multipleHomeUnits/T25122/T25122.hs
=====================================
@@ -0,0 +1 @@
+module T25122 where
=====================================
testsuite/tests/driver/multipleHomeUnits/all.T
=====================================
@@ -71,6 +71,11 @@ test('multipleHomeUnits_shared', [extra_files([ 'A.hs', 'unitShared1', 'unitShar
test('multipleHomeUnits_shared_ghci', [extra_files([ 'shared.script', 'A.hs', 'unitShared1', 'unitShared2']), extra_run_opts('-unit @unitShared1 -unit @unitShared2')], ghci_script, ['shared.script'])
+test('T25122',
+ [ extra_files(
+ [ 'T25122', 'unitSame1', 'unitSame2'])
+ ], multiunit_compile, [['unitSame1', 'unitSame2'], '-v0 -fhide-source-paths -Werror -Wmissing-home-modules'])
+
=====================================
testsuite/tests/driver/multipleHomeUnits/unitSame1
=====================================
@@ -0,0 +1,3 @@
+T25122
+-iT25122
+-this-unit-id=s1
=====================================
testsuite/tests/driver/multipleHomeUnits/unitSame2
=====================================
@@ -0,0 +1,3 @@
+T25122
+-iT25122
+-this-unit-id=u2
=====================================
testsuite/tests/pmcheck/complete_sigs/T25115.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module T25115 where
+
+import T25115a ( ABC )
+
+-- Check that we don't suggest to use the 'Foo' pattern synonym from
+-- T25115a, as it is not imported (even though the import of T25115a
+-- has brought into scope all COMPLETE pragmas from that module).
+
+foo :: Bool -> Int
+foo = \case {}
+
+bar :: Bool -> Int
+bar = \case
+ True -> 3
+
+baz :: Ordering -> Int
+baz = \case
+ EQ -> 5
+
+-- Check that we do still suggest something for ABC, even though
+-- all constructors are out of scope.
+
+quux :: ABC -> Int
+quux = \case {}
=====================================
testsuite/tests/pmcheck/complete_sigs/T25115.stderr
=====================================
@@ -0,0 +1,25 @@
+[1 of 2] Compiling T25115a ( T25115a.hs, T25115a.o )
+[2 of 2] Compiling T25115 ( T25115.hs, T25115.o )
+T25115.hs:14:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative:
+ Patterns of type ‘Bool’ not matched:
+ False
+ True
+
+T25115.hs:17:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative: Patterns of type ‘Bool’ not matched: False
+
+T25115.hs:21:7: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative:
+ Patterns of type ‘Ordering’ not matched:
+ LT
+ GT
+
+T25115.hs:28:8: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a \case alternative:
+ Patterns of type ‘ABC’ not matched: T25115a.Foo
+
=====================================
testsuite/tests/pmcheck/complete_sigs/T25115a.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T25115a ( pattern Foo, ABC ) where
+
+pattern Foo :: a
+pattern Foo <- _unused
+{-# COMPLETE Foo #-}
+
+data ABC = A | B | C
=====================================
testsuite/tests/pmcheck/complete_sigs/all.T
=====================================
@@ -32,3 +32,4 @@ test('T18960', normal, compile, [''])
test('T18960b', normal, compile, [''])
test('T19475', normal, compile, [''])
test('T24326', normal, compile, [''])
+test('T25115', [extra_files(['T25115a.hs'])], multimod_compile, ['T25115', ''])
=====================================
testsuite/tests/showIface/HaddockIssue849.stdout
=====================================
@@ -11,12 +11,12 @@ docs:
re-exported module(s): [Data.Functor.Identity]
[]
re-exported module(s): [Data.Maybe]
- [GHC.Internal.Maybe.Maybe{GHC.Internal.Maybe.Maybe,
- GHC.Internal.Maybe.Nothing, GHC.Internal.Maybe.Just},
- GHC.Internal.Data.Maybe.maybe]
+ [GHC.Internal.Data.Maybe.maybe,
+ GHC.Internal.Maybe.Maybe{GHC.Internal.Maybe.Maybe,
+ GHC.Internal.Maybe.Nothing, GHC.Internal.Maybe.Just}]
re-exported module(s): [Data.Tuple]
- [GHC.Internal.Data.Tuple.swap, GHC.Internal.Data.Tuple.curry,
- GHC.Internal.Data.Tuple.fst, GHC.Internal.Data.Tuple.snd,
+ [GHC.Internal.Data.Tuple.curry, GHC.Internal.Data.Tuple.fst,
+ GHC.Internal.Data.Tuple.snd, GHC.Internal.Data.Tuple.swap,
GHC.Internal.Data.Tuple.uncurry]
named chunks:
haddock options:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b4621e523f605974bd38d933c7fe79658e7bbd8...346ac5c5876ee553aa73d02a10fa281949c0caf7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b4621e523f605974bd38d933c7fe79658e7bbd8...346ac5c5876ee553aa73d02a10fa281949c0caf7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240801/f7c06a5d/attachment-0001.html>
More information about the ghc-commits
mailing list