diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/DataCon.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Core/Type.hs | 8 |
4 files changed, 15 insertions, 11 deletions
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 064cdc866f..7e18b471f3 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -250,6 +250,8 @@ in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep. * Type variables may be permuted; see MkId Note [Data con wrappers and GADT syntax] +* Datatype contexts require dropping some dictionary arguments. + See Note [Instantiating stupid theta]. Note [The stupid context] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1449,9 +1451,9 @@ dataConWrapperType :: DataCon -> Type -- mentions the family tycon, not the internal one. dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) + dcOrigResTy = res_ty, dcStupidTheta = stupid }) = mkInvisForAllTys user_tvbs $ - mkInvisFunTysMany theta $ + mkInvisFunTysMany (stupid ++ theta) $ mkVisFunTys arg_tys $ res_ty diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 0511a4004d..b336bdef09 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -922,7 +922,7 @@ lintCoreExpr (Lit lit) = return (literalType lit, zeroUE) lintCoreExpr (Cast expr co) - = do (expr_ty, ue) <- markAllJoinsBad $ lintCoreExpr expr + = do (expr_ty, ue) <- markAllJoinsBad $ lintCoreExpr expr to_ty <- lintCastExpr expr expr_ty co return (to_ty, ue) @@ -1216,7 +1216,7 @@ checkCanEtaExpand (Var fun_id) args app_ty = ty : go (i+1) bndrs bad_arg_tys :: [Type] - bad_arg_tys = check_args . map fst $ getRuntimeArgTys app_ty + bad_arg_tys = check_args . map (scaledThing . fst) $ getRuntimeArgTys app_ty -- We use 'getRuntimeArgTys' to find all the argument types, -- including those hidden under newtypes. For example, -- if `FunNT a b` is a newtype around `a -> b`, then diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index f052bae942..a84ca01536 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -2904,9 +2904,11 @@ doCaseToLet scrut case_bndr | isTyCoVar case_bndr -- Respect GHC.Core = isTyCoArg scrut -- Note [Core type and coercion invariant] - | isUnliftedType (idType case_bndr) - -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase) - = exprOkForSpeculation scrut + | isUnliftedType (exprType scrut) + -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). + -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' + -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. + = exprOkForSpeculation scrut | otherwise -- Scrut has a lifted type = exprIsHNF scrut diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 419c0c8806..7029125768 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -2153,14 +2153,14 @@ splitPiTys ty = split ty ty [] -- newtype N a = MkN (a -> N a) -- getRuntimeArgTys (N a) == repeat (a, VisArg) -- @ -getRuntimeArgTys :: Type -> [(Type, AnonArgFlag)] +getRuntimeArgTys :: Type -> [(Scaled Type, AnonArgFlag)] getRuntimeArgTys = go where - go :: Type -> [(Type, AnonArgFlag)] + go :: Type -> [(Scaled Type, AnonArgFlag)] go (ForAllTy _ res) = go res - go (FunTy { ft_arg = arg, ft_res = res, ft_af = af }) - = (arg, af) : go res + go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af }) + = (Scaled w arg, af) : go res go ty | Just ty' <- coreView ty = go ty' |