Cache.hs

{-# 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.Internal
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 pacc = do
  let opt = defaultHashOptions { perfect=False }
      uid = hashPreOpenAccWith opt encodeDelayedOpenAcc pacc
  cacheFile <- cacheOfUID uid
  return (uid, 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 = do
  appdir   <- liftIO $ getXdgDirectory XdgCache "accelerate"
  template <- targetCacheTemplate
  let
      (base, file)  = splitFileName template
      (name, ext)   = splitExtensions file
      --
      tag | tracyIsEnabled = "tracy"
          | debuggingIsEnabled = "dbg"
          | otherwise = "rel"
      cachepath     = appdir </> "accelerate-llvm-" ++ showVersion version </> base </> tag
      cachefile     = cachepath </> printf "%s%s" name (show uid) <.> ext
  --
  liftIO $ createDirectoryIfMissing True cachepath
  return cachefile

-- | Remove the cache directory
--
{-# INLINEABLE removeCacheDirectory #-}
removeCacheDirectory :: Persistent arch => LLVM arch ()
removeCacheDirectory = do
  appdir    <- liftIO $ getXdgDirectory XdgCache "accelerate"
  template  <- targetCacheTemplate
  let
      (base, _)     = splitFileName template
      cachepath     = appdir </> "accelerate-llvm-" ++ showVersion version </> base
  --
  liftIO $ removeDirectoryRecursive cachepath