[Git][ghc/ghc][wip/romes/9557] deriving Traversable: Eta reduce more constructor

[Rodrigo Mesquita (@alt-romes)]

Rodrigo Mesquita pushed to branch wip/romes/9557 at Glasgow Haskell Compiler / GHC


Commits:
e59b353d by Rodrigo Mesquita at 2024-11-10T14:59:20+00:00
deriving Traversable: Eta reduce more constructor

We were generating unnecessarily eta-expanded lambdas in derived
Traversable instances (via mkSimpleConMatch2).

We can generate smaller code by eta-reducing all trailing arguments
which do mention the last type variable

- - - - -


2 changed files:

- compiler/GHC/Tc/Deriv/Functor.hs
- testsuite/tests/deriving/should_compile/T20496.stderr


Changes:

=====================================
compiler/GHC/Tc/Deriv/Functor.hs
=====================================
@@ -689,9 +689,18 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do
         con_expr
           | null asWithTyVar = nlHsApps con_name asWithoutTyVar
           | otherwise =
-              let bs   = filterByList  argTysTyVarInfo bs_RDRs
-                  vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
-              in mkHsLam (noLocA (map nlVarPat bs)) (nlHsApps con_name vars)
+              let -- All trailing b-args can be eta-reduced:
+                  -- (\b1 b2 b3 -> A b1 a2 b2 b3) ==> (\b1 -> A b1 a2)
+                  -- This improves the number of allocations needed to compile
+                  -- the generated code (it is not relevant for correctness)
+                  -- We do this by counting the n of args to keep
+                  keep_n = length $ dropWhile (== True) $ reverse argTysTyVarInfo
+                  bs   = filterByList (take keep_n argTysTyVarInfo) bs_RDRs
+                  vars = take keep_n $
+                         filterByLists argTysTyVarInfo bs_Vars as_Vars
+               in if keep_n == 0
+                    then nlHsVar con_name
+                    else mkHsLam (noLocA (map nlVarPat bs)) (nlHsApps con_name vars)
 
     rhs <- fold con_expr exps
     return $ mkMatch ctxt (noLocA (extra_pats ++ [pat])) rhs emptyLocalBinds


=====================================
testsuite/tests/deriving/should_compile/T20496.stderr
=====================================
@@ -32,5 +32,5 @@ rnd
     null (MkT _) = False
   
   instance Traversable T where
-    traverse f (MkT a1) = fmap (\ b1 -> MkT b1) (f a1)
+    traverse f (MkT a1) = fmap MkT (f a1)
 



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

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