{-# LANGUAGE GADTs           #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies    #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Execute.Environment
-- 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.Environment
  where

import Data.Array.Accelerate.AST                                    ( ALeftHandSide, ELeftHandSide )
import Data.Array.Accelerate.AST.Idx
import Data.Array.Accelerate.AST.LeftHandSide
import Data.Array.Accelerate.Representation.Array

import Data.Array.Accelerate.LLVM.Execute.Async


-- Environments
-- ------------

-- Valuation for an environment of futures
--
data ValR arch env where
  Empty :: ValR arch ()
  Push  :: ValR arch env -> FutureR arch t -> ValR arch (env, t)

push :: ValR arch env -> (ALeftHandSide t env env', FutureArraysR arch t) -> ValR arch env'
push :: ValR arch env
-> (ALeftHandSide t env env', FutureArraysR arch t)
-> ValR arch env'
push ValR arch env
env (LeftHandSideWildcard TupR ArrayR t
_     , FutureArraysR arch t
_       ) = ValR arch env
ValR arch env'
env
push ValR arch env
env (LeftHandSideSingle ArrayR{}, FutureArraysR arch t
a       ) = ValR arch env
env ValR arch env
-> FutureR arch (Array sh e) -> ValR arch (env, Array sh e)
forall arch env t.
ValR arch env -> FutureR arch t -> ValR arch (env, t)
`Push` FutureArraysR arch t
FutureR arch (Array sh e)
a
push ValR arch env
env (LeftHandSidePair LeftHandSide ArrayR v1 env env'1
l1 LeftHandSide ArrayR v2 env'1 env'
l2     , (a1, a2)) = ValR arch env
-> (LeftHandSide ArrayR v1 env env'1, FutureArraysR arch v1)
-> ValR arch env'1
forall arch env t env'.
ValR arch env
-> (ALeftHandSide t env env', FutureArraysR arch t)
-> ValR arch env'
push ValR arch env
env (LeftHandSide ArrayR v1 env env'1
l1, FutureArraysR arch v1
a1) ValR arch env'1
-> (LeftHandSide ArrayR v2 env'1 env', FutureArraysR arch v2)
-> ValR arch env'
forall arch env t env'.
ValR arch env
-> (ALeftHandSide t env env', FutureArraysR arch t)
-> ValR arch env'
`push` (LeftHandSide ArrayR v2 env'1 env'
l2, FutureArraysR arch v2
a2)

pushE :: Async arch => ValR arch env -> (ELeftHandSide t env env', FutureR arch t) -> Par arch (ValR arch env')
pushE :: ValR arch env
-> (ELeftHandSide t env env', FutureR arch t)
-> Par arch (ValR arch env')
pushE ValR arch env
env (LeftHandSideSingle ScalarType t
_  , FutureR arch t
e) = ValR arch (env, t) -> Par arch (ValR arch (env, t))
forall (m :: * -> *) a. Monad m => a -> m a
return (ValR arch (env, t) -> Par arch (ValR arch (env, t)))
-> ValR arch (env, t) -> Par arch (ValR arch (env, t))
forall a b. (a -> b) -> a -> b
$ ValR arch env
env ValR arch env -> FutureR arch t -> ValR arch (env, t)
forall arch env t.
ValR arch env -> FutureR arch t -> ValR arch (env, t)
`Push` FutureR arch t
e
pushE ValR arch env
env (LeftHandSideWildcard TupR ScalarType t
_, FutureR arch t
_) = ValR arch env -> Par arch (ValR arch env)
forall (m :: * -> *) a. Monad m => a -> m a
return ValR arch env
env
pushE ValR arch env
env (LeftHandSidePair LeftHandSide ScalarType v1 env env'1
l1 LeftHandSide ScalarType v2 env'1 env'
l2, FutureR arch t
e) = do
  -- TODO: This code creates many intermediate Futures, in case of deeply nested pairs.
  -- We could improve this to only construct Futures for the values actually stored
  -- in the environment and not have any intermediate ones. We can do that in a similar
  -- way as done in Data.Array.Accelerate.LLVM.Execute.split
  --
  FutureR arch v1
e1 <- Par arch (FutureR arch v1)
forall arch a.
(Async arch, HasCallStack) =>
Par arch (FutureR arch a)
new
  FutureR arch v2
e2 <- Par arch (FutureR arch v2)
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
    (v1
v1, v2
v2) <- FutureR arch (v1, v2) -> Par arch (v1, v2)
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> Par arch a
get FutureR arch t
FutureR arch (v1, v2)
e
    FutureR arch v1 -> v1 -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureR arch v1
e1 v1
v1
    FutureR arch v2 -> v2 -> Par arch ()
forall arch a.
(Async arch, HasCallStack) =>
FutureR arch a -> a -> Par arch ()
put FutureR arch v2
e2 v2
v2
  ValR arch env'1
env' <- ValR arch env
-> (LeftHandSide ScalarType v1 env env'1, FutureR arch v1)
-> Par arch (ValR arch env'1)
forall arch env t env'.
Async arch =>
ValR arch env
-> (ELeftHandSide t env env', FutureR arch t)
-> Par arch (ValR arch env')
pushE ValR arch env
env (LeftHandSide ScalarType v1 env env'1
l1, FutureR arch v1
e1)
  ValR arch env'1
-> (LeftHandSide ScalarType v2 env'1 env', FutureR arch v2)
-> 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 ValR arch env'1
env' (LeftHandSide ScalarType v2 env'1 env'
l2, FutureR arch v2
e2)

-- Projection of a value from a valuation using a de Bruijn index.
--
prj :: Idx env t -> ValR arch env -> FutureR arch t
prj :: Idx env t -> ValR arch env -> FutureR arch t
prj Idx env t
ZeroIdx       (Push ValR arch env
_   FutureR arch t
x) = FutureR arch t
FutureR arch t
x
prj (SuccIdx Idx env1 t
idx) (Push ValR arch env
val FutureR arch t
_) = Idx env1 t -> ValR arch env1 -> FutureR arch t
forall env t arch. Idx env t -> ValR arch env -> FutureR arch t
prj Idx env1 t
idx ValR arch env1
ValR arch env
val