Fix missing unboxed tuple RuntimeReps (#16565)
authorKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Sun, 5 May 2019 18:37:31 +0000 (20:37 +0200)
committerBen Gamari <ben@smart-cactus.org>
Mon, 24 Jun 2019 22:35:12 +0000 (18:35 -0400)
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 69b1633104a43d5654e65f2c05fa6b73775936e2)

compiler/deSugar/Check.hs
compiler/types/TyCoRep.hs
compiler/types/TyCon.hs
compiler/utils/Util.hs

index 81832c8..1cd185d 100644 (file)
@@ -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
index 0a628e1..eac3c25 100644 (file)
@@ -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)
index eb0b84d..03749e3 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 16eeea5..46ef0e6 100644 (file)
@@ -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