File Coverage

blib/lib/Data/Layout/BuddySystem.pm
Criterion Covered Total %
statement 245 265 92.4
branch 58 84 69.0
condition 19 24 79.1
subroutine 43 46 93.4
pod 14 28 50.0
total 379 447 84.7


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   654 use warnings FATAL => qw(all);
  1         3  
  1         42  
10 1     1   8 use strict;
  1         2  
  1         31  
11 1     1   617 use Data::Table::Text qw(:all);
  1         31260  
  1         499  
12 1     1   14 use Carp;
  1         3  
  1         2356  
13             our $VERSION = 20170808;
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 1495 {return bless {};
23             }
24              
25 52380   100 52380 0 120906 sub freeChains{$_[0]{freeChains} //= []} ## Addresses of free blocks organised by power of two size
26 4427   100 4427 0 24142 sub usedSize {$_[0]{usedSize} //= {}} ## {address} = size of allocation at that address
27 974   100 974 0 2085 sub wentTo {$_[0]{wentTo} //= {}} ## {address1} = address2 - where address 1 was relocated to by copy
28 991   100 991 0 2003 sub cameFrom {$_[0]{cameFrom} //= {}} ## {address1} = address2 - where address 1 came from before being copied
29 18415   100 18415 0 49846 sub allFrees {$_[0]{allFrees} //= []} ## [chain] = count of allocations minus frees on this chain
30 45   100 45 0 144 sub nameAlloc {$_[0]{nameAlloc} //= {}} ## {name} = name of allocation if a name has been supplied
31 45   100 45 0 122 sub allocName {$_[0]{allocName} //= {}} ## {address} = name of allocation at this address if a name has been supplied
32 11160     11160 0 15026 sub size {scalar @{$_[0]->freeChains}} ## Number of free chains in use
  11160         18256  
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 42 {my ($buddySystem, $name, $size) = @_; # Buddy system, name of block, integer log2(size of allocation)
36 18 50       38 $name or # Check name has been supplied
37             confess "Name required";
38 18 50       99 $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       45 defined($buddySystem->nameAlloc->{$name}) and # Check proposed name of allocation is not already in use
41             confess "Name already defined: $name";
42 18         38 my $alloc = $buddySystem->alloc($size); # Perform allocation
43 18         37 $buddySystem->nameAlloc->{$name} = $alloc; # Name to address of allocation
44 18         46 $buddySystem->allocName->{$alloc} = $name; # Address to name of allocation
45 18         272 $alloc # Return address of allocation
46             } # allocField
47              
48             sub alloc($$) # Allocate a block and return its bit address
49 1117     1117 1 2406 {my ($buddySystem, $size) = @_; # Buddy system, integer log2(size of allocation)
50 1117 50       2378 $size >= 0 or confess "Size must be positive, not $size";
51 1117 50       2228 $size == int($size) or confess "Size must be integral, not $size";
52 1117         2016 $buddySystem->allFrees->[$size]++; # Count allocations and frees on this chain - alloc always works
53              
54 1117 100       2225 if ($buddySystem->size == 0) # Initial allocation
55 76         166 {my $alloc = 0; # Allocation address
56 76         174 $buddySystem->freeChains->[$size] = {}; # Create chain for initial allocation
57 76         173 $buddySystem->usedSize->{$alloc} = $size; # Save size of allocation at offset
58 76         1572 return $alloc; # Return allocation
59             }
60              
61 1041         1892 for my $F($size..$buddySystem->size-1) # Look for space on the free chains
62 1932 100       3356 {if (my $f = $buddySystem->freeChains->[$F]) # Each chain
63 1885 100       4117 {if (keys %$f) # Free chain with space
64 949         2830 {for my $alloc(sort {$a <=> $b} keys %$f) # Allocation address
  68         206  
65 949         1880 {delete $f->{$alloc};
66 949         2162 $buddySystem->usedSize->{$alloc} = $size; # Save size of allocation at offset
67 949         2286 $buddySystem->freeChains->[$_]{$alloc + (1<<$_)}++ for $size..$F-1; # Return excess space to lower chains
68 949         21714 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         174 my $s = $buddySystem->size; # Size less than current allocation
75 92 100       244 if ($size < $s-1)
76 45         104 {my $F = $buddySystem->freeChains->[$s] = {}; # Create new chain
77 45         91 my $alloc = (1<<($s-1)); # Allocation address
78 45         112 $buddySystem->usedSize->{$alloc} = $size; # Allocation size
79 45         139 $buddySystem->freeChains->[$_]{$alloc + (1<<$_)}++ for $size..$s-2; # Spread excess space across lower chains
80 45         894 return $alloc
81             }
82             else # Size greater than or equal to current allocation
83 47         112 {my $F = $buddySystem->freeChains->[$size+1] = {}; # Create new chain
84 47         81 my $alloc = (1<<$size); # Allocation address
85 47         84 $buddySystem->usedSize->{$alloc} = $size; # Allocation size
86 47         109 for($s..$size) # Spread excess space across lower chains
87 51         107 {my $i = $size-($_+1-$s);
88 51         87 $buddySystem->freeChains->[$i]{(1<<$i)}++;
89             }
90 47         983 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 13 {my ($buddySystem, $alloc) = @_; # Buddy system, address at which the block was originally located
96 9   66     20 $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 16 {my ($buddySystem, $name) = @_; # Buddy system, name of the block
101 9         21 my $alloc = $buddySystem->nameAlloc->{$name}; # Address of named block
102 9 50       21 defined($alloc) or confess "No such named block: $name"; # Complain of no such block exists
103 9         18 $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 14 {my ($buddySystem, $address) = @_; # Buddy system, address of allocation whiose size we want
108 9         32 $buddySystem->{usedSize}{$address} # Size of allocation at specified address
109             } # sizeAddress
110              
111             sub sizeName($$) # Size of a named allocation
112 9     9 0 1895 {my ($buddySystem, $name) = @_; # Buddy system, address of allocation whiose size we want
113 9         18 my $address = $buddySystem->locateName($name); # Address of allocation
114 9 50       19 defined($address) or confess "No allocation with name $name"; # Check allocation by this name exists
115 9         16 $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 1899 {my ($buddySystem, $alloc) = @_; # Buddy system, original allocation address
127 965         1784 my $s = delete $buddySystem->usedSize->{$alloc}; # Size of allocation at this alloc
128 965 50       1920 return 0 unless defined($s); # No allocation present and so no free is possible
129 965         1771 $buddySystem->allFrees->[$s]--; # Count allocations and frees on this chain - free always works beyond this point
130              
131 965         1624 delete $buddySystem->usedSize->{$alloc}; # Remove information appertaining to this block
132 965         1721 delete $buddySystem->wentTo->{$alloc};
133 965         1655 delete $buddySystem->cameFrom->{$alloc};
134              
135 965         1743 my $S = $buddySystem->size-1; # Freeing will not make the system larger
136 965         2003 for my $c($s..$S) # Merge buddies
137 1840         3018 {my $f = $buddySystem->freeChains->[$c]; # Free chain involved
138 1840         2843 my $C = (1<<($c+1)); # Modulus to get upper or lower buddy of a pair
139 1840         3197 my $u = $alloc % $C; # True if this the upper block of a buddy pair
140 1840 100       3766 my $b = $alloc + ($u ? -$C : +$C) / 2; # Locate possible buddy
141 1840 100       2923 if (delete $buddySystem->freeChains->[$c]{$b}) # Remove buddy if it exists
    100          
142 875 100       1969 {$alloc = $u ? $b : $alloc; # New block to place on next free chain
143             }
144             elsif ($c < $S)
145 919         1575 {$buddySystem->freeChains->[$c]{$alloc}++; # Place this unpaired block on free chain
146 919         21639 return 1; # Finished successfully - no block merges
147             }
148             else # Remove excess free chains
149 46         79 {my $c = $buddySystem->freeChains;
150 46         78 my $a = $buddySystem->allFrees;
151 46         99 for(1..@$c) # Remove a chain if it has nothing allocated
152 306         446 {my $i = @$c-$_;
153 306 50       672 last if $a->[$i];
154 306 100       510 pop @$a if $i < @$a;
155 306         505 pop @$c;
156             }
157 46         1142 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 1717 {my ($buddySystem) = @_; # Buddy system
167 1100         1626 my $n = 0;
168 1100         2076 my $u = $buddySystem->usedSize;
169 1100         56281 $n += (1<<$u->{$_}) for keys %$u;
170 1100         7587 $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 3472 {my ($buddySystem) = @_; # Buddy system
175 2099         2924 my $n = 0;
176 2099         3650 for(0..$buddySystem->size-1)
177 32412         49937 {my $f = $buddySystem->freeChains->[$_];
178 32412 100       54037 next unless $f;
179 30218         50357 $n += scalar(keys %$f) * (1<<$_);
180             }
181             $n
182 2099         3755 } # freeSpace
183              
184             sub totalSpace($) # Total space currently occupied by this buddy system
185 2371     2371 1 3880 {my ($buddySystem) = @_; # Buddy system
186 2371         4046 my $n = $buddySystem->size;
187 2371 100       4647 return 0 unless $n;
188 2291         3614 1 << ($buddySystem->size-1) # System invariant
189             } # totalSpace
190              
191             sub fractionalFreeSpace($) ## Fraction of space currently free vs total space
192 1015     1015 0 2469 {my ($buddySystem) = @_; # Buddy system
193 1015         1951 my $t = $buddySystem->totalSpace;
194 1015         1885 my $f = $buddySystem->freeSpace;
195 1015 50       1930 return 1 unless $t > 0;
196 1015         23678 $f / $t
197             } # fractionalFreeSpace
198              
199             sub checkSpace($) ## Check free space and used space match total space
200 1084     1084 0 2061 {my ($buddySystem) = @_; # Buddy system
201 1084         1524 my $b = $buddySystem; # Shorten
202 1084         2027 my $u = $b->usedSpace;
203 1084         2280 my $f = $b->freeSpace;
204 1084         1986 my $t = $b->totalSpace;
205 1084         1676 my $T = $u + $f;
206 1084 50       2317 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         1435 if (1) # Confirm used space matches allocated space
211 1084         1448 {my $n = 0;
212 1084         2152 for my $s(0..$b->size-1) # All the free chains
213 16287   100     25460 {$n += ($b->allFrees->[$s]//0) * (1<<$s); # Number of currently allocated blocks of this size
214             }
215 1084 50       2191 confess "checkSpace failed used=$u n=$n"
216             # .dump($b)."\n"
217             unless $u == $n;
218             }
219              
220             1
221 1084         26358 } # 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 202 {my ($buddySystem, $title) = @_; # BuddySystem, title
225 82         189 my $S = $buddySystem->size; # Size of system
226 82         156 my $L = 26; # Length of alphabet
227 82         219 my @A = map {chr(ord('a')-1+$_)} 1..$L; # Use lowercase for free areas and upper case for used areas
  2132         3448  
228 82         199 my $e = 0; my $x = 0; # Number of error cells, number of cells examined
  82         139  
229              
230 82         200 my @t = map {undef()} 1..$buddySystem->totalSpace; # Long representation
  150481         185290  
231 82         2809 for my $B(0..$S-1) # All the free/used blocks
232 543         797 {my $s = (1<<$B); # Size of free blocks on this chain
233 543 100       967 if (my $F = $buddySystem->freeChains->[$B]) # Free blocks of this size
234 223         759 {for my $f(sort {$a <=> $b} keys %$F) # Free block
  12         59  
235 100         246 {for(0..$s-1) # Each cell of free block
236 131634         171209 {my $o = $f+$_; # Offset
237 131634         176009 my $c = $A[$B % $L]; # Marker character for free block
238 131634         157967 ++$x; # Examined cells count
239 131634 50       189414 if (defined($t[$o])) {++$e; $t[$o] = '*'} else {$t[$o] = $c} # Do not overwrite previous free or used block
  0         0  
  0         0  
  131634         211680  
240             }
241             }
242             }
243             }
244 82 50       176 if (my $U = $buddySystem->usedSize) # Used blocks
245 82         391 {for my $u(sort {$a <=> $b} keys %$U) # Used blocks in ascending order of offset
  284         552  
246 216         408 {my $s = $U->{$u}; # Size of this used block
247 216         421 for(1..(1<<$s)) # Each cell of used block
248 18847         25242 {my $o = $u+$_-1; # Offset
249 18847         25196 my $c = $A[$s % $L]; # Marker character for used block
250 18847         21946 ++$x;
251 18847 50       26684 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         30956  
252             }
253             }
254             }
255 82 50 33     404 if ($e or $x != $buddySystem->totalSpace) # Inconsistent state detected
256 1     1   10 {use Data::Dump qw(dump);
  1         3  
  1         44  
257 1     1   5 use Carp;
  1         1  
  1         726  
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         212 my @T = map {''} 1..$buddySystem->totalSpace; # Short representation
  150481         216495  
266 82         2879 for my $B(0..$S-1) # All the free/used blocks
267 543         804 {my $s = (1<<$B); # Size of free blocks on this chain
268 543 100       896 if (my $F = $buddySystem->freeChains->[$B]) # Free blocks of this size
269 223         770 {$T[$_] = $A[$B % $L] for sort {$a <=> $b} keys %$F; # Free block
  12         62  
270             }
271             }
272 82 50       437 if (my $U = $buddySystem->usedSize) # Used blocks
273 82         300 {for my $u(sort {$a <=> $b} keys %$U) # Used blocks in ascending order of offset
  284         771  
274 216         367 {my $s = $U->{$u}; # Size of this used block
275 216         465 $T[$u] = uc $A[$s % $L];
276             }
277             }
278 82         4421 my $T = join '', @T; # Representation as a string
279 82 100       336 say STDOUT "$title $T" if $title;
280 82         23138 $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 7 {my ($buddySystem, $order, $copy) = @_; # Buddy system, order, optional copy method to copy an old allocation into its corresponding new allocation
286 2         9 my $n = new; # The new buddy system
287              
288 2 50       8 if (my $u = $buddySystem->usedSize) # Used blocks decreasing in size but increasing by address within each size
289             {my @u = sort
290 2 100       24 {my $c = $order ? $u->{$b} <=> $u->{$a} : $u->{$a} <=> $u->{$b}; # 0 - Ascending, 1 - Descending order
  71         115  
291 71 100       116 return $c unless $c == 0;
292 14         37 $a <=> $b # Ascending address
293             } keys %$u;
294              
295 2         9 for my $a(@u) # Each used block
296 26         37 {my $size = $u->{$a}; # Size of this block
297 26         33 my $A; # Address of relocated block
298 26 100       43 if (my $name = $buddySystem->allocName->{$a}) # Name attached to the block
299 9         16 {$A = $n->allocField($name, $size); # Create new block with same name in new buddy system
300             }
301             else
302 17         30 {$A = $n->alloc($size); # Matching block in new buddy system
303             }
304 26 50       47 $copy->($a, $A, $size) if $copy; # Copy data from old block to new block, using the specified size
305 26 50       42 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         27 } # 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 3 {my ($buddySystem, $copy) = @_; # BuddySystem, copy method to copy an old allocation into a new allocation
318 1         5 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 5 {my ($buddySystem, $copy) = @_; # BuddySystem, copy method to copy an old allocation into a new allocation
323 1         6 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 3 {my ($buddySystem, $package) = @_; # Buddy system, structure name
330 1         5 my $new = $buddySystem->copyLargestLast; # Organise the buddy system by element size
331 1         3 my %allocs = %{$new->allocName}; # Named allocations
  1         3  
332 1         3 my %sizes = %{$new->usedSize}; # Size of each named allocation
  1         4  
333 1         5 my $s = <
334             package $package;
335             use utf8;
336             END
337 1         2 my @s;
338 1         6 for my $alloc(sort {$a<=>$b} keys %allocs)
  20         27  
339 9         17 {my $name = $allocs{$alloc}; # Name of block
340 9         33 my $size = $sizes{$alloc}; # Log2 width of block
341 9         16 my $bits = 2**$size; # Block size in vec terms
342 9         19 my $offset = $alloc/$bits; # Block offset in vec terms
343 9 50       48 $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         38 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         9 $s .= formatTableBasic([@s]); # Layout the method definitions so they are easy to read
349 1     1   15 eval $s; # Generate methods
  1     2   4  
  1     2   11  
  1     0   744  
  2     3   26  
  2     3   49  
  0     3   0  
  3     0   36  
  3     4   49  
  3     1   32  
  0         0  
  4         50  
  1         19  
350 1 50       191 $@ and confess "$s\n$@";
351 1         4 my $p = <
352             bless sub {\$s}, "$package";
353             END
354 1         58 my $P = eval $p; # Generate the blessed sub whose value is the text representation if its methods
355 1 50       6 $@ and confess "$p\n$@";
356 1         34 $P
357             } # generateStructureFields
358              
359             # Test
360 1 50   1 0 417 sub test{eval join('', ) or die $@}
  1     1   33  
  1     1   5  
  1         398  
  1         49974  
  1         10  
  1         211  
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__