Initial version

Control/Monad/Primitive.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, TypeFamilies #-}
+
+-- |
+-- Module      : Control.Monad.Primitive
+-- Copyright   : (c) Roman Leshchinskiy 2009
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+-- 
+-- Primitive state-transformer monads
+--
+
+module Control.Monad.Primitive ( PrimMonad(..), primitive_ ) where
+
+import GHC.Prim   ( State#, RealWorld )
+import GHC.IOBase ( IO(..) )
+import GHC.ST     ( ST(..) )
+
+-- | Class of primitive state-transformer monads
+class Monad m => PrimMonad m where
+  -- | State token type
+  type PrimState m
+
+  -- | Execute a primitive operation
+  primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+
+-- | Execute a primitive operation with no result
+primitive_ :: PrimMonad m
+              => (State# (PrimState m) -> State# (PrimState m)) -> m ()
+{-# INLINE primitive_ #-}
+primitive_ f = primitive (\s# -> (# f s#, () #))
+
+instance PrimMonad IO where
+  type PrimState IO = RealWorld
+  primitive = IO
+
+instance PrimMonad (ST s) where
+  type PrimState (ST s) = s
+  primitive = ST
+

Data/Primitive/Addr.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+module Data.Primitive.Addr (
+  Addr(..),
+
+  nullAddr, plusAddr, minusAddr, remAddr,
+  indexOffAddr, readOffAddr, writeOffAddr
+) where
+
+import Control.Monad.Primitive
+import Data.Primitive.Types
+
+import GHC.Base ( Int(..) )
+import GHC.Prim
+
+instance Eq Addr where
+  Addr a# == Addr b# = eqAddr# a# b#
+  Addr a# /= Addr b# = neAddr# a# b#
+
+instance Ord Addr where
+  Addr a# > Addr b# = gtAddr# a# b#
+  Addr a# >= Addr b# = geAddr# a# b#
+  Addr a# < Addr b# = ltAddr# a# b#
+  Addr a# <= Addr b# = leAddr# a# b#
+
+nullAddr :: Addr
+nullAddr = Addr nullAddr#
+
+infixl 6 `plusAddr`, `minusAddr`
+infixl 7 `remAddr`
+
+plusAddr :: Addr -> Int -> Addr
+plusAddr (Addr a#) (I# i#) = Addr (plusAddr# a# i#)
+
+minusAddr :: Addr -> Addr -> Int
+minusAddr (Addr a#) (Addr b#) = I# (minusAddr# a# b#)
+
+remAddr :: Addr -> Int -> Int
+remAddr (Addr a#) (I# i#) = I# (remAddr# a# i#)
+
+indexOffAddr :: Prim a => Addr -> Int -> a
+{-# INLINE indexOffAddr #-}
+indexOffAddr (Addr addr#) (I# i#) = indexOffAddr# addr# i#
+
+readOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> m a
+{-# INLINE readOffAddr #-}
+readOffAddr (Addr addr#) (I# i#) = primitive (readOffAddr# addr# i#)
+
+writeOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m ()
+{-# INLINE writeOffAddr #-}
+writeOffAddr (Addr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x)
+

Data/Primitive/Array.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+module Data.Primitive.Array (
+  Array(..), MutableArray(..),
+
+  newArray, readArray, writeArray, indexArray,
+  unsafeFreezeArray, unsafeThawArray, sameMutableArray
+) where
+
+import Control.Monad.Primitive
+
+import GHC.Base  ( Int(..) )
+import GHC.Prim
+
+data Array a = Array (Array# a)
+data MutableArray m a = MutableArray (MutableArray# (PrimState m) a)
+
+newArray :: PrimMonad m => Int -> a -> m (MutableArray m a)
+newArray (I# n#) x = primitive
+   (\s# -> case newArray# n# x s# of
+             (# s'#, arr# #) -> (# s'#, MutableArray arr# #))
+
+readArray :: PrimMonad m => MutableArray m a -> Int -> m a
+readArray (MutableArray arr#) (I# i#) = primitive (readArray# arr# i#)
+
+writeArray :: PrimMonad m => MutableArray m a -> Int -> a -> m ()
+writeArray (MutableArray arr#) (I# i#) x = primitive_ (writeArray# arr# i# x)
+
+indexArray :: Array a -> Int -> (a -> b) -> b
+indexArray (Array arr#) (I# i#) f = case indexArray# arr# i# of (# x #) -> f x
+
+unsafeFreezeArray :: PrimMonad m => MutableArray m a -> m (Array a)
+unsafeFreezeArray (MutableArray arr#)
+  = primitive (\s# -> case unsafeFreezeArray# arr# s# of
+                        (# s'#, arr'# #) -> (# s'#, Array arr'# #))
+
+unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray m a)
+unsafeThawArray (Array arr#)
+  = primitive (\s# -> case unsafeThawArray# arr# s# of
+                        (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #))
+
+sameMutableArray :: MutableArray m a -> MutableArray m a -> Bool
+sameMutableArray (MutableArray arr#) (MutableArray brr#)
+  = sameMutableArray# arr# brr#
+

Data/Primitive/ByteArray.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+module Data.Primitive.ByteArray (
+  ByteArray(..), MutableByteArray(..),
+
+  newByteArray, newPinnedByteArray, newAlignedPinnedByteArray,
+  readByteArray, writeByteArray, indexByteArray,
+  unsafeFreezeByteArray,
+  sizeofByteArray, sizeofMutableByteArray, sameMutableByteArray,
+  byteArrayContents
+) where
+
+import Control.Monad.Primitive
+import Data.Primitive.Types
+
+import GHC.Base ( Int(..) )
+import GHC.Prim
+
+data ByteArray = ByteArray ByteArray#
+data MutableByteArray m = MutableByteArray (MutableByteArray# (PrimState m))
+
+newByteArray :: PrimMonad m => Int -> m (MutableByteArray m)
+newByteArray (I# n#)
+  = primitive (\s# -> case newByteArray# n# s# of
+                        (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray m)
+newPinnedByteArray (I# n#)
+  = primitive (\s# -> case newPinnedByteArray# n# s# of
+                        (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+newAlignedPinnedByteArray :: PrimMonad m => Int -> Int -> m (MutableByteArray m)
+newAlignedPinnedByteArray (I# n#) (I# k#)
+  = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of
+                        (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+byteArrayContents :: ByteArray -> Addr
+byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#)
+
+sameMutableByteArray :: MutableByteArray m -> MutableByteArray m -> Bool
+sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#)
+  = sameMutableByteArray# arr# brr#
+
+unsafeFreezeByteArray :: PrimMonad m => MutableByteArray m -> m ByteArray
+unsafeFreezeByteArray (MutableByteArray arr#)
+  = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of
+                        (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #))
+
+sizeofByteArray :: ByteArray -> Int
+sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#)
+
+sizeofMutableByteArray :: MutableByteArray s -> Int
+sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#)
+
+indexByteArray :: Prim a => ByteArray -> Int -> a
+indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i#
+
+readByteArray :: (Prim a, PrimMonad m)
+              => MutableByteArray m -> Int -> m a
+readByteArray (MutableByteArray arr#) (I# i#)
+  = primitive (readByteArray# arr# i#)
+
+writeByteArray :: (Prim a, PrimMonad m)
+               => MutableByteArray m -> Int -> a -> m ()
+writeByteArray (MutableByteArray arr#) (I# i#) x
+  = primitive (\s# -> (# writeByteArray# arr# i# x s#, () #))
+

Data/Primitive/MachDeps.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE CPP #-}
+
+-- |
+-- Module      : Data.Primitive.MachDeps
+-- Copyright   : (c) Roman Leshchinskiy 2009
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+-- 
+-- Machine-dependent constants
+--
+
+module Data.Primitive.MachDeps where
+
+#include "MachDeps.h"
+
+sIZEOF_CHAR,
+ aLIGNMENT_CHAR,
+
+ sIZEOF_INT,
+ aLIGNMENT_INT,
+
+ sIZEOF_WORD,
+ aLIGNMENT_WORD,
+
+ sIZEOF_DOUBLE,
+ aLIGNMENT_DOUBLE,
+
+ sIZEOF_FLOAT,
+ aLIGNMENT_FLOAT,
+
+ sIZEOF_PTR,
+ aLIGNMENT_PTR,
+
+ sIZEOF_FUNPTR,
+ aLIGNMENT_FUNPTR,
+
+ sIZEOF_STABLEPTR,
+ aLIGNMENT_STABLEPTR,
+
+ sIZEOF_INT8,
+ aLIGNMENT_INT8,
+
+ sIZEOF_WORD8,
+ aLIGNMENT_WORD8,
+
+ sIZEOF_INT16,
+ aLIGNMENT_INT16,
+
+ sIZEOF_WORD16,
+ aLIGNMENT_WORD16,
+
+ sIZEOF_INT32,
+ aLIGNMENT_INT32,
+
+ sIZEOF_WORD32,
+ aLIGNMENT_WORD32,
+
+ sIZEOF_INT64,
+ aLIGNMENT_INT64,
+
+ sIZEOF_WORD64,
+ aLIGNMENT_WORD64 :: Int
+
+
+sIZEOF_CHAR = SIZEOF_HSCHAR
+aLIGNMENT_CHAR = ALIGNMENT_HSCHAR
+
+sIZEOF_INT = SIZEOF_HSINT
+aLIGNMENT_INT = ALIGNMENT_HSINT
+
+sIZEOF_WORD = SIZEOF_HSWORD
+aLIGNMENT_WORD = ALIGNMENT_HSWORD
+
+sIZEOF_DOUBLE = SIZEOF_HSDOUBLE
+aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE
+
+sIZEOF_FLOAT = SIZEOF_HSFLOAT
+aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT
+
+sIZEOF_PTR = SIZEOF_HSPTR
+aLIGNMENT_PTR = ALIGNMENT_HSPTR
+
+sIZEOF_FUNPTR = SIZEOF_HSFUNPTR
+aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR
+
+sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR
+aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR
+
+sIZEOF_INT8 = SIZEOF_INT8
+aLIGNMENT_INT8 = ALIGNMENT_INT8
+
+sIZEOF_WORD8 = SIZEOF_WORD8
+aLIGNMENT_WORD8 = ALIGNMENT_WORD8
+
+sIZEOF_INT16 = SIZEOF_INT16
+aLIGNMENT_INT16 = ALIGNMENT_INT16
+
+sIZEOF_WORD16 = SIZEOF_WORD16
+aLIGNMENT_WORD16 = ALIGNMENT_WORD16
+
+sIZEOF_INT32 = SIZEOF_INT32
+aLIGNMENT_INT32 = ALIGNMENT_INT32
+
+sIZEOF_WORD32 = SIZEOF_WORD32
+aLIGNMENT_WORD32 = ALIGNMENT_WORD32
+
+sIZEOF_INT64 = SIZEOF_INT64
+aLIGNMENT_INT64 = ALIGNMENT_INT64
+
+sIZEOF_WORD64 = SIZEOF_WORD64
+aLIGNMENT_WORD64 = ALIGNMENT_WORD64
+