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. |
059a8bb7 |
7 | |
a798dbf2 |
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); |
13 | require ByteLoader; # we just need its $VERSIOM |
a798dbf2 |
14 | |
15 | @ISA = qw(Exporter); |
059a8bb7 |
16 | @EXPORT_OK = qw(assemble_fh newasm endasm assemble); |
f4abc3e7 |
17 | $VERSION = 0.04; |
a798dbf2 |
18 | |
19 | use strict; |
20 | my %opnumber; |
21 | my ($i, $opname); |
22 | for ($i = 0; defined($opname = ppname($i)); $i++) { |
23 | $opnumber{$opname} = $i; |
24 | } |
25 | |
059a8bb7 |
26 | my($linenum, $errors, $out); # global state, set up by newasm |
a798dbf2 |
27 | |
28 | sub error { |
29 | my $str = shift; |
30 | warn "$linenum: $str\n"; |
31 | $errors++; |
32 | } |
33 | |
34 | my $debug = 0; |
35 | sub debug { $debug = shift } |
36 | |
f4abc3e7 |
37 | sub limcheck($$$$){ |
38 | my( $val, $lo, $hi, $loc ) = @_; |
39 | if( $val < $lo || $hi < $val ){ |
40 | error "argument for $loc outside [$lo, $hi]: $val"; |
41 | $val = $hi; |
42 | } |
43 | return $val; |
44 | } |
45 | |
a798dbf2 |
46 | # |
47 | # First define all the data conversion subs to which Asmdata will refer |
48 | # |
49 | |
50 | sub B::Asmdata::PUT_U8 { |
51 | my $arg = shift; |
52 | my $c = uncstring($arg); |
53 | if (defined($c)) { |
54 | if (length($c) != 1) { |
55 | error "argument for U8 is too long: $c"; |
56 | $c = substr($c, 0, 1); |
57 | } |
58 | } else { |
f4abc3e7 |
59 | $arg = limcheck( $arg, 0, 0xff, 'U8' ); |
a798dbf2 |
60 | $c = chr($arg); |
61 | } |
62 | return $c; |
63 | } |
64 | |
f4abc3e7 |
65 | sub B::Asmdata::PUT_U16 { |
66 | my $arg = limcheck( $_[0], 0, 0xffff, 'U16' ); |
67 | pack("S", $arg); |
68 | } |
69 | sub B::Asmdata::PUT_U32 { |
70 | my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' ); |
71 | pack("L", $arg); |
72 | } |
73 | sub B::Asmdata::PUT_I32 { |
74 | my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' ); |
e53790c1 |
75 | pack("l", $arg); |
f4abc3e7 |
76 | } |
77 | sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) |
059a8bb7 |
78 | # may not even be portable between compilers |
f4abc3e7 |
79 | sub B::Asmdata::PUT_objindex { # could allow names here |
80 | my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' ); |
81 | pack("L", $arg); |
82 | } |
cf743617 |
83 | sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } |
84 | sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } |
059a8bb7 |
85 | sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } |
a798dbf2 |
86 | |
87 | sub B::Asmdata::PUT_strconst { |
88 | my $arg = shift; |
f4abc3e7 |
89 | my $str = uncstring($arg); |
90 | if (!defined($str)) { |
a798dbf2 |
91 | error "bad string constant: $arg"; |
f4abc3e7 |
92 | $str = ''; |
a798dbf2 |
93 | } |
f4abc3e7 |
94 | if ($str =~ s/\0//g) { |
a798dbf2 |
95 | error "string constant argument contains NUL: $arg"; |
f4abc3e7 |
96 | $str = ''; |
a798dbf2 |
97 | } |
f4abc3e7 |
98 | return $str . "\0"; |
a798dbf2 |
99 | } |
100 | |
101 | sub B::Asmdata::PUT_pvcontents { |
102 | my $arg = shift; |
103 | error "extraneous argument: $arg" if defined $arg; |
104 | return ""; |
105 | } |
106 | sub B::Asmdata::PUT_PV { |
107 | my $arg = shift; |
f4abc3e7 |
108 | my $str = uncstring($arg); |
109 | if( ! defined($str) ){ |
110 | error "bad string argument: $arg"; |
111 | $str = ''; |
112 | } |
113 | return pack("L", length($str)) . $str; |
a798dbf2 |
114 | } |
d53d2b93 |
115 | sub B::Asmdata::PUT_comment_t { |
a798dbf2 |
116 | my $arg = shift; |
117 | $arg = uncstring($arg); |
118 | error "bad string argument: $arg" unless defined($arg); |
119 | if ($arg =~ s/\n//g) { |
120 | error "comment argument contains linefeed: $arg"; |
121 | } |
122 | return $arg . "\n"; |
123 | } |
059a8bb7 |
124 | sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above |
a798dbf2 |
125 | sub B::Asmdata::PUT_none { |
126 | my $arg = shift; |
127 | error "extraneous argument: $arg" if defined $arg; |
128 | return ""; |
129 | } |
130 | sub B::Asmdata::PUT_op_tr_array { |
131 | my $arg = shift; |
132 | my @ary = split(/\s*,\s*/, $arg); |
133 | if (@ary != 256) { |
134 | error "wrong number of arguments to op_tr_array"; |
135 | @ary = (0) x 256; |
136 | } |
059a8bb7 |
137 | return pack("S256", @ary); |
a798dbf2 |
138 | } |
139 | # XXX Check this works |
f4abc3e7 |
140 | # Note: $arg >> 32 is a no-op on 32-bit systems |
a798dbf2 |
141 | sub B::Asmdata::PUT_IV64 { |
142 | my $arg = shift; |
f4abc3e7 |
143 | return pack("LL", ($arg >> 16) >>16 , $arg & 0xffffffff); |
144 | } |
145 | |
146 | sub B::Asmdata::PUT_IV { |
147 | $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64; |
a798dbf2 |
148 | } |
149 | |
150 | my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", |
151 | b => "\b", f => "\f", v => "\013"); |
152 | |
153 | sub uncstring { |
154 | my $s = shift; |
155 | $s =~ s/^"// and $s =~ s/"$// or return undef; |
156 | $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg; |
157 | return $s; |
158 | } |
159 | |
160 | sub strip_comments { |
161 | my $stmt = shift; |
162 | # Comments only allowed in instructions which don't take string arguments |
a41e59e3 |
163 | # Treat string as a single line so .* eats \n characters. |
a798dbf2 |
164 | $stmt =~ s{ |
a798dbf2 |
165 | ^\s* # Ignore leading whitespace |
166 | ( |
167 | [^"]* # A double quote '"' indicates a string argument. If we |
168 | # find a double quote, the match fails and we strip nothing. |
169 | ) |
170 | \s*\# # Any amount of whitespace plus the comment marker... |
171 | .*$ # ...which carries on to end-of-string. |
a41e59e3 |
172 | }{$1}sx; # Keep only the instruction and optional argument. |
a798dbf2 |
173 | return $stmt; |
174 | } |
175 | |
059a8bb7 |
176 | # create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, |
177 | # ptrsize, byteorder |
178 | # nvtype is irrelevant (floats are stored as strings) |
179 | # byteorder is strconst not U32 because of varying size issues |
180 | |
181 | sub gen_header { |
182 | my $header = ""; |
183 | |
184 | $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' |
185 | $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); |
186 | $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); |
187 | $header .= B::Asmdata::PUT_U32($Config{ivsize}); |
188 | $header .= B::Asmdata::PUT_U32($Config{ptrsize}); |
189 | $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder})); |
190 | |
191 | $header; |
192 | } |
193 | |
a798dbf2 |
194 | sub parse_statement { |
195 | my $stmt = shift; |
196 | my ($insn, $arg) = $stmt =~ m{ |
a798dbf2 |
197 | ^\s* # allow (but ignore) leading whitespace |
198 | (.*?) # Instruction continues up until... |
199 | (?: # ...an optional whitespace+argument group |
200 | \s+ # first whitespace. |
201 | (.*) # The argument is all the rest (newlines included). |
202 | )?$ # anchor at end-of-line |
f4abc3e7 |
203 | }sx; |
a798dbf2 |
204 | if (defined($arg)) { |
205 | if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) { |
206 | $arg = hex($arg); |
207 | } elsif ($arg =~ s/^0(?=[0-7]+$)//) { |
208 | $arg = oct($arg); |
209 | } elsif ($arg =~ /^pp_/) { |
210 | $arg =~ s/\s*$//; # strip trailing whitespace |
211 | my $opnum = $opnumber{$arg}; |
212 | if (defined($opnum)) { |
213 | $arg = $opnum; |
214 | } else { |
215 | error qq(No such op type "$arg"); |
216 | $arg = 0; |
217 | } |
218 | } |
219 | } |
220 | return ($insn, $arg); |
221 | } |
222 | |
223 | sub assemble_insn { |
224 | my ($insn, $arg) = @_; |
225 | my $data = $insn_data{$insn}; |
226 | if (defined($data)) { |
227 | my ($bytecode, $putsub) = @{$data}[0, 1]; |
228 | my $argcode = &$putsub($arg); |
229 | return chr($bytecode).$argcode; |
230 | } else { |
231 | error qq(no such instruction "$insn"); |
232 | return ""; |
233 | } |
234 | } |
235 | |
236 | sub assemble_fh { |
237 | my ($fh, $out) = @_; |
059a8bb7 |
238 | my $line; |
239 | my $asm = newasm($out); |
a798dbf2 |
240 | while ($line = <$fh>) { |
059a8bb7 |
241 | assemble($line); |
a798dbf2 |
242 | } |
059a8bb7 |
243 | endasm(); |
244 | } |
245 | |
246 | sub newasm { |
247 | my($outsub) = @_; |
248 | |
249 | die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; |
250 | die <<EOD if ref $out; |
251 | Can't have multiple byteassembly sessions at once! |
252 | (perhaps you forgot an endasm()?) |
253 | EOD |
254 | |
255 | $linenum = $errors = 0; |
256 | $out = $outsub; |
257 | |
258 | $out->(gen_header()); |
259 | } |
260 | |
261 | sub endasm { |
a798dbf2 |
262 | if ($errors) { |
059a8bb7 |
263 | die "There were $errors assembly errors\n"; |
264 | } |
265 | $linenum = $errors = $out = 0; |
266 | } |
267 | |
268 | sub assemble { |
269 | my($line) = @_; |
270 | my ($insn, $arg); |
271 | $linenum++; |
272 | chomp $line; |
273 | if ($debug) { |
274 | my $quotedline = $line; |
275 | $quotedline =~ s/\\/\\\\/g; |
276 | $quotedline =~ s/"/\\"/g; |
277 | $out->(assemble_insn("comment", qq("$quotedline"))); |
278 | } |
f4abc3e7 |
279 | if( $line = strip_comments($line) ){ |
280 | ($insn, $arg) = parse_statement($line); |
281 | $out->(assemble_insn($insn, $arg)); |
282 | if ($debug) { |
283 | $out->(assemble_insn("nop", undef)); |
284 | } |
a798dbf2 |
285 | } |
286 | } |
287 | |
288 | 1; |
7f20e9dd |
289 | |
290 | __END__ |
291 | |
292 | =head1 NAME |
293 | |
294 | B::Assembler - Assemble Perl bytecode |
295 | |
296 | =head1 SYNOPSIS |
297 | |
059a8bb7 |
298 | use B::Assembler qw(newasm endasm assemble); |
299 | newasm(\&printsub); # sets up for assembly |
300 | assemble($buf); # assembles one line |
301 | endasm(); # closes down |
302 | |
303 | use B::Assembler qw(assemble_fh); |
304 | assemble_fh($fh, \&printsub); # assemble everything in $fh |
7f20e9dd |
305 | |
306 | =head1 DESCRIPTION |
307 | |
308 | See F<ext/B/B/Assembler.pm>. |
309 | |
059a8bb7 |
310 | =head1 AUTHORS |
7f20e9dd |
311 | |
312 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
059a8bb7 |
313 | Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> |
7f20e9dd |
314 | |
315 | =cut |