fix unequal pairing

src/Data/Array/Accelerate/AST/Partitioned.hs

@@ -446,22 +446,22 @@ mkFused :: MakesILP op => LabelledArgsOp op env l -> LabelledArgsOp op env r ->
 mkFused ArgsNil ArgsNil k = k EmptyF
 mkFused ArgsNil ((LOp r _ _) :>: rs) k = mkFused ArgsNil rs $ \f -> k (addright r f)
 mkFused (LOp l _ _ :>: ls) ArgsNil k = mkFused ls ArgsNil $ \f -> k (addleft l f)
-mkFused ((LOp l ((NotArr,_)) _) :>: ls) rs k = mkFused ls rs $ \f -> k (addleft l f)
-mkFused ls ((LOp r ((NotArr,_))_ ) :>: rs) k = mkFused ls rs $ \f -> k (addright r f)
-mkFused ((LOp l ((Arr TupRunit,_))_ ) :>: ls) rs k = mkFused ls rs $ \f -> k (addleft l f)
-mkFused ls ((LOp r ((Arr TupRunit,_))_) :>: rs) k = mkFused ls rs $ \f -> k (addright r f)
-mkFused (l'@(LOp l _ _) :>: ls) (r'@(LOp r _ _) :>: rs) k
+mkFused ((LOp l (NotArr,_) _) :>: ls) rs k = mkFused ls rs $ \f -> k (addleft l f)
+mkFused ls ((LOp r (NotArr,_)_ ) :>: rs) k = mkFused ls rs $ \f -> k (addright r f)
+mkFused ((LOp l (Arr TupRunit,_)_ ) :>: ls) rs k = mkFused ls rs $ \f -> k (addleft l f)
+mkFused ls ((LOp r (Arr TupRunit,_)_) :>: rs) k = mkFused ls rs $ \f -> k (addright r f)
+mkFused (l'@(LOp l _ bl) :>: ls) (r'@(LOp r _ br) :>: rs) k
   | Left le <- getElabelForSort $ unOpLabel l'
   , Left re <- getElabelForSort $ unOpLabel r'
     = case compare le re of
-      EQ -> mkFused ls rs $ \f -> addboth l r f k
       LT -> mkFused ls (r':>:rs) $ \f -> k (addleft l f)
       GT -> mkFused (l':>:ls) rs $ \f -> k (addright r f)
-  | otherwise = error "simple math, the truth cannot be questioned"
+      EQ -> mkFused ls rs $ \f -> if bl == br then addboth l r f k else k (addleft l (addright r f))
 mkFused ((LOp l@(ArgArray Mut _ _ _) _ _) :>: ls) rs k = mkFused ls rs $ \f -> k (addleft l f)
 mkFused ls ((LOp r@(ArgArray Mut _ _ _) _ _) :>: rs) k = mkFused ls rs $ \f -> k (addright r f)
 mkFused ((LOp _ (Arr TupRpair{}, _)_) :>: _) _ _ = error "not soa'd array"
 mkFused _ ((LOp _ (Arr TupRpair{}, _)_) :>: _) _ = error "not soa'd array"
+mkFused _ _ _ = error "exhaustive"
 
 addleft :: Arg env arg -> Fusion left right args -> Fusion (arg->left) right (arg->args)
 addleft (ArgVar _          ) f = IntroL  f

src/Data/Array/Accelerate/Eval.hs

@@ -136,7 +136,7 @@ makeBackendArg args env c b = go args c (defaultOuts args b) b
               env
 
     combineB   :: Arg env (g (l,r)) -> BackendClusterArg2 op env (f l) -> BackendClusterArg2 op env (f r) -> BackendClusterArg2 op env (f (l,r))
-    combineB = unsafeCoerce $ pairinfo @op
+    combineB a x y = (unsafeCoerce $ pairinfo @op) a x y
     uncombineB :: Arg env (g (l,r)) -> BackendClusterArg2 op env (f (l,r)) -> (BackendClusterArg2 op env (f l), BackendClusterArg2 op env (f r))
     uncombineB = unsafeCoerce $ unpairinfo @op
     combineB' :: Both (Arg env) (BackendClusterArg2 op env) (g l)

src/Data/Array/Accelerate/Trafo/Partitioning/ILP/Clustering.hs

@@ -173,10 +173,6 @@ openReconstructF a b c d l e f = (\(Right x) -> x) $ openReconstruct' a b c d (J
 
 openReconstruct' :: forall op aenv. MakesILP op => Bool -> LabelEnv aenv -> Graph -> [ClusterLs] -> Maybe Label -> M.Map Label [ClusterLs] -> M.Map Label (Construction op)  -> Either (Exists (PreOpenAcc (Clustered op) aenv)) (Exists (PreOpenAfun (Clustered op) aenv))
 openReconstruct' singletons labelenv graph clusterslist mlab subclustersmap construct = 
-  Debug.Trace.traceShow ("number of execs:", M.size $ M.filter (\case
-    CExe{} -> True
-    CExe'{} -> True
-    _ -> False) construct) $
   case mlab of
   Just l  -> Right $ makeASTF labelenv l mempty
   Nothing -> Left $ makeAST labelenv clusters mempty

src/Data/Array/Accelerate/Trafo/Partitioning/ILP/HiGHS.hs

@@ -34,8 +34,8 @@ instance MakesILP op => ILPSolver HiGHS op where
         Minimise -> LP.Minimize
       cost' = case highexpr n cost of (term,_constant) -> fromMap . M.unionWith (+) (M.fromSet (const 0) vs) $ term2Map term
 
-getSolution (s, Nothing)      = Debug.Trace.traceShow s Nothing
-getSolution (s, Just (c,arr)) = Debug.Trace.traceShow (s,c) $ Just (round <$> toMap arr) 
+getSolution (s, Nothing)      = Nothing
+getSolution (s, Just (c,arr)) = Just (round <$> toMap arr) 
 
 term2Map [] = mempty
 term2Map ((Term d v):ts) = M.unionWith (+) (M.singleton v d) (term2Map ts)