[Git][ghc/ghc][wip/fix-zipping] Fix missing unboxed tuple RuntimeReps (#16565)
Krzysztof Gogolewski
gitlab at gitlab.haskell.org
Tue May 21 09:14:37 UTC 2019
Krzysztof Gogolewski pushed to branch wip/fix-zipping at Glasgow Haskell Compiler / GHC
Commits:
73d55913 by Krzysztof Gogolewski at 2019-05-21T08:41:40Z
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.
- - - - -
4 changed files:
- compiler/deSugar/Check.hs
- compiler/types/TyCoRep.hs
- compiler/types/TyCon.hs
- compiler/utils/Util.hs
Changes:
=====================================
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
=====================================
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)
=====================================
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/73d559136814e3ed9dcbab19ec4d746a7ee3173d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/73d559136814e3ed9dcbab19ec4d746a7ee3173d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190521/036384b3/attachment-0001.html>
More information about the ghc-commits
mailing list