-- XXX: deactivate orphan instance warning as we're defining a few Storable
-- instances here. It's not worth fixing as I [aspiwack] intend to change the
-- interface for something more appropriate, which won't require these Storable
-- instances.
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}

module Foreign.Marshal.Pure.Internal where

import Control.Exception
import qualified Data.Functor.Linear as Data
import Data.Kind (Constraint, Type)
import Data.Word (Word8)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import Foreign.Storable.Tuple ()
import Prelude.Linear hiding (Eq (..))
import System.IO.Unsafe
import qualified Unsafe.Linear as Unsafe
import Prelude (Eq (..), return, (<$>), (<*>), (=<<))

-- XXX: [2018-02-09] I'm having trouble with the `constraints` package (it seems
-- that the version of Type.Reflection.Unsafe in the linear ghc compiler is not
-- the one that was released with 8.2, and that `mtl` fails to compile against
-- it), therefore, I'm redefining `Dict` here, as it's cheap.
data Dict :: Constraint -> Type where
  Dict :: (c) => Dict c

-- TODO: organise into sections

-- | This abstract type class represents values natively known to have a GC-less
-- implementation. Basically, these are sequences (represented as tuples) of
-- base types.
class KnownRepresentable a where
  storable :: Dict (Storable a)
  default storable :: (Storable a) => Dict (Storable a)
  storable = Dict (Storable a)
forall (c :: Constraint). c => Dict c
Dict

-- This ought to be read a `newtype` around `Storable`. This type is abstract,
-- because using Storable this way is highly unsafe: Storable uses IO so we
-- will call unsafePerformIO, and Storable doesn't guarantee linearity. But
-- Storable comes with a lot of machinery, in particular for
-- architecture-independent alignment. So we can depend on it.
--
-- So, we restrict ourselves to known instances that we trust. For base types
-- there is no reason to expect problems. Tuples are a bit more subtle in that
-- they use non-linear operations. But the way they are used should be ok. At
-- any rate: in case a bug is found, the tuple instances are a good place to
-- look.

instance KnownRepresentable Word -- TODO: more word types

instance KnownRepresentable Int

instance KnownRepresentable (Ptr a)

instance KnownRepresentable ()

instance
  (KnownRepresentable a, KnownRepresentable b) =>
  KnownRepresentable (a, b)
  where
  storable :: Dict (Storable (a, b))
storable =
    case (forall a. KnownRepresentable a => Dict (Storable a)
storable @a, forall a. KnownRepresentable a => Dict (Storable a)
storable @b) of
      (Dict (Storable a)
Dict, Dict (Storable b)
Dict) -> Dict (Storable (a, b))
forall (c :: Constraint). c => Dict c
Dict

instance
  (KnownRepresentable a, KnownRepresentable b, KnownRepresentable c) =>
  KnownRepresentable (a, b, c)
  where
  storable :: Dict (Storable (a, b, c))
storable =
    case (forall a. KnownRepresentable a => Dict (Storable a)
storable @a, forall a. KnownRepresentable a => Dict (Storable a)
storable @b, forall a. KnownRepresentable a => Dict (Storable a)
storable @c) of
      (Dict (Storable a)
Dict, Dict (Storable b)
Dict, Dict (Storable c)
Dict) -> Dict (Storable (a, b, c))
forall (c :: Constraint). c => Dict c
Dict

-- TODO: move to the definition of Ur
instance (Storable a) => Storable (Ur a) where
  sizeOf :: Ur a -> Int
sizeOf Ur a
_ = a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
  alignment :: Ur a -> Int
alignment Ur a
_ = a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)
  peek :: Ptr (Ur a) -> IO (Ur a)
peek Ptr (Ur a)
ptr = a -> Ur a
forall a. a -> Ur a
Ur (a -> Ur a) -> IO a -> IO (Ur a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr (Ur a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ur a)
ptr :: Ptr a)
  poke :: Ptr (Ur a) -> Ur a -> IO ()
poke Ptr (Ur a)
ptr (Ur a
a) = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (Ur a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ur a)
ptr :: Ptr a) a
a

instance (KnownRepresentable a) => KnownRepresentable (Ur a) where
  storable :: Dict (Storable (Ur a))
storable | Dict (Storable a)
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @a = Dict (Storable (Ur a))
forall (c :: Constraint). c => Dict c
Dict

