[Git][ghc/ghc][wip/romes/9557] 4 commits: 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:
d3f89b92 by Rodrigo Mesquita at 2024-10-28T17:30:54+00: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.

- - - - -
48cc6c0c by Rodrigo Mesquita at 2024-10-29T11:30:37+00:00
deriving Traversable: Eta reduce more constructor

- - - - -
21fcec77 by Rodrigo Mesquita at 2024-10-29T15:53:54+00:00
X WRNOG BRANCH

- - - - -
8cfd8dd4 by Rodrigo Mesquita at 2024-10-29T15:53:57+00:00
Revert "X WRNOG BRANCH"

This reverts commit 21fcec778136c0e9dbe8274c3329befee1136da9.

- - - - -


2 changed files:

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


Changes:

=====================================
compiler/GHC/Tc/Deriv/Functor.hs
=====================================
@@ -689,9 +689,16 @@ 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)
+                  -- 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


=====================================
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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36c10986dd71c60e106891dfe333f93255cd0332...8cfd8dd40b50bd5302092982abdad1ffa34f8a38

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36c10986dd71c60e106891dfe333f93255cd0332...8cfd8dd40b50bd5302092982abdad1ffa34f8a38
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/20241029/0b676706/attachment-0001.html>