Commit 0e83efa2 authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Marge Bot

Don't generalize when typechecking a tuple section

The code is simpler and cleaner.
parent a04020b8
Pipeline #21581 failed with stages
in 861 minutes and 26 seconds
......@@ -27,7 +27,6 @@ module GHC.Builtin.Types.Prim(
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,
multiplicityTyVar,
multiplicityTyVarList,
-- Kind constructors...
tYPETyCon, tYPETyConName,
......@@ -392,11 +391,6 @@ openBetaTy = mkTyVarTy openBetaTyVar
multiplicityTyVar :: TyVar
multiplicityTyVar = mkTemplateTyVars (repeat multiplicityTy) !! 13 -- selects 'n'
-- Create 'count' multiplicity TyVars
multiplicityTyVarList :: Int -> [TyVar]
multiplicityTyVarList count = take count $
drop 13 $ -- selects 'n', 'o'...
mkTemplateTyVars (repeat multiplicityTy)
{-
************************************************************************
* *
......
......@@ -740,7 +740,7 @@ type instance XPresent (GhcPass _) = NoExtField
type instance XMissing GhcPs = NoExtField
type instance XMissing GhcRn = NoExtField
type instance XMissing GhcTc = Type
type instance XMissing GhcTc = Scaled Type
type instance XXTupArg (GhcPass _) = NoExtCon
......
......@@ -64,7 +64,6 @@ import GHC.Types.Basic
import GHC.Data.Maybe
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
import GHC.Builtin.Types.Prim ( mkTemplateTyVars )
import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
......@@ -427,26 +426,22 @@ dsExpr e@(SectionR _ op expr) = do
core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple _ tup_args boxity)
= do { let go (lam_vars, args, usedmults, mult:mults) (L _ (Missing ty))
= do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty)))
-- For every missing expression, we need
-- another lambda in the desugaring. This lambda is linear
-- since tuples are linear
= do { lam_var <- newSysLocalDsNoLP (mkTyVarTy mult) ty
; return (lam_var : lam_vars, Var lam_var : args, mult:usedmults, mults) }
go (lam_vars, args, missing, mults) (L _ (Present _ expr))
-- another lambda in the desugaring.
= do { lam_var <- newSysLocalDsNoLP mult ty
; return (lam_var : lam_vars, Var lam_var : args) }
go (lam_vars, args) (L _ (Present _ expr))
-- Expressions that are present don't generate
-- lambdas, just arguments.
= do { core_expr <- dsLExprNoLP expr
; return (lam_vars, core_expr : args, missing, mults) }
go (lam_vars, args, missing, mults) _ = pprPanic "dsExpr" (ppr lam_vars <+> ppr args <+> ppr missing <+> ppr mults)
; return (lam_vars, core_expr : args) }
; let multiplicityVars = mkTemplateTyVars (repeat multiplicityTy)
; dsWhenNoErrs (foldM go ([], [], [], multiplicityVars) (reverse tup_args))
; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
-- The reverse is because foldM goes left-to-right
(\(lam_vars, args, usedmults, _) ->
mkCoreLams usedmults $
(\(lam_vars, args) ->
mkCoreLams lam_vars $
mkCoreTupBoxity boxity args) }
mkCoreTupBoxity boxity args) }
-- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
dsExpr (ExplicitSum types alt arity expr)
......
......@@ -1109,7 +1109,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
---------
tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
tup_arg (L _ (Missing (Scaled _ t1))) (L _ (Missing (Scaled _ t2))) = eqType t1 t2
tup_arg _ _ = False
---------
......
......@@ -71,7 +71,6 @@ import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim( multiplicityTyVarList )
import GHC.Builtin.PrimOps( tagToEnumKey )
import GHC.Builtin.Names
import GHC.Driver.Session
......@@ -500,22 +499,17 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
-- Handle tuple sections where
; tup_args1 <- tcTupArgs tup_args arg_tys
; let expr' = ExplicitTuple x tup_args1 boxity
; let expr' = ExplicitTuple x tup_args1 boxity
missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys]
missing_tys = [ty | (ty, L _ (Missing _)) <- zip arg_tys tup_args]
w_tyvars = multiplicityTyVarList (length missing_tys)
-- See Note [Linear fields generalization]
w_tvb = map (mkTyVarBinder Inferred) w_tyvars
-- See Note [Linear fields generalization]
act_res_ty
= mkForAllTys w_tvb $
mkVisFunTys [ mkScaled (mkTyVarTy w_ty) ty |
(ty, w_ty) <- zip missing_tys w_tyvars]
(mkTupleTy1 boxity arg_tys)
= mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)
-- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)
; tcWrapResult expr expr' act_res_ty res_ty }
; tcWrapResultMono expr expr' act_res_ty res_ty }
tcExpr (ExplicitSum _ alt arity expr) res_ty
= do { let sum_tc = sumTyCon arity
......@@ -1557,7 +1551,8 @@ tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]
tcTupArgs args tys
= ASSERT( equalLength args tys ) mapM go (args `zip` tys)
where
go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy
; return (L l (Missing (Scaled mult arg_ty))) }
go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty
; return (L l (Present x expr')) }
......
......@@ -811,7 +811,7 @@ zonkExpr env (ExplicitTuple x tup_args boxed)
where
zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
; return (L l (Present x e')) }
zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
zonk_tup_arg (L l (Missing t)) = do { t' <- zonkScaledTcTypeToTypeX env t
; return (L l (Missing t')) }
......
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