{-# LANGUAGE CPP, GADTs #-}
-- |
-- Module      : Data.Array.Accelerate.CUDA.Analysis.Hash
-- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell
-- License     : BSD3
--
-- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>
-- Stability   : experimental
-- Portability : non-partable (GHC extensions)
--

module Data.Array.Accelerate.CUDA.Analysis.Hash (

  AccKey, accToKey, hashAccKey

) where

import Data.Char
import Language.C
import Text.PrettyPrint
import Codec.Compression.Zlib
import Data.ByteString.Lazy.Char8                       (ByteString)
import qualified Data.ByteString.Lazy.Char8             as L
import qualified Data.HashTable                         as Hash

import Data.Array.Accelerate.AST
import Data.Array.Accelerate.Type
import Data.Array.Accelerate.Pretty ()
import Data.Array.Accelerate.Analysis.Type
import Data.Array.Accelerate.Analysis.Shape
import Data.Array.Accelerate.CUDA.CodeGen
import Data.Array.Accelerate.Array.Representation
import qualified Data.Array.Accelerate.Array.Sugar      as Sugar

#include "accelerate.h"


type AccKey = ByteString

-- | Reimplementation of Data.HashTable.hashString to fold over a lazy
-- bytestring rather than a list of characters.
--
hashAccKey :: AccKey -> Int32
hashAccKey = L.foldl' f golden
  where
    f m c  = fromIntegral (ord c) * magic + Hash.hashInt (fromIntegral m)
    magic  = 0xdeadbeef
    golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32)


-- | Generate a unique key for each kernel computation
--
accToKey :: OpenAcc aenv a -> AccKey
accToKey acc =
  let key = compress . L.pack $ showAcc acc
  in  L.head key `seq` key


-- The first radical identifies the skeleton type (actually, this is arithmetic
-- sequence A000978), followed by the salient features that parameterise
-- skeleton instantiation.
--
showAcc :: OpenAcc aenv a -> String
showAcc acc@(OpenAcc pacc) =
  case pacc of
    Generate e f       -> chr   1 : showExp e ++ showFun f
    Replicate s e a    -> chr   3 : showTy (accType a) ++ showExp e ++ showSI s e a acc
    Index s a e        -> chr   5 : showTy (accType a) ++ showExp e ++ showSI s e acc a
    Map f a            -> chr   7 : showTy (accType a) ++ showFun f
    ZipWith f x y      -> chr  11 : showTy (accType x) ++ showTy (accType y) ++ showFun f
    Fold f e a         -> chr  13 : chr (accDim a) : showTy (accType a) ++ showFun f ++ showExp e
    Fold1 f a          -> chr  17 : chr (accDim a) : showTy (accType a) ++ showFun f
    FoldSeg f e a _    -> chr  19 : chr (accDim a) : showTy (accType a) ++ showFun f ++ showExp e
    Fold1Seg f a _     -> chr  23 : chr (accDim a) : showTy (accType a) ++ showFun f
    Scanl f e a        -> chr  31 : showTy (accType a) ++ showFun f ++ showExp e
    Scanl' f e a       -> chr  43 : showTy (accType a) ++ showFun f ++ showExp e
    Scanl1 f a         -> chr  61 : showTy (accType a) ++ showFun f
    Scanr f e a        -> chr  79 : showTy (accType a) ++ showFun f ++ showExp e
    Scanr' f e a       -> chr 101 : showTy (accType a) ++ showFun f ++ showExp e
    Scanr1 f a         -> chr 127 : showTy (accType a) ++ showFun f
    Permute c _ p a    -> chr 167 : showTy (accType a) ++ showFun c ++ showFun p
    Backpermute _ p a  -> chr 191 : showTy (accType a) ++ showFun p
    Stencil f _ a      -> chr 199 : showTy (accType a) ++ showFun f
    Stencil2 f _ x _ y -> chr 313 : showTy (accType x) ++ showTy (accType y) ++ showFun f
    _                  ->
      let msg = unlines ["incomplete patterns for key generation", render (nest 2 doc)]
          ppr = show acc
          doc | length ppr <= 250 = text ppr
              | otherwise         = text (take 250 ppr) <+> text "... {truncated}"
      in
      INTERNAL_ERROR(error) "accToKey" msg

  where
    showTy :: TupleType a -> String
    showTy UnitTuple = []
    showTy (SingleTuple ty) = show ty
    showTy (PairTuple a b)  = showTy a ++ showTy b

    showFun :: OpenFun env aenv a -> String
    showFun = render . hcat . map pretty . codeGenFun

    showExp :: OpenExp env aenv a -> String
    showExp = render . hcat . map pretty . codeGenExp

    showSI :: SliceIndex (Sugar.EltRepr slix) (Sugar.EltRepr sl) co (Sugar.EltRepr dim)
           -> Exp aenv slix                         {- dummy -}
           -> OpenAcc aenv (Sugar.Array sl e)       {- dummy -}
           -> OpenAcc aenv (Sugar.Array dim e)      {- dummy -}
           -> String
    showSI sl _ _ _ = slice sl 0
      where
        slice :: SliceIndex slix sl co dim -> Int -> String
        slice (SliceNil)            _ = []
        slice (SliceAll   sliceIdx) n = '_'    :  slice sliceIdx n
        slice (SliceFixed sliceIdx) n = show n ++ slice sliceIdx (n+1)

{-
-- hash function from the dragon book pp437; assumes 7 bit characters and needs
-- the (nearly) full range of values guaranteed for `Int' by the Haskell
-- language definition; can handle 8 bit characters provided we have 29 bit for
-- the `Int's without sign
--
quad :: String -> Int32
quad (c1:c2:c3:c4:s)  = (( ord' c4 * bits21
                         + ord' c3 * bits14
                         + ord' c2 * bits7
                         + ord' c1)
                         `mod` bits28)
                        + (quad s `mod` bits28)
quad (c1:c2:c3:[]  )  = ord' c3 * bits14 + ord' c2 * bits7 + ord' c1
quad (c1:c2:[]     )  = ord' c2 * bits7  + ord' c1
quad (c1:[]        )  = ord' c1
quad ([]           )  = 0

ord' :: Char -> Int32
ord' = fromIntegral . ord

bits7, bits14, bits21, bits28 :: Int32
bits7  = 2^(7 ::Int32)
bits14 = 2^(14::Int32)
bits21 = 2^(21::Int32)
bits28 = 2^(28::Int32)
-}