module Data.Array.Accelerate.Smart (
Acc(..), PreAcc(..), Exp(..), PreExp(..), Boundary(..), Stencil(..),
convertAcc, convertAccFun1,
constant,
tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9,
untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9,
atup2, atup3, atup4, atup5, atup6, atup7, atup8, atup9,
unatup2, unatup3, unatup4, unatup5, unatup6, unatup7, unatup8, unatup9,
mkMinBound, mkMaxBound, mkPi,
mkSin, mkCos, mkTan,
mkAsin, mkAcos, mkAtan,
mkAsinh, mkAcosh, mkAtanh,
mkExpFloating, mkSqrt, mkLog,
mkFPow, mkLogBase,
mkTruncate, mkRound, mkFloor, mkCeiling,
mkAtan2,
mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkIDiv, mkMod,
mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR,
mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin,
mkLAnd, mkLOr, mkLNot,
mkBoolToInt, mkFromIntegral,
($$), ($$$), ($$$$), ($$$$$)
) where
import Control.Applicative hiding (Const)
import Control.Monad.Fix
import Control.Monad
import Data.HashTable as Hash
import Data.List
import Data.Maybe
import qualified Data.IntMap as IntMap
import Data.Typeable
import System.Mem.StableName
import System.IO.Unsafe (unsafePerformIO)
import Prelude hiding (exp)
import Data.Array.Accelerate.Debug
import Data.Array.Accelerate.Type
import Data.Array.Accelerate.Array.Sugar
import qualified Data.Array.Accelerate.Array.Sugar as Sugar
import Data.Array.Accelerate.Tuple hiding (Tuple)
import Data.Array.Accelerate.AST hiding (
PreOpenAcc(..), OpenAcc(..), Acc, Stencil(..), PreOpenExp(..), OpenExp, PreExp, Exp)
import qualified Data.Array.Accelerate.Tuple as Tuple
import qualified Data.Array.Accelerate.AST as AST
import Data.Array.Accelerate.Pretty ()
#include "accelerate.h"
recoverAccSharing :: Bool
recoverAccSharing = True
floatOutAccFromExp :: Bool
floatOutAccFromExp = recoverAccSharing && True
recoverExpSharing :: Bool
recoverExpSharing = True
data Layout env env' where
EmptyLayout :: Layout env ()
PushLayout :: Typeable t
=> Layout env env' -> Idx env t -> Layout env (env', t)
prjIdx :: forall t env env'. Typeable t => String -> Int -> Layout env env' -> Idx env t
prjIdx ctxt 0 (PushLayout _ (ix :: Idx env0 t0))
= case gcast ix of
Just ix' -> ix'
Nothing -> possiblyNestedErr ctxt $
"Couldn't match expected type `" ++ show (typeOf (undefined::t)) ++
"' with actual type `" ++ show (typeOf (undefined::t0)) ++ "'" ++
"\n Type mismatch"
prjIdx ctxt n (PushLayout l _) = prjIdx ctxt (n 1) l
prjIdx ctxt _ EmptyLayout = possiblyNestedErr ctxt "Environment doesn't contain index"
possiblyNestedErr :: String -> String -> a
possiblyNestedErr ctxt failreason
= error $ "Fatal error in Smart.prjIdx:"
++ "\n " ++ failreason ++ " at " ++ ctxt
++ "\n Possible reason: nested data parallelism — array computation that depends on a"
++ "\n scalar variable of type 'Exp a'"
incLayout :: Layout env env' -> Layout (env, t) env'
incLayout EmptyLayout = EmptyLayout
incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix)
type Level = Int
data PreAcc acc exp as where
Atag :: Arrays as
=> Level
-> PreAcc acc exp as
Pipe :: (Arrays as, Arrays bs, Arrays cs)
=> (Acc as -> Acc bs)
-> (Acc bs -> Acc cs)
-> acc as
-> PreAcc acc exp cs
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
Aprj :: (Arrays arrs, IsTuple arrs, Arrays a)
=> TupleIdx (TupleRepr arrs) a
-> acc arrs
-> PreAcc acc exp a
Use :: Arrays arrs
=> arrs
-> PreAcc acc exp arrs
Unit :: Elt e
=> exp e
-> PreAcc acc exp (Scalar e)
Generate :: (Shape sh, Elt e)
=> exp sh
-> (Exp sh -> exp e)
-> PreAcc acc exp (Array sh e)
Reshape :: (Shape sh, Shape sh', Elt e)
=> exp sh
-> acc (Array sh' e)
-> PreAcc acc exp (Array sh e)
Replicate :: (Slice slix, Elt e,
Typeable (SliceShape slix), Typeable (FullShape slix))
=> exp slix
-> acc (Array (SliceShape slix) e)
-> PreAcc acc exp (Array (FullShape slix) e)
Index :: (Slice slix, Elt e,
Typeable (SliceShape slix), Typeable (FullShape slix))
=> acc (Array (FullShape slix) e)
-> exp slix
-> PreAcc acc exp (Array (SliceShape slix) e)
Map :: (Shape sh, Elt e, Elt e')
=> (Exp e -> exp e')
-> acc (Array sh 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)
Fold :: (Shape sh, Elt e)
=> (Exp e -> Exp e -> exp e)
-> exp e
-> acc (Array (sh:.Int) e)
-> PreAcc acc exp (Array sh e)
Fold1 :: (Shape sh, Elt 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)
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)
Scanl' :: Elt e
=> (Exp e -> Exp e -> exp e)
-> exp e
-> acc (Vector e)
-> PreAcc acc exp (Vector e, Scalar 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)
Scanr' :: Elt e
=> (Exp e -> Exp e -> exp e)
-> exp e
-> acc (Vector e)
-> PreAcc acc exp (Vector e, Scalar e)
Scanr1 :: Elt e
=> (Exp e -> Exp e -> exp e)
-> acc (Vector e)
-> PreAcc acc exp (Vector 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)
Backpermute :: (Shape sh, Shape sh', Elt e)
=> exp sh'
-> (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)
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)
newtype Acc a = Acc (PreAcc Acc Exp a)
deriving instance Typeable1 Acc
convertAcc :: Arrays arrs => Acc arrs -> AST.Acc arrs
convertAcc = convertOpenAcc 0 [] EmptyLayout
convertOpenAcc :: Arrays arrs => Level -> [Level] -> Layout aenv aenv -> Acc arrs -> AST.OpenAcc aenv arrs
convertOpenAcc lvl fvs alyt acc
= let
(sharingAcc, initialEnv) = recoverSharingAcc floatOutAccFromExp lvl fvs acc
in
convertSharingAcc alyt initialEnv sharingAcc
convertAccFun1 :: forall a b. (Arrays a, Arrays b)
=> (Acc a -> Acc b)
-> AST.Afun (a -> b)
convertAccFun1 f = Alam (Abody openF)
where
lvl = 0
a = Atag lvl
alyt = EmptyLayout
`PushLayout`
(ZeroIdx :: Idx ((), a) a)
openF = convertOpenAcc (lvl + 1) [lvl] alyt (f (Acc a))
convertSharingAcc :: forall a aenv. Arrays a
=> Layout aenv aenv
-> [StableSharingAcc]
-> SharingAcc a
-> AST.OpenAcc aenv a
convertSharingAcc alyt env (AvarSharing sa)
| Just i <- findIndex (matchStableAcc sa) env
= AST.OpenAcc $ AST.Avar (prjIdx (ctxt ++ "; i = " ++ show i) i alyt)
| null env
= error $ "Cyclic definition of a value of type 'Acc' (sa = " ++
show (hashStableNameHeight sa) ++ ")"
| otherwise
= INTERNAL_ERROR(error) "convertSharingAcc" err
where
ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa)
err = "inconsistent valuation @ " ++ ctxt ++ ";\n env = " ++ show env
convertSharingAcc alyt env (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc)
= AST.OpenAcc
$ let alyt' = incLayout alyt `PushLayout` ZeroIdx
in
AST.Alet (convertSharingAcc alyt env boundAcc) (convertSharingAcc alyt' (sa:env) bodyAcc)
convertSharingAcc alyt env (AccSharing _ preAcc)
= AST.OpenAcc
$ (case preAcc of
Atag i
-> AST.Avar (prjIdx ("de Bruijn conversion tag " ++ show i) i alyt)
Pipe afun1 afun2 acc
-> let boundAcc = convertAccFun1 afun1 `AST.Apply` convertSharingAcc alyt env acc
bodyAcc = convertAccFun1 afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx)
in
AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc)
Acond b acc1 acc2
-> AST.Acond (convertExp alyt env b) (convertSharingAcc alyt env acc1)
(convertSharingAcc alyt env acc2)
Atuple arrs
-> AST.Atuple (convertSharingAtuple alyt env arrs)
Aprj ix a
-> AST.Aprj ix (convertSharingAcc alyt env a)
Use array
-> AST.Use (fromArr array)
Unit e
-> AST.Unit (convertExp alyt env e)
Generate sh f
-> AST.Generate (convertExp alyt env sh) (convertFun1 alyt env f)
Reshape e acc
-> AST.Reshape (convertExp alyt env e) (convertSharingAcc alyt env acc)
Replicate ix acc
-> mkReplicate (convertExp alyt env ix) (convertSharingAcc alyt env acc)
Index acc ix
-> mkIndex (convertSharingAcc alyt env acc) (convertExp alyt env ix)
Map f acc
-> AST.Map (convertFun1 alyt env f) (convertSharingAcc alyt env acc)
ZipWith f acc1 acc2
-> AST.ZipWith (convertFun2 alyt env f)
(convertSharingAcc alyt env acc1)
(convertSharingAcc alyt env acc2)
Fold f e acc
-> AST.Fold (convertFun2 alyt env f) (convertExp alyt env e)
(convertSharingAcc alyt env acc)
Fold1 f acc
-> AST.Fold1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc)
FoldSeg f e acc1 acc2
-> AST.FoldSeg (convertFun2 alyt env f) (convertExp alyt env e)
(convertSharingAcc alyt env acc1) (convertSharingAcc alyt env acc2)
Fold1Seg f acc1 acc2
-> AST.Fold1Seg (convertFun2 alyt env f)
(convertSharingAcc alyt env acc1)
(convertSharingAcc alyt env acc2)
Scanl f e acc
-> AST.Scanl (convertFun2 alyt env f) (convertExp alyt env e)
(convertSharingAcc alyt env acc)
Scanl' f e acc
-> AST.Scanl' (convertFun2 alyt env f)
(convertExp alyt env e)
(convertSharingAcc alyt env acc)
Scanl1 f acc
-> AST.Scanl1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc)
Scanr f e acc
-> AST.Scanr (convertFun2 alyt env f) (convertExp alyt env e)
(convertSharingAcc alyt env acc)
Scanr' f e acc
-> AST.Scanr' (convertFun2 alyt env f)
(convertExp alyt env e)
(convertSharingAcc alyt env acc)
Scanr1 f acc
-> AST.Scanr1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc)
Permute f dftAcc perm acc
-> AST.Permute (convertFun2 alyt env f)
(convertSharingAcc alyt env dftAcc)
(convertFun1 alyt env perm)
(convertSharingAcc alyt env acc)
Backpermute newDim perm acc
-> AST.Backpermute (convertExp alyt env newDim)
(convertFun1 alyt env perm)
(convertSharingAcc alyt env acc)
Stencil stencil boundary acc
-> AST.Stencil (convertStencilFun acc alyt env stencil)
(convertBoundary boundary)
(convertSharingAcc alyt env acc)
Stencil2 stencil bndy1 acc1 bndy2 acc2
-> AST.Stencil2 (convertStencilFun2 acc1 acc2 alyt env stencil)
(convertBoundary bndy1)
(convertSharingAcc alyt env acc1)
(convertBoundary bndy2)
(convertSharingAcc alyt env acc2)
:: AST.PreOpenAcc AST.OpenAcc aenv a)
convertSharingAtuple
:: forall aenv a.
Layout aenv aenv
-> [StableSharingAcc]
-> Tuple.Atuple SharingAcc a
-> Tuple.Atuple (AST.OpenAcc aenv) a
convertSharingAtuple alyt aenv = cvt
where
cvt :: Tuple.Atuple SharingAcc a' -> Tuple.Atuple (AST.OpenAcc aenv) a'
cvt NilAtup = NilAtup
cvt (SnocAtup t a) = cvt t `SnocAtup` convertSharingAcc alyt aenv a
convertBoundary :: Elt e => Boundary e -> Boundary (EltRepr e)
convertBoundary Clamp = Clamp
convertBoundary Mirror = Mirror
convertBoundary Wrap = Wrap
convertBoundary (Constant e) = Constant (fromElt e)
data PreExp acc exp t where
Tag :: Elt t
=> Level -> 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)
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
IndexScalar :: (Shape sh, Elt t)
=> acc (Array sh t) -> exp sh -> 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
newtype Exp t = Exp (PreExp Acc Exp t)
deriving instance Typeable1 Exp
convertSharingExp :: forall t env aenv
. Elt t
=> Layout env env
-> Layout aenv aenv
-> [StableSharingExp]
-> [StableSharingAcc]
-> SharingExp t
-> AST.OpenExp env aenv t
convertSharingExp lyt alyt env aenv = cvt
where
cvt :: Elt t' => SharingExp t' -> AST.OpenExp env aenv t'
cvt (VarSharing se)
| Just i <- findIndex (matchStableExp se) env
= AST.Var (prjIdx (ctxt ++ "; i = " ++ show i) i lyt)
| 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)
= let lyt' = incLayout lyt `PushLayout` ZeroIdx
in
AST.Let (cvt boundExp) (convertSharingExp lyt' alyt (se:env) aenv bodyExp)
cvt (ExpSharing _ pexp)
= case pexp of
Tag i -> AST.Var (prjIdx ("de Bruijn conversion tag " ++ show i) i lyt)
Const v -> AST.Const (fromElt v)
Tuple tup -> AST.Tuple (convertTuple lyt alyt env aenv tup)
Prj idx e -> AST.Prj idx (cvt e)
IndexNil -> AST.IndexNil
IndexCons ix i -> AST.IndexCons (cvt ix) (cvt i)
IndexHead i -> AST.IndexHead (cvt i)
IndexTail ix -> AST.IndexTail (cvt ix)
IndexAny -> AST.IndexAny
Cond e1 e2 e3 -> AST.Cond (cvt e1) (cvt e2) (cvt e3)
PrimConst c -> AST.PrimConst c
PrimApp p e -> AST.PrimApp p (cvt e)
IndexScalar a e -> AST.IndexScalar (convertSharingAcc alyt aenv a) (cvt e)
Shape a -> AST.Shape (convertSharingAcc alyt aenv a)
ShapeSize e -> AST.ShapeSize (cvt e)
convertTuple :: Layout env env
-> Layout aenv aenv
-> [StableSharingExp]
-> [StableSharingAcc]
-> Tuple.Tuple SharingExp t
-> Tuple.Tuple (AST.OpenExp env aenv) t
convertTuple _lyt _alyt _env _aenv NilTup = NilTup
convertTuple lyt alyt env aenv (es `SnocTup` e)
= convertTuple lyt alyt env aenv es `SnocTup` convertSharingExp lyt alyt env aenv e
convertExp :: Elt t
=> Layout aenv aenv
-> [StableSharingAcc]
-> RootExp t
-> AST.Exp aenv t
convertExp alyt aenv (EnvExp env exp) = convertSharingExp EmptyLayout alyt env aenv exp
convertExp _ _ _ = INTERNAL_ERROR(error) "convertExp" "not an 'EnvExp'"
convertFun1 :: forall a b aenv. (Elt a, Elt b)
=> Layout aenv aenv
-> [StableSharingAcc]
-> (Exp a -> RootExp b)
-> AST.Fun aenv (a -> b)
convertFun1 alyt aenv f = Lam (Body openF)
where
a = Exp $ undefined
lyt = EmptyLayout
`PushLayout`
(ZeroIdx :: Idx ((), a) a)
EnvExp env body = f a
openF = convertSharingExp lyt alyt env aenv body
convertFun2 :: forall a b c aenv. (Elt a, Elt b, Elt c)
=> Layout aenv aenv
-> [StableSharingAcc]
-> (Exp a -> Exp b -> RootExp c)
-> AST.Fun aenv (a -> b -> c)
convertFun2 alyt aenv f = Lam (Lam (Body openF))
where
a = Exp $ undefined
b = Exp $ undefined
lyt = EmptyLayout
`PushLayout`
(SuccIdx ZeroIdx :: Idx (((), a), b) a)
`PushLayout`
(ZeroIdx :: Idx (((), a), b) b)
EnvExp env body = f a b
openF = convertSharingExp lyt alyt env aenv body
convertStencilFun :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil, Elt b)
=> SharingAcc (Array sh a)
-> Layout aenv aenv
-> [StableSharingAcc]
-> (stencil -> RootExp b)
-> AST.Fun aenv (StencilRepr sh stencil -> b)
convertStencilFun _ alyt aenv stencilFun = Lam (Body openStencilFun)
where
stencil = Exp $ undefined :: Exp (StencilRepr sh stencil)
lyt = EmptyLayout
`PushLayout`
(ZeroIdx :: Idx ((), StencilRepr sh stencil)
(StencilRepr sh stencil))
EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)
openStencilFun = convertSharingExp lyt alyt env aenv body
convertStencilFun2 :: forall sh a b stencil1 stencil2 c aenv.
(Elt a, Stencil sh a stencil1,
Elt b, Stencil sh b stencil2,
Elt c)
=> SharingAcc (Array sh a)
-> SharingAcc (Array sh b)
-> Layout aenv aenv
-> [StableSharingAcc]
-> (stencil1 -> stencil2 -> RootExp c)
-> AST.Fun aenv (StencilRepr sh stencil1 ->
StencilRepr sh stencil2 -> c)
convertStencilFun2 _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun))
where
stencil1 = Exp $ undefined :: Exp (StencilRepr sh stencil1)
stencil2 = Exp $ undefined :: Exp (StencilRepr sh stencil2)
lyt = EmptyLayout
`PushLayout`
(SuccIdx ZeroIdx :: Idx (((), StencilRepr sh stencil1),
StencilRepr sh stencil2)
(StencilRepr sh stencil1))
`PushLayout`
(ZeroIdx :: Idx (((), StencilRepr sh stencil1),
StencilRepr sh stencil2)
(StencilRepr sh stencil2))
EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)
(stencilPrj (undefined::sh) (undefined::b) stencil2)
openStencilFun = convertSharingExp lyt alyt env aenv body
data StableASTName c where
StableASTName :: (Typeable1 c, Typeable t) => StableName (c t) -> StableASTName c
instance Show (StableASTName c) where
show (StableASTName sn) = show $ hashStableName sn
instance Eq (StableASTName c) where
StableASTName sn1 == StableASTName sn2
| Just sn1' <- gcast sn1 = sn1' == sn2
| otherwise = False
makeStableAST :: c t -> IO (StableName (c t))
makeStableAST e = e `seq` makeStableName e
data StableNameHeight t = StableNameHeight (StableName t) Int
instance Eq (StableNameHeight t) where
(StableNameHeight sn1 _) == (StableNameHeight sn2 _) = sn1 == sn2
higherSNH :: StableNameHeight t1 -> StableNameHeight t2 -> Bool
StableNameHeight _ h1 `higherSNH` StableNameHeight _ h2 = h1 > h2
hashStableNameHeight :: StableNameHeight t -> Int
hashStableNameHeight (StableNameHeight sn _) = hashStableName sn
type ASTHashTable c v = Hash.HashTable (StableASTName c) v
type OccMapHash c = ASTHashTable c (Int, Int)
newASTHashTable :: IO (ASTHashTable c v)
newASTHashTable = Hash.new (==) hashStableAST
where
hashStableAST (StableASTName sn) = fromIntegral (hashStableName sn)
enterOcc :: OccMapHash c -> StableASTName c -> Int -> IO (Maybe Int)
enterOcc occMap sa height
= do
entry <- Hash.lookup occMap sa
case entry of
Nothing -> Hash.insert occMap sa (1 , height) >> return Nothing
Just (n, heightS) -> Hash.update occMap sa (n + 1, heightS) >> return (Just heightS)
type OccMap c = IntMap.IntMap [(StableASTName c, Int)]
freezeOccMap :: OccMapHash c -> IO (OccMap c)
freezeOccMap oc
= do
kvs <- map dropHeight <$> Hash.toList oc
return . IntMap.fromList . map (\kvs -> (key (head kvs), kvs)). groupBy sameKey $ kvs
where
key (StableASTName sn, _) = hashStableName sn
sameKey kv1 kv2 = key kv1 == key kv2
dropHeight (k, (cnt, _)) = (k, cnt)
lookupWithASTName :: OccMap c -> StableASTName c -> Int
lookupWithASTName oc sa@(StableASTName sn)
= fromMaybe 1 $ IntMap.lookup (hashStableName sn) oc >>= Prelude.lookup sa
lookupWithSharingAcc :: OccMap Acc -> StableSharingAcc -> Int
lookupWithSharingAcc oc (StableSharingAcc (StableNameHeight sn _) _)
= lookupWithASTName oc (StableASTName sn)
lookupWithSharingExp :: OccMap Exp -> StableSharingExp -> Int
lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _)
= lookupWithASTName oc (StableASTName sn)
type StableAccName arrs = StableNameHeight (Acc arrs)
data SharingAcc arrs where
AvarSharing :: Arrays arrs
=> StableAccName arrs -> SharingAcc arrs
AletSharing :: StableSharingAcc -> SharingAcc arrs -> SharingAcc arrs
AccSharing :: Arrays arrs
=> StableAccName arrs -> PreAcc SharingAcc RootExp arrs -> SharingAcc arrs
data StableSharingAcc where
StableSharingAcc :: Arrays arrs => StableAccName arrs -> SharingAcc arrs -> StableSharingAcc
instance Show StableSharingAcc where
show (StableSharingAcc sn _) = show $ hashStableNameHeight sn
instance Eq StableSharingAcc where
StableSharingAcc sn1 _ == StableSharingAcc sn2 _
| Just sn1' <- gcast sn1 = sn1' == sn2
| otherwise = False
higherSSA :: StableSharingAcc -> StableSharingAcc -> Bool
StableSharingAcc sn1 _ `higherSSA` StableSharingAcc sn2 _ = sn1 `higherSNH` sn2
matchStableAcc :: Typeable arrs => StableAccName arrs -> StableSharingAcc -> Bool
matchStableAcc sn1 (StableSharingAcc sn2 _)
| Just sn1' <- gcast sn1 = sn1' == sn2
| otherwise = False
noStableAccName :: StableAccName arrs
noStableAccName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0
type StableExpName t = StableNameHeight (Exp t)
data SharingExp t where
VarSharing :: Elt t
=> StableExpName t -> SharingExp t
LetSharing :: StableSharingExp -> SharingExp t -> SharingExp t
ExpSharing :: Elt t
=> StableExpName t -> PreExp SharingAcc SharingExp t -> SharingExp t
data RootExp t where
OccMapExp :: [Int] -> OccMap Exp -> SharingExp t -> RootExp t
EnvExp :: [StableSharingExp] -> SharingExp t -> RootExp t
data StableSharingExp where
StableSharingExp :: Elt t => StableExpName t -> SharingExp t -> StableSharingExp
instance Show StableSharingExp where
show (StableSharingExp sn _) = show $ hashStableNameHeight sn
instance Eq StableSharingExp where
StableSharingExp sn1 _ == StableSharingExp sn2 _
| Just sn1' <- gcast sn1 = sn1' == sn2
| otherwise = False
higherSSE :: StableSharingExp -> StableSharingExp -> Bool
StableSharingExp sn1 _ `higherSSE` StableSharingExp sn2 _ = sn1 `higherSNH` sn2
matchStableExp :: Typeable t => StableExpName t -> StableSharingExp -> Bool
matchStableExp sn1 (StableSharingExp sn2 _)
| Just sn1' <- gcast sn1 = sn1' == sn2
| otherwise = False
noStableExpName :: StableExpName t
noStableExpName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0
makeOccMap :: Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, OccMapHash Acc)
makeOccMap lvl rootAcc
= do
traceLine "makeOccMap" "Enter"
occMap <- newASTHashTable
(rootAcc', _) <- traverseAcc lvl occMap rootAcc
traceLine "makeOccMap" "Exit"
return (rootAcc', occMap)
where
traverseAcc :: forall arrs. Typeable arrs
=> Level -> OccMapHash Acc -> Acc arrs -> IO (SharingAcc arrs, Int)
traverseAcc lvl occMap acc@(Acc pacc)
= mfix $ \ ~(_, height) -> do
{
; sn <- makeStableAST acc
; heightIfRepeatedOccurence <- enterOcc occMap (StableASTName sn) height
; traceLine (showPreAccOp pacc) $
case heightIfRepeatedOccurence of
Just height -> "REPEATED occurence (sn = " ++ show (hashStableName sn) ++
"; height = " ++ show height ++ ")"
Nothing -> "first occurence (sn = " ++ show (hashStableName sn) ++ ")"
; let reconstruct :: Arrays arrs
=> IO (PreAcc SharingAcc RootExp arrs, Int)
-> IO (SharingAcc arrs, Int)
reconstruct newAcc
= case heightIfRepeatedOccurence of
Just height | recoverAccSharing
-> return (AvarSharing (StableNameHeight sn height), height)
_ -> do
{ (acc, height) <- newAcc
; return (AccSharing (StableNameHeight sn height) acc, height)
}
; case pacc of
Atag i -> reconstruct $ return (Atag i, 0)
Pipe afun1 afun2 acc -> reconstruct $ travA (Pipe afun1 afun2) acc
Acond e acc1 acc2 -> reconstruct $ do
(e' , h1) <- enterExp lvl occMap e
(acc1', h2) <- traverseAcc lvl occMap acc1
(acc2', h3) <- traverseAcc lvl occMap acc2
return (Acond e' acc1' acc2', h1 `max` h2 `max` h3 + 1)
Atuple tup -> reconstruct $ do
(tup', h) <- travAtup tup
return (Atuple tup', h)
Aprj ix a -> reconstruct $ travA (Aprj ix) a
Use arr -> reconstruct $ return (Use arr, 1)
Unit e -> reconstruct $ do
(e', h) <- enterExp lvl occMap e
return (Unit e', h + 1)
Generate e f -> reconstruct $ do
(e', h1) <- enterExp lvl occMap e
(f', h2) <- traverseFun1 lvl occMap f
return (Generate e' f', h1 `max` h2 + 1)
Reshape e acc -> reconstruct $ travEA Reshape e acc
Replicate e acc -> reconstruct $ travEA Replicate e acc
Index acc e -> reconstruct $ travEA (flip Index) e acc
Map f acc -> reconstruct $ do
(f' , h1) <- traverseFun1 lvl occMap f
(acc', h2) <- traverseAcc lvl occMap acc
return (Map f' acc', h1 `max` h2 + 1)
ZipWith f acc1 acc2 -> reconstruct $ travF2A2 ZipWith f acc1 acc2
Fold f e acc -> reconstruct $ travF2EA Fold f e acc
Fold1 f acc -> reconstruct $ travF2A Fold1 f acc
FoldSeg f e acc1 acc2 -> reconstruct $ do
(f' , h1) <- traverseFun2 lvl occMap f
(e' , h2) <- enterExp lvl occMap e
(acc1', h3) <- traverseAcc lvl occMap acc1
(acc2', h4) <- traverseAcc lvl occMap acc2
return (FoldSeg f' e' acc1' acc2',
h1 `max` h2 `max` h3 `max` h4 + 1)
Fold1Seg f acc1 acc2 -> reconstruct $ travF2A2 Fold1Seg f acc1 acc2
Scanl f e acc -> reconstruct $ travF2EA Scanl f e acc
Scanl' f e acc -> reconstruct $ travF2EA Scanl' f e acc
Scanl1 f acc -> reconstruct $ travF2A Scanl1 f acc
Scanr f e acc -> reconstruct $ travF2EA Scanr f e acc
Scanr' f e acc -> reconstruct $ travF2EA Scanr' f e acc
Scanr1 f acc -> reconstruct $ travF2A Scanr1 f acc
Permute c acc1 p acc2 -> reconstruct $ do
(c' , h1) <- traverseFun2 lvl occMap c
(p' , h2) <- traverseFun1 lvl occMap p
(acc1', h3) <- traverseAcc lvl occMap acc1
(acc2', h4) <- traverseAcc lvl occMap acc2
return (Permute c' acc1' p' acc2',
h1 `max` h2 `max` h3 `max` h4 + 1)
Backpermute e p acc -> reconstruct $ do
(e' , h1) <- enterExp lvl occMap e
(p' , h2) <- traverseFun1 lvl occMap p
(acc', h3) <- traverseAcc lvl occMap acc
return (Backpermute e' p' acc', h1 `max` h2 `max` h3 + 1)
Stencil s bnd acc -> reconstruct $ do
(s' , h1) <- traverseStencil1 acc lvl occMap s
(acc', h2) <- traverseAcc lvl occMap acc
return (Stencil s' bnd acc', h1 `max` h2 + 1)
Stencil2 s bnd1 acc1
bnd2 acc2 -> reconstruct $ do
(s' , h1) <- traverseStencil2 acc1 acc2 lvl occMap s
(acc1', h2) <- traverseAcc lvl occMap acc1
(acc2', h3) <- traverseAcc lvl occMap acc2
return (Stencil2 s' bnd1 acc1' bnd2 acc2',
h1 `max` h2 `max` h3 + 1)
}
where
travA :: Arrays arrs'
=> (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
-> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int)
travA c acc
= do
(acc', h) <- traverseAcc lvl occMap 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)
travEA c exp acc
= do
(exp', h1) <- enterExp lvl occMap exp
(acc', h2) <- traverseAcc lvl occMap acc
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 -> Exp d) -> Acc arrs'
-> IO (PreAcc SharingAcc RootExp arrs, Int)
travF2A c fun acc
= do
(fun', h1) <- traverseFun2 lvl occMap fun
(acc', h2) <- traverseAcc lvl occMap acc
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 -> Exp d) -> Exp e -> Acc arrs'
-> IO (PreAcc SharingAcc RootExp arrs, Int)
travF2EA c fun exp acc
= do
(fun', h1) <- traverseFun2 lvl occMap fun
(exp', h2) <- enterExp lvl occMap exp
(acc', h3) <- traverseAcc lvl occMap acc
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 -> Exp d) -> Acc arrs1 -> Acc arrs2
-> IO (PreAcc SharingAcc RootExp arrs, Int)
travF2A2 c fun acc1 acc2
= do
(fun' , h1) <- traverseFun2 lvl occMap fun
(acc1', h2) <- traverseAcc lvl occMap acc1
(acc2', h3) <- traverseAcc lvl occMap acc2
return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1)
travAtup :: Tuple.Atuple Acc a
-> IO (Tuple.Atuple SharingAcc a, Int)
travAtup NilAtup = return (NilAtup, 1)
travAtup (SnocAtup tup a) = do
(tup', h1) <- travAtup tup
(a', h2) <- traverseAcc lvl occMap a
return (SnocAtup tup' a', h1 `max` h2 + 1)
traverseFun1 :: (Elt b, Typeable c)
=> Level -> OccMapHash Acc -> (Exp b -> Exp c) -> IO (Exp b -> RootExp c, Int)
traverseFun1 lvl occMap f
= do
(body, h) <- enterFun (lvl + 1) [lvl] occMap $ f (Exp $ Tag lvl)
return (const body, h + 1)
traverseFun2 :: (Elt b, Elt c, Typeable d)
=> Level -> OccMapHash Acc -> (Exp b -> Exp c -> Exp d)
-> IO (Exp b -> Exp c -> RootExp d, Int)
traverseFun2 lvl occMap f
= do
(body, h) <- enterFun (lvl + 2) [lvl, lvl + 1] occMap $ f (Exp $ Tag (lvl + 1)) (Exp $ Tag lvl)
return (\_ _ -> body, h + 2)
traverseStencil1 :: forall sh b c stencil. (Stencil sh b stencil, Typeable c)
=> Acc (Array sh b)
-> Level -> OccMapHash Acc -> (stencil -> Exp c)
-> IO (stencil -> RootExp c, Int)
traverseStencil1 _ lvl occMap stencilFun
= do
(body, h) <- enterFun (lvl + 1) [lvl] occMap $
stencilFun (stencilPrj (undefined::sh) (undefined::b) (Exp $ Tag lvl))
return (const body, h + 1)
traverseStencil2 :: forall sh b c d stencil1 stencil2.
(Stencil sh b stencil1, Stencil sh c stencil2, Typeable d)
=> Acc (Array sh b)
-> Acc (Array sh c)
-> Level
-> OccMapHash Acc
-> (stencil1 -> stencil2 -> Exp d)
-> IO (stencil1 -> stencil2 -> RootExp d, Int)
traverseStencil2 _ _ lvl occMap stencilFun
= do
(body, h) <- enterFun (lvl + 2) [lvl, lvl + 1] occMap $
stencilFun (stencilPrj (undefined::sh) (undefined::b) (Exp $ Tag (lvl + 1)))
(stencilPrj (undefined::sh) (undefined::c) (Exp $ Tag lvl))
return (\_ _ -> body, h + 2)
enterFun :: forall a. Typeable a => Level -> [Int] -> OccMapHash Acc -> Exp a -> IO (RootExp a, Int)
enterFun lvl fvs accOccMap exp
= do
{ expOccMap <- newASTHashTable
; (exp', h) <- traverseExp lvl accOccMap expOccMap exp
; frozenExpOccMap <- freezeOccMap expOccMap
; return (OccMapExp fvs frozenExpOccMap exp', h)
}
enterExp :: forall a. Typeable a => Level -> OccMapHash Acc -> Exp a -> IO (RootExp a, Int)
enterExp lvl = enterFun lvl []
traverseExp :: forall a. Typeable a => Level -> OccMapHash Acc -> OccMapHash Exp -> Exp a -> IO (SharingExp a, Int)
traverseExp lvl accOccMap expOccMap exp@(Exp pexp)
= mfix $ \ ~(_, height) -> do
{
; sn <- makeStableAST exp
; heightIfRepeatedOccurence <- enterOcc expOccMap (StableASTName sn) height
; traceLine (showPreExpOp pexp) $
case heightIfRepeatedOccurence of
Just height -> "REPEATED occurence (sn = " ++ show (hashStableName sn) ++
"; height = " ++ show height ++ ")"
Nothing -> "first occurence (sn = " ++ show (hashStableName sn) ++ ")"
; let reconstruct :: Elt a
=> IO (PreExp SharingAcc SharingExp a, Int)
-> IO (SharingExp a, Int)
reconstruct newExp
= case heightIfRepeatedOccurence of
Just height | recoverExpSharing
-> return (VarSharing (StableNameHeight sn height), height)
_ -> do
{ (exp, height) <- newExp
; return (ExpSharing (StableNameHeight sn height) exp, height)
}
; case pexp of
Tag i -> reconstruct $ return (Tag i, 0)
Const c -> reconstruct $ return (Const c, 1)
Tuple tup -> reconstruct $ do
(tup', h) <- travTup tup
return (Tuple tup', h)
Prj i e -> reconstruct $ travE1 (Prj i) e
IndexNil -> reconstruct $ return (IndexNil, 1)
IndexCons ix i -> reconstruct $ travE2 IndexCons ix i
IndexHead i -> reconstruct $ travE1 IndexHead i
IndexTail ix -> reconstruct $ travE1 IndexTail ix
IndexAny -> reconstruct $ return (IndexAny, 1)
Cond e1 e2 e3 -> reconstruct $ travE3 Cond e1 e2 e3
PrimConst c -> reconstruct $ return (PrimConst c, 1)
PrimApp p e -> reconstruct $ travE1 (PrimApp p) e
IndexScalar a e -> reconstruct $ travAE IndexScalar a e
Shape a -> reconstruct $ travA Shape a
ShapeSize e -> reconstruct $ travE1 ShapeSize e
}
where
travE1 :: Typeable b => (SharingExp b -> PreExp SharingAcc SharingExp a) -> Exp b
-> IO (PreExp SharingAcc SharingExp a, Int)
travE1 c e
= do
(e', h) <- traverseExp lvl accOccMap expOccMap e
return (c e', h + 1)
travE2 :: (Typeable b, Typeable c)
=> (SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp a)
-> Exp b -> Exp c
-> IO (PreExp SharingAcc SharingExp a, Int)
travE2 c e1 e2
= do
(e1', h1) <- traverseExp lvl accOccMap expOccMap e1
(e2', h2) <- traverseExp lvl accOccMap expOccMap e2
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)
-> Exp b -> Exp c -> Exp d
-> IO (PreExp SharingAcc SharingExp a, Int)
travE3 c e1 e2 e3
= do
(e1', h1) <- traverseExp lvl accOccMap expOccMap e1
(e2', h2) <- traverseExp lvl accOccMap expOccMap e2
(e3', h3) <- traverseExp lvl accOccMap expOccMap 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 c acc
= do
(acc', h) <- traverseAcc lvl accOccMap acc
return (c acc', h + 1)
travAE :: (Typeable b, Typeable c)
=> (SharingAcc b -> SharingExp c -> PreExp SharingAcc SharingExp a)
-> Acc b -> Exp c
-> IO (PreExp SharingAcc SharingExp a, Int)
travAE c acc e
= do
(acc', h1) <- traverseAcc lvl accOccMap acc
(e' , h2) <- traverseExp lvl accOccMap expOccMap e
return (c acc' e', h1 `max` h2 + 1)
travTup :: Tuple.Tuple Exp tup -> IO (Tuple.Tuple SharingExp tup, Int)
travTup NilTup = return (NilTup, 1)
travTup (SnocTup tup e) = do
(tup', h1) <- travTup tup
(e' , h2) <- traverseExp lvl accOccMap expOccMap e
return (SnocTup tup' e', h1 `max` h2 + 1)
type NodeCounts = [NodeCount]
data NodeCount = AccNodeCount StableSharingAcc Int
| ExpNodeCount StableSharingExp Int
deriving Show
noNodeCounts :: NodeCounts
noNodeCounts = []
accNodeCount :: StableSharingAcc -> Int -> NodeCounts
accNodeCount ssa n = [AccNodeCount ssa n]
expNodeCount :: StableSharingExp -> Int -> NodeCounts
expNodeCount sse n = [ExpNodeCount sse n]
(+++) :: NodeCounts -> NodeCounts -> NodeCounts
us +++ vs = foldr insert us vs
where
insert x [] = [x]
insert x@(AccNodeCount sa1 count1) ys@(y@(AccNodeCount sa2 count2) : ys')
| sa1 == sa2 = AccNodeCount (sa1 `pickNoneAvar` sa2) (count1 + count2) : ys'
| sa1 `higherSSA` sa2 = x : ys
| otherwise = y : insert x ys'
insert x@(ExpNodeCount se1 count1) ys@(y@(ExpNodeCount se2 count2) : ys')
| se1 == se2 = ExpNodeCount (se1 `pickNoneVar` se2) (count1 + count2) : ys'
| se1 `higherSSE` se2 = x : ys
| otherwise = y : insert x ys'
insert x@(AccNodeCount _ _) (y@(ExpNodeCount _ _) : ys')
= y : insert x ys'
insert x@(ExpNodeCount _ _) (y@(AccNodeCount _ _) : ys')
= x : insert y ys'
(StableSharingAcc _ (AvarSharing _)) `pickNoneAvar` sa2 = sa2
sa1 `pickNoneAvar` _sa2 = sa1
(StableSharingExp _ (VarSharing _)) `pickNoneVar` sa2 = sa2
sa1 `pickNoneVar` _sa2 = sa1
buildInitialEnvAcc :: [Level] -> [StableSharingAcc] -> [StableSharingAcc]
buildInitialEnvAcc tags sas = map (lookupSA sas) tags
where
lookupSA sas tag1
= case filter hasTag sas of
[] -> noStableSharing
[sa] -> sa
sas2 -> INTERNAL_ERROR(error) "buildInitialEnvAcc"
("Encountered duplicate 'ATag's\n " ++ concat (intersperse ", " (map showSA sas2)))
where
hasTag (StableSharingAcc _ (AccSharing _ (Atag tag2))) = tag1 == tag2
hasTag sa
= INTERNAL_ERROR(error) "buildInitialEnvAcc"
("Encountered a node that is not a plain 'Atag'\n " ++ showSA sa)
noStableSharing :: StableSharingAcc
noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc ())
showSA (StableSharingAcc _ (AccSharing sn acc)) = show (hashStableNameHeight sn) ++ ": " ++
showPreAccOp acc
showSA (StableSharingAcc _ (AvarSharing sn)) = "AvarSharing " ++ show (hashStableNameHeight sn)
showSA (StableSharingAcc _ (AletSharing sa _ )) = "AletSharing " ++ show sa ++ "..."
buildInitialEnvExp :: [Level] -> [StableSharingExp] -> [StableSharingExp]
buildInitialEnvExp tags ses = map (lookupSE ses) tags
where
lookupSE ses tag1
= case filter hasTag ses of
[] -> noStableSharing
[se] -> se
ses2 -> INTERNAL_ERROR(error) "buildInitialEnvExp"
("Encountered a duplicate 'Tag'\n " ++ concat (intersperse ", " (map showSE ses2)))
where
hasTag (StableSharingExp _ (ExpSharing _ (Tag tag2))) = tag1 == tag2
hasTag se
= INTERNAL_ERROR(error) "buildInitialEnvExp"
("Encountered a node that is not a plain 'Tag'\n " ++ showSE se)
noStableSharing :: StableSharingExp
noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp ())
showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++
showPreExpOp exp
showSE (StableSharingExp _ (VarSharing sn)) = "VarSharing " ++ show (hashStableNameHeight sn)
showSE (StableSharingExp _ (LetSharing se _ )) = "LetSharing " ++ show se ++ "..."
isFreeVar :: NodeCount -> Bool
isFreeVar (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag _))) _) = True
isFreeVar (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag _))) _) = True
isFreeVar _ = False
determineScopes :: Typeable a
=> Bool -> [Level] -> OccMap Acc -> SharingAcc a -> (SharingAcc a, [StableSharingAcc])
determineScopes floatOutAcc fvs accOccMap rootAcc
= let
(sharingAcc, counts) = scopesAcc rootAcc
unboundTrees = filter (not . isFreeVar) counts
in
if all isFreeVar counts
then
(sharingAcc, buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- counts])
else
INTERNAL_ERROR(error) "determineScopes" ("unbound shared subtrees" ++ show unboundTrees)
where
scopesAcc :: forall arrs. SharingAcc arrs -> (SharingAcc arrs, NodeCounts)
scopesAcc (AletSharing _ _)
= INTERNAL_ERROR(error) "determineScopes: scopesAcc" "unexpected 'AletSharing'"
scopesAcc sharingAcc@(AvarSharing sn)
= (sharingAcc, StableSharingAcc sn sharingAcc `accNodeCount` 1)
scopesAcc (AccSharing sn pacc)
= case pacc of
Atag i -> reconstruct (Atag i) noNodeCounts
Pipe afun1 afun2 acc -> travA (Pipe afun1 afun2) acc
Acond e acc1 acc2 -> let
(e' , accCount1) = scopesExpInit e
(acc1', accCount2) = scopesAcc acc1
(acc2', accCount3) = scopesAcc acc2
in
reconstruct (Acond e' acc1' acc2')
(accCount1 +++ accCount2 +++ accCount3)
Atuple tup -> let (tup', accCount) = travAtup tup
in reconstruct (Atuple tup') accCount
Aprj ix a -> travA (Aprj ix) a
Use arr -> reconstruct (Use arr) noNodeCounts
Unit e -> let
(e', accCount) = scopesExpInit e
in
reconstruct (Unit e') accCount
Generate sh f -> let
(sh', accCount1) = scopesExpInit sh
(f' , accCount2) = scopesFun1 f
in
reconstruct (Generate sh' f') (accCount1 +++ accCount2)
Reshape sh acc -> travEA Reshape sh acc
Replicate n acc -> travEA Replicate n acc
Index acc i -> travEA (flip Index) i acc
Map f acc -> let
(f' , accCount1) = scopesFun1 f
(acc', accCount2) = scopesAcc acc
in
reconstruct (Map f' acc') (accCount1 +++ accCount2)
ZipWith f acc1 acc2 -> travF2A2 ZipWith f acc1 acc2
Fold f z acc -> travF2EA Fold f z acc
Fold1 f acc -> travF2A Fold1 f acc
FoldSeg f z acc1 acc2 -> let
(f' , accCount1) = scopesFun2 f
(z' , accCount2) = scopesExpInit z
(acc1', accCount3) = scopesAcc acc1
(acc2', accCount4) = scopesAcc acc2
in
reconstruct (FoldSeg f' z' acc1' acc2')
(accCount1 +++ accCount2 +++ accCount3 +++ accCount4)
Fold1Seg f acc1 acc2 -> travF2A2 Fold1Seg f acc1 acc2
Scanl f z acc -> travF2EA Scanl f z acc
Scanl' f z acc -> travF2EA Scanl' f z acc
Scanl1 f acc -> travF2A Scanl1 f acc
Scanr f z acc -> travF2EA Scanr f z acc
Scanr' f z acc -> travF2EA Scanr' f z acc
Scanr1 f acc -> travF2A Scanr1 f acc
Permute fc acc1 fp acc2 -> let
(fc' , accCount1) = scopesFun2 fc
(acc1', accCount2) = scopesAcc acc1
(fp' , accCount3) = scopesFun1 fp
(acc2', accCount4) = scopesAcc acc2
in
reconstruct (Permute fc' acc1' fp' acc2')
(accCount1 +++ accCount2 +++ accCount3 +++ accCount4)
Backpermute sh fp acc -> let
(sh' , accCount1) = scopesExpInit sh
(fp' , accCount2) = scopesFun1 fp
(acc', accCount3) = scopesAcc acc
in
reconstruct (Backpermute sh' fp' acc')
(accCount1 +++ accCount2 +++ accCount3)
Stencil st bnd acc -> let
(st' , accCount1) = scopesStencil1 acc st
(acc', accCount2) = scopesAcc acc
in
reconstruct (Stencil st' bnd acc') (accCount1 +++ accCount2)
Stencil2 st bnd1 acc1 bnd2 acc2
-> let
(st' , accCount1) = scopesStencil2 acc1 acc2 st
(acc1', accCount2) = scopesAcc acc1
(acc2', accCount3) = scopesAcc acc2
in
reconstruct (Stencil2 st' bnd1 acc1' bnd2 acc2')
(accCount1 +++ accCount2 +++ accCount3)
where
travEA :: Arrays arrs
=> (RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
-> RootExp e
-> SharingAcc arrs'
-> (SharingAcc arrs, NodeCounts)
travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2)
where
(e' , accCount1) = scopesExpInit 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 -> RootExp c)
-> SharingAcc arrs'
-> (SharingAcc 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 -> RootExp c)
-> RootExp e
-> SharingAcc arrs'
-> (SharingAcc arrs, NodeCounts)
travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3)
where
(f' , accCount1) = scopesFun2 f
(e' , accCount2) = scopesExpInit e
(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 -> RootExp c)
-> SharingAcc arrs1
-> SharingAcc arrs2
-> (SharingAcc arrs, NodeCounts)
travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2')
(accCount1 +++ accCount2 +++ accCount3)
where
(f' , accCount1) = scopesFun2 f
(acc1', accCount2) = scopesAcc acc1
(acc2', accCount3) = scopesAcc acc2
travAtup :: Tuple.Atuple SharingAcc a
-> (Tuple.Atuple SharingAcc a, NodeCounts)
travAtup NilAtup = (NilAtup, noNodeCounts)
travAtup (SnocAtup tup a) = let (tup', accCountT) = travAtup tup
(a', accCountA) = scopesAcc a
in
(SnocAtup tup' a', accCountT +++ accCountA)
travA :: Arrays arrs
=> (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
-> SharingAcc arrs'
-> (SharingAcc arrs, NodeCounts)
travA c acc = reconstruct (c acc') accCount
where
(acc', accCount) = scopesAcc acc
accOccCount = let StableNameHeight sn' _ = sn
in
lookupWithASTName accOccMap (StableASTName sn')
reconstruct :: Arrays arrs
=> PreAcc SharingAcc RootExp arrs -> NodeCounts
-> (SharingAcc arrs, NodeCounts)
reconstruct newAcc@(Atag _) _subCount
= let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `accNodeCount` 1
in
tracePure "FREE" (show thisCount) $
(AvarSharing sn, thisCount)
reconstruct newAcc subCount
| accOccCount > 1 && recoverAccSharing
= let allCount = (StableSharingAcc sn sharingAcc `accNodeCount` 1) +++ newCount
in
tracePure ("SHARED" ++ completed) (show allCount) $
(AvarSharing sn, allCount)
| otherwise
= tracePure ("Normal" ++ completed) (show newCount) $
(sharingAcc, newCount)
where
(newCount, bindHere) = filterCompleted subCount
lets = foldl (flip (.)) id . map AletSharing $ bindHere
sharingAcc = lets $ AccSharing sn newAcc
completed | null bindHere = ""
| otherwise = "(" ++ show (length bindHere) ++ " lets)"
filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc])
filterCompleted counts
= let (completed, counts') = break notComplete counts
in (counts', [sa | AccNodeCount sa _ <- completed])
where
notComplete nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa > n
notComplete _ = True
scopesExpInit :: RootExp t -> (RootExp t, NodeCounts)
scopesExpInit (OccMapExp fvs expOccMap exp)
= let
(expWithScopes, nodeCounts) = scopesExp expOccMap exp
(expCounts, accCounts) = break isAccNodeCount nodeCounts
in
(EnvExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, accCounts)
where
isAccNodeCount (AccNodeCount {}) = True
isAccNodeCount _ = False
scopesExpInit _ = INTERNAL_ERROR(error) "scopesExpInit" "not an 'OccMapExp'"
scopesExp :: forall t. OccMap Exp -> SharingExp t -> (SharingExp t, NodeCounts)
scopesExp _expOccMap (LetSharing _ _)
= INTERNAL_ERROR(error) "determineScopes: scopesExp" "unexpected 'LetSharing'"
scopesExp _expOccMap sharingExp@(VarSharing sn)
= (sharingExp, StableSharingExp sn sharingExp `expNodeCount` 1)
scopesExp expOccMap (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
Cond e1 e2 e3 -> travE3 Cond e1 e2 e3
PrimConst c -> reconstruct (PrimConst c) noNodeCounts
PrimApp p e -> travE1 (PrimApp p) e
IndexScalar a e -> travAE IndexScalar a e
Shape a -> travA Shape a
ShapeSize e -> travE1 ShapeSize e
where
travTup :: Tuple.Tuple SharingExp tup -> (Tuple.Tuple SharingExp tup, NodeCounts)
travTup NilTup = (NilTup, noNodeCounts)
travTup (SnocTup tup e) = let
(tup', accCountT) = travTup tup
(e' , accCountE) = scopesExp expOccMap e
in
(SnocTup tup' e', accCountT +++ accCountE)
travE1 :: (SharingExp a -> PreExp SharingAcc SharingExp t) -> SharingExp a
-> (SharingExp t, NodeCounts)
travE1 c e = reconstruct (c e') accCount
where
(e', accCount) = scopesExp expOccMap e
travE2 :: (SharingExp a -> SharingExp b -> PreExp SharingAcc SharingExp t)
-> SharingExp a
-> SharingExp b
-> (SharingExp t, NodeCounts)
travE2 c e1 e2 = reconstruct (c e1' e2') (accCount1 +++ accCount2)
where
(e1', accCount1) = scopesExp expOccMap e1
(e2', accCount2) = scopesExp expOccMap e2
travE3 :: (SharingExp a -> SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp t)
-> SharingExp a
-> SharingExp b
-> SharingExp c
-> (SharingExp t, NodeCounts)
travE3 c e1 e2 e3 = reconstruct (c e1' e2' e3') (accCount1 +++ accCount2 +++ accCount3)
where
(e1', accCount1) = scopesExp expOccMap e1
(e2', accCount2) = scopesExp expOccMap e2
(e3', accCount3) = scopesExp expOccMap e3
travA :: (SharingAcc a -> PreExp SharingAcc SharingExp t) -> SharingAcc a
-> (SharingExp 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 c acc e = maybeFloatOutAcc (flip c e') acc' (accCountA +++ accCountE)
where
(acc', accCountA) = scopesAcc acc
(e' , accCountE) = scopesExp expOccMap e
maybeFloatOutAcc :: (SharingAcc a -> PreExp SharingAcc SharingExp t)
-> SharingAcc a
-> NodeCounts
-> (SharingExp t, NodeCounts)
maybeFloatOutAcc c acc@(AvarSharing _) accCount
= reconstruct (c acc) accCount
maybeFloatOutAcc c acc accCount
| floatOutAcc = reconstruct (c var) ((stableAcc `accNodeCount` 1) +++ accCount)
| otherwise = reconstruct (c acc) accCount
where
(var, stableAcc) = abstract acc id
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))
expOccCount = let StableNameHeight sn' _ = sn
in
lookupWithASTName expOccMap (StableASTName sn')
reconstruct :: PreExp SharingAcc SharingExp t -> NodeCounts
-> (SharingExp t, NodeCounts)
reconstruct newExp@(Tag _) _subCount
= let thisCount = StableSharingExp sn (ExpSharing sn newExp) `expNodeCount` 1
in
tracePure "FREE" (show thisCount) $
(VarSharing sn, thisCount)
reconstruct newExp subCount
| expOccCount > 1 && recoverExpSharing
= let allCount = (StableSharingExp sn sharingExp `expNodeCount` 1) +++ newCount
in
tracePure ("SHARED" ++ completed) (show allCount) $
(VarSharing sn, allCount)
| otherwise
= tracePure ("Normal" ++ completed) (show newCount) $
(sharingExp, newCount)
where
(newCount, bindHere) = filterCompleted subCount
lets = foldl (flip (.)) id . map LetSharing $ bindHere
sharingExp = lets $ ExpSharing sn newExp
completed | null bindHere = ""
| otherwise = " (" ++ show (length bindHere) ++ " lets)"
filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp])
filterCompleted counts
= let (completed, counts') = break notComplete counts
in (counts', [sa | ExpNodeCount sa _ <- completed])
where
notComplete nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa > n
notComplete _ = True
scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> RootExp e2, NodeCounts)
scopesFun1 f = (const body, counts)
where
(body, counts) = scopesExpInit (f undefined)
scopesFun2 :: (Elt e1, Elt e2)
=> (Exp e1 -> Exp e2 -> RootExp e3)
-> (Exp e1 -> Exp e2 -> RootExp e3, NodeCounts)
scopesFun2 f = (\_ _ -> body, counts)
where
(body, counts) = scopesExpInit (f undefined undefined)
scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil
=> SharingAcc (Array sh e1)
-> (stencil -> RootExp e2)
-> (stencil -> RootExp e2, NodeCounts)
scopesStencil1 _ stencilFun = (const body, counts)
where
(body, counts) = scopesExpInit (stencilFun undefined)
scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2.
(Stencil sh e1 stencil1, Stencil sh e2 stencil2)
=> SharingAcc (Array sh e1)
-> SharingAcc (Array sh e2)
-> (stencil1 -> stencil2 -> RootExp e3)
-> (stencil1 -> stencil2 -> RootExp e3, NodeCounts)
scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts)
where
(body, counts) = scopesExpInit (stencilFun undefined undefined)
recoverSharingAcc :: Typeable a => Bool -> Level -> [Level] -> Acc a -> (SharingAcc a, [StableSharingAcc])
recoverSharingAcc floatOutAcc lvl fvs acc
= let (acc', occMap) =
unsafePerformIO $ do
{ (acc', occMap) <- makeOccMap lvl acc
; occMapList <- Hash.toList occMap
; traceChunk "OccMap" $
show occMapList
; frozenOccMap <- freezeOccMap occMap
; return (acc', frozenOccMap)
}
in
determineScopes floatOutAcc fvs occMap acc'
instance Arrays arrs => Show (Acc arrs) where
show = show . convertAcc
instance Elt a => Show (Exp a) where
show = show . convertExp EmptyLayout [] . EnvExp undefined . toSharingExp
where
toSharingExp :: Exp b -> SharingExp b
toSharingExp (Exp pexp)
= case pexp of
Tag i -> ExpSharing undefined $ Tag i
Const v -> ExpSharing undefined $ Const v
Tuple tup -> ExpSharing undefined $ Tuple (toSharingTup tup)
Prj idx e -> ExpSharing undefined $ Prj idx (toSharingExp e)
IndexNil -> ExpSharing undefined $ IndexNil
IndexCons ix i -> ExpSharing undefined $ IndexCons (toSharingExp ix) (toSharingExp i)
IndexHead ix -> ExpSharing undefined $ IndexHead (toSharingExp ix)
IndexTail ix -> ExpSharing undefined $ IndexTail (toSharingExp ix)
IndexAny -> ExpSharing undefined $ IndexAny
Cond e1 e2 e3 -> ExpSharing undefined $ Cond (toSharingExp e1) (toSharingExp e2)
(toSharingExp e3)
PrimConst c -> ExpSharing undefined $ PrimConst c
PrimApp p e -> ExpSharing undefined $ PrimApp p (toSharingExp e)
IndexScalar a e -> ExpSharing undefined $ IndexScalar (fst $ recoverSharingAcc False 0 [] a)
(toSharingExp e)
Shape a -> ExpSharing undefined $ Shape (fst $ recoverSharingAcc False 0 [] a)
ShapeSize e -> ExpSharing undefined $ ShapeSize (toSharingExp e)
toSharingTup :: Tuple.Tuple Exp tup -> Tuple.Tuple SharingExp tup
toSharingTup NilTup = NilTup
toSharingTup (SnocTup tup e) = SnocTup (toSharingTup tup) (toSharingExp e)
showPreAccOp :: forall acc exp arrs. PreAcc acc exp arrs -> String
showPreAccOp (Atag i) = "Atag " ++ show i
showPreAccOp (Pipe _ _ _) = "Pipe"
showPreAccOp (Acond _ _ _) = "Acond"
showPreAccOp (Atuple _) = "Atuple"
showPreAccOp (Aprj _ _) = "Aprj"
showPreAccOp (Use a) = "Use " ++ showArrays a
showPreAccOp (Unit _) = "Unit"
showPreAccOp (Generate _ _) = "Generate"
showPreAccOp (Reshape _ _) = "Reshape"
showPreAccOp (Replicate _ _) = "Replicate"
showPreAccOp (Index _ _) = "Index"
showPreAccOp (Map _ _) = "Map"
showPreAccOp (ZipWith _ _ _) = "ZipWith"
showPreAccOp (Fold _ _ _) = "Fold"
showPreAccOp (Fold1 _ _) = "Fold1"
showPreAccOp (FoldSeg _ _ _ _) = "FoldSeg"
showPreAccOp (Fold1Seg _ _ _) = "Fold1Seg"
showPreAccOp (Scanl _ _ _) = "Scanl"
showPreAccOp (Scanl' _ _ _) = "Scanl'"
showPreAccOp (Scanl1 _ _) = "Scanl1"
showPreAccOp (Scanr _ _ _) = "Scanr"
showPreAccOp (Scanr' _ _ _) = "Scanr'"
showPreAccOp (Scanr1 _ _) = "Scanr1"
showPreAccOp (Permute _ _ _ _) = "Permute"
showPreAccOp (Backpermute _ _ _) = "Backpermute"
showPreAccOp (Stencil _ _ _) = "Stencil"
showPreAccOp (Stencil2 _ _ _ _ _) = "Stencil2"
showArrays :: forall arrs. Arrays arrs => arrs -> String
showArrays = display . collect (arrays (undefined::arrs)) . fromArr
where
collect :: ArraysR a -> a -> [String]
collect ArraysRunit _ = []
collect ArraysRarray arr = [showShortendArr arr]
collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2
display [] = []
display [x] = x
display xs = "(" ++ concat (intersperse ", " xs) ++ ")"
showShortendArr :: Elt e => Array sh e -> String
showShortendArr arr
= show (take cutoff l) ++ if length l > cutoff then ".." else ""
where
l = Sugar.toList arr
cutoff = 5
_showSharingAccOp :: SharingAcc arrs -> String
_showSharingAccOp (AvarSharing sn) = "AVAR " ++ show (hashStableNameHeight sn)
_showSharingAccOp (AletSharing _ acc) = "ALET " ++ _showSharingAccOp acc
_showSharingAccOp (AccSharing _ acc) = showPreAccOp acc
showPreExpOp :: PreExp acc exp t -> String
showPreExpOp (Tag _) = "Tag"
showPreExpOp (Const c) = "Const " ++ show c
showPreExpOp (Tuple _) = "Tuple"
showPreExpOp (Prj _ _) = "Prj"
showPreExpOp IndexNil = "IndexNil"
showPreExpOp (IndexCons _ _) = "IndexCons"
showPreExpOp (IndexHead _) = "IndexHead"
showPreExpOp (IndexTail _) = "IndexTail"
showPreExpOp IndexAny = "IndexAny"
showPreExpOp (Cond _ _ _) = "Cons"
showPreExpOp (PrimConst _) = "PrimConst"
showPreExpOp (PrimApp _ _) = "PrimApp"
showPreExpOp (IndexScalar _ _) = "IndexScalar"
showPreExpOp (Shape _) = "Shape"
showPreExpOp (ShapeSize _) = "ShapeSize"
mkIndex :: forall slix e aenv. (Slice slix, Elt e)
=> AST.OpenAcc aenv (Array (FullShape slix) e)
-> AST.Exp aenv slix
-> AST.PreOpenAcc AST.OpenAcc aenv (Array (SliceShape slix) e)
mkIndex arr e
= AST.Index (sliceIndex slix) arr e
where
slix = undefined :: slix
mkReplicate :: forall slix e aenv. (Slice slix, Elt e)
=> AST.Exp aenv slix
-> AST.OpenAcc aenv (Array (SliceShape slix) e)
-> AST.PreOpenAcc AST.OpenAcc aenv (Array (FullShape slix) e)
mkReplicate e arr
= AST.Replicate (sliceIndex slix) e arr
where
slix = undefined :: slix
atup2 :: (Arrays a, Arrays b) => (Acc a, Acc b) -> Acc (a, b)
atup2 (x1, x2) = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2)
atup3 :: (Arrays a, Arrays b, Arrays c) => (Acc a, Acc b, Acc c) -> Acc (a, b, c)
atup3 (x1, x2, x3) = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3)
atup4 :: (Arrays a, Arrays b, Arrays c, Arrays d)
=> (Acc a, Acc b, Acc c, Acc d) -> Acc (a, b, c, d)
atup4 (x1, x2, x3, x4)
= Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4)
atup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)
=> (Acc a, Acc b, Acc c, Acc d, Acc e) -> Acc (a, b, c, d, e)
atup5 (x1, x2, x3, x4, x5)
= Acc $ Atuple $
NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4 `SnocAtup` x5
atup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)
=> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) -> Acc (a, b, c, d, e, f)
atup6 (x1, x2, x3, x4, x5, x6)
= Acc $ Atuple $
NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3
`SnocAtup` x4 `SnocAtup` x5 `SnocAtup` x6
atup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)
=> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g)
-> Acc (a, b, c, d, e, f, g)
atup7 (x1, x2, x3, x4, x5, x6, x7)
= Acc $ Atuple $
NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3
`SnocAtup` x4 `SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7
atup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)
=> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h)
-> Acc (a, b, c, d, e, f, g, h)
atup8 (x1, x2, x3, x4, x5, x6, x7, x8)
= Acc $ Atuple $
NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4
`SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 `SnocAtup` x8
atup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)
=> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i)
-> Acc (a, b, c, d, e, f, g, h, i)
atup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9)
= Acc $ Atuple $
NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4
`SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 `SnocAtup` x8 `SnocAtup` x9
unatup2 :: (Arrays a, Arrays b) => Acc (a, b) -> (Acc a, Acc b)
unatup2 e = (Acc $ SuccTupIdx ZeroTupIdx `Aprj` e, Acc $ ZeroTupIdx `Aprj` e)
unatup3 :: (Arrays a, Arrays b, Arrays c) => Acc (a, b, c) -> (Acc a, Acc b, Acc c)
unatup3 e =
( Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e
, Acc $ SuccTupIdx ZeroTupIdx `Aprj` e
, Acc $ ZeroTupIdx `Aprj` e )
unatup4
:: (Arrays a, Arrays b, Arrays c, Arrays d)
=> Acc (a, b, c, d) -> (Acc a, Acc b, Acc c, Acc d)
unatup4 e =
( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e
, Acc $ SuccTupIdx ZeroTupIdx `Aprj` e
, Acc $ ZeroTupIdx `Aprj` e )
unatup5
:: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)
=> Acc (a, b, c, d, e) -> (Acc a, Acc b, Acc c, Acc d, Acc e)
unatup5 e =
( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e
, Acc $ SuccTupIdx ZeroTupIdx `Aprj` e
, Acc $ ZeroTupIdx `Aprj` e )
unatup6
:: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)
=> Acc (a, b, c, d, e, f) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f)
unatup6 e =
( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e
, Acc $ SuccTupIdx ZeroTupIdx `Aprj` e
, Acc $ ZeroTupIdx `Aprj` e )
unatup7
:: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)
=> Acc (a, b, c, d, e, f, g) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g)
unatup7 e =
( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e
, Acc $ SuccTupIdx ZeroTupIdx `Aprj` e
, Acc $ ZeroTupIdx `Aprj` e )
unatup8
:: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)
=> Acc (a, b, c, d, e, f, g, h) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h)
unatup8 e =
( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e
, Acc $ SuccTupIdx ZeroTupIdx `Aprj` e
, Acc $ ZeroTupIdx `Aprj` e )
unatup9
:: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)
=> Acc (a, b, c, d, e, f, g, h, i) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i)
unatup9 e =
( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e
, Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e
, Acc $ SuccTupIdx ZeroTupIdx `Aprj` e
, Acc $ ZeroTupIdx `Aprj` e )
class (Elt (StencilRepr sh stencil), AST.Stencil sh a (StencilRepr sh stencil))
=> Stencil sh a stencil where
type StencilRepr sh stencil :: *
stencilPrj :: sh -> a -> Exp (StencilRepr sh stencil) -> stencil
instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e) where
type StencilRepr DIM1 (Exp e, Exp e, Exp e)
= (e, e, e)
stencilPrj _ _ s = (Exp $ Prj tix2 s,
Exp $ Prj tix1 s,
Exp $ Prj tix0 s)
instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e) where
type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e)
= (e, e, e, e, e)
stencilPrj _ _ s = (Exp $ Prj tix4 s,
Exp $ Prj tix3 s,
Exp $ Prj tix2 s,
Exp $ Prj tix1 s,
Exp $ Prj tix0 s)
instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where
type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)
= (e, e, e, e, e, e, e)
stencilPrj _ _ s = (Exp $ Prj tix6 s,
Exp $ Prj tix5 s,
Exp $ Prj tix4 s,
Exp $ Prj tix3 s,
Exp $ Prj tix2 s,
Exp $ Prj tix1 s,
Exp $ Prj tix0 s)
instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)
where
type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)
= (e, e, e, e, e, e, e, e, e)
stencilPrj _ _ s = (Exp $ Prj tix8 s,
Exp $ Prj tix7 s,
Exp $ Prj tix6 s,
Exp $ Prj tix5 s,
Exp $ Prj tix4 s,
Exp $ Prj tix3 s,
Exp $ Prj tix2 s,
Exp $ Prj tix1 s,
Exp $ Prj tix0 s)
instance (Stencil (sh:.Int) a row2,
Stencil (sh:.Int) a row1,
Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row2, row1, row0) where
type StencilRepr (sh:.Int:.Int) (row2, row1, row0)
= (StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row0)
stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))
instance (Stencil (sh:.Int) a row1,
Stencil (sh:.Int) a row2,
Stencil (sh:.Int) a row3,
Stencil (sh:.Int) a row4,
Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where
type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5)
= (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,
StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5)
stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))
instance (Stencil (sh:.Int) a row1,
Stencil (sh:.Int) a row2,
Stencil (sh:.Int) a row3,
Stencil (sh:.Int) a row4,
Stencil (sh:.Int) a row5,
Stencil (sh:.Int) a row6,
Stencil (sh:.Int) a row7)
=> Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where
type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7)
= (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,
StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,
StencilRepr (sh:.Int) row7)
stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))
instance (Stencil (sh:.Int) a row1,
Stencil (sh:.Int) a row2,
Stencil (sh:.Int) a row3,
Stencil (sh:.Int) a row4,
Stencil (sh:.Int) a row5,
Stencil (sh:.Int) a row6,
Stencil (sh:.Int) a row7,
Stencil (sh:.Int) a row8,
Stencil (sh:.Int) a row9)
=> Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where
type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7, row8, row9)
= (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,
StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,
StencilRepr (sh:.Int) row7, StencilRepr (sh:.Int) row8, StencilRepr (sh:.Int) row9)
stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix8 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix7 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),
stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))
tix0 :: Elt s => TupleIdx (t, s) s
tix0 = ZeroTupIdx
tix1 :: Elt s => TupleIdx ((t, s), s1) s
tix1 = SuccTupIdx tix0
tix2 :: Elt s => TupleIdx (((t, s), s1), s2) s
tix2 = SuccTupIdx tix1
tix3 :: Elt s => TupleIdx ((((t, s), s1), s2), s3) s
tix3 = SuccTupIdx tix2
tix4 :: Elt s => TupleIdx (((((t, s), s1), s2), s3), s4) s
tix4 = SuccTupIdx tix3
tix5 :: Elt s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s
tix5 = SuccTupIdx tix4
tix6 :: Elt s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s
tix6 = SuccTupIdx tix5
tix7 :: Elt s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s
tix7 = SuccTupIdx tix6
tix8 :: Elt s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s
tix8 = SuccTupIdx tix7
constant :: Elt t => t -> Exp t
constant = Exp . Const
tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b)
tup2 (x1, x2) = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2)
tup3 :: (Elt a, Elt b, Elt c) => (Exp a, Exp b, Exp c) -> Exp (a, b, c)
tup3 (x1, x2, x3) = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3)
tup4 :: (Elt a, Elt b, Elt c, Elt d)
=> (Exp a, Exp b, Exp c, Exp d) -> Exp (a, b, c, d)
tup4 (x1, x2, x3, x4)
= Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4)
tup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e)
=> (Exp a, Exp b, Exp c, Exp d, Exp e) -> Exp (a, b, c, d, e)
tup5 (x1, x2, x3, x4, x5)
= Exp $ Tuple $
NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5
tup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)
=> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) -> Exp (a, b, c, d, e, f)
tup6 (x1, x2, x3, x4, x5, x6)
= Exp $ Tuple $
NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6
tup7 :: (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)
-> Exp (a, b, c, d, e, f, g)
tup7 (x1, x2, x3, x4, x5, x6, x7)
= Exp $ Tuple $
NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3
`SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7
tup8 :: (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)
-> Exp (a, b, c, d, e, f, g, h)
tup8 (x1, x2, x3, x4, x5, x6, x7, x8)
= Exp $ Tuple $
NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4
`SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8
tup9 :: (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)
-> Exp (a, b, c, d, e, f, g, h, i)
tup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9)
= Exp $ Tuple $
NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4
`SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9
untup2 :: (Elt a, Elt b) => Exp (a, b) -> (Exp a, Exp b)
untup2 e = (Exp $ SuccTupIdx ZeroTupIdx `Prj` e, Exp $ ZeroTupIdx `Prj` e)
untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c)
untup3 e = (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,
Exp $ SuccTupIdx ZeroTupIdx `Prj` e,
Exp $ ZeroTupIdx `Prj` e)
untup4 :: (Elt a, Elt b, Elt c, Elt d)
=> Exp (a, b, c, d) -> (Exp a, Exp b, Exp c, Exp d)
untup4 e = (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,
Exp $ SuccTupIdx ZeroTupIdx `Prj` e,
Exp $ ZeroTupIdx `Prj` e)
untup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e)
=> Exp (a, b, c, d, e) -> (Exp a, Exp b, Exp c, Exp d, Exp e)
untup5 e = (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,
Exp $ SuccTupIdx ZeroTupIdx `Prj` e,
Exp $ ZeroTupIdx `Prj` e)
untup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)
=> Exp (a, b, c, d, e, f) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)
untup6 e = (Exp $
SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,
Exp $ SuccTupIdx ZeroTupIdx `Prj` e,
Exp $ ZeroTupIdx `Prj` e)
untup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)
=> Exp (a, b, c, d, e, f, g) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)
untup7 e = (Exp $
SuccTupIdx
(SuccTupIdx
(SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,
Exp $
SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,
Exp $ SuccTupIdx ZeroTupIdx `Prj` e,
Exp $ ZeroTupIdx `Prj` e)
untup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)
=> Exp (a, b, c, d, e, f, g, h) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)
untup8 e = (Exp $
SuccTupIdx
(SuccTupIdx
(SuccTupIdx
(SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e,
Exp $
SuccTupIdx
(SuccTupIdx
(SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,
Exp $
SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,
Exp $ SuccTupIdx ZeroTupIdx `Prj` e,
Exp $ ZeroTupIdx `Prj` e)
untup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)
=> Exp (a, b, c, d, e, f, g, h, i) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)
untup9 e = (Exp $
SuccTupIdx
(SuccTupIdx
(SuccTupIdx
(SuccTupIdx
(SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e,
Exp $
SuccTupIdx
(SuccTupIdx
(SuccTupIdx
(SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e,
Exp $
SuccTupIdx
(SuccTupIdx
(SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,
Exp $
SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,
Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,
Exp $ SuccTupIdx ZeroTupIdx `Prj` e,
Exp $ ZeroTupIdx `Prj` e)
mkMinBound :: (Elt t, IsBounded t) => Exp t
mkMinBound = Exp $ PrimConst (PrimMinBound boundedType)
mkMaxBound :: (Elt t, IsBounded t) => Exp t
mkMaxBound = Exp $ PrimConst (PrimMaxBound boundedType)
mkPi :: (Elt r, IsFloating r) => Exp r
mkPi = Exp $ PrimConst (PrimPi floatingType)
mkSin :: (Elt t, IsFloating t) => Exp t -> Exp t
mkSin x = Exp $ PrimSin floatingType `PrimApp` x
mkCos :: (Elt t, IsFloating t) => Exp t -> Exp t
mkCos x = Exp $ PrimCos floatingType `PrimApp` x
mkTan :: (Elt t, IsFloating t) => Exp t -> Exp t
mkTan x = Exp $ PrimTan floatingType `PrimApp` x
mkAsin :: (Elt t, IsFloating t) => Exp t -> Exp t
mkAsin x = Exp $ PrimAsin floatingType `PrimApp` x
mkAcos :: (Elt t, IsFloating t) => Exp t -> Exp t
mkAcos x = Exp $ PrimAcos floatingType `PrimApp` x
mkAtan :: (Elt t, IsFloating t) => Exp t -> Exp t
mkAtan x = Exp $ PrimAtan floatingType `PrimApp` x
mkAsinh :: (Elt t, IsFloating t) => Exp t -> Exp t
mkAsinh x = Exp $ PrimAsinh floatingType `PrimApp` x
mkAcosh :: (Elt t, IsFloating t) => Exp t -> Exp t
mkAcosh x = Exp $ PrimAcosh floatingType `PrimApp` x
mkAtanh :: (Elt t, IsFloating t) => Exp t -> Exp t
mkAtanh x = Exp $ PrimAtanh floatingType `PrimApp` x
mkExpFloating :: (Elt t, IsFloating t) => Exp t -> Exp t
mkExpFloating x = Exp $ PrimExpFloating floatingType `PrimApp` x
mkSqrt :: (Elt t, IsFloating t) => Exp t -> Exp t
mkSqrt x = Exp $ PrimSqrt floatingType `PrimApp` x
mkLog :: (Elt t, IsFloating t) => Exp t -> Exp t
mkLog x = Exp $ PrimLog floatingType `PrimApp` x
mkFPow :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t
mkFPow x y = Exp $ PrimFPow floatingType `PrimApp` tup2 (x, y)
mkLogBase :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t
mkLogBase x y = Exp $ PrimLogBase floatingType `PrimApp` tup2 (x, y)
mkAdd :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t
mkAdd x y = Exp $ PrimAdd numType `PrimApp` tup2 (x, y)
mkSub :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t
mkSub x y = Exp $ PrimSub numType `PrimApp` tup2 (x, y)
mkMul :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t
mkMul x y = Exp $ PrimMul numType `PrimApp` tup2 (x, y)
mkNeg :: (Elt t, IsNum t) => Exp t -> Exp t
mkNeg x = Exp $ PrimNeg numType `PrimApp` x
mkAbs :: (Elt t, IsNum t) => Exp t -> Exp t
mkAbs x = Exp $ PrimAbs numType `PrimApp` x
mkSig :: (Elt t, IsNum t) => Exp t -> Exp t
mkSig x = Exp $ PrimSig numType `PrimApp` x
mkQuot :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t
mkQuot x y = Exp $ PrimQuot integralType `PrimApp` tup2 (x, y)
mkRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t
mkRem x y = Exp $ PrimRem integralType `PrimApp` tup2 (x, y)
mkIDiv :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t
mkIDiv x y = Exp $ PrimIDiv integralType `PrimApp` tup2 (x, y)
mkMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t
mkMod x y = Exp $ PrimMod integralType `PrimApp` tup2 (x, y)
mkBAnd :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t
mkBAnd x y = Exp $ PrimBAnd integralType `PrimApp` tup2 (x, y)
mkBOr :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t
mkBOr x y = Exp $ PrimBOr integralType `PrimApp` tup2 (x, y)
mkBXor :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t
mkBXor x y = Exp $ PrimBXor integralType `PrimApp` tup2 (x, y)
mkBNot :: (Elt t, IsIntegral t) => Exp t -> Exp t
mkBNot x = Exp $ PrimBNot integralType `PrimApp` x
mkBShiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t
mkBShiftL x i = Exp $ PrimBShiftL integralType `PrimApp` tup2 (x, i)
mkBShiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t
mkBShiftR x i = Exp $ PrimBShiftR integralType `PrimApp` tup2 (x, i)
mkBRotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t
mkBRotateL x i = Exp $ PrimBRotateL integralType `PrimApp` tup2 (x, i)
mkBRotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t
mkBRotateR x i = Exp $ PrimBRotateR integralType `PrimApp` tup2 (x, i)
mkFDiv :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t
mkFDiv x y = Exp $ PrimFDiv floatingType `PrimApp` tup2 (x, y)
mkRecip :: (Elt t, IsFloating t) => Exp t -> Exp t
mkRecip x = Exp $ PrimRecip floatingType `PrimApp` x
mkTruncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b
mkTruncate x = Exp $ PrimTruncate floatingType integralType `PrimApp` x
mkRound :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b
mkRound x = Exp $ PrimRound floatingType integralType `PrimApp` x
mkFloor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b
mkFloor x = Exp $ PrimFloor floatingType integralType `PrimApp` x
mkCeiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b
mkCeiling x = Exp $ PrimCeiling floatingType integralType `PrimApp` x
mkAtan2 :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t
mkAtan2 x y = Exp $ PrimAtan2 floatingType `PrimApp` tup2 (x, y)
mkLt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool
mkLt x y = Exp $ PrimLt scalarType `PrimApp` tup2 (x, y)
mkGt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool
mkGt x y = Exp $ PrimGt scalarType `PrimApp` tup2 (x, y)
mkLtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool
mkLtEq x y = Exp $ PrimLtEq scalarType `PrimApp` tup2 (x, y)
mkGtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool
mkGtEq x y = Exp $ PrimGtEq scalarType `PrimApp` tup2 (x, y)
mkEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool
mkEq x y = Exp $ PrimEq scalarType `PrimApp` tup2 (x, y)
mkNEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool
mkNEq x y = Exp $ PrimNEq scalarType `PrimApp` tup2 (x, y)
mkMax :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t
mkMax x y = Exp $ PrimMax scalarType `PrimApp` tup2 (x, y)
mkMin :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t
mkMin x y = Exp $ PrimMin scalarType `PrimApp` tup2 (x, y)
mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool
mkLAnd x y = Exp $ PrimLAnd `PrimApp` tup2 (x, y)
mkLOr :: Exp Bool -> Exp Bool -> Exp Bool
mkLOr x y = Exp $ PrimLOr `PrimApp` tup2 (x, y)
mkLNot :: Exp Bool -> Exp Bool
mkLNot x = Exp $ PrimLNot `PrimApp` x
mkFromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b
mkFromIntegral x = Exp $ PrimFromIntegral integralType numType `PrimApp` x
mkBoolToInt :: Exp Bool -> Exp Int
mkBoolToInt b = Exp $ PrimBoolToInt `PrimApp` b
infixr 0 $$
($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a
(f $$ g) x y = f (g x y)
infixr 0 $$$
($$$) :: (b -> a) -> (c -> d -> e -> b) -> c -> d -> e -> a
(f $$$ g) x y z = f (g x y z)
infixr 0 $$$$
($$$$) :: (b -> a) -> (c -> d -> e -> f -> b) -> c -> d -> e -> f -> a
(f $$$$ g) x y z u = f (g x y z u)
infixr 0 $$$$$
($$$$$) :: (b -> a) -> (c -> d -> e -> f -> g -> b) -> c -> d -> e -> f -> g-> a
(f $$$$$ g) x y z u v = f (g x y z u v)