[Git][ghc/ghc][wip/eps-hpt] get external rules
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Feb 21 14:47:49 UTC 2025
Matthew Pickering pushed to branch wip/eps-hpt at Glasgow Haskell Compiler / GHC
Commits:
4395b83c by Matthew Pickering at 2025-02-21T14:47:39+00:00
get external rules
- - - - -
6 changed files:
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Module/External/Graph.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -43,7 +43,7 @@ import GHC.Prelude hiding ( read )
import GHC.Driver.DynFlags
import GHC.Driver.Env
-import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv )
+import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv, extendRuleBaseList )
import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount )
import GHC.Types.Annotations
@@ -72,6 +72,7 @@ import Data.Maybe (listToMaybe)
import Data.Word
import Control.Monad
import Control.Applicative ( Alternative(..) )
+import qualified GHC.Unit.Home.Graph as HUG
data FloatOutSwitches = FloatOutSwitches
{ floatOutLambdas :: Maybe Int -- ^ Just n <=> float lambdas to top level, if
@@ -255,7 +256,17 @@ initRuleEnv guts
; return (mkRuleEnv guts eps_rules hpt_rules) }
getExternalRuleBase :: CoreM RuleBase
-getExternalRuleBase = eps_rule_base <$> get_eps
+getExternalRuleBase = do
+ eps_rules <- eps_rule_base <$> get_eps
+ hug <- hsc_HUG <$> getHscEnv
+
+ dflags <- getDynFlags
+ hpt_rules <- liftIO $ if (isOneShot (ghcMode dflags)) then HUG.allRules hug else return []
+ let final = extendRuleBaseList eps_rules hpt_rules
+ return final
+
+
+
getNamePprCtx :: CoreM NamePprCtx
getNamePprCtx = read cr_name_ppr_ctx
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -637,7 +637,6 @@ loadInterface doc_str mod from
else do
details <- liftIfG $ typecheckIface iface
mb_object <- liftIO $ findObjectLinkableMaybe (mi_module iface) loc
- -- TODO, make lazy
mb_bytecode <- liftIO $ case loadIfaceByteCodeLazy hsc_env iface loc (md_types details) of
Just l -> Just <$> l
Nothing -> return Nothing
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -494,6 +494,7 @@ data TcGblEnv
-- bound in this module when dealing with hi-boot recursions
-- Updated at intervals (e.g. after dealing with types and classes)
+ -- Should only contain things defined in module
tcg_inst_env :: !InstEnv,
-- ^ Instance envt for all /home-package/ modules;
-- Includes the dfuns in tcg_insts
=====================================
compiler/GHC/Unit/Home/Graph.hs
=====================================
@@ -40,6 +40,7 @@ module GHC.Unit.Home.Graph
-- * Very important queries
, allInstances
+ , allRules
, allFamInstances
, allAnns
, allCompleteSigs
@@ -88,6 +89,8 @@ import GHC.Types.Annotations
import GHC.Types.CompleteMatch
import GHC.Core.InstEnv
+import GHC.Core
+
-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across
-- all home units.
@@ -104,6 +107,15 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where
go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b'))
(hptAllInstances (homeUnitEnv_hpt hue))
+-- | Find all the instance declarations (of classes and families) from
+-- the Home Package Table filtered by the provided predicate function.
+-- Used in @tcRnImports@, to select the instances that are in the
+-- transitive closure of imports from the currently compiled module.
+allRules :: HomeUnitGraph -> IO [CoreRule]
+allRules hug = foldr go (pure []) hug where
+ go hue = liftA2 (\b b' -> (b ++ b'))
+ (hptAllRules (homeUnitEnv_hpt hue))
+
allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv)
allFamInstances hug = foldr go (pure emptyModuleEnv) hug where
go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue))
=====================================
compiler/GHC/Unit/Home/PackageTable.hs
=====================================
@@ -43,6 +43,7 @@ module GHC.Unit.Home.PackageTable
, hptAllInstances
, hptAllFamInstances
, hptAllAnnotations
+ , hptAllRules
-- ** More Traversal-based queries
, hptCollectDependencies
@@ -95,6 +96,7 @@ import GHC.Unit.Module.ModIface
import GHC.Utils.Outputable
import GHC.Types.Unique (getUnique, getKey)
import qualified GHC.Data.Word64Set as W64
+import GHC.Core
-- | Helps us find information about modules in the home package
newtype HomePackageTable = HPT {
@@ -220,6 +222,10 @@ hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiF
hptAllAnnotations :: HomePackageTable -> IO AnnEnv
hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details)
+-- | All annotations from the HPT
+hptAllRules :: HomePackageTable -> IO [CoreRule]
+hptAllRules = concatHpt (md_rules . hm_details)
+
--------------------------------------------------------------------------------
-- * Traversal-based queries
=====================================
compiler/GHC/Unit/Module/External/Graph.hs
=====================================
@@ -9,7 +9,7 @@ module GHC.Unit.Module.External.Graph
-- | A module graph for the EPS.
ExternalModuleGraph, ExternalGraphNode(..)
, ExternalKey(..), emptyExternalModuleGraph
- , emgNodeKey, emgNodeDeps, emgLookupKey
+ , emgNodeKey, emgNodeDeps
-- * Extending
--
@@ -123,10 +123,6 @@ emgNodeKey :: ExternalGraphNode -> ExternalKey
emgNodeKey (NodeHomePackage k _) = ExternalModuleKey k
emgNodeKey (NodeExternalPackage k _) = ExternalPackageKey k
--- | Lookup a key in the EMG.
-emgLookupKey :: ExternalKey -> ExternalModuleGraph -> Maybe ExternalGraphNode
-emgLookupKey k emg = node_payload <$> (snd (external_trans emg)) k
-
--------------------------------------------------------------------------------
-- * Extending
--------------------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4395b83c0ca3c6e23de8cf8f01a0c095a9ad1068
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4395b83c0ca3c6e23de8cf8f01a0c095a9ad1068
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/20250221/09291527/attachment-0001.html>
More information about the ghc-commits
mailing list