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); |
6f8e50fd |
13 | require ByteLoader; # we just need its $VERSION |
a798dbf2 |
14 | |
1df34986 |
15 | no warnings; # XXX |
16 | |
a798dbf2 |
17 | @ISA = qw(Exporter); |
1df34986 |
18 | @EXPORT_OK = qw(assemble_fh newasm endasm assemble asm); |
20a6717b |
19 | $VERSION = 0.07; |
a798dbf2 |
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 |
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 |
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 |
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 |
62 | $c = chr($arg); |
63 | } |
64 | return $c; |
65 | } |
66 | |
f4abc3e7 |
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 |
78 | } |
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 |
81 | sub B::Asmdata::PUT_objindex { # could allow names here |
82 | my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' ); |
83 | pack("L", $arg); |
84 | } |
cf743617 |
85 | sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } |
86 | sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } |
059a8bb7 |
87 | sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } |
a798dbf2 |
88 | |
89 | sub B::Asmdata::PUT_strconst { |
90 | my $arg = shift; |
f4abc3e7 |
91 | my $str = uncstring($arg); |
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 |
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 |
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 |
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 |
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 |
133 | my @ary = split /\s*,\s*/, shift; |
134 | return pack "S*", @ary; |
a798dbf2 |
135 | } |
1df34986 |
136 | |
a798dbf2 |
137 | sub B::Asmdata::PUT_IV64 { |
1df34986 |
138 | return pack "Q", shift; |
f4abc3e7 |
139 | } |
140 | |
141 | sub B::Asmdata::PUT_IV { |
142 | $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64; |
a798dbf2 |
143 | } |
144 | |
ca337316 |
145 | sub B::Asmdata::PUT_PADOFFSET { |
146 | $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; |
147 | } |
148 | |
113d5bd9 |
149 | sub B::Asmdata::PUT_long { |
150 | $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; |
151 | } |
152 | |
ede336cb |
153 | sub B::Asmdata::PUT_svtype { |
154 | $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; |
155 | } |
156 | |
a798dbf2 |
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 |
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 |
180 | return $stmt; |
181 | } |
182 | |
059a8bb7 |
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 |
196 | $header; |
197 | } |
198 | |
a798dbf2 |
199 | sub parse_statement { |
200 | my $stmt = shift; |
201 | my ($insn, $arg) = $stmt =~ m{ |
a798dbf2 |
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 |
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 |
243 | my $line; |
244 | my $asm = newasm($out); |
a798dbf2 |
245 | while ($line = <$fh>) { |
059a8bb7 |
246 | assemble($line); |
a798dbf2 |
247 | } |
059a8bb7 |
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 |
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 |
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 |
290 | } |
291 | } |
292 | |
1df34986 |
293 | ### temporary workaround |
294 | |
295 | sub asm { |
296 | return if $_[0] =~ /\s*\W/; |
297 | if (defined $_[1]) { |
fd680345 |
298 | return if $_[1] eq "0" and |
299 | $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/; |
1df34986 |
300 | return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/; |
301 | } |
1df34986 |
302 | assemble "@_"; |
303 | } |
304 | |
a798dbf2 |
305 | 1; |
7f20e9dd |
306 | |
307 | __END__ |
308 | |
309 | =head1 NAME |
310 | |
311 | B::Assembler - Assemble Perl bytecode |
312 | |
313 | =head1 SYNOPSIS |
314 | |
059a8bb7 |
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 |
322 | |
323 | =head1 DESCRIPTION |
324 | |
325 | See F<ext/B/B/Assembler.pm>. |
326 | |
059a8bb7 |
327 | =head1 AUTHORS |
7f20e9dd |
328 | |
329 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
059a8bb7 |
330 | Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> |
7f20e9dd |
331 | |
332 | =cut |