[p5sagit/p5-mst-13.2.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);

@ISA = qw(Exporter);
@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
		parse_statement uncstring gen_header);

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

my ($linenum, $errors);

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

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

#
# 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 {
	$c = chr($arg);
    }
    return $c;
}

sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
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 { pack("L", $_[0]) } # could allow names here
sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }

sub B::Asmdata::PUT_strconst {
    my $arg = shift;
    $arg = uncstring($arg);
    if (!defined($arg)) {
	error "bad string constant: $arg";
	return "";
    }
    if ($arg =~ s/\0//g) {
	error "string constant argument contains NUL: $arg";
    }
    return $arg . "\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;
    $arg = uncstring($arg);
    error "bad string argument: $arg" unless defined($arg);
    return pack("L", length($arg)) . $arg;
}
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 $arg = shift;
    my @ary = split(/\s*,\s*/, $arg);
    if (@ary != 256) {
	error "wrong number of arguments to op_tr_array";
	@ary = (0) x 256;
    }
    return pack("S256", @ary);
}
# XXX Check this works
sub B::Asmdata::PUT_IV64 {
    my $arg = shift;
    return pack("LL", $arg >> 32, $arg & 0xffffffff);
}

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
    $stmt =~ s{
	(?sx)	# Snazzy extended regexp coming up. Also, treat
		# string as a single line so .* eats \n characters.
	^\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};	# Keep only the instruction and optional argument.
    return $stmt;
}

sub gen_header {	# create the ByteCode header: magic, archname, ivsize, ptrsize, 
			# byteorder
			# nvtype irrelevant (floats are stored as strings)
    my $header = B::Asmdata::PUT_U32(0x43424c50);	# 'PLBC'
    $header .= B::Asmdata::PUT_strconst(qq["$Config{archname}"]);
    $header .= B::Asmdata::PUT_U32($Config{ivsize});
    $header .= B::Asmdata::PUT_U32($Config{ptrsize});
    $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder}));
							# PV not U32 because 
							# of varying size

    $header;
}

sub parse_statement {
    my $stmt = shift;
    my ($insn, $arg) = $stmt =~ m{
	(?sx)
	^\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
    };	
    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, $insn, $arg);
    $linenum = 0;
    $errors = 0;
    &$out(gen_header());
    while ($line = <$fh>) {
	$linenum++;
	chomp $line;
	if ($debug) {
	    my $quotedline = $line;
	    $quotedline =~ s/\\/\\\\/g;
	    $quotedline =~ s/"/\\"/g;
	    &$out(assemble_insn("comment", qq("$quotedline")));
	}
	$line = strip_comments($line) or next;
	($insn, $arg) = parse_statement($line);
	&$out(assemble_insn($insn, $arg));
	if ($debug) {
	    &$out(assemble_insn("nop", undef));
	}
    }
    if ($errors) {
	die "Assembly failed with $errors error(s)\n";
    }
}

1;

__END__

=head1 NAME

B::Assembler - Assemble Perl bytecode

=head1 SYNOPSIS

	use Assembler;

=head1 DESCRIPTION

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

=head1 AUTHOR

Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>

=cut
Commit	Line	Data
a798dbf2	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	package B::Assembler;
	8	use Exporter;
	9	use B qw(ppname);
	10	use B::Asmdata qw(%insn_data @insn_name);
e8fcef16	11	use Config qw(%Config);
a798dbf2	12
	13	@ISA = qw(Exporter);
	14	@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
e8fcef16	15	parse_statement uncstring gen_header);
a798dbf2	16
	17	use strict;
	18	my %opnumber;
	19	my ($i, $opname);
	20	for ($i = 0; defined($opname = ppname($i)); $i++) {
	21	$opnumber{$opname} = $i;
	22	}
	23
	24	my ($linenum, $errors);
	25
	26	sub error {
	27	my $str = shift;
	28	warn "$linenum: $str\n";
	29	$errors++;
	30	}
	31
	32	my $debug = 0;
	33	sub debug { $debug = shift }
	34
	35	#
	36	# First define all the data conversion subs to which Asmdata will refer
	37	#
	38
	39	sub B::Asmdata::PUT_U8 {
	40	my $arg = shift;
	41	my $c = uncstring($arg);
	42	if (defined($c)) {
	43	if (length($c) != 1) {
	44	error "argument for U8 is too long: $c";
	45	$c = substr($c, 0, 1);
	46	}
	47	} else {
	48	$c = chr($arg);
	49	}
	50	return $c;
	51	}
	52
e8fcef16	53	sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
	54	sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
	55	sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
	56	sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
	57	# may not even be portable between compilers
	58	sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
cf743617	59	sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
cf743617	60	sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
a798dbf2	61
	62	sub B::Asmdata::PUT_strconst {
	63	my $arg = shift;
	64	$arg = uncstring($arg);
	65	if (!defined($arg)) {
	66	error "bad string constant: $arg";
	67	return "";
	68	}
	69	if ($arg =~ s/\0//g) {
	70	error "string constant argument contains NUL: $arg";
	71	}
	72	return $arg . "\0";
	73	}
	74
	75	sub B::Asmdata::PUT_pvcontents {
	76	my $arg = shift;
	77	error "extraneous argument: $arg" if defined $arg;
	78	return "";
	79	}
	80	sub B::Asmdata::PUT_PV {
	81	my $arg = shift;
	82	$arg = uncstring($arg);
	83	error "bad string argument: $arg" unless defined($arg);
e8fcef16	84	return pack("L", length($arg)) . $arg;
a798dbf2	85	}
d53d2b93	86	sub B::Asmdata::PUT_comment_t {
a798dbf2	87	my $arg = shift;
	88	$arg = uncstring($arg);
	89	error "bad string argument: $arg" unless defined($arg);
	90	if ($arg =~ s/\n//g) {
	91	error "comment argument contains linefeed: $arg";
	92	}
	93	return $arg . "\n";
	94	}
