-
Notifications
You must be signed in to change notification settings - Fork 26
/
Internal.hs
130 lines (106 loc) · 4.67 KB
/
Internal.hs
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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
{-# LANGUAGE CPP, TypeSynonymInstances, BangPatterns #-}
{-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, MagicHash, UnboxedTuples, UnliftedFFITypes #-}
-- | This module provides only the raw primops (and necessary types) for atomic
-- operations.
module Data.Atomics.Internal
(casArray#,
readForCAS#, casMutVarTicketed#,
Ticket,
stg_storeLoadBarrier#, stg_loadLoadBarrier#, stg_writeBarrier# )
where
import GHC.Base (Int(I#))
import GHC.Word (Word(W#))
import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, unsafeCoerce#, MutVar#, reallyUnsafePtrEquality#)
#if MIN_VERSION_base(4,5,0)
-- Any is only in GHC 7.6!!! We want 7.4 support.
import GHC.Prim (readMutVar#, casMutVar#, Any)
#else
#error "Need to figure out how to emulate Any () in GHC < 7.4 !"
-- type Any a = Word#
#endif
#ifdef DEBUG_ATOMICS
{-# NOINLINE readForCAS# #-}
{-# NOINLINE casArray# #-}
{-# NOINLINE casMutVarTicketed# #-}
#define CASTFUN
#else
{-# INLINE casMutVarTicketed# #-}
{-# INLINE casArray# #-}
-- I *think* inlining may be ok here as long as casting happens on the arrow types:
#define CASTFUN
#endif
--------------------------------------------------------------------------------
-- CAS and friendsa
--------------------------------------------------------------------------------
-- | Unsafe, machine-level atomic compare and swap on an element within an Array.
casArray# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a
-> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)
#ifdef CASTFUN
-- WARNING: cast of a function -- need to verify these are safe or eta expand.
casArray# = unsafeCoerce# casArrayTypeErased#
#endif
-- | When performing compare-and-swaps, the /ticket/ encapsulates proof
-- that a thread observed a specific previous value of a mutable
-- variable. It is provided in lieu of the "old" value to
-- compare-and-swap.
type Ticket a = Any a
-- If we allow tickets to be a pointer type, then the garbage collector will update
-- the pointer when the object moves.
#if 0
-- This technique is UNSAFE. False negatives are tolerable, but it may also
-- introduce the possibility of false positives.
type Ticket = Word
type Ticket# = Word#
#endif
instance Show (Ticket a) where
show _ = "<CAS_ticket>"
{-# NOINLINE ptrEq #-}
ptrEq :: a -> a -> Bool
ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1
instance Eq (Ticket a) where
(==) = ptrEq
--------------------------------------------------------------------------------
readForCAS# :: MutVar# RealWorld a ->
State# RealWorld -> (# State# RealWorld, Ticket a #)
-- WARNING: cast of a function -- need to verify these are safe or eta expand:
#ifdef CASTFUN
readForCAS# = unsafeCoerce# readMutVar#
#else
readForCAS# mv rw =
case readMutVar# mv rw of
(# rw', a #) -> (# rw', unsafeCoerce# a #)
#endif
casMutVarTicketed# :: MutVar# RealWorld a -> Ticket a -> Ticket a ->
State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)
-- WARNING: cast of a function -- need to verify these are safe or eta expand:
#ifdef CASTFUN
casMutVarTicketed# = unsafeCoerce# casMutVar_TypeErased#
#endif
--------------------------------------------------------------------------------
-- Memory barriers
--------------------------------------------------------------------------------
foreign import prim "stg_store_load_barrier" stg_storeLoadBarrier#
:: State# RealWorld -> (# State# RealWorld, Int# #)
foreign import prim "stg_load_load_barrier" stg_loadLoadBarrier#
:: State# RealWorld -> (# State# RealWorld, Int# #)
foreign import prim "stg_write_barrier" stg_writeBarrier#
:: State# RealWorld -> (# State# RealWorld, Int# #)
--------------------------------------------------------------------------------
-- Type-erased versions that call the raw foreign primops:
--------------------------------------------------------------------------------
-- Due to limitations of the "foreign import prim" mechanism, we can't use the
-- polymorphic signature for the below functions. So we lie to the type system
-- instead.
foreign import prim "stg_casArrayzh" casArrayTypeErased#
:: MutableArray# RealWorld () -> Int# -> Any () -> Any () ->
State# RealWorld -> (# State# RealWorld, Int#, Any () #)
-- out_of_line = True
-- has_side_effects = True
-- | This alternate version of casMutVar returns an opaque "ticket" for
-- future CAS operations.
foreign import prim "stg_casMutVar2zh" casMutVar_TypeErased#
:: MutVar# RealWorld () -> Any () -> Any () ->
State# RealWorld -> (# State# RealWorld, Int#, Any () #)
-- foreign import prim "stg_readMutVar2zh" readMutVar_TypeErased#
-- :: MutVar# RealWorld () ->
-- State# RealWorld -> (# State# RealWorld, Any () #)