Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 93fc7265 by sheaf at 2025-11-06T21:33:24-05:00 Correct hasFixedRuntimeRep in matchExpectedFunTys This commit fixes a bug in the representation-polymormorphism check in GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put the coercion resulting from hasFixedRuntimeRep in the wrong place, leading to the Core Lint error reported in #26528. The change is that we have to be careful when using 'mkWpFun': it expects **both** the expected and actual argument types to have a syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT] in GHC.Tc.Types.Evidence. On the way, this patch improves some of the commentary relating to other usages of 'mkWpFun' in the compiler, in particular in the view pattern case of 'tc_pat'. No functional changes, but some stylistic changes to make the code more readable, and make it easier to understand how we are upholding the WpFun-FRR-INVARIANT. Fixes #26528 - - - - - c052c724 by Simon Peyton Jones at 2025-11-06T21:34:06-05:00 Fix a horrible shadowing bug in implicit parameters Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts where we now do /not/ delete /Wanted/ implicit-parameeter constraints. This bug has been in GHC since 9.8! But it's quite hard to provoke; I contructed a tests in T26451, but it was hard to do so. - - - - - 26628a77 by Georgios Karachalias at 2025-11-07T11:21:02-05:00 Remove the `CoreBindings` constructor from `LinkablePart` Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings from being passed as input to getLinkDeps (which would previously panic in this case). Fixes #26497 - - - - - 19a1f0d9 by Sylvain Henry at 2025-11-07T11:21:26-05:00 Testsuite: pass ext-interp test way (#26552) Note that some tests are still marked as broken with the ext-interp way (see #26552 and #14335) - - - - - 23 changed files: - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - libraries/base/tests/all.T - testsuite/driver/testlib.py - testsuite/tests/driver/T20696/all.T - testsuite/tests/driver/fat-iface/all.T - + testsuite/tests/rep-poly/T26528.hs - testsuite/tests/rep-poly/all.T - testsuite/tests/splice-imports/all.T - + testsuite/tests/typecheck/should_compile/T26451.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -277,6 +277,7 @@ import Data.Data hiding (Fixity, TyCon) import Data.Functor ((<&>)) import Data.List ( nub, isPrefixOf, partition ) import qualified Data.List.NonEmpty as NE +import Data.Traversable (for) import Control.Monad import Data.IORef import System.FilePath as FilePath @@ -850,11 +851,11 @@ hscRecompStatus if | not (backendGeneratesCode (backend lcl_dflags)) -> do -- No need for a linkable, we're good to go msg UpToDate - return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + return $ HscUpToDate checked_iface emptyRecompLinkables | not (backendGeneratesCodeForHsBoot (backend lcl_dflags)) , IsBoot <- isBootSummary mod_summary -> do msg UpToDate - return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + return $ HscUpToDate checked_iface emptyRecompLinkables -- Always recompile with the JS backend when TH is enabled until -- #23013 is fixed. @@ -883,7 +884,7 @@ hscRecompStatus let just_o = justObjects <$> obj_linkable bytecode_or_object_code - | gopt Opt_WriteByteCode lcl_dflags = justBytecode <$> definitely_bc + | gopt Opt_WriteByteCode lcl_dflags = justBytecode . Left <$> definitely_bc | otherwise = (justBytecode <$> maybe_bc) `choose` just_o @@ -900,13 +901,13 @@ hscRecompStatus definitely_bc = bc_obj_linkable `prefer` bc_in_memory_linkable -- If not -fwrite-byte-code, then we could use core bindings or object code if that's available. - maybe_bc = bc_in_memory_linkable `choose` - bc_obj_linkable `choose` - bc_core_linkable + maybe_bc = (Left <$> bc_in_memory_linkable) `choose` + (Left <$> bc_obj_linkable) `choose` + (Right <$> bc_core_linkable) bc_result = if gopt Opt_WriteByteCode lcl_dflags -- If the byte-code artifact needs to be produced, then we certainly need bytecode. - then definitely_bc + then Left <$> definitely_bc else maybe_bc trace_if (hsc_logger hsc_env) @@ -1021,14 +1022,13 @@ checkByteCodeFromObject hsc_env mod_sum = do -- | Attempt to load bytecode from whole core bindings in the interface if they exist. -- This is a legacy code-path, these days it should be preferred to use the bytecode object linkable. -checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated Linkable) +checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated WholeCoreBindingsLinkable) checkByteCodeFromIfaceCoreBindings _hsc_env iface mod_sum = do let this_mod = ms_mod mod_sum if_date = fromJust $ ms_iface_date mod_sum case iface_core_bindings iface (ms_location mod_sum) of - Just fi -> do - return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi)))) + Just fi -> return $ UpToDateItem (Linkable if_date this_mod fi) _ -> return $ outOfDateItemBecause MissingBytecode Nothing -------------------------------------------------------------- @@ -1142,20 +1142,22 @@ initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> - Linkable -> - IO Linkable -initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do - Linkable utc_time this_mod <$> mapM (go hsc_env) uls + RecompLinkables -> + IO HomeModLinkable +initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do + bc' <- go bc + pure $ HomeModLinkable bc' o where - go hsc_env' = \case - CoreBindings wcb -> do + type_env = md_types details + + go :: RecompBytecodeLinkable -> IO (Maybe Linkable) + go (NormalLinkable l) = pure l + go (WholeCoreBindingsLinkable wcbl) = + fmap Just $ for wcbl $ \wcb -> do add_iface_to_hpt iface details hsc_env bco <- unsafeInterleaveIO $ - compileWholeCoreBindings hsc_env' type_env wcb - pure (DotGBC bco) - l -> pure l - - type_env = md_types details + compileWholeCoreBindings hsc_env type_env wcb + pure $ NE.singleton (DotGBC bco) -- | Hydrate interface Core bindings and compile them to bytecode. -- ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -109,6 +109,7 @@ import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Status import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable @@ -249,8 +250,8 @@ compileOne' mHscMessage (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline -- See Note [ModDetails and --make mode] details <- initModDetails plugin_hsc_env iface - linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable) - return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' }) + linkable' <- initWholeCoreBindings plugin_hsc_env iface details linkable + return $! HomeModInfo iface details linkable' where lcl_dflags = ms_hspp_opts summary location = ms_location summary @@ -759,7 +760,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do $ phaseIfFlag hsc_env flag def action -- | The complete compilation pipeline, from start to finish -fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable) +fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, RecompLinkables) fullPipeline pipe_env hsc_env pp_fn src_flavour = do (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn let hsc_env' = hscSetFlags dflags hsc_env @@ -768,7 +769,7 @@ fullPipeline pipe_env hsc_env pp_fn src_flavour = do hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) -- | Everything after preprocess -hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable) +hscPipeline :: P m => PipeEnv -> (HscEnv, ModSummary, HscRecompStatus) -> m (ModIface, RecompLinkables) hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do case hsc_recomp_status of HscUpToDate iface mb_linkable -> return (iface, mb_linkable) @@ -777,7 +778,7 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash ) hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction -hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable) +hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, RecompLinkables) hscBackendPipeline pipe_env hsc_env mod_sum result = if backendGeneratesCode (backend (hsc_dflags hsc_env)) then do @@ -796,15 +797,15 @@ hscBackendPipeline pipe_env hsc_env mod_sum result = return res else case result of - HscUpdate iface -> return (iface, emptyHomeModInfoLinkable) - HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable + HscUpdate iface -> return (iface, emptyRecompLinkables) + HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyRecompLinkables hscGenBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction - -> m (ModIface, HomeModLinkable) + -> m (ModIface, RecompLinkables) hscGenBackendPipeline pipe_env hsc_env mod_sum result = do let mod_name = moduleName (ms_mod mod_sum) src_flavour = (ms_hsc_src mod_sum) @@ -812,7 +813,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result) final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file final_linkable <- - case final_fp of + safeCastHomeModLinkable <$> case final_fp of -- No object file produced, bytecode or NoBackend Nothing -> return mlinkable Just o_fp -> do @@ -936,7 +937,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase = as :: P m => Bool -> m (Maybe FilePath) as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn - objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk + objFromLinkable (_, recompLinkables_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk objFromLinkable _ = Nothing fromPhase :: P m => Phase -> m (Maybe FilePath) ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -33,7 +33,6 @@ import GHC.Utils.Error import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module -import GHC.Unit.Module.WholeCoreBindings import GHC.Unit.Home.ModInfo import GHC.Iface.Errors.Types @@ -206,10 +205,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do DotO file ForeignObject -> pure (DotO file ForeignObject) DotA fp -> panic ("adjust_ul DotA " ++ show fp) DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp) - DotGBC {} -> pure part - CoreBindings WholeCoreBindings {wcb_module} -> - pprPanic "Unhydrated core bindings" (ppr wcb_module) - + DotGBC {} -> pure part {- ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- -- @@ -30,7 +31,9 @@ module GHC.Linker.Types , PkgsLoaded -- * Linkable - , Linkable(..) + , Linkable + , WholeCoreBindingsLinkable + , LinkableWith(..) , mkModuleByteCodeLinkable , LinkablePart(..) , LinkableObjectSort (..) @@ -254,7 +257,7 @@ instance Outputable LoadedPkgInfo where -- | Information we can use to dynamically link modules into the compiler -data Linkable = Linkable +data LinkableWith parts = Linkable { linkableTime :: !UTCTime -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, @@ -263,9 +266,13 @@ data Linkable = Linkable , linkableModule :: !Module -- ^ The linkable module itself - , linkableParts :: NonEmpty LinkablePart + , linkableParts :: parts -- ^ Files and chunks of code to link. - } + } deriving (Functor, Traversable, Foldable) + +type Linkable = LinkableWith (NonEmpty LinkablePart) + +type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings type LinkableSet = ModuleEnv Linkable @@ -282,7 +289,7 @@ unionLinkableSet = plusModuleEnv_C go | linkableTime l1 > linkableTime l2 = l1 | otherwise = l2 -instance Outputable Linkable where +instance Outputable a => Outputable (LinkableWith a) where ppr (Linkable when_made mod parts) = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod) $$ nest 3 (ppr parts) @@ -318,11 +325,6 @@ data LinkablePart | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | CoreBindings WholeCoreBindings - -- ^ Serialised core which we can turn into BCOs (or object files), or - -- used by some other backend See Note [Interface Files with Core - -- Definitions] - | DotGBC ModuleByteCode -- ^ A byte-code object, lives only in memory. @@ -350,7 +352,6 @@ instance Outputable LinkablePart where ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path ppr (DotGBC bco) = text "DotGBC" <+> ppr bco - ppr (CoreBindings {}) = text "CoreBindings" -- | Return true if the linkable only consists of native code (no BCO) linkableIsNativeCodeOnly :: Linkable -> Bool @@ -391,7 +392,6 @@ isNativeCode = \case DotA {} -> True DotDLL {} -> True DotGBC {} -> False - CoreBindings {} -> False -- | Is the part a native library? (.so/.dll) isNativeLib :: LinkablePart -> Bool @@ -400,7 +400,6 @@ isNativeLib = \case DotA {} -> True DotDLL {} -> True DotGBC {} -> False - CoreBindings {} -> False -- | Get the FilePath of linkable part (if applicable) linkablePartPath :: LinkablePart -> Maybe FilePath @@ -408,7 +407,6 @@ linkablePartPath = \case DotO fn _ -> Just fn DotA fn -> Just fn DotDLL fn -> Just fn - CoreBindings {} -> Nothing DotGBC {} -> Nothing -- | Return the paths of all object code files (.o, .a, .so) contained in this @@ -418,7 +416,6 @@ linkablePartNativePaths = \case DotO fn _ -> [fn] DotA fn -> [fn] DotDLL fn -> [fn] - CoreBindings {} -> [] DotGBC {} -> [] -- | Return the paths of all object files (.o) contained in this 'LinkablePart'. @@ -427,7 +424,6 @@ linkablePartObjectPaths = \case DotO fn _ -> [fn] DotA _ -> [] DotDLL _ -> [] - CoreBindings {} -> [] DotGBC bco -> gbc_foreign_files bco -- | Retrieve the compiled byte-code from the linkable part. @@ -444,12 +440,11 @@ linkableFilter f linkable = do Just linkable {linkableParts = new} linkablePartNative :: LinkablePart -> [LinkablePart] -linkablePartNative = \case - u@DotO {} -> [u] - u@DotA {} -> [u] - u@DotDLL {} -> [u] +linkablePartNative u = case u of + DotO {} -> [u] + DotA {} -> [u] + DotDLL {} -> [u] DotGBC bco -> [DotO f ForeignObject | f <- gbc_foreign_files bco] - _ -> [] linkablePartByteCode :: LinkablePart -> [LinkablePart] linkablePartByteCode = \case ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -957,7 +957,7 @@ tcSynArgE :: CtOrigin -> SyntaxOpType -- ^ shape it is expected to have -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments -> TcM (a, HsWrapper) - -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) + -- ^ returns a wrapper :: (type of right shape) ~~> (type passed in) tcSynArgE orig op sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper)) <- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty -> @@ -978,10 +978,10 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside ; return (result, mkWpCastN list_co) } go rho_ty (SynFun arg_shape res_shape) - = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty + = do { ( match_wrapper -- :: (arg_ty -> res_ty) ~~> rho_ty , ( ( (result, arg_ty, res_ty, op_mult) - , res_wrapper ) -- :: res_ty_out "->" res_ty - , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out + , res_wrapper ) -- :: res_ty_out ~~> res_ty + , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty ~~> arg_ty_out <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ \ [ExpFunPatTy arg_ty] res_ty -> do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) @@ -1031,7 +1031,7 @@ tcSynArgA :: CtOrigin tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside = do { (match_wrapper, arg_tys, res_ty) <- matchActualFunTys herald orig (length arg_shapes) sigma_ty - -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) + -- match_wrapper :: sigma_ty ~~> (arg_tys -> res_ty) ; ((result, res_wrapper), arg_wrappers) <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults -> tc_syn_arg res_ty res_shape $ \ res_results -> @@ -1061,12 +1061,12 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside ; return (result, idHsWrapper) } tc_syn_arg res_ty SynRho thing_inside = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty + -- inst_wrap :: res_ty ~~> rho_ty ; result <- thing_inside [rho_ty] ; return (result, inst_wrap) } tc_syn_arg res_ty SynList thing_inside = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty + -- inst_wrap :: res_ty ~~> rho_ty ; (list_co, elt_ty) <- matchExpectedListTy rho_ty -- list_co :: [elt_ty] ~N rho_ty ; result <- thing_inside [elt_ty] ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -329,7 +329,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind | Just bndr_id <- sig_fn bndr_name -- There is a signature - = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id) + = do { wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing exp_pat_ty) (idType bndr_id) -- See Note [Subsumption check at pattern variables] ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) ; return (wrap, bndr_id) } @@ -376,10 +376,12 @@ newLetBndr LetLclBndr name w ty newLetBndr (LetGblBndr prags) name w ty = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name) -tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt --- Used during typechecking patterns -tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2 +-- | A version of 'tcSubTypePat' specialised to 'GenSigCtxt'. +-- +-- Used during typechecking of patterns. +tcSubTypePat_GenSigCtxt :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +tcSubTypePat_GenSigCtxt penv t1 t2 = + tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2 {- Note [Subsumption check at pattern variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -618,111 +620,123 @@ tc_pat :: Scaled ExpSigmaTypeFRR -> Checker (Pat GhcRn) (Pat GhcTc) -- ^ Translated pattern -tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of - - VarPat x (L l name) -> do - { (wrap, id) <- tcPatBndr penv name pat_ty - ; res <- tcCheckUsage name (scaledMult pat_ty) $ - tcExtendIdEnv1 name id thing_inside - ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } - - ParPat x pat -> do - { (pat', res) <- tc_lpat pat_ty penv pat thing_inside - ; return (ParPat x pat', res) } - - BangPat x pat -> do - { (pat', res) <- tc_lpat pat_ty penv pat thing_inside - ; return (BangPat x pat', res) } - - OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1) - { let pats_list = NE.toList pats - ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside) - ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness - ; emitConstraints pat_ct - -- captureConstraints/extendConstraints: - -- like in Note [Hopping the LIE in lazy patterns] - ; pat_ty <- expTypeToType (scaledThing pat_ty) - ; return (OrPat pat_ty pats', res) } - - LazyPat x pat -> do - { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty - ; (pat', (res, pat_ct)) - <- tc_lpat pat_ty (makeLazy penv) pat $ - captureConstraints thing_inside - -- Ignore refined penv', revert to penv - - ; emitConstraints pat_ct - -- captureConstraints/extendConstraints: - -- see Note [Hopping the LIE in lazy patterns] - - -- Check that the expected pattern type is itself lifted - ; pat_ty <- readExpType (scaledThing pat_ty) - ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind - - ; return ((LazyPat x pat'), res) } - - WildPat _ -> do - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty - ; res <- thing_inside - ; pat_ty <- expTypeToType (scaledThing pat_ty) - ; return (WildPat pat_ty, res) } - - AsPat x (L nm_loc name) pat -> do - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty - ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty) - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) - penv pat thing_inside - -- NB: if we do inference on: - -- \ (y@(x::forall a. a->a)) = e - -- we'll fail. The as-pattern infers a monotype for 'y', which then - -- fails to unify with the polymorphic type for 'x'. This could - -- perhaps be fixed, but only with a bit more work. - -- - -- If you fix it, don't forget the bindInstsOfPatIds! - ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } - - ViewPat _ expr pat -> do - { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty - -- - -- It should be possible to have view patterns at linear (or otherwise - -- non-Many) multiplicity. But it is not clear at the moment what - -- restriction need to be put in place, if any, for linear view - -- patterns to desugar to type-correct Core. - - ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr - -- IIF_ShallowRho: do not perform deep instantiation, regardless of - -- DeepSubsumption (Note [View patterns and polymorphism]) - -- But we must do top-instantiation to expose the arrow to matchActualFunTy - - -- Expression must be a function - ; let herald = ExpectedFunTyViewPat $ unLoc expr - ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma) - <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho - -- See Note [View patterns and polymorphism] - -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma) - - -- Check that overall pattern is more polymorphic than arg type - ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty - -- expr_wrap2 :: pat_ty "->" inf_arg_ty - - -- Pattern must have inf_res_sigma - ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside - - ; let Scaled w h_pat_ty = pat_ty - ; pat_ty <- readExpType h_pat_ty - ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - (Scaled w pat_ty) inf_res_sigma - -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" - -- (pat_ty -> inf_res_sigma) - -- NB: pat_ty comes from matchActualFunTy, so it has a - -- fixed RuntimeRep, as needed to call mkWpFun. - - expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1 - - ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) } +tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside = + + case ps_pat of + + VarPat x (L l name) -> do + { (wrap, id) <- tcPatBndr penv name scaled_exp_pat_ty + ; res <- tcCheckUsage name w_pat $ tcExtendIdEnv1 name id thing_inside + ; pat_ty <- readExpType exp_pat_ty + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } + + ParPat x pat -> do + { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside + ; return (ParPat x pat', res) } + + BangPat x pat -> do + { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside + ; return (BangPat x pat', res) } + + OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1) + { let pats_list = NE.toList pats + pat_exp_tys = map (const scaled_exp_pat_ty) pats_list + ; (pats_list', (res, pat_ct)) <- tc_lpats pat_exp_tys penv pats_list (captureConstraints thing_inside) + ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness + ; emitConstraints pat_ct + -- captureConstraints/extendConstraints: + -- like in Note [Hopping the LIE in lazy patterns] + ; pat_ty <- expTypeToType exp_pat_ty + ; return (OrPat pat_ty pats', res) } + + LazyPat x pat -> do + { checkManyPattern LazyPatternReason (noLocA ps_pat) scaled_exp_pat_ty + ; (pat', (res, pat_ct)) + <- tc_lpat scaled_exp_pat_ty (makeLazy penv) pat $ + captureConstraints thing_inside + -- Ignore refined penv', revert to penv + + ; emitConstraints pat_ct + -- captureConstraints/extendConstraints: + -- see Note [Hopping the LIE in lazy patterns] + + -- Check that the expected pattern type is itself lifted + ; pat_ty <- readExpType exp_pat_ty + ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind + + ; return ((LazyPat x pat'), res) } + + WildPat _ -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty + ; res <- thing_inside + ; pat_ty <- expTypeToType exp_pat_ty + ; return (WildPat pat_ty, res) } + + AsPat x (L nm_loc name) pat -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty + ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name scaled_exp_pat_ty) + ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ + tc_lpat (Scaled w_pat (mkCheckExpType $ idType bndr_id)) + penv pat thing_inside + -- NB: if we do inference on: + -- \ (y@(x::forall a. a->a)) = e + -- we'll fail. The as-pattern infers a monotype for 'y', which then + -- fails to unify with the polymorphic type for 'x'. This could + -- perhaps be fixed, but only with a bit more work. + -- + -- If you fix it, don't forget the bindInstsOfPatIds! + ; pat_ty <- readExpType exp_pat_ty + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } + + ViewPat _ view_expr inner_pat -> do + + -- The pattern is a view pattern, 'pat = (view_expr -> inner_pat)'. + -- First infer the type of 'view_expr'; the overall type of the pattern + -- is the argument type of 'view_expr', and the inner pattern type is + -- checked against the result type of 'view_expr'. + + { checkManyPattern ViewPatternReason (noLocA ps_pat) scaled_exp_pat_ty + -- It should be possible to have view patterns at linear (or otherwise + -- non-Many) multiplicity. But it is not clear at the moment what + -- restrictions need to be put in place, if any, for linear view + -- patterns to desugar to type-correct Core. + + -- Infer the type of 'view_expr'. + ; (view_expr', view_expr_rho) <- tcInferExpr IIF_ShallowRho view_expr + -- IIF_ShallowRho: do not perform deep instantiation, regardless of + -- DeepSubsumption (Note [View patterns and polymorphism]) + -- But we must do top-instantiation to expose the arrow to matchActualFunTy + + -- 'view_expr' must be a function; expose its argument/result types + -- using 'matchActualFunTy'. + ; let herald = ExpectedFunTyViewPat $ unLoc view_expr + ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty) + <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr) + (1, view_expr_rho) view_expr_rho + -- See Note [View patterns and polymorphism] + -- view_expr_co1 :: view_expr_rho ~~> (view_arg_ty -> view_res_ty) + + -- Check that the overall pattern's type is more polymorphic than + -- the view function argument type. + ; view_expr_wrap2 <- tcSubTypePat_GenSigCtxt penv exp_pat_ty view_arg_ty + -- view_expr_wrap2 :: pat_ty ~~> view_arg_ty + + -- The inner pattern must have type 'view_res_ty'. + ; (inner_pat', res) <- tc_lpat (Scaled w_pat (mkCheckExpType view_res_ty)) penv inner_pat thing_inside + + ; pat_ty <- readExpType exp_pat_ty + ; let view_expr_wrap2' = + mkWpFun view_expr_wrap2 idHsWrapper + (Scaled w_pat pat_ty) view_res_ty + -- view_expr_wrap2' :: (view_arg_ty -> view_res_ty) + -- ~~> (pat_ty -> view_res_ty) + -- This satisfies WpFun-FRR-INVARIANT: + -- 'view_arg_ty' was returned by matchActualFunTy, hence FRR + -- 'pat_ty' was passed in and is an 'ExpSigmaTypeFRR' + + view_expr_wrap = view_expr_wrap2' <.> mkWpCastN view_expr_co1 + + ; return $ (ViewPat pat_ty (mkLHsWrap view_expr_wrap view_expr') inner_pat', res) } {- Note [View patterns and polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -748,93 +762,91 @@ Another example is #26331. -- Type signatures in patterns -- See Note [Pattern coercions] below - SigPat _ pat sig_ty -> do - { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) - sig_ty (scaledThing pat_ty) - -- Using tcExtendNameTyVarEnv is appropriate here - -- because we're not really bringing fresh tyvars into scope. - -- We're *naming* existing tyvars. Note that it is OK for a tyvar - -- from an outer scope to mention one of these tyvars in its kind. - ; (pat', res) <- tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv tv_binds $ - tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside - ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } + SigPat _ pat sig_ty -> do + { (inner_ty, tv_binds, wcs, wrap) <- + tcPatSig (inPatBind penv) sig_ty exp_pat_ty + -- Using tcExtendNameTyVarEnv is appropriate here + -- because we're not really bringing fresh tyvars into scope. + -- We're *naming* existing tyvars. Note that it is OK for a tyvar + -- from an outer scope to mention one of these tyvars in its kind. + ; (pat', res) <- tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv tv_binds $ + tc_lpat (Scaled w_pat $ mkCheckExpType inner_ty) penv pat thing_inside + ; pat_ty <- readExpType exp_pat_ty + ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } ------------------------ -- Lists, tuples, arrays -- Necessarily a built-in list pattern, not an overloaded list pattern. -- See Note [Desugaring overloaded list patterns]. - ListPat _ pats -> do - { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty) - ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) - penv pats thing_inside - ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat coi - (ListPat elt_ty pats') pat_ty, res) } - - TuplePat _ pats boxity -> do - { let arity = length pats - tc = tupleTyCon boxity arity - -- NB: tupleTyCon does not flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - ; checkTupSize arity - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv (scaledThing pat_ty) - -- Unboxed tuples have RuntimeRep vars, which we discard: - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys) + ListPat _ pats -> do + { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv exp_pat_ty + ; (pats', res) <- tcMultiple (tc_lpat (Scaled w_pat $ mkCheckExpType elt_ty)) penv pats thing_inside - - ; dflags <- getDynFlags - - -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) - -- so that we can experiment with lazy tuple-matching. - -- This is a pretty odd place to make the switch, but - -- it was easy to do. - ; let - unmangled_result = TuplePat con_arg_tys pats' boxity - -- pat_ty /= pat_ty iff coi /= IdCo - possibly_mangled_result - | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat noExtField (noLocA unmangled_result) - | otherwise = unmangled_result - - ; pat_ty <- readExpType (scaledThing pat_ty) - ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced - ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) - } - - SumPat _ pat alt arity -> do - { let tc = sumTyCon arity - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv (scaledThing pat_ty) - ; -- Drop levity vars, we don't care about them here - let con_arg_tys = drop arity arg_tys - ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1))) - penv pat thing_inside - ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty - , res) - } + ; pat_ty <- readExpType exp_pat_ty + ; return (mkHsWrapPat coi + (ListPat elt_ty pats') pat_ty, res) } + + TuplePat _ pats boxity -> do + { let arity = length pats + tc = tupleTyCon boxity arity + -- NB: tupleTyCon does not flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; checkTupSize arity + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty + -- Unboxed tuples have RuntimeRep vars, which we discard: + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; (pats', res) <- tc_lpats (map (Scaled w_pat . mkCheckExpType) con_arg_tys) + penv pats thing_inside + + ; dflags <- getDynFlags + + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) + -- so that we can experiment with lazy tuple-matching. + -- This is a pretty odd place to make the switch, but + -- it was easy to do. + ; let + unmangled_result = TuplePat con_arg_tys pats' boxity + -- pat_ty /= pat_ty iff coi /= IdCo + possibly_mangled_result + | gopt Opt_IrrefutableTuples dflags && + isBoxed boxity = LazyPat noExtField (noLocA unmangled_result) + | otherwise = unmangled_result + + ; pat_ty <- readExpType exp_pat_ty + ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced + ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) + } + + SumPat _ pat alt arity -> do + { let tc = sumTyCon arity + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty + ; -- Drop levity vars, we don't care about them here + let con_arg_tys = drop arity arg_tys + ; (pat', res) <- tc_lpat (Scaled w_pat $ mkCheckExpType (con_arg_tys `getNth` (alt - 1))) + penv pat thing_inside + ; pat_ty <- readExpType exp_pat_ty + ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty + , res) + } ------------------------ -- Data constructors - ConPat _ con arg_pats -> - tcConPat penv con pat_ty arg_pats thing_inside + ConPat _ con arg_pats -> + tcConPat penv con scaled_exp_pat_ty arg_pats thing_inside ------------------------ -- Literal patterns - LitPat x simple_lit -> do - { let lit_ty = hsLitType simple_lit - ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty - ; res <- thing_inside - ; pat_ty <- readExpType (scaledThing pat_ty) - ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty - , res) } + LitPat x simple_lit -> do + { let lit_ty = hsLitType simple_lit + ; wrap <- tcSubTypePat_GenSigCtxt penv exp_pat_ty lit_ty + ; res <- thing_inside + ; pat_ty <- readExpType exp_pat_ty + ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty + , res) } ------------------------ -- Overloaded patterns: n, and n+k @@ -854,31 +866,31 @@ Another example is #26331. -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same - NPat _ (L l over_lit) mb_neg eq -> do - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty - -- It may be possible to refine linear pattern so that they work in - -- linear environments. But it is not clear how useful this is. - ; let orig = LiteralOrigin over_lit - ; ((lit', mb_neg'), eq') - <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny] - (mkCheckExpType boolTy) $ - \ [neg_lit_ty] _ -> - let new_over_lit lit_ty = newOverloadedLit over_lit - (mkCheckExpType lit_ty) - in case mb_neg of - Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty - Just neg -> -- Negative literal - -- The 'negate' is re-mappable syntax - second Just <$> - (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ - \ [lit_ty] _ -> new_over_lit lit_ty) - -- applied to a closed literal: linearity doesn't matter as - -- literals are typed in an empty environment, hence have - -- all multiplicities. - - ; res <- thing_inside - ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } + NPat _ (L l over_lit) mb_neg eq -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty + -- It may be possible to refine linear pattern so that they work in + -- linear environments. But it is not clear how useful this is. + ; let orig = LiteralOrigin over_lit + ; ((lit', mb_neg'), eq') + <- tcSyntaxOp orig eq [SynType exp_pat_ty, SynAny] + (mkCheckExpType boolTy) $ + \ [neg_lit_ty] _ -> + let new_over_lit lit_ty = newOverloadedLit over_lit + (mkCheckExpType lit_ty) + in case mb_neg of + Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + second Just <$> + (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ + \ [lit_ty] _ -> new_over_lit lit_ty) + -- applied to a closed literal: linearity doesn't matter as + -- literals are typed in an empty environment, hence have + -- all multiplicities. + + ; res <- thing_inside + ; pat_ty <- readExpType exp_pat_ty + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -904,68 +916,67 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] - NPlusKPat _ (L nm_loc name) - (L loc lit) _ ge minus -> do - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty - ; let pat_exp_ty = scaledThing pat_ty - orig = LiteralOrigin lit - ; (lit1', ge') - <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho] - (mkCheckExpType boolTy) $ - \ [lit1_ty] _ -> - newOverloadedLit lit (mkCheckExpType lit1_ty) - ; ((lit2', minus_wrap, bndr_id), minus') - <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $ - \ [lit2_ty, var_ty] _ -> - do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) - ; (wrap, bndr_id) <- setSrcSpanA nm_loc $ - tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) - -- co :: var_ty ~ idType bndr_id - - -- minus_wrap is applicable to minus' - ; return (lit2', wrap, bndr_id) } - - ; pat_ty <- readExpType pat_exp_ty - - -- The Report says that n+k patterns must be in Integral - -- but it's silly to insist on this in the RebindableSyntax case - ; unlessM (xoptM LangExt.RebindableSyntax) $ - do { icls <- tcLookupClass integralClassName - ; instStupidTheta orig [mkClassPred icls [pat_ty]] } - - ; res <- tcExtendIdEnv1 name bndr_id thing_inside - - ; let minus'' = case minus' of - NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') - -- this should be statically avoidable - -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr" - SyntaxExprTc { syn_expr = minus'_expr - , syn_arg_wraps = minus'_arg_wraps - , syn_res_wrap = minus'_res_wrap } - -> SyntaxExprTc { syn_expr = minus'_expr - , syn_arg_wraps = minus'_arg_wraps - , syn_res_wrap = minus_wrap <.> minus'_res_wrap } - -- Oy. This should really be a record update, but - -- we get warnings if we try. #17783 - pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' - ge' minus'' - ; return (pat', res) } + NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty + ; let orig = LiteralOrigin lit + ; (lit1', ge') + <- tcSyntaxOp orig ge [SynType exp_pat_ty, SynRho] + (mkCheckExpType boolTy) $ + \ [lit1_ty] _ -> + newOverloadedLit lit (mkCheckExpType lit1_ty) + ; ((lit2', minus_wrap, bndr_id), minus') + <- tcSyntaxOpGen orig minus [SynType exp_pat_ty, SynRho] SynAny $ + \ [lit2_ty, var_ty] _ -> + do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) + ; (wrap, bndr_id) <- setSrcSpanA nm_loc $ + tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) + -- co :: var_ty ~ idType bndr_id + + -- minus_wrap is applicable to minus' + ; return (lit2', wrap, bndr_id) } + + ; pat_ty <- readExpType exp_pat_ty + + -- The Report says that n+k patterns must be in Integral + -- but it's silly to insist on this in the RebindableSyntax case + ; unlessM (xoptM LangExt.RebindableSyntax) $ + do { icls <- tcLookupClass integralClassName + ; instStupidTheta orig [mkClassPred icls [pat_ty]] } + + ; res <- tcExtendIdEnv1 name bndr_id thing_inside + + ; let minus'' = case minus' of + NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') + -- this should be statically avoidable + -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr" + SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus'_res_wrap } + -> SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus_wrap <.> minus'_res_wrap } + -- Oy. This should really be a record update, but + -- we get warnings if we try. #17783 + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' + ; return (pat', res) } -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. - SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do + SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do { addModFinalizersWithLclEnv mod_finalizers - ; tc_pat pat_ty penv pat thing_inside } + ; tc_pat scaled_exp_pat_ty penv pat thing_inside } - SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat" + SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat" - EmbTyPat _ _ -> failWith TcRnIllegalTypePattern + EmbTyPat _ _ -> failWith TcRnIllegalTypePattern - InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern" + InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern" - XPat (HsPatExpanded lpat rpat) -> do - { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside - ; return (XPat $ ExpansionPat lpat rpat', res) } + XPat (HsPatExpanded lpat rpat) -> do + { (rpat', res) <- tc_pat scaled_exp_pat_ty penv rpat thing_inside + ; return (XPat $ ExpansionPat lpat rpat', res) } {- Note [Hopping the LIE in lazy patterns] @@ -1295,7 +1306,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats - ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' + ; wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing pat_ty) ty' ; traceTc "tcPatSynPat" $ vcat [ text "Pat syn:" <+> ppr pat_syn @@ -1405,8 +1416,9 @@ matchExpectedConTy :: PatEnv -- In the case of a data family, this would -- mention the /family/ TyCon -> TcM (HsWrapper, [TcSigmaType]) --- See Note [Matching constructor patterns] --- Returns a wrapper : pat_ty "->" T ty1 ... tyn +-- ^ See Note [Matching constructor patterns] +-- +-- Returns a wrapper : pat_ty ~~> T ty1 ... tyn matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc -- Comments refer to Note [Matching constructor patterns] ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -263,7 +263,9 @@ in two places: * In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any existing [G] (?x :: ty'), regardless of ty'. -* Wrinkle (SIP1): we must be careful of superclasses. Consider +There are wrinkles: + +* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider f,g :: (?x::Int, C a) => a -> a f v = let ?x = 4 in g v @@ -271,24 +273,31 @@ in two places: We must /not/ solve this from the Given (?x::Int, C a), because of the intervening binding for (?x::Int). #14218. - We deal with this by arranging that when we add [G] (?x::ty) we delete + We deal with this by arranging that when we add [G] (?x::ty) we /delete/ * from the inert_cans, and * from the inert_solved_dicts any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate. - An important special case is constraint tuples like [G] (% ?x::ty, Eq a %). - But it could happen for `class xx => D xx where ...` and the constraint D - (?x :: int). This corner (constraint-kinded variables instantiated with - implicit parameter constraints) is not well explored. + An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %). + + But it could also happen for `class xx => D xx where ...` and the constraint + D (?x :: int); again see Note [Local implicit parameters]. This corner + (constraint-kinded variables instantiated with implicit parameter constraints) + is not well explored. - Example in #14218, and #23761 + You might worry about whether deleting an /entire/ constraint just because + a distant superclass has an implicit parameter might make another Wanted for + that constraint un-solvable. Indeed so. But for constraint tuples it doesn't + matter -- their entire payload is their superclasses. And the other case is + the ill-explored corner above. The code that accounts for (SIP1) is in updInertDicts; in particular the call to GHC.Core.Predicate.mentionsIP. * Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts` - as well as `inert_cans`. + as well as `inert_cans` (#23761). + You might think that wouldn't be necessary, because an element of `inert_solved_dicts` is never an implicit parameter (see Note [Solved dictionaries] in GHC.Tc.Solver.InertSet). @@ -301,6 +310,19 @@ in two places: Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`. +* Wrinkle (SIP3) + - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete + existing /Givens/! Deleting an existing Wanted led to #26451; we just never + solved it! + + - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like + Givens; they may be "inherited" from outer scopes, so we must delete any + solved dictionaries for this implicit parameter for /both/ Givens /and/ + Wanteds. + + Otherwise the new Given doesn't properly shadow those inherited solved + dictionaries. Test T23761 showed this up. + Example 1: Suppose we have (typecheck/should_compile/ImplicitParamFDs) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict. -} updInertDicts :: DictCt -> TcS () -updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) - = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) - - ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys - -> -- For [G] ?x::ty, remove any dicts mentioning ?x, - -- from /both/ inert_cans /and/ inert_solved_dicts (#23761) - -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] - updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> - inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics - , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved } - | otherwise - -> return () +updInertDicts dict_ct + = do { traceTcS "Adding inert dict" (ppr dict_ct) + + -- For Given implicit parameters (only), delete any existing + -- Givens for the same implicit parameter. + -- See Note [Shadowing of implicit parameters] + ; deleteGivenIPs dict_ct + -- Add the new constraint to the inert set ; updInertCans (updDicts (addDict dict_ct)) } + +deleteGivenIPs :: DictCt -> TcS () +-- Special magic when adding a Given implicit parameter to the inert set +-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x, +-- from /both/ inert_cans /and/ inert_solved_dicts (#23761) +-- See Note [Shadowing of implicit parameters] +deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) + | isGiven ev + , Just (str_ty, _) <- isIPPred_maybe cls tys + = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> + inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics + , inert_solved_dicts = filterDicts (keep_solved str_ty) solved } + | otherwise + = return () where - -- Does this class constraint or any of its superclasses mention - -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'? - does_not_mention_ip_for :: Type -> DictCt -> Bool - does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) - = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys - -- See Note [Using typesAreApart when calling mightMentionIP] - -- in GHC.Core.Predicate + keep_can, keep_solved :: Type -> DictCt -> Bool + -- keep_can: we keep an inert dictionary UNLESS + -- (1) it is a Given + -- (2) it binds an implicit parameter (?str :: ty) for the given 'str' + -- regardless of 'ty', possibly via its superclasses + -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart` + -- See Note [Using typesAreApart when calling mightMentionIP] + -- in GHC.Core.Predicate + -- + -- keep_solved: same as keep_can, but for /all/ constraints not just Givens + -- + -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters] + keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) + = not (isGiven ev -- (1) + && mentions_ip str cls tys) -- (2) + keep_solved str (DictCt { di_cls = cls, di_tys = tys }) + = not (mentions_ip str cls tys) + + -- mentions_ip: the inert constraint might provide evidence + -- for an implicit parameter (?str :: ty) for the given 'str' + mentions_ip str cls tys + = mightMentionIP (not . typesAreApart str) (const True) cls tys updInertIrreds :: IrredCt -> TcS () updInertIrreds irred ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -197,29 +197,29 @@ that it is a no-op. Here's our solution: * we /must/ optimise subtype-HsWrappers (that's the point of this Note!) * there is little point in attempting to optimise any other HsWrappers -Note [WpFun-RR-INVARIANT] -~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [WpFun-FRR-INVARIANT] +~~~~~~~~~~~~~~~~~~~~~~~~~~ Given wrap = WpFun wrap1 wrap2 sty1 ty2 where: wrap1 :: exp_arg ~~> act_arg wrap2 :: act_res ~~> exp_res wrap :: (act_arg -> act_res) ~~> (exp_arg -> exp_res) we have - WpFun-RR-INVARIANT: + WpFun-FRR-INVARIANT: the input (exp_arg) and output (act_arg) types of `wrap1` both have a fixed runtime-rep Reason: We desugar wrap[e] into \(x:exp_arg). wrap2[ e wrap1[x] ] -And then, because of Note [Representation polymorphism invariants], we need: +And then, because of Note [Representation polymorphism invariants]: * `exp_arg` must have a fixed runtime rep, so that lambda obeys the the FRR rules * `act_arg` must have a fixed runtime rep, - so the that application (e wrap1[x]) obeys the FRR tules + so that the application (e wrap1[x]) obeys the FRR rules -Hence WpFun-INVARIANT. +Hence WpFun-FRR-INVARIANT. -} data HsWrapper @@ -246,7 +246,7 @@ data HsWrapper -- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ] -- -- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep - -- See Note [WpFun-RR-INVARIANT] + -- See Note [WpFun-FRR-INVARIANT] -- -- Typing rules: -- If e :: act_arg -> act_res @@ -319,7 +319,7 @@ mkWpFun :: HsWrapper -> HsWrapper -- ^ Smart constructor for `WpFun` -- Just removes clutter and optimises some common cases. -- --- PRECONDITION: same as Note [WpFun-RR-INVARIANT] +-- PRECONDITION: same as Note [WpFun-FRR-INVARIANT] -- -- Unfortunately, we can't check PRECONDITION with an assertion here, because of -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -277,7 +277,7 @@ skolemiseRequired skolem_info n_req sigma topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -- Instantiate outer invisible binders (both Inferred and Specified) -- If top_instantiate ty = (wrap, inner_ty) --- then wrap :: inner_ty "->" ty +-- then wrap :: inner_ty ~~> ty -- NB: returns a type with no (=>), -- and no invisible forall at the top topInstantiate orig sigma ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -66,7 +66,6 @@ module GHC.Tc.Utils.Unify ( import GHC.Prelude import GHC.Hs - import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) ) import GHC.Tc.Errors.Ppr ( pprErrCtxtMsg ) import GHC.Tc.Utils.Concrete @@ -256,24 +255,24 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected -- and res_ty is a RhoType -- NB: the returned type is top-instantiated; it's a RhoType matchActualFunTys herald ct_orig n_val_args_wanted top_ty - = go n_val_args_wanted [] top_ty + = go n_val_args_wanted top_ty where - go n so_far fun_ty + go n fun_ty | not (isRhoTy fun_ty) = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty - ; (wrap2, arg_tys, res_ty) <- go n so_far rho + ; (wrap2, arg_tys, res_ty) <- go n rho ; return (wrap2 <.> wrap1, arg_tys, res_ty) } - go 0 _ fun_ty = return (idHsWrapper, [], fun_ty) + go 0 fun_ty = return (idHsWrapper, [], fun_ty) - go n so_far fun_ty - = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing - (n_val_args_wanted, top_ty) fun_ty - ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 - ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty - -- NB: arg_ty1 comes from matchActualFunTy, so it has - -- a syntactically fixed RuntimeRep - ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) } + go n fun_ty + = do { (co1, arg1_ty_frr, res_ty1) <- + matchActualFunTy herald Nothing (n_val_args_wanted, top_ty) fun_ty + ; (wrap_res, arg_tys, res_ty) <- go (n-1) res_ty1 + ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg1_ty_frr res_ty + -- This call to mkWpFun satisfies WpFun-FRR-INVARIANT: + -- 'arg1_ty_frr' comes from matchActualFunTy, so is FRR. + ; return (wrap_fun2 <.> mkWpCastN co1, arg1_ty_frr:arg_tys, res_ty) } {- ************************************************************************ @@ -866,12 +865,30 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside = assert (isVisibleFunArg af) $ do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty - ; let arg_sty_frr = Scaled mult arg_ty_frr - ; (wrap_res, result) <- check (n_req - 1) - (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys) + ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr + ; (res_wrap, result) <- check (n_req - 1) + (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys) res_ty - ; let wrap_arg = mkWpCastN arg_co - fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty + + -- arg_co :: arg_ty ~ arg_ty_frr + -- res_wrap :: act_res_ty ~~> res_ty + ; let fun_wrap1 -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty_frr -> res_ty) + = mkWpFun idHsWrapper res_wrap scaled_arg_ty_frr res_ty + -- Satisfies WpFun-FRR-INVARIANT because arg_sty_frr is FRR + + fun_wrap2 -- :: (arg_ty_frr -> res_ty) ~~> (arg_ty -> res_ty) + = mkWpCastN (mkFunCo Nominal af (mkNomReflCo mult) (mkSymCo arg_co) (mkNomReflCo res_ty)) + + fun_wrap -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty -> res_ty) + = fun_wrap2 <.> fun_wrap1 + +-- NB: in the common case, 'arg_ty' is already FRR (in the sense of +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete), hence 'arg_co' is 'Refl'. +-- Then 'fun_wrap' will collapse down to 'fun_wrap1'. This applies recursively; +-- as 'mkWpFun WpHole WpHole' is 'WpHole', this means that 'fun_wrap' will +-- typically just be 'WpHole'; no clutter. +-- This is important because 'matchExpectedFunTys' is called a lot. + ; return (fun_wrap, result) } ---------------------------- @@ -1404,7 +1421,7 @@ tcSubTypeMono rn_expr act_ty exp_ty ------------------------ tcSubTypePat :: CtOrigin -> UserTypeCtxt - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper + -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper -- Used in patterns; polarity is backwards compared -- to tcSubType -- If wrap = tc_sub_type_et t1 t2 ===================================== compiler/GHC/Unit/Home/ModInfo.hs ===================================== @@ -3,13 +3,10 @@ module GHC.Unit.Home.ModInfo ( HomeModInfo (..) - , HomeModLinkable(..) + , HomeModLinkable (..) , homeModInfoObject , homeModInfoByteCode , emptyHomeModInfoLinkable - , justBytecode - , justObjects - , bytecodeAndObjects ) where @@ -18,11 +15,9 @@ import GHC.Prelude import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails -import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly ) +import GHC.Linker.Types ( Linkable ) import GHC.Utils.Outputable -import GHC.Utils.Panic - -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo @@ -68,22 +63,6 @@ data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable) instance Outputable HomeModLinkable where ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2 -justBytecode :: Linkable -> HomeModLinkable -justBytecode lm = - assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) - $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm } - -justObjects :: Linkable -> HomeModLinkable -justObjects lm = - assertPpr (linkableIsNativeCodeOnly lm) (ppr lm) - $ emptyHomeModInfoLinkable { homeMod_object = Just lm } - -bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable -bytecodeAndObjects bc o = - assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) - (HomeModLinkable (Just bc) (Just o)) - - {- Note [Home module build products] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Unit/Module/Status.hs ===================================== @@ -1,22 +1,35 @@ +{-# LANGUAGE LambdaCase #-} + module GHC.Unit.Module.Status - ( HscBackendAction(..), HscRecompStatus (..) + ( HscBackendAction(..) + , HscRecompStatus (..) + , RecompLinkables (..) + , RecompBytecodeLinkable (..) + , emptyRecompLinkables + , justBytecode + , justObjects + , bytecodeAndObjects + , safeCastHomeModLinkable ) where import GHC.Prelude import GHC.Unit +import GHC.Unit.Home.ModInfo import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface +import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly ) + import GHC.Utils.Fingerprint import GHC.Utils.Outputable -import GHC.Unit.Home.ModInfo +import GHC.Utils.Panic -- | Status of a module in incremental compilation data HscRecompStatus -- | Nothing to do because code already exists. - = HscUpToDate ModIface HomeModLinkable + = HscUpToDate ModIface RecompLinkables -- | Recompilation of module, or update of interface is required. Optionally -- pass the old interface hash to avoid updating the existing interface when -- it has not changed. @@ -41,6 +54,16 @@ data HscBackendAction -- changed. } +-- | Linkables produced by @hscRecompStatus@. Might contain serialized core +-- which can be turned into BCOs (or object files), or used by some other +-- backend. See Note [Interface Files with Core Definitions]. +data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompBytecodeLinkable + , recompLinkables_object :: !(Maybe Linkable) } + +data RecompBytecodeLinkable + = NormalLinkable !(Maybe Linkable) + | WholeCoreBindingsLinkable !WholeCoreBindingsLinkable + instance Outputable HscRecompStatus where ppr HscUpToDate{} = text "HscUpToDate" ppr HscRecompNeeded{} = text "HscRecompNeeded" @@ -48,3 +71,37 @@ instance Outputable HscRecompStatus where instance Outputable HscBackendAction where ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi)) ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml + +instance Outputable RecompLinkables where + ppr (RecompLinkables l1 l2) = ppr l1 $$ ppr l2 + +instance Outputable RecompBytecodeLinkable where + ppr (NormalLinkable lm) = text "NormalLinkable:" <+> ppr lm + ppr (WholeCoreBindingsLinkable lm) = text "WholeCoreBindingsLinkable:" <+> ppr lm + +emptyRecompLinkables :: RecompLinkables +emptyRecompLinkables = RecompLinkables (NormalLinkable Nothing) Nothing + +safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables +safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable bc) o + +justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables +justBytecode = \case + Left lm -> + assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) + $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) } + Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm } + +justObjects :: Linkable -> RecompLinkables +justObjects lm = + assertPpr (linkableIsNativeCodeOnly lm) (ppr lm) + $ emptyRecompLinkables { recompLinkables_object = Just lm } + +bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables +bytecodeAndObjects either_bc o = case either_bc of + Left bc -> + assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) + $ RecompLinkables (NormalLinkable (Just bc)) (Just o) + Right bc -> + assertPpr (linkableIsNativeCodeOnly o) (ppr o) + $ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o) ===================================== compiler/GHC/Unit/Module/WholeCoreBindings.hs ===================================== @@ -130,6 +130,9 @@ data WholeCoreBindings = WholeCoreBindings , wcb_foreign :: IfaceForeign } +instance Outputable WholeCoreBindings where + ppr (WholeCoreBindings {}) = text "WholeCoreBindings" + {- Note [Foreign stubs and TH bytecode linking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/tests/all.T ===================================== @@ -80,7 +80,7 @@ test('length001', # excessive amounts of stack space. So we specifically set a low # stack limit and mark it as failing under a few conditions. [extra_run_opts('+RTS -K8m -RTS'), - expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']), + expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc', 'ext-interp']), # JS doesn't support stack limit so the test sometimes passes just fine. Therefore the test is # marked as fragile. when(js_arch(), fragile(22921))], ===================================== testsuite/driver/testlib.py ===================================== @@ -352,6 +352,9 @@ def req_plugins( name, opts ): """ req_interp(name, opts) + # Plugins aren't supported with the external interpreter (#14335) + expect_broken_for(14335,['ext-interp'])(name,opts) + if config.cross: opts.skip = True ===================================== testsuite/tests/driver/T20696/all.T ===================================== @@ -1,4 +1,5 @@ test('T20696', [extra_files(['A.hs', 'B.hs', 'C.hs']) + , expect_broken_for(26552, ['ext-interp']) , unless(ghc_dynamic(), skip)], multimod_compile, ['A', '']) test('T20696-static', [extra_files(['A.hs', 'B.hs', 'C.hs']) , when(ghc_dynamic(), skip)], multimod_compile, ['A', '']) ===================================== testsuite/tests/driver/fat-iface/all.T ===================================== @@ -9,12 +9,12 @@ test('fat010', [req_th,extra_files(['THA.hs', 'THB.hs', 'THC.hs']), copy_files], # Check linking works when using -fbyte-code-and-object-code test('fat011', [req_th, extra_files(['FatMain.hs', 'FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatMain', '-fbyte-code-and-object-code -fprefer-byte-code']) # Check that we use interpreter rather than enable dynamic-too if needed for TH -test('fat012', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code']) +test('fat012', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code']) # Check that no objects are generated if using -fno-code and -fprefer-byte-code test('fat013', [req_th, req_bco, extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fno-code -fprefer-byte-code']) # When using interpreter should not produce objects test('fat014', [req_th, extra_files(['FatTH.hs', 'FatQuote.hs']), extra_run_opts('-fno-code')], ghci_script, ['fat014.script']) -test('fat015', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface']) +test('fat015', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface']) test('T22807', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807A.hs', 'T22807B.hs'])] , makefile_test, ['T22807']) test('T22807_ghci', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807_ghci.hs'])] ===================================== testsuite/tests/rep-poly/T26528.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE GHC2024, TypeFamilies #-} + +module T26528 where + +import Data.Kind +import GHC.Exts + +type F :: Type -> RuntimeRep +type family F a where + F Int = LiftedRep + +g :: forall (r::RuntimeRep). + (forall (a :: TYPE r). a -> forall b. b -> b) -> Int +g _ = 3 +{-# NOINLINE g #-} + +foo = g @(F Int) (\x y -> y) ===================================== testsuite/tests/rep-poly/all.T ===================================== @@ -42,6 +42,7 @@ test('T23883b', normal, compile_fail, ['']) test('T23883c', normal, compile_fail, ['']) test('T23903', normal, compile_fail, ['']) test('T26107', js_broken(22364), compile, ['-O']) +test('T26528', normal, compile, ['']) test('EtaExpandDataCon', normal, compile, ['-O']) test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags']) ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -9,7 +9,7 @@ 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']) test('SI06', [extra_files(["SI01A.hs"])], multimod_compile, ['SI06', '-v0']) -test('SI07', [unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code']) +test('SI07', [expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code']) # Instance tests test('SI08', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile_fail, ['SI08', '-v0']) test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI09', '-v0']) ===================================== testsuite/tests/typecheck/should_compile/T26451.hs ===================================== @@ -0,0 +1,34 @@ +{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-} + +module T26451 where + +type family F a +type instance F Bool = [Char] + +class C a b | b -> a +instance C Bool Bool +instance C Char Char + +eq :: forall a b. C a b => a -> b -> () +eq p q = () + +g :: a -> F a +g = g + +f (x::tx) (y::ty) -- x :: alpha y :: beta + = let ?v = g x -- ?ip :: F alpha + in (?v::[ty], eq x True) + + +{- tx, and ty are unification variables + +Inert: [G] dg :: IP "v" (F tx) + [W] dw :: IP "v" [ty] +Work-list: [W] dc1 :: C tx Bool + [W] dc2 :: C ty Char + +* Solve dc1, we get tx := Bool from fundep +* Kick out dg +* Solve dg to get [G] dc : IP "v" [Char] +* Add that new dg to the inert set: that simply deletes dw!!! +-} ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -955,3 +955,4 @@ test('T26376', normal, compile, ['']) test('T26457', normal, compile, ['']) test('T17705', normal, compile, ['']) test('T14745', normal, compile, ['']) +test('T26451', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9d258d32e9b8e3adfb9079dde931ed... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9d258d32e9b8e3adfb9079dde931ed... You're receiving this email because of your account on gitlab.haskell.org.