[Git][ghc/ghc][wip/romes/9557] Dont' eta expand cons when deriving Data

[Rodrigo Mesquita (@alt-romes)]

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


Commits:
aa1bf18e by Rodrigo Mesquita at 2024-10-26T11:05:12+01:00
Dont' eta expand cons when deriving Data

This eta expansion was introduced with the initial commit for Linear
types.

I believe this isn't needed any longer. My guess is it is an artifact
from the initial linear types implementation: data constructors are
linear, but they shouldn't need to be eta expanded to be used as higher
order functions. I suppose in the early days this wasn't true.

For instance, this works now:

    data T x = T x
    f = \(x :: forall y. y -> T y) -> x True
    f T -- ok!

T is linear, but can be passed where an unrestricted higher order
function is expected. I recall there being some magic around to make
this work for data constructors...

Since this works, there's no need to eta_expand the data constructors in
the derived Data instances.

On my machine, this brings the module from #9557 with deriving Data from:
* 8s to 6.2s with -O0
* 13s to 9.7s with -O1

- - - - -


1 changed file:

- compiler/GHC/Tc/Deriv/Generate.hs


Changes:

=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -1404,7 +1404,7 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
 
     gfoldl_eqn con
       = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
-                   foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed)
+                   foldl' mk_k_app (z_Expr `nlHsApp` (nlHsVar (getRdrName con))) as_needed)
                    where
                      con_name ::  RdrName
                      con_name = getRdrName con
@@ -1424,16 +1424,17 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
 
     gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
     mk_unfold_rhs dc = foldr nlHsApp
-                           (z_Expr `nlHsApp` (eta_expand_data_con dc))
+                           (z_Expr `nlHsApp` (nlHsVar (getRdrName dc)))
                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
 
-    eta_expand_data_con dc =
-        mkHsLam (noLocA eta_expand_pats)
-          (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)
-      where
-        eta_expand_pats = map nlVarPat eta_expand_vars
-        eta_expand_hsvars = map nlHsVar eta_expand_vars
-        eta_expand_vars = take (dataConSourceArity dc) as_RDRs
+    -- This was needed by the original implementation of Linear Types. But not anymore...?
+    -- eta_expand_data_con dc =
+    --     mkHsLam (noLocA eta_expand_pats)
+    --       (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)
+      -- where
+      --   eta_expand_pats = map nlVarPat eta_expand_vars
+      --   eta_expand_hsvars = map nlHsVar eta_expand_vars
+      --   eta_expand_vars = take (dataConSourceArity dc) as_RDRs
 
 
     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
@@ -2570,10 +2571,10 @@ as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) ..
 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
 
-a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
+a_Expr, {- b_Expr, -} c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
     true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs
 a_Expr                = nlHsVar a_RDR
-b_Expr                = nlHsVar b_RDR
+-- b_Expr                = nlHsVar b_RDR
 c_Expr                = nlHsVar c_RDR
 z_Expr                = nlHsVar z_RDR
 ltTag_Expr            = nlHsVar ltTag_RDR



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa1bf18ef4111055c4b4d22c473b9715d3b7f909
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/20241026/89bb9732/attachment-0001.html>