diff --git a/src/Data/Array/Accelerate/AST/Partitioned.hs b/src/Data/Array/Accelerate/AST/Partitioned.hs index f333c6281..3c2e502db 100644 --- a/src/Data/Array/Accelerate/AST/Partitioned.hs +++ b/src/Data/Array/Accelerate/AST/Partitioned.hs @@ -55,7 +55,7 @@ import Data.Array.Accelerate.Type (ScalarType (..), SingleType (..), NumType (.. import Data.Array.Accelerate.AST.Environment (Env (..), prj') import Data.Functor.Identity -import Data.Array.Accelerate.Trafo.Partitioning.ILP.Labels (LabelledArgs, LabelledArg (..), ALabel (..), ALabels (..), ELabel (..), Label) +import Data.Array.Accelerate.Trafo.Partitioning.ILP.Labels (Labels, LabelledArgs, LabelledArg (..), ALabel (..), ALabels (..), ELabel (..), Label) import Data.List (nub, sortOn) import Lens.Micro (_1) import qualified Data.Functor.Const as C @@ -410,7 +410,10 @@ instance TupRmonoid (TupR f) where unOpLabels' :: LabelledArgsOp op env args -> LabelledArgs env args -unOpLabels' = mapArgs $ \(LOp arg l _) -> L arg l +unOpLabels' = mapArgs unOpLabel + +unOpLabel :: LabelledArgOp op env args -> LabelledArg env args +unOpLabel (LOp arg l _) = L arg l data Both f g a = Both (f a) (g a) deriving (Show, Eq) fst' (Both x _) = x @@ -439,7 +442,8 @@ fuse' :: MakesILP op => LabelledArgsOp op env l -> LabelledArgsOp op env r -> Pr -> (forall sh e. f (Out sh e) -> f (In sh e) -> f (Var' sh)) -> (forall args. PreArgs f args -> Cluster op args -> result) -> result -fuse' labl labr largs rargs l r c k = mkFused labl labr $ \f -> k (both c f largs rargs) (Fused f l r) +fuse' labl labr largs rargs l r c k = + mkFused labl labr $ \f -> k (both c f largs rargs) (Fused f l r) mkFused :: MakesILP op => LabelledArgsOp op env l -> LabelledArgsOp op env r -> (forall args. Fusion l r args -> result) -> result mkFused ArgsNil ArgsNil k = k EmptyF @@ -449,10 +453,13 @@ mkFused ((LOp l ((NotArr,_)) _) :>: ls) rs k = mkFused ls rs $ \f -> k (addleft 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 ((Arr (TupRsingle (C.Const (ELabel llab))), lls))lop) :>: ls) (r'@(LOp r ((Arr (TupRsingle (C.Const (ELabel rlab))), rls))rop) :>: rs) k - | lls == rls = mkFused ls rs $ \f -> addboth l r f k - | lls < rls = mkFused ls (r':>:rs) $ \f -> k (addleft l f) - | lls > rls = mkFused (l':>:ls) rs $ \f -> k (addright r f) +mkFused (l'@(LOp l _ _) :>: ls) (r'@(LOp r _ _) :>: 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" 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) @@ -501,11 +508,20 @@ sortArgs args k = unsort :: PreArgs f sorted -> PreArgs f args unsort srts = case argsFromList . map snd . sortOn fst . zip ls' . argsToList $ srts of Exists a -> unsafeCoerce a args' = argsToList args - ls = map (\(Exists (L _ (_,l)))->l) args' + ls = map (\(Exists l) -> getElabelForSort l) args' ls' = map snd $ sortOn fst $ zip ls [1..] keepAll :: LabelledArgs env args -> SubArgs args args keepAll ArgsNil = SubArgsNil keepAll (_:>:as) = SubArgKeep `SubArgsLive` keepAll as +-- If it's a buffer, we only care about its unique label. If it's not a buffer, the other labels suffice to give any ordering. +getElabelForSort :: LabelledArg env a -> Either ELabel Labels +getElabelForSort (L (ArgArray m (ArrayR _ TupRsingle{}) _ _) (Arr (TupRsingle (C.Const e)),_)) + | In <- m = Left e + | Out <- m = Left e +getElabelForSort (L _ (_,ls)) = Right ls + + + subargsId :: PreArgs f args -> SubArgs args args subargsId ArgsNil = SubArgsNil @@ -643,4 +659,8 @@ slvOut (a :>: args) (SubArgsLive SubArgKeep sas) env = case a of slvOut _ _ _ = error "not soa'ed" - +showSorted :: LabelledArgsOp op env args -> String +showSorted ArgsNil = "" +showSorted (a :>: args) = case a of + LOp (ArgArray m _ _ _) (_,ls) _ -> show m <> "{" <> show ls <> "}" <> showSorted args + _ -> showSorted args diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 4ba03e047..fc4a6545d 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -129,7 +129,7 @@ terminalLayoutOptions = unsafePerformIO $ do term <- Term.size return $ case term of - Nothing -> defaultLayoutOptions + Nothing -> LayoutOptions { layoutPageWidth = Unbounded } Just t -> LayoutOptions { layoutPageWidth = AvailablePerLine (min w 120) f } where w = Term.width t diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 16d71fbb6..cf4da5ee7 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -228,8 +228,8 @@ convertAfunWith -> f -> sched kernel () (Scheduled sched (DesugaredAfun (ArraysFunctionR f))) convertAfunWith config - = (\s -> Debug.Trace.trace (Pretty.renderForTerminal (Pretty.prettySchedule s)) s) - . phase' "codegen" rnfSchedule convertScheduleFun + = --(\s -> Debug.Trace.trace (Pretty.renderForTerminal (Pretty.prettySchedule s)) s) . + phase' "codegen" rnfSchedule convertScheduleFun . phase "partition-live-vars" (Operation.simplifyFun . Operation.stronglyLiveVariablesFun) . phase "array-fusion" (Operation.simplifyFun . NewNewFusion.convertAfunWith config defaultObjective) . phase "operation-live-vars" (Operation.simplifyFun . Operation.stronglyLiveVariablesFun) diff --git a/src/Data/Array/Accelerate/Trafo/Partitioning/ILP/Labels.hs b/src/Data/Array/Accelerate/Trafo/Partitioning/ILP/Labels.hs index 702535ecb..6e07f648f 100644 --- a/src/Data/Array/Accelerate/Trafo/Partitioning/ILP/Labels.hs +++ b/src/Data/Array/Accelerate/Trafo/Partitioning/ILP/Labels.hs @@ -65,7 +65,7 @@ data Label = Label makeLenses ''Label instance Show Label where -- show = ("Label"<>) . show . _labelId - show (Label i p) = "L" <> show i <> "{" <> show p <> "} " + show (Label i p) = show i -- "L" <> show i <> "{" <> show p <> "} " instance Eq Label where (Label x a) == (Label y b) | x == y = if a == b then True else error $ "same labelId but different parents: " <> show x <> show a <> " - " <> show b diff --git a/src/Data/Array/Accelerate/Trafo/Schedule/Partial.hs b/src/Data/Array/Accelerate/Trafo/Schedule/Partial.hs index faf010310..ca4516cdb 100644 --- a/src/Data/Array/Accelerate/Trafo/Schedule/Partial.hs +++ b/src/Data/Array/Accelerate/Trafo/Schedule/Partial.hs @@ -65,7 +65,7 @@ import Prelude hiding (id, (.), read) import Control.Category import Data.Functor.Identity - +import Debug.Trace -- Constructs a partial schedule. It is partial as many details still need -- to be filled in for the actual schedule. This schedule does however -- decide whether the binding and body of a let-binding should be executed @@ -336,7 +336,7 @@ data Exists' (a :: (Type -> Type -> Type) -> Type) where combineMod :: Modifier m -> Modifier m' -> Exists' Modifier combineMod In In = Exists' In combineMod Out Out = Exists' Out -combineMod _ _ = Exists' Mut +combineMod _ _ = error "Remove this error once we add in place updates" -- Exists' Mut combineAccessGroundR :: AccessGroundR t -> AccessGroundR t -> AccessGroundR t combineAccessGroundR (AccessGroundRbuffer m1 tp) (AccessGroundRbuffer m2 _)