Fix eta-expansion in evaluator (copy #2782)

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)

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

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

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") #-}