[Git][ghc/ghc][wip/fix-zipping] Fix missing unboxed tuple RuntimeReps (#16565)

[Krzysztof Gogolewski]

Krzysztof Gogolewski pushed to branch wip/fix-zipping at Glasgow Haskell Compiler / GHC


Commits:
b4a7261e by Krzysztof Gogolewski at 2019-05-17T23:01:58Z
Fix missing unboxed tuple RuntimeReps (#16565)

Unboxed tuples and sums take extra RuntimeRep arguments,
which must be manually passed in a few places.
Three of them were missed.

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/hsSyn/HsPat.hs
- compiler/types/TyCoRep.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]
+                 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]
+    return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p]
 
   -- --------------------------------------------------------------------------
   -- Not supposed to happen


=====================================
compiler/hsSyn/HsPat.hs
=====================================
@@ -622,8 +622,12 @@ mkPrefixConPat dc pats tys
                       , pat_dicts = []
                       , pat_binds = emptyTcEvBinds
                       , pat_args = PrefixCon pats
-                      , pat_arg_tys = tys
+                      , pat_arg_tys = tys'
                       , pat_wrap = idHsWrapper }
+  where tys' = if isUnboxedTupleCon dc || isUnboxedSumCon dc
+               -- See Note [Unboxed tuple RuntimeRep vars]
+               then map getRuntimeRep tys ++ tys
+               else tys
 
 mkNilPat :: Type -> OutPat (GhcPass p)
 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]


=====================================
compiler/types/TyCoRep.hs
=====================================
@@ -2965,10 +2965,6 @@ unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)
 -- environment. No CoVars, please!
 zipTvSubst :: [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
@@ -2977,25 +2973,19 @@ zipTvSubst tvs tys
 -- environment.  No TyVars, please!
 zipCvSubst :: [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 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!
@@ -3011,6 +3001,10 @@ mkTvSubstPrs prs =
 
 zipTyEnv :: [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
@@ -3027,7 +3021,12 @@ zipTyEnv tyvars tys
         -- Simplest fix is to nuke the "optimisation"
 
 zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv
-zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos)
+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/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/b4a7261e982e92e08d71e76746e7e07fed8b47ae

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/b4a7261e982e92e08d71e76746e7e07fed8b47ae
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/20190517/f3e436c2/attachment-0001.html>