xref: /onnv-gate/usr/src/cmd/perl/5.8.4/distrib/ext/B/B/Assembler.pm (revision 0:68f95e015346) 
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
8package B::Assembler;
9use Exporter;
10use B qw(ppname);
11use B::Asmdata qw(%insn_data @insn_name);
12use Config qw(%Config);
13require ByteLoader;		# we just need its $VERSIOM
14
15no warnings;			# XXX
16
17@ISA = qw(Exporter);
18@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
19$VERSION = 0.07;
20
21use strict;
22my %opnumber;
23my ($i, $opname);
24for ($i = 0; defined($opname = ppname($i)); $i++) {
25    $opnumber{$opname} = $i;
26}
27
28my($linenum, $errors, $out); #	global state, set up by newasm
29
30sub error {
31    my $str = shift;
32    warn "$linenum: $str\n";
33    $errors++;
34}
35
36my $debug = 0;
37sub debug { $debug = shift }
38
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
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 {
61        $arg = limcheck( $arg, 0, 0xff, 'U8' );
62	$c = chr($arg);
63    }
64    return $c;
65}
66
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' );
77    pack("l", $arg);
78}
79sub B::Asmdata::PUT_NV  { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
80						   # may not even be portable between compilers
81sub B::Asmdata::PUT_objindex { # could allow names here
82    my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
83    pack("L", $arg);
84}
85sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
86sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
87sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
88
89sub 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
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;
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}
117sub 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}
126sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
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 {
133    my @ary = split /\s*,\s*/, shift;
134    return pack "S*", @ary;
135}
136
137sub B::Asmdata::PUT_IV64 {
138    return pack "Q", shift;
139}
140
141sub B::Asmdata::PUT_IV {
142    $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
143}
144
145sub B::Asmdata::PUT_PADOFFSET {
146    $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
147}
148
149sub B::Asmdata::PUT_long {
150    $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
151}
152
153my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
154	     b => "\b", f => "\f", v => "\013");
155
156sub uncstring {
157    my $s = shift;
158    $s =~ s/^"// and $s =~ s/"$// or return undef;
159    $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
160    return $s;
161}
162
163sub strip_comments {
164    my $stmt = shift;
165    # Comments only allowed in instructions which don't take string arguments
166    # Treat string as a single line so .* eats \n characters.
167    $stmt =~ s{
168	^\s*	# Ignore leading whitespace
169	(
170	  [^"]*	# A double quote '"' indicates a string argument. If we
171		# find a double quote, the match fails and we strip nothing.
172	)
173	\s*\#	# Any amount of whitespace plus the comment marker...
174	.*$	# ...which carries on to end-of-string.
175    }{$1}sx;	# Keep only the instruction and optional argument.
176    return $stmt;
177}
178
179# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
180# 	ptrsize, byteorder
181# nvtype is irrelevant (floats are stored as strings)
182# byteorder is strconst not U32 because of varying size issues
183
184sub gen_header {
185    my $header = "";
186
187    $header .= B::Asmdata::PUT_U32(0x43424c50);	# 'PLBC'
188    $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
189    $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
190    $header .= B::Asmdata::PUT_U32($Config{ivsize});
191    $header .= B::Asmdata::PUT_U32($Config{ptrsize});
192    $header;
193}
194
195sub parse_statement {
196    my $stmt = shift;
197    my ($insn, $arg) = $stmt =~ m{
198	^\s*	# allow (but ignore) leading whitespace
199	(.*?)	# Instruction continues up until...
200	(?:	# ...an optional whitespace+argument group
201	    \s+		# first whitespace.
202	    (.*)	# The argument is all the rest (newlines included).
203	)?$	# anchor at end-of-line
204    }sx;
205    if (defined($arg)) {
206	if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
207	    $arg = hex($arg);
208	} elsif ($arg =~ s/^0(?=[0-7]+$)//) {
209	    $arg = oct($arg);
210	} elsif ($arg =~ /^pp_/) {
211	    $arg =~ s/\s*$//; # strip trailing whitespace
212	    my $opnum = $opnumber{$arg};
213	    if (defined($opnum)) {
214		$arg = $opnum;
215	    } else {
216		error qq(No such op type "$arg");
217		$arg = 0;
218	    }
219	}
220    }
221    return ($insn, $arg);
222}
223
224sub assemble_insn {
225    my ($insn, $arg) = @_;
226    my $data = $insn_data{$insn};
227    if (defined($data)) {
228	my ($bytecode, $putsub) = @{$data}[0, 1];
229	my $argcode = &$putsub($arg);
230	return chr($bytecode).$argcode;
231    } else {
232	error qq(no such instruction "$insn");
233	return "";
234    }
235}
236
237sub assemble_fh {
238    my ($fh, $out) = @_;
239    my $line;
240    my $asm = newasm($out);
241    while ($line = <$fh>) {
242	assemble($line);
243    }
244    endasm();
245}
246
247sub newasm {
248    my($outsub) = @_;
249
250    die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
251    die <<EOD if ref $out;
252Can't have multiple byteassembly sessions at once!
253	(perhaps you forgot an endasm()?)
254EOD
255
256    $linenum = $errors = 0;
257    $out = $outsub;
258
259    $out->(gen_header());
260}
261
262sub endasm {
263    if ($errors) {
264	die "There were $errors assembly errors\n";
265    }
266    $linenum = $errors = $out = 0;
267}
268
269sub assemble {
270    my($line) = @_;
271    my ($insn, $arg);
272    $linenum++;
273    chomp $line;
274    if ($debug) {
275	my $quotedline = $line;
276	$quotedline =~ s/\\/\\\\/g;
277	$quotedline =~ s/"/\\"/g;
278	$out->(assemble_insn("comment", qq("$quotedline")));
279    }
280    if( $line = strip_comments($line) ){
281        ($insn, $arg) = parse_statement($line);
282        $out->(assemble_insn($insn, $arg));
283        if ($debug) {
284	    $out->(assemble_insn("nop", undef));
285        }
286    }
287}
288
289### temporary workaround
290
291sub asm {
292    return if $_[0] =~ /\s*\W/;
293    if (defined $_[1]) {
294	return if $_[1] eq "0" and
295	    $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
296	return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
297    }
298    assemble "@_";
299}
300
3011;
302
303__END__
304
305=head1 NAME
306
307B::Assembler - Assemble Perl bytecode
308
309=head1 SYNOPSIS
310
311	use B::Assembler qw(newasm endasm assemble);
312	newasm(\&printsub);	# sets up for assembly
313	assemble($buf); 	# assembles one line
314	endasm();		# closes down
315
316	use B::Assembler qw(assemble_fh);
317	assemble_fh($fh, \&printsub);	# assemble everything in $fh
318
319=head1 DESCRIPTION
320
321See F<ext/B/B/Assembler.pm>.
322
323=head1 AUTHORS
324
325Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
326Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
327
328=cut
329