diff options
-rw-r--r-- | compiler/deSugar/Check.hs | 10 | ||||
-rw-r--r-- | compiler/types/TyCoRep.hs | 37 | ||||
-rw-r--r-- | compiler/types/TyCon.hs | 26 | ||||
-rw-r--r-- | compiler/utils/Util.hs | 8 |
4 files changed, 47 insertions, 34 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index e87eb39d26..4a27d485c0 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -43,6 +43,7 @@ import FastString import DataCon import PatSyn import HscTypes (CompleteMatch(..)) +import BasicTypes (Boxity(..)) import DsMonad import TcSimplify (tcCheckSatisfiability) @@ -1078,12 +1079,17 @@ translatePat fam_insts pat = case pat of TuplePat tys ps boxity -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) - return [vanillaConPattern tuple_con tys (concat tidy_ps)] + tys' = case boxity of + Boxed -> tys + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + Unboxed -> map getRuntimeRep tys ++ tys + return [vanillaConPattern tuple_con tys' (concat tidy_ps)] SumPat ty p alt arity -> do tidy_p <- translatePat fam_insts (unLoc p) let sum_con = RealDataCon (sumDataCon alt arity) - return [vanillaConPattern sum_con ty tidy_p] + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p] -- -------------------------------------------------------------------------- -- Not supposed to happen diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index c90f54d8db..4bc2ff013d 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -2963,39 +2963,29 @@ unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming -- environment. No CoVars, please! -zipTvSubst :: [TyVar] -> [Type] -> TCvSubst +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst zipTvSubst tvs tys - | debugIsOn - , not (all isTyVar tvs) || neLength tvs tys - = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst - | otherwise = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv where tenv = zipTyEnv tvs tys -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming -- environment. No TyVars, please! -zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst zipCvSubst cvs cos - | debugIsOn - , not (all isCoVar cvs) || neLength cvs cos - = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst - | otherwise = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv where cenv = zipCoEnv cvs cos -zipTCvSubst :: [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst zipTCvSubst tcvs tys - | debugIsOn - , neLength tcvs tys - = pprTrace "zipTCvSubst" (ppr tcvs $$ ppr tys) emptyTCvSubst - | otherwise = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst zip_tcvsubst (tv:tvs) (ty:tys) subst = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) - zip_tcvsubst _ _ subst = subst -- empty case + zip_tcvsubst [] [] subst = subst -- empty case + zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" + (ppr tcvs <+> ppr tys) -- | Generates the in-scope set for the 'TCvSubst' from the types in the -- incoming environment. No CoVars, please! @@ -3009,8 +2999,12 @@ mkTvSubstPrs prs = and [ isTyVar tv && not (isCoercionTy ty) | (tv, ty) <- prs ] -zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys + | debugIsOn + , not (all isTyVar tyvars) + = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) + | otherwise = ASSERT( all (not . isCoercionTy) tys ) mkVarEnv (zipEqual "zipTyEnv" tyvars tys) -- There used to be a special case for when @@ -3026,8 +3020,13 @@ zipTyEnv tyvars tys -- -- Simplest fix is to nuke the "optimisation" -zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv -zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos) +zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos + | debugIsOn + , not (all isCoVar cvs) + = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) + | otherwise + = mkVarEnv (zipEqual "zipCoEnv" cvs cos) instance Outputable TCvSubst where ppr (TCvSubst ins tenv cenv) diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index cdfcf181a5..54a57cfc45 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -358,13 +358,27 @@ Note [Unboxed tuple RuntimeRep vars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The contents of an unboxed tuple may have any representation. Accordingly, the kind of the unboxed tuple constructor is runtime-representation -polymorphic. For example, +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no levity polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> # - -These extra tyvars (v and w) cause some delicate processing around tuples, -where we used to be able to assume that the tycon arity and the -datacon arity were the same. Note [Injective type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index c07b87f547..e923cea9bf 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -35,7 +35,7 @@ module Util ( lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, listLengthCmp, atLength, - equalLength, neLength, compareLength, leLength, ltLength, + equalLength, compareLength, leLength, ltLength, isSingleton, only, singleton, notNull, snocView, @@ -535,12 +535,6 @@ equalLength [] [] = True equalLength (_:xs) (_:ys) = equalLength xs ys equalLength _ _ = False -neLength :: [a] -> [b] -> Bool --- ^ True if length xs /= length ys -neLength [] [] = False -neLength (_:xs) (_:ys) = neLength xs ys -neLength _ _ = True - compareLength :: [a] -> [b] -> Ordering compareLength [] [] = EQ compareLength (_:xs) (_:ys) = compareLength xs ys |