[Git][ghc/ghc][master] Don't generalize when typechecking a tuple section
Marge Bot
gitlab at gitlab.haskell.org
Sat Jun 27 15:57:55 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0e83efa2 by Krzysztof Gogolewski at 2020-06-27T11:57:49-04:00
Don't generalize when typechecking a tuple section
The code is simpler and cleaner.
- - - - -
6 changed files:
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Utils/Zonk.hs
Changes:
=====================================
compiler/GHC/Builtin/Types/Prim.hs
=====================================
@@ -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)
{-
************************************************************************
* *
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -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
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -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)
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -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
---------
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -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')) }
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -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')) }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e83efa24636c72811e4c79fe1c7e4f7cf3170cd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e83efa24636c72811e4c79fe1c7e4f7cf3170cd
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/20200627/cb593135/attachment-0001.html>
More information about the ghc-commits
mailing list