From 5a0a5e9ef69926265289ae5229e68060a7c77a27 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Wed, 18 Jun 2025 10:29:16 +0200
Subject: Don't introduce sparsity if zero is cheap

---
 src/CHAD.hs | 37 +++++++++++++++++++++++++------------
 1 file changed, 25 insertions(+), 12 deletions(-)

(limited to 'src/CHAD.hs')

diff --git a/src/CHAD.hs b/src/CHAD.hs
index 9a08457..143376a 100644
--- a/src/CHAD.hs
+++ b/src/CHAD.hs
@@ -423,18 +423,31 @@ subenvPlus req1 SF (SCons _ env) (SEYes sp1 sub1) (SENo sub2) k =
           EPair ext (pl (EFst ext (EVar ext (typeOf e1) IZ))
                         (weakenExpr WSink e2))
                     (ESnd ext (EVar ext (typeOf e1) IZ)))
-subenvPlus req1 ST (SCons t env) (SEYes sp1 sub1) (SENo sub2) k =
-  subenvPlus req1 ST env sub1 sub2 $ \sub3 minj13 (Inj inj23) pl ->
-    k (SEYes (SpSparse sp1) sub3)
-      (withInj minj13 $ \inj13 ->
-        \e1 -> eunPair e1 $ \_ e1a e1b ->
-          EPair ext (inj13 e1a) (EJust ext e1b))
-      (Inj $ \e2 -> EPair ext (inj23 e2) (ENothing ext (applySparse sp1 (fromSMTy t))))
-      (\e1 e2 ->
-        ELet ext e1 $
-          EPair ext (pl (EFst ext (EVar ext (typeOf e1) IZ))
-                        (weakenExpr WSink e2))
-                    (EJust ext (ESnd ext (EVar ext (typeOf e1) IZ))))
+subenvPlus req1 ST (SCons t env) (SEYes sp1 sub1) (SENo sub2) k
+  | Just zero1 <- cheapZero (applySparse sp1 t) =
+      subenvPlus req1 ST env sub1 sub2 $ \sub3 minj13 (Inj inj23) pl ->
+        k (SEYes sp1 sub3)
+          (withInj minj13 $ \inj13 ->
+            \e1 -> eunPair e1 $ \_ e1a e1b ->
+              EPair ext (inj13 e1a) e1b)
+          (Inj $ \e2 -> EPair ext (inj23 e2) zero1)
+          (\e1 e2 ->
+            ELet ext e1 $
+              EPair ext (pl (EFst ext (EVar ext (typeOf e1) IZ))
+                            (weakenExpr WSink e2))
+                        (ESnd ext (EVar ext (typeOf e1) IZ)))
+  | otherwise =
+      subenvPlus req1 ST env sub1 sub2 $ \sub3 minj13 (Inj inj23) pl ->
+        k (SEYes (SpSparse sp1) sub3)
+          (withInj minj13 $ \inj13 ->
+            \e1 -> eunPair e1 $ \_ e1a e1b ->
+              EPair ext (inj13 e1a) (EJust ext e1b))
+          (Inj $ \e2 -> EPair ext (inj23 e2) (ENothing ext (applySparse sp1 (fromSMTy t))))
+          (\e1 e2 ->
+            ELet ext e1 $
+              EPair ext (pl (EFst ext (EVar ext (typeOf e1) IZ))
+                            (weakenExpr WSink e2))
+                        (EJust ext (ESnd ext (EVar ext (typeOf e1) IZ))))
 
 subenvPlus req1 req2 (SCons t env) sub1@SENo{} sub2@SEYes{} k =
   subenvPlus req2 req1 (SCons t env) sub2 sub1 $ \sub3 minj23 minj13 pl ->
-- 
cgit v1.2.3-70-g09d2