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