-- Below is a KnownRepresentable instance for Maybe. The Storable instance is
-- taken from
-- https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe
--
-- aspiwack: This does not yield very good data representation for the general
-- case. But I believe that to improve on it we need to rethink the abstraction
-- in more depths.

instance (Storable a) => Storable (Maybe a) where
  sizeOf :: Maybe a -> Int
sizeOf Maybe a
x = a -> Int
forall a. Storable a => a -> Int
sizeOf (Maybe a -> a
forall a. Maybe a -> a
stripMaybe Maybe a
x) Int %1 -> Int %1 -> Int
forall a. Additive a => a %1 -> a %1 -> a
+ Int
1
  alignment :: Maybe a -> Int
alignment Maybe a
x = a -> Int
forall a. Storable a => a -> Int
alignment (Maybe a -> a
forall a. Maybe a -> a
stripMaybe Maybe a
x)
  peek :: Ptr (Maybe a) -> IO (Maybe a)
peek Ptr (Maybe a)
ptr = do
    Word8
filled <- Ptr (Maybe a) -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (Maybe a)
ptr (Int -> IO Word8) -> Int -> IO Word8
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ a -> Int
forall a. Storable a => a -> Int
sizeOf (a -> Int) -> a -> Int
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ Maybe a -> a
forall a. Maybe a -> a
stripMaybe (Maybe a -> a) -> Maybe a -> a
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ Ptr (Maybe a) -> Maybe a
forall a. Ptr a -> a
stripPtr Ptr (Maybe a)
ptr
    case Word8
filled Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word8
1 :: Word8) of
      Bool
True -> do
        a
x <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr (Maybe a) -> Ptr a
forall a. Ptr (Maybe a) -> Ptr a
stripMaybePtr Ptr (Maybe a)
ptr)
        Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
      Bool
False ->
        Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
  poke :: Ptr (Maybe a) -> Maybe a -> IO ()
poke Ptr (Maybe a)
ptr Maybe a
Nothing = Ptr (Maybe a) -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Maybe a)
ptr (a -> Int
forall a. Storable a => a -> Int
sizeOf (a -> Int) -> a -> Int
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ Maybe a -> a
forall a. Maybe a -> a
stripMaybe (Maybe a -> a) -> Maybe a -> a
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ Ptr (Maybe a) -> Maybe a
forall a. Ptr a -> a
stripPtr Ptr (Maybe a)
ptr) (Word8
0 :: Word8)
  poke Ptr (Maybe a)
ptr (Just a
a) = do
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (Maybe a) -> Ptr a
forall a. Ptr (Maybe a) -> Ptr a
stripMaybePtr Ptr (Maybe a)
ptr) a
a
    Ptr (Maybe a) -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Maybe a)
ptr (a -> Int
forall a. Storable a => a -> Int
sizeOf a
a) (Word8
1 :: Word8)

stripMaybe :: Maybe a -> a
stripMaybe :: forall a. Maybe a -> a
stripMaybe Maybe a
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"stripMaybe"

