[Git][ghc/ghc][wip/T25445b] Wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T25445b at Glasgow Haskell Compiler / GHC


Commits:
ad2315ee by Simon Peyton Jones at 2024-11-30T23:43:02+00:00
Wibbles

- - - - -


3 changed files:

- compiler/GHC/Core/Lint.hs
- compiler/GHC/Iface/Type.hs
- testsuite/tests/perf/compiler/genT14766.py


Changes:

=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -2101,13 +2101,14 @@ lint_tyco_app msg fun_kind arg_tys
        ; return () }
 
 ----------------
-lint_app2 :: Outputable a => SDoc
+lint_app2 :: forall a acc. Outputable a =>
+             SDoc
           -> (a -> LintM OutType)                        -- Lint the thing and return its value
           -> (a -> Mult -> acc -> LintM (OutKind, acc))  -- Lint the thing and return its type
           -> OutType -> acc -> [a] -> LintM (OutType,acc)
 {-# INLINE lint_app2 #-}    -- Very few call sites
 -- 'acc' is either () for types, or UsageEnv for terms
-lint_app2 msg lint_val lint_ty !orig_fun_ty acc all_args
+lint_app2 msg lint_forall_arg lint_arrow_arg !orig_fun_ty acc all_args
     = do { !in_scope <- getInScope
          -- We need the in_scope set to satisfy the invariant in
          -- Note [The substitution invariant] in GHC.Core.TyCo.Subst
@@ -2115,10 +2116,12 @@ lint_app2 msg lint_val lint_ty !orig_fun_ty acc all_args
 
          ; let init_subst = mkEmptySubst in_scope
 
+               go :: Subst -> OutType -> acc -> [a] -> LintM (OutType, acc)
+                     -- The Subst applies (only) to the fun_ty
                go subst fun_ty acc [] = return (substTy subst fun_ty, acc)
 
                go subst fun_ty@(FunTy _ mult exp_arg_ty res_ty) acc (arg:args)
-                 = do { (arg_ty, acc') <- lint_ty arg mult acc
+                 = do { (arg_ty, acc') <- lint_arrow_arg arg (substTy subst mult) acc
                       ; ensureEqTys (substTy subst exp_arg_ty) arg_ty $
                         lint_app_fail_msg msg orig_fun_ty all_args
                             (hang (text "Fun:" <+> ppr fun_ty)
@@ -2127,7 +2130,7 @@ lint_app2 msg lint_val lint_ty !orig_fun_ty acc all_args
                       ; go subst res_ty acc' args }
 
                go subst (ForAllTy (Bndr tv _vis) body_ty) acc (arg:args)
-                 = do { arg' <- lint_val arg
+                 = do { arg' <- lint_forall_arg arg
                       ; let tv_kind = substTy subst (varType tv)
                             karg'   = typeKind arg'
                             subst'  = extendTCvSubst subst tv arg'
@@ -3417,7 +3420,7 @@ addInScopeTyCoVar tcv tcv_type thing_inside
       | isEmptyTCvSubst subst                -- No change in kind
       , not (tcv `elemInScopeSet` in_scope)  -- No change in unique
       = -- Do not extend the substitution, just the in-scope set
-        (if (varType tcv `eqType` tcv_type) then (\x->x) else 
+        (if (varType tcv `eqType` tcv_type) then (\x->x) else
           pprTrace "addInScopeTyCoVar" (
             vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv)
                  , text "tcv_type" <+> ppr tcv_type ])) $


=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1980,7 +1980,7 @@ ppr_co ctxt_prec (IfaceFunCo r co_mult co1 co2)
     mb_conc _                        = Nothing
 
 ppr_co _         (IfaceTyConAppCo r tc cos)
-  = parens (text "tcapp" <+> pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
+  = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
 ppr_co ctxt_prec (IfaceAppCo co1 co2)
   = maybeParen ctxt_prec appPrec $
     ppr_co funPrec co1 <+> pprParendIfaceCoercion co2


=====================================
testsuite/tests/perf/compiler/genT14766.py
=====================================
@@ -1,12 +1,8 @@
 #!/usr/bin/env python3
 # -*- coding: utf-8 -*-
 
-# N_VARS = 100
-# N_BINDS = 50
-
-N_VARS = 600
-# N_VARS = 10
-N_BINDS = 1
+N_VARS = 100
+N_BINDS = 50
 
 tyvars = ' '.join('v{i}'.format(i=i) for i in range(N_VARS))
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad2315ee4b36092299b64872d2fcd8c541e71c02

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad2315ee4b36092299b64872d2fcd8c541e71c02
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/20241130/96ae294b/attachment-0001.html>