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
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.
7
8 package B::Assembler;
9 use Exporter;
10 use B qw(ppname);
11 use B::Asmdata qw(%insn_data @insn_name);
12 use Config qw(%Config);
13 require ByteLoader;             # we just need its $VERSIOM
14
15 no warnings;                    # XXX
16
17 @ISA = qw(Exporter);
18 @EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
19 $VERSION = 0.06;
20
21 use strict;
22 my %opnumber;
23 my ($i, $opname);
24 for ($i = 0; defined($opname = ppname($i)); $i++) {
25     $opnumber{$opname} = $i;
26 }
27
28 my($linenum, $errors, $out); #  global state, set up by newasm
29
30 sub error {
31     my $str = shift;
32     warn "$linenum: $str\n";
33     $errors++;
34 }
35
36 my $debug = 0;
37 sub debug { $debug = shift }
38
39 sub 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
48 #
49 # First define all the data conversion subs to which Asmdata will refer
50 #
51
52 sub 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 {
61         $arg = limcheck( $arg, 0, 0xff, 'U8' );
62         $c = chr($arg);
63     }
64     return $c;
65 }
66
67 sub B::Asmdata::PUT_U16 {
68     my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
69     pack("S", $arg);
70 }
71 sub B::Asmdata::PUT_U32 {
72     my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
73     pack("L", $arg);
74 }
75 sub B::Asmdata::PUT_I32 {
76     my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
77     pack("l", $arg);
78 }
79 sub B::Asmdata::PUT_NV  { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
80                                                    # may not even be portable between compilers
81 sub B::Asmdata::PUT_objindex { # could allow names here
82     my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
83     pack("L", $arg);
84
85 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
86 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
87 sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
88
89 sub B::Asmdata::PUT_strconst {
90     my $arg = shift;
91     my $str = uncstring($arg);
92     if (!defined($str)) {
93         error "bad string constant: $arg";
94         $str = '';
95     }
96     if ($str =~ s/\0//g) {
97         error "string constant argument contains NUL: $arg";
98         $str = '';
99     }
100     return $str . "\0";
101 }
102
103 sub B::Asmdata::PUT_pvcontents {
104     my $arg = shift;
105     error "extraneous argument: $arg" if defined $arg;
106     return "";
107 }
108 sub B::Asmdata::PUT_PV {
109     my $arg = shift;
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;
116 }
117 sub B::Asmdata::PUT_comment_t {
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 }
126 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
127 sub B::Asmdata::PUT_none {
128     my $arg = shift;
129     error "extraneous argument: $arg" if defined $arg;
130     return "";
131 }
132 sub B::Asmdata::PUT_op_tr_array {
133     my @ary = split /\s*,\s*/, shift;
134     return pack "S*", @ary;
135 }
136
137 sub B::Asmdata::PUT_IV64 {
138     return pack "Q", shift;
139 }
140
141 sub B::Asmdata::PUT_IV {
142     $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
143 }
144
145 sub B::Asmdata::PUT_PADOFFSET {
146     $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
147 }
148
149 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
150              b => "\b", f => "\f", v => "\013");
151
152 sub 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
159 sub strip_comments {
160     my $stmt = shift;
161     # Comments only allowed in instructions which don't take string arguments
162     # Treat string as a single line so .* eats \n characters.
163     $stmt =~ s{
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.
171     }{$1}sx;    # Keep only the instruction and optional argument.
172     return $stmt;
173 }
174
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
180 sub 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});
188     $header;
189 }
190
191 sub parse_statement {
192     my $stmt = shift;
193     my ($insn, $arg) = $stmt =~ m{
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
200     }sx;
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
220 sub 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
233 sub assemble_fh {
234     my ($fh, $out) = @_;
235     my $line;
236     my $asm = newasm($out);
237     while ($line = <$fh>) {
238         assemble($line);
239     }
240     endasm();
241 }
242
243 sub 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;
248 Can't have multiple byteassembly sessions at once!
249         (perhaps you forgot an endasm()?)
250 EOD
251
252     $linenum = $errors = 0;
253     $out = $outsub;
254
255     $out->(gen_header());
256 }
257
258 sub endasm {
259     if ($errors) {
260         die "There were $errors assembly errors\n";
261     }
262     $linenum = $errors = $out = 0;
263 }
264
265 sub 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     }
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         }
282     }
283 }
284
285 ### temporary workaround
286
287 sub asm {
288     return if $_[0] =~ /\s*\W/;
289     if (defined $_[1]) {
290         return if $_[1] eq "0" and $_[0] !~ /^(?:newsvx?|av_pushx?|xav_flags)$/;
291         return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
292     }
293     assemble "@_";
294 }
295
296 1;
297
298 __END__
299
300 =head1 NAME
301
302 B::Assembler - Assemble Perl bytecode
303
304 =head1 SYNOPSIS
305
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
313
314 =head1 DESCRIPTION
315
316 See F<ext/B/B/Assembler.pm>.
317
318 =head1 AUTHORS
319
320 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
321 Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
322
323 =cut