[perl5.git] / ext / B / B / Assembler.pm

#      Assembler.pm
#
#      Copyright (c) 1996 Malcolm Beattie
#
#      You may distribute under the terms of either the GNU General Public
#      License or the Artistic License, as specified in the README file.

package B::Assembler;
use Exporter;
use B qw(ppname);
use B::Asmdata qw(%insn_data @insn_name);
use Config qw(%Config);
require ByteLoader;		# we just need its $VERSION

no warnings;			# XXX

@ISA = qw(Exporter);
@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
$VERSION = 0.07;

use strict;
my %opnumber;
my ($i, $opname);
for ($i = 0; defined($opname = ppname($i)); $i++) {
    $opnumber{$opname} = $i;
}

my($linenum, $errors, $out); #	global state, set up by newasm

sub error {
    my $str = shift;
    warn "$linenum: $str\n";
    $errors++;
}

my $debug = 0;
sub debug { $debug = shift }

sub limcheck($$$$){
    my( $val, $lo, $hi, $loc ) = @_;
    if( $val < $lo || $hi < $val ){
        error "argument for $loc outside [$lo, $hi]: $val";
        $val = $hi;
    }
    return $val;
}

#
# First define all the data conversion subs to which Asmdata will refer
#

sub B::Asmdata::PUT_U8 {
    my $arg = shift;
    my $c = uncstring($arg);
    if (defined($c)) {
	if (length($c) != 1) {
	    error "argument for U8 is too long: $c";
	    $c = substr($c, 0, 1);
	}
    } else {
        $arg = limcheck( $arg, 0, 0xff, 'U8' );
	$c = chr($arg);
    }
    return $c;
}

sub B::Asmdata::PUT_U16 {
    my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
    pack("S", $arg);
}
sub B::Asmdata::PUT_U32 {
    my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
    pack("L", $arg);
}
sub B::Asmdata::PUT_I32 {
    my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
    pack("l", $arg);
}
sub B::Asmdata::PUT_NV  { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
						   # may not even be portable between compilers
sub B::Asmdata::PUT_objindex { # could allow names here
    my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
    pack("L", $arg);
} 
sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }

sub B::Asmdata::PUT_strconst {
    my $arg = shift;
    my $str = uncstring($arg);
    if (!defined($str)) {
	error "bad string constant: $arg";
	$str = '';
    }
    if ($str =~ s/\0//g) {
	error "string constant argument contains NUL: $arg";
        $str = '';
    }
    return $str . "\0";
}

sub B::Asmdata::PUT_pvcontents {
    my $arg = shift;
    error "extraneous argument: $arg" if defined $arg;
    return "";
}
sub B::Asmdata::PUT_PV {
    my $arg = shift;
    my $str = uncstring($arg);
    if( ! defined($str) ){
        error "bad string argument: $arg";
        $str = '';
    }
    return pack("L", length($str)) . $str;
}
sub B::Asmdata::PUT_comment_t {
    my $arg = shift;
    $arg = uncstring($arg);
    error "bad string argument: $arg" unless defined($arg);
    if ($arg =~ s/\n//g) {
	error "comment argument contains linefeed: $arg";
    }
    return $arg . "\n";
}
sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
sub B::Asmdata::PUT_none {
    my $arg = shift;
    error "extraneous argument: $arg" if defined $arg;
    return "";
}
sub B::Asmdata::PUT_op_tr_array {
    my @ary = split /\s*,\s*/, shift;
    return pack "S*", @ary;
}

sub B::Asmdata::PUT_IV64 {
    return pack "Q", shift;
}

sub B::Asmdata::PUT_IV {
    $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
}

sub B::Asmdata::PUT_PADOFFSET {
    $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
}

sub B::Asmdata::PUT_long {
    $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
}

sub B::Asmdata::PUT_svtype { # svtype is an enum, so an int.
    $Config{intsize} == 4 ? &B::Asmdata::PUT_U32 : &B::Asmdata::PUT_IV64;
}

my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
	     b => "\b", f => "\f", v => "\013");

sub uncstring {
    my $s = shift;
    $s =~ s/^"// and $s =~ s/"$// or return undef;
    $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
    return $s;
}

