{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Compile.Cache
-- Copyright   : [2017..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.Compile.Cache (

  Persistent(..), UID,
  cacheOfUID,
  cacheOfPreOpenAcc,
  removeCacheDirectory,

) where

import Data.Array.Accelerate.AST
import Data.Array.Accelerate.Analysis.Hash
import Data.Array.Accelerate.Debug
import Data.Array.Accelerate.Trafo.Delayed

import Data.Array.Accelerate.LLVM.State

import Control.Monad.Trans
import Data.Version
import System.Directory
import System.FilePath
import Text.Printf

import Paths_accelerate_llvm


-- TODO:
--  * Remove old files which have not been accessed in some time
--  * Reuse old cache files when upgrading to new versions (ala stack)

class Persistent arch where
  -- | Specify a filename template which can be used to cache files for a given
  -- backend. This should also include something to distinguish this
  -- particular backend/target from another.
  --
  targetCacheTemplate :: LLVM arch FilePath


-- | Unique identifier for an accelerate computation (SHA3-256 digest)
--
type UID = Hash


-- | Return the unique cache file path corresponding to a given accelerate
-- computation.
--
{-# INLINEABLE cacheOfPreOpenAcc #-}
cacheOfPreOpenAcc
    :: Persistent arch
    => PreOpenAcc DelayedOpenAcc aenv a
    -> LLVM arch (UID, FilePath)
cacheOfPreOpenAcc :: PreOpenAcc DelayedOpenAcc aenv a -> LLVM arch (UID, FilePath)
cacheOfPreOpenAcc PreOpenAcc DelayedOpenAcc aenv a
pacc = do
  let opt :: HashOptions
opt = HashOptions
defaultHashOptions { perfect :: Bool
perfect=Bool
False }
      uid :: UID
uid = HashOptions
-> EncodeAcc DelayedOpenAcc
-> PreOpenAcc DelayedOpenAcc aenv a
-> UID
forall (acc :: * -> * -> *) aenv a.
HasArraysR acc =>
HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> UID
hashPreOpenAccWith HashOptions
opt EncodeAcc DelayedOpenAcc
encodeDelayedOpenAcc PreOpenAcc DelayedOpenAcc aenv a
pacc
  FilePath
cacheFile <- UID -> LLVM arch FilePath
forall arch. Persistent arch => UID -> LLVM arch FilePath
cacheOfUID UID
uid
  (UID, FilePath) -> LLVM arch (UID, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (UID
uid, FilePath
cacheFile)


-- | Return the unique cache file path corresponding to the unique identifier of
-- an accelerate computation.
--
{-# INLINEABLE cacheOfUID #-}
cacheOfUID
    :: Persistent arch
    => UID
    -> LLVM arch FilePath
cacheOfUID :: UID -> LLVM arch FilePath
cacheOfUID UID
uid = do
  Bool
dbg       <- IO Bool -> LLVM arch Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> LLVM arch Bool) -> IO Bool -> LLVM arch Bool
forall a b. (a -> b) -> a -> b
$ if Bool
debuggingIsEnabled then Flag -> IO Bool
getFlag Flag
debug else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  FilePath
appdir    <- IO FilePath -> LLVM arch FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> LLVM arch FilePath)
-> IO FilePath -> LLVM arch FilePath
forall a b. (a -> b) -> a -> b
$ XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgCache FilePath
"accelerate"
  FilePath
template  <- LLVM arch FilePath
forall arch. Persistent arch => LLVM arch FilePath
targetCacheTemplate
  let
      (FilePath
base, FilePath
file)  = FilePath -> (FilePath, FilePath)
splitFileName FilePath
template
      (FilePath
name, FilePath
ext)   = FilePath -> (FilePath, FilePath)
splitExtensions FilePath
file
      --
      cachepath :: FilePath
cachepath     = FilePath
appdir FilePath -> FilePath -> FilePath
</> FilePath
"accelerate-llvm-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
version FilePath -> FilePath -> FilePath
</> FilePath
base FilePath -> FilePath -> FilePath
</> if Bool
dbg then FilePath
"dbg" else FilePath
"rel"
      cachefile :: FilePath
cachefile     = FilePath
cachepath FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s%s" FilePath
name (UID -> FilePath
forall a. Show a => a -> FilePath
show UID
uid) FilePath -> FilePath -> FilePath
<.> FilePath
ext
  --
  IO () -> LLVM arch ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LLVM arch ()) -> IO () -> LLVM arch ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
cachepath
  FilePath -> LLVM arch FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
cachefile


-- | Remove the cache directory
--
{-# INLINEABLE removeCacheDirectory #-}
removeCacheDirectory :: Persistent arch => LLVM arch ()
removeCacheDirectory :: LLVM arch ()
removeCacheDirectory = do
  FilePath
appdir    <- IO FilePath -> LLVM arch FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> LLVM arch FilePath)
-> IO FilePath -> LLVM arch FilePath
forall a b. (a -> b) -> a -> b
$ XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgCache FilePath
"accelerate"
  FilePath
template  <- LLVM arch FilePath
forall arch. Persistent arch => LLVM arch FilePath
targetCacheTemplate
  let
      (FilePath
base, FilePath
_)     = FilePath -> (FilePath, FilePath)
splitFileName FilePath
template
      cachepath :: FilePath
cachepath     = FilePath
appdir FilePath -> FilePath -> FilePath
</> FilePath
"accelerate-llvm-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
version FilePath -> FilePath -> FilePath
</> FilePath
base
  --
  IO () -> LLVM arch ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LLVM arch ()) -> IO () -> LLVM arch ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
cachepath