Base.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-# OPTIONS_GHC -Wno-orphans     #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Base
-- Copyright   : [2015..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.Native.CodeGen.Base
  where

import Data.Array.Accelerate.LLVM.CodeGen.Base
import Data.Array.Accelerate.LLVM.CodeGen.IR
import Data.Array.Accelerate.LLVM.CodeGen.Module
import Data.Array.Accelerate.LLVM.CodeGen.Monad
import Data.Array.Accelerate.LLVM.CodeGen.Profile
import Data.Array.Accelerate.LLVM.CodeGen.Sugar
import Data.Array.Accelerate.LLVM.Compile.Cache
import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )
import Data.Array.Accelerate.Representation.Shape

import LLVM.AST.Type.Name
import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty     as LP

import Data.String
import qualified Data.ByteString.Short.Char8                        as S8


-- | Generate function parameters that will specify the first and last (linear)
-- index of the array this thread should evaluate.
--
gangParam :: ShapeR sh -> (Operands sh, Operands sh, [LP.Typed LP.Ident])
gangParam shr =
  let start = "ix.start"
      end   = "ix.end"
      tp    = shapeType shr
  in
  (local tp start, local tp end, parameter tp start ++ parameter tp end)


-- -- | The worker ID of the calling thread
-- --
-- gangId :: (Operands Int, [LLVM.Parameter])
-- gangId =
--   let tid = "ix.tid"
--   in (local (TupRsingle scalarTypeInt) tid, [ downcast scalarTypeInt ] )


-- Global function definitions
-- ---------------------------

data instance KernelMetadata Native = KM_Native ()

-- | Combine kernels into a single program
--
(+++) :: IROpenAcc Native aenv a -> IROpenAcc Native aenv a -> IROpenAcc Native aenv a
IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2)

-- | Create a single kernel program
--
makeOpenAcc :: UID -> Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (IROpenAcc Native aenv a)
makeOpenAcc uid name param kernel = do
  body  <- makeKernel (name <> fromString ('_' : show uid)) param kernel
  return $ IROpenAcc [body]

-- | Create a complete kernel function by running the code generation process
-- specified in the final parameter.
--
makeKernel :: Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (Kernel Native aenv a)
makeKernel name@(Label sbs) param kernel = do
  zone <- zone_begin_alloc 0 [] (S8.unpack sbs) [] 0
  _    <- kernel
  _    <- zone_end zone
  return_
  code <- createBlocks
  return  $ Kernel
    { kernelMetadata = KM_Native ()
    , unKernel       = LP.Define
        { LP.defLinkage = Just LP.DLLExport  -- ensure the symbols are visible on Windows
        , LP.defVisibility = Nothing
        , LP.defRetType = LP.PrimType LP.Void
        , LP.defName = labelToPrettyS name
        , LP.defArgs = param
        , LP.defVarArgs = False
        , LP.defAttrs = []
        , LP.defSection = Nothing
        , LP.defGC = Nothing
        , LP.defBody = code
        , LP.defMetadata = mempty
        , LP.defComdat = Nothing
        }
    }