Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: c319ea08 by Matthew Pickering at 2025-04-24T10:43:56+01:00 Refactor instances - - - - - e443f033 by Matthew Pickering at 2025-04-24T10:45:07+01:00 Add support for ghc-debug to ghc executable - - - - - b434257a by Matthew Pickering at 2025-04-24T15:02:19+01:00 fixes - - - - - a676a4fa by Matthew Pickering at 2025-04-24T15:02:32+01:00 Revert "Add support for ghc-debug to ghc executable" This reverts commit e443f0336b5497125d1e882255f515c84464cf59. - - - - - c54ecffa by Matthew Pickering at 2025-04-24T15:20:25+01:00 Add a proper error for trying to derive Lift instance - - - - - 9 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error/Codes.hs - testsuite/tests/splice-imports/SI14.stderr - testsuite/tests/splice-imports/SI15.stderr Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -245,10 +245,14 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do -- | Construct a module graph starting from the interactive context. -- Produces, a thunk, which when forced will perform the downsweep. -- This graph contains the current interactive module, and its dependencies. - +-- +-- Invariant: The hsc_mod_graph already contains the relevant home modules which +-- might be imported by the interactive imports. +-- -- This is a first approximation for this function. downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do + debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...") let imps = ic_imports (hsc_IC hsc_env) let mn = icInteractiveModule ic @@ -256,9 +260,11 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do let key = moduleToMnk mn NotBoot let node_type = ModuleNodeFixed key ml + let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ] + let edges = map mkEdge imps let env = DownsweepEnv hsc_env DownsweepUseCompile mempty [] - (module_edges, graph, _) <- runDownsweepM env $ loopImports edges M.empty Map.empty + (module_edges, graph) <- runDownsweepM env $ loopFromInteractive edges cached_nodes let node = ModuleNode module_edges node_type let all_nodes = M.elems graph @@ -282,6 +288,36 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do unitId = homeUnitId $ hsc_home_unit hsc_env in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) +loopFromInteractive :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) +loopFromInteractive [] cached_nodes = return ([], cached_nodes) +loopFromInteractive (edge:edges) cached_nodes = do + hsc_env <- asks downsweep_hsc_env + let (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) = edge + let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) + let k _ loc mod = + let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] + case found of + -- Case 1: Home modules have to already be in the cache. + FoundHome (ModuleNodeFixed mod _) -> do + let edge = ModuleNodeEdge lvl (NodeKey_Module mod) + (edges, cached_nodes') <- loopFromInteractive edges cached_nodes + return (edge : edges, cached_nodes') + -- Case 2: External units may not be in the cache, if we haven't already initialised the + -- module graph. + External uid -> do + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + cached_nodes' = loopUnit hsc_env' cached_nodes [uid] + edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) + (edges, cached_nodes') <- loopFromInteractive edges cached_nodes' + return (edge : edges, cached_nodes') + -- And if it's not found.. just carry on and hope. + _ -> loopFromInteractive edges cached_nodes + + -- | Create a module graph from a list of installed modules. -- This is used by the loader when we need to load modules but there -- isn't already an existing module graph. For example, when loading plugins ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -927,6 +927,7 @@ stockSideConditions deriv_ctxt cls cond_vanilla `andCond` cond_Representable1Ok) | sameUnique cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` + checkFlag LangExt.ImplicitStagePersistence `andCond` cond_vanilla `andCond` cond_args cls) | otherwise = Nothing ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -2035,6 +2035,10 @@ instance Diagnostic TcRnMessage where TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $ text "Unexpected" <+> pprTypeSyntaxName syntax + TcRnDeriveLiftWithoutImplicitStagePersistence{} + -> mkSimpleDecorated $ + text "Deriving Lift is not possible when ImplicitStagePersistence is disabled." + diagnosticReason :: TcRnMessage -> DiagnosticReason diagnosticReason = \case TcRnUnknownMessage m @@ -2685,6 +2689,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnUnexpectedTypeSyntaxInTerms{} -> ErrorWithoutFlag + TcRnDeriveLiftWithoutImplicitStagePersistence{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -3374,6 +3380,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnUnexpectedTypeSyntaxInTerms syntax -> [suggestExtension (typeSyntaxExtension syntax)] + TcRnDeriveLiftWithoutImplicitStagePersistence{} + -> noHints diagnosticCode = constructorCode @GHC ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -4453,6 +4453,17 @@ data TcRnMessage where Test cases: T24159_type_syntax_rn_fail -} TcRnUnexpectedTypeSyntaxInTerms :: TypeSyntax -> TcRnMessage + + {-| TcRnDeriveLiftWithoutImplicitStagePersistence is an error indicating that + someone tried to derive a Lift instance when ImplicitStagePersistence is enabled. + + + Test cases: + None yet + -} + TcRnDeriveLiftWithoutImplicitStagePersistence :: !Name -- ^ The type for which Lift is being derived + -> TcRnMessage + deriving Generic ---- ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -194,6 +194,8 @@ import GHC.Types.Var.Set import GHC.Types.Unique.Supply import GHC.Types.Unique.Set( elementOfUniqSet ) import GHC.Types.Id +import GHC.Types.Basic (allImportLevels) +import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel) import GHC.Unit.Module import qualified GHC.Rename.Env as TcM @@ -1642,40 +1644,51 @@ checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local checkWellLevelledInstanceWhat :: HasCallStack => InstanceWhat -> TcS (Maybe (Set.Set ThLevelIndex, Bool)) checkWellLevelledInstanceWhat what | TopLevInstance { iw_dfun_id = dfun_id } <- what - = do - -- MP: I am not sure if we have to only do this check for orphan instances. - cur_mod <- extractModule <$> getGblEnv - if nameIsLocalOrFrom cur_mod (idName dfun_id) - then return $ Just ( (Set.singleton topLevelIndex, True) ) - else do - hsc_env <- getTopEnv - let q = mgQueryZero (hsc_mod_graph hsc_env) - let mkKey s m = (Left (ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m), s)) - let scope_key s = mkKey s cur_mod - let lkup :: ImportLevel -> Either (ModNodeKeyWithUid, ImportLevel) UnitId -> Bool - lkup s k = q (scope_key s) k - let splice_lvl = lkup SpliceLevel - normal_lvl = lkup NormalLevel - quote_lvl = lkup QuoteLevel - - name_module = nameModule (idName dfun_id) - instance_key = if moduleUnitId name_module `Set.member` hsc_all_home_unit_ids hsc_env - then (mkKey NormalLevel name_module) - else Right (moduleUnitId name_module) - let lvls = [ spliceLevelIndex | splice_lvl instance_key] - ++ [ topLevelIndex | normal_lvl instance_key] - ++ [ quoteLevelIndex | quote_lvl instance_key] - return $ Just ( Set.fromList lvls, False ) - + = Just <$> checkNameVisibleLevels (idName dfun_id) | BuiltinTypeableInstance tc <- what - = do - cur_mod <- extractModule <$> getGblEnv - return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc) - then (Set.singleton topLevelIndex, True) - -- TODO, not correct, needs similar checks to normal instances - else (Set.fromList [spliceLevelIndex, topLevelIndex], False)) + -- The typeable instance is always defined in the same module as the TyCon. + = Just <$> checkNameVisibleLevels (tyConName tc) | otherwise = return Nothing +-- | Check the levels at which the given name is visible, including a boolean +-- indicating if the name is local or not. +checkNameVisibleLevels :: Name -> TcS (Set.Set ThLevelIndex, Bool) +checkNameVisibleLevels name = do + cur_mod <- extractModule <$> getGblEnv + if nameIsLocalOrFrom cur_mod name + then return (Set.singleton topLevelIndex, True) + else do + lvls <- checkModuleVisibleLevels (nameModule name) + return (lvls, False) + +-- | This function checks which levels the given module is visible at. +-- It does this by querying the module graph, hence it is suitable for usage +-- in instance checking, where the reason an instance is brought into scope is +-- implicit. +checkModuleVisibleLevels :: Module -> TcS (Set.Set ThLevelIndex) +checkModuleVisibleLevels check_mod = do + cur_mod <- extractModule <$> getGblEnv + hsc_env <- getTopEnv + + -- 0. The keys for the scope of the current module. + let mkKey s m = (Left (moduleToMnk m NotBoot, s)) + cur_mod_scope_key s = mkKey s cur_mod + + -- 1. is_visible checks that a specific key is visible from the given level in the + -- current module. + let is_visible :: ImportLevel -> Either (ModNodeKeyWithUid, ImportLevel) UnitId -> Bool + is_visible s k = mgQueryZero (hsc_mod_graph hsc_env) (cur_mod_scope_key s) k + + -- 2. The key we are looking for, either the module itself in the home package or the + -- module unit id of the module we are checking. + let instance_key = if moduleUnitId check_mod `Set.member` hsc_all_home_unit_ids hsc_env + then mkKey NormalLevel check_mod + else Right (moduleUnitId check_mod) + + -- 3. For each level, check if the key is visible from that level. + let lvls = [ thLevelIndexFromImportLevel lvl | lvl <- allImportLevels, is_visible lvl instance_key] + return $ Set.fromList lvls + {- Note [Well-levelled instance evidence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -123,7 +123,7 @@ module GHC.Types.Basic ( ForeignSrcLang (..), - ImportLevel(..), convImportLevel, convImportLevelSpec, + ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels ) where import GHC.Prelude @@ -2442,7 +2442,7 @@ instance Outputable DefaultingStrategy where -- | ImportLevel -data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum) +data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum, Bounded) instance Outputable ImportLevel where ppr NormalLevel = text "normal" @@ -2451,6 +2451,9 @@ instance Outputable ImportLevel where deriving via (EnumBinary ImportLevel) instance Binary ImportLevel +allImportLevels :: [ImportLevel] +allImportLevels = [minBound..maxBound] + convImportLevel :: ImportDeclLevelStyle -> ImportLevel convImportLevel (LevelStylePre level) = convImportLevelSpec level convImportLevel (LevelStylePost level) = convImportLevelSpec level ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -700,6 +700,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnIllegalTypeExpr" = 35499 GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms" = 31244 GhcDiagnosticCode "TcRnTypeApplicationsDisabled" = 23482 + GhcDiagnosticCode "TcRnDeriveLiftWithoutImplicitStagePersistence" = 87906 -- TcRnIllegalInvisibleTypePattern GhcDiagnosticCode "InvisPatWithoutFlag" = 78249 ===================================== testsuite/tests/splice-imports/SI14.stderr ===================================== @@ -1,12 +1,5 @@ -SI14.hs:9:21: error: [GHC-28914] - • Level error: ‘A’ is bound at level 0 but used at level 1 - Hint: quoting [| A |] or an enclosing expression - would allow the quotation to be used at an earlier level - • In the Template Haskell quotation: 'A - -SI14.hs:9:21: error: [GHC-28914] - • Level error: ‘A’ is bound at level 0 but used at level 1 - Hint: quoting [| A |] or an enclosing expression - would allow the quotation to be used at an earlier level - • In the Template Haskell quotation: 'A +SI14.hs:9:21: error: [GHC-86639] + • Can't make a derived instance of ‘Lift A’: + You need ImplicitStagePersistence to derive an instance for this class + • In the data type declaration for ‘A’ ===================================== testsuite/tests/splice-imports/SI15.stderr ===================================== @@ -1,12 +1,5 @@ -SI15.hs:9:21: error: [GHC-28914] - • Level error: ‘A’ is bound at level 0 but used at level 1 - Hint: quoting [| A |] or an enclosing expression - would allow the quotation to be used at an earlier level - • In the Template Haskell quotation: 'A - -SI15.hs:9:21: error: [GHC-28914] - • Level error: ‘A’ is bound at level 0 but used at level 1 - Hint: quoting [| A |] or an enclosing expression - would allow the quotation to be used at an earlier level - • In the Template Haskell quotation: 'A +SI15.hs:9:21: error: [GHC-86639] + • Can't make a derived instance of ‘Lift A’: + You need ImplicitStagePersistence to derive an instance for this class + • In the data type declaration for ‘A’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0aac7dcc195371d7ce82eac0f10d427... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0aac7dcc195371d7ce82eac0f10d427... You're receiving this email because of your account on gitlab.haskell.org.