[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Deriving-via one-shot strict state Monad instances
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jul 31 08:56:12 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
34432558 by Rodrigo Mesquita at 2024-07-31T04:55:50-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
- - - - -
17d4c72f by Sylvain Henry at 2024-07-31T04:56:02-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
- - - - -
847e8052 by Matthew Pickering at 2024-07-31T04:56:03-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
- - - - -
12 changed files:
- compiler/GHC/Cmm/GenericOpt.hs
- compiler/GHC/CmmToAsm/Reg/Linear/State.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/GHC/Utils/Monad/State/Strict.hs
- 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
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/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/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' #)
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee5cfbf15522a5b5ed71468afbdc9e2387a5f850...847e805265f2fe06c1fb68abf1b009b5bb2e74d1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee5cfbf15522a5b5ed71468afbdc9e2387a5f850...847e805265f2fe06c1fb68abf1b009b5bb2e74d1
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/20240731/42b4dc00/attachment-0001.html>
More information about the ghc-commits
mailing list