| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | #!/usr/bin/perl | 
| 2 |  |  |  |  |  |  | #------------------------------------------------------------------------------- | 
| 3 |  |  |  |  |  |  | # Buddy system memory allocation in 100% Pure Perl | 
| 4 |  |  |  |  |  |  | # Philip R Brenan at gmail dot com, Appa Apps Ltd, 2016 | 
| 5 |  |  |  |  |  |  | #------------------------------------------------------------------------------- | 
| 6 |  |  |  |  |  |  |  | 
| 7 |  |  |  |  |  |  | package Data::Layout::BuddySystem; | 
| 8 |  |  |  |  |  |  | require v5.16.0; | 
| 9 | 1 |  |  | 1 |  | 584 | use warnings FATAL => qw(all); | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 28 |  | 
| 10 | 1 |  |  | 1 |  | 3 | use strict; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 17 |  | 
| 11 | 1 |  |  | 1 |  | 515 | use Data::Table::Text qw(:all); | 
|  | 1 |  |  |  |  | 15336 |  | 
|  | 1 |  |  |  |  | 212 |  | 
| 12 | 1 |  |  | 1 |  | 6 | use Carp; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 1433 |  | 
| 13 |  |  |  |  |  |  | our $VERSION = 2017.117; | 
| 14 |  |  |  |  |  |  |  | 
| 15 |  |  |  |  |  |  | if (0)                                                                          # Save to S3:- this will not work, unless you're me, or you happen, to know the key | 
| 16 |  |  |  |  |  |  | {my $z = 'DataLayoutBuddySystem.zip'; | 
| 17 |  |  |  |  |  |  | print for qx(zip $z $0 && aws s3 cp $z s3://AppaAppsSourceVersions/$z && rm $z); | 
| 18 |  |  |  |  |  |  | } | 
| 19 |  |  |  |  |  |  |  | 
| 20 |  |  |  |  |  |  | #1 Methods | 
| 21 |  |  |  |  |  |  | sub new                                                                         # Create a new Buddy system | 
| 22 | 76 |  |  | 76 | 1 | 1399 | {return bless {}; | 
| 23 |  |  |  |  |  |  | } | 
| 24 |  |  |  |  |  |  |  | 
| 25 | 52380 |  | 100 | 52380 | 0 | 86966 | sub freeChains{$_[0]{freeChains} //= []}                                        ## Addresses of free blocks organised by power of two size | 
| 26 | 4427 |  | 100 | 4427 | 0 | 18256 | sub usedSize  {$_[0]{usedSize}   //= {}}                                        ## {address} = size of allocation at that address | 
| 27 | 974 |  | 100 | 974 | 0 | 1538 | sub wentTo    {$_[0]{wentTo}     //= {}}                                        ## {address1} = address2 - where address 1 was relocated to by copy | 
| 28 | 991 |  | 100 | 991 | 0 | 1452 | sub cameFrom  {$_[0]{cameFrom}   //= {}}                                        ## {address1} = address2 - where address 1 came from before being copied | 
| 29 | 18415 |  | 100 | 18415 | 0 | 41783 | sub allFrees  {$_[0]{allFrees}   //= []}                                        ## [chain] = count of allocations minus frees on this chain | 
| 30 | 45 |  | 100 | 45 | 0 | 124 | sub nameAlloc {$_[0]{nameAlloc}  //= {}}                                        ## {name}  = name of allocation if a name has been supplied | 
| 31 | 45 |  | 100 | 45 | 0 | 116 | sub allocName {$_[0]{allocName}  //= {}}                                        ## {address}  = name of allocation at this address if a name has been supplied | 
| 32 | 11160 |  |  | 11160 | 0 | 6635 | sub size      {scalar @{$_[0]->freeChains}}                                     ## Number of free chains in use | 
|  | 11160 |  |  |  |  | 10642 |  | 
| 33 |  |  |  |  |  |  |  | 
| 34 |  |  |  |  |  |  | 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 return the address of its location in the buddy system | 
| 35 | 18 |  |  | 18 | 1 | 19 | {my ($buddySystem, $name, $size) = @_;                                         # Buddy system, name of block, integer log2(size of allocation) | 
| 36 | 18 | 50 |  |  |  | 25 | $name              or                                                         # Check name has been supplied | 
| 37 |  |  |  |  |  |  | confess "Name required"; | 
| 38 | 18 | 50 |  |  |  | 55 | $name =~ /\A\w+\Z/ or                                                         # Check that only word characters are being used to construct the field name | 
| 39 |  |  |  |  |  |  | confess "Name must consist of word characters, not: $name"; | 
| 40 | 18 | 50 |  |  |  | 22 | defined($buddySystem->nameAlloc->{$name}) and                                 # Check proposed name of allocation is not already in use | 
| 41 |  |  |  |  |  |  | confess "Name already defined: $name"; | 
| 42 | 18 |  |  |  |  | 19 | my $alloc = $buddySystem->alloc($size);                                       # Perform allocation | 
| 43 | 18 |  |  |  |  | 24 | $buddySystem->nameAlloc->{$name}  = $alloc;                                   # Name to address of allocation | 
| 44 | 18 |  |  |  |  | 22 | $buddySystem->allocName->{$alloc} = $name;                                    # Address to name of allocation | 
| 45 | 18 |  |  |  |  | 215 | $alloc                                                                        # Return address of allocation | 
| 46 |  |  |  |  |  |  | } # allocField | 
| 47 |  |  |  |  |  |  |  | 
| 48 |  |  |  |  |  |  | sub alloc($$)                                                                   # Allocate a block and return its bit address | 
| 49 | 1117 |  |  | 1117 | 1 | 1036 | {my ($buddySystem, $size) = @_;                                                # Buddy system, integer log2(size of allocation) | 
| 50 | 1117 | 50 |  |  |  | 1616 | $size >= 0          or confess "Size must be positive, not $size"; | 
| 51 | 1117 | 50 |  |  |  | 1611 | $size == int($size) or confess "Size must be integral, not $size"; | 
| 52 | 1117 |  |  |  |  | 1371 | $buddySystem->allFrees->[$size]++;                                            # Count allocations and frees on this chain - alloc always works | 
| 53 |  |  |  |  |  |  |  | 
| 54 | 1117 | 100 |  |  |  | 1313 | if ($buddySystem->size == 0)                                                  # Initial allocation | 
| 55 | 76 |  |  |  |  | 74 | {my $alloc = 0;                                                              # Allocation address | 
| 56 | 76 |  |  |  |  | 110 | $buddySystem->freeChains->[$size] = {};                                     # Create chain for initial allocation | 
| 57 | 76 |  |  |  |  | 103 | $buddySystem->usedSize->{$alloc} = $size;                                   # Save size of allocation at offset | 
| 58 | 76 |  |  |  |  | 1489 | return $alloc;                                                              # Return allocation | 
| 59 |  |  |  |  |  |  | } | 
| 60 |  |  |  |  |  |  |  | 
| 61 | 1041 |  |  |  |  | 1213 | for my $F($size..$buddySystem->size-1)                                        # Look for space on the free chains | 
| 62 | 1932 | 100 |  |  |  | 1936 | {if (my $f = $buddySystem->freeChains->[$F])                                 # Each chain | 
| 63 | 1885 | 100 |  |  |  | 2767 | {if (keys %$f)                                                             # Free chain with space | 
| 64 | 949 |  |  |  |  | 1510 | {for my $alloc(sort {$a <=> $b} keys %$f)                                # Allocation address | 
|  | 67 |  |  |  |  | 101 |  | 
| 65 | 949 |  |  |  |  | 945 | {delete $f->{$alloc}; | 
| 66 | 949 |  |  |  |  | 1078 | $buddySystem->usedSize->{$alloc} = $size;                             # Save size of allocation at offset | 
| 67 | 949 |  |  |  |  | 1428 | $buddySystem->freeChains->[$_]{$alloc + (1<<$_)}++ for $size..$F-1;   # Return excess space to lower chains | 
| 68 | 949 |  |  |  |  | 17832 | return $alloc;                                                        # Return allocation | 
| 69 |  |  |  |  |  |  | } | 
| 70 |  |  |  |  |  |  | } | 
| 71 |  |  |  |  |  |  | } | 
| 72 |  |  |  |  |  |  | } | 
| 73 |  |  |  |  |  |  | # No space on any free chain - start a new chain to hold the allocation | 
| 74 | 92 |  |  |  |  | 116 | my $s = $buddySystem->size;                                                   # Size less than current allocation | 
| 75 | 92 | 100 |  |  |  | 155 | if ($size < $s-1) | 
| 76 | 45 |  |  |  |  | 64 | {my $F = $buddySystem->freeChains->[$s] = {};                                # Create new chain | 
| 77 | 45 |  |  |  |  | 46 | my $alloc = (1<<($s-1));                                                    # Allocation address | 
| 78 | 45 |  |  |  |  | 51 | $buddySystem->usedSize->{$alloc} = $size;                                   # Allocation size | 
| 79 | 45 |  |  |  |  | 92 | $buddySystem->freeChains->[$_]{$alloc + (1<<$_)}++ for $size..$s-2;         # Spread excess space across lower chains | 
| 80 | 45 |  |  |  |  | 714 | return $alloc | 
| 81 |  |  |  |  |  |  | } | 
| 82 |  |  |  |  |  |  | else                                                                          # Size greater than or equal to current allocation | 
| 83 | 47 |  |  |  |  | 66 | {my $F = $buddySystem->freeChains->[$size+1] = {};                           # Create new chain | 
| 84 | 47 |  |  |  |  | 45 | my $alloc = (1<<$size);                                                     # Allocation address | 
| 85 | 47 |  |  |  |  | 53 | $buddySystem->usedSize->{$alloc} = $size;                                   # Allocation size | 
| 86 | 47 |  |  |  |  | 73 | for($s..$size)                                                              # Spread excess space across lower chains | 
| 87 | 51 |  |  |  |  | 52 | {my $i = $size-($_+1-$s); | 
| 88 | 51 |  |  |  |  | 62 | $buddySystem->freeChains->[$i]{(1<<$i)}++; | 
| 89 |  |  |  |  |  |  | } | 
| 90 | 47 |  |  |  |  | 885 | return $alloc                                                               # Return allocation | 
| 91 |  |  |  |  |  |  | } | 
| 92 |  |  |  |  |  |  | } # alloc | 
| 93 |  |  |  |  |  |  |  | 
| 94 |  |  |  |  |  |  | sub locateAddress($$)                                                           # Find the current location of a block by its original address after it has been copied to a new buddy system | 
| 95 | 9 |  |  | 9 | 1 | 11 | {my ($buddySystem, $alloc) = @_;                                               # Buddy system, address at which the block was originally located | 
| 96 | 9 |  | 66 |  |  | 17 | $buddySystem->wentTo->{$alloc} // $alloc                                      # The relocated address if there is one, else the current address | 
| 97 |  |  |  |  |  |  | } # locateAddress | 
| 98 |  |  |  |  |  |  |  | 
| 99 |  |  |  |  |  |  | sub locateName($$)                                                              # Find the current location of a named block after it has been copied to a new buddy system | 
| 100 | 9 |  |  | 9 | 1 | 9 | {my ($buddySystem, $name) = @_;                                                # Buddy system, name of the block | 
| 101 | 9 |  |  |  |  | 16 | my $alloc = $buddySystem->nameAlloc->{$name};                                 # Address of named block | 
| 102 | 9 | 50 |  |  |  | 17 | defined($alloc) or confess "No such named block: $name";                      # Complain of no such block exists | 
| 103 | 9 |  |  |  |  | 14 | $buddySystem->locateAddress($alloc)                                           # The relocated address if there is one, else the current address | 
| 104 |  |  |  |  |  |  | } # locateName | 
| 105 |  |  |  |  |  |  |  | 
| 106 |  |  |  |  |  |  | sub sizeAddress($$)                                                             # Size of allocation at an address | 
| 107 | 9 |  |  | 9 | 0 | 11 | {my ($buddySystem, $address) = @_;                                             # Buddy system, address of allocation whiose size we want | 
| 108 | 9 |  |  |  |  | 31 | $buddySystem->{usedSize}{$address}                                            # Size of allocation at specified address | 
| 109 |  |  |  |  |  |  | } # sizeAddress | 
| 110 |  |  |  |  |  |  |  | 
| 111 |  |  |  |  |  |  | sub sizeName($$)                                                                # Size of a named allocation | 
| 112 | 9 |  |  | 9 | 0 | 3170 | {my ($buddySystem, $name) = @_;                                                # Buddy system, address of allocation whiose size we want | 
| 113 | 9 |  |  |  |  | 17 | my $address = $buddySystem->locateName($name);                                # Address of allocation | 
| 114 | 9 | 50 |  |  |  | 18 | defined($address) or confess "No allocation with name $name";                 # Check allocation by this name exists | 
| 115 | 9 |  |  |  |  | 13 | $buddySystem->sizeAddress($address)                                           # Size of named allocation | 
| 116 |  |  |  |  |  |  | } # sizeName | 
| 117 |  |  |  |  |  |  |  | 
| 118 |  |  |  |  |  |  | sub freeName($$)                                                                # Free an allocated block via its name | 
| 119 | 0 |  |  | 0 | 1 | 0 | {my ($buddySystem, $name) = @_;                                                # Buddy system, name used to allocate block | 
| 120 | 0 |  |  |  |  | 0 | my $alloc = $buddySystem->locateName($name);                                  # Current address of named block | 
| 121 | 0 |  |  |  |  | 0 | delete $buddySystem->nameAlloc->{$name};                                      # Disassociate name from block | 
| 122 | 0 |  |  |  |  | 0 | $buddySystem->free($alloc);                                                   # Free block by address | 
| 123 |  |  |  |  |  |  | } # freeName | 
| 124 |  |  |  |  |  |  |  | 
| 125 |  |  |  |  |  |  | sub free($$)                                                                    # Free an allocation via its original allocation address | 
| 126 | 965 |  |  | 965 | 1 | 916 | {my ($buddySystem, $alloc) = @_;                                               # Buddy system, original allocation address | 
| 127 | 965 |  |  |  |  | 990 | my $s = delete $buddySystem->usedSize->{$alloc};                              # Size of allocation at this alloc | 
| 128 | 965 | 50 |  |  |  | 1221 | return 0 unless defined($s);                                                  # No allocation present and so no free is possible | 
| 129 | 965 |  |  |  |  | 1068 | $buddySystem->allFrees->[$s]--;                                               # Count allocations and frees on this chain - free always works beyond this point | 
| 130 |  |  |  |  |  |  |  | 
| 131 | 965 |  |  |  |  | 979 | delete $buddySystem->usedSize->{$alloc};                                      # Remove information appertaining to this block | 
| 132 | 965 |  |  |  |  | 1070 | delete $buddySystem->wentTo->{$alloc}; | 
| 133 | 965 |  |  |  |  | 991 | delete $buddySystem->cameFrom->{$alloc}; | 
| 134 |  |  |  |  |  |  |  | 
| 135 | 965 |  |  |  |  | 985 | my $S = $buddySystem->size-1;                                                 # Freeing will not make the system larger | 
| 136 | 965 |  |  |  |  | 1167 | for my $c($s..$S)                                                             # Merge buddies | 
| 137 | 1840 |  |  |  |  | 1724 | {my $f = $buddySystem->freeChains->[$c];                                     # Free chain involved | 
| 138 | 1840 |  |  |  |  | 1401 | my $C = (1<<($c+1));                                                        # Modulus to get upper or lower buddy of a pair | 
| 139 | 1840 |  |  |  |  | 1420 | my $u = $alloc % $C;                                                        # True if this the upper block of a buddy pair | 
| 140 | 1840 | 100 |  |  |  | 2240 | my $b = $alloc + ($u ? -$C : +$C) / 2;                                      # Locate possible buddy | 
| 141 | 1840 | 100 |  |  |  | 1618 | if (delete $buddySystem->freeChains->[$c]{$b})                              # Remove buddy if it exists | 
|  |  | 100 |  |  |  |  |  | 
| 142 | 875 | 100 |  |  |  | 1125 | {$alloc = $u ? $b : $alloc;                                                # New block to place on next free chain | 
| 143 |  |  |  |  |  |  | } | 
| 144 |  |  |  |  |  |  | elsif ($c < $S) | 
| 145 | 919 |  |  |  |  | 861 | {$buddySystem->freeChains->[$c]{$alloc}++;                                 # Place this unpaired block on free chain | 
| 146 | 919 |  |  |  |  | 18088 | return 1;                                                                 # Finished successfully - no block merges | 
| 147 |  |  |  |  |  |  | } | 
| 148 |  |  |  |  |  |  | else                                                                        # Remove excess free chains | 
| 149 | 46 |  |  |  |  | 53 | {my $c = $buddySystem->freeChains; | 
| 150 | 46 |  |  |  |  | 59 | my $a = $buddySystem->allFrees; | 
| 151 | 46 |  |  |  |  | 65 | for(1..@$c)                                                               # Remove a chain if it has nothing allocated | 
| 152 | 306 |  |  |  |  | 204 | {my $i = @$c-$_; | 
| 153 | 306 | 50 |  |  |  | 368 | last if $a->[$i]; | 
| 154 | 306 | 100 |  |  |  | 392 | pop @$a if $i < @$a; | 
| 155 | 306 |  |  |  |  | 278 | pop @$c; | 
| 156 |  |  |  |  |  |  | } | 
| 157 | 46 |  |  |  |  | 971 | return 2;                                                                 # Finished successfully - one or more blocks were merged | 
| 158 |  |  |  |  |  |  | } | 
| 159 |  |  |  |  |  |  | } | 
| 160 | 0 |  |  |  |  | 0 | confess "This code should be unreachable"                                     # Unreachable | 
| 161 |  |  |  |  |  |  | } # free | 
| 162 |  |  |  |  |  |  |  | 
| 163 |  |  |  |  |  |  | #2 Statistics                                                                   # These methods provide statistics on memory usage in the buddy system | 
| 164 |  |  |  |  |  |  |  | 
| 165 |  |  |  |  |  |  | sub usedSpace($)                                                                # Total allocated space in this buddy system | 
| 166 | 1100 |  |  | 1100 | 1 | 768 | {my ($buddySystem) = @_;                                                       # Buddy system | 
| 167 | 1100 |  |  |  |  | 738 | my $n = 0; | 
| 168 | 1100 |  |  |  |  | 1230 | my $u = $buddySystem->usedSize; | 
| 169 | 1100 |  |  |  |  | 49394 | $n += (1<<$u->{$_}) for keys %$u; | 
| 170 | 1100 |  |  |  |  | 5409 | $n | 
| 171 |  |  |  |  |  |  | } # usedSpace | 
| 172 |  |  |  |  |  |  |  | 
| 173 |  |  |  |  |  |  | sub freeSpace($)                                                                # Total free space that can still be allocated in this buddy system without changing its size | 
| 174 | 2099 |  |  | 2099 | 1 | 1490 | {my ($buddySystem) = @_;                                                       # Buddy system | 
| 175 | 2099 |  |  |  |  | 1408 | my $n = 0; | 
| 176 | 2099 |  |  |  |  | 2049 | for(0..$buddySystem->size-1) | 
| 177 | 32412 |  |  |  |  | 27843 | {my $f = $buddySystem->freeChains->[$_]; | 
| 178 | 32412 | 100 |  |  |  | 36772 | next unless $f; | 
| 179 | 30218 |  |  |  |  | 25180 | $n += scalar(keys %$f) * (1<<$_); | 
| 180 |  |  |  |  |  |  | } | 
| 181 |  |  |  |  |  |  | $n | 
| 182 | 2099 |  |  |  |  | 1784 | } # freeSpace | 
| 183 |  |  |  |  |  |  |  | 
| 184 |  |  |  |  |  |  | sub totalSpace($)                                                               # Total space currently occupied by this buddy system | 
| 185 | 2371 |  |  | 2371 | 1 | 1701 | {my ($buddySystem) = @_;                                                       # Buddy system | 
| 186 | 2371 |  |  |  |  | 2341 | my $n = $buddySystem->size; | 
| 187 | 2371 | 100 |  |  |  | 3165 | return 0 unless $n; | 
| 188 | 2291 |  |  |  |  | 2098 | 1 << ($buddySystem->size-1)                                                   # System invariant | 
| 189 |  |  |  |  |  |  | } # totalSpace | 
| 190 |  |  |  |  |  |  |  | 
| 191 |  |  |  |  |  |  | sub fractionalFreeSpace($)                                                      ## Fraction of space currently free vs total space | 
| 192 | 1015 |  |  | 1015 | 0 | 788 | {my ($buddySystem) = @_;                                                       # Buddy system | 
| 193 | 1015 |  |  |  |  | 1100 | my $t = $buddySystem->totalSpace; | 
| 194 | 1015 |  |  |  |  | 1182 | my $f = $buddySystem->freeSpace; | 
| 195 | 1015 | 50 |  |  |  | 1345 | return 1 unless $t > 0; | 
| 196 | 1015 |  |  |  |  | 19331 | $f / $t | 
| 197 |  |  |  |  |  |  | } # fractionalFreeSpace | 
| 198 |  |  |  |  |  |  |  | 
| 199 |  |  |  |  |  |  | sub checkSpace($)                                                               ## Check free space and used space match total space | 
| 200 | 1084 |  |  | 1084 | 0 | 959 | {my ($buddySystem) = @_;                                                       # Buddy system | 
| 201 | 1084 |  |  |  |  | 723 | my $b = $buddySystem;                                                         # Shorten | 
| 202 | 1084 |  |  |  |  | 1137 | my $u = $b->usedSpace; | 
| 203 | 1084 |  |  |  |  | 1232 | my $f = $b->freeSpace; | 
| 204 | 1084 |  |  |  |  | 1168 | my $t = $b->totalSpace; | 
| 205 | 1084 |  |  |  |  | 919 | my $T = $u + $f; | 
| 206 | 1084 | 50 |  |  |  | 1420 | confess "checkSpace failed used=$u free=$f used+free=$T != total=$t\n" | 
| 207 |  |  |  |  |  |  | #   .dump($b)."\n" | 
| 208 |  |  |  |  |  |  | unless $u+$f == $t; | 
| 209 |  |  |  |  |  |  |  | 
| 210 | 1084 |  |  |  |  | 649 | if (1)                                                                        # Confirm used space matches allocated space | 
| 211 | 1084 |  |  |  |  | 705 | {my $n = 0; | 
| 212 | 1084 |  |  |  |  | 1064 | for my $s(0..$b->size-1)                                                    # All the free chains | 
| 213 | 16287 |  | 100 |  |  | 14399 | {$n += ($b->allFrees->[$s]//0) * (1<<$s);                                  # Number of currently allocated blocks of this size | 
| 214 |  |  |  |  |  |  | } | 
| 215 | 1084 | 50 |  |  |  | 1540 | confess "checkSpace failed used=$u n=$n" | 
| 216 |  |  |  |  |  |  | #   .dump($b)."\n" | 
| 217 |  |  |  |  |  |  | unless $u == $n; | 
| 218 |  |  |  |  |  |  | } | 
| 219 |  |  |  |  |  |  |  | 
| 220 |  |  |  |  |  |  | 1 | 
| 221 | 1084 |  |  |  |  | 21444 | } # checkSpace | 
| 222 |  |  |  |  |  |  |  | 
| 223 |  |  |  |  |  |  | sub visualise($$)                                                               ## Create a pictorial representation of the buddy system with free in lowercase and used in uppercase. Confess if free and used chains are inconsistent | 
| 224 | 82 |  |  | 82 | 0 | 85 | {my ($buddySystem, $title) = @_;                                               # BuddySystem, title | 
| 225 | 82 |  |  |  |  | 108 | my $S = $buddySystem->size;                                                   # Size of system | 
| 226 | 82 |  |  |  |  | 67 | my $L = 26;                                                                   # Length of alphabet | 
| 227 | 82 |  |  |  |  | 146 | my @A = map {chr(ord('a')-1+$_)} 1..$L;                                       # Use lowercase for free areas and upper case for used areas | 
|  | 2132 |  |  |  |  | 1939 |  | 
| 228 | 82 |  |  |  |  | 145 | my $e = 0; my $x = 0;                                                         # Number of error cells, number of cells examined | 
|  | 82 |  |  |  |  | 60 |  | 
| 229 |  |  |  |  |  |  |  | 
| 230 | 82 |  |  |  |  | 112 | my @t = map {undef()} 1..$buddySystem->totalSpace;                            # Long representation | 
|  | 150481 |  |  |  |  | 102760 |  | 
| 231 | 82 |  |  |  |  | 4301 | for my $B(0..$S-1)                                                            # All the free/used blocks | 
| 232 | 543 |  |  |  |  | 357 | {my $s = (1<<$B);                                                            # Size of free blocks on this chain | 
| 233 | 543 | 100 |  |  |  | 599 | if (my $F = $buddySystem->freeChains->[$B])                                 # Free blocks of this size | 
| 234 | 223 |  |  |  |  | 488 | {for my $f(sort {$a <=> $b} keys %$F)                                      # Free block | 
|  | 14 |  |  |  |  | 39 |  | 
| 235 | 100 |  |  |  |  | 153 | {for(0..$s-1)                                                            # Each cell of free block | 
| 236 | 131634 |  |  |  |  | 81011 | {my $o = $f+$_;                                                        # Offset | 
| 237 | 131634 |  |  |  |  | 87257 | my $c = $A[$B % $L];                                                  # Marker character for free block | 
| 238 | 131634 |  |  |  |  | 74513 | ++$x;                                                                 # Examined cells count | 
| 239 | 131634 | 50 |  |  |  | 116992 | if (defined($t[$o])) {++$e; $t[$o] = '*'} else {$t[$o] = $c}          # Do not overwrite previous free or used block | 
|  | 0 |  |  |  |  | 0 |  | 
|  | 0 |  |  |  |  | 0 |  | 
|  | 131634 |  |  |  |  | 116948 |  | 
| 240 |  |  |  |  |  |  | } | 
| 241 |  |  |  |  |  |  | } | 
| 242 |  |  |  |  |  |  | } | 
| 243 |  |  |  |  |  |  | } | 
| 244 | 82 | 50 |  |  |  | 114 | if (my $U = $buddySystem->usedSize)                                           # Used blocks | 
| 245 | 82 |  |  |  |  | 235 | {for my $u(sort {$a <=> $b} keys %$U)                                        # Used blocks in ascending order of offset | 
|  | 290 |  |  |  |  | 289 |  | 
| 246 | 216 |  |  |  |  | 212 | {my $s = $U->{$u};                                                         # Size of this used block | 
| 247 | 216 |  |  |  |  | 223 | for(1..(1<<$s))                                                           # Each cell of used block | 
| 248 | 18847 |  |  |  |  | 12649 | {my $o = $u+$_-1;                                                        # Offset | 
| 249 | 18847 |  |  |  |  | 13109 | my $c = $A[$s % $L];                                                    # Marker character for used block | 
| 250 | 18847 |  |  |  |  | 10945 | ++$x; | 
| 251 | 18847 | 50 |  |  |  | 17350 | if (defined($t[$o])) {++$e; $t[$o] = '*'} else {$t[$o] = uc $c}         # Do not overwrite previous free or used block | 
|  | 0 |  |  |  |  | 0 |  | 
|  | 0 |  |  |  |  | 0 |  | 
|  | 18847 |  |  |  |  | 17089 |  | 
| 252 |  |  |  |  |  |  | } | 
| 253 |  |  |  |  |  |  | } | 
| 254 |  |  |  |  |  |  | } | 
| 255 | 82 | 50 | 33 |  |  | 259 | if ($e or $x != $buddySystem->totalSpace)                                     # Inconsistent state detected | 
| 256 | 1 |  |  | 1 |  | 4 | {use Data::Dump qw(dump); | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 37 |  | 
| 257 | 1 |  |  | 1 |  | 4 | use Carp; | 
|  | 1 |  |  |  |  | 5 |  | 
|  | 1 |  |  |  |  | 725 |  | 
| 258 | 0 |  |  |  |  | 0 | say STDOUT "Inconsistent State!"; | 
| 259 | 0 |  |  |  |  | 0 | say STDOUT "  e=$e  x=$x length=", $buddySystem->totalSpace; | 
| 260 | 0 |  |  |  |  | 0 | say STDOUT "  ", dump($buddySystem); | 
| 261 | 0 |  | 0 |  |  | 0 | say STDOUT '=', join '', map {$_//'*'} @t, "="; | 
|  | 0 |  |  |  |  | 0 |  | 
| 262 | 0 |  |  |  |  | 0 | confess "Inconsistent state"; | 
| 263 |  |  |  |  |  |  | } | 
| 264 |  |  |  |  |  |  |  | 
| 265 | 82 |  |  |  |  | 126 | my @T = map {''} 1..$buddySystem->totalSpace;                                 # Short representation | 
|  | 150481 |  |  |  |  | 125379 |  | 
| 266 | 82 |  |  |  |  | 4812 | for my $B(0..$S-1)                                                            # All the free/used blocks | 
| 267 | 543 |  |  |  |  | 368 | {my $s = (1<<$B);                                                            # Size of free blocks on this chain | 
| 268 | 543 | 100 |  |  |  | 531 | if (my $F = $buddySystem->freeChains->[$B])                                 # Free blocks of this size | 
| 269 | 223 |  |  |  |  | 547 | {$T[$_] = $A[$B % $L] for sort {$a <=> $b} keys %$F;                       # Free block | 
|  | 14 |  |  |  |  | 53 |  | 
| 270 |  |  |  |  |  |  | } | 
| 271 |  |  |  |  |  |  | } | 
| 272 | 82 | 50 |  |  |  | 105 | if (my $U = $buddySystem->usedSize)                                           # Used blocks | 
| 273 | 82 |  |  |  |  | 166 | {for my $u(sort {$a <=> $b} keys %$U)                                        # Used blocks in ascending order of offset | 
|  | 290 |  |  |  |  | 258 |  | 
| 274 | 216 |  |  |  |  | 173 | {my $s = $U->{$u};                                                         # Size of this used block | 
| 275 | 216 |  |  |  |  | 261 | $T[$u] = uc $A[$s % $L]; | 
| 276 |  |  |  |  |  |  | } | 
| 277 |  |  |  |  |  |  | } | 
| 278 | 82 |  |  |  |  | 3269 | my $T = join '', @T;                                                          # Representation as a string | 
| 279 | 82 | 100 |  |  |  | 274 | say STDOUT "$title $T" if $title; | 
| 280 | 82 |  |  |  |  | 18687 | $T | 
| 281 |  |  |  |  |  |  | } # visualise | 
| 282 |  |  |  |  |  |  |  | 
| 283 |  |  |  |  |  |  | #2 Relocation                                                                   # These methods copy one buddy system to another compacting free space in the process. | 
| 284 |  |  |  |  |  |  | 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 positions in the new buddy system will still be accessible by their original address or name | 
| 285 | 2 |  |  | 2 | 1 | 3 | {my ($buddySystem, $order, $copy) = @_;                                        # Buddy system, order, optional copy method to copy an old allocation into its corresponding new allocation | 
| 286 | 2 |  |  |  |  | 7 | my $n = new;                                                                  # The new buddy system | 
| 287 |  |  |  |  |  |  |  | 
| 288 | 2 | 50 |  |  |  | 6 | if (my $u = $buddySystem->usedSize)                                           # Used blocks decreasing in size but increasing by address within each size | 
| 289 |  |  |  |  |  |  | {my @u = sort | 
| 290 | 2 | 100 |  |  |  | 37 | {my $c = $order ? $u->{$b} <=> $u->{$a} : $u->{$a} <=> $u->{$b};           # 0 - Ascending, 1 - Descending order | 
|  | 71 |  |  |  |  | 81 |  | 
| 291 | 71 | 100 |  |  |  | 81 | return $c unless $c == 0; | 
| 292 | 17 |  |  |  |  | 22 | $a <=> $b                                                                 # Ascending address | 
| 293 |  |  |  |  |  |  | } keys %$u; | 
| 294 |  |  |  |  |  |  |  | 
| 295 | 2 |  |  |  |  | 6 | for my $a(@u)                                                               # Each used block | 
| 296 | 26 |  |  |  |  | 24 | {my $size = $u->{$a};                                                      # Size of this block | 
| 297 | 26 |  |  |  |  | 16 | my $A;                                                                    # Address of relocated block | 
| 298 | 26 | 100 |  |  |  | 58 | if (my $name = $buddySystem->allocName->{$a})                             # Name attached to the block | 
| 299 | 9 |  |  |  |  | 11 | {$A = $n->allocField($name, $size);                                      # Create new block with same name in new buddy system | 
| 300 |  |  |  |  |  |  | } | 
| 301 |  |  |  |  |  |  | else | 
| 302 | 17 |  |  |  |  | 19 | {$A = $n->alloc($size);                                                  # Matching block in new buddy system | 
| 303 |  |  |  |  |  |  | } | 
| 304 | 26 | 50 |  |  |  | 40 | $copy->($a, $A, $size) if $copy;                                          # Copy data from old block to new block, using the specified size | 
| 305 | 26 | 50 |  |  |  | 32 | if (my $f = $buddySystem->cameFrom->{$a})                                 # Address this block originally came from if different from new address | 
| 306 | 0 | 0 |  |  |  | 0 | {if ($f != $A)                                                           # Record new position if different | 
| 307 | 0 |  |  |  |  | 0 | {$n->cameFrom->{$A} = $f;                                              # The original address at which the block was allocated | 
| 308 | 0 |  |  |  |  | 0 | $n->wentTo  ->{$f} = $A;                                              # The current address of a block from its original address | 
| 309 |  |  |  |  |  |  | } | 
| 310 |  |  |  |  |  |  | } | 
| 311 |  |  |  |  |  |  | } | 
| 312 |  |  |  |  |  |  | } | 
| 313 |  |  |  |  |  |  | $n | 
| 314 | 2 |  |  |  |  | 33 | } # copy | 
| 315 |  |  |  |  |  |  |  | 
| 316 |  |  |  |  |  |  | sub copyLargestLast($;$)                                                        # Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed last | 
| 317 | 1 |  |  | 1 | 1 | 2 | {my ($buddySystem, $copy) = @_;                                                # BuddySystem, copy method to copy an old allocation into a new allocation | 
| 318 | 1 |  |  |  |  | 4 | copy($buddySystem, 0, $copy);                                                 # Copy the buddy system | 
| 319 |  |  |  |  |  |  | } # copyLargestLast | 
| 320 |  |  |  |  |  |  |  | 
| 321 |  |  |  |  |  |  | sub copyLargestFirst($;$)                                                       # Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed first | 
| 322 | 1 |  |  | 1 | 1 | 3 | {my ($buddySystem, $copy) = @_;                                                # BuddySystem, copy method to copy an old allocation into a new allocation | 
| 323 | 1 |  |  |  |  | 5 | copy($buddySystem, 1, $copy);                                                 # Copy the buddy system | 
| 324 |  |  |  |  |  |  | } # copyLargestFirst | 
| 325 |  |  |  |  |  |  |  | 
| 326 |  |  |  |  |  |  |  | 
| 327 |  |  |  |  |  |  | #2 Structure                                                                    # This method generates a blessed sub whose methods provide named access to allocations backed by a L string | 
| 328 |  |  |  |  |  |  | sub generateStructureFields($$)                                                 # Return a blessed sub whose methods access the named blocks in the buddy system. The blessed sub returns a text representation of the method definitions | 
| 329 | 1 |  |  | 1 | 1 | 2 | {my ($buddySystem, $package) = @_;                                             # Buddy system, structure name | 
| 330 | 1 |  |  |  |  | 2 | my $new    = $buddySystem->copyLargestLast;                                   # Organise the buddy system by element size | 
| 331 | 1 |  |  |  |  | 2 | my %allocs = %{$new->allocName};                                              # Named allocations | 
|  | 1 |  |  |  |  | 2 |  | 
| 332 | 1 |  |  |  |  | 3 | my %sizes  = %{$new->usedSize};                                               # Size of each named allocation | 
|  | 1 |  |  |  |  | 2 |  | 
| 333 | 1 |  |  |  |  | 4 | my $s = < | 
| 334 |  |  |  |  |  |  | package $package; | 
| 335 |  |  |  |  |  |  | use utf8; | 
| 336 |  |  |  |  |  |  | END | 
| 337 | 1 |  |  |  |  | 1 | my @s; | 
| 338 | 1 |  |  |  |  | 4 | for my $alloc(sort {$a<=>$b} keys %allocs) | 
|  | 21 |  |  |  |  | 21 |  | 
| 339 | 9 |  |  |  |  | 9 | {my $name = $allocs{$alloc};                                                 # Name of block | 
| 340 | 9 |  |  |  |  | 5 | my $size = $sizes{$alloc};                                                  # Log2 width of block | 
| 341 | 9 |  |  |  |  | 11 | my $bits = 2**$size;                                                        # Block size in vec terms | 
| 342 | 9 |  |  |  |  | 11 | my $offset = $alloc/$bits;                                                  # Block offset in vec terms | 
| 343 | 9 | 50 |  |  |  | 17 | $offset == int($offset) or                                                  # Something has gone seriously wrong if this calculation fails to produce an integer | 
| 344 |  |  |  |  |  |  | confess "Offset should be an integer not $offset"; | 
| 345 | 9 |  |  |  |  | 27 | push @s,                                                                    # Generate an lvalue sub to access the block by the assigned name | 
| 346 |  |  |  |  |  |  | ["sub $name", " :lvalue {vec(\$_[1], ", $offset.", ",  $bits, ")}\n"]; | 
| 347 |  |  |  |  |  |  | } | 
| 348 | 1 |  |  |  |  | 7 | $s .= formatTableBasic([@s]);                                                 # Layout the method definitions so they are easy to read | 
| 349 | 1 |  |  | 1 |  | 5 | eval $s;                                                                      # Generate methods | 
|  | 1 |  |  | 2 |  | 1 |  | 
|  | 1 |  |  | 2 |  | 8 |  | 
|  | 1 |  |  | 0 |  | 507 |  | 
|  | 2 |  |  | 3 |  | 25 |  | 
|  | 2 |  |  | 3 |  | 26 |  | 
|  | 0 |  |  | 3 |  | 0 |  | 
|  | 3 |  |  | 0 |  | 31 |  | 
|  | 3 |  |  | 4 |  | 31 |  | 
|  | 3 |  |  | 1 |  | 40 |  | 
|  | 0 |  |  |  |  | 0 |  | 
|  | 4 |  |  |  |  | 48 |  | 
|  | 1 |  |  |  |  | 20 |  | 
| 350 | 1 | 50 |  |  |  | 180 | $@ and confess "$s\n$@"; | 
| 351 | 1 |  |  |  |  | 3 | my $p = < | 
| 352 |  |  |  |  |  |  | bless sub {\$s}, "$package"; | 
| 353 |  |  |  |  |  |  | END | 
| 354 | 1 |  |  |  |  | 59 | my $P = eval $p;                                                              # Generate the blessed sub whose value is the text representation if its methods | 
| 355 | 1 | 50 |  |  |  | 3 | $@ and confess "$p\n$@"; | 
| 356 | 1 |  |  |  |  | 34 | $P | 
| 357 |  |  |  |  |  |  | } # generateStructureFields | 
| 358 |  |  |  |  |  |  |  | 
| 359 |  |  |  |  |  |  | # Test | 
| 360 | 1 | 50 |  | 1 | 0 | 512 | sub test{eval join('', ) or die $@} | 
|  | 1 |  |  | 1 |  | 29 |  | 
|  | 1 |  |  | 1 |  | 4 |  | 
|  | 1 |  |  |  |  | 549 |  | 
|  | 1 |  |  |  |  | 11647 |  | 
|  | 1 |  |  |  |  | 7 |  | 
|  | 1 |  |  |  |  | 180 |  | 
| 361 |  |  |  |  |  |  |  | 
| 362 |  |  |  |  |  |  | test unless caller; | 
| 363 |  |  |  |  |  |  |  | 
| 364 |  |  |  |  |  |  | # Documentation | 
| 365 |  |  |  |  |  |  | #extractDocumentation() unless caller;                                          # Extract the documentation | 
| 366 |  |  |  |  |  |  |  | 
| 367 |  |  |  |  |  |  | 1; | 
| 368 |  |  |  |  |  |  |  | 
| 369 |  |  |  |  |  |  | =encoding utf-8 | 
| 370 |  |  |  |  |  |  |  | 
| 371 |  |  |  |  |  |  | =head1 Name | 
| 372 |  |  |  |  |  |  |  | 
| 373 |  |  |  |  |  |  | Data::Layout::BuddySystem - Layout data in memory allocated via a buddy system | 
| 374 |  |  |  |  |  |  |  | 
| 375 |  |  |  |  |  |  | =head1 Synopsis | 
| 376 |  |  |  |  |  |  |  | 
| 377 |  |  |  |  |  |  | use Test::More tests=>10; | 
| 378 |  |  |  |  |  |  | use Data::Layout::BuddySystem; | 
| 379 |  |  |  |  |  |  | use utf8; | 
| 380 |  |  |  |  |  |  |  | 
| 381 |  |  |  |  |  |  | my $b = Data::Layout::BuddySystem::new;                                        # Create a new buddy system | 
| 382 |  |  |  |  |  |  |  | 
| 383 |  |  |  |  |  |  | $b->allocField(@$_) for                                                        # Allocate fields in the buddy system | 
| 384 |  |  |  |  |  |  | [𝝳=>6], [𝝰=>0], [𝝙=>6],[𝝱=>0],[𝞈 =>4], [𝝺=>5], [𝝲=>0], [𝝖=>3], [𝝗=>3];       # Name and log2 size of each field | 
| 385 |  |  |  |  |  |  |  | 
| 386 |  |  |  |  |  |  | my $s = $b->generateStructureFields('Struct');                                 # Generate structure definition | 
| 387 |  |  |  |  |  |  |  | 
| 388 |  |  |  |  |  |  | ok nws($s->()) eq nws(<<'END');                                                # String representation of methods associated with generated structure | 
| 389 |  |  |  |  |  |  | package Struct; | 
| 390 |  |  |  |  |  |  | use utf8; | 
| 391 |  |  |  |  |  |  | sub 𝝰    :lvalue {vec($_[1],   0,    1  )} | 
| 392 |  |  |  |  |  |  | sub 𝝱    :lvalue {vec($_[1],   1,    1  )} | 
| 393 |  |  |  |  |  |  | sub 𝝲    :lvalue {vec($_[1],   2,    1  )} | 
| 394 |  |  |  |  |  |  | sub 𝝖    :lvalue {vec($_[1],   1,    8  )} | 
| 395 |  |  |  |  |  |  | sub 𝝗    :lvalue {vec($_[1],   2,    8  )} | 
| 396 |  |  |  |  |  |  | sub 𝞈   :lvalue {vec($_[1],   2,   16  )} | 
| 397 |  |  |  |  |  |  | sub 𝝺    :lvalue {vec($_[1],   2,   32  )} | 
| 398 |  |  |  |  |  |  | sub 𝝳    :lvalue {vec($_[1],   2,   64  )} | 
| 399 |  |  |  |  |  |  | sub 𝝙    :lvalue {vec($_[1],   3,   64  )} | 
| 400 |  |  |  |  |  |  | END | 
| 401 |  |  |  |  |  |  |  | 
| 402 |  |  |  |  |  |  | if (1)                                                                        # Set fields | 
| 403 |  |  |  |  |  |  | {$s->𝝰(my $𝕄) = 1; ok $𝕄 eq "\1"; | 
| 404 |  |  |  |  |  |  | $s->𝝱(   $𝕄) = 0; ok $𝕄 eq "\1"; | 
| 405 |  |  |  |  |  |  | $s->𝝲(   $𝕄) = 1; ok $𝕄 eq "\5"; | 
| 406 |  |  |  |  |  |  | $s->𝝖(   $𝕄) = 3; ok $𝕄 eq "\x05\x03";                                      # Byte fields | 
| 407 |  |  |  |  |  |  | $s->𝝗(   $𝕄) = 7; ok $𝕄 eq "\x05\x03\x07"; | 
| 408 |  |  |  |  |  |  | $s->𝞈(   $𝕄) = 9; ok $𝕄 eq "\x05\x03\x07\x00\x00\x09";                      # Word field | 
| 409 |  |  |  |  |  |  | } | 
| 410 |  |  |  |  |  |  |  | 
| 411 |  |  |  |  |  |  | if (1)                                                                        # Set and get an integer field | 
| 412 |  |  |  |  |  |  | {$s->𝝺(my $𝕄) = 2; ok $s->𝝺($𝕄) == 2;                                        # Set field | 
| 413 |  |  |  |  |  |  | $s->𝝺(   $𝕄)++;   ok $s->𝝺($𝕄) == 3;                                        # Increment field | 
| 414 |  |  |  |  |  |  | ok $𝕄 eq "\0\0\0\0\0\0\0\0\0\0\0\3";                                        # Dump the memory organised by the buddy system | 
| 415 |  |  |  |  |  |  | } | 
| 416 |  |  |  |  |  |  |  | 
| 417 |  |  |  |  |  |  | =head1 Description | 
| 418 |  |  |  |  |  |  |  | 
| 419 |  |  |  |  |  |  | Implements the buddy system described at L | 
| 420 |  |  |  |  |  |  | in 100% Pure Perl.  Blocks can be identified by names or addresses which remain | 
| 421 |  |  |  |  |  |  | invariant even after one buddy system has been copied to a new one to compact | 
| 422 |  |  |  |  |  |  | free space. Each named allocation can be accessed via a generated method which | 
| 423 |  |  |  |  |  |  | identifies an lvalue area of a L string used to back the memory | 
| 424 |  |  |  |  |  |  | organised by the buddy system. | 
| 425 |  |  |  |  |  |  |  | 
| 426 |  |  |  |  |  |  |  | 
| 427 |  |  |  |  |  |  | =head1 Methods | 
| 428 |  |  |  |  |  |  |  | 
| 429 |  |  |  |  |  |  | =head2 new() | 
| 430 |  |  |  |  |  |  |  | 
| 431 |  |  |  |  |  |  | Create a new Buddy system | 
| 432 |  |  |  |  |  |  |  | 
| 433 |  |  |  |  |  |  |  | 
| 434 |  |  |  |  |  |  | =head2 allocField($buddySystem, $name, $size) | 
| 435 |  |  |  |  |  |  |  | 
| 436 |  |  |  |  |  |  | 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 return the address of its location in the buddy system | 
| 437 |  |  |  |  |  |  |  | 
| 438 |  |  |  |  |  |  | Parameter     Description | 
| 439 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 440 |  |  |  |  |  |  | 2  $name         name of block | 
| 441 |  |  |  |  |  |  | 3  $size         integer log2(size of allocation) | 
| 442 |  |  |  |  |  |  |  | 
| 443 |  |  |  |  |  |  | =head2 alloc($buddySystem, $size) | 
| 444 |  |  |  |  |  |  |  | 
| 445 |  |  |  |  |  |  | Allocate a block and return its address | 
| 446 |  |  |  |  |  |  |  | 
| 447 |  |  |  |  |  |  | Parameter     Description | 
| 448 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 449 |  |  |  |  |  |  | 2  $size         integer log2(size of allocation) | 
| 450 |  |  |  |  |  |  |  | 
| 451 |  |  |  |  |  |  | =head2 locateAddress($buddySystem, $alloc) | 
| 452 |  |  |  |  |  |  |  | 
| 453 |  |  |  |  |  |  | Find the current location of a block by its original address after it has been copied to a new buddy system | 
| 454 |  |  |  |  |  |  |  | 
| 455 |  |  |  |  |  |  | Parameter     Description | 
| 456 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 457 |  |  |  |  |  |  | 2  $alloc        address at which the block was originally located | 
| 458 |  |  |  |  |  |  |  | 
| 459 |  |  |  |  |  |  | =head2 locateName($buddySystem, $name) | 
| 460 |  |  |  |  |  |  |  | 
| 461 |  |  |  |  |  |  | Find the current location of a named block after it has been copied to a new buddy system | 
| 462 |  |  |  |  |  |  |  | 
| 463 |  |  |  |  |  |  | Parameter     Description | 
| 464 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 465 |  |  |  |  |  |  | 2  $name         name of the block | 
| 466 |  |  |  |  |  |  |  | 
| 467 |  |  |  |  |  |  | =head2 freeName($buddySystem, $name) | 
| 468 |  |  |  |  |  |  |  | 
| 469 |  |  |  |  |  |  | Free an allocated block via its name | 
| 470 |  |  |  |  |  |  |  | 
| 471 |  |  |  |  |  |  | Parameter     Description | 
| 472 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 473 |  |  |  |  |  |  | 2  $name         name used to allocate block | 
| 474 |  |  |  |  |  |  |  | 
| 475 |  |  |  |  |  |  | =head2 free($buddySystem, $alloc) | 
| 476 |  |  |  |  |  |  |  | 
| 477 |  |  |  |  |  |  | Free an allocation via its original allocation address | 
| 478 |  |  |  |  |  |  |  | 
| 479 |  |  |  |  |  |  | Parameter     Description | 
| 480 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 481 |  |  |  |  |  |  | 2  $alloc        original allocation address | 
| 482 |  |  |  |  |  |  |  | 
| 483 |  |  |  |  |  |  | =head2 Statistics | 
| 484 |  |  |  |  |  |  |  | 
| 485 |  |  |  |  |  |  | These methods provide statistics on memory usage in the buddy system | 
| 486 |  |  |  |  |  |  |  | 
| 487 |  |  |  |  |  |  | =head3 usedSpace($buddySystem) | 
| 488 |  |  |  |  |  |  |  | 
| 489 |  |  |  |  |  |  | Total allocated space in this buddy system | 
| 490 |  |  |  |  |  |  |  | 
| 491 |  |  |  |  |  |  | Parameter     Description | 
| 492 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 493 |  |  |  |  |  |  |  | 
| 494 |  |  |  |  |  |  | =head3 freeSpace($buddySystem) | 
| 495 |  |  |  |  |  |  |  | 
| 496 |  |  |  |  |  |  | Total free space that can still be allocated in this buddy system without changing its size | 
| 497 |  |  |  |  |  |  |  | 
| 498 |  |  |  |  |  |  | Parameter     Description | 
| 499 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 500 |  |  |  |  |  |  |  | 
| 501 |  |  |  |  |  |  | =head3 totalSpace($buddySystem) | 
| 502 |  |  |  |  |  |  |  | 
| 503 |  |  |  |  |  |  | Total space currently occupied by this buddy system | 
| 504 |  |  |  |  |  |  |  | 
| 505 |  |  |  |  |  |  | Parameter     Description | 
| 506 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 507 |  |  |  |  |  |  |  | 
| 508 |  |  |  |  |  |  | =head2 Relocation | 
| 509 |  |  |  |  |  |  |  | 
| 510 |  |  |  |  |  |  | These methods copy one buddy system to another compacting free space in the process. | 
| 511 |  |  |  |  |  |  |  | 
| 512 |  |  |  |  |  |  | =head3 copy($buddySystem, $order, $copy) | 
| 513 |  |  |  |  |  |  |  | 
| 514 |  |  |  |  |  |  | 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 name | 
| 515 |  |  |  |  |  |  |  | 
| 516 |  |  |  |  |  |  | Parameter     Description | 
| 517 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 518 |  |  |  |  |  |  | 2  $order        order | 
| 519 |  |  |  |  |  |  | 3  $copy         optional copy method to copy an old allocation into its corresponding new allocation | 
| 520 |  |  |  |  |  |  |  | 
| 521 |  |  |  |  |  |  | =head3 copyLargestLast($buddySystem, $copy) | 
| 522 |  |  |  |  |  |  |  | 
| 523 |  |  |  |  |  |  | Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed last | 
| 524 |  |  |  |  |  |  |  | 
| 525 |  |  |  |  |  |  | Parameter     Description | 
| 526 |  |  |  |  |  |  | 1  $buddySystem  BuddySystem | 
| 527 |  |  |  |  |  |  | 2  $copy         copy method to copy an old allocation into a new allocation | 
| 528 |  |  |  |  |  |  |  | 
| 529 |  |  |  |  |  |  | =head3 copyLargestFirst($buddySystem, $copy) | 
| 530 |  |  |  |  |  |  |  | 
| 531 |  |  |  |  |  |  | Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed first | 
| 532 |  |  |  |  |  |  |  | 
| 533 |  |  |  |  |  |  | Parameter     Description | 
| 534 |  |  |  |  |  |  | 1  $buddySystem  BuddySystem | 
| 535 |  |  |  |  |  |  | 2  $copy         copy method to copy an old allocation into a new allocation | 
| 536 |  |  |  |  |  |  |  | 
| 537 |  |  |  |  |  |  | =head2 Structure | 
| 538 |  |  |  |  |  |  |  | 
| 539 |  |  |  |  |  |  | This method generates a blessed sub whose methods provide named access to allocations backed by a L string | 
| 540 |  |  |  |  |  |  |  | 
| 541 |  |  |  |  |  |  | =head3 generateStructureFields($buddySystem, $package) | 
| 542 |  |  |  |  |  |  |  | 
| 543 |  |  |  |  |  |  | Return a blessed sub whose methods access the named blocks in the buddy system. The blessed sub returns a text representation of the method definitions | 
| 544 |  |  |  |  |  |  |  | 
| 545 |  |  |  |  |  |  | Parameter     Description | 
| 546 |  |  |  |  |  |  | 1  $buddySystem  Buddy system | 
| 547 |  |  |  |  |  |  | 2  $package      structure name | 
| 548 |  |  |  |  |  |  |  | 
| 549 |  |  |  |  |  |  | =head1 Index | 
| 550 |  |  |  |  |  |  |  | 
| 551 |  |  |  |  |  |  | The following methods will be exported by the :all tag | 
| 552 |  |  |  |  |  |  |  | 
| 553 |  |  |  |  |  |  | L | 
| 554 |  |  |  |  |  |  | L | 
| 555 |  |  |  |  |  |  | L | 
| 556 |  |  |  |  |  |  | L | 
| 557 |  |  |  |  |  |  | L | 
| 558 |  |  |  |  |  |  | L | 
| 559 |  |  |  |  |  |  | L | 
| 560 |  |  |  |  |  |  | L | 
| 561 |  |  |  |  |  |  | L | 
| 562 |  |  |  |  |  |  | L | 
| 563 |  |  |  |  |  |  | L | 
| 564 |  |  |  |  |  |  | L | 
| 565 |  |  |  |  |  |  | L | 
| 566 |  |  |  |  |  |  | L | 
| 567 |  |  |  |  |  |  |  | 
| 568 |  |  |  |  |  |  | =head1 Installation | 
| 569 |  |  |  |  |  |  |  | 
| 570 |  |  |  |  |  |  | This module is written in 100% Pure Perl and is thus easy to read, modify and | 
| 571 |  |  |  |  |  |  | install. | 
| 572 |  |  |  |  |  |  |  | 
| 573 |  |  |  |  |  |  | Standard Module::Build process for building and installing modules: | 
| 574 |  |  |  |  |  |  |  | 
| 575 |  |  |  |  |  |  | perl Build.PL | 
| 576 |  |  |  |  |  |  | ./Build | 
| 577 |  |  |  |  |  |  | ./Build test | 
| 578 |  |  |  |  |  |  | ./Build install | 
| 579 |  |  |  |  |  |  |  | 
| 580 |  |  |  |  |  |  | =head1 Author | 
| 581 |  |  |  |  |  |  |  | 
| 582 |  |  |  |  |  |  | philiprbrenan@gmail.com | 
| 583 |  |  |  |  |  |  |  | 
| 584 |  |  |  |  |  |  | http://www.appaapps.com | 
| 585 |  |  |  |  |  |  |  | 
| 586 |  |  |  |  |  |  | =head1 Copyright | 
| 587 |  |  |  |  |  |  |  | 
| 588 |  |  |  |  |  |  | Copyright (c) 2016 Philip R Brenan. | 
| 589 |  |  |  |  |  |  |  | 
| 590 |  |  |  |  |  |  | This module is free software. It may be used, redistributed and/or modified | 
| 591 |  |  |  |  |  |  | under the same terms as Perl itself. | 
| 592 |  |  |  |  |  |  |  | 
| 593 |  |  |  |  |  |  | =cut | 
| 594 |  |  |  |  |  |  |  | 
| 595 |  |  |  |  |  |  | __DATA__ |