Hash.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE PatternGuards       #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Analysis.Hash
-- 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.Analysis.Hash (

  -- hashing expressions
  Hash,
  HashOptions(..), defaultHashOptions,
  hashPreOpenAcc, hashPreOpenAccWith,
  hashOpenFun, hashOpenExp,

  -- auxiliary
  EncodeAcc,
  encodePreOpenAcc,
  encodeOpenExp,
  encodeOpenFun,
  encodeArraysType,
  hashQ,

) where

import Data.Array.Accelerate.AST
import Data.Array.Accelerate.AST.Idx
import Data.Array.Accelerate.AST.LeftHandSide
import Data.Array.Accelerate.AST.Var
import Data.Array.Accelerate.Analysis.Hash.TH
import Data.Array.Accelerate.Representation.Array
import Data.Array.Accelerate.Representation.Shape
import Data.Array.Accelerate.Representation.Slice
import Data.Array.Accelerate.Representation.Stencil
import Data.Array.Accelerate.Representation.Type
import Data.Array.Accelerate.Type
import Data.Primitive.Vec

import Crypto.Hash
import qualified Data.Hashable as Hashable
import Data.ByteString.Builder
import Data.ByteString.Builder.Extra
import Data.ByteString.Short.Internal                               ( ShortByteString(..) )
import Data.Monoid
import System.IO.Unsafe                                             ( unsafePerformIO )
import System.Mem.StableName                                        ( hashStableName, makeStableName )
import Prelude                                                      hiding ( exp )


-- Hashing
-- -------

type Hash = Digest SHA3_256

data HashOptions = HashOptions
  { perfect :: Bool
    -- ^ Should the hash function include _all_ substructure, recursively?
    --
    -- Set to true (the default) if you want a truly unique fingerprint for
    -- the entire expression:
    --
    -- Example:
    --
    -- xs, ys :: Acc (Vector Float)
    -- xs = fill (constant (Z:.10)) 1.0
    -- ys = fill (constant (Z:.20)) 1.0
    --
    -- with perfect=True:
    --
    --   hash xs = 2e1f91aca4c476d13b36f22462e73c15bbdd9fcacb0d4996280f6004058e9732
    --   hash ys = 2fce5c849b6c652192b09aaeafdc8029e57b9f006c1ecd79ccf9114f349aaf9e
    --
    -- However, for a code generating backend the object code used to
    -- evaluate both of these expressions is likely to be identical.
    --
    -- Setting perfect=False results in:
    --
    --   hash xs = hash ys = f97944b0ec64ab8aa989fd60c8b50e7ec3eff759d22d2b340039d837d74dfc3c
    --
    -- Note that to be useful the provided 'EncodeAcc' function must also
    -- understand this option, and the consumer of the hash value must be
    -- agnostic to the elided details.
  }
  deriving Show

defaultHashOptions :: HashOptions
defaultHashOptions = HashOptions True


