Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -245,10 +245,14 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
    245 245 
     -- | Construct a module graph starting from the interactive context.
    246 246 
     -- Produces, a thunk, which when forced will perform the downsweep.
    247 247 
     -- This graph contains the current interactive module, and its dependencies.
    248 
    -
    248 
    +--
    249 
    +--  Invariant: The hsc_mod_graph already contains the relevant home modules which
    250 
    +--  might be imported by the interactive imports.
    251 
    +--
    249 252 
     -- This is a first approximation for this function.
    250 253 
     downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph
    251 254 
     downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
    255 
    +  debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...")
    252 256 
       let imps = ic_imports (hsc_IC hsc_env)
    253 257
    254 258 
       let mn = icInteractiveModule ic
    ... ... @@ -256,9 +260,11 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
    256 260 
       let key = moduleToMnk mn NotBoot
    257 261 
       let node_type = ModuleNodeFixed key ml
    258 262
    263 
    +  let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ]
    264 
    +
    259 265 
       let edges = map mkEdge imps
    260 266 
       let env = DownsweepEnv hsc_env DownsweepUseCompile mempty []
    261 
    -  (module_edges, graph, _) <- runDownsweepM env $ loopImports edges M.empty Map.empty
    267 
    +  (module_edges, graph) <- runDownsweepM env $ loopFromInteractive edges cached_nodes
    262 268 
       let node = ModuleNode module_edges node_type
    263 269
    264 270 
       let all_nodes  = M.elems graph
    ... ... @@ -282,6 +288,36 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
    282 288 
               unitId = homeUnitId $ hsc_home_unit hsc_env
    283 289 
           in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)
    284 290
    291 
    +loopFromInteractive :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
    292 
    +                    -> M.Map NodeKey ModuleGraphNode
    293 
    +                    -> DownsweepM ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)
    294 
    +loopFromInteractive [] cached_nodes = return ([], cached_nodes)
    295 
    +loopFromInteractive (edge:edges) cached_nodes = do
    296 
    +  hsc_env <- asks downsweep_hsc_env
    297 
    +  let (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) = edge
    298 
    +  let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)
    299 
    +  let k _ loc mod =
    300 
    +        let key = moduleToMnk mod is_boot
    301 
    +        in return $ FoundHome (ModuleNodeFixed key loc)
    302 
    +  found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg []
    303 
    +  case found of
    304 
    +    -- Case 1: Home modules have to already be in the cache.
    305 
    +    FoundHome (ModuleNodeFixed mod _) -> do
    306 
    +      let edge = ModuleNodeEdge lvl (NodeKey_Module mod)
    307 
    +      (edges, cached_nodes') <- loopFromInteractive edges cached_nodes
    308 
    +      return (edge : edges, cached_nodes')
    309 
    +    -- Case 2: External units may not be in the cache, if we haven't already initialised the
    310 
    +    -- module graph.
    311 
    +    External uid -> do
    312 
    +      let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
    313 
    +          cached_nodes' = loopUnit hsc_env' cached_nodes [uid]
    314 
    +          edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)
    315 
    +      (edges, cached_nodes') <- loopFromInteractive edges cached_nodes'
    316 
    +      return (edge : edges, cached_nodes')
    317 
    +    -- And if it's not found.. just carry on and hope.
    318 
    +    _ -> loopFromInteractive edges cached_nodes
    319 
    +
    320 
    +
    285 321 
     -- | Create a module graph from a list of installed modules.
    286 322 
     -- This is used by the loader when we need to load modules but there
    287 323 
     -- 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
    927 927 
                                                        cond_vanilla `andCond`
    928 928 
                                                        cond_Representable1Ok)
    929 929 
       | sameUnique cls_key liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`
    930 
    +                                                   checkFlag LangExt.ImplicitStagePersistence `andCond`
    930 931 
                                                        cond_vanilla `andCond`
    931 932 
                                                        cond_args cls)
    932 933 
       | otherwise                        = Nothing

  • compiler/GHC/Tc/Errors/Ppr.hs
    ... ... @@ -2035,6 +2035,10 @@ instance Diagnostic TcRnMessage where
    2035 2035 
         TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $
    2036 2036 
           text "Unexpected" <+> pprTypeSyntaxName syntax
    2037 2037
    2038 
    +    TcRnDeriveLiftWithoutImplicitStagePersistence{}
    2039 
    +      -> mkSimpleDecorated $
    2040 
    +         text "Deriving Lift is not possible when ImplicitStagePersistence is disabled."
    2041 
    +
    2038 2042 
       diagnosticReason :: TcRnMessage -> DiagnosticReason
    2039 2043 
       diagnosticReason = \case
    2040 2044 
         TcRnUnknownMessage m
    ... ... @@ -2685,6 +2689,8 @@ instance Diagnostic TcRnMessage where
    2685 2689 
           -> ErrorWithoutFlag
    2686 2690 
         TcRnUnexpectedTypeSyntaxInTerms{}
    2687 2691 
           -> ErrorWithoutFlag
    2692 
    +    TcRnDeriveLiftWithoutImplicitStagePersistence{}
    2693 
    +      -> ErrorWithoutFlag
    2688 2694
    2689 2695 
       diagnosticHints = \case
    2690 2696 
         TcRnUnknownMessage m
    ... ... @@ -3374,6 +3380,8 @@ instance Diagnostic TcRnMessage where
    3374 3380 
           -> noHints
    3375 3381 
         TcRnUnexpectedTypeSyntaxInTerms syntax
    3376 3382 
           -> [suggestExtension (typeSyntaxExtension syntax)]
    3383 
    +    TcRnDeriveLiftWithoutImplicitStagePersistence{}
    3384 
    +      -> noHints
    3377 3385
    3378 3386 
       diagnosticCode = constructorCode @GHC
    3379 3387

  • compiler/GHC/Tc/Errors/Types.hs
    ... ... @@ -4453,6 +4453,17 @@ data TcRnMessage where
    4453 4453 
         Test cases: T24159_type_syntax_rn_fail
    4454 4454 
       -}
    4455 4455 
       TcRnUnexpectedTypeSyntaxInTerms :: TypeSyntax -> TcRnMessage
    4456 
    +
    4457 
    +  {-| TcRnDeriveLiftWithoutImplicitStagePersistence is an error indicating that
    4458 
    +    someone tried to derive a Lift instance when ImplicitStagePersistence is enabled.
    4459 
    +
    4460 
    +
    4461 
    +    Test cases:
    4462 
    +      None yet
    4463 
    +  -}
    4464 
    +  TcRnDeriveLiftWithoutImplicitStagePersistence :: !Name -- ^ The type for which Lift is being derived
    4465 
    +                                             -> TcRnMessage
    4466 
    +
    4456 4467 
       deriving Generic
    4457 4468
    4458 4469 
     ----

  • compiler/GHC/Tc/Solver/Monad.hs
    ... ... @@ -194,6 +194,8 @@ import GHC.Types.Var.Set
    194 194 
     import GHC.Types.Unique.Supply
    195 195 
     import GHC.Types.Unique.Set( elementOfUniqSet )
    196 196 
     import GHC.Types.Id
    197 
    +import GHC.Types.Basic (allImportLevels)
    198 
    +import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel)
    197 199
    198 200 
     import GHC.Unit.Module
    199 201 
     import qualified GHC.Rename.Env as TcM
    ... ... @@ -1642,40 +1644,51 @@ checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local
    1642 1644 
     checkWellLevelledInstanceWhat :: HasCallStack => InstanceWhat -> TcS (Maybe (Set.Set ThLevelIndex, Bool))
    1643 1645 
     checkWellLevelledInstanceWhat what
    1644 1646 
       | TopLevInstance { iw_dfun_id = dfun_id } <- what
    1645 
    -    = do
    1646 
    -        -- MP: I am not sure if we have to only do this check for orphan instances.
    1647 
    -        cur_mod <- extractModule <$> getGblEnv
    1648 
    -        if nameIsLocalOrFrom cur_mod (idName dfun_id)
    1649 
    -          then return $ Just ( (Set.singleton topLevelIndex, True) )
    1650 
    -          else do
    1651 
    -            hsc_env <- getTopEnv
    1652 
    -            let q = mgQueryZero (hsc_mod_graph hsc_env)
    1653 
    -            let mkKey s m = (Left (ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m), s))
    1654 
    -            let scope_key s = mkKey s cur_mod
    1655 
    -            let lkup :: ImportLevel -> Either (ModNodeKeyWithUid, ImportLevel) UnitId -> Bool
    1656 
    -                lkup s k = q (scope_key s) k
    1657 
    -            let splice_lvl = lkup SpliceLevel
    1658 
    -                normal_lvl = lkup NormalLevel
    1659 
    -                quote_lvl  = lkup QuoteLevel
    1660 
    -
    1661 
    -                name_module = nameModule (idName dfun_id)
    1662 
    -                instance_key = if moduleUnitId name_module `Set.member` hsc_all_home_unit_ids hsc_env
    1663 
    -                                 then (mkKey NormalLevel name_module)
    1664 
    -                                 else Right (moduleUnitId name_module)
    1665 
    -            let lvls = [ spliceLevelIndex | splice_lvl instance_key]
    1666 
    -                     ++ [ topLevelIndex | normal_lvl instance_key]
    1667 
    -                     ++ [ quoteLevelIndex | quote_lvl instance_key]
    1668 
    -            return $ Just ( Set.fromList lvls, False )
    1669 
    -
    1647 
    +    = Just <$> checkNameVisibleLevels (idName dfun_id)
    1670 1648 
       | BuiltinTypeableInstance tc <- what
    1671 
    -    = do
    1672 
    -        cur_mod <- extractModule <$> getGblEnv
    1673 
    -        return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)
    1674 
    -                        then (Set.singleton topLevelIndex, True)
    1675 
    -                        -- TODO, not correct, needs similar checks to normal instances
    1676 
    -                        else (Set.fromList [spliceLevelIndex, topLevelIndex], False))
    1649 
    +    -- The typeable instance is always defined in the same module as the TyCon.
    1650 
    +    = Just <$> checkNameVisibleLevels (tyConName tc)
    1677 1651 
       | otherwise = return Nothing
    1678 1652
    1653 
    +-- | Check the levels at which the given name is visible, including a boolean
    1654 
    +-- indicating if the name is local or not.
    1655 
    +checkNameVisibleLevels :: Name -> TcS (Set.Set ThLevelIndex, Bool)
    1656 
    +checkNameVisibleLevels name = do
    1657 
    +  cur_mod <- extractModule <$> getGblEnv
    1658 
    +  if nameIsLocalOrFrom cur_mod name
    1659 
    +    then return (Set.singleton topLevelIndex, True)
    1660 
    +    else do
    1661 
    +      lvls <- checkModuleVisibleLevels (nameModule name)
    1662 
    +      return (lvls, False)
    1663 
    +
    1664 
    +-- | This function checks which levels the given module is visible at.
    1665 
    +-- It does this by querying the module graph, hence it is suitable for usage
    1666 
    +-- in instance checking, where the reason an instance is brought into scope is
    1667 
    +-- implicit.
    1668 
    +checkModuleVisibleLevels :: Module -> TcS (Set.Set ThLevelIndex)
    1669 
    +checkModuleVisibleLevels check_mod = do
    1670 
    +  cur_mod <- extractModule <$> getGblEnv
    1671 
    +  hsc_env <- getTopEnv
    1672 
    +
    1673 
    +  -- 0. The keys for the scope of the current module.
    1674 
    +  let mkKey s m = (Left (moduleToMnk m NotBoot, s))
    1675 
    +      cur_mod_scope_key s = mkKey s cur_mod
    1676 
    +
    1677 
    +  -- 1. is_visible checks that a specific key is visible from the given level in the
    1678 
    +  -- current module.
    1679 
    +  let is_visible :: ImportLevel -> Either (ModNodeKeyWithUid, ImportLevel) UnitId -> Bool
    1680 
    +      is_visible s k = mgQueryZero (hsc_mod_graph hsc_env) (cur_mod_scope_key s) k
    1681 
    +
    1682 
    +  -- 2. The key we are looking for, either the module itself in the home package or the
    1683 
    +  -- module unit id of the module we are checking.
    1684 
    +  let instance_key = if moduleUnitId check_mod `Set.member` hsc_all_home_unit_ids hsc_env
    1685 
    +                       then mkKey NormalLevel check_mod
    1686 
    +                       else Right (moduleUnitId check_mod)
    1687 
    +
    1688 
    +  -- 3. For each level, check if the key is visible from that level.
    1689 
    +  let lvls = [ thLevelIndexFromImportLevel lvl | lvl <- allImportLevels, is_visible lvl instance_key]
    1690 
    +  return $ Set.fromList lvls
    1691 
    +
    1679 1692 
     {-
    1680 1693 
     Note [Well-levelled instance evidence]
    1681 1694 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  • compiler/GHC/Types/Basic.hs
    ... ... @@ -123,7 +123,7 @@ module GHC.Types.Basic (
    123 123
    124 124 
             ForeignSrcLang (..),
    125 125
    126 
    -        ImportLevel(..), convImportLevel, convImportLevelSpec,
    126 
    +        ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels
    127 127 
        ) where
    128 128
    129 129 
     import GHC.Prelude
    ... ... @@ -2442,7 +2442,7 @@ instance Outputable DefaultingStrategy where
    2442 2442
    2443 2443 
     -- | ImportLevel
    2444 2444
    2445 
    -data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum)
    2445 
    +data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum, Bounded)
    2446 2446
    2447 2447 
     instance Outputable ImportLevel where
    2448 2448 
       ppr NormalLevel = text "normal"
    ... ... @@ -2451,6 +2451,9 @@ instance Outputable ImportLevel where
    2451 2451
    2452 2452 
     deriving via (EnumBinary ImportLevel) instance Binary ImportLevel
    2453 2453
    2454 
    +allImportLevels :: [ImportLevel]
    2455 
    +allImportLevels = [minBound..maxBound]
    2456 
    +
    2454 2457 
     convImportLevel :: ImportDeclLevelStyle -> ImportLevel
    2455 2458 
     convImportLevel (LevelStylePre level) = convImportLevelSpec level
    2456 2459 
     convImportLevel (LevelStylePost level) = convImportLevelSpec level

  • compiler/GHC/Types/Error/Codes.hs
    ... ... @@ -700,6 +700,7 @@ type family GhcDiagnosticCode c = n | n -> c where
    700 700 
       GhcDiagnosticCode "TcRnIllegalTypeExpr"                           = 35499
    701 701 
       GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms"               = 31244
    702 702 
       GhcDiagnosticCode "TcRnTypeApplicationsDisabled"                  = 23482
    703 
    +  GhcDiagnosticCode "TcRnDeriveLiftWithoutImplicitStagePersistence"    = 87906
    703 704
    704 705 
       -- TcRnIllegalInvisibleTypePattern
    705 706 
       GhcDiagnosticCode "InvisPatWithoutFlag"                           = 78249

  • testsuite/tests/splice-imports/SI14.stderr
    1 
    -SI14.hs:9:21: error: [GHC-28914]
    2 
    -    • Level error: ‘A’ is bound at level 0 but used at level 1
    3 
    -      Hint: quoting [| A |] or an enclosing expression
    4 
    -      would allow the quotation to be used at an earlier level
    5 
    -    • In the Template Haskell quotation: 'A
    6 
    -
    7 
    -SI14.hs:9:21: error: [GHC-28914]
    8 
    -    • Level error: ‘A’ is bound at level 0 but used at level 1
    9 
    -      Hint: quoting [| A |] or an enclosing expression
    10 
    -      would allow the quotation to be used at an earlier level
    11 
    -    • In the Template Haskell quotation: 'A
    1 
    +SI14.hs:9:21: error: [GHC-86639]
    2 
    +    • Can't make a derived instance of ‘Lift A’:
    3 
    +        You need ImplicitStagePersistence to derive an instance for this class
    4 
    +    • In the data type declaration for ‘A’
    12 5

  • testsuite/tests/splice-imports/SI15.stderr
    1 
    -SI15.hs:9:21: error: [GHC-28914]
    2 
    -    • Level error: ‘A’ is bound at level 0 but used at level 1
    3 
    -      Hint: quoting [| A |] or an enclosing expression
    4 
    -      would allow the quotation to be used at an earlier level
    5 
    -    • In the Template Haskell quotation: 'A
    6 
    -
    7 
    -SI15.hs:9:21: error: [GHC-28914]
    8 
    -    • Level error: ‘A’ is bound at level 0 but used at level 1
    9 
    -      Hint: quoting [| A |] or an enclosing expression
    10 
    -      would allow the quotation to be used at an earlier level
    11 
    -    • In the Template Haskell quotation: 'A
    1 
    +SI15.hs:9:21: error: [GHC-86639]
    2 
    +    • Can't make a derived instance of ‘Lift A’:
    3 
    +        You need ImplicitStagePersistence to derive an instance for this class
    4 
    +    • In the data type declaration for ‘A’
    12 5

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help