diff options
96 files changed, 1064 insertions, 616 deletions
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 041be10e3b..27375c5fe3 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -150,6 +150,7 @@ optCoercion' env co where lc = mkSubstLiftingContext env + type NormalCo = Coercion -- Invariants: -- * The substitution has been fully applied diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index adf8124b12..b9ca990f3d 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -634,7 +634,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- Check the let/app invariant -- See Note [Core let/app invariant] in GHC.Core ; checkL ( isJoinId binder - || not (isUnliftedType binder_ty) + || mightBeLiftedType binder_ty || (isNonRec rec_flag && exprOkForSpeculation rhs) || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed || exprIsTickedString rhs) @@ -1280,14 +1280,14 @@ lintCoreArg (fun_ty, fun_ue) arg ; flags <- getLintFlags ; when (lf_check_fixed_rep flags) $ - -- Only do these checks if lf_check_fixed_rep is on, - -- because otherwise isUnliftedType panics + -- Only check that 'arg_ty' has a fixed RuntimeRep + -- if 'lf_check_fixed_rep' is on. do { checkL (typeHasFixedRuntimeRep arg_ty) (text "Argument does not have a fixed runtime representation" <+> ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) - ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) + ; checkL (mightBeLiftedType arg_ty || exprOkForSpeculation arg) (mkLetAppMsg arg) } ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 2dafaf8e0b..f136aba04a 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -352,7 +352,7 @@ dmdAnalStar env (n :* sd) e -- NB: (:*) expands AbsDmd and BotDmd as needed -- See Note [Analysing with absent demand] | WithDmdType dmd_ty e' <- dmdAnal env sd e - = assertPpr (not (isUnliftedType (exprType e)) || exprOkForSpeculation e) (ppr e) + = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e) -- The argument 'e' should satisfy the let/app invariant (toPlusDmdArg $ multDmdType n dmd_ty, e') diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index abd56abdf0..ed62d3dfb2 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -27,7 +27,7 @@ import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Type -import GHC.Types.Basic ( RecFlag(..), isRec ) +import GHC.Types.Basic ( RecFlag(..), isRec, Levity(Unlifted) ) import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var @@ -448,6 +448,7 @@ bindings are: fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) | isUnliftedType (idType case_bndr) + -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType , exprOkForSideEffects (deAnnotate scrut) -- See Note [Floating primops] = wrapFloats shared_binds $ @@ -592,7 +593,7 @@ noFloatIntoRhs is_rec bndr rhs noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool noFloatIntoArg expr expr_ty - | isUnliftedType expr_ty + | Just Unlifted <- typeLevity_maybe expr_ty = True -- See Note [Do not destroy the let/app invariant] | AnnLam bndr e <- expr diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index 1a88c97d55..19b687a4a3 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -269,6 +269,8 @@ splitRecFloats fs = go [] [] (bagToList fs) where go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b) + -- NB: isUnliftedType is OK here as binders always + -- have a fixed RuntimeRep. , not (isJoinId b) = go ((b,r):ul_prs) prs fs | otherwise diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index f77411e0b1..3c3854bf41 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -574,25 +574,40 @@ When we transform to Its not wrong to drop it on the floor, but better to keep it. -Note [Cast w/w: unlifted] -~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT don't do cast worker/wrapper if 'e' has an unlifted type. -This *can* happen: +Note [Preserve RuntimeRep info in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not do cast w/w when the presence of the coercion is needed in order +to determine the runtime representation. + +Example: + + Suppose we have a type family: + + type F :: RuntimeRep + type family F where + F = LiftedRep + + together with a type `ty :: TYPE F` and a top-level binding + + a :: ty |> TYPE F[0] + + The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding. + However, were we to apply cast w/w, we would get: - foo :: Int = (error (# Int,Int #) "urk") - `cast` CoUnsafe (# Int,Int #) Int + b :: ty + b = ... -If do the makeTrivial thing to the error call, we'll get - foo = case error (# Int,Int #) "urk" of v -> v `cast` ... -But 'v' isn't in scope! + a :: ty |> TYPE F[0] + a = b `cast` GRefl (TYPE F[0]) -These strange casts can happen as a result of case-of-case - bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of - (# p,q #) -> p+q + Now we are in trouble because `ty :: TYPE F` does not have a known runtime + representation, because we need to be able to reduce the nullary type family + application `F` to find that out. -NOTE: Nowadays we don't use casts for these error functions; -instead, we use (case erorr ... of {}). So I'm not sure -this Note makes much sense any more. +Conclusion: only do cast w/w when doing so would not lose the RuntimeRep +information. That is, when handling `Cast rhs co`, don't attempt cast w/w +unless the kind of the type of rhs is concrete, in the sense of +Note [Concrete types] in GHC.Tc.Utils.Concrete. -} tryCastWorkerWrapper :: SimplEnv -> TopLevelFlag @@ -606,8 +621,9 @@ tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co) -- a DFunUnfolding in mk_worker_unfolding , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 - , not (isUnliftedType rhs_ty) -- Not if rhs has an unlifted type; - -- see Note [Cast w/w: unlifted] + , isConcrete (typeKind rhs_ty) -- Don't peel off a cast if doing so would + -- lose the underlying runtime representation. + -- See Note [Preserve RuntimeRep info in cast w/w] = do { (rhs_floats, work_rhs) <- prepareRhs env top_lvl occ_fs rhs ; uniq <- getUniqueM ; let work_name = mkSystemVarName uniq occ_fs @@ -2850,6 +2866,7 @@ doCaseToLet scrut case_bndr = 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 | otherwise -- Scrut has a lifted type diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 54a5f171ec..cb3e1854d5 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -526,6 +526,8 @@ unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ -- See Note [Core top-level string literals] in GHC.Core. | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) | otherwise = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr) + -- NB: binders always have a fixed RuntimeRep, so calling + -- isUnliftedType is OK here FltCareful -- Unlifted binders can only be let-bound if exprOkForSpeculation holds diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index ec26ba89fb..4ed22d2914 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -590,21 +590,14 @@ mkArgInfo env fun rules n_val_args call_cont | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info , dmd : rest_dmds <- dmds , let dmd' - -- TODO: we should just use isLiftedType_maybe, but that - -- function is currently wrong (#20837). - | Just rr <- getRuntimeRep_maybe arg_ty - , Just False <- isLiftedRuntimeRep_maybe rr - -- The type is definitely unlifted, such as: - -- - TYPE (BoxedRep Unlifted) - -- - TYPE IntRep, TYPE FloatRep, ... + | Just Unlifted <- typeLevity_maybe arg_ty = strictifyDmd dmd | otherwise - -- Could be definitely lifted, or we're not sure (e.g. levity-polymorphic). + -- Something that's not definitely unlifted. + -- If the type is representation-polymorphic, we can't know whether + -- it's strict. = dmd = dmd' : add_type_strictness fun_ty' rest_dmds - -- If the type is representation-polymorphic, we can't know whether - -- it's strict. isLiftedType_maybe will return Just False only when - -- we're sure the type is unlifted. | otherwise = dmds diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index d973c75570..aec343508e 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -2458,7 +2458,7 @@ setStrUnfolding id str | not (isId id) || isEvaldUnfolding (idUnfolding id) = id | isMarkedStrict str - , not (isUnliftedType (idType id)) -- Pointless to stick an evald unfolding on unlifted types + , not $ isUnliftedType (idType id) -- Pointless to stick an evald unfolding on unlifted types = -- trace "setStrUnfolding2" $ assert (isId id) $ assert (not $ hasCoreUnfolding $ idUnfolding id) $ diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index c62ba572de..06a7e91eae 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -630,6 +630,7 @@ wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd) , isStrUsedDmd dmd , not (isFunTy ty) , not (isUnliftedType ty) -- Already unlifted! + -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here = Unlift | otherwise @@ -915,7 +916,7 @@ mkAbsentFiller :: WwOpts -> Id -> Maybe CoreExpr mkAbsentFiller opts arg -- The lifted case: Bind 'absentError' for a nice panic message if we are -- wrong (like we were in #11126). See (1) in Note [Absent fillers] - | not (isUnliftedType arg_ty) + | mightBeLiftedType arg_ty , not is_strict, not is_evald -- See (2) in Note [Absent fillers] = Just (mkAbsentErrorApp arg_ty msg) diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index c3aeb87c27..39cafc46e2 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -59,7 +59,9 @@ data PatSyn psName :: Name, psUnique :: Unique, -- Cached from Name - psArgs :: [Type], + psArgs :: [Type], -- ^ Argument types. + -- These always have a fixed RuntimeRep as per + -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. psArity :: Arity, -- == length psArgs psInfix :: Bool, -- True <=> declared infix psFieldLabels :: [FieldLabel], -- List of fields for a @@ -381,6 +383,8 @@ mkPatSyn :: Name -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type -- variables and provided dicts -> [Type] -- ^ Original arguments + -- These must have a fixed RuntimeRep as per + -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -> Type -- ^ Original result type -> PatSynMatcher -- ^ Matcher -> PatSynBuilder -- ^ Builder diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index c71bbdfc9e..6adf7c7a34 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -121,12 +121,13 @@ module GHC.Core.Type ( tyConAppNeedsKindSig, -- *** Levity and boxity - isLiftedType_maybe, + typeLevity_maybe, isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, isLiftedRuntimeRep_maybe, + isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, isBoxedRuntimeRep, isLiftedLevity, isUnliftedLevity, - isUnliftedType, isBoxedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, + isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType, + mightBeLiftedType, mightBeUnliftedType, isStateType, isAlgType, isDataFamilyAppType, isPrimitiveType, isStrictType, @@ -733,25 +734,25 @@ isBoxedRuntimeRep_maybe rep -- -- @isLiftedRuntimeRep rr@ returns: -- --- * @Just True @ if @rr@ is @LiftedRep :: RuntimeRep@ --- * @Just False@ if @rr@ is definitely not lifted, e.g. @IntRep@ --- * @Nothing @ if not known (e.g. it's a type variable or a type family application). -isLiftedRuntimeRep_maybe :: Type -> Maybe Bool -isLiftedRuntimeRep_maybe rep +-- * @Just Lifted@ if @rr@ is @LiftedRep :: RuntimeRep@ +-- * @Just Unlifted@ if @rr@ is definitely unlifted, e.g. @IntRep@ +-- * @Nothing@ if not known (e.g. it's a type variable or a type family application). +runtimeRepLevity_maybe :: Type -> Maybe Levity +runtimeRepLevity_maybe rep | TyConApp rr_tc args <- coreFullView rep , isPromotedDataCon rr_tc = -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] if (rr_tc `hasKey` boxedRepDataConKey) then case args of - [lev] | isLiftedLevity lev -> Just True - | isUnliftedLevity lev -> Just False + [lev] | isLiftedLevity lev -> Just Lifted + | isUnliftedLevity lev -> Just Unlifted _ -> Nothing - else Just False + else Just Unlifted -- Avoid searching all the unlifted RuntimeRep type cons -- In the RuntimeRep data type, only LiftedRep is lifted -- But be careful of type families (F tys) :: RuntimeRep, -- hence the isPromotedDataCon rr_tc -isLiftedRuntimeRep_maybe _ = Nothing +runtimeRepLevity_maybe _ = Nothing -- | Check whether a type of kind 'RuntimeRep' is lifted. -- @@ -761,11 +762,8 @@ isLiftedRuntimeRep_maybe _ = Nothing -- * False of type variables, type family applications, -- and of other reps such as @IntRep :: RuntimeRep@. isLiftedRuntimeRep :: Type -> Bool -isLiftedRuntimeRep rep - | Just True <- isLiftedRuntimeRep_maybe rep - = True - | otherwise - = False +isLiftedRuntimeRep rep = + runtimeRepLevity_maybe rep == Just Lifted -- | Check whether a type of kind 'RuntimeRep' is unlifted. -- @@ -774,11 +772,8 @@ isLiftedRuntimeRep rep -- * False of 'LiftedRep', -- * False for type variables and type family applications. isUnliftedRuntimeRep :: Type -> Bool -isUnliftedRuntimeRep rep - | Just False <- isLiftedRuntimeRep_maybe rep - = True - | otherwise - = False +isUnliftedRuntimeRep rep = + runtimeRepLevity_maybe rep == Just Unlifted -- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'. -- @@ -2453,18 +2448,17 @@ buildSynTyCon name binders res_kind roles rhs ************************************************************************ -} --- | Returns Just True if this type is surely lifted, Just False --- if it is surely unlifted, Nothing if we can't be sure (i.e., it is --- representation-polymorphic), and panics if the kind does not have the shape --- TYPE r. -isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool -isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of - ty' | isLiftedRuntimeRep ty' -> Just True - | isUnliftedRuntimeRep ty' -> Just False - TyConApp {} -> Just False -- Everything else is unlifted - _ -> Nothing -- representation-polymorphic - --- | See "Type#type_classification" for what an unlifted type is. +-- | Tries to compute the 'Levity' of the given type. Returns either +-- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the +-- type is representation-polymorphic). +-- +-- Panics if the kind does not have the shape @TYPE r@. +typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity +typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) + +-- | Is the given type definitely unlifted? +-- See "Type#type_classification" for what an unlifted type is. +-- -- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for -- a more approximate predicate that behaves better in the presence of -- representation polymorphism. @@ -2474,9 +2468,12 @@ isUnliftedType :: HasDebugCallStack => Type -> Bool -- I found bindings like these were getting floated to the top level. -- They are pretty bogus types, mind you. It would be better never to -- construct them -isUnliftedType ty - = not (isLiftedType_maybe ty `orElse` - pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) +isUnliftedType ty = + case typeLevity_maybe ty of + Just Lifted -> False + Just Unlifted -> True + Nothing -> + pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)) -- | State token type. isStateType :: Type -> Bool @@ -2487,14 +2484,19 @@ isStateType ty -- | Returns: -- +-- * 'False' if the type is /guaranteed/ unlifted or +-- * 'True' if it lifted, OR we aren't sure +-- (e.g. in a representation-polymorphic case) +mightBeLiftedType :: Type -> Bool +mightBeLiftedType = mightBeLifted . typeLevity_maybe + +-- | Returns: +-- -- * 'False' if the type is /guaranteed/ lifted or -- * 'True' if it is unlifted, OR we aren't sure -- (e.g. in a representation-polymorphic case) mightBeUnliftedType :: Type -> Bool -mightBeUnliftedType ty - = case isLiftedType_maybe ty of - Just is_lifted -> not is_lifted - Nothing -> True +mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe -- | See "Type#type_classification" for what a boxed type is. -- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index c341107957..3dba991bed 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -522,7 +522,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr -- unboxed variables, inline primops and unsafe foreign calls -- are all "inline" things: - is_inline_scrut (Var v) = isUnliftedType (idType v) + is_inline_scrut (Var v) = + isUnliftedType (idType v) + -- isUnliftedType is OK here: scrutinees have a fixed RuntimeRep (search for FRRCase) is_inline_scrut scrut | (Var f, _) <- collectArgs scrut = case idDetails f of @@ -581,6 +583,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr | isTyVar bndr -- Doesn't exist at runtime || isJoinId bndr -- Not allocated at all || isUnliftedType (idType bndr) -- Doesn't live in heap + -- OK to call isUnliftedType: binders have a fixed RuntimeRep (search for FRRBinder) = 0 | otherwise = 10 diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 03e2ecee55..da13a346d8 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -96,7 +96,8 @@ import GHC.Types.Tickish import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Unique -import GHC.Types.Basic ( Arity, CbvMark(..), isMarkedCbv ) +import GHC.Types.Basic ( Arity, CbvMark(..), Levity(..) + , isMarkedCbv ) import GHC.Types.Unique.Set import GHC.Data.FastString @@ -524,7 +525,8 @@ bindNonRec bndr rhs body -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression -- as per the invariants of 'CoreExpr': see "GHC.Core#let_app_invariant" needsCaseBinding :: Type -> CoreExpr -> Bool -needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) +needsCaseBinding ty rhs = + mightBeUnliftedType ty && not (exprOkForSpeculation rhs) -- Make a case expression instead of a let -- These can arise either from the desugarer, -- or from beta reductions: (\x.e) (x +# y) @@ -1590,6 +1592,7 @@ expr_ok primop_ok (Case scrut bndr _ alts) = -- See Note [exprOkForSpeculation: case expressions] expr_ok primop_ok scrut && isUnliftedType (idType bndr) + -- OK to call isUnliftedType: binders always have a fixed RuntimeRep && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts && altsAreExhaustive alts @@ -1646,7 +1649,7 @@ app_ok primop_ok fun args _ -- Unlifted types -- c.f. the Var case of exprIsHNF - | isUnliftedType (idType fun) + | Just Unlifted <- typeLevity_maybe (idType fun) -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args) True -- Our only unlifted types are Int# etc, so will have -- no value args. The assert is just to check this. @@ -1671,8 +1674,10 @@ app_ok primop_ok fun args primop_arg_ok :: TyBinder -> CoreExpr -> Bool primop_arg_ok (Named _) _ = True -- A type argument primop_arg_ok (Anon _ ty) arg -- A term argument - | isUnliftedType (scaledThing ty) = expr_ok primop_ok arg - | otherwise = True -- See Note [Primops with lifted arguments] + | Just Lifted <- typeLevity_maybe (scaledThing ty) + = True -- See Note [Primops with lifted arguments] + | otherwise + = expr_ok primop_ok arg ----------------------------- altsAreExhaustive :: [Alt b] -> Bool @@ -1917,7 +1922,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like -- We don't look through loop breakers here, which is a bit conservative -- but otherwise I worry that if an Id's unfolding is just itself, -- we could get an infinite loop - || isUnliftedType (idType v) + || ( typeLevity_maybe (idType v) == Just Unlifted ) -- Unlifted binders are always evaluated (#20140) is_hnf_like (Lit l) = not (isLitRubbish l) @@ -2684,15 +2689,20 @@ computeCbvInfo id rhs = map fst . -- Starting at the end, drop all non-cbv marks, and marks applied to unlifted types dropWhileEndLE (\(m,v) -> not (isMarkedCbv m) || isUnliftedType (idType v)) $ + -- NB: function arguments must have a fixed RuntimeRep, so isUnliftedType can't crash. zip marks val_args mkCbvMarks :: ([Id]) -> [CbvMark] mkCbvMarks = map mkMark where cbv_arg arg = isEvaldUnfolding (idUnfolding arg) - mkMark arg = if cbv_arg arg && (not $ isUnliftedType (idType arg)) - then MarkedCbv - else NotMarkedCbv + mkMark arg + | cbv_arg arg + , not $ isUnliftedType (idType arg) + -- NB: isUnliftedType can't crash here as function arguments have a fixed RuntimeRep + = MarkedCbv + | otherwise + = NotMarkedCbv -- If we determined earlier one an argument should be passed cbv it should -- still be so here. checkMarks id new_marks diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 050fa53d30..51306d627c 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -991,6 +991,8 @@ isUnliftedHsBind bind = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind) where is_unlifted_id id = isUnliftedType (idType id) + -- bindings always have a fixed RuntimeRep, so it's OK + -- to call isUnliftedType here -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? isBangedHsBind :: HsBind GhcTc -> Bool diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 93694c4750..e06f7b09f8 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -1230,7 +1230,7 @@ mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] -> TM CoreTickish mkTickish boxLabel countEntries topOnly pos fvs decl_path = do - let ids = filter (not . isUnliftedType . idType) $ nonDetOccEnvElts fvs + let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs -- unlifted types cause two problems here: -- * we can't bind them at the GHCi prompt -- (bindLocalsAtBreakpoint already filters them out), diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index c9e6ef050d..b510281dbd 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -161,6 +161,7 @@ ds_val_bind (is_rec, binds) body ; (force_vars,prs) <- dsLHsBinds binds ; let body' = foldr seqVar body force_vars ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $ + -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType case prs of [] -> return body _ -> return (Let (Rec prs) body') } diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 3575dda036..6f9118604d 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -820,6 +820,8 @@ getPrimTyOf ty Just (_, _, data_con, [Scaled _ prim_ty]) -> assert (dataConSourceArity data_con == 1) $ assertPpr (isUnliftedType prim_ty) (ppr prim_ty) + -- NB: it's OK to call isUnliftedType here, as we don't allow + -- representation-polymorphic types in foreign import/export declarations prim_ty _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty) where diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 7719e14192..8fcb150329 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -450,6 +450,7 @@ tidy1 v _ (LazyPat _ pat) -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) + -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType ; unless (null unlifted_bndrs) $ putSrcSpanDs (getLocA pat) $ diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index b19ce0c475..7b0986e6f0 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -46,6 +46,7 @@ import GHC.Utils.Monad (allM) import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.Bag +import GHC.Types.Basic (Levity(..)) import GHC.Types.CompleteMatch import GHC.Types.Unique.Set import GHC.Types.Unique.DSet @@ -674,7 +675,7 @@ addPhiTmCt nabla (PhiNotBotCt x) = addNotBotCt nabla x filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args = [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con) - , isBanged bang || isUnliftedType (idType arg) ] + , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ] -- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ -- surely diverges. Quite similar to 'addConCt', only that it only cares about @@ -685,11 +686,12 @@ addBotCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x = do case bot of IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction! IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do - MaybeBot -> -- We add x ~ ⊥ + MaybeBot -- We add x ~ ⊥ + | Just Unlifted <- typeLevity_maybe (idType x) -- Case (3) in Note [Strict fields and variables of unlifted type] - if isUnliftedType (idType x) - then mzero -- unlifted vars can never be ⊥ - else do + -> mzero -- unlifted vars can never be ⊥ + | otherwise + -> do let vi' = vi{ vi_bot = IsBot } pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } } @@ -1355,15 +1357,13 @@ isDataConTriviallyInhabited :: DataCon -> Bool isDataConTriviallyInhabited dc | isTyConTriviallyInhabited (dataConTyCon dc) = True isDataConTriviallyInhabited dc = - null (dataConTheta dc) && -- (1) - null (dataConImplBangs dc) && -- (2) - null (dataConUnliftedFieldTys dc) -- (3) + null (dataConTheta dc) && -- (1) + null (dataConImplBangs dc) && -- (2) + null (dataConMightBeUnliftedFieldTys dc) -- (3) -dataConUnliftedFieldTys :: DataCon -> [Type] -dataConUnliftedFieldTys = - -- A representation-polymorphic field requires an inhabitation test, hence compare to - -- @Just True@ - filter ((== Just True) . isLiftedType_maybe) . map scaledThing . dataConOrigArgTys +dataConMightBeUnliftedFieldTys :: DataCon -> [Type] +dataConMightBeUnliftedFieldTys = + filter mightBeUnliftedType . map scaledThing . dataConOrigArgTys isTyConTriviallyInhabited :: TyCon -> Bool isTyConTriviallyInhabited tc = elementOfUniqSet (getUnique tc) triviallyInhabitedTyConKeys @@ -1401,7 +1401,7 @@ compareConLikeTestability (RealDataCon a) (RealDataCon b) = mconcat -- the unlikely bogus case of an unlifted field that has a bang. unlifted_or_strict_fields :: DataCon -> Int unlifted_or_strict_fields dc = fast_length (dataConImplBangs dc) - + fast_length (dataConUnliftedFieldTys dc) + + fast_length (dataConMightBeUnliftedFieldTys dc) -- | @instCon fuel nabla (x::match_ty) K@ tries to instantiate @x@ to @K@ by -- adding the proper constructor constraint. diff --git a/compiler/GHC/Stg/BcPrep.hs b/compiler/GHC/Stg/BcPrep.hs index c1fd67d484..d167a8c791 100644 --- a/compiler/GHC/Stg/BcPrep.hs +++ b/compiler/GHC/Stg/BcPrep.hs @@ -126,8 +126,7 @@ bcPrep us bnds = evalState (mapM bcPrepTopLvl bnds) (BcPrepM_State us) -- Is this Id a not-necessarily-lifted join point? -- See Note [Not-necessarily-lifted join points], step 1 isNNLJoinPoint :: Id -> Bool -isNNLJoinPoint x = isJoinId x && - Just True /= isLiftedType_maybe (idType x) +isNNLJoinPoint x = isJoinId x && mightBeUnliftedType (idType x) -- Update an Id's type to take a Void# argument. -- Precondition: the Id is a not-necessarily-lifted join point. diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index dde32082e6..6240de3205 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -183,7 +183,7 @@ canDoGenerics dit@(DerivInstTys{dit_rep_tc = tc}) -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) - bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty)) + bad_arg_type ty = (mightBeUnliftedType ty && not (allowedUnliftedTy ty)) || not (isTauTy ty) -- Returns True the Type argument is an unlifted type which has a diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 5fe1f6b185..d25db38be0 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -911,7 +911,7 @@ cond_args cls _ dit@(DerivInstTys{dit_rep_tc = rep_tc}) where bad_args = [ arg_ty | con <- tyConDataCons rep_tc , arg_ty <- derivDataConInstArgTys con dit - , isLiftedType_maybe arg_ty /= Just True + , mightBeUnliftedType arg_ty , not (ok_ty arg_ty) ] cls_key = classKey cls diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index f6e71f57cf..ad78cfaf76 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1741,8 +1741,43 @@ pprTcSolverReportMsg _ (FixedRuntimeRepError frr_infos) = (if length frr_infos > 1 then (bullet <+>) else id) $ vcat [ sep [ pprFRROrigin frr_orig , text "does not have a fixed runtime representation." ] - , text "Its type is:" - , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ] + , type_printout ty ] + + -- Don't print out the type (only the kind), if the type includes + -- a confusing cast, unless the user passed -fprint-explicit-coercions. + -- + -- Example: + -- + -- In T20363, we have a representation-polymorphism error with a type + -- of the form + -- + -- ( (# #) |> co ) :: TYPE NilRep + -- + -- where NilRep is a nullary type family application which reduces to TupleRep '[]. + -- We prefer avoiding showing the cast to the user, but we also don't want to + -- print the confusing: + -- + -- (# #) :: TYPE NilRep + -- + -- So in this case we simply don't print the type, only the kind. + confusing_cast :: Type -> Bool + confusing_cast ty = + case ty of + CastTy inner_ty _ + -- A confusing cast is one that is responsible + -- for a representation-polymorphism error. + -> isConcrete (typeKind inner_ty) + _ -> False + + type_printout :: Type -> SDoc + type_printout ty = + sdocOption sdocPrintExplicitCoercions $ \ show_coercions -> + if confusing_cast ty && not show_coercions + then vcat [ text "Its kind is:" + , nest 2 $ pprWithTYPE (typeKind ty) + , text "(Use -fprint-explicit-coercions to see the full type.)" ] + else vcat [ text "Its type is:" + , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ] -- In PHASE 1 of FixedRuntimeRep, we don't allow rewriting in hasFixedRuntimeRep, -- so we add a special message to explain this to the user. diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index ddf94f1410..743587ed25 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -22,7 +22,7 @@ module GHC.Tc.Gen.App import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Types.Basic ( Arity ) +import GHC.Types.Basic ( Arity, ExprOrPat(Expression) ) import GHC.Types.Id ( idArity, idName, hasNoBinding ) import GHC.Types.Name ( isWiredInName ) import GHC.Types.Var @@ -547,7 +547,7 @@ hasFixedRuntimeRep_remainingValArgs applied_args app_res_rho = \case -- (4): Unboxed tuples and unboxed sums || isUnboxedTupleDataCon con || isUnboxedSumDataCon con - -> check_thing con (dataConRepArity con) (FRRDataConArg con) + -> check_thing con (dataConRepArity con) (FRRDataConArg Expression con) _ -> return () @@ -673,12 +673,11 @@ tcValArgs do_ql args ; return (eva { eva_arg = ValArg arg' , eva_arg_ty = Scaled mult arg_ty }) } -tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc) +tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaTypeFRR -> TcM (LHsExpr GhcTc) -- Typecheck one value argument of a function call tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma = addArgCtxt ctxt larg $ do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma) - ; hasFixedRuntimeRep_MustBeRefl (FRRApp arg') exp_arg_sigma ; return (L arg_loc arg') } tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _) @@ -690,7 +689,6 @@ tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _) ; 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 - ; hasFixedRuntimeRep_MustBeRefl (FRRApp arg') exp_arg_sigma ; traceTc "tcEValArgQL }" empty ; return (L arg_loc arg') } @@ -741,9 +739,6 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args VAExpansion orig _ -> addExprCtxt orig thing_inside VACall {} -> thing_inside - herald = sep [ text "The function" <+> quotes (ppr rn_fun) - , text "is applied to"] - -- Count value args only when complaining about a function -- applied to too many value args -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. @@ -776,8 +771,8 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args ----------- go, go1 :: Delta - -> [HsExprArg 'TcpInst] -- Accumulator, reversed - -> [Scaled TcSigmaType] -- Value args to which applied so far + -> [HsExprArg 'TcpInst] -- Accumulator, reversed + -> [Scaled TcSigmaTypeFRR] -- Value args to which applied so far -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType) @@ -873,10 +868,12 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IARG from Fig 4 of the QL paper: go1 delta acc so_far fun_ty - (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args) - = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald - (Just $ HsExprRnThing rn_fun) - (n_val_args, so_far) fun_ty + (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args) + = do { (wrap, arg_ty, res_ty) <- + matchActualFunTySigma + (ExpectedFunTyArg (HsExprRnThing rn_fun) (unLoc arg)) + (Just $ HsExprRnThing rn_fun) + (n_val_args, so_far) fun_ty ; (delta', arg') <- if do_ql then addArgCtxt ctxt arg $ -- Context needed for constraints @@ -1053,8 +1050,8 @@ Wrinkles: ---------------- quickLookArg :: Delta - -> LHsExpr GhcRn -- Argument - -> Scaled TcSigmaType -- Type expected by the function + -> LHsExpr GhcRn -- ^ Argument + -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function -> TcM (Delta, EValArg 'TcpInst) -- See Note [Quick Look at value arguments] -- @@ -1093,7 +1090,7 @@ isGuardedTy ty | Just {} <- tcSplitAppTy_maybe ty = True | otherwise = False -quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaType +quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR -> TcM (Delta, EValArg 'TcpInst) quickLookArg1 guarded delta larg@(L _ arg) arg_ty = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index dd3d19dfab..ad4b67ee88 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -163,12 +163,18 @@ tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do (scrut', scrut_ty) <- tcInferRho scrut + hasFixedRuntimeRep_MustBeRefl + (FRRArrow $ ArrowCmdCase { isCmdLamCase = False }) + scrut_ty matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty) return (HsCmdCase x scrut' matches') tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk + hasFixedRuntimeRep_MustBeRefl + (FRRArrow $ ArrowCmdCase { isCmdLamCase = True }) + scrut_ty matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty) return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches')) @@ -365,7 +371,9 @@ tc_cmd _ cmd _ -- | Typechecking for case command alternatives. Used for both -- 'HsCmdCase' and 'HsCmdLamCase'. tcCmdMatches :: CmdEnv - -> TcType -- ^ type of the scrutinee + -> TcType -- ^ Type of the scrutinee. + -- Must have a fixed RuntimeRep as per + -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete -> MatchGroup GhcRn (LHsCmd GhcRn) -- ^ case alternatives -> CmdType -> TcM (MatchGroup GhcTc (LHsCmd GhcTc)) diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index a14ff790fa..3adbb1b0d6 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -1212,7 +1212,7 @@ tcMonoBinds is_rec sig_fn no_gen do { (grhss', pat_ty) <- tcInfer $ \ exp_ty -> tcGRHSsPat grhss exp_ty - ; let exp_pat_ty :: Scaled ExpSigmaType + ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR exp_pat_ty = unrestricted (mkCheckExpType pat_ty) ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $ mapM lookupMBI bndrs @@ -1342,7 +1342,7 @@ mono_id in the first place. data TcMonoBind -- Half completed; LHS done, RHS not done = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn)) - TcSigmaType + TcSigmaTypeFRR tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- Only called with plan InferGen (LetBndrSpec = LetLclBndr) diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 189eb989c5..3043bed44c 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -40,7 +40,7 @@ import GHC.Types.Error import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl, mkWpFun ) +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head @@ -262,22 +262,15 @@ tcExpr (HsLam _ match) res_ty ; return (mkHsWrap wrap (HsLam noExtField match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = sep [ text "The lambda expression" <+> - quotes (pprSetDepth (PartWay 1) $ - pprMatches match), - -- The pprSetDepth makes the abstraction print briefly - text "has"] + herald = ExpectedFunTyLam match tcExpr e@(HsLamCase x matches) res_ty = do { (wrap, matches') - <- tcMatchLambda msg match_ctxt matches res_ty - -- The laziness annotation is because we don't want to fail here - -- if there are multiple arguments + <- tcMatchLambda herald match_ctxt matches res_ty ; return (mkHsWrap wrap $ HsLamCase x matches') } where - msg = sep [ text "The function" <+> quotes (ppr e) - , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } + herald = ExpectedFunTyLamCase e @@ -391,6 +384,7 @@ tcExpr (HsCase x scrut matches) res_ty ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut ; traceTc "HsCase" (ppr scrut_ty) + ; hasFixedRuntimeRep_MustBeRefl FRRCase scrut_ty ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty ; return (HsCase x scrut' matches') } where @@ -945,7 +939,12 @@ arithSeqEltType (Just fl) res_ty ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } ---------------- -tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc] +tcTupArgs :: [HsTupArg GhcRn] + -> [TcSigmaType] + -- ^ Argument types. + -- This function ensures they all have + -- a fixed runtime representation. + -> TcM [HsTupArg GhcTc] tcTupArgs args tys = do massert (equalLength args tys) checkTupSize (length args) @@ -984,14 +983,14 @@ tcSyntaxOpGen :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType - -> ([TcSigmaType] -> [Mult] -> TcM a) + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] -- Ugh!! But all this code is scheduled for demolition anyway ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) ; (result, expr_wrap, arg_wraps, res_wrap) - <- tcSynArgA orig sigma arg_tys res_ty $ + <- tcSynArgA orig op sigma arg_tys res_ty $ thing_inside ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr @@ -1012,12 +1011,13 @@ two tcSynArgs. -- works on "expected" types, skolemising where necessary -- See Note [tcSynArg] tcSynArgE :: CtOrigin + -> HsExpr GhcRn -- ^ the operator to check (for error messages only) -> TcSigmaType -> SyntaxOpType -- ^ shape it is expected to have - -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments -> TcM (a, HsWrapper) -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) -tcSynArgE orig sigma_ty syn_ty thing_inside +tcSynArgE orig op sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper)) <- tcSkolemise GenSigCtxt sigma_ty (\ rho_ty -> go rho_ty syn_ty) @@ -1055,18 +1055,20 @@ tcSynArgE orig sigma_ty syn_ty thing_inside pprCtOrigin orig) ; let arg_mult = scaledMult arg_ty - ; tcSynArgA orig arg_tc_ty [] arg_shape $ + ; tcSynArgA orig op arg_tc_ty [] arg_shape $ \ arg_results arg_res_mults -> - tcSynArgE orig res_tc_ty res_shape $ + tcSynArgE orig op res_tc_ty res_shape $ \ res_results res_res_mults -> do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} - ; fun_wrap <- mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - (Scaled op_mult arg_ty) res_ty (WpFunSyntaxOp orig) + ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper + (Scaled op_mult arg_ty) res_ty + -- NB: arg_ty comes from matchExpectedFunTys, so it has a + -- fixed RuntimeRep, as needed to call mkWpFun. ; return (result, match_wrapper <.> fun_wrap) } where - herald = text "This rebindable syntax expects a function with" + herald = ExpectedFunTySyntaxOp orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1076,15 +1078,16 @@ tcSynArgE orig sigma_ty syn_ty thing_inside -- works on "actual" types, instantiating where necessary -- See Note [tcSynArg] tcSynArgA :: CtOrigin + -> HsExpr GhcRn -- ^ the operator we are checking (for error messages) -> TcSigmaType -> [SyntaxOpType] -- ^ argument shapes -> SyntaxOpType -- ^ result shape - -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) -- ^ returns a wrapper to be applied to the original function, -- wrappers to be applied to arguments -- and a wrapper to be applied to the overall expression -tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside +tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside = do { (match_wrapper, arg_tys, res_ty) <- matchActualFunTysRho herald orig Nothing (length arg_shapes) sigma_ty @@ -1095,22 +1098,22 @@ tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where - herald = text "This rebindable syntax expects a function with" + herald = ExpectedFunTySyntaxOp orig op - tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] - -> ([TcSigmaType] -> [Mult] -> TcM a) + tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, [HsWrapper]) -- the wrappers are for arguments tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside = do { ((result, arg_wraps), arg_wrap) - <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results arg1_mults -> - tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> + <- tcSynArgE orig op arg_ty arg_shape $ \ arg1_results arg1_mults -> + tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) ; return (result, arg_wrap : arg_wraps) } tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] - tc_syn_arg :: TcSigmaType -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) + tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType + -> ([TcSigmaTypeFRR] -> TcM a) -> TcM (a, HsWrapper) -- the wrapper applies to the overall result tc_syn_arg res_ty SynAny thing_inside diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot index 22abe79491..6850e8aed2 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs-boot +++ b/compiler/GHC/Tc/Gen/Expr.hs-boot @@ -1,7 +1,8 @@ module GHC.Tc.Gen.Expr where import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn , SyntaxExprTc ) -import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType +import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR + , SyntaxOpType , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) @@ -32,13 +33,13 @@ tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpType -- ^ overall result type - -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ Type check any arguments -> TcM (a, SyntaxExprTc) tcSyntaxOpGen :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType - -> ([TcSigmaType] -> [Mult] -> TcM a) + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 56a995b3ba..3028f540d9 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -675,14 +675,17 @@ tcInferOverLit lit@(OverLit { ol_val = val -- where fromInteger is gotten by looking up from_name, and -- the (3 :: Integer) is returned by mkOverLit -- Ditto the string literal "foo" to (fromString ("foo" :: String)) - do { from_id <- tcLookupId from_name - ; (wrap1, from_ty) <- topInstantiate orig (idType from_id) - + do { hs_lit <- mkOverLit val + ; from_id <- tcLookupId from_name + ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id) + ; let + thing = NameThing from_name + mb_thing = Just thing + herald = ExpectedFunTyArg thing (HsLit noAnn hs_lit) ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing (1, []) from_ty - ; hs_lit <- mkOverLit val - ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) + ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ HsLit noAnn hs_lit from_expr = mkHsWrap (wrap2 <.> wrap1) $ @@ -692,12 +695,6 @@ tcInferOverLit lit@(OverLit { ol_val = val , ol_witness = witness , ol_type = res_ty } } ; return (HsOverLit noAnn lit', res_ty) } - where - orig = LiteralOrigin lit - mb_thing = Just (NameThing from_name) - herald = sep [ text "The function" <+> quotes (ppr from_name) - , text "is applied to"] - {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index a4f24dbb1b..d6f3590910 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -121,8 +121,7 @@ tcMatchesFun fun_id matches exp_ty where fun_name = idName (unLoc fun_id) arity = matchGroupArity matches - herald = text "The equation(s) for" - <+> quotes (ppr fun_name) <+> text "have" + herald = ExpectedFunTyMatches (NameThing fun_name) matches ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True -- But that's wrong for f :: Int -> forall a. blah what = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness } @@ -145,10 +144,10 @@ parser guarantees that each equation has exactly one argument. -} tcMatchesCase :: (AnnoBody body) => - TcMatchCtxt body -- Case context - -> Scaled TcSigmaType -- Type of scrutinee - -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives - -> ExpRhoType -- Type of whole case expressions + TcMatchCtxt body -- ^ Case context + -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee + -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives + -> ExpRhoType -- ^ Type of the whole case expression -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty @@ -156,7 +155,7 @@ tcMatchesCase :: (AnnoBody body) => tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches -tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify +tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify -> TcMatchCtxt HsExpr -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType @@ -213,8 +212,8 @@ type AnnoBody body -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body ) => TcMatchCtxt body - -> [Scaled ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. + -> [Scaled ExpSigmaTypeFRR] -- ^ Expected pattern types. + -> ExpRhoType -- ^ Expected result-type of the Match. -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) @@ -227,10 +226,6 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches = do { tcEmitBindingUsage bottomUE ; pat_tys <- mapM scaledExpTypeToType pat_tys ; rhs_ty <- expTypeToType rhs_ty - ; zipWithM_ - (\ i (Scaled _ pat_ty) -> - hasFixedRuntimeRep_MustBeRefl (FRRMatch (mc_what ctxt) i) pat_ty) - [1..] pat_tys ; return (MG { mg_alts = L l [] , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) } @@ -241,10 +236,6 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches ; tcEmitBindingUsage $ supUEs usages ; pat_tys <- mapM readScaledExpType pat_tys ; rhs_ty <- readExpType rhs_ty - ; zipWithM_ - (\ i (Scaled _ pat_ty) -> - hasFixedRuntimeRep_MustBeRefl (FRRMatch (mc_what ctxt) i) pat_ty) - [1..] pat_tys ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) } diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 7f31b4edb3..fb629e8826 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -35,7 +35,6 @@ import GHC.Rename.Utils import GHC.Tc.Errors.Types import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) -import GHC.Tc.Utils.Concrete ( mkWpFun ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate import GHC.Types.Error @@ -44,6 +43,7 @@ import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Core.Multiplicity +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Validity( arityErr ) @@ -83,7 +83,7 @@ import GHC.Data.List.SetOps ( getNth ) tcLetPat :: (Name -> Maybe TcId) -> LetBndrSpec - -> LPat GhcRn -> Scaled ExpSigmaType + -> LPat GhcRn -> Scaled ExpSigmaTypeFRR -> TcM a -> TcM (LPat GhcTc, a) tcLetPat sig_fn no_gen pat pat_ty thing_inside @@ -99,9 +99,9 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside ----------------- tcPats :: HsMatchContext GhcTc - -> [LPat GhcRn] -- Patterns, - -> [Scaled ExpSigmaType] -- and their types - -> TcM a -- and the checker for the body + -> [LPat GhcRn] -- ^ atterns + -> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns + -> TcM a -- ^ checker for the body -> TcM ([LPat GhcTc], a) -- This is the externally-callable wrapper function @@ -130,7 +130,7 @@ tcInferPat ctxt pat thing_inside penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } tcCheckPat :: HsMatchContext GhcTc - -> LPat GhcRn -> Scaled TcSigmaType + -> LPat GhcRn -> Scaled TcSigmaTypeFRR -> TcM a -- Checker for body -> TcM (LPat GhcTc, a) tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin @@ -138,7 +138,7 @@ tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin -- | A variant of 'tcPat' that takes a custom origin tcCheckPat_O :: HsMatchContext GhcTc -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat GhcRn -> Scaled TcSigmaType + -> LPat GhcRn -> Scaled TcSigmaTypeFRR -> TcM a -- Checker for body -> TcM (LPat GhcTc, a) tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside @@ -204,7 +204,7 @@ inPatBind (PE { pe_ctxt = LamPat {} }) = False * * ********************************************************************* -} -tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaType -> TcM (HsWrapper, TcId) +tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaTypeFRR -> TcM (HsWrapper, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- @@ -331,7 +331,7 @@ tcMultiple tc_pat penv args thing_inside ; loop penv args } -------------------- -tc_lpat :: Scaled ExpSigmaType +tc_lpat :: Scaled ExpSigmaTypeFRR -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside = setSrcSpanA span $ @@ -339,7 +339,7 @@ tc_lpat pat_ty penv (L span pat) thing_inside thing_inside ; return (L span pat', res) } -tc_lpats :: [Scaled ExpSigmaType] +tc_lpats :: [Scaled ExpSigmaTypeFRR] -> Checker [LPat GhcRn] [LPat GhcTc] tc_lpats tys penv pats = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $ @@ -352,7 +352,7 @@ tc_lpats tys penv pats checkManyPattern :: Scaled a -> TcM HsWrapper checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) -tc_pat :: Scaled ExpSigmaType +tc_pat :: Scaled ExpSigmaTypeFRR -- ^ Fully refined result type -> Checker (Pat GhcRn) (Pat GhcTc) -- ^ Translated pattern @@ -430,7 +430,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- Note [View patterns and polymorphism] -- Expression must be a function - ; let herald = text "A view pattern expression expects" + ; let herald = ExpectedFunTyViewPat $ unLoc expr ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty -- See Note [View patterns and polymorphism] @@ -445,10 +445,12 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of ; let Scaled w h_pat_ty = pat_ty ; pat_ty <- readExpType h_pat_ty - ; expr_wrap2' <- mkWpFun expr_wrap2 idHsWrapper - (Scaled w pat_ty) inf_res_sigma (WpFunViewPat $ unLoc expr) - -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" - -- (pat_ty -> inf_res_sigma) + ; 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 matchActualFunTySigma, so it has a + -- fixed RuntimeRep, as needed to call mkWpFun. ; let expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap @@ -855,7 +857,7 @@ same name, leading to shadowing. -- with scrutinee of type (T ty) tcConPat :: PatEnv -> LocatedN Name - -> Scaled ExpSigmaType -- Type of the pattern + -> Scaled ExpSigmaTypeFRR -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside @@ -881,7 +883,7 @@ warnMonoLocalBinds } tcDataConPat :: PatEnv -> LocatedN Name -> DataCon - -> Scaled ExpSigmaType -- Type of the pattern + -> Scaled ExpSigmaTypeFRR -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled @@ -925,15 +927,28 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled pat_mult = scaledMult pat_ty_scaled arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' - ; traceTc "tcConPat" (vcat [ ppr con_name - , pprTyVars univ_tvs - , pprTyVars ex_tvs - , ppr eq_spec - , ppr theta - , pprTyVars ex_tvs' - , ppr ctxt_res_tys - , ppr arg_tys' - , ppr arg_pats ]) + -- This check is necessary to uphold the invariant that 'tcConArgs' + -- is given argument types with a fixed runtime representation. + -- See test case T20363. + ; zipWithM_ + ( \ i arg_sty -> + hasFixedRuntimeRep_MustBeRefl + (FRRDataConArg Pattern data_con i) + (scaledThing arg_sty) + ) + [1..] + arg_tys' + + ; traceTc "tcConPat" (vcat [ text "con_name:" <+> ppr con_name + , text "univ_tvs:" <+> pprTyVars univ_tvs + , text "ex_tvs:" <+> pprTyVars ex_tvs + , text "eq_spec:" <+> ppr eq_spec + , text "theta:" <+> ppr theta + , text "ex_tvs':" <+> pprTyVars ex_tvs' + , text "ctxt_res_tys:" <+> ppr ctxt_res_tys + , text "pat_ty:" <+> ppr pat_ty + , text "arg_tys':" <+> ppr arg_tys' + , text "arg_pats" <+> ppr arg_pats ]) ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) @@ -979,7 +994,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled } } tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn - -> Scaled ExpSigmaType -- Type of the pattern + -> Scaled ExpSigmaType -- ^ Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside @@ -1028,6 +1043,18 @@ tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside -- see Note [Call-stack tracing of pattern synonyms] ; traceTc "instCall" (ppr req_wrap) + -- Pattern synonyms can never have representation-polymorphic argument types, + -- as checked in 'GHC.Tc.Gen.Sig.tcPatSynSig' (see use of 'FixedRuntimeRepPatSynSigArg'). + -- (If you want to lift this restriction, use 'hasFixedRuntimeRep' here, to match + -- 'tcDataConPat'.) + ; let + bad_arg_tys :: [(Int, Scaled Type)] + bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> typeLevity_maybe arg_ty == Nothing) + $ zip [0..] arg_tys' + ; massertPpr (null bad_arg_tys) $ + vcat [ text "tcPatSynPat: pattern arguments do not have a fixed RuntimeRep" + , text "bad_arg_tys:" <+> ppr bad_arg_tys ] + ; traceTc "checkConstraints {" Outputable.empty ; (ev_binds, (arg_pats', res)) <- checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $ @@ -1073,7 +1100,7 @@ and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) - -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) + -> PatEnv -> ExpSigmaTypeFRR -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~R inner_ty matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty @@ -1085,13 +1112,14 @@ matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty ---------------------------- matchExpectedConTy :: PatEnv - -> TyCon -- The TyCon that this data - -- constructor actually returns - -- In the case of a data family this is - -- the /representation/ TyCon - -> Scaled ExpSigmaType -- The type of the pattern; in the - -- case of a data family this would - -- mention the /family/ TyCon + -> TyCon + -- ^ The TyCon that this data constructor actually returns. + -- In the case of a data family, this is + -- the /representation/ TyCon. + -> Scaled ExpSigmaTypeFRR + -- ^ The type of the pattern. + -- 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 @@ -1212,7 +1240,7 @@ Wrinkles: -} tcConArgs :: ConLike - -> [Scaled TcSigmaType] + -> [Scaled TcSigmaTypeFRR] -> TCvSubst -- Instantiating substitution for constructor type -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index aa4be8e76e..dca5bce99e 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -2167,7 +2167,7 @@ tcRnStmt hsc_env rdr_stmt -- None of the Ids should be of unboxed type, because we -- cast them all to HValues in the end! - mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ; + mapM_ bad_unboxed (filter (mightBeUnliftedType . idType) zonked_ids) ; traceTc "tcs 1" empty ; this_mod <- getModule ; diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index e1baaba7c0..222a665eaa 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -544,6 +544,8 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) do_one_given sel_id | isUnliftedType sc_pred + -- NB: class superclasses are never representation-polymorphic, + -- so isUnliftedType is OK here. , not (null tvs && null theta) = -- See Note [Equality superclasses in quantified constraints] return [] diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 3c2ba8a9b3..302f93e691 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -4515,7 +4515,7 @@ checkNewDataCon con ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; let allowedArgType = - unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True + unlifted_newtypes || typeLevity_maybe (scaledThing arg_ty1) == Just Lifted ; checkTc allowedArgType $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index 8c855dacbc..9f508491dc 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -211,6 +211,8 @@ buildPatSyn :: Name -> Bool -> ([InvisTVBinder], ThetaType) -- ^ Univ and req -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov -> [Type] -- ^ Argument types + -- These must have a fixed RuntimeRep as per + -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -> Type -- ^ Result type -> [FieldLabel] -- ^ Field labels for -- a record pattern synonym diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 8091869187..6e7316d544 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -669,7 +669,10 @@ tc_patsyn_finish :: LocatedN Name -- ^ PatSyn Name -> TcPragEnv -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar]) -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm]) - -> ([LHsExpr GhcTc], [TcType]) -- ^ Pattern arguments and types + -> ([LHsExpr GhcTc], [TcType]) + -- ^ Pattern arguments and types. + -- These must have a fixed RuntimeRep as per + -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -> TcType -- ^ Pattern type -> [FieldLabel] -- ^ Selector names -- ^ Whether fields, empty if not record PatSyn @@ -869,6 +872,8 @@ mkPatSynBuilder dir (L _ name) = do { builder_name <- newImplicitBinder name mkBuilderOcc ; let theta = req_theta ++ prov_theta need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta + -- NB: pattern arguments cannot be representation-polymorphic, + -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here. builder_sigma = add_void need_dummy_arg $ mkInvisForAllTys univ_bndrs $ mkInvisForAllTys ex_bndrs $ diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index cf083b3c6f..74240b1f94 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, mkWpCastN, mkWpCastR, collectHsWrapBinders, + mkWpLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, pprHsWrapper, hsWrapDictBinders, @@ -281,6 +281,24 @@ WpHole <.> c = c c <.> WpHole = c c1 <.> c2 = c1 `WpCompose` c2 +-- | Smart constructor to create a 'WpFun' 'HsWrapper'. +-- +-- PRECONDITION: the "from" type of the first wrapper must have a +-- fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). +mkWpFun :: HsWrapper -> HsWrapper + -> Scaled TcType -- ^ the "from" type of the first wrapper + -- MUST have a fixed RuntimeRep + -> TcType -- ^ either type of the second wrapper (used only when the + -- second wrapper is the identity) + -> HsWrapper + -- NB: can't check that the argument type has a fixed RuntimeRep with an assertion, + -- as we will only be able to know that after typechecking. +mkWpFun WpHole WpHole _ _ = WpHole +mkWpFun WpHole (WpCast co2) (Scaled w t1) _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole (Scaled w _) t2 = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2) +mkWpFun co1 co2 t1 _ = WpFun co1 co2 t1 + mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co | isTcReflCo co = WpHole diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 38345d82aa..ebbf802026 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -8,16 +9,16 @@ -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. module GHC.Tc.Types.Origin ( - -- UserTypeCtxt + -- * UserTypeCtxt UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, ReportRedundantConstraints(..), reportRedundantConstraints, redundantConstraintsSpan, - -- SkolemInfo + -- * SkolemInfo SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, unkSkol, unkSkolAnon, - -- CtOrigin + -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin, @@ -25,16 +26,16 @@ module GHC.Tc.Types.Origin ( TypedThing(..), TyVarBndrs(..), - -- CtOrigin and CallStack + -- * CtOrigin and CallStack isPushCallStackOrigin, callStackOriginFS, - -- FixedRuntimeRep origin + -- * FixedRuntimeRep origin FRROrigin(..), pprFRROrigin, StmtOrigin(..), - -- Arrow command origin + -- * Arrow command origin FRRArrowOrigin(..), pprFRRArrowOrigin, - -- HsWrapper WpFun origin - WpFunOrigin(..), pprWpFunOrigin, + -- * ExpectedFunTy origin + ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, ) where @@ -993,24 +994,21 @@ data FRROrigin -- Test cases: LevPolyLet, RepPolyPatBind. | FRRBinder !Name - -- | The type of a pattern in a match group must have a fixed runtime representation. + -- | The type of the scrutinee in a case statement must have a + -- fixed runtime representation. -- - -- This rules out: - -- - individual patterns which don't have a fixed runtime representation, - -- - a representation-polymorphic empty case statement, - -- - representation-polymorphic GADT pattern matches - -- in which individual pattern types have a fixed runtime representation. - -- - -- Test cases: RepPolyRecordPattern, RepPolyUnboxedPatterns, - -- RepPolyBinder, RepPolyWildcardPattern, RepPolyMatch, - -- RepPolyNPlusK, RepPolyPatBind, T20426. - | FRRMatch !(HsMatchContext GhcTc) !Int + -- Test cases: RepPolyCase{1,2}. + | FRRCase -- | An instantiation of a newtype/data constructor in which - -- one of the remaining arguments types does not have a fixed runtime representation. + -- an argument type does not have a fixed runtime representation. + -- + -- The argument can either be an expression or a pattern. -- - -- Test case: UnliftedNewtypesLevityBinder. - | FRRDataConArg !DataCon !Int + -- Test cases: + -- Expression: UnliftedNewtypesLevityBinder. + -- Pattern: T20363. + | FRRDataConArg !ExprOrPat !DataCon !Int -- | An instantiation of an 'Id' with no binding (e.g. `coerce`, `unsafeCoerce#`) -- in which one of the remaining arguments types does not have a fixed runtime representation. @@ -1061,10 +1059,14 @@ data FRROrigin -- See 'FRRArrowOrigin' for more details. | FRRArrow !FRRArrowOrigin - -- | A representation-polymorphic check arising from an 'HsWrapper'. + -- | A representation-polymorphic check arising from a call + -- to 'matchExpectedFunTys' or 'matchActualFunTySigma'. -- - -- See 'WpFunOrigin' for more details. - | FRRWpFun !WpFunOrigin + -- See 'ExpectedFunTyOrigin' for more details. + | FRRExpectedFunTy + !ExpectedFunTyOrigin + !Int + -- ^ argument position (0-indexed) -- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check. -- @@ -1072,25 +1074,28 @@ data FRROrigin -- which is not fixed. That information is added by 'GHC.Tc.Errors.mkFRRErr'. pprFRROrigin :: FRROrigin -> SDoc pprFRROrigin (FRRApp arg) - = vcat [ text "The function argument" - , nest 2 $ quotes (ppr arg) ] + = sep [ text "The function argument" + , nest 2 $ quotes (ppr arg) ] pprFRROrigin (FRRRecordUpdate lbl _arg) - = hsep [ text "The record update at field" - , quotes (ppr lbl) ] + = sep [ text "The record update at field" + , quotes (ppr lbl) ] pprFRROrigin (FRRBinder binder) - = hsep [ text "The binder" - , quotes (ppr binder) ] -pprFRROrigin (FRRMatch matchCtxt i) - = text "The" <+> speakNth i <+> text "pattern in the" <+> pprMatchContextNoun matchCtxt -pprFRROrigin (FRRDataConArg con i) + = sep [ text "The binder" + , quotes (ppr binder) ] +pprFRROrigin FRRCase + = text "The scrutinee of the case statement" +pprFRROrigin (FRRDataConArg expr_or_pat con i) = text "The" <+> what where - what :: SDoc + arg, what :: SDoc + arg = case expr_or_pat of + Expression -> text "argument" + Pattern -> text "pattern" what | isNewDataCon con - = text "newtype constructor argument" + = text "newtype constructor" <+> arg | otherwise - = text "data constructor argument in" <+> speakNth i <+> text "position" + = text "data constructor" <+> arg <+> text "in" <+> speakNth i <+> text "position" pprFRROrigin (FRRNoBindingResArg fn i) = vcat [ text "Unsaturated use of a representation-polymorphic primitive function." , text "The" <+> speakNth i <+> text "argument of" <+> quotes (ppr $ getName fn) ] @@ -1110,12 +1115,11 @@ pprFRROrigin (FRRBindStmt stmtOrig) = vcat [ text "The first argument to (>>=)" <> comma , text "arising from the" <+> ppr stmtOrig <> comma ] pprFRROrigin FRRBindStmtGuard - = hsep [ text "The body of the bind statement" ] + = sep [ text "The body of the bind statement" ] pprFRROrigin (FRRArrow arrowOrig) = pprFRRArrowOrigin arrowOrig -pprFRROrigin (FRRWpFun wpFunOrig) - = hsep [ text "The function argument" - , pprWpFunOrigin wpFunOrig ] +pprFRROrigin (FRRExpectedFunTy funTyOrig zero_indexed_arg) + = pprExpectedFunTyOrigin funTyOrig (zero_indexed_arg + 1) instance Outputable FRROrigin where ppr = pprFRROrigin @@ -1166,6 +1170,15 @@ data FRRArrowOrigin -- Test cases: none. | ArrowCmdLam !Int + -- | The scrutinee type in an arrow command case or lambda-case + -- statement does not have a fixed runtime representation. + -- + -- Test cases: none. + | ArrowCmdCase { isCmdLamCase :: Bool + -- ^ Whether this is a lambda-case (True) + -- or a normal case (False) + } + -- | The overall type of an arrow proc expression does not have -- a fixed runtime representation. -- @@ -1181,12 +1194,19 @@ pprFRRArrowOrigin (ArrowCmdApp fun arg) , text "to" , nest 2 (quotes (ppr arg)) ] pprFRRArrowOrigin (ArrowCmdArrApp fun arg ho_app) - = vcat [ text "The function un the" <+> pprHsArrType ho_app <+> text "of" + = vcat [ text "The function in the" <+> pprHsArrType ho_app <+> text "of" , nest 2 (quotes (ppr fun)) , text "to" , nest 2 (quotes (ppr arg)) ] pprFRRArrowOrigin (ArrowCmdLam i) = vcat [ text "The" <+> speakNth i <+> text "pattern of the arrow command abstraction" ] +pprFRRArrowOrigin (ArrowCmdCase { isCmdLamCase = is_lam_case }) + = text "The scrutinee of the arrow" <+> what <+> text "command" + where + what :: SDoc + what = if is_lam_case + then text "lambda-case" + else text "case" pprFRRArrowOrigin (ArrowFun fun) = vcat [ text "The return type of the arrow function" , nest 2 (quotes (ppr fun)) ] @@ -1196,33 +1216,87 @@ instance Outputable FRRArrowOrigin where {- ********************************************************************* * * - FixedRuntimeRep: HsWrapper WpFun origin + FixedRuntimeRep: ExpectedFunTy origin * * ********************************************************************* -} --- | While typechecking a 'WpFun' 'HsWrapper', in which context --- did a representation polymorphism check arise? +-- | In what context are we calling 'matchExpectedFunTys' +-- or 'matchActualFunTySigma'? -- --- See 'FRROrigin' for more general origins of representation polymorphism checks. -data WpFunOrigin - = WpFunSyntaxOp !CtOrigin - | WpFunViewPat !(HsExpr GhcRn) - | WpFunFunTy !Type - | WpFunFunExpTy !ExpType - -pprWpFunOrigin :: WpFunOrigin -> SDoc -pprWpFunOrigin (WpFunSyntaxOp orig) - = vcat [ text "of a rebindable syntax operator arising from" - , nest 2 (ppr orig) ] -pprWpFunOrigin (WpFunViewPat expr) - = vcat [ text "of the view pattern function" - , nest 2 (ppr expr) ] -pprWpFunOrigin (WpFunFunTy fun_ty) - = vcat [ text "of the inferred argument type of a function with type" - , nest 2 (ppr fun_ty) ] -pprWpFunOrigin (WpFunFunExpTy fun_ty) - = vcat [ text "of the inferred argument type of a function with expected type" - , nest 2 (ppr fun_ty) ] - -instance Outputable WpFunOrigin where - ppr = pprWpFunOrigin +-- Used for two things: +-- +-- 1. Reporting error messages which explain that a function has been +-- given an unexpected number of arguments. +-- Uses 'pprExpectedFunTyHerald'. +-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. +-- +-- 2. Reporting representation-polymorphism errors when a function argument +-- doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- Uses 'pprExpectedFunTyOrigin'. +-- See 'FRROrigin' for more general origins of representation polymorphism checks. +data ExpectedFunTyOrigin + = ExpectedFunTySyntaxOp !CtOrigin !(HsExpr GhcRn) + | ExpectedFunTyViewPat !(HsExpr GhcRn) + | forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTyArg + !TypedThing + -- ^ function + !(HsExpr (GhcPass p)) + -- ^ argument + | ExpectedFunTyMatches !TypedThing !(MatchGroup GhcRn (LHsExpr GhcRn)) + | ExpectedFunTyLam !(MatchGroup GhcRn (LHsExpr GhcRn)) + | ExpectedFunTyLamCase !(HsExpr GhcRn) + +pprExpectedFunTyOrigin :: ExpectedFunTyOrigin + -> Int -- ^ argument position (starting at 1) + -> SDoc +pprExpectedFunTyOrigin funTy_origin i = + case funTy_origin of + ExpectedFunTySyntaxOp orig op -> + vcat [ sep [ the_arg_of + , text "the rebindable syntax operator" + , quotes (ppr op) ] + , nest 2 (ppr orig) ] + ExpectedFunTyViewPat expr -> + vcat [ the_arg_of <+> text "the view pattern" + , nest 2 (ppr expr) ] + ExpectedFunTyArg fun arg -> + sep [ text "The argument" + , quotes (ppr arg) + , text "of" + , quotes (ppr fun) ] + ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }) + | null alts + -> the_arg_of <+> quotes (ppr fun) + | otherwise + -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts + <+> text "for" <+> quotes (ppr fun) + ExpectedFunTyLam {} -> + text "The binder of the lambda expression" + ExpectedFunTyLamCase {} -> + text "The binder of the lambda-case expression" + where + the_arg_of :: SDoc + the_arg_of = text "The" <+> speakNth i <+> text "argument of" + +pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc +pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) + = text "This rebindable syntax expects a function with" +pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) + = text "A view pattern expression expects" +pprExpectedFunTyHerald (ExpectedFunTyArg fun _) + = sep [ text "The function" <+> quotes (ppr fun) + , text "is applied to" ] +pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) + = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts +pprExpectedFunTyHerald (ExpectedFunTyLam match) + = sep [ text "The lambda expression" <+> + quotes (pprSetDepth (PartWay 1) $ + pprMatches match) + -- The pprSetDepth makes the lambda abstraction print briefly + , text "has" ] +pprExpectedFunTyHerald (ExpectedFunTyLamCase expr) + = sep [ text "The function" <+> quotes (ppr expr) + , text "requires" ] diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs index dbf379479d..22ba6b45e3 100644 --- a/compiler/GHC/Tc/Utils/Concrete.hs +++ b/compiler/GHC/Tc/Utils/Concrete.hs @@ -8,8 +8,6 @@ module GHC.Tc.Utils.Concrete ( -- * Ensuring that a type has a fixed runtime representation hasFixedRuntimeRep , hasFixedRuntimeRep_MustBeRefl - -- * HsWrapper: checking for representation-polymorphism - , mkWpFun ) where @@ -17,17 +15,15 @@ import GHC.Prelude import GHC.Builtin.Types ( unliftedTypeKindTyCon, liftedTypeKindTyCon ) -import GHC.Core.Coercion ( Role(..), multToCo ) +import GHC.Core.Coercion ( Role(..) ) import GHC.Core.Predicate ( mkIsReflPrimPred ) -import GHC.Core.TyCo.Rep ( Type(TyConApp), Scaled(..) - , mkTyVarTy, scaledThing ) +import GHC.Core.TyCo.Rep ( Type(TyConApp), mkTyVarTy ) import GHC.Core.Type ( isConcrete, typeKind ) import GHC.Tc.Types ( TcM, ThStage(Brack), PendingStuff(TcPending) ) import GHC.Tc.Types.Constraint ( mkNonCanonical ) -import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper(..) - , mkTcFunCo, mkTcRepReflCo, mkTcSymCo ) -import GHC.Tc.Types.Origin ( CtOrigin(..), FRROrigin(..), WpFunOrigin(..) ) +import GHC.Tc.Types.Evidence ( TcCoercion ) +import GHC.Tc.Types.Origin ( CtOrigin(..), FRROrigin(..) ) import GHC.Tc.Utils.Monad ( emitSimple, getStage ) import GHC.Tc.Utils.TcType ( TcType, TcKind, TcTyVar, MetaInfo(ConcreteTv) ) import GHC.Tc.Utils.TcMType ( newAnonMetaTyVar, newWanted, emitWantedEq ) @@ -471,31 +467,3 @@ emitNewConcreteWantedEq_maybe orig ty where ki :: TcKind ki = typeKind ty - -{-*********************************************************************** -* * - HsWrapper -* * -***********************************************************************-} - --- | Smart constructor to create a 'WpFun' 'HsWrapper'. --- --- Might emit new Wanted constraints to check for representation polymorphism. --- This is necessary, as 'WpFun' will desugar to a lambda abstraction, --- whose binder must have a fixed runtime representation. -mkWpFun :: HsWrapper -> HsWrapper - -> Scaled TcType -- ^ the "from" type of the first wrapper - -> TcType -- ^ either type of the second wrapper (used only when the - -- second wrapper is the identity) - -> WpFunOrigin -- ^ what caused you to want a WpFun? - -> TcM HsWrapper -mkWpFun WpHole WpHole _ _ _ = return $ WpHole -mkWpFun WpHole (WpCast co2) (Scaled w t1) _ _ = return $ WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole (Scaled w _) t2 _ = return $ WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ _ = return $ WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2) -mkWpFun co1 co2 t1 _ wpFunOrig - = do { hasFixedRuntimeRep_MustBeRefl (FRRWpFun wpFunOrig) (scaledThing t1) - ; return $ WpFun co1 co2 t1 } - - -- NB: feel free to move this function elsewhere if you find a better place - -- for it (which doesn't create any cyclic imports). diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index d538638279..090415b16d 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -22,12 +22,16 @@ module GHC.Tc.Utils.TcType ( -------------------------------- -- Types - TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, + TcType, TcSigmaType, TcSigmaTypeFRR, + TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder, TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied, - ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, + ExpType(..), InferResult(..), + ExpSigmaType, ExpSigmaTypeFRR, + ExpRhoType, + mkCheckExpType, SyntaxOpType(..), synKnownType, mkSynFunTys, @@ -354,6 +358,19 @@ type TcTyConBinder = TyConBinder -- With skolem TcTyVars type TcPredType = PredType type TcThetaType = ThetaType type TcSigmaType = TcType + +-- | A 'TcSigmaTypeFRR' is a 'TcSigmaType' which has a fixed 'RuntimeRep' +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- +-- In particular, this means that: +-- +-- - 'GHC.Types.RepType.typePrimRep' does not panic, +-- - 'GHC.Core.typeLevity_maybe' does not return 'Nothing'. +-- +-- This property is important in functions such as 'matchExpectedFunTys', where +-- we want to provide argument types which have a known runtime representation. +-- See Note [Return arguments with a fixed RuntimeRep. +type TcSigmaTypeFRR = TcSigmaType type TcRhoType = TcType -- Note [TcRhoType] type TcTauType = TcType type TcKind = Kind @@ -427,8 +444,10 @@ data InferResult -- The type that fills in this hole should be a Type, -- that is, its kind should be (TYPE rr) for some rr -type ExpSigmaType = ExpType -type ExpRhoType = ExpType +type ExpSigmaType = ExpType +-- | Like 'TcSigmaTypeFRR', but for an expected type. +type ExpSigmaTypeFRR = ExpType +type ExpRhoType = ExpType instance Outputable ExpType where ppr (Check ty) = text "Check" <> braces (ppr ty) diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 7bd489dc50..c19b592765 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -44,14 +44,13 @@ import GHC.Prelude import GHC.Hs import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr( debugPprType ) -import GHC.Tc.Utils.Concrete ( mkWpFun ) +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Instantiate import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType - import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity @@ -86,19 +85,29 @@ import qualified Data.Semigroup as S ( (<>) ) * * ********************************************************************* -} --- | matchActualFunTySigma does looks for just one function arrow --- returning an uninstantiated sigma-type +-- | 'matchActualFunTySigma' looks for just one function arrow, +-- returning an uninstantiated sigma-type. +-- +-- Invariant: the returned argument type has a fixed RuntimeRep +-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTySigma - :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> Maybe TypedThing -- The thing with type TcSigmaType - -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and - -- types of values args to which function has - -- been applied already (reversed) - -- Both are used only for error messages) - -> TcRhoType -- Type to analyse: a TcRhoType - -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType) --- The /argument/ is a RhoType --- The /result/ is an (uninstantiated) SigmaType + :: ExpectedFunTyOrigin + -- ^ See Note [Herald for matchExpectedFunTys] + -> Maybe TypedThing + -- ^ The thing with type TcSigmaType + -> (Arity, [Scaled TcSigmaType]) + -- ^ Total number of value args in the call, and + -- types of values args to which function has + -- been applied already (reversed) + -- Both are used only for error messages) + -> TcRhoType + -- ^ Type to analyse: a TcRhoType + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) +-- This function takes in a type to analyse (a RhoType) and returns +-- an argument type and a result type (splitting apart a function arrow). +-- The returned argument type is a SigmaType with a fixed RuntimeRep; +-- as explained in Note [Return arguments with a fixed RuntimeRep]. -- -- See Note [matchActualFunTy error handling] for the first three arguments @@ -118,12 +127,13 @@ matchActualFunTySigma herald mb_thing err_info fun_ty -- hide the forall inside a meta-variable go :: TcRhoType -- The type we're processing, perhaps after -- expanding any type synonym - -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType) + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) go ty | Just ty' <- tcView ty = go ty' go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) = assert (af == VisArg) $ - return (idHsWrapper, Scaled w arg_ty, res_ty) + do { hasFixedRuntimeRep_MustBeRefl (FRRExpectedFunTy herald 0) arg_ty + ; return (idHsWrapper, Scaled w arg_ty, res_ty) } go ty@(TyVarTy tv) | isMetaTyVar tv @@ -156,6 +166,7 @@ matchActualFunTySigma herald mb_thing err_info fun_ty ; mult <- newFlexiTyVarTy multiplicityTy ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty ; co <- unifyType mb_thing fun_ty unif_fun_ty + ; hasFixedRuntimeRep_MustBeRefl (FRRExpectedFunTy herald 0) arg_ty ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } ------------ @@ -187,14 +198,18 @@ in the error message. Ugh! -} --- Like 'matchExpectedFunTys', but used when you have an "actual" type, --- for example in function application -matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys] +-- | Like 'matchExpectedFunTys', but used when you have an "actual" type, +-- for example in function application. +-- +-- INVARIANT: the returned arguemnt types all have a fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. +matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> CtOrigin - -> Maybe TypedThing -- the thing with type TcSigmaType + -> Maybe TypedThing -- ^ the thing with type TcSigmaType -> Arity -> TcSigmaType - -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType) + -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) -- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) -- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) -- and res_ty is a RhoType @@ -216,7 +231,9 @@ matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty (n_val_args_wanted, so_far) fun_ty ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 - ; wrap_fun2 <- mkWpFun idHsWrapper wrap_res arg_ty1 res_ty (WpFunFunTy fun_ty) + ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty + -- NB: arg_ty1 comes from matchActualFunTySigma, so it has + -- a fixed RuntimeRep as neede to call mkWpFun. ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } {- @@ -281,16 +298,73 @@ This function must be written CPS'd because it needs to fill in the ExpTypes produced for arguments before it can fill in the ExpType passed in. +Note [Return arguments with a fixed RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions + + - matchExpectedFunTys, + - matchActualFunTySigma, + - matchActualFunTysRho, + +peel off argument types, as explained in Note [matchExpectedFunTys]. +It's important that these functions return argument types that have +a fixed runtime representation, otherwise we would be in violation +of the representation-polymorphism invariants of +Note [Representation polymorphism invariants] in GHC.Core. + +This is why all these functions have an additional invariant, +that the argument types they return all have a fixed RuntimeRep, +in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. + +Example: + + Suppose we have + + type F :: Type -> RuntimeRep + type family F a where { F Int = LiftedRep } + + type Dual :: Type -> Type + type family Dual a where + Dual a = a -> () + + f :: forall (a :: TYPE (F Int)). Dual a + f = \ x -> () + + The body of `f` is a lambda abstraction, so we must be able to split off + one argument type from its type. This is handled by `matchExpectedFunTys` + (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that + looks like this: + + f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0])) + f = \ @(a :: TYPE (F Int)) -> + (\ (x :: (a |> (TYPE F[0]))) -> ()) + `cast` + (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>))) + + Two important transformations took place: + + 1. We inserted casts around the argument type to ensure that it has + a fixed runtime representation, as required by invariant (I1) from + Note [Representation polymorphism invariants] in GHC.Core. + 2. We inserted a cast around the whole lambda to make everything line up + with the type signature. -} --- Use this one when you have an "expected" type. +-- | Use this function to split off arguments types when you have an +-- \"expected\" type. +-- -- This function skolemises at each polytype. +-- +-- Invariant: this function only applies the provided function +-- to a list of argument types which all have a fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a. - SDoc -- See Note [Herald for matchExpectedFunTys] + ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> Arity -> ExpRhoType -- Skolemised - -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a) + -> ([Scaled ExpSigmaTypeFRR] -> ExpRhoType -> TcM a) -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (_, wrap) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, @@ -320,9 +394,13 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) = assert (af == VisArg) $ - do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) + do { let arg_pos = length acc_arg_tys -- for error messages only + ; hasFixedRuntimeRep_MustBeRefl (FRRExpectedFunTy herald arg_pos) arg_ty + ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) (n-1) res_ty - ; fun_wrap <- mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty (WpFunFunExpTy orig_ty) + ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty + -- NB: we are ensuring that arg_ty has a fixed RuntimeRep, + -- so we satisfy the precondition that mkWpFun requires. ; return ( fun_wrap, result ) } go acc_arg_tys n ty@(TyVarTy tv) @@ -351,12 +429,17 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside defer acc_arg_tys n (mkCheckExpType ty) ------------ - defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) + defer :: [Scaled ExpSigmaTypeFRR] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) defer acc_arg_tys n fun_ty = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType) ; res_ty <- newInferExpType ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys + ; zipWithM_ + ( \ i (Scaled _ arg_ty) -> + hasFixedRuntimeRep_MustBeRefl (FRRExpectedFunTy herald i) arg_ty ) + [0..] + more_arg_tys ; res_ty <- readExpType res_ty ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty @@ -364,7 +447,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside ; return (wrap, result) } ------------ - mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) + mk_ctxt :: [Scaled ExpSigmaTypeFRR] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_ctxt arg_tys res_ty env = mkFunTysMsg env herald arg_tys' res_ty arity where @@ -372,7 +455,9 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside reverse arg_tys -- this is safe b/c we're called from "go" -mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity +mkFunTysMsg :: TidyEnv + -> ExpectedFunTyOrigin + -> [Scaled TcType] -> TcType -> Arity -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call = do { (env', fun_rho) <- zonkTidyTcType env $ @@ -391,7 +476,8 @@ mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call ; return (env', msg) } where - full_herald = herald <+> speakNOf n_val_args_in_call (text "value argument") + full_herald = pprExpectedFunTyHerald herald + <+> speakNOf n_val_args_in_call (text "value argument") ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index ccb660e130..9f4cedbb39 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -104,6 +104,10 @@ module GHC.Types.Basic ( TypeOrKind(..), isTypeLevel, isKindLevel, + Levity(..), mightBeLifted, mightBeUnlifted, + + ExprOrPat(..), + NonStandardDefaultingStrategy(..), DefaultingStrategy(..), defaultNonStandardTyVars, @@ -1839,6 +1843,48 @@ isKindLevel KindLevel = True {- ********************************************************************* * * + Levity information +* * +********************************************************************* -} + +data Levity + = Lifted + | Unlifted + deriving Eq + +instance Outputable Levity where + ppr Lifted = text "Lifted" + ppr Unlifted = text "Unlifted" + +mightBeLifted :: Maybe Levity -> Bool +mightBeLifted (Just Unlifted) = False +mightBeLifted _ = True + +mightBeUnlifted :: Maybe Levity -> Bool +mightBeUnlifted (Just Lifted) = False +mightBeUnlifted _ = True + +{- ********************************************************************* +* * + Expressions vs Patterns +* * +********************************************************************* -} + +-- | Are we dealing with an expression or a pattern? +-- +-- Used only for the textual output of certain error messages; +-- see the 'FRRDataConArg' constructor of 'FRROrigin'. +data ExprOrPat + = Expression + | Pattern + deriving Eq + +instance Outputable ExprOrPat where + ppr Expression = text "expression" + ppr Pattern = text "pattern" + +{- ********************************************************************* +* * Defaulting options * * ********************************************************************* -} diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 6c328fc693..4d04c82a35 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -1069,7 +1069,7 @@ transferPolyIdInfo old_id abstract_wrt new_id = Nothing | isId v , isEvaldUnfolding (idUnfolding v) - , not (isUnliftedType $ idType v) + , mightBeLiftedType (idType v) = Just MarkedCbv | otherwise = Just NotMarkedCbv transfer new_info = new_info `setArityInfo` new_arity diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 0b3959e646..cfacdc9f70 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1007,6 +1007,8 @@ dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) dataConSrcToImplBang bang_opts fam_envs arg_ty (HsSrcBang _ unpk_prag SrcStrict) | isUnliftedType (scaledThing arg_ty) + -- NB: non-newtype data constructors can't have representation-polymorphic fields + -- so this is OK. = HsLazy -- For !Int#, say, use HsLazy -- See Note [Data con wrappers and unlifted types] diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index a6d20a2467..f4bf62232d 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -44,7 +44,8 @@ module GHC.Utils.Outputable ( fsep, fcat, hang, hangNotEmpty, punctuate, ppWhen, ppUnless, ppWhenOption, ppUnlessOption, - speakNth, speakN, speakNOf, plural, singular, isOrAre, doOrDoes, itsOrTheir, thisOrThese, + speakNth, speakN, speakNOf, plural, singular, + isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave, unicodeSyntax, coloured, keyword, @@ -1469,4 +1470,9 @@ itsOrTheir _ = text "their" -- > thisOrThese [] = text "These" -- probably avoid this thisOrThese :: [a] -> SDoc thisOrThese [_] = text "This" -thisOrThese _ = text "These"
\ No newline at end of file +thisOrThese _ = text "These" + +-- | @"has"@ or @"have"@ depending on the length of a list. +hasOrHave :: [a] -> SDoc +hasOrHave [_] = text "has" +hasOrHave _ = text "have" diff --git a/testsuite/tests/rep-poly/Makefile b/testsuite/tests/rep-poly/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/rep-poly/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/rep-poly/RepPolyApp.stderr b/testsuite/tests/rep-poly/RepPolyApp.stderr index e823c04dc2..77dd0a30cf 100644 --- a/testsuite/tests/rep-poly/RepPolyApp.stderr +++ b/testsuite/tests/rep-poly/RepPolyApp.stderr @@ -1,10 +1,8 @@ -RepPolyApp.hs:11:11: error: - • The function argument - ‘(undefined :: a)’ +RepPolyApp.hs:11:9: error: + • The argument ‘(undefined :: a)’ of ‘f’ does not have a fixed runtime representation. Its type is: a :: TYPE rep - • In the first argument of ‘f’, namely ‘(undefined :: a)’ - In the expression: f (undefined :: a) + • In the expression: f (undefined :: a) In an equation for ‘foo’: foo f = f (undefined :: a) diff --git a/testsuite/tests/rep-poly/RepPolyArrowFun.stderr b/testsuite/tests/rep-poly/RepPolyArrowFun.stderr index 014dc19144..db14b272f3 100644 --- a/testsuite/tests/rep-poly/RepPolyArrowFun.stderr +++ b/testsuite/tests/rep-poly/RepPolyArrowFun.stderr @@ -22,7 +22,7 @@ RepPolyArrowFun.hs:29:9: error: In an equation for ‘foo’: foo _ = proc x -> undefined -< x RepPolyArrowFun.hs:29:19: error: - • The function un the first order arrow application of + • The function in the first order arrow application of ‘undefined’ to ‘x’ diff --git a/testsuite/tests/rep-poly/RepPolyBackpack1.stderr b/testsuite/tests/rep-poly/RepPolyBackpack1.stderr index 9f3d77ff46..f521ada91c 100644 --- a/testsuite/tests/rep-poly/RepPolyBackpack1.stderr +++ b/testsuite/tests/rep-poly/RepPolyBackpack1.stderr @@ -8,42 +8,19 @@ RepPolyBackpack1.bkp:17:5: error: Its type is: Number l :: TYPE (Rep l) -RepPolyBackpack1.bkp:17:22: error: - • The function argument - ‘x’ +RepPolyBackpack1.bkp:17:17: error: + • The argument ‘x’ of ‘plus’ does not have a fixed runtime representation. Its type is: Number l :: TYPE (Rep l) - • In the first argument of ‘plus’, namely ‘x’ - In the expression: plus x (multiply x y) + • In the expression: plus x (multiply x y) In an equation for ‘funcA’: funcA x y = plus x (multiply x y) -RepPolyBackpack1.bkp:17:24: error: - • The function argument - ‘(multiply x y)’ +RepPolyBackpack1.bkp:17:25: error: + • The argument ‘x’ of ‘multiply’ does not have a fixed runtime representation. Its type is: Number l :: TYPE (Rep l) • In the second argument of ‘plus’, namely ‘(multiply x y)’ In the expression: plus x (multiply x y) In an equation for ‘funcA’: funcA x y = plus x (multiply x y) - -RepPolyBackpack1.bkp:17:34: error: - • The function argument - ‘x’ - does not have a fixed runtime representation. - Its type is: - Number l :: TYPE (Rep l) - • In the first argument of ‘multiply’, namely ‘x’ - In the second argument of ‘plus’, namely ‘(multiply x y)’ - In the expression: plus x (multiply x y) - -RepPolyBackpack1.bkp:17:36: error: - • The function argument - ‘y’ - does not have a fixed runtime representation. - Its type is: - Number l :: TYPE (Rep l) - • In the second argument of ‘multiply’, namely ‘y’ - In the second argument of ‘plus’, namely ‘(multiply x y)’ - In the expression: plus x (multiply x y) diff --git a/testsuite/tests/rep-poly/RepPolyBinder.stderr b/testsuite/tests/rep-poly/RepPolyBinder.stderr index 177a4865e6..33802a0621 100644 --- a/testsuite/tests/rep-poly/RepPolyBinder.stderr +++ b/testsuite/tests/rep-poly/RepPolyBinder.stderr @@ -8,3 +8,12 @@ RepPolyBinder.hs:11:1: error: does not have a fixed runtime representation. Its type is: b :: TYPE rep2 + +RepPolyBinder.hs:11:17: error: + • The first argument of the view pattern + myId + does not have a fixed runtime representation. + Its type is: + b :: TYPE rep2 + • In the pattern: myId -> bndr_b + In an equation for ‘foo’: foo bndr_a pat@(myId -> bndr_b) = () diff --git a/testsuite/tests/rep-poly/RepPolyCase1.hs b/testsuite/tests/rep-poly/RepPolyCase1.hs new file mode 100644 index 0000000000..11579c563f --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyCase1.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module RepPolyCase1 where + +import GHC.Exts + +bar :: forall {r} (a :: TYPE r). () -> a +bar = error "no bar" + +x :: forall {r} (a :: TYPE r) proxy. proxy a -> () +x _ = case bar @a () of {} + diff --git a/testsuite/tests/rep-poly/RepPolyCase1.stderr b/testsuite/tests/rep-poly/RepPolyCase1.stderr new file mode 100644 index 0000000000..4804a67f8a --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyCase1.stderr @@ -0,0 +1,8 @@ + +RepPolyCase1.hs:14:7: error: + • The scrutinee of the case statement + does not have a fixed runtime representation. + Its type is: + a :: TYPE r + • In the expression: case bar @a () of {} + In an equation for ‘x’: x _ = case bar @a () of {} diff --git a/testsuite/tests/rep-poly/RepPolyCase2.hs b/testsuite/tests/rep-poly/RepPolyCase2.hs new file mode 100644 index 0000000000..5b8b355fee --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyCase2.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module RepPolyCase2 where + +import Data.Kind +import GHC.Exts + +type Rep :: Type -> RuntimeRep +type family Rep a + +class Unboxable a where + type Unbox a :: TYPE (Rep a) + unbox :: a -> Unbox a + +type instance Rep Int = IntRep +instance Unboxable Int where + type Unbox Int = Int# + unbox (I# i#) = i# + +type instance Rep Double = DoubleRep +instance Unboxable Double where + type Unbox Double = Double# + unbox (D# d#) = d# + +x :: () -> () +x _ = case unbox (3 :: Int) of { _ -> () } diff --git a/testsuite/tests/rep-poly/RepPolyCase2.stderr b/testsuite/tests/rep-poly/RepPolyCase2.stderr new file mode 100644 index 0000000000..f1f59116c9 --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyCase2.stderr @@ -0,0 +1,11 @@ + +RepPolyCase2.hs:33:7: error: + • The scrutinee of the case statement + does not have a fixed runtime representation. + Its type is: + Unbox Int :: TYPE (Rep Int) + NB: GHC does not (yet) support rewriting in runtime representations. + Please comment on GHC ticket #13105 if this is causing you trouble. + <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> + • In the expression: case unbox (3 :: Int) of _ -> () + In an equation for ‘x’: x _ = case unbox (3 :: Int) of _ -> () diff --git a/testsuite/tests/rep-poly/RepPolyDoBind.stderr b/testsuite/tests/rep-poly/RepPolyDoBind.stderr index ff92a1ae26..b3541dc5d5 100644 --- a/testsuite/tests/rep-poly/RepPolyDoBind.stderr +++ b/testsuite/tests/rep-poly/RepPolyDoBind.stderr @@ -1,7 +1,7 @@ RepPolyDoBind.hs:26:3: error: - • The first argument to (>>=), - arising from the ‘do’ statement, + • The first argument of the rebindable syntax operator ‘(>>=)’ + arising from a do statement does not have a fixed runtime representation. Its type is: ma0 :: TYPE rep diff --git a/testsuite/tests/rep-poly/RepPolyDoBody1.stderr b/testsuite/tests/rep-poly/RepPolyDoBody1.stderr index 8779c23b39..f71deeb24b 100644 --- a/testsuite/tests/rep-poly/RepPolyDoBody1.stderr +++ b/testsuite/tests/rep-poly/RepPolyDoBody1.stderr @@ -1,12 +1,12 @@ RepPolyDoBody1.hs:24:3: error: - • • The first argument to (>>), - arising from the ‘do’ statement, + • • The first argument of the rebindable syntax operator ‘(>>)’ + arising from a do statement does not have a fixed runtime representation. Its type is: ma :: TYPE rep - • The second argument to (>>), - arising from the ‘do’ statement, + • The first argument of the rebindable syntax operator ‘(>>)’ + arising from a do statement does not have a fixed runtime representation. Its type is: mb0 :: TYPE rep diff --git a/testsuite/tests/rep-poly/RepPolyDoBody2.stderr b/testsuite/tests/rep-poly/RepPolyDoBody2.stderr index 5d83af9891..1d28c20d26 100644 --- a/testsuite/tests/rep-poly/RepPolyDoBody2.stderr +++ b/testsuite/tests/rep-poly/RepPolyDoBody2.stderr @@ -1,7 +1,7 @@ RepPolyDoBody2.hs:23:3: error: - • The second argument to (>>), - arising from the ‘do’ statement, + • The first argument of the rebindable syntax operator ‘(>>)’ + arising from a do statement does not have a fixed runtime representation. Its type is: mb0 :: TYPE rep diff --git a/testsuite/tests/rep-poly/RepPolyFFI.hs b/testsuite/tests/rep-poly/RepPolyFFI.hs new file mode 100644 index 0000000000..4dabe7b7a6 --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyFFI.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module RepPolyFFI1 where + +import GHC.Exts + +foreign import ccall safe "foo" foo + :: forall {l} (a :: TYPE (BoxedRep l)). Array# a -> Array# a diff --git a/testsuite/tests/rep-poly/RepPolyLeftSection2.stderr b/testsuite/tests/rep-poly/RepPolyLeftSection2.stderr index 6d299f2fed..fd9dbb31b1 100644 --- a/testsuite/tests/rep-poly/RepPolyLeftSection2.stderr +++ b/testsuite/tests/rep-poly/RepPolyLeftSection2.stderr @@ -1,10 +1,8 @@ RepPolyLeftSection2.hs:14:11: error: - • The function argument - ‘undefined’ + • The argument ‘undefined’ of ‘f’ does not have a fixed runtime representation. Its type is: a :: TYPE r - • In the expression: undefined - In the expression: undefined `f` + • In the expression: undefined `f` In an equation for ‘test1’: test1 = (undefined `f`) diff --git a/testsuite/tests/rep-poly/RepPolyMatch.stderr b/testsuite/tests/rep-poly/RepPolyMatch.stderr index 7573de3c18..420c38efe2 100644 --- a/testsuite/tests/rep-poly/RepPolyMatch.stderr +++ b/testsuite/tests/rep-poly/RepPolyMatch.stderr @@ -1,6 +1,6 @@ RepPolyMatch.hs:11:9: error: - • The first pattern in the case alternative + • The binder of the lambda-case expression does not have a fixed runtime representation. Its type is: a :: TYPE rep diff --git a/testsuite/tests/rep-poly/RepPolyMcBind.stderr b/testsuite/tests/rep-poly/RepPolyMcBind.stderr index 2febf28b9f..647a8d625d 100644 --- a/testsuite/tests/rep-poly/RepPolyMcBind.stderr +++ b/testsuite/tests/rep-poly/RepPolyMcBind.stderr @@ -1,7 +1,7 @@ RepPolyMcBind.hs:26:16: error: - • The first argument to (>>=), - arising from the monad comprehension, + • The first argument of the rebindable syntax operator ‘(>>=)’ + arising from a statement in a monad comprehension does not have a fixed runtime representation. Its type is: ma :: TYPE rep diff --git a/testsuite/tests/rep-poly/RepPolyMcBody.stderr b/testsuite/tests/rep-poly/RepPolyMcBody.stderr index 56df668fdd..de9848d4c6 100644 --- a/testsuite/tests/rep-poly/RepPolyMcBody.stderr +++ b/testsuite/tests/rep-poly/RepPolyMcBody.stderr @@ -1,7 +1,7 @@ RepPolyMcBody.hs:30:16: error: - • The first argument to (>>), - arising from the monad comprehension, + • The first argument of the rebindable syntax operator ‘(>>)’ + arising from a statement in a monad comprehension does not have a fixed runtime representation. Its type is: ma0 :: TYPE rep diff --git a/testsuite/tests/rep-poly/RepPolyMcGuard.stderr b/testsuite/tests/rep-poly/RepPolyMcGuard.stderr index 46addb9982..a1a32f7a3a 100644 --- a/testsuite/tests/rep-poly/RepPolyMcGuard.stderr +++ b/testsuite/tests/rep-poly/RepPolyMcGuard.stderr @@ -1,12 +1,12 @@ RepPolyMcGuard.hs:30:16: error: - • • The first argument to (>>), - arising from the monad comprehension, + • • The first argument of the rebindable syntax operator ‘(>>)’ + arising from a statement in a monad comprehension does not have a fixed runtime representation. Its type is: ma0 :: TYPE rep - • The argument to ‘guard’, - arising from the monad comprehension, + • The first argument of the rebindable syntax operator ‘guard’ + arising from a statement in a monad comprehension does not have a fixed runtime representation. Its type is: a0 :: TYPE rep diff --git a/testsuite/tests/rep-poly/RepPolyNPlusK.stderr b/testsuite/tests/rep-poly/RepPolyNPlusK.stderr index 80672387db..c5e5f84662 100644 --- a/testsuite/tests/rep-poly/RepPolyNPlusK.stderr +++ b/testsuite/tests/rep-poly/RepPolyNPlusK.stderr @@ -4,3 +4,12 @@ RepPolyNPlusK.hs:22:1: error: does not have a fixed runtime representation. Its type is: a :: TYPE rep1 + +RepPolyNPlusK.hs:22:6: error: + • The first argument of the rebindable syntax operator ‘(>=)’ + arising from the literal ‘2’ + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep1 + • In the pattern: bndr_a+2 + In an equation for ‘foo’: foo (bndr_a+2) = () diff --git a/testsuite/tests/rep-poly/RepPolyNewtypePat1.stderr b/testsuite/tests/rep-poly/RepPolyNewtypePat1.stderr index 6981d02016..b49bd58f2a 100644 --- a/testsuite/tests/rep-poly/RepPolyNewtypePat1.stderr +++ b/testsuite/tests/rep-poly/RepPolyNewtypePat1.stderr @@ -4,3 +4,11 @@ RepPolyNewtypePat1.hs:16:1: error: does not have a fixed runtime representation. Its type is: X a :: TYPE rep + +RepPolyNewtypePat1.hs:16:6: error: + • The newtype constructor pattern + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep + • In the pattern: MkX bndr_a + In an equation for ‘bar’: bar (MkX bndr_a) = bndr_a diff --git a/testsuite/tests/rep-poly/RepPolyRecordPattern.stderr b/testsuite/tests/rep-poly/RepPolyRecordPattern.stderr index 50651762dd..085e2da393 100644 --- a/testsuite/tests/rep-poly/RepPolyRecordPattern.stderr +++ b/testsuite/tests/rep-poly/RepPolyRecordPattern.stderr @@ -1,12 +1,24 @@ RepPolyRecordPattern.hs:7:35: error: - The first pattern in the equation for ‘fld’ - does not have a fixed runtime representation. - Its type is: - X a :: TYPE rep + • The newtype constructor pattern + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep + • The first pattern in the equation for ‘fld’ + does not have a fixed runtime representation. + Its type is: + X a :: TYPE rep RepPolyRecordPattern.hs:13:1: error: The first pattern in the equation for ‘upd’ does not have a fixed runtime representation. Its type is: X a :: TYPE rep + +RepPolyRecordPattern.hs:13:7: error: + • The newtype constructor pattern + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep + • In the pattern: MkX bndr_a + In an equation for ‘upd’: upd (MkX bndr_a) = bndr_a diff --git a/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr b/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr index 9189df8168..5cdc9205f0 100644 --- a/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr +++ b/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr @@ -1,9 +1,13 @@ RepPolyRecordUpdate.hs:7:35: error: - The first pattern in the equation for ‘fld’ - does not have a fixed runtime representation. - Its type is: - X a :: TYPE rep + • The newtype constructor pattern + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep + • The first pattern in the equation for ‘fld’ + does not have a fixed runtime representation. + Its type is: + X a :: TYPE rep RepPolyRecordUpdate.hs:13:9: error: • The record update at field ‘fld’ diff --git a/testsuite/tests/rep-poly/RepPolyRule1.stderr b/testsuite/tests/rep-poly/RepPolyRule1.stderr index bef17d948f..f2fcb378da 100644 --- a/testsuite/tests/rep-poly/RepPolyRule1.stderr +++ b/testsuite/tests/rep-poly/RepPolyRule1.stderr @@ -1,10 +1,8 @@ -RepPolyRule1.hs:11:51: error: - • The function argument - ‘x’ +RepPolyRule1.hs:11:49: error: + • The argument ‘x’ of ‘f’ does not have a fixed runtime representation. Its type is: a :: TYPE rep - • In the first argument of ‘f’, namely ‘x’ - In the expression: f x + • In the expression: f x When checking the rewrite rule "f_id" diff --git a/testsuite/tests/rep-poly/RepPolyRule2.stderr b/testsuite/tests/rep-poly/RepPolyRule2.stderr index 70bd7eaa3a..82403d3c7d 100644 --- a/testsuite/tests/rep-poly/RepPolyRule2.stderr +++ b/testsuite/tests/rep-poly/RepPolyRule2.stderr @@ -1,10 +1,8 @@ -RepPolyRule2.hs:17:55: error: - • The function argument - ‘x’ +RepPolyRule2.hs:17:53: error: + • The argument ‘x’ of ‘f’ does not have a fixed runtime representation. Its type is: a :: TYPE (F rep) - • In the first argument of ‘f’, namely ‘x’ - In the expression: f x + • In the expression: f x When checking the rewrite rule "f_id" diff --git a/testsuite/tests/rep-poly/RepPolyRule3.stderr b/testsuite/tests/rep-poly/RepPolyRule3.stderr index 524ddfd3e0..cdbfcdb66b 100644 --- a/testsuite/tests/rep-poly/RepPolyRule3.stderr +++ b/testsuite/tests/rep-poly/RepPolyRule3.stderr @@ -1,26 +1,24 @@ -RepPolyRule3.hs:17:59: error: - • The function argument - ‘x’ +RepPolyRule3.hs:17:57: error: + • The argument ‘x’ of ‘g’ does not have a fixed runtime representation. - Its type is: - a :: TYPE (F 'WordRep) + Its kind is: + TYPE (F 'WordRep) + (Use -fprint-explicit-coercions to see the full type.) NB: GHC does not (yet) support rewriting in runtime representations. Please comment on GHC ticket #13105 if this is causing you trouble. <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> - • In the first argument of ‘g’, namely ‘x’ - In the expression: g x + • In the expression: g x When checking the rewrite rule "g_id" -RepPolyRule3.hs:23:54: error: - • The function argument - ‘x’ +RepPolyRule3.hs:23:52: error: + • The argument ‘x’ of ‘h’ does not have a fixed runtime representation. - Its type is: - a :: TYPE (F 'WordRep) + Its kind is: + TYPE (F 'WordRep) + (Use -fprint-explicit-coercions to see the full type.) NB: GHC does not (yet) support rewriting in runtime representations. Please comment on GHC ticket #13105 if this is causing you trouble. <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> - • In the first argument of ‘h’, namely ‘x’ - In the expression: h x + • In the expression: h x When checking the rewrite rule "h_id" diff --git a/testsuite/tests/rep-poly/RepPolyUnboxedPatterns.stderr b/testsuite/tests/rep-poly/RepPolyUnboxedPatterns.stderr index 7efa7431c5..a2d6e6bd1d 100644 --- a/testsuite/tests/rep-poly/RepPolyUnboxedPatterns.stderr +++ b/testsuite/tests/rep-poly/RepPolyUnboxedPatterns.stderr @@ -6,7 +6,7 @@ RepPolyUnboxedPatterns.hs:8:1: error: (# a, b #) :: TYPE ('TupleRep '[rep1, rep2]) RepPolyUnboxedPatterns.hs:11:1: error: - The first pattern in the equation for ‘bar’ + The first pattern in the equations for ‘bar’ does not have a fixed runtime representation. Its type is: (# a | b #) :: TYPE ('SumRep '[rep1, rep2]) diff --git a/testsuite/tests/rep-poly/RepPolyUnliftedDatatype2.hs b/testsuite/tests/rep-poly/RepPolyUnliftedDatatype2.hs new file mode 100644 index 0000000000..b16480f0ef --- /dev/null +++ b/testsuite/tests/rep-poly/RepPolyUnliftedDatatype2.hs @@ -0,0 +1,34 @@ + +{-# LANGUAGE UnliftedDatatypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} + +module RepPolyUnliftedDatatype2 where + +import GHC.Exts + +type Interpret :: Bool -> Levity +type family Interpret b where + Interpret True = Lifted + Interpret False = Unlifted + +type A :: TYPE (BoxedRep (Interpret b)) +data A = MkA Int + +a :: A @True +a = MkA 42 + +-- type Interpret :: Bool -> RuntimeRep +-- type family Interpret b where +-- Interpret True = BoxedRep Lifted +-- Interpret False = BoxedRep Unlifted +-- +-- type A :: TYPE (Interpret b) +-- data A = MkA Int +-- +-- data B :: TYPE (Interpret b) where +-- MkB :: Int -> B @b diff --git a/testsuite/tests/rep-poly/T11473.stderr b/testsuite/tests/rep-poly/T11473.stderr index 2a4e92eae9..411e074c0e 100644 --- a/testsuite/tests/rep-poly/T11473.stderr +++ b/testsuite/tests/rep-poly/T11473.stderr @@ -5,12 +5,10 @@ T11473.hs:19:1: error: Its type is: a :: TYPE r -T11473.hs:19:17: error: - • The function argument - ‘x’ +T11473.hs:19:11: error: + • The argument ‘x’ of ‘boxed’ does not have a fixed runtime representation. Its type is: a :: TYPE r - • In the first argument of ‘boxed’, namely ‘x’ - In the expression: boxed x + • In the expression: boxed x In an equation for ‘hello’: hello x = boxed x diff --git a/testsuite/tests/rep-poly/T12709.stderr b/testsuite/tests/rep-poly/T12709.stderr index 78ebe39a7c..782f995942 100644 --- a/testsuite/tests/rep-poly/T12709.stderr +++ b/testsuite/tests/rep-poly/T12709.stderr @@ -1,40 +1,13 @@ T12709.hs:28:13: error: - • The function argument - ‘1’ + • The argument ‘1 + 2 + 3’ of ‘(+)’ does not have a fixed runtime representation. Its type is: a :: TYPE rep - • In the first argument of ‘(+)’, namely ‘1’ - In the first argument of ‘(+)’, namely ‘1 + 2’ - In the first argument of ‘(+)’, namely ‘1 + 2 + 3’ - -T12709.hs:28:17: error: - • The function argument - ‘2’ - does not have a fixed runtime representation. - Its type is: - a :: TYPE rep - • In the second argument of ‘(+)’, namely ‘2’ - In the first argument of ‘(+)’, namely ‘1 + 2’ - In the first argument of ‘(+)’, namely ‘1 + 2 + 3’ - -T12709.hs:28:21: error: - • The function argument - ‘3’ - does not have a fixed runtime representation. - Its type is: - a :: TYPE rep - • In the second argument of ‘(+)’, namely ‘3’ - In the first argument of ‘(+)’, namely ‘1 + 2 + 3’ - In the expression: 1 + 2 + 3 + 4 - -T12709.hs:28:25: error: - • The function argument - ‘4’ - does not have a fixed runtime representation. - Its type is: - a :: TYPE rep - • In the second argument of ‘(+)’, namely ‘4’ - In the expression: 1 + 2 + 3 + 4 + • In the expression: 1 + 2 + 3 + 4 In an equation for ‘u’: u = 1 + 2 + 3 + 4 + In the expression: + let + u :: Num (a :: TYPE rep) => a + u = 1 + 2 + 3 + 4 + in BUB u u diff --git a/testsuite/tests/rep-poly/T12973.stderr b/testsuite/tests/rep-poly/T12973.stderr index 1f677f3050..7a70b92859 100644 --- a/testsuite/tests/rep-poly/T12973.stderr +++ b/testsuite/tests/rep-poly/T12973.stderr @@ -1,20 +1,8 @@ T12973.hs:13:7: error: - • The function argument - ‘3’ + • The argument ‘3’ of ‘(+)’ does not have a fixed runtime representation. Its type is: a :: TYPE r - • In the first argument of ‘(+)’, namely ‘3’ - In the expression: 3 + 4 - In an equation for ‘foo’: foo = 3 + 4 - -T12973.hs:13:11: error: - • The function argument - ‘4’ - does not have a fixed runtime representation. - Its type is: - a :: TYPE r - • In the second argument of ‘(+)’, namely ‘4’ - In the expression: 3 + 4 + • In the expression: 3 + 4 In an equation for ‘foo’: foo = 3 + 4 diff --git a/testsuite/tests/rep-poly/T14765.stderr b/testsuite/tests/rep-poly/T14765.stderr index 57281f6507..0b70a16404 100644 --- a/testsuite/tests/rep-poly/T14765.stderr +++ b/testsuite/tests/rep-poly/T14765.stderr @@ -1,10 +1,10 @@ -T14765.hs:11:31: error: - • The function argument - ‘(k proxy#)’ +T14765.hs:11:29: error: + • The argument ‘(k proxy#)’ of ‘f’ does not have a fixed runtime representation. Its type is: r :: TYPE rep - • In the first argument of ‘f’, namely ‘(k proxy#)’ - In the second argument of ‘fold’, namely ‘(f (k proxy#) x)’ + • In the second argument of ‘fold’, namely ‘(f (k proxy#) x)’ In the expression: fold f (f (k proxy#) x) xs + In an equation for ‘fold’: + fold f k (x : xs) = fold f (f (k proxy#) x) xs diff --git a/testsuite/tests/rep-poly/T17021.stderr b/testsuite/tests/rep-poly/T17021.stderr index accd9c1560..0521ed1259 100644 --- a/testsuite/tests/rep-poly/T17021.stderr +++ b/testsuite/tests/rep-poly/T17021.stderr @@ -1,13 +1,12 @@ -T17021.hs:18:9: error: - • The function argument - ‘42’ +T17021.hs:18:5: error: + • The argument ‘42’ of ‘MkT’ does not have a fixed runtime representation. - Its type is: - Int :: TYPE (Id LiftedRep) + Its kind is: + TYPE (Id LiftedRep) + (Use -fprint-explicit-coercions to see the full type.) NB: GHC does not (yet) support rewriting in runtime representations. Please comment on GHC ticket #13105 if this is causing you trouble. <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> - • In the first argument of ‘MkT’, namely ‘42’ - In the expression: MkT 42 + • In the expression: MkT 42 In an equation for ‘f’: f = MkT 42 diff --git a/testsuite/tests/rep-poly/T17536b.stderr b/testsuite/tests/rep-poly/T17536b.stderr index 0682f44282..a2d161038a 100644 --- a/testsuite/tests/rep-poly/T17536b.stderr +++ b/testsuite/tests/rep-poly/T17536b.stderr @@ -1,6 +1,6 @@ T17536b.hs:19:7: error: - • The first pattern in the lambda abstraction + • The binder of the lambda expression does not have a fixed runtime representation. Its type is: a :: TYPE r @@ -11,7 +11,7 @@ T17536b.hs:19:7: error: In an equation for ‘g’: g L = \ _ -> 0 T17536b.hs:20:7: error: - • The first pattern in the lambda abstraction + • The binder of the lambda expression does not have a fixed runtime representation. Its type is: a :: TYPE r diff --git a/testsuite/tests/rep-poly/T19615.stderr b/testsuite/tests/rep-poly/T19615.stderr index aff0d742cf..873b3816f9 100644 --- a/testsuite/tests/rep-poly/T19615.stderr +++ b/testsuite/tests/rep-poly/T19615.stderr @@ -1,10 +1,9 @@ -T19615.hs:17:20: error: - • The function argument - ‘(f x)’ +T19615.hs:17:14: error: + • The argument ‘(f x)’ of ‘lift'’ does not have a fixed runtime representation. Its type is: b :: TYPE r' - • In the first argument of ‘lift'’, namely ‘(f x)’ - In the expression: lift' (f x) id + • In the expression: lift' (f x) id In an equation for ‘mapF’: mapF f x = lift' (f x) id + In the instance declaration for ‘Call LiftedRep’ diff --git a/testsuite/tests/rep-poly/T19709b.stderr b/testsuite/tests/rep-poly/T19709b.stderr index 63aa0f3751..6592f2d67f 100644 --- a/testsuite/tests/rep-poly/T19709b.stderr +++ b/testsuite/tests/rep-poly/T19709b.stderr @@ -1,10 +1,13 @@ -T19709b.hs:11:14: error: - • The function argument - ‘(error @Any "e2")’ +T19709b.hs:11:7: error: + • The argument ‘(error @Any "e2")’ of ‘levfun’ does not have a fixed runtime representation. Its type is: a0 :: TYPE Any - • In the first argument of ‘levfun’, namely ‘(error @Any "e2")’ - In the first argument of ‘seq’, namely ‘levfun (error @Any "e2")’ + • In the first argument of ‘seq’, namely ‘levfun (error @Any "e2")’ In the expression: levfun (error @Any "e2") `seq` return [] + In the expression: + let + levfun :: forall (r :: RuntimeRep) (a :: TYPE r). a -> () + levfun = error "e1" + in levfun (error @Any "e2") `seq` return [] diff --git a/testsuite/tests/rep-poly/T20113.hs b/testsuite/tests/rep-poly/T20113.hs index da01589dfb..40184483df 100644 --- a/testsuite/tests/rep-poly/T20113.hs +++ b/testsuite/tests/rep-poly/T20113.hs @@ -1,4 +1,7 @@ {-# LANGUAGE PolyKinds, UnliftedNewtypes, NoFieldSelectors #-} + +module T20113 where + import GHC.Exts newtype Y (a :: TYPE rep) = MkY { y_fld :: a } diff --git a/testsuite/tests/rep-poly/T20113.stderr b/testsuite/tests/rep-poly/T20113.stderr index da8439e9e7..2e51b23d85 100644 --- a/testsuite/tests/rep-poly/T20113.stderr +++ b/testsuite/tests/rep-poly/T20113.stderr @@ -1,6 +1,10 @@ -T20113.hs:4:35: error: - The first pattern in the equation for ‘$sel:y_fld:MkY’ - does not have a fixed runtime representation. - Its type is: - Y a :: TYPE rep +T20113.hs:7:35: error: + • The newtype constructor pattern + does not have a fixed runtime representation. + Its type is: + a :: TYPE rep + • The first pattern in the equation for ‘$sel:y_fld:MkY’ + does not have a fixed runtime representation. + Its type is: + Y a :: TYPE rep diff --git a/testsuite/tests/rep-poly/T20363.hs b/testsuite/tests/rep-poly/T20363.hs index a28e483ffb..f6ab357972 100644 --- a/testsuite/tests/rep-poly/T20363.hs +++ b/testsuite/tests/rep-poly/T20363.hs @@ -12,37 +12,12 @@ module T20363 where import GHC.Exts -data Nat = Zero | Suc Nat +type NilRep :: RuntimeRep +type family NilRep where + NilRep = TupleRep '[] -type NestedTupleRep :: Nat -> RuntimeRep -> RuntimeRep -type family NestedTupleRep n r where - NestedTupleRep Zero r = TupleRep '[] - NestedTupleRep (Suc n) r = TupleRep '[ r, NestedTupleRep n r ] +type UnitTupleNT :: TYPE NilRep +newtype UnitTupleNT = MkNT (# #) -type NestedTuple - :: forall ( n :: Nat ) - -> forall ( r :: RuntimeRep ) - . forall ( a :: TYPE r ) - -> TYPE ( NestedTupleRep n r ) -type family NestedTuple n a where - NestedTuple Zero @r a = (# #) - NestedTuple (Suc n) @r a = (# a, NestedTuple n @r a #) - -type NestedTupleNT - :: forall ( n :: Nat ) - -> forall ( r :: RuntimeRep ) - . forall ( a :: TYPE r ) - -> TYPE ( NestedTupleRep n r ) -newtype NestedTupleNT n (a :: TYPE r) = MkNT ( NestedTuple n a ) - -test1a :: NestedTuple Zero Addr# -> Int -test1a (# #) = 0 - -test2a :: NestedTuple (Suc Zero) Addr# -> Addr# -test2a (# i, (# #) #) = i - -test1b :: NestedTupleNT Zero Addr# -> Int +test1b :: UnitTupleNT -> Int test1b ( MkNT (# #) ) = 0 - -test2b :: NestedTupleNT (Suc Zero) Addr# -> Addr# -test2b ( MkNT (# i, (# #) #) ) = i diff --git a/testsuite/tests/rep-poly/T20363.stderr b/testsuite/tests/rep-poly/T20363.stderr new file mode 100644 index 0000000000..fdc6f94db6 --- /dev/null +++ b/testsuite/tests/rep-poly/T20363.stderr @@ -0,0 +1,12 @@ + +T20363.hs:23:10: error: + • The newtype constructor pattern + does not have a fixed runtime representation. + Its kind is: + TYPE NilRep + (Use -fprint-explicit-coercions to see the full type.) + NB: GHC does not (yet) support rewriting in runtime representations. + Please comment on GHC ticket #13105 if this is causing you trouble. + <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> + • In the pattern: MkNT (##) + In an equation for ‘test1b’: test1b (MkNT (##)) = 0 diff --git a/testsuite/tests/rep-poly/T20363_show_co.hs b/testsuite/tests/rep-poly/T20363_show_co.hs new file mode 100644 index 0000000000..00a3492f3f --- /dev/null +++ b/testsuite/tests/rep-poly/T20363_show_co.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +module T20363_show_co where + +import GHC.Exts + +type NilRep :: RuntimeRep +type family NilRep where + NilRep = TupleRep '[] + +type UnitTupleNT :: TYPE NilRep +newtype UnitTupleNT = MkNT (# #) + +test1b :: UnitTupleNT -> Int +test1b ( MkNT (# #) ) = 0 diff --git a/testsuite/tests/rep-poly/T20363_show_co.stderr b/testsuite/tests/rep-poly/T20363_show_co.stderr new file mode 100644 index 0000000000..6b18496208 --- /dev/null +++ b/testsuite/tests/rep-poly/T20363_show_co.stderr @@ -0,0 +1,12 @@ + +T20363_show_co.hs:23:10: error: + • The newtype constructor pattern + does not have a fixed runtime representation. + Its type is: + ((# #) |> (TYPE (Sym (T20363_show_co.D:R:NilRep[0])))_N) :: TYPE + NilRep + NB: GHC does not (yet) support rewriting in runtime representations. + Please comment on GHC ticket #13105 if this is causing you trouble. + <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> + • In the pattern: MkNT (##) + In an equation for ‘test1b’: test1b (MkNT (##)) = 0 diff --git a/testsuite/tests/rep-poly/T20363b.stderr b/testsuite/tests/rep-poly/T20363b.stderr index 1d657f3237..8d2251390f 100644 --- a/testsuite/tests/rep-poly/T20363b.stderr +++ b/testsuite/tests/rep-poly/T20363b.stderr @@ -1,20 +1,41 @@ -T20363b.hs:51:24: error: - • The function argument - ‘(##)’ +T20363b.hs:45:10: error: + • The newtype constructor pattern does not have a fixed runtime representation. Its type is: NestedTuple 'Zero Addr# :: TYPE (NestedTupleRep 'Zero 'AddrRep) NB: GHC does not (yet) support rewriting in runtime representations. Please comment on GHC ticket #13105 if this is causing you trouble. <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> - • In the first argument of ‘MkNT’, namely ‘(##)’ - In the first argument of ‘test1b’, namely ‘(MkNT (##))’ + • In the pattern: MkNT (##) + In an equation for ‘test1b’: test1b (MkNT (##)) = 0 + +T20363b.hs:48:10: error: + • The newtype constructor pattern + does not have a fixed runtime representation. + Its type is: + NestedTuple ('Suc 'Zero) Addr# :: TYPE + (NestedTupleRep ('Suc 'Zero) 'AddrRep) + NB: GHC does not (yet) support rewriting in runtime representations. + Please comment on GHC ticket #13105 if this is causing you trouble. + <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> + • In the pattern: MkNT (# i, (##) #) + In an equation for ‘test2b’: test2b (MkNT (# i, (##) #)) = i + +T20363b.hs:51:19: error: + • The argument ‘(##)’ of ‘MkNT’ + does not have a fixed runtime representation. + Its type is: + NestedTuple 'Zero Addr# :: TYPE (NestedTupleRep 'Zero 'AddrRep) + NB: GHC does not (yet) support rewriting in runtime representations. + Please comment on GHC ticket #13105 if this is causing you trouble. + <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> + • In the first argument of ‘test1b’, namely ‘(MkNT (##))’ In the expression: test1b (MkNT (##)) + In an equation for ‘test1c’: test1c = test1b (MkNT (##)) -T20363b.hs:54:26: error: - • The function argument - ‘(# nullAddr#, (##) #)’ +T20363b.hs:54:21: error: + • The argument ‘(# nullAddr#, (##) #)’ of ‘MkNT’ does not have a fixed runtime representation. Its type is: NestedTuple ('Suc 'Zero) Addr# :: TYPE @@ -22,7 +43,8 @@ T20363b.hs:54:26: error: NB: GHC does not (yet) support rewriting in runtime representations. Please comment on GHC ticket #13105 if this is causing you trouble. <https://gitlab.haskell.org/ghc/ghc/-/issues/13105> - • In the first argument of ‘MkNT’, namely ‘(# nullAddr#, (##) #)’ - In the first argument of ‘test2b’, namely + • In the first argument of ‘test2b’, namely ‘(MkNT (# nullAddr#, (##) #))’ In the expression: test2b (MkNT (# nullAddr#, (##) #)) + In an equation for ‘test2c’: + test2c _ = test2b (MkNT (# nullAddr#, (##) #)) diff --git a/testsuite/tests/rep-poly/T20426.stderr b/testsuite/tests/rep-poly/T20426.stderr index 9d9db41f8a..9c4f802a1b 100644 --- a/testsuite/tests/rep-poly/T20426.stderr +++ b/testsuite/tests/rep-poly/T20426.stderr @@ -1,6 +1,6 @@ T20426.hs:15:1: error: - The first pattern in the equation for ‘getInt#’ + The first pattern in the equations for ‘getInt#’ does not have a fixed runtime representation. Its type is: LPGADT l :: TYPE ('BoxedRep l) diff --git a/testsuite/tests/rep-poly/all.T b/testsuite/tests/rep-poly/all.T index d035558ef4..e97ae78192 100644 --- a/testsuite/tests/rep-poly/all.T +++ b/testsuite/tests/rep-poly/all.T @@ -24,7 +24,6 @@ test('T20113', normal, compile_fail, ['']) test('T20277', normal, compile_fail, ['']) test('T20330a', normal, compile, ['']) test('T20330b', normal, compile, ['']) -test('T20363', normal, compile, ['']) test('T20423', normal, compile_fail, ['']) test('T20423b', normal, compile_fail, ['']) test('T20426', normal, compile_fail, ['']) @@ -40,12 +39,14 @@ test('RepPolyBackpack3', normal, backpack_compile_fail, ['']) test('RepPolyBackpack4', normal, backpack_run, ['']) test('RepPolyBackpack5', normal, backpack_run, ['']) test('RepPolyBinder', normal, compile_fail, ['']) +test('RepPolyCase1', normal, compile_fail, ['']) test('RepPolyClassMethod', normal, compile_fail, ['']) test('RepPolyDeferred', normal, compile_fail, ['']) test('RepPolyDoBind', normal, compile_fail, ['']) test('RepPolyDoBody1', normal, compile_fail, ['']) test('RepPolyDoBody2', normal, compile_fail, ['']) test('RepPolyDoReturn', normal, compile, ['']) +test('RepPolyFFI', normal, compile, ['']) test('RepPolyLeftSection1', normal, compile, ['']) test('RepPolyLeftSection2', normal, compile_fail, ['']) test('RepPolyMagic', normal, compile_fail, ['']) @@ -70,6 +71,7 @@ test('RepPolyTuple', normal, compile_fail, ['']) test('RepPolyTupleSection', normal, compile_fail, ['']) test('RepPolyUnboxedPatterns', normal, compile_fail, ['']) test('RepPolyUnliftedDatatype', normal, compile, ['']) +test('RepPolyUnliftedDatatype2', normal, compile, ['-O']) test('RepPolyWildcardPattern', normal, compile_fail, ['']) test('RepPolyWrappedVar', normal, compile_fail, ['']) test('RepPolyWrappedVar2', normal, compile, ['']) @@ -86,6 +88,10 @@ test('UnliftedNewtypesLevityBinder', normal, compile_fail, ['']) test('T13105', normal, compile_fail, ['']) ## test('T17021', normal, compile_fail, ['']) ## test('T17536b', normal, compile_fail, ['']) ## +test('T20363', normal, compile_fail, ['']) ## +test('T20363_show_co', normal, compile_fail ## + , ['-fprint-explicit-coercions']) ## test('T20363b', normal, compile_fail, ['']) ## +test('RepPolyCase2', normal, compile_fail, ['']) ## test('RepPolyRule3', normal, compile_fail, ['']) ## ###################################################################### diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr index d6f775fa37..c6bb4c11c8 100644 --- a/testsuite/tests/th/T5358.stderr +++ b/testsuite/tests/th/T5358.stderr @@ -1,12 +1,12 @@ T5358.hs:7:1: error: • Couldn't match expected type ‘Int’ with actual type ‘p1 -> p1’ - • The equation(s) for ‘t1’ have one value argument, + • The equation for ‘t1’ has one value argument, but its type ‘Int’ has none T5358.hs:8:1: error: • Couldn't match expected type ‘Int’ with actual type ‘p0 -> p0’ - • The equation(s) for ‘t2’ have one value argument, + • The equation for ‘t2’ has one value argument, but its type ‘Int’ has none T5358.hs:10:13: error: diff --git a/testsuite/tests/typecheck/should_fail/FD1.stderr b/testsuite/tests/typecheck/should_fail/FD1.stderr index 64a01c43e1..b0beafb416 100644 --- a/testsuite/tests/typecheck/should_fail/FD1.stderr +++ b/testsuite/tests/typecheck/should_fail/FD1.stderr @@ -5,6 +5,6 @@ FD1.hs:16:1: error: the type signature for: plus :: forall a. E a (Int -> Int) => Int -> a at FD1.hs:15:1-38 - • The equation(s) for ‘plus’ have two value arguments, + • The equation for ‘plus’ has two value arguments, but its type ‘Int -> a’ has only one • Relevant bindings include plus :: Int -> a (bound at FD1.hs:16:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail001.stderr b/testsuite/tests/typecheck/should_fail/tcfail001.stderr index 7f49c869ee..3403057fa9 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail001.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail001.stderr @@ -2,7 +2,7 @@ tcfail001.hs:9:2: error: • Couldn't match expected type: [a] with actual type: [a0] -> [a1] - • The equation(s) for ‘op’ have one value argument, + • The equation for ‘op’ has one value argument, but its type ‘[a]’ has none In the instance declaration for ‘A [a]’ • Relevant bindings include op :: [a] (bound at tcfail001.hs:9:2) diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.stderr b/testsuite/tests/typecheck/should_fail/tcfail140.stderr index d40b317130..da0141da67 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail140.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail140.stderr @@ -34,5 +34,5 @@ tcfail140.hs:17:8: error: tcfail140.hs:20:1: error: • Couldn't match expected type ‘Int’ with actual type ‘p0 -> Bool’ - • The equation(s) for ‘g’ have two value arguments, + • The equation for ‘g’ has two value arguments, but its type ‘Int -> Int’ has only one diff --git a/testsuite/tests/typecheck/should_fail/tcfail175.stderr b/testsuite/tests/typecheck/should_fail/tcfail175.stderr index 90ec5b13a5..38597e1487 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail175.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail175.stderr @@ -6,7 +6,7 @@ tcfail175.hs:11:1: error: the type signature for: evalRHS :: forall a. Int -> a at tcfail175.hs:10:1-19 - • The equation(s) for ‘evalRHS’ have three value arguments, + • The equation for ‘evalRHS’ has three value arguments, but its type ‘Int -> a’ has only one • Relevant bindings include evalRHS :: Int -> a (bound at tcfail175.hs:11:1) diff --git a/testsuite/tests/unlifted-datatypes/should_compile/UnlDataFams.hs b/testsuite/tests/unlifted-datatypes/should_compile/UnlDataFams.hs index 8315540fa3..aea373298c 100644 --- a/testsuite/tests/unlifted-datatypes/should_compile/UnlDataFams.hs +++ b/testsuite/tests/unlifted-datatypes/should_compile/UnlDataFams.hs @@ -8,8 +8,8 @@ module UnlDataFams where +import Data.Kind import GHC.Exts -import GHC.Types data family F a :: UnliftedType @@ -26,25 +26,3 @@ data instance G Char :: Type where data family H :: Type -> UnliftedType data instance H Int = HInt Int - -type Interpret :: Bool -> Levity -type family Interpret b where - Interpret True = Lifted - Interpret False = Unlifted - -type A :: TYPE (BoxedRep (Interpret b)) -data A = MkA Int - -a :: A @True -a = MkA 42 - --- type Interpret :: Bool -> RuntimeRep --- type family Interpret b where --- Interpret True = BoxedRep Lifted --- Interpret False = BoxedRep Unlifted --- --- type A :: TYPE (Interpret b) --- data A = MkA Int --- --- data B :: TYPE (Interpret b) where --- MkB :: Int -> B @b |