sub strip_comments {
    my $stmt = shift;
    # Comments only allowed in instructions which don't take string arguments
    # Treat string as a single line so .* eats \n characters.
    $stmt =~ s{
	^\s*	# Ignore leading whitespace
	(
	  [^"]*	# A double quote '"' indicates a string argument. If we
		# find a double quote, the match fails and we strip nothing.
	)
	\s*\#	# Any amount of whitespace plus the comment marker...
	.*$	# ...which carries on to end-of-string.
    }{$1}sx;	# Keep only the instruction and optional argument.
    return $stmt;
}

# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
# 	ptrsize, byteorder
# nvtype is irrelevant (floats are stored as strings)
# byteorder is strconst not U32 because of varying size issues

sub gen_header {
    my $header = "";

    $header .= B::Asmdata::PUT_U32(0x43424c50);	# 'PLBC'
    $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
    $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
    $header .= B::Asmdata::PUT_U32($Config{ivsize});
    $header .= B::Asmdata::PUT_U32($Config{ptrsize});
    $header;
}

sub parse_statement {
    my $stmt = shift;
    my ($insn, $arg) = $stmt =~ m{
	^\s*	# allow (but ignore) leading whitespace
	(.*?)	# Instruction continues up until...
	(?:	# ...an optional whitespace+argument group
	    \s+		# first whitespace.
	    (.*)	# The argument is all the rest (newlines included).
	)?$	# anchor at end-of-line
    }sx;
    if (defined($arg)) {
	if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
	    $arg = hex($arg);
	} elsif ($arg =~ s/^0(?=[0-7]+$)//) {
	    $arg = oct($arg);
	} elsif ($arg =~ /^pp_/) {
	    $arg =~ s/\s*$//; # strip trailing whitespace
	    my $opnum = $opnumber{$arg};
	    if (defined($opnum)) {
		$arg = $opnum;
	    } else {
		error qq(No such op type "$arg");
		$arg = 0;
	    }
	}
    }
    return ($insn, $arg);
}

sub assemble_insn {
    my ($insn, $arg) = @_;
    my $data = $insn_data{$insn};
    if (defined($data)) {
	my ($bytecode, $putsub) = @{$data}[0, 1];
	my $argcode = &$putsub($arg);
	return chr($bytecode).$argcode;
    } else {
	error qq(no such instruction "$insn");
	return "";
    }
}

sub assemble_fh {
    my ($fh, $out) = @_;
    my $line;
    my $asm = newasm($out);
    while ($line = <$fh>) {
	assemble($line);
    }
    endasm();
}

sub newasm {
    my($outsub) = @_;

    die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
    die <<EOD if ref $out;
Can't have multiple byteassembly sessions at once!
	(perhaps you forgot an endasm()?)
EOD

    $linenum = $errors = 0;
    $out = $outsub;

    $out->(gen_header());
}

sub endasm {
    if ($errors) {
	die "There were $errors assembly errors\n";
    }
    $linenum = $errors = $out = 0;
}

sub assemble {
    my($line) = @_;
    my ($insn, $arg);
    $linenum++;
    chomp $line;
    if ($debug) {
	my $quotedline = $line;
	$quotedline =~ s/\\/\\\\/g;
	$quotedline =~ s/"/\\"/g;
	$out->(assemble_insn("comment", qq("$quotedline")));
    }
    if( $line = strip_comments($line) ){
        ($insn, $arg) = parse_statement($line);
        $out->(assemble_insn($insn, $arg));
        if ($debug) {
	    $out->(assemble_insn("nop", undef));
        }
    }
}

### temporary workaround

sub asm {
    return if $_[0] =~ /\s*\W/;
    if (defined $_[1]) {
	return if $_[1] eq "0" and
	    $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
	return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
    }
    assemble "@_";
}

1;

__END__

=head1 NAME

B::Assembler - Assemble Perl bytecode

=head1 SYNOPSIS

	use B::Assembler qw(newasm endasm assemble);
	newasm(\&printsub);	# sets up for assembly
	assemble($buf); 	# assembles one line
	endasm();		# closes down

	use B::Assembler qw(assemble_fh);
	assemble_fh($fh, \&printsub);	# assemble everything in $fh

=head1 DESCRIPTION

See F<ext/B/B/Assembler.pm>.

=head1 AUTHORS

Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>

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