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   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__