Commit 9d9eb267 authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Ben Gamari
Browse files

Fix missing unboxed tuple RuntimeReps (#16565)

Unboxed tuples and sums take extra RuntimeRep arguments,
which must be manually passed in a few places.
This was not done in deSugar/Check.

This error was hidden because zipping functions in TyCoRep
ignored lists with mismatching length. This is now fixed;
the lengths are now checked by calling zipEqual.

As suggested in #16565, I moved checking for isTyVar and
isCoVar to zipTyEnv and zipCoEnv.

(cherry picked from commit 69b16331)
parent 8a9cbe08
......@@ -39,6 +39,7 @@ import FastString
import DataCon
import PatSyn
import HscTypes (CompleteMatch(..))
import BasicTypes (Boxity(..))
import DsMonad
import TcSimplify (tcCheckSatisfiability)
......@@ -1072,12 +1073,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
......
......@@ -2499,39 +2499,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!
......@@ -2545,8 +2535,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
......@@ -2562,8 +2556,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)
......
......@@ -359,13 +359,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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,
......@@ -536,12 +536,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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment