diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2022-06-02 14:42:08 +0200 |
|---|---|---|
| committer | sheaf <sam.derbyshire@gmail.com> | 2022-06-02 14:42:08 +0200 |
| commit | 30da74aa9c0cc6537c30581f30b8cc52d95c1c61 (patch) | |
| tree | 275a32008985627e79ce7d69f7e8aa0200de857a | |
| parent | 24b5bb61c33b2675bdfb09504aeec88e70ac3abf (diff) | |
| download | haskell-wip/datacon-eta.tar.gz | |
Eta-expand remaining ValArgs in rebuildHsAppswip/datacon-eta
This patch expands the scope of hasFixedRuntimeRep_remainingValArgs:
instead of simply checking that eta-expansion is possible, actually
perform the eta-expansion then and there.
Changes:
1. hasFixedRuntimeRep_remainingValArgs renamed to tcRemainingValArgs.
2. tcRemainingValArgs is now called at the end of tcApp within
rebuildHsApps; this fills a hole as the logic in the implementation
of quick-look impredicativity (in quickLookArg1/tcEValArg) mirrors
in some important aspects the implementation in tcApp.
3. tcRemainingValArgs now performs eta-expansion (instead of only
checking whether eta expansion is possible). In particular, it
eta-expands data constructors up to their arity, allowing us to
remove the problematic implementation of dsConLike which introduced
representation-polymorphic lambdas.
Consequences:
A. rebuildHsApps is now monadic, as necessitated by (2)+(3)
B. Introduce WpHsLet, a wrapper that creates a let binding.
This is because we might need to let-bind existing value
arguments when eta-expanding, to avoid loss of sharing.
We rename the existing WpLet to WpEvLet, being more specific
about its nature.
Some Data and Outputable instances had to be moved to avoid
recursive imports now HsWrapper, through WpHsLet, mentions HsExpr.
C. We drop stupid-theta dictionaries in the wrapper for the data
constructor, which is the only other sensible place for this logic
to go now that we got rid of dsConLike.
For the moment, the FixedRuntimeRep check in tcRemainingValArgs
is kept as a syntactic check, as a full on PHASE 2 check doesn't jibe
well with the rest of the compiler, which doesn't look at application
chains in a single go.
Fixes #21346.
35 files changed, 721 insertions, 517 deletions
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 064cdc866f..7e18b471f3 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -250,6 +250,8 @@ in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep. * Type variables may be permuted; see MkId Note [Data con wrappers and GADT syntax] +* Datatype contexts require dropping some dictionary arguments. + See Note [Instantiating stupid theta]. Note [The stupid context] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1449,9 +1451,9 @@ dataConWrapperType :: DataCon -> Type -- mentions the family tycon, not the internal one. dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) + dcOrigResTy = res_ty, dcStupidTheta = stupid }) = mkInvisForAllTys user_tvbs $ - mkInvisFunTysMany theta $ + mkInvisFunTysMany (stupid ++ theta) $ mkVisFunTys arg_tys $ res_ty diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 0511a4004d..b336bdef09 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -922,7 +922,7 @@ lintCoreExpr (Lit lit) = return (literalType lit, zeroUE) lintCoreExpr (Cast expr co) - = do (expr_ty, ue) <- markAllJoinsBad $ lintCoreExpr expr + = do (expr_ty, ue) <- markAllJoinsBad $ lintCoreExpr expr to_ty <- lintCastExpr expr expr_ty co return (to_ty, ue) @@ -1216,7 +1216,7 @@ checkCanEtaExpand (Var fun_id) args app_ty = ty : go (i+1) bndrs bad_arg_tys :: [Type] - bad_arg_tys = check_args . map fst $ getRuntimeArgTys app_ty + bad_arg_tys = check_args . map (scaledThing . fst) $ getRuntimeArgTys app_ty -- We use 'getRuntimeArgTys' to find all the argument types, -- including those hidden under newtypes. For example, -- if `FunNT a b` is a newtype around `a -> b`, then diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index f052bae942..a84ca01536 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -2904,9 +2904,11 @@ doCaseToLet scrut case_bndr | isTyCoVar case_bndr -- Respect GHC.Core = isTyCoArg scrut -- Note [Core type and coercion invariant] - | isUnliftedType (idType case_bndr) - -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase) - = exprOkForSpeculation scrut + | isUnliftedType (exprType scrut) + -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). + -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' + -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. + = exprOkForSpeculation scrut | otherwise -- Scrut has a lifted type = exprIsHNF scrut diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 419c0c8806..7029125768 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -2153,14 +2153,14 @@ splitPiTys ty = split ty ty [] -- newtype N a = MkN (a -> N a) -- getRuntimeArgTys (N a) == repeat (a, VisArg) -- @ -getRuntimeArgTys :: Type -> [(Type, AnonArgFlag)] +getRuntimeArgTys :: Type -> [(Scaled Type, AnonArgFlag)] getRuntimeArgTys = go where - go :: Type -> [(Type, AnonArgFlag)] + go :: Type -> [(Scaled Type, AnonArgFlag)] go (ForAllTy _ res) = go res - go (FunTy { ft_arg = arg, ft_res = res, ft_af = af }) - = (arg, af) : go res + go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af }) + = (Scaled w arg, af) : go res go ty | Just ty' <- coreView ty = go ty' diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 3a22863537..70e5c3c27a 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -31,7 +31,7 @@ import GHC.Prelude import Language.Haskell.Syntax.Binds import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind ) -import {-# SOURCE #-} GHC.Hs.Pat (pprLPat ) +import {-# SOURCE #-} GHC.Hs.Pat ( pprLPat ) import Language.Haskell.Syntax.Extension import GHC.Hs.Extension @@ -679,7 +679,6 @@ data TcSpecPrags = IsDefaultMethod -- ^ Super-specialised: a default method should -- be macro-expanded at every call site | SpecPrags [LTcSpecPrag] - deriving Data -- | Located Type checker Specification Pragmas type LTcSpecPrag = Located TcSpecPrag @@ -692,7 +691,6 @@ data TcSpecPrag InlinePragma -- ^ The Id to be specialised, a wrapper that specialises the -- polymorphic function, and inlining spec for the specialised function - deriving Data noSpecPrags :: TcSpecPrags noSpecPrags = SpecPrags [] diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index d664456654..ce415ead33 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -8,7 +8,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -60,7 +59,7 @@ import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Core.Type import GHC.Builtin.Types (mkTupleStr) -import GHC.Tc.Utils.TcType (TcType, TcTyVar) +import GHC.Tc.Utils.TcType (TcType) import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv) import GHCi.RemoteTypes ( ForeignRef ) @@ -169,8 +168,6 @@ instance Outputable SyntaxExprTc where data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper (hs_syn GhcTc) -- the thing that is wrapped -deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) - -- --------------------------------------------------------------------- data HsBracketTc = HsBracketTc @@ -427,9 +424,9 @@ data XXExprGhcTc | ConLikeTc -- Result of typechecking a data-con -- See Note [Typechecking data constructors] in -- GHC.Tc.Gen.Head - -- The two arguments describe how to eta-expand - -- the data constructor when desugaring - ConLike [TcTyVar] [Scaled TcType] + ConLike + [Scaled Type] -- ^ for a 'DataCon': constructor argument types + -- (ignored for a 'PatSynCon') --------------------------------------- -- Haskell program coverage (Hpc) Support @@ -685,7 +682,7 @@ instance Outputable XXExprGhcTc where -- expression (LHsExpr GhcPs), not the -- desugared one (LHsExpr GhcTc). - ppr (ConLikeTc con _ _) = pprPrefixOcc con + ppr (ConLikeTc con _) = pprPrefixOcc con -- Used in error messages generated by -- the pattern match overlap checker @@ -1198,7 +1195,7 @@ ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args) | HsVar _ (L _ v) <- op = ppr_cmd_infix v | GhcTc <- ghcPass @p - , XExpr (ConLikeTc c _ _) <- op + , XExpr (ConLikeTc c _) <- op = ppr_cmd_infix (conLikeName c) | otherwise = fall_through diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 3f4c0b16bd..d0a578dd61 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -33,6 +33,7 @@ import GHC.Hs.Type import GHC.Hs.Pat import GHC.Hs.ImpExp import GHC.Parser.Annotation +import GHC.Tc.Types.Evidence -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs----------------------------------------- @@ -66,6 +67,10 @@ deriving instance Data (HsBindLR GhcTc GhcTc) deriving instance Data AbsBinds deriving instance Data ABExport +deriving instance Data HsWrapper +deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) +deriving instance Data TcSpecPrags +deriving instance Data TcSpecPrag -- deriving instance DataId p => Data (RecordPatSynField p) deriving instance Data (RecordPatSynField GhcPs) diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index 63b568df4a..ff7bcfc51f 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -138,7 +138,7 @@ hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e -hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con +hsExprType (XExpr (ConLikeTc con _)) = conLikeType con hsExprType (XExpr (HsTick _ e)) = lhsExprType e hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e @@ -186,7 +186,8 @@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) go (WpEvApp _) = liftPRType $ funResultTy go (WpTyLam tv) = liftPRType $ mkForAllTy tv Inferred go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) - go (WpLet _) = id + go (WpEvLet _) = id + go (WpHsLet {}) = id go (WpMultCoercion _) = id lhsCmdTopType :: LHsCmdTop GhcTc -> Type diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 4dd0aab928..44182569e2 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -457,7 +457,11 @@ mkHsCharPrimLit :: Char -> HsLit (GhcPass p) mkHsCharPrimLit c = HsChar NoSourceText c mkConLikeTc :: ConLike -> HsExpr GhcTc -mkConLikeTc con = XExpr (ConLikeTc con [] []) +mkConLikeTc con = XExpr (ConLikeTc con arg_tys) + where + arg_tys = case con of + RealDataCon dc -> dataConOrigArgTys dc + PatSynCon {} -> [] {- ************************************************************************ @@ -812,7 +816,7 @@ mkHsWrapPatCo co pat ty | isTcReflCo co = pat | otherwise = XPat $ CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc -mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpEvLet ev_binds) expr {- l diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 44bb82312f..deddab68b3 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -30,7 +30,7 @@ import GHC.Driver.Config import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr ) import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) import GHC.HsToCore.Monad @@ -697,7 +697,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) (spec_bndrs, spec_app) = collectHsWrapBinders spec_co -- spec_co looks like -- \spec_bndrs. [] spec_args - -- perhaps with the body of the lambda wrapped in some WpLets + -- perhaps with the body of the lambda wrapped in some WpEvLets -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 ; core_app <- dsHsWrapper spec_app @@ -1127,13 +1127,16 @@ dsHsWrapper WpHole = return $ \e -> e dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) dsHsWrapper (WpEvLam ev) = return $ Lam ev dsHsWrapper (WpTyLam tv) = return $ Lam tv -dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds +dsHsWrapper (WpHsLet id rhs) = do { rhs <- dsExpr rhs + ; return (mkCoreLet (NonRec id rhs)) } +dsHsWrapper (WpEvLet ev_binds)= do { bs <- dsTcEvBinds ev_binds ; return (mkCoreLets bs) } dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; return (w1 . w2) } dsHsWrapper (WpFun c1 c2 (Scaled w t1)) -- See Note [Desugaring WpFun] - = do { x <- newSysLocalDs w t1 + = do { x <- setOneShotLambda <$> newSysLocalDs w t1 + -- SLD TODO: debugging perf regressions in eta-expansion. ; w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 5feee52901..43f5d3a4d4 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -261,7 +261,7 @@ dsExpr e@(XExpr ext_expr_tc) = case ext_expr_tc of ExpansionExpr (HsExpanded _ b) -> dsExpr b WrapExpr {} -> dsHsWrapped e - ConLikeTc con tvs tys -> dsConLike con tvs tys + ConLikeTc con _ -> dsHsConLike con -- Hpc Support HsTick tickish e -> do e' <- dsLExpr e @@ -767,29 +767,11 @@ dsHsConLike (PatSynCon ps) | Just (builder_name, _, add_void) <- patSynBuilder ps = do { builder_id <- dsLookupGlobalId builder_name ; return (if add_void - then mkCoreApp (text "dsConLike" <+> ppr ps) + then mkCoreApp (text "dsPatSynCon" <+> ppr ps) (Var builder_id) (Var voidPrimId) else Var builder_id) } | otherwise - = pprPanic "dsConLike" (ppr ps) - -dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr --- This function desugars ConLikeTc --- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head --- for what is going on here -dsConLike con tvs tys - = do { ds_con <- dsHsConLike con - ; ids <- newSysLocalsDs tys - -- newSysLocalDs: /can/ be lev-poly; see - ; return (mkLams tvs $ - mkLams ids $ - ds_con `mkTyApps` mkTyVarTys tvs - `mkVarApps` drop_stupid ids) } - where - - drop_stupid = dropList (conLikeStupidTheta con) - -- drop_stupid: see Note [Instantiating stupid theta] - -- in GHC.Tc.Gen.Head + = pprPanic "dsHsConLike" (ppr ps) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 1780c30755..e403612af9 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -1072,7 +1072,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) = exp b b' exp (HsVar _ i) (HsVar _ i') = i == i' - exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c' + exp (XExpr (ConLikeTc c _)) (XExpr (ConLikeTc c' _)) = c == c' -- the instance for IPName derives using the id, so this works if the -- above does exp (HsIPVar _ i) (HsIPVar _ i') = i == i' diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index b6725331a1..1cd8127f1b 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -1073,7 +1073,7 @@ isTrueLHsExpr (L _ (HsVar _ (L _ v))) || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _))) +isTrueLHsExpr (L _ (XExpr (ConLikeTc con _))) | con `hasKey` getUnique trueDataCon = Just return isTrueLHsExpr (L _ (XExpr (HsTick tickish e))) | Just ticks <- isTrueLHsExpr e diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index e92327f6d7..3f5cd9ffe9 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -684,7 +684,7 @@ instance ToHie (EvBindContext (LocatedA TcEvBinds)) where instance ToHie (LocatedA HsWrapper) where toHie (L osp wrap) = case wrap of - (WpLet bs) -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs) + (WpEvLet bs) -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs) (WpCompose a b) -> concatM $ [toHie (L osp a), toHie (L osp b)] (WpFun a b _) -> concatM $ @@ -1223,7 +1223,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where , toHie (L mspan w) ] ExpansionExpr (HsExpanded _ b) -> [ toHie (L mspan b) ] - ConLikeTc con _ _ + ConLikeTc con _ -> [ toHie $ C Use $ L mspan $ conLikeName con ] HsTick _ expr -> [ toHie expr diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 8f59daf24a..ecb79b8248 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -22,21 +21,14 @@ module GHC.Tc.Gen.App import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Types.Basic ( Arity, ExprOrPat(Expression) ) -import GHC.Types.Id ( idArity, idName, hasNoBinding ) -import GHC.Types.Name ( isWiredInName ) import GHC.Types.Var import GHC.Builtin.Types ( multiplicityTy ) -import GHC.Core.ConLike ( ConLike(..) ) -import GHC.Core.DataCon ( dataConRepArity - , isNewDataCon, isUnboxedSumDataCon, isUnboxedTupleDataCon ) import GHC.Tc.Gen.Head import GHC.Hs import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate -import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType @@ -331,28 +323,16 @@ tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- See Note [tcApp: typechecking applications] tcApp rn_expr exp_res_ty | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr - = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args + = do { traceTc "tcApp {" $ + vcat [ text "rn_fun:" <+> ppr rn_fun + , text "rn_args:" <+> ppr rn_args ] + + ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args -- Instantiate ; do_ql <- wantQuickLook rn_fun ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args - -- Check for representation polymorphism in the case that - -- the head of the application is a primop or data constructor - -- which has argument types that are representation-polymorphic. - -- This amounts to checking that the leftover argument types, - -- up until the arity, are not representation-polymorphic, - -- so that we can perform eta-expansion later without introducing - -- representation-polymorphic binders. - -- - -- See Note [Checking for representation-polymorphic built-ins] - ; traceTc "tcApp FRR" $ - vcat - [ text "tc_fun =" <+> ppr tc_fun - , text "inst_args =" <+> ppr inst_args - , text "app_res_rho =" <+> ppr app_res_rho ] - ; hasFixedRuntimeRep_remainingValArgs inst_args app_res_rho tc_fun - -- Quick look at result ; app_res_rho <- if do_ql then quickLookResultType delta app_res_rho exp_res_ty @@ -375,239 +355,33 @@ tcApp rn_expr exp_res_ty ; res_co <- perhaps_add_res_ty_ctxt $ unifyExpectedType rn_expr app_res_rho exp_res_ty - ; whenDOptM Opt_D_dump_tc_trace $ - do { inst_args <- mapM zonkArg inst_args -- Only when tracing - ; traceTc "tcApp" (vcat [ text "rn_fun" <+> ppr rn_fun - , text "inst_args" <+> brackets (pprWithCommas pprHsExprArgTc inst_args) - , text "do_ql: " <+> ppr do_ql - , text "fun_sigma: " <+> ppr fun_sigma - , text "delta: " <+> ppr delta - , text "app_res_rho:" <+> ppr app_res_rho - , text "exp_res_ty:" <+> ppr exp_res_ty - , text "rn_expr:" <+> ppr rn_expr ]) } - -- Typecheck the value arguments ; tc_args <- tcValArgs do_ql inst_args - -- Reconstruct, with a special cases for tagToEnum#. + -- Reconstruct, with a special case for tagToEnum#. ; tc_expr <- if isTagToEnum rn_fun then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho - else do return (rebuildHsApps tc_fun fun_ctxt tc_args) + else do rebuildHsApps tc_fun fun_ctxt tc_args app_res_rho + + ; whenDOptM Opt_D_dump_tc_trace $ + do { inst_args <- mapM zonkArg inst_args -- Only when tracing + ; traceTc "tcApp }" (vcat [ text "rn_fun:" <+> ppr rn_fun + , text "rn_args:" <+> ppr rn_args + , text "inst_args" <+> brackets (pprWithCommas pprHsExprArgTc inst_args) + , text "do_ql: " <+> ppr do_ql + , text "fun_sigma: " <+> ppr fun_sigma + , text "delta: " <+> ppr delta + , text "app_res_rho:" <+> ppr app_res_rho + , text "exp_res_ty:" <+> ppr exp_res_ty + , text "rn_expr:" <+> ppr rn_expr + , text "tc_fun:" <+> ppr tc_fun + , text "tc_args:" <+> ppr tc_args + , text "tc_expr:" <+> ppr tc_expr ]) } -- Wrap the result ; return (mkHsWrapCo res_co tc_expr) } -{- -Note [Checking for representation-polymorphic built-ins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We cannot have representation-polymorphic or levity-polymorphic -function arguments. See Note [Representation polymorphism invariants] -in GHC.Core. That is checked by the calls to `hasFixedRuntimeRep` in -`tcEValArg`. - -But some /built-in/ functions have representation-polymorphic argument -types. Users can't define such Ids; they are all GHC built-ins or data -constructors. Specifically they are: - -1. A few wired-in Ids like unsafeCoerce#, with compulsory unfoldings. -2. Primops, such as raise#. -3. Newtype constructors with `UnliftedNewtypes` that have - a representation-polymorphic argument. -4. Representation-polymorphic data constructors: unboxed tuples - and unboxed sums. - -For (1) consider - badId :: forall r (a :: TYPE r). a -> a - badId = unsafeCoerce# @r @r @a @a - -The wired-in function - unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b -has a convenient but representation-polymorphic type. It has no -binding; instead it has a compulsory unfolding, after which we -would have - badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#... -And this is no good because of that rep-poly \(x::a). So we want -to reject this. - -On the other hand - goodId :: forall (a :: Type). a -> a - goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a - -is absolutely fine, because after we inline the unfolding, the \(x::a) -is representation-monomorphic. - -Test cases: T14561, RepPolyWrappedVar2. - -For primops (2) the situation is similar; they are eta-expanded in -CorePrep to be saturated, and that eta-expansion must not add a -representation-polymorphic lambda. - -Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail. - -For (3), consider a representation-polymorphic newtype with -UnliftedNewtypes: - - type Id :: forall r. TYPE r -> TYPE r - newtype Id a where { MkId :: a } - - bad :: forall r (a :: TYPE r). a -> Id a - bad = MkId @r @a -- Want to reject - - good :: forall (a :: Type). a -> Id a - good = MkId @LiftedRep @a -- Want to accept - -Test cases: T18481, UnliftedNewtypesLevityBinder - -So these three cases need special treatment. We add a special case -in tcApp to check whether an application of an Id has any remaining -representation-polymorphic arguments, after instantiation and application -of previous arguments. This is achieved by the hasFixedRuntimeRep_remainingValArgs -function, which computes the types of the remaining value arguments, and checks -that each of these have a fixed runtime representation using hasFixedRuntimeRep. - -Wrinkles - -* Because of Note [Typechecking data constructors] in GHC.Tc.Gen.Head, - we desugar a representation-polymorphic data constructor application - like this: - (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4 - That is, a rep-poly lambda applied to arguments that instantiate it in - a rep-mono way. It's a bit like a compulsory unfolding that has been - inlined, but not yet beta-reduced. - - Because we want to accept this, we switch off Lint's representation - polymorphism checks when Lint checks the output of the desugarer; - see the lf_check_fixed_rep flag in GHC.Core.Lint.lintCoreBindings. - - We then rely on the simple optimiser to beta reduce these - representation-polymorphic lambdas (e.g. GHC.Core.SimpleOpt.simple_app). - -* Arity. We don't want to check for arguments past the - arity of the function. For example - - raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b - - has arity 1, so an instantiation such as: - - foo :: forall w r (z :: TYPE r). w -> z -> z - foo = raise# @w @(z -> z) - - is unproblematic. This means we must take care not to perform a - representation-polymorphism check on `z`. - - To achieve this, we consult the arity of the 'Id' which is the head - of the application (or just use 1 for a newtype constructor), - and keep track of how many value-level arguments we have seen, - to ensure we stop checking once we reach the arity. - This is slightly complicated by the need to include both visible - and invisible arguments, as the arity counts both: - see GHC.Tc.Gen.Head.countVisAndInvisValArgs. - - Test cases: T20330{a,b} - --} - --- | Check for representation-polymorphism in the remaining argument types --- of a variable or data constructor, after it has been instantiated and applied to some arguments. --- --- See Note [Checking for representation-polymorphic built-ins] -hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcRhoType -> HsExpr GhcTc -> TcM () -hasFixedRuntimeRep_remainingValArgs applied_args app_res_rho = \case - - HsVar _ (L _ fun_id) - - -- (1): unsafeCoerce# - -- 'unsafeCoerce#' is peculiar: it is patched in manually as per - -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore. - -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair, - -- at this stage, if we query idArity, we get 0. This is because - -- we end up looking at the non-patched version of unsafeCoerce# - -- defined in Unsafe.Coerce, and that one indeed has arity 0. - -- - -- We thus manually specify the correct arity of 1 here. - | idName fun_id == unsafeCoercePrimName - -> check_thing fun_id 1 (FRRNoBindingResArg fun_id) - - -- (2): primops and other wired-in representation-polymorphic functions, - -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings - -- in GHC.Types.Id.Make - | isWiredInName (idName fun_id) && hasNoBinding fun_id - -> check_thing fun_id (idArity fun_id) (FRRNoBindingResArg fun_id) - -- NB: idArity consults the IdInfo of the Id. This can be a problem - -- in the presence of hs-boot files, as we might not have finished - -- typechecking; inspecting the IdInfo at this point can cause - -- strange Core Lint errors (see #20447). - -- We avoid this entirely by only checking wired-in names, - -- as those are the only ones this check is applicable to anyway. - - - XExpr (ConLikeTc (RealDataCon con) _ _) - -- (3): Representation-polymorphic newtype constructors. - | isNewDataCon con - -- (4): Unboxed tuples and unboxed sums - || isUnboxedTupleDataCon con - || isUnboxedSumDataCon con - -> check_thing con (dataConRepArity con) (FRRDataConArg Expression con) - - _ -> return () - - where - nb_applied_vis_val_args :: Int - nb_applied_vis_val_args = count isHsValArg applied_args - - nb_applied_val_args :: Int - nb_applied_val_args = countVisAndInvisValArgs applied_args - - arg_tys :: [(Type,AnonArgFlag)] - arg_tys = getRuntimeArgTys app_res_rho - -- We do not need to zonk app_res_rho first, because the number of arrows - -- in the (possibly instantiated) inferred type of the function will - -- be at least the arity of the function. - - check_thing :: Outputable thing - => thing - -> Arity - -> (Int -> FixedRuntimeRepContext) - -> TcM () - check_thing thing arity mk_frr_orig = do - traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity) - go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys - where - go :: Int -- visible value argument index, starting from 1 - -- only used to report the argument position in error messages - -> Int -- value argument index, starting from 1 - -- used to count up to the arity to ensure we don't check too many argument types - -> [(Type, AnonArgFlag)] -- run-time argument types - -> TcM () - go _ i_val _ - | i_val > arity - = return () - go _ _ [] - -- Should never happen: it would mean that the arity is higher - -- than the number of arguments apparent from the type - = pprPanic "hasFixedRuntimeRep_remainingValArgs" (debug_msg thing arity) - go i_visval !i_val ((arg_ty, af) : tys) - = case af of - InvisArg -> - go i_visval (i_val + 1) tys - VisArg -> do - hasFixedRuntimeRep_syntactic (mk_frr_orig i_visval) arg_ty - go (i_visval + 1) (i_val + 1) tys - - -- A message containing all the relevant info, in case this functions - -- needs to be debugged again at some point. - debug_msg :: Outputable thing => thing -> Arity -> SDoc - debug_msg thing arity = - vcat - [ text "thing =" <+> ppr thing - , text "arity =" <+> ppr arity - , text "applied_args =" <+> ppr applied_args - , text "nb_applied_val_args =" <+> ppr nb_applied_val_args - , text "arg_tys =" <+> ppr arg_tys ] - -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool -- GHC switches on impredicativity all the time for ($) @@ -645,6 +419,7 @@ zonkArg arg = return arg ---------------- + tcValArgs :: Bool -- Quick-look on? -> [HsExprArg 'TcpInst] -- Actual argument -> TcM [HsExprArg 'TcpTc] -- Resulting argument @@ -694,9 +469,13 @@ tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _) = addArgCtxt ctxt larg $ do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ]) ; tc_args <- tcValArgs True inner_args - ; co <- unifyType Nothing app_res_rho exp_arg_sigma - ; let arg' = mkHsWrapCo co $ rebuildHsApps inner_fun fun_ctxt tc_args - ; traceTc "tcEValArgQL }" empty + + ; co <- unifyType Nothing app_res_rho exp_arg_sigma + ; arg' <- mkHsWrapCo co <$> rebuildHsApps inner_fun fun_ctxt tc_args app_res_rho + ; traceTc "tcEValArgQL }" $ + vcat [ text "inner_fun:" <+> ppr inner_fun + , text "app_res_rho:" <+> ppr app_res_rho + , text "exp_arg_sigma:" <+> ppr exp_arg_sigma ] ; return (L arg_loc arg') } {- ********************************************************************* @@ -1418,15 +1197,15 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty check_enumeration res_ty rep_tc ; let rep_ty = mkTyConApp rep_tc rep_args tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun - tc_expr = rebuildHsApps tc_fun' fun_ctxt [val_arg] df_wrap = mkWpCastR (mkTcSymCo coi) + ; tc_expr <- rebuildHsApps tc_fun' fun_ctxt [val_arg] res_ty ; return (mkHsWrap df_wrap tc_expr) }}}}} | otherwise = failWithTc TcRnTagToEnumMissingValArg where - vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args) + vanilla_result = rebuildHsApps tc_fun fun_ctxt tc_args res_ty check_enumeration ty' tc | isEnumerationTyCon tc = return () diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index e26fee1f98..de544e3ea5 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -325,7 +325,6 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty ; let expr' = ExplicitTuple x tup_args1 boxity missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] - -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys) diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index f663aab407..dcd8152b9a 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -43,6 +43,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Types.Error +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv ( FamInstEnvs ) @@ -75,6 +76,7 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc +import GHC.Data.FastString ( fsLit ) import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic @@ -85,7 +87,6 @@ import Data.Function import GHC.Prelude - {- ********************************************************************* * * HsExprArg: auxiliary data type @@ -187,12 +188,12 @@ data EValArg (p :: TcPass) where -- See Note [EValArg] ValArg :: LHsExpr (GhcPass (XPass p)) -> EValArg p - ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original application + ValArgQL :: { va_expr :: LHsExpr GhcRn -- ^ Original application -- For location and error msgs - , va_fun :: (HsExpr GhcTc, AppCtxt) -- Function of the application, + , va_fun :: (HsExpr GhcTc, AppCtxt) -- ^ Function of the application, -- typechecked, plus its context - , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated - , va_ty :: TcRhoType } -- Result type + , va_args :: [HsExprArg 'TcpInst] -- ^ Args, instantiated + , va_ty :: TcRhoType } -- ^ Result type -> EValArg 'TcpInst -- Only exists in TcpInst phase data AppCtxt @@ -321,25 +322,472 @@ splitHsApps e = go e (top_ctxt 0 e) [] dec l (VACall f n _) = VACall f (n-1) (locA l) dec _ ctxt@(VAExpansion {}) = ctxt -rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc -rebuildHsApps fun _ [] = fun -rebuildHsApps fun ctxt (arg : args) +-- | Rebuild an application: takes a type-checked application head +-- expression together with arguments in the form of typechecked 'HsExprArg's +-- and returns a typechecked application of the head to the arguments. +-- +-- Can eta-expand the application. See Wrinkle [Eta-expansion and sharing] +-- in Note [Checking for representation-polymorphic built-ins]. +rebuildHsApps :: HsExpr GhcTc + -- ^ the function being applied + -> AppCtxt + -> [HsExprArg 'TcpTc] + -- ^ the arguments to the function + -> TcRhoType + -- ^ result type of the application + -> TcM (HsExpr GhcTc) +rebuildHsApps fun ctxt args app_res_rho + = do { (wrap, args) <- tcRemainingValArgs args app_res_rho fun + ; return $ mkHsWrap wrap $ rebuild_hs_apps fun ctxt args } + +-- | The worker function for 'rebuildHsApps': simply rebuilds +-- an application chain in which arguments are specified as +-- typechecked 'HsExprArg's. +rebuild_hs_apps :: HsExpr GhcTc + -- ^ the function being applied + -> AppCtxt + -> [HsExprArg 'TcpTc] + -- ^ the arguments to the function + -> HsExpr GhcTc +rebuild_hs_apps fun _ [] = fun +rebuild_hs_apps fun ctxt (arg : args) = case arg of EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } - -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args - ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } - -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args + -> rebuild_hs_apps (HsApp noAnn lfun arg) ctxt' args + ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } + -> rebuild_hs_apps (HsAppType ty lfun hs_ty) ctxt' args EPrag ctxt' p - -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args + -> rebuild_hs_apps (HsPragE noExtField p lfun) ctxt' args EWrap (EPar ctxt') - -> rebuildHsApps (gHsPar lfun) ctxt' args + -> rebuild_hs_apps (gHsPar lfun) ctxt' args EWrap (EExpand orig) - -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args + -> rebuild_hs_apps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args EWrap (EHsWrap wrap) - -> rebuildHsApps (mkHsWrap wrap fun) ctxt args + -> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args where lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun +{- Note [Checking for representation-polymorphic built-ins] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We cannot have representation-polymorphic or levity-polymorphic +function arguments. See Note [Representation polymorphism invariants] +in GHC.Core. That is checked by the calls to `hasFixedRuntimeRep` in +`tcEValArg`. + +But some /built-in/ functions have representation-polymorphic argument +types. Users can't define such Ids; they are all GHC built-ins or data +constructors. Specifically they are: + +1. A few wired-in Ids such as coerce and unsafeCoerce#, +2. Primops, such as raise#. +3. Newtype constructors with `UnliftedNewtypes` which have + a representation-polymorphic argument. +4. Representation-polymorphic data constructors: unboxed tuples + and unboxed sums. + +For (1) consider + badId :: forall r (a :: TYPE r). a -> a + badId = unsafeCoerce# @r @r @a @a + +The wired-in function + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b +has a convenient but representation-polymorphic type. It has no +binding; instead it has a compulsory unfolding, after which we +would have + badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#... +And this is no good because of that rep-poly \(x::a). So we want +to reject this. + +On the other hand + goodId :: forall (a :: Type). a -> a + goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a + +is absolutely fine, because after we inline the unfolding, the \(x::a) +is representation-monomorphic. + +Test cases: T14561, RepPolyWrappedVar2. + +For primops (2) the situation is similar; they are eta-expanded in +CorePrep to be saturated, and that eta-expansion must not add a +representation-polymorphic lambda. + +Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail. + +For (3), consider a representation-polymorphic newtype with +UnliftedNewtypes: + + type Id :: forall r. TYPE r -> TYPE r + newtype Id a where { MkId :: a } + + bad :: forall r (a :: TYPE r). a -> Id a + bad = MkId @r @a -- Want to reject + + good :: forall (a :: Type). a -> Id a + good = MkId @LiftedRep @a -- Want to accept + +Test cases: T18481, UnliftedNewtypesLevityBinder + +So these cases need special treatment. We add a special case +in tcApp to check whether an application of an Id has any remaining +representation-polymorphic arguments, after instantiation and application +of previous arguments. This is achieved by the tcRemainingValArgs +function, which computes the types of the remaining value arguments, and checks +that each of these have a fixed runtime representation. + +Note that this function also ensures that data constructors always +appear saturated, by performing eta-expansion if necessary. +See Note [Typechecking data constructors]. + +Wrinkle [Arity] + + We don't want to check for arguments past the arity of the function. + + For example + + raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b + + has arity 1, so an instantiation such as: + + foo :: forall w r (z :: TYPE r). w -> z -> z + foo = raise# @w @(z -> z) + + is unproblematic. This means we must take care not to perform a + representation-polymorphism check on `z`. + + To achieve this, we consult the arity of the 'Id' which is the head + of the application (or just use 1 for a newtype constructor), + and keep track of how many value-level arguments we have seen, + to ensure we stop checking once we reach the arity. + This is slightly complicated by the need to include both visible + and invisible arguments, as the arity counts both: + see GHC.Tc.Gen.Head.countVisAndInvisValArgs. + + Test cases: T20330{a,b} + +Wrinkle [Eta-expansion and sharing] + + We need to eta-expand partial applications of representation-polymorphic + primops without losing sharing. + + Consider the following example: + + type RR :: RuntimeRep + type family RR where { RR = FloatRep } + type F :: TYPE RR + type family F where { F = Float# } + + tup :: F -> (# Float#, F #) + tup = (# , #) big_expression + + Here, tcRemainingValArgs checks that the second value argument to `(# , #)` + has a fixed RuntimeRep. Naively, we would elaborate to: + + ( \ (y :: F |> TYPE RR[0]) -> (# , #) big_expression y ) |> outer_co + + However, this loses sharing of big_expression. So we instead proceed as follows: + + [LET] + Let-bind the value arguments that are already present, to avoid + pushing them under a lambda. This is what letBindValArgs does: + + - traverse the existing arguments and create new 'Id's + for each of them, + - update the arguments to refer to those 'Id's + - create a WpHsLet wrapper which performs the let-binding + at the outermost level: [_] ===> let x1 = expr in [_] + + [ETA] + Perform eta-expansion using an HsWrapper. + + This results in the following elaboration of `tup`: + + let e = big_expression + in + ( \ (y :: F |> TYPE RR[0]) -> (# , #) e y ) |> outer_co + +Wrinkle [Syntactic check] + + We only perform a syntactic check in tcRemainingValArgs. That is, + we will reject partial applications such as: + + type RR :: RuntimeREp + type family RR where { RR = IntRep } + type T :: TYPE RR + type family T where { T = Int# } + + (# , #) @LiftedRep @RR e1 + + Here, we would need to elaborate this partial application of (# , #) as follows: + + let x1 = e1 + in + ( \ @(ty2 :: TYPE RR) (x2 :: ty2 |> TYPE RR[0]) + -> ( ( (# , #) @LiftedRep @RR @Char @ty2 x1 ) |> co1 ) + x2 + ) |> co2 + + That is, we need to cast the partial application + + (# , #) @LiftedRep @RR @Char @ty2 x1 + + so that the next argument we provide to it has a fixed RuntimeRep. + + This causes problems in the rest of the compiler, because we don't handle + application chains in one go like we do in tcApp. So, for now, we limit + ourselves to a simple syntactic check. + See issue #21683 for more context. + +Note [Typechecking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Polymorphisation of linear fields] in +GHC.Core.Multiplicity, linear fields of data constructors get a +polymorphic multiplicity when the data constructor is used as a term, +e.g. + + Just :: forall {p} a. a %p -> Maybe a + +This is necessary to allow code such as "map Just" to typecheck. + +Worked example: consider a data constructor 'K' with type + + K :: forall (r :: RuntimeRep) (a :: TYPE r). a -> a %1 -> T r a + +We want to type-check the partial application + + f :: Int# -> Int# + f = K big_expr + +This proceeds as follows: + +1. Compute the type of the head of the application, K, in tcInferDataCon. + + To allow the function f to typecheck, we must tweak the multiplicities: + we start with the user-written type + + K :: forall (r :: RuntimeRep) (a :: TYPE r). a -> a %1 -> T r a + + and switch out the multiplicity %1 on the second value argument of K + to a fresh multiplicity metavariable %p. We do this for the arguments + types which are declared linear, and only those. + + We achieve this by returning a ConLikeTc, an extension constructor at GhcTc pass: + + XExpr (ConLikeTc K [Scaled Many a, Scaled m a]) + :: forall (r :: RuntimeRep) (a :: TYPE r). a -> a %p -> T r a + + which stores the tweaked multiplicities of the argument types. + + One can think of (ConLikeTc K ..) as being obtained from instantiating + the multiplicities of the general multiplicity-polymorphic constructor + + forall (m :: Multiplicity) (r :: RuntimeRep) (a :: TYPE r). a -> a %m -> T r a + +2. Instantiate the constructor in tcApp, elaborating (ConLikeTc K ..) big_expr to + + (ConLikeTc K ..) @IntRep @Int# big_expr + + In this case, we will unify the metavariable p with Many, as required + by the type signature on 'f'. + +3. Ensure the data constructor K is saturated, by performing eta expansion + in tcRemainingValArgs. As per Wrinkle [Eta-expansion and sharing] in + Note [Checking for representation-polymorphic built-ins], this may + introduce a let-binding to avoid losing sharing. + We thus elaborate the previous expression to + + let x = big_expr + in \ (y %Many :: Int#) -> (ConLikeTc K ..) @IntRep @Int# x y + +4. Desugar (ConLikeTc K ..) to K, in dsConLike. This is OK because + step (3) has saturated data constructors, taking care of the multiplicities. + We end up with: + + f :: Int# -> Int# + f = + let x = big_expr + in \ (y %Many :: Int#) -> K @IntRep @Int# x y + +See Note [Instantiating stupid theta] for an extra wrinkle. +-} + +-- | Typecheck the remaining value arguments in a partial application, +-- eta-expanding the application to saturate the function. +-- +-- Example: +-- +-- > coerce @LiftedRep @a @b ===> \ (x :: a) -> coerce @LiftedRep @a @b x +-- +-- This function ensures that all the remaining value arguments have a +-- fixed RuntimeRep in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete, +-- which is a precondition for the eta-expansion to be well-defined. +-- See Note [Checking for representation-polymorphic built-ins]. +-- +-- NB: this function only does anything for 'Id's with no bindings +-- and data constructors. For other functions at the head of an application, +-- 'tcRemainingValArgs' is a no-op. +tcRemainingValArgs :: HasDebugCallStack + => [HsExprArg 'TcpTc] + -> TcRhoType + -> HsExpr GhcTc + -> TcM (HsWrapper, [HsExprArg 'TcpTc]) +tcRemainingValArgs applied_args app_res_rho fun = case fun of + + HsVar _ (L _ fun_id) + + -- (1): unsafeCoerce# + -- 'unsafeCoerce#' is peculiar: it is patched in manually as per + -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore. + -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair, + -- at this stage, if we query idArity, we get 0. This is because + -- we end up looking at the non-patched version of unsafeCoerce# + -- defined in Unsafe.Coerce, and that one indeed has arity 0. + -- + -- We thus manually specify the correct arity of 1 here. + | idName fun_id == unsafeCoercePrimName + -> wrap_args 1 (FRRNoBindingResArg fun_id) + + -- (2): primops and other wired-in representation-polymorphic functions, + -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings + -- in GHC.Types.Id.Make + | isWiredInName (idName fun_id) && hasNoBinding fun_id + -> wrap_args (idArity fun_id) (FRRNoBindingResArg fun_id) + -- NB: idArity consults the IdInfo of the Id. This can be a problem + -- in the presence of hs-boot files, as we might not have finished + -- typechecking; inspecting the IdInfo at this point can cause + -- strange Core Lint errors (see #20447). + -- We avoid this entirely by only checking wired-in names, + -- as those are the only ones this check is applicable to anyway. + + XExpr (ConLikeTc (RealDataCon con) _) + -- Data constructors. This covers + -- (3): Representation-polymorphic newtype constructors. + -- (4): Unboxed tuples and unboxed sums. + -- + -- But we need to do this for all data constructors, + -- as they might require eta-expansion even if they don't + -- have representation-polymorphic arguments, as per + -- Note [Typechecking data constructors]. + -> wrap_args (dc_val_arity con) (FRRDataConArg Expression con) + + _ -> return (idHsWrapper, applied_args) + + where + + dc_val_arity :: DataCon -> Arity + dc_val_arity con = count (not . isEqPrimPred) (dataConTheta con) + + length (dataConStupidTheta con) + + dataConSourceArity con + -- Count how many value-level arguments this data constructor expects: + -- - dictionary arguments from the context (including the stupid context) + -- - source value arguments. + -- Tests: EtaExpandDataCon, EtaExpandStupid{1,2}. + + nb_applied_vis_val_args :: Int + nb_applied_vis_val_args = count isHsValArg applied_args + + nb_applied_val_args :: Int + nb_applied_val_args = countVisAndInvisValArgs applied_args + + rem_arg_tys :: [(Scaled Type, AnonArgFlag)] + rem_arg_tys = getRuntimeArgTys app_res_rho + -- We do not need to zonk app_res_rho first, because the number of arrows + -- in the (possibly instantiated) inferred type of the function will + -- be at least the arity of the function. + + wrap_args :: Arity + -> (Int -> FixedRuntimeRepContext) + -> TcM (HsWrapper, [HsExprArg 'TcpTc]) + wrap_args arity mk_frr_ctxt + = do { let partial_application = nb_applied_val_args < arity + -- See Wrinkle [Arity] in + -- Note [Checking for representation-polymorphic built-ins]. + ; if not partial_application + then return (idHsWrapper, applied_args) + else + do { rem_args_wrap <- + check_remaining_args + (nb_applied_vis_val_args + 1) + (nb_applied_val_args + 1) + rem_arg_tys + + -- If eta-expanion is needed, we must also let-bind the value arguments. + -- See [LET] in Note [Typechecking data constructors]. + ; (let_wrap, final_args) <- letBindValArgs applied_args + ; traceTc "tcRemainingValArgs: eta-expansion" $ + vcat [ text "fun:" <+> ppr fun + , text "applied_args:" <+> ppr applied_args + , text "final_args:" <+> ppr final_args + , text "let_wrap:" <+> ppr let_wrap + , text "rem_args_wrap:" <+> ppr rem_args_wrap ] + + ; return (let_wrap <.> rem_args_wrap, final_args) } } + + where + + check_remaining_args :: Int -- visible value argument index, starting from 1 + -- only used to report the argument position in error messages + -> Int -- value argument index, starting from 1 + -- used to count up to the arity to ensure we don't check too many argument types + -> [(Scaled Type, AnonArgFlag)] -- run-time argument types + -> TcM HsWrapper + -- the wrapper that performs the eta-expansion + check_remaining_args _ i_val _ + | i_val > arity + = return idHsWrapper + check_remaining_args _ _ [] + -- Should never happen: it would mean that the arity is higher + -- than the number of arguments apparent from the type + = pprPanic "tcRemainingValArgs" (debug_msg fun arity) + check_remaining_args i_visval !i_val ((Scaled mult arg_ty, af) : tys) + = do { hasFixedRuntimeRep_syntactic (mk_frr_ctxt i_visval) arg_ty + -- Why is this a syntactic check? See Wrinkle [Syntactic check] in + -- Note [Checking for representation-polymorphic built-ins]. + ; let i_visval' = case af of { InvisArg -> i_visval; VisArg -> i_visval + 1} + ; eta_wrap <- check_remaining_args i_visval' (i_val + 1) tys + ; let wrap = WpFun idHsWrapper eta_wrap (Scaled mult arg_ty) + -- Add a wrapper that eta-expands. + -- See [ETA] in Note [Checking for representation-polymorphic built-ins] + -- + -- NB: we use WpFun and not mkWpFun, because we want the eta expansion + -- to happen no matter what, even if it's "\ x -> f x" + -- (with no argument/result wrappers). + ; return wrap } + + debug_msg :: Outputable app_head => app_head -> Arity -> SDoc + debug_msg thing arity = + vcat + [ text "thing =" <+> ppr thing + , text "arity =" <+> ppr arity + , text "applied_args =" <+> ppr applied_args + , text "nb_applied_val_args =" <+> ppr nb_applied_val_args + , text "rem_arg_tys =" <+> ppr rem_arg_tys ] + +-- | Create a wrapper that let-binds the value arguments +-- within the supplied arguments. Returns the wrapper, +-- and an updated list to arguments. +-- +-- See [LET] in Note [Typechecking data constructors]. +letBindValArgs :: [HsExprArg 'TcpTc] -> TcM (HsWrapper, [HsExprArg 'TcpTc]) +letBindValArgs old_args = + do { res@(wrap, new_args) <- mapAccumLM let_bind_one idHsWrapper old_args + ; traceTc "letBindValArgs" $ + vcat [ text "old_args:" <+> ppr old_args + , text "new_args:" <+> ppr new_args + , text "wrap:" <+> ppr wrap ] + ; return res } + where + let_bind_one :: HsWrapper -> HsExprArg 'TcpTc -> TcM (HsWrapper, HsExprArg 'TcpTc) + let_bind_one acc_wrap arg = case arg of + EValArg { eva_arg = ValArg (L _ rhs), eva_arg_ty = Scaled m arg_ty } + -> do { arg_id <- newSysLocalId (fsLit "eta") m arg_ty + ; let new_arg_expr = L gen $ HsVar noExtField $ L gen arg_id + ; return ( acc_wrap <.> mkWpHsLet arg_id rhs + , arg { eva_arg = ValArg new_arg_expr } ) } + _ -> return (acc_wrap, arg) + gen = noAnnSrcSpan generatedSrcSpan + isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True isHsValArg _ = False @@ -385,7 +833,8 @@ countHsWrapperInvisArgs = go go (WpEvApp _) = 1 go tyLam@(WpTyLam {}) = nope tyLam go (WpTyApp _) = 0 - go (WpLet _) = 0 + go (WpEvLet _) = 0 + go (WpHsLet {}) = 0 go (WpMultCoercion {}) = 0 nope x = pprPanic "countHsWrapperInvisApps" (ppr x) @@ -654,7 +1103,7 @@ tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) ; let poly_wrap = wrap <.> mkWpTyLams qtvs <.> mkWpLams givens - <.> mkWpLet ev_binds + <.> mkWpEvLet ev_binds ; return (mkLHsWrap poly_wrap expr', my_sigma) } @@ -835,7 +1284,6 @@ tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType) -- See Note [Typechecking data constructors] tcInferDataCon con = do { let tvbs = dataConUserTyVarBinders con - tvs = binderVars tvbs theta = dataConOtherTheta con args = dataConOrigArgTys con res = dataConOrigResTy con @@ -843,17 +1291,16 @@ tcInferDataCon con ; scaled_arg_tys <- mapM linear_to_poly args - ; let full_theta = stupid_theta ++ theta - all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys + ; let full_theta = stupid_theta ++ theta -- stupid-theta must come first -- See Note [Instantiating stupid theta] - ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys) + ; return ( XExpr (ConLikeTc (RealDataCon con) scaled_arg_tys) , mkInvisForAllTys tvbs $ mkPhiTy full_theta $ mkVisFunTys scaled_arg_tys res ) } where linear_to_poly :: Scaled Type -> TcM (Scaled Type) - -- linear_to_poly implements point (3,4) + -- linear_to_poly implements (1) -- of Note [Typechecking data constructors] linear_to_poly (Scaled One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy ; return (Scaled mul_var ty) } @@ -868,79 +1315,29 @@ tcInferPatSyn id_name ps nonBidirectionalErr :: Name -> TcRnMessage nonBidirectionalErr = TcRnPatSynNotBidirectional -{- Note [Typechecking data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As per Note [Polymorphisation of linear fields] in -GHC.Core.Multiplicity, linear fields of data constructors get a -polymorphic multiplicity when the data constructor is used as a term: - - Just :: forall {p} a. a %p -> Maybe a - -So at an occurrence of a data constructor we do the following, -mostly in tcInferDataCon: - -1. Get its type, say - K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a - Note the %1: it is linear - -2. We are going to return a ConLikeTc, thus: - XExpr (ConLikeTc K [r,a] [Scaled p a]) - :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a - where 'p' is a fresh multiplicity unification variable. - - To get the returned ConLikeTc, we allocate a fresh multiplicity - variable for each linear argument, and store the type, scaled by - the fresh multiplicity variable in the ConLikeTc; along with - the type of the ConLikeTc. This is done by linear_to_poly. - -3. If the argument is not linear (perhaps explicitly declared as - non-linear by the user), don't bother with this. - -4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by - GHC.HsToCore.Expr.dsConLike to: - (/\r (a :: TYPE r). \(x %p :: a). K @r @a x) - which has the desired type given in the previous bullet. - The 'p' is the multiplicity unification variable, which - will by now have been unified to something, or defaulted in - `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an - (unbound) variable. - -Wrinkles - -* Note that the [TcType] is strictly redundant anyway; those are the - type variables from the dataConUserTyVarBinders of the data constructor. - Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly - from the data constructor. The only bit that /isn't/ redundant is the - fresh multiplicity variables! - - So an alternative would be to define ConLikeTc like this: - | ConLikeTc [TcType] -- Just the multiplicity variables - But then the desugarer would need to repeat some of the work done here. - So for now at least ConLikeTc records this strictly-redundant info. +{- Note [Instantiating stupid theta] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a data type with a "stupid theta" (see +Note [The stupid context] in GHC.Core.DataCon): -* The lambda expression we produce in (4) can have representation-polymorphic - arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x), - we have a lambda-bound variable x :: (a :: TYPE r). - This goes against the representation polymorphism invariants given in - Note [Representation polymorphism invariants] in GHC.Core. The trick is that - this this lambda will always be instantiated in a way that upholds the invariants. - This is achieved as follows: + data Ord a => T a = MkT (Maybe a) - A. Any arguments to such lambda abstractions are guaranteed to have - a fixed runtime representation. This is enforced in 'tcApp' by - 'matchActualFunTySigma'. +We want to generate an Ord constraint for every use of MkT; but +we also want to allow visible type application, such as - B. If there are fewer arguments than there are bound term variables, - hasFixedRuntimeRep_remainingValArgs will ensure that we are still - instantiating at a representation-monomorphic type, e.g. + MkT @Int - ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int# - :: Int# -> T IntRep Int# +To achieve this, the wrapper for a data (or newtype) constructor +with a datatype context contains a lambda which drops the dictionary +argments corresponding to the datatype context: - We then rely on the simple optimiser to beta reduce the lambda. + /\a \(_d:Ord a). MkT @a -* See Note [Instantiating stupid theta] for an extra wrinkle +Notice that 'd' is dropped in this desugaring. We don't need it; +it was only there to generate a Wanted constraint. (That is why +it is stupid.) +This all happens in GHC.Types.Id.Make.mkDataConRep. Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -949,37 +1346,6 @@ This isn't really the Right Thing because there's no way to "undo" if you want to see the original source code in the typechecker output. We'll have fix this in due course, when we care more about being able to reconstruct the exact original program. - - -Note [Instantiating stupid theta] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a data type with a "stupid theta" (see -Note [The stupid context] in GHC.Core.DataCon): - - data Ord a => T a = MkT (Maybe a) - -We want to generate an Ord constraint for every use of MkT; but -we also want to allow visible type application, such as - MkT @Int - -So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type - forall a. Ord a => Maybe a -> T a - -Now visible type application will work fine. But we desugar the -ConLikeTc to - /\a \(d:Ord a) (x:Maybe a). MkT x -Notice that 'd' is dropped in this desugaring. We don't need it; -it was only there to generate a Wanted constraint. (That is why -it is stupid.) To achieve this: - -* We put the stupid-thata at the front of the list of argument - types in ConLikeTc - -* GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the - arguments, but drops the stupid-theta arguments when building the - /application/. - -Nice. -} {- diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index eb31cec392..4c56ff5f80 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -826,7 +826,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] - body = mkLHsWrap (mkWpLet req_ev_binds) $ + body = mkLHsWrap (mkWpEvLet req_ev_binds) $ L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ MG{ mg_alts = L (l2l $ getLoc lpat) cases @@ -1009,7 +1009,7 @@ patSynBuilderOcc ps = Just $ if add_void_arg then ( builder_expr -- still just return builder_expr; the void# arg - -- is added by dsConLike in the desugarer + -- is added by dsHsConLike in the desugarer , tcFunResultTy builder_ty ) else (builder_expr, builder_ty) diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index 42704013a7..fe8fe7e3b9 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -8,7 +8,7 @@ module GHC.Tc.Types.Evidence ( -- * HsWrapper HsWrapper(..), (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, - mkWpLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, + mkWpLams, mkWpHsLet, mkWpEvLet, mkWpFun, mkWpCastN, mkWpCastR, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, pprHsWrapper, hsWrapDictBinders, @@ -65,6 +65,10 @@ module GHC.Tc.Types.Evidence ( import GHC.Prelude +import Language.Haskell.Syntax.Expr ( HsExpr ) +import GHC.Hs.Extension ( GhcTc ) +import {-# SOURCE #-} GHC.Hs.Expr () -- Outputable (HsExpr GhcTc) + import GHC.Types.Unique.DFM import GHC.Types.Unique.FM import GHC.Types.Var @@ -258,13 +262,14 @@ data HsWrapper | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) - | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, + | WpEvLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, -- so that the identity coercion is always exactly WpHole + | WpHsLet Id (HsExpr GhcTc) + | WpMultCoercion Coercion -- Require that a Coercion be reflexive; otherwise, -- error in the desugarer. See GHC.Tc.Utils.Unify -- Note [Wrapper returned from tcSubMult] - deriving Data.Data -- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data -- constructor, is "syntactic" and not associative. Concretely, if @a@, @b@, @@ -337,10 +342,13 @@ mkWpTyLams ids = mk_co_lam_fn WpTyLam ids mkWpLams :: [Var] -> HsWrapper mkWpLams ids = mk_co_lam_fn WpEvLam ids -mkWpLet :: TcEvBinds -> HsWrapper +mkWpEvLet :: TcEvBinds -> HsWrapper -- This no-op is a quite a common case -mkWpLet (EvBinds b) | isEmptyBag b = WpHole -mkWpLet ev_binds = WpLet ev_binds +mkWpEvLet (EvBinds b) | isEmptyBag b = WpHole +mkWpEvLet ev_binds = WpEvLet ev_binds + +mkWpHsLet :: Id -> HsExpr GhcTc -> HsWrapper +mkWpHsLet = WpHsLet mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as @@ -362,7 +370,7 @@ hsWrapDictBinders :: HsWrapper -> Bag DictId -- (only) to allow the pattern-match overlap checker to know what Given -- dictionaries are in scope. -- --- We specifically do not collect dictionaries bound in a 'WpLet'. These are +-- We specifically do not collect dictionaries bound in a 'WpEvLet'. These are -- either superclasses of lambda-bound ones, or (extremely numerous) results of -- binding Wanted dictionaries. We definitely don't want all those cluttering -- up the Given dictionaries for pattern-match overlap checking! @@ -376,7 +384,8 @@ hsWrapDictBinders wrap = go wrap go (WpEvApp {}) = emptyBag go (WpTyLam {}) = emptyBag go (WpTyApp {}) = emptyBag - go (WpLet {}) = emptyBag + go (WpEvLet {}) = emptyBag + go (WpHsLet {}) = emptyBag go (WpMultCoercion {}) = emptyBag collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) @@ -991,7 +1000,8 @@ pprHsWrapper wrap pp_thing_inside help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <> pprParendType ty] help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] - help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] + help it (WpHsLet id rhs)= add_parens $ sep [text "let" <+> braces (ppr id <+> text "=" <+> ppr rhs), it False] + help it (WpEvLet binds)= add_parens $ sep [text "let" <+> braces (ppr binds), it False] help it (WpMultCoercion co) = add_parens $ sep [it False, nest 2 (text "<multiplicity coercion>" <+> pprParendCo co)] diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 8ffbfb959b..cd40ba4a13 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -1118,7 +1118,7 @@ tcSkolemiseScoped ctxt expected_ty thing_inside tcExtendNameTyVarEnv tv_prs $ thing_inside rho_ty - ; return (wrap <.> mkWpLet ev_binds, res) } + ; return (wrap <.> mkWpEvLet ev_binds, res) } tcSkolemise ctxt expected_ty thing_inside | isRhoTy expected_ty -- Short cut for common case @@ -1136,9 +1136,9 @@ tcSkolemise ctxt expected_ty thing_inside <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ thing_inside rho_ty - ; return (wrap <.> mkWpLet ev_binds, result) } + ; return (wrap <.> mkWpEvLet ev_binds, result) } -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op + -- often empty, in which case mkWpEvLet is a no-op -- | Variant of 'tcSkolemise' that takes an ExpType tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 2180a113da..8a208b1714 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -891,12 +891,12 @@ zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr))) zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b))) = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b -zonkExpr env (XExpr (ConLikeTc con tvs tys)) - = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys +zonkExpr env (XExpr (ConLikeTc con arg_tys)) + = XExpr . ConLikeTc con <$> mapM zonk_scale arg_tys where zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty - -- Only the multiplicity can contain unification variables - -- The tvs come straight from the data-con, and so are strictly redundant + -- Only the multiplicities can contain unification variables; + -- the types come straight from the data constructor. -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) @@ -1037,8 +1037,14 @@ zonkCoFn env (WpTyLam tv) = assert (isImmutableTyVar tv) $ ; return (env', WpTyLam tv') } zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty ; return (env, WpTyApp ty') } -zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs - ; return (env1, WpLet bs') } +zonkCoFn env (WpEvLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs + ; return (env1, WpEvLet bs') } +zonkCoFn env (WpHsLet id rhs) = do { rhs' <- zonkExpr env rhs + -- NB: important to zonk RHS first, so that + -- the 'Id' has the most up-to-date type. + ; id' <- zonkId id + ; let env' = extendIdZonkEnv env id' + ; return (env', WpHsLet id' rhs') } zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co ; return (env, WpMultCoercion co') } diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 6b7f1053b9..d1b7a03a6d 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -368,7 +368,7 @@ argument is not representation-polymorphic (which it can't be, according to Note [Representation polymorphism invariants] in GHC.Core), and it's saturated, no representation-polymorphic code ends up in the code generator. The saturation condition is effectively checked in -GHC.Tc.Gen.App.hasFixedRuntimeRep_remainingValArgs. +GHC.Tc.Gen.App.tcRemainingValArgs. However, if we make a *wrapper* for a newtype, we get into trouble. In that case, we generate a forbidden representation-polymorphic @@ -679,17 +679,19 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con | otherwise = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys - ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + ; wrap_body <- mk_rep_app (dropList stupid_theta wrap_args `zip` dropList eq_spec unboxers) initial_wrap_app + -- Drop the stupid theta arguments, as per + -- Note [Instantiating stupid theta] in GHC.Tc.Gen.Head. ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info wrap_info = noCafIdInfo - `setArityInfo` wrap_arity + `setArityInfo` wrap_arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setInlinePragInfo` wrap_prag - `setUnfoldingInfo` wrap_unf - `setDmdSigInfo` wrap_sig + `setInlinePragInfo` wrap_prag + `setUnfoldingInfo` wrap_unf + `setDmdSigInfo` wrap_sig -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane @@ -735,6 +737,7 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) = dataConFullSig data_con + stupid_theta = dataConStupidTheta data_con wrap_tvs = dataConUserTyVars data_con res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs @@ -745,7 +748,7 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con ev_ibangs = map (const HsLazy) ev_tys orig_bangs = dataConSrcBangs data_con - wrap_arg_tys = (map unrestricted theta) ++ orig_arg_tys + wrap_arg_tys = (map unrestricted $ stupid_theta ++ theta) ++ orig_arg_tys wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the @@ -784,6 +787,10 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con -- worker expects, it needs a data con wrapper to reorder -- the type variables. -- See Note [Data con wrappers and GADT syntax]. + || not (null stupid_theta) + -- If the data constructor has a datatype context, + -- we need a wrapper in order to drop the stupid arguments. + -- See Note [Instantiating stupid theta] in GHC.Tc.Gen.Head. initial_wrap_app = Var (dataConWorkId data_con) `mkTyApps` res_ty_args diff --git a/testsuite/tests/linear/should_compile/LinearDataConSections.hs b/testsuite/tests/linear/should_compile/LinearDataConSections.hs index 8a71a494c8..b00fabced5 100644 --- a/testsuite/tests/linear/should_compile/LinearDataConSections.hs +++ b/testsuite/tests/linear/should_compile/LinearDataConSections.hs @@ -14,4 +14,4 @@ foo :: Char %Many -> D foo = (True `MkD`) bar :: Bool %Many -> D -bar = (`MkD` 'y')
\ No newline at end of file +bar = (`MkD` 'y') diff --git a/testsuite/tests/rep-poly/EtaExpandDataCon.hs b/testsuite/tests/rep-poly/EtaExpandDataCon.hs index fb4618578a..9f31b7f452 100644 --- a/testsuite/tests/rep-poly/EtaExpandDataCon.hs +++ b/testsuite/tests/rep-poly/EtaExpandDataCon.hs @@ -39,7 +39,6 @@ newtype N3 a where foo3 :: (a %1 -> N3 a) -> N3 a foo3 = MkN3 - type D4 :: TYPE FloatRep -> Type -> Type data D4 a b = MkD4 a b b diff --git a/testsuite/tests/rep-poly/RepPolyMagic.stderr b/testsuite/tests/rep-poly/RepPolyMagic.stderr index f99d0c740a..47e7ba81d3 100644 --- a/testsuite/tests/rep-poly/RepPolyMagic.stderr +++ b/testsuite/tests/rep-poly/RepPolyMagic.stderr @@ -4,23 +4,15 @@ RepPolyMagic.hs:12:7: error: The second argument of ‘seq’ does not have a fixed runtime representation. Its type is: - b0 :: TYPE c1 - Cannot unify ‘r’ with the type variable ‘c1’ - because it is not a concrete ‘RuntimeRep’. + b :: TYPE r • In the expression: seq In an equation for ‘foo’: foo = seq - • Relevant bindings include - foo :: a -> b -> b (bound at RepPolyMagic.hs:12:1) RepPolyMagic.hs:15:7: error: • Unsaturated use of a representation-polymorphic primitive function. The second argument of ‘oneShot’ does not have a fixed runtime representation. Its type is: - a0 :: TYPE c0 - Cannot unify ‘r’ with the type variable ‘c0’ - because it is not a concrete ‘RuntimeRep’. + a :: TYPE r • In the expression: oneShot In an equation for ‘bar’: bar = oneShot - • Relevant bindings include - bar :: (a -> a) -> a -> a (bound at RepPolyMagic.hs:15:1) diff --git a/testsuite/tests/rep-poly/RepPolyRightSection.stderr b/testsuite/tests/rep-poly/RepPolyRightSection.stderr index fdc7a399fa..62c0bdcd8d 100644 --- a/testsuite/tests/rep-poly/RepPolyRightSection.stderr +++ b/testsuite/tests/rep-poly/RepPolyRightSection.stderr @@ -4,10 +4,6 @@ RepPolyRightSection.hs:14:11: error: The third argument of ‘rightSection’ does not have a fixed runtime representation. Its type is: - a :: TYPE c0 - Cannot unify ‘r’ with the type variable ‘c0’ - because it is not a concrete ‘RuntimeRep’. + a :: TYPE r • In the expression: `g` undefined In an equation for ‘test2’: test2 = (`g` undefined) - • Relevant bindings include - test2 :: a -> a (bound at RepPolyRightSection.hs:14:1) diff --git a/testsuite/tests/rep-poly/RepPolyTuple2.hs b/testsuite/tests/rep-poly/RepPolyTuple2.hs new file mode 100644 index 0000000000..43e590587b --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyTuple2.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +module RepPolyTuple2 where + +import GHC.Exts + +type RR :: RuntimeRep +type family RR where { RR = FloatRep } +type F :: TYPE RR +type family F where { F = Float# } + +{-# NOINLINE expensive #-} +expensive :: Float -> Float +expensive x = cos x ** 123.45 + +tup x = (# , #) @LiftedRep @RR (expensive x) diff --git a/testsuite/tests/rep-poly/RepPolyUnliftedNewtype.hs b/testsuite/tests/rep-poly/RepPolyUnliftedNewtype.hs new file mode 100644 index 0000000000..65a1fea656 --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyUnliftedNewtype.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DatatypeContexts #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnliftedNewtypes #-} + +module RepPolyUnliftedNewtype where + +import GHC.Exts +import GHC.Types (Multiplicity(..)) + +type C :: forall (r :: RuntimeRep). TYPE r -> Constraint +class C a +instance C Int# + +type N :: forall (r :: RuntimeRep). TYPE r -> TYPE r +newtype C a => N a = MkN a + +f1, f2, f3, f4, f5, f6, f7 :: Int# %Many -> N Int# +f1 = MkN +f2 = MkN @_ +f3 = MkN @IntRep +f4 = MkN @_ @_ +f5 = MkN @_ @Int# +f6 = MkN @IntRep @_ +f7 = MkN @IntRep @Int# + +g1, g2, g3, g4, g5, g6, g7 :: Int# %Many -> N Int# +g1 x = MkN x +g2 x = MkN @_ x +g3 x = MkN @IntRep x +g4 x = MkN @_ @_ x +g5 x = MkN @_ @Int# x +g6 x = MkN @IntRep @_ x +g7 x = MkN @IntRep @Int# x + +h3, h5, h6, h7 :: _ => _ %Many -> N _ +h3 = MkN @IntRep +h5 = MkN @_ @Int# +h6 = MkN @IntRep @_ +h7 = MkN @IntRep @Int# + +k1 (x :: Int#) = MkN x +k2 (x :: Int#) = MkN @_ x +k3 x = MkN @IntRep x +k4 (x :: Int#) = MkN @_ @_ x +k5 x = MkN @_ @Int# x +k6 x = MkN @IntRep @_ x +k7 x = MkN @IntRep @Int# x + +l1 = (MkN :: Int# %Many -> N Int#) diff --git a/testsuite/tests/rep-poly/T13233.stderr b/testsuite/tests/rep-poly/T13233.stderr index 5b083ea6c7..c275c5f795 100644 --- a/testsuite/tests/rep-poly/T13233.stderr +++ b/testsuite/tests/rep-poly/T13233.stderr @@ -1,24 +1,26 @@ T13233.hs:14:11: error: - • The data constructor argument in second position - does not have a fixed runtime representation. - Its type is: - b1 :: TYPE c3 - Cannot unify ‘rep’ with the type variable ‘c3’ - because it is not a concrete ‘RuntimeRep’. + • • The data constructor argument in first position + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep + • The data constructor argument in second position + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep • In the first argument of ‘bar’, namely ‘(#,#)’ In the expression: bar (#,#) In an equation for ‘baz’: baz = bar (#,#) - • Relevant bindings include - baz :: a -> a -> (# a, a #) (bound at T13233.hs:14:1) T13233.hs:22:16: error: - • The data constructor argument in second position - does not have a fixed runtime representation. - Its type is: - b0 :: TYPE c1 - Cannot unify ‘rep2’ with the type variable ‘c1’ - because it is not a concrete ‘RuntimeRep’. + • • The data constructor argument in first position + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep1 + • The data constructor argument in second position + does not have a fixed runtime representation. + Its type is: + b :: TYPE rep2 • In the first argument of ‘obscure’, namely ‘(#,#)’ In the expression: obscure (#,#) In an equation for ‘quux’: quux = obscure (#,#) diff --git a/testsuite/tests/rep-poly/T14561.stderr b/testsuite/tests/rep-poly/T14561.stderr index 8f102143eb..3c372e689c 100644 --- a/testsuite/tests/rep-poly/T14561.stderr +++ b/testsuite/tests/rep-poly/T14561.stderr @@ -4,10 +4,6 @@ T14561.hs:12:9: error: The first argument of ‘unsafeCoerce#’ does not have a fixed runtime representation. Its type is: - a0 :: TYPE c0 - Cannot unify ‘r’ with the type variable ‘c0’ - because it is not a concrete ‘RuntimeRep’. + a :: TYPE r • In the expression: unsafeCoerce# In an equation for ‘badId’: badId = unsafeCoerce# - • Relevant bindings include - badId :: a -> a (bound at T14561.hs:12:1) diff --git a/testsuite/tests/rep-poly/T14561b.stderr b/testsuite/tests/rep-poly/T14561b.stderr index bbc72d01d8..7af3b05511 100644 --- a/testsuite/tests/rep-poly/T14561b.stderr +++ b/testsuite/tests/rep-poly/T14561b.stderr @@ -4,10 +4,6 @@ T14561b.hs:12:9: error: The first argument of ‘coerce’ does not have a fixed runtime representation. Its type is: - a0 :: TYPE c0 - Cannot unify ‘r’ with the type variable ‘c0’ - because it is not a concrete ‘RuntimeRep’. + a :: TYPE r • In the expression: coerce In an equation for ‘badId’: badId = coerce - • Relevant bindings include - badId :: a -> a (bound at T14561b.hs:12:1) diff --git a/testsuite/tests/rep-poly/T17817.stderr b/testsuite/tests/rep-poly/T17817.stderr index 4fb45622bc..7acdec120a 100644 --- a/testsuite/tests/rep-poly/T17817.stderr +++ b/testsuite/tests/rep-poly/T17817.stderr @@ -4,15 +4,6 @@ T17817.hs:16:10: error: The first argument of ‘mkWeak#’ does not have a fixed runtime representation. Its type is: - a0 :: TYPE ('BoxedRep c0) - Cannot unify ‘l’ with the type variable ‘c0’ - because it is not a concrete ‘Levity’. + a :: TYPE ('BoxedRep l) • In the expression: mkWeak# In an equation for ‘primop’: primop = mkWeak# - • Relevant bindings include - primop :: a - -> b - -> (State# RealWorld -> (# State# RealWorld, c #)) - -> State# RealWorld - -> (# State# RealWorld, Weak# b #) - (bound at T17817.hs:16:1) diff --git a/testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr b/testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr index db08ac81d8..ba92961bcb 100644 --- a/testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr +++ b/testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr @@ -4,10 +4,6 @@ UnliftedNewtypesCoerceFail.hs:15:8: error: The first argument of ‘coerce’ does not have a fixed runtime representation. Its type is: - a0 :: TYPE c0 - Cannot unify ‘rep’ with the type variable ‘c0’ - because it is not a concrete ‘RuntimeRep’. + x :: TYPE rep • In the expression: coerce In an equation for ‘goof’: goof = coerce - • Relevant bindings include - goof :: x -> y (bound at UnliftedNewtypesCoerceFail.hs:15:1) diff --git a/testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr b/testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr index 41dbd44d3f..f4e7c62b46 100644 --- a/testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr +++ b/testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr @@ -3,10 +3,6 @@ UnliftedNewtypesLevityBinder.hs:16:7: error: • The newtype constructor argument does not have a fixed runtime representation. Its type is: - a0 :: TYPE c0 - Cannot unify ‘r’ with the type variable ‘c0’ - because it is not a concrete ‘RuntimeRep’. + a :: TYPE r • In the expression: IdentC In an equation for ‘bad’: bad = IdentC - • Relevant bindings include - bad :: a -> Ident a (bound at UnliftedNewtypesLevityBinder.hs:16:1) diff --git a/testsuite/tests/rep-poly/all.T b/testsuite/tests/rep-poly/all.T index c37289e568..0156b63a7c 100644 --- a/testsuite/tests/rep-poly/all.T +++ b/testsuite/tests/rep-poly/all.T @@ -83,6 +83,8 @@ test('RepPolyTupleSection', normal, compile_fail, ['']) test('RepPolyUnboxedPatterns', normal, compile_fail, ['']) test('RepPolyUnliftedDatatype', normal, compile, ['']) test('RepPolyUnliftedDatatype2', normal, compile, ['-O']) +test('RepPolyUnliftedNewtype', normal, compile, + ['-fno-warn-partial-type-signatures -fno-warn-deprecated-flags']) test('RepPolyWildcardPattern', normal, compile_fail, ['']) test('RepPolyWrappedVar', normal, compile_fail, ['']) test('RepPolyWrappedVar2', normal, compile, ['']) @@ -110,4 +112,5 @@ test('T20363_show_co', normal, compile_fail ## test('T20363b', normal, compile_fail, ['']) ## test('RepPolyCase2', normal, compile_fail, ['']) ## test('RepPolyRule3', normal, compile_fail, ['']) ## +test('RepPolyTuple2', normal, compile_fail, ['']) ## see #21683 ## ###################################################################### |