{-# INLINEABLE hashPreOpenAcc #-}
hashPreOpenAcc :: HasArraysR acc => EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash
hashPreOpenAcc = hashPreOpenAccWith defaultHashOptions

{-# INLINEABLE hashPreOpenAccWith #-}
hashPreOpenAccWith :: HasArraysR acc => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash
hashPreOpenAccWith options encodeAcc
  = hashlazy
  . toLazyByteString
  . encodePreOpenAcc options encodeAcc

{-# INLINEABLE hashOpenFun #-}
hashOpenFun :: OpenFun env aenv f -> Hash
hashOpenFun
  = hashlazy
  . toLazyByteString
  . encodeOpenFun

{-# INLINEABLE hashOpenExp #-}
hashOpenExp :: OpenExp env aenv t -> Hash
hashOpenExp
  = hashlazy
  . toLazyByteString
  . encodeOpenExp


-- Array computations
-- ------------------

type EncodeAcc acc = forall aenv a. HashOptions -> acc aenv a -> Builder

{-# INLINEABLE encodePreOpenAcc #-}
encodePreOpenAcc
    :: forall acc aenv arrs. HasArraysR acc
    => HashOptions
    -> EncodeAcc acc
    -> PreOpenAcc acc aenv arrs
    -> Builder
encodePreOpenAcc options encodeAcc pacc =
  let
      travA :: forall aenv' a. acc aenv' a -> Builder
      travA = encodeAcc options

      travAF :: PreOpenAfun acc aenv' f -> Builder
      travAF = encodePreOpenAfun options encodeAcc

      travE :: OpenExp env' aenv' e -> Builder
      travE = encodeOpenExp

      travF :: OpenFun env' aenv' f -> Builder
      travF = encodeOpenFun

      travD :: Direction -> Builder
      travD LeftToRight = intHost $(hashQ "L")
      travD RightToLeft = intHost $(hashQ "R")

      deep :: Builder -> Builder
      deep | perfect options = id
           | otherwise       = const mempty

      deepE :: forall env' aenv' e. OpenExp env' aenv' e -> Builder
      deepE e
        | perfect options = travE e
        | otherwise       = encodeTypeR $ expType e
  in
  case pacc of
    Alet lhs bnd body               -> intHost $(hashQ "Alet")        <> encodeLeftHandSide encodeArrayType lhs <> travA bnd <> travA body
    Avar (Var repr v)               -> intHost $(hashQ "Avar")        <> encodeArrayType repr <> deep (encodeIdx v)
    Apair a1 a2                     -> intHost $(hashQ "Apair")       <> travA a1 <> travA a2
    Anil                            -> intHost $(hashQ "Anil")
    Atrace (Message _ _ msg) as bs  -> intHost $(hashQ "Atrace")      <> intHost (Hashable.hash msg) <> travA as <> travA bs
    Apply _ f a                     -> intHost $(hashQ "Apply")       <> travAF f <> travA a
    Aforeign _ _ f a                -> intHost $(hashQ "Aforeign")    <> travAF f <> travA a
    Use repr a                      -> intHost $(hashQ "Use")         <> encodeArrayType repr <> deep (encodeArray a)
    Awhile p f a                    -> intHost $(hashQ "Awhile")      <> travAF f <> travAF p <> travA a
    Unit _ e                        -> intHost $(hashQ "Unit")        <> travE e
    Generate _ e f                  -> intHost $(hashQ "Generate")    <> deepE e <> travF f
    -- We don't need to encode the type of 'e' when perfect is False, as 'e' is an expression of type Bool.
    -- We thus use `deep (travE e)` instead of `deepE e`.
    Acond e a1 a2                   -> intHost $(hashQ "Acond")       <> deep (travE e) <> travA a1 <> travA a2
    Reshape _ sh a                  -> intHost $(hashQ "Reshape")     <> deepE sh <> travA a
    Backpermute _ sh f a            -> intHost $(hashQ "Backpermute") <> deepE sh <> travF f  <> travA a
    Transform _ sh f1 f2 a          -> intHost $(hashQ "Transform")   <> deepE sh <> travF f1 <> travF f2 <> travA a
    Replicate spec ix a             -> intHost $(hashQ "Replicate")   <> deepE ix <> travA a  <> encodeSliceIndex spec
    Slice spec a ix                 -> intHost $(hashQ "Slice")       <> deepE ix <> travA a  <> encodeSliceIndex spec
    Map _ f a                       -> intHost $(hashQ "Map")         <> travF f  <> travA a
    ZipWith _ f a1 a2               -> intHost $(hashQ "ZipWith")     <> travF f  <> travA a1 <> travA a2
    Fold f e a                      -> intHost $(hashQ "Fold")        <> travF f  <> encodeMaybe travE e  <> travA a
    FoldSeg _ f e a s               -> intHost $(hashQ "FoldSeg")     <> travF f  <> encodeMaybe travE e  <> travA a <> travA s
    Scan  d f e a                   -> intHost $(hashQ "Scan")        <> travD d  <> travF f  <> encodeMaybe travE e <> travA a
    Scan' d f e a                   -> intHost $(hashQ "Scan'")       <> travD d  <> travF f  <>             travE e <> travA a
    Permute f1 a1 f2 a2             -> intHost $(hashQ "Permute")     <> travF f1 <> travA a1 <> travF f2 <> travA a2
    Stencil s _ f b a               -> intHost $(hashQ "Stencil")     <> travF f  <> encodeBoundary (stencilEltR s) b   <> travA a
    Stencil2 s1 s2 _ f b1 a1 b2 a2  -> intHost $(hashQ "Stencil2")    <> travF f  <> encodeBoundary (stencilEltR s1) b1 <> travA a1 <> encodeBoundary (stencilEltR s2) b2 <> travA a2

{--
{-# INLINEABLE encodePreOpenSeq #-}
encodePreOpenSeq :: forall acc aenv senv arrs. EncodeAcc acc -> PreOpenSeq acc aenv senv arrs -> Int
encodePreOpenSeq encodeAcc s =
  let
      travA :: acc aenv' a -> Builder
      travA = encodeAcc -- XXX: plus type information?

      travE :: OpenExp env' aenv' e -> Builder
      travE = encodeOpenExp encodeAcc

      travAF :: PreOpenAfun acc aenv' f -> Builder
      travAF = encodePreOpenAfun encodeAcc

      travF :: OpenFun env' aenv' f -> Builder
      travF = encodeOpenFun encodeAcc

      travS :: PreOpenSeq acc aenv senv' arrs' -> Builder
      travS = encodePreOpenSeq encodeAcc

      travV :: forall a. Arrays a => Idx senv' a -> Builder
      travV v = encodeArraysType (arrays @a) <> encodeIdx v

      travP :: Producer acc aenv senv a -> Builder
      travP p =
        case p of
          StreamIn arrs       -> intHost . unsafePerformIO $! hashStableName `fmap` makeStableName arrs
          ToSeq spec _ acc    -> intHost $(hashQ "ToSeq")         <> travA  acc <> stringUtf8 (show spec)
          MapSeq f x          -> intHost $(hashQ "MapSeq")        <> travAF f   <> travV x
          ChunkedMapSeq f x   -> intHost $(hashQ "ChunkedMapSeq") <> travAF f   <> travV x
          ZipWithSeq f x y    -> intHost $(hashQ "ZipWithSeq")    <> travAF f   <> travV x <> travV y
          ScanSeq f e x       -> intHost $(hashQ "ScanSeq")       <> travF  f   <> travE e <> travV x

      travC :: Consumer acc aenv senv' a -> Builder
      travC c =
        case c of
          FoldSeq f e x          -> intHost $(hashQ "FoldSeq")        <> travF  f <> travE e   <> travV x
          FoldSeqFlatten f acc x -> intHost $(hashQ "FoldSeqFlatten") <> travAF f <> travA acc <> travV x
          Stuple t               -> intHost $(hashQ "Stuple")         <> encodeAtuple travC t
  in
  case s of
    Producer p s' -> intHost $(hashQ "Producer")   <> travP p <> travS s'
    Consumer c    -> intHost $(hashQ "Consumer")   <> travC c
    Reify ix      -> intHost $(hashQ "Reify")      <> travV ix
--}

encodeIdx :: Idx env t -> Builder
encodeIdx = intHost . idxToInt

encodeArray :: Array sh e -> Builder
encodeArray ad = intHost . unsafePerformIO $! hashStableName <$> makeStableName ad

encodeTupR :: (forall b. s b -> Builder) -> TupR s a -> Builder
encodeTupR _ TupRunit         = intHost $(hashQ "TupRunit")
encodeTupR f (TupRpair r1 r2) = intHost $(hashQ "TupRpair")   <> encodeTupR f r1 <> encodeTupR f r2
encodeTupR f (TupRsingle s)   = intHost $(hashQ "TupRsingle") <> f s

encodeLeftHandSide :: (forall b. s b -> Builder) -> LeftHandSide s a env env' -> Builder
encodeLeftHandSide f (LeftHandSideWildcard r) = intHost $(hashQ "LeftHandSideWildcard") <> encodeTupR f r
encodeLeftHandSide f (LeftHandSidePair r1 r2) = intHost $(hashQ "LeftHandSidePair")     <> encodeLeftHandSide f r1 <> encodeLeftHandSide f r2
encodeLeftHandSide f (LeftHandSideSingle s)   = intHost $(hashQ "LeftHandSideArray")    <> f s

encodeArrayType :: ArrayR a -> Builder
encodeArrayType (ArrayR shr tp) = encodeShapeR shr <> encodeTypeR tp

encodeArraysType :: ArraysR arrs -> Builder
encodeArraysType = encodeTupR encodeArrayType

encodeShapeR :: ShapeR sh -> Builder
encodeShapeR = intHost . rank

encodePreOpenAfun
    :: forall acc aenv f.
       HashOptions
    -> EncodeAcc acc
    -> PreOpenAfun acc aenv f
    -> Builder
encodePreOpenAfun options travA afun =
  let
      travL :: forall aenv1 aenv2 a b. ALeftHandSide a aenv1 aenv2 -> PreOpenAfun acc aenv2 b -> Builder
      travL lhs l = encodeLeftHandSide encodeArrayType lhs <> encodePreOpenAfun options travA l
  in
  case afun of
    Abody b    -> intHost $(hashQ "Abody") <> travA options b
    Alam lhs l -> intHost $(hashQ "Alam")  <> travL lhs  l


encodeBoundary
    :: TypeR e
    -> Boundary aenv (Array sh e)
    -> Builder
encodeBoundary _  Wrap          = intHost $(hashQ "Wrap")
encodeBoundary _  Clamp         = intHost $(hashQ "Clamp")
encodeBoundary _  Mirror        = intHost $(hashQ "Mirror")
encodeBoundary tp (Constant c)  = intHost $(hashQ "Constant") <> encodeConst tp c
encodeBoundary _  (Function f)  = intHost $(hashQ "Function") <> encodeOpenFun f

encodeSliceIndex :: SliceIndex slix sl co sh -> Builder
encodeSliceIndex SliceNil         = intHost $(hashQ "SliceNil")
encodeSliceIndex (SliceAll r)     = intHost $(hashQ "SliceAll")   <> encodeSliceIndex r
encodeSliceIndex (SliceFixed r)   = intHost $(hashQ "sliceFixed") <> encodeSliceIndex r


-- Scalar expressions
-- ------------------

{-# INLINEABLE encodeOpenExp #-}
encodeOpenExp
    :: forall env aenv exp.
       OpenExp env aenv exp
    -> Builder
encodeOpenExp exp =
  let
      travE :: forall env' aenv' e. OpenExp env' aenv' e -> Builder
      travE e = encodeOpenExp e

      travF :: OpenFun env' aenv' f -> Builder
      travF = encodeOpenFun
  in
  case exp of
    Let lhs bnd body            -> intHost $(hashQ "Let")         <> encodeLeftHandSide encodeScalarType lhs <> travE bnd <> travE body
    Evar (Var tp ix)            -> intHost $(hashQ "Evar")        <> encodeScalarType tp <> encodeIdx ix
    Nil                         -> intHost $(hashQ "Nil")
    Pair e1 e2                  -> intHost $(hashQ "Pair")        <> travE e1 <> travE e2
    VecPack   _ e               -> intHost $(hashQ "VecPack")     <> travE e
    VecUnpack _ e               -> intHost $(hashQ "VecUnpack")   <> travE e
    Const tp c                  -> intHost $(hashQ "Const")       <> encodeScalarConst tp c
    Undef tp                    -> intHost $(hashQ "Undef")       <> encodeScalarType tp
    IndexSlice spec ix sh       -> intHost $(hashQ "IndexSlice")  <> travE ix <> travE sh <> encodeSliceIndex spec
    IndexFull  spec ix sl       -> intHost $(hashQ "IndexFull")   <> travE ix <> travE sl <> encodeSliceIndex spec
    ToIndex _ sh i              -> intHost $(hashQ "ToIndex")     <> travE sh <> travE i
    FromIndex _ sh i            -> intHost $(hashQ "FromIndex")   <> travE sh <> travE i
    Case e rhs def              -> intHost $(hashQ "Case")        <> travE e  <> mconcat [ word8 t <> travE c | (t,c) <- rhs ] <> encodeMaybe travE def
    Cond c t e                  -> intHost $(hashQ "Cond")        <> travE c  <> travE t  <> travE e
    While p f x                 -> intHost $(hashQ "While")       <> travF p  <> travF f  <> travE x
    PrimApp f x                 -> intHost $(hashQ "PrimApp")     <> encodePrimFun f <> travE x
    PrimConst c                 -> intHost $(hashQ "PrimConst")   <> encodePrimConst c
    Index a ix                  -> intHost $(hashQ "Index")       <> encodeArrayVar a <> travE ix
    LinearIndex a ix            -> intHost $(hashQ "LinearIndex") <> encodeArrayVar a <> travE ix
    Shape a                     -> intHost $(hashQ "Shape")       <> encodeArrayVar a
    ShapeSize _ sh              -> intHost $(hashQ "ShapeSize")   <> travE sh
    Foreign _ _ f e             -> intHost $(hashQ "Foreign")     <> travF f  <> travE e
    Coerce _ tp e               -> intHost $(hashQ "Coerce")      <> encodeScalarType tp <> travE e

encodeArrayVar :: ArrayVar aenv a -> Builder
encodeArrayVar (Var repr v) = encodeArrayType repr <> encodeIdx v

{-# INLINEABLE encodeOpenFun #-}
encodeOpenFun
    :: OpenFun env aenv f
    -> Builder
encodeOpenFun (Body b)    = intHost $(hashQ "Body") <> encodeOpenExp b
encodeOpenFun (Lam lhs l) = intHost $(hashQ "Lam") <> encodeLeftHandSide encodeScalarType lhs <> encodeOpenFun l


encodeConst :: TypeR t -> t -> Builder
encodeConst TupRunit         ()    = intHost $(hashQ "nil")
encodeConst (TupRsingle t)   c     = encodeScalarConst t c
encodeConst (TupRpair ta tb) (a,b) = intHost $(hashQ "pair") <> encodeConst ta a <> encodeConst tb b

encodeScalarConst :: ScalarType t -> t -> Builder
encodeScalarConst (SingleScalarType t) = encodeSingleConst t
encodeScalarConst (VectorScalarType t) = encodeVectorConst t

encodeSingleConst :: SingleType t -> t -> Builder
encodeSingleConst (NumSingleType t) = encodeNumConst t

encodeVectorConst :: VectorType (Vec n t) -> Vec n t -> Builder
encodeVectorConst (VectorType n t) (Vec ba#) = intHost $(hashQ "Vec") <> intHost n <> encodeSingleType t <> shortByteString (SBS ba#)

encodeNumConst :: NumType t -> t -> Builder
encodeNumConst (IntegralNumType t) = encodeIntegralConst t
encodeNumConst (FloatingNumType t) = encodeFloatingConst t

encodeIntegralConst :: IntegralType t -> t -> Builder
encodeIntegralConst TypeInt{}    x = intHost $(hashQ "Int")    <> intHost x
encodeIntegralConst TypeInt8{}   x = intHost $(hashQ "Int8")   <> int8 x
encodeIntegralConst TypeInt16{}  x = intHost $(hashQ "Int16")  <> int16Host x
encodeIntegralConst TypeInt32{}  x = intHost $(hashQ "Int32")  <> int32Host x
encodeIntegralConst TypeInt64{}  x = intHost $(hashQ "Int64")  <> int64Host x
encodeIntegralConst TypeWord{}   x = intHost $(hashQ "Word")   <> wordHost x
encodeIntegralConst TypeWord8{}  x = intHost $(hashQ "Word8")  <> word8 x
encodeIntegralConst TypeWord16{} x = intHost $(hashQ "Word16") <> word16Host x
encodeIntegralConst TypeWord32{} x = intHost $(hashQ "Word32") <> word32Host x
encodeIntegralConst TypeWord64{} x = intHost $(hashQ "Word64") <> word64Host x

encodeFloatingConst :: FloatingType t -> t -> Builder
encodeFloatingConst TypeHalf{}    (Half (CUShort x)) = intHost $(hashQ "Half")    <> word16Host x
encodeFloatingConst TypeFloat{}   x                  = intHost $(hashQ "Float")   <> floatHost x
encodeFloatingConst TypeDouble{}  x                  = intHost $(hashQ "Double")  <> doubleHost x

encodePrimConst :: PrimConst c -> Builder
encodePrimConst (PrimMinBound t)  = intHost $(hashQ "PrimMinBound") <> encodeBoundedType t
encodePrimConst (PrimMaxBound t)  = intHost $(hashQ "PrimMaxBound") <> encodeBoundedType t
encodePrimConst (PrimPi t)        = intHost $(hashQ "PrimPi")       <> encodeFloatingType t
encodePrimConst (PrimVectorCreate t) = intHost $(hashQ "PrimVectorCreate") <> encodeVectorType t

encodePrimFun :: PrimFun f -> Builder
encodePrimFun (PrimAdd a)                = intHost $(hashQ "PrimAdd")                <> encodeNumType a
encodePrimFun (PrimSub a)                = intHost $(hashQ "PrimSub")                <> encodeNumType a
encodePrimFun (PrimMul a)                = intHost $(hashQ "PrimMul")                <> encodeNumType a
encodePrimFun (PrimNeg a)                = intHost $(hashQ "PrimNeg")                <> encodeNumType a
encodePrimFun (PrimAbs a)                = intHost $(hashQ "PrimAbs")                <> encodeNumType a
encodePrimFun (PrimSig a)                = intHost $(hashQ "PrimSig")                <> encodeNumType a
encodePrimFun (PrimQuot a)               = intHost $(hashQ "PrimQuot")               <> encodeIntegralType a
encodePrimFun (PrimRem a)                = intHost $(hashQ "PrimRem")                <> encodeIntegralType a
encodePrimFun (PrimQuotRem a)            = intHost $(hashQ "PrimQuotRem")            <> encodeIntegralType a
encodePrimFun (PrimIDiv a)               = intHost $(hashQ "PrimIDiv")               <> encodeIntegralType a
encodePrimFun (PrimMod a)                = intHost $(hashQ "PrimMod")                <> encodeIntegralType a
encodePrimFun (PrimDivMod a)             = intHost $(hashQ "PrimDivMod")             <> encodeIntegralType a
encodePrimFun (PrimBAnd a)               = intHost $(hashQ "PrimBAnd")               <> encodeIntegralType a
encodePrimFun (PrimBOr a)                = intHost $(hashQ "PrimBOr")                <> encodeIntegralType a
encodePrimFun (PrimBXor a)               = intHost $(hashQ "PrimBXor")               <> encodeIntegralType a
encodePrimFun (PrimBNot a)               = intHost $(hashQ "PrimBNot")               <> encodeIntegralType a
encodePrimFun (PrimBShiftL a)            = intHost $(hashQ "PrimBShiftL")            <> encodeIntegralType a
encodePrimFun (PrimBShiftR a)            = intHost $(hashQ "PrimBShiftR")            <> encodeIntegralType a
encodePrimFun (PrimBRotateL a)           = intHost $(hashQ "PrimBRotateL")           <> encodeIntegralType a
encodePrimFun (PrimBRotateR a)           = intHost $(hashQ "PrimBRotateR")           <> encodeIntegralType a
encodePrimFun (PrimPopCount a)           = intHost $(hashQ "PrimPopCount")           <> encodeIntegralType a
encodePrimFun (PrimCountLeadingZeros a)  = intHost $(hashQ "PrimCountLeadingZeros")  <> encodeIntegralType a
encodePrimFun (PrimCountTrailingZeros a) = intHost $(hashQ "PrimCountTrailingZeros") <> encodeIntegralType a
encodePrimFun (PrimFDiv a)               = intHost $(hashQ "PrimFDiv")               <> encodeFloatingType a
encodePrimFun (PrimRecip a)              = intHost $(hashQ "PrimRecip")              <> encodeFloatingType a
encodePrimFun (PrimSin a)                = intHost $(hashQ "PrimSin")                <> encodeFloatingType a
encodePrimFun (PrimCos a)                = intHost $(hashQ "PrimCos")                <> encodeFloatingType a
encodePrimFun (PrimTan a)                = intHost $(hashQ "PrimTan")                <> encodeFloatingType a
encodePrimFun (PrimAsin a)               = intHost $(hashQ "PrimAsin")               <> encodeFloatingType a
encodePrimFun (PrimAcos a)               = intHost $(hashQ "PrimAcos")               <> encodeFloatingType a
encodePrimFun (PrimAtan a)               = intHost $(hashQ "PrimAtan")               <> encodeFloatingType a
encodePrimFun (PrimSinh a)               = intHost $(hashQ "PrimSinh")               <> encodeFloatingType a
encodePrimFun (PrimCosh a)               = intHost $(hashQ "PrimCosh")               <> encodeFloatingType a
encodePrimFun (PrimTanh a)               = intHost $(hashQ "PrimTanh")               <> encodeFloatingType a
encodePrimFun (PrimAsinh a)              = intHost $(hashQ "PrimAsinh")              <> encodeFloatingType a
encodePrimFun (PrimAcosh a)              = intHost $(hashQ "PrimAcosh")              <> encodeFloatingType a
encodePrimFun (PrimAtanh a)              = intHost $(hashQ "PrimAtanh")              <> encodeFloatingType a
encodePrimFun (PrimExpFloating a)        = intHost $(hashQ "PrimExpFloating")        <> encodeFloatingType a
encodePrimFun (PrimSqrt a)               = intHost $(hashQ "PrimSqrt")               <> encodeFloatingType a
encodePrimFun (PrimLog a)                = intHost $(hashQ "PrimLog")                <> encodeFloatingType a
encodePrimFun (PrimFPow a)               = intHost $(hashQ "PrimFPow")               <> encodeFloatingType a
encodePrimFun (PrimLogBase a)            = intHost $(hashQ "PrimLogBase")            <> encodeFloatingType a
encodePrimFun (PrimAtan2 a)              = intHost $(hashQ "PrimAtan2")              <> encodeFloatingType a
encodePrimFun (PrimTruncate a b)         = intHost $(hashQ "PrimTruncate")           <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimRound a b)            = intHost $(hashQ "PrimRound")              <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimFloor a b)            = intHost $(hashQ "PrimFloor")              <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimCeiling a b)          = intHost $(hashQ "PrimCeiling")            <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimIsNaN a)              = intHost $(hashQ "PrimIsNaN")              <> encodeFloatingType a
encodePrimFun (PrimIsInfinite a)         = intHost $(hashQ "PrimIsInfinite")         <> encodeFloatingType a
encodePrimFun (PrimLt a)                 = intHost $(hashQ "PrimLt")                 <> encodeSingleType a
encodePrimFun (PrimGt a)                 = intHost $(hashQ "PrimGt")                 <> encodeSingleType a
encodePrimFun (PrimLtEq a)               = intHost $(hashQ "PrimLtEq")               <> encodeSingleType a
encodePrimFun (PrimGtEq a)               = intHost $(hashQ "PrimGtEq")               <> encodeSingleType a
encodePrimFun (PrimEq a)                 = intHost $(hashQ "PrimEq")                 <> encodeSingleType a
encodePrimFun (PrimNEq a)                = intHost $(hashQ "PrimNEq")                <> encodeSingleType a
encodePrimFun (PrimMax a)                = intHost $(hashQ "PrimMax")                <> encodeSingleType a
encodePrimFun (PrimMin a)                = intHost $(hashQ "PrimMin")                <> encodeSingleType a
encodePrimFun (PrimVectorIndex (VectorType _ a) b) = intHost $(hashQ "PrimVectorIndex") <> encodeSingleType a <> encodeNumType (IntegralNumType b)
encodePrimFun (PrimVectorWrite (VectorType _ a) b) = intHost $(hashQ "PrimVectorWrite") <> encodeSingleType a <> encodeNumType (IntegralNumType b)
encodePrimFun (PrimFromIntegral a b)     = intHost $(hashQ "PrimFromIntegral")       <> encodeIntegralType a <> encodeNumType b
encodePrimFun (PrimToFloating a b)       = intHost $(hashQ "PrimToFloating")         <> encodeNumType a      <> encodeFloatingType b
encodePrimFun PrimLAnd                   = intHost $(hashQ "PrimLAnd")
encodePrimFun PrimLOr                    = intHost $(hashQ "PrimLOr")
encodePrimFun PrimLNot                   = intHost $(hashQ "PrimLNot")


encodeTypeR :: TypeR t -> Builder
encodeTypeR TupRunit       = intHost $(hashQ "TupRunit")
encodeTypeR (TupRsingle t) = intHost $(hashQ "TupRsingle") <> encodeScalarType t
encodeTypeR (TupRpair a b) = intHost $(hashQ "TupRpair")   <> encodeTypeR a <> intHost (depthTypeR a)
                                                           <> encodeTypeR b <> intHost (depthTypeR b)

depthTypeR :: TypeR t -> Int
depthTypeR TupRunit       = 0
depthTypeR TupRsingle{}   = 1
depthTypeR (TupRpair a b) = depthTypeR a + depthTypeR b

encodeScalarType :: ScalarType t -> Builder
encodeScalarType (SingleScalarType t) = intHost $(hashQ "SingleScalarType") <> encodeSingleType t
encodeScalarType (VectorScalarType t) = intHost $(hashQ "VectorScalarType") <> encodeVectorType t

encodeSingleType :: SingleType t -> Builder
encodeSingleType (NumSingleType t) = intHost $(hashQ "NumSingleType")    <> encodeNumType t

encodeVectorType :: VectorType (Vec n t) -> Builder
encodeVectorType (VectorType n t) = intHost $(hashQ "VectorType") <> intHost n <> encodeSingleType t

encodeBoundedType :: BoundedType t -> Builder
encodeBoundedType (IntegralBoundedType t) = intHost $(hashQ "IntegralBoundedType") <> encodeIntegralType t

encodeNumType :: NumType t -> Builder
encodeNumType (IntegralNumType t) = intHost $(hashQ "IntegralNumType") <> encodeIntegralType t
encodeNumType (FloatingNumType t) = intHost $(hashQ "FloatingNumType") <> encodeFloatingType t

encodeIntegralType :: IntegralType t -> Builder
encodeIntegralType TypeInt{}    = intHost $(hashQ "Int")
encodeIntegralType TypeInt8{}   = intHost $(hashQ "Int8")
encodeIntegralType TypeInt16{}  = intHost $(hashQ "Int16")
encodeIntegralType TypeInt32{}  = intHost $(hashQ "Int32")
encodeIntegralType TypeInt64{}  = intHost $(hashQ "Int64")
encodeIntegralType TypeWord{}   = intHost $(hashQ "Word")
encodeIntegralType TypeWord8{}  = intHost $(hashQ "Word8")
encodeIntegralType TypeWord16{} = intHost $(hashQ "Word16")
encodeIntegralType TypeWord32{} = intHost $(hashQ "Word32")
encodeIntegralType TypeWord64{} = intHost $(hashQ "Word64")

encodeFloatingType :: FloatingType t -> Builder
encodeFloatingType TypeHalf{}   = intHost $(hashQ "Half")
encodeFloatingType TypeFloat{}  = intHost $(hashQ "Float")
encodeFloatingType TypeDouble{} = intHost $(hashQ "Double")

encodeMaybe :: (a -> Builder) -> Maybe a -> Builder
encodeMaybe _ Nothing  = intHost $(hashQ "Nothing")
encodeMaybe f (Just x) = intHost $(hashQ "Just") <> f x