{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Execute
-- Copyright   : [2014..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.LLVM.Execute (

  Execute(..), Delayed(..), Gamma,
  executeAcc,
  executeOpenAcc,

) where

import Data.Array.Accelerate.AST                                ( Direction, PreOpenAfun(..), ALeftHandSide, ArrayVar, Fun, OpenFun(..), Exp, OpenExp(..), PrimBool, arraysR, arrayR )
import Data.Array.Accelerate.AST.Idx
import Data.Array.Accelerate.AST.Var
import Data.Array.Accelerate.Analysis.Match
import Data.Array.Accelerate.Array.Data
import Data.Array.Accelerate.Interpreter                        ( evalPrim, evalPrimConst, evalCoerceScalar )
import Data.Array.Accelerate.Representation.Array
import Data.Array.Accelerate.Representation.Elt
import Data.Array.Accelerate.Representation.Shape
import Data.Array.Accelerate.Representation.Slice
import Data.Array.Accelerate.Representation.Tag
import Data.Array.Accelerate.Representation.Type
import Data.Array.Accelerate.Representation.Vec
import Data.Array.Accelerate.Type
import qualified Data.Array.Accelerate.Debug                    as Debug

import Data.Array.Accelerate.LLVM.AST                           hiding ( Delayed, Manifest )
import Data.Array.Accelerate.LLVM.Array.Data
import Data.Array.Accelerate.LLVM.CodeGen.Environment           ( Gamma )
import Data.Array.Accelerate.LLVM.Execute.Async
import Data.Array.Accelerate.LLVM.Execute.Environment
import Data.Array.Accelerate.LLVM.Link
import qualified Data.Array.Accelerate.LLVM.AST                 as AST

import Control.Monad
import System.IO.Unsafe
import Prelude                                                  hiding ( exp, map, unzip, scanl, scanr, scanl1, scanr1 )


class Remote arch => Execute arch where
  map           :: Maybe (a :~: b)              -- update values in-place?
                -> ArrayR (Array sh a)
                -> TypeR b
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Array sh a
                -> Par arch (FutureR arch (Array sh b))

  generate      :: ArrayR (Array sh e)
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> sh
                -> Par arch (FutureR arch (Array sh e))

  transform     :: ArrayR (Array sh a)
                -> ArrayR (Array sh' b)
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> sh'
                -> Array sh a
                -> Par arch (FutureR arch (Array sh' b))

  backpermute   :: ArrayR (Array sh e)
                -> ShapeR sh'
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> sh'
                -> Array sh e
                -> Par arch (FutureR arch (Array sh' e))

  fold          :: HasInitialValue
                -> ArrayR (Array sh e)
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Delayed (Array (sh, Int) e)
                -> Par arch (FutureR arch (Array sh e))

  foldSeg       :: IntegralType i
                -> HasInitialValue
                -> ArrayR (Array (sh, Int) e)
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Delayed (Array (sh, Int) e)
                -> Delayed (Segments i)
                -> Par arch (FutureR arch (Array (sh, Int) e))

  scan          :: Direction
                -> HasInitialValue
                -> ArrayR (Array (sh, Int) e)
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Delayed (Array (sh, Int) e)
                -> Par arch (FutureR arch (Array (sh, Int) e))

  scan'         :: Direction
                -> ArrayR (Array (sh, Int) e)
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Delayed (Array (sh, Int) e)
                -> Par arch (FutureR arch (Array (sh, Int) e, Array sh e))

  permute       :: Bool                         -- ^ update defaults array in-place?
                -> ArrayR (Array sh e)
                -> ShapeR sh'
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Array sh' e
                -> Delayed (Array sh e)
                -> Par arch (FutureR arch (Array sh' e))

  stencil1      :: TypeR a
                -> ArrayR (Array sh b)
                -> sh
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Delayed (Array sh a)
                -> Par arch (FutureR arch (Array sh b))

  stencil2      :: TypeR a
                -> TypeR b
                -> ArrayR (Array sh c)
                -> sh
                -> ExecutableR arch
                -> Gamma aenv
                -> ValR arch aenv
                -> Delayed (Array sh a)
                -> Delayed (Array sh b)
                -> Par arch (FutureR arch (Array sh c))

  aforeign      :: String
                -> ArraysR as
                -> ArraysR bs
                -> (as -> Par arch (FutureR arch bs))
                -> as
                -> Par arch (FutureR arch bs)

data Delayed a where
  Delayed       :: sh -> Delayed (Array sh e)
  Manifest      :: a  -> Delayed a


-- Array expression evaluation
-- ---------------------------

-- Computations are evaluated by traversing the AST bottom up, and for each node
-- distinguishing between three cases:
--
--  1. If it is a Use node, asynchronously transfer the data to the remote
--     device (if necessary).
--
--  2. If it is a non-skeleton node, such as a let-binding or shape conversion,
--     then execute directly by updating the environment or similar.
--
--  3. If it is a skeleton node, then we need to execute the compiled kernel for
--     that node.
--
{-# INLINEABLE executeAcc #-}
executeAcc
    :: Execute arch
    => ExecAcc arch a
    -> Par arch (FutureArraysR arch a)
executeAcc :: ExecAcc arch a -> Par arch (FutureArraysR arch a)
executeAcc !ExecAcc arch a
acc =
  ExecAcc arch a -> ValR arch () -> Par arch (FutureArraysR arch a)
forall arch aenv arrs.
Execute arch =>
ExecOpenAcc arch aenv arrs
-> ValR arch aenv -> Par arch (FutureArraysR arch arrs)
executeOpenAcc ExecAcc arch a
acc ValR arch ()
forall arch. ValR arch ()
Empty


{--
-- Execute a variadic array function
--
{-# INLINEABLE executeAfun #-}
executeAfun
    :: ExecuteAfun arch f
    => ExecAfun arch (ExecAfunR arch f)
    -> f
executeAfun f = executeOpenAfun f (return Aempty)

class ExecuteAfun arch f where
  type ExecAfunR arch f
  executeOpenAfun :: ExecOpenAfun arch aenv (ExecAfunR arch f) -> Par arch (AvalR arch aenv) -> f

instance (Remote arch, ExecuteAfun arch b) => ExecuteAfun arch (a -> b) where
  type ExecAfunR arch (a -> b) = a -> ExecAfunR arch b
  {-# INLINEABLE executeOpenAfun #-}
  executeOpenAfun Abody{}      _ _    = $internalError "executeOpenAfun" "malformed array function"
  executeOpenAfun (Alam lhs f) k arrs =
    let k' = do aenv <- k
                a    <- useRemoteAsync arrs
                return (aenv `Apush` a)
    in
    executeOpenAfun f k'

instance Execute arch => ExecuteAfun arch (Par arch b) where
  type ExecAfunR arch (Par arch b) = b
  {-# INLINEABLE executeOpenAfun #-}
  executeOpenAfun Alam{}    _ = $internalError "executeOpenAfun" "function not fully applied"
  executeOpenAfun (Abody b) k = do
    aenv <- k
    executeOpenAcc b aenv
--}


-- NOTE: [ExecuteAfun and closed type families]
--
-- It would be nice to use something like the following closed type family
-- instance, and implement 'executeOpenAfun' as a regular recursive function,
-- rather than as a class function.
--
-- > type family ExecAfunR arch r :: * where
-- >   ExecAfunR arch (a -> b) = a -> ExecAfunR arch b
-- >   ExecAfunR arch r        = LLVM arch r
-- >
-- > executeOpenAfun
-- >     :: Execute arch
-- >     => ExecOpenAfun arch aenv f
-- >     -> LLVM arch (AvalR arch aenv)
-- >     -> ExecAfunR arch f
-- > executeOpenAfun (Alam f)  k = \arrs -> ...
-- > executeOpenAfun (Abody b) k = do ...
--
-- However, closed type families don't quite work the way that we might think.
-- It seems that they rely on some notion of type inequality, or at least types
-- which don't have a unifier.
--
-- When we match of the `Abody` constructor, we expose a constraint of the form
-- `Arrays a, T a ~ a0`. For the type checker to figure out that
-- `a0 ~ LLVM arch a`, it needs to know that it _can not_ match on the first
-- case of the type family; i.e., that `a` can't unify with `b -> c`. Since it
-- doesn't have constraints to figure that out, it doesn't proceed and fall
-- through to the case that we want. If we had something like `a ~ Array sh e`,
-- then it could.
--


-- Execute an open array computation
--
{-# INLINEABLE executeOpenAcc #-}
executeOpenAcc
    :: forall arch aenv arrs. Execute arch
    => ExecOpenAcc arch aenv arrs
    -> ValR arch aenv
    -> Par arch (FutureArraysR arch arrs)
executeOpenAcc :: ExecOpenAcc arch aenv arrs
-> ValR arch aenv -> Par arch (FutureArraysR arch arrs)
executeOpenAcc !ExecOpenAcc arch aenv arrs
topAcc !ValR arch aenv
aenv = ExecOpenAcc arch aenv arrs -> Par arch (FutureArraysR arch arrs)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv arrs
topAcc
  where
    travA :: ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
    travA :: ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA (EvalAcc ArraysR a
_ PreOpenAccCommand ExecOpenAcc arch aenv a
pacc) =
      case PreOpenAccCommand ExecOpenAcc arch aenv a
pacc of
        Use ArrayR (Array sh e)
repr Array sh e
arr        -> Par arch (FutureR arch (Array sh e))
-> Par arch (FutureR arch (Array sh e))
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch (Array sh e))
 -> Par arch (FutureR arch (Array sh e)))
-> Par arch (FutureR arch (Array sh e))
-> Par arch (FutureR arch (Array sh e))
forall a b. (a -> b) -> a -> b
$ ArraysR (Array sh e)
-> Array sh e -> Par arch (FutureArraysR arch (Array sh e))
forall arch arrs.
Remote arch =>
ArraysR arrs -> arrs -> Par arch (FutureArraysR arch arrs)
useRemoteAsync (ArrayR (Array sh e) -> ArraysR (Array sh e)
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle ArrayR (Array sh e)
repr) Array sh e
arr
        Unit TypeR e
tp Exp aenv e
x           -> TypeR e -> Exp aenv e -> Par arch (FutureR arch (Scalar e))
forall t.
TypeR t -> Exp aenv t -> Par arch (FutureR arch (Scalar t))
unit TypeR e
tp Exp aenv e
x
        Avar (Var ArrayR{} Idx aenv a
ix) -> FutureR arch (Array sh e) -> Par arch (FutureR arch (Array sh e))
forall (m :: * -> *) a. Monad m => a -> m a
return (FutureR arch (Array sh e) -> Par arch (FutureR arch (Array sh e)))
-> FutureR arch (Array sh e)
-> Par arch (FutureR arch (Array sh e))
forall a b. (a -> b) -> a -> b
$ Idx aenv a -> ValR arch aenv -> FutureR arch a
forall env t arch. Idx env t -> ValR arch env -> FutureR arch t
prj Idx aenv a
ix ValR arch aenv
aenv
        Alet ALeftHandSide bnd aenv aenv'
lhs ExecOpenAcc arch aenv bnd
bnd ExecOpenAcc arch aenv' a
body      -> ALeftHandSide bnd aenv aenv'
-> ExecOpenAcc arch aenv bnd
-> ExecOpenAcc arch aenv' a
-> Par arch (FutureArraysR arch a)
forall a aenv' b.
ALeftHandSide a aenv aenv'
-> ExecOpenAcc arch aenv a
-> ExecOpenAcc arch aenv' b
-> Par arch (FutureArraysR arch b)
alet ALeftHandSide bnd aenv aenv'
lhs ExecOpenAcc arch aenv bnd
bnd ExecOpenAcc arch aenv' a
body
        Apair ExecOpenAcc arch aenv arrs1
a1 ExecOpenAcc arch aenv arrs2
a2            -> (FutureArraysR arch arrs1
 -> FutureArraysR arch arrs2
 -> (FutureArraysR arch arrs1, FutureArraysR arch arrs2))
-> Par arch (FutureArraysR arch arrs1)
-> Par arch (FutureArraysR arch arrs2)
-> Par arch (FutureArraysR arch arrs1, FutureArraysR arch arrs2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (ExecOpenAcc arch aenv arrs1 -> Par arch (FutureArraysR arch arrs1)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv arrs1
a1) (ExecOpenAcc arch aenv arrs2 -> Par arch (FutureArraysR arch arrs2)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv arrs2
a2)
        PreOpenAccCommand ExecOpenAcc arch aenv a
Anil                   -> () -> Par arch ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Alloc ArrayR (Array sh e)
repr Exp aenv sh
sh          -> ArrayR (Array sh e)
-> Exp aenv sh -> Par arch (FutureR arch (Array sh e))
forall sh e.
ArrayR (Array sh e)
-> Exp aenv sh -> Par arch (FutureR arch (Array sh e))
allocate ArrayR (Array sh e)
repr Exp aenv sh
sh
        Apply ArraysR a
_ PreOpenAfun (ExecOpenAcc arch) aenv (as -> a)
f ExecOpenAcc arch aenv as
a            -> PreOpenAfun (ExecOpenAcc arch) aenv (as -> a)
-> FutureArraysR arch as -> Par arch (FutureArraysR arch a)
forall a b.
ExecOpenAfun arch aenv (a -> b)
-> FutureArraysR arch a -> Par arch (FutureArraysR arch b)
travAF PreOpenAfun (ExecOpenAcc arch) aenv (as -> a)
f (FutureArraysR arch as -> Par arch (FutureArraysR arch a))
-> Par arch (FutureArraysR arch as)
-> Par arch (FutureArraysR arch a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Par arch (FutureArraysR arch as)
-> Par arch (FutureArraysR arch as)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (ExecOpenAcc arch aenv as -> Par arch (FutureArraysR arch as)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv as
a)
        -- We need quite some type applications in the rules for acond and awhile, and cannot use do notation.
        -- For some unknown reason, GHC will "simplify" 'FutureArraysR arch a' to 'FutureR arch a', which is not sound.
        -- It then complains that 'FutureR arch a' isn't assignable to 'FutureArraysR arch a'. By adding explicit
        -- type applications, type checking works fine. This appears to be fixed in GHC 8.8; we don't have problems
        -- with type inference there after removing the explicit type applications.
        Acond Exp aenv PrimBool
p (ExecOpenAcc arch aenv a
t :: ExecOpenAcc arch aenv a) ExecOpenAcc arch aenv a
e
                               -> Par arch (FutureR arch PrimBool)
-> (FutureR arch PrimBool -> Par arch (FutureArraysR arch a))
-> Par arch (FutureArraysR arch a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) @(Par arch) @(FutureR arch PrimBool) @(FutureArraysR arch a) (Exp aenv PrimBool -> Par arch (FutureR arch PrimBool)
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv PrimBool
p) (ExecOpenAcc arch aenv a
-> ExecOpenAcc arch aenv a
-> FutureR arch PrimBool
-> Par arch (FutureArraysR arch a)
forall a.
ExecOpenAcc arch aenv a
-> ExecOpenAcc arch aenv a
-> FutureR arch PrimBool
-> Par arch (FutureArraysR arch a)
acond ExecOpenAcc arch aenv a
t ExecOpenAcc arch aenv a
e)
        Awhile PreOpenAfun (ExecOpenAcc arch) aenv (a -> Scalar PrimBool)
p PreOpenAfun (ExecOpenAcc arch) aenv (a -> a)
f (ExecOpenAcc arch aenv a
a :: ExecOpenAcc arch aenv a)
                               -> Par arch (FutureArraysR arch a)
-> (FutureArraysR arch a -> Par arch (FutureArraysR arch a))
-> Par arch (FutureArraysR arch a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) @(Par arch) @(FutureArraysR arch a) @(FutureArraysR arch a)
                                    (HasCallStack =>
Par arch (FutureArraysR arch a) -> Par arch (FutureArraysR arch a)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn @arch @(FutureArraysR arch a) (Par arch (FutureArraysR arch a)
 -> Par arch (FutureArraysR arch a))
-> Par arch (FutureArraysR arch a)
-> Par arch (FutureArraysR arch a)
forall a b. (a -> b) -> a -> b
$ ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv a
a)
                                    (PreOpenAfun (ExecOpenAcc arch) aenv (a -> Scalar PrimBool)
-> PreOpenAfun (ExecOpenAcc arch) aenv (a -> a)
-> FutureArraysR arch a
-> Par arch (FutureArraysR arch a)
forall a.
ExecOpenAfun arch aenv (a -> Scalar PrimBool)
-> ExecOpenAfun arch aenv (a -> a)
-> FutureArraysR arch a
-> Par arch (FutureArraysR arch a)
awhile PreOpenAfun (ExecOpenAcc arch) aenv (a -> Scalar PrimBool)
p PreOpenAfun (ExecOpenAcc arch) aenv (a -> a)
f)
        Reshape ShapeR sh
shr Exp aenv sh
sh (Var (ArrayR ShapeR sh
shr' TypeR e
_) Idx aenv (Array sh' e)
ix)
                               -> (sh -> Array sh e -> Array sh e)
-> Par arch (FutureR arch sh)
-> Par arch (FutureR arch (Array sh e))
-> Par arch (FutureR arch (Array sh e))
forall arch a b c.
Async arch =>
(a -> b -> c)
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
liftF2 (\sh
s -> ShapeR sh -> sh -> ShapeR sh -> Array sh e -> Array sh e
forall sh sh' e.
HasCallStack =>
ShapeR sh -> sh -> ShapeR sh' -> Array sh' e -> Array sh e
reshape ShapeR sh
shr sh
s ShapeR sh
shr') (Exp aenv sh -> Par arch (FutureR arch sh)
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv sh
sh) (FutureR arch (Array sh' e) -> Par arch (FutureR arch (Array sh' e))
forall (m :: * -> *) a. Monad m => a -> m a
return (FutureR arch (Array sh' e)
 -> Par arch (FutureR arch (Array sh' e)))
-> FutureR arch (Array sh' e)
-> Par arch (FutureR arch (Array sh' e))
forall a b. (a -> b) -> a -> b
$ Idx aenv (Array sh' e)
-> ValR arch aenv -> FutureR arch (Array sh' e)
forall env t arch. Idx env t -> ValR arch env -> FutureR arch t
prj Idx aenv (Array sh' e)
ix ValR arch aenv
aenv)
        Unzip UnzipIdx tup e
tix (Var ArrayR (Array sh tup)
_ Idx aenv (Array sh tup)
ix)   -> (Array sh tup -> Array sh e)
-> Par arch (FutureR arch (Array sh tup))
-> Par arch (FutureR arch (Array sh e))
forall arch a b.
Async arch =>
(a -> b) -> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
liftF1 (UnzipIdx tup e -> Array sh tup -> Array sh e
forall t e sh. UnzipIdx t e -> Array sh t -> Array sh e
unzip UnzipIdx tup e
tix) (FutureR arch (Array sh tup)
-> Par arch (FutureR arch (Array sh tup))
forall (m :: * -> *) a. Monad m => a -> m a
return (FutureR arch (Array sh tup)
 -> Par arch (FutureR arch (Array sh tup)))
-> FutureR arch (Array sh tup)
-> Par arch (FutureR arch (Array sh tup))
forall a b. (a -> b) -> a -> b
$ Idx aenv (Array sh tup)
-> ValR arch aenv -> FutureR arch (Array sh tup)
forall env t arch. Idx env t -> ValR arch env -> FutureR arch t
prj Idx aenv (Array sh tup)
ix ValR arch aenv
aenv)
        Aforeign ArraysR a
r String
str as -> Par arch (FutureR arch a)
asm ExecOpenAcc arch aenv as
a   -> do
          FutureArraysR arch as
x <- ExecOpenAcc arch aenv as -> Par arch (FutureArraysR arch as)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv as
a
          FutureR arch a
y <- Par arch (FutureR arch a) -> Par arch (FutureR arch a)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch a) -> Par arch (FutureR arch a))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch a)
forall a b. (a -> b) -> a -> b
$ String
-> ArraysR as
-> ArraysR a
-> (as -> Par arch (FutureR arch a))
-> as
-> Par arch (FutureR arch a)
forall arch as bs.
Execute arch =>
String
-> ArraysR as
-> ArraysR bs
-> (as -> Par arch (FutureR arch bs))
-> as
-> Par arch (FutureR arch bs)
aforeign String
str (ExecOpenAcc arch aenv as -> ArraysR as
forall (f :: * -> * -> *) aenv a.
HasArraysR f =>
f aenv a -> ArraysR a
arraysR ExecOpenAcc arch aenv as
a) ArraysR a
r as -> Par arch (FutureR arch a)
asm (as -> Par arch (FutureR arch a))
-> Par arch as -> Par arch (FutureR arch a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArraysR as -> FutureArraysR arch as -> Par arch as
forall arch a.
Async arch =>
ArraysR a -> FutureArraysR arch a -> Par arch a
getArrays (ExecOpenAcc arch aenv as -> ArraysR as
forall (f :: * -> * -> *) aenv a.
HasArraysR f =>
f aenv a -> ArraysR a
arraysR ExecOpenAcc arch aenv as
a) FutureArraysR arch as
x
          ArraysR a -> FutureR arch a -> Par arch (FutureArraysR arch a)
forall arch a.
Execute arch =>
ArraysR a -> FutureR arch a -> Par arch (FutureArraysR arch a)
split ArraysR a
r FutureR arch a
y

    travA (ExecAcc ArraysR a
_ !Gamma aenv
gamma !ExecutableR arch
kernel PreOpenAccSkeleton ExecOpenAcc arch aenv a
pacc) =
      case PreOpenAccSkeleton ExecOpenAcc arch aenv a
pacc of
        -- Producers
        Map TypeR b
tp ExecOpenAcc arch aenv (Array sh a)
a               -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Array sh a
 -> Par arch (FutureR arch (Array sh b)))
-> Par arch (FutureR arch (Array sh a))
-> Par arch (FutureR arch (Array sh b))
forall a b.
(ExecutableR arch
 -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
exec1 (ExecOpenAcc arch aenv (Array sh a)
-> ArrayR (Array sh a)
-> TypeR b
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh a
-> Par arch (FutureR arch (Array sh b))
forall sh a b.
ExecOpenAcc arch aenv (Array sh a)
-> ArrayR (Array sh a)
-> TypeR b
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh a
-> Par arch (FutureR arch (Array sh b))
map_ ExecOpenAcc arch aenv (Array sh a)
a (ExecOpenAcc arch aenv (Array sh a) -> ArrayR (Array sh a)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR ExecOpenAcc arch aenv (Array sh a)
a) TypeR b
tp) (ExecOpenAcc arch aenv (Array sh a)
-> Par arch (FutureArraysR arch (Array sh a))
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv (Array sh a)
a)
        Generate ArrayR (Array sh e)
repr Exp aenv sh
sh       -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> sh
 -> Par arch (FutureR arch (Array sh e)))
-> Par arch (FutureR arch sh)
-> Par arch (FutureR arch (Array sh e))
forall a b.
(ExecutableR arch
 -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
exec1 (ArrayR (Array sh e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> sh
-> Par arch (FutureR arch (Array sh e))
forall arch sh e aenv.
Execute arch =>
ArrayR (Array sh e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> sh
-> Par arch (FutureR arch (Array sh e))
generate ArrayR (Array sh e)
repr) (Exp aenv sh -> Par arch (FutureR arch sh)
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv sh
sh)
        Transform ArrayR (Array sh' b)
repr Exp aenv sh'
sh ExecOpenAcc arch aenv (Array sh a)
a    -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> sh'
 -> Array sh a
 -> Par arch (FutureR arch (Array sh' b)))
-> Par arch (FutureR arch sh')
-> Par arch (FutureR arch (Array sh a))
-> Par arch (FutureR arch (Array sh' b))
forall a b c.
(ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> a
 -> b
 -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
exec2 (ArrayR (Array sh a)
-> ArrayR (Array sh' b)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> sh'
-> Array sh a
-> Par arch (FutureR arch (Array sh' b))
forall arch sh a sh' b aenv.
Execute arch =>
ArrayR (Array sh a)
-> ArrayR (Array sh' b)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> sh'
-> Array sh a
-> Par arch (FutureR arch (Array sh' b))
transform (ExecOpenAcc arch aenv (Array sh a) -> ArrayR (Array sh a)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR ExecOpenAcc arch aenv (Array sh a)
a) ArrayR (Array sh' b)
repr) (Exp aenv sh' -> Par arch (FutureR arch sh')
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv sh'
sh) (ExecOpenAcc arch aenv (Array sh a)
-> Par arch (FutureArraysR arch (Array sh a))
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv (Array sh a)
a)
        Backpermute ShapeR sh'
shr Exp aenv sh'
sh ExecOpenAcc arch aenv (Array sh e)
a   -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> sh'
 -> Array sh e
 -> Par arch (FutureR arch (Array sh' e)))
-> Par arch (FutureR arch sh')
-> Par arch (FutureR arch (Array sh e))
-> Par arch (FutureR arch (Array sh' e))
forall a b c.
(ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> a
 -> b
 -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
exec2 (ArrayR (Array sh e)
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> sh'
-> Array sh e
-> Par arch (FutureR arch (Array sh' e))
forall arch sh e sh' aenv.
Execute arch =>
ArrayR (Array sh e)
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> sh'
-> Array sh e
-> Par arch (FutureR arch (Array sh' e))
backpermute (ExecOpenAcc arch aenv (Array sh e) -> ArrayR (Array sh e)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR ExecOpenAcc arch aenv (Array sh e)
a) ShapeR sh'
shr) (Exp aenv sh' -> Par arch (FutureR arch sh')
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv sh'
sh) (ExecOpenAcc arch aenv (Array sh e)
-> Par arch (FutureArraysR arch (Array sh e))
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv (Array sh e)
a)

        -- Consumers
        Fold HasInitialValue
z DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a               -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Par arch (FutureR arch (Array sh e)))
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
-> Par arch (FutureR arch (Array sh e))
forall a b.
(ExecutableR arch
 -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
exec1 (HasInitialValue
-> ArrayR (Array sh e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array sh e))
forall arch sh e aenv.
Execute arch =>
HasInitialValue
-> ArrayR (Array sh e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array sh e))
fold HasInitialValue
z     (ArrayR (Array sh e)
 -> ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Par arch (FutureR arch (Array sh e)))
-> ArrayR (Array sh e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array sh e))
forall a b. (a -> b) -> a -> b
$ ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e)
forall sh e. ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e)
reduceRank (ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e))
-> ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e)
forall a b. (a -> b) -> a -> b
$ DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> ArrayR (Array (sh, Int) e)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a) (DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a)
        FoldSeg IntegralType i
i HasInitialValue
z DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a DelayedOpenAcc ExecOpenAcc arch aenv (Segments i)
s        -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Delayed (Segments i)
 -> Par arch (FutureR arch (Array (sh, Int) e)))
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
-> Par arch (FutureR arch (Delayed (Segments i)))
-> Par arch (FutureR arch (Array (sh, Int) e))
forall a b c.
(ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> a
 -> b
 -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
exec2 (IntegralType i
-> HasInitialValue
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Delayed (Segments i)
-> Par arch (FutureR arch (Array (sh, Int) e))
forall arch i sh e aenv.
Execute arch =>
IntegralType i
-> HasInitialValue
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Delayed (Segments i)
-> Par arch (FutureR arch (Array (sh, Int) e))
foldSeg IntegralType i
i HasInitialValue
z (ArrayR (Array (sh, Int) e)
 -> ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Delayed (Segments i)
 -> Par arch (FutureR arch (Array (sh, Int) e)))
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Delayed (Segments i)
-> Par arch (FutureR arch (Array (sh, Int) e))
forall a b. (a -> b) -> a -> b
$             DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> ArrayR (Array (sh, Int) e)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a) (DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a) (DelayedOpenAcc ExecOpenAcc arch aenv (Segments i)
-> Par arch (FutureR arch (Delayed (Segments i)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Segments i)
s)
        Scan Direction
d HasInitialValue
z DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a             -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Par arch (FutureR arch (Array (sh, Int) e)))
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
-> Par arch (FutureR arch (Array (sh, Int) e))
forall a b.
(ExecutableR arch
 -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
exec1 (Direction
-> HasInitialValue
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array (sh, Int) e))
forall arch sh e aenv.
Execute arch =>
Direction
-> HasInitialValue
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array (sh, Int) e))
scan Direction
d HasInitialValue
z   (ArrayR (Array (sh, Int) e)
 -> ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Par arch (FutureR arch (Array (sh, Int) e)))
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array (sh, Int) e))
forall a b. (a -> b) -> a -> b
$              DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> ArrayR (Array (sh, Int) e)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a) (DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a)
        Scan' Direction
d DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a              -> Par arch (FutureR arch (Array (sh, Int) e, Array sh e))
-> Par
     arch (FutureR arch (Array (sh, Int) e), FutureR arch (Array sh e))
forall a b.
Par arch (FutureR arch (a, b))
-> Par arch (FutureR arch a, FutureR arch b)
splitPair
                                (Par arch (FutureR arch (Array (sh, Int) e, Array sh e))
 -> Par
      arch (FutureR arch (Array (sh, Int) e), FutureR arch (Array sh e)))
-> Par arch (FutureR arch (Array (sh, Int) e, Array sh e))
-> Par
     arch (FutureR arch (Array (sh, Int) e), FutureR arch (Array sh e))
forall a b. (a -> b) -> a -> b
$ (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Par arch (FutureR arch (Array (sh, Int) e, Array sh e)))
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
-> Par arch (FutureR arch (Array (sh, Int) e, Array sh e))
forall a b.
(ExecutableR arch
 -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
exec1 (Direction
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array (sh, Int) e, Array sh e))
forall arch sh e aenv.
Execute arch =>
Direction
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array (sh, Int) e, Array sh e))
scan' Direction
d    (ArrayR (Array (sh, Int) e)
 -> ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array (sh, Int) e)
 -> Par arch (FutureR arch (Array (sh, Int) e, Array sh e)))
-> ArrayR (Array (sh, Int) e)
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array (sh, Int) e)
-> Par arch (FutureR arch (Array (sh, Int) e, Array sh e))
forall a b. (a -> b) -> a -> b
$              DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> ArrayR (Array (sh, Int) e)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a) (DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
-> Par arch (FutureR arch (Delayed (Array (sh, Int) e)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array (sh, Int) e)
a)
        Permute ExecOpenAcc arch aenv (Array sh' e)
d DelayedOpenAcc ExecOpenAcc arch aenv (Array sh e)
a            -> (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Array sh' e
 -> Delayed (Array sh e)
 -> Par arch (FutureR arch (Array sh' e)))
-> Par arch (FutureR arch (Array sh' e))
-> Par arch (FutureR arch (Delayed (Array sh e)))
-> Par arch (FutureR arch (Array sh' e))
forall a b c.
(ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> a
 -> b
 -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
exec2 (ExecOpenAcc arch aenv (Array sh' e)
-> ArrayR (Array sh e)
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh' e
-> Delayed (Array sh e)
-> Par arch (FutureR arch (Array sh' e))
forall sh' e sh.
ExecOpenAcc arch aenv (Array sh' e)
-> ArrayR (Array sh e)
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh' e
-> Delayed (Array sh e)
-> Par arch (FutureR arch (Array sh' e))
permute_ ExecOpenAcc arch aenv (Array sh' e)
d (DelayedOpenAcc ExecOpenAcc arch aenv (Array sh e)
-> ArrayR (Array sh e)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array sh e)
a) (ShapeR sh'
 -> ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Array sh' e
 -> Delayed (Array sh e)
 -> Par arch (FutureR arch (Array sh' e)))
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh' e
-> Delayed (Array sh e)
-> Par arch (FutureR arch (Array sh' e))
forall a b. (a -> b) -> a -> b
$ ArrayR (Array sh' e) -> ShapeR sh'
forall sh e. ArrayR (Array sh e) -> ShapeR sh
arrayRshape (ArrayR (Array sh' e) -> ShapeR sh')
-> ArrayR (Array sh' e) -> ShapeR sh'
forall a b. (a -> b) -> a -> b
$ ExecOpenAcc arch aenv (Array sh' e) -> ArrayR (Array sh' e)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR ExecOpenAcc arch aenv (Array sh' e)
d) (ExecOpenAcc arch aenv (Array sh' e)
-> Par arch (FutureArraysR arch (Array sh' e))
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv (Array sh' e)
d) (DelayedOpenAcc ExecOpenAcc arch aenv (Array sh e)
-> Par arch (FutureR arch (Delayed (Array sh e)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array sh e)
a)
        Stencil1 TypeR b
tpB sh
h DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
a       -> let ArrayR ShapeR sh
shr TypeR e
tpA = DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
-> ArrayR (Array sh a)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
a
                                  in  (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array sh a)
 -> Par arch (FutureR arch (Array sh b)))
-> Par arch (FutureR arch (Delayed (Array sh a)))
-> Par arch (FutureR arch (Array sh b))
forall a b.
(ExecutableR arch
 -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
exec1 (TypeR a
-> ArrayR (Array sh b)
-> sh
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array sh a)
-> Par arch (FutureR arch (Array sh b))
forall arch a sh b aenv.
Execute arch =>
TypeR a
-> ArrayR (Array sh b)
-> sh
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array sh a)
-> Par arch (FutureR arch (Array sh b))
stencil1 TypeR a
tpA (ShapeR sh -> TypeR b -> ArrayR (Array sh b)
forall sh e. ShapeR sh -> TypeR e -> ArrayR (Array sh e)
ArrayR ShapeR sh
shr TypeR b
tpB) sh
h) (DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
-> Par arch (FutureR arch (Delayed (Array sh a)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
a)
        Stencil2 TypeR c
tpC sh
h DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
a DelayedOpenAcc ExecOpenAcc arch aenv (Array sh b)
b     -> let ArrayR ShapeR sh
shr TypeR e
tpA = DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
-> ArrayR (Array sh a)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
a
                                      ArrayR ShapeR sh
_   TypeR e
tpB = DelayedOpenAcc ExecOpenAcc arch aenv (Array sh b)
-> ArrayR (Array sh b)
forall (f :: * -> * -> *) aenv sh e.
HasArraysR f =>
f aenv (Array sh e) -> ArrayR (Array sh e)
arrayR DelayedOpenAcc ExecOpenAcc arch aenv (Array sh b)
b
                                  in  (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> Delayed (Array sh a)
 -> Delayed (Array sh b)
 -> Par arch (FutureR arch (Array sh c)))
-> Par arch (FutureR arch (Delayed (Array sh a)))
-> Par arch (FutureR arch (Delayed (Array sh b)))
-> Par arch (FutureR arch (Array sh c))
forall a b c.
(ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> a
 -> b
 -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
exec2 (TypeR a
-> TypeR b
-> ArrayR (Array sh c)
-> sh
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array sh a)
-> Delayed (Array sh b)
-> Par arch (FutureR arch (Array sh c))
forall arch a b sh c aenv.
Execute arch =>
TypeR a
-> TypeR b
-> ArrayR (Array sh c)
-> sh
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Delayed (Array sh a)
-> Delayed (Array sh b)
-> Par arch (FutureR arch (Array sh c))
stencil2 TypeR a
tpA TypeR b
tpB (ShapeR sh -> TypeR c -> ArrayR (Array sh c)
forall sh e. ShapeR sh -> TypeR e -> ArrayR (Array sh e)
ArrayR ShapeR sh
shr TypeR c
tpC) sh
h) (DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
-> Par arch (FutureR arch (Delayed (Array sh a)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array sh a)
a) (DelayedOpenAcc ExecOpenAcc arch aenv (Array sh b)
-> Par arch (FutureR arch (Delayed (Array sh b)))
forall a.
DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD DelayedOpenAcc ExecOpenAcc arch aenv (Array sh b)
b)

      where
        exec1 :: (ExecutableR arch -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
              -> Par arch (FutureR arch a)
              -> Par arch (FutureR arch b)
        exec1 :: (ExecutableR arch
 -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
exec1 ExecutableR arch
-> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b)
f Par arch (FutureR arch a)
x = do
          FutureR arch a
x' <- Par arch (FutureR arch a)
x
          Par arch (FutureR arch b) -> Par arch (FutureR arch b)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch b) -> Par arch (FutureR arch b))
-> Par arch (FutureR arch b) -> Par arch (FutureR arch b)
forall a b. (a -> b) -> a -> b
$ ExecutableR arch
-> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b)
f ExecutableR arch
kernel Gamma aenv
gamma ValR arch aenv
aenv (a -> Par arch (FutureR arch b))
-> Par arch a -> Par arch (FutureR arch b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutureR arch a -> Par arch a
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch a
x'

        exec2 :: (ExecutableR arch -> Gamma aenv -> ValR arch aenv -> a -> b -> Par arch (FutureR arch c))
              -> Par arch (FutureR arch a)
              -> Par arch (FutureR arch b)
              -> Par arch (FutureR arch c)
        exec2 :: (ExecutableR arch
 -> Gamma aenv
 -> ValR arch aenv
 -> a
 -> b
 -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
exec2 ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> a
-> b
-> Par arch (FutureR arch c)
f Par arch (FutureR arch a)
x Par arch (FutureR arch b)
y = do
          FutureR arch a
x' <- Par arch (FutureR arch a)
x
          FutureR arch b
y' <- Par arch (FutureR arch b)
y
          Par arch (FutureR arch c) -> Par arch (FutureR arch c)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch c) -> Par arch (FutureR arch c))
-> Par arch (FutureR arch c) -> Par arch (FutureR arch c)
forall a b. (a -> b) -> a -> b
$ Par arch (FutureR arch c) -> Par arch (FutureR arch c)
forall a. a -> a
id (Par arch (FutureR arch c) -> Par arch (FutureR arch c))
-> Par arch (Par arch (FutureR arch c))
-> Par arch (FutureR arch c)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> b -> Par arch (FutureR arch c))
-> Par arch a -> Par arch b -> Par arch (Par arch (FutureR arch c))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> a
-> b
-> Par arch (FutureR arch c)
f ExecutableR arch
kernel Gamma aenv
gamma ValR arch aenv
aenv) (FutureR arch a -> Par arch a
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch a
x') (FutureR arch b -> Par arch b
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch b
y')

        splitPair :: forall a b. Par arch (FutureR arch (a, b))
              -> Par arch (FutureR arch a, FutureR arch b)
        splitPair :: Par arch (FutureR arch (a, b))
-> Par arch (FutureR arch a, FutureR arch b)
splitPair Par arch (FutureR arch (a, b))
x = do
          FutureR arch a
r1 <- Par arch (FutureR arch a)
forall arch a.
(Async arch, HasCallStack) =>
Par arch (FutureR arch a)
new
          FutureR arch b
r2 <- Par arch (FutureR arch b)
forall arch a.
(Async arch, HasCallStack) =>
Par arch (FutureR arch a)
new
          Par arch () -> Par arch ()
forall arch.
(Async arch, HasCallStack) =>
Par arch () -> Par arch ()
fork (Par arch () -> Par arch ()) -> Par arch () -> Par arch ()
forall a b. (a -> b) -> a -> b
$ do
            FutureR arch (a, b)
x' <- Par arch (FutureR arch (a, b))
x
            (a
a, b
b) <- FutureR arch (a, b) -> Par arch (a, b)
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch (a, b)
x'
            FutureR arch a -> a -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureR arch a
r1 a
a
            FutureR arch b -> b -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureR arch b
r2 b
b
          (FutureR arch a, FutureR arch b)
-> Par arch (FutureR arch a, FutureR arch b)
forall (m :: * -> *) a. Monad m => a -> m a
return (FutureR arch a
r1, FutureR arch b
r2)

    travAF :: ExecOpenAfun arch aenv (a -> b) -> FutureArraysR arch a -> Par arch (FutureArraysR arch b)
    travAF :: ExecOpenAfun arch aenv (a -> b)
-> FutureArraysR arch a -> Par arch (FutureArraysR arch b)
travAF (Alam ALeftHandSide a aenv aenv'
lhs (Abody ExecOpenAcc arch aenv' t1
f)) FutureArraysR arch a
a = ExecOpenAcc arch aenv' t1
-> ValR arch aenv' -> Par arch (FutureArraysR arch t1)
forall arch aenv arrs.
Execute arch =>
ExecOpenAcc arch aenv arrs
-> ValR arch aenv -> Par arch (FutureArraysR arch arrs)
executeOpenAcc ExecOpenAcc arch aenv' t1
f (ValR arch aenv' -> Par arch (FutureArraysR arch t1))
-> ValR arch aenv' -> Par arch (FutureArraysR arch t1)
forall a b. (a -> b) -> a -> b
$ ValR arch aenv
aenv ValR arch aenv
-> (ALeftHandSide a aenv aenv', FutureArraysR arch a)
-> ValR arch aenv'
forall arch env t env'.
ValR arch env
-> (ALeftHandSide t env env', FutureArraysR arch t)
-> ValR arch env'
`push` (ALeftHandSide a aenv aenv'
lhs, FutureArraysR arch a
FutureArraysR arch a
a)
    travAF ExecOpenAfun arch aenv (a -> b)
_                    FutureArraysR arch a
_ = String -> Par arch (FutureArraysR arch b)
forall a. HasCallStack => String -> a
error String
"boop!"

    travE :: Exp aenv t -> Par arch (FutureR arch t)
    travE :: Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv t
exp = Exp aenv t -> ValR arch aenv -> Par arch (FutureR arch t)
forall arch aenv t.
Execute arch =>
Exp aenv t -> ValR arch aenv -> Par arch (FutureR arch t)
executeExp Exp aenv t
exp ValR arch aenv
aenv

    travD :: DelayedOpenAcc ExecOpenAcc arch aenv a -> Par arch (FutureR arch (Delayed a))
    travD :: DelayedOpenAcc ExecOpenAcc arch aenv a
-> Par arch (FutureR arch (Delayed a))
travD (AST.Delayed ArrayR (Array sh e)
_ Exp aenv sh
sh) = (sh -> Delayed (Array sh e))
-> Par arch (FutureR arch sh)
-> Par arch (FutureR arch (Delayed (Array sh e)))
forall arch a b.
Async arch =>
(a -> b) -> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
liftF1 sh -> Delayed (Array sh e)
forall sh e. sh -> Delayed (Array sh e)
Delayed  (Exp aenv sh -> Par arch (FutureR arch sh)
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv sh
sh)
    travD (AST.Manifest ArraysR (Array sh e)
_ ExecOpenAcc arch aenv (Array sh e)
a) = (Array sh e -> Delayed (Array sh e))
-> Par arch (FutureR arch (Array sh e))
-> Par arch (FutureR arch (Delayed (Array sh e)))
forall arch a b.
Async arch =>
(a -> b) -> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
liftF1 Array sh e -> Delayed (Array sh e)
forall a. a -> Delayed a
Manifest (ExecOpenAcc arch aenv (Array sh e)
-> Par arch (FutureArraysR arch (Array sh e))
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv (Array sh e)
a)

    unit :: TypeR t -> Exp aenv t -> Par arch (FutureR arch (Scalar t))
    unit :: TypeR t -> Exp aenv t -> Par arch (FutureR arch (Scalar t))
unit TypeR t
tp Exp aenv t
x = do
      FutureR arch t
x'   <- Exp aenv t -> Par arch (FutureR arch t)
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv t
x
      Par arch (FutureR arch (Scalar t))
-> Par arch (FutureR arch (Scalar t))
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch (Scalar t))
 -> Par arch (FutureR arch (Scalar t)))
-> Par arch (FutureR arch (Scalar t))
-> Par arch (FutureR arch (Scalar t))
forall a b. (a -> b) -> a -> b
$ ArrayR (Scalar t)
-> () -> (() -> t) -> Par arch (FutureR arch (Scalar t))
forall arch sh e.
Remote arch =>
ArrayR (Array sh e)
-> sh -> (sh -> e) -> Par arch (FutureR arch (Array sh e))
newRemoteAsync (ShapeR () -> TypeR t -> ArrayR (Scalar t)
forall sh e. ShapeR sh -> TypeR e -> ArrayR (Array sh e)
ArrayR ShapeR ()
ShapeRz TypeR t
tp) () ((() -> t) -> Par arch (FutureR arch (Scalar t)))
-> (t -> () -> t) -> t -> Par arch (FutureR arch (Scalar t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> () -> t
forall a b. a -> b -> a
const (t -> Par arch (FutureR arch (Scalar t)))
-> Par arch t -> Par arch (FutureR arch (Scalar t))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutureR arch t -> Par arch t
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch t
x'

    -- Let bindings
    alet :: ALeftHandSide a aenv aenv' -> ExecOpenAcc arch aenv a -> ExecOpenAcc arch aenv' b -> Par arch (FutureArraysR arch b)
    alet :: ALeftHandSide a aenv aenv'
-> ExecOpenAcc arch aenv a
-> ExecOpenAcc arch aenv' b
-> Par arch (FutureArraysR arch b)
alet ALeftHandSide a aenv aenv'
lhs ExecOpenAcc arch aenv a
bnd ExecOpenAcc arch aenv' b
body = do
      FutureArraysR arch a
bnd'  <- Par arch (FutureArraysR arch a) -> Par arch (FutureArraysR arch a)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureArraysR arch a)
 -> Par arch (FutureArraysR arch a))
-> Par arch (FutureArraysR arch a)
-> Par arch (FutureArraysR arch a)
forall a b. (a -> b) -> a -> b
$ ExecOpenAcc arch aenv a
-> ValR arch aenv -> Par arch (FutureArraysR arch a)
forall arch aenv arrs.
Execute arch =>
ExecOpenAcc arch aenv arrs
-> ValR arch aenv -> Par arch (FutureArraysR arch arrs)
executeOpenAcc ExecOpenAcc arch aenv a
bnd ValR arch aenv
aenv
      FutureArraysR arch b
body' <- Par arch (FutureArraysR arch b) -> Par arch (FutureArraysR arch b)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureArraysR arch b)
 -> Par arch (FutureArraysR arch b))
-> Par arch (FutureArraysR arch b)
-> Par arch (FutureArraysR arch b)
forall a b. (a -> b) -> a -> b
$ ExecOpenAcc arch aenv' b
-> ValR arch aenv' -> Par arch (FutureArraysR arch b)
forall arch aenv arrs.
Execute arch =>
ExecOpenAcc arch aenv arrs
-> ValR arch aenv -> Par arch (FutureArraysR arch arrs)
executeOpenAcc ExecOpenAcc arch aenv' b
body (ValR arch aenv' -> Par arch (FutureArraysR arch b))
-> ValR arch aenv' -> Par arch (FutureArraysR arch b)
forall a b. (a -> b) -> a -> b
$ ValR arch aenv
aenv ValR arch aenv
-> (ALeftHandSide a aenv aenv', FutureArraysR arch a)
-> ValR arch aenv'
forall arch env t env'.
ValR arch env
-> (ALeftHandSide t env env', FutureArraysR arch t)
-> ValR arch env'
`push` (ALeftHandSide a aenv aenv'
lhs, FutureArraysR arch a
bnd')
      FutureArraysR arch b -> Par arch (FutureArraysR arch b)
forall (m :: * -> *) a. Monad m => a -> m a
return FutureArraysR arch b
body'

    -- Allocate an array on the remote device
    allocate :: ArrayR (Array sh e) -> Exp aenv sh -> Par arch (FutureR arch (Array sh e))
    allocate :: ArrayR (Array sh e)
-> Exp aenv sh -> Par arch (FutureR arch (Array sh e))
allocate ArrayR (Array sh e)
repr Exp aenv sh
sh = do
      FutureR arch (Array sh e)
r    <- Par arch (FutureR arch (Array sh e))
forall arch a.
(Async arch, HasCallStack) =>
Par arch (FutureR arch a)
new
      FutureR arch sh
sh'  <- Exp aenv sh -> Par arch (FutureR arch sh)
forall t. Exp aenv t -> Par arch (FutureR arch t)
travE Exp aenv sh
sh
      Par arch () -> Par arch ()
forall arch.
(Async arch, HasCallStack) =>
Par arch () -> Par arch ()
fork (Par arch () -> Par arch ()) -> Par arch () -> Par arch ()
forall a b. (a -> b) -> a -> b
$ do
        Array sh e
arr <- ArrayR (Array sh e) -> sh -> Par arch (Array sh e)
forall arch sh e.
Remote arch =>
ArrayR (Array sh e) -> sh -> Par arch (Array sh e)
allocateRemote ArrayR (Array sh e)
repr (sh -> Par arch (Array sh e))
-> Par arch sh -> Par arch (Array sh e)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutureR arch sh -> Par arch sh
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch sh
sh'
        FutureR arch (Array sh e) -> Array sh e -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureR arch (Array sh e)
r Array sh e
arr
      FutureR arch (Array sh e) -> Par arch (FutureR arch (Array sh e))
forall (m :: * -> *) a. Monad m => a -> m a
return FutureR arch (Array sh e)
r

    -- Array level conditionals
    acond :: ExecOpenAcc arch aenv a
          -> ExecOpenAcc arch aenv a
          -> FutureR arch PrimBool
          -> Par arch (FutureArraysR arch a)
    acond :: ExecOpenAcc arch aenv a
-> ExecOpenAcc arch aenv a
-> FutureR arch PrimBool
-> Par arch (FutureArraysR arch a)
acond ExecOpenAcc arch aenv a
yes ExecOpenAcc arch aenv a
no FutureR arch PrimBool
p =
      Par arch (FutureArraysR arch a) -> Par arch (FutureArraysR arch a)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureArraysR arch a)
 -> Par arch (FutureArraysR arch a))
-> Par arch (FutureArraysR arch a)
-> Par arch (FutureArraysR arch a)
forall a b. (a -> b) -> a -> b
$ do
        PrimBool
c <- FutureR arch PrimBool -> Par arch PrimBool
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
block FutureR arch PrimBool
p
        if PrimBool -> HasInitialValue
toBool PrimBool
c then ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv a
yes
                    else ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
forall a.
ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)
travA ExecOpenAcc arch aenv a
no

    -- Array loops
    awhile :: ExecOpenAfun arch aenv (a -> Scalar PrimBool)
           -> ExecOpenAfun arch aenv (a -> a)
           -> FutureArraysR arch a
           -> Par arch (FutureArraysR arch a)
    awhile :: ExecOpenAfun arch aenv (a -> Scalar PrimBool)
-> ExecOpenAfun arch aenv (a -> a)
-> FutureArraysR arch a
-> Par arch (FutureArraysR arch a)
awhile ExecOpenAfun arch aenv (a -> Scalar PrimBool)
p ExecOpenAfun arch aenv (a -> a)
f FutureArraysR arch a
a = do
      Scalar PrimBool
r  <- FutureR arch (Scalar PrimBool) -> Par arch (Scalar PrimBool)
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get (FutureR arch (Scalar PrimBool) -> Par arch (Scalar PrimBool))
-> Par arch (FutureR arch (Scalar PrimBool))
-> Par arch (Scalar PrimBool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExecOpenAfun arch aenv (a -> Scalar PrimBool)
-> FutureArraysR arch a
-> Par arch (FutureArraysR arch (Scalar PrimBool))
forall a b.
ExecOpenAfun arch aenv (a -> b)
-> FutureArraysR arch a -> Par arch (FutureArraysR arch b)
travAF ExecOpenAfun arch aenv (a -> Scalar PrimBool)
p FutureArraysR arch a
a
      PrimBool
ok <- TypeR PrimBool -> Scalar PrimBool -> Int -> Par arch PrimBool
forall arch e sh.
Remote arch =>
TypeR e -> Array sh e -> Int -> Par arch e
indexRemote (ScalarType PrimBool -> TypeR PrimBool
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle ScalarType PrimBool
forall a. IsScalar a => ScalarType a
scalarType) Scalar PrimBool
r Int
0
      if PrimBool -> HasInitialValue
toBool PrimBool
ok then ExecOpenAfun arch aenv (a -> Scalar PrimBool)
-> ExecOpenAfun arch aenv (a -> a)
-> FutureArraysR arch a
-> Par arch (FutureArraysR arch a)
forall a.
ExecOpenAfun arch aenv (a -> Scalar PrimBool)
-> ExecOpenAfun arch aenv (a -> a)
-> FutureArraysR arch a
-> Par arch (FutureArraysR arch a)
awhile ExecOpenAfun arch aenv (a -> Scalar PrimBool)
p ExecOpenAfun arch aenv (a -> a)
f (FutureArraysR arch a -> Par arch (FutureArraysR arch a))
-> Par arch (FutureArraysR arch a)
-> Par arch (FutureArraysR arch a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExecOpenAfun arch aenv (a -> a)
-> FutureArraysR arch a -> Par arch (FutureArraysR arch a)
forall a b.
ExecOpenAfun arch aenv (a -> b)
-> FutureArraysR arch a -> Par arch (FutureArraysR arch b)
travAF ExecOpenAfun arch aenv (a -> a)
f FutureArraysR arch a
a
                   else FutureArraysR arch a -> Par arch (FutureArraysR arch a)
forall (m :: * -> *) a. Monad m => a -> m a
return FutureArraysR arch a
a

    -- Pull apart the unzipped struct-of-array representation
    unzip :: UnzipIdx t e -> Array sh t -> Array sh e
    unzip :: UnzipIdx t e -> Array sh t -> Array sh e
unzip UnzipIdx t e
tix (Array sh
sh ArrayData t
adata) = sh -> ArrayData e -> Array sh e
forall sh e. sh -> ArrayData e -> Array sh e
Array sh
sh (ArrayData e -> Array sh e) -> ArrayData e -> Array sh e
forall a b. (a -> b) -> a -> b
$ UnzipIdx t e -> ArrayData t -> ArrayData e
forall a b. UnzipIdx a b -> ArrayData a -> ArrayData b
go UnzipIdx t e
tix ArrayData t
adata
      where
        go :: UnzipIdx a b -> ArrayData a -> ArrayData b
        go :: UnzipIdx a b -> ArrayData a -> ArrayData b
go UnzipIdx a b
UnzipUnit                  ArrayData a
_       = ()
        go UnzipIdx a b
UnzipId                    ArrayData a
ad      = ArrayData a
ArrayData b
ad
        go (UnzipPrj PairIdx a b
PairIdxLeft  UnzipIdx b b
ix) (ad, _) = UnzipIdx b b -> ArrayData b -> ArrayData b
forall a b. UnzipIdx a b -> ArrayData a -> ArrayData b
go UnzipIdx b b
ix ArrayData b
ad
        go (UnzipPrj PairIdx a b
PairIdxRight UnzipIdx b b
ix) (_, ad) = UnzipIdx b b -> ArrayData b -> ArrayData b
forall a b. UnzipIdx a b -> ArrayData a -> ArrayData b
go UnzipIdx b b
ix ArrayData b
ad
        go (UnzipPair UnzipIdx a b1
ix1 UnzipIdx a b2
ix2)        ArrayData a
ad      = (UnzipIdx a b1 -> ArrayData a -> ArrayData b1
forall a b. UnzipIdx a b -> ArrayData a -> ArrayData b
go UnzipIdx a b1
ix1 ArrayData a
ad, UnzipIdx a b2 -> ArrayData a -> ArrayData b2
forall a b. UnzipIdx a b -> ArrayData a -> ArrayData b
go UnzipIdx a b2
ix2 ArrayData a
ad)

    map_ :: ExecOpenAcc arch aenv (Array sh a)
         -> ArrayR (Array sh a)
         -> TypeR b
         -> ExecutableR arch
         -> Gamma aenv
         -> ValR arch aenv
         -> Array sh a
         -> Par arch (FutureR arch (Array sh b))
    map_ :: ExecOpenAcc arch aenv (Array sh a)
-> ArrayR (Array sh a)
-> TypeR b
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh a
-> Par arch (FutureR arch (Array sh b))
map_ ExecOpenAcc arch aenv (Array sh a)
a repr :: ArrayR (Array sh a)
repr@(ArrayR ShapeR sh
_ TypeR e
tp) TypeR b
tp'
      = Maybe (e :~: b)
-> ArrayR (Array sh e)
-> TypeR b
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh e
-> Par arch (FutureR arch (Array sh b))
forall arch a b sh aenv.
Execute arch =>
Maybe (a :~: b)
-> ArrayR (Array sh a)
-> TypeR b
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh a
-> Par arch (FutureR arch (Array sh b))
map (if ExecOpenAcc arch aenv (Array sh a) -> HasInitialValue
forall a. ExecOpenAcc arch aenv a -> HasInitialValue
inplace ExecOpenAcc arch aenv (Array sh a)
a then TypeR e -> TypeR b -> Maybe (e :~: b)
forall s t. TypeR s -> TypeR t -> Maybe (s :~: t)
matchTypeR TypeR e
tp TypeR b
tp' else Maybe (e :~: b)
forall a. Maybe a
Nothing) ArrayR (Array sh a)
ArrayR (Array sh e)
repr TypeR b
tp'

    permute_ :: ExecOpenAcc arch aenv (Array sh' e)
             -> ArrayR (Array sh e)
             -> ShapeR sh'
             -> ExecutableR arch
             -> Gamma aenv
             -> ValR arch aenv
             -> Array sh' e
             -> Delayed (Array sh e)
             -> Par arch (FutureR arch (Array sh' e))
    permute_ :: ExecOpenAcc arch aenv (Array sh' e)
-> ArrayR (Array sh e)
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh' e
-> Delayed (Array sh e)
-> Par arch (FutureR arch (Array sh' e))
permute_ ExecOpenAcc arch aenv (Array sh' e)
d = HasInitialValue
-> ArrayR (Array sh e)
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh' e
-> Delayed (Array sh e)
-> Par arch (FutureR arch (Array sh' e))
forall arch sh e sh' aenv.
Execute arch =>
HasInitialValue
-> ArrayR (Array sh e)
-> ShapeR sh'
-> ExecutableR arch
-> Gamma aenv
-> ValR arch aenv
-> Array sh' e
-> Delayed (Array sh e)
-> Par arch (FutureR arch (Array sh' e))
permute (ExecOpenAcc arch aenv (Array sh' e) -> HasInitialValue
forall a. ExecOpenAcc arch aenv a -> HasInitialValue
inplace ExecOpenAcc arch aenv (Array sh' e)
d)

    -- Can the function store its results in-place to the input array?
    inplace :: ExecOpenAcc arch aenv a -> Bool
    inplace :: ExecOpenAcc arch aenv a -> HasInitialValue
inplace ExecOpenAcc arch aenv a
a
      | IO HasInitialValue -> HasInitialValue
forall a. IO a -> a
unsafePerformIO (Flag -> IO HasInitialValue
Debug.getFlag Flag
Debug.inplace) -- liftPar :: IO a -> Par arch a
      = case ExecOpenAcc arch aenv a
a of
          ExecAcc{}    -> HasInitialValue
True
          EvalAcc ArraysR a
_ PreOpenAccCommand ExecOpenAcc arch aenv a
pacc ->
            case PreOpenAccCommand ExecOpenAcc arch aenv a
pacc of
              Avar{} -> HasInitialValue
False
              Use{}  -> HasInitialValue
False
              Unit{} -> HasInitialValue
False
              PreOpenAccCommand ExecOpenAcc arch aenv a
_      -> HasInitialValue
True
      --
      | HasInitialValue
otherwise
      = HasInitialValue
False


-- Scalar expression evaluation
-- ----------------------------

-- TLM: Returning a future seems the correct thing to do here, but feels pretty
--      heavy-weight. In particular, perhaps we only need to know the shape of
--      an array before proceeding (i.e. scheduling execution of the next array)
--      without having to wait for the array elements to be evaluated.
--
--      Additionally, most operations do not interact with arrays and could be
--      evaluated directly (e.g. shape/index manipulations) (currently futures
--      are implemented in both backends as a data structure in an IORef, so we
--      could avoid some indirections).
--

{-# INLINEABLE executeExp #-}
executeExp
    :: Execute arch
    => Exp aenv t
    -> ValR arch aenv
    -> Par arch (FutureR arch t)
executeExp :: Exp aenv t -> ValR arch aenv -> Par arch (FutureR arch t)
executeExp Exp aenv t
exp ValR arch aenv
aenv = Exp aenv t
-> ValR arch () -> ValR arch aenv -> Par arch (FutureR arch t)
forall arch env aenv exp.
Execute arch =>
OpenExp env aenv exp
-> ValR arch env -> ValR arch aenv -> Par arch (FutureR arch exp)
executeOpenExp Exp aenv t
exp ValR arch ()
forall arch. ValR arch ()
Empty ValR arch aenv
aenv

{-# INLINEABLE executeOpenExp #-}
executeOpenExp
    :: forall arch env aenv exp. Execute arch
    => OpenExp env aenv exp
    -> ValR arch env
    -> ValR arch aenv
    -> Par arch (FutureR arch exp)
executeOpenExp :: OpenExp env aenv exp
-> ValR arch env -> ValR arch aenv -> Par arch (FutureR arch exp)
executeOpenExp OpenExp env aenv exp
rootExp ValR arch env
env ValR arch aenv
aenv = OpenExp env aenv exp -> Par arch (FutureR arch exp)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv exp
rootExp
  where
    travE :: OpenExp env aenv t -> Par arch (FutureR arch t)
    travE :: OpenExp env aenv t -> Par arch (FutureR arch t)
travE = \case
      Evar (Var ScalarType t
_ Idx env t
ix)           -> FutureR arch t -> Par arch (FutureR arch t)
forall (m :: * -> *) a. Monad m => a -> m a
return (FutureR arch t -> Par arch (FutureR arch t))
-> FutureR arch t -> Par arch (FutureR arch t)
forall a b. (a -> b) -> a -> b
$ Idx env t -> ValR arch env -> FutureR arch t
forall env t arch. Idx env t -> ValR arch env -> FutureR arch t
prj Idx env t
ix ValR arch env
env
      Let ELeftHandSide bnd_t env env'
lhs OpenExp env aenv bnd_t
bnd OpenExp env' aenv t
body          -> do
                                     FutureR arch bnd_t
x <- OpenExp env aenv bnd_t -> Par arch (FutureR arch bnd_t)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv bnd_t
bnd
                                     ValR arch env'
env' <- ValR arch env
env ValR arch env
-> (ELeftHandSide bnd_t env env', FutureR arch bnd_t)
-> Par arch (ValR arch env')
forall arch env t env'.
Async arch =>
ValR arch env
-> (ELeftHandSide t env env', FutureR arch t)
-> Par arch (ValR arch env')
`pushE` (ELeftHandSide bnd_t env env'
lhs, FutureR arch bnd_t
x)
                                     OpenExp env' aenv t
-> ValR arch env' -> ValR arch aenv -> Par arch (FutureR arch t)
forall arch env aenv exp.
Execute arch =>
OpenExp env aenv exp
-> ValR arch env -> ValR arch aenv -> Par arch (FutureR arch exp)
executeOpenExp OpenExp env' aenv t
body ValR arch env'
env' ValR arch aenv
aenv
      Undef ScalarType t
tp                  -> t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (t -> Par arch (FutureR arch t)) -> t -> Par arch (FutureR arch t)
forall a b. (a -> b) -> a -> b
$ TypeR t -> t
forall t. TypeR t -> t
undefElt (ScalarType t -> TypeR t
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle ScalarType t
tp)
      Const ScalarType t
_ t
c                 -> t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull t
c
      PrimConst PrimConst t
c               -> t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (PrimConst t -> t
forall a. PrimConst a -> a
evalPrimConst PrimConst t
c)
      PrimApp PrimFun (a -> t)
f OpenExp env aenv a
x               -> (a -> Par arch (FutureR arch t))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch t)
forall arch a b.
Async arch =>
(a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
lift1 (t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (t -> Par arch (FutureR arch t))
-> (a -> t) -> a -> Par arch (FutureR arch t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimFun (a -> t) -> a -> t
forall a r. PrimFun (a -> r) -> a -> r
evalPrim PrimFun (a -> t)
f) (OpenExp env aenv a -> Par arch (FutureR arch a)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv a
x)
      OpenExp env aenv t
Nil                       -> () -> Par arch (FutureR arch ())
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull ()
      Pair OpenExp env aenv t1
e1 OpenExp env aenv t2
e2                -> (t1 -> t2 -> (t1, t2))
-> Par arch (FutureR arch t1)
-> Par arch (FutureR arch t2)
-> Par arch (FutureR arch (t1, t2))
forall arch a b c.
Async arch =>
(a -> b -> c)
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
liftF2 (,) (OpenExp env aenv t1 -> Par arch (FutureR arch t1)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv t1
e1) (OpenExp env aenv t2 -> Par arch (FutureR arch t2)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv t2
e2)
      VecPack   VecR n s tup
vecr OpenExp env aenv tup
e          -> (tup -> Vec n s)
-> Par arch (FutureR arch tup) -> Par arch (FutureR arch (Vec n s))
forall arch a b.
Async arch =>
(a -> b) -> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
liftF1 (VecR n s tup -> tup -> Vec n s
forall (n :: Nat) single tuple.
KnownNat n =>
VecR n single tuple -> tuple -> Vec n single
pack   VecR n s tup
vecr) (OpenExp env aenv tup -> Par arch (FutureR arch tup)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv tup
e)
      VecUnpack VecR n s t
vecr OpenExp env aenv (Vec n s)
e          -> (Vec n s -> t)
-> Par arch (FutureR arch (Vec n s)) -> Par arch (FutureR arch t)
forall arch a b.
Async arch =>
(a -> b) -> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
liftF1 (VecR n s t -> Vec n s -> t
forall (n :: Nat) single tuple.
KnownNat n =>
VecR n single tuple -> Vec n single -> tuple
unpack VecR n s t
vecr) (OpenExp env aenv (Vec n s) -> Par arch (FutureR arch (Vec n s))
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv (Vec n s)
e)
      Case OpenExp env aenv PrimBool
p [(PrimBool, OpenExp env aenv t)]
xs Maybe (OpenExp env aenv t)
x               -> [(PrimBool, OpenExp env aenv t)]
-> Maybe (OpenExp env aenv t)
-> FutureR arch PrimBool
-> Par arch (FutureR arch t)
forall a.
[(PrimBool, OpenExp env aenv a)]
-> Maybe (OpenExp env aenv a)
-> FutureR arch PrimBool
-> Par arch (FutureR arch a)
caseof [(PrimBool, OpenExp env aenv t)]
xs Maybe (OpenExp env aenv t)
x (FutureR arch PrimBool -> Par arch (FutureR arch t))
-> Par arch (FutureR arch PrimBool) -> Par arch (FutureR arch t)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OpenExp env aenv PrimBool -> Par arch (FutureR arch PrimBool)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv PrimBool
p
      Cond OpenExp env aenv PrimBool
p OpenExp env aenv t
t OpenExp env aenv t
e                -> OpenExp env aenv t
-> OpenExp env aenv t
-> FutureR arch PrimBool
-> Par arch (FutureR arch t)
forall a.
OpenExp env aenv a
-> OpenExp env aenv a
-> FutureR arch PrimBool
-> Par arch (FutureR arch a)
cond OpenExp env aenv t
t OpenExp env aenv t
e (FutureR arch PrimBool -> Par arch (FutureR arch t))
-> Par arch (FutureR arch PrimBool) -> Par arch (FutureR arch t)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OpenExp env aenv PrimBool -> Par arch (FutureR arch PrimBool)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv PrimBool
p
      While OpenFun env aenv (t -> PrimBool)
p OpenFun env aenv (t -> t)
f OpenExp env aenv t
x               -> OpenFun env aenv (t -> PrimBool)
-> OpenFun env aenv (t -> t)
-> FutureR arch t
-> Par arch (FutureR arch t)
forall a.
OpenFun env aenv (a -> PrimBool)
-> OpenFun env aenv (a -> a)
-> FutureR arch a
-> Par arch (FutureR arch a)
while OpenFun env aenv (t -> PrimBool)
p OpenFun env aenv (t -> t)
f (FutureR arch t -> Par arch (FutureR arch t))
-> Par arch (FutureR arch t) -> Par arch (FutureR arch t)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OpenExp env aenv t -> Par arch (FutureR arch t)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv t
x
      IndexSlice SliceIndex slix t co sh
ix OpenExp env aenv slix
slix OpenExp env aenv sh
sh     -> (slix -> sh -> Par arch (FutureR arch t))
-> Par arch (FutureR arch slix)
-> Par arch (FutureR arch sh)
-> Par arch (FutureR arch t)
forall arch a b c.
Async arch =>
(a -> b -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
lift2 (t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (t -> Par arch (FutureR arch t))
-> (slix -> sh -> t) -> slix -> sh -> Par arch (FutureR arch t)
forall b a c d. (b -> a) -> (c -> d -> b) -> c -> d -> a
$$ SliceIndex slix t co sh -> slix -> sh -> t
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sh -> sl
indexSlice SliceIndex slix t co sh
ix) (OpenExp env aenv slix -> Par arch (FutureR arch slix)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv slix
slix) (OpenExp env aenv sh -> Par arch (FutureR arch sh)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv sh
sh)
      IndexFull SliceIndex slix sl co t
ix OpenExp env aenv slix
slix OpenExp env aenv sl
sl      -> (slix -> sl -> Par arch (FutureR arch t))
-> Par arch (FutureR arch slix)
-> Par arch (FutureR arch sl)
-> Par arch (FutureR arch t)
forall arch a b c.
Async arch =>
(a -> b -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
lift2 (t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (t -> Par arch (FutureR arch t))
-> (slix -> sl -> t) -> slix -> sl -> Par arch (FutureR arch t)
forall b a c d. (b -> a) -> (c -> d -> b) -> c -> d -> a
$$ SliceIndex slix sl co t -> slix -> sl -> t
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sl -> sh
indexFull  SliceIndex slix sl co t
ix) (OpenExp env aenv slix -> Par arch (FutureR arch slix)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv slix
slix) (OpenExp env aenv sl -> Par arch (FutureR arch sl)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv sl
sl)
      ToIndex ShapeR sh
shr OpenExp env aenv sh
sh OpenExp env aenv sh
ix         -> (sh -> sh -> Par arch (FutureR arch Int))
-> Par arch (FutureR arch sh)
-> Par arch (FutureR arch sh)
-> Par arch (FutureR arch Int)
forall arch a b c.
Async arch =>
(a -> b -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
lift2 (Int -> Par arch (FutureR arch Int)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (Int -> Par arch (FutureR arch Int))
-> (sh -> sh -> Int) -> sh -> sh -> Par arch (FutureR arch Int)
forall b a c d. (b -> a) -> (c -> d -> b) -> c -> d -> a
$$ ShapeR sh -> sh -> sh -> Int
forall sh. HasCallStack => ShapeR sh -> sh -> sh -> Int
toIndex ShapeR sh
shr) (OpenExp env aenv sh -> Par arch (FutureR arch sh)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv sh
sh) (OpenExp env aenv sh -> Par arch (FutureR arch sh)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv sh
ix)
      FromIndex ShapeR t
shr OpenExp env aenv t
sh OpenExp env aenv Int
ix       -> (t -> Int -> Par arch (FutureR arch t))
-> Par arch (FutureR arch t)
-> Par arch (FutureR arch Int)
-> Par arch (FutureR arch t)
forall arch a b c.
Async arch =>
(a -> b -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
lift2 (t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (t -> Par arch (FutureR arch t))
-> (t -> Int -> t) -> t -> Int -> Par arch (FutureR arch t)
forall b a c d. (b -> a) -> (c -> d -> b) -> c -> d -> a
$$ ShapeR t -> t -> Int -> t
forall sh. HasCallStack => ShapeR sh -> sh -> Int -> sh
fromIndex ShapeR t
shr) (OpenExp env aenv t -> Par arch (FutureR arch t)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv t
sh) (OpenExp env aenv Int -> Par arch (FutureR arch Int)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv Int
ix)
      ShapeSize ShapeR dim
shr OpenExp env aenv dim
sh          -> (dim -> Par arch (FutureR arch Int))
-> Par arch (FutureR arch dim) -> Par arch (FutureR arch Int)
forall arch a b.
Async arch =>
(a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
lift1 (Int -> Par arch (FutureR arch Int)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (Int -> Par arch (FutureR arch Int))
-> (dim -> Int) -> dim -> Par arch (FutureR arch Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShapeR dim -> dim -> Int
forall sh. ShapeR sh -> sh -> Int
size ShapeR dim
shr) (OpenExp env aenv dim -> Par arch (FutureR arch dim)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv dim
sh)
      Shape ArrayVar aenv (Array t e)
var                 -> (Array t e -> Par arch (FutureR arch t))
-> Par arch (FutureR arch (Array t e)) -> Par arch (FutureR arch t)
forall arch a b.
Async arch =>
(a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
lift1 (t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (t -> Par arch (FutureR arch t))
-> (Array t e -> t) -> Array t e -> Par arch (FutureR arch t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array t e -> t
forall sh e. Array sh e -> sh
shape) (ArrayVar aenv (Array t e) -> Par arch (FutureR arch (Array t e))
forall a. ArrayVar aenv a -> Par arch (FutureR arch a)
travAvar ArrayVar aenv (Array t e)
var)
      Index (Var ArrayR (Array dim t)
repr Idx aenv (Array dim t)
a) OpenExp env aenv dim
ix     -> (Array dim t -> dim -> Par arch (FutureR arch t))
-> Par arch (FutureR arch (Array dim t))
-> Par arch (FutureR arch dim)
-> Par arch (FutureR arch t)
forall arch a b c.
Async arch =>
(a -> b -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
lift2 (ArrayR (Array dim t)
-> Array dim t -> dim -> Par arch (FutureR arch t)
forall sh e.
ArrayR (Array sh e)
-> Array sh e -> sh -> Par arch (FutureR arch e)
index ArrayR (Array dim t)
repr) (Idx aenv (Array dim t) -> Par arch (FutureR arch (Array dim t))
forall a. Idx aenv a -> Par arch (FutureR arch a)
travAIdx Idx aenv (Array dim t)
a) (OpenExp env aenv dim -> Par arch (FutureR arch dim)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv dim
ix)
      LinearIndex (Var (ArrayR ShapeR sh
_ TypeR e
tp) Idx aenv (Array dim t)
a) OpenExp env aenv Int
ix -> (Array dim e -> Int -> Par arch (FutureR arch t))
-> Par arch (FutureR arch (Array dim e))
-> Par arch (FutureR arch Int)
-> Par arch (FutureR arch t)
forall arch a b c.
Async arch =>
(a -> b -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
lift2 (TypeR e -> Array dim e -> Int -> Par arch (FutureR arch e)
forall arch e sh.
Remote arch =>
TypeR e -> Array sh e -> Int -> Par arch (FutureR arch e)
indexRemoteAsync TypeR e
tp) (Idx aenv (Array dim t) -> Par arch (FutureR arch (Array dim t))
forall a. Idx aenv a -> Par arch (FutureR arch a)
travAIdx Idx aenv (Array dim t)
a) (OpenExp env aenv Int -> Par arch (FutureR arch Int)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv Int
ix)
      Coerce ScalarType a
t1 ScalarType t
t2 OpenExp env aenv a
x            -> (a -> Par arch (FutureR arch t))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch t)
forall arch a b.
Async arch =>
(a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
lift1 (t -> Par arch (FutureR arch t)
forall arch a.
(Async arch, HasCallStack) =>
a -> Par arch (FutureR arch a)
newFull (t -> Par arch (FutureR arch t))
-> (a -> t) -> a -> Par arch (FutureR arch t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScalarType a -> ScalarType t -> a -> t
forall a b. ScalarType a -> ScalarType b -> a -> b
evalCoerceScalar ScalarType a
t1 ScalarType t
t2) (OpenExp env aenv a -> Par arch (FutureR arch a)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv a
x)
      Foreign TypeR t
_ asm (x -> t)
_ Fun () (x -> t)
f OpenExp env aenv x
x           -> Fun () (x -> t) -> OpenExp env aenv x -> Par arch (FutureR arch t)
forall a b.
Fun () (a -> b) -> OpenExp env aenv a -> Par arch (FutureR arch b)
foreignE Fun () (x -> t)
f OpenExp env aenv x
x

    -- Helpers
    -- -------

    travAvar :: ArrayVar aenv a -> Par arch (FutureR arch a)
    travAvar :: ArrayVar aenv a -> Par arch (FutureR arch a)
travAvar (Var ArrayR a
_ Idx aenv a
ix) = Idx aenv a -> Par arch (FutureR arch a)
forall a. Idx aenv a -> Par arch (FutureR arch a)
travAIdx Idx aenv a
ix

    travAIdx :: Idx aenv a -> Par arch (FutureR arch a)
    travAIdx :: Idx aenv a -> Par arch (FutureR arch a)
travAIdx Idx aenv a
a = FutureR arch a -> Par arch (FutureR arch a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FutureR arch a -> Par arch (FutureR arch a))
-> FutureR arch a -> Par arch (FutureR arch a)
forall a b. (a -> b) -> a -> b
$ Idx aenv a -> ValR arch aenv -> FutureR arch a
forall env t arch. Idx env t -> ValR arch env -> FutureR arch t
prj Idx aenv a
a ValR arch aenv
aenv

    foreignE :: Fun () (a -> b) -> OpenExp env aenv a -> Par arch (FutureR arch b)
    foreignE :: Fun () (a -> b) -> OpenExp env aenv a -> Par arch (FutureR arch b)
foreignE (Lam ELeftHandSide a () env'
lhs (Body OpenExp env' () t1
f)) OpenExp env aenv a
x = do FutureR arch a
e    <- OpenExp env aenv a -> Par arch (FutureR arch a)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv a
x
                                       ValR arch env'
env' <- ValR arch ()
forall arch. ValR arch ()
Empty ValR arch ()
-> (ELeftHandSide a () env', FutureR arch a)
-> Par arch (ValR arch env')
forall arch env t env'.
Async arch =>
ValR arch env
-> (ELeftHandSide t env env', FutureR arch t)
-> Par arch (ValR arch env')
`pushE` (ELeftHandSide a () env'
lhs, FutureR arch a
FutureR arch a
e)
                                       OpenExp env' () t1
-> ValR arch env' -> ValR arch () -> Par arch (FutureR arch t1)
forall arch env aenv exp.
Execute arch =>
OpenExp env aenv exp
-> ValR arch env -> ValR arch aenv -> Par arch (FutureR arch exp)
executeOpenExp OpenExp env' () t1
f ValR arch env'
env' ValR arch ()
forall arch. ValR arch ()
Empty
    foreignE Fun () (a -> b)
_                  OpenExp env aenv a
_ = String -> Par arch (FutureR arch b)
forall a. HasCallStack => String -> a
error String
"I bless the rains down in Africa"

    travF1 :: OpenFun env aenv (a -> b) -> FutureR arch a -> Par arch (FutureR arch b)
    travF1 :: OpenFun env aenv (a -> b)
-> FutureR arch a -> Par arch (FutureR arch b)
travF1 (Lam ELeftHandSide a env env'
lhs (Body OpenExp env' aenv t1
f)) FutureR arch a
x = do ValR arch env'
env' <- ValR arch env
env ValR arch env
-> (ELeftHandSide a env env', FutureR arch a)
-> Par arch (ValR arch env')
forall arch env t env'.
Async arch =>
ValR arch env
-> (ELeftHandSide t env env', FutureR arch t)
-> Par arch (ValR arch env')
`pushE` (ELeftHandSide a env env'
lhs, FutureR arch a
FutureR arch a
x)
                                     OpenExp env' aenv t1
-> ValR arch env' -> ValR arch aenv -> Par arch (FutureR arch t1)
forall arch env aenv exp.
Execute arch =>
OpenExp env aenv exp
-> ValR arch env -> ValR arch aenv -> Par arch (FutureR arch exp)
executeOpenExp OpenExp env' aenv t1
f ValR arch env'
env' ValR arch aenv
aenv
    travF1 OpenFun env aenv (a -> b)
_                  FutureR arch a
_ = String -> Par arch (FutureR arch b)
forall a. HasCallStack => String -> a
error String
"LANAAAAAAAA!"

    while :: OpenFun env aenv (a -> PrimBool)
          -> OpenFun env aenv (a -> a)
          -> FutureR arch a
          -> Par arch (FutureR arch a)
    while :: OpenFun env aenv (a -> PrimBool)
-> OpenFun env aenv (a -> a)
-> FutureR arch a
-> Par arch (FutureR arch a)
while OpenFun env aenv (a -> PrimBool)
p OpenFun env aenv (a -> a)
f FutureR arch a
x = do
      PrimBool
ok <- FutureR arch PrimBool -> Par arch PrimBool
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
block (FutureR arch PrimBool -> Par arch PrimBool)
-> Par arch (FutureR arch PrimBool) -> Par arch PrimBool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OpenFun env aenv (a -> PrimBool)
-> FutureR arch a -> Par arch (FutureR arch PrimBool)
forall a b.
OpenFun env aenv (a -> b)
-> FutureR arch a -> Par arch (FutureR arch b)
travF1 OpenFun env aenv (a -> PrimBool)
p FutureR arch a
x
      if PrimBool -> HasInitialValue
toBool PrimBool
ok then OpenFun env aenv (a -> PrimBool)
-> OpenFun env aenv (a -> a)
-> FutureR arch a
-> Par arch (FutureR arch a)
forall a.
OpenFun env aenv (a -> PrimBool)
-> OpenFun env aenv (a -> a)
-> FutureR arch a
-> Par arch (FutureR arch a)
while OpenFun env aenv (a -> PrimBool)
p OpenFun env aenv (a -> a)
f (FutureR arch a -> Par arch (FutureR arch a))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OpenFun env aenv (a -> a)
-> FutureR arch a -> Par arch (FutureR arch a)
forall a b.
OpenFun env aenv (a -> b)
-> FutureR arch a -> Par arch (FutureR arch b)
travF1 OpenFun env aenv (a -> a)
f FutureR arch a
x
                   else FutureR arch a -> Par arch (FutureR arch a)
forall (m :: * -> *) a. Monad m => a -> m a
return FutureR arch a
x

    cond :: OpenExp env aenv a
         -> OpenExp env aenv a
         -> FutureR arch PrimBool
         -> Par arch (FutureR arch a)
    cond :: OpenExp env aenv a
-> OpenExp env aenv a
-> FutureR arch PrimBool
-> Par arch (FutureR arch a)
cond OpenExp env aenv a
yes OpenExp env aenv a
no FutureR arch PrimBool
p =
      Par arch (FutureR arch a) -> Par arch (FutureR arch a)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch a) -> Par arch (FutureR arch a))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch a)
forall a b. (a -> b) -> a -> b
$ do
        PrimBool
c <- FutureR arch PrimBool -> Par arch PrimBool
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
block FutureR arch PrimBool
p
        if PrimBool -> HasInitialValue
toBool PrimBool
c then OpenExp env aenv a -> Par arch (FutureR arch a)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv a
yes
                    else OpenExp env aenv a -> Par arch (FutureR arch a)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv a
no

    caseof :: [(TAG, OpenExp env aenv a)]
           -> Maybe (OpenExp env aenv a)
           -> FutureR arch TAG
           -> Par arch (FutureR arch a)
    caseof :: [(PrimBool, OpenExp env aenv a)]
-> Maybe (OpenExp env aenv a)
-> FutureR arch PrimBool
-> Par arch (FutureR arch a)
caseof [(PrimBool, OpenExp env aenv a)]
xs Maybe (OpenExp env aenv a)
d FutureR arch PrimBool
p =
      Par arch (FutureR arch a) -> Par arch (FutureR arch a)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch a) -> Par arch (FutureR arch a))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch a)
forall a b. (a -> b) -> a -> b
$ do
        PrimBool
t <- FutureR arch PrimBool -> Par arch PrimBool
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
block FutureR arch PrimBool
p
        case PrimBool
-> [(PrimBool, OpenExp env aenv a)] -> Maybe (OpenExp env aenv a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PrimBool
t [(PrimBool, OpenExp env aenv a)]
xs of
          Just OpenExp env aenv a
r  -> OpenExp env aenv a -> Par arch (FutureR arch a)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv a
r
          Maybe (OpenExp env aenv a)
Nothing -> case Maybe (OpenExp env aenv a)
d of
                       Just OpenExp env aenv a
r  -> OpenExp env aenv a -> Par arch (FutureR arch a)
forall t. OpenExp env aenv t -> Par arch (FutureR arch t)
travE OpenExp env aenv a
r
                       Maybe (OpenExp env aenv a)
Nothing -> String -> Par arch (FutureR arch a)
forall a. HasCallStack => String -> a
error String
"unmatched case"

    indexSlice :: SliceIndex slix sl co sh
               -> slix
               -> sh
               -> sl
    indexSlice :: SliceIndex slix sl co sh -> slix -> sh -> sl
indexSlice SliceIndex slix sl co sh
ix slix
slix sh
sh = SliceIndex slix sl co sh -> slix -> sh -> sl
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sh -> sl
restrict SliceIndex slix sl co sh
ix slix
slix sh
sh
      where
        restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl
        restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl
restrict SliceIndex slix sl co sh
SliceNil              ()        ()       = ()
        restrict (SliceAll   SliceIndex ix1 slice1 co dim
sliceIdx) (slx, ()) (sl, sz) = (SliceIndex ix1 slice1 co dim -> ix1 -> dim -> slice1
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sh -> sl
restrict SliceIndex ix1 slice1 co dim
sliceIdx ix1
slx dim
sl, Int
sz)
        restrict (SliceFixed SliceIndex ix1 sl co dim
sliceIdx) (slx,  _) (sl,  _) = SliceIndex ix1 sl co dim -> ix1 -> dim -> sl
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sh -> sl
restrict SliceIndex ix1 sl co dim
sliceIdx ix1
slx dim
sl

    indexFull :: SliceIndex slix sl co sh
              -> slix
              -> sl
              -> sh
    indexFull :: SliceIndex slix sl co sh -> slix -> sl -> sh
indexFull SliceIndex slix sl co sh
ix slix
slix sl
sl = SliceIndex slix sl co sh -> slix -> sl -> sh
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sl -> sh
extend SliceIndex slix sl co sh
ix slix
slix sl
sl
      where
        extend :: SliceIndex slix sl co sh -> slix -> sl -> sh
        extend :: SliceIndex slix sl co sh -> slix -> sl -> sh
extend SliceIndex slix sl co sh
SliceNil              ()        ()       = ()
        extend (SliceAll SliceIndex ix1 slice1 co dim
sliceIdx)   (slx, ()) (sh, sz) = (SliceIndex ix1 slice1 co dim -> ix1 -> slice1 -> dim
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sl -> sh
extend SliceIndex ix1 slice1 co dim
sliceIdx ix1
slx slice1
sh, Int
sz)
        extend (SliceFixed SliceIndex ix1 sl co dim
sliceIdx) (slx, sz) sl
sh       = (SliceIndex ix1 sl co dim -> ix1 -> sl -> dim
forall slix sl co sh. SliceIndex slix sl co sh -> slix -> sl -> sh
extend SliceIndex ix1 sl co dim
sliceIdx ix1
slx sl
sh, Int
sz)

    index :: ArrayR (Array sh e) -> Array sh e -> sh -> Par arch (FutureR arch e)
    index :: ArrayR (Array sh e)
-> Array sh e -> sh -> Par arch (FutureR arch e)
index (ArrayR ShapeR sh
shr TypeR e
tp) Array sh e
arr sh
ix = TypeR e -> Array sh e -> Int -> Par arch (FutureR arch e)
forall arch e sh.
Remote arch =>
TypeR e -> Array sh e -> Int -> Par arch (FutureR arch e)
indexRemoteAsync TypeR e
tp Array sh e
Array sh e
arr (ShapeR sh -> sh -> sh -> Int
forall sh. HasCallStack => ShapeR sh -> sh -> sh -> Int
toIndex ShapeR sh
shr (Array sh e -> sh
forall sh e. Array sh e -> sh
shape Array sh e
arr) sh
sh
ix)


-- Utilities
-- ---------

{-# INLINE toBool #-}
toBool :: PrimBool -> Bool
toBool :: PrimBool -> HasInitialValue
toBool PrimBool
0 = HasInitialValue
False
toBool PrimBool
_ = HasInitialValue
True

{-# INLINE lift1 #-}
lift1 :: Async arch
      => (a -> Par arch (FutureR arch b))
      -> Par arch (FutureR arch a)
      -> Par arch (FutureR arch b)
lift1 :: (a -> Par arch (FutureR arch b))
-> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
lift1 a -> Par arch (FutureR arch b)
f Par arch (FutureR arch a)
x = do
  FutureR arch a
x' <- Par arch (FutureR arch a)
x
  Par arch (FutureR arch b) -> Par arch (FutureR arch b)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch b) -> Par arch (FutureR arch b))
-> Par arch (FutureR arch b) -> Par arch (FutureR arch b)
forall a b. (a -> b) -> a -> b
$ a -> Par arch (FutureR arch b)
f (a -> Par arch (FutureR arch b))
-> Par arch a -> Par arch (FutureR arch b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutureR arch a -> Par arch a
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch a
x'

{-# INLINE lift2 #-}
lift2 :: Async arch
      => (a -> b -> Par arch (FutureR arch c))
      -> Par arch (FutureR arch a)
      -> Par arch (FutureR arch b)
      -> Par arch (FutureR arch c)
lift2 :: (a -> b -> Par arch (FutureR arch c))
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
lift2 a -> b -> Par arch (FutureR arch c)
f Par arch (FutureR arch a)
x Par arch (FutureR arch b)
y = do
  FutureR arch a
x' <- Par arch (FutureR arch a)
x
  FutureR arch b
y' <- Par arch (FutureR arch b)
y
  Par arch (FutureR arch c) -> Par arch (FutureR arch c)
forall arch a.
(Async arch, HasCallStack) =>
Par arch a -> Par arch a
spawn (Par arch (FutureR arch c) -> Par arch (FutureR arch c))
-> Par arch (FutureR arch c) -> Par arch (FutureR arch c)
forall a b. (a -> b) -> a -> b
$ Par arch (FutureR arch c) -> Par arch (FutureR arch c)
forall a. a -> a
id (Par arch (FutureR arch c) -> Par arch (FutureR arch c))
-> Par arch (Par arch (FutureR arch c))
-> Par arch (FutureR arch c)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> b -> Par arch (FutureR arch c))
-> Par arch a -> Par arch b -> Par arch (Par arch (FutureR arch c))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> b -> Par arch (FutureR arch c)
f (FutureR arch a -> Par arch a
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch a
x') (FutureR arch b -> Par arch b
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch b
y')

{-# INLINE liftF1 #-}
liftF1 :: Async arch
       => (a -> b)
       -> Par arch (FutureR arch a)
       -> Par arch (FutureR arch b)
liftF1 :: (a -> b) -> Par arch (FutureR arch a) -> Par arch (FutureR arch b)
liftF1 a -> b
f Par arch (FutureR arch a)
x = do
  FutureR arch b
r  <- Par arch (FutureR arch b)
forall arch a.
(Async arch, HasCallStack) =>
Par arch (FutureR arch a)
new
  FutureR arch a
x' <- Par arch (FutureR arch a)
x
  Par arch () -> Par arch ()
forall arch.
(Async arch, HasCallStack) =>
Par arch () -> Par arch ()
fork (Par arch () -> Par arch ()) -> Par arch () -> Par arch ()
forall a b. (a -> b) -> a -> b
$ FutureR arch b -> b -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureR arch b
r (b -> Par arch ()) -> (a -> b) -> a -> Par arch ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> Par arch ()) -> Par arch a -> Par arch ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutureR arch a -> Par arch a
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch a
x'
  FutureR arch b -> Par arch (FutureR arch b)
forall (m :: * -> *) a. Monad m => a -> m a
return FutureR arch b
r

{-# INLINE liftF2 #-}
liftF2 :: Async arch
       => (a -> b -> c)
       -> Par arch (FutureR arch a)
       -> Par arch (FutureR arch b)
       -> Par arch (FutureR arch c)
liftF2 :: (a -> b -> c)
-> Par arch (FutureR arch a)
-> Par arch (FutureR arch b)
-> Par arch (FutureR arch c)
liftF2 a -> b -> c
f Par arch (FutureR arch a)
x Par arch (FutureR arch b)
y = do
  FutureR arch c
r  <- Par arch (FutureR arch c)
forall arch a.
(Async arch, HasCallStack) =>
Par arch (FutureR arch a)
new
  FutureR arch a
x' <- Par arch (FutureR arch a)
x
  FutureR arch b
y' <- Par arch (FutureR arch b)
y
  Par arch () -> Par arch ()
forall arch.
(Async arch, HasCallStack) =>
Par arch () -> Par arch ()
fork (Par arch () -> Par arch ()) -> Par arch () -> Par arch ()
forall a b. (a -> b) -> a -> b
$ FutureR arch c -> c -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureR arch c
r (c -> Par arch ()) -> Par arch c -> Par arch ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> b -> c) -> Par arch a -> Par arch b -> Par arch c
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> b -> c
f (FutureR arch a -> Par arch a
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch a
x') (FutureR arch b -> Par arch b
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch b
y')
  FutureR arch c -> Par arch (FutureR arch c)
forall (m :: * -> *) a. Monad m => a -> m a
return FutureR arch c
r

{-# INLINE ($$) #-}
infixr 0 $$
($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a
(b -> a
f $$ :: (b -> a) -> (c -> d -> b) -> c -> d -> a
$$ c -> d -> b
g) c
x d
y = b -> a
f (c -> d -> b
g c
x d
y)

split :: Execute arch => ArraysR a -> FutureR arch a -> Par arch (FutureArraysR arch a)
split :: ArraysR a -> FutureR arch a -> Par arch (FutureArraysR arch a)
split ArraysR a
repr FutureR arch a
x = do
  FutureArraysR arch a
rs <- ArraysR a -> Par arch (FutureArraysR arch a)
forall arch a.
Async arch =>
ArraysR a -> Par arch (FutureArraysR arch a)
newArrays ArraysR a
repr
  Par arch () -> Par arch ()
forall arch.
(Async arch, HasCallStack) =>
Par arch () -> Par arch ()
fork (Par arch () -> Par arch ()) -> Par arch () -> Par arch ()
forall a b. (a -> b) -> a -> b
$ FutureR arch a -> Par arch a
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch a
x Par arch a -> (a -> Par arch ()) -> Par arch ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ArraysR a -> FutureArraysR arch a -> a -> Par arch ()
forall arch a.
Execute arch =>
ArraysR a -> FutureArraysR arch a -> a -> Par arch ()
fill ArraysR a
repr FutureArraysR arch a
rs
  FutureArraysR arch a -> Par arch (FutureArraysR arch a)
forall (m :: * -> *) a. Monad m => a -> m a
return FutureArraysR arch a
rs
  where
    fill :: Execute arch => ArraysR a -> FutureArraysR arch a -> a -> Par arch ()
    fill :: ArraysR a -> FutureArraysR arch a -> a -> Par arch ()
fill ArraysR a
TupRunit               FutureArraysR arch a
_        a
_        = () -> Par arch ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    fill (TupRsingle ArrayR{})  FutureArraysR arch a
r        a
a        = FutureR arch a -> a -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureArraysR arch a
FutureR arch a
r a
a
    fill (TupRpair TupR ArrayR a1
repr1 TupR ArrayR b
repr2) (r1, r2) (a1, a2) = TupR ArrayR a1 -> FutureArraysR arch a1 -> a1 -> Par arch ()
forall arch a.
Execute arch =>
ArraysR a -> FutureArraysR arch a -> a -> Par arch ()
fill TupR ArrayR a1
repr1 FutureArraysR arch a1
r1 a1
a1 Par arch () -> Par arch () -> Par arch ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TupR ArrayR b -> FutureArraysR arch b -> b -> Par arch ()
forall arch a.
Execute arch =>
ArraysR a -> FutureArraysR arch a -> a -> Par arch ()
fill TupR ArrayR b
repr2 FutureArraysR arch b
r2 b
a2