1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
-- |
-- Module : Basement.FinalPtr
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : portable
--
-- A smaller ForeignPtr reimplementation that work in any prim monad.
--
-- Here be dragon.
--
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE CPP #-}
module Basement.FinalPtr
( FinalPtr(..)
, finalPtrSameMemory
, castFinalPtr
, toFinalPtr
, toFinalPtrForeign
, touchFinalPtr
, withFinalPtr
, withUnsafeFinalPtr
, withFinalPtrNoTouch
) where
import GHC.Ptr
import qualified GHC.ForeignPtr as GHCF
import GHC.IO
import Basement.Monad
import Basement.Compat.Primitive
import Basement.Compat.Base
import Control.Monad.ST (runST)
-- | Create a pointer with an associated finalizer
data FinalPtr a = FinalPtr (Ptr a)
| FinalForeign (GHCF.ForeignPtr a)
instance Show (FinalPtr a) where
show f = runST $ withFinalPtr f (pure . show)
instance Eq (FinalPtr a) where
(==) f1 f2 = runST (equal f1 f2)
instance Ord (FinalPtr a) where
compare f1 f2 = runST (compare_ f1 f2)
-- | Check if 2 final ptr points on the same memory bits
--
-- it stand to reason that provided a final ptr that is still being referenced
-- and thus have the memory still valid, if 2 final ptrs have the
-- same address, they should be the same final ptr
finalPtrSameMemory :: FinalPtr a -> FinalPtr b -> Bool
finalPtrSameMemory (FinalPtr p1) (FinalPtr p2) = p1 == castPtr p2
finalPtrSameMemory (FinalForeign p1) (FinalForeign p2) = p1 == GHCF.castForeignPtr p2
finalPtrSameMemory (FinalForeign _) (FinalPtr _) = False
finalPtrSameMemory (FinalPtr _) (FinalForeign _) = False
-- | create a new FinalPtr from a Pointer
toFinalPtr :: PrimMonad prim => Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a)
toFinalPtr ptr finalizer = unsafePrimFromIO (primitive makeWithFinalizer)
where
makeWithFinalizer s =
case compatMkWeak# ptr () (finalizer ptr) s of { (# s2, _ #) -> (# s2, FinalPtr ptr #) }
-- | Create a new FinalPtr from a ForeignPtr
toFinalPtrForeign :: GHCF.ForeignPtr a -> FinalPtr a
toFinalPtrForeign fptr = FinalForeign fptr
-- | Cast a finalized pointer from type a to type b
castFinalPtr :: FinalPtr a -> FinalPtr b
castFinalPtr (FinalPtr a) = FinalPtr (castPtr a)
castFinalPtr (FinalForeign a) = FinalForeign (GHCF.castForeignPtr a)
withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a
withFinalPtrNoTouch (FinalPtr ptr) f = f ptr
withFinalPtrNoTouch (FinalForeign fptr) f = f (GHCF.unsafeForeignPtrToPtr fptr)
{-# INLINE withFinalPtrNoTouch #-}
-- | Looks at the raw pointer inside a FinalPtr, making sure the
-- data pointed by the pointer is not finalized during the call to 'f'
withFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> prim a
withFinalPtr (FinalPtr ptr) f = do
r <- f ptr
primTouch ptr
pure r
withFinalPtr (FinalForeign fptr) f = do
r <- f (GHCF.unsafeForeignPtrToPtr fptr)
unsafePrimFromIO (GHCF.touchForeignPtr fptr)
pure r
{-# INLINE withFinalPtr #-}
touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim ()
touchFinalPtr (FinalPtr ptr) = primTouch ptr
touchFinalPtr (FinalForeign fptr) = unsafePrimFromIO (GHCF.touchForeignPtr fptr)
-- | Unsafe version of 'withFinalPtr'
withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a
withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f))
{-# NOINLINE withUnsafeFinalPtr #-}
equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool
equal f1 f2 =
withFinalPtr f1 $ \ptr1 ->
withFinalPtr f2 $ \ptr2 ->
pure $ ptr1 == ptr2
{-# INLINE equal #-}
compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering
compare_ f1 f2 =
withFinalPtr f1 $ \ptr1 ->
withFinalPtr f2 $ \ptr2 ->
pure $ ptr1 `compare` ptr2
{-# INLINE compare_ #-}
|
