[Git][ghc/ghc][wip/T17173] Final wibbles

[Simon Peyton Jones]

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


Commits:
27399067 by Simon Peyton Jones at 2020-04-15T14:04:02+01:00
Final wibbles

Metric Decrease:
    T9961

Reduction of 1.6% in comiler allocation on T9961, I think.

- - - - -


4 changed files:

- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Module.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -131,12 +131,12 @@ tc_poly_expr_nc (L loc expr) res_ty
        ; return $ L loc (mkHsWrap wrap expr') }
 
 ---------------
-tcInferSigma :: LHsExpr GhcRn -> TcM TcSigmaType
+tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
 -- Used by tcRnExpr to implement GHCi :type
 tcInferSigma le@(L loc expr)
   = addExprCtxt le $ setSrcSpan loc $
-    do { (_, _, ty) <- tcInferApp expr
-       ; return ty }
+    do { (fun, args, ty) <- tcInferApp expr
+       ; return (L loc (wrapHsArgs fun args), ty) }
 
 ---------------
 tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)


=====================================
compiler/GHC/Tc/Gen/Expr.hs-boot
=====================================
@@ -15,6 +15,8 @@ tcExpr :: HsExpr GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTcId)
 tcInferRho, tcInferRhoNC
   :: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcRhoType)
 
+tcInferSigma :: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcSigmaType)
+
 tcSyntaxOp :: CtOrigin
            -> SyntaxExprRn
            -> [SyntaxOpType]           -- ^ shape of syntax operator arguments


=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -28,7 +28,7 @@ where
 
 import GhcPrelude
 
-import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )
+import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )
 
 import GHC.Hs
 import GHC.Tc.Utils.Zonk
@@ -409,7 +409,9 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
          -- An exotic example:
          --    pair :: forall a. a -> forall b. b -> (a,b)
          --    f (pair True -> x) = ...here (x :: forall b. b -> (Bool,b))
-        ; (expr',expr_ty) <- tcInferRho expr
+         --
+         -- TEMPORARY: pending simple subsumption, use tcInferSigma
+        ; (expr',expr_ty) <- tcInferSigma expr
 
          -- Expression must be a function
         ; let expr_orig = lexprCtOrigin expr


=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2489,7 +2489,7 @@ tcRnExpr hsc_env mode rdr_expr
         -- it might have a rank-2 type (e.g. :t runST)
     uniq <- newUnique ;
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
-    ((tclvl, res_ty), lie)
+    ((tclvl, (_tc_expr, res_ty)), lie)
           <- captureTopConstraints $
              pushTcLevelM          $
              tc_infer rn_expr ;
@@ -2518,8 +2518,7 @@ tcRnExpr hsc_env mode rdr_expr
     return (snd (normaliseType fam_envs Nominal ty))
     }
   where
-    tc_infer expr | inst      = do { (_, ty) <- tcInferRho expr
-                                   ; return ty }
+    tc_infer expr | inst      = tcInferRho expr
                   | otherwise = tcInferSigma expr
 
     -- See Note [TcRnExprMode]



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27399067b5ff7c335e5bf1f2bc7490f8f8e5027d
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/20200415/2a1d80a5/attachment-0001.html>