{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

-- | Code generation for ImpCode with multicore operations.
module Futhark.CodeGen.ImpGen.Multicore
  ( Futhark.CodeGen.ImpGen.Multicore.compileProg,
    Warnings,
  )
where

import Control.Monad
import qualified Data.Map as M
import qualified Futhark.CodeGen.ImpCode.Multicore as Imp
import Futhark.CodeGen.ImpGen
import Futhark.CodeGen.ImpGen.Multicore.Base
import Futhark.CodeGen.ImpGen.Multicore.SegHist
import Futhark.CodeGen.ImpGen.Multicore.SegMap
import Futhark.CodeGen.ImpGen.Multicore.SegRed
import Futhark.CodeGen.ImpGen.Multicore.SegScan
import Futhark.IR.MCMem
import Futhark.MonadFreshNames
import Futhark.Util.IntegralExp (rem)
import Prelude hiding (quot, rem)

-- GCC supported primitve atomic Operations
-- TODO: Add support for 1, 2, and 16 bytes too
gccAtomics :: AtomicBinOp
gccAtomics :: AtomicBinOp
gccAtomics = (BinOp
 -> [(BinOp,
      VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp)]
 -> Maybe
      (VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp))
-> [(BinOp,
     VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp)]
-> AtomicBinOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip BinOp
-> [(BinOp,
     VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp)]
-> Maybe
     (VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(BinOp,
  VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp)]
cpu
  where
    cpu :: [(BinOp,
  VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp)]
cpu =
      [ (IntType -> Overflow -> BinOp
Add IntType
Int32 Overflow
OverflowUndef, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicAdd IntType
Int32),
        (IntType -> Overflow -> BinOp
Sub IntType
Int32 Overflow
OverflowUndef, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicSub IntType
Int32),
        (IntType -> BinOp
And IntType
Int32, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicAnd IntType
Int32),
        (IntType -> BinOp
Xor IntType
Int32, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicXor IntType
Int32),
        (IntType -> BinOp
Or IntType
Int32, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicOr IntType
Int32),
        (IntType -> Overflow -> BinOp
Add IntType
Int64 Overflow
OverflowUndef, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicAdd IntType
Int64),
        (IntType -> Overflow -> BinOp
Sub IntType
Int64 Overflow
OverflowUndef, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicSub IntType
Int64),
        (IntType -> BinOp
And IntType
Int64, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicAnd IntType
Int64),
        (IntType -> BinOp
Xor IntType
Int64, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicXor IntType
Int64),
        (IntType -> BinOp
Or IntType
Int64, IntType
-> VName -> VName -> Count Elements (TExp Int32) -> Exp -> AtomicOp
Imp.AtomicOr IntType
Int64)
      ]

compileProg ::
  MonadFreshNames m =>
  Prog MCMem ->
  m (Warnings, Imp.Definitions Imp.Multicore)
compileProg :: Prog MCMem -> m (Warnings, Definitions Multicore)
compileProg = HostEnv
-> Operations MCMem HostEnv Multicore
-> Space
-> Prog MCMem
-> m (Warnings, Definitions Multicore)
forall rep inner op (m :: * -> *) r.
(Mem rep inner, FreeIn op, MonadFreshNames m) =>
r
-> Operations rep r op
-> Space
-> Prog rep
-> m (Warnings, Definitions op)
Futhark.CodeGen.ImpGen.compileProg (AtomicBinOp -> Map VName Locks -> HostEnv
HostEnv AtomicBinOp
gccAtomics Map VName Locks
forall a. Monoid a => a
mempty) Operations MCMem HostEnv Multicore
ops Space
Imp.DefaultSpace
  where
    ops :: Operations MCMem HostEnv Multicore
ops =
      (OpCompiler MCMem HostEnv Multicore
-> Operations MCMem HostEnv Multicore
forall rep inner op r.
(Mem rep inner, FreeIn op) =>
OpCompiler rep r op -> Operations rep r op
defaultOperations OpCompiler MCMem HostEnv Multicore
PatT LetDecMem
-> MemOp (MCOp MCMem ()) -> ImpM MCMem HostEnv Multicore ()
opCompiler)
        { opsExpCompiler :: ExpCompiler MCMem HostEnv Multicore
opsExpCompiler = ExpCompiler MCMem HostEnv Multicore
compileMCExp
        }
    opCompiler :: PatT LetDecMem
-> MemOp (MCOp MCMem ()) -> ImpM MCMem HostEnv Multicore ()
opCompiler PatT LetDecMem
dest (Alloc SubExp
e Space
space) = Pat MCMem -> SubExp -> Space -> ImpM MCMem HostEnv Multicore ()
forall rep inner r op.
Mem rep inner =>
Pat rep -> SubExp -> Space -> ImpM rep r op ()
compileAlloc Pat MCMem
PatT LetDecMem
dest SubExp
e Space
space
    opCompiler PatT LetDecMem
dest (Inner MCOp MCMem ()
op) = Pat MCMem -> MCOp MCMem () -> ImpM MCMem HostEnv Multicore ()
compileMCOp Pat MCMem
PatT LetDecMem
dest MCOp MCMem ()
op

updateAcc :: VName -> [SubExp] -> [SubExp] -> MulticoreGen ()
updateAcc :: VName -> [SubExp] -> [SubExp] -> ImpM MCMem HostEnv Multicore ()
updateAcc VName
acc [SubExp]
is [SubExp]
vs = String
-> ImpM MCMem HostEnv Multicore ()
-> ImpM MCMem HostEnv Multicore ()
forall rep r op. String -> ImpM rep r op () -> ImpM rep r op ()
sComment String
"UpdateAcc" (ImpM MCMem HostEnv Multicore ()
 -> ImpM MCMem HostEnv Multicore ())
-> ImpM MCMem HostEnv Multicore ()
-> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ do
  -- See the ImpGen implementation of UpdateAcc for general notes.
  let is' :: [TExp Int64]
is' = (SubExp -> TExp Int64) -> [SubExp] -> [TExp Int64]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> TExp Int64
forall a. ToExp a => a -> TExp Int64
toInt64Exp [SubExp]
is
  (VName
c, Space
_space, [VName]
arrs, [TExp Int64]
dims, Maybe (Lambda MCMem)
op) <- VName
-> [TExp Int64]
-> ImpM
     MCMem
     HostEnv
     Multicore
     (VName, Space, [VName], [TExp Int64], Maybe (Lambda MCMem))
forall rep r op.
VName
-> [TExp Int64]
-> ImpM
     rep r op (VName, Space, [VName], [TExp Int64], Maybe (Lambda rep))
lookupAcc VName
acc [TExp Int64]
is'
  TExp Bool
-> ImpM MCMem HostEnv Multicore ()
-> ImpM MCMem HostEnv Multicore ()
forall rep r op. TExp Bool -> ImpM rep r op () -> ImpM rep r op ()
sWhen (Slice (TExp Int64) -> [TExp Int64] -> TExp Bool
inBounds ([DimIndex (TExp Int64)] -> Slice (TExp Int64)
forall d. [DimIndex d] -> Slice d
Slice ((TExp Int64 -> DimIndex (TExp Int64))
-> [TExp Int64] -> [DimIndex (TExp Int64)]
forall a b. (a -> b) -> [a] -> [b]
map TExp Int64 -> DimIndex (TExp Int64)
forall d. d -> DimIndex d
DimFix [TExp Int64]
is')) [TExp Int64]
dims) (ImpM MCMem HostEnv Multicore ()
 -> ImpM MCMem HostEnv Multicore ())
-> ImpM MCMem HostEnv Multicore ()
-> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$
    case Maybe (Lambda MCMem)
op of
      Maybe (Lambda MCMem)
Nothing ->
        [(VName, SubExp)]
-> ((VName, SubExp) -> ImpM MCMem HostEnv Multicore ())
-> ImpM MCMem HostEnv Multicore ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([VName] -> [SubExp] -> [(VName, SubExp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
arrs [SubExp]
vs) (((VName, SubExp) -> ImpM MCMem HostEnv Multicore ())
 -> ImpM MCMem HostEnv Multicore ())
-> ((VName, SubExp) -> ImpM MCMem HostEnv Multicore ())
-> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ \(VName
arr, SubExp
v) -> VName
-> [TExp Int64]
-> SubExp
-> [TExp Int64]
-> ImpM MCMem HostEnv Multicore ()
forall rep r op.
VName -> [TExp Int64] -> SubExp -> [TExp Int64] -> ImpM rep r op ()
copyDWIMFix VName
arr [TExp Int64]
is' SubExp
v []
      Just Lambda MCMem
lam -> do
        [LParam MCMem] -> ImpM MCMem HostEnv Multicore ()
forall rep inner r op.
Mem rep inner =>
[LParam rep] -> ImpM rep r op ()
dLParams ([LParam MCMem] -> ImpM MCMem HostEnv Multicore ())
-> [LParam MCMem] -> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ Lambda MCMem -> [LParam MCMem]
forall rep. LambdaT rep -> [LParam rep]
lambdaParams Lambda MCMem
lam
        let ([VName]
_x_params, [VName]
y_params) =
              Int -> [VName] -> ([VName], [VName])
forall a. Int -> [a] -> ([a], [a])
splitAt ([SubExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SubExp]
vs) ([VName] -> ([VName], [VName])) -> [VName] -> ([VName], [VName])
forall a b. (a -> b) -> a -> b
$ (Param LetDecMem -> VName) -> [Param LetDecMem] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param LetDecMem -> VName
forall dec. Param dec -> VName
paramName ([Param LetDecMem] -> [VName]) -> [Param LetDecMem] -> [VName]
forall a b. (a -> b) -> a -> b
$ Lambda MCMem -> [LParam MCMem]
forall rep. LambdaT rep -> [LParam rep]
lambdaParams Lambda MCMem
lam
        [(VName, SubExp)]
-> ((VName, SubExp) -> ImpM MCMem HostEnv Multicore ())
-> ImpM MCMem HostEnv Multicore ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([VName] -> [SubExp] -> [(VName, SubExp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
y_params [SubExp]
vs) (((VName, SubExp) -> ImpM MCMem HostEnv Multicore ())
 -> ImpM MCMem HostEnv Multicore ())
-> ((VName, SubExp) -> ImpM MCMem HostEnv Multicore ())
-> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ \(VName
yp, SubExp
v) -> VName
-> [DimIndex (TExp Int64)]
-> SubExp
-> [DimIndex (TExp Int64)]
-> ImpM MCMem HostEnv Multicore ()
forall rep r op.
VName
-> [DimIndex (TExp Int64)]
-> SubExp
-> [DimIndex (TExp Int64)]
-> ImpM rep r op ()
copyDWIM VName
yp [] SubExp
v []
        AtomicBinOp
atomics <- HostEnv -> AtomicBinOp
hostAtomics (HostEnv -> AtomicBinOp)
-> ImpM MCMem HostEnv Multicore HostEnv
-> ImpM MCMem HostEnv Multicore AtomicBinOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM MCMem HostEnv Multicore HostEnv
forall rep r op. ImpM rep r op r
askEnv
        case AtomicBinOp -> Lambda MCMem -> AtomicUpdate MCMem ()
atomicUpdateLocking AtomicBinOp
atomics Lambda MCMem
lam of
          AtomicPrim DoAtomicUpdate MCMem ()
f -> DoAtomicUpdate MCMem ()
f [VName]
arrs [TExp Int64]
is'
          AtomicCAS DoAtomicUpdate MCMem ()
f -> DoAtomicUpdate MCMem ()
f [VName]
arrs [TExp Int64]
is'
          AtomicLocking Locking -> DoAtomicUpdate MCMem ()
f -> do
            Maybe Locks
c_locks <- VName -> Map VName Locks -> Maybe Locks
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
c (Map VName Locks -> Maybe Locks)
-> (HostEnv -> Map VName Locks) -> HostEnv -> Maybe Locks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostEnv -> Map VName Locks
hostLocks (HostEnv -> Maybe Locks)
-> ImpM MCMem HostEnv Multicore HostEnv
-> ImpM MCMem HostEnv Multicore (Maybe Locks)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM MCMem HostEnv Multicore HostEnv
forall rep r op. ImpM rep r op r
askEnv
            case Maybe Locks
c_locks of
              Just (Locks VName
locks Int
num_locks) -> do
                let locking :: Locking
locking =
                      VName
-> TExp Int32
-> TExp Int32
-> TExp Int32
-> ([TExp Int64] -> [TExp Int64])
-> Locking
Locking VName
locks TExp Int32
0 TExp Int32
1 TExp Int32
0 (([TExp Int64] -> [TExp Int64]) -> Locking)
-> ([TExp Int64] -> [TExp Int64]) -> Locking
forall a b. (a -> b) -> a -> b
$
                        TExp Int64 -> [TExp Int64]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TExp Int64 -> [TExp Int64])
-> ([TExp Int64] -> TExp Int64) -> [TExp Int64] -> [TExp Int64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TExp Int64 -> TExp Int64 -> TExp Int64
forall e. IntegralExp e => e -> e -> e
`rem` Int -> TExp Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num_locks) (TExp Int64 -> TExp Int64)
-> ([TExp Int64] -> TExp Int64) -> [TExp Int64] -> TExp Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TExp Int64] -> [TExp Int64] -> TExp Int64
forall num. IntegralExp num => [num] -> [num] -> num
flattenIndex [TExp Int64]
dims
                Locking -> DoAtomicUpdate MCMem ()
f Locking
locking [VName]
arrs [TExp Int64]
is'
              Maybe Locks
Nothing ->
                String -> ImpM MCMem HostEnv Multicore ()
forall a. HasCallStack => String -> a
error (String -> ImpM MCMem HostEnv Multicore ())
-> String -> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ String
"Missing locks for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VName -> String
forall a. Pretty a => a -> String
pretty VName
acc

withAcc ::
  Pat MCMem ->
  [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))] ->
  Lambda MCMem ->
  MulticoreGen ()
withAcc :: Pat MCMem
-> [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
-> Lambda MCMem
-> ImpM MCMem HostEnv Multicore ()
withAcc Pat MCMem
pat [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
inputs Lambda MCMem
lam = do
  AtomicBinOp
atomics <- HostEnv -> AtomicBinOp
hostAtomics (HostEnv -> AtomicBinOp)
-> ImpM MCMem HostEnv Multicore HostEnv
-> ImpM MCMem HostEnv Multicore AtomicBinOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM MCMem HostEnv Multicore HostEnv
forall rep r op. ImpM rep r op r
askEnv
  AtomicBinOp
-> [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
-> ImpM MCMem HostEnv Multicore ()
locksForInputs AtomicBinOp
atomics ([(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
 -> ImpM MCMem HostEnv Multicore ())
-> [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
-> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ [VName]
-> [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
-> [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
accs [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
inputs
  where
    accs :: [VName]
accs = (Param LetDecMem -> VName) -> [Param LetDecMem] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param LetDecMem -> VName
forall dec. Param dec -> VName
paramName ([Param LetDecMem] -> [VName]) -> [Param LetDecMem] -> [VName]
forall a b. (a -> b) -> a -> b
$ Lambda MCMem -> [LParam MCMem]
forall rep. LambdaT rep -> [LParam rep]
lambdaParams Lambda MCMem
lam
    locksForInputs :: AtomicBinOp
-> [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
-> ImpM MCMem HostEnv Multicore ()
locksForInputs AtomicBinOp
_ [] =
      ExpCompiler MCMem HostEnv Multicore
forall rep inner r op.
Mem rep inner =>
Pat rep -> Exp rep -> ImpM rep r op ()
defCompileExp Pat MCMem
pat (Exp MCMem -> ImpM MCMem HostEnv Multicore ())
-> Exp MCMem -> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
-> Lambda MCMem -> Exp MCMem
forall rep. [WithAccInput rep] -> Lambda rep -> ExpT rep
WithAcc [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
inputs Lambda MCMem
lam
    locksForInputs AtomicBinOp
atomics ((VName
c, (Shape
_, [VName]
_, Maybe (Lambda MCMem, [SubExp])
op)) : [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
inputs')
      | Just (Lambda MCMem
op_lam, [SubExp]
_) <- Maybe (Lambda MCMem, [SubExp])
op,
        AtomicLocking Locking -> DoAtomicUpdate MCMem ()
_ <- AtomicBinOp -> Lambda MCMem -> AtomicUpdate MCMem ()
atomicUpdateLocking AtomicBinOp
atomics Lambda MCMem
op_lam = do
        let num_locks :: Int
num_locks = Int
100151
        VName
locks_arr <-
          String
-> Space
-> PrimType
-> ArrayContents
-> ImpM MCMem HostEnv Multicore VName
forall rep r op.
String -> Space -> PrimType -> ArrayContents -> ImpM rep r op VName
sStaticArray String
"withacc_locks" Space
DefaultSpace PrimType
int32 (ArrayContents -> ImpM MCMem HostEnv Multicore VName)
-> ArrayContents -> ImpM MCMem HostEnv Multicore VName
forall a b. (a -> b) -> a -> b
$
            Int -> ArrayContents
Imp.ArrayZeros Int
num_locks
        let locks :: Locks
locks = VName -> Int -> Locks
Locks VName
locks_arr Int
num_locks
            extend :: HostEnv -> HostEnv
extend HostEnv
env = HostEnv
env {hostLocks :: Map VName Locks
hostLocks = VName -> Locks -> Map VName Locks -> Map VName Locks
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
c Locks
locks (Map VName Locks -> Map VName Locks)
-> Map VName Locks -> Map VName Locks
forall a b. (a -> b) -> a -> b
$ HostEnv -> Map VName Locks
hostLocks HostEnv
env}
        (HostEnv -> HostEnv)
-> ImpM MCMem HostEnv Multicore ()
-> ImpM MCMem HostEnv Multicore ()
forall r rep op a. (r -> r) -> ImpM rep r op a -> ImpM rep r op a
localEnv HostEnv -> HostEnv
extend (ImpM MCMem HostEnv Multicore ()
 -> ImpM MCMem HostEnv Multicore ())
-> ImpM MCMem HostEnv Multicore ()
-> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ AtomicBinOp
-> [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
-> ImpM MCMem HostEnv Multicore ()
locksForInputs AtomicBinOp
atomics [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
inputs'
      | Bool
otherwise =
        AtomicBinOp
-> [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
-> ImpM MCMem HostEnv Multicore ()
locksForInputs AtomicBinOp
atomics [(VName, (Shape, [VName], Maybe (Lambda MCMem, [SubExp])))]
inputs'

compileMCExp :: ExpCompiler MCMem HostEnv Imp.Multicore
compileMCExp :: ExpCompiler MCMem HostEnv Multicore
compileMCExp Pat MCMem
_ (BasicOp (UpdateAcc VName
acc [SubExp]
is [SubExp]
vs)) =
  VName -> [SubExp] -> [SubExp] -> ImpM MCMem HostEnv Multicore ()
updateAcc VName
acc [SubExp]
is [SubExp]
vs
compileMCExp Pat MCMem
pat (WithAcc [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
inputs Lambda MCMem
lam) =
  Pat MCMem
-> [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
-> Lambda MCMem
-> ImpM MCMem HostEnv Multicore ()
withAcc Pat MCMem
pat [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))]
inputs Lambda MCMem
lam
compileMCExp Pat MCMem
dest Exp MCMem
e =
  ExpCompiler MCMem HostEnv Multicore
forall rep inner r op.
Mem rep inner =>
Pat rep -> Exp rep -> ImpM rep r op ()
defCompileExp Pat MCMem
dest Exp MCMem
e

compileMCOp ::
  Pat MCMem ->
  MCOp MCMem () ->
  ImpM MCMem HostEnv Imp.Multicore ()
compileMCOp :: Pat MCMem -> MCOp MCMem () -> ImpM MCMem HostEnv Multicore ()
compileMCOp Pat MCMem
_ (OtherOp ()) = () -> ImpM MCMem HostEnv Multicore ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compileMCOp Pat MCMem
pat (ParOp Maybe (SegOp () MCMem)
par_op SegOp () MCMem
op) = do
  let space :: SegSpace
space = SegOp () MCMem -> SegSpace
getSpace SegOp () MCMem
op
  VName -> TExp Int64 -> ImpM MCMem HostEnv Multicore ()
forall t rep r op. VName -> TExp t -> ImpM rep r op ()
dPrimV_ (SegSpace -> VName
segFlat SegSpace
space) (TExp Int64
0 :: Imp.TExp Int64)
  TExp Int64
iterations <- SegOp () MCMem -> SegSpace -> MulticoreGen (TExp Int64)
getIterationDomain SegOp () MCMem
op SegSpace
space
  TV Int32
nsubtasks <- String -> PrimType -> ImpM MCMem HostEnv Multicore (TV Int32)
forall rep r op t. String -> PrimType -> ImpM rep r op (TV t)
dPrim String
"num_tasks" (PrimType -> ImpM MCMem HostEnv Multicore (TV Int32))
-> PrimType -> ImpM MCMem HostEnv Multicore (TV Int32)
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
IntType IntType
Int32
  Code
seq_code <- Pat MCMem
-> SegOp () MCMem -> TV Int32 -> ImpM MCMem HostEnv Multicore Code
compileSegOp Pat MCMem
pat SegOp () MCMem
op TV Int32
nsubtasks
  [Param]
retvals <- Pat MCMem -> SegOp () MCMem -> MulticoreGen [Param]
getReturnParams Pat MCMem
pat SegOp () MCMem
op

  let scheduling_info :: Scheduling -> SchedulerInfo
scheduling_info = VName -> Exp -> Scheduling -> SchedulerInfo
Imp.SchedulerInfo (TV Int32 -> VName
forall t. TV t -> VName
tvVar TV Int32
nsubtasks) (TExp Int64 -> Exp
forall t v. TPrimExp t v -> PrimExp v
untyped TExp Int64
iterations)

  Code
par_code <- case Maybe (SegOp () MCMem)
par_op of
    Just SegOp () MCMem
nested_op -> do
      let space' :: SegSpace
space' = SegOp () MCMem -> SegSpace
getSpace SegOp () MCMem
nested_op
      VName -> TExp Int64 -> ImpM MCMem HostEnv Multicore ()
forall t rep r op. VName -> TExp t -> ImpM rep r op ()
dPrimV_ (SegSpace -> VName
segFlat SegSpace
space') (TExp Int64
0 :: Imp.TExp Int64)
      Pat MCMem
-> SegOp () MCMem -> TV Int32 -> ImpM MCMem HostEnv Multicore Code
compileSegOp Pat MCMem
pat SegOp () MCMem
nested_op TV Int32
nsubtasks
    Maybe (SegOp () MCMem)
Nothing -> Code -> ImpM MCMem HostEnv Multicore Code
forall (m :: * -> *) a. Monad m => a -> m a
return Code
forall a. Monoid a => a
mempty

  let par_task :: Maybe ParallelTask
par_task = case Maybe (SegOp () MCMem)
par_op of
        Just SegOp () MCMem
nested_op -> ParallelTask -> Maybe ParallelTask
forall a. a -> Maybe a
Just (ParallelTask -> Maybe ParallelTask)
-> ParallelTask -> Maybe ParallelTask
forall a b. (a -> b) -> a -> b
$ Code -> VName -> ParallelTask
Imp.ParallelTask Code
par_code (VName -> ParallelTask) -> VName -> ParallelTask
forall a b. (a -> b) -> a -> b
$ SegSpace -> VName
segFlat (SegSpace -> VName) -> SegSpace -> VName
forall a b. (a -> b) -> a -> b
$ SegOp () MCMem -> SegSpace
getSpace SegOp () MCMem
nested_op
        Maybe (SegOp () MCMem)
Nothing -> Maybe ParallelTask
forall a. Maybe a
Nothing

  let non_free :: [VName]
non_free =
        ( [SegSpace -> VName
segFlat SegSpace
space, TV Int32 -> VName
forall t. TV t -> VName
tvVar TV Int32
nsubtasks]
            [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
Imp.paramName [Param]
retvals
        )
          [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ case Maybe (SegOp () MCMem)
par_op of
            Just SegOp () MCMem
nested_op ->
              [SegSpace -> VName
segFlat (SegSpace -> VName) -> SegSpace -> VName
forall a b. (a -> b) -> a -> b
$ SegOp () MCMem -> SegSpace
getSpace SegOp () MCMem
nested_op]
            Maybe (SegOp () MCMem)
Nothing -> []

  String
s <- SegOp () MCMem -> MulticoreGen String
segOpString SegOp () MCMem
op
  [Param]
free_params <- Code -> [VName] -> MulticoreGen [Param]
freeParams (Code
par_code Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> Code
seq_code) [VName]
non_free
  let seq_task :: ParallelTask
seq_task = Code -> VName -> ParallelTask
Imp.ParallelTask Code
seq_code (SegSpace -> VName
segFlat SegSpace
space)
  Code -> ImpM MCMem HostEnv Multicore ()
forall op rep r. Code op -> ImpM rep r op ()
emit (Code -> ImpM MCMem HostEnv Multicore ())
-> Code -> ImpM MCMem HostEnv Multicore ()
forall a b. (a -> b) -> a -> b
$ Multicore -> Code
forall a. a -> Code a
Imp.Op (Multicore -> Code) -> Multicore -> Code
forall a b. (a -> b) -> a -> b
$ String
-> [Param]
-> ParallelTask
-> Maybe ParallelTask
-> [Param]
-> SchedulerInfo
-> Multicore
Imp.Segop String
s [Param]
free_params ParallelTask
seq_task Maybe ParallelTask
par_task [Param]
retvals (SchedulerInfo -> Multicore) -> SchedulerInfo -> Multicore
forall a b. (a -> b) -> a -> b
$ Scheduling -> SchedulerInfo
scheduling_info (SegOp () MCMem -> Code -> Scheduling
forall rep. SegOp () rep -> Code -> Scheduling
decideScheduling' SegOp () MCMem
op Code
seq_code)

compileSegOp ::
  Pat MCMem ->
  SegOp () MCMem ->
  TV Int32 ->
  ImpM MCMem HostEnv Imp.Multicore Imp.Code
compileSegOp :: Pat MCMem
-> SegOp () MCMem -> TV Int32 -> ImpM MCMem HostEnv Multicore Code
compileSegOp Pat MCMem
pat (SegHist ()
_ SegSpace
space [HistOp MCMem]
histops [Type]
_ KernelBody MCMem
kbody) TV Int32
ntasks =
  Pat MCMem
-> SegSpace
-> [HistOp MCMem]
-> KernelBody MCMem
-> TV Int32
-> ImpM MCMem HostEnv Multicore Code
compileSegHist Pat MCMem
pat SegSpace
space [HistOp MCMem]
histops KernelBody MCMem
kbody TV Int32
ntasks
compileSegOp Pat MCMem
pat (SegScan ()
_ SegSpace
space [SegBinOp MCMem]
scans [Type]
_ KernelBody MCMem
kbody) TV Int32
ntasks =
  Pat MCMem
-> SegSpace
-> [SegBinOp MCMem]
-> KernelBody MCMem
-> TV Int32
-> ImpM MCMem HostEnv Multicore Code
compileSegScan Pat MCMem
pat SegSpace
space [SegBinOp MCMem]
scans KernelBody MCMem
kbody TV Int32
ntasks
compileSegOp Pat MCMem
pat (SegRed ()
_ SegSpace
space [SegBinOp MCMem]
reds [Type]
_ KernelBody MCMem
kbody) TV Int32
ntasks =
  Pat MCMem
-> SegSpace
-> [SegBinOp MCMem]
-> KernelBody MCMem
-> TV Int32
-> ImpM MCMem HostEnv Multicore Code
compileSegRed Pat MCMem
pat SegSpace
space [SegBinOp MCMem]
reds KernelBody MCMem
kbody TV Int32
ntasks
compileSegOp Pat MCMem
pat (SegMap ()
_ SegSpace
space [Type]
_ KernelBody MCMem
kbody) TV Int32
_ =
  Pat MCMem
-> SegSpace
-> KernelBody MCMem
-> ImpM MCMem HostEnv Multicore Code
compileSegMap Pat MCMem
pat SegSpace
space KernelBody MCMem
kbody