From 807bd8bfff9914b41473ddb7031ba7dfc36520f8 Mon Sep 17 00:00:00 2001
From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Tue, 27 Aug 2024 11:20:03 +0200
Subject: [PATCH] Fix eta-expansion in evaluator (#2782)

For some eta-reduced 'e', we used to bogusly eta-expand to:

\x.(\y. e y) x

We now correctly expand to:

\x.\y.(e x) y

Fixes #2781

(cherry picked from commit f946617561565440d82f67747acb2486f6526a66)
---
 changelog/2024-08-05T22_45_27+02_00_fix2781 |  1 +
 clash-ghc/src-ghc/Clash/GHC/Evaluator.hs    | 27 +++++++++-------
 tests/Main.hs                               |  1 +
 tests/shouldwork/Issues/T2781.hs            | 35 +++++++++++++++++++++
 4 files changed, 52 insertions(+), 12 deletions(-)
 create mode 100644 changelog/2024-08-05T22_45_27+02_00_fix2781
 create mode 100644 tests/shouldwork/Issues/T2781.hs

diff --git a/changelog/2024-08-05T22_45_27+02_00_fix2781 b/changelog/2024-08-05T22_45_27+02_00_fix2781
new file mode 100644
index 0000000000..f7b5cd37e6
--- /dev/null
+++ b/changelog/2024-08-05T22_45_27+02_00_fix2781
@@ -0,0 +1 @@
+FIXED: Bug in the compile-time evaluator [#2781](https://github.com/clash-lang/clash-compiler/issues/2781)
diff --git a/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs b/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs
index cfc82a2b78..f393ebdb0f 100644
--- a/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs
+++ b/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs
@@ -265,19 +265,22 @@ ghcStep m = case mTerm m of
 -- for each one around the given term.
 --
 newBinder :: [Either TyVar Type] -> Term -> Step
-newBinder tys x m tcm =
-  let (s', iss', x') = mkAbstr (mSupply m, mScopeNames m, x) tys
-      m' = m { mSupply = s', mScopeNames = iss', mTerm = x' }
-   in ghcStep m' tcm
+newBinder tys e m tcm =
+  let ((supply1,_), e1) = etaExpand (mSupply m, mScopeNames m) tys
+      m1 = m { mSupply = supply1, mTerm = e1 }
+   in ghcStep m1 tcm
  where
-  mkAbstr = foldr go
-    where
-      go (Left tv) (s', iss', e') =
-        (s', iss', TyLam tv (TyApp e' (VarTy tv)))
-
-      go (Right ty) (s', iss', e') =
-        let ((s'', _), n) = mkUniqSystemId (s', iss') ("x", ty)
-        in  (s'', iss' ,Lam n (App e' (Var n)))
+  etaExpand env args =
+    let (env1,args1) = mapAccumL go env args
+     in (env1,mkAbstraction (foldl' go2 e args1) args1)
+
+  go env (Left tv) = (env, Right tv)
+  go env (Right ty) =
+    let (env1, n) = mkUniqSystemId env ("x", ty)
+     in (env1, Left n)
+
+  go2 u (Left i) = App u (Var i)
+  go2 u (Right tv) = TyApp u (VarTy tv)
 
 newLetBinding
   :: TyConMap
diff --git a/tests/Main.hs b/tests/Main.hs
index 2cc4fd2de7..cb4589aaba 100755
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -789,6 +789,7 @@ runClashTest = defaultMain $ clashTestRoot
         , outputTest "T2542" def{hdlTargets=[VHDL]}
         , runTest "T2593" def{hdlSim=[]}
         , runTest "T2623CaseConFVs" def{hdlLoad=[],hdlSim=[],hdlTargets=[VHDL]}
+        , runTest "T2781" def{hdlLoad=[],hdlSim=[],hdlTargets=[VHDL]}
         ] <>
         if compiledWith == Cabal then
           -- This tests fails without environment files present, which are only
diff --git a/tests/shouldwork/Issues/T2781.hs b/tests/shouldwork/Issues/T2781.hs
new file mode 100644
index 0000000000..03f47ff9ac
--- /dev/null
+++ b/tests/shouldwork/Issues/T2781.hs
@@ -0,0 +1,35 @@
+module T2781
+  ( fullMeshSwCcTest
+  ) where
+
+import Clash.Explicit.Prelude
+import Clash.Cores.Xilinx.Ila (IlaConfig(..), Depth(..), ila, ilaConfig)
+
+fullMeshHwTestDummy ::
+  Clock System ->
+  (  Signal System Bool
+  ,  Vec 1 (Signal System Bool)
+  )
+fullMeshHwTestDummy sysClk =
+  fincFdecIla `hwSeqX`
+  ( pure False
+  , repeat (pure True)
+  )
+ where
+  fincFdecIla :: Signal System ()
+  fincFdecIla = ila
+    (ilaConfig ("trigger_0" :> Nil))
+    sysClk
+    (pure True :: Signal System Bool)
+
+-- | Top entity for this test. See module documentation for more information.
+fullMeshSwCcTest ::
+  Clock System ->
+  (Signal System Bool
+  )
+fullMeshSwCcTest sysClk = spiDone
+ where
+  (spiDone
+    , ugnsStable
+    ) = fullMeshHwTestDummy sysClk
+{-# ANN fullMeshSwCcTest (defSyn "fullMeshSwCcTest") #-}