Merge branch 'new-pipeline' of https://www.github.com/ivogabe/accelerate

 into new-pipeline-david

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

@@ -34,7 +34,8 @@ module Data.Array.Accelerate.AST.Partitioned (
   GroundR(..), GroundsR, GroundVar, GroundVars, NFData'(..), Arg(..),
   AccessGroundR(..),
   PreArgs(..), Args, Modifier(..),
-  Exp', Var', Fun', In, Out, Mut
+  Exp', Var', Fun', In, Out, Mut,
+  flattenClustered, flattenCluster,
 ) where
 
 import Data.Array.Accelerate.AST.Idx
@@ -65,7 +66,6 @@ import qualified Debug.Trace
 
 
 
-
 type PartitionedAcc  op = PreOpenAcc  (Clustered op)
 type PartitionedAfun op = PreOpenAfun (Clustered op)
 
@@ -274,6 +274,19 @@ both k (IntroR        f)      ls  (r:>:rs) = r     :>: both k f ls rs
 
 
 
+flattenClustered :: Clustered op args -> [Exists op]
+flattenClustered (Clustered c _) = flattenCluster c
+
+flattenCluster :: Cluster op args -> [Exists op]
+flattenCluster = (`go` [])
+  where
+    go :: Cluster op args -> [Exists op] -> [Exists op]
+    go (Op s _)      accum = extract s : accum
+    go (Fused _ a b) accum = go a $ go b accum
+
+    extract :: SLVOp op args -> Exists op
+    extract (SLV (SOp (SOAOp op _) _) _) = Exists op
+
 varsToShapeR :: Vars ScalarType g sh -> ShapeR sh
 varsToShapeR = typeRtoshapeR . varsType
 

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

@@ -35,16 +35,19 @@ module Data.Array.Accelerate.AST.Schedule (
   Scheduled,
   reprIsBody,
   IOFun, FullIOFun, FullIOFun',
-  flattenIOFun, unsafePerformIOFun
+  flattenIOFun, unsafePerformIOFun,
+  generateKernelNameAndDescription
 ) where
 
 import Data.Array.Accelerate.AST.Partitioned
 import Data.Array.Accelerate.AST.Kernel
+import Data.Array.Accelerate.AST.LeftHandSide
 import Data.Array.Accelerate.Type
 import Data.Array.Accelerate.Representation.Ground
 import Data.Array.Accelerate.Representation.Type
 import Data.Typeable                                                ( (:~:)(..) )
-import Data.Array.Accelerate.AST.Operation
+import Data.List (sortOn, group)
+import Data.Ord
 import Control.Monad
 import System.IO.Unsafe
 
@@ -111,3 +114,48 @@ unsafePerformIOFun :: GFunctionR f -> IOFun f -> f
 unsafePerformIOFun (GFunctionRlam _ funR) fun = unsafePerformIOFun funR . fun
 unsafePerformIOFun (GFunctionRbody tp)    body
   | Refl <- reprIsBody tp = unsafePerformIO body
+
+generateKernelNameAndDescription
+  -- Function that gives the priority, singular name and plural name of an
+  -- operation. The operations with highest priority are used in the name.
+  :: (forall s. op s -> (Int, String, String))
+  -> Clustered op t
+  -- Returns a function name, a detailed description and a brief description
+  -> (String, String, String)
+generateKernelNameAndDescription f cluster =
+  ( formatList False "-" "-" (take 2 sorted) ++ (if length sorted > 2 then "-etc" else "")
+  , if trivial then "" else "Cluster with " ++
+      formatList True ", then " (if length grouped == 2 then " and then " else " and finally ") (groupAndCount ops)
+  , if trivial then "" else "Cluster with " ++
+      formatList True ", " " and " sorted
+  )
+  where
+    trivial 
+      | [_] <- ops = True
+      | otherwise  = False
+
+    ops = map (\(Exists op) -> f op) $ flattenClustered cluster
+    grouped = groupAndCount ops
+    sorted = groupAndCount $ sortOn Down $ ops
+
+    groupAndCount :: Eq a => [a] -> [(a, Int)]
+    groupAndCount = map g . group
+      where
+        g [] = error "impossible"
+        g as@(a:_) = (a, length as)
+
+    formatList :: Bool -> String -> String -> [((Int, String, String), Int)] -> String
+    formatList includeNumber separator finalSeparator list = case list of
+      [] -> ""
+      [a] -> formatItem includeNumber a
+      [a, b] -> formatItem includeNumber a ++ finalSeparator ++ formatItem includeNumber b
+      (a:as) -> formatItem includeNumber a ++ separator ++ formatList includeNumber separator finalSeparator as
+
+    formatItem :: Bool -> ((Int, String, String), Int) -> String
+    formatItem includeNumber ((_, singular, plural), count)
+      | includeNumber = show count ++ " " ++ name
+      | otherwise = name
+      where
+        name
+          | count == 1 = singular
+          | otherwise  = plural

