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

package Tie::Array::Atomic;

use warnings;
use strict;
use vars qw($VERSION);
use base qw(Tie::Array);
use Devel::Malloc;

$VERSION = '0.01';

my %type_sizes = ( 'C'=>1, 'c'=>1, 'S'=>2, 's'=>2, 'L'=>4, 'l'=>4, 'Q'=>8, 'q'=>8 );

sub TIEARRAY {
  my ($class, $opt) = @_;
  my $self  = { %$opt };

  my $myelement_size = ($self->{type} =~ /^a(\d+)$/) ? $1 : $type_sizes{$self->{type}};
  return if (!defined $myelement_size) || ($myelement_size < 1) || ($myelement_size > 8);
  my $element_size = $myelement_size;
  $element_size = 4 if $element_size == 3;
  $element_size = 8 if ($element_size >= 5) && ($element_size <= 7);
  my $address = _malloc($self->{length} * $element_size) or return;
  $self->{address} = $address;
  $self->{element_size} = $element_size;
  $self->{myelement_size} = $myelement_size;
  $self->{numeric} = (length($self->{type}) == 1);
  $self->{signed} = ($self->{numeric} && (lc($self->{type}) eq $self->{type}));

  bless($self, __PACKAGE__);
  return $self;
}

sub DESTROY {
  my ($self) = @_;

  _free($self->{address}) if $self->{address};
}

#
sub FETCH {
  my ($self, $n) = @_;

  my $address = $self->{address} + $n * $self->{element_size};
  my $val;
  if ($self->{numeric})
  {
      $val = __sync_fetch_and_or($address, 0, $self->{element_size});
      if (($self->{signed}) && ($val > 0) && ($val >> (8 * $self->{element_size} - 1))) # is negative
      {
        $val = -((~abs($val)&(2**(8*$self->{element_size})-1)) + 1); # 2-way conversion
      }
  } else {
      $val = __sync_load_sv($address, $self->{myelement_size});
  }
  return $val;
}

sub FETCHSIZE {
  return $_[0]->{length};
}

#
sub STORE {
  my ($self, $n, $val) = @_;

  my $address = $self->{address} + $n * $self->{element_size};
  if ($self->{numeric})
  {
     if (($self->{signed}) && ($val < 0)) # is negative
     {
         $val = ~abs($val) + 1; # 2-way conversion
     }
     __sync_lock_test_and_set($address, $val, $self->{element_size});
  } else {
     __sync_store_sv($address, $val, $self->{myelement_size});
  }
  return $val;
}

#
sub STORESIZE {
  die('not allowed (yet)');
}

sub PUSH {
  die('not allowed (yet)');
}

sub POP {
  die('not allowed (yet)');
}

sub SHIFT {
  die('not allowed (yet)');
}

sub UNSHIFT {
  die('not allowed (yet)');
}

sub DELETE {
  die('not allowed (yet)');
}

sub EXISTS {
  my ($self, $n) = @_;

  return ($n < $self->{length});
}

sub add {
  my ($self, $element, $n) = @_;

  __sync_add_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
}

sub sub {
  my ($self, $element, $n) = @_;

  __sync_sub_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
}

sub or {
  my ($self, $element, $n) = @_;

  __sync_or_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
}

sub and {
  my ($self, $element, $n) = @_;

  __sync_and_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
}

sub xor {
  my ($self, $element, $n) = @_;

  __sync_xor_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
}

sub nand {
  my ($self, $element, $n) = @_;

  __sync_nand_and_fetch($self->{address} + $element * $self->{element_size}, $n, $self->{element_size});
}


1;

__END__