packages feed

accelerate 0.13.0.5 → 0.14.0.0

raw patch · 27 files changed

+2449/−1791 lines, 27 filesdep +unordered-containersdep ~arraydep ~basedep ~blaze-html

Dependencies added: unordered-containers

Dependency ranges changed: array, base, blaze-html, blaze-markup, bytestring, containers, directory, fclabels, filepath, ghc-prim, mtl, pretty, text, unix

Files

Data/Array/Accelerate.hs view
@@ -62,10 +62,10 @@    -- ** Accessors   -- *** Indexing-  (L.!), (L.!!), L.the,+  (L.!), (L.!!), P.the,    -- *** Shape information-  L.null, L.shape, L.size, L.shapeSize,+  P.null, L.shape, L.size, L.shapeSize,    -- *** Extracting sub-arrays   L.slice,@@ -81,9 +81,12 @@   -- *** Enumeration   P.enumFromN, P.enumFromStepN, +  -- *** Concatenation+  (P.++),+   -- ** Composition   -- *** Flow control-  (L.?|), L.cond,+  (P.?|), L.acond, L.awhile,    -- *** Pipelining   (L.>->),@@ -103,11 +106,11 @@   L.map,    -- *** Zipping-  L.zipWith, P.zipWith3, P.zipWith4,-  P.zip, P.zip3, P.zip4,+  L.zipWith, P.zipWith3, P.zipWith4, P.zipWith5, P.zipWith6, P.zipWith7, P.zipWith8, P.zipWith9,+  P.zip, P.zip3, P.zip4, P.zip5, P.zip6, P.zip7, P.zip8, P.zip9,    -- *** Unzipping-  P.unzip, P.unzip3, P.unzip4,+  P.unzip, P.unzip3, P.unzip4, P.unzip5, P.unzip6, P.unzip7, P.unzip8, P.unzip9,    -- ** Working with predicates   -- *** Filtering@@ -171,17 +174,32 @@    -- | A value of type `Int` is a plain Haskell value (unlifted), whereas an   -- @Exp Int@ is a /lifted/ value, that is, an integer lifted into the domain-  -- of expressions (an abstract syntax tree in disguise).  Both `Acc` and `Exp`-  -- are /surface types/ into which values may be lifted.+  -- of expressions (an abstract syntax tree in disguise). Both `Acc` and `Exp`+  -- are /surface types/ into which values may be lifted. Lifting plain array+  -- and scalar surface types is equivalent to 'use' and 'constant'+  -- respectively.   --   -- In general an @Exp Int@ cannot be unlifted into an `Int`, because the   -- actual number will not be available until a later stage of execution (e.g.-  -- GPU execution, when `run` is called).  However, in some cases unlifting-  -- makes sense.  For example, unlifting can convert, or unpack, an expression-  -- of tuple type into a tuple of expressions; those expressions, at runtime,-  -- will become tuple dereferences.+  -- GPU execution, when `run` is called). Similarly an @Acc array@ can not be+  -- unlifted to a vanilla `array`; should instead `run` the expression with a+  -- specific backend to evaluate it.   ---  L.Lift(..), L.Unlift(..), L.lift1, L.lift2, L.ilift1, L.ilift2,+  -- Lifting and unlift are also used to pack and unpack an expression into and+  -- out of constructors such as tuples, respectively. Those expressions, at+  -- runtime, will become tuple dereferences. For example:+  --+  -- > Exp (Z :. Int :. Int)+  -- >     -> unlift -> (Z :. Exp Int :. Exp Int)+  -- >     -> lift   -> Exp (Z :. Int :. Int)+  -- >     -> ...+  --+  -- > Acc (Scalar Int, Vector Float)+  -- >     -> unlift -> (Acc (Scalar Int), Acc (Vector Float))+  -- >     -> lift   -> Acc (Scalar Int, Vector Float)+  -- >     -> ...+  --+  P.Lift(..), P.Unlift(..), P.lift1, P.lift2, P.ilift1, P.ilift2,    -- ** Operations   --@@ -195,17 +213,20 @@   L.constant,    -- *** Tuples-  L.fst, L.snd, L.curry, L.uncurry,+  P.fst, P.snd, P.curry, P.uncurry, -  -- *** Conditional-  (L.?),+  -- *** Flow control+  (P.?), L.cond, L.while, P.iterate, +  -- *** Scalar reduction+  P.sfoldl,+   -- *** Basic operations   (L.&&*), (L.||*), L.not,-  (L.==*), (L./=*), (L.<*), (L.<=*), (L.>*), (L.>=*), L.max, L.min,+  (L.==*), (L./=*), (L.<*), (L.<=*), (L.>*), (L.>=*),    -- *** Numeric functions-  L.truncate, L.round, L.floor, L.ceiling,+  L.truncate, L.round, L.floor, L.ceiling, L.even, L.odd,    -- *** Bitwise functions   L.bit, L.setBit, L.clearBit, L.complementBit, L.testBit,@@ -213,9 +234,10 @@   L.rotate, L.rotateL, L.rotateR,    -- *** Shape manipulation-  L.index0, L.index1, L.unindex1, L.index2, L.unindex2,+  P.index0, P.index1, P.unindex1, P.index2, P.unindex2,   L.indexHead, L.indexTail,   L.toIndex, L.fromIndex,+  L.intersect,    -- *** Conversions   L.boolToInt, L.fromIntegral,@@ -231,6 +253,9 @@   -- | For additional conversion routines, see the accelerate-io package:   -- <http://hackage.haskell.org/package/accelerate-io> +  -- *** Function+  fromFunction,+   -- *** Lists   S.fromList, S.toList, @@ -258,25 +283,31 @@  -- rename as '(!)' is already used by the EDSL for indexing --- |Array indexing in plain Haskell code+-- |Array indexing in plain Haskell code. -- indexArray :: S.Array sh e -> sh -> e indexArray = (S.!) --- | Rank of an array+-- | Rank of an array. -- arrayDim :: S.Shape sh => sh -> T.Int arrayDim = S.dim -- FIXME: Rename to rank --- |Array shape in plain Haskell code+-- |Array shape in plain Haskell code. -- arrayShape :: S.Shape sh => S.Array sh e -> sh arrayShape = S.shape -- rename as 'shape' is already used by the EDSL to query an array's shape --- | Total number of elements in an array of the given 'Shape'+-- | Total number of elements in an array of the given 'Shape'. -- arraySize :: S.Shape sh => sh -> T.Int arraySize = S.size++-- | Create an array from its representation function.+--+{-# INLINE fromFunction #-}+fromFunction :: (S.Shape sh, S.Elt e) => sh -> (sh -> e) -> S.Array sh e+fromFunction = S.newArray
Data/Array/Accelerate/AST.hs view
@@ -246,12 +246,20 @@               -> PreOpenAcc   acc aenv a    -- If-then-else for array-level computations-  Acond       :: (Arrays arrs)+  Acond       :: Arrays arrs               => PreExp     acc aenv Bool               -> acc            aenv arrs               -> acc            aenv arrs               -> PreOpenAcc acc aenv arrs +  -- Value-recursion for array-level computations+  Awhile      :: Arrays arrs+              => PreOpenAfun acc aenv (arrs -> Scalar Bool)     -- continue iteration while true+              -> PreOpenAfun acc aenv (arrs -> arrs)            -- function to iterate+              -> acc             aenv arrs                      -- initial value+              -> PreOpenAcc  acc aenv arrs++   -- Array inlet (triggers async host->device transfer if necessary)   Use         :: Arrays arrs               => ArrRepr arrs@@ -393,18 +401,26 @@               -> acc            aenv (Vector e)                 -- linear array               -> PreOpenAcc acc aenv (Vector e) -  -- Generalised forward permutation is characterised by a permutation-  -- function that determines for each element of the source array where it-  -- should go in the target; the permutation can be between arrays of varying-  -- shape; the permutation function must be total.+  -- Generalised forward permutation is characterised by a permutation function+  -- that determines for each element of the source array where it should go in+  -- the output. The permutation can be between arrays of varying shape and+  -- dimensionality.   ---  -- The target array is initialised from an array of default values (in case-  -- some positions in the target array are never picked by the permutation-  -- functions).  Moreover, we have a combination function (in case some-  -- positions on the target array are picked multiple times by the-  -- permutation functions).  The combination function needs to be-  -- /associative/ and /commutative/ .  We drop every element for which the-  -- permutation function yields -1 (i.e., a tuple of -1 values).+  -- Other characteristics of the permutation function 'f':+  --+  --   1. 'f' is a partial function: if it evaluates to the magic value 'ignore'+  --      (i.e. a tuple of -1 values) then those elements of the domain are+  --      dropped.+  --+  --   2. 'f' is not surjective: positions in the target array need not be+  --      picked up by the permutation function, so the target array must first+  --      be initialised from an array of default values.+  --+  --   3. 'f' is not injective: distinct elements of the domain may map to the+  --      same position in the target array. In this case the combination+  --      function is used to combine elements, which needs to be /associative/+  --      and /commutative/.+  --   Permute     :: (Shape sh, Shape sh', Elt e)               => PreFun     acc aenv (e -> e -> e)              -- combination function               -> acc            aenv (Array sh' e)              -- default values@@ -765,10 +781,10 @@                 -> PreOpenExp acc env aenv t                 -> PreOpenExp acc env aenv t -  -- Value recursion with static loop count-  Iterate       :: Elt a-                => PreOpenExp acc env aenv Int          -- number of times to repeat-                -> PreOpenExp acc (env, a) aenv a       -- function to iterate+  -- Value recursion+  While         :: Elt a+                => PreOpenFun acc env aenv (a -> Bool)  -- continue while true+                -> PreOpenFun acc env aenv (a -> a)     -- function to iterate                 -> PreOpenExp acc env aenv a            -- initial value                 -> PreOpenExp acc env aenv a @@ -928,6 +944,7 @@ showPreAccOp Apply{}            = "Apply" showPreAccOp Aforeign{}         = "Aforeign" showPreAccOp Acond{}            = "Acond"+showPreAccOp Awhile{}           = "Awhile" showPreAccOp Atuple{}           = "Atuple" showPreAccOp Aprj{}             = "Aprj" showPreAccOp Unit{}             = "Unit"@@ -991,7 +1008,7 @@ showPreExpOp ToIndex{}          = "ToIndex" showPreExpOp FromIndex{}        = "FromIndex" showPreExpOp Cond{}             = "Cond"-showPreExpOp Iterate{}          = "Iterate"+showPreExpOp While{}            = "While" showPreExpOp PrimConst{}        = "PrimConst" showPreExpOp PrimApp{}          = "PrimApp" showPreExpOp Index{}            = "Index"
Data/Array/Accelerate/Analysis/Match.hs view
@@ -87,10 +87,10 @@     -> Maybe (s :=: t) matchPreOpenAcc matchAcc hashAcc = match   where-    matchFun :: PreOpenFun acc env aenv u -> PreOpenFun acc env aenv v -> Maybe (u :=: v)+    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :=: v)     matchFun = matchPreOpenFun matchAcc hashAcc -    matchExp :: PreOpenExp acc env aenv u -> PreOpenExp acc env aenv v -> Maybe (u :=: v)+    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :=: v)     matchExp = matchPreOpenExp matchAcc hashAcc      match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :=: t)@@ -117,8 +117,8 @@       = Just REFL      match (Aforeign ff1 _ a1) (Aforeign ff2 _ a2)-      | Just REFL <- matchAcc a1 a2,-        unsafePerformIO $ do+      | Just REFL <- matchAcc a1 a2+      , unsafePerformIO $ do           sn1 <- makeStableName ff1           sn2 <- makeStableName ff2           return $! hashStableName sn1 == hashStableName sn2@@ -130,6 +130,12 @@       , Just REFL <- matchAcc e1 e2       = Just REFL +    match (Awhile p1 f1 a1) (Awhile p2 f2 a2)+      | Just REFL <- matchAcc a1 a2+      , Just REFL <- matchPreOpenAfun matchAcc p1 p2+      , Just REFL <- matchPreOpenAfun matchAcc f1 f2+      = Just REFL+     match (Use a1) (Use a2)       | Just REFL <- matchArrays (arrays (undefined::s)) (arrays (undefined::t)) a1 a2       = gcast REFL@@ -436,10 +442,10 @@       , Just REFL <- match e1 e2       = Just REFL -    match (Iterate n1 f1 x1) (Iterate n2 f2 x2)-      | Just REFL <- match n1 n2-      , Just REFL <- match x1 x2-      , Just REFL <- match f1 f2+    match (While p1 f1 x1) (While p2 f2 x2)+      | Just REFL <- match x1 x2+      , Just REFL <- matchPreOpenFun matchAcc hashAcc p1 p2+      , Just REFL <- matchPreOpenFun matchAcc hashAcc f1 f2       = Just REFL      match (PrimConst c1) (PrimConst c2)@@ -878,6 +884,7 @@     Apply f a                   -> hash "Apply"         `hashWithSalt` hashAfun hashAcc f `hashA` a     Aforeign _ f a              -> hash "Aforeign"      `hashWithSalt` hashAfun hashAcc f `hashA` a     Use a                       -> hash "Use"           `hashWithSalt` hashArrays (arrays (undefined::arrs)) a+    Awhile p f a                -> hash "Awhile"        `hashWithSalt` hashAfun hashAcc f `hashWithSalt` hashAfun hashAcc p `hashA` a     Unit e                      -> hash "Unit"          `hashE` e     Generate e f                -> hash "Generate"      `hashE` e  `hashF` f     Acond e a1 a2               -> hash "Acond"         `hashE` e  `hashA` a1 `hashA` a2@@ -954,7 +961,7 @@     ToIndex sh i                -> hash "ToIndex"       `hashE` sh `hashE` i     FromIndex sh i              -> hash "FromIndex"     `hashE` sh `hashE` i     Cond c t e                  -> hash "Cond"          `hashE` c  `hashE` t  `hashE` e-    Iterate n f x               -> hash "Iterate"       `hashE` n  `hashE` f  `hashE` x+    While p f x                 -> hash "While"         `hashWithSalt` hashPreOpenFun hashAcc p  `hashWithSalt` hashPreOpenFun hashAcc f  `hashE` x     PrimApp f x                 -> hash "PrimApp"       `hashWithSalt` hashPrimFun f `hashE` fromMaybe x (commutes hashAcc f x)     PrimConst c                 -> hash "PrimConst"     `hashWithSalt` hashPrimConst c     Index a ix                  -> hash "Index"         `hashA` a  `hashE` ix
Data/Array/Accelerate/Analysis/Shape.hs view
@@ -66,6 +66,7 @@                               _            -> error "inconceivable!"      Acond _ acc _        -> k acc+    Awhile _ _ acc       -> k acc     Use ((),(Array _ _)) -> ndim (eltType (undefined::sh))     Unit _               -> 0     Generate _ _         -> ndim (eltType (undefined::sh))
Data/Array/Accelerate/Analysis/Type.hs view
@@ -102,6 +102,7 @@                              _            -> error "Who on earth wrote all these weird error messages?"      Acond _ acc _       -> k acc+    Awhile _ _ acc      -> k acc     Use ((),a)          -> arrayType a     Unit _              -> eltType (undefined::e)     Generate _ _        -> eltType (undefined::e)@@ -157,7 +158,7 @@     ToIndex _ _       -> eltType (undefined::t)     FromIndex _ _     -> eltType (undefined::t)     Cond _ t _        -> preExpType k t-    Iterate _ _ _     -> eltType (undefined::t)+    While _ _ _       -> eltType (undefined::t)     PrimConst _       -> eltType (undefined::t)     PrimApp _ _       -> eltType (undefined::t)     Index acc _       -> k acc
Data/Array/Accelerate/Array/Data.hs view
@@ -55,11 +55,7 @@ import qualified Data.Array.Base    as MArray (unsafeRead, unsafeWrite) import qualified Data.Array.Base    as IArray (unsafeAt) #endif-#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 703-import qualified Data.Array.MArray  as Unsafe-#else import qualified Data.Array.Unsafe  as Unsafe-#endif import Data.Array.ST      (STUArray) import Data.Array.Unboxed (UArray) import Data.Array.MArray  (MArray)
Data/Array/Accelerate/Array/Delayed.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} -- |--- Module      : Data.Array.Accelerate+-- Module      : Data.Array.Accelerate.Array.Delayed -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --               [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License     : BSD3
Data/Array/Accelerate/Array/Sugar.hs view
@@ -663,9 +663,7 @@ {-# RULES  "fromElt/toElt" forall e.-  fromElt (toElt e) = e--  #-}+  fromElt (toElt e) = e #-}   -- Foreign functions@@ -678,9 +676,7 @@ class Typeable2 f => Foreign (f :: * -> * -> *) where    -- Backends should be able to produce a string representation of the foreign-  -- function for pretty printing. It should contain the backend name and-  -- ideally a string uniquely identifying the foreign function being used.-  --+  -- function for pretty printing, typically the name of the function.   strForeign :: f args results -> String  @@ -1087,8 +1083,38 @@ -- Convert an array to a string -- instance Show (Array sh e) where-  show arr@(Array sh _adata)-    = "Array (" ++ showShape (toElt sh :: sh) ++ ") " ++ show (toList arr)+  show arr@Array{}+    = "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)++{--+-- Specialised Show instances for dimensions zero, one, and two. Requires+-- overlapping instances.+--+-- TODO:+--   * Formatting of the matrix should be better, such as aligning the columns?+--   * Make matrix formatting optional? It is more difficult to copy/paste the+--     result, for example.+--+instance Show (Scalar e) where+  show arr@Array{}+    = "Scalar Z " ++ show (toList arr)++instance Show (Vector e) where+  show arr@Array{}+    = "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)++instance Show (Array DIM2 e) where+  show arr@Array{}+    = "Array (" ++ showShape (shape arr) ++ ") \n " ++ showMat (toMatrix (toList arr))+    where+      showRow xs        = intercalate "," (map show xs)+      showMat mat       = "[" ++ intercalate "\n ," (map showRow mat) ++ "]"++      Z :. _ :. cols    = shape arr+      toMatrix []       = []+      toMatrix xs       = let (r,rs) = splitAt cols xs+                          in  r : toMatrix rs+--}  -- | Nicely format a shape as a string --
Data/Array/Accelerate/Debug.hs view
@@ -47,26 +47,7 @@ import System.IO.Unsafe                         ( unsafePerformIO ) import qualified Data.Map                       as Map --#if __GLASGOW_HASKELL__ >= 704 import Debug.Trace                              ( traceIO, traceEventIO )-#else-import Debug.Trace                              ( putTraceMsg )--traceIO :: String -> IO ()-traceIO = putTraceMsg--traceEventIO :: String -> IO ()-traceEventIO = traceIO-#endif--#if !MIN_VERSION_base(4,6,0)-modifyIORef' :: IORef a -> (a -> a) -> IO ()-modifyIORef' ref f = do-  x <- readIORef ref-  let x' = f x-  x' `seq` writeIORef ref x'-#endif   -- -----------------------------------------------------------------------------
Data/Array/Accelerate/Interpreter.hs view
@@ -130,6 +130,15 @@ evalPreOpenAcc (Acond cond acc1 acc2) aenv   = if (evalExp cond aenv) then evalOpenAcc acc1 aenv else evalOpenAcc acc2 aenv +evalPreOpenAcc (Awhile cond body acc) aenv+  = let f       = evalOpenAfun body aenv+        p       = evalOpenAfun cond aenv+        go !x+          | (p x) Sugar.! Z = go (f x)+          | otherwise       = delay x+    in+    go . force $ evalOpenAcc acc aenv+ evalPreOpenAcc (Use arr) _aenv = delay (Sugar.toArr arr :: a)  evalPreOpenAcc (Unit e) aenv = unitOp (evalExp e aenv)@@ -311,22 +320,22 @@         in         BOUNDS_CHECK(checkIndex) "slice" i sz $ (sl', \ix -> (f' ix, i)) -mapOp :: Sugar.Elt e' -      => (e -> e') -      -> Delayed (Array dim e) +mapOp :: Sugar.Elt e'+      => (e -> e')+      -> Delayed (Array dim e)       -> Delayed (Array dim e') mapOp f (DelayedRpair DelayedRunit (DelayedRarray sh rf))   = DelayedRpair DelayedRunit   $ DelayedRarray sh (Sugar.sinkFromElt f . rf)  zipWithOp :: Sugar.Elt e3-          => (e1 -> e2 -> e3) -          -> Delayed (Array dim e1) -          -> Delayed (Array dim e2) +          => (e1 -> e2 -> e3)+          -> Delayed (Array dim e1)+          -> Delayed (Array dim e2)           -> Delayed (Array dim e3) zipWithOp f (DelayedRpair DelayedRunit (DelayedRarray sh1 rf1)) (DelayedRpair DelayedRunit (DelayedRarray sh2 rf2))   = DelayedRpair DelayedRunit-  $ DelayedRarray (sh1 `intersect` sh2) +  $ DelayedRarray (sh1 `intersect` sh2)                  (\ix -> (Sugar.sinkFromElt2 f) (rf1 ix) (rf2 ix))  foldOp :: Sugar.Shape dim@@ -634,8 +643,8 @@                                     Left v    -> v                                     Right ix' -> rf (Sugar.fromElt ix') -stencil2Op :: forall dim e1 e2 e' stencil1 stencil2. -              (Sugar.Elt e1, Sugar.Elt e2, Sugar.Elt e', +stencil2Op :: forall dim e1 e2 e' stencil1 stencil2.+              (Sugar.Elt e1, Sugar.Elt e2, Sugar.Elt e',                Stencil dim e1 stencil1, Stencil dim e2 stencil2)            => (stencil1 -> stencil2 -> e')            -> Boundary (Sugar.EltRepr e1)@@ -669,7 +678,7 @@ -- evalOpenFun :: OpenFun env aenv t -> ValElt env -> Val aenv -> t evalOpenFun (Body e) env aenv = evalOpenExp e env aenv-evalOpenFun (Lam f)  env aenv +evalOpenFun (Lam f)  env aenv   = \x -> evalOpenFun f (env `PushElt` Sugar.fromElt x) aenv  -- Evaluate a closed function@@ -684,7 +693,7 @@ --     execution.  If these operations are in the body of a function that --     gets mapped over an array, the array argument would be forced many times --     leading to a large amount of wasteful recomputation.---  +-- evalOpenExp :: OpenExp env aenv a -> ValElt env -> Val aenv -> a  evalOpenExp (Let exp1 exp2) env aenv@@ -697,22 +706,22 @@ evalOpenExp (Const c) _ _   = Sugar.toElt c -evalOpenExp (Tuple tup) env aenv +evalOpenExp (Tuple tup) env aenv   = toTuple $ evalTuple tup env aenv -evalOpenExp (Prj idx e) env aenv +evalOpenExp (Prj idx e) env aenv   = evalPrj idx (fromTuple $ evalOpenExp e env aenv) -evalOpenExp IndexNil _env _aenv +evalOpenExp IndexNil _env _aenv   = Z -evalOpenExp (IndexCons sh i) env aenv +evalOpenExp (IndexCons sh i) env aenv   = evalOpenExp sh env aenv :. evalOpenExp i env aenv -evalOpenExp (IndexHead ix) env aenv +evalOpenExp (IndexHead ix) env aenv   = case evalOpenExp ix env aenv of _:.h -> h -evalOpenExp (IndexTail ix) env aenv +evalOpenExp (IndexTail ix) env aenv   = case evalOpenExp ix env aenv of t:._ -> t  evalOpenExp (IndexAny) _ _@@ -756,14 +765,14 @@     then evalOpenExp t env aenv     else evalOpenExp e env aenv -evalOpenExp (Iterate limit loop seed) env aenv-  = let f = evalOpenFun (Lam (Body loop)) env aenv-        x = evalOpenExp seed  env aenv-        n = evalOpenExp limit env aenv-        ---        go !i !acc | i >= n     = acc-                   | otherwise  = go (i+1) (f acc)-    in go 0 x+evalOpenExp (While cond body seed) env aenv+  = let f       = evalOpenFun body env aenv+        p       = evalOpenFun cond env aenv+        go !x+          | p x         = go (f x)+          | otherwise   = x+    in+    go (evalOpenExp seed env aenv)  evalOpenExp (PrimConst c) _ _ = evalPrimConst c @@ -924,25 +933,25 @@   -- Extract methods from reified dictionaries--- +--  -- Constant methods of Bounded--- +--  evalMinBound :: BoundedType a -> a-evalMinBound (IntegralBoundedType ty) +evalMinBound (IntegralBoundedType ty)   | IntegralDict <- integralDict ty = minBound-evalMinBound (NonNumBoundedType   ty) +evalMinBound (NonNumBoundedType   ty)   | NonNumDict   <- nonNumDict ty   = minBound  evalMaxBound :: BoundedType a -> a-evalMaxBound (IntegralBoundedType ty) +evalMaxBound (IntegralBoundedType ty)   | IntegralDict <- integralDict ty = maxBound-evalMaxBound (NonNumBoundedType   ty) +evalMaxBound (NonNumBoundedType   ty)   | NonNumDict   <- nonNumDict ty   = maxBound  -- Constant method of floating--- +--  evalPi :: FloatingType a -> a evalPi ty | FloatingDict <- floatingDict ty = pi@@ -1014,7 +1023,7 @@   -- Methods of Num--- +--  evalAdd :: NumType a -> ((a, a) -> a) evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (+)@@ -1085,66 +1094,66 @@   evalLt :: ScalarType a -> ((a, a) -> Bool)-evalLt (NumScalarType (IntegralNumType ty)) +evalLt (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry (<)-evalLt (NumScalarType (FloatingNumType ty)) +evalLt (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry (<)-evalLt (NonNumScalarType ty) +evalLt (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry (<)  evalGt :: ScalarType a -> ((a, a) -> Bool)-evalGt (NumScalarType (IntegralNumType ty)) +evalGt (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry (>)-evalGt (NumScalarType (FloatingNumType ty)) +evalGt (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry (>)-evalGt (NonNumScalarType ty) +evalGt (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry (>)  evalLtEq :: ScalarType a -> ((a, a) -> Bool)-evalLtEq (NumScalarType (IntegralNumType ty)) +evalLtEq (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry (<=)-evalLtEq (NumScalarType (FloatingNumType ty)) +evalLtEq (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry (<=)-evalLtEq (NonNumScalarType ty) +evalLtEq (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry (<=)  evalGtEq :: ScalarType a -> ((a, a) -> Bool)-evalGtEq (NumScalarType (IntegralNumType ty)) +evalGtEq (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry (>=)-evalGtEq (NumScalarType (FloatingNumType ty)) +evalGtEq (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry (>=)-evalGtEq (NonNumScalarType ty) +evalGtEq (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry (>=)  evalEq :: ScalarType a -> ((a, a) -> Bool)-evalEq (NumScalarType (IntegralNumType ty)) +evalEq (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry (==)-evalEq (NumScalarType (FloatingNumType ty)) +evalEq (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry (==)-evalEq (NonNumScalarType ty) +evalEq (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry (==)  evalNEq :: ScalarType a -> ((a, a) -> Bool)-evalNEq (NumScalarType (IntegralNumType ty)) +evalNEq (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry (/=)-evalNEq (NumScalarType (FloatingNumType ty)) +evalNEq (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry (/=)-evalNEq (NonNumScalarType ty) +evalNEq (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry (/=)  evalMax :: ScalarType a -> ((a, a) -> a)-evalMax (NumScalarType (IntegralNumType ty)) +evalMax (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry max-evalMax (NumScalarType (FloatingNumType ty)) +evalMax (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry max-evalMax (NonNumScalarType ty) +evalMax (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry max  evalMin :: ScalarType a -> ((a, a) -> a)-evalMin (NumScalarType (IntegralNumType ty)) +evalMin (NumScalarType (IntegralNumType ty))   | IntegralDict <- integralDict ty = uncurry min-evalMin (NumScalarType (FloatingNumType ty)) +evalMin (NumScalarType (FloatingNumType ty))   | FloatingDict <- floatingDict ty = uncurry min-evalMin (NonNumScalarType ty) +evalMin (NonNumScalarType ty)   | NonNumDict   <- nonNumDict ty   = uncurry min
Data/Array/Accelerate/Language.hs view
@@ -1,13 +1,7 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances  #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}+{-# LANGUAGE OverlappingInstances #-}   -- TLM: required by client code+{-# LANGUAGE TypeOperators        #-}+{-# OPTIONS -fno-warn-missing-methods #-}+{-# OPTIONS -fno-warn-orphans         #-} -- | -- Module      : Data.Array.Accelerate.Language -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -28,98 +22,80 @@  module Data.Array.Accelerate.Language ( -  -- ** Array and scalar expressions+  -- * Array and scalar expressions   Acc, Exp,                                 -- re-exporting from 'Smart' -  -- ** Stencil specification-  Boundary(..), Stencil,                    -- re-exporting from 'Smart'--  -- ** Common stencil types-  Stencil3, Stencil5, Stencil7, Stencil9,-  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,-  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,-  Stencil3x5x5, Stencil5x5x5,--  -- ** Scalar introduction+  -- * Scalar introduction   constant,                                 -- re-exporting from 'Smart' -  -- ** Array construction+  -- * Array construction   use, unit, replicate, generate, -  -- ** Shape manipulation+  -- * Shape manipulation   reshape, -  -- ** Extraction of subarrays+  -- * Extraction of subarrays   slice, -  -- ** Map-like functions+  -- * Map-like functions   map, zipWith, -  -- ** Reductions+  -- * Reductions   fold, fold1, foldSeg, fold1Seg, -  -- ** Scan functions+  -- * Scan functions   scanl, scanl', scanl1, scanr, scanr', scanr1, -  -- ** Permutations+  -- * Permutations   permute, backpermute, -  -- ** Stencil operations+  -- * Stencil operations   stencil, stencil2, -  -- ** Foreign functions+  -- ** Stencil specification+  Boundary(..), Stencil,++  -- ** Common stencil types+  Stencil3, Stencil5, Stencil7, Stencil9,+  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,+  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,+  Stencil3x5x5, Stencil5x5x5,++  -- * Foreign functions   foreignAcc, foreignAcc2, foreignAcc3,   foreignExp, foreignExp2, foreignExp3, -  -- ** Pipelining+  -- * Pipelining   (>->), -  -- ** Array-level flow-control-  cond, (?|),--  -- ** Lifting and Unlifting-  -- | A value of type `Int` is a plain Haskell value (unlifted),-  --   whereas an @Exp Int@ is a /lifted/ value, that is, an integer-  --   lifted into the domain of expressions (an abstract syntax tree-  --   in disguise).  Both `Acc` and `Exp` are /surface types/ into-  --   which values may be lifted.-  ---  --   In general an @Exp Int@ cannot be unlifted into an `Int`,-  --   because the actual number will not be available until a later stage of-  --   execution (e.g. GPU execution, when `run` is called).  However,-  --   in some cases unlifting makes sense.  For example, unlifting-  --   can convert unpack an expression of tuple type into a tuple of-  --   expressions; those expressions, at runtime, will become tuple-  --   dereferences.-  Lift(..), Unlift(..), lift1, lift2, ilift1, ilift2,--  -- ** Tuple construction and destruction-  fst, snd, curry, uncurry,+  -- * Array-level flow-control+  acond, awhile, -  -- ** Index construction and destruction-  index0, index1, unindex1, index2, unindex2,+  -- * Index construction and destruction   indexHead, indexTail, toIndex, fromIndex,+  intersect, -  -- ** Conditional expressions-  (?),+  -- * Flow-control+  cond, while, -  -- ** Array operations with a scalar result-  (!), (!!), the, null, shape, size, shapeSize,+  -- * Array operations with a scalar result+  (!), (!!), shape, size, shapeSize, -  -- ** Methods of H98 classes that we need to redefine as their signatures change-  (==*), (/=*), (<*), (<=*), (>*), (>=*), max, min,+  -- * Methods of H98 classes that we need to redefine as their signatures change+  (==*), (/=*), (<*), (<=*), (>*), (>=*),   bit, setBit, clearBit, complementBit, testBit,   shift,  shiftL,  shiftR,   rotate, rotateL, rotateR,   truncate, round, floor, ceiling,+  even, odd, -  -- ** Standard functions that we need to redefine as their signatures change+  -- * Standard functions that we need to redefine as their signatures change   (&&*), (||*), not, -  -- ** Conversions+  -- * Conversions   boolToInt, fromIntegral, -  -- ** Constants+  -- * Constants   ignore    -- Instances of Bounded, Enum, Eq, Ord, Bits, Num, Real, Floating,@@ -127,20 +103,16 @@  ) where --- avoid clashes with Prelude functions-import Prelude  hiding (-  (!!), replicate, zip, unzip, map, scanl, scanl1, scanr, scanr1, zipWith,-  filter, max, min, not, fst, snd, curry, uncurry, null, truncate, round, floor,-  ceiling, fromIntegral)- -- standard libraries-import Data.Bits (Bits((.&.), (.|.), xor, complement))+import Prelude ( Bounded, Enum, Num, Real, Integral, Floating, Fractional,+  RealFloat, RealFrac, Eq, Ord, Bool, Char, Float, Double, (.), ($), id, error )+import Data.Bits ( Bits((.&.), (.|.), xor, complement) )+import qualified Prelude                                as P  -- friends import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Array.Sugar                hiding ((!), ignore, shape, size, toIndex, fromIndex)+import Data.Array.Accelerate.Array.Sugar                hiding ((!), ignore, shape, size, toIndex, fromIndex, intersect) import qualified Data.Array.Accelerate.Array.Sugar      as Sugar  @@ -338,7 +310,7 @@        -> Exp a        -> Acc (Vector a)        -> (Acc (Vector a), Acc (Scalar a))-scanl' = unlift . Acc $$$ Scanl'+scanl' = unatup2 . Acc $$$ Scanl'  -- | Data.List style left-to-right scan without an initial value (aka inclusive -- scan).  Again, the first argument needs to be an /associative/ function.@@ -368,7 +340,7 @@        -> Exp a        -> Acc (Vector a)        -> (Acc (Vector a), Acc (Scalar a))-scanr' = unlift . Acc $$$ Scanr'+scanr' = unatup2 . Acc $$$ Scanr'  -- | Right-to-left variant of 'scanl1'. --@@ -381,13 +353,14 @@ -- Permutations -- ------------ --- | Forward permutation specified by an index mapping.  The result array is+-- | Forward permutation specified by an index mapping. The result array is -- initialised with the given defaults and any further values that are permuted -- into the result array are added to the current value using the given -- combination function. ----- The combination function must be /associative/.  Elements that are mapped to--- the magic value 'ignore' by the permutation function are dropped.+-- The combination function must be /associative/ and /commutative/. Elements+-- that are mapped to the magic value 'ignore' by the permutation function are+-- dropped. -- permute :: (Shape ix, Shape ix', Elt a)         => (Exp a -> Exp a -> Exp a)    -- ^combination function@@ -435,6 +408,7 @@ type Stencil3x5x5 a = (Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a) type Stencil5x5x5 a = (Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a) + -- |Map a stencil over an array.  In contrast to 'map', the domain of a stencil function is an --  entire /neighbourhood/ of each array element.  Neighbourhoods are sub-arrays centred around a --  focal point.  They are not necessarily rectangular, but they are symmetric in each dimension@@ -554,482 +528,25 @@  -- | An array-level if-then-else construct. ---cond :: (Arrays a)-     => Exp Bool          -- ^if-condition-     -> Acc a             -- ^then-array-     -> Acc a             -- ^else-array-     -> Acc a-cond = Acc $$$ Acond---- | Infix version of 'cond'.----infix 0 ?|-(?|) :: (Arrays a) => Exp Bool -> (Acc a, Acc a) -> Acc a-c ?| (t, e) = cond c t e----- Lifting surface expressions--- ------------------------------- | The class of types @e@ which can be lifted into @c@.-class Lift c e where-  -- | An associated-type (i.e. a type-level function) that strips all-  --   instances of surface type constructors @c@ from the input type @e@.-  ---  --   For example, the tuple types @(Exp Int, Int)@ and @(Int, Exp-  --   Int)@ have the same \"Plain\" representation.  That is, the-  --   following type equality holds:-  ---  --    @Plain (Exp Int, Int) ~ (Int,Int) ~ Plain (Int, Exp Int)@-  type Plain e--  -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar-  -- expressions or 'Acc' for array computations. The value may already contain-  -- subexpressions in 'c'.-  ---  lift :: e -> c (Plain e)---- | A limited subset of types which can be lifted, can also be unlifted.-class Lift c e => Unlift c e where--  -- | Unlift the outermost constructor through the surface type. This is only-  -- possible if the constructor is fully determined by its type - i.e., it is a-  -- singleton.-  ---  unlift :: c (Plain e) -> e---- instances for indices--instance Lift Exp () where-  type Plain () = ()-  lift _ = Exp $ Tuple NilTup--instance Unlift Exp () where-  unlift _ = ()--instance Lift Exp Z where-  type Plain Z = Z-  lift _ = Exp $ IndexNil--instance Unlift Exp Z where-  unlift _ = Z--instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where-  type Plain (ix :. Int) = Plain ix :. Int-  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)--instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where-  type Plain (ix :. All) = Plain ix :. All-  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)--instance (Elt e, Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where-  type Plain (ix :. Exp e) = Plain ix :. e-  lift (ix:.i) = Exp $ IndexCons (lift ix) i--instance (Elt e, Slice (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where-  unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e)--instance (Elt e, Slice ix) => Unlift Exp (Exp ix :. Exp e) where-  unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e)--instance Shape sh => Lift Exp (Any sh) where- type Plain (Any sh) = Any sh- lift Any = Exp $ IndexAny---- instances for numeric types--instance Lift Exp Int where-  type Plain Int = Int-  lift = Exp . Const--instance Lift Exp Int8 where-  type Plain Int8 = Int8-  lift = Exp . Const--instance Lift Exp Int16 where-  type Plain Int16 = Int16-  lift = Exp . Const--instance Lift Exp Int32 where-  type Plain Int32 = Int32-  lift = Exp . Const--instance Lift Exp Int64 where-  type Plain Int64 = Int64-  lift = Exp . Const--instance Lift Exp Word where-  type Plain Word = Word-  lift = Exp . Const--instance Lift Exp Word8 where-  type Plain Word8 = Word8-  lift = Exp . Const--instance Lift Exp Word16 where-  type Plain Word16 = Word16-  lift = Exp . Const--instance Lift Exp Word32 where-  type Plain Word32 = Word32-  lift = Exp . Const--instance Lift Exp Word64 where-  type Plain Word64 = Word64-  lift = Exp . Const--{--instance Lift Exp CShort where-  type Plain CShort = CShort-  lift = Exp . Const--instance Lift Exp CUShort where-  type Plain CUShort = CUShort-  lift = Exp . Const--instance Lift Exp CInt where-  type Plain CInt = CInt-  lift = Exp . Const--instance Lift Exp CUInt where-  type Plain CUInt = CUInt-  lift = Exp . Const--instance Lift Exp CLong where-  type Plain CLong = CLong-  lift = Exp . Const--instance Lift Exp CULong where-  type Plain CULong = CULong-  lift = Exp . Const--instance Lift Exp CLLong where-  type Plain CLLong = CLLong-  lift = Exp . Const--instance Lift Exp CULLong where-  type Plain CULLong = CULLong-  lift = Exp . Const- -}--instance Lift Exp Float where-  type Plain Float = Float-  lift = Exp . Const--instance Lift Exp Double where-  type Plain Double = Double-  lift = Exp . Const--{--instance Lift Exp CFloat where-  type Plain CFloat = CFloat-  lift = Exp . Const--instance Lift Exp CDouble where-  type Plain CDouble = CDouble-  lift = Exp . Const- -}--instance Lift Exp Bool where-  type Plain Bool = Bool-  lift = Exp . Const--instance Lift Exp Char where-  type Plain Char = Char-  lift = Exp . Const--{--instance Lift Exp CChar where-  type Plain CChar = CChar-  lift = Exp . Const--instance Lift Exp CSChar where-  type Plain CSChar = CSChar-  lift = Exp . Const--instance Lift Exp CUChar where--type Plain CUChar = CUChar-  lift = Exp . Const- -}---- Instances for tuples--instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (a, b) where-  type Plain (a, b) = (Plain a, Plain b)-  lift (x, y) = tup2 (lift x, lift y)--instance (Elt a, Elt b) => Unlift Exp (Exp a, Exp b) where-  unlift = untup2--instance (Lift Exp a, Lift Exp b, Lift Exp c,-          Elt (Plain a), Elt (Plain b), Elt (Plain c))-  => Lift Exp (a, b, c) where-  type Plain (a, b, c) = (Plain a, Plain b, Plain c)-  lift (x, y, z) = tup3 (lift x, lift y, lift z)--instance (Elt a, Elt b, Elt c) => Unlift Exp (Exp a, Exp b, Exp c) where-  unlift = untup3--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d))-  => Lift Exp (a, b, c, d) where-  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)-  lift (x, y, z, u) = tup4 (lift x, lift y, lift z, lift u)--instance (Elt a, Elt b, Elt c, Elt d) => Unlift Exp (Exp a, Exp b, Exp c, Exp d) where-  unlift = untup4--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e))-  => Lift Exp (a, b, c, d, e) where-  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)-  lift (x, y, z, u, v) = tup5 (lift x, lift y, lift z, lift u, lift v)--instance (Elt a, Elt b, Elt c, Elt d, Elt e)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e) where-  unlift = untup5--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f))-  => Lift Exp (a, b, c, d, e, f) where-  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)-  lift (x, y, z, u, v, w) = tup6 (lift x, lift y, lift z, lift u, lift v, lift w)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where-  unlift = untup6--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g))-  => Lift Exp (a, b, c, d, e, f, g) where-  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)-  lift (x, y, z, u, v, w, r) = tup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where-  unlift = untup7--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g, Lift Exp h,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g), Elt (Plain h))-  => Lift Exp (a, b, c, d, e, f, g, h) where-  type Plain (a, b, c, d, e, f, g, h)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)-  lift (x, y, z, u, v, w, r, s)-    = tup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where-  unlift = untup8--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,-          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),-          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i))-  => Lift Exp (a, b, c, d, e, f, g, h, i) where-  type Plain (a, b, c, d, e, f, g, h, i)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)-  lift (x, y, z, u, v, w, r, s, t)-    = tup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where-  unlift = untup9---- Instance for scalar Accelerate expressions--instance Lift Exp (Exp e) where-  type Plain (Exp e) = e-  lift = id----- Instance for Accelerate array computations--instance Lift Acc (Acc a) where-  type Plain (Acc a) = a-  lift = id---- Instances for Arrays class----instance Lift Acc () where---  type Plain () = ()---  lift _ = Acc (Atuple NilAtup)--instance (Shape sh, Elt e) => Lift Acc (Array sh e) where-  type Plain (Array sh e) = Array sh e-  lift = Acc . Use--instance (Lift Acc a, Lift Acc b, Arrays (Plain a), Arrays (Plain b)) => Lift Acc (a, b) where-  type Plain (a, b) = (Plain a, Plain b)-  lift (x, y) = atup2 (lift x, lift y)--instance (Arrays a, Arrays b) => Unlift Acc (Acc a, Acc b) where-  unlift = unatup2--instance (Lift Acc a, Lift Acc b, Lift Acc c,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))-  => Lift Acc (a, b, c) where-  type Plain (a, b, c) = (Plain a, Plain b, Plain c)-  lift (x, y, z) = atup3 (lift x, lift y, lift z)--instance (Arrays a, Arrays b, Arrays c) => Unlift Acc (Acc a, Acc b, Acc c) where-  unlift = unatup3--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))-  => Lift Acc (a, b, c, d) where-  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)-  lift (x, y, z, u) = atup4 (lift x, lift y, lift z, lift u)--instance (Arrays a, Arrays b, Arrays c, Arrays d) => Unlift Acc (Acc a, Acc b, Acc c, Acc d) where-  unlift = unatup4--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))-  => Lift Acc (a, b, c, d, e) where-  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)-  lift (x, y, z, u, v) = atup5 (lift x, lift y, lift z, lift u, lift v)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e) where-  unlift = unatup5--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))-  => Lift Acc (a, b, c, d, e, f) where-  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)-  lift (x, y, z, u, v, w) = atup6 (lift x, lift y, lift z, lift u, lift v, lift w)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where-  unlift = unatup6--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g))-  => Lift Acc (a, b, c, d, e, f, g) where-  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)-  lift (x, y, z, u, v, w, r) = atup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where-  unlift = unatup7--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g, Lift Acc h,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g), Arrays (Plain h))-  => Lift Acc (a, b, c, d, e, f, g, h) where-  type Plain (a, b, c, d, e, f, g, h)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)-  lift (x, y, z, u, v, w, r, s)-    = atup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) where-  unlift = unatup8--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,-          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))-  => Lift Acc (a, b, c, d, e, f, g, h, i) where-  type Plain (a, b, c, d, e, f, g, h, i)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)-  lift (x, y, z, u, v, w, r, s, t)-    = atup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) where-  unlift = unatup9----- Helpers to lift functions---- |Lift a unary function into 'Exp'.----lift1 :: (Unlift Exp e1, Lift Exp e2)-      => (e1 -> e2)-      -> Exp (Plain e1)-      -> Exp (Plain e2)-lift1 f = lift . f . unlift---- |Lift a binary function into 'Exp'.----lift2 :: (Unlift Exp e1, Unlift Exp e2, Lift Exp e3)-      => (e1 -> e2 -> e3)-      -> Exp (Plain e1)-      -> Exp (Plain e2)-      -> Exp (Plain e3)-lift2 f x y = lift $ f (unlift x) (unlift y)---- |Lift a unary function to a computation over rank-1 indices.----ilift1 :: (Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1-ilift1 f = lift1 (\(Z:.i) -> Z :. f i)+acond :: Arrays a+      => Exp Bool               -- ^ if-condition+      -> Acc a                  -- ^ then-array+      -> Acc a                  -- ^ else-array+      -> Acc a+acond = Acc $$$ Acond --- |Lift a binary function to a computation over rank-1 indices.+-- | An array-level while construct ---ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1-ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j)+awhile :: (Arrays a)+       => (Acc a -> Acc (Scalar Bool))+       -> (Acc a -> Acc a)+       -> Acc a+       -> Acc a+awhile = Acc $$$ Awhile  --- Helpers to lift tuples---- |Extract the first component of a pair.----fst :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f a-fst e = let (x, _:: f b) = unlift e in x---- |Extract the second component of a pair.----snd :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f b-snd e = let (_::f a, y) = unlift e in y---- |Converts an uncurried function to a curried function.----curry :: Lift f (f a, f b) => (f (Plain (f a), Plain (f b)) -> f c) -> f a -> f b -> f c-curry f x y = f (lift (x, y))---- |Converts a curried function to a function on pairs.----uncurry :: Unlift f (f a, f b) => (f a -> f b -> f c) -> f (Plain (f a), Plain (f b)) -> f c-uncurry f t = let (x, y) = unlift t in f x y---- Helpers to lift shapes and indices---- |The one index for a rank-0 array.----index0 :: Exp Z-index0 = lift Z---- |Turn an 'Int' expression into a rank-1 indexing expression.----index1 :: Elt i => Exp i -> Exp (Z :. i)-index1 i = lift (Z :. i)---- |Turn a rank-1 indexing expression into an 'Int' expression.----unindex1 :: Elt i => Exp (Z :. i) -> Exp i-unindex1 ix = let Z :. i = unlift ix in i---- | Creates a rank-2 index from two Exp Int`s----index2 :: (Elt i, Slice (Z :. i))-       => Exp i-       -> Exp i-       -> Exp (Z :. i :. i)-index2 i j = lift (Z :. i :. j)---- | Destructs a rank-2 index to an Exp tuple of two Int`s.----unindex2 :: forall i. (Elt i, Slice (Z :. i))-         => Exp (Z :. i :. i)-         -> Exp (i, i)-unindex2 ix-  = let Z :. i :. j = unlift ix :: Z :. Exp i :. Exp i-    in  lift (i, j)+-- Shapes and indices+-- ------------------  -- | Get the outermost dimension of a shape --@@ -1052,18 +569,35 @@ fromIndex :: Shape sh => Exp sh -> Exp Int -> Exp sh fromIndex = Exp $$ FromIndex +-- | Intersection of two shapes+--+intersect :: Shape sh => Exp sh -> Exp sh -> Exp sh+intersect = Exp $$ Intersect --- Conditional expressions--- ----------------------- --- |Conditional expression. If the predicate evaluates to 'True', the first--- component of the tuple is returned, else the second.+-- Flow-control+-- ------------++-- | A scalar-level if-then-else construct. ---infix 0 ?-(?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t-c ? (t, e) = Exp $ Cond c t e+cond :: Elt t+     => Exp Bool                -- ^ condition+     -> Exp t                   -- ^ then-expression+     -> Exp t                   -- ^ else-expression+     -> Exp t+cond = Exp $$$ Cond +-- | While construct. Continue to apply the given function, starting with the+-- initial value, until the test function evaluates to true.+--+while :: Elt e+      => (Exp e -> Exp Bool)+      -> (Exp e -> Exp e)+      -> Exp e+      -> Exp e+while = Exp $$$ While + -- Array operations with a scalar result -- ------------------------------------- @@ -1071,23 +605,13 @@ -- infixl 9 ! (!) :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp ix -> Exp e-(!) arr ix = Exp $ Index arr ix+(!) = Exp $$ Index  -- |Expression form that extracts a scalar from an array at a linear index -- infixl 9 !! (!!) :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Int -> Exp e-(!!) arr i = Exp $ LinearIndex arr i---- |Extraction of the element in a singleton array----the :: Elt e => Acc (Scalar e) -> Exp e-the = (!index0)---- |Test whether an array is empty----null :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Bool-null arr = size arr ==* 0+(!!) = Exp $$ LinearIndex  -- |Expression form that yields the shape of an array --@@ -1123,7 +647,9 @@  instance (Elt t, IsScalar t) => Prelude.Ord (Exp t) where   -- FIXME: instance makes no sense with standard signatures-  compare     = error "Prelude.Ord.compare applied to EDSL types"+  compare       = error "Prelude.Ord.compare applied to EDSL types"+  min           = mkMin+  max           = mkMax  instance (Elt t, IsNum t, IsIntegral t) => Bits (Exp t) where   (.&.)      = mkBAnd@@ -1139,7 +665,10 @@ -- otherwise. -- shift :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-shift  x i = i ==* 0 ? (x, i <* 0 ? (x `shiftR` (-i), x `shiftL` i))+shift  x i+  = cond (i ==* 0) x+  $ cond (i <*  0) (x `shiftR` (-i))+                   (x `shiftL` i)  -- | Shift the argument left by the specified number of bits -- (which must be non-negative).@@ -1161,7 +690,10 @@ -- @-i@ bits otherwise. -- rotate :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-rotate x i = i ==* 0 ? (x, i <* 0 ? (x `rotateR` (-i), x `rotateL` i))+rotate x i+  = cond (i ==* 0) x+  $ cond (i <*  0) (x `rotateR` (-i))+                   (x `rotateL` i)  -- | Rotate the argument left by the specified number of bits -- (which must be non-negative).@@ -1208,7 +740,7 @@   negate      = mkNeg   abs         = mkAbs   signum      = mkSig-  fromInteger = constant . fromInteger+  fromInteger = constant . P.fromInteger  instance (Elt t, IsNum t) => Real (Exp t)   -- FIXME: Why did we include this class?  We won't need `toRational' until@@ -1243,7 +775,7 @@ instance (Elt t, IsFloating t) => Fractional (Exp t) where   (/)          = mkFDiv   recip        = mkRecip-  fromRational = constant . fromRational+  fromRational = constant . P.fromRational  instance (Elt t, IsFloating t) => RealFrac (Exp t)   -- FIXME: add other ops@@ -1291,16 +823,6 @@ (<=*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool (<=*) = mkLtEq --- |Determine the maximum of two scalars.----max :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t-max = mkMax---- |Determine the minimum of two scalars.----min :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t-min = mkMin- -- Conversions from the RealFrac class -- @@ -1324,6 +846,16 @@ -- ceiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b ceiling = mkCeiling++-- | return if the integer is even+--+even :: (Elt a, IsIntegral a) => Exp a -> Exp Bool+even x = x .&. 1 ==* 0++-- | return if the integer is odd+--+odd :: (Elt a, IsIntegral a) => Exp a -> Exp Bool+odd x = x .&. 1 ==* 1   -- Non-overloaded standard functions, where we need other signatures
Data/Array/Accelerate/Prelude.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE TypeOperators, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances  #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} -- | -- Module      : Data.Array.Accelerate.Prelude -- Copyright   : [2010..2011] Manuel M T Chakravarty, Gabriele Keller, Ben Lever@@ -9,18 +15,18 @@ -- Stability   : experimental -- Portability : non-portable (GHC extensions) ----- Standard functions that are not part of the core set (directly represented in the AST), but are--- instead implemented in terms of the core set.+-- Standard functions that are not part of the core set (directly represented in+-- the AST), but are instead implemented in terms of the core set. --  module Data.Array.Accelerate.Prelude (    -- * Zipping-  zipWith3, zipWith4,-  zip, zip3, zip4,+  zipWith3, zipWith4, zipWith5, zipWith6, zipWith7, zipWith8, zipWith9,+  zip, zip3, zip4, zip5, zip6, zip7, zip8, zip9,    -- * Unzipping-  unzip, unzip3, unzip4,+  unzip, unzip3, unzip4, unzip5, unzip6, unzip7, unzip8, unzip9,    -- * Reductions   foldAll, fold1All,@@ -41,6 +47,9 @@   -- * Enumeration and filling   fill, enumFromN, enumFromStepN, +  -- * Concatenation+  (++),+   -- * Working with predicates   -- ** Filtering   filter,@@ -52,29 +61,56 @@   -- * Permutations   reverse, transpose, -  -- * Extracting sub-vectors-  init, tail, take, drop, slit+  --  Extracting sub-vectors+  init, tail, take, drop, slit, +  -- * Array-level flow control+  (?|),++  -- * Expression-level flow control+  (?),++  -- * Scalar iteration+  iterate,++  -- * Scalar reduction+  sfoldl, -- sfoldr,++  -- * Lifting and unlifting+  Lift(..), Unlift(..),+  lift1, lift2, ilift1, ilift2,++  -- ** Tuple construction and destruction+  fst, snd, curry, uncurry,++  -- ** Index construction and destruction+  index0, index1, unindex1, index2, unindex2,++  -- * Array operations with a scalar result+  the, null,+ ) where  -- avoid clashes with Prelude functions -- import Data.Bits import Data.Bool-import Prelude ((.), ($), (+), (-), (*), const, subtract, id)+import Prelude ((.), ($), (+), (-), (*), const, subtract, id, min, max, Float,+  Double, Char) import qualified Prelude as P  -- friends-import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size)+import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, intersect) import Data.Array.Accelerate.Language import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Tuple import Data.Array.Accelerate.Type   -- Map-like composites -- ------------------- --- | Zip three arrays with the given function+-- | Zip three arrays with the given function, analogous to 'zipWith'. -- zipWith3 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)          => (Exp a -> Exp b -> Exp c -> Exp d)@@ -83,10 +119,10 @@          -> Acc (Array sh c)          -> Acc (Array sh d) zipWith3 f as bs cs-  = map (\x -> let (a,b,c) = unlift x in f a b c)-  $ zip3 as bs cs+  = generate (shape as `intersect` shape bs `intersect` shape cs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix)) --- | Zip four arrays with the given function+-- | Zip four arrays with the given function, analogous to 'zipWith'. -- zipWith4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)          => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e)@@ -96,9 +132,102 @@          -> Acc (Array sh d)          -> Acc (Array sh e) zipWith4 f as bs cs ds-  = map (\x -> let (a,b,c,d) = unlift x in f a b c d)-  $ zip4 as bs cs ds+  = generate (shape as `intersect` shape bs `intersect`+              shape cs `intersect` shape ds)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix)) +-- | Zip five arrays with the given function, analogous to 'zipWith'.+--+zipWith5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f)+         -> Acc (Array sh a)+         -> Acc (Array sh b)+         -> Acc (Array sh c)+         -> Acc (Array sh d)+         -> Acc (Array sh e)+         -> Acc (Array sh f)+zipWith5 f as bs cs ds es+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix))++-- | Zip six arrays with the given function, analogous to 'zipWith'.+--+zipWith6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g)+         -> Acc (Array sh a)+         -> Acc (Array sh b)+         -> Acc (Array sh c)+         -> Acc (Array sh d)+         -> Acc (Array sh e)+         -> Acc (Array sh f)+         -> Acc (Array sh g)+zipWith6 f as bs cs ds es fs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix))++-- | Zip seven arrays with the given function, analogous to 'zipWith'.+--+zipWith7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h)+         -> Acc (Array sh a)+         -> Acc (Array sh b)+         -> Acc (Array sh c)+         -> Acc (Array sh d)+         -> Acc (Array sh e)+         -> Acc (Array sh f)+         -> Acc (Array sh g)+         -> Acc (Array sh h)+zipWith7 f as bs cs ds es fs gs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix))++-- | Zip eight arrays with the given function, analogous to 'zipWith'.+--+zipWith8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i)+         -> Acc (Array sh a)+         -> Acc (Array sh b)+         -> Acc (Array sh c)+         -> Acc (Array sh d)+         -> Acc (Array sh e)+         -> Acc (Array sh f)+         -> Acc (Array sh g)+         -> Acc (Array sh h)+         -> Acc (Array sh i)+zipWith8 f as bs cs ds es fs gs hs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs+                       `intersect` shape hs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix))++-- | Zip nine arrays with the given function, analogous to 'zipWith'.+--+zipWith9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j)+         -> Acc (Array sh a)+         -> Acc (Array sh b)+         -> Acc (Array sh c)+         -> Acc (Array sh d)+         -> Acc (Array sh e)+         -> Acc (Array sh f)+         -> Acc (Array sh g)+         -> Acc (Array sh h)+         -> Acc (Array sh i)+         -> Acc (Array sh j)+zipWith9 f as bs cs ds es fs gs hs is+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs+                       `intersect` shape hs `intersect` shape is)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix) (is ! ix))++ -- | Combine the elements of two arrays pairwise.  The shape of the result is -- the intersection of the two argument shapes. --@@ -110,27 +239,89 @@  -- | Take three arrays and return an array of triples, analogous to zip. ---zip3 :: forall sh. forall a. forall b. forall c. (Shape sh, Elt a, Elt b, Elt c)+zip3 :: (Shape sh, Elt a, Elt b, Elt c)      => Acc (Array sh a)      -> Acc (Array sh b)      -> Acc (Array sh c)      -> Acc (Array sh (a, b, c))-zip3 as bs cs-  = zipWith (\a bc -> let (b, c) = unlift bc :: (Exp b, Exp c) in lift (a, b, c)) as-  $ zip bs cs+zip3 = zipWith3 (\a b c -> lift (a,b,c))  -- | Take four arrays and return an array of quadruples, analogous to zip. ---zip4 :: forall sh. forall a. forall b. forall c. forall d. (Shape sh, Elt a, Elt b, Elt c, Elt d)+zip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)      => Acc (Array sh a)      -> Acc (Array sh b)      -> Acc (Array sh c)      -> Acc (Array sh d)      -> Acc (Array sh (a, b, c, d))-zip4 as bs cs ds-  = zipWith (\a bcd -> let (b, c, d) = unlift bcd :: (Exp b, Exp c, Exp d) in lift (a, b, c, d)) as-  $ zip3 bs cs ds+zip4 = zipWith4 (\a b c d -> lift (a,b,c,d)) +-- | Take five arrays and return an array of five-tuples, analogous to zip.+--+zip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh (a, b, c, d, e))+zip5 = zipWith5 (\a b c d e -> lift (a,b,c,d,e))++-- | Take six arrays and return an array of six-tuples, analogous to zip.+--+zip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh (a, b, c, d, e, f))+zip6 = zipWith6 (\a b c d e f -> lift (a,b,c,d,e,f))++-- | Take seven arrays and return an array of seven-tuples, analogous to zip.+--+zip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh g)+     -> Acc (Array sh (a, b, c, d, e, f, g))+zip7 = zipWith7 (\a b c d e f g -> lift (a,b,c,d,e,f,g))++-- | Take seven arrays and return an array of seven-tuples, analogous to zip.+--+zip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh g)+     -> Acc (Array sh h)+     -> Acc (Array sh (a, b, c, d, e, f, g, h))+zip8 = zipWith8 (\a b c d e f g h -> lift (a,b,c,d,e,f,g,h))++-- | Take seven arrays and return an array of seven-tuples, analogous to zip.+--+zip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh g)+     -> Acc (Array sh h)+     -> Acc (Array sh i)+     -> Acc (Array sh (a, b, c, d, e, f, g, h, i))+zip9 = zipWith9 (\a b c d e f g h i -> lift (a,b,c,d,e,f,g,h,i))++ -- | The converse of 'zip', but the shape of the two results is identical to the -- shape of the argument. --@@ -146,14 +337,9 @@        -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)) unzip3 xs = (map get1 xs, map get2 xs, map get3 xs)   where-    get1 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp a-    get1 x = let (a, _ :: Exp b, _ :: Exp c) = unlift x in a--    get2 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp b-    get2 x = let (_ :: Exp a, b, _ :: Exp c) = unlift x in b--    get3 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp c-    get3 x = let (_ :: Exp a, _ :: Exp b, c) = unlift x in c+    get1 x = let (a,_,_) = untup3 x in a+    get2 x = let (_,b,_) = untup3 x in b+    get3 x = let (_,_,c) = untup3 x in c   -- | Take an array of quadruples and return four arrays, analogous to unzip.@@ -163,19 +349,100 @@        -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d)) unzip4 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs)   where-    get1 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp a-    get1 x = let (a, _ :: Exp b, _ :: Exp c, _ :: Exp d) = unlift x in a+    get1 x = let (a,_,_,_) = untup4 x in a+    get2 x = let (_,b,_,_) = untup4 x in b+    get3 x = let (_,_,c,_) = untup4 x in c+    get4 x = let (_,_,_,d) = untup4 x in d -    get2 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp b-    get2 x = let (_ :: Exp a, b, _ :: Exp c, _ :: Exp d) = unlift x in b+-- | Take an array of 5-tuples and return five arrays, analogous to unzip.+--+unzip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)+       => Acc (Array sh (a, b, c, d, e))+       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d), Acc (Array sh e))+unzip5 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs)+  where+    get1 x = let (a,_,_,_,_) = untup5 x in a+    get2 x = let (_,b,_,_,_) = untup5 x in b+    get3 x = let (_,_,c,_,_) = untup5 x in c+    get4 x = let (_,_,_,d,_) = untup5 x in d+    get5 x = let (_,_,_,_,e) = untup5 x in e -    get3 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp c-    get3 x = let (_ :: Exp a, _ :: Exp b, c, _ :: Exp d) = unlift x in c+-- | Take an array of 6-tuples and return six arrays, analogous to unzip.+--+unzip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+       => Acc (Array sh (a, b, c, d, e, f))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f))+unzip6 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs, map get6 xs)+  where+    get1 x = let (a,_,_,_,_,_) = untup6 x in a+    get2 x = let (_,b,_,_,_,_) = untup6 x in b+    get3 x = let (_,_,c,_,_,_) = untup6 x in c+    get4 x = let (_,_,_,d,_,_) = untup6 x in d+    get5 x = let (_,_,_,_,e,_) = untup6 x in e+    get6 x = let (_,_,_,_,_,f) = untup6 x in f -    get4 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp d-    get4 x = let (_ :: Exp a, _ :: Exp b, _ :: Exp c, d) = unlift x in d+-- | Take an array of 7-tuples and return seven arrays, analogous to unzip.+--+unzip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+       => Acc (Array sh (a, b, c, d, e, f, g))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)+          , Acc (Array sh g))+unzip7 xs = ( map get1 xs, map get2 xs, map get3 xs+            , map get4 xs, map get5 xs, map get6 xs+            , map get7 xs )+  where+    get1 x = let (a,_,_,_,_,_,_) = untup7 x in a+    get2 x = let (_,b,_,_,_,_,_) = untup7 x in b+    get3 x = let (_,_,c,_,_,_,_) = untup7 x in c+    get4 x = let (_,_,_,d,_,_,_) = untup7 x in d+    get5 x = let (_,_,_,_,e,_,_) = untup7 x in e+    get6 x = let (_,_,_,_,_,f,_) = untup7 x in f+    get7 x = let (_,_,_,_,_,_,g) = untup7 x in g +-- | Take an array of 8-tuples and return eight arrays, analogous to unzip.+--+unzip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+       => Acc (Array sh (a, b, c, d, e, f, g, h))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)+          , Acc (Array sh g), Acc (Array sh h) )+unzip8 xs = ( map get1 xs, map get2 xs, map get3 xs+            , map get4 xs, map get5 xs, map get6 xs+            , map get7 xs, map get8 xs )+  where+    get1 x = let (a,_,_,_,_,_,_,_) = untup8 x in a+    get2 x = let (_,b,_,_,_,_,_,_) = untup8 x in b+    get3 x = let (_,_,c,_,_,_,_,_) = untup8 x in c+    get4 x = let (_,_,_,d,_,_,_,_) = untup8 x in d+    get5 x = let (_,_,_,_,e,_,_,_) = untup8 x in e+    get6 x = let (_,_,_,_,_,f,_,_) = untup8 x in f+    get7 x = let (_,_,_,_,_,_,g,_) = untup8 x in g+    get8 x = let (_,_,_,_,_,_,_,h) = untup8 x in h +-- | Take an array of 8-tuples and return eight arrays, analogous to unzip.+--+unzip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+       => Acc (Array sh (a, b, c, d, e, f, g, h, i))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)+          , Acc (Array sh g), Acc (Array sh h), Acc (Array sh i))+unzip9 xs = ( map get1 xs, map get2 xs, map get3 xs+            , map get4 xs, map get5 xs, map get6 xs+            , map get7 xs, map get8 xs, map get9 xs )+  where+    get1 x = let (a,_,_,_,_,_,_,_,_) = untup9 x in a+    get2 x = let (_,b,_,_,_,_,_,_,_) = untup9 x in b+    get3 x = let (_,_,c,_,_,_,_,_,_) = untup9 x in c+    get4 x = let (_,_,_,d,_,_,_,_,_) = untup9 x in d+    get5 x = let (_,_,_,_,e,_,_,_,_) = untup9 x in e+    get6 x = let (_,_,_,_,_,f,_,_,_) = untup9 x in f+    get7 x = let (_,_,_,_,_,_,g,_,_) = untup9 x in g+    get8 x = let (_,_,_,_,_,_,_,h,_) = untup9 x in h+    get9 x = let (_,_,_,_,_,_,_,_,i) = untup9 x in i++ -- Reductions -- ---------- @@ -628,7 +895,26 @@   $ generate (index1 $ shapeSize sh)              (\ix -> (fromIntegral (unindex1 ix :: Exp Int) * y) + x) +-- Concatenation+-- ------------- +-- | Concatenate outermost component of two arrays. The extent of the lower+--   dimensional component is the intersection of the two arrays.+--+infixr 5 +++(++) :: forall sh e. (Slice sh, Shape sh, Elt e)+     => Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+(++) xs ys+  = let sh1 :. n        = unlift (shape xs)     :: Exp sh :. Exp Int+        sh2 :. m        = unlift (shape ys)     :: Exp sh :. Exp Int+    in+    generate (lift (intersect sh1 sh2 :. n + m))+             (\ix -> let sh :. i = unlift ix    :: Exp sh :. Exp Int+                     in  i <* n ? ( xs ! ix, ys ! lift (sh :. i-n)) )++ -- Filtering -- --------- @@ -832,4 +1118,531 @@   let i' = the (unit i)       n' = the (unit n)   in  backpermute (index1 n') (ilift1 (+ i'))+++-- Flow control+-- ------------++-- | Infix version of 'acond'. If the predicate evaluates to 'True', the first+-- component of the tuple is returned, else the second.+--+infix 0 ?|+(?|) :: (Arrays a) => Exp Bool -> (Acc a, Acc a) -> Acc a+c ?| (t, e) = acond c t e++-- | An infix version of 'cond'. If the predicate evaluates to 'True', the first+-- component of the tuple is returned, else the second.+--+infix 0 ?+(?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t+c ? (t, e) = cond c t e+++-- Scalar iteration+-- ----------------++-- | Repeatedly apply a function a fixed number of times+--+iterate :: forall a. Elt a+        => Exp Int+        -> (Exp a -> Exp a)+        -> Exp a+        -> Exp a+iterate n f z+  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)+        step (i, acc)   = ( i+1, f acc )+    in+    snd $ while (\v -> fst v <* n) (lift1 step) (lift (constant 0, z))+++-- Scalar bulk operations+-- ----------------------++-- | Reduce along an innermost slice of an array /sequentially/, by applying a+-- binary operator to a starting value and the array from left to right.+--+sfoldl :: forall sh a b. (Shape sh, Slice sh, Elt a, Elt b)+       => (Exp a -> Exp b -> Exp a)+       -> Exp a+       -> Exp sh+       -> Acc (Array (sh :. Int) b)+       -> Exp a+sfoldl f z ix xs+  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)+        step (i, acc)   = ( i+1, acc `f` (xs ! lift (ix :. i)) )+        (_ :. n)        = unlift (shape xs)     :: Exp sh :. Exp Int+    in+    snd $ while (\v -> fst v <* n) (lift1 step) (lift (constant 0, z))+++-- Lifting surface expressions+-- ---------------------------++-- | The class of types @e@ which can be lifted into @c@.+class Lift c e where+  -- | An associated-type (i.e. a type-level function) that strips all+  --   instances of surface type constructors @c@ from the input type @e@.+  --+  --   For example, the tuple types @(Exp Int, Int)@ and @(Int, Exp+  --   Int)@ have the same \"Plain\" representation.  That is, the+  --   following type equality holds:+  --+  --    @Plain (Exp Int, Int) ~ (Int,Int) ~ Plain (Int, Exp Int)@+  type Plain e++  -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar+  -- expressions or 'Acc' for array computations. The value may already contain+  -- subexpressions in 'c'.+  --+  lift :: e -> c (Plain e)++-- | A limited subset of types which can be lifted, can also be unlifted.+class Lift c e => Unlift c e where++  -- | Unlift the outermost constructor through the surface type. This is only+  -- possible if the constructor is fully determined by its type - i.e., it is a+  -- singleton.+  --+  unlift :: c (Plain e) -> e++-- instances for indices++instance Lift Exp () where+  type Plain () = ()+  lift _ = Exp $ Tuple NilTup++instance Unlift Exp () where+  unlift _ = ()++instance Lift Exp Z where+  type Plain Z = Z+  lift _ = Exp $ IndexNil++instance Unlift Exp Z where+  unlift _ = Z++instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where+  type Plain (ix :. Int) = Plain ix :. Int+  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)++instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where+  type Plain (ix :. All) = Plain ix :. All+  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)++instance (Elt e, Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where+  type Plain (ix :. Exp e) = Plain ix :. e+  lift (ix:.i) = Exp $ IndexCons (lift ix) i++instance (Elt e, Slice (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where+  unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e)++instance (Elt e, Slice ix) => Unlift Exp (Exp ix :. Exp e) where+  unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e)++instance Shape sh => Lift Exp (Any sh) where+ type Plain (Any sh) = Any sh+ lift Any = Exp $ IndexAny++-- instances for numeric types++instance Lift Exp Int where+  type Plain Int = Int+  lift = Exp . Const++instance Lift Exp Int8 where+  type Plain Int8 = Int8+  lift = Exp . Const++instance Lift Exp Int16 where+  type Plain Int16 = Int16+  lift = Exp . Const++instance Lift Exp Int32 where+  type Plain Int32 = Int32+  lift = Exp . Const++instance Lift Exp Int64 where+  type Plain Int64 = Int64+  lift = Exp . Const++instance Lift Exp Word where+  type Plain Word = Word+  lift = Exp . Const++instance Lift Exp Word8 where+  type Plain Word8 = Word8+  lift = Exp . Const++instance Lift Exp Word16 where+  type Plain Word16 = Word16+  lift = Exp . Const++instance Lift Exp Word32 where+  type Plain Word32 = Word32+  lift = Exp . Const++instance Lift Exp Word64 where+  type Plain Word64 = Word64+  lift = Exp . Const++instance Lift Exp CShort where+  type Plain CShort = CShort+  lift = Exp . Const++instance Lift Exp CUShort where+  type Plain CUShort = CUShort+  lift = Exp . Const++instance Lift Exp CInt where+  type Plain CInt = CInt+  lift = Exp . Const++instance Lift Exp CUInt where+  type Plain CUInt = CUInt+  lift = Exp . Const++instance Lift Exp CLong where+  type Plain CLong = CLong+  lift = Exp . Const++instance Lift Exp CULong where+  type Plain CULong = CULong+  lift = Exp . Const++instance Lift Exp CLLong where+  type Plain CLLong = CLLong+  lift = Exp . Const++instance Lift Exp CULLong where+  type Plain CULLong = CULLong+  lift = Exp . Const++instance Lift Exp Float where+  type Plain Float = Float+  lift = Exp . Const++instance Lift Exp Double where+  type Plain Double = Double+  lift = Exp . Const++instance Lift Exp CFloat where+  type Plain CFloat = CFloat+  lift = Exp . Const++instance Lift Exp CDouble where+  type Plain CDouble = CDouble+  lift = Exp . Const++instance Lift Exp Bool where+  type Plain Bool = Bool+  lift = Exp . Const++instance Lift Exp Char where+  type Plain Char = Char+  lift = Exp . Const++instance Lift Exp CChar where+  type Plain CChar = CChar+  lift = Exp . Const++instance Lift Exp CSChar where+  type Plain CSChar = CSChar+  lift = Exp . Const++instance Lift Exp CUChar where+  type Plain CUChar = CUChar+  lift = Exp . Const++-- Instances for tuples++instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (a, b) where+  type Plain (a, b) = (Plain a, Plain b)+  lift (x, y) = tup2 (lift x, lift y)++instance (Elt a, Elt b) => Unlift Exp (Exp a, Exp b) where+  unlift = untup2++instance (Lift Exp a, Lift Exp b, Lift Exp c,+          Elt (Plain a), Elt (Plain b), Elt (Plain c))+  => Lift Exp (a, b, c) where+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)+  lift (x, y, z) = tup3 (lift x, lift y, lift z)++instance (Elt a, Elt b, Elt c) => Unlift Exp (Exp a, Exp b, Exp c) where+  unlift = untup3++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d))+  => Lift Exp (a, b, c, d) where+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)+  lift (x, y, z, u) = tup4 (lift x, lift y, lift z, lift u)++instance (Elt a, Elt b, Elt c, Elt d) => Unlift Exp (Exp a, Exp b, Exp c, Exp d) where+  unlift = untup4++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e))+  => Lift Exp (a, b, c, d, e) where+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)+  lift (x, y, z, u, v) = tup5 (lift x, lift y, lift z, lift u, lift v)++instance (Elt a, Elt b, Elt c, Elt d, Elt e)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e) where+  unlift = untup5++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f))+  => Lift Exp (a, b, c, d, e, f) where+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)+  lift (x, y, z, u, v, w) = tup6 (lift x, lift y, lift z, lift u, lift v, lift w)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where+  unlift = untup6++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),+          Elt (Plain g))+  => Lift Exp (a, b, c, d, e, f, g) where+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)+  lift (x, y, z, u, v, w, r) = tup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where+  unlift = untup7++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g, Lift Exp h,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),+          Elt (Plain g), Elt (Plain h))+  => Lift Exp (a, b, c, d, e, f, g, h) where+  type Plain (a, b, c, d, e, f, g, h)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)+  lift (x, y, z, u, v, w, r, s)+    = tup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where+  unlift = untup8++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),+          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i))+  => Lift Exp (a, b, c, d, e, f, g, h, i) where+  type Plain (a, b, c, d, e, f, g, h, i)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)+  lift (x, y, z, u, v, w, r, s, t)+    = tup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where+  unlift = untup9++-- Instance for scalar Accelerate expressions++instance Lift Exp (Exp e) where+  type Plain (Exp e) = e+  lift = id+++-- Instance for Accelerate array computations++instance Lift Acc (Acc a) where+  type Plain (Acc a) = a+  lift = id++-- Instances for Arrays class++--instance Lift Acc () where+--  type Plain () = ()+--  lift _ = Acc (Atuple NilAtup)++instance (Shape sh, Elt e) => Lift Acc (Array sh e) where+  type Plain (Array sh e) = Array sh e+  lift = Acc . Use++instance (Lift Acc a, Lift Acc b, Arrays (Plain a), Arrays (Plain b)) => Lift Acc (a, b) where+  type Plain (a, b) = (Plain a, Plain b)+  lift (x, y) = atup2 (lift x, lift y)++instance (Arrays a, Arrays b) => Unlift Acc (Acc a, Acc b) where+  unlift = unatup2++instance (Lift Acc a, Lift Acc b, Lift Acc c,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))+  => Lift Acc (a, b, c) where+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)+  lift (x, y, z) = atup3 (lift x, lift y, lift z)++instance (Arrays a, Arrays b, Arrays c) => Unlift Acc (Acc a, Acc b, Acc c) where+  unlift = unatup3++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))+  => Lift Acc (a, b, c, d) where+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)+  lift (x, y, z, u) = atup4 (lift x, lift y, lift z, lift u)++instance (Arrays a, Arrays b, Arrays c, Arrays d) => Unlift Acc (Acc a, Acc b, Acc c, Acc d) where+  unlift = unatup4++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))+  => Lift Acc (a, b, c, d, e) where+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)+  lift (x, y, z, u, v) = atup5 (lift x, lift y, lift z, lift u, lift v)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e) where+  unlift = unatup5++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))+  => Lift Acc (a, b, c, d, e, f) where+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)+  lift (x, y, z, u, v, w) = atup6 (lift x, lift y, lift z, lift u, lift v, lift w)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where+  unlift = unatup6++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g))+  => Lift Acc (a, b, c, d, e, f, g) where+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)+  lift (x, y, z, u, v, w, r) = atup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where+  unlift = unatup7++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g, Lift Acc h,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h))+  => Lift Acc (a, b, c, d, e, f, g, h) where+  type Plain (a, b, c, d, e, f, g, h)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)+  lift (x, y, z, u, v, w, r, s)+    = atup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) where+  unlift = unatup8++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))+  => Lift Acc (a, b, c, d, e, f, g, h, i) where+  type Plain (a, b, c, d, e, f, g, h, i)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)+  lift (x, y, z, u, v, w, r, s, t)+    = atup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) where+  unlift = unatup9++++-- |Lift a unary function into 'Exp'.+--+lift1 :: (Unlift Exp e1, Lift Exp e2)+      => (e1 -> e2)+      -> Exp (Plain e1)+      -> Exp (Plain e2)+lift1 f = lift . f . unlift++-- |Lift a binary function into 'Exp'.+--+lift2 :: (Unlift Exp e1, Unlift Exp e2, Lift Exp e3)+      => (e1 -> e2 -> e3)+      -> Exp (Plain e1)+      -> Exp (Plain e2)+      -> Exp (Plain e3)+lift2 f x y = lift $ f (unlift x) (unlift y)++-- |Lift a unary function to a computation over rank-1 indices.+--+ilift1 :: (Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1+ilift1 f = lift1 (\(Z:.i) -> Z :. f i)++-- |Lift a binary function to a computation over rank-1 indices.+--+ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1+ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j)+++-- Tuples+-- ------++-- |Extract the first component of a pair.+--+fst :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f a+fst e = let (x, _:: f b) = unlift e in x++-- |Extract the second component of a pair.+--+snd :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f b+snd e = let (_::f a, y) = unlift e in y++-- |Converts an uncurried function to a curried function.+--+curry :: Lift f (f a, f b) => (f (Plain (f a), Plain (f b)) -> f c) -> f a -> f b -> f c+curry f x y = f (lift (x, y))++-- |Converts a curried function to a function on pairs.+--+uncurry :: Unlift f (f a, f b) => (f a -> f b -> f c) -> f (Plain (f a), Plain (f b)) -> f c+uncurry f t = let (x, y) = unlift t in f x y+++-- Shapes and indices+-- ------------------++-- |The one index for a rank-0 array.+--+index0 :: Exp Z+index0 = lift Z++-- |Turn an 'Int' expression into a rank-1 indexing expression.+--+index1 :: Elt i => Exp i -> Exp (Z :. i)+index1 i = lift (Z :. i)++-- |Turn a rank-1 indexing expression into an 'Int' expression.+--+unindex1 :: Elt i => Exp (Z :. i) -> Exp i+unindex1 ix = let Z :. i = unlift ix in i++-- | Creates a rank-2 index from two Exp Int`s+--+index2 :: (Elt i, Slice (Z :. i))+       => Exp i+       -> Exp i+       -> Exp (Z :. i :. i)+index2 i j = lift (Z :. i :. j)++-- | Destructs a rank-2 index to an Exp tuple of two Int`s.+--+unindex2 :: forall i. (Elt i, Slice (Z :. i))+         => Exp (Z :. i :. i)+         -> Exp (i, i)+unindex2 ix+  = let Z :. i :. j = unlift ix :: Z :. Exp i :. Exp i+    in  lift (i, j)++-- Array operations with a scalar result+-- -------------------------------------++-- |Extraction of the element in a singleton array+--+the :: Elt e => Acc (Scalar e) -> Exp e+the = (!index0)++-- |Test whether an array is empty+--+null :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Bool+null arr = size arr ==* 0
Data/Array/Accelerate/Pretty.hs view
@@ -39,9 +39,22 @@ wide :: Style wide = style { lineLength = 150 } -instance Kit acc => Show (acc aenv a) where+-- Explicitly enumerate Show instances for the Accelerate array AST types. If we+-- instead use a generic instance of the form:+--+--   instance Kit acc => Show (acc aenv a) where+--+-- This matches any type of kind (* -> * -> *), which can cause problems+-- interacting with other packages. See Issue #108.+--+instance Show (OpenAcc aenv a) where   show c = renderStyle wide $ prettyAcc 0 noParens c +instance Show (DelayedOpenAcc aenv a) where+  show c = renderStyle wide $ prettyAcc 0 noParens c++-- These parameterised instances are fine because there is a concrete kind+-- instance Kit acc => Show (PreOpenAfun acc aenv f) where   show f = renderStyle wide $ prettyPreAfun prettyAcc 0 f
Data/Array/Accelerate/Pretty/HTML.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -20,12 +19,7 @@ ) where  -- standard libraries-#if !MIN_VERSION_base(4,6,0)-import Prelude                                                  hiding ( catch )-import System.IO.Error                                          hiding ( catch )-#else import System.IO.Error-#endif import Control.Exception import Data.String import Data.Monoid
Data/Array/Accelerate/Pretty/Print.hs view
@@ -52,137 +52,88 @@ prettyOpenAcc alvl wrap (OpenAcc acc) = prettyPreAcc prettyOpenAcc alvl wrap acc  prettyPreAcc-    :: forall acc aenv a.+    :: forall acc aenv arrs.        PrettyAcc acc-    -> Int-    -> (Doc -> Doc)-    -> PreOpenAcc acc aenv a+    -> Int                                      -- level of array variables+    -> (Doc -> Doc)                             -- apply to compound expressions+    -> PreOpenAcc acc aenv arrs     -> Doc-prettyPreAcc pp alvl wrap (Alet acc1 acc2)-  | not (isAlet acc1') && isAlet acc2'-  = wrap $ sep [ text "let" <+> a <+> equals <+> acc1' <+> text "in"-               , acc2' ]-  ---  | otherwise-  = wrap $ sep [ hang (text "let" <+> a <+> equals) 2 acc1'-               , text "in" <+> acc2' ]+prettyPreAcc prettyAcc alvl wrap = pp   where-    -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet-    ---    isAlet doc  = "let" `isPrefixOf` render doc+    ppE :: PreOpenExp acc env aenv e -> Doc+    ppE = prettyPreExp prettyAcc 0 alvl parens -    acc1'       = pp alvl     noParens acc1-    acc2'       = pp (alvl+1) noParens acc2-    a           = char 'a' <> int alvl+    ppF :: PreOpenFun acc env aenv f -> Doc+    ppF = parens . prettyPreFun prettyAcc alvl +    ppA :: acc aenv a -> Doc+    ppA = prettyAcc alvl parens -prettyPreAcc _  alvl _    (Avar idx)-  = text $ 'a' : show (alvl - idxToInt idx - 1)-prettyPreAcc pp alvl wrap (Aprj ix arrs)-  = wrap $ char '#' <> prettyTupleIdx ix <+> pp alvl parens arrs-prettyPreAcc pp alvl _    (Atuple tup)-  = prettyAtuple pp alvl tup-prettyPreAcc pp alvl wrap (Apply afun acc)-  = wrap $ sep [parens (prettyPreAfun pp alvl afun), pp alvl parens acc]-prettyPreAcc pp alvl wrap (Acond e acc1 acc2)-  = wrap $ prettyArrOp "cond" [prettyPreExp pp 0 alvl parens e, pp alvl parens acc1, pp alvl parens acc2]-prettyPreAcc _  _    wrap (Use arr)-  = wrap $ prettyArrOp "use" [prettyArrays (arrays (undefined::a)) arr]-prettyPreAcc pp alvl wrap (Unit e)-  = wrap $ prettyArrOp "unit" [prettyPreExp pp 0 alvl parens e]-prettyPreAcc pp alvl wrap (Generate sh f)-  = wrap-  $ prettyArrOp "generate" [prettyPreExp pp 0 alvl parens sh, parens (prettyPreFun pp alvl f)]-prettyPreAcc pp alvl wrap (Transform sh ix f acc)-  = wrap-  $ prettyArrOp "transform" [ prettyPreExp pp 0 alvl parens sh-                            , parens (prettyPreFun pp alvl ix)-                            , parens (prettyPreFun pp alvl f)-                            , pp alvl parens acc ]-prettyPreAcc pp alvl wrap (Reshape sh acc)-  = wrap $ prettyArrOp "reshape" [prettyPreExp pp 0 alvl parens sh, pp alvl parens acc]-prettyPreAcc pp alvl wrap (Replicate _ty ix acc)-  = wrap $ prettyArrOp "replicate" [prettyPreExp pp 0 alvl noParens ix, pp alvl parens acc]-prettyPreAcc pp alvl wrap (Slice _ty acc ix)-  = wrap $ sep [pp alvl parens acc, char '!', prettyPreExp pp 0 alvl noParens ix]-prettyPreAcc pp alvl wrap (Map f acc)-  = wrap $ prettyArrOp "map" [parens (prettyPreFun pp alvl f), pp alvl parens acc]-prettyPreAcc pp alvl wrap (ZipWith f acc1 acc2)-  = wrap-  $ prettyArrOp "zipWith"-      [parens (prettyPreFun pp alvl f), pp alvl parens acc1, pp alvl parens acc2]-prettyPreAcc pp alvl wrap (Fold f e acc)-  = wrap-  $ prettyArrOp "fold" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,-                        pp alvl parens acc]-prettyPreAcc pp alvl wrap (Fold1 f acc)-  = wrap $ prettyArrOp "fold1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]-prettyPreAcc pp alvl wrap (FoldSeg f e acc1 acc2)-  = wrap-  $ prettyArrOp "foldSeg" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,-                           pp alvl parens acc1, pp alvl parens acc2]-prettyPreAcc pp alvl wrap (Fold1Seg f acc1 acc2)-  = wrap-  $ prettyArrOp "fold1Seg" [parens (prettyPreFun pp alvl f), pp alvl parens acc1,-                            pp alvl parens acc2]-prettyPreAcc pp alvl wrap (Scanl f e acc)-  = wrap-  $ prettyArrOp "scanl" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,-                         pp alvl parens acc]-prettyPreAcc pp alvl wrap (Scanl' f e acc)-  = wrap-  $ prettyArrOp "scanl'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,-                          pp alvl parens acc]-prettyPreAcc pp alvl wrap (Scanl1 f acc)-  = wrap-  $ prettyArrOp "scanl1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]-prettyPreAcc pp alvl wrap (Scanr f e acc)-  = wrap-  $ prettyArrOp "scanr" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,-                         pp alvl parens acc]-prettyPreAcc pp alvl wrap (Scanr' f e acc)-  = wrap-  $ prettyArrOp "scanr'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,-                          pp alvl parens acc]-prettyPreAcc pp alvl wrap (Scanr1 f acc)-  = wrap-  $ prettyArrOp "scanr1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]-prettyPreAcc pp alvl wrap (Permute f dfts p acc)-  = wrap-  $ prettyArrOp "permute" [parens (prettyPreFun pp alvl f), pp alvl parens dfts,-                           parens (prettyPreFun pp alvl p), pp alvl parens acc]-prettyPreAcc pp alvl wrap (Backpermute sh p acc)-  = wrap-  $ prettyArrOp "backpermute" [prettyPreExp pp 0 alvl parens sh,-                               parens (prettyPreFun pp alvl p),-                               pp alvl parens acc]-prettyPreAcc pp alvl wrap (Stencil sten bndy acc)-  = wrap-  $ prettyArrOp "stencil" [parens (prettyPreFun pp alvl sten),-                           prettyBoundary acc bndy,-                           pp alvl parens acc]-prettyPreAcc pp alvl wrap (Stencil2 sten bndy1 acc1 bndy2 acc2)-  = wrap-  $ prettyArrOp "stencil2" [parens (prettyPreFun pp alvl sten),-                            prettyBoundary acc1 bndy1,-                            pp alvl parens acc1,-                            prettyBoundary acc2 bndy2,-                            pp alvl parens acc2]-prettyPreAcc pp alvl wrap (Aforeign ff afun acc)-  = wrap $ prettyArrOp "aforeign" [text (strForeign ff),-                                   parens (prettyPreAfun pp alvl afun),-                                   pp alvl parens acc]+    ppAF :: PreOpenAfun acc aenv f -> Doc+    ppAF = parens . prettyPreAfun prettyAcc alvl -prettyBoundary :: forall acc aenv dim e. Elt e-               => {-dummy-}acc aenv (Array dim e) -> Boundary (EltRepr e) -> Doc-prettyBoundary _ Clamp        = text "Clamp"-prettyBoundary _ Mirror       = text "Mirror"-prettyBoundary _ Wrap         = text "Wrap"-prettyBoundary _ (Constant e) = parens $ text "Constant" <+> text (show (toElt e :: e))+    ppB :: forall sh e. Elt e+        => {-dummy-} acc aenv (Array sh e)+        -> Boundary (EltRepr e)+        -> Doc+    ppB _ Clamp        = text "Clamp"+    ppB _ Mirror       = text "Mirror"+    ppB _ Wrap         = text "Wrap"+    ppB _ (Constant e) = parens $ text "Constant" <+> text (show (toElt e :: e)) -prettyArrOp :: String -> [Doc] -> Doc-prettyArrOp name docs = hang (text name) 2 $ sep docs+    -- pretty print a named array operation with its arguments+    name .$ docs = wrap $ hang (text name) 2 (sep docs) +    -- The main pretty-printer+    -- -----------------------+    --+    pp :: PreOpenAcc acc aenv arrs -> Doc+    pp (Alet acc1 acc2)+      | not (isAlet acc1') && isAlet acc2'+      = wrap $ vcat [ text "let" <+> a <+> equals <+> acc1' <+> text "in", acc2' ]+      | otherwise+      = wrap $ vcat [ hang (text "let" <+> a <+> equals) 2 acc1', text "in" <+> acc2' ]+      where+        -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet+        isAlet doc  = "let" `isPrefixOf` render doc+        acc1'       = prettyAcc alvl     noParens acc1+        acc2'       = prettyAcc (alvl+1) noParens acc2+        a           = char 'a' <> int alvl++    pp (Awhile p afun acc)      = "awhile" .$ [ppAF p, ppAF afun, ppA acc]+    pp (Atuple tup)             = prettyAtuple prettyAcc alvl tup+    pp (Avar idx)               = text $ 'a' : show (alvl - idxToInt idx - 1)+    pp (Aprj ix arrs)           = wrap $ char '#' <> prettyTupleIdx ix <+> ppA arrs+    pp (Apply afun acc)         = wrap $ sep [ ppAF afun, ppA acc ]+    pp (Acond e acc1 acc2)      = wrap $ sep [ ppE e, text "?|", tuple [ppA acc1, ppA acc2] ]+    pp (Slice _ty acc ix)       = wrap $ sep [ ppA acc, char '!', prettyPreExp prettyAcc 0 alvl noParens ix ]+    pp (Use arrs)               = "use"         .$ [ prettyArrays (arrays (undefined :: arrs)) arrs ]+    pp (Unit e)                 = "unit"        .$ [ ppE e ]+    pp (Generate sh f)          = "generate"    .$ [ ppE sh, ppF f ]+    pp (Transform sh ix f acc)  = "transform"   .$ [ ppE sh, ppF ix, ppF f, ppA acc ]+    pp (Reshape sh acc)         = "reshape"     .$ [ ppE sh, ppA acc ]+    pp (Replicate _ty ix acc)   = "replicate"   .$ [ prettyPreExp prettyAcc 0 alvl noParens ix, ppA acc ]+    pp (Map f acc)              = "map"         .$ [ ppF f, ppA acc ]+    pp (ZipWith f acc1 acc2)    = "zipWith"     .$ [ ppF f, ppA acc1, ppA acc2 ]+    pp (Fold f e acc)           = "fold"        .$ [ ppF f, ppE e, ppA acc ]+    pp (Fold1 f acc)            = "fold1"       .$ [ ppF f, ppA acc ]+    pp (FoldSeg f e acc1 acc2)  = "foldSeg"     .$ [ ppF f, ppE e, ppA acc1, ppA acc2 ]+    pp (Fold1Seg f acc1 acc2)   = "fold1Seg"    .$ [ ppF f, ppA acc1, ppA acc2 ]+    pp (Scanl f e acc)          = "scanl"       .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanl' f e acc)         = "scanl'"      .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanl1 f acc)           = "scanl1"      .$ [ ppF f, ppA acc ]+    pp (Scanr f e acc)          = "scanr"       .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanr' f e acc)         = "scanr'"      .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanr1 f acc)           = "scanr1"      .$ [ ppF f, ppA acc ]+    pp (Permute f dfts p acc)   = "permute"     .$ [ ppF f, ppA dfts, ppF p, ppA acc ]+    pp (Backpermute sh p acc)   = "backpermute" .$ [ ppE sh, ppF p, ppA acc ]+    pp (Aforeign ff _afun acc)  = "aforeign"    .$ [ text (strForeign ff), {- ppAf afun, -} ppA acc ]+    pp (Stencil sten bndy acc)  = "stencil"     .$ [ ppF sten, ppB acc bndy, ppA acc ]+    pp (Stencil2 sten bndy1 acc1 bndy2 acc2)+                                = "stencil2"    .$ [ ppF sten, ppB acc1 bndy1, ppA acc1,+                                                               ppB acc2 bndy2, ppA acc2 ]++ -- Pretty print a function over array computations. -- prettyAfun :: Int -> OpenAfun aenv t -> Doc@@ -225,93 +176,81 @@ prettyExp :: Int -> Int -> (Doc -> Doc) -> OpenExp env aenv t -> Doc prettyExp = prettyPreExp prettyOpenAcc -prettyPreExp :: forall acc t env aenv.-                PrettyAcc acc -> Int -> Int -> (Doc -> Doc) -> PreOpenExp acc env aenv t -> Doc-prettyPreExp pp lvl alvl wrap (Let e1 e2)-  | not (isLet e1) && isLet e2-  = wrap $ sep [ text "let" <+> x <+> equals <+> e1' <+> text "in"-               , e2' ]-  ---  | otherwise-  = wrap $ sep [ hang (text "let" <+> x <+> equals) 2 e1'-               , text "in" <+> e2' ]+prettyPreExp+    :: forall acc t env aenv.+       PrettyAcc acc+    -> Int                                      -- level of scalar variables+    -> Int                                      -- level of array variables+    -> (Doc -> Doc)                             -- apply to compound expressions+    -> PreOpenExp acc env aenv t+    -> Doc+prettyPreExp prettyAcc lvl alvl wrap = pp   where-    isLet (Let _ _)     = True-    isLet _             = False-    e1'                 = prettyPreExp pp lvl     alvl noParens e1-    e2'                 = prettyPreExp pp (lvl+1) alvl noParens e2-    x                   = char 'x' <> int lvl+    ppE, ppE' :: PreOpenExp acc env aenv e -> Doc+    ppE  = prettyPreExp prettyAcc lvl alvl parens+    ppE' = prettyPreExp prettyAcc lvl alvl noParens -prettyPreExp _pp lvl _ _ (Var idx)-  = text $ 'x' : show (lvl - idxToInt idx - 1)-prettyPreExp _pp _ _ _ (Const v)-  = text $ show (toElt v :: t)-prettyPreExp pp lvl alvl _ (Tuple tup)-  = prettyTuple pp lvl alvl tup-prettyPreExp pp lvl alvl wrap (Prj idx e)-  = wrap $ char '#' <> prettyTupleIdx idx <+> prettyPreExp pp lvl alvl parens e-prettyPreExp _pp _lvl _alvl _wrap IndexNil-  = char 'Z'-prettyPreExp pp lvl alvl wrap (IndexCons t h)-  = wrap $ prettyPreExp pp lvl alvl noParens t <+> text ":." <+> prettyPreExp pp lvl alvl noParens h-prettyPreExp pp lvl alvl wrap (IndexHead ix)-  = wrap $ text "indexHead" <+> prettyPreExp pp lvl alvl parens ix-prettyPreExp pp lvl alvl wrap (IndexTail ix)-  = wrap $ text "indexTail" <+> prettyPreExp pp lvl alvl parens ix-prettyPreExp _ _ _ wrap (IndexAny)-  = wrap $ text "indexAny"-prettyPreExp pp lvl alvl wrap (IndexSlice _ slix sh)-  = wrap $ text "indexSlice" <+> sep [ prettyPreExp pp lvl alvl parens slix-                                     , prettyPreExp pp lvl alvl parens sh ]-prettyPreExp pp lvl alvl wrap (IndexFull _ slix sl)-  = wrap $ text "indexFull" <+> sep [ prettyPreExp pp lvl alvl parens slix-                                    , prettyPreExp pp lvl alvl parens sl ]-prettyPreExp pp lvl alvl wrap (ToIndex sh ix)-  = wrap $ text "toIndex" <+> sep [ prettyPreExp pp lvl alvl parens sh-                                  , prettyPreExp pp lvl alvl parens ix ]-prettyPreExp pp lvl alvl wrap (FromIndex sh ix)-  = wrap $ text "fromIndex" <+> sep [ prettyPreExp pp lvl alvl parens sh-                                    , prettyPreExp pp lvl alvl parens ix ]-prettyPreExp pp lvl alvl wrap (Cond c t e)-  = wrap $ sep [ prettyPreExp pp lvl alvl parens c <+> char '?',-                 tuple [ prettyPreExp pp lvl alvl noParens t-                       , prettyPreExp pp lvl alvl noParens e ] ]-prettyPreExp pp lvl alvl wrap (Iterate i fun a)-  = wrap $ text "iterate" <>  brackets (prettyPreExp pp lvl alvl id i)-                          <+> sep [ wrap   (prettyPreExp pp lvl alvl parens a)-                                  , parens (prettyPreOpenFun pp lvl alvl (Lam (Body fun))) ]-prettyPreExp pp lvl alvl wrap (Foreign ff f e)-  = wrap $ text "foreign" <+> text (strForeign ff)-                          <+> prettyPreFun pp alvl f-                          <+> prettyPreExp pp lvl alvl parens e+    ppF :: PreOpenFun acc env aenv f -> Doc+    ppF = parens . prettyPreOpenFun prettyAcc lvl alvl -prettyPreExp _pp _ _ _ (PrimConst a)- = prettyConst a-prettyPreExp pp lvl alvl wrap (PrimApp p a)-  | infixOp, Tuple (NilTup `SnocTup` x `SnocTup` y) <- a-  = wrap $ prettyPreExp pp lvl alvl parens x <+> f <+> prettyPreExp pp lvl alvl parens y+    ppA :: acc aenv a -> Doc+    ppA = prettyAcc alvl parens -  | otherwise-  = wrap $ f' <+> prettyPreExp pp lvl alvl parens a-  where-    -- sometimes the infix function arguments are obstructed by. If so, add-    -- parentheses and print prefix.+    -- pretty print a named array operation with its arguments+    name .$ docs = wrap $ text name <+> sep docs++    -- The main pretty-printer+    -- -----------------------     ---    (infixOp, f) = prettyPrim p-    f'           = if infixOp then parens f else f+    pp :: PreOpenExp acc env aenv t -> Doc+    pp (Let e1 e2)+      | not (isLet e1) && isLet e2+      = wrap $ vcat [ text "let" <+> x <+> equals <+> e1' <+> text "in", e2' ]+      | otherwise+      = wrap $ vcat [ hang (text "let" <+> x <+> equals) 2 e1', text "in" <+> e2' ]+      where+        isLet (Let _ _)     = True+        isLet _             = False+        e1'                 = prettyPreExp prettyAcc lvl     alvl noParens e1+        e2'                 = prettyPreExp prettyAcc (lvl+1) alvl noParens e2+        x                   = char 'x' <> int lvl -prettyPreExp pp lvl alvl wrap (Index idx i)-  = wrap $ cat [pp alvl parens idx, char '!', prettyPreExp pp lvl alvl parens i]-prettyPreExp pp lvl alvl wrap (LinearIndex idx i)-  = wrap $ cat [pp alvl parens idx, text "!!", prettyPreExp pp lvl alvl parens i]-prettyPreExp pp _lvl alvl wrap (Shape idx)-  = wrap $ text "shape" <+> pp alvl parens idx-prettyPreExp pp lvl alvl wrap (ShapeSize idx)-  = wrap $ text "shapeSize" <+> parens (prettyPreExp pp lvl alvl parens idx)-prettyPreExp pp lvl alvl wrap (Intersect sh1 sh2)-  = wrap $ text "intersect" <+> sep [ prettyPreExp pp lvl alvl parens sh1-                                    , prettyPreExp pp lvl alvl parens sh2 ]+    pp (PrimApp p a)+      | infixOp, Tuple (NilTup `SnocTup` x `SnocTup` y) <- a+      = wrap $ ppE x <+> f <+> ppE y+      | otherwise+      = wrap $ f' <+> ppE a+      where+        -- sometimes the infix function arguments are obstructed. If so, add+        -- parentheses and print prefix.+        --+        (infixOp, f) = prettyPrim p+        f'           = if infixOp then parens f else f +    pp (PrimConst a)            = prettyConst a+    pp (Tuple tup)              = prettyTuple prettyAcc lvl alvl tup+    pp (Var idx)                = text $ 'x' : show (lvl - idxToInt idx - 1)+    pp (Const v)                = text $ show (toElt v :: t)+    pp (Prj idx e)              = wrap $ char '#' <> prettyTupleIdx idx <+> ppE e+    pp (Cond c t e)             = wrap $ sep [ ppE c, char '?' , tuple [ ppE' t, ppE' e ]]+    pp IndexNil                 = char 'Z'+    pp (IndexAny)               = text "indexAny"+    pp (IndexCons t h)          = wrap $ ppE' t <+> text ":." <+> ppE' h+    pp (IndexHead ix)           = "indexHead"  .$ [ ppE ix ]+    pp (IndexTail ix)           = "indexTail"  .$ [ ppE ix ]+    pp (IndexSlice _ slix sh)   = "indexSlice" .$ [ ppE slix, ppE sh ]+    pp (IndexFull _ slix sl)    = "indexFull"  .$ [ ppE slix, ppE sl ]+    pp (ToIndex sh ix)          = "toIndex"    .$ [ ppE sh, ppE ix ]+    pp (FromIndex sh ix)        = "fromIndex"  .$ [ ppE sh, ppE ix ]+    pp (While p f x)            = "while"      .$ [ ppF p, ppF f, ppE x ]+    pp (Foreign ff _f e)        = "foreign"    .$ [ text (strForeign ff), {- ppF f, -} ppE e ]+    pp (Shape idx)              = "shape"      .$ [ ppA idx ]+    pp (ShapeSize idx)          = "shapeSize"  .$ [ parens (ppE idx) ]+    pp (Intersect sh1 sh2)      = "intersect"  .$ [ ppE sh1, ppE sh2 ]+    pp (Index idx i)            = wrap $ cat [ ppA idx, char '!',  ppE i ]+    pp (LinearIndex idx i)      = wrap $ cat [ ppA idx, text "!!", ppE i ]++ -- Pretty print nested pairs as a proper tuple. -- prettyAtuple :: forall acc aenv t.@@ -454,7 +393,7 @@   case ds of     []  -> left <> right     [d] -> left <> d <> right-    _   -> left <> sep (punctuate p ds) <> right+    _   -> cat (zipWith (<>) (left : repeat p) ds) <> right   -- Auxiliary ops
Data/Array/Accelerate/Pretty/Traverse.hs view
@@ -43,6 +43,7 @@     travAcc' (Apply afun acc)                      = combine "Apply" [travAfun f c l afun, travAcc f c l acc]     travAcc' (Aforeign ff afun acc)                = combine ("Aforeign " ++ strForeign ff) [travAfun f c l afun, travAcc f c l acc]     travAcc' (Acond e acc1 acc2)                   = combine "Acond" [travExp f c l e, travAcc f c l acc1, travAcc f c l acc2]+    travAcc' (Awhile cond body acc)                = combine "Awhile" [travAfun f c l cond, travAfun f c l body, travAcc f c l acc]     travAcc' (Atuple tup)                          = combine "Atuple" [ travAtuple f c l tup ]     travAcc' (Aprj idx a)                          = combine ("Aprj " `cat` tupleIdxToInt idx) [ travAcc f c l a ]     travAcc' (Use arr)                             = combine "Use" [ travArrays f c l (arrays (undefined::a)) arr ]@@ -99,7 +100,7 @@     travExp' (ToIndex sh ix)            = combine "ToIndex" [ travExp f c l sh, travExp f c l ix ]     travExp' (FromIndex sh ix)          = combine "FromIndex" [ travExp f c l sh, travExp f c l ix ]     travExp' (Cond cond thn els)        = combine "Cond" [travExp f c l cond, travExp f c l thn, travExp f c l els]-    travExp' (Iterate _ fun x)          = combine "Iterate" [ travFun f c l (Lam (Body fun)), travExp f c l x ]+    travExp' (While cond body x)        = combine "While" [ travFun f c l cond, travFun f c l body, travExp f c l x ]     travExp' (PrimConst a)              = leaf ("PrimConst " `cat` labelForConst a)     travExp' (PrimApp p a)              = combine "PrimApp" [ l (primFunFormat f) (labelForPrimFun p), travExp f c l a ]     travExp' (Index idx i)              = combine "Index" [ travAcc f c l idx, travExp f c l i]
Data/Array/Accelerate/Smart.hs view
@@ -99,168 +99,174 @@ -- data PreAcc acc exp as where     -- Needed for conversion to de Bruijn form-  Atag        :: Arrays as-              => Level                      -- environment size at defining occurrence-              -> PreAcc acc exp as+  Atag          :: Arrays as+                => Level                        -- environment size at defining occurrence+                -> PreAcc acc exp as -  Pipe        :: (Arrays as, Arrays bs, Arrays cs)-              => (Acc as -> Acc bs)         -- see comment above on why 'Acc' and not 'acc'-              -> (Acc bs -> Acc cs)-              -> acc as-              -> PreAcc acc exp cs+  Pipe          :: (Arrays as, Arrays bs, Arrays cs)+                => (Acc as -> Acc bs)           -- see comment above on why 'Acc' and not 'acc'+                -> (Acc bs -> Acc cs)+                -> acc as+                -> PreAcc acc exp cs -  Aforeign    :: (Arrays arrs, Arrays a, Foreign f)-              => f arrs a-              -> (Acc arrs -> Acc a)-              -> acc arrs-              -> PreAcc acc exp a+  Aforeign      :: (Arrays arrs, Arrays a, Foreign f)+                => f arrs a+                -> (Acc arrs -> Acc a)+                -> acc arrs+                -> PreAcc acc exp a -  Acond       :: (Arrays as)-              => exp Bool-              -> acc as-              -> acc as-              -> PreAcc acc exp as+  Acond         :: Arrays as+                => exp Bool+                -> acc as+                -> acc as+                -> PreAcc acc exp as -  Atuple      :: (Arrays arrs, IsTuple arrs)-              => Tuple.Atuple acc (TupleRepr arrs)-              -> PreAcc acc exp arrs+  Awhile        :: Arrays arrs+                => (Acc arrs -> acc (Scalar Bool))+                -> (Acc arrs -> acc arrs)+                -> acc arrs+                -> PreAcc acc exp arrs -  Aprj        :: (Arrays arrs, IsTuple arrs, Arrays a)-              => TupleIdx (TupleRepr arrs) a-              ->        acc     arrs-              -> PreAcc acc exp a+  Atuple        :: (Arrays arrs, IsTuple arrs)+                => Tuple.Atuple acc (TupleRepr arrs)+                -> PreAcc acc exp arrs -  Use         :: Arrays arrs-              => arrs-              -> PreAcc acc exp arrs+  Aprj          :: (Arrays arrs, IsTuple arrs, Arrays a)+                => TupleIdx (TupleRepr arrs) a+                ->        acc     arrs+                -> PreAcc acc exp a -  Unit        :: Elt e-              => exp e-              -> PreAcc acc exp (Scalar e)+  Use           :: Arrays arrs+                => arrs+                -> PreAcc acc exp arrs -  Generate    :: (Shape sh, Elt e)-              => exp sh-              -> (Exp sh -> exp e)-              -> PreAcc acc exp (Array sh e)+  Unit          :: Elt e+                => exp e+                -> PreAcc acc exp (Scalar e) -  Reshape     :: (Shape sh, Shape sh', Elt e)-              => exp sh-              -> acc (Array sh' e)-              -> PreAcc acc exp (Array sh e)+  Generate      :: (Shape sh, Elt e)+                => exp sh+                -> (Exp sh -> exp e)+                -> PreAcc acc exp (Array sh e) -  Replicate   :: (Slice slix, Elt e,-                  Typeable (SliceShape slix), Typeable (FullShape slix))-                  -- the Typeable constraints shouldn't be necessary as they are implied by-                  -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that-              => exp slix-              -> acc            (Array (SliceShape slix) e)-              -> PreAcc acc exp (Array (FullShape  slix) e)+  Reshape       :: (Shape sh, Shape sh', Elt e)+                => exp sh+                -> acc (Array sh' e)+                -> PreAcc acc exp (Array sh e) -  Slice       :: (Slice slix, Elt e,-                  Typeable (SliceShape slix), Typeable (FullShape slix))-                  -- the Typeable constraints shouldn't be necessary as they are implied by-                  -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that-              => acc            (Array (FullShape  slix) e)-              -> exp slix-              -> PreAcc acc exp (Array (SliceShape slix) e)+  Replicate     :: (Slice slix, Elt e,+                    Typeable (SliceShape slix), Typeable (FullShape slix))+                    -- the Typeable constraints shouldn't be necessary as they are implied by+                    -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that+                => exp slix+                -> acc            (Array (SliceShape slix) e)+                -> PreAcc acc exp (Array (FullShape  slix) e) -  Map         :: (Shape sh, Elt e, Elt e')-              => (Exp e -> exp e')-              -> acc (Array sh e)-              -> PreAcc acc exp (Array sh e')+  Slice         :: (Slice slix, Elt e,+                    Typeable (SliceShape slix), Typeable (FullShape slix))+                    -- the Typeable constraints shouldn't be necessary as they are implied by+                    -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that+                => acc            (Array (FullShape  slix) e)+                -> exp slix+                -> PreAcc acc exp (Array (SliceShape slix) e) -  ZipWith     :: (Shape sh, Elt e1, Elt e2, Elt e3)-              => (Exp e1 -> Exp e2 -> exp e3)-              -> acc (Array sh e1)-              -> acc (Array sh e2)-              -> PreAcc acc exp (Array sh e3)+  Map           :: (Shape sh, Elt e, Elt e')+                => (Exp e -> exp e')+                -> acc (Array sh e)+                -> PreAcc acc exp (Array sh e') -  Fold        :: (Shape sh, Elt e)-              => (Exp e -> Exp e -> exp e)-              -> exp e-              -> acc (Array (sh:.Int) e)-              -> PreAcc acc exp (Array sh e)+  ZipWith       :: (Shape sh, Elt e1, Elt e2, Elt e3)+                => (Exp e1 -> Exp e2 -> exp e3)+                -> acc (Array sh e1)+                -> acc (Array sh e2)+                -> PreAcc acc exp (Array sh e3) -  Fold1       :: (Shape sh, Elt e)-              => (Exp e -> Exp e -> exp e)-              -> acc (Array (sh:.Int) e)-              -> PreAcc acc exp (Array sh e)+  Fold          :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh:.Int) e)+                -> PreAcc acc exp (Array sh e) -  FoldSeg     :: (Shape sh, Elt e, Elt i, IsIntegral i)-              => (Exp e -> Exp e -> exp e)-              -> exp e-              -> acc (Array (sh:.Int) e)-              -> acc (Segments i)-              -> PreAcc acc exp (Array (sh:.Int) e)+  Fold1         :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array (sh:.Int) e)+                -> PreAcc acc exp (Array sh e) -  Fold1Seg    :: (Shape sh, Elt e, Elt i, IsIntegral i)-              => (Exp e -> Exp e -> exp e)-              -> acc (Array (sh:.Int) e)-              -> acc (Segments i)-              -> PreAcc acc exp (Array (sh:.Int) e)+  FoldSeg       :: (Shape sh, Elt e, Elt i, IsIntegral i)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh:.Int) e)+                -> acc (Segments i)+                -> PreAcc acc exp (Array (sh:.Int) e) -  Scanl       :: Elt e-              => (Exp e -> Exp e -> exp e)-              -> exp e-              -> acc (Vector e)-              -> PreAcc acc exp (Vector e)+  Fold1Seg      :: (Shape sh, Elt e, Elt i, IsIntegral i)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array (sh:.Int) e)+                -> acc (Segments i)+                -> PreAcc acc exp (Array (sh:.Int) e) -  Scanl'      :: Elt e-              => (Exp e -> Exp e -> exp e)-              -> exp e-              -> acc (Vector e)-              -> PreAcc acc exp (Vector e, Scalar e)+  Scanl         :: Elt e+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Vector e)+                -> PreAcc acc exp (Vector e) -  Scanl1      :: Elt e-              => (Exp e -> Exp e -> exp e)-              -> acc (Vector e)-              -> PreAcc acc exp (Vector e)+  Scanl'        :: Elt e+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Vector e)+                -> PreAcc acc exp (Vector e, Scalar e) -  Scanr       :: Elt e-              => (Exp e -> Exp e -> exp e)-              -> exp e-              -> acc (Vector e)-              -> PreAcc acc exp (Vector e)+  Scanl1        :: Elt e+                => (Exp e -> Exp e -> exp e)+                -> acc (Vector e)+                -> PreAcc acc exp (Vector e) -  Scanr'      :: Elt e-              => (Exp e -> Exp e -> exp e)-              -> exp e-              -> acc (Vector e)-              -> PreAcc acc exp (Vector e, Scalar e)+  Scanr         :: Elt e+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Vector e)+                -> PreAcc acc exp (Vector e) -  Scanr1      :: Elt e-              => (Exp e -> Exp e -> exp e)-              -> acc (Vector e)-              -> PreAcc acc exp (Vector e)+  Scanr'        :: Elt e+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Vector e)+                -> PreAcc acc exp (Vector e, Scalar e) -  Permute     :: (Shape sh, Shape sh', Elt e)-              => (Exp e -> Exp e -> exp e)-              -> acc (Array sh' e)-              -> (Exp sh -> exp sh')-              -> acc (Array sh e)-              -> PreAcc acc exp (Array sh' e)+  Scanr1        :: Elt e+                => (Exp e -> Exp e -> exp e)+                -> acc (Vector e)+                -> PreAcc acc exp (Vector e) -  Backpermute :: (Shape sh, Shape sh', Elt e)-              => exp sh'-              -> (Exp sh' -> exp sh)-              -> acc (Array sh e)-              -> PreAcc acc exp (Array sh' e)+  Permute       :: (Shape sh, Shape sh', Elt e)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array sh' e)+                -> (Exp sh -> exp sh')+                -> acc (Array sh e)+                -> PreAcc acc exp (Array sh' e) -  Stencil     :: (Shape sh, Elt a, Elt b, Stencil sh a stencil)-              => (stencil -> exp b)-              -> Boundary a-              -> acc (Array sh a)-              -> PreAcc acc exp (Array sh b)+  Backpermute   :: (Shape sh, Shape sh', Elt e)+                => exp sh'+                -> (Exp sh' -> exp sh)+                -> acc (Array sh e)+                -> PreAcc acc exp (Array sh' e) -  Stencil2    :: (Shape sh, Elt a, Elt b, Elt c,-                 Stencil sh a stencil1, Stencil sh b stencil2)-              => (stencil1 -> stencil2 -> exp c)-              -> Boundary a-              -> acc (Array sh a)-              -> Boundary b-              -> acc (Array sh b)-              -> PreAcc acc exp (Array sh c)+  Stencil       :: (Shape sh, Elt a, Elt b, Stencil sh a stencil)+                => (stencil -> exp b)+                -> Boundary a+                -> acc (Array sh a)+                -> PreAcc acc exp (Array sh b) +  Stencil2      :: (Shape sh, Elt a, Elt b, Elt c,+                   Stencil sh a stencil1, Stencil sh b stencil2)+                => (stencil1 -> stencil2 -> exp c)+                -> Boundary a+                -> acc (Array sh a)+                -> Boundary b+                -> acc (Array sh b)+                -> PreAcc acc exp (Array sh c)+ -- |Array-valued collective computations -- newtype Acc a = Acc (PreAcc Acc Exp a)@@ -282,51 +288,102 @@ -- data PreExp acc exp t where     -- Needed for conversion to de Bruijn form-  Tag         :: Elt t-              => Level                          -> PreExp acc exp t-                 -- environment size at defining occurrence+  Tag           :: Elt t+                => Level                        -- environment size at defining occurrence+                -> PreExp acc exp t    -- All the same constructors as 'AST.Exp'-  Const       :: Elt t-              => t                              -> PreExp acc exp t+  Const         :: Elt t+                => t+                -> PreExp acc exp t -  Tuple       :: (Elt t, IsTuple t)-              => Tuple.Tuple exp (TupleRepr t)  -> PreExp acc exp t-  Prj         :: (Elt t, IsTuple t, Elt e)-              => TupleIdx (TupleRepr t) e-              -> exp t                          -> PreExp acc exp e-  IndexNil    ::                                   PreExp acc exp Z-  IndexCons   :: (Slice sl, Elt a)-              => exp sl -> exp a                -> PreExp acc exp (sl:.a)-  IndexHead   :: (Slice sl, Elt a)-              => exp (sl:.a)                    -> PreExp acc exp a-  IndexTail   :: (Slice sl, Elt a)-              => exp (sl:.a)                    -> PreExp acc exp sl-  IndexAny    :: Shape sh-              =>                                   PreExp acc exp (Any sh)-  ToIndex     :: Shape sh-              => exp sh -> exp sh               -> PreExp acc exp Int-  FromIndex   :: Shape sh-              => exp sh -> exp Int              -> PreExp acc exp sh-  Cond        :: Elt t-              => exp Bool -> exp t -> exp t     -> PreExp acc exp t-  PrimConst   :: Elt t-              => PrimConst t                    -> PreExp acc exp t-  PrimApp     :: (Elt a, Elt r)-              => PrimFun (a -> r) -> exp a      -> PreExp acc exp r-  Index       :: (Shape sh, Elt t)-              => acc (Array sh t) -> exp sh     -> PreExp acc exp t-  LinearIndex :: (Shape sh, Elt t)-              => acc (Array sh t) -> exp Int    -> PreExp acc exp t-  Shape       :: (Shape sh, Elt e)-              => acc (Array sh e)               -> PreExp acc exp sh-  ShapeSize   :: Shape sh-              => exp sh                         -> PreExp acc exp Int-  Foreign     :: (Elt x, Elt y, Foreign f)-              => f x y-              -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery.-              -> exp x                          -> PreExp acc exp y+  Tuple         :: (Elt t, IsTuple t)+                => Tuple.Tuple exp (TupleRepr t)+                -> PreExp acc exp t +  Prj           :: (Elt t, IsTuple t, Elt e)+                => TupleIdx (TupleRepr t) e+                -> exp t+                -> PreExp acc exp e++  IndexNil      :: PreExp acc exp Z++  IndexCons     :: (Slice sl, Elt a)+                => exp sl+                -> exp a+                -> PreExp acc exp (sl:.a)++  IndexHead     :: (Slice sl, Elt a)+                => exp (sl:.a)+                -> PreExp acc exp a++  IndexTail     :: (Slice sl, Elt a)+                => exp (sl:.a)+                -> PreExp acc exp sl++  IndexAny      :: Shape sh+                => PreExp acc exp (Any sh)++  ToIndex       :: Shape sh+                => exp sh+                -> exp sh+                -> PreExp acc exp Int++  FromIndex     :: Shape sh+                => exp sh+                -> exp Int+                -> PreExp acc exp sh++  Cond          :: Elt t+                => exp Bool+                -> exp t+                -> exp t+                -> PreExp acc exp t++  While         :: Elt t+                => (Exp t -> exp Bool)+                -> (Exp t -> exp t)+                -> exp t+                -> PreExp acc exp t++  PrimConst     :: Elt t+                => PrimConst t+                -> PreExp acc exp t++  PrimApp       :: (Elt a, Elt r)+                => PrimFun (a -> r)+                -> exp a+                -> PreExp acc exp r++  Index         :: (Shape sh, Elt t)+                => acc (Array sh t)+                -> exp sh+                -> PreExp acc exp t++  LinearIndex   :: (Shape sh, Elt t)+                => acc (Array sh t)+                -> exp Int+                -> PreExp acc exp t++  Shape         :: (Shape sh, Elt e)+                => acc (Array sh e)+                -> PreExp acc exp sh++  ShapeSize     :: Shape sh+                => exp sh+                -> PreExp acc exp Int++  Intersect     :: Shape sh+                => exp sh+                -> exp sh+                -> PreExp acc exp sh++  Foreign       :: (Elt x, Elt y, Foreign f)+                => f x y+                -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery.+                -> exp x+                -> PreExp acc exp y+ -- | Scalar expressions for plain array computations. -- newtype Exp t = Exp (PreExp Acc Exp t)@@ -988,6 +1045,7 @@ showPreAccOp (Use a)            = "Use "  ++ showArrays a showPreAccOp Pipe{}             = "Pipe" showPreAccOp Acond{}            = "Acond"+showPreAccOp Awhile{}           = "Awhile" showPreAccOp Atuple{}           = "Atuple" showPreAccOp Aprj{}             = "Aprj" showPreAccOp Unit{}             = "Unit"@@ -1036,7 +1094,7 @@  showPreExpOp :: PreExp acc exp t -> String showPreExpOp (Const c)          = "Const " ++ show c-showPreExpOp Tag{}              = "Tag"+showPreExpOp (Tag i)            = "Tag" ++ show i showPreExpOp Tuple{}            = "Tuple" showPreExpOp Prj{}              = "Prj" showPreExpOp IndexNil           = "IndexNil"@@ -1047,11 +1105,13 @@ showPreExpOp ToIndex{}          = "ToIndex" showPreExpOp FromIndex{}        = "FromIndex" showPreExpOp Cond{}             = "Cond"+showPreExpOp While{}            = "While" showPreExpOp PrimConst{}        = "PrimConst" showPreExpOp PrimApp{}          = "PrimApp" showPreExpOp Index{}            = "Index" showPreExpOp LinearIndex{}      = "LinearIndex" showPreExpOp Shape{}            = "Shape" showPreExpOp ShapeSize{}        = "ShapeSize"+showPreExpOp Intersect{}        = "Intersect" showPreExpOp Foreign{}          = "Foreign"
Data/Array/Accelerate/Trafo.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP                  #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE RecordWildCards      #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-}@@ -84,7 +85,11 @@   , convertOffsetOfSegment = False   } +when :: (a -> a) -> Bool -> a -> a+when f True  = f+when _ False = id + -- HOAS -> de Bruijn conversion -- ---------------------------- @@ -95,14 +100,11 @@ convertAcc = convertAccWith phases  convertAccWith :: Arrays arrs => Phase -> Acc arrs -> DelayedAcc arrs-convertAccWith ok acc-  = Fusion.convertAcc    -- `when` enableAccFusion+convertAccWith Phase{..} acc+  = Fusion.convertAcc enableAccFusion   $ Rewrite.convertSegments `when` convertOffsetOfSegment-  $ Sharing.convertAcc (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc-  where-    when f phase-      | phase ok        = f-      | otherwise       = id+  $ Sharing.convertAcc recoverAccSharing recoverExpSharing floatOutAccFromExp+  $ acc   -- | Convert a unary function over array computations, incorporating sharing@@ -112,14 +114,11 @@ convertAfun = convertAfunWith phases  convertAfunWith :: Afunction f => Phase -> f -> DelayedAfun (AfunctionR f)-convertAfunWith ok acc-  = Fusion.convertAfun       -- `when` enableAccFusion+convertAfunWith Phase{..} acc+  = Fusion.convertAfun enableAccFusion   $ Rewrite.convertSegmentsAfun `when` convertOffsetOfSegment-  $ Sharing.convertAfun (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc-  where-    when f phase-      | phase ok        = f-      | otherwise       = id+  $ Sharing.convertAfun recoverAccSharing recoverExpSharing floatOutAccFromExp+  $ acc   -- | Convert a closed scalar expression, incorporating sharing observation and
Data/Array/Accelerate/Trafo/Fusion.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE IncoherentInstances  #-} {-# LANGUAGE PatternGuards        #-} {-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE RecordWildCards      #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeOperators        #-} {-# LANGUAGE UndecidableInstances #-}@@ -67,13 +66,13 @@  -- | Apply the fusion transformation to a closed de Bruijn AST ---convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs-convertAcc = withSimplStats . quenchAcc . annealAcc+convertAcc :: Arrays arrs => Bool -> Acc arrs -> DelayedAcc arrs+convertAcc fuseAcc = withSimplStats . convertOpenAcc fuseAcc  -- | Apply the fusion transformation to a function of array arguments ---convertAfun :: Afun f -> DelayedAfun f-convertAfun = withSimplStats . quenchAfun . annealAfun+convertAfun :: Bool -> Afun f -> DelayedAfun f+convertAfun fuseAcc = withSimplStats . convertOpenAfun fuseAcc  withSimplStats :: a -> a #ifdef ACCELERATE_DEBUG@@ -83,58 +82,60 @@ #endif  --- | An optional second phase of the fusion transformation that makes the--- representation of fused consumer/producer terms explicit. Note that quenching--- happens after annealing.+-- | Apply the fusion transformation to an AST. This consists of two phases: ----- TODO: integrate this with the first phase?+--    1. A bottom-up traversal that converts nodes into the internal delayed+--       representation, merging adjacent producer/producer pairs. ---quenchAcc :: Arrays arrs => OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs-quenchAcc = cvtA+--    2. A top-down traversal that makes the representation of fused+--       consumer/producer pairs explicit as a 'DelayedAcc' of manifest and+--       delayed nodes.+--+-- TLM: Note that there really is no ambiguity as to which state an array will+--      be in following this process: an array will be either delayed or+--      manifest, and the two helper functions are even named as such! We should+--      encode this property in the type somehow...+--+convertOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs+convertOpenAcc fuseAcc = manifest . computeAcc . embedOpenAcc fuseAcc   where     -- Convert array computations into an embeddable delayed representation.-    -- This is essentially the reverse of 'compute'.+    -- Reapply the embedding function from the first pass and unpack the+    -- representation. It is safe to match on BaseEnv because the first pass+    -- will put producers adjacent to the term consuming it.     ---    embed :: (Shape sh, Elt e) => OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e)-    embed (OpenAcc pacc) =-      case pacc of-        Avar v-          -> Delayed (arrayShape v) (indexArray v) (linearIndex v)--        Generate (cvtE -> sh) (cvtF -> f)-          -> Delayed sh f (f `compose` fromIndex sh)--        Map (cvtF -> f) (embed -> Delayed{..})-          -> Delayed extentD (f `compose` indexD) (f `compose` linearIndexD)--        Backpermute (cvtE -> sh) (cvtF -> p) (embed -> Delayed{..})-          -> let p' = indexD `compose` p-             in  Delayed sh p'(p' `compose` fromIndex sh)--        Transform (cvtE -> sh) (cvtF -> p) (cvtF -> f) (embed -> Delayed{..})-          -> let f' = f `compose` indexD `compose` p-             in  Delayed sh f' (f' `compose` fromIndex sh)--        _ -> INTERNAL_ERROR(error) "quench" "tried to consume a non-embeddable term"+    delayed :: (Shape sh, Elt e) => OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e)+    delayed (embedOpenAcc fuseAcc -> Embed BaseEnv cc) =+      case cc of+        Done v                                -> Delayed (arrayShape v) (indexArray v) (linearIndex v)+        Yield (cvtE -> sh) (cvtF -> f)        -> Delayed sh f (f `compose` fromIndex sh)+        Step  (cvtE -> sh) (cvtF -> p) (cvtF -> f) v+          | Just REFL <- match sh (arrayShape v)+          , Just REFL <- isIdentity p+          -> Delayed sh (f `compose` indexArray v) (f `compose` linearIndex v) -    fusionError = INTERNAL_ERROR(error) "quench" "unexpected fusible materials"+          | f'        <- f `compose` indexArray v `compose` p+          -> Delayed sh f' (f' `compose` fromIndex sh)      -- Convert array programs as manifest terms.     ---    cvtA :: OpenAcc aenv a -> DelayedOpenAcc aenv a-    cvtA (OpenAcc pacc) = Manifest $-      case pacc of+    manifest :: OpenAcc aenv a -> DelayedOpenAcc aenv a+    manifest (OpenAcc pacc) =+      let fusionError = INTERNAL_ERROR(error) "manifest" "unexpected fusible materials"+      in+      Manifest $ case pacc of         -- Non-fusible terms         -- -----------------         Avar ix                 -> Avar ix         Use arr                 -> Use arr         Unit e                  -> Unit (cvtE e)-        Alet bnd body           -> Alet (cvtA bnd) (cvtA body)-        Acond p t e             -> Acond (cvtE p) (cvtA t) (cvtA e)+        Alet bnd body           -> alet (manifest bnd) (manifest body)+        Acond p t e             -> Acond (cvtE p) (manifest t) (manifest e)+        Awhile p f a            -> Awhile (cvtAF p) (cvtAF f) (manifest a)         Atuple tup              -> Atuple (cvtAT tup)-        Aprj ix tup             -> Aprj ix (cvtA tup)-        Apply f a               -> Apply (cvtAF f) (cvtA a)-        Aforeign ff f a         -> Aforeign ff (cvtAF f) (cvtA a)+        Aprj ix tup             -> Aprj ix (manifest tup)+        Apply f a               -> Apply (cvtAF f) (manifest a)+        Aforeign ff f a         -> Aforeign ff (cvtAF f) (manifest a)          -- Producers         -- ---------@@ -144,12 +145,12 @@         -- result of a let-binding to be used multiple times. The input array         -- here should be an array variable, else something went wrong.         ---        Map f a                 -> Map (cvtF f) (embed a)+        Map f a                 -> Map (cvtF f) (delayed a)         Generate sh f           -> Generate (cvtE sh) (cvtF f)-        Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (embed a)-        Backpermute sh p a      -> backpermute (cvtE sh) (cvtF p) (embed a) a+        Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (delayed a)+        Backpermute sh p a      -> Backpermute (cvtE sh) (cvtF p) (delayed a)+        Reshape sl a            -> Reshape (cvtE sl) (manifest a) -        Reshape{}               -> fusionError         Replicate{}             -> fusionError         Slice{}                 -> fusionError         ZipWith{}               -> fusionError@@ -162,42 +163,38 @@         -- argument array multiple times, we are careful not to duplicate work         -- and instead force the argument to be a manifest array.         ---        Fold f z a              -> Fold     (cvtF f) (cvtE z) (embed a)-        Fold1 f a               -> Fold1    (cvtF f) (embed a)-        FoldSeg f z a s         -> FoldSeg  (cvtF f) (cvtE z) (embed a) (embed s)-        Fold1Seg f a s          -> Fold1Seg (cvtF f) (embed a) (embed s)-        Scanl f z a             -> Scanl    (cvtF f) (cvtE z) (embed a)-        Scanl1 f a              -> Scanl1   (cvtF f) (embed a)-        Scanl' f z a            -> Scanl'   (cvtF f) (cvtE z) (embed a)-        Scanr f z a             -> Scanr    (cvtF f) (cvtE z) (embed a)-        Scanr1 f a              -> Scanr1   (cvtF f) (embed a)-        Scanr' f z a            -> Scanr'   (cvtF f) (cvtE z) (embed a)-        Permute f d p a         -> Permute  (cvtF f) (cvtA d) (cvtF p) (embed a)-        Stencil f x a           -> Stencil  (cvtF f) x (cvtA a)-        Stencil2 f x a y b      -> Stencil2 (cvtF f) x (cvtA a) y (cvtA b)+        Fold f z a              -> Fold     (cvtF f) (cvtE z) (delayed a)+        Fold1 f a               -> Fold1    (cvtF f) (delayed a)+        FoldSeg f z a s         -> FoldSeg  (cvtF f) (cvtE z) (delayed a) (delayed s)+        Fold1Seg f a s          -> Fold1Seg (cvtF f) (delayed a) (delayed s)+        Scanl f z a             -> Scanl    (cvtF f) (cvtE z) (delayed a)+        Scanl1 f a              -> Scanl1   (cvtF f) (delayed a)+        Scanl' f z a            -> Scanl'   (cvtF f) (cvtE z) (delayed a)+        Scanr f z a             -> Scanr    (cvtF f) (cvtE z) (delayed a)+        Scanr1 f a              -> Scanr1   (cvtF f) (delayed a)+        Scanr' f z a            -> Scanr'   (cvtF f) (cvtE z) (delayed a)+        Permute f d p a         -> Permute  (cvtF f) (manifest d) (cvtF p) (delayed a)+        Stencil f x a           -> Stencil  (cvtF f) x (manifest a)+        Stencil2 f x a y b      -> Stencil2 (cvtF f) x (manifest a) y (manifest b) -    -- A backwards permutation at this stage might be further simplified as a-    -- reshape operation, which can be executed in constant time without-    -- actually executing any array operations.-    ---    -- This requires that the argument of reshape be a manifest array, which is-    -- an exception to the rule of having all array inputs in delayed form.+    -- Flatten needless let-binds, which can be introduced by the conversion to+    -- the internal embeddable representation.     ---    backpermute sh p a x-      | OpenAcc (Avar v)        <- x-      , Just REFL               <- match p (simplify $ reindex (arrayShape v) sh)-      = Reshape sh (Manifest (Avar v))+    alet bnd body+      | Manifest (Avar ZeroIdx) <- body+      , Manifest x              <- bnd+      = x        | otherwise-      = Backpermute sh p a+      = Alet bnd body      cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a     cvtAT NilAtup        = NilAtup-    cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` cvtA a+    cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest a      cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f     cvtAF (Alam f)  = Alam  (cvtAF f)-    cvtAF (Abody b) = Abody (cvtA b)+    cvtAF (Abody b) = Abody (manifest b)      -- Conversions for closed scalar functions and expressions     --@@ -223,12 +220,12 @@         ToIndex sh ix           -> ToIndex (cvtE sh) (cvtE ix)         FromIndex sh ix         -> FromIndex (cvtE sh) (cvtE ix)         Cond p t e              -> Cond (cvtE p) (cvtE t) (cvtE e)-        Iterate n f x           -> Iterate (cvtE n) (cvtE f) (cvtE x)+        While p f x             -> While (cvtF p) (cvtF f) (cvtE x)         PrimConst c             -> PrimConst c         PrimApp f x             -> PrimApp f (cvtE x)-        Index a sh              -> Index (cvtA a) (cvtE sh)-        LinearIndex a i         -> LinearIndex (cvtA a) (cvtE i)-        Shape a                 -> Shape (cvtA a)+        Index a sh              -> Index (manifest a) (cvtE sh)+        LinearIndex a i         -> LinearIndex (manifest a) (cvtE i)+        Shape a                 -> Shape (manifest a)         ShapeSize sh            -> ShapeSize (cvtE sh)         Intersect s t           -> Intersect (cvtE s) (cvtE t)         Foreign ff f e          -> Foreign ff (cvtF f) (cvtE e)@@ -238,63 +235,61 @@     cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e  -quenchAfun :: OpenAfun aenv f -> DelayedOpenAfun aenv f-quenchAfun (Alam  f) = Alam  (quenchAfun f)-quenchAfun (Abody b) = Abody (quenchAcc b)+convertOpenAfun :: Bool -> OpenAfun aenv f -> DelayedOpenAfun aenv f+convertOpenAfun c (Alam  f) = Alam  (convertOpenAfun c f)+convertOpenAfun c (Abody b) = Abody (convertOpenAcc  c b)   -- | Apply the fusion transformation to the AST to combine and simplify terms.--- This combines producer/producer terms and makes consumer/producer nodes--- adjacent.+-- This converts terms into the internal delayed array representation and merges+-- adjacent producer/producer terms. Using the reduced internal form limits the+-- number of combinations that need to be considered. ---annealAcc :: Arrays arrs => OpenAcc aenv arrs -> OpenAcc aenv arrs-annealAcc = computeAcc . delayAcc-  where-    delayAcc :: Arrays a => OpenAcc aenv a -> Delayed OpenAcc aenv a-    delayAcc (OpenAcc pacc) = delayPreAcc delayAcc elimAcc pacc--    countAcc :: UsesOfAcc OpenAcc-    countAcc ok idx (OpenAcc pacc) = usesOfPreAcc ok countAcc idx pacc+type EmbedAcc acc = forall aenv arrs. Arrays arrs => acc aenv arrs -> Embed acc aenv arrs+type ElimAcc  acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Bool +embedOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs+embedOpenAcc fuseAcc (OpenAcc pacc) =+  embedPreAcc fuseAcc (embedOpenAcc fuseAcc) elimOpenAcc pacc+  where     -- When does the cost of re-computation outweigh that of memory access? For     -- the moment only do the substitution on a single use of the bound array     -- into the use site, but it is likely advantageous to be far more     -- aggressive here. SEE: [Sharing vs. Fusion]     ---    elimAcc :: Idx aenv s -> OpenAcc aenv t -> Bool-    elimAcc v acc = countAcc False v acc <= lIMIT+    -- As a special case, look for the definition of 'unzip' applied to manifest+    -- data, which is defined in the prelude as a map projecting out the+    -- appropriate element.+    --+    elimOpenAcc :: ElimAcc OpenAcc+    elimOpenAcc bnd body+      | Map f a                 <- extract bnd+      , Avar _                  <- extract a+      , Lam (Body (Prj _ _))    <- f+      = Stats.ruleFired "unzipD" True++      | count False ZeroIdx body <= lIMIT+      = True++      | otherwise+      = False       where         lIMIT = 1 --annealAfun :: OpenAfun aenv f -> OpenAfun aenv f-annealAfun (Alam  f) = Alam  (annealAfun f)-annealAfun (Abody b) = Abody (annealAcc b)+        count :: UsesOfAcc OpenAcc+        count ok idx (OpenAcc pacc) = usesOfPreAcc ok count idx pacc  --- | Recast terms into the internal fusion delayed array representation to be--- forged into combined terms. Using the reduced internal form limits the number--- of combinations that need to be considered.----type DelayAcc acc = forall aenv arrs. Arrays arrs => acc aenv arrs -> Delayed acc aenv arrs-type ElimAcc  acc = forall aenv s t. Idx aenv s -> acc aenv t -> Bool--{-# SPECIALISE-      delayPreAcc :: Arrays a-                  => DelayAcc   OpenAcc-                  -> ElimAcc    OpenAcc-                  -> PreOpenAcc OpenAcc aenv a-                  -> Delayed    OpenAcc aenv a- #-}--delayPreAcc+embedPreAcc     :: forall acc aenv arrs. (Kit acc, Arrays arrs)-    => DelayAcc   acc+    => Bool+    -> EmbedAcc   acc     -> ElimAcc    acc     -> PreOpenAcc acc aenv arrs-    -> Delayed    acc aenv arrs-delayPreAcc delayAcc elimAcc pacc =-  case pacc of+    -> Embed      acc aenv arrs+embedPreAcc fuseAcc embedAcc elimAcc pacc+  = unembed+  $ case pacc of      -- Non-fusible terms     -- -----------------@@ -305,9 +300,10 @@     -- want to fuse past array let bindings, as this would imply work     -- duplication. SEE: [Sharing vs. Fusion]     ---    Alet bnd body       -> aletD delayAcc elimAcc bnd body-    Acond p at ae       -> acondD delayAcc (cvtE p) at ae-    Aprj ix tup         -> aprjD delayAcc ix tup+    Alet bnd body       -> aletD embedAcc elimAcc bnd body+    Acond p at ae       -> acondD embedAcc (cvtE p) at ae+    Aprj ix tup         -> aprjD embedAcc ix tup+    Awhile p f a        -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a)     Atuple tup          -> done $ Atuple (cvtAT tup)     Apply f a           -> done $ Apply (cvtAF f) (cvtA a)     Aforeign ff f a     -> done $ Aforeign ff (cvtAF f) (cvtA a)@@ -339,7 +335,7 @@     Backpermute sl p a  -> fuse  (into2 backpermuteD      (cvtE sl) (cvtF p)) a     Slice slix a sl     -> fuse  (into  (sliceD slix)     (cvtE sl)) a     Replicate slix sh a -> fuse  (into  (replicateD slix) (cvtE sh)) a-    Reshape sl a        -> fuse  (into  reshapeD          (cvtE sl)) a+    Reshape sl a        -> reshapeD (embedAcc a) (cvtE sl)      -- Consumers     -- ---------@@ -372,8 +368,15 @@     Stencil2 f x a y b  -> embed2 (into (stencil2 x y) (cvtF f)) a b    where+    -- If fusion is not enabled, force terms to the manifest representation+    --+    unembed :: Embed acc aenv arrs -> Embed acc aenv arrs+    unembed x+      | fuseAcc         = x+      | otherwise       = done (compute x)+     cvtA :: Arrays a => acc aenv' a -> acc aenv' a-    cvtA = computeAcc . delayAcc+    cvtA = computeAcc . embedAcc      cvtAT :: Atuple (acc aenv') a -> Atuple (acc aenv') a     cvtAT NilAtup          = NilAtup@@ -396,7 +399,7 @@     cvtF :: PreFun acc aenv t -> PreFun acc aenv t     cvtF = cvtF' . simplify -    cvtE :: PreExp acc aenv t -> PreExp acc aenv t+    cvtE :: PreExp acc aenv' t -> PreExp acc aenv' t     cvtE = cvtE' . simplify      -- Conversions for scalar functions and expressions without@@ -424,7 +427,7 @@         ToIndex sh ix           -> ToIndex (cvtE' sh) (cvtE' ix)         FromIndex sh ix         -> FromIndex (cvtE' sh) (cvtE' ix)         Cond p t e              -> Cond (cvtE' p) (cvtE' t) (cvtE' e)-        Iterate n f x           -> Iterate (cvtE' n) (cvtE' f) (cvtE' x)+        While p f x             -> While (cvtF' p) (cvtF' f) (cvtE' x)         PrimConst c             -> PrimConst c         PrimApp f x             -> PrimApp f (cvtE' x)         Index a sh              -> Index a (cvtE' sh)@@ -453,45 +456,38 @@      fuse :: Arrays as          => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs)-         ->         acc aenv as-         -> Delayed acc aenv bs-    fuse op (delayAcc -> Term env cc) = Term env (op env cc)+         ->       acc aenv as+         -> Embed acc aenv bs+    fuse op (embedAcc -> Embed env cc) = Embed env (op env cc)      fuse2 :: (Arrays as, Arrays bs)           => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs -> Cunctation acc aenv' cs)-          ->         acc aenv as-          ->         acc aenv bs-          -> Delayed acc aenv cs+          ->       acc aenv as+          ->       acc aenv bs+          -> Embed acc aenv cs     fuse2 op a1 a0-      | Term env1 cc1   <- delayAcc a1-      , Term env0 cc0   <- delayAcc (sink env1 a0)+      | Embed env1 cc1  <- embedAcc a1+      , Embed env0 cc0  <- embedAcc (sink env1 a0)       , env             <- env1 `join` env0-      = Term env (op env (sink env0 cc1) cc0)+      = Embed env (op env (sink env0 cc1) cc0)      embed :: (Arrays as, Arrays bs)           => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs)-          ->         acc aenv as-          -> Delayed acc aenv bs-    embed op (delayAcc -> Term env cc) = case cc of-      Done v        -> Term (env `PushEnv` op env (avarIn v)) (Done ZeroIdx)-      Step sh p f v -> Term (env `PushEnv` op env (computeAcc (Term BaseEnv (Step sh p f v)))) (Done ZeroIdx)-      Yield sh f    -> Term (env `PushEnv` op env (computeAcc (Term BaseEnv (Yield sh f)))) (Done ZeroIdx)+          ->       acc aenv as+          -> Embed acc aenv bs+    embed op (embedAcc -> Embed env cc)+      = Embed (env `PushEnv` op env (inject (compute' cc))) (Done ZeroIdx)      embed2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs)            => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs)-           ->         acc aenv as-           ->         acc aenv bs-           -> Delayed acc aenv cs-    embed2 op (delayAcc -> Term env1 cc1) a0 = case cc1 of-      Done v        -> inner env1 v a0-      Step sh p f v -> inner (env1 `PushEnv` compute (Term BaseEnv (Step sh p f v))) ZeroIdx a0-      Yield sh f    -> inner (env1 `PushEnv` compute (Term BaseEnv (Yield sh f))) ZeroIdx a0-      where-        inner :: Extend acc aenv aenv' -> Idx aenv' as -> acc aenv bs -> Delayed acc aenv cs-        inner env1 v1 (delayAcc . sink env1 -> Term env0 cc0) = case cc0 of-          Done v0       -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (avarIn v0)) (Done ZeroIdx)-          Step sh p f v -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (computeAcc (Term BaseEnv (Step sh p f v)))) (Done ZeroIdx)-          Yield sh f    -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (computeAcc (Term BaseEnv (Yield sh f)))) (Done ZeroIdx)+           ->       acc aenv as+           ->       acc aenv bs+           -> Embed acc aenv cs+    embed2 op (embedAcc -> Embed env1 cc1) (embedAcc . sink env1 -> Embed env0 cc0)+      | env     <- env1 `join` env0+      , acc1    <- inject . compute' $ sink env0 cc1+      , acc0    <- inject . compute' $ cc0+      = Embed (env `PushEnv` op env acc1 acc0) (Done ZeroIdx)   -- Internal representation@@ -524,10 +520,10 @@ -- of the fusion algorithm for an AST of N terms becomes O(r^n), where r is the -- number of different rules we have for combining terms. ---data Delayed acc aenv a where-  Term  :: Extend     acc aenv aenv'+data Embed acc aenv a where+  Embed :: Extend     acc aenv aenv'         -> Cunctation acc      aenv' a-        -> Delayed    acc aenv       a+        -> Embed      acc aenv       a   -- Cunctation (n): the action or an instance of delaying; a tardy action.@@ -542,7 +538,9 @@    -- The base case is just a real (manifest) array term. No fusion happens here.   -- Note that the array is referenced by an index into the extended-  -- environment, making the term non-recursive.+  -- environment, ensuring that the array is manifest and making the term+  -- non-recursive in 'acc'. Also note that the return type is a general+  -- instance of Arrays and not restricted to a single Array.   --   Done  :: Arrays a         => Idx            aenv a@@ -570,12 +568,18 @@         -> Cunctation acc aenv (Array sh' b)  +instance Kit acc => Simplify (Cunctation acc aenv a) where+  simplify (Done v)        = Done v+  simplify (Yield sh f)    = Yield (simplify sh) (simplify f)+  simplify (Step sh p f v) = Step (simplify sh) (simplify p) (simplify f) v++ -- Convert a real AST node into the internal representation ---done :: Arrays a => PreOpenAcc acc aenv a -> Delayed acc aenv a+done :: Arrays a => PreOpenAcc acc aenv a -> Embed acc aenv a done pacc-  | Avar v <- pacc      = Term BaseEnv                  (Done v)-  | otherwise           = Term (BaseEnv `PushEnv` pacc) (Done ZeroIdx)+  | Avar v <- pacc      = Embed BaseEnv                  (Done v)+  | otherwise           = Embed (BaseEnv `PushEnv` pacc) (Done ZeroIdx)   -- Recast a cunctation into a mapping from indices to elements.@@ -615,8 +619,7 @@   | Yield sh _           <- yield cc    = sh  --- Reified type of a delayed array representation. This way we don't require--- additional class constraints on 'step' and 'yield'.+-- Reified type of a delayed array representation. -- accType' :: forall acc aenv a. Arrays a => Cunctation acc aenv a -> ArraysR (ArrRepr' a) accType' _ = arrays' (undefined :: a)@@ -668,55 +671,48 @@ -- bindings have come into scope according to the witness and no old things have -- vanished. --+sink :: Sink f => Extend acc env env' -> f env t -> f env' t+sink env = weaken (k env)+  where+    k :: Extend acc env env' -> Idx env t -> Idx env' t+    k BaseEnv       = Stats.substitution "sink" id+    k (PushEnv e _) = SuccIdx . k e++sink1 :: Sink f => Extend acc env env' -> f (env,s) t -> f (env',s) t+sink1 env = weaken (k env)+  where+    k :: Extend acc env env' -> Idx (env,s) t -> Idx (env',s) t+    k BaseEnv       = Stats.substitution "sink1" id+    k (PushEnv e _) = split . k e+    --+    split :: Idx (env,s) t -> Idx ((env,u),s) t+    split ZeroIdx      = ZeroIdx+    split (SuccIdx ix) = SuccIdx (SuccIdx ix)++ class Sink f where-  sink :: Extend acc env env' -> f env t -> f env' t+  weaken :: env :> env' -> f env t -> f env' t  instance Sink Idx where-  sink BaseEnv       = Stats.substitution "sink" id-  sink (PushEnv e _) = SuccIdx . sink e+  weaken k = k  instance Kit acc => Sink (PreOpenExp acc env) where-  sink env = weakenEA rebuildAcc (sink env)+  weaken k = weakenEA rebuildAcc k  instance Kit acc => Sink (PreOpenFun acc env) where-  sink env = weakenFA rebuildAcc (sink env)+  weaken k = weakenFA rebuildAcc k  instance Kit acc => Sink (PreOpenAcc acc) where-  sink env = weakenA rebuildAcc (sink env)+  weaken k = weakenA rebuildAcc k -instance Kit acc => Sink acc where      -- overlapping, undecidable, incoherent-  sink env = rebuildAcc (Avar . sink env)+instance Kit acc => Sink acc where+  weaken k = rebuildAcc (Avar . k)  instance Kit acc => Sink (Cunctation acc) where-  sink env cc = case cc of-    Done v              -> Done (sink env v)-    Step sh p f v       -> Step (sink env sh) (sink env p) (sink env f) (sink env v)-    Yield sh f          -> Yield (sink env sh) (sink env f)---class Sink1 f where-  sink1 :: Extend acc env env' -> f (env,s) t -> f (env',s) t--instance Sink1 Idx where-  sink1 BaseEnv         = Stats.substitution "sink1" id-  sink1 (PushEnv e _)   = split . sink1 e-    where-      split :: Idx (env,s) t -> Idx ((env,u),s) t-      split ZeroIdx      = ZeroIdx-      split (SuccIdx ix) = SuccIdx (SuccIdx ix)--instance Kit acc => Sink1 (PreOpenExp acc env) where-  sink1 env = weakenEA rebuildAcc (sink1 env)--instance Kit acc => Sink1 (PreOpenFun acc env) where-  sink1 env = weakenFA rebuildAcc (sink1 env)--instance Kit acc => Sink1 (PreOpenAcc acc) where-  sink1 env = weakenA rebuildAcc (sink1 env)--instance Kit acc => Sink1 acc where     -- overlapping, undecidable, incoherent-  sink1 env = rebuildAcc (Avar . sink1 env)-+  weaken k cc = case cc of+    Done v              -> Done (weaken k v)+    Step sh p f v       -> Step (weaken k sh) (weaken k p) (weaken k f) (weaken k v)+    Yield sh f          -> Yield (weaken k sh) (weaken k f)   -- Array fusion of a de Bruijn computation AST@@ -728,40 +724,38 @@ -- Recast the internal representation of delayed arrays into a real AST node. -- Use the most specific version of a combinator whenever possible. ---compute :: (Kit acc, Arrays arrs) => Delayed acc aenv arrs -> PreOpenAcc acc aenv arrs-compute (Term env cc)-  = bind env-  $ case cc of-      Done v                                    -> Avar v-      Yield (simplify -> sh) (simplify -> f)    -> Generate sh f-      Step  (simplify -> sh) (simplify -> p) (simplify -> f) v-        | Just REFL <- identShape-        , Just REFL <- isIdentity p-        , Just REFL <- isIdentity f             -> Avar v-        | Just REFL <- identShape-        , Just REFL <- isIdentity p             -> Map f acc-        | Just REFL <- isIdentity f             -> Backpermute sh p acc-        | otherwise                             -> Transform sh p f acc-        where-          identShape    = match sh (arrayShape v)-          acc           = avarIn v+compute :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> PreOpenAcc acc aenv arrs+compute (Embed env cc) = bind env (compute' cc) +compute' :: (Kit acc, Arrays arrs) => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs+compute' cc = case simplify cc of+  Done v                                        -> Avar v+  Yield sh f                                    -> Generate sh f+  Step sh p f v+    | Just REFL <- match sh (arrayShape v)+    , Just REFL <- isIdentity p+    , Just REFL <- isIdentity f                 -> Avar v+    | Just REFL <- match sh (arrayShape v)+    , Just REFL <- isIdentity p                 -> Map f (avarIn v)+    | Just REFL <- isIdentity f                 -> Backpermute sh p (avarIn v)+    | otherwise                                 -> Transform sh p f (avarIn v) + -- Evaluate a delayed computation and tie the recursive knot ---computeAcc :: (Kit acc, Arrays arrs) => Delayed acc aenv arrs -> acc aenv arrs+computeAcc :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> acc aenv arrs computeAcc = inject . compute   -- Representation of a generator as a delayed array -- generateD :: (Shape sh, Elt e)-          => PreExp  acc aenv sh-          -> PreFun  acc aenv (sh -> e)-          -> Delayed acc aenv (Array sh e)+          => PreExp acc aenv sh+          -> PreFun acc aenv (sh -> e)+          -> Embed  acc aenv (Array sh e) generateD sh f   = Stats.ruleFired "generateD"-  $ Term BaseEnv (Yield sh f)+  $ Embed BaseEnv (Yield sh f)   -- Fuse a unary function into a delayed array.@@ -838,24 +832,26 @@  -- Reshape an array ----- For delayed arrays this is implemented as an index space transformation.--- However for manifest arrays this can be done in constant time. However, if--- the reshaped array is later consumed, for example in foldAll, this won't be--- fused into the consumer. At this point always convert into a delayed--- representation, and attempt to recover the reshape operation in the final--- quenching phase.+-- For delayed arrays this is implemented as an index space transformation. For+-- manifest arrays this can be done with the standard Reshape operation in+-- constant time without executing any array operations. This does not affect+-- the fusion process since the term is already manifest. -- -- TLM: there was a runtime check to ensure the old and new shapes contained the --      same number of elements: this has been lost for the delayed cases! -- reshapeD-    :: (Kit acc, Shape sh, Shape sl)-    => PreExp     acc aenv sl-    -> Cunctation acc aenv (Array sh e)-    -> Cunctation acc aenv (Array sl e)-reshapeD sl cc+    :: (Kit acc, Shape sh, Shape sl, Elt e)+    => Embed  acc aenv (Array sh e)+    -> PreExp acc aenv sl+    -> Embed  acc aenv (Array sl e)+reshapeD (Embed env cc) (sink env -> sl)+  | Done v      <- cc+  = Embed (env `PushEnv` Reshape sl (avarIn v)) (Done ZeroIdx)++  | otherwise   = Stats.ruleFired "reshapeD"-  $ backpermuteD sl (reindex (shape cc) sl) cc+  $ Embed env (backpermuteD sl (reindex (shape cc) sl) cc)   -- Combine two arrays element-wise with a binary function to produce a delayed@@ -956,13 +952,35 @@ -- the cost of completely evaluating the array and subsequently retrieving the -- data from memory. ---aletD :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs)-      => DelayAcc acc+-- let-binding:+-- ------------+--+-- Ultimately, we might not want to eliminate the binding. If so, evaluate it+-- and add it to a _clean_ Extend environment for the body. If not, the Extend+-- list effectively _flattens_ all bindings, so any terms required for the bound+-- term get lifted out to the same scope as the body. This increases their+-- lifetime and hence raises the maximum memory used. If we don't do this, we+-- get terms such as:+--+--   let a0  = <terms for binding> in+--   let bnd = <bound term> in+--   <body term>+--+-- rather than the following, where the scope of a0 is clearly only availably+-- when evaluating the bound term, as it should be:+--+--   let bnd =+--     let a0 = <terms for binding>+--     in <bound term>+--   in <body term>+--+aletD :: (Kit acc, Arrays arrs, Arrays brrs)+      => EmbedAcc acc       -> ElimAcc  acc       ->          acc aenv        arrs       ->          acc (aenv,arrs) brrs-      -> Delayed  acc aenv        brrs-aletD delayAcc elimAcc (delayAcc -> Term env1 cc1) acc0+      -> Embed    acc aenv        brrs+aletD embedAcc elimAcc (embedAcc -> Embed env1 cc1) acc0    -- let-floating   -- ------------@@ -972,60 +990,75 @@   -- that must be later eliminated by shrinking.   --   | Done v1             <- cc1-  , Term env0 cc0       <- delayAcc $ rebuildAcc (subTop (Avar v1) . sink1 env1) acc0+  , Embed env0 cc0      <- embedAcc $ rebuildAcc (subAtop (Avar v1) . sink1 env1) acc0   = Stats.ruleFired "aletD/float"-  $ Term (env1 `join` env0) cc0+  $ Embed (env1 `join` env0) cc0 +  -- Ensure we only call 'embedAcc' once on the body expression+  --+  | otherwise+  = aletD' embedAcc elimAcc (Embed env1 cc1) (embedAcc acc0)+++aletD' :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs)+       => EmbedAcc acc+       -> ElimAcc  acc+       -> Embed    acc aenv         arrs+       -> Embed    acc (aenv, arrs) brrs+       -> Embed    acc aenv         brrs+aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0)++  -- let-binding+  -- -----------+  --+  -- Check whether we can eliminate the let-binding. Note that we must inspect+  -- the entire term, not just the Cunctation that would be produced by+  -- embedAcc. If we don't we can be left with dead terms that don't get+  -- eliminated. This problem occurred in the canny program.+  --+  | acc1                <- compute (Embed env1 cc1)+  , False               <- elimAcc (inject acc1) acc0+  = Stats.ruleFired "aletD/bind"+  $ Embed (BaseEnv `PushEnv` acc1 `join` env0) cc0++  -- let-elimination+  -- ---------------+  --   -- Handle the remaining cases in a separate function. It turns out that this   -- is important so we aren't excessively sinking/delaying terms.   ---  | otherwise-  , Term env0 cc0       <- delayAcc $ sink1 env1 acc0-  = case cc1 of-      Step{}    -> aletD' env1 cc1 env0 cc0-      Yield{}   -> aletD' env1 cc1 env0 cc0+  | acc0'               <- sink1 env1 acc0+  = Stats.ruleFired "aletD/eliminate"+  $ case cc1 of+      Step{}    -> eliminate env1 cc1 acc0'+      Yield{}   -> eliminate env1 cc1 acc0'    where-    subTop :: forall aenv s t. Arrays t => PreOpenAcc acc aenv s -> Idx (aenv,s) t -> PreOpenAcc acc aenv t-    subTop t ZeroIdx       = t-    subTop _ (SuccIdx idx) = Avar idx+    acc0 = computeAcc (Embed env0 cc0)      -- The second part of let-elimination. Splitting into two steps exposes the-    -- extra type variables, and ensures we don't do extra work for the-    -- let-floating case (which can lead to a complexity blowup.)+    -- extra type variables, and ensures we don't do extra work manipulating the+    -- body when not necessary (which can lead to a complexity blowup).     ---    aletD' :: forall aenv aenv' aenv'' sh e brrs. (Kit acc, Shape sh, Elt e, Arrays brrs)-           => Extend     acc aenv                aenv'-           -> Cunctation acc                     aenv'  (Array sh e)-           -> Extend     acc (aenv', Array sh e) aenv''-           -> Cunctation acc                     aenv'' brrs-           -> Delayed    acc aenv                       brrs-    aletD' env1 cc1 env0 cc0-      | not shouldInline         = Term (env1 `PushEnv` bnd `join` env0) cc0--      | Stats.ruleFired "aletD/eliminate" False-      = undefined--      | Done v1           <- cc1 = eliminate (arrayShape v1) (indexArray v1)-      | Step sh1 p1 f1 v1 <- cc1 = eliminate sh1 (f1 `compose` indexArray v1 `compose` p1)-      | Yield sh1 f1      <- cc1 = eliminate sh1 f1+    eliminate :: forall aenv aenv' sh e brrs. (Kit acc, Shape sh, Elt e, Arrays brrs)+              => Extend     acc aenv aenv'+              -> Cunctation acc      aenv' (Array sh e)+              ->            acc     (aenv', Array sh e) brrs+              -> Embed      acc aenv                    brrs+    eliminate env1 cc1 body+      | Done v1           <- cc1 = elim (arrayShape v1) (indexArray v1)+      | Step sh1 p1 f1 v1 <- cc1 = elim sh1 (f1 `compose` indexArray v1 `compose` p1)+      | Yield sh1 f1      <- cc1 = elim sh1 f1       where-        -- The main terms, remade manifest. We need to do this so that eliminating-        -- terms considers not just the main term but any of the environment terms-        -- (in Extend). This problem occurred in the Canny example program.-        ---        shouldInline = elimAcc ZeroIdx body-        body         = computeAcc (Term env0    cc0)-        bnd          = compute    (Term BaseEnv cc1)+        bnd :: PreOpenAcc acc aenv' (Array sh e)+        bnd = compute' cc1 -        eliminate :: PreExp  acc      aenv' sh-                  -> PreFun  acc      aenv' (sh -> e)-                  -> Delayed acc aenv       brrs-        eliminate sh1 f1-          | sh1'            <- weakenEA rebuildAcc SuccIdx sh1-          , f1'             <- weakenFA rebuildAcc SuccIdx f1-          , Term env0' cc0' <- delayAcc $ rebuildAcc (subTop bnd) $ kmap (replaceA sh1' f1' ZeroIdx) body-          = Term (env1 `join` env0') cc0'+        elim :: PreExp acc aenv' sh -> PreFun acc aenv' (sh -> e) -> Embed acc aenv brrs+        elim sh1 f1+          | sh1'                <- weakenEA rebuildAcc SuccIdx sh1+          , f1'                 <- weakenFA rebuildAcc SuccIdx f1+          , Embed env0' cc0'    <- embedAcc $ rebuildAcc (subAtop bnd) $ kmap (replaceA sh1' f1' ZeroIdx) body+          = Embed (env1 `join` env0') cc0'      -- As part of let-elimination, we need to replace uses of array variables in     -- scalar expressions with an equivalent expression that generates the@@ -1058,23 +1091,24 @@         ToIndex sh ix                   -> ToIndex (cvtE sh) (cvtE ix)         FromIndex sh i                  -> FromIndex (cvtE sh) (cvtE i)         Cond p t e                      -> Cond (cvtE p) (cvtE t) (cvtE e)-        Iterate n f x                   -> Iterate (cvtE n) (replaceE (weakenE SuccIdx sh') (weakenFE SuccIdx f') avar f) (cvtE x)         PrimConst c                     -> PrimConst c         PrimApp g x                     -> PrimApp g (cvtE x)         ShapeSize sh                    -> ShapeSize (cvtE sh)         Intersect sh sl                 -> Intersect (cvtE sh) (cvtE sl)+        While p f x                     -> While (replaceF sh' f' avar p) (replaceF sh' f' avar f) (cvtE x)+         Shape a           | Just REFL <- match a a'     -> Stats.substitution "replaceE/shape" sh'           | otherwise                   -> exp          Index a sh           | Just REFL    <- match a a'-          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!" $ Let sh b+          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!" . cvtE $ Let sh b           | otherwise                   -> Index a (cvtE sh)          LinearIndex a i           | Just REFL    <- match a a'-          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!!" $ Let (Let i (FromIndex (weakenE SuccIdx sh') (Var ZeroIdx))) b+          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!!" . cvtE $ Let (Let i (FromIndex (weakenE SuccIdx sh') (Var ZeroIdx))) b           | otherwise                   -> LinearIndex a (cvtE i)        where@@ -1117,8 +1151,9 @@         Acond p at ae           -> Acond (cvtE p) (cvtA at) (cvtA ae)         Aprj ix tup             -> Aprj ix (cvtA tup)         Atuple tup              -> Atuple (cvtAT tup)-        Apply f a               -> Apply f (cvtA a)            -- no sharing between f and a-        Aforeign ff f a         -> Aforeign ff f (cvtA a)      -- no sharing between f and a+        Awhile p f a            -> Awhile p f (cvtA a)          -- no sharing between p or f and a+        Apply f a               -> Apply f (cvtA a)             -- no sharing between f and a+        Aforeign ff f a         -> Aforeign ff f (cvtA a)       -- no sharing between f and a         Generate sh f           -> Generate (cvtE sh) (cvtF f)         Map f a                 -> Map (cvtF f) (cvtA a)         ZipWith f a b           -> ZipWith (cvtF f) (cvtA a) (cvtA b)@@ -1167,33 +1202,33 @@ -- for the branch not taken. -- acondD :: (Kit acc, Arrays arrs)-       => DelayAcc acc+       => EmbedAcc acc        -> PreExp   acc aenv Bool        ->          acc aenv arrs        ->          acc aenv arrs-       -> Delayed  acc aenv arrs-acondD delayAcc p t e-  | Const ((),True)  <- p   = Stats.knownBranch "True"      $ delayAcc t-  | Const ((),False) <- p   = Stats.knownBranch "False"     $ delayAcc e-  | Just REFL <- match t e  = Stats.knownBranch "redundant" $ delayAcc e-  | otherwise               = done $ Acond p (computeAcc (delayAcc t))-                                             (computeAcc (delayAcc e))+       -> Embed    acc aenv arrs+acondD embedAcc p t e+  | Const ((),True)  <- p   = Stats.knownBranch "True"      $ embedAcc t+  | Const ((),False) <- p   = Stats.knownBranch "False"     $ embedAcc e+  | Just REFL <- match t e  = Stats.knownBranch "redundant" $ embedAcc e+  | otherwise               = done $ Acond p (computeAcc (embedAcc t))+                                             (computeAcc (embedAcc e))   -- Array tuple projection. Whenever possible we want to peek underneath the -- tuple structure and continue the fusion process. -- aprjD :: forall acc aenv arrs a. (Kit acc, IsTuple arrs, Arrays arrs, Arrays a)-      => DelayAcc acc+      => EmbedAcc acc       -> TupleIdx (TupleRepr arrs) a-      ->         acc aenv arrs-      -> Delayed acc aenv a-aprjD delayAcc ix a-  | Atuple tup <- extract a = Stats.ruleFired "aprj/Atuple" . delayAcc $ aprjAT ix tup+      ->       acc aenv arrs+      -> Embed acc aenv a+aprjD embedAcc ix a+  | Atuple tup <- extract a = Stats.ruleFired "aprj/Atuple" . embedAcc $ aprjAT ix tup   | otherwise               = done $ Aprj ix (cvtA a)   where     cvtA :: acc aenv arrs -> acc aenv arrs-    cvtA = computeAcc . delayAcc+    cvtA = computeAcc . embedAcc      aprjAT :: TupleIdx atup a -> Atuple (acc aenv) atup -> acc aenv a     aprjAT ZeroTupIdx      (SnocAtup _ a) = a
Data/Array/Accelerate/Trafo/Rewrite.hs view
@@ -66,6 +66,7 @@       Apply f a                 -> Apply (cvtAfun f) (cvtA a)       Aforeign ff afun acc      -> Aforeign ff (cvtAfun afun) (cvtA acc)       Acond p t e               -> Acond (cvtE p) (cvtA t) (cvtA e)+      Awhile p f a              -> Awhile (cvtAfun p) (cvtAfun f) (cvtA a)       Use a                     -> Use a       Unit e                    -> Unit (cvtE e)       Reshape e a               -> Reshape (cvtE e) (cvtA a)
Data/Array/Accelerate/Trafo/Sharing.hs view
@@ -38,6 +38,8 @@ import Data.Typeable import qualified Data.HashTable.IO                      as Hash import qualified Data.IntMap                            as IntMap+import qualified Data.HashMap.Strict                    as Map+import qualified Data.HashSet                           as Set import System.IO.Unsafe                                 ( unsafePerformIO ) import System.Mem.StableName @@ -202,40 +204,50 @@     => Config     -> Layout aenv aenv     -> [StableSharingAcc]-    -> SharingAcc arrs+    -> ScopedAcc arrs     -> AST.OpenAcc aenv arrs-convertSharingAcc _ alyt aenv (AvarSharing sa)-  | Just i <- findIndex (matchStableAcc sa) aenv+convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa))+  | Just i <- findIndex (matchStableAcc sa) aenv'   = AST.OpenAcc $ AST.Avar (prjIdx (ctxt ++ "; i = " ++ show i) i alyt)-  | null aenv+  | null aenv'   = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++             show (hashStableNameHeight sa) ++ ")"   | otherwise   = INTERNAL_ERROR(error) "convertSharingAcc" err   where+    aenv' = lams ++ aenv     ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa)-    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  aenv = " ++ show aenv+    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  aenv = " ++ show aenv' -convertSharingAcc config alyt aenv (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc)+convertSharingAcc config alyt aenv (ScopedAcc lams (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc))   = AST.OpenAcc   $ let alyt' = incLayout alyt `PushLayout` ZeroIdx+        aenv' = lams ++ aenv     in-    AST.Alet (convertSharingAcc config alyt aenv boundAcc)-             (convertSharingAcc config alyt' (sa:aenv) bodyAcc)+    AST.Alet (convertSharingAcc config alyt aenv' (ScopedAcc [] boundAcc))+             (convertSharingAcc config alyt' (sa:aenv') bodyAcc) -convertSharingAcc config alyt aenv (AccSharing _ preAcc)+convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc))   = AST.OpenAcc-  $ let cvtA :: Arrays a => SharingAcc a -> AST.OpenAcc aenv a-        cvtA = convertSharingAcc config alyt aenv+  $ let aenv' = lams ++ aenv -        cvtE :: Elt t => RootExp t -> AST.Exp aenv t-        cvtE = convertRootExp config alyt aenv+        cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a+        cvtA = convertSharingAcc config alyt aenv' -        cvtF1 :: (Elt a, Elt b) => (Exp a -> RootExp b) -> AST.Fun aenv (a -> b)-        cvtF1 = convertSharingFun1 config alyt aenv+        cvtE :: Elt t => ScopedExp t -> AST.Exp aenv t+        cvtE = convertSharingExp config EmptyLayout alyt [] aenv' -        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> RootExp c) -> AST.Fun aenv (a -> b -> c)-        cvtF2 = convertSharingFun2 config alyt aenv+        cvtF1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.Fun aenv (a -> b)+        cvtF1 = convertSharingFun1 config alyt aenv'++        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)+        cvtF2 = convertSharingFun2 config alyt aenv'++        cvtAfun1 :: (Arrays a, Arrays b) => (Acc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b)+        cvtAfun1 f = Alam (Abody (convertSharingAcc config alyt' aenv' body))+          where+            alyt' = incLayout alyt `PushLayout` ZeroIdx+            body  = f undefined     in     case preAcc of @@ -244,7 +256,7 @@        Pipe afun1 afun2 acc         -> let alyt'    = incLayout alyt `PushLayout` ZeroIdx-               boundAcc = aconvert config alyt  afun1 `AST.Apply` convertSharingAcc config alyt aenv acc+               boundAcc = aconvert config alyt  afun1 `AST.Apply` convertSharingAcc config alyt aenv' acc                bodyAcc  = aconvert config alyt' afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx)            in            AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc)@@ -257,7 +269,8 @@            AST.Aforeign ff (convertAfun a e f afun) (cvtA acc)        Acond b acc1 acc2           -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2)-      Atuple arrs                 -> AST.Atuple (convertSharingAtuple config alyt aenv arrs)+      Awhile pred iter init       -> AST.Awhile (cvtAfun1 pred) (cvtAfun1 iter) (cvtA init)+      Atuple arrs                 -> AST.Atuple (convertSharingAtuple config alyt aenv' arrs)       Aprj ix a                   -> AST.Aprj ix (cvtA a)       Use array                   -> AST.Use (fromArr array)       Unit e                      -> AST.Unit (cvtE e)@@ -280,11 +293,11 @@       Permute f dftAcc perm acc   -> AST.Permute (cvtF2 f) (cvtA dftAcc) (cvtF1 perm) (cvtA acc)       Backpermute newDim perm acc -> AST.Backpermute (cvtE newDim) (cvtF1 perm) (cvtA acc)       Stencil stencil boundary acc-        -> AST.Stencil (convertSharingStencilFun1 config acc alyt aenv stencil)+        -> AST.Stencil (convertSharingStencilFun1 config acc alyt aenv' stencil)                        (convertBoundary boundary)                        (cvtA acc)       Stencil2 stencil bndy1 acc1 bndy2 acc2-        -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv stencil)+        -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv' stencil)                         (convertBoundary bndy1)                         (cvtA acc1)                         (convertBoundary bndy2)@@ -295,11 +308,11 @@        Config     -> Layout aenv aenv     -> [StableSharingAcc]-    -> Tuple.Atuple SharingAcc a+    -> Tuple.Atuple ScopedAcc a     -> Tuple.Atuple (AST.OpenAcc aenv) a convertSharingAtuple config alyt aenv = cvt   where-    cvt :: Tuple.Atuple SharingAcc a' -> Tuple.Atuple (AST.OpenAcc aenv) a'+    cvt :: Tuple.Atuple ScopedAcc a' -> Tuple.Atuple (AST.OpenAcc aenv) a'     cvt NilAtup         = NilAtup     cvt (SnocAtup t a)  = cvt t `SnocAtup` convertSharingAcc config alyt aenv a @@ -417,26 +430,29 @@     -> Layout aenv aenv         -- array environment     -> [StableSharingExp]       -- currently bound sharing variables of expressions     -> [StableSharingAcc]       -- currently bound sharing variables of array computations-    -> SharingExp t             -- expression to be converted+    -> ScopedExp t              -- expression to be converted     -> AST.OpenExp env aenv t-convertSharingExp config lyt alyt env aenv = cvt+convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp   where-    cvt :: Elt t' => SharingExp t' -> AST.OpenExp env aenv t'-    cvt (VarSharing se)-      | Just i <- findIndex (matchStableExp se) env+    -- scalar environment with any lambda bound variables this expression is rooted in+    env' = lams ++ env++    cvt :: Elt t' => ScopedExp t' -> AST.OpenExp env aenv t'+    cvt (ScopedExp _ (VarSharing se))+      | Just i <- findIndex (matchStableExp se) env'       = AST.Var (prjIdx (ctxt ++ "; i = " ++ show i) i lyt)-      | null env+      | null env'       = error $ "Cyclic definition of a value of type 'Exp' (sa = " ++ show (hashStableNameHeight se) ++ ")"       | otherwise       = INTERNAL_ERROR(error) "convertSharingExp" err       where         ctxt = "shared 'Exp' tree with stable name " ++ show (hashStableNameHeight se)-        err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  env = " ++ show env-    cvt (LetSharing se@(StableSharingExp _ boundExp) bodyExp)+        err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  env' = " ++ show env'+    cvt (ScopedExp _ (LetSharing se@(StableSharingExp _ boundExp) bodyExp))       = let lyt' = incLayout lyt `PushLayout` ZeroIdx         in-        AST.Let (cvt boundExp) (convertSharingExp config lyt' alyt (se:env) aenv bodyExp)-    cvt (ExpSharing _ pexp)+        AST.Let (cvt (ScopedExp [] boundExp)) (convertSharingExp config lyt' alyt (se:env') aenv bodyExp)+    cvt (ScopedExp _ (ExpSharing _ pexp))       = case pexp of           Tag i                 -> AST.Var (prjIdx ("de Bruijn conversion tag " ++ show i) i lyt)           Const v               -> AST.Const (fromElt v)@@ -450,20 +466,28 @@           ToIndex sh ix         -> AST.ToIndex (cvt sh) (cvt ix)           FromIndex sh e        -> AST.FromIndex (cvt sh) (cvt e)           Cond e1 e2 e3         -> AST.Cond (cvt e1) (cvt e2) (cvt e3)+          While p it i          -> AST.While (cvtFun1 p) (cvtFun1 it) (cvt i)           PrimConst c           -> AST.PrimConst c           PrimApp f e           -> cvtPrimFun f (cvt e)           Index a e             -> AST.Index (cvtA a) (cvt e)           LinearIndex a i       -> AST.LinearIndex (cvtA a) (cvt i)           Shape a               -> AST.Shape (cvtA a)           ShapeSize e           -> AST.ShapeSize (cvt e)+          Intersect sh1 sh2     -> AST.Intersect (cvt sh1) (cvt sh2)           Foreign ff f e        -> AST.Foreign ff (convertFun (recoverExpSharing config) f) (cvt e) -    cvtA :: Arrays a => SharingAcc a -> AST.OpenAcc aenv a+    cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a     cvtA = convertSharingAcc config alyt aenv -    cvtT :: Tuple.Tuple SharingExp tup -> Tuple.Tuple (AST.OpenExp env aenv) tup-    cvtT = convertSharingTuple config lyt alyt env aenv+    cvtT :: Tuple.Tuple ScopedExp tup -> Tuple.Tuple (AST.OpenExp env aenv) tup+    cvtT = convertSharingTuple config lyt alyt env' aenv +    cvtFun1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b)+    cvtFun1 f = Lam (Body (convertSharingExp config lyt' alyt env' aenv body))+      where+        lyt' = incLayout lyt `PushLayout` ZeroIdx+        body = f undefined+     -- Push primitive function applications down through let bindings so that     -- they are adjacent to their arguments. It looks a bit nicer this way.     --@@ -481,7 +505,7 @@     -> Layout aenv aenv     -> [StableSharingExp]                 -- currently bound scalar sharing-variables     -> [StableSharingAcc]                 -- currently bound array sharing-variables-    -> Tuple.Tuple SharingExp t+    -> Tuple.Tuple ScopedExp t     -> Tuple.Tuple (AST.OpenExp env aenv) t convertSharingTuple config lyt alyt env aenv tup =   case tup of@@ -489,20 +513,6 @@     SnocTup t e -> convertSharingTuple config lyt alyt env aenv t          `SnocTup` convertSharingExp   config lyt alyt env aenv e --- | Convert a scalar expression, which is closed with respect to scalar variables----convertRootExp-    :: Elt t-    => Config-    -> Layout aenv aenv         -- array environment-    -> [StableSharingAcc]       -- currently bound array sharing-variables-    -> RootExp t                -- expression to be converted-    -> AST.Exp aenv t-convertRootExp config alyt aenv exp-  = case exp of-      EnvExp env exp    -> convertSharingExp config EmptyLayout alyt env aenv exp-      _                 -> INTERNAL_ERROR(error) "convertRootExp" "not an 'EnvExp'"- -- | Convert a unary functions -- convertSharingFun1@@ -510,7 +520,7 @@     => Config     -> Layout aenv aenv     -> [StableSharingAcc]       -- currently bound array sharing-variables-    -> (Exp a -> RootExp b)+    -> (Exp a -> ScopedExp b)     -> AST.Fun aenv (a -> b) convertSharingFun1 config alyt aenv f = Lam (Body openF)   where@@ -518,8 +528,7 @@     lyt             = EmptyLayout                       `PushLayout`                       (ZeroIdx :: Idx ((), a) a)-    EnvExp env body = f a-    openF           = convertSharingExp config lyt alyt env aenv body+    openF           = convertSharingExp config lyt alyt [] aenv (f a)  -- | Convert a binary functions --@@ -528,7 +537,7 @@     => Config     -> Layout aenv aenv     -> [StableSharingAcc]       -- currently bound array sharing-variables-    -> (Exp a -> Exp b -> RootExp c)+    -> (Exp a -> Exp b -> ScopedExp c)     -> AST.Fun aenv (a -> b -> c) convertSharingFun2 config alyt aenv f = Lam (Lam (Body openF))   where@@ -539,18 +548,17 @@                       (SuccIdx ZeroIdx :: Idx (((), a), b) a)                       `PushLayout`                       (ZeroIdx         :: Idx (((), a), b) b)-    EnvExp env body = f a b-    openF           = convertSharingExp config lyt alyt env aenv body+    openF           = convertSharingExp config lyt alyt [] aenv (f a b)  -- | Convert a unary stencil function -- convertSharingStencilFun1     :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil, Elt b)     => Config-    -> SharingAcc (Array sh a)          -- just passed to fix the type variables+    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables     -> Layout aenv aenv     -> [StableSharingAcc]               -- currently bound array sharing-variables-    -> (stencil -> RootExp b)+    -> (stencil -> ScopedExp b)     -> AST.Fun aenv (StencilRepr sh stencil -> b) convertSharingStencilFun1 config _ alyt aenv stencilFun = Lam (Body openStencilFun)   where@@ -560,8 +568,8 @@               (ZeroIdx :: Idx ((), StencilRepr sh stencil)                               (StencilRepr sh stencil)) -    EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)-    openStencilFun  = convertSharingExp config lyt alyt env aenv body+    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)+    openStencilFun  = convertSharingExp config lyt alyt [] aenv body  -- | Convert a binary stencil function --@@ -571,11 +579,11 @@         Elt b, Stencil sh b stencil2,         Elt c)     => Config-    -> SharingAcc (Array sh a)          -- just passed to fix the type variables-    -> SharingAcc (Array sh b)          -- just passed to fix the type variables+    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables+    -> ScopedAcc (Array sh b)          -- just passed to fix the type variables     -> Layout aenv aenv     -> [StableSharingAcc]               -- currently bound array sharing-variables-    -> (stencil1 -> stencil2 -> RootExp c)+    -> (stencil1 -> stencil2 -> ScopedExp c)     -> AST.Fun aenv (StencilRepr sh stencil1 -> StencilRepr sh stencil2 -> c) convertSharingStencilFun2 config _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun))   where@@ -591,9 +599,9 @@                                             StencilRepr sh stencil2)                                        (StencilRepr sh stencil2)) -    EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)-                                 (stencilPrj (undefined::sh) (undefined::b) stencil2)-    openStencilFun  = convertSharingExp config lyt alyt env aenv body+    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)+                      (stencilPrj (undefined::sh) (undefined::b) stencil2)+    openStencilFun  = convertSharingExp config lyt alyt [] aenv body   -- Sharing recovery@@ -781,19 +789,28 @@ -- represented by variable (binding a shared subtree) using 'AvarSharing' and as being prefixed by -- a let binding (for a shared subtree) using 'AletSharing'. ---data SharingAcc arrs where+data SharingAcc acc exp arrs where   AvarSharing :: Arrays arrs-              => StableAccName arrs                                   -> SharingAcc arrs-  AletSharing :: StableSharingAcc -> SharingAcc arrs                  -> SharingAcc arrs+              => StableAccName arrs                        -> SharingAcc acc exp arrs+  AletSharing :: StableSharingAcc -> acc arrs              -> SharingAcc acc exp arrs   AccSharing  :: Arrays arrs-              => StableAccName arrs -> PreAcc SharingAcc RootExp arrs -> SharingAcc arrs+              => StableAccName arrs -> PreAcc acc exp arrs -> SharingAcc acc exp arrs +-- Array expression with sharing but shared values have not been scoped; i.e. no let bindings. If+-- the expression is rooted in a function, the list contains the tags of the variables bound by the+-- immediate surrounding lambdas.+data UnscopedAcc t = UnscopedAcc [Int] (SharingAcc UnscopedAcc RootExp t)++-- Array expression with sharing. For expressions rooted in functions the list holds a sorted+-- environment corresponding to the variables bound in the immediate surounding lambdas.+data ScopedAcc t = ScopedAcc [StableSharingAcc] (SharingAcc ScopedAcc ScopedExp t)+ -- Stable name for an array computation associated with its sharing-annotated version. -- data StableSharingAcc where   StableSharingAcc :: Arrays arrs                    => StableAccName arrs-                   -> SharingAcc arrs+                   -> SharingAcc ScopedAcc ScopedExp arrs                    -> StableSharingAcc  instance Show StableSharingAcc where@@ -829,29 +846,35 @@ -- Interleave sharing annotations into a scalar expressions AST in the same manner as 'SharingAcc' -- do for array computations. ---data SharingExp t where+data SharingExp (acc :: * -> *) exp t where   VarSharing :: Elt t-             => StableExpName t                                   -> SharingExp t-  LetSharing :: StableSharingExp -> SharingExp t                  -> SharingExp t+             => StableExpName t                            -> SharingExp acc exp t+  LetSharing :: StableSharingExp -> exp t                  -> SharingExp acc exp t   ExpSharing :: Elt t-             => StableExpName t -> PreExp SharingAcc SharingExp t -> SharingExp t+             => StableExpName t -> PreExp acc exp t -> SharingExp acc exp t +-- Specifies a scalar expression AST with sharing annotations but no scoping; i.e. no LetSharing+-- constructors. If the expression is rooted in a function, the list contains the tags of the+-- variables bound by the immediate surrounding lambdas.+data UnscopedExp t = UnscopedExp [Int] (SharingExp UnscopedAcc UnscopedExp t)++-- Specifies a scalar expression AST with sharing. For expressions rooted in functions the list+-- holds a sorted environment corresponding to the variables bound in the immediate surounding+-- lambdas.+data ScopedExp t = ScopedExp [StableSharingExp] (SharingExp ScopedAcc ScopedExp t)+ -- Expressions rooted in 'Acc' computations. ----- * Between counting occurrences and determining scopes, the root of every expression embedded in an---   'Acc' is annotated by (1) the tags of free scalar variables and (2) an occurrence map for that---   one expression (excluding any subterms that are rooted in embedded 'Acc's.)--- * After determining scopes, the root of every expression is annotated with a sorted environment of---   the 'StableSharingExp's corresponding to its free expression-valued variables.+-- * When counting occurrences, the root of every expression embedded in an 'Acc' is annotated by+--   an occurrence map for that one expression (excluding any subterms that are rooted in embedded+--   'Acc's.) ---data RootExp t where-  OccMapExp :: [Int] -> OccMap Exp -> SharingExp t -> RootExp t-  EnvExp    :: [StableSharingExp]  -> SharingExp t -> RootExp t+data RootExp t = RootExp (OccMap Exp) (UnscopedExp t)  -- Stable name for an expression associated with its sharing-annotated version. -- data StableSharingExp where-  StableSharingExp :: Elt t => StableExpName t -> SharingExp t -> StableSharingExp+  StableSharingExp :: Elt t => StableExpName t -> SharingExp ScopedAcc ScopedExp t -> StableSharingExp  instance Show StableSharingExp where   show (StableSharingExp sn _) = show $ hashStableNameHeight sn@@ -910,7 +933,7 @@     => Config     -> Level     -> Acc arrs-    -> IO (SharingAcc arrs, OccMap Acc)+    -> IO (UnscopedAcc arrs, OccMap Acc) makeOccMapAcc config lvl acc = do   traceLine "makeOccMapAcc" "Enter"   accOccMap             <- newASTHashTable@@ -926,7 +949,7 @@     -> OccMapHash Acc     -> Level     -> Acc arrs-    -> IO (SharingAcc arrs, Int)+    -> IO (UnscopedAcc arrs, Int) makeOccMapSharingAcc config accOccMap = traverseAcc   where     traverseFun1 :: (Elt a, Typeable b) => Level -> (Exp a -> Exp b) -> IO (Exp a -> RootExp b, Int)@@ -938,10 +961,13 @@                  -> IO (Exp a -> Exp b -> RootExp c, Int)     traverseFun2 = makeOccMapFun2 config accOccMap +    traverseAfun1 :: (Arrays a, Typeable b) => Level -> (Acc a -> Acc b) -> IO (Acc a -> UnscopedAcc b, Int)+    traverseAfun1 = makeOccMapAfun1 config accOccMap+     traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int)     traverseExp = makeOccMapExp config accOccMap -    traverseAcc :: forall arrs. Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, Int)+    traverseAcc :: forall arrs. Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)     traverseAcc lvl acc@(Acc pacc)       = mfix $ \ ~(_, height) -> do           -- Compute stable name and enter it into the occurrence map@@ -964,14 +990,14 @@           --     case we cannot discharge the 'Arrays arrs' constraint.           --           let reconstruct :: Arrays arrs-                          => IO (PreAcc SharingAcc RootExp arrs, Int)-                          -> IO (SharingAcc arrs, Int)+                          => IO (PreAcc UnscopedAcc RootExp arrs, Int)+                          -> IO (UnscopedAcc arrs, Int)               reconstruct newAcc                 = case heightIfRepeatedOccurrence of                     Just height | recoverAccSharing config-                      -> return (AvarSharing (StableNameHeight sn height), height)+                      -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height)), height)                     _ -> do (acc, height) <- newAcc-                            return (AccSharing (StableNameHeight sn height) acc, height)+                            return (UnscopedAcc [] (AccSharing (StableNameHeight sn height) acc), height)            case pacc of             Atag i                      -> reconstruct $ return (Atag i, 0)           -- height is 0!@@ -982,6 +1008,12 @@                                              (acc1', h2) <- traverseAcc lvl acc1                                              (acc2', h3) <- traverseAcc lvl acc2                                              return (Acond e' acc1' acc2', h1 `max` h2 `max` h3 + 1)+            Awhile pred iter init       -> reconstruct $ do+                                             (pred', h1) <- traverseAfun1 lvl pred+                                             (iter', h2) <- traverseAfun1 lvl iter+                                             (init', h3) <- traverseAcc lvl init+                                             return (Awhile pred' iter' init'+                                                    , h1 `max` h2 `max` h3 + 1)              Atuple tup                  -> reconstruct $ do                                              (tup', h) <- travAtup tup@@ -1046,16 +1078,16 @@        where         travA :: Arrays arrs'-              => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)-              -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int)+              => (UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)+              -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)         travA c acc           = do               (acc', h) <- traverseAcc lvl acc               return (c acc', h + 1)          travEA :: (Typeable b, Arrays arrs')-               => (RootExp b -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)-               -> Exp b -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int)+               => (RootExp b -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)+               -> Exp b -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)         travEA c exp acc           = do               (exp', h1) <- traverseExp lvl exp@@ -1063,10 +1095,10 @@               return (c exp' acc', h1 `max` h2 + 1)          travF2A :: (Elt b, Elt c, Typeable d, Arrays arrs')-                => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs'-                    -> PreAcc SharingAcc RootExp arrs)+                => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs'+                    -> PreAcc UnscopedAcc RootExp arrs)                 -> (Exp b -> Exp c -> Exp d) -> Acc arrs'-                -> IO (PreAcc SharingAcc RootExp arrs, Int)+                -> IO (PreAcc UnscopedAcc RootExp arrs, Int)         travF2A c fun acc           = do               (fun', h1) <- traverseFun2 lvl fun@@ -1074,9 +1106,9 @@               return (c fun' acc', h1 `max` h2 + 1)          travF2EA :: (Elt b, Elt c, Typeable d, Typeable e, Arrays arrs')-                 => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)+                 => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)                  -> (Exp b -> Exp c -> Exp d) -> Exp e -> Acc arrs'-                 -> IO (PreAcc SharingAcc RootExp arrs, Int)+                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)         travF2EA c fun exp acc           = do               (fun', h1) <- traverseFun2 lvl fun@@ -1085,9 +1117,9 @@               return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1)          travF2A2 :: (Elt b, Elt c, Typeable d, Arrays arrs1, Arrays arrs2)-                 => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs1 -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs)+                 => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreAcc UnscopedAcc RootExp arrs)                  -> (Exp b -> Exp c -> Exp d) -> Acc arrs1 -> Acc arrs2-                 -> IO (PreAcc SharingAcc RootExp arrs, Int)+                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)         travF2A2 c fun acc1 acc2           = do               (fun' , h1) <- traverseFun2 lvl fun@@ -1096,14 +1128,26 @@               return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1)          travAtup :: Tuple.Atuple Acc a-                 -> IO (Tuple.Atuple SharingAcc a, Int)+                 -> IO (Tuple.Atuple UnscopedAcc a, Int)         travAtup NilAtup          = return (NilAtup, 1)         travAtup (SnocAtup tup a) = do           (tup', h1) <- travAtup tup           (a',   h2) <- traverseAcc lvl a           return (SnocAtup tup' a', h1 `max` h2 + 1) +makeOccMapAfun1 :: (Arrays a, Typeable b)+                => Config+                -> OccMapHash Acc+                -> Level+                -> (Acc a -> Acc b)+                -> IO (Acc a -> UnscopedAcc b, Int)+makeOccMapAfun1 config accOccMap lvl f = do+  let x = Acc (Atag lvl)+  --+  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+1) (f x)+  return (const (UnscopedAcc [lvl] body), height) + -- Generate occupancy information for scalar functions and expressions. Helper -- functions wrapping around 'makeOccMapRootExp' with more specific types. --@@ -1195,11 +1239,11 @@     -> IO (RootExp e, Int) makeOccMapRootExp config accOccMap lvl fvs exp = do   traceLine "makeOccMapRootExp" "Enter"-  expOccMap             <- newASTHashTable-  (exp', height)        <- makeOccMapSharingExp config accOccMap expOccMap lvl exp-  frozenExpOccMap       <- freezeOccMap expOccMap+  expOccMap                     <- newASTHashTable+  (UnscopedExp [] exp', height) <- makeOccMapSharingExp config accOccMap expOccMap lvl exp+  frozenExpOccMap               <- freezeOccMap expOccMap   traceLine "makeOccMapRootExp" "Exit"-  return (OccMapExp fvs frozenExpOccMap exp', height)+  return (RootExp frozenExpOccMap (UnscopedExp fvs exp'), height)   -- Generate sharing information for an open scalar expression.@@ -1211,10 +1255,10 @@     -> OccMapHash Exp     -> Level                            -- The level of currently bound variables     -> Exp e-    -> IO (SharingExp e, Int)+    -> IO (UnscopedExp e, Int) makeOccMapSharingExp config accOccMap expOccMap = travE   where-    travE :: forall a. Typeable a => Level -> Exp a -> IO (SharingExp a, Int)+    travE :: forall a. Typeable a => Level -> Exp a -> IO (UnscopedExp a, Int)     travE lvl exp@(Exp pexp)       = mfix $ \ ~(_, height) -> do           -- Compute stable name and enter it into the occurrence map@@ -1237,14 +1281,14 @@           --     case we cannot discharge the 'Elt a' constraint.           --           let reconstruct :: Elt a-                          => IO (PreExp SharingAcc SharingExp a, Int)-                          -> IO (SharingExp a, Int)+                          => IO (PreExp UnscopedAcc UnscopedExp a, Int)+                          -> IO (UnscopedExp a, Int)               reconstruct newExp                 = case heightIfRepeatedOccurrence of                     Just height | recoverExpSharing config-                      -> return (VarSharing (StableNameHeight sn height), height)+                      -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height)), height)                     _ -> do (exp, height) <- newExp-                            return (ExpSharing (StableNameHeight sn height) exp, height)+                            return (UnscopedExp [] (ExpSharing (StableNameHeight sn height) exp), height)            case pexp of             Tag i               -> reconstruct $ return (Tag i, 0)      -- height is 0!@@ -1261,31 +1305,48 @@             ToIndex sh ix       -> reconstruct $ travE2 ToIndex sh ix             FromIndex sh e      -> reconstruct $ travE2 FromIndex sh e             Cond e1 e2 e3       -> reconstruct $ travE3 Cond e1 e2 e3+            While p iter init   -> reconstruct $ do+                                     (p'   , h1) <- traverseFun1 lvl p+                                     (iter', h2) <- traverseFun1 lvl iter+                                     (init', h3) <- travE lvl init+                                     return (While p' iter' init', h1 `max` h2 `max` h3 + 1)             PrimConst c         -> reconstruct $ return (PrimConst c, 1)             PrimApp p e         -> reconstruct $ travE1 (PrimApp p) e             Index a e           -> reconstruct $ travAE Index a e             LinearIndex a i     -> reconstruct $ travAE LinearIndex a i             Shape a             -> reconstruct $ travA Shape a             ShapeSize e         -> reconstruct $ travE1 ShapeSize e+            Intersect sh1 sh2   -> reconstruct $ travE2 Intersect sh1 sh2             Foreign ff f e      -> reconstruct $ do                                       (e', h) <- travE lvl e                                       return  (Foreign ff f e', h+1)        where-        traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, Int)+        traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)         traverseAcc = makeOccMapSharingAcc config accOccMap -        travE1 :: Typeable b => (SharingExp b -> PreExp SharingAcc SharingExp a) -> Exp b-               -> IO (PreExp SharingAcc SharingExp a, Int)+        traverseFun1 :: (Elt a, Typeable b)+                     => Level+                     -> (Exp a -> Exp b)+                     -> IO (Exp a -> UnscopedExp b, Int)+        traverseFun1 lvl f+          = do+              let x = Exp (Tag lvl)+              (UnscopedExp [] body, height) <- travE (lvl+1) (f x)+              return (const (UnscopedExp [lvl] body), height + 1)+++        travE1 :: Typeable b => (UnscopedExp b -> PreExp UnscopedAcc UnscopedExp a) -> Exp b+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)         travE1 c e           = do               (e', h) <- travE lvl e               return (c e', h + 1)          travE2 :: (Typeable b, Typeable c)-               => (SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp a)+               => (UnscopedExp b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)                -> Exp b -> Exp c-               -> IO (PreExp SharingAcc SharingExp a, Int)+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)         travE2 c e1 e2           = do               (e1', h1) <- travE lvl e1@@ -1293,9 +1354,9 @@               return (c e1' e2', h1 `max` h2 + 1)          travE3 :: (Typeable b, Typeable c, Typeable d)-               => (SharingExp b -> SharingExp c -> SharingExp d -> PreExp SharingAcc SharingExp a)+               => (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> PreExp UnscopedAcc UnscopedExp a)                -> Exp b -> Exp c -> Exp d-               -> IO (PreExp SharingAcc SharingExp a, Int)+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)         travE3 c e1 e2 e3           = do               (e1', h1) <- travE lvl e1@@ -1303,24 +1364,24 @@               (e3', h3) <- travE lvl e3               return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1) -        travA :: Typeable b => (SharingAcc b -> PreExp SharingAcc SharingExp a) -> Acc b-              -> IO (PreExp SharingAcc SharingExp a, Int)+        travA :: Typeable b => (UnscopedAcc b -> PreExp UnscopedAcc UnscopedExp a) -> Acc b+              -> IO (PreExp UnscopedAcc UnscopedExp a, Int)         travA c acc           = do               (acc', h) <- traverseAcc lvl acc               return (c acc', h + 1)          travAE :: (Typeable b, Typeable c)-               => (SharingAcc b -> SharingExp c -> PreExp SharingAcc SharingExp a)+               => (UnscopedAcc b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)                -> Acc b -> Exp c-               -> IO (PreExp SharingAcc SharingExp a, Int)+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)         travAE c acc e           = do               (acc', h1) <- traverseAcc lvl acc               (e'  , h2) <- travE lvl e               return (c acc' e', h1 `max` h2 + 1) -        travTup :: Tuple.Tuple Exp tup -> IO (Tuple.Tuple SharingExp tup, Int)+        travTup :: Tuple.Tuple Exp tup -> IO (Tuple.Tuple UnscopedExp tup, Int)         travTup NilTup          = return (NilTup, 1)         travTup (SnocTup tup e) = do                                     (tup', h1) <- travTup tup@@ -1328,11 +1389,13 @@                                     return (SnocTup tup' e', h1 `max` h2 + 1)  --- Type used to maintain how often each shared subterm, so far, occurred during a bottom-up sweep.+-- Type used to maintain how often each shared subterm, so far, occurred during a bottom-up sweep,+-- as well as the relation between subterms. It is comprised of a list of terms and a graph giving+-- their relation. -----   Invariants:+--   Invariants of the list: --   - If one shared term 's' is itself a subterm of another shared term 't', then 's' must occur---     *after* 't' in the 'NodeCounts'.+--     *after* 't' in the list. --   - No shared term occurs twice. --   - A term may have a final occurrence count of only 1 iff it is either a free variable ('Atag' --     or 'Tag') or an array computation lifted out of an expression.@@ -1344,11 +1407,31 @@ -- is 0, whereas other leaves have height 1.  This guarantees that all free variables are at the end -- of the 'NodeCounts' list. ----- To ensure the invariant is preserved over merging node counts from sibling subterms, the--- function '(+++)' must be used.+-- The graph is represented as a map where a stable name 'a' is mapped to a set of stables names 'b'+-- such that if there exists a edge from 'a' to 'c' that 'c' is contained within 'b'. ---type NodeCounts = [NodeCount]+--  Properties of the graph:+--  - There exists an edge from 'a' to 'b' if the term 'a' names is a subterm of the term named by+--    'b'.+--+-- To ensure the list invariant and the graph properties are preserved over merging node counts from+-- sibling subterms, the function '(+++)' must be used.+--+type NodeCounts = ([NodeCount], Map.HashMap NodeName (Set.HashSet NodeName)) +data NodeName where+  NodeName :: Typeable a => StableName a -> NodeName++instance Eq NodeName where+  (NodeName sn1) == (NodeName sn2) | Just sn2' <- gcast sn2 = sn1 == sn2'+                                   | otherwise              = False++instance Hashable NodeName where+  hashWithSalt hash (NodeName sn1) = hash + hashStableName sn1++instance Show NodeName where+  show (NodeName sn) = show (hashStableName sn)+ data NodeCount = AccNodeCount StableSharingAcc Int                | ExpNodeCount StableSharingExp Int                deriving Show@@ -1356,27 +1439,55 @@ -- Empty node counts -- noNodeCounts :: NodeCounts-noNodeCounts = []+noNodeCounts = ([], Map.empty) --- Singleton node counts for 'Acc'+-- Insert an Acc node into the node counts, assuming that it is a superterm of the all the existing+-- nodes. ---accNodeCount :: StableSharingAcc -> Int -> NodeCounts-accNodeCount ssa n = [AccNodeCount ssa n]+-- TODO: Perform cycle detection here.+insertAccNode :: StableSharingAcc -> NodeCounts -> NodeCounts+insertAccNode ssa@(StableSharingAcc (StableNameHeight sn _) _) (subterms,g)+  = ([AccNodeCount ssa 1], g') +++ (subterms,g)+  where+    k  = NodeName sn+    hs = map nodeName subterms+    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs] --- Singleton node counts for 'Exp'+-- Insert an Exp node into the node counts, assuming that it is a superterm of the all the existing+-- nodes. ---expNodeCount :: StableSharingExp -> Int -> NodeCounts-expNodeCount sse n = [ExpNodeCount sse n]+-- TODO: Perform cycle detection here.+insertExpNode :: StableSharingExp -> NodeCounts -> NodeCounts+insertExpNode ssa@(StableSharingExp (StableNameHeight sn _) _) (subterms,g)+  = ([ExpNodeCount ssa 1], g') +++ (subterms,g)+  where+    k  = NodeName sn+    hs = map nodeName subterms+    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs] +-- Remove nodes that aren't in the list from the graph.+--+-- RCE: This is no longer necessary when NDP is supported.+cleanCounts :: NodeCounts -> NodeCounts+cleanCounts (ns, g) = (ns, Map.fromList $ [(h, Set.filter (flip elem hs) (g Map.! h)) | h <- hs ])+  where+    hs = (map nodeName ns)++nodeName :: NodeCount -> NodeName+nodeName (AccNodeCount (StableSharingAcc (StableNameHeight sn _) _) _) = NodeName sn+nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeName sn+ -- Combine node counts that belong to the same node. ----- * We assume that the node counts invariant —subterms follow their parents— holds for both---   arguments and guarantee that it still holds for the result.+-- * We assume that the list invariant —subterms follow their parents— holds for both arguments and+--   guarantee that it still holds for the result. -- * In the same manner, we assume that all 'Exp' node counts precede 'Acc' node counts and --   guarantee that this also hold for the result. --+-- RCE: The list combination should be able to be performed as a more efficient merge.+-- (+++) :: NodeCounts -> NodeCounts -> NodeCounts-us +++ vs = foldr insert us vs+(ns1,g1) +++ (ns2,g2) = (foldr insert ns1 ns2, Map.unionWith Set.union g1 g2)   where     insert x               []                         = [x]     insert x@(AccNodeCount sa1 count1) ys@(y@(AccNodeCount sa2 count2) : ys')@@ -1422,7 +1533,7 @@           $ "Encountered a node that is not a plain 'Atag'\n  " ++ showSA sa          noStableSharing :: StableSharingAcc-        noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc ())+        noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ())      showSA (StableSharingAcc _ (AccSharing  sn acc)) = show (hashStableNameHeight sn) ++ ": " ++                                                        showPreAccOp acc@@ -1453,7 +1564,7 @@               ("Encountered a node that is not a plain 'Tag'\n  " ++ showSE se)          noStableSharing :: StableSharingExp-        noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp ())+        noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp acc exp ())      showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++                                                       showPreExpOp exp@@ -1487,10 +1598,10 @@     => Config     -> [Level]     -> OccMap Acc-    -> SharingAcc a-    -> (SharingAcc a, [StableSharingAcc])+    -> UnscopedAcc a+    -> (ScopedAcc a, [StableSharingAcc]) determineScopesAcc config fvs accOccMap rootAcc-  = let (sharingAcc, counts) = determineScopesSharingAcc config accOccMap rootAcc+  = let (sharingAcc, (counts, _)) = determineScopesSharingAcc config accOccMap rootAcc         unboundTrees         = filter (not . isFreeVar) counts     in     if all isFreeVar counts@@ -1501,18 +1612,18 @@ determineScopesSharingAcc     :: Config     -> OccMap Acc-    -> SharingAcc a-    -> (SharingAcc a, NodeCounts)+    -> UnscopedAcc a+    -> (ScopedAcc a, NodeCounts) determineScopesSharingAcc config accOccMap = scopesAcc   where-    scopesAcc :: forall arrs. SharingAcc arrs -> (SharingAcc arrs, NodeCounts)-    scopesAcc (AletSharing _ _)+    scopesAcc :: forall arrs. UnscopedAcc arrs -> (ScopedAcc arrs, NodeCounts)+    scopesAcc (UnscopedAcc _ (AletSharing _ _))       = INTERNAL_ERROR(error) "determineScopesSharingAcc: scopesAcc" "unexpected 'AletSharing'" -    scopesAcc sharingAcc@(AvarSharing sn)-      = (sharingAcc, StableSharingAcc sn sharingAcc `accNodeCount` 1)+    scopesAcc (UnscopedAcc _ (AvarSharing sn))+      = (ScopedAcc [] (AvarSharing sn), StableSharingAcc sn (AvarSharing sn) `insertAccNode` noNodeCounts) -    scopesAcc (AccSharing sn pacc)+    scopesAcc (UnscopedAcc _ (AccSharing sn pacc))       = case pacc of           Atag i                  -> reconstruct (Atag i) noNodeCounts           Pipe afun1 afun2 acc    -> travA (Pipe afun1 afun2) acc@@ -1529,6 +1640,14 @@                                      reconstruct (Acond e' acc1' acc2')                                                  (accCount1 +++ accCount2 +++ accCount3) +          Awhile pred iter init   -> let+                                       (pred', accCount1) = scopesAfun1 pred+                                       (iter', accCount2) = scopesAfun1 iter+                                       (init', accCount3) = scopesAcc init+                                     in+                                     reconstruct (Awhile pred' iter' init')+                                                 (accCount1 +++ accCount2 +++ accCount3)+           Atuple tup              -> let (tup', accCount) = travAtup tup                                      in  reconstruct (Atuple tup') accCount           Aprj ix a               -> travA (Aprj ix) a@@ -1599,33 +1718,33 @@                                        (accCount1 +++ accCount2 +++ accCount3)       where         travEA :: Arrays arrs-               => (RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)+               => (ScopedExp e -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)                -> RootExp e-               -> SharingAcc arrs'-               -> (SharingAcc arrs, NodeCounts)+               -> UnscopedAcc arrs'+               -> (ScopedAcc arrs, NodeCounts)         travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2)           where             (e'  , accCount1) = scopesExp e             (acc', accCount2) = scopesAcc acc          travF2A :: (Elt a, Elt b, Arrays arrs)-                => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs'-                    -> PreAcc SharingAcc RootExp arrs)+                => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs'+                    -> PreAcc ScopedAcc ScopedExp arrs)                 -> (Exp a -> Exp b -> RootExp c)-                -> SharingAcc arrs'-                -> (SharingAcc arrs, NodeCounts)+                -> UnscopedAcc arrs'+                -> (ScopedAcc arrs, NodeCounts)         travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2)           where             (f'  , accCount1) = scopesFun2 f             (acc', accCount2) = scopesAcc  acc          travF2EA :: (Elt a, Elt b, Arrays arrs)-                 => ((Exp a -> Exp b -> RootExp c) -> RootExp e-                     -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)+                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedExp e+                     -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)                  -> (Exp a -> Exp b -> RootExp c)                  -> RootExp e-                 -> SharingAcc arrs'-                 -> (SharingAcc arrs, NodeCounts)+                 -> UnscopedAcc arrs'+                 -> (ScopedAcc arrs, NodeCounts)         travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3)           where             (f'  , accCount1) = scopesFun2 f@@ -1633,12 +1752,12 @@             (acc', accCount3) = scopesAcc  acc          travF2A2 :: (Elt a, Elt b, Arrays arrs)-                 => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs1-                     -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs)+                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs1+                     -> ScopedAcc arrs2 -> PreAcc ScopedAcc ScopedExp arrs)                  -> (Exp a -> Exp b -> RootExp c)-                 -> SharingAcc arrs1-                 -> SharingAcc arrs2-                 -> (SharingAcc arrs, NodeCounts)+                 -> UnscopedAcc arrs1+                 -> UnscopedAcc arrs2+                 -> (ScopedAcc arrs, NodeCounts)         travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2')                                              (accCount1 +++ accCount2 +++ accCount3)           where@@ -1646,8 +1765,8 @@             (acc1', accCount2) = scopesAcc  acc1             (acc2', accCount3) = scopesAcc  acc2 -        travAtup ::  Tuple.Atuple SharingAcc a-                 -> (Tuple.Atuple SharingAcc a, NodeCounts)+        travAtup ::  Tuple.Atuple UnscopedAcc a+                 -> (Tuple.Atuple ScopedAcc a, NodeCounts)         travAtup NilAtup          = (NilAtup, noNodeCounts)         travAtup (SnocAtup tup a) = let (tup', accCountT) = travAtup tup                                         (a',   accCountA) = scopesAcc a@@ -1655,9 +1774,9 @@                                     (SnocAtup tup' a', accCountT +++ accCountA)          travA :: Arrays arrs-              => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)-              -> SharingAcc arrs'-              -> (SharingAcc arrs, NodeCounts)+              => (ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)+              -> UnscopedAcc arrs'+              -> (ScopedAcc arrs, NodeCounts)         travA c acc = reconstruct (c acc') accCount           where             (acc', accCount) = scopesAcc acc@@ -1680,32 +1799,32 @@         -- node.         --         reconstruct :: Arrays arrs-                    => PreAcc SharingAcc RootExp arrs -> NodeCounts-                    -> (SharingAcc arrs, NodeCounts)+                    => PreAcc ScopedAcc ScopedExp arrs -> NodeCounts+                    -> (ScopedAcc arrs, NodeCounts)         reconstruct newAcc@(Atag _) _subCount               -- free variable => replace by a sharing variable regardless of the number of               -- occurrences-          = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `accNodeCount` 1+          = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `insertAccNode` noNodeCounts             in             tracePure "FREE" (show thisCount)-            (AvarSharing sn, thisCount)+            (ScopedAcc [] (AvarSharing sn), thisCount)         reconstruct newAcc subCount               -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled)           | accOccCount > 1 && recoverAccSharing config-          = let allCount = (StableSharingAcc sn sharingAcc `accNodeCount` 1) +++ newCount+          = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount)             in             tracePure ("SHARED" ++ completed) (show allCount)-            (AvarSharing sn, allCount)+            (ScopedAcc [] (AvarSharing sn), allCount)               -- neither shared nor free variable => leave it as it is           | otherwise           = tracePure ("Normal" ++ completed) (show newCount)-            (sharingAcc, newCount)+            (ScopedAcc [] sharingAcc, newCount)           where               -- Determine the bindings that need to be attached to the current node...             (newCount, bindHere) = filterCompleted subCount                -- ...and wrap them in 'AletSharing' constructors-            lets       = foldl (flip (.)) id . map AletSharing $ bindHere+            lets       = foldl (flip (.)) id . map (\x y -> AletSharing x (ScopedAcc [] y)) $ bindHere             sharingAcc = lets $ AccSharing sn newAcc                -- trace support@@ -1722,23 +1841,46 @@         --     scope errors.         --         filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc])-        filterCompleted counts-          = let (completed, counts') = break notComplete counts-            in (counts', [sa | AccNodeCount sa _ <- completed])+        filterCompleted (ns, graph)+          = let bindable     = map (isBindable bindable (map nodeName ns)) ns+                (bind, rest) = partition fst $ zip bindable ns+            in ((map snd rest, graph), [sa | AccNodeCount sa _ <- map snd bind])           where             -- a node is not yet complete while the node count 'n' is below the overall number             -- of occurrences for that node in the whole program, with the exception that free             -- variables are never complete-            notComplete nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa > n-            notComplete _                                             = True+            isCompleted nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa == n+            isCompleted _                                             = False -    scopesExp :: RootExp t -> (RootExp t, NodeCounts)+            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool+            isBindable bindable nodes nc@(AccNodeCount _ _) =+              let superTerms = Set.toList $ graph Map.! nodeName nc+                  unbound    = mapMaybe (`elemIndex` nodes) superTerms+              in    isCompleted nc+                 && all (bindable !!) unbound+            isBindable _ _ (ExpNodeCount _ _) = False++    scopesExp :: RootExp t -> (ScopedExp t, NodeCounts)     scopesExp = determineScopesExp config accOccMap      -- The lambda bound variable is at this point already irrelevant; for details, see     -- Note [Traversing functions and side effects]     ---    scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> RootExp e2, NodeCounts)+    scopesAfun1 :: Arrays a1 => (Acc a1 -> UnscopedAcc a2) -> (Acc a1 -> ScopedAcc a2, NodeCounts)+    scopesAfun1 f = (const (ScopedAcc ssa body'), (counts',graph))+      where+        body@(UnscopedAcc fvs _) = f undefined+        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body+        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]+        (freeCounts, counts') = partition isBoundHere counts++        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs+        isBoundHere _                                                             = False++    -- The lambda bound variable is at this point already irrelevant; for details, see+    -- Note [Traversing functions and side effects]+    --+    scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> ScopedExp e2, NodeCounts)     scopesFun1 f = (const body, counts)       where         (body, counts) = scopesExp (f undefined)@@ -1748,7 +1890,7 @@     --     scopesFun2 :: (Elt e1, Elt e2)                => (Exp e1 -> Exp e2 -> RootExp e3)-               -> (Exp e1 -> Exp e2 -> RootExp e3, NodeCounts)+               -> (Exp e1 -> Exp e2 -> ScopedExp e3, NodeCounts)     scopesFun2 f = (\_ _ -> body, counts)       where         (body, counts) = scopesExp (f undefined undefined)@@ -1757,9 +1899,9 @@     -- Note [Traversing functions and side effects]     --     scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil-                   => SharingAcc (Array sh e1){-dummy-}+                   => UnscopedAcc (Array sh e1){-dummy-}                    -> (stencil -> RootExp e2)-                   -> (stencil -> RootExp e2, NodeCounts)+                   -> (stencil -> ScopedExp e2, NodeCounts)     scopesStencil1 _ stencilFun = (const body, counts)       where         (body, counts) = scopesExp (stencilFun undefined)@@ -1769,10 +1911,10 @@     --     scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2.                       (Stencil sh e1 stencil1, Stencil sh e2 stencil2)-                   => SharingAcc (Array sh e1){-dummy-}-                   -> SharingAcc (Array sh e2){-dummy-}+                   => UnscopedAcc (Array sh e1){-dummy-}+                   -> UnscopedAcc (Array sh e2){-dummy-}                    -> (stencil1 -> stencil2 -> RootExp e3)-                   -> (stencil1 -> stencil2 -> RootExp e3, NodeCounts)+                   -> (stencil1 -> stencil2 -> ScopedExp e3, NodeCounts)     scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts)       where         (body, counts) = scopesExp (stencilFun undefined undefined)@@ -1782,63 +1924,79 @@     :: Config     -> OccMap Acc     -> RootExp t-    -> (RootExp t, NodeCounts)          -- Root (closed) expression plus Acc node counts-determineScopesExp config accOccMap (OccMapExp fvs expOccMap exp)+    -> (ScopedExp t, NodeCounts)          -- Root (closed) expression plus Acc node counts+determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _))   = let-        (expWithScopes, nodeCounts)     = determineScopesSharingExp config accOccMap expOccMap exp+        ((ScopedExp [] expWithScopes), (nodeCounts,graph)) = determineScopesSharingExp config accOccMap expOccMap exp         (expCounts, accCounts)          = break isAccNodeCount nodeCounts          isAccNodeCount AccNodeCount{}   = True         isAccNodeCount _                = False     in-    (EnvExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, accCounts)--determineScopesExp _ _ _ = INTERNAL_ERROR(error) "determineScopesExp" "not an 'OccMapExp'"+    (ScopedExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, cleanCounts (accCounts,graph))   determineScopesSharingExp     :: Config     -> OccMap Acc     -> OccMap Exp-    -> SharingExp t-    -> (SharingExp t, NodeCounts)+    -> UnscopedExp t+    -> (ScopedExp t, NodeCounts) determineScopesSharingExp config accOccMap expOccMap = scopesExp   where-    scopesAcc :: SharingAcc a -> (SharingAcc a, NodeCounts)+    scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts)     scopesAcc = determineScopesSharingAcc config accOccMap -    scopesExp :: forall t. SharingExp t -> (SharingExp t, NodeCounts)-    scopesExp (LetSharing _ _)+    scopesFun1 :: (Exp a -> UnscopedExp b) -> (Exp a -> ScopedExp b, NodeCounts)+    scopesFun1 f = tracePure ("LAMBDA " ++ (show ssa)) (show counts) (const (ScopedExp ssa body'), (counts',graph))+      where+        body@(UnscopedExp fvs _) = f undefined+        ((ScopedExp [] body'), (counts, graph)) = scopesExp body+        ssa     = buildInitialEnvExp fvs [se | ExpNodeCount se _ <- freeCounts]+        (freeCounts, counts') = partition isBoundHere counts++        isBoundHere (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag i))) _) = i `elem` fvs+        isBoundHere _                                                            = False+++    scopesExp :: forall t. UnscopedExp t -> (ScopedExp t, NodeCounts)+    scopesExp (UnscopedExp _ (LetSharing _ _))       = INTERNAL_ERROR(error) "determineScopesSharingExp: scopesExp" "unexpected 'LetSharing'" -    scopesExp sharingExp@(VarSharing sn)-      = (sharingExp, StableSharingExp sn sharingExp `expNodeCount` 1)+    scopesExp (UnscopedExp _ (VarSharing sn))+      = (ScopedExp [] (VarSharing sn), StableSharingExp sn (VarSharing sn) `insertExpNode` noNodeCounts) -    scopesExp (ExpSharing sn pexp)+    scopesExp (UnscopedExp _ (ExpSharing sn pexp))       = case pexp of-          Tag i           -> reconstruct (Tag i) noNodeCounts-          Const c         -> reconstruct (Const c) noNodeCounts-          Tuple tup       -> let (tup', accCount) = travTup tup-                             in-                             reconstruct (Tuple tup') accCount-          Prj i e         -> travE1 (Prj i) e-          IndexNil        -> reconstruct IndexNil noNodeCounts-          IndexCons ix i  -> travE2 IndexCons ix i-          IndexHead i     -> travE1 IndexHead i-          IndexTail ix    -> travE1 IndexTail ix-          IndexAny        -> reconstruct IndexAny noNodeCounts-          ToIndex sh ix   -> travE2 ToIndex sh ix-          FromIndex sh e  -> travE2 FromIndex sh e-          Cond e1 e2 e3   -> travE3 Cond e1 e2 e3-          PrimConst c     -> reconstruct (PrimConst c) noNodeCounts-          PrimApp p e     -> travE1 (PrimApp p) e-          Index a e       -> travAE Index a e-          LinearIndex a e -> travAE LinearIndex a e-          Shape a         -> travA Shape a-          ShapeSize e     -> travE1 ShapeSize e-          Foreign ff f e  -> travE1 (Foreign ff f) e+          Tag i                 -> reconstruct (Tag i) noNodeCounts+          Const c               -> reconstruct (Const c) noNodeCounts+          Tuple tup             -> let (tup', accCount) = travTup tup+                                   in+                                   reconstruct (Tuple tup') accCount+          Prj i e               -> travE1 (Prj i) e+          IndexNil              -> reconstruct IndexNil noNodeCounts+          IndexCons ix i        -> travE2 IndexCons ix i+          IndexHead i           -> travE1 IndexHead i+          IndexTail ix          -> travE1 IndexTail ix+          IndexAny              -> reconstruct IndexAny noNodeCounts+          ToIndex sh ix         -> travE2 ToIndex sh ix+          FromIndex sh e        -> travE2 FromIndex sh e+          Cond e1 e2 e3         -> travE3 Cond e1 e2 e3+          While p it i          -> let+                                     (p' , accCount1) = scopesFun1 p+                                     (it', accCount2) = scopesFun1 it+                                     (i' , accCount3) = scopesExp i+                                   in reconstruct (While p' it' i') (accCount1 +++ accCount2 +++ accCount3)+          PrimConst c           -> reconstruct (PrimConst c) noNodeCounts+          PrimApp p e           -> travE1 (PrimApp p) e+          Index a e             -> travAE Index a e+          LinearIndex a e       -> travAE LinearIndex a e+          Shape a               -> travA Shape a+          ShapeSize e           -> travE1 ShapeSize e+          Intersect sh1 sh2     -> travE2 Intersect sh1 sh2+          Foreign ff f e        -> travE1 (Foreign ff f) e       where-        travTup :: Tuple.Tuple SharingExp tup -> (Tuple.Tuple SharingExp tup, NodeCounts)+        travTup :: Tuple.Tuple UnscopedExp tup -> (Tuple.Tuple ScopedExp tup, NodeCounts)         travTup NilTup          = (NilTup, noNodeCounts)         travTup (SnocTup tup e) = let                                     (tup', accCountT) = travTup tup@@ -1846,64 +2004,64 @@                                   in                                   (SnocTup tup' e', accCountT +++ accCountE) -        travE1 :: (SharingExp a -> PreExp SharingAcc SharingExp t) -> SharingExp a-               -> (SharingExp t, NodeCounts)+        travE1 :: (ScopedExp a -> PreExp ScopedAcc ScopedExp t) -> UnscopedExp a+               -> (ScopedExp t, NodeCounts)         travE1 c e = reconstruct (c e') accCount           where             (e', accCount) = scopesExp e -        travE2 :: (SharingExp a -> SharingExp b -> PreExp SharingAcc SharingExp t)-               -> SharingExp a-               -> SharingExp b-               -> (SharingExp t, NodeCounts)+        travE2 :: (ScopedExp a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)+               -> UnscopedExp a+               -> UnscopedExp b+               -> (ScopedExp t, NodeCounts)         travE2 c e1 e2 = reconstruct (c e1' e2') (accCount1 +++ accCount2)           where             (e1', accCount1) = scopesExp e1             (e2', accCount2) = scopesExp e2 -        travE3 :: (SharingExp a -> SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp t)-               -> SharingExp a-               -> SharingExp b-               -> SharingExp c-               -> (SharingExp t, NodeCounts)+        travE3 :: (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreExp ScopedAcc ScopedExp t)+               -> UnscopedExp a+               -> UnscopedExp b+               -> UnscopedExp c+               -> (ScopedExp t, NodeCounts)         travE3 c e1 e2 e3 = reconstruct (c e1' e2' e3') (accCount1 +++ accCount2 +++ accCount3)           where             (e1', accCount1) = scopesExp e1             (e2', accCount2) = scopesExp e2             (e3', accCount3) = scopesExp e3 -        travA :: (SharingAcc a -> PreExp SharingAcc SharingExp t) -> SharingAcc a-              -> (SharingExp t, NodeCounts)+        travA :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t) -> UnscopedAcc a+              -> (ScopedExp t, NodeCounts)         travA c acc = maybeFloatOutAcc c acc' accCount           where             (acc', accCount)  = scopesAcc acc -        travAE :: (SharingAcc a -> SharingExp b -> PreExp SharingAcc SharingExp t)-               -> SharingAcc a-               -> SharingExp b-               -> (SharingExp t, NodeCounts)+        travAE :: (ScopedAcc a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)+               -> UnscopedAcc a+               -> UnscopedExp b+               -> (ScopedExp t, NodeCounts)         travAE c acc e = maybeFloatOutAcc (`c` e') acc' (accCountA +++ accCountE)           where             (acc', accCountA) = scopesAcc acc             (e'  , accCountE) = scopesExp e -        maybeFloatOutAcc :: (SharingAcc a -> PreExp SharingAcc SharingExp t)-                         -> SharingAcc a+        maybeFloatOutAcc :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t)+                         -> ScopedAcc a                          -> NodeCounts-                         -> (SharingExp t, NodeCounts)-        maybeFloatOutAcc c acc@(AvarSharing _) accCount        -- nothing to float out+                         -> (ScopedExp t, NodeCounts)+        maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _)) accCount        -- nothing to float out           = reconstruct (c acc) accCount         maybeFloatOutAcc c acc                 accCount-          | floatOutAcc config = reconstruct (c var) ((stableAcc `accNodeCount` 1) +++ accCount)+          | floatOutAcc config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount)           | otherwise          = reconstruct (c acc) accCount           where-             (var, stableAcc) = abstract acc id+             (var, stableAcc) = abstract acc (\(ScopedAcc _ s) -> s) -        abstract :: SharingAcc a -> (SharingAcc a -> SharingAcc a)-                 -> (SharingAcc a, StableSharingAcc)-        abstract (AvarSharing _)       _    = INTERNAL_ERROR(error) "sharingAccToVar" "AvarSharing"-        abstract (AletSharing sa acc)  lets = abstract acc (lets . AletSharing sa)-        abstract acc@(AccSharing sn _) lets = (AvarSharing sn, StableSharingAcc sn (lets acc))+        abstract :: ScopedAcc a -> (ScopedAcc a -> SharingAcc ScopedAcc ScopedExp a)+                 -> (ScopedAcc a, StableSharingAcc)+        abstract (ScopedAcc _ (AvarSharing _))       _      = INTERNAL_ERROR(error) "sharingAccToVar" "AvarSharing"+        abstract (ScopedAcc ssa (AletSharing sa acc))  lets = abstract acc (lets . (\x -> ScopedAcc ssa (AletSharing sa x)))+        abstract acc@(ScopedAcc ssa (AccSharing sn _)) lets = (ScopedAcc ssa (AvarSharing sn), StableSharingAcc sn (lets acc))          -- Occurrence count of the currently processed node         expOccCount = let StableNameHeight sn' _ = sn@@ -1922,32 +2080,32 @@         -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing'         -- node.         ---        reconstruct :: PreExp SharingAcc SharingExp t -> NodeCounts-                    -> (SharingExp t, NodeCounts)+        reconstruct :: PreExp ScopedAcc ScopedExp t -> NodeCounts+                    -> (ScopedExp t, NodeCounts)         reconstruct newExp@(Tag _) _subCount               -- free variable => replace by a sharing variable regardless of the number of               -- occurrences-          = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `expNodeCount` 1+          = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `insertExpNode` noNodeCounts             in             tracePure "FREE" (show thisCount)-            (VarSharing sn, thisCount)+            (ScopedExp [] (VarSharing sn), thisCount)         reconstruct newExp subCount               -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled)           | expOccCount > 1 && recoverExpSharing config-          = let allCount = (StableSharingExp sn sharingExp `expNodeCount` 1) +++ newCount+          = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount             in             tracePure ("SHARED" ++ completed) (show allCount)-            (VarSharing sn, allCount)+            (ScopedExp [] (VarSharing sn), allCount)               -- neither shared nor free variable => leave it as it is           | otherwise           = tracePure ("Normal" ++ completed) (show newCount)-            (sharingExp, newCount)+            (ScopedExp [] sharingExp, newCount)           where               -- Determine the bindings that need to be attached to the current node...             (newCount, bindHere) = filterCompleted subCount                -- ...and wrap them in 'LetSharing' constructors-            lets       = foldl (flip (.)) id . map LetSharing $ bindHere+            lets       = foldl (flip (.)) id . map (\x y -> LetSharing x (ScopedExp [] y)) $ bindHere             sharingExp = lets $ ExpSharing sn newExp                -- trace support@@ -1964,17 +2122,26 @@         --     scope errors.         --         filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp])-        filterCompleted counts-          = let (completed, counts') = break notComplete counts-            in (counts', [sa | ExpNodeCount sa _ <- completed])+        filterCompleted (ns,graph)+          = let bindable       = map (isBindable bindable (map nodeName ns)) ns+                (bind, unbind) = partition fst $ zip bindable ns+            in ((map snd unbind, graph), [se | ExpNodeCount se _ <- map snd bind])           where             -- a node is not yet complete while the node count 'n' is below the overall number             -- of occurrences for that node in the whole program, with the exception that free             -- variables are never complete-            notComplete nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa > n-            notComplete _                                             = True+            isCompleted nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa == n+            isCompleted _                                             = False +            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool+            isBindable bindable nodes nc@(ExpNodeCount _ _) =+              let superTerms = Set.toList $ graph Map.! nodeName nc+                  unbound    = mapMaybe (`elemIndex` nodes) superTerms+              in    isCompleted nc+                 && all (bindable !!) unbound+            isBindable _ _ (AccNodeCount _ _) = False + -- |Recover sharing information and annotate the HOAS AST with variable and let binding -- annotations.  The first argument determines whether array computations are floated out of -- expressions irrespective of whether they are shared or not — 'True' implies floating them out.@@ -1999,7 +2166,7 @@     -> Level            -- The level of currently bound array variables     -> [Level]          -- The tags of newly introduced free array variables     -> Acc a-    -> (SharingAcc a, [StableSharingAcc])+    -> (ScopedAcc a, [StableSharingAcc]) {-# NOINLINE recoverSharingAcc #-} recoverSharingAcc config alvl avars acc   = let (acc', occMap)@@ -2015,7 +2182,7 @@     -> Level            -- The level of currently bound scalar variables     -> [Level]          -- The tags of newly introduced free scalar variables     -> Exp e-    -> (SharingExp e, [StableSharingExp])+    -> (ScopedExp e, [StableSharingExp]) {-# NOINLINE recoverSharingExp #-} recoverSharingExp config lvl fvar exp   = let@@ -2026,10 +2193,10 @@            return (exp', frozenAccOccMap) -        (EnvExp sse sharingExp, _) =+        (ScopedExp sse sharingExp, _) =           determineScopesExp config accOccMap rootExp     in-    (sharingExp, sse)+    (ScopedExp [] sharingExp, sse)   -- Debugging@@ -2049,10 +2216,4 @@ tracePure header msg   = Debug.tracePure Debug.dump_sharing   $ header ++ ": " ++ msg---_showSharingAccOp :: SharingAcc arrs -> String-_showSharingAccOp (AvarSharing sn)    = "AVAR " ++ show (hashStableNameHeight sn)-_showSharingAccOp (AletSharing _ acc) = "ALET " ++ _showSharingAccOp acc-_showSharingAccOp (AccSharing _ acc)  = showPreAccOp acc
Data/Array/Accelerate/Trafo/Shrink.hs view
@@ -40,7 +40,6 @@ import Data.Array.Accelerate.AST import Data.Array.Accelerate.Tuple import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Array.Sugar                ( Arrays ) import Data.Array.Accelerate.Trafo.Substitution  import qualified Data.Array.Accelerate.Debug            as Stats@@ -109,7 +108,7 @@       ToIndex sh ix             -> ToIndex <$> shrinkE sh <*> shrinkE ix       FromIndex sh i            -> FromIndex <$> shrinkE sh <*> shrinkE i       Cond p t e                -> Cond <$> shrinkE p <*> shrinkE t <*> shrinkE e-      Iterate n f x             -> Iterate <$> shrinkE n <*> shrinkE f <*> shrinkE x+      While p f x               -> While <$> shrinkF p <*> shrinkF f <*> shrinkE x       PrimConst c               -> pure (PrimConst c)       PrimApp f x               -> PrimApp f <$> shrinkE x       Index a sh                -> Index a <$> shrinkE sh@@ -165,6 +164,7 @@       Apply f a                 -> Apply (shrinkAF f) (shrinkAcc a)       Aforeign ff af a          -> Aforeign ff af (shrinkAcc a)       Acond p t e               -> Acond (shrinkE p) (shrinkAcc t) (shrinkAcc e)+      Awhile p f a              -> Awhile (shrinkAF p) (shrinkAF f) (shrinkAcc a)       Use a                     -> Use a       Unit e                    -> Unit (shrinkE e)       Reshape e a               -> Reshape (shrinkE e) (shrinkAcc a)@@ -206,7 +206,7 @@       ToIndex sh ix             -> ToIndex (shrinkE sh) (shrinkE ix)       FromIndex sh i            -> FromIndex (shrinkE sh) (shrinkE i)       Cond p t e                -> Cond (shrinkE p) (shrinkE t) (shrinkE e)-      Iterate n f x             -> Iterate (shrinkE n) (shrinkE f) (shrinkE x)+      While p f x               -> While (shrinkF p) (shrinkF f) (shrinkE x)       PrimConst c               -> PrimConst c       PrimApp f x               -> PrimApp f (shrinkE x)       Index a sh                -> Index (shrinkAcc a) (shrinkE sh)@@ -242,8 +242,8 @@     -> UsesOfAcc acc     -> ReduceAcc acc basicReduceAcc unwrapAcc countAcc (unwrapAcc -> bnd) body@(unwrapAcc -> pbody)-  | Avar _ <- bnd       = Stats.inline "Avar"  . Just $ rebuildA rebuildAcc (subTop bnd) pbody-  | uses <= lIMIT       = Stats.betaReduce msg . Just $ rebuildA rebuildAcc (subTop bnd) pbody+  | Avar _ <- bnd       = Stats.inline "Avar"  . Just $ rebuildA rebuildAcc (subAtop bnd) pbody+  | uses <= lIMIT       = Stats.betaReduce msg . Just $ rebuildA rebuildAcc (subAtop bnd) pbody   | otherwise           = Nothing   where     -- If the bound variable is used at most this many times, it will be inlined@@ -258,11 +258,7 @@       0 -> "dead acc"       _ -> "inline acc"         -- forced inlining when lIMIT > 1 -    subTop :: Arrays t => PreOpenAcc acc aenv s -> Idx (aenv,s) t -> PreOpenAcc acc aenv t-    subTop t ZeroIdx       = t-    subTop _ (SuccIdx idx) = Avar idx - -- Occurrence Counting -- =================== @@ -292,7 +288,7 @@       ToIndex sh ix             -> countE sh + countE ix       FromIndex sh i            -> countE sh + countE i       Cond p t e                -> countE p  + countE t `max` countE e-      Iterate n f x             -> countE n  + countE x + usesOfExp (SuccIdx idx) f+      While p f x               -> countE x  + countF idx p + countF idx f       PrimConst _               -> 0       PrimApp _ x               -> countE x       Index _ sh                -> countE sh@@ -302,6 +298,10 @@       Intersect sh sz           -> countE sh + countE sz       Foreign _ _ e             -> countE e +    countF :: Idx env' s -> PreOpenFun acc env' aenv f -> Int+    countF idx' (Lam  f) = countF (SuccIdx idx') f+    countF idx' (Body b) = usesOfExp idx' b+     countT :: Tuple (PreOpenExp acc env aenv) e -> Int     countT NilTup        = 0     countT (SnocTup t e) = countT t + countE e@@ -334,6 +334,7 @@       Apply _ a                 -> countA a       Aforeign _ _ a            -> countA a       Acond p t e               -> countE p  + countA t `max` countA e+      Awhile _ _ a              -> countA a       Use _                     -> 0       Unit e                    -> countE e       Reshape e a               -> countE e  + countA a@@ -378,7 +379,7 @@       ToIndex sh ix             -> countE sh + countE ix       FromIndex sh i            -> countE sh + countE i       Cond p t e                -> countE p  + countE t + countE e-      Iterate n f x             -> countE n  + countE x + countE f+      While p f x               -> countF p  + countF f + countE x       PrimConst _               -> 0       PrimApp _ x               -> countE x       Index a sh                -> countA a + countE sh
Data/Array/Accelerate/Trafo/Simplify.hs view
@@ -24,6 +24,7 @@  -- standard library import Prelude                                          hiding ( exp, iterate )+import Data.List                                        ( nubBy ) import Data.Maybe import Data.Monoid import Data.Typeable@@ -31,7 +32,7 @@  -- friends import Data.Array.Accelerate.AST                        hiding ( prj )-import Data.Array.Accelerate.Type+-- import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Trafo.Base@@ -124,6 +125,9 @@     -> PreOpenExp acc env     aenv a     -> PreOpenExp acc (env,a) aenv b     -> Maybe (PreOpenExp acc env aenv b)+recoverLoops _ _ _+  = Nothing+{-- recoverLoops _ bnd e3   -- To introduce scaler loops, we look for expressions of the form:   --@@ -169,6 +173,7 @@                 -> PreOpenExp acc (env,t) aenv g                 -> Maybe (s :=: t)     matchEnvTop _ _ = gcast REFL+--}   -- Walk a scalar expression applying simplifications to terms bottom-up.@@ -210,7 +215,6 @@       ToIndex sh ix             -> ToIndex <$> cvtE sh <*> cvtE ix       FromIndex sh ix           -> FromIndex <$> cvtE sh <*> cvtE ix       Cond p t e                -> cond (cvtE p) (cvtE t) (cvtE e)-      Iterate n f x             -> Iterate <$> cvtE n <*> cvtE' (incExp env `PushExp` Var ZeroIdx) f <*> cvtE x       PrimConst c               -> pure $ PrimConst c       PrimApp f x               -> evalPrimApp env f <$> cvtE x       Index a sh                -> Index a <$> cvtE sh@@ -219,6 +223,7 @@       ShapeSize sh              -> ShapeSize <$> cvtE sh       Intersect s t             -> cvtE s `intersect` cvtE t       Foreign ff f e            -> Foreign ff <$> first Any (simplifyOpenFun EmptyExp f) <*> cvtE e+      While p f x               -> While <$> cvtF env p <*> cvtF env f <*> cvtE x      cvtT :: Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t)     cvtT NilTup        = pure NilTup@@ -227,16 +232,30 @@     cvtE' :: Gamma acc env' env' aenv -> PreOpenExp acc env' aenv e' -> (Any, PreOpenExp acc env' aenv e')     cvtE' env' = first Any . simplifyOpenExp env' -    -- If the head terms of a shape intersection match, avoid the intersection-    -- test and return the shape.+    cvtF :: Gamma acc env' env' aenv -> PreOpenFun acc env' aenv f -> (Any, PreOpenFun acc env' aenv f)+    cvtF env' = first Any . simplifyOpenFun env'++    -- Return the minimal set of unique shapes to intersect. This is a bit+    -- inefficient, but the number of shapes is expected to be small so should+    -- be fine in practice.     --     intersect :: Shape t               => (Any, PreOpenExp acc env aenv t)               -> (Any, PreOpenExp acc env aenv t)               -> (Any, PreOpenExp acc env aenv t)-    intersect sh1@(_,sh1') sh2@(_,sh2')-      | Just REFL <- match sh1' sh2' = Stats.ruleFired "intersect" (yes sh1')-      | otherwise                    = Intersect <$> sh1 <*> sh2+    intersect (c1, sh1) (c2, sh2)+      | Nothing <- match sh sh' = Stats.ruleFired "intersect" (yes sh')+      | otherwise               = (c1 <> c2, sh')+      where+        sh      = Intersect sh1 sh2+        sh'     = foldl1 Intersect+                $ nubBy (\x y -> isJust (match x y))+                $ leaves sh1 ++ leaves sh2++        leaves :: Shape t => PreOpenExp acc env aenv t -> [PreOpenExp acc env aenv t]+        leaves (Intersect x y)  = leaves x ++ leaves y+        leaves rest             = [rest]+      -- Simplify conditional expressions, in particular by eliminating branches     -- when the predicate is a known constant.
Data/Array/Accelerate/Trafo/Substitution.hs view
@@ -18,6 +18,7 @@    -- ** Renaming & Substitution   inline, substitute, compose,+  subTop, subAtop,    -- ** Weakening   (:>),@@ -76,10 +77,6 @@        -> PreOpenExp acc env      aenv s        -> PreOpenExp acc env      aenv t inline f g = Stats.substitution "inline" $ rebuildE (subTop g) f-  where-    subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc env aenv t-    subTop s ZeroIdx      = s-    subTop _ (SuccIdx ix) = Var ix  -- | Replace an expression that uses the top environment variable with another. -- The result of the first is let bound into the second.@@ -109,6 +106,15 @@ compose _              _              = error "compose: impossible evaluation"  +subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc env aenv t+subTop s ZeroIdx      = s+subTop _ (SuccIdx ix) = Var ix++subAtop :: Arrays t => PreOpenAcc acc aenv s -> Idx (aenv, s) t -> PreOpenAcc acc aenv t+subAtop t ZeroIdx       = t+subAtop _ (SuccIdx idx) = Avar idx++ -- NOTE: [Weakening] -- -- Weakening is something we usually take for granted: every time you learn a@@ -218,7 +224,7 @@     ToIndex sh ix       -> ToIndex (rebuildE v sh) (rebuildE v ix)     FromIndex sh ix     -> FromIndex (rebuildE v sh) (rebuildE v ix)     Cond p t e          -> Cond (rebuildE v p) (rebuildE v t) (rebuildE v e)-    Iterate n f x       -> Iterate (rebuildE v n) (rebuildE (shiftE v) f) (rebuildE v x)+    While p f x         -> While (rebuildFE v p) (rebuildFE v f) (rebuildE v x)     PrimConst c         -> PrimConst c     PrimApp f x         -> PrimApp f (rebuildE v x)     Index a sh          -> Index a (rebuildE v sh)@@ -308,6 +314,7 @@     Apply f a           -> Apply (rebuildAfun rebuild v f) (rebuild v a)     Aforeign ff afun as -> Aforeign ff afun (rebuild v as)     Acond p t e         -> Acond (rebuildEA rebuild v p) (rebuild v t) (rebuild v e)+    Awhile p f a        -> Awhile (rebuildAfun rebuild v p) (rebuildAfun rebuild v f) (rebuild v a)     Use a               -> Use a     Unit e              -> Unit (rebuildEA rebuild v e)     Reshape e a         -> Reshape (rebuildEA rebuild v e) (rebuild v a)@@ -386,7 +393,7 @@     ToIndex sh ix       -> ToIndex (rebuildEA k v sh) (rebuildEA k v ix)     FromIndex sh ix     -> FromIndex (rebuildEA k v sh) (rebuildEA k v ix)     Cond p t e          -> Cond (rebuildEA k v p) (rebuildEA k v t) (rebuildEA k v e)-    Iterate n f x       -> Iterate (rebuildEA k v n) (rebuildEA k v f) (rebuildEA k v x)+    While p f x         -> While (rebuildFA k v p) (rebuildFA k v f) (rebuildEA k v x)     PrimConst c         -> PrimConst c     PrimApp f x         -> PrimApp f (rebuildEA k v x)     Index a sh          -> Index (k v a) (rebuildEA k v sh)
Data/Array/Accelerate/Tuple.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeFamilies      #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Tuple
Data/Array/Accelerate/Type.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, TypeOperators, GADTs, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -- |@@ -48,11 +51,7 @@ -- ------------------------------------------  myMkTyCon :: String -> TyCon-#if __GLASGOW_HASKELL__ == 700-myMkTyCon = mkTyCon-#else myMkTyCon = mkTyCon3 "accelerate" "Data.Array.Accelerate.Type"-#endif  class Typeable8 t where   typeOf8 :: t a b c d e f g h -> TypeRep@@ -61,7 +60,7 @@   typeOf8 _ = myMkTyCon "(,,,,,,,)" `mkTyConApp` []  typeOf7Default :: (Typeable8 t, Typeable a) => t a b c d e f g h -> TypeRep-typeOf7Default x = typeOf7 x `mkAppTy` typeOf (argType x)+typeOf7Default x = typeOf8 x `mkAppTy` typeOf (argType x)  where    argType :: t a b c d e f g h -> a    argType =  undefined@@ -77,7 +76,7 @@   typeOf9 _ = myMkTyCon "(,,,,,,,,)" `mkTyConApp` []  typeOf8Default :: (Typeable9 t, Typeable a) => t a b c d e f g h i -> TypeRep-typeOf8Default x = typeOf8 x `mkAppTy` typeOf (argType x)+typeOf8Default x = typeOf9 x `mkAppTy` typeOf (argType x)  where    argType :: t a b c d e f g h i -> a    argType =  undefined
accelerate.cabal view
@@ -1,7 +1,7 @@ Name:                   accelerate-Version:                0.13.0.5+Version:                0.14.0.0 Cabal-version:          >= 1.6-Tested-with:            GHC >= 7.4.2+Tested-with:            GHC == 7.6.* Build-type:             Custom  Synopsis:               An embedded language for accelerated array processing@@ -98,6 +98,9 @@   .   [/Release notes/]   .+    * /0.14.0.0:/ New iteration constructs. Additional Prelude-like functions.+      Improved code generation and fusion optimisation. Bug fixes.+  .     * /0.13.0.0:/ New array fusion optimisation. New foreign function       interface for array and scalar expressions. Additional Prelude-like       functions. New example programs. Bug fixes and performance improvements.@@ -128,6 +131,15 @@   .     * /0.7.1.0:/ The CUDA backend and a number of scalar functions.   .+  [/Hackage note/]+  .+  The module documentation list generated by Hackage is incorrect. The only+  exposed modules should be:+  .+    * "Data.Array.Accelerate"+  .+    * "Data.Array.Accelerate.Interpreter"+  .  License:                BSD3 License-file:           LICENSE@@ -189,24 +201,25 @@  Library   Include-Dirs:         include-  Build-depends:        base            == 4.*,-                        ghc-prim,-                        array           >= 0.3  && < 0.5,-                        containers      >= 0.3  && < 0.6,-                        fclabels        >= 1.0  && < 1.2,-                        hashable        >= 1.1  && < 1.3,-                        hashtables      >= 1.0  && < 1.2,-                        pretty          >= 1.0  && < 1.2+  Build-depends:        array                >= 0.3,+                        base                 == 4.6.*,+                        containers           >= 0.3,+                        unordered-containers >= 0.2     && < 0.3,+                        fclabels             >= 2.0     && < 2.1,+                        ghc-prim             >= 0.2,+                        hashable             >= 1.1     && < 1.3,+                        hashtables           >= 1.0     && < 1.2,+                        pretty               >= 1.0    if flag(more-pp)-    Build-depends:      bytestring      >= 0.9  && < 0.11,-                        blaze-html      >= 0.5  && < 0.7,-                        blaze-markup    >= 0.5  && < 0.6,-                        directory       >= 1.0  && < 1.3,-                        filepath        >= 1.0  && < 1.4,-                        mtl             >= 2.0  && < 2.2,-                        text            >= 0.10 && < 0.12,-                        unix            >= 2.4  && < 2.7+    Build-depends:      bytestring           >= 0.9,+                        blaze-html           >= 0.5,+                        blaze-markup         >= 0.5,+                        directory            >= 1.0,+                        filepath             >= 1.0,+                        mtl                  >= 2.0,+                        text                 >= 0.10,+                        unix                 >= 2.4    Exposed-modules:      Data.Array.Accelerate                         Data.Array.Accelerate.AST