{-# OPTIONS_GHC -fno-warn-orphans #-}
-- 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 NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module introduces primitives to /safely/ allocate and discard system
-- heap memory (/not GC heap memory/) for storing  values /explicitly/.
-- (Basically, a haskell program has a GC that at runtime, manages its own heap
-- by freeing and allocating space from the system heap.) Values discarded
-- explicitly don't need to be managed by the garbage collector (GC), which
-- therefore has less work to do. Less work for the GC can sometimes mean more
-- predictable request latencies in multi-threaded and distributed
-- applications.
--
-- This module is meant to be imported qualified.
--
-- == The Interface
--
-- Run a computation that uses heap memory by passing a continuation to
-- 'withPool' of type @Pool %1-> Ur b@. Allocate and free with
-- 'alloc' and 'deconstruct'. Make as many or as few pools you need, by
-- using the 'Dupable' and 'Consumable' instances of  'Pool'.
--
-- A toy example:
--
-- >>> :set -XLinearTypes
-- >>> import Data.Unrestricted.Linear
-- >>> import qualified Foreign.Marshal.Pure as Manual
-- >>> :{
--   nothingWith3 :: Pool %1-> Ur Int
--   nothingWith3 pool = move (Manual.deconstruct (Manual.alloc 3 pool))
-- :}
--
-- >>> unur (Manual.withPool nothingWith3)
-- 3
--
--
-- === What are 'Pool's?
--
-- 'Pool's are memory pools from which a user can safely allocate and use
-- heap memory manually by passing 'withPool' a continuation.
-- An alternative design would have allowed passing continuations to
-- allocation functions but this could break tail-recursion in certain cases.
--
-- Pools play another role: resilience to exceptions. If an exception is raised,
-- all the data in the pool is deallocated.
--
-- Note that data from one pool can refer to data in another pool and vice
-- versa.
--
-- == Large Examples
--
-- You can find example data structure implementations in @Foreign.List@ and
-- @Foreign.Heap@ [here](https://github.com/tweag/linear-base/tree/master/examples/Foreign).

module Foreign.Marshal.Pure
  (
  -- * Allocating and using values on the heap
    Pool
  , withPool
  , Box
  , alloc
  , deconstruct
  -- * Typeclasses for values that can be allocated
  , KnownRepresentable
  , Representable(..)
  , MkRepresentable(..)
  ) 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 (($), return, (<*>), Eq(..), (<$>), (=<<))
import Prelude.Linear hiding (($), Eq(..))
import System.IO.Unsafe
import qualified Unsafe.Linear as Unsafe

-- 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 a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (Maybe a)
ptr (Int -> IO Word8) -> Int -> IO Word8
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Storable a => a -> Int
sizeOf (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ Maybe a -> a
forall a. Maybe a -> a
stripMaybe (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> 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 (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 (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 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. (a -> b) -> a -> b
$ Maybe a -> a
forall a. Maybe a -> a
stripMaybe (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> 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 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 -> AsKnown Word
forall a. a %1 -> a
id
  ofKnown :: AsKnown Word %1 -> Word
ofKnown = AsKnown Word %1 -> Word
forall a. a %1 -> a
id
instance Representable Int where
  type AsKnown Int = Int
  toKnown :: Int %1 -> AsKnown Int
toKnown = Int %1 -> AsKnown Int
forall a. a %1 -> a
id
  ofKnown :: AsKnown Int %1 -> Int
ofKnown = AsKnown Int %1 -> Int
forall a. a %1 -> a
id
instance Representable (Ptr a) where
  type AsKnown (Ptr a) = Ptr a
  toKnown :: Ptr a %1 -> AsKnown (Ptr a)
toKnown = Ptr a %1 -> AsKnown (Ptr a)
forall a. a %1 -> a
id
  ofKnown :: AsKnown (Ptr a) %1 -> Ptr a
ofKnown = AsKnown (Ptr a) %1 -> Ptr a
forall a. a %1 -> a
id
instance Representable () where
  type AsKnown () = ()
  toKnown :: () %1 -> AsKnown ()
toKnown = () %1 -> AsKnown ()
forall a. a %1 -> a
id
  ofKnown :: AsKnown () %1 -> ()
ofKnown = AsKnown () %1 -> ()
forall a. a %1 -> 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 %1 -> 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  = AsKnown (Maybe a)
forall a. Maybe a
Nothing
  ofKnown :: AsKnown (Maybe a) %1 -> Maybe a
ofKnown (Just AsKnown a
x) = a %1 -> 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
/= :: DLL a -> DLL a -> Bool
$c/= :: forall a. DLL a -> DLL a -> Bool
== :: DLL a -> DLL a -> Bool
$c== :: forall a. 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 (m :: * -> *) a. Monad m => a -> m a
return (DLL a -> IO (DLL a)) -> DLL a -> IO (DLL a)
forall a b. (a -> b) -> a -> 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. (a -> b) -> a -> 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 (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 (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. (a -> b) -> a -> 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. (a -> b) -> a -> 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 :: (Pool %1-> Ur b) %1-> Ur b
withPool :: forall b. (Pool %1 -> Ur b) %1 -> Ur b
withPool Pool %1 -> Ur b
scope = ((Pool %1 -> Ur b) -> Ur b) %1 -> (Pool %1 -> Ur b) %1 -> Ur b
forall a b (p :: Multiplicity). (a %p -> b) %1 -> a %1 -> b
Unsafe.toLinear (Pool %1 -> Ur b) -> Ur b
forall b. (Pool %1 -> Ur b) -> Ur b
performScope Pool %1 -> Ur b
scope
    -- XXX: do ^ without `toLinear` by using linear IO
  where
    performScope :: (Pool %1-> Ur b) -> Ur b
    performScope :: forall b. (Pool %1 -> Ur b) -> Ur b
performScope Pool %1 -> Ur 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. (a -> b) -> a -> 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 (Pool %1 -> Ur 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
  dupV :: forall (n :: Nat). KnownNat n => Pool %1 -> V n Pool
dupV (Pool DLL (Ptr ())
l) = Pool -> V n Pool
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 (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) where
instance Representable (Box a) where
  type AsKnown (Box a) = Box a
  ofKnown :: AsKnown (Box a) %1 -> Box a
ofKnown = AsKnown (Box a) %1 -> Box a
forall a. a %1 -> a
id
  toKnown :: Box a %1 -> AsKnown (Box a)
toKnown = Box a %1 -> AsKnown (Box a)
forall a. a %1 -> 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). (a %p -> b) %1 -> a %1 -> 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). (a %p -> b) %1 -> a %1 -> 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 (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). (a %p -> b) %1 -> a %1 -> 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. (a -> b) -> a -> 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 (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 (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. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> 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 (m :: * -> *) a. Monad m => a -> m a
return a
res