[Git][ghc/ghc][wip/splice-imports-2024] WIPS
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Tue Nov 5 17:33:05 UTC 2024
Matthew Pickering pushed to branch wip/splice-imports-2024 at Glasgow Haskell Compiler / GHC
Commits:
48c4e78b by Matthew Pickering at 2024-11-05T17:32:44+00:00
WIPS
- - - - -
23 changed files:
- compiler/GHC/Data/Graph/Directed.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- testsuite/tests/splice-imports/SI03.stderr
- testsuite/tests/splice-imports/SI05.stderr
- testsuite/tests/splice-imports/SI09.hs
- testsuite/tests/splice-imports/SI20.stderr
- testsuite/tests/splice-imports/all.T
Changes:
=====================================
compiler/GHC/Data/Graph/Directed.hs
=====================================
@@ -70,7 +70,6 @@ import qualified Data.Set as S
import Data.Array.ST.Safe (STUArray)
import Control.Monad.ST
import Data.Array.ST.Safe (newArray, readArray, writeArray)
-import Data.Array
{-
************************************************************************
@@ -523,6 +522,7 @@ dfs2 g vs0 = run (bounds g) $ start vs0
reachable :: IntGraph -> [Vertex] -> [Vertex]
reachable g vs = preorderF (G.dfs g vs)
+reachableBut :: G.Graph -> [Vertex] -> [Vertex]
reachableBut g vs = dfs2 g vs
reachableGraph :: IntGraph -> IM.IntMap IS.IntSet
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -259,12 +259,12 @@ hptInstancesBelow hsc_env uid lvl mnwib =
-- | Get rules from modules "below" this one (in the dependency sense)
hptRules :: HscEnv -> UnitId -> ModuleStage -> ModuleNameWithIsBoot -> [CoreRule]
-hptRules = hptSomeThingsBelowUs (\lvl info -> md_rules (hm_details info)) False
+hptRules = hptSomeThingsBelowUs (\_lvl info -> md_rules (hm_details info)) False
-- | Get annotations from modules "below" this one (in the dependency sense)
hptAnns :: HscEnv -> Maybe (UnitId, ModuleStage, ModuleNameWithIsBoot) -> [Annotation]
-hptAnns hsc_env (Just (uid, lvl, mn)) = hptSomeThingsBelowUs (\lvl info -> md_anns (hm_details info)) False hsc_env uid lvl mn
+hptAnns hsc_env (Just (uid, lvl, mn)) = hptSomeThingsBelowUs (\_lvl info -> md_anns (hm_details info)) False hsc_env uid lvl mn
hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -631,13 +631,13 @@ createBuildPlan mod_graph maybe_top_mod =
-- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists
boot_modules = mkModuleEnv
- [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ _ lvl ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
+ [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ _ _lvl ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = mapMaybe (fmap fst . get_boot_module)
get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
- get_boot_module m = case m of ModuleNode _ _ lvl ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
+ get_boot_module m = case m of ModuleNode _ _ _lvl ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
-- Any cycles should be resolved now
collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
@@ -1600,6 +1600,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
= do
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
+ pprTraceM "roots" (ppr root_map)
(deps, map0) <- loopSummaries (zip (repeat zeroStage) rootSummariesOk) (M.empty, root_map)
let closure_errs = checkHomeUnitsClosed unit_env
unit_env = hsc_unit_env hsc_env
@@ -1673,10 +1674,14 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
(final_deps, uids, done', summarised') <- loopImports (calcDeps lvl ms) done summarised
-- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
(_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
- loopSummaries next (M.insert k (ModuleNode final_deps uids lvl ms) done'', summarised'')
+ loopSummaries (maybeToList zero ++ next) (M.insert k (ModuleNode final_deps uids lvl ms) done'', summarised'')
where
k = NodeKey_Module (msKey lvl ms)
+ --MP: Not clear if this is needed
+ zero | lvl == zeroStage = Nothing
+ | otherwise = Just (zeroStage, ms)
+
hs_file_for_boot
| HsBootFile <- ms_hsc_src ms
= Just $ ((ms_unitid ms), lvl, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
@@ -2053,7 +2058,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state mod_graph
-- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
-- it's dependencies.
[ (msKey lvl ms, code_stage ms)
- | (ModuleNode deps uids lvl ms) <- mod_graph
+ | (ModuleNode _deps _uids lvl ms) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
]
@@ -2061,7 +2066,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state mod_graph
-- The direct dependencies of modules which require byte code
need_bc_set =
[ (msKey lvl ms, code_stage ms)
- | (ModuleNode deps uids lvl ms) <- mod_graph
+ | (ModuleNode _deps _uids lvl ms) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
]
@@ -2415,8 +2420,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
<- ExceptT $ do
let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags
popts = initParserOpts pi_local_dflags
- splice_imports = xopt LangExt.StagedImports pi_local_dflags
- mimps <- getImports popts imp_prelude splice_imports pi_hspp_buf pi_hspp_fn src_fn
+ mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)
let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn))
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -705,11 +705,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
- splice_imports = xopt LangExt.StagedImports dflags
popts = initParserOpts dflags
rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn))
- eimps <- getImports popts imp_prelude splice_imports buf input_fn (basename <.> suff)
+ eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
Left errs -> throwErrors (GhcPsMessage <$> errs)
Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -173,7 +173,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) lvl uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) lvl uid) <- Set.toList trans_deps]
in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
Nothing ->
- let (ModNodeKeyWithUid _ lvl uid) = nk
+ let (ModNodeKeyWithUid _ _lvl uid) = nk
in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) todoStage (moduleUnitId m)
@@ -181,7 +181,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]
- get_mod_info (ModNodeKeyWithUid gwib lvl uid) =
+ get_mod_info (ModNodeKeyWithUid gwib _lvl uid) =
case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of
Just hmi ->
let iface = (hm_iface hmi)
=====================================
compiler/GHC/Parser/Header.hs
=====================================
@@ -67,7 +67,6 @@ import Text.Read (readPrec)
-- Throws a 'SourceError' if parsing fails.
getImports :: ParserOpts -- ^ Parser options
-> Bool -- ^ Implicit Prelude?
- -> Bool -- ^ Explicit staged imports?
-> StringBuffer -- ^ Parse this.
-> FilePath -- ^ Filename the buffer came from. Used for
-- reporting parse error locations.
@@ -81,7 +80,7 @@ getImports :: ParserOpts -- ^ Parser options
Located ModuleName))
-- ^ The source imports and normal imports (with optional package
-- names from -XPackageImports), and the module name.
-getImports popts implicit_prelude staged_imports buf filename source_filename = do
+getImports popts implicit_prelude buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (initParserState popts buf loc) of
PFailed pst ->
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -310,7 +310,7 @@ finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
-- Separated from rnExpr because it's also used
-- when renaming infix expressions
finishHsVar (L l name)
- = do { this_mod <- getModule
+ = do { --this_mod <- getModule
-- ; when (nameIsLocalOrFrom this_mod name) $
; checkThLocalName name
; return (HsVar noExtField (L (l2l l) name), unitFV name) }
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -44,7 +44,7 @@ import Control.Monad ( unless, when )
import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
-import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy )
+import GHC.Tc.Utils.Env ( tcMetaTy )
import GHC.Driver.DynFlags
import GHC.Data.FastString
@@ -188,6 +188,7 @@ rn_utbracket (VarBr x flg rdr_name)
; check_namespace flg name
; this_mod <- getModule
; dflags <- getDynFlags
+ ; env <- getGlobalRdrEnv
; when (flg && nameIsLocalOrFrom this_mod name) $
-- Type variables can be quoted in TH. See #5721.
@@ -206,9 +207,9 @@ rn_utbracket (VarBr x flg rdr_name)
-> do { traceRn "rn_utbracket VarBr"
(ppr name <+> ppr bind_lvl
<+> ppr use_lvl)
-
+ ; let mgre = lookupGRE_Name env name
; checkTc (any (thLevel use_lvl ==) (Set.toList bind_lvl))
- (TcRnBadlyStaged (StageCheckSplice name) bind_lvl (thLevel use_lvl))
+ (TcRnBadlyStaged (StageCheckSplice name mgre) bind_lvl (thLevel use_lvl))
; when (isExternalName name) (keepAlive name) }
}
}
@@ -524,7 +525,7 @@ rnUntypedSpliceExpr splice
-- mod_finalizers: See Note [Delaying modFinalizers in untyped splices].
-- Rename the expanded expression
- ; (L l expr_rn, fvs) <- checkNoErrs (rnLExpr expr_ps)
+ ; (L l expr_rn, fvs) <- setXOptM LangExt.PathCrossStagedPersistence $ checkNoErrs (rnLExpr expr_ps)
-- rn_splice :: HsUntypedSplice GhcRn is the original TH expression,
-- before expansion
@@ -982,7 +983,7 @@ checkThLocalName name
| otherwise
= do { --pprTraceM "checkThLocalName" (ppr name)
- ; mb_local_use <- getStageAndBindLevel name
+ mb_local_use <- getStageAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_stage) ->
@@ -990,11 +991,13 @@ checkThLocalName name
; cur_mod <- extractModule <$> getGblEnv
; let is_local = nameIsLocalOrFrom cur_mod name
-- ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
- --; pprTraceM "checkThLocalName" (ppr name <+> ppr bind_lvl
- -- <+> ppr use_stage
- -- <+> ppr use_lvl)
+ {-} ; pprTraceM "checkThLocalName" (ppr name <+> ppr bind_lvl
+ <+> ppr use_stage
+ <+> ppr use_lvl) -}
; dflags <- getDynFlags
- ; checkCrossStageLifting dflags (StageCheckSplice name) top_lvl is_local bind_lvl use_stage use_lvl name } } }
+ ; env <- getGlobalRdrEnv
+ ; let mgre = lookupGRE_Name env name
+ ; checkCrossStageLifting dflags (StageCheckSplice name mgre) top_lvl is_local bind_lvl use_stage use_lvl name } } }
--------------------------------------
checkCrossStageLifting :: DynFlags
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -1671,7 +1671,7 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
as_needed = take con_arity as_RDRs
lift_Expr = mk_bracket finish
con_brack :: LHsExpr GhcPs
- con_brack = nlHsApps (Exact varEName) [noLocA $ HsUntypedBracket noAnn $ VarBr noExtField True (noLocA (Exact (dataConName data_con)))]
+ con_brack = nlHsApps (Exact conEName) [noLocA $ HsUntypedBracket noAnn $ VarBr noExtField True (noLocA (Exact (dataConName data_con)))]
finish = foldl' (\b1 b2 -> nlHsApps (Exact appEName) [b1, b2]) con_brack (map lift_var2 as_needed)
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1470,8 +1470,11 @@ instance Diagnostic TcRnMessage where
[ hsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n)
, text "or an enclosing expression would allow the quotation to be used in an earlier stage"
]
- | StageCheckSplice n <- [reason]
- ]
+ | StageCheckSplice n _ <- [reason]
+ ] ++
+ [ "From imports" <+> (ppr (gre_imp gre))
+ | StageCheckSplice _ (Just gre) <- [reason]
+ , not (isEmptyBag (gre_imp gre)) ]
TcRnBadlyStagedType name bind_lvl use_lvl
-> mkSimpleDecorated $
text "Badly staged type:" <+> ppr name <+>
@@ -5613,7 +5616,7 @@ pprStageCheckReason :: StageCheckReason -> SDoc
pprStageCheckReason = \case
StageCheckInstance _ t ->
text "instance for" <+> quotes (ppr t)
- StageCheckSplice t ->
+ StageCheckSplice t _ ->
quotes (ppr t)
pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -6096,7 +6096,7 @@ data WrongThingSort
data StageCheckReason
= StageCheckInstance !InstanceWhat !PredType
- | StageCheckSplice !Name
+ | StageCheckSplice !Name !(Maybe GlobalRdrElt)
data UninferrableTyVarCtx
= UninfTyCtx_ClassContext [TcType]
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -138,9 +138,9 @@ import qualified GHC.Tc.Utils.Monad as TcM
import qualified GHC.Tc.Utils.TcMType as TcM
import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )
import qualified GHC.Tc.Utils.Env as TcM
- ( checkWellStaged, tcGetDefaultTys
+ ( tcGetDefaultTys
, tcLookupClass, tcLookupId, tcLookupTyCon
- , topIdLvl )
+ )
import GHC.Tc.Zonk.Monad ( ZonkM )
import qualified GHC.Tc.Zonk.TcType as TcM
import qualified GHC.Tc.Zonk.Type as TcM
@@ -163,7 +163,6 @@ import GHC.Tc.Types
import GHC.Tc.Types.Origin
import GHC.Tc.Types.CtLoc
import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.LclEnv
import GHC.Builtin.Names ( unsatisfiableClassNameKey )
@@ -184,7 +183,6 @@ import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Unique.Supply
import GHC.Types.Unique.Set( elementOfUniqSet )
-import GHC.Types.Name.Env
import GHC.Types.Id
import GHC.Unit.Module
@@ -219,6 +217,8 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import GHC.Unit.Module.Graph
+import Data.Bifunctor (bimap)
+
{- *********************************************************************
* *
SolverStage and StopOrContinue
@@ -1420,8 +1420,8 @@ checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
checkWellStagedDFun loc what pred
= do
mbind_lvl <- checkWellStagedInstanceWhat what
- env <- getLclEnv
- use_lvl <- thLevel <$> (wrapTcS $ TcM.getStage)
+ --env <- getLclEnv
+ --use_lvl <- thLevel <$> (wrapTcS $ TcM.getStage)
case mbind_lvl of
Just (bind_lvl, is_local) ->
wrapTcS $ TcM.setCtLocM loc $ do
@@ -1456,56 +1456,35 @@ checkWellStagedInstanceWhat what
| TopLevInstance { iw_dfun_id = dfun_id } <- what
= do
cur_mod <- extractModule <$> getGblEnv
- gbl_env <- getGblEnv
--- pprTraceM "checkWellStaged" (ppr what)
hsc_env <- getTopEnv
let tg = mkTransDepsZero (hsc_units hsc_env) (mgModSummaries' (hsc_mod_graph hsc_env))
- let lkup s = flip (Map.!) (Left (ModNodeKeyWithUid (GWIB (moduleName cur_mod) NotBoot) zeroStage (moduleUnitId cur_mod), s)) tg
+ pprTraceM "tg" (ppr tg)
+ pprTraceM "tg" (ppr $ mgModSummaries' (hsc_mod_graph hsc_env))
+ let lkup s = Set.map (bimap (\(ModNodeKeyWithUid mn _ u,_) -> mkModule (RealUnit (Definite u)) (gwib_mod mn)) id) $ flip (Map.!) (Left (ModNodeKeyWithUid (GWIB (moduleName cur_mod) NotBoot) zeroStage (moduleUnitId cur_mod), s)) tg
let splice_lvl = lkup SpliceStage
normal_lvl = lkup NormalStage
quote_lvl = lkup QuoteStage
name_module = nameModule (idName dfun_id)
instance_key = if moduleUnitId name_module `Set.member` hsc_all_home_unit_ids hsc_env
- then Left (ModNodeKeyWithUid (GWIB (moduleName name_module) NotBoot) zeroStage (moduleUnitId name_module), NormalStage)
+ then Left name_module
else Right (moduleUnitId name_module)
- {- pprTraceM "instnace_key" (ppr instance_key)
- pprTraceM "splice_lvl" (ppr (instance_key `Set.member` splice_lvl))
- pprTraceM "splice_lvl" (ppr (instance_key `Set.member` normal_lvl))
- pprTraceM "splice_lvl" (ppr (instance_key `Set.member` quote_lvl))
- -}
let lvls = [ 0 | instance_key `Set.member` splice_lvl]
++ [ 1 | instance_key `Set.member` normal_lvl ]
++ [ 2 | instance_key `Set.member` quote_lvl ]
-
+ pprTraceM "lvls" (ppr dfun_id $$ ppr splice_lvl $$ ppr normal_lvl $$ ppr quote_lvl)
if isLocalId dfun_id
then return $ Just ( (Set.singleton outerLevel, True) )
else return $ Just ( Set.fromList lvls, False )
-
--- pprTraceM "checkWellStaged" (ppr (tcg_bind_env gbl_env))
--- pprTraceM "checkWellStaged"
--- (ppr (lookupNameEnv (tcg_bind_env gbl_env) (idName dfun_id)))
--- {-
- return $ (,isLocalId dfun_id) <$> (lookupNameEnv (tcg_bind_env gbl_env) (idName dfun_id))
- return $ case lookupNameEnv (tcg_bind_env gbl_env) (idName dfun_id) of
- -- The instance comes from HPT imported module
- Just res -> Just (res, isLocalId dfun_id)
- Nothing ->
- if isLocalId dfun_id
- then Just ( (Set.singleton outerLevel, True) )
- -- TODO: Instances coming from external packages also need somehow
- -- to deal with splice imports
- else Just ( (Set.fromList [impLevel, outerLevel], False) )
--- return $ Just (TcM.topIdLvl dfun_id)
--- -}
| BuiltinTypeableInstance tc <- what
= do
cur_mod <- extractModule <$> getGblEnv
return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)
then (Set.singleton outerLevel, True)
- else (Set.singleton impLevel, False))
+ -- TODO, not correct, needs similar checks to normal instances
+ else (Set.fromList [impLevel, outerLevel], False))
| otherwise = return Nothing
{-
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -1167,7 +1167,7 @@ notFound name
Splice {}
| isUnboundName name -> failM -- If the name really isn't in scope
-- don't report it again (#11941)
- | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name))
+ | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name Nothing))
_ | isTermVarOrFieldNameSpace (nameNameSpace name) ->
-- This code path is only reachable with RequiredTypeArguments enabled
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2088,8 +2088,9 @@ getStageAndBindLevel name
--
-- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]
then do
- env <- getGlobalRdrEnv
- pprTrace "NO_LVLS" (ppr name) (return Nothing)
+ --env <- getGlobalRdrEnv
+ --pprTrace "NO_LVLS" (ppr name) (return Nothing)
+ return Nothing
else return (Just (TopLevel, lvls, getLclEnvThStage env))
Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThStage env)) }
@@ -2102,7 +2103,8 @@ getExternalBindLvl name = do
Nothing ->
if nameIsLocalOrFrom mod name
then return $ Set.singleton outerLevel
- else pprTrace "NO LVLS" (ppr name) (return Set.empty) -- pprPanic "getExternalBindLvl" (ppr env $$ ppr name $$ ppr (nameSrcSpan name))
+-- else pprTrace "NO LVLS" (ppr name) (return Set.empty) -- pprPanic "getExternalBindLvl" (ppr env $$ ppr name $$ ppr (nameSrcSpan name))
+ else return Set.empty
where
convert_lvl NormalStage = thLevel topStage
convert_lvl SpliceStage = thLevel topSpliceStage
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -101,7 +101,7 @@ module GHC.Types.Name.Reader (
Parent(..), greParent_maybe,
mkParent, availParent,
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
- importSpecLoc, importSpecModule, isExplicitItem, bestImport,
+ importSpecLoc, importSpecModule, importSpecStage, isExplicitItem, bestImport,
-- * Utils
opIsAt,
@@ -2080,6 +2080,9 @@ importSpecLoc (ImpSpec _ item) = is_iloc item
importSpecModule :: ImportSpec -> ModuleName
importSpecModule = moduleName . is_mod . is_decl
+importSpecStage :: ImportSpec -> ImportStage
+importSpecStage = is_staged . is_decl
+
isExplicitItem :: ImpItemSpec -> Bool
isExplicitItem ImpAll = False
isExplicitItem (ImpSome {is_explicit = exp}) = exp
@@ -2117,11 +2120,17 @@ instance Outputable ImportSpec where
ppr imp_spec
= text "imported" <+> qual
<+> text "from" <+> quotes (ppr (importSpecModule imp_spec))
+ <+> stage
<+> pprLoc (importSpecLoc imp_spec)
where
qual | is_qual (is_decl imp_spec) = text "qualified"
| otherwise = empty
+ stage = case importSpecStage imp_spec of
+ NormalStage -> empty
+ QuoteStage -> text "at 2"
+ SpliceStage -> text "at 0"
+
pprLoc :: SrcSpan -> SDoc
pprLoc (RealSrcSpan s _) = text "at" <+> ppr s
pprLoc (UnhelpfulSpan {}) = empty
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -150,9 +150,9 @@ nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk
nodeKeyUnitId (NodeKey_Link uid) = uid
nodeKeyLevel :: NodeKey -> ModuleStage
-nodeKeyLevel (NodeKey_Unit iud) = zeroStage
+nodeKeyLevel (NodeKey_Unit {}) = zeroStage
nodeKeyLevel (NodeKey_Module mk) = mnkLevel mk
-nodeKeyLevel (NodeKey_Link uid) = zeroStage
+nodeKeyLevel (NodeKey_Link {}) = zeroStage
nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)
@@ -170,7 +170,10 @@ todoStage :: HasCallStack => ModuleStage
todoStage -- = pprTrace "todoStage" callStackDoc
= zeroStage
+moduleStageToThLevel :: ModuleStage -> Int
moduleStageToThLevel (ModuleStage m) = m
+
+decModuleStage, incModuleStage :: ModuleStage -> ModuleStage
incModuleStage (ModuleStage m) = ModuleStage (m + 1)
decModuleStage (ModuleStage m) = ModuleStage (m - 1)
@@ -289,6 +292,7 @@ extendMG' mg = \case
mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph = foldr (flip extendMG') emptyMG
+collapseModuleGraph :: ModuleGraph -> ModuleGraph
collapseModuleGraph = mkModuleGraph . collapseModuleGraphNodes . mgModSummaries'
-- Collapse information about levels and map everything to level 0
@@ -387,7 +391,7 @@ nodeDependencies drop_hs_boot_nodes = \case
LinkNode deps _uid -> deps
InstantiationNode uid iuid ->
NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) zeroStage uid) <$> uniqDSetToList (instUnitHoles iuid)
- ModuleNode deps uid _lvl _ms ->
+ ModuleNode deps _ _lvl _ms ->
map drop_hs_boot deps
where
-- Drop hs-boot nodes by using HsSrcFile as the key
@@ -471,7 +475,7 @@ moduleGraphNodesZero ::
UnitState
-> [ModuleGraphNode]
-> (Graph ZeroSummaryNode, Either (ModNodeKeyWithUid, ImportStage) UnitId -> Maybe ZeroSummaryNode)
-moduleGraphNodesZero us summaries =
+moduleGraphNodesZero us summaries = pprTrace "mg_zero" (ppr summaries)
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
-- Map from module to extra boot summary dependencies which need to be merged in
=====================================
compiler/GHC/Unit/Module/ModSummary.hs
=====================================
@@ -170,8 +170,7 @@ ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms)
-- | Returns the dependencies of the ModSummary s.
msDeps :: ModSummary -> ([(ImportStage, PkgQual, GenWithIsBoot (Located ModuleName))])
-msDeps s =
- [ (unanalysedStage, NoPkgQual, d)
+msDeps s = [ (unanalysedStage, NoPkgQual, d)
| m <- ms_home_srcimps s
, d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }
]
=====================================
compiler/Language/Haskell/Syntax/ImpExp.hs
=====================================
@@ -17,8 +17,6 @@ import Prelude ( (.), show )
import Control.DeepSeq
import GHC.Stack
-import GHC.Utils.Panic
-import GHC.Utils.Trace
import GHC.Utils.Outputable
import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST
@@ -57,7 +55,7 @@ data ImportStage = NormalStage | SpliceStage | QuoteStage deriving (Eq, Ord, Dat
-- A placeholder which is used when the stage is not yet analysed.
unanalysedStage :: HasCallStack => ImportStage
-unanalysedStage = pprTrace "unanalysedStage" callStackDoc NormalStage
+unanalysedStage = NormalStage -- pprTrace "unanalysedStage" callStackDoc NormalStage
instance Outputable ImportStage where
ppr = text . show
=====================================
testsuite/tests/splice-imports/SI03.stderr
=====================================
@@ -1,5 +1,6 @@
SI03.hs:8:11: error: [GHC-28914]
• Stage error: ‘sid’ is bound at stage {1} but used at stage 0
Hint: quoting [| sid |] or an enclosing expression would allow the quotation to be used in an earlier stage
+ From imports {imported from ‘SI01A’ at SI03.hs:5:1-12}
• In the untyped splice: $(sid [| pure () |])
=====================================
testsuite/tests/splice-imports/SI05.stderr
=====================================
@@ -1,6 +1,7 @@
SI05.hs:9:11: error: [GHC-28914]
• Stage error: ‘SI01A.sid’ is bound at stage {1} but used at stage 0
Hint: quoting [| SI01A.sid |] or an enclosing expression would allow the quotation to be used in an earlier stage
+ From imports {imported from ‘SI01A’ at SI05.hs:5:1-12}
• In the untyped splice: $(sid [| pure () |])
SI05.hs:9:11: error: [GHC-87543]
@@ -10,7 +11,7 @@ SI05.hs:9:11: error: [GHC-87543]
imported from ‘SI01A’ at SI05.hs:5:1-12
(and originally defined at SI01A.hs:3:1-3),
or ‘SI05A.sid’,
- imported from ‘SI05A’ at SI05.hs:6:1-19
+ imported from ‘SI05A’ at 0 at SI05.hs:6:1-19
(and originally defined at SI05A.hs:3:1-3).
• In the untyped splice: $(sid [| pure () |])
=====================================
testsuite/tests/splice-imports/SI09.hs
=====================================
@@ -5,8 +5,6 @@ module SI09 where
import splice InstanceA ()
import splice ClassA
import splice Prelude
--- Why is implicit prelude import broken?
-import Prelude
e :: IO ()
-- Uses a non-splice imported instance
=====================================
testsuite/tests/splice-imports/SI20.stderr
=====================================
@@ -1,5 +1,7 @@
SI20.hs:9:7: error: [GHC-28914]
• Stage error: ‘foo’ is bound at stage {0, 1} but used at stage 2
Hint: quoting [| foo |] or an enclosing expression would allow the quotation to be used in an earlier stage
+ From imports {imported from ‘SI19A’ at 0 at SI20.hs:7:1-19,
+ imported from ‘SI19A’ at SI20.hs:6:1-12}
• In the Template Haskell quotation 'foo
=====================================
testsuite/tests/splice-imports/all.T
=====================================
@@ -4,7 +4,7 @@ def check_nothing(actual_file, normaliser):
test('SI01', normal, multimod_compile, ['SI01', '-v0'])
-test('SI02', normal, compile, [''])
+test('SI02', normal, multimod_compile, ['SI02', '-v0'])
test('SI03', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI03', '-v0'])
test('SI04', [extra_files(["SI01A.hs"])], multimod_compile, ['SI04', '-v0'])
test('SI05', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI05', '-v0'])
@@ -16,7 +16,7 @@ test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['S
test('SI10', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI10', '-v0'])
test('SI11', normal, compile_fail, [''])
test('SI12', normal, compile_fail, [''])
-test('SI13', normal, compile, [''])
+test('SI13', normal, multimod_compile, ['SI13', '-v0'])
test('SI14', normal, compile_fail, [''])
test('SI15', normal, compile_fail, [''])
test('SI16', normal, compile_fail, [''])
@@ -26,4 +26,5 @@ test('SI19', extra_files(["SI19A.hs"]), multimod_compile, ['SI19', '-v0'])
test('SI20', extra_files(["SI19A.hs"]), multimod_compile_fail, ['SI20', '-v0'])
test('SI21', normal, multimod_compile_fail, ['SI21', '-v0'])
test('SI22', normal, multimod_compile_fail, ['SI22', '-v0'])
+test('SI23', extra_files(["SI23A.hs"]), multimod_compile, ['SI23', '-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/48c4e78bd382f53846a30daa7d3f2ab1dbf17d55
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/48c4e78bd382f53846a30daa7d3f2ab1dbf17d55
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/20241105/dc0de978/attachment-0001.html>
More information about the ghc-commits
mailing list