Converted Comm to abstract datatype

Converted Comm to abstract datatype

{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

#include <mpi.h>
#include "init_wrapper.h"
#include "comparison_result.h"
#include "error_classes.h"
#include "thread_support.h"
-----------------------------------------------------------------------------
{- |
Module      : Control.Parallel.MPI.Internal
Copyright   : (c) 2010 Bernie Pope, Dmitry Astapov
License     : BSD-style
Maintainer  : florbitous@gmail.com
Stability   : experimental
Portability : ghc

This module contains low-level Haskell bindings to core MPI functions.
All Haskell functions correspond to MPI functions with the similar
name (i.e. @commRank@ is the binding for @MPI_Comm_rank@)

Actual types of all functions defined here depend on the MPI
implementation.

Since "Control.Parallel.MPI.Storable" and
"Control.Parallel.MPI.Serializable" contains many functions of the
same name as defined here, users would want to import this module
qualified.
-}
-----------------------------------------------------------------------------
module Control.Parallel.MPI.Internal
   ( maxProcessorName,
     maxErrorString,
     init, initThread, queryThread, isThreadMain, initialized, finalized,
     finalize, getProcessorName, getVersion,
     send, bsend, ssend, rsend, recv,
     commRank, probe, commSize, commTestInter, commRemoteSize,
     commCompare,
     isend, ibsend, issend, irecv, bcast, barrier, wait, waitall, test,
     cancel, scatter, gather,
     scatterv, gatherv,
     allgather, allgatherv,
     alltoall, alltoallv,
     reduce, allreduce, reduceScatter,
     opCreate, opFree,
     wtime, wtick,
     commGroup, groupRank, groupSize, groupUnion, groupIntersection, groupDifference,
     groupCompare, groupExcl, groupIncl, groupTranslateRanks,
     typeSize,
     errorClass, errorString, commSetErrhandler, commGetErrhandler,
     abort,
     Comm(), commWorld, commSelf,
     ComparisonResult (..),
     Datatype, char, wchar, short, int, long, longLong, unsignedChar,
     unsignedShort, unsigned, unsignedLong, unsignedLongLong, float, double,
     longDouble, byte, packed,
     Errhandler, errorsAreFatal, errorsReturn,
     ErrorClass (..),
     Group(MkGroup), groupEmpty,
     Operation, maxOp, minOp, sumOp, prodOp, landOp, bandOp, lorOp,
     borOp, lxorOp, bxorOp,
     Rank, rankId, toRank, fromRank, anySource, theRoot, procNull,
     Request,
     Status (..), StatusPtr,
     Tag, toTag, fromTag, tagVal, anyTag,
     ThreadSupport (..)
   ) where

import Prelude hiding (init)
import C2HS
import Data.Typeable
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

{-
This module provides Haskell enum that comprises of MPI constants
@MPI_IDENT@, @MPI_CONGRUENT@, @MPI_SIMILAR@ and @MPI_UNEQUAL@.

Those are used to compare communicators (f.e. 'commCompare') and
process groups (f.e. 'groupCompare').
-}
{# enum ComparisonResult {underscoreToCase} deriving (Eq,Ord,Show) #}

-- | Which Haskell type will be used as @Comm@ depends on the MPI
-- implementation that was selected during compilation. It could be
-- @CInt@, @Ptr ()@, @Ptr CInt@ or something else.
type MPIComm = {# type MPI_Comm #}
newtype Comm = MkComm { fromComm :: MPIComm }
foreign import ccall "&mpi_comm_world" commWorld_ :: Ptr MPIComm
foreign import ccall "&mpi_comm_self" commSelf_ :: Ptr MPIComm

-- | Predefined handle for communicator that includes all running
-- processes. Similar to @MPI_Comm_world@
commWorld :: Comm
commWorld = MkComm <$> unsafePerformIO $ peek commWorld_

-- | Predefined handle for communicator that includes only current
-- process. Similar to @MPI_Comm_self@
commSelf :: Comm
commSelf = MkComm <$> unsafePerformIO $ peek commSelf_

foreign import ccall "&mpi_max_processor_name" max_processor_name_ :: Ptr CInt
foreign import ccall "&mpi_max_error_string" max_error_string_ :: Ptr CInt
maxProcessorName :: CInt
maxProcessorName = unsafePerformIO $ peek max_processor_name_
maxErrorString :: CInt
maxErrorString = unsafePerformIO $ peek max_error_string_

init = {# call unsafe init_wrapper as init_wrapper_ #}
initialized = {# call unsafe Initialized as initialized_ #}
finalized = {# call unsafe Finalized as finalized_ #}
initThread = {# call unsafe init_wrapper_thread as init_wrapper_thread_ #}
queryThread = {# call unsafe Query_thread as queryThread_ #}
isThreadMain = {# call unsafe Is_thread_main as isThreadMain_ #}
finalize = {# call unsafe Finalize as finalize_ #}
getProcessorName = {# call unsafe Get_processor_name as getProcessorName_ #}
getVersion = {# call unsafe Get_version as getVersion_ #}
commSize = {# call unsafe Comm_size as commSize_ #} <$> fromComm
commRank = {# call unsafe Comm_rank as commRank_ #} <$> fromComm
commTestInter = {# call unsafe Comm_test_inter as commTestInter_ #} <$> fromComm
commRemoteSize = {# call unsafe Comm_remote_size as commRemoteSize_ #} <$> fromComm
commCompare c1 c2 = {# call unsafe Comm_compare as commCompare_ #} (fromComm c1) (fromComm c2)
probe s t c = {# call Probe as probe_ #} s t (fromComm c)
send b cnt d r t c = {# call unsafe Send as send_ #} b cnt d r t (fromComm c)
bsend b cnt d r t c = {# call unsafe Bsend as bsend_ #} b cnt d r t (fromComm c)
ssend b cnt d r t c = {# call unsafe Ssend as ssend_ #} b cnt d r t (fromComm c)
rsend b cnt d r t c = {# call unsafe Rsend as rsend_ #} b cnt d r t (fromComm c)
recv b cnt d r t c = {# call unsafe Recv as recv_ #} b cnt d r t (fromComm c)
isend b cnt d r t c = {# call unsafe Isend as isend_ #} b cnt d r t (fromComm c)
ibsend b cnt d r t c = {# call unsafe Ibsend as ibsend_ #} b cnt d r t (fromComm c)
issend b cnt d r t c = {# call unsafe Issend as issend_ #} b cnt d r t (fromComm c)
irecv b cnt d r t c = {# call Irecv as irecv_ #} b cnt d r t (fromComm c)
bcast b cnt d r c = {# call unsafe Bcast as bcast_ #} b cnt d r (fromComm c)
barrier = {# call unsafe Barrier as barrier_ #} <$> fromComm
wait = {# call unsafe Wait as wait_ #}
waitall = {# call unsafe Waitall as waitall_ #}
test = {# call unsafe Test as test_ #}
cancel = {# call unsafe Cancel as cancel_ #}
scatter sb se st rb re rt r c = {# call unsafe Scatter as scatter_ #} sb se st rb re rt r (fromComm c)
gather sb se st rb re rt r c = {# call unsafe Gather as gather_ #} sb se st rb re rt r (fromComm c)
scatterv sb sc sd st rb re rt r c = {# call unsafe Scatterv as scatterv_ #} sb sc sd st rb re rt r (fromComm c)
gatherv sb se st rb rc rd rt r c = {# call unsafe Gatherv as gatherv_ #} sb se st rb rc rd rt r (fromComm c)
allgather sb se st rb re rt c = {# call unsafe Allgather as allgather_ #} sb se st rb re rt (fromComm c)
allgatherv sb se st rb rc rd rt c = {# call unsafe Allgatherv as allgatherv_ #} sb se st rb rc rd rt (fromComm c)
alltoall sb sc st rb rc rt c = {# call unsafe Alltoall as alltoall_ #} sb sc st rb rc rt (fromComm c)
alltoallv sb sc sd st rb rc rd rt c = {# call unsafe Alltoallv as alltoallv_ #} sb sc sd st rb rc rd rt (fromComm c)
-- Reduce, allreduce and reduceScatter could call back to Haskell
-- via user-defined ops, so they should be imported in "safe" mode
reduce sb rb se st o r c  = {# call Reduce as reduce_ #} sb rb se st o r (fromComm c)
allreduce sb rb se st o c = {# call Allreduce as allreduce_ #} sb rb se st o (fromComm c)
reduceScatter sb rb cnt t o c = {# call Reduce_scatter as reduceScatter_ #} sb rb cnt t o (fromComm c)
opCreate = {# call unsafe Op_create as opCreate_ #}
opFree = {# call unsafe Op_free as opFree_ #}
wtime = {# call unsafe Wtime as wtime_ #}
wtick = {# call unsafe Wtick as wtick_ #}
commGroup = {# call unsafe Comm_group as commGroup_ #} <$> fromComm
groupRank = {# call unsafe Group_rank as groupRank_ #} <$> fromGroup
groupSize = {# call unsafe Group_size as groupSize_ #} <$> fromGroup
groupUnion g1 g2 = {# call unsafe Group_union as groupUnion_ #} (fromGroup g1) (fromGroup g2)
groupIntersection g1 g2 = {# call unsafe Group_intersection as groupIntersection_ #} (fromGroup g1) (fromGroup g2)
groupDifference g1 g2 = {# call unsafe Group_difference as groupDifference_ #} (fromGroup g1) (fromGroup g2)
groupCompare g1 g2 = {# call unsafe Group_compare as groupCompare_ #} (fromGroup g1) (fromGroup g2)
groupExcl g = {# call unsafe Group_excl as groupExcl_ #} (fromGroup g)
groupIncl g = {# call unsafe Group_incl as groupIncl_ #} (fromGroup g)
groupTranslateRanks g1 s r g2 = {# call unsafe Group_translate_ranks as groupTranslateRanks_ #} (fromGroup g1) s r (fromGroup g2)
typeSize = {# call unsafe Type_size as typeSize_ #}
errorClass = {# call unsafe Error_class as errorClass_ #}
errorString = {# call unsafe Error_string as errorString_ #}
commSetErrhandler = {# call unsafe Comm_set_errhandler as commSetErrhandler_ #} <$> fromComm
commGetErrhandler = {# call unsafe Comm_get_errhandler as commGetErrhandler_ #} <$> fromComm
abort = {# call unsafe Abort as abort_ #} <$> fromComm

type Datatype = {# type MPI_Datatype #}

foreign import ccall unsafe "&mpi_char" char_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_wchar" wchar_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_short" short_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_int" int_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_long" long_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_long_long" longLong_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_char" unsignedChar_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_short" unsignedShort_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned" unsigned_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_long" unsignedLong_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_long_long" unsignedLongLong_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_float" float_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_double" double_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_long_double" longDouble_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_byte" byte_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_packed" packed_ :: Ptr Datatype

char, wchar, short, int, long, longLong, unsignedChar, unsignedShort :: Datatype
unsigned, unsignedLong, unsignedLongLong, float, double, longDouble :: Datatype
byte, packed :: Datatype

char = unsafePerformIO $ peek char_
wchar = unsafePerformIO $ peek wchar_
short = unsafePerformIO $ peek short_
int = unsafePerformIO $ peek int_
long = unsafePerformIO $ peek long_
longLong = unsafePerformIO $ peek longLong_
unsignedChar = unsafePerformIO $ peek unsignedChar_
unsignedShort = unsafePerformIO $ peek unsignedShort_
unsigned = unsafePerformIO $ peek unsigned_
unsignedLong = unsafePerformIO $ peek unsignedLong_
unsignedLongLong = unsafePerformIO $ peek unsignedLongLong_
float = unsafePerformIO $ peek float_
double = unsafePerformIO $ peek double_
longDouble = unsafePerformIO $ peek longDouble_
byte = unsafePerformIO $ peek byte_
packed = unsafePerformIO $ peek packed_

type Errhandler = {# type MPI_Errhandler #}
foreign import ccall "&mpi_errors_are_fatal" errorsAreFatal_ :: Ptr Errhandler
foreign import ccall "&mpi_errors_return" errorsReturn_ :: Ptr Errhandler
errorsAreFatal, errorsReturn :: Errhandler
errorsAreFatal = unsafePerformIO $ peek errorsAreFatal_
errorsReturn = unsafePerformIO $ peek errorsReturn_

{# enum ErrorClass {underscoreToCase} deriving (Eq,Ord,Show,Typeable) #}

-- XXX Should this be a ForeinPtr?
-- there is a MPI_Group_free function, which we should probably
-- call when the group is no longer referenced.

-- | Actual Haskell type used depends on the MPI implementation.
type MPIGroup = {# type MPI_Group #}

newtype Group = MkGroup { fromGroup :: MPIGroup }

foreign import ccall "&mpi_group_empty" groupEmpty_ :: Ptr MPIGroup
-- | Predefined handle for group without any members. Corresponds to @MPI_GROUP_EMPTY@
groupEmpty :: Group
groupEmpty = MkGroup <$> unsafePerformIO $ peek groupEmpty_

{-
This module provides Haskell type that represents values of @MPI_Op@
type (reduction operations), and predefined reduction operations
defined in the MPI Report.
-}

-- | Actual Haskell type used depends on the MPI implementation.
type Operation = {# type MPI_Op #}

foreign import ccall unsafe "&mpi_max" maxOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_min" minOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_sum" sumOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_prod" prodOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_land" landOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_band" bandOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_lor" lorOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_bor" borOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_lxor" lxorOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_bxor" bxorOp_ :: Ptr Operation
-- foreign import ccall "mpi_maxloc" maxlocOp :: Operation
-- foreign import ccall "mpi_minloc" minlocOp :: Operation
-- foreign import ccall "mpi_replace" replaceOp :: Operation
-- TODO: support for those requires better support for pair datatypes

maxOp, minOp, sumOp, prodOp, landOp, bandOp, lorOp, borOp, lxorOp, bxorOp :: Operation
maxOp = unsafePerformIO $ peek maxOp_
minOp = unsafePerformIO $ peek minOp_
sumOp = unsafePerformIO $ peek sumOp_
prodOp = unsafePerformIO $ peek prodOp_
landOp = unsafePerformIO $ peek landOp_
bandOp = unsafePerformIO $ peek bandOp_
lorOp = unsafePerformIO $ peek lorOp_
borOp = unsafePerformIO $ peek borOp_
lxorOp = unsafePerformIO $ peek lxorOp_
bxorOp = unsafePerformIO $ peek bxorOp_

{-
This module provides Haskell datatype that represents values which
could be used as MPI rank designations.
-}

-- TODO: actually, this should be 32-bit int
newtype Rank = MkRank { rankId :: Int }
   deriving (Eq, Ord, Enum, Num, Integral, Real)

foreign import ccall "mpi_any_source" anySource_ :: Ptr Int
foreign import ccall "mpi_root" theRoot_ :: Ptr Int
foreign import ccall "mpi_proc_null" procNull_ :: Ptr Int

-- | Predefined rank number that allows reception of point-to-point messages
-- regardless of their source. Corresponds to @MPI_ANY_SOURCE@
anySource :: Rank
anySource = toRank $ unsafePerformIO $ peek anySource_

-- | Predefined rank number that specifies root process during
-- operations involving intercommunicators. Corresponds to @MPI_ROOT@
theRoot :: Rank
theRoot = toRank $ unsafePerformIO $ peek theRoot_

-- | Predefined rank number that specifies non-root processes during
-- operations involving intercommunicators. Corresponds to @MPI_PROC_NULL@
procNull :: Rank
procNull  = toRank $ unsafePerformIO $ peek procNull_

instance Show Rank where
   show = show . rankId

toRank :: Enum a => a -> Rank
toRank x = MkRank { rankId = fromEnum x }

fromRank :: Enum a => Rank -> a
fromRank = toEnum . rankId

{- This module provides Haskell representation of the @MPI_Request@ type. -}
type Request = {# type MPI_Request #}

{-
This module provides Haskell representation of the @MPI_Status@ type
(request status).

Field `status_error' should be used with care:
\"The error field in status is not needed for calls that return only
one status, such as @MPI_WAIT@, since that would only duplicate the
information returned by the function itself. The current design avoids
the additional overhead of setting it, in such cases. The field is
needed for calls that return multiple statuses, since each request may
have had a different failure.\"
(this is a quote from <http://mpi-forum.org/docs/mpi22-report/node47.htm#Node47>)

This means that, for example, during the call to @MPI_Wait@
implementation is free to leave this field filled with whatever
garbage got there during memory allocation. Haskell FFI is not
blanking out freshly allocated memory, so beware!
-}

-- | Haskell structure that holds fields of @MPI_Status@.
--
-- Please note that MPI report lists only three fields as mandatory:
-- @status_source@, @status_tag@ and @status_error@. However, all
-- MPI implementations that were used to test those bindings supported
-- extended set of fields represented here.
data Status =
   Status
   { status_source :: CInt -- ^ rank of the source process
   , status_tag :: CInt -- ^ tag assigned at source
   , status_error :: CInt -- ^ error code, if any
   , status_count :: CInt -- ^ number of received elements, if applicable
   , status_cancelled :: CInt -- ^ whether the request was cancelled
   }
   deriving (Eq, Ord, Show)

{#pointer *Status as StatusPtr -> Status #}

instance Storable Status where
  sizeOf _ = {#sizeof MPI_Status #}
  alignment _ = 4
  peek p = Status
    <$> liftM cIntConv ({#get MPI_Status->MPI_SOURCE #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_TAG #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p)
#ifdef MPICH2
    -- MPICH2 and OpenMPI use different names for the status struct
    -- fields-
    <*> liftM cIntConv ({#get MPI_Status->count #} p)
    <*> liftM cIntConv ({#get MPI_Status->cancelled #} p)
#else
    <*> liftM cIntConv ({#get MPI_Status->_count #} p)
    <*> liftM cIntConv ({#get MPI_Status->_cancelled #} p)
#endif
  poke p x = do
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_TAG #} p (cIntConv $ status_tag x)
    {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x)
#ifdef MPICH2
    -- MPICH2 and OpenMPI use different names for the status struct
    -- fields AND different order of fields
    {#set MPI_Status.count #} p (cIntConv $ status_count x)
    {#set MPI_Status.cancelled #} p (cIntConv $ status_cancelled x)
#else
    {#set MPI_Status._count #} p (cIntConv $ status_count x)
    {#set MPI_Status._cancelled #} p (cIntConv $ status_cancelled x)
#endif

{-
This module provides Haskell datatype that represents values which
could be used as MPI tags.
-}

-- TODO: actually, this is a 32-bit int, and even less than that.
-- See section 8 of MPI report about extracting MPI_TAG_UB
-- and using it here
newtype Tag = MkTag { tagVal :: Int }
   deriving (Eq, Ord, Enum, Num, Integral, Real)

instance Show Tag where
  show = show . tagVal

toTag :: Enum a => a -> Tag
toTag x = MkTag { tagVal = fromEnum x }

fromTag :: Enum a => Tag -> a
fromTag = toEnum . tagVal

foreign import ccall unsafe "&mpi_any_tag" anyTag_ :: Ptr Int

-- | Predefined tag value that allows reception of the messages with
--   arbitrary tag values. Corresponds to @MPI_ANY_TAG@.
anyTag :: Tag
anyTag = toTag $ unsafePerformIO $ peek anyTag_

{-
This module provides Haskell datatypes that comprises of values of
predefined MPI constants @MPI_THREAD_SINGLE@, @MPI_THREAD_FUNNELED@,
@MPI_THREAD_SERIALIZED@, @MPI_THREAD_MULTIPLE@.
-}

{# enum ThreadSupport {underscoreToCase} deriving (Eq,Ord,Show) #}

{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

#include <mpi.h>
#include "init_wrapper.h"
#include "comparison_result.h"
#include "error_classes.h"
#include "thread_support.h"
-----------------------------------------------------------------------------
{- |
Module      : Control.Parallel.MPI.Internal
Copyright   : (c) 2010 Bernie Pope, Dmitry Astapov
License     : BSD-style
Maintainer  : florbitous@gmail.com
Stability   : experimental
Portability : ghc

This module contains low-level Haskell bindings to core MPI functions.
All Haskell functions correspond to MPI functions with the similar
name (i.e. @commRank@ is the binding for @MPI_Comm_rank@)

Actual types of all functions defined here depend on the MPI
implementation.

Since "Control.Parallel.MPI.Storable" and
"Control.Parallel.MPI.Serializable" contains many functions of the
same name as defined here, users would want to import this module
qualified.
-}
-----------------------------------------------------------------------------
module Control.Parallel.MPI.Internal
   ( maxProcessorName,
     maxErrorString,
     init, initThread, queryThread, isThreadMain, initialized, finalized,
     finalize, getProcessorName, getVersion,
     send, bsend, ssend, rsend, recv,
     commRank, probe, commSize, commTestInter, commRemoteSize,
     commCompare,
     isend, ibsend, issend, irecv, bcast, barrier, wait, waitall, test,
     cancel, scatter, gather,
     scatterv, gatherv,
     allgather, allgatherv,
     alltoall, alltoallv,
     reduce, allreduce, reduceScatter,
     opCreate, opFree,
     wtime, wtick,
     commGroup, groupRank, groupSize, groupUnion, groupIntersection, groupDifference,
     groupCompare, groupExcl, groupIncl, groupTranslateRanks,
     typeSize,
     errorClass, errorString, commSetErrhandler, commGetErrhandler,
     abort,
     Comm, commWorld, commSelf,
     ComparisonResult (..),
     Datatype, char, wchar, short, int, long, longLong, unsignedChar,
     unsignedShort, unsigned, unsignedLong, unsignedLongLong, float, double,
     longDouble, byte, packed,
     Errhandler, errorsAreFatal, errorsReturn,
     ErrorClass (..),
     Group(MkGroup), groupEmpty,
     Operation, maxOp, minOp, sumOp, prodOp, landOp, bandOp, lorOp,
     borOp, lxorOp, bxorOp,
     Rank, rankId, toRank, fromRank, anySource, theRoot, procNull,
     Request,
     Status (..), StatusPtr,
     Tag, toTag, fromTag, tagVal, anyTag,
     ThreadSupport (..)
   ) where

import Prelude hiding (init)
import C2HS
import Data.Typeable
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

{-
This module provides Haskell enum that comprises of MPI constants
@MPI_IDENT@, @MPI_CONGRUENT@, @MPI_SIMILAR@ and @MPI_UNEQUAL@.

Those are used to compare communicators (f.e. 'commCompare') and
process groups (f.e. 'groupCompare').
-}
{# enum ComparisonResult {underscoreToCase} deriving (Eq,Ord,Show) #}

-- | Which Haskell type will be used as @Comm@ depends on the MPI
-- implementation that was selected during compilation. It could be
-- @CInt@, @Ptr ()@, @Ptr CInt@ or something else.
type Comm = {# type MPI_Comm #}
foreign import ccall "&mpi_comm_world" commWorld_ :: Ptr Comm
foreign import ccall "&mpi_comm_self" commSelf_ :: Ptr Comm

-- | Predefined handle for communicator that includes all running
-- processes. Similar to @MPI_Comm_world@
commWorld :: Comm
commWorld = unsafePerformIO $ peek commWorld_

-- | Predefined handle for communicator that includes only current
-- process. Similar to @MPI_Comm_self@
commSelf :: Comm
commSelf = unsafePerformIO $ peek commSelf_

foreign import ccall "&mpi_max_processor_name" max_processor_name_ :: Ptr CInt
foreign import ccall "&mpi_max_error_string" max_error_string_ :: Ptr CInt
maxProcessorName :: CInt
maxProcessorName = unsafePerformIO $ peek max_processor_name_
maxErrorString :: CInt
maxErrorString = unsafePerformIO $ peek max_error_string_

init = {# call unsafe init_wrapper as init_wrapper_ #}
initialized = {# call unsafe Initialized as initialized_ #}
finalized = {# call unsafe Finalized as finalized_ #}
initThread = {# call unsafe init_wrapper_thread as init_wrapper_thread_ #}
queryThread = {# call unsafe Query_thread as queryThread_ #}
isThreadMain = {# call unsafe Is_thread_main as isThreadMain_ #}
finalize = {# call unsafe Finalize as finalize_ #}
getProcessorName = {# call unsafe Get_processor_name as getProcessorName_ #}
getVersion = {# call unsafe Get_version as getVersion_ #}
commSize = {# call unsafe Comm_size as commSize_ #}
commRank = {# call unsafe Comm_rank as commRank_ #}
commTestInter = {# call unsafe Comm_test_inter as commTestInter_ #}
commRemoteSize = {# call unsafe Comm_remote_size as commRemoteSize_ #}
commCompare = {# call unsafe Comm_compare as commCompare_ #}
probe = {# call Probe as probe_ #}
send = {# call unsafe Send as send_ #}
bsend = {# call unsafe Bsend as bsend_ #}
ssend = {# call unsafe Ssend as ssend_ #}
rsend = {# call unsafe Rsend as rsend_ #}
recv = {# call unsafe Recv as recv_ #}
isend = {# call unsafe Isend as isend_ #}
ibsend = {# call unsafe Ibsend as ibsend_ #}
issend = {# call unsafe Issend as issend_ #}
irecv = {# call Irecv as irecv_ #}
bcast = {# call unsafe Bcast as bcast_ #}
barrier = {# call unsafe Barrier as barrier_ #}
wait = {# call unsafe Wait as wait_ #}
waitall = {# call unsafe Waitall as waitall_ #}
test = {# call unsafe Test as test_ #}
cancel = {# call unsafe Cancel as cancel_ #}
scatter = {# call unsafe Scatter as scatter_ #}
gather = {# call unsafe Gather as gather_ #}
scatterv = {# call unsafe Scatterv as scatterv_ #}
gatherv = {# call unsafe Gatherv as gatherv_ #}
allgather = {# call unsafe Allgather as allgather_ #}
allgatherv = {# call unsafe Allgatherv as allgatherv_ #}
alltoall = {# call unsafe Alltoall as alltoall_ #}
alltoallv = {# call unsafe Alltoallv as alltoallv_ #}
-- Reduce, allreduce and reduceScatter could call back to Haskell
-- via user-defined ops, so they should be imported in "safe" mode
reduce = {# call Reduce as reduce_ #}
allreduce = {# call Allreduce as allreduce_ #}
reduceScatter = {# call Reduce_scatter as reduceScatter_ #}
opCreate = {# call unsafe Op_create as opCreate_ #}
opFree = {# call unsafe Op_free as opFree_ #}
wtime = {# call unsafe Wtime as wtime_ #}
wtick = {# call unsafe Wtick as wtick_ #}
commGroup = {# call unsafe Comm_group as commGroup_ #}
groupRank = {# call unsafe Group_rank as groupRank_ #} <$> fromGroup
groupSize = {# call unsafe Group_size as groupSize_ #} <$> fromGroup
groupUnion g1 g2 = {# call unsafe Group_union as groupUnion_ #} (fromGroup g1) (fromGroup g2)
groupIntersection g1 g2 = {# call unsafe Group_intersection as groupIntersection_ #} (fromGroup g1) (fromGroup g2)
groupDifference g1 g2 = {# call unsafe Group_difference as groupDifference_ #} (fromGroup g1) (fromGroup g2)
groupCompare g1 g2 = {# call unsafe Group_compare as groupCompare_ #} (fromGroup g1) (fromGroup g2)
groupExcl g = {# call unsafe Group_excl as groupExcl_ #} (fromGroup g)
groupIncl g = {# call unsafe Group_incl as groupIncl_ #} (fromGroup g)
groupTranslateRanks g1 s r g2 = {# call unsafe Group_translate_ranks as groupTranslateRanks_ #} (fromGroup g1) s r (fromGroup g2)
typeSize = {# call unsafe Type_size as typeSize_ #}
errorClass = {# call unsafe Error_class as errorClass_ #}
errorString = {# call unsafe Error_string as errorString_ #}
commSetErrhandler = {# call unsafe Comm_set_errhandler as commSetErrhandler_ #}
commGetErrhandler = {# call unsafe Comm_get_errhandler as commGetErrhandler_ #}
abort = {# call unsafe Abort as abort_ #}

type Datatype = {# type MPI_Datatype #}

foreign import ccall unsafe "&mpi_char" char_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_wchar" wchar_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_short" short_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_int" int_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_long" long_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_long_long" longLong_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_char" unsignedChar_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_short" unsignedShort_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned" unsigned_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_long" unsignedLong_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_unsigned_long_long" unsignedLongLong_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_float" float_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_double" double_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_long_double" longDouble_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_byte" byte_ :: Ptr Datatype
foreign import ccall unsafe "&mpi_packed" packed_ :: Ptr Datatype

char, wchar, short, int, long, longLong, unsignedChar, unsignedShort :: Datatype
unsigned, unsignedLong, unsignedLongLong, float, double, longDouble :: Datatype
byte, packed :: Datatype

char = unsafePerformIO $ peek char_
wchar = unsafePerformIO $ peek wchar_
short = unsafePerformIO $ peek short_
int = unsafePerformIO $ peek int_
long = unsafePerformIO $ peek long_
longLong = unsafePerformIO $ peek longLong_
unsignedChar = unsafePerformIO $ peek unsignedChar_
unsignedShort = unsafePerformIO $ peek unsignedShort_
unsigned = unsafePerformIO $ peek unsigned_
unsignedLong = unsafePerformIO $ peek unsignedLong_
unsignedLongLong = unsafePerformIO $ peek unsignedLongLong_
float = unsafePerformIO $ peek float_
double = unsafePerformIO $ peek double_
longDouble = unsafePerformIO $ peek longDouble_
byte = unsafePerformIO $ peek byte_
packed = unsafePerformIO $ peek packed_

type Errhandler = {# type MPI_Errhandler #}
foreign import ccall "&mpi_errors_are_fatal" errorsAreFatal_ :: Ptr Errhandler
foreign import ccall "&mpi_errors_return" errorsReturn_ :: Ptr Errhandler
errorsAreFatal, errorsReturn :: Errhandler
errorsAreFatal = unsafePerformIO $ peek errorsAreFatal_
errorsReturn = unsafePerformIO $ peek errorsReturn_

{# enum ErrorClass {underscoreToCase} deriving (Eq,Ord,Show,Typeable) #}

-- XXX Should this be a ForeinPtr?
-- there is a MPI_Group_free function, which we should probably
-- call when the group is no longer referenced.

-- | Actual Haskell type used depends on the MPI implementation.
type MPIGroup = {# type MPI_Group #}

newtype Group = MkGroup { fromGroup :: MPIGroup }

foreign import ccall "&mpi_group_empty" groupEmpty_ :: Ptr MPIGroup
-- | Predefined handle for group without any members. Corresponds to @MPI_GROUP_EMPTY@
groupEmpty :: Group
groupEmpty = MkGroup <$> unsafePerformIO $ peek groupEmpty_

{-
This module provides Haskell type that represents values of @MPI_Op@
type (reduction operations), and predefined reduction operations
defined in the MPI Report.
-}

-- | Actual Haskell type used depends on the MPI implementation.
type Operation = {# type MPI_Op #}

foreign import ccall unsafe "&mpi_max" maxOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_min" minOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_sum" sumOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_prod" prodOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_land" landOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_band" bandOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_lor" lorOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_bor" borOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_lxor" lxorOp_ :: Ptr Operation
foreign import ccall unsafe "&mpi_bxor" bxorOp_ :: Ptr Operation
-- foreign import ccall "mpi_maxloc" maxlocOp :: Operation
-- foreign import ccall "mpi_minloc" minlocOp :: Operation
-- foreign import ccall "mpi_replace" replaceOp :: Operation
-- TODO: support for those requires better support for pair datatypes

maxOp, minOp, sumOp, prodOp, landOp, bandOp, lorOp, borOp, lxorOp, bxorOp :: Operation
maxOp = unsafePerformIO $ peek maxOp_
minOp = unsafePerformIO $ peek minOp_
sumOp = unsafePerformIO $ peek sumOp_
prodOp = unsafePerformIO $ peek prodOp_
landOp = unsafePerformIO $ peek landOp_
bandOp = unsafePerformIO $ peek bandOp_
lorOp = unsafePerformIO $ peek lorOp_
borOp = unsafePerformIO $ peek borOp_
lxorOp = unsafePerformIO $ peek lxorOp_
bxorOp = unsafePerformIO $ peek bxorOp_

{-
This module provides Haskell datatype that represents values which
could be used as MPI rank designations.
-}

-- TODO: actually, this should be 32-bit int
newtype Rank = MkRank { rankId :: Int }
   deriving (Eq, Ord, Enum, Num, Integral, Real)

foreign import ccall "mpi_any_source" anySource_ :: Ptr Int
foreign import ccall "mpi_root" theRoot_ :: Ptr Int
foreign import ccall "mpi_proc_null" procNull_ :: Ptr Int

-- | Predefined rank number that allows reception of point-to-point messages
-- regardless of their source. Corresponds to @MPI_ANY_SOURCE@
anySource :: Rank
anySource = toRank $ unsafePerformIO $ peek anySource_

-- | Predefined rank number that specifies root process during
-- operations involving intercommunicators. Corresponds to @MPI_ROOT@
theRoot :: Rank
theRoot = toRank $ unsafePerformIO $ peek theRoot_

-- | Predefined rank number that specifies non-root processes during
-- operations involving intercommunicators. Corresponds to @MPI_PROC_NULL@
procNull :: Rank
procNull  = toRank $ unsafePerformIO $ peek procNull_

instance Show Rank where
   show = show . rankId

toRank :: Enum a => a -> Rank
toRank x = MkRank { rankId = fromEnum x }

fromRank :: Enum a => Rank -> a
fromRank = toEnum . rankId

{- This module provides Haskell representation of the @MPI_Request@ type. -}
type Request = {# type MPI_Request #}

{-
This module provides Haskell representation of the @MPI_Status@ type
(request status).

Field `status_error' should be used with care:
\"The error field in status is not needed for calls that return only
one status, such as @MPI_WAIT@, since that would only duplicate the
information returned by the function itself. The current design avoids
the additional overhead of setting it, in such cases. The field is
needed for calls that return multiple statuses, since each request may
have had a different failure.\"
(this is a quote from <http://mpi-forum.org/docs/mpi22-report/node47.htm#Node47>)

This means that, for example, during the call to @MPI_Wait@
implementation is free to leave this field filled with whatever
garbage got there during memory allocation. Haskell FFI is not
blanking out freshly allocated memory, so beware!
-}

-- | Haskell structure that holds fields of @MPI_Status@.
--
-- Please note that MPI report lists only three fields as mandatory:
-- @status_source@, @status_tag@ and @status_error@. However, all
-- MPI implementations that were used to test those bindings supported
-- extended set of fields represented here.
data Status =
   Status
   { status_source :: CInt -- ^ rank of the source process
   , status_tag :: CInt -- ^ tag assigned at source
   , status_error :: CInt -- ^ error code, if any
   , status_count :: CInt -- ^ number of received elements, if applicable
   , status_cancelled :: CInt -- ^ whether the request was cancelled
   }
   deriving (Eq, Ord, Show)

{#pointer *Status as StatusPtr -> Status #}

instance Storable Status where
  sizeOf _ = {#sizeof MPI_Status #}
  alignment _ = 4
  peek p = Status
    <$> liftM cIntConv ({#get MPI_Status->MPI_SOURCE #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_TAG #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p)
#ifdef MPICH2
    -- MPICH2 and OpenMPI use different names for the status struct
    -- fields-
    <*> liftM cIntConv ({#get MPI_Status->count #} p)
    <*> liftM cIntConv ({#get MPI_Status->cancelled #} p)
#else
    <*> liftM cIntConv ({#get MPI_Status->_count #} p)
    <*> liftM cIntConv ({#get MPI_Status->_cancelled #} p)
#endif
  poke p x = do
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_TAG #} p (cIntConv $ status_tag x)
    {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x)
#ifdef MPICH2
    -- MPICH2 and OpenMPI use different names for the status struct
    -- fields AND different order of fields
    {#set MPI_Status.count #} p (cIntConv $ status_count x)
    {#set MPI_Status.cancelled #} p (cIntConv $ status_cancelled x)
#else
    {#set MPI_Status._count #} p (cIntConv $ status_count x)
    {#set MPI_Status._cancelled #} p (cIntConv $ status_cancelled x)
#endif

{-
This module provides Haskell datatype that represents values which
could be used as MPI tags.
-}

-- TODO: actually, this is a 32-bit int, and even less than that.
-- See section 8 of MPI report about extracting MPI_TAG_UB
-- and using it here
newtype Tag = MkTag { tagVal :: Int }
   deriving (Eq, Ord, Enum, Num, Integral, Real)

instance Show Tag where
  show = show . tagVal

toTag :: Enum a => a -> Tag
toTag x = MkTag { tagVal = fromEnum x }

fromTag :: Enum a => Tag -> a
fromTag = toEnum . tagVal

foreign import ccall unsafe "&mpi_any_tag" anyTag_ :: Ptr Int

-- | Predefined tag value that allows reception of the messages with
--   arbitrary tag values. Corresponds to @MPI_ANY_TAG@.
anyTag :: Tag
anyTag = toTag $ unsafePerformIO $ peek anyTag_

{-
This module provides Haskell datatypes that comprises of values of
predefined MPI constants @MPI_THREAD_SINGLE@, @MPI_THREAD_FUNNELED@,
@MPI_THREAD_SERIALIZED@, @MPI_THREAD_MULTIPLE@.
-}

{# enum ThreadSupport {underscoreToCase} deriving (Eq,Ord,Show) #}


Fix ref counting bug in sourceBufferCreateMarker (reported by bwwx in #haskell) The docs say that gtk_source_buffer_create_marker returns a new GtkSourceMarker, owned by the buffer. So we need to ref the object, so we should use makeGObject rather than constructNewGObject.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Duncan Coutts
--  derived from GtkTextView bindings by Axel Simon
--
--  Created: 15 October 2003
--
--  Copyright (C) 2003-2005 Duncan Coutts, Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceBuffer (
  SourceBuffer,
  SourceBufferClass,
  castToSourceBuffer,
  sourceBufferNew,
  sourceBufferNewWithLanguage,
  sourceBufferSetCheckBrackets,
  sourceBufferGetCheckBrackets,
  sourceBufferSetBracketsMatchStyle,
  sourceBufferSetHighlight,
  sourceBufferGetHighlight,
  sourceBufferSetMaxUndoLevels,
  sourceBufferGetMaxUndoLevels,
  sourceBufferSetLanguage,
  sourceBufferGetLanguage,
  sourceBufferSetEscapeChar,
  sourceBufferGetEscapeChar,
  sourceBufferCanUndo,
  sourceBufferCanRedo,
  sourceBufferUndo,
  sourceBufferRedo,
  sourceBufferBeginNotUndoableAction,
  sourceBufferEndNotUndoableAction,
  sourceBufferCreateMarker,
  sourceBufferMoveMarker,
  sourceBufferDeleteMarker,
  sourceBufferGetMarker,
  sourceBufferGetMarkersInRegion,
  sourceBufferGetFirstMarker,
  sourceBufferGetLastMarker,
  sourceBufferGetIterAtMarker,
  sourceBufferGetNextMarker,
  sourceBufferGetPrevMarker
) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.GList		(fromGSList)
import System.Glib.GObject              (constructNewGObject,
					 makeNewGObject)
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.Signals#}
import Graphics.UI.Gtk.SourceView.SourceTagStyle
import Graphics.UI.Gtk.SourceView.SourceMarker
{#import Graphics.UI.Gtk.Multiline.Types#}
{#import Graphics.UI.Gtk.Multiline.TextIter#}

{# context lib="gtk" prefix="gtk" #}

-- methods

-- | Create a new 'SourceBuffer', possibly
-- taking a 'SourceTagTable'.
--
sourceBufferNew :: Maybe SourceTagTable -> IO SourceBuffer
sourceBufferNew tt = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new#}
  (fromMaybe (mkSourceTagTable nullForeignPtr) tt)

-- | Create a new 'SourceBuffer'
-- with a 'SourceLanguage'.
--
sourceBufferNewWithLanguage :: SourceLanguage -> IO SourceBuffer
sourceBufferNewWithLanguage lang = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new_with_language#} lang

-- |
--
sourceBufferSetCheckBrackets :: SourceBuffer -> Bool -> IO ()
sourceBufferSetCheckBrackets sb newVal =
  {#call unsafe source_buffer_set_check_brackets#} sb (fromBool newVal)

-- |
--
sourceBufferGetCheckBrackets :: SourceBuffer -> IO Bool
sourceBufferGetCheckBrackets sb = liftM toBool $
  {#call unsafe source_buffer_get_check_brackets#} sb

-- |
--
sourceBufferSetBracketsMatchStyle :: SourceBuffer -> SourceTagStyle -> IO ()
sourceBufferSetBracketsMatchStyle sb ts =
  alloca $ \tsPtr -> do
  poke tsPtr ts
  {#call unsafe source_buffer_set_bracket_match_style#} sb (castPtr tsPtr)

-- |
--
sourceBufferSetHighlight :: SourceBuffer -> Bool -> IO ()
sourceBufferSetHighlight sb newVal =
  {#call unsafe source_buffer_set_highlight#} sb (fromBool newVal)

-- |
--
sourceBufferGetHighlight :: SourceBuffer -> IO Bool
sourceBufferGetHighlight sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight#} sb

-- |
--
sourceBufferSetMaxUndoLevels :: SourceBuffer -> Int -> IO ()
sourceBufferSetMaxUndoLevels sb newVal =
  {#call unsafe source_buffer_set_max_undo_levels#} sb (fromIntegral newVal)

-- |
--
sourceBufferGetMaxUndoLevels :: SourceBuffer -> IO Int
sourceBufferGetMaxUndoLevels sb = liftM fromIntegral $
  {#call unsafe source_buffer_get_max_undo_levels#} sb

-- |
--
sourceBufferSetLanguage :: SourceBuffer -> SourceLanguage -> IO ()
sourceBufferSetLanguage sb lang =
  {#call unsafe source_buffer_set_language#} sb lang

-- |
--
sourceBufferGetLanguage :: SourceBuffer -> IO SourceLanguage
sourceBufferGetLanguage sb = makeNewGObject mkSourceLanguage $
  {#call unsafe source_buffer_get_language#} sb

-- |
--
sourceBufferSetEscapeChar :: SourceBuffer -> Char -> IO ()
sourceBufferSetEscapeChar sb char =
  {#call unsafe source_buffer_set_escape_char#} sb ((toEnum . fromEnum) char)

-- |
--
sourceBufferGetEscapeChar :: SourceBuffer -> IO Char
sourceBufferGetEscapeChar sb = liftM (toEnum . fromEnum) $
  {#call unsafe source_buffer_get_escape_char#} sb

-- |
--
sourceBufferCanUndo :: SourceBuffer -> IO Bool
sourceBufferCanUndo sb = liftM toBool $
  {#call unsafe source_buffer_can_undo#} sb

-- |
--
sourceBufferCanRedo :: SourceBuffer -> IO Bool
sourceBufferCanRedo sb = liftM toBool $
  {#call unsafe source_buffer_can_redo#} sb

-- |
--
sourceBufferUndo :: SourceBuffer -> IO ()
sourceBufferUndo sb =
  {#call source_buffer_undo#} sb

-- |
--
sourceBufferRedo :: SourceBuffer -> IO ()
sourceBufferRedo sb =
  {#call source_buffer_redo#} sb

-- |
--
sourceBufferBeginNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferBeginNotUndoableAction sb =
  {#call source_buffer_begin_not_undoable_action#} sb

-- |
--
sourceBufferEndNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferEndNotUndoableAction sb =
  {#call source_buffer_end_not_undoable_action#} sb

-- | Creates a marker in the buffer of the given type.
--
-- *  A marker is
--    semantically very similar to a 'Graphics.UI.Gtk.Multiline.TextMark',
--    except it has a type
--    which is used by the 'SourceView' displaying the buffer to show a
--    pixmap on the left margin, at the line the marker is in.  Because
--    of this, a marker is generally associated to a line and not a
--    character position.  Markers are also accessible through a position
--    or range in the buffer.
--
-- *  Markers are implemented using 'Graphics.UI.Gtk.Multiline.TextMark',
--    so all characteristics
--    and restrictions to marks apply to markers too.  These includes
--    life cycle issues and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkSet'
--    and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkDeleted' signal
--    emissions.
--
-- *  Like a 'Graphics.UI.Gtk.Multiline.TextMark', a 'SourceMarker'
--    can be anonymous if the
--    passed name is @Nothing@.  Also, the buffer owns the markers so you
--    shouldn't unreference it.

sourceBufferCreateMarker :: SourceBuffer -- the buffer
			 -> Maybe String -- the name of the marker
			 -> String -- the type of the marker
			 -> TextIter -> IO SourceMarker
sourceBufferCreateMarker sb name markerType iter =
  makeNewGObject mkSourceMarker $
  maybeWith withCString name       $ \strPtr1 ->
  withCString markerType $ \strPtr2 ->
  {#call source_buffer_create_marker#} sb strPtr1 strPtr2 iter

-- |
--
sourceBufferMoveMarker :: SourceBuffer -> SourceMarker -> TextIter -> IO ()
sourceBufferMoveMarker sb mark iter =
  {#call source_buffer_move_marker#} sb mark iter

-- |
--
sourceBufferDeleteMarker :: SourceBuffer -> SourceMarker -> IO ()
sourceBufferDeleteMarker sb mark =
  {#call source_buffer_delete_marker#} sb mark

-- |
--
sourceBufferGetMarker :: SourceBuffer -> String -> IO (Maybe SourceMarker)
sourceBufferGetMarker sb name =
  maybeNull (makeNewGObject mkSourceMarker) $
  withCString name $ \strPtr1 ->
  {#call unsafe source_buffer_get_marker#} sb strPtr1

-- | Returns an /ordered/ (by position) list of 'SourceMarker's inside the
--   region delimited by the two 'TextIter's. The iterators may be in any
--   order.
--
sourceBufferGetMarkersInRegion :: SourceBuffer -> TextIter -> TextIter -> IO [SourceMarker]
sourceBufferGetMarkersInRegion sb begin end = do
  gList <- {#call unsafe source_buffer_get_markers_in_region#} sb begin end
  wList <- fromGSList gList
  mapM (makeNewGObject mkSourceMarker) (map return wList)

-- | Returns the first (nearest to the top of the buffer) marker.
--
sourceBufferGetFirstMarker :: SourceBuffer -> IO (Maybe SourceMarker)
sourceBufferGetFirstMarker sb =
  maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_first_marker#} sb

-- | Returns the last (nearest to the bottom of the buffer) marker.
--
sourceBufferGetLastMarker :: SourceBuffer -> IO (Maybe SourceMarker)
sourceBufferGetLastMarker sb =
  maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_last_marker#} sb

-- |
--
sourceBufferGetIterAtMarker :: SourceBuffer -> SourceMarker -> IO TextIter
sourceBufferGetIterAtMarker sb mark = do
  iter <- makeEmptyTextIter
  {#call unsafe source_buffer_get_iter_at_marker#} sb iter mark
  return iter

-- | Returns the nearest marker to the right of the given iterator.
-- If there are
-- multiple markers at the same position, this function will always
-- return the first one (from the internal linked list), even if
-- starting the search exactly at its location.  You can get the
-- others using 'sourceMarkerNext'.
--
sourceBufferGetNextMarker :: SourceBuffer -> TextIter -> IO (Maybe SourceMarker)
sourceBufferGetNextMarker sb iter = maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_next_marker#} sb iter

-- | Returns the nearest marker to the left of the given iterator.
-- If there are
-- multiple markers at the same position, this function will always
-- return the last one (from the internal linked list), even if
-- starting the search exactly at its location.  You can get the
-- others using 'sourceMarkerPrev'.
--
sourceBufferGetPrevMarker :: SourceBuffer -> TextIter -> IO (Maybe SourceMarker)
sourceBufferGetPrevMarker sb iter = maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_prev_marker#} sb iter

-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Duncan Coutts
--  derived from GtkTextView bindings by Axel Simon
--
--  Created: 15 October 2003
--
--  Copyright (C) 2003-2005 Duncan Coutts, Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceBuffer (
  SourceBuffer,
  SourceBufferClass,
  castToSourceBuffer,
  sourceBufferNew,
  sourceBufferNewWithLanguage,
  sourceBufferSetCheckBrackets,
  sourceBufferGetCheckBrackets,
  sourceBufferSetBracketsMatchStyle,
  sourceBufferSetHighlight,
  sourceBufferGetHighlight,
  sourceBufferSetMaxUndoLevels,
  sourceBufferGetMaxUndoLevels,
  sourceBufferSetLanguage,
  sourceBufferGetLanguage,
  sourceBufferSetEscapeChar,
  sourceBufferGetEscapeChar,
  sourceBufferCanUndo,
  sourceBufferCanRedo,
  sourceBufferUndo,
  sourceBufferRedo,
  sourceBufferBeginNotUndoableAction,
  sourceBufferEndNotUndoableAction,
  sourceBufferCreateMarker,
  sourceBufferMoveMarker,
  sourceBufferDeleteMarker,
  sourceBufferGetMarker,
  sourceBufferGetMarkersInRegion,
  sourceBufferGetFirstMarker,
  sourceBufferGetLastMarker,
  sourceBufferGetIterAtMarker,
  sourceBufferGetNextMarker,
  sourceBufferGetPrevMarker
) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.GList		(fromGSList)
import System.Glib.GObject              (constructNewGObject,
					 makeNewGObject)
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.Signals#}
import Graphics.UI.Gtk.SourceView.SourceTagStyle
import Graphics.UI.Gtk.SourceView.SourceMarker
{#import Graphics.UI.Gtk.Multiline.Types#}
{#import Graphics.UI.Gtk.Multiline.TextIter#}

{# context lib="gtk" prefix="gtk" #}

-- methods

-- | Create a new 'SourceBuffer', possibly
-- taking a 'SourceTagTable'.
--
sourceBufferNew :: Maybe SourceTagTable -> IO SourceBuffer
sourceBufferNew tt = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new#}
  (fromMaybe (mkSourceTagTable nullForeignPtr) tt)

-- | Create a new 'SourceBuffer'
-- with a 'SourceLanguage'.
--
sourceBufferNewWithLanguage :: SourceLanguage -> IO SourceBuffer
sourceBufferNewWithLanguage lang = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new_with_language#} lang

-- |
--
sourceBufferSetCheckBrackets :: SourceBuffer -> Bool -> IO ()
sourceBufferSetCheckBrackets sb newVal =
  {#call unsafe source_buffer_set_check_brackets#} sb (fromBool newVal)

-- |
--
sourceBufferGetCheckBrackets :: SourceBuffer -> IO Bool
sourceBufferGetCheckBrackets sb = liftM toBool $
  {#call unsafe source_buffer_get_check_brackets#} sb

-- |
--
sourceBufferSetBracketsMatchStyle :: SourceBuffer -> SourceTagStyle -> IO ()
sourceBufferSetBracketsMatchStyle sb ts =
  alloca $ \tsPtr -> do
  poke tsPtr ts
  {#call unsafe source_buffer_set_bracket_match_style#} sb (castPtr tsPtr)

-- |
--
sourceBufferSetHighlight :: SourceBuffer -> Bool -> IO ()
sourceBufferSetHighlight sb newVal =
  {#call unsafe source_buffer_set_highlight#} sb (fromBool newVal)

-- |
--
sourceBufferGetHighlight :: SourceBuffer -> IO Bool
sourceBufferGetHighlight sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight#} sb

-- |
--
sourceBufferSetMaxUndoLevels :: SourceBuffer -> Int -> IO ()
sourceBufferSetMaxUndoLevels sb newVal =
  {#call unsafe source_buffer_set_max_undo_levels#} sb (fromIntegral newVal)

-- |
--
sourceBufferGetMaxUndoLevels :: SourceBuffer -> IO Int
sourceBufferGetMaxUndoLevels sb = liftM fromIntegral $
  {#call unsafe source_buffer_get_max_undo_levels#} sb

-- |
--
sourceBufferSetLanguage :: SourceBuffer -> SourceLanguage -> IO ()
sourceBufferSetLanguage sb lang =
  {#call unsafe source_buffer_set_language#} sb lang

-- |
--
sourceBufferGetLanguage :: SourceBuffer -> IO SourceLanguage
sourceBufferGetLanguage sb = makeNewGObject mkSourceLanguage $
  {#call unsafe source_buffer_get_language#} sb

-- |
--
sourceBufferSetEscapeChar :: SourceBuffer -> Char -> IO ()
sourceBufferSetEscapeChar sb char =
  {#call unsafe source_buffer_set_escape_char#} sb ((toEnum . fromEnum) char)

-- |
--
sourceBufferGetEscapeChar :: SourceBuffer -> IO Char
sourceBufferGetEscapeChar sb = liftM (toEnum . fromEnum) $
  {#call unsafe source_buffer_get_escape_char#} sb

-- |
--
sourceBufferCanUndo :: SourceBuffer -> IO Bool
sourceBufferCanUndo sb = liftM toBool $
  {#call unsafe source_buffer_can_undo#} sb

-- |
--
sourceBufferCanRedo :: SourceBuffer -> IO Bool
sourceBufferCanRedo sb = liftM toBool $
  {#call unsafe source_buffer_can_redo#} sb

-- |
--
sourceBufferUndo :: SourceBuffer -> IO ()
sourceBufferUndo sb =
  {#call source_buffer_undo#} sb

-- |
--
sourceBufferRedo :: SourceBuffer -> IO ()
sourceBufferRedo sb =
  {#call source_buffer_redo#} sb

-- |
--
sourceBufferBeginNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferBeginNotUndoableAction sb =
  {#call source_buffer_begin_not_undoable_action#} sb

-- |
--
sourceBufferEndNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferEndNotUndoableAction sb =
  {#call source_buffer_end_not_undoable_action#} sb

-- | Creates a marker in the buffer of the given type.
--
-- *  A marker is
--    semantically very similar to a 'Graphics.UI.Gtk.Multiline.TextMark',
--    except it has a type
--    which is used by the 'SourceView' displaying the buffer to show a
--    pixmap on the left margin, at the line the marker is in.  Because
--    of this, a marker is generally associated to a line and not a
--    character position.  Markers are also accessible through a position
--    or range in the buffer.
--
-- *  Markers are implemented using 'Graphics.UI.Gtk.Multiline.TextMark',
--    so all characteristics
--    and restrictions to marks apply to markers too.  These includes
--    life cycle issues and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkSet'
--    and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkDeleted' signal
--    emissions.
--
-- *  Like a 'Graphics.UI.Gtk.Multiline.TextMark', a 'SourceMarker'
--    can be anonymous if the
--    passed name is @Nothing@.  Also, the buffer owns the markers so you
--    shouldn't unreference it.

sourceBufferCreateMarker :: SourceBuffer -- the buffer
			 -> Maybe String -- the name of the marker
			 -> String -- the type of the marker
			 -> TextIter -> IO SourceMarker
sourceBufferCreateMarker sb name markerType iter =
  constructNewGObject mkSourceMarker $
  maybeWith withCString name       $ \strPtr1 ->
  withCString markerType $ \strPtr2 ->
  {#call source_buffer_create_marker#} sb strPtr1 strPtr2 iter

-- |
--
sourceBufferMoveMarker :: SourceBuffer -> SourceMarker -> TextIter -> IO ()
sourceBufferMoveMarker sb mark iter =
  {#call source_buffer_move_marker#} sb mark iter

-- |
--
sourceBufferDeleteMarker :: SourceBuffer -> SourceMarker -> IO ()
sourceBufferDeleteMarker sb mark =
  {#call source_buffer_delete_marker#} sb mark

-- |
--
sourceBufferGetMarker :: SourceBuffer -> String -> IO (Maybe SourceMarker)
sourceBufferGetMarker sb name =
  maybeNull (makeNewGObject mkSourceMarker) $
  withCString name $ \strPtr1 ->
  {#call unsafe source_buffer_get_marker#} sb strPtr1

-- | Returns an /ordered/ (by position) list of 'SourceMarker's inside the
--   region delimited by the two 'TextIter's. The iterators may be in any
--   order.
--
sourceBufferGetMarkersInRegion :: SourceBuffer -> TextIter -> TextIter -> IO [SourceMarker]
sourceBufferGetMarkersInRegion sb begin end = do
  gList <- {#call unsafe source_buffer_get_markers_in_region#} sb begin end
  wList <- fromGSList gList
  mapM (makeNewGObject mkSourceMarker) (map return wList)

-- | Returns the first (nearest to the top of the buffer) marker.
--
sourceBufferGetFirstMarker :: SourceBuffer -> IO (Maybe SourceMarker)
sourceBufferGetFirstMarker sb =
  maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_first_marker#} sb

-- | Returns the last (nearest to the bottom of the buffer) marker.
--
sourceBufferGetLastMarker :: SourceBuffer -> IO (Maybe SourceMarker)
sourceBufferGetLastMarker sb =
  maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_last_marker#} sb

-- |
--
sourceBufferGetIterAtMarker :: SourceBuffer -> SourceMarker -> IO TextIter
sourceBufferGetIterAtMarker sb mark = do
  iter <- makeEmptyTextIter
  {#call unsafe source_buffer_get_iter_at_marker#} sb iter mark
  return iter

-- | Returns the nearest marker to the right of the given iterator.
-- If there are
-- multiple markers at the same position, this function will always
-- return the first one (from the internal linked list), even if
-- starting the search exactly at its location.  You can get the
-- others using 'sourceMarkerNext'.
--
sourceBufferGetNextMarker :: SourceBuffer -> TextIter -> IO (Maybe SourceMarker)
sourceBufferGetNextMarker sb iter = maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_next_marker#} sb iter

-- | Returns the nearest marker to the left of the given iterator.
-- If there are
-- multiple markers at the same position, this function will always
-- return the last one (from the internal linked list), even if
-- starting the search exactly at its location.  You can get the
-- others using 'sourceMarkerPrev'.
--
sourceBufferGetPrevMarker :: SourceBuffer -> TextIter -> IO (Maybe SourceMarker)
sourceBufferGetPrevMarker sb iter = maybeNull (makeNewGObject mkSourceMarker) $
  {#call unsafe source_buffer_get_prev_marker#} sb iter


Add real Show instances for the C enumeration types

module Data.LLVM.Private.Types.Attributes (
  -- * Types
  ArithFlags(..),
  CmpPredicate(..),
  CallingConvention(..),
  LinkageType(..),
  VisibilityStyle(..),
  ParamAttribute(..),
  FunctionAttribute(..),
  Endian(..),
  DataLayout(..),
  TargetTriple(..),
  AlignSpec(..),
  Assembly(..),
  -- * Values
  defaultDataLayout
  ) where

#include "c++/marshal.h"

import Control.DeepSeq
import Data.ByteString.Char8 ( ByteString, unpack )

{#enum LinkageType {} deriving (Eq) #}
instance Show LinkageType where
  show LTExternal = ""
  show LTAvailableExternally = "available_externally"
  show LTLinkOnceAny = "linkonce"
  show LTLinkOnceODR = "linkonce_odr"
  show LTWeakAny = "weak"
  show LTWeakODR = "weak_odr"
  show LTAppending = "appending"
  show LTInternal = "internal"
  show LTPrivate = "private"
  show LTLinkerPrivate = "linker_private"
  show LTLinkerPrivateWeak = "linker_private_weak"
  show LTLinkerPrivateWeakDefAuto = "linker_private_weak_def_auto"
  show LTDLLImport = "dllimport"
  show LTDLLExport = "dllexport"
  show LTExternalWeak = "extern_weak"
  show LTCommon = "common"

instance NFData LinkageType

{#enum VisibilityStyle {} deriving (Eq) #}

instance Show VisibilityStyle where
  show VisibilityDefault = ""
  show VisibilityHidden = "hidden"
  show VisibilityProtected = "protected"

instance NFData VisibilityStyle

{#enum ArithFlags {} deriving (Eq) #}

instance Show ArithFlags where
  show ArithNone = ""
  show ArithNUW = "nuw"
  show ArithNSW = "nsw"
  show ArithBoth = "nuw nsw"

instance NFData ArithFlags

{#enum CmpPredicate {underscoreToCase} deriving (Eq) #}

instance Show CmpPredicate where
  show FCmpFalse = "false"
  show FCmpOeq = "oeq"
  show FCmpOgt = "ogt"
  show FCmpOge = "oge"
  show FCmpOlt = "olt"
  show FCmpOle = "ole"
  show FCmpOne = "one"
  show FCmpOrd = "ord"
  show FCmpUno = "uno"
  show FCmpUeq = "ueq"
  show FCmpUgt = "ugt"
  show FCmpUge = "uge"
  show FCmpUlt = "ult"
  show FCmpUle = "ule"
  show FCmpUne = "une"
  show FCmpTrue = "true"
  show ICmpEq = "eq"
  show ICmpNe = "ne"
  show ICmpUgt = "ugt"
  show ICmpUge = "uge"
  show ICmpUlt = "ult"
  show ICmpUle = "ule"
  show ICmpSgt = "sgt"
  show ICmpSge = "sge"
  show ICmpSlt = "slt"
  show ICmpSle = "sle"

instance NFData CmpPredicate

{#enum CallingConvention {} deriving (Eq) #}
instance Show CallingConvention where
  show CC_C = ""
  show CC_FAST = "fastcc"
  show CC_COLD = "coldcc"
  show CC_GHC = "cc 10"
  show CC_X86_STDCALL = "cc 64"
  show CC_X86_FASTCALL = "cc 65"
  show CC_ARM_APCS = "cc 66"
  show CC_ARM_AAPCS = "cc 67"
  show CC_ARM_AAPCS_VFP = "cc 68"
  show CC_MSP430_INTR = "cc 69"
  show CC_X86_THISCALL = "cc 70"
  show CC_PTX_KERNEL = "cc 71"
  show CC_PTX_DEVICE = "cc 72"
  show CC_MBLAZE_INTR = "cc 73"
  show CC_MBLAZE_SVOL = "cc 74"

instance NFData CallingConvention

 -- Representing Assembly
data Assembly = Assembly !ByteString
                deriving (Eq, Ord)

instance Show Assembly where
  show (Assembly txt) = unpack txt

instance NFData Assembly where
  rnf a@(Assembly txt) = txt `seq` a `seq` ()

-- Param attributes

data ParamAttribute = PAZeroExt
                    | PASignExt
                    | PAInReg
                    | PAByVal
                    | PASRet
                    | PANoAlias
                    | PANoCapture
                    | PANest
                    | PAAlign !Int
                    deriving (Eq, Ord)

instance NFData ParamAttribute

instance Show ParamAttribute where
  show PAZeroExt = "zeroext"
  show PASignExt = "signext"
  show PAInReg = "inreg"
  show PAByVal = "byval"
  show PASRet = "sret"
  show PANoAlias = "noalias"
  show PANoCapture = "nocapture"
  show PANest = "nest"
  show (PAAlign i) = "align " ++ show i

-- Function Attributes

data FunctionAttribute = FAAlignStack !Int
                       | FAAlwaysInline
                       | FAHotPatch
                       | FAInlineHint
                       | FANaked
                       | FANoImplicitFloat
                       | FANoInline
                       | FANoRedZone
                       | FANoReturn
                       | FANoUnwind
                       | FAOptSize
                       | FAReadNone
                       | FAReadOnly
                       | FASSP
                       | FASSPReq
                       deriving (Eq, Ord)

instance NFData FunctionAttribute

instance Show FunctionAttribute where
  show (FAAlignStack n) = "alignstack(" ++ show n ++ ")"
  show FAAlwaysInline = "alwaysinline"
  show FAHotPatch = "hotpatch"
  show FAInlineHint = "inlinehint"
  show FANaked = "naked"
  show FANoImplicitFloat = "noimplicitfloat"
  show FANoInline = "noinline"
  show FANoRedZone = "noredzone"
  show FANoReturn = "noreturn"
  show FANoUnwind = "nounwind"
  show FAOptSize = "optsize"
  show FAReadNone = "readnone"
  show FAReadOnly = "readonly"
  show FASSP = "ssp"
  show FASSPReq = "sspreq"

data Endian = EBig
            | ELittle
              deriving (Eq, Ord)

instance NFData Endian

instance Show Endian where
  show EBig = "E"
  show ELittle = "e"

-- Track the ABI alignment and preferred alignment
data AlignSpec = AlignSpec !Int !Int
                 deriving (Show, Eq, Ord)

instance NFData AlignSpec where
  rnf a@(AlignSpec i1 i2) = i1 `seq` i2 `seq` a `seq` ()

data TargetTriple = TargetTriple ByteString
                    deriving (Eq)

instance Show TargetTriple where
  show (TargetTriple t) = unpack t

instance NFData TargetTriple where
  rnf t@(TargetTriple t') = t' `seq` t `seq` ()

data DataLayout = DataLayout { endianness :: Endian
                             , pointerAlign :: (Int, AlignSpec)
                             , intAlign :: [ (Int, AlignSpec) ]
                             , vectorAlign :: [ (Int, AlignSpec) ]
                             , floatAlign :: [ (Int, AlignSpec) ]
                             , aggregateAlign :: [ (Int, AlignSpec) ]
                             , stackAlign :: [ (Int, AlignSpec) ]
                             , nativeWidths :: [ Int ]
                             }
                  deriving (Show, Eq)

instance NFData DataLayout where
  rnf d = endianness d `deepseq` pointerAlign d `deepseq`
           intAlign d `deepseq` vectorAlign d `deepseq`
           floatAlign d `deepseq` aggregateAlign d `deepseq`
           stackAlign d `deepseq` nativeWidths d `deepseq` d `seq` ()

-- Defaults specified by LLVM.  I think there can only be one pointer
-- align specification, though it isn't explicitly stated
defaultDataLayout :: DataLayout
defaultDataLayout = DataLayout { endianness = EBig
                               , pointerAlign = (64, AlignSpec 64 64)
                               , intAlign = [ (1, AlignSpec 8 8)
                                            , (8, AlignSpec 8 8)
                                            , (16, AlignSpec 16 16)
                                            , (32, AlignSpec 32 32)
                                            , (64, AlignSpec 32 64)
                                            ]
                               , vectorAlign = [ (64, AlignSpec 64 64)
                                               , (128, AlignSpec 128 128)
                                               ]
                               , floatAlign = [ (32, AlignSpec 32 32)
                                              , (64, AlignSpec 64 64)
                                              ]
                               , aggregateAlign = [ (0, AlignSpec 0 1) ]
                               , stackAlign = [ (0, AlignSpec 64 64) ]
                               , nativeWidths = [] -- Set.empty
                               }

module Data.LLVM.Private.Types.Attributes (
  -- * Types
  ArithFlags(..),
  CmpPredicate(..),
  CallingConvention(..),
  LinkageType(..),
  VisibilityStyle(..),
  ParamAttribute(..),
  FunctionAttribute(..),
  Endian(..),
  DataLayout(..),
  TargetTriple(..),
  AlignSpec(..),
  Assembly(..),
  -- * Values
  defaultDataLayout
  ) where

#include "c++/marshal.h"

import Control.DeepSeq
import Data.ByteString.Char8 ( ByteString, unpack )

{#enum ArithFlags {} deriving (Show, Eq) #}
{#enum CmpPredicate {underscoreToCase} deriving (Show, Eq) #}
{#enum CallingConvention {} deriving (Show, Eq) #}
{#enum LinkageType {} deriving (Show, Eq) #}
{#enum VisibilityStyle {} deriving (Show, Eq) #}

instance NFData ArithFlags
instance NFData CmpPredicate
instance NFData CallingConvention
instance NFData LinkageType
instance NFData VisibilityStyle

 -- Representing Assembly
data Assembly = Assembly !ByteString
                deriving (Eq, Ord)

instance Show Assembly where
  show (Assembly txt) = unpack txt

instance NFData Assembly where
  rnf a@(Assembly txt) = txt `seq` a `seq` ()

-- Param attributes

data ParamAttribute = PAZeroExt
                    | PASignExt
                    | PAInReg
                    | PAByVal
                    | PASRet
                    | PANoAlias
                    | PANoCapture
                    | PANest
                    | PAAlign !Int
                    deriving (Eq, Ord)

instance NFData ParamAttribute

instance Show ParamAttribute where
  show PAZeroExt = "zeroext"
  show PASignExt = "signext"
  show PAInReg = "inreg"
  show PAByVal = "byval"
  show PASRet = "sret"
  show PANoAlias = "noalias"
  show PANoCapture = "nocapture"
  show PANest = "nest"
  show (PAAlign i) = "align " ++ show i

-- Function Attributes

data FunctionAttribute = FAAlignStack !Int
                       | FAAlwaysInline
                       | FAHotPatch
                       | FAInlineHint
                       | FANaked
                       | FANoImplicitFloat
                       | FANoInline
                       | FANoRedZone
                       | FANoReturn
                       | FANoUnwind
                       | FAOptSize
                       | FAReadNone
                       | FAReadOnly
                       | FASSP
                       | FASSPReq
                       deriving (Eq, Ord)

instance NFData FunctionAttribute

instance Show FunctionAttribute where
  show (FAAlignStack n) = "alignstack(" ++ show n ++ ")"
  show FAAlwaysInline = "alwaysinline"
  show FAHotPatch = "hotpatch"
  show FAInlineHint = "inlinehint"
  show FANaked = "naked"
  show FANoImplicitFloat = "noimplicitfloat"
  show FANoInline = "noinline"
  show FANoRedZone = "noredzone"
  show FANoReturn = "noreturn"
  show FANoUnwind = "nounwind"
  show FAOptSize = "optsize"
  show FAReadNone = "readnone"
  show FAReadOnly = "readonly"
  show FASSP = "ssp"
  show FASSPReq = "sspreq"

data Endian = EBig
            | ELittle
              deriving (Eq, Ord)

instance NFData Endian

instance Show Endian where
  show EBig = "E"
  show ELittle = "e"

-- Track the ABI alignment and preferred alignment
data AlignSpec = AlignSpec !Int !Int
                 deriving (Show, Eq, Ord)

instance NFData AlignSpec where
  rnf a@(AlignSpec i1 i2) = i1 `seq` i2 `seq` a `seq` ()

data TargetTriple = TargetTriple ByteString
                    deriving (Eq)

instance Show TargetTriple where
  show (TargetTriple t) = unpack t

instance NFData TargetTriple where
  rnf t@(TargetTriple t') = t' `seq` t `seq` ()

data DataLayout = DataLayout { endianness :: Endian
                             , pointerAlign :: (Int, AlignSpec)
                             , intAlign :: [ (Int, AlignSpec) ]
                             , vectorAlign :: [ (Int, AlignSpec) ]
                             , floatAlign :: [ (Int, AlignSpec) ]
                             , aggregateAlign :: [ (Int, AlignSpec) ]
                             , stackAlign :: [ (Int, AlignSpec) ]
                             , nativeWidths :: [ Int ]
                             }
                  deriving (Show, Eq)

instance NFData DataLayout where
  rnf d = endianness d `deepseq` pointerAlign d `deepseq`
           intAlign d `deepseq` vectorAlign d `deepseq`
           floatAlign d `deepseq` aggregateAlign d `deepseq`
           stackAlign d `deepseq` nativeWidths d `deepseq` d `seq` ()

-- Defaults specified by LLVM.  I think there can only be one pointer
-- align specification, though it isn't explicitly stated
defaultDataLayout :: DataLayout
defaultDataLayout = DataLayout { endianness = EBig
                               , pointerAlign = (64, AlignSpec 64 64)
                               , intAlign = [ (1, AlignSpec 8 8)
                                            , (8, AlignSpec 8 8)
                                            , (16, AlignSpec 16 16)
                                            , (32, AlignSpec 32 32)
                                            , (64, AlignSpec 32 64)
                                            ]
                               , vectorAlign = [ (64, AlignSpec 64 64)
                                               , (128, AlignSpec 128 128)
                                               ]
                               , floatAlign = [ (32, AlignSpec 32 32)
                                              , (64, AlignSpec 64 64)
                                              ]
                               , aggregateAlign = [ (0, AlignSpec 0 1) ]
                               , stackAlign = [ (0, AlignSpec 64 64) ]
                               , nativeWidths = [] -- Set.empty
                               }


Implement annotGetName, annotGetPageIndex, annotGetColor, annotSetColor, annotGetContents, annotSetContents and annotGetModified

module Graphics.UI.Gtk.Poppler.Annotation (
    Annot,
    AnnotClass,
    AnnotType (..),
    AnnotFlag (..),
    annotGetAnnotType,
    annotGetAnnotFlags,
    annotGetName,
    annotGetPageIndex,
    annotGetColor,
    annotSetColor,
    annotGetContents,
    annotSetContents,
    annotGetModified,
    annotTextNew
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs

{# context lib="poppler" prefix="poppler" #}

annotGetAnnotType :: AnnotClass annot => annot -> IO AnnotType
annotGetAnnotType annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_annot_type #} (toAnnot annot)

annotGetAnnotFlags :: AnnotClass annot => annot -> IO AnnotFlag
annotGetAnnotFlags annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_flags #} (toAnnot annot)

annotGetName :: AnnotClass annot => annot -> IO String
annotGetName annot =
  {# call poppler_annot_get_name #} (toAnnot annot) >>= peekUTFString

annotGetPageIndex :: AnnotClass annot => annot -> IO Int
annotGetPageIndex annot =
  liftM fromIntegral $
  {# call poppler_annot_get_page_index #} (toAnnot annot)

annotGetColor :: AnnotClass annot => annot -> IO PopplerColor
annotGetColor annot =
  (peekPopplerColor . castPtr) =<<
  {# call poppler_annot_get_color #} (toAnnot annot)

annotSetColor :: AnnotClass annot => annot -> PopplerColor -> IO ()
annotSetColor annot color =
  with color $ \colorPtr ->
    {# call poppler_annot_set_color #} (toAnnot annot) (castPtr colorPtr)

annotGetContents :: AnnotClass annot => annot -> IO String
annotGetContents annot =
  {# call poppler_annot_get_contents #} (toAnnot annot) >>= peekUTFString

annotSetContents :: AnnotClass annot => annot -> String -> IO ()
annotSetContents annot content =
  withUTFString content $ \contentPtr ->
    {# call poppler_annot_set_contents #} (toAnnot annot) contentPtr

annotGetModified :: AnnotClass annot => annot -> IO String
annotGetModified annot =
  {# call poppler_annot_get_modified #} (toAnnot annot) >>= peekUTFString

annotTextNew :: DocumentClass doc => doc -> PopplerRectangle -> IO Annot
annotTextNew doc selection =
  wrapNewGObject mkAnnot $
  with selection $ \selectionPtr ->
    {# call poppler_annot_text_new #} (toDocument doc) (castPtr selectionPtr)

module Graphics.UI.Gtk.Poppler.Annotation (
    Annot,
    AnnotClass,
    AnnotType (..),
    AnnotFlag (..),
    annotGetAnnotType,
    annotGetAnnotFlag,
    annotTextNew
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs

{# context lib="poppler" prefix="poppler" #}

annotGetAnnotType :: AnnotClass annot => annot -> IO AnnotType
annotGetAnnotType annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_annot_type #} (toAnnot annot)

annotGetAnnotFlag :: AnnotClass annot => annot -> IO AnnotFlag
annotGetAnnotFlag annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_flags #} (toAnnot annot)

annotTextNew :: DocumentClass doc => doc -> PopplerRectangle -> IO Annot
annotTextNew doc selection =
  wrapNewGObject mkAnnot $
  with selection $ \selectionPtr ->
    {# call poppler_annot_text_new #} (toDocument doc) (castPtr selectionPtr)


Add device resources for compute 3.2 (Jetson K1)

Somewhat speculative, check when 6.5 is released. Fixes #15.

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include "cbits/stubs.h"

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
#if CUDA_VERSION >= 4000
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp      :: !Int,        -- ^ Warp size
    threadsPerMP        :: !Int,        -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP   :: !Int,        -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP          :: !Int,        -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP          :: !Int,        -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP      :: !Int,        -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit  :: !Int,        -- ^ Shared memory allocation unit size (bytes)
    regFileSize         :: !Int,        -- ^ Total number of registers in a multiprocessor
    regAllocUnit        :: !Int,        -- ^ Register allocation unit size
    regAllocWarp        :: !Int,        -- ^ Register allocation granularity for warps
    regPerThread        :: !Int,        -- ^ Maximum number of registers per thread
    allocation          :: !Allocation  -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2  63 Warp   -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2  63 Warp   -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4  63 Warp   -- Kepler GK10x
      Compute 3 2 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Jetson TK1 (speculative)
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Kepler GK11x
      Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp   -- Maxwell GM10x

      -- Something might have gone wrong, or the library just needs to be
      -- updated for the next generation of hardware, in which case we just want
      -- to pick a sensible default and carry on.
      --
      -- This is slightly dodgy as the warning message is coming from pure code.
      -- However, it should be OK because all library functions run in IO, so it
      -- is likely the user code is as well.
      --
      _           -> trace warning $ resources (Compute 3 0)
        where warning = unlines [ "*** Warning: Unknown CUDA device compute capability: " ++ show compute
                                , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include "cbits/stubs.h"

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
#if CUDA_VERSION >= 4000
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp      :: !Int,        -- ^ Warp size
    threadsPerMP        :: !Int,        -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP   :: !Int,        -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP          :: !Int,        -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP          :: !Int,        -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP      :: !Int,        -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit  :: !Int,        -- ^ Shared memory allocation unit size (bytes)
    regFileSize         :: !Int,        -- ^ Total number of registers in a multiprocessor
    regAllocUnit        :: !Int,        -- ^ Register allocation unit size
    regAllocWarp        :: !Int,        -- ^ Register allocation granularity for warps
    regPerThread        :: !Int,        -- ^ Maximum number of registers per thread
    allocation          :: !Allocation  -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2  63 Warp   -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2  63 Warp   -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4  63 Warp   -- Kepler GK10x
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Kepler GK11x
      Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp   -- Maxwell GM10x

      -- Something might have gone wrong, or the library just needs to be
      -- updated for the next generation of hardware, in which case we just want
      -- to pick a sensible default and carry on.
      --
      -- This is slightly dodgy as the warning message is coming from pure code.
      -- However, it should be OK because all library functions run in IO, so it
      -- is likely the user code is as well.
      --
      _           -> trace warning $ resources (Compute 3 0)
        where warning = unlines [ "*** Warning: unknown CUDA device compute capability: " ++ show compute
                                , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]