[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add special case for :Main module in `GHC.IfaceToCore.mk_top_id`
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Dec 3 03:18:40 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
85ecc1a0 by Matthew Pickering at 2022-12-02T19:46:43-05:00
Add special case for :Main module in `GHC.IfaceToCore.mk_top_id`
See Note [Root-main Id]
The `:Main` special binding is actually defined in the current module
(hence don't go looking for it externally) but the module name is rOOT_MAIN
rather than the current module so we need this special case.
There was already some similar logic in `GHC.Rename.Env` for
External Core, but now the "External Core" is in interface files it
needs to be moved here instead.
Fixes #22405
- - - - -
108c319f by Krzysztof Gogolewski at 2022-12-02T19:47:18-05:00
Fix linearity checking in Lint
Lint was not able to see that x*y <= x*y, because this inequality
was decomposed to x <= x*y && y <= x*y, but there was no rule
to see that x <= x*y.
Fixes #22546.
- - - - -
ac237eb4 by Bryan Richter at 2022-12-02T22:18:27-05:00
Mark T16916 fragile
See https://gitlab.haskell.org/ghc/ghc/-/issues/16966
- - - - -
cdd40740 by Vladislav Zavialov at 2022-12-02T22:18:27-05:00
Refactor: FreshOrReuse instead of addTyClTyVarBinds
This is a refactoring that should have no effect on observable behavior.
Prior to this change, GHC.HsToCore.Quote contained a few closely related
functions to process type variable bindings: addSimpleTyVarBinds,
addHsTyVarBinds, addQTyVarBinds, and addTyClTyVarBinds.
We can classify them by their input type and name generation strategy:
Fresh names only Reuse bound names
+---------------------+-------------------+
[Name] | addSimpleTyVarBinds | |
[LHsTyVarBndr flag GhcRn] | addHsTyVarBinds | |
LHsQTyVars GhcRn | addQTyVarBinds | addTyClTyVarBinds |
+---------------------+-------------------+
Note how two functions are missing. Because of this omission, there were
two places where a LHsQTyVars value was constructed just to be able to pass it
to addTyClTyVarBinds:
1. mk_qtvs in addHsOuterFamEqnTyVarBinds -- bad
2. mkHsQTvs in repFamilyDecl -- bad
This prevented me from making other changes to LHsQTyVars, so the main
goal of this refactoring is to get rid of those workarounds.
The most direct solution would be to define the missing functions.
But that would lead to a certain amount of code duplication. To avoid
code duplication, I factored out the name generation strategy into a
function parameter:
data FreshOrReuse
= FreshNamesOnly
| ReuseBoundNames
addSimpleTyVarBinds :: FreshOrReuse -> ...
addHsTyVarBinds :: FreshOrReuse -> ...
addQTyVarBinds :: FreshOrReuse -> ...
- - - - -
0bf27239 by Vladislav Zavialov at 2022-12-02T22:18:27-05:00
addHsOuterFamEqnTyVarBinds: use FreshNamesOnly for explicit binders
Consider this example:
[d| instance forall a. C [a] where
type forall b. G [a] b = Proxy b |]
When we process "forall b." in the associated type instance, it is
unambiguously the binding site for "b" and we want a fresh name for it.
Therefore, FreshNamesOnly is more fitting than ReuseBoundNames.
This should not have any observable effect but it avoids pointless
lookups in the MetaEnv.
- - - - -
14 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Tc/Module.hs
- + testsuite/tests/driver/fat-iface/T22405/Main.hs
- + testsuite/tests/driver/fat-iface/T22405/Main2.hs
- + testsuite/tests/driver/fat-iface/T22405/Makefile
- + testsuite/tests/driver/fat-iface/T22405/T22405.stdout
- + testsuite/tests/driver/fat-iface/T22405/T22405b.stdout
- + testsuite/tests/driver/fat-iface/T22405/all.T
- testsuite/tests/lib/base/all.T
- + testsuite/tests/linear/should_compile/T22546.hs
- testsuite/tests/linear/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -3235,22 +3235,29 @@ ensureSubUsage Zero described_mult err_msg = ensureSubMult ManyTy describe
ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg
ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()
-ensureSubMult actual_usage described_usage err_msg = do
+ensureSubMult actual_mult described_mult err_msg = do
flags <- getLintFlags
- when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of
- Submult -> return ()
- Unknown -> case isMultMul actual_usage' of
- Just (m1, m2) -> ensureSubMult m1 described_usage' err_msg >>
- ensureSubMult m2 described_usage' err_msg
- Nothing -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg)
-
- where actual_usage' = normalize actual_usage
- described_usage' = normalize described_usage
-
- normalize :: Mult -> Mult
- normalize m = case isMultMul m of
- Just (m1, m2) -> mkMultMul (normalize m1) (normalize m2)
- Nothing -> m
+ when (lf_check_linearity flags) $
+ unless (deepSubMult actual_mult described_mult) $
+ addErrL err_msg
+ where
+ -- Check for submultiplicity using the following rules:
+ -- 1. x*y <= z when x <= z and y <= z.
+ -- This rule follows from the fact that x*y = sup{x,y} for any
+ -- multiplicities x,y.
+ -- 2. x <= y*z when x <= y or x <= z.
+ -- This rule is not complete: when x = y*z, we cannot
+ -- change y*z <= y*z to y*z <= y or y*z <= z.
+ -- However, we eliminate products on the LHS in step 1.
+ -- 3. One <= x and x <= Many for any x, as checked by 'submult'.
+ -- 4. x <= x.
+ -- Otherwise, we fail.
+ deepSubMult :: Mult -> Mult -> Bool
+ deepSubMult m n
+ | Just (m1, m2) <- isMultMul m = deepSubMult m1 n && deepSubMult m2 n
+ | Just (n1, n2) <- isMultMul n = deepSubMult m n1 || deepSubMult m n2
+ | Submult <- m `submult` n = True
+ | otherwise = m `eqType` n
lintRole :: Outputable thing
=> thing -- where the role appeared
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -461,7 +461,7 @@ repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
= do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences]
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+ ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
repSynDecl tc1 bndrs rhs
; return (Just (locA loc, dec)) }
@@ -469,7 +469,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc
, tcdTyVars = tvs
, tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences]
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+ ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
repDataDefn tc1 (Left bndrs) defn
; return (Just (locA loc, dec)) }
@@ -478,7 +478,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdSigs = sigs, tcdMeths = meth_binds,
tcdATs = ats, tcdATDefs = atds }))
= do { cls1 <- lookupLOcc cls -- See Note [Binders and occurrences]
- ; dec <- addQTyVarBinds tvs $ \bndrs ->
+ ; dec <- addQTyVarBinds FreshNamesOnly tvs $ \bndrs ->
do { cxt1 <- repLContext cxt
-- See Note [Scoped type variables in quotes]
; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
@@ -549,14 +549,11 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
, fdResultSig = L _ resultSig
, fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences]
- ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
- mkHsQTvs tvs = HsQTvs { hsq_ext = []
- , hsq_explicit = tvs }
- resTyVar = case resultSig of
- TyVarSig _ bndr -> mkHsQTvs [bndr]
- _ -> mkHsQTvs []
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- addTyClTyVarBinds resTyVar $ \_ ->
+ ; let resTyVar = case resultSig of
+ TyVarSig _ bndr -> [hsLTyVarName bndr]
+ _ -> []
+ ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
+ addSimpleTyVarBinds ReuseBoundNames resTyVar $
case info of
ClosedTypeFamily Nothing ->
notHandled (ThAbstractClosedTypeFamily decl)
@@ -645,7 +642,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_datafam_insts = adts
, cid_overlap_mode = overlap
})
- = addSimpleTyVarBinds tvs $
+ = addSimpleTyVarBinds FreshNamesOnly tvs $
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
-- appear in the resulting data structure
@@ -672,7 +669,7 @@ repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
, deriv_type = ty }))
= do { dec <- repDerivStrategy strat $ \strat' ->
- addSimpleTyVarBinds tvs $
+ addSimpleTyVarBinds FreshNamesOnly tvs $
do { cxt' <- repLContext cxt
; inst_ty' <- repLTy inst_ty
; repDeriv strat' cxt' inst_ty' }
@@ -804,16 +801,17 @@ repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
, rd_act = act
- , rd_tyvs = ty_bndrs
+ , rd_tyvs = m_ty_bndrs
, rd_tmvs = tm_bndrs
, rd_lhs = lhs
, rd_rhs = rhs }))
- = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+ = do { let ty_bndrs = fromMaybe [] m_ty_bndrs
+ ; rule <- addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->
do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
; ss <- mkGenSyms tm_bndr_names
; rule <- addBinds ss $
do { elt_ty <- wrapName tyVarBndrUnitTyConName
- ; ty_bndrs' <- return $ case ty_bndrs of
+ ; ty_bndrs' <- return $ case m_ty_bndrs of
Nothing -> coreNothing' (mkListTy elt_ty)
Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
; tm_bndrs' <- repListM ruleBndrTyConName
@@ -878,7 +876,7 @@ repC (L _ (ConDeclH98 { con_name = con
, con_ex_tvs = con_tvs
, con_mb_cxt = mcxt
, con_args = args }))
- = addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+ = addHsTyVarBinds FreshNamesOnly con_tvs $ \ ex_bndrs ->
do { c' <- repH98DataCon con args
; ctxt' <- repMbContext mcxt
; if not is_existential && isNothing mcxt
@@ -1188,14 +1186,11 @@ addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do
elt_ty <- wrapName tyVarBndrUnitTyConName
case outer_bndrs of
HsOuterImplicit{hso_ximplicit = imp_tvs} ->
- addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->
+ addSimpleTyVarBinds ReuseBoundNames imp_tvs $
thing_inside $ coreNothingList elt_ty
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
- addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->
+ addHsTyVarBinds FreshNamesOnly exp_bndrs $ \th_exp_bndrs ->
thing_inside $ coreJustList elt_ty th_exp_bndrs
- where
- mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs
- , hsq_explicit = exp_tvs }
addHsOuterSigTyVarBinds ::
HsOuterSigTyVarBndrs GhcRn
@@ -1204,9 +1199,9 @@ addHsOuterSigTyVarBinds ::
addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
HsOuterImplicit{hso_ximplicit = imp_tvs} ->
do th_nil <- coreListM tyVarBndrSpecTyConName []
- addSimpleTyVarBinds imp_tvs $ thing_inside th_nil
+ addSimpleTyVarBinds FreshNamesOnly imp_tvs $ thing_inside th_nil
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
- addHsTyVarBinds exp_bndrs thing_inside
+ addHsTyVarBinds FreshNamesOnly exp_bndrs thing_inside
-- | If a type implicitly quantifies its outermost type variables, return
-- 'True' if the list of implicitly bound type variables is empty. If a type
@@ -1230,69 +1225,86 @@ nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs
nullOuterExplicit (HsOuterImplicit{}) = True
-- Vacuously true, as there is no outermost explicit quantification
-addSimpleTyVarBinds :: [Name] -- the binders to be added
+-- Do we want to generate fresh names for type variables
+-- or reuse the ones that are already in scope?
+data FreshOrReuse
+ = FreshNamesOnly
+ -- Generate fresh names for all type variables, regardless of existing
+ -- variables in the MetaEnv.
+ --
+ -- This is the default strategy.
+
+ | ReuseBoundNames
+ -- Generate fresh names for type variables not in the MetaEnv.
+ -- Where a name is already bound in the MetaEnv, use that existing binding;
+ -- do not create a new one with a fresh name.
+ --
+ -- This is the strategy used for data/newtype declarations and type family
+ -- instances, so that the nested type variables work right:
+ --
+ -- class C a where
+ -- type W a b
+ -- instance C (T a) where
+ -- type W (T a) b = blah
+ --
+ -- The 'a' in the type instance is the one bound by the instance decl
+ --
+ -- Test cases: TH_reifyExplicitForAllFams T9081 T9199 T10811
+
+mkGenSyms' :: FreshOrReuse -> [Name] -> MetaM [GenSymBind]
+mkGenSyms' FreshNamesOnly names = mkGenSyms names
+mkGenSyms' ReuseBoundNames names =
+ -- Make fresh names for the ones that are not already in scope
+ -- This makes things work for associated types
+ do { env <- lift dsGetMetaEnv
+ ; mkGenSyms (filterOut (`elemNameEnv` env) names) }
+
+addSimpleTyVarBinds :: FreshOrReuse
+ -> [Name] -- the binders to be added
-> MetaM (Core (M a)) -- action in the ext env
-> MetaM (Core (M a))
-addSimpleTyVarBinds names thing_inside
- = do { fresh_names <- mkGenSyms names
+addSimpleTyVarBinds fresh_or_reuse names thing_inside
+ = do { fresh_names <- mkGenSyms' fresh_or_reuse names
; term <- addBinds fresh_names thing_inside
; wrapGenSyms fresh_names term }
addHsTyVarBinds :: forall flag flag' a. RepTV flag flag'
- => [LHsTyVarBndr flag GhcRn] -- the binders to be added
+ => FreshOrReuse
+ -> [LHsTyVarBndr flag GhcRn] -- the binders to be added
-> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
-> MetaM (Core (M a))
-addHsTyVarBinds exp_tvs thing_inside
- = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
+addHsTyVarBinds fresh_or_reuse exp_tvs thing_inside
+ = do { fresh_exp_names <- mkGenSyms' fresh_or_reuse (hsLTyVarNames exp_tvs)
; term <- addBinds fresh_exp_names $
do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr
exp_tvs
; thing_inside kbs }
; wrapGenSyms fresh_exp_names term }
-addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
+addQTyVarBinds :: FreshOrReuse
+ -> LHsQTyVars GhcRn -- the binders to be added
-> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env
-> MetaM (Core (M a))
-addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs
- , hsq_explicit = exp_tvs })
- thing_inside
- = addTyVarBinds exp_tvs imp_tvs thing_inside
+addQTyVarBinds fresh_or_reuse qtvs thing_inside =
+ let HsQTvs { hsq_ext = imp_tvs
+ , hsq_explicit = exp_tvs }
+ = qtvs
+ in addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside
addTyVarBinds :: RepTV flag flag'
- => [LHsTyVarBndr flag GhcRn] -- the binders to be added
+ => FreshOrReuse
+ -> [LHsTyVarBndr flag GhcRn] -- the binders to be added
-> [Name]
-> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
-> MetaM (Core (M a))
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
-- meta environment and gets the *new* names on Core-level as an argument
-addTyVarBinds exp_tvs imp_tvs thing_inside
- = addSimpleTyVarBinds imp_tvs $
- addHsTyVarBinds exp_tvs $
+addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside
+ = addSimpleTyVarBinds fresh_or_reuse imp_tvs $
+ addHsTyVarBinds fresh_or_reuse exp_tvs $
thing_inside
-addTyClTyVarBinds :: LHsQTyVars GhcRn
- -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a)))
- -> MetaM (Core (M a))
--- Used for data/newtype declarations, and family instances,
--- so that the nested type variables work right
--- instance C (T a) where
--- type W (T a) = blah
--- The 'a' in the type instance is the one bound by the instance decl
-addTyClTyVarBinds tvs m
- = do { let tv_names = hsAllLTyVarNames tvs
- ; env <- lift $ dsGetMetaEnv
- ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
- -- Make fresh names for the ones that are not already in scope
- -- This makes things work for family declarations
-
- ; term <- addBinds freshNames $
- do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr
- (hsQTvExplicit tvs)
- ; m kbs }
-
- ; wrapGenSyms freshNames term }
-
-- | Represent a type variable binder
repTyVarBndr :: RepTV flag flag'
=> LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))
@@ -1341,7 +1353,7 @@ repLTy ty = repTy (unLoc ty)
repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
repForallT ty
| (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty)
- = addHsTyVarBinds tvs $ \bndrs ->
+ = addHsTyVarBinds FreshNamesOnly tvs $ \bndrs ->
do { ctxt1 <- repLContext ctxt
; tau1 <- repLTy tau
; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
@@ -1352,7 +1364,7 @@ repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) =
case tele of
HsForAllInvis{} -> repForallT ty
HsForAllVis { hsf_vis_bndrs = tvs } ->
- addHsTyVarBinds tvs $ \bndrs ->
+ addHsTyVarBinds FreshNamesOnly tvs $ \bndrs ->
do body1 <- repLTy body
repTForallVis bndrs body1
repTy ty@(HsQualTy {}) = repForallT ty
@@ -1606,7 +1618,7 @@ repE (RecordUpd { rupd_flds = Right _ })
panic "The impossible has happened!"
repE (ExprWithTySig _ e wc_ty)
- = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $
+ = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $
do { e1 <- repLE e
; t1 <- rep_ty_sig' sig_ty
; repSigExp e1 t1 }
@@ -2560,7 +2572,7 @@ repDerivStrategy mds thing_inside =
StockStrategy _ -> thing_inside =<< just =<< repStockStrategy
AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy
NewtypeStrategy _ -> thing_inside =<< just =<< repNewtypeStrategy
- ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $
+ ViaStrategy ty -> addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig ty) $
do ty' <- rep_ty_sig' ty
via_strat <- repViaStrategy ty'
m_via_strat <- just via_strat
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -123,6 +123,7 @@ import GHC.Driver.Env.KnotVars
import GHC.Unit.Module.WholeCoreBindings
import Data.IORef
import Data.Foldable
+import GHC.Builtin.Names (ioTyConName, rOOT_MAIN)
{-
This module takes
@@ -930,7 +931,17 @@ tc_iface_binding i IfUseUnfoldingRhs = return (unfoldingTemplate $ realIdUnfoldi
tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs
mk_top_id :: IfaceTopBndrInfo -> IfL Id
-mk_top_id (IfGblTopBndr gbl_name) = tcIfaceExtId gbl_name
+mk_top_id (IfGblTopBndr gbl_name)
+ -- See Note [Root-main Id]
+ -- This special binding is actually defined in the current module
+ -- (hence don't go looking for it externally) but the module name is rOOT_MAIN
+ -- rather than the current module so we need this special case.
+ -- See some similar logic in `GHC.Rename.Env`.
+ | Just rOOT_MAIN == nameModule_maybe gbl_name
+ = do
+ ATyCon ioTyCon <- tcIfaceGlobal ioTyConName
+ return $ mkExportedVanillaId gbl_name (mkTyConApp ioTyCon [unitTy])
+ | otherwise = tcIfaceExtId gbl_name
mk_top_id (IfLclTopBndr raw_name iface_type info details) = do
name <- newIfaceName (mkVarOccFS raw_name)
ty <- tcIfaceType iface_type
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -207,6 +207,11 @@ newTopSrcBinder (L loc rdr_name)
-- the nice Exact name for the TyCon gets swizzled to an Orig name.
-- Hence the badOrigBinding error message.
--
+
+ -- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore
+ -- because External Core has been removed but we instead have some similar logic for
+ -- serialising whole programs into interface files in GHC.IfaceToCore.mk_top_id.
+
-- Except for the ":Main.main = ..." definition inserted into
-- the Main module; ugh!
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2047,6 +2047,14 @@ This is unusual: it's a LocalId whose Name has a Module from another
module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we
get two defns for 'main' in the interface file!
+When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file.
+When the interface is read back in we have to add a special case when creating the
+Id because otherwise we would go looking for the :Main module which obviously doesn't
+exist. For this logic see GHC.IfaceToCore.mk_top_id.
+
+There is also some similar (probably dead) logic in GHC.Rename.Env which says it
+was added for External Core which faced a similar issue.
+
*********************************************************
* *
=====================================
testsuite/tests/driver/fat-iface/T22405/Main.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = return ()
=====================================
testsuite/tests/driver/fat-iface/T22405/Main2.hs
=====================================
@@ -0,0 +1,6 @@
+module Main2 where
+
+main :: IO ()
+main = return ()
+
+
=====================================
testsuite/tests/driver/fat-iface/T22405/Makefile
=====================================
@@ -0,0 +1,17 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RTSOPTS = $(filter-out -rtsopts,$(TEST_HC_OPTS))
+
+clean:
+ rm -f *.hi *.hi-fat *.o
+
+T22405: clean
+ "$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main
+ "$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main
+
+T22405b: clean
+ "$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main2 -main-is Main2
+ "$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main2 -main-is Main2
+
=====================================
testsuite/tests/driver/fat-iface/T22405/T22405.stdout
=====================================
@@ -0,0 +1,2 @@
+[1 of 2] Compiling Main ( Main.hs, Main.o, interpreted )
+[2 of 2] Linking Main
=====================================
testsuite/tests/driver/fat-iface/T22405/T22405b.stdout
=====================================
@@ -0,0 +1,2 @@
+[1 of 2] Compiling Main2 ( Main2.hs, Main2.o, interpreted )
+[2 of 2] Linking Main2
=====================================
testsuite/tests/driver/fat-iface/T22405/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T22405', [extra_files(['Main.hs'])], makefile_test, ['T22405'])
+test('T22405b', [extra_files(['Main2.hs'])], makefile_test, ['T22405b'])
=====================================
testsuite/tests/lib/base/all.T
=====================================
@@ -1,7 +1,7 @@
test('DataTypeOrd', normal, compile_and_run, [''])
test('T16586', normal, compile_and_run, ['-O2'])
# Event-manager not supported on Windows
-test('T16916', [when(opsys('mingw32'), skip), js_broken(22261)], compile_and_run, ['-O2 -threaded -with-rtsopts="-I0" -rtsopts'])
+test('T16916', [when(opsys('mingw32'), skip), js_broken(22261), fragile(16966)], compile_and_run, ['-O2 -threaded -with-rtsopts="-I0" -rtsopts'])
test('T17310', normal, compile, [''])
test('T19691', normal, compile, [''])
test('executablePath', [extra_run_opts(config.os), js_broken(22261)], compile_and_run, [''])
=====================================
testsuite/tests/linear/should_compile/T22546.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE LinearTypes, GADTSyntax #-}
+
+module T22546 where
+
+import GHC.Types (Multiplicity (..))
+import Data.Kind (Type)
+
+data T :: Multiplicity -> Type where
+ MkT :: () %m-> T m
+
+unMkT :: T m %n-> ()
+unMkT (MkT x) = x
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -39,3 +39,4 @@ test('LinearDataConSections', normal, compile, [''])
test('T18731', normal, compile, [''])
test('T19400', unless(compiler_debugged(), skip), compile, [''])
test('T20023', normal, compile, [''])
+test('T22546', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4dd67cb0ec230aa876a529d8cb4fa78eb3c7adfe...0bf27239066dd59f2524bf3df4f2f6015b5ff6d7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4dd67cb0ec230aa876a529d8cb4fa78eb3c7adfe...0bf27239066dd59f2524bf3df4f2f6015b5ff6d7
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/20221202/7ed28cad/attachment-0001.html>
More information about the ghc-commits
mailing list