src/Data/Array/Accelerate/Trafo/Operation/Simplify.hs

@@ -46,7 +46,7 @@ import Data.Array.Accelerate.Trafo.Var
 import Data.Array.Accelerate.Trafo.Substitution             hiding ( weakenArrayInstr )
 import Data.Array.Accelerate.Trafo.WeakenedEnvironment
 import Data.Array.Accelerate.Trafo.Operation.Substitution
-import Data.Array.Accelerate.Trafo.LiveVars                 ( SubTupR(..), subTupR, subTupRpair )
+import Data.Array.Accelerate.Trafo.LiveVars                 ( SubTupR(..), subTupR, subTupRpair, subTupPreserves )
 import Data.Maybe                                           ( mapMaybe )
 import Data.List                                            ( foldl' )
 import Data.Either                                          ( partitionEithers )
@@ -448,8 +448,8 @@ awhileSimplifyInvariant
   -> GroundVars     env a
   -> PreOpenAcc  op env a
 awhileSimplifyInvariant us cond step initial = case awhileDropInvariantFun step of
-  Exists SubTupRkeep -> Awhile us cond step initial
   Exists sub
+    | Just Refl <- subTupPreserves tp sub -> Awhile us cond step initial
     | DeclareVars lhs k value <- declareVars $ subTupR sub tp ->
       Alet lhs (subTupR sub us)
         (Awhile (subTupR sub us)
@@ -485,9 +485,12 @@ awhileDropInvariant argument = \case
     matchReturn (TupRpair a1 a2) (TupRpair v1 v2)
       | Exists s1 <- matchReturn a1 v1
       , Exists s2 <- matchReturn a2 v2
-      = Exists $ subTupRpair s1 s2
+      = case (s1, s2) of
+          (SubTupRskip, SubTupRskip) -> Exists SubTupRskip
+          _ -> Exists $ subTupRpair s1 s2
     matchReturn (TupRsingle (JustVar arg)) (TupRsingle var)
       | Just Refl <- matchVar arg var = Exists SubTupRskip
+    matchReturn TupRunit _ = Exists SubTupRskip
     matchReturn _ _ = Exists SubTupRkeep
 
 subTupFunctionResult :: SubTupR t t' -> OperationAfun op env (ta -> t) -> OperationAfun op env (ta -> t')

src/Data/Array/Accelerate/Trafo/Schedule/Uniform.hs

@@ -72,19 +72,6 @@ import Data.Array.Accelerate.AST.Partitioned (Clustered)
 
 import System.IO
 
-poorReadMVar :: MVar a -> IO a
-poorReadMVar mvar = do
-  value <- tryReadMVar mvar
-  case value 
-    of
-    Just a -> return a
-    Nothing -> 
-      do
-      threadDelay 1000000
-      hPutStr stderr "*"
-      poorReadMVar mvar
-
-
 instance IsSchedule UniformScheduleFun where
   type ScheduleInput  UniformScheduleFun a = Input a
   type ScheduleOutput UniformScheduleFun a = Output a
@@ -112,7 +99,7 @@ instance IsSchedule UniformScheduleFun where
           mvar <- newEmptyMVar
           -- We return the result lazily, as the value is not yet available
           let value = unsafePerformIO $ do
-                poorReadMVar mvar
+                readMVar mvar
                 readIORef ref
           return ((SignalResolver mvar, OutputRef ref), value)
   callScheduledFun (GFunctionRlam arg ret) f = do

src/Data/Array/Accelerate/Trafo/Schedule/Uniform/Simplify.hs

@@ -275,6 +275,13 @@ propagate implications infoEnv@(InfoEnv env awaitedSignals) = InfoEnv (foldl' ad
       InfoSignalResolved  -> idx
       _                   -> internalError "Expected this index to point to a Signal"
 
+-- On a schedule of this form:
+--   spawn { await [s1, s2]; resolve [s3']}
+--   next
+--
+-- We will replace 'await [s3]' with 'await [s1, s2]'.
+-- This function will, given the spawned schedule, update the InfoEnv
+-- to remember that s3 should be replaced with [s1, s2].
 findSignalReplacements :: forall kernel env. UniformSchedule kernel env -> InfoEnv env -> InfoEnv env
 findSignalReplacements = go []
   where