e8fcef16	95	sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
a798dbf2	96	sub B::Asmdata::PUT_none {
	97	my $arg = shift;
	98	error "extraneous argument: $arg" if defined $arg;
	99	return "";
	100	}
	101	sub B::Asmdata::PUT_op_tr_array {
	102	my $arg = shift;
	103	my @ary = split(/\s,\s/, $arg);
	104	if (@ary != 256) {
	105	error "wrong number of arguments to op_tr_array";
	106	@ary = (0) x 256;
	107	}
e8fcef16	108	return pack("S256", @ary);
a798dbf2	109	}
	110	# XXX Check this works
	111	sub B::Asmdata::PUT_IV64 {
	112	my $arg = shift;
e8fcef16	113	return pack("LL", $arg >> 32, $arg & 0xffffffff);
a798dbf2	114	}
	115
	116	my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
	117	b => "\b", f => "\f", v => "\013");
	118
	119	sub uncstring {
	120	my $s = shift;
	121	$s =~ s/^"// and $s =~ s/"$// or return undef;
	122	$s =~ s/\\(\d\d\d\|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}\|\|$1)/eg;
	123	return $s;
	124	}
	125
	126	sub strip_comments {
	127	my $stmt = shift;
	128	# Comments only allowed in instructions which don't take string arguments
	129	$stmt =~ s{
	130	(?sx) # Snazzy extended regexp coming up. Also, treat
	131	# string as a single line so .* eats \n characters.
	132	^\s* # Ignore leading whitespace
	133	(
	134	[^"]* # A double quote '"' indicates a string argument. If we
	135	# find a double quote, the match fails and we strip nothing.
	136	)
	137	\s*\# # Any amount of whitespace plus the comment marker...
	138	.*$ # ...which carries on to end-of-string.
	139	}{$1}; # Keep only the instruction and optional argument.
	140	return $stmt;
	141	}
	142
e717db08	143	sub gen_header { # create the ByteCode header: magic, archname, ivsize, ptrsize,
	144	# byteorder
	145	# nvtype irrelevant (floats are stored as strings)
e8fcef16	146	my $header = B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
e717db08	147	$header .= B::Asmdata::PUT_strconst(qq["$Config{archname}"]);
e8fcef16	148	$header .= B::Asmdata::PUT_U32($Config{ivsize});
e8fcef16	149	$header .= B::Asmdata::PUT_U32($Config{ptrsize});
e717db08	150	$header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder}));
	151	# PV not U32 because
	152	# of varying size
	153
e8fcef16	154	$header;
e8fcef16	155	}
e717db08	156
a798dbf2	157	sub parse_statement {
	158	my $stmt = shift;
	159	my ($insn, $arg) = $stmt =~ m{
	160	(?sx)
	161	^\s* # allow (but ignore) leading whitespace
	162	(.*?) # Instruction continues up until...
	163	(?: # ...an optional whitespace+argument group
	164	\s+ # first whitespace.
	165	(.*) # The argument is all the rest (newlines included).
	166	)?$ # anchor at end-of-line
	167	};
	168	if (defined($arg)) {
	169	if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
	170	$arg = hex($arg);
	171	} elsif ($arg =~ s/^0(?=[0-7]+$)//) {
	172	$arg = oct($arg);
	173	} elsif ($arg =~ /^pp_/) {
	174	$arg =~ s/\s*$//; # strip trailing whitespace
	175	my $opnum = $opnumber{$arg};
	176	if (defined($opnum)) {
	177	$arg = $opnum;
	178	} else {
	179	error qq(No such op type "$arg");
	180	$arg = 0;
	181	}
	182	}
	183	}
	184	return ($insn, $arg);
	185	}
	186
	187	sub assemble_insn {
	188	my ($insn, $arg) = @_;
	189	my $data = $insn_data{$insn};
	190	if (defined($data)) {
	191	my ($bytecode, $putsub) = @{$data}[0, 1];
	192	my $argcode = &$putsub($arg);
	193	return chr($bytecode).$argcode;
	194	} else {
	195	error qq(no such instruction "$insn");
	196	return "";
	197	}
	198	}
	199
	200	sub assemble_fh {
	201	my ($fh, $out) = @_;
	202	my ($line, $insn, $arg);
	203	$linenum = 0;
	204	$errors = 0;
e8fcef16	205	&$out(gen_header());
a798dbf2	206	while ($line = <$fh>) {
	207	$linenum++;
	208	chomp $line;
	209	if ($debug) {
	210	my $quotedline = $line;
	211	$quotedline =~ s/\\/\\\\/g;
	212	$quotedline =~ s/"/\\"/g;
	213	&$out(assemble_insn("comment", qq("$quotedline")));
	214	}
	215	$line = strip_comments($line) or next;
	216	($insn, $arg) = parse_statement($line);
	217	&$out(assemble_insn($insn, $arg));
	218	if ($debug) {
	219	&$out(assemble_insn("nop", undef));
	220	}
	221	}
	222	if ($errors) {
	223	die "Assembly failed with $errors error(s)\n";
	224	}
	225	}
	226
	227	1;
7f20e9dd	228
	229	__END__
	230
	231	=head1 NAME
	232
	233	B::Assembler - Assemble Perl bytecode
	234
	235	=head1 SYNOPSIS
	236
	237	use Assembler;
	238
	239	=head1 DESCRIPTION
	240
	241	See F<ext/B/B/Assembler.pm>.
	242
	243	=head1 AUTHOR
	244
	245	Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
	246
	247	=cut