fix "unequal pairing" on backpermute on tuple

dpvanbalen · Mar 18, 2024 · 8f02840 · 8f02840
1 parent e4e5935
commit 8f02840
Show file tree

Hide file tree

Showing 3 changed files with 7 additions and 4 deletions.
diff --git a/accelerate.cabal b/accelerate.cabal
@@ -476,6 +476,8 @@ library
         -- For testing
         Data.Array.Accelerate.Test.NoFib
         Data.Array.Accelerate.Test.Similar
+        Data.Array.Accelerate.Pretty.Operation
+        Data.Array.Accelerate.Pretty.Exp
 
         -- Other
         Data.BitSet
@@ -517,11 +519,9 @@ library
         Data.Array.Accelerate.Pattern.Ordering
         Data.Array.Accelerate.Pattern.TH
         Data.Array.Accelerate.Prelude
-        Data.Array.Accelerate.Pretty.Exp
         Data.Array.Accelerate.Pretty.Graphviz
         Data.Array.Accelerate.Pretty.Graphviz.Monad
         Data.Array.Accelerate.Pretty.Graphviz.Type
-        Data.Array.Accelerate.Pretty.Operation
         Data.Array.Accelerate.Pretty.Partitioned
         Data.Array.Accelerate.Pretty.Print
         Data.Array.Accelerate.Pretty.Type

diff --git a/src/Data/Array/Accelerate/AST/Operation.hs b/src/Data/Array/Accelerate/AST/Operation.hs
@@ -15,6 +15,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE InstanceSigs #-}
 -- |
 -- Module      : Data.Array.Accelerate.AST.Operation
 -- Copyright   : [2008..2020] The Accelerate Team
@@ -359,6 +360,7 @@ instance HasGroundsR (GroundVars env) where
   groundsR = varsType
 
 instance HasGroundsR (OpenExp env benv) where
+  groundsR :: OpenExp env benv a -> GroundsR a
   groundsR = typeRtoGroundsR . expType
 
 type OpenExp env benv = PreOpenExp (ArrayInstr benv) env

diff --git a/src/Data/Array/Accelerate/Eval.hs b/src/Data/Array/Accelerate/Eval.hs
@@ -49,6 +49,7 @@ import Data.Composition ((.*))
 import Data.Array.Accelerate.Trafo.Partitioning.ILP.Labels (Label)
 import Data.Array.Accelerate.AST.Var (varsType)
 import qualified Debug.Trace
+import Data.Array.Accelerate.Pretty.Exp (PrettyEnv)
 
 
 type BackendArgs op env = PreArgs (BackendClusterArg2 op env)
@@ -64,7 +65,7 @@ pattern PushFA env x = Push env (FromArg x)
 
 
 class ( MakesILP op
-      , forall env arg. Eq (BackendClusterArg2 op env arg)
+      -- , forall env arg. Eq (BackendClusterArg2 op env arg)
       , forall env arg. Show (BackendClusterArg2 op env arg))
     => StaticClusterAnalysis (op :: Type -> Type) where
   data BackendClusterArg2 op env arg
@@ -86,7 +87,7 @@ class ( MakesILP op
   varToUnit    :: BackendClusterArg2 op env (Var' sh)        -> BackendClusterArg2 op env (m     sh ())
   inToVar      :: BackendClusterArg2 op env (In sh e)        -> BackendClusterArg2 op env (Var' sh   )
   pairinfo     :: BackendClusterArg2 op env (m sh a)         -> BackendClusterArg2 op env (m sh b) -> BackendClusterArg2 op env (m sh (a,b))
-  pairinfo a b = if shrinkOrGrow a == b then shrinkOrGrow a else error "pairing unequal"
+  -- pairinfo a b = if shrinkOrGrow a == b then shrinkOrGrow a else error $ "pairing unequal: " <> show a <> ", " <> show b
   unpairinfo   :: BackendClusterArg2 op env (m sh (a,b))     -> (BackendClusterArg2 op env (m sh a),  BackendClusterArg2 op env (m sh b))
   unpairinfo x = (shrinkOrGrow x, shrinkOrGrow x)