3 # Copyright (c) 1996 Malcolm Beattie
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.
11 use B::Asmdata qw(%insn_data @insn_name);
12 use Config qw(%Config);
13 require ByteLoader; # we just need its $VERSIOM
16 @EXPORT_OK = qw(assemble_fh newasm endasm assemble);
22 for ($i = 0; defined($opname = ppname($i)); $i++) {
23 $opnumber{$opname} = $i;
26 my($linenum, $errors, $out); # global state, set up by newasm
30 warn "$linenum: $str\n";
35 sub debug { $debug = shift }
38 # First define all the data conversion subs to which Asmdata will refer
41 sub B::Asmdata::PUT_U8 {
43 my $c = uncstring($arg);
45 if (length($c) != 1) {
46 error "argument for U8 is too long: $c";
47 $c = substr($c, 0, 1);
55 sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
56 sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
57 sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
58 sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" loses precision and pack('d',...)
59 # may not even be portable between compilers
60 sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
61 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
62 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
63 sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
65 sub B::Asmdata::PUT_strconst {
67 $arg = uncstring($arg);
69 error "bad string constant: $arg";
72 if ($arg =~ s/\0//g) {
73 error "string constant argument contains NUL: $arg";
78 sub B::Asmdata::PUT_pvcontents {
80 error "extraneous argument: $arg" if defined $arg;
83 sub B::Asmdata::PUT_PV {
85 $arg = uncstring($arg);
86 error "bad string argument: $arg" unless defined($arg);
87 return pack("L", length($arg)) . $arg;
89 sub B::Asmdata::PUT_comment_t {
91 $arg = uncstring($arg);
92 error "bad string argument: $arg" unless defined($arg);
93 if ($arg =~ s/\n//g) {
94 error "comment argument contains linefeed: $arg";
98 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
99 sub B::Asmdata::PUT_none {
101 error "extraneous argument: $arg" if defined $arg;
104 sub B::Asmdata::PUT_op_tr_array {
106 my @ary = split(/\s*,\s*/, $arg);
108 error "wrong number of arguments to op_tr_array";
111 return pack("S256", @ary);
113 # XXX Check this works
114 sub B::Asmdata::PUT_IV64 {
116 return pack("LL", $arg >> 32, $arg & 0xffffffff);
119 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
120 b => "\b", f => "\f", v => "\013");
124 $s =~ s/^"// and $s =~ s/"$// or return undef;
125 $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
131 # Comments only allowed in instructions which don't take string arguments
133 (?sx) # Snazzy extended regexp coming up. Also, treat
134 # string as a single line so .* eats \n characters.
135 ^\s* # Ignore leading whitespace
137 [^"]* # A double quote '"' indicates a string argument. If we
138 # find a double quote, the match fails and we strip nothing.
140 \s*\# # Any amount of whitespace plus the comment marker...
141 .*$ # ...which carries on to end-of-string.
142 }{$1}; # Keep only the instruction and optional argument.
146 # create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
148 # nvtype is irrelevant (floats are stored as strings)
149 # byteorder is strconst not U32 because of varying size issues
154 $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
155 $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
156 $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
157 $header .= B::Asmdata::PUT_U32($Config{ivsize});
158 $header .= B::Asmdata::PUT_U32($Config{ptrsize});
159 $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder}));
164 sub parse_statement {
166 my ($insn, $arg) = $stmt =~ m{
168 ^\s* # allow (but ignore) leading whitespace
169 (.*?) # Instruction continues up until...
170 (?: # ...an optional whitespace+argument group
171 \s+ # first whitespace.
172 (.*) # The argument is all the rest (newlines included).
173 )?$ # anchor at end-of-line
176 if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
178 } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
180 } elsif ($arg =~ /^pp_/) {
181 $arg =~ s/\s*$//; # strip trailing whitespace
182 my $opnum = $opnumber{$arg};
183 if (defined($opnum)) {
186 error qq(No such op type "$arg");
191 return ($insn, $arg);
195 my ($insn, $arg) = @_;
196 my $data = $insn_data{$insn};
197 if (defined($data)) {
198 my ($bytecode, $putsub) = @{$data}[0, 1];
199 my $argcode = &$putsub($arg);
200 return chr($bytecode).$argcode;
202 error qq(no such instruction "$insn");
210 my $asm = newasm($out);
211 while ($line = <$fh>) {
220 die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
221 die <<EOD if ref $out;
222 Can't have multiple byteassembly sessions at once!
223 (perhaps you forgot an endasm()?)
226 $linenum = $errors = 0;
229 $out->(gen_header());
234 die "There were $errors assembly errors\n";
236 $linenum = $errors = $out = 0;
245 my $quotedline = $line;
246 $quotedline =~ s/\\/\\\\/g;
247 $quotedline =~ s/"/\\"/g;
248 $out->(assemble_insn("comment", qq("$quotedline")));
250 $line = strip_comments($line) or next;
251 ($insn, $arg) = parse_statement($line);
252 $out->(assemble_insn($insn, $arg));
254 $out->(assemble_insn("nop", undef));
264 B::Assembler - Assemble Perl bytecode
268 use B::Assembler qw(newasm endasm assemble);
269 newasm(\&printsub); # sets up for assembly
270 assemble($buf); # assembles one line
271 endasm(); # closes down
273 use B::Assembler qw(assemble_fh);
274 assemble_fh($fh, \&printsub); # assemble everything in $fh
278 See F<ext/B/B/Assembler.pm>.
282 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
283 Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>