stripMaybePtr :: Ptr (Maybe a) -> Ptr a
stripMaybePtr :: forall a. Ptr (Maybe a) -> Ptr a
stripMaybePtr = Ptr (Maybe a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr

stripPtr :: Ptr a -> a
stripPtr :: forall a. Ptr a -> a
stripPtr Ptr a
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"stripPtr"

instance (KnownRepresentable a) => KnownRepresentable (Maybe a) where
  storable :: Dict (Storable (Maybe a))
storable | Dict (Storable a)
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @a = Dict (Storable (Maybe a))
forall (c :: Constraint). c => Dict c
Dict

-- | Laws of 'Representable':
--
-- * 'toKnown' must be total
-- * 'ofKnown' may be partial, but must be total on the image of 'toKnown'
-- * @ofKnown . toKnown == id@
class (KnownRepresentable (AsKnown a)) => Representable a where
  type AsKnown a :: Type

  toKnown :: a %1 -> AsKnown a
  ofKnown :: AsKnown a %1 -> a

  default toKnown ::
    (MkRepresentable a b, AsKnown a ~ AsKnown b) => a %1 -> AsKnown a
  default ofKnown ::
    (MkRepresentable a b, AsKnown a ~ AsKnown b) => AsKnown a %1 -> a

  toKnown a
a = b %1 -> AsKnown b
forall a. Representable a => a %1 -> AsKnown a
toKnown (a %1 -> b
forall a b. MkRepresentable a b => a %1 -> b
toRepr a
a)
  ofKnown AsKnown a
b = b %1 -> a
forall a b. MkRepresentable a b => b %1 -> a
ofRepr (AsKnown b %1 -> b
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
AsKnown b
b)

-- Some boilerplate: all the KnownRepresentable are Representable, by virtue of
-- the identity being a retraction. We generalise a bit for the types of tuples:
-- tuples of Representable (not only KnownRepresentable) are Representable.
instance Representable Word where
  type AsKnown Word = Word
  toKnown :: Word %1 -> AsKnown Word
toKnown = Word %1 -> Word
Word %1 -> AsKnown Word
forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown Word %1 -> Word
ofKnown = Word %1 -> Word
AsKnown Word %1 -> Word
forall a (q :: Multiplicity). a %q -> a
id

instance Representable Int where
  type AsKnown Int = Int
  toKnown :: Int %1 -> AsKnown Int
toKnown = Int %1 -> Int
Int %1 -> AsKnown Int
forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown Int %1 -> Int
ofKnown = Int %1 -> Int
AsKnown Int %1 -> Int
forall a (q :: Multiplicity). a %q -> a
id

instance Representable (Ptr a) where
  type AsKnown (Ptr a) = Ptr a
  toKnown :: Ptr a %1 -> AsKnown (Ptr a)
toKnown = Ptr a %1 -> Ptr a
Ptr a %1 -> AsKnown (Ptr a)
forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown (Ptr a) %1 -> Ptr a
ofKnown = Ptr a %1 -> Ptr a
AsKnown (Ptr a) %1 -> Ptr a
forall a (q :: Multiplicity). a %q -> a
id

instance Representable () where
  type AsKnown () = ()
  toKnown :: () %1 -> AsKnown ()
toKnown = () %1 -> ()
() %1 -> AsKnown ()
forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown () %1 -> ()
ofKnown = () %1 -> ()
AsKnown () %1 -> ()
forall a (q :: Multiplicity). a %q -> a
id

instance
  (Representable a, Representable b) =>
  Representable (a, b)
  where
  type AsKnown (a, b) = (AsKnown a, AsKnown b)
  toKnown :: (a, b) %1 -> AsKnown (a, b)
toKnown (a
a, b
b) = (a %1 -> AsKnown a
forall a. Representable a => a %1 -> AsKnown a
toKnown a
a, b %1 -> AsKnown b
forall a. Representable a => a %1 -> AsKnown a
toKnown b
b)
  ofKnown :: AsKnown (a, b) %1 -> (a, b)
ofKnown (AsKnown a
x, AsKnown b
y) = (AsKnown a %1 -> a
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
x, AsKnown b %1 -> b
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown b
y)

instance
  (Representable a, Representable b, Representable c) =>
  Representable (a, b, c)
  where
  type AsKnown (a, b, c) = (AsKnown a, AsKnown b, AsKnown c)
  toKnown :: (a, b, c) %1 -> AsKnown (a, b, c)
toKnown (a
a, b
b, c
c) = (a %1 -> AsKnown a
forall a. Representable a => a %1 -> AsKnown a
toKnown a
a, b %1 -> AsKnown b
forall a. Representable a => a %1 -> AsKnown a
toKnown b
b, c %1 -> AsKnown c
forall a. Representable a => a %1 -> AsKnown a
toKnown c
c)
  ofKnown :: AsKnown (a, b, c) %1 -> (a, b, c)
ofKnown (AsKnown a
x, AsKnown b
y, AsKnown c
z) = (AsKnown a %1 -> a
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
x, AsKnown b %1 -> b
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown b
y, AsKnown c %1 -> c
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown c
z)

instance (Representable a) => Representable (Maybe a) where
  type AsKnown (Maybe a) = Maybe (AsKnown a)
  toKnown :: Maybe a %1 -> AsKnown (Maybe a)
toKnown (Just a
x) = AsKnown a -> Maybe (AsKnown a)
forall a. a -> Maybe a
Just (a %1 -> AsKnown a
forall a. Representable a => a %1 -> AsKnown a
toKnown a
x)
  toKnown Maybe a
Nothing = Maybe (AsKnown a)
AsKnown (Maybe a)
forall a. Maybe a
Nothing
  ofKnown :: AsKnown (Maybe a) %1 -> Maybe a
ofKnown (Just AsKnown a
x) = a -> Maybe a
forall a. a -> Maybe a
Just (AsKnown a %1 -> a
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
x)
  ofKnown Maybe (AsKnown a)
AsKnown (Maybe a)
Nothing = Maybe a
forall a. Maybe a
Nothing

-- | This is an easier way to create an instance of 'Representable'. It is a bit
-- abusive to use a type class for this (after all, it almost never makes sense
-- to use this as a constraint). But it works in practice.
--
-- To use, define an instance of @MkRepresentable <myType> <intermediateType>@
-- then declare the following instance:
--
-- @instance Representable <myType> where {type AsKnown = AsKnown <intermediateType>}@
--
-- And the default instance mechanism will create the appropriate
-- 'Representable' instance.
--
-- Laws of 'MkRepresentable':
--
-- * 'toRepr' must be total
-- * 'ofRepr' may be partial, but must be total on the image of 'toRepr'
-- * @ofRepr . toRepr = id@
class (Representable b) => MkRepresentable a b | a -> b where
  toRepr :: a %1 -> b
  ofRepr :: b %1 -> a

-- TODO: Briefly explain the Dupable-reader style of API, below, and fix
-- details.

-- | Pools represent collections of values. A 'Pool' can be 'consume'-ed. This
-- is a no-op: it does not deallocate the data in that pool. It cannot do so,
-- because accessible values might still exist. Consuming a pool simply makes it
-- impossible to add new data to the pool.
data Pool where
  Pool :: DLL (Ptr ()) -> Pool

-- /!\ Black magic: the pointers in the pool are only used to deallocate
-- dangling pointers. Therefore their 'sizeOf' does not matter. It is simpler
-- to cast all the pointers to some canonical type (here `Ptr ()`) so that we
-- don't have to deal with heterogeneous types. /!\

-- Implementing a doubly-linked list with `Ptr`

data DLL a = DLL {forall a. DLL a -> Ptr (DLL a)
prev :: Ptr (DLL a), forall a. DLL a -> Ptr a
elt :: Ptr a, forall a. DLL a -> Ptr (DLL a)
next :: Ptr (DLL a)}
  deriving (DLL a -> DLL a -> Bool
(DLL a -> DLL a -> Bool) -> (DLL a -> DLL a -> Bool) -> Eq (DLL a)
forall a. DLL a -> DLL a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. DLL a -> DLL a -> Bool
== :: DLL a -> DLL a -> Bool
$c/= :: forall a. DLL a -> DLL a -> Bool
/= :: DLL a -> DLL a -> Bool
Eq)

-- XXX: probably replaceable by storable-generic
instance Storable (DLL a) where
  sizeOf :: DLL a -> Int
sizeOf DLL a
_ = (Ptr (DLL a), Ptr a, Ptr (DLL a)) -> Int
forall a. Storable a => a -> Int
sizeOf ((Ptr (DLL a), Ptr a, Ptr (DLL a))
forall a. HasCallStack => a
undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))
  alignment :: DLL a -> Int
