Data-Layout-BuddySystem

 view release on metacpan or  search on metacpan

lib/Data/Layout/BuddySystem.pm  view on Meta::CPAN

  print for qx(zip $z $0 && aws s3 cp $z s3://AppaAppsSourceVersions/$z && rm $z);
 }

#1 Methods
sub new                                                                         # Create a new Buddy system
 {return bless {};
 }

sub freeChains{$_[0]{freeChains} //= []}                                        ## Addresses of free blocks organised by power of two size
sub usedSize  {$_[0]{usedSize}   //= {}}                                        ## {address} = size of allocation at that address
sub wentTo    {$_[0]{wentTo}     //= {}}                                        ## {address1} = address2 - where address 1 was relocated to by copy
sub cameFrom  {$_[0]{cameFrom}   //= {}}                                        ## {address1} = address2 - where address 1 came from before being copied
sub allFrees  {$_[0]{allFrees}   //= []}                                        ## [chain] = count of allocations minus frees on this chain
sub nameAlloc {$_[0]{nameAlloc}  //= {}}                                        ## {name}  = name of allocation if a name has been supplied
sub allocName {$_[0]{allocName}  //= {}}                                        ## {address}  = name of allocation at this address if a name has been supplied
sub size      {scalar @{$_[0]->freeChains}}                                     ## Number of free chains in use

sub allocField($$$)                                                             # Allocate a block in the buddy system, give it a name that is invariant even after this buddy system has been copied to a new buddy system to compact its storage, and re...
 {my ($buddySystem, $name, $size) = @_;                                         # Buddy system, name of block, integer log2(size of allocation)
  $name              or                                                         # Check name has been supplied
    confess "Name required";

lib/Data/Layout/BuddySystem.pm  view on Meta::CPAN

    for($s..$size)                                                              # Spread excess space across lower chains
     {my $i = $size-($_+1-$s);
      $buddySystem->freeChains->[$i]{(1<<$i)}++;
     }
    return $alloc                                                               # Return allocation
   }
 } # alloc

sub locateAddress($$)                                                           # Find the current location of a block by its original address after it has been copied to a new buddy system
 {my ($buddySystem, $alloc) = @_;                                               # Buddy system, address at which the block was originally located
  $buddySystem->wentTo->{$alloc} // $alloc                                      # The relocated address if there is one, else the current address
 } # locateAddress

sub locateName($$)                                                              # Find the current location of a named block after it has been copied to a new buddy system
 {my ($buddySystem, $name) = @_;                                                # Buddy system, name of the block
  my $alloc = $buddySystem->nameAlloc->{$name};                                 # Address of named block
  defined($alloc) or confess "No such named block: $name";                      # Complain of no such block exists
  $buddySystem->locateAddress($alloc)                                           # The relocated address if there is one, else the current address
 } # locateName

sub sizeAddress($$)                                                             # Size of allocation at an address
 {my ($buddySystem, $address) = @_;                                             # Buddy system, address of allocation whiose size we want
  $buddySystem->{usedSize}{$address}                                            # Size of allocation at specified address
 } # sizeAddress

sub sizeName($$)                                                                # Size of a named allocation
 {my ($buddySystem, $name) = @_;                                                # Buddy system, address of allocation whiose size we want
  my $address = $buddySystem->locateName($name);                                # Address of allocation

lib/Data/Layout/BuddySystem.pm  view on Meta::CPAN

     {my $s = $U->{$u};                                                         # Size of this used block
      $T[$u] = uc $A[$s % $L];
     }
   }
  my $T = join '', @T;                                                          # Representation as a string
  say STDOUT "$title $T" if $title;
  $T
 } # visualise

#2 Relocation                                                                   # These methods copy one buddy system to another compacting free space in the process.
sub copy($$;$)                                                                  # Copy a buddy system to compact its free space, the largest blocks are placed in (0) - ascending, (1) - descending order of size, blocks that get relocated to new positi...
 {my ($buddySystem, $order, $copy) = @_;                                        # Buddy system, order, optional copy method to copy an old allocation into its corresponding new allocation
  my $n = new;                                                                  # The new buddy system

  if (my $u = $buddySystem->usedSize)                                           # Used blocks decreasing in size but increasing by address within each size
   {my @u = sort
     {my $c = $order ? $u->{$b} <=> $u->{$a} : $u->{$a} <=> $u->{$b};           # 0 - Ascending, 1 - Descending order
      return $c unless $c == 0;
      $a <=> $b                                                                 # Ascending address
     } keys %$u;

    for my $a(@u)                                                               # Each used block
     {my $size = $u->{$a};                                                      # Size of this block
      my $A;                                                                    # Address of relocated block
      if (my $name = $buddySystem->allocName->{$a})                             # Name attached to the block
       {$A = $n->allocField($name, $size);                                      # Create new block with same name in new buddy system
       }
      else
       {$A = $n->alloc($size);                                                  # Matching block in new buddy system
       }
      $copy->($a, $A, $size) if $copy;                                          # Copy data from old block to new block, using the specified size
      if (my $f = $buddySystem->cameFrom->{$a})                                 # Address this block originally came from if different from new address
       {if ($f != $A)                                                           # Record new position if different
         {$n->cameFrom->{$A} = $f;                                              # The original address at which the block was allocated

lib/Data/Layout/BuddySystem.pm  view on Meta::CPAN

     Parameter     Description
  1  $buddySystem  Buddy system

=head2 Relocation

These methods copy one buddy system to another compacting free space in the process.

=head3 copy($buddySystem, $order, $copy)

Copy a buddy system to compact its free space, the largest blocks are placed in (0) - ascending, (1) - descending order of size, blocks that get relocated to new positions in the new buddy system will still be accessible by their original address or ...

     Parameter     Description
  1  $buddySystem  Buddy system
  2  $order        order
  3  $copy         optional copy method to copy an old allocation into its corresponding new allocation

=head3 copyLargestLast($buddySystem, $copy)

Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed last