@@ -1,4 +1,8 @@
1+{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE UnboxedTuples #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+
5+-- | TODO: Implement TH based instance derivation for better performance.
26
37module Streamly.Internal.Data.Unboxed
48 ( Unbox(..)
@@ -15,16 +19,37 @@ module Streamly.Internal.Data.Unboxed
1519 , newUnpinnedBytes
1620 , newAlignedPinnedBytes
1721 , nil
22+
23+ -- * Type Parser and Builder
24+ , BoundedPtr (..)
25+
26+ , Peeker (..)
27+ , read
28+ , readUnsafe
29+ , skipByte
30+ , runPeeker
31+
32+ , pokeBoundedPtrUnsafe
33+ , pokeBoundedPtr
34+
35+ -- * Generic Unbox instances
36+ , genericSizeOf
37+ , genericPeekByteIndex
38+ , genericPokeByteIndex
39+
1840 ) where
1941
2042#include "MachDeps.h"
2143
2244#include "ArrayMacros.h"
2345
46+import Control.Monad (void, when)
2447import Data.Complex (Complex((:+)))
25−import Data.Functor ((<&>))
48+import Data.Functor ((<&>), ($>))
2649import Data.Functor.Const (Const(..))
2750import Data.Functor.Identity (Identity(..))
51+import Data.Kind (Type)
52+import Data.Proxy (Proxy (..))
2853import Foreign.Ptr (IntPtr(..), WordPtr(..))
2954import Foreign.Storable (Storable(..))
3055import GHC.Base (IO(..))
@@ -36,9 +61,13 @@ import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..))
3661#if MIN_VERSION_base(4,15,0)
3762import GHC.RTS.Flags (IoSubSystem(..))
3863#endif
64+import Streamly.Internal.Data.Builder (Builder (..))
3965import System.IO.Unsafe (unsafePerformIO)
4066
67+import GHC.Generics
4168import GHC.Exts
69+import GHC.TypeLits
70+import Prelude hiding (read)
4271
4372--------------------------------------------------------------------------------
4473-- The ArrayContents type
@@ -60,6 +89,14 @@ touch :: MutableByteArray a -> IO ()
6089touch (MutableByteArray contents) =
6190 IO $ \s -> case touch# contents s of s' -> (# s', () #)
6291
92+-- | Return the size of the array in bytes.
93+{-# INLINE sizeOfMutableByteArray #-}
94+sizeOfMutableByteArray :: MutableByteArray a -> IO Int
95+sizeOfMutableByteArray (MutableByteArray arr) =
96+ IO $ \s ->
97+ case getSizeofMutableByteArray# arr s of
98+ (# s1, i #) -> (# s1, I# i #)
99+
63100--------------------------------------------------------------------------------
64101-- Creation
65102--------------------------------------------------------------------------------
@@ -138,6 +175,12 @@ unpin arr@(MutableByteArray marr#) =
138175-- The Unbox type class
139176--------------------------------------------------------------------------------
140177
178+-- XXX Remove dependency on Storable
179+-- XXX Use Proxy type in sizeOf method.
180+-- XXX generate error if the size is < 1
181+-- XXX Remove the phantom parameter from MutableByteArray?
182+-- XXX Rename/remove castContents
183+
141184-- In theory we could convert a type to and from a byte stream and use that
142185-- to implement boxing, unboxing. But that would be inefficient. This type
143186-- class allows each primitive type to have its own specific efficient
@@ -169,6 +212,18 @@ unpin arr@(MutableByteArray marr#) =
169212-- size and alignment. We can possibly write tests for checking compatibility
170213-- with Storable.
171214
215+-- The main goal of the Unbox type class is to be used in arrays. Invariants
216+-- for the sizeOf value required for use in arrays:
217+--
218+-- * size is independent of the value, it is determined by the type only. So
219+-- that we can store values of the same type in fixed length array cells.
220+-- * size cannot be zero. So that the length of an array storing the element
221+-- and the number of elements can be related.
222+--
223+-- Note, for general serializable types the size cannot be fixed e.g. we may
224+-- want to serialize a list. This type class can be considered a special case
225+-- of a more general serialization type class.
226+
172227-- | A type implementing the 'Unbox' interface supplies operations for reading
173228-- and writing the type from and to a mutable byte array (an unboxed
174229-- representation) in memory. The read operation 'peekByteIndex' constructs the
@@ -232,9 +287,15 @@ unpin arr@(MutableByteArray marr#) =
232287class Storable a => Unbox a where
233288 -- | Read an element of type "a" from a MutableByteArray given the byte
234289 -- index.
290+ --
291+ -- IMPORTANT: The implementation of this interface may not check the bounds
292+ -- of the array, the caller must not assume that.
235293 peekByteIndex :: MutableByteArray a -> Int -> IO a
236294 -- | Write an element of type "a" to a MutableByteArray given the byte
237295 -- index.
296+ --
297+ -- IMPORTANT: The implementation of this interface may not check the bounds
298+ -- of the array, the caller must not assume that.
238299 pokeByteIndex :: MutableByteArray a -> Int -> a -> IO ()
239300
240301#define DERIVE_UNBOXED(_type, _constructor, _readArray, _writeArray) \
@@ -361,6 +422,7 @@ DERIVE_BINARY_UNBOX(forall a. Unbox a =>,(Complex a),(:+),a)
361422DERIVE_BINARY_UNBOX(forall a. (Integral a, Unbox a) =>,(Ratio a),(:%),a)
362423DERIVE_BINARY_UNBOX(,Fingerprint,Fingerprint,Word64)
363424
425+-- XXX This should have a size 1.
364426instance Unbox () where
365427
366428 {-# INLINE peekByteIndex #-}
@@ -403,3 +465,360 @@ peekWith = peekByteIndex
403465{-# INLINE pokeWith #-}
404466pokeWith :: Unbox a => MutableByteArray a -> Int -> a -> IO ()
405467pokeWith = pokeByteIndex
468+
469+--------------------------------------------------------------------------------
470+-- Generic deriving
471+--------------------------------------------------------------------------------
472+
473+-- Utilities to build or parse a type safely and easily.
474+
475+-- | A location inside a mutable byte array with the bound of the array. Is it
476+-- cheaper to just get the bound using the size of the array whenever needed?
477+data BoundedPtr =
478+ BoundedPtr
479+ (MutableByteArray Word8) -- byte array
480+ Int -- current pos
481+ Int -- position after end
482+
483+--------------------------------------------------------------------------------
484+-- Peeker monad
485+--------------------------------------------------------------------------------
486+
487+-- | Chains peek functions that pass the current position to the next function
488+newtype Peeker a = Peeker (Builder BoundedPtr IO a)
489+ deriving (Functor, Applicative, Monad)
490+
491+{-# INLINE readUnsafe #-}
492+readUnsafe :: Unbox a => Peeker a
493+readUnsafe = Peeker (Builder step)
494+
495+ where
496+
497+ {-# INLINE step #-}
498+ step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
499+ step (BoundedPtr arr pos end) = do
500+ let next = pos + sizeOf (undefined :: a)
501+ r <- peekByteIndex (castContents arr) pos
502+ return (BoundedPtr arr next end, r)
503+
504+{-# INLINE read #-}
505+read :: Unbox a => Peeker a
506+read = Peeker (Builder step)
507+
508+ where
509+
510+ {-# INLINE step #-}
511+ step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
512+ step (BoundedPtr arr pos end) = do
513+ let next = pos + sizeOf (undefined :: a)
514+ when (next > end) $ error "peekObject reading beyond limit"
515+ r <- peekByteIndex (castContents arr) pos
516+ return (BoundedPtr arr next end, r)
517+
518+{-# INLINE skipByte #-}
519+skipByte :: Peeker ()
520+skipByte = Peeker (Builder step)
521+
522+ where
523+
524+ {-# INLINE step #-}
525+ step :: BoundedPtr -> IO (BoundedPtr, ())
526+ step (BoundedPtr arr pos end) = do
527+ let next = pos + 1
528+ when (next > end) $ error "skipByte: reading beyond limit"
529+ return (BoundedPtr arr next end, ())
530+
531+{-# INLINE runPeeker #-}
532+runPeeker :: Peeker a -> BoundedPtr -> IO a
533+runPeeker (Peeker (Builder f)) ptr = fmap snd (f ptr)
534+
535+--------------------------------------------------------------------------------
536+-- Poke utilities
537+--------------------------------------------------------------------------------
538+
539+-- XXX Using a Poker monad may be useful when we have to compute the size to be
540+-- poked as we go and then poke the size at a previous location. For variable
541+-- sized object serialization we may also want to reallocate the array and
542+-- return the newly allocated array in the output.
543+
544+-- Does not check writing beyond bound.
545+{-# INLINE pokeBoundedPtrUnsafe #-}
546+pokeBoundedPtrUnsafe :: Unbox a => a -> BoundedPtr -> IO BoundedPtr
547+pokeBoundedPtrUnsafe a (BoundedPtr arr pos end) = do
548+ let next = pos + sizeOf a
549+ pokeByteIndex (castContents arr) pos a
550+ return (BoundedPtr arr next end)
551+
552+{-# INLINE pokeBoundedPtr #-}
553+pokeBoundedPtr :: Unbox a => a -> BoundedPtr -> IO BoundedPtr
554+pokeBoundedPtr a (BoundedPtr arr pos end) = do
555+ let next = pos + sizeOf a
556+ when (next > end) $ error "pokeBoundedPtr writing beyond limit"
557+ pokeByteIndex (castContents arr) pos a
558+ return (BoundedPtr arr next end)
559+
560+--------------------------------------------------------------------------------
561+-- Check the number of constructors in a sum type
562+--------------------------------------------------------------------------------
563+
564+-- Count the constructors of a sum type.
565+type family SumArity (a :: Type -> Type) :: Nat where
566+ SumArity (C1 _ _) = 1
567+ -- Requires UndecidableInstances
568+ SumArity (f :+: g) = SumArity f + SumArity g
569+
570+type family TypeErrorMessage (a :: Symbol) :: Constraint where
571+ TypeErrorMessage a = TypeError ('Text a)
572+
573+type family ArityCheck (b :: Bool) :: Constraint where
574+ ArityCheck 'True = ()
575+ ArityCheck 'False = TypeErrorMessage
576+ "Generic Unbox deriving does not support > 256 constructors."
577+
578+-- Type constraint to restrict the sum type arity so that the constructor tag
579+-- can fit in a single byte.
580+type MaxArity256 n = ArityCheck (n <=? 255)
581+
582+--------------------------------------------------------------------------------
583+-- Generic Deriving of Unbox instance
584+--------------------------------------------------------------------------------
585+
586+-- Unbox uses fixed size encoding, therefore, when a (sum) type has multiple
587+-- constructors, the size of the type is computed as the maximum required by
588+-- any constructor. Therefore, size is independent of the value, it can be
589+-- determined solely by the type.
590+
591+-- | Implementation of sizeOf that works on the generic representation of an
592+-- ADT.
593+class SizeOfRep (f :: Type -> Type) where
594+ sizeOfRep :: f x -> Int
595+
596+-- Meta information wrapper, go inside
597+instance SizeOfRep f => SizeOfRep (M1 i c f) where
598+ {-# INLINE sizeOfRep #-}
599+ sizeOfRep _ = sizeOfRep (undefined :: f x)
600+
601+-- Primitive type "a".
602+instance Unbox a => SizeOfRep (K1 i a) where
603+ {-# INLINE sizeOfRep #-}
604+ sizeOfRep _ = sizeOf (undefined :: a)
605+
606+-- Void: data type without constructors. Values of this type cannot exist,
607+-- therefore the size is undefined. We should never be serializing structures
608+-- with elements of this type.
609+instance SizeOfRep V1 where
610+ {-# INLINE sizeOfRep #-}
611+ sizeOfRep = error "sizeOfRep: a value of a Void type must not exist"
612+
613+-- Unit: constructors without arguments.
614+-- Theoretically the size can be 0, but we use 1 to simplify the implementation
615+-- of an array of unit type elements. With a non-zero size we can count the number
616+-- of elements in the array based on the size of the array. Otherwise we will
617+-- have to store a virtual length in the array, but keep the physical size of
618+-- the array as 0. Or we will have to make a special handling for zero sized
619+-- elements to make the size as 1. Or we can disallow arrays with elements
620+-- having size 0.
621+--
622+-- Note that when a sum type has many unit constructors only a single byte is
623+-- required to encode the type as only the constructor tag is stored.
624+instance SizeOfRep U1 where
625+ {-# INLINE sizeOfRep #-}
626+ sizeOfRep _ = 1
627+
628+-- Product type
629+instance (SizeOfRep f, SizeOfRep g) => SizeOfRep (f :*: g) where
630+ {-# INLINE sizeOfRep #-}
631+ sizeOfRep _ = sizeOfRep (undefined :: f x) + sizeOfRep (undefined :: g x)
632+
633+-------------------------------------------------------------------------------
634+
635+class SizeOfRepSum (f :: Type -> Type) where
636+ sizeOfRepSum :: f x -> Int
637+
638+-- Constructor
639+instance SizeOfRep a => SizeOfRepSum (C1 c a) where
640+ {-# INLINE sizeOfRepSum #-}
641+ sizeOfRepSum = sizeOfRep
642+
643+instance (SizeOfRepSum f, SizeOfRepSum g) => SizeOfRepSum (f :+: g) where
644+ {-# INLINE sizeOfRepSum #-}
645+ sizeOfRepSum _ =
646+ max (sizeOfRepSum (undefined :: f x)) (sizeOfRepSum (undefined :: g x))
647+
648+-------------------------------------------------------------------------------
649+
650+instance (MaxArity256 (SumArity (f :+: g)), SizeOfRepSum f, SizeOfRepSum g) =>
651+ SizeOfRep (f :+: g) where
652+
653+ -- The size of a sum type is the max of any of the constructor size.
654+ -- sizeOfRepSum type class operation is used here instead of sizeOfRep so
655+ -- that we add the constructor index byte only for the first time and avoid
656+ -- including it for the subsequent sum constructors.
657+ {-# INLINE sizeOfRep #-}
658+ sizeOfRep _ =
659+ -- One byte for the constructor id and then the constructor value.
660+ sizeOf (undefined :: Word8) +
661+ max (sizeOfRepSum (undefined :: f x))
662+ (sizeOfRepSum (undefined :: g x))
663+
664+{-# INLINE genericSizeOf #-}
665+genericSizeOf :: forall a. (SizeOfRep (Rep a)) => Proxy a -> Int
666+genericSizeOf _ = sizeOfRep (undefined :: Rep a x)
667+
668+--------------------------------------------------------------------------------
669+-- Generic poke
670+--------------------------------------------------------------------------------
671+
672+class PokeRep (f :: Type -> Type) where
673+ pokeRep :: f a -> BoundedPtr -> IO BoundedPtr
674+
675+instance PokeRep f => PokeRep (M1 i c f) where
676+ {-# INLINE pokeRep #-}
677+ pokeRep f = pokeRep (unM1 f)
678+
679+instance Unbox a => PokeRep (K1 i a) where
680+ {-# INLINE pokeRep #-}
681+ pokeRep a = pokeBoundedPtr (unK1 a)
682+
683+instance PokeRep V1 where
684+ {-# INLINE pokeRep #-}
685+ pokeRep = error "pokeRep: a value of a Void type should not exist"
686+
687+instance PokeRep U1 where
688+ {-# INLINE pokeRep #-}
689+ -- XXX Can we use sizeof U1 to determine the size?
690+ pokeRep _ (BoundedPtr arr pos end) =
691+ return (BoundedPtr arr (pos + 1) end)
692+
693+instance (PokeRep f, PokeRep g) => PokeRep (f :*: g) where
694+ {-# INLINE pokeRep #-}
695+ pokeRep (f :*: g) ptr = pokeRep f ptr >>= pokeRep g
696+
697+-------------------------------------------------------------------------------
698+
699+class KnownNat n => PokeRepSum (n :: Nat) (f :: Type -> Type) where
700+ -- "n" is the constructor tag to be poked.
701+ pokeRepSum :: Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
702+
703+instance (KnownNat n, PokeRep a) => PokeRepSum n (C1 c a) where
704+ {-# INLINE pokeRepSum #-}
705+ pokeRepSum _ x ptr = do
706+ pokeBoundedPtr (fromInteger (natVal (Proxy :: Proxy n)) :: Word8) ptr
707+ >>= pokeRep x
708+
709+instance (KnownNat n, PokeRepSum n f, PokeRepSum (n + SumArity f) g)
710+ => PokeRepSum n (f :+: g) where
711+ {-# INLINE pokeRepSum #-}
712+ pokeRepSum _ (L1 x) ptr =
713+ pokeRepSum (Proxy :: Proxy n) x ptr
714+ pokeRepSum _ (R1 x) ptr =
715+ pokeRepSum (Proxy :: Proxy (n + SumArity f)) x ptr
716+
717+-------------------------------------------------------------------------------
718+
719+instance (MaxArity256 (SumArity (f :+: g)), PokeRepSum 0 (f :+: g)) =>
720+ PokeRep (f :+: g) where
721+
722+ {-# INLINE pokeRep #-}
723+ pokeRep = pokeRepSum (Proxy :: Proxy 0)
724+
725+{-# INLINE genericPokeObject #-}
726+genericPokeObject :: (Generic a, PokeRep (Rep a)) =>
727+ a -> BoundedPtr -> IO BoundedPtr
728+genericPokeObject a = pokeRep (from a)
729+
730+genericPokeObj :: (Generic a, PokeRep (Rep a)) => a -> BoundedPtr -> IO ()
731+genericPokeObj a ptr = void $ genericPokeObject a ptr
732+
733+{-# INLINE genericPokeByteIndex #-}
734+genericPokeByteIndex :: (Generic a, PokeRep (Rep a)) =>
735+ MutableByteArray a -> Int -> a -> IO ()
736+genericPokeByteIndex arr index x = do
737+ -- XXX Should we use unsafe poke?
738+ end <- sizeOfMutableByteArray arr
739+ genericPokeObj x (BoundedPtr (castContents arr) index end)
740+
741+--------------------------------------------------------------------------------
742+-- Generic peek
743+--------------------------------------------------------------------------------
744+
745+class PeekRep (f :: Type -> Type) where
746+ peekRep :: Peeker (f x)
747+
748+instance PeekRep f => PeekRep (M1 i c f) where
749+ {-# INLINE peekRep #-}
750+ peekRep = fmap M1 peekRep
751+
752+instance Unbox a => PeekRep (K1 i a) where
753+ {-# INLINE peekRep #-}
754+ peekRep = fmap K1 read
755+
756+instance PeekRep V1 where
757+ {-# INLINE peekRep #-}
758+ peekRep = error "peekRep: a value of a Void type should not exist"
759+
760+instance PeekRep U1 where
761+ {-# INLINE peekRep #-}
762+ peekRep = skipByte $> U1
763+
764+instance (PeekRep f, PeekRep g) => PeekRep (f :*: g) where
765+ {-# INLINE peekRep #-}
766+ peekRep = (:*:) <$> peekRep <*> peekRep
767+
768+-------------------------------------------------------------------------------
769+
770+class KnownNat n => PeekRepSum (n :: Nat) (f :: Type -> Type) where
771+ -- "n" is the constructor tag to be matched.
772+ peekRepSum :: Proxy n -> Word8 -> Peeker (f a)
773+
774+instance (KnownNat n, PeekRep a) => PeekRepSum n (C1 c a) where
775+ {-# INLINE peekRepSum #-}
776+ peekRepSum _ tag
777+ | tag == curTag = peekRep
778+ | tag > curTag =
779+ error $ "Unbox instance peek: Constructor tag index "
780+ ++ show tag ++ " out of range, max tag index is "
781+ ++ show curTag
782+ | otherwise = error "peekRepSum: bug"
783+
784+ where
785+
786+ curTag = fromInteger (natVal (Proxy :: Proxy n))
787+
788+instance (KnownNat n, PeekRepSum n f, PeekRepSum (n + SumArity f) g)
789+ => PeekRepSum n (f :+: g) where
790+ {-# INLINE peekRepSum #-}
791+ peekRepSum curProxy tag
792+ | tag < firstRightTag =
793+ L1 <$> peekRepSum curProxy tag
794+ | otherwise =
795+ R1 <$> peekRepSum (Proxy :: Proxy (n + SumArity f)) tag
796+
797+ where
798+
799+ firstRightTag = fromInteger (natVal (Proxy :: Proxy (n + SumArity f)))
800+
801+-------------------------------------------------------------------------------
802+
803+instance (MaxArity256 (SumArity (f :+: g)), PeekRepSum 0 (f :+: g))
804+ => PeekRep (f :+: g) where
805+ {-# INLINE peekRep #-}
806+ peekRep = do
807+ tag <- read
808+ peekRepSum (Proxy :: Proxy 0) tag
809+
810+{-# INLINE genericPeeker #-}
811+genericPeeker :: (Generic a, PeekRep (Rep a)) => Peeker a
812+genericPeeker = to <$> peekRep
813+
814+{-# INLINE genericPeekBoundedPtr #-}
815+genericPeekBoundedPtr :: (Generic a, PeekRep (Rep a)) => BoundedPtr -> IO a
816+genericPeekBoundedPtr = runPeeker genericPeeker
817+
818+{-# INLINE genericPeekByteIndex #-}
819+genericPeekByteIndex :: (Generic a, PeekRep (Rep a)) =>
820+ MutableByteArray a -> Int -> IO a
821+genericPeekByteIndex arr index = do
822+ -- XXX Should we use unsafe peek?
823+ end <- sizeOfMutableByteArray arr
824+ genericPeekBoundedPtr (BoundedPtr (castContents arr) index end)