alignment DLL a
_ = (Ptr (DLL a), Ptr a, Ptr (DLL a)) -> Int
forall a. Storable a => a -> Int
alignment ((Ptr (DLL a), Ptr a, Ptr (DLL a))
forall a. HasCallStack => a
undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))

  peek :: Ptr (DLL a) -> IO (DLL a)
peek Ptr (DLL a)
ptr = do
    (Ptr (DLL a)
p, Ptr a
e, Ptr (DLL a)
n) <- Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))
-> IO (Ptr (DLL a), Ptr a, Ptr (DLL a))
forall a. Storable a => Ptr a -> IO a
peek (Ptr (DLL a) -> Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))
forall a b. Ptr a -> Ptr b
castPtr Ptr (DLL a)
ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a)))
    DLL a -> IO (DLL a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DLL a -> IO (DLL a)) -> DLL a -> IO (DLL a)
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL Ptr (DLL a)
p Ptr a
e Ptr (DLL a)
n

  poke :: Ptr (DLL a) -> DLL a -> IO ()
poke Ptr (DLL a)
ptr (DLL Ptr (DLL a)
p Ptr a
e Ptr (DLL a)
n) =
    Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))
-> (Ptr (DLL a), Ptr a, Ptr (DLL a)) -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (DLL a) -> Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))
forall a b. Ptr a -> Ptr b
castPtr Ptr (DLL a)
ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))) (Ptr (DLL a)
p, Ptr a
e, Ptr (DLL a)
n)

