[Git][ghc/ghc][wip/stability-flag] WIP
Josh Meredith (@JoshMeredith)
gitlab at gitlab.haskell.org
Mon Oct 9 12:35:55 UTC 2023
Josh Meredith pushed to branch wip/stability-flag at Glasgow Haskell Compiler / GHC
Commits:
ed0ddfc6 by Josh Meredith at 2023-10-09T23:35:41+11:00
WIP
- - - - -
5 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Stability.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Types/Stability.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -137,6 +137,7 @@ import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Tidy
import GHC.Driver.Hooks
import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks)
+import GHC.Driver.Stability
import GHC.Runtime.Context
import GHC.Runtime.Interpreter
@@ -1098,12 +1099,14 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h
(cg_guts, details) <-
liftIO $ hscTidy hsc_env simplified_guts
- !partial_iface <-
+ stability <- checkStability_ hsc_env (mg_deps simplified_guts) (mg_module simplified_guts)
+
+ let !partial_iface =
{-# SCC "GHC.Driver.Main.mkPartialIface" #-}
-- This `force` saves 2M residency in test T10370
-- See Note [Avoiding space leaks in toIface*] for details.
- liftIO $ force <$>
- mkPartialIface hsc_env (cg_binds cg_guts) details summary simplified_guts
+ force $
+ mkPartialIface hsc_env (cg_binds cg_guts) details summary stability simplified_guts
return HscRecomp { hscs_guts = cg_guts,
hscs_mod_location = ms_location summary,
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -517,7 +517,17 @@ setSafeHaskell s = updM f
_ -> return $ dfs { safeHaskell = safeM }
setStability :: String -> DynP ()
-setStability "experimental" = updM (\d -> return $ d { stabilityMode = StabilityExperimental })
+
+setStability "experimental" = updM setExperimental
+ where
+ setExperimental d = case stabilityMode d of
+ StabilityRestricted StabilityExperimental
+ -> panic "Cannot set -std=experimental with -std=-experimental"
+ _
+ -> return d { stabilityMode = StabilityNonstable StabilityExperimental}
+
+setStability "-experimental" = updM (\d -> return $ d { stabilityMode = StabilityRestricted StabilityExperimental })
+
setStability l = addErr $ "Unknown stability level: " ++ l
-- | Are all direct imports required to be safe for this Safe Haskell mode?
=====================================
compiler/GHC/Driver/Stability.hs
=====================================
@@ -1,6 +1,8 @@
+{-# LANGUAGE LambdaCase #-}
+
module GHC.Driver.Stability (
- checkStability,
+ checkStability, checkStability_,
module GHC.Types.Stability
@@ -9,6 +11,7 @@ module GHC.Driver.Stability (
import GHC.Driver.DynFlags
import GHC.Driver.Env
import GHC.LanguageExtensions
+import GHC.Tc.Module
import GHC.Types.Stability
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Env
@@ -20,26 +23,42 @@ import GHC.Unit.Types
import GHC.Data.EnumSet as EnumSet
import GHC.IORef
+import GHC.Utils.Panic
import qualified Data.Set as Set
import Data.List (singleton)
import Data.Maybe
+import Control.Monad.IO.Class
+
import GHC.Prelude
extensionStability :: Extension -> StabilityMode
extensionStability _ = StabilityDefault
+checkStability_ :: MonadIO m => HscEnv -> Dependencies -> Module -> m StabilityMode
+checkStability_ hsc_env deps m = liftIO (checkStability hsc_env deps m) >>= \case
+ Just s -> return s
+ Nothing -> panic $ "Failed stability check for " ++ (show $ moduleName m)
+
checkStability :: HscEnv -> Dependencies -> Module -> IO (Maybe StabilityMode)
checkStability hsc_env deps m = do
- external_graph <- hscEPS hsc_env
- let
- home_graph = hsc_HUG hsc_env
- hu_deps = hptSomeThingsBelowUs (singleton . mi_stability . hm_iface)
- True hsc_env (moduleUnitId m) (GWIB (moduleName m) NotBoot)
+ ifaceMs <- mapM (getModuleInterface hsc_env) dep_mods
+ let ifaces = catMaybes $ map snd ifaceMs
+
+ -- external_graph <- hscEPS hsc_env
+ -- let
+ -- home_graph = hsc_HUG hsc_env
+ -- hu_deps = hptSomeThingsBelowUs (singleton . mi_stability . hm_iface)
+ -- True hsc_env (moduleUnitId m) (GWIB (moduleName m) IsBoot)
- return $ checkStability' flagMode exts (hu_deps ++ [])
+ return $ checkStability' flagMode exts (map mi_stability ifaces)
where
+ dep_mods = catMaybes
+ . map toModule
+ $ Set.toList (dep_direct_mods deps)
+ toModule (_ , GWIB _ IsBoot ) = Nothing
+ toModule (uid, GWIB m NotBoot) = Just $ Module (RealUnit $ Definite uid) m
dflags = hsc_dflags hsc_env
flagMode = stabilityMode dflags
exts = EnumSet.toList $ extensionFlags dflags
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -108,9 +108,10 @@ mkPartialIface :: HscEnv
-> CoreProgram
-> ModDetails
-> ModSummary
+ -> StabilityMode
-> ModGuts
- -> IO PartialModIface
-mkPartialIface hsc_env core_prog mod_details mod_summary
+ -> PartialModIface
+mkPartialIface hsc_env core_prog mod_details mod_summary stability_mode
ModGuts{ mg_module = this_mod
, mg_hsc_src = hsc_src
, mg_usages = usages
@@ -125,7 +126,7 @@ mkPartialIface hsc_env core_prog mod_details mod_summary
, mg_docs = docs
}
= mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
- safe_mode usages docs mod_summary mod_details
+ safe_mode stability_mode usages docs mod_summary mod_details
-- | Fully instantiate an interface. Adds fingerprints and potentially code
-- generator produced information.
@@ -232,12 +233,14 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
docs <- extractDocs (ms_hspp_opts mod_summary) tc_result
- partial_iface <- mkIface_ hsc_env
+ stability_mode <- checkStability_ hsc_env deps this_mod
+
+ let partial_iface = mkIface_ hsc_env
this_mod (fromMaybe [] mb_program) hsc_src
used_th deps rdr_env
fix_env warns hpc_info
- (imp_trust_own_pkg imports) safe_mode usages
- docs mod_summary
+ (imp_trust_own_pkg imports) safe_mode stability_mode
+ usages docs mod_summary
mod_details
mkFullIface hsc_env partial_iface Nothing Nothing
@@ -247,14 +250,15 @@ mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource
-> NameEnv FixItem -> Warnings GhcRn -> HpcInfo
-> Bool
-> SafeHaskellMode
+ -> StabilityMode
-> [Usage]
-> Maybe Docs
-> ModSummary
-> ModDetails
- -> IO PartialModIface
+ -> PartialModIface
mkIface_ hsc_env
this_mod core_prog hsc_src used_th deps rdr_env fix_env src_warns
- hpc_info pkg_trust_req safe_mode usages
+ hpc_info pkg_trust_req safe_mode stability_mode usages
docs mod_summary
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
@@ -303,11 +307,8 @@ mkIface_ hsc_env
annotations = map mkIfaceAnnotation anns
icomplete_matches = map mkIfaceCompleteMatch complete_matches
!rdrs = maybeGlobalRdrEnv rdr_env
- stability <- checkStability hsc_env deps this_mod >>= \case
- Just s -> return s
- Nothing -> panic $ "Failed stability check for " ++ (show $ ms_mod_name mod_summary)
- return ModIface {
+ ModIface {
mi_module = this_mod,
-- Need to record this because it depends on the -instantiated-with flag
-- which could change
@@ -335,7 +336,7 @@ mkIface_ hsc_env
mi_hpc = isHpcUsed hpc_info,
mi_trust = trust_info,
mi_trust_pkg = pkg_trust_req,
- mi_stability = stability,
+ mi_stability = stability_mode,
mi_complete_matches = icomplete_matches,
mi_docs = docs,
mi_final_exts = (),
=====================================
compiler/GHC/Types/Stability.hs
=====================================
@@ -1,15 +1,27 @@
+{-# LANGUAGE LambdaCase #-}
+
module GHC.Types.Stability where
import GHC.Utils.Binary
import GHC.Prelude
-
data StabilityMode
- = StabilityDefault
- | StabilityExperimental
+ = StabilityDefault
+ | StabilityRestricted ExperimentalLevel
+ | StabilityNonstable ExperimentalLevel
+ deriving (Eq, Ord)
+
+data ExperimentalLevel
+ = StabilityExperimental
deriving (Enum, Eq, Ord)
instance Binary StabilityMode where
- put_ bh m = putByte bh (fromIntegral (fromEnum m))
- get bh = do m <- getByte bh; return $! (toEnum (fromIntegral m))
\ No newline at end of file
+ put_ bh = \case
+ StabilityDefault -> putByte bh 0
+ StabilityRestricted StabilityExperimental -> putByte bh 1
+ StabilityNonstable StabilityExperimental -> putByte bh 2
+ get bh = getByte bh >>= return . \case
+ 0 -> StabilityDefault
+ 1 -> StabilityRestricted StabilityExperimental
+ 2 -> StabilityNonstable StabilityExperimental
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed0ddfc6bec549def09e46420b0755b177ea75eb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed0ddfc6bec549def09e46420b0755b177ea75eb
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/20231009/686bf9c2/attachment-0001.html>
More information about the ghc-commits
mailing list