This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Byteloader patching from Enache continues;
[perl5.git] / ext / B / B / Assembler.pm
CommitLineData
a798dbf2
MB
1# Assembler.pm
2#
3# Copyright (c) 1996 Malcolm Beattie
4#
5# You may distribute under the terms of either the GNU General Public
6# License or the Artistic License, as specified in the README file.
059a8bb7 7
a798dbf2
MB
8package B::Assembler;
9use Exporter;
10use B qw(ppname);
11use B::Asmdata qw(%insn_data @insn_name);
059a8bb7
JH
12use Config qw(%Config);
13require ByteLoader; # we just need its $VERSIOM
a798dbf2 14
1df34986
AE
15no warnings; # XXX
16
a798dbf2 17@ISA = qw(Exporter);
1df34986 18@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
3353beaa 19$VERSION = 0.06;
a798dbf2
MB
20
21use strict;
22my %opnumber;
23my ($i, $opname);
24for ($i = 0; defined($opname = ppname($i)); $i++) {
25 $opnumber{$opname} = $i;
26}
27
059a8bb7 28my($linenum, $errors, $out); # global state, set up by newasm
a798dbf2
MB
29
30sub error {
31 my $str = shift;
32 warn "$linenum: $str\n";
33 $errors++;
34}
35
36my $debug = 0;
37sub debug { $debug = shift }
38
f4abc3e7
JH
39sub limcheck($$$$){
40 my( $val, $lo, $hi, $loc ) = @_;
41 if( $val < $lo || $hi < $val ){
42 error "argument for $loc outside [$lo, $hi]: $val";
43 $val = $hi;
44 }
45 return $val;
46}
47
a798dbf2
MB
48#
49# First define all the data conversion subs to which Asmdata will refer
50#
51
52sub B::Asmdata::PUT_U8 {
53 my $arg = shift;
54 my $c = uncstring($arg);
55 if (defined($c)) {
56 if (length($c) != 1) {
57 error "argument for U8 is too long: $c";
58 $c = substr($c, 0, 1);
59 }
60 } else {
f4abc3e7 61 $arg = limcheck( $arg, 0, 0xff, 'U8' );
a798dbf2
MB
62 $c = chr($arg);
63 }
64 return $c;
65}
66
f4abc3e7
JH
67sub B::Asmdata::PUT_U16 {
68 my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
69 pack("S", $arg);
70}
71sub B::Asmdata::PUT_U32 {
72 my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
73 pack("L", $arg);
74}
75sub B::Asmdata::PUT_I32 {
76 my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
e53790c1 77 pack("l", $arg);
f4abc3e7
JH
78}
79sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
059a8bb7 80 # may not even be portable between compilers
f4abc3e7
JH
81sub B::Asmdata::PUT_objindex { # could allow names here
82 my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
83 pack("L", $arg);
84}
cf743617
GS
85sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
86sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
059a8bb7 87sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
a798dbf2
MB
88
89sub B::Asmdata::PUT_strconst {
90 my $arg = shift;
f4abc3e7
JH
91 my $str = uncstring($arg);
92 if (!defined($str)) {
a798dbf2 93 error "bad string constant: $arg";
f4abc3e7 94 $str = '';
a798dbf2 95 }
f4abc3e7 96 if ($str =~ s/\0//g) {
a798dbf2 97 error "string constant argument contains NUL: $arg";
f4abc3e7 98 $str = '';
a798dbf2 99 }
f4abc3e7 100 return $str . "\0";
a798dbf2
MB
101}
102
103sub B::Asmdata::PUT_pvcontents {
104 my $arg = shift;
105 error "extraneous argument: $arg" if defined $arg;
106 return "";
107}
108sub B::Asmdata::PUT_PV {
109 my $arg = shift;
f4abc3e7
JH
110 my $str = uncstring($arg);
111 if( ! defined($str) ){
112 error "bad string argument: $arg";
113 $str = '';
114 }
115 return pack("L", length($str)) . $str;
a798dbf2 116}
d53d2b93 117sub B::Asmdata::PUT_comment_t {
a798dbf2
MB
118 my $arg = shift;
119 $arg = uncstring($arg);
120 error "bad string argument: $arg" unless defined($arg);
121 if ($arg =~ s/\n//g) {
122 error "comment argument contains linefeed: $arg";
123 }
124 return $arg . "\n";
125}
059a8bb7 126sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
a798dbf2
MB
127sub B::Asmdata::PUT_none {
128 my $arg = shift;
129 error "extraneous argument: $arg" if defined $arg;
130 return "";
131}
132sub B::Asmdata::PUT_op_tr_array {
1df34986
AE
133 my @ary = split /\s*,\s*/, shift;
134 return pack "S*", @ary;
a798dbf2 135}
1df34986 136
a798dbf2 137sub B::Asmdata::PUT_IV64 {
1df34986 138 return pack "Q", shift;
f4abc3e7
JH
139}
140
141sub B::Asmdata::PUT_IV {
142 $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
a798dbf2
MB
143}
144
ca337316
JH
145sub B::Asmdata::PUT_PADOFFSET {
146 $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
147}
148
a798dbf2
MB
149my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
150 b => "\b", f => "\f", v => "\013");
151
152sub uncstring {
153 my $s = shift;
154 $s =~ s/^"// and $s =~ s/"$// or return undef;
155 $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
156 return $s;
157}
158
159sub strip_comments {
160 my $stmt = shift;
161 # Comments only allowed in instructions which don't take string arguments
a41e59e3 162 # Treat string as a single line so .* eats \n characters.
a798dbf2 163 $stmt =~ s{
a798dbf2
MB
164 ^\s* # Ignore leading whitespace
165 (
166 [^"]* # A double quote '"' indicates a string argument. If we
167 # find a double quote, the match fails and we strip nothing.
168 )
169 \s*\# # Any amount of whitespace plus the comment marker...
170 .*$ # ...which carries on to end-of-string.
a41e59e3 171 }{$1}sx; # Keep only the instruction and optional argument.
a798dbf2
MB
172 return $stmt;
173}
174
059a8bb7
JH
175# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
176# ptrsize, byteorder
177# nvtype is irrelevant (floats are stored as strings)
178# byteorder is strconst not U32 because of varying size issues
179
180sub gen_header {
181 my $header = "";
182
183 $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
184 $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
185 $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
186 $header .= B::Asmdata::PUT_U32($Config{ivsize});
187 $header .= B::Asmdata::PUT_U32($Config{ptrsize});
059a8bb7
JH
188 $header;
189}
190
a798dbf2
MB
191sub parse_statement {
192 my $stmt = shift;
193 my ($insn, $arg) = $stmt =~ m{
a798dbf2
MB
194 ^\s* # allow (but ignore) leading whitespace
195 (.*?) # Instruction continues up until...
196 (?: # ...an optional whitespace+argument group
197 \s+ # first whitespace.
198 (.*) # The argument is all the rest (newlines included).
199 )?$ # anchor at end-of-line
f4abc3e7 200 }sx;
a798dbf2
MB
201 if (defined($arg)) {
202 if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
203 $arg = hex($arg);
204 } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
205 $arg = oct($arg);
206 } elsif ($arg =~ /^pp_/) {
207 $arg =~ s/\s*$//; # strip trailing whitespace
208 my $opnum = $opnumber{$arg};
209 if (defined($opnum)) {
210 $arg = $opnum;
211 } else {
212 error qq(No such op type "$arg");
213 $arg = 0;
214 }
215 }
216 }
217 return ($insn, $arg);
218}
219
220sub assemble_insn {
221 my ($insn, $arg) = @_;
222 my $data = $insn_data{$insn};
223 if (defined($data)) {
224 my ($bytecode, $putsub) = @{$data}[0, 1];
225 my $argcode = &$putsub($arg);
226 return chr($bytecode).$argcode;
227 } else {
228 error qq(no such instruction "$insn");
229 return "";
230 }
231}
232
233sub assemble_fh {
234 my ($fh, $out) = @_;
059a8bb7
JH
235 my $line;
236 my $asm = newasm($out);
a798dbf2 237 while ($line = <$fh>) {
059a8bb7 238 assemble($line);
a798dbf2 239 }
059a8bb7
JH
240 endasm();
241}
242
243sub newasm {
244 my($outsub) = @_;
245
246 die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
247 die <<EOD if ref $out;
248Can't have multiple byteassembly sessions at once!
249 (perhaps you forgot an endasm()?)
250EOD
251
252 $linenum = $errors = 0;
253 $out = $outsub;
254
255 $out->(gen_header());
256}
257
258sub endasm {
a798dbf2 259 if ($errors) {
059a8bb7
JH
260 die "There were $errors assembly errors\n";
261 }
262 $linenum = $errors = $out = 0;
263}
264
265sub assemble {
266 my($line) = @_;
267 my ($insn, $arg);
268 $linenum++;
269 chomp $line;
270 if ($debug) {
271 my $quotedline = $line;
272 $quotedline =~ s/\\/\\\\/g;
273 $quotedline =~ s/"/\\"/g;
274 $out->(assemble_insn("comment", qq("$quotedline")));
275 }
f4abc3e7
JH
276 if( $line = strip_comments($line) ){
277 ($insn, $arg) = parse_statement($line);
278 $out->(assemble_insn($insn, $arg));
279 if ($debug) {
280 $out->(assemble_insn("nop", undef));
281 }
a798dbf2
MB
282 }
283}
284
1df34986
AE
285### temporary workaround
286
287sub asm {
288 return if $_[0] =~ /\s*\W/;
289 if (defined $_[1]) {
566ece03 290 return if $_[1] eq "0" and $_[0] !~ /^(?:newsvx?|av_pushx?|xav_flags)$/;
1df34986
AE
291 return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
292 }
1df34986
AE
293 assemble "@_";
294}
295
a798dbf2 2961;
7f20e9dd
GS
297
298__END__
299
300=head1 NAME
301
302B::Assembler - Assemble Perl bytecode
303
304=head1 SYNOPSIS
305
059a8bb7
JH
306 use B::Assembler qw(newasm endasm assemble);
307 newasm(\&printsub); # sets up for assembly
308 assemble($buf); # assembles one line
309 endasm(); # closes down
310
311 use B::Assembler qw(assemble_fh);
312 assemble_fh($fh, \&printsub); # assemble everything in $fh
7f20e9dd
GS
313
314=head1 DESCRIPTION
315
316See F<ext/B/B/Assembler.pm>.
317
059a8bb7 318=head1 AUTHORS
7f20e9dd
GS
319
320Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
059a8bb7 321Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
7f20e9dd
GS
322
323=cut