-- Precondition: in `insertAfter start ptr`, `next start` must be initalised,
-- and so must be `prev =<< peek (next start)`
insertAfter :: (Storable a) => DLL a -> a -> IO (Ptr (DLL a))
insertAfter :: forall a. Storable a => DLL a -> a -> IO (Ptr (DLL a))
insertAfter DLL a
start a
ptr = do
  DLL a
secondLink <- Ptr (DLL a) -> IO (DLL a)
forall a. Storable a => Ptr a -> IO a
peek (Ptr (DLL a) -> IO (DLL a)) -> Ptr (DLL a) -> IO (DLL a)
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ DLL a -> Ptr (DLL a)
forall a. DLL a -> Ptr (DLL a)
next DLL a
start
  DLL a
newLink <- Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL (Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a)
-> IO (Ptr (DLL a)) -> IO (Ptr a -> Ptr (DLL a) -> DLL a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DLL a -> IO (Ptr (DLL a))
forall a. Storable a => a -> IO (Ptr a)
new DLL a
start IO (Ptr a -> Ptr (DLL a) -> DLL a)
-> IO (Ptr a) -> IO (Ptr (DLL a) -> DLL a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> IO (Ptr a)
forall a. Storable a => a -> IO (Ptr a)
new a
ptr IO (Ptr (DLL a) -> DLL a) -> IO (Ptr (DLL a)) -> IO (DLL a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DLL a -> IO (Ptr (DLL a))
forall a. Storable a => a -> IO (Ptr a)
new DLL a
secondLink
  Ptr (DLL a) -> DLL a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (DLL a -> Ptr (DLL a)
forall a. DLL a -> Ptr (DLL a)
next DLL a
start) DLL a
newLink
  Ptr (DLL a) -> DLL a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (DLL a -> Ptr (DLL a)
forall a. DLL a -> Ptr (DLL a)
prev DLL a
secondLink) DLL a
newLink
  DLL a -> IO (Ptr (DLL a))
forall a. Storable a => a -> IO (Ptr a)
new DLL a
newLink

delete :: DLL a -> IO ()
delete :: forall a. DLL a -> IO ()
delete DLL a
link = do
  DLL a
prevLink <- Ptr (DLL a) -> IO (DLL a)
forall a. Storable a => Ptr a -> IO a
peek (Ptr (DLL a) -> IO (DLL a)) -> Ptr (DLL a) -> IO (DLL a)
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ DLL a -> Ptr (DLL a)
forall a. DLL a -> Ptr (DLL a)
prev DLL a
link
  DLL a
nextLink <- Ptr (DLL a) -> IO (DLL a)
forall a. Storable a => Ptr a -> IO a
peek (Ptr (DLL a) -> IO (DLL a)) -> Ptr (DLL a) -> IO (DLL a)
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ DLL a -> Ptr (DLL a)
forall a. DLL a -> Ptr (DLL a)
next DLL a
link
  Ptr (DLL a) -> DLL a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (DLL a -> Ptr (DLL a)
forall a. DLL a -> Ptr (DLL a)
next DLL a
prevLink) DLL a
nextLink
  Ptr (DLL a) -> DLL a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (DLL a -> Ptr (DLL a)
forall a. DLL a -> Ptr (DLL a)
prev DLL a
nextLink) DLL a
prevLink

-- /Doubly-linked list

-- @freeAll start end@ frees all pointer in the linked list. Assumes that @end@
-- doesn't have a pointer, and indeed terminates the list.
--
freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll DLL (Ptr ())
start DLL (Ptr ())
end = do
  DLL (Ptr ())
nextLink <- Ptr (DLL (Ptr ())) -> IO (DLL (Ptr ()))
forall a. Storable a => Ptr a -> IO a
peek (DLL (Ptr ()) -> Ptr (DLL (Ptr ()))
forall a. DLL a -> Ptr (DLL a)
next DLL (Ptr ())
start)
  if DLL (Ptr ())
nextLink DLL (Ptr ()) -> DLL (Ptr ()) -> Bool
forall a. Eq a => a -> a -> Bool
== DLL (Ptr ())
end
    then do
      Ptr (DLL (Ptr ())) -> IO ()
forall a. Ptr a -> IO ()
free (DLL (Ptr ()) -> Ptr (DLL (Ptr ()))
forall a. DLL a -> Ptr (DLL a)
next DLL (Ptr ())
start)
      Ptr (DLL (Ptr ())) -> IO ()
forall a. Ptr a -> IO ()
free (DLL (Ptr ()) -> Ptr (DLL (Ptr ()))
forall a. DLL a -> Ptr (DLL a)
prev DLL (Ptr ())
end)
    else do
      DLL (Ptr ()) -> IO ()
forall a. DLL a -> IO ()
delete DLL (Ptr ())
nextLink
      Ptr (DLL (Ptr ())) -> IO ()
forall a. Ptr a -> IO ()
free (DLL (Ptr ()) -> Ptr (DLL (Ptr ()))
forall a. DLL a -> Ptr (DLL a)
prev DLL (Ptr ())
nextLink)
      Ptr (Ptr ()) -> IO ()
forall a. Ptr a -> IO ()
free (DLL (Ptr ()) -> Ptr (Ptr ())
forall a. DLL a -> Ptr a
elt DLL (Ptr ())
nextLink)
      Ptr (DLL (Ptr ())) -> IO ()
forall a. Ptr a -> IO ()
free (DLL (Ptr ()) -> Ptr (DLL (Ptr ()))
forall a. DLL a -> Ptr (DLL a)
next DLL (Ptr ())
nextLink)
      DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll DLL (Ptr ())
start DLL (Ptr ())
end

-- TODO: document individual functions

-- | Given a linear computation that manages memory, run that computation.
withPool :: forall b. (Movable b) => (Pool %1 -> b) %1 -> b
withPool :: forall b. Movable b => (Pool %1 -> b) %1 -> b
withPool Pool %1 -> b
scope = Ur b %1 -> b
forall a. Ur a %1 -> a
unur (Ur b %1 -> b) -> Ur b %1 -> b
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ ((Pool %1 -> b) -> Ur b) %1 -> (Pool %1 -> b) %1 -> Ur b
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (Pool %1 -> b) -> Ur b
performScope Pool %1 -> b
scope
  where
    -- XXX: do ^ without `toLinear` by using linear IO

    performScope :: (Pool %1 -> b) -> Ur b
    performScope :: (Pool %1 -> b) -> Ur b
performScope Pool %1 -> b
scope' = IO (Ur b) -> Ur b
forall a. IO a -> a
unsafeDupablePerformIO (IO (Ur b) -> Ur b) -> IO (Ur b) -> Ur b
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ do
      -- Initialise the pool
      Ptr (DLL (Ptr ()))
backPtr <- IO (Ptr (DLL (Ptr ())))
forall a. Storable a => IO (Ptr a)
malloc
      let end :: DLL (Ptr ())
end = Ptr (DLL (Ptr ()))
-> Ptr (Ptr ()) -> Ptr (DLL (Ptr ())) -> DLL (Ptr ())
forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL Ptr (DLL (Ptr ()))
backPtr Ptr (Ptr ())
forall a. Ptr a
nullPtr Ptr (DLL (Ptr ()))
forall a. Ptr a
nullPtr -- always at the end of the list
      DLL (Ptr ())
start <- Ptr (DLL (Ptr ()))
-> Ptr (Ptr ()) -> Ptr (DLL (Ptr ())) -> DLL (Ptr ())
forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL Ptr (DLL (Ptr ()))
forall a. Ptr a
nullPtr Ptr (Ptr ())
forall a. Ptr a
nullPtr (Ptr (DLL (Ptr ())) -> DLL (Ptr ()))
-> IO (Ptr (DLL (Ptr ()))) -> IO (DLL (Ptr ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DLL (Ptr ()) -> IO (Ptr (DLL (Ptr ())))
forall a. Storable a => a -> IO (Ptr a)
new DLL (Ptr ())
end -- always at the start of the list
      Ptr (DLL (Ptr ())) -> DLL (Ptr ()) -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (DLL (Ptr ()))
backPtr DLL (Ptr ())
start
      -- Run the computation
      Ur b -> IO (Ur b)
forall a. a -> IO a
evaluate (b %1 -> Ur b
forall a. Movable a => a %1 -> Ur a
move (b %1 -> Ur b) -> b %1 -> Ur b
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ Pool %1 -> b
scope' (DLL (Ptr ()) -> Pool
Pool DLL (Ptr ())
start))
        IO (Ur b) -> IO () -> IO (Ur b)
forall a b. IO a -> IO b -> IO a
`finally`
        -- Clean up remaining variables.
        (DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll DLL (Ptr ())
start DLL (Ptr ())
end)

instance Consumable Pool where
  consume :: Pool %1 -> ()
consume (Pool DLL (Ptr ())
_) = ()

instance Dupable Pool where
  dupR :: Pool %1 -> Replicator Pool
dupR (Pool DLL (Ptr ())
l) = Pool -> Replicator Pool
forall a. a -> Replicator a
forall (f :: * -> *) a. Applicative f => a -> f a
Data.pure (DLL (Ptr ()) -> Pool
Pool DLL (Ptr ())
l)

-- | 'Box a' is the abstract type of manually managed data. It can be used as
-- part of data type definitions in order to store linked data structure off
-- heap. See @Foreign.List@ and @Foreign.Pair@ in the @examples@ directory of
-- the source repository.
data Box a where
  Box :: Ptr (DLL (Ptr ())) -> Ptr a -> Box a

-- XXX: if Box is a newtype, can be derived
instance Storable (Box a) where
  sizeOf :: Box a -> Int
sizeOf Box a
_ = (Ptr (DLL (Ptr ())), Ptr a) -> Int
forall a. Storable a => a -> Int
sizeOf ((Ptr (DLL (Ptr ())), Ptr a)
forall a. HasCallStack => a
undefined :: (Ptr (DLL (Ptr ())), Ptr a))
  alignment :: Box a -> Int
alignment Box a
_ = (Ptr (DLL (Ptr ())), Ptr a) -> Int
forall a. Storable a => a -> Int
alignment ((Ptr (DLL (Ptr ())), Ptr a)
forall a. HasCallStack => a
undefined :: (Ptr (DLL (Ptr ())), Ptr a))
  peek :: Ptr (Box a) -> IO (Box a)
peek Ptr (Box a)
ptr = do
    (Ptr (DLL (Ptr ()))
pool, Ptr a
ptr') <- Ptr (Ptr (DLL (Ptr ())), Ptr a) -> IO (Ptr (DLL (Ptr ())), Ptr a)
forall a. Storable a => Ptr a -> IO a
peek (Ptr (Box a) -> Ptr (Ptr (DLL (Ptr ())), Ptr a)
forall a b. Ptr a -> Ptr b
castPtr Ptr (Box a)
ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a))
    Box a -> IO (Box a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr (DLL (Ptr ())) -> Ptr a -> Box a
forall a. Ptr (DLL (Ptr ())) -> Ptr a -> Box a
Box Ptr (DLL (Ptr ()))
pool Ptr a
ptr')
  poke :: Ptr (Box a) -> Box a -> IO ()
poke Ptr (Box a)
ptr (Box Ptr (DLL (Ptr ()))
pool Ptr a
ptr') =
    Ptr (Ptr (DLL (Ptr ())), Ptr a)
-> (Ptr (DLL (Ptr ())), Ptr a) -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (Box a) -> Ptr (Ptr (DLL (Ptr ())), Ptr a)
forall a b. Ptr a -> Ptr b
castPtr Ptr (Box a)
ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a)) (Ptr (DLL (Ptr ()))
pool, Ptr a
ptr')

instance KnownRepresentable (Box a)

instance Representable (Box a) where
  type AsKnown (Box a) = Box a
  ofKnown :: AsKnown (Box a) %1 -> Box a
ofKnown = Box a %1 -> Box a
AsKnown (Box a) %1 -> Box a
forall a (q :: Multiplicity). a %q -> a
id
  toKnown :: Box a %1 -> AsKnown (Box a)
toKnown = Box a %1 -> Box a
Box a %1 -> AsKnown (Box a)
forall a (q :: Multiplicity). a %q -> a
id

-- TODO: a way to store GC'd data using a StablePtr

-- TODO: reference counted pointer. Remarks: rc pointers are Dupable but not
-- Movable. In order to be useful, need some kind of borrowing on the values, I
-- guess. 'Box' can be realloced, but not RC pointers.

reprPoke :: forall a. (Representable a) => Ptr a -> a %1 -> IO ()
reprPoke :: forall a. Representable a => Ptr a -> a %1 -> IO ()
reprPoke Ptr a
ptr a
a
  | Dict (Storable (AsKnown a))
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @(AsKnown a) =
      (AsKnown a -> IO ()) %1 -> AsKnown a %1 -> IO ()
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (Ptr (AsKnown a) -> AsKnown a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr a -> Ptr (AsKnown a)
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr :: Ptr (AsKnown a))) (a %1 -> AsKnown a
forall a. Representable a => a %1 -> AsKnown a
toKnown a
a)

reprNew :: forall a. (Representable a) => a %1 -> IO (Ptr a)
reprNew :: forall a. Representable a => a %1 -> IO (Ptr a)
reprNew a
a =
  (a -> IO (Ptr a)) %1 -> a %1 -> IO (Ptr a)
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear a -> IO (Ptr a)
mkPtr a
a
  where
    -- XXX: should be improved by using linear IO
    mkPtr :: a -> IO (Ptr a)
    mkPtr :: a -> IO (Ptr a)
mkPtr a
a' | Dict (Storable (AsKnown a))
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @(AsKnown a) =
      do
        Ptr (AsKnown a)
ptr0 <- forall a. Storable a => IO (Ptr a)
malloc @(AsKnown a)
        let ptr :: Ptr a
ptr = Ptr (AsKnown a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (AsKnown a)
ptr0 :: Ptr a
        Ptr a -> a %1 -> IO ()
forall a. Representable a => Ptr a -> a %1 -> IO ()
reprPoke Ptr a
ptr a
a'
        Ptr a -> IO (Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr

-- TODO: Ideally, we would like to avoid having a boxed representation of the
-- data before a pointer is created. A better solution is to have a destination
-- passing-style API (but there is still some design to be done there). This
-- alloc primitive would then be derived (but most of the time we would rather
-- write bespoke constructors).

-- | Store a value @a@ on the system heap that is not managed by the GC.
alloc :: forall a. (Representable a) => a %1 -> Pool %1 -> Box a
alloc :: forall a. Representable a => a %1 -> Pool %1 -> Box a
alloc a
a (Pool DLL (Ptr ())
pool) =
  (a -> Box a) %1 -> a %1 -> Box a
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear a -> Box a
mkPtr a
a
  where
    -- XXX: should be improved by using linear IO
    mkPtr :: a -> Box a
    mkPtr :: a -> Box a
mkPtr a
a' = IO (Box a) -> Box a
forall a. IO a -> a
unsafeDupablePerformIO (IO (Box a) -> Box a) -> IO (Box a) -> Box a
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ do
      Ptr a
ptr <- a %1 -> IO (Ptr a)
forall a. Representable a => a %1 -> IO (Ptr a)
reprNew a
a'
      Ptr (DLL (Ptr ()))
poolPtr <- DLL (Ptr ()) -> Ptr () -> IO (Ptr (DLL (Ptr ())))
forall a. Storable a => DLL a -> a -> IO (Ptr (DLL a))
insertAfter DLL (Ptr ())
pool (Ptr a -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr :: Ptr ())
      Box a -> IO (Box a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr (DLL (Ptr ())) -> Ptr a -> Box a
forall a. Ptr (DLL (Ptr ())) -> Ptr a -> Box a
Box Ptr (DLL (Ptr ()))
poolPtr Ptr a
ptr)

-- TODO: would be better in linear IO, for we pretend that we are making an
-- unrestricted 'a', where really we are not.
reprPeek :: forall a. (Representable a) => Ptr a -> IO a
reprPeek :: forall a. Representable a => Ptr a -> IO a
reprPeek Ptr a
ptr | Dict (Storable (AsKnown a))
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @(AsKnown a) = do
  AsKnown a
knownRepr <- Ptr (AsKnown a) -> IO (AsKnown a)
forall a. Storable a => Ptr a -> IO a
peek (Ptr a -> Ptr (AsKnown a)
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr :: Ptr (AsKnown a))
  a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AsKnown a %1 -> a
forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
knownRepr)

-- | Retrieve the value stored on system heap memory.
deconstruct :: (Representable a) => Box a %1 -> a
deconstruct :: forall a. Representable a => Box a %1 -> a
deconstruct (Box Ptr (DLL (Ptr ()))
poolPtr Ptr a
ptr) = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$
  IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ do
    a
res <- Ptr a -> IO a
forall a. Representable a => Ptr a -> IO a
reprPeek Ptr a
ptr
    DLL (Ptr ()) -> IO ()
forall a. DLL a -> IO ()
delete (DLL (Ptr ()) -> IO ()) -> IO (DLL (Ptr ())) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr (DLL (Ptr ())) -> IO (DLL (Ptr ()))
forall a. Storable a => Ptr a -> IO a
peek Ptr (DLL (Ptr ()))
poolPtr
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptr
    Ptr (DLL (Ptr ())) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (DLL (Ptr ()))
poolPtr
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res