File Coverage

blib/lib/Tie/Array/Atomic.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package Tie::Array::Atomic;
2              
3 1     1   47617 use warnings;
  1         3  
  1         37  
4 1     1   6 use strict;
  1         2  
  1         30  
5 1     1   5 use vars qw($VERSION);
  1         6  
  1         66  
6 1     1   5 use base qw(Tie::Array);
  1         2  
  1         966  
7 1     1   3233 use Devel::Malloc;
  0            
  0            
8              
9             $VERSION = '0.01';
10              
11             my %type_sizes = ( 'C'=>1, 'c'=>1, 'S'=>2, 's'=>2, 'L'=>4, 'l'=>4, 'Q'=>8, 'q'=>8 );
12              
13             sub TIEARRAY {
14             my ($class, $opt) = @_;
15             my $self = { %$opt };
16              
17             my $myelement_size = ($self->{type} =~ /^a(\d+)$/) ? $1 : $type_sizes{$self->{type}};
18             return if (!defined $myelement_size) || ($myelement_size < 1) || ($myelement_size > 8);
19             my $element_size = $myelement_size;
20             $element_size = 4 if $element_size == 3;
21             $element_size = 8 if ($element_size >= 5) && ($element_size <= 7);
22             my $address = _malloc($self->{length} * $element_size) or return;
23             $self->{address} = $address;
24             $self->{element_size} = $element_size;
25             $self->{myelement_size} = $myelement_size;
26             $self->{numeric} = (length($self->{type}) == 1);
27             $self->{signed} = ($self->{numeric} && (lc($self->{type}) eq $self->{type}));
28              
29             bless($self, __PACKAGE__);
30             return $self;
31             }
32              
33             sub DESTROY {
34             my ($self) = @_;
35              
36             _free($self->{address}) if $self->{address};
37             }
38              
39             #
40             sub FETCH {
41             my ($self, $n) = @_;
42              
43             my $address = $self->{address} + $n * $self->{element_size};
44             my $val;
45             if ($self->{numeric})
46             {
47             $val = __sync_fetch_and_or($address, 0, $self->{element_size});
48             if (($self->{signed}) && ($val > 0) && ($val >> (8 * $self->{element_size} - 1))) # is negative
49             {
50             $val = -((~abs($val)&(2**(8*$self->{element_size})-1)) + 1); # 2-way conversion
51             }
52             } else {
53             $val = __sync_load_sv($address, $self->{myelement_size});
54             }
55             return $val;
56             }
57              
58             sub FETCHSIZE {
59             return $_[0]->{length};
60             }
61              
62             #
63             sub STORE {
64             my ($self, $n, $val) = @_;
65              
66             my $address = $self->{address} + $n * $self->{element_size};
67             if ($self->{numeric})
68             {
69             if (($self->{signed}) && ($val < 0)) # is negative
70             {
71             $val = ~abs($val) + 1; # 2-way conversion
72             }
73             __sync_lock_test_and_set($address, $val, $self->{element_size});
74             } else {
75             __sync_store_sv($address, $val, $self->{myelement_size});
76             }
77             return $val;
78             }
79              
80             #
81             sub STORESIZE {
82             die('not allowed (yet)');
83             }
84              
85             sub PUSH {
86             die('not allowed (yet)');
87             }
88              
89             sub POP {
90             die('not allowed (yet)');
91             }
92              
93             sub SHIFT {
94             die('not allowed (yet)');
95             }
96              
97             sub UNSHIFT {
98             die('not allowed (yet)');
99             }
100              
101             sub DELETE {
102             die('not allowed (yet)');
103             }
104              
105             sub EXISTS {
106             my ($self, $n) = @_;
107            
108             return ($n < $self->{length});
109             }
110              
111             sub add {
112             my ($self, $element, $n) = @_;
113              
114             __sync_add_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
115             }
116              
117             sub sub {
118             my ($self, $element, $n) = @_;
119              
120             __sync_sub_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
121             }
122              
123             sub or {
124             my ($self, $element, $n) = @_;
125              
126             __sync_or_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
127             }
128              
129             sub and {
130             my ($self, $element, $n) = @_;
131              
132             __sync_and_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
133             }
134              
135             sub xor {
136             my ($self, $element, $n) = @_;
137              
138             __sync_xor_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
139             }
140              
141             sub nand {
142             my ($self, $element, $n) = @_;
143              
144             __sync_nand_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
145             }
146              
147              
148             1;
149              
150             __END__