Commit | Line | Data |
---|---|---|
d6480c9d | 1 | #!/usr/bin/perl -w |
6294c161 DM |
2 | # |
3 | # Regenerate (overwriting only if changed): | |
4 | # | |
5 | # opcode.h | |
6 | # opnames.h | |
897d3989 | 7 | # pp_proto.h |
f3574cc6 | 8 | # lib/B/Op_private.pm |
6294c161 | 9 | # |
f3574cc6 DM |
10 | # from: |
11 | # * information stored in regen/opcodes; | |
12 | # * information stored in regen/op_private (which is actually perl code); | |
13 | # * the values hardcoded into this script in @raw_alias. | |
6294c161 DM |
14 | # |
15 | # Accepts the standard regen_lib -q and -v args. | |
16 | # | |
17 | # This script is normally invoked from regen.pl. | |
18 | ||
d6480c9d NC |
19 | use strict; |
20 | ||
36bb303b NC |
21 | BEGIN { |
22 | # Get function prototypes | |
3d7c117d | 23 | require './regen/regen_lib.pl'; |
36bb303b | 24 | } |
79072805 | 25 | |
cc49830d NC |
26 | my $oc = open_new('opcode.h', '>', |
27 | {by => 'regen/opcode.pl', from => 'its data', | |
28 | file => 'opcode.h', style => '*', | |
29 | copyright => [1993 .. 2007]}); | |
30 | ||
31 | my $on = open_new('opnames.h', '>', | |
32 | { by => 'regen/opcode.pl', from => 'its data', style => '*', | |
33 | file => 'opnames.h', copyright => [1999 .. 2008] }); | |
79072805 | 34 | |
f3574cc6 DM |
35 | my $oprivpm = open_new('lib/B/Op_private.pm', '>', |
36 | { by => 'regen/opcode.pl', | |
00fdc80f FC |
37 | from => "data in\nregen/op_private " |
38 | ."and pod embedded in regen/opcode.pl", | |
f3574cc6 DM |
39 | style => '#', |
40 | file => 'lib/B/Op_private.pm', | |
41 | copyright => [2014 .. 2014] }); | |
42 | ||
43 | # Read 'opcodes' data. | |
79072805 | 44 | |
d6480c9d | 45 | my %seen; |
e71197e2 | 46 | my (@ops, %desc, %check, %ckname, %flags, %args, %opnum); |
d6480c9d | 47 | |
1ae6ead9 | 48 | open OPS, '<', 'regen/opcodes' or die $!; |
f8a58b02 NC |
49 | |
50 | while (<OPS>) { | |
79072805 LW |
51 | chop; |
52 | next unless $_; | |
53 | next if /^#/; | |
d6480c9d NC |
54 | my ($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5); |
55 | $args = '' unless defined $args; | |
c07a80fd | 56 | |
6342d5c5 | 57 | warn qq[Description "$desc" duplicates $seen{$desc}\n] |
e839e6ed | 58 | if $seen{$desc} and $key !~ "concat|transr|(?:intro|clone)cv|lvref"; |
c07a80fd | 59 | die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key}; |
6e64f32b FC |
60 | die qq[Opcode "freed" is reserved for the slab allocator\n] |
61 | if $key eq 'freed'; | |
c07a80fd | 62 | $seen{$desc} = qq[description of opcode "$key"]; |
63 | $seen{$key} = qq[opcode "$key"]; | |
64 | ||
79072805 | 65 | push(@ops, $key); |
e71197e2 | 66 | $opnum{$key} = $#ops; |
c07a80fd | 67 | $desc{$key} = $desc; |
79072805 LW |
68 | $check{$key} = $check; |
69 | $ckname{$check}++; | |
70 | $flags{$key} = $flags; | |
71 | $args{$key} = $args; | |
72 | } | |
73 | ||
f2c0bf37 | 74 | # Set up aliases |
1d5774de | 75 | |
f2c0bf37 | 76 | my %alias; |
1d5774de NC |
77 | |
78 | # Format is "this function" => "does these op names" | |
79 | my @raw_alias = ( | |
6faeeb49 | 80 | Perl_do_kv => [qw( keys values )], |
21b66d1c | 81 | Perl_unimplemented_op => [qw(padany custom)], |
0b612f93 NC |
82 | # All the ops with a body of { return NORMAL; } |
83 | Perl_pp_null => [qw(scalar regcmaybe lineseq scope)], | |
84 | ||
85 | Perl_pp_goto => ['dump'], | |
86 | Perl_pp_require => ['dofile'], | |
87 | Perl_pp_untie => ['dbmclose'], | |
7627e6d0 | 88 | Perl_pp_sysread => {read => '', recv => '#ifdef HAS_SOCKET'}, |
0b612f93 NC |
89 | Perl_pp_sysseek => ['seek'], |
90 | Perl_pp_ioctl => ['fcntl'], | |
7627e6d0 NC |
91 | Perl_pp_ssockopt => {gsockopt => '#ifdef HAS_SOCKET'}, |
92 | Perl_pp_getpeername => {getsockname => '#ifdef HAS_SOCKET'}, | |
0b612f93 | 93 | Perl_pp_stat => ['lstat'], |
f1cb2d48 | 94 | Perl_pp_ftrowned => [qw(fteowned ftzero ftsock ftchr ftblk |
17ad201a NC |
95 | ftfile ftdir ftpipe ftsuid ftsgid |
96 | ftsvtx)], | |
0b612f93 NC |
97 | Perl_pp_fttext => ['ftbinary'], |
98 | Perl_pp_gmtime => ['localtime'], | |
99 | Perl_pp_semget => [qw(shmget msgget)], | |
100 | Perl_pp_semctl => [qw(shmctl msgctl)], | |
0b612f93 NC |
101 | Perl_pp_ghostent => [qw(ghbyname ghbyaddr)], |
102 | Perl_pp_gnetent => [qw(gnbyname gnbyaddr)], | |
103 | Perl_pp_gprotoent => [qw(gpbyname gpbynumber)], | |
104 | Perl_pp_gservent => [qw(gsbyname gsbyport)], | |
105 | Perl_pp_gpwent => [qw(gpwnam gpwuid)], | |
106 | Perl_pp_ggrent => [qw(ggrnam ggrgid)], | |
957b0e1d | 107 | Perl_pp_ftis => [qw(ftsize ftmtime ftatime ftctime)], |
605b9385 | 108 | Perl_pp_chown => [qw(unlink chmod utime kill)], |
ce6987d0 | 109 | Perl_pp_link => ['symlink'], |
af9e49b4 NC |
110 | Perl_pp_ftrread => [qw(ftrwrite ftrexec fteread ftewrite |
111 | fteexec)], | |
ca563b4e | 112 | Perl_pp_shmwrite => [qw(shmread msgsnd msgrcv semop)], |
7627e6d0 | 113 | Perl_pp_syswrite => {send => '#ifdef HAS_SOCKET'}, |
c960fc3b | 114 | Perl_pp_defined => [qw(dor dorassign)], |
62726f23 SP |
115 | Perl_pp_and => ['andassign'], |
116 | Perl_pp_or => ['orassign'], | |
12e9c124 | 117 | Perl_pp_ucfirst => ['lcfirst'], |
afd9910b | 118 | Perl_pp_sle => [qw(slt sgt sge)], |
0d863452 | 119 | Perl_pp_print => ['say'], |
2723d216 | 120 | Perl_pp_index => ['rindex'], |
daa2adfd | 121 | Perl_pp_oct => ['hex'], |
789b4bc9 | 122 | Perl_pp_shift => ['pop'], |
71302fe3 | 123 | Perl_pp_sin => [qw(cos exp log sqrt)], |
3658c1f1 | 124 | Perl_pp_bit_or => ['bit_xor'], |
5d01050a FC |
125 | Perl_pp_nbit_or => ['nbit_xor'], |
126 | Perl_pp_sbit_or => ['sbit_xor'], | |
17ab7946 | 127 | Perl_pp_rv2av => ['rv2hv'], |
878d132a | 128 | Perl_pp_akeys => ['avalues'], |
7627e6d0 NC |
129 | Perl_pp_trans => [qw(trans transr)], |
130 | Perl_pp_chop => [qw(chop chomp)], | |
131 | Perl_pp_schop => [qw(schop schomp)], | |
132 | Perl_pp_bind => {connect => '#ifdef HAS_SOCKET'}, | |
4c2c3128 DM |
133 | Perl_pp_preinc => ['i_preinc'], |
134 | Perl_pp_predec => ['i_predec'], | |
20e96431 DM |
135 | Perl_pp_postinc => ['i_postinc'], |
136 | Perl_pp_postdec => ['i_postdec'], | |
720d5dbf NC |
137 | Perl_pp_ehostent => [qw(enetent eprotoent eservent |
138 | spwent epwent sgrent egrent)], | |
396166e1 | 139 | Perl_pp_shostent => [qw(snetent sprotoent sservent)], |
93bad3fd | 140 | Perl_pp_aelemfast => ['aelemfast_lex'], |
21b66d1c | 141 | Perl_pp_grepstart => ['mapstart'], |
605b9385 | 142 | ); |
1d5774de NC |
143 | |
144 | while (my ($func, $names) = splice @raw_alias, 0, 2) { | |
7627e6d0 NC |
145 | if (ref $names eq 'ARRAY') { |
146 | foreach (@$names) { | |
f2c0bf37 | 147 | $alias{$_} = [$func, '']; |
7627e6d0 NC |
148 | } |
149 | } else { | |
150 | while (my ($opname, $cond) = each %$names) { | |
f2c0bf37 | 151 | $alias{$opname} = [$func, $cond]; |
7627e6d0 | 152 | } |
916e4025 | 153 | } |
1d5774de NC |
154 | } |
155 | ||
7627e6d0 NC |
156 | foreach my $sock_func (qw(socket bind listen accept shutdown |
157 | ssockopt getpeername)) { | |
158 | $alias{$sock_func} = ["Perl_pp_$sock_func", '#ifdef HAS_SOCKET'], | |
159 | } | |
160 | ||
f3574cc6 DM |
161 | |
162 | ||
163 | # ================================================================= | |
164 | # | |
165 | # Functions for processing regen/op_private data. | |
166 | # | |
167 | # Put them in a separate package so that croak() does the right thing | |
168 | ||
169 | package OP_PRIVATE; | |
170 | ||
171 | use Carp; | |
172 | ||
173 | ||
174 | # the vars holding the global state built up by all the calls to addbits() | |
175 | ||
176 | ||
177 | # map OPpLVAL_INTRO => LVINTRO | |
178 | my %LABELS; | |
179 | ||
180 | ||
181 | # the numeric values of flags - what will get output as a #define | |
182 | my %DEFINES; | |
183 | ||
184 | # %BITFIELDS: the various bit field types. The key is the concatenation of | |
185 | # all the field values that make up a bit field hash; the values are bit | |
186 | # field hash refs. This allows us to de-dup identical bit field defs | |
187 | # across different ops, and thus make the output tables more compact (esp | |
188 | # important for the C version) | |
189 | my %BITFIELDS; | |
190 | ||
191 | # %FLAGS: the main data structure. Indexed by op name, then bit index: | |
192 | # single bit flag: | |
193 | # $FLAGS{rv2av}{2} = 'OPpSLICEWARNING'; | |
194 | # bit field (bits 5 and 6): | |
195 | # $FLAGS{rv2av}{5} = $FLAGS{rv2av}{6} = { .... }; | |
196 | my %FLAGS; | |
197 | ||
198 | ||
199 | # do, with checking, $LABELS{$name} = $label | |
200 | ||
201 | sub add_label { | |
202 | my ($name, $label) = @_; | |
203 | if (exists $LABELS{$name} and $LABELS{$name} ne $label) { | |
204 | croak "addbits(): label for flag '$name' redefined:\n" | |
205 | . " was '$LABELS{$name}', now '$label'"; | |
206 | } | |
207 | $LABELS{$name} = $label; | |
208 | } | |
209 | ||
210 | # | |
211 | # do, with checking, $DEFINES{$name} = $val | |
212 | ||
213 | sub add_define { | |
214 | my ($name, $val) = @_; | |
215 | if (exists $DEFINES{$name} && $DEFINES{$name} != $val) { | |
216 | croak "addbits(): value for flag '$name' redefined:\n" | |
217 | . " was $DEFINES{$name}, now $val"; | |
218 | } | |
219 | $DEFINES{$name} = $val; | |
220 | } | |
221 | ||
222 | ||
223 | # intended to be called from regen/op_private; see that file for details | |
224 | ||
225 | sub ::addbits { | |
226 | my @args = @_; | |
227 | ||
228 | croak "too few arguments for addbits()" unless @args >= 3; | |
229 | my $op = shift @args; | |
230 | croak "invalid op name: '$op'" unless exists $opnum{$op}; | |
231 | ||
232 | while (@args) { | |
233 | my $bits = shift @args; | |
234 | if ($bits =~ /^[0-7]$/) { | |
235 | # single bit | |
236 | croak "addbits(): too few arguments for single bit flag" | |
237 | unless @args >= 2; | |
238 | my $flag_name = shift @args; | |
239 | my $flag_label = shift @args; | |
240 | add_label($flag_name, $flag_label); | |
f802a825 | 241 | croak "addbits(): bit $bits of $op already specified ($FLAGS{$op}{$bits})" |
f3574cc6 DM |
242 | if defined $FLAGS{$op}{$bits}; |
243 | $FLAGS{$op}{$bits} = $flag_name; | |
244 | add_define($flag_name, (1 << $bits)); | |
245 | } | |
246 | elsif ($bits =~ /^([0-7])\.\.([0-7])$/) { | |
247 | # bit range | |
248 | my ($bitmin, $bitmax) = ($1,$2); | |
249 | ||
250 | croak "addbits(): min bit > max bit in bit range '$bits'" | |
251 | unless $bitmin <= $bitmax; | |
252 | croak "addbits(): bit field argument missing" | |
253 | unless @args >= 1; | |
254 | ||
255 | my $arg_hash = shift @args; | |
256 | croak "addbits(): arg to $bits must be a hash ref" | |
257 | unless defined $arg_hash and ref($arg_hash) =~ /HASH/; | |
258 | ||
259 | my %valid_keys; | |
260 | @valid_keys{qw(baseshift_def bitcount_def mask_def label enum)} = (); | |
261 | for (keys %$arg_hash) { | |
262 | croak "addbits(): unrecognised bifield key: '$_'" | |
263 | unless exists $valid_keys{$_}; | |
264 | } | |
265 | ||
266 | my $bitmask = 0; | |
267 | $bitmask += (1 << $_) for $bitmin..$bitmax; | |
268 | ||
269 | my $enum_id =''; | |
270 | ||
271 | if (defined $arg_hash->{enum}) { | |
272 | my $enum = $arg_hash->{enum}; | |
273 | croak "addbits(): arg to enum must be an array ref" | |
274 | unless defined $enum and ref($enum) =~ /ARRAY/; | |
275 | croak "addbits(): enum list must be in triplets" | |
276 | unless @$enum % 3 == 0; | |
277 | ||
278 | my $max_id = (1 << ($bitmax - $bitmin + 1)) - 1; | |
279 | ||
280 | my @e = @$enum; | |
281 | while (@e) { | |
282 | my $enum_ix = shift @e; | |
283 | my $enum_name = shift @e; | |
284 | my $enum_label = shift @e; | |
285 | croak "addbits(): enum index must be a number: '$enum_ix'" | |
286 | unless $enum_ix =~ /^\d+$/; | |
287 | croak "addbits(): enum index too big: '$enum_ix'" | |
288 | unless $enum_ix <= $max_id; | |
289 | add_label($enum_name, $enum_label); | |
290 | add_define($enum_name, $enum_ix << $bitmin); | |
291 | $enum_id .= "($enum_ix:$enum_name:$enum_label)"; | |
292 | } | |
293 | } | |
294 | ||
295 | # id is a fingerprint of all the content of the bit field hash | |
296 | my $id = join ':', map defined() ? $_ : "-undef-", | |
297 | $bitmin, $bitmax, | |
298 | $arg_hash->{label}, | |
299 | $arg_hash->{mask_def}, | |
300 | $arg_hash->{baseshift_def}, | |
301 | $arg_hash->{bitcount_def}, | |
302 | $enum_id; | |
303 | ||
304 | unless (defined $BITFIELDS{$id}) { | |
305 | ||
306 | if (defined $arg_hash->{mask_def}) { | |
307 | add_define($arg_hash->{mask_def}, $bitmask); | |
308 | } | |
309 | ||
310 | if (defined $arg_hash->{baseshift_def}) { | |
311 | add_define($arg_hash->{baseshift_def}, $bitmin); | |
312 | } | |
313 | ||
314 | if (defined $arg_hash->{bitcount_def}) { | |
315 | add_define($arg_hash->{bitcount_def}, $bitmax-$bitmin+1); | |
316 | } | |
317 | ||
318 | # create deep copy | |
319 | ||
320 | my $copy = {}; | |
321 | for (qw(baseshift_def bitcount_def mask_def label)) { | |
322 | $copy->{$_} = $arg_hash->{$_} if defined $arg_hash->{$_}; | |
323 | } | |
324 | if (defined $arg_hash->{enum}) { | |
325 | $copy->{enum} = [ @{$arg_hash->{enum}} ]; | |
326 | } | |
327 | ||
328 | # and add some extra fields | |
329 | ||
330 | $copy->{bitmask} = $bitmask; | |
331 | $copy->{bitmin} = $bitmin; | |
332 | $copy->{bitmax} = $bitmax; | |
333 | ||
334 | $BITFIELDS{$id} = $copy; | |
335 | } | |
336 | ||
337 | for my $bit ($bitmin..$bitmax) { | |
f802a825 | 338 | croak "addbits(): bit $bit of $op already specified ($FLAGS{$op}{$bit})" |
f3574cc6 DM |
339 | if defined $FLAGS{$op}{$bit}; |
340 | $FLAGS{$op}{$bit} = $BITFIELDS{$id}; | |
341 | } | |
342 | } | |
343 | else { | |
344 | croak "addbits(): invalid bit specifier '$bits'"; | |
345 | } | |
346 | } | |
347 | } | |
348 | ||
349 | ||
350 | # intended to be called from regen/op_private; see that file for details | |
351 | ||
352 | sub ::ops_with_flag { | |
353 | my $flag = shift; | |
354 | return grep $flags{$_} =~ /\Q$flag/, sort keys %flags; | |
355 | } | |
356 | ||
357 | ||
358 | # intended to be called from regen/op_private; see that file for details | |
359 | ||
360 | sub ::ops_with_check { | |
361 | my $c = shift; | |
362 | return grep $check{$_} eq $c, sort keys %check; | |
363 | } | |
364 | ||
365 | ||
366 | # intended to be called from regen/op_private; see that file for details | |
367 | ||
368 | sub ::ops_with_arg { | |
369 | my ($i, $arg_type) = @_; | |
370 | my @ops; | |
371 | for my $op (sort keys %args) { | |
372 | my @args = split(' ',$args{$op}); | |
373 | push @ops, $op if defined $args[$i] and $args[$i] eq $arg_type; | |
374 | } | |
375 | @ops; | |
376 | } | |
377 | ||
378 | ||
379 | # output '#define OPpLVAL_INTRO 0x80' etc | |
380 | ||
381 | sub print_defines { | |
382 | my $fh = shift; | |
383 | ||
384 | for (sort { $DEFINES{$a} <=> $DEFINES{$b} || $a cmp $b } keys %DEFINES) { | |
385 | printf $fh "#define %-23s 0x%02x\n", $_, $DEFINES{$_}; | |
386 | } | |
387 | } | |
388 | ||
389 | ||
390 | # Generate the content of B::Op_private | |
391 | ||
392 | sub print_B_Op_private { | |
393 | my $fh = shift; | |
394 | ||
395 | my $header = <<'EOF'; | |
396 | @=head1 NAME | |
397 | @ | |
2085092c | 398 | @B::Op_private - OP op_private flag definitions |
f3574cc6 DM |
399 | @ |
400 | @=head1 SYNOPSIS | |
401 | @ | |
402 | @ use B::Op_private; | |
403 | @ | |
404 | @ # flag details for bit 7 of OP_AELEM's op_private: | |
405 | @ my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO | |
406 | @ my $value = $B::Op_private::defines{$name}; # 128 | |
407 | @ my $label = $B::Op_private::labels{$name}; # LVINTRO | |
408 | @ | |
409 | @ # the bit field at bits 5..6 of OP_AELEM's op_private: | |
410 | @ my $bf = $B::Op_private::bits{aelem}{6}; | |
411 | @ my $mask = $bf->{bitmask}; # etc | |
412 | @ | |
413 | @=head1 DESCRIPTION | |
414 | @ | |
dc1230de | 415 | @This module provides four global hashes: |
f3574cc6 DM |
416 | @ |
417 | @ %B::Op_private::bits | |
418 | @ %B::Op_private::defines | |
419 | @ %B::Op_private::labels | |
dc1230de | 420 | @ %B::Op_private::ops_using |
f3574cc6 DM |
421 | @ |
422 | @which contain information about the per-op meanings of the bits in the | |
423 | @op_private field. | |
424 | @ | |
425 | @=head2 C<%bits> | |
426 | @ | |
427 | @This is indexed by op name and then bit number (0..7). For single bit flags, | |
428 | @it returns the name of the define (if any) for that bit: | |
429 | @ | |
430 | @ $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO'; | |
431 | @ | |
432 | @For bit fields, it returns a hash ref containing details about the field. | |
433 | @The same reference will be returned for all bit positions that make | |
434 | @up the bit field; so for example these both return the same hash ref: | |
435 | @ | |
436 | @ $bitfield = $B::Op_private::bits{aelem}{5}; | |
437 | @ $bitfield = $B::Op_private::bits{aelem}{6}; | |
438 | @ | |
439 | @The general format of this hash ref is | |
440 | @ | |
441 | @ { | |
442 | @ # The bit range and mask; these are always present. | |
443 | @ bitmin => 5, | |
444 | @ bitmax => 6, | |
445 | @ bitmask => 0x60, | |
446 | @ | |
447 | @ # (The remaining keys are optional) | |
448 | @ | |
449 | @ # The names of any defines that were requested: | |
450 | @ mask_def => 'OPpFOO_MASK', | |
451 | @ baseshift_def => 'OPpFOO_SHIFT', | |
452 | @ bitcount_def => 'OPpFOO_BITS', | |
453 | @ | |
454 | @ # If present, Concise etc will display the value with a 'FOO=' | |
cdb679b6 FC |
455 | @ # prefix. If it equals '-', then Concise will treat the bit |
456 | @ # field as raw bits and not try to interpret it. | |
f3574cc6 DM |
457 | @ label => 'FOO', |
458 | @ | |
2febb45a FC |
459 | @ # If present, specifies the names of some defines and the |
460 | @ # display labels that are used to assign meaning to particu- | |
461 | @ # lar integer values within the bit field; e.g. 3 is dis- | |
462 | @ # played as 'C'. | |
f3574cc6 DM |
463 | @ enum => [ qw( |
464 | @ 1 OPpFOO_A A | |
465 | @ 2 OPpFOO_B B | |
466 | @ 3 OPpFOO_C C | |
467 | @ )], | |
468 | @ | |
469 | @ }; | |
470 | @ | |
471 | @ | |
472 | @=head2 C<%defines> | |
473 | @ | |
474 | @This gives the value of every C<OPp> define, e.g. | |
475 | @ | |
476 | @ $B::Op_private::defines{OPpLVAL_INTRO} == 128; | |
477 | @ | |
478 | @=head2 C<%labels> | |
479 | @ | |
480 | @This gives the short display label for each define, as used by C<B::Concise> | |
481 | @and C<perl -Dx>, e.g. | |
482 | @ | |
483 | @ $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO'; | |
484 | @ | |
485 | @If the label equals '-', then Concise will treat the bit as a raw bit and | |
486 | @not try to display it symbolically. | |
487 | @ | |
dc1230de FC |
488 | @=head2 C<%ops_using> |
489 | @ | |
490 | @For each define, this gives a reference to an array of op names that use | |
491 | @the flag. | |
492 | @ | |
493 | @ @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} }; | |
494 | @ | |
f3574cc6 DM |
495 | @=cut |
496 | ||
497 | package B::Op_private; | |
498 | ||
499 | our %bits; | |
500 | ||
501 | EOF | |
502 | # remove podcheck.t-defeating leading char | |
503 | $header =~ s/^\@//gm; | |
504 | print $fh $header; | |
99275276 DM |
505 | my $v = (::perl_version())[3]; |
506 | print $fh qq{\nour \$VERSION = "$v";\n\n}; | |
f3574cc6 | 507 | |
dc1230de FC |
508 | my %ops_using; |
509 | ||
f3574cc6 DM |
510 | # for each flag/bit combination, find the ops which use it |
511 | my %combos; | |
512 | for my $op (sort keys %FLAGS) { | |
513 | my $entry = $FLAGS{$op}; | |
514 | for my $bit (0..7) { | |
515 | my $e = $entry->{$bit}; | |
516 | next unless defined $e; | |
517 | next if ref $e; # bit field, not flag | |
518 | push @{$combos{$e}{$bit}}, $op; | |
dc1230de | 519 | push @{$ops_using{$e}}, $op; |
f3574cc6 DM |
520 | } |
521 | } | |
522 | ||
523 | # dump flags used by multiple ops | |
524 | for my $flag (sort keys %combos) { | |
525 | for my $bit (sort keys %{$combos{$flag}}) { | |
526 | my $ops = $combos{$flag}{$bit}; | |
527 | next unless @$ops > 1; | |
528 | my @o = sort @$ops; | |
529 | print $fh "\$bits{\$_}{$bit} = '$flag' for qw(@o);\n"; | |
530 | } | |
531 | } | |
532 | ||
533 | # dump bit field definitions | |
534 | ||
535 | my %bitfield_ix; | |
536 | { | |
537 | my %bitfields; | |
538 | # stringified-ref to ref mapping | |
539 | $bitfields{$_} = $_ for values %BITFIELDS; | |
540 | my $ix = -1; | |
541 | my $s = "\nmy \@bf = (\n"; | |
542 | for my $bitfield_key (sort keys %BITFIELDS) { | |
543 | my $bitfield = $BITFIELDS{$bitfield_key}; | |
544 | $ix++; | |
545 | $bitfield_ix{$bitfield} = $ix; | |
546 | ||
547 | $s .= " {\n"; | |
548 | for (qw(label mask_def baseshift_def bitcount_def)) { | |
549 | next unless defined $bitfield->{$_}; | |
550 | $s .= sprintf " %-9s => '%s',\n", | |
551 | $_, $bitfield->{$_}; | |
552 | } | |
553 | for (qw(bitmin bitmax bitmask)) { | |
554 | croak "panic" unless defined $bitfield->{$_}; | |
555 | $s .= sprintf " %-9s => %d,\n", | |
556 | $_, $bitfield->{$_}; | |
557 | } | |
558 | if (defined $bitfield->{enum}) { | |
559 | $s .= " enum => [\n"; | |
560 | my @enum = @{$bitfield->{enum}}; | |
561 | while (@enum) { | |
562 | my $i = shift @enum; | |
563 | my $name = shift @enum; | |
564 | my $label = shift @enum; | |
565 | $s .= sprintf " %d, %-10s, %s,\n", | |
566 | $i, "'$name'", "'$label'"; | |
567 | } | |
568 | $s .= " ],\n"; | |
569 | } | |
570 | $s .= " },\n"; | |
571 | ||
572 | } | |
573 | $s .= ");\n"; | |
574 | print $fh "$s\n"; | |
575 | } | |
576 | ||
577 | # dump bitfields and remaining labels | |
578 | ||
579 | for my $op (sort keys %FLAGS) { | |
580 | my @indices; | |
581 | my @vals; | |
582 | my $entry = $FLAGS{$op}; | |
583 | my $bit; | |
584 | ||
585 | for ($bit = 7; $bit >= 0; $bit--) { | |
586 | next unless defined $entry->{$bit}; | |
587 | my $e = $entry->{$bit}; | |
588 | if (ref $e) { | |
589 | my $ix = $bitfield_ix{$e}; | |
590 | for (reverse $e->{bitmin}..$e->{bitmax}) { | |
591 | push @indices, $_; | |
592 | push @vals, "\$bf[$ix]"; | |
593 | } | |
594 | $bit = $e->{bitmin}; | |
595 | } | |
596 | else { | |
597 | next if @{$combos{$e}{$bit}} > 1; # already output | |
598 | push @indices, $bit; | |
599 | push @vals, "'$e'"; | |
600 | } | |
601 | } | |
602 | if (@indices) { | |
603 | my $s = ''; | |
604 | $s = '@{' if @indices > 1; | |
605 | $s .= "\$bits{$op}"; | |
606 | $s .= '}' if @indices > 1; | |
607 | $s .= '{' . join(',', @indices) . '} = '; | |
608 | $s .= '(' if @indices > 1; | |
609 | $s .= join ', ', @vals; | |
610 | $s .= ')' if @indices > 1; | |
611 | print $fh "$s;\n"; | |
612 | } | |
613 | } | |
614 | ||
615 | # populate %defines and %labels | |
616 | ||
617 | print $fh "\n\nour %defines = (\n"; | |
618 | printf $fh " %-23s => %3d,\n", $_ , $DEFINES{$_} for sort keys %DEFINES; | |
619 | print $fh ");\n\nour %labels = (\n"; | |
620 | printf $fh " %-23s => '%s',\n", $_ , $LABELS{$_} for sort keys %LABELS; | |
621 | print $fh ");\n"; | |
622 | ||
dc1230de FC |
623 | # %ops_using |
624 | print $fh "\n\nour %ops_using = (\n"; | |
625 | # Save memory by using the same array wherever possible. | |
626 | my %flag_by_op_list; | |
627 | my $pending = ''; | |
628 | for my $flag (sort keys %ops_using) { | |
629 | my $op_list = $ops_using{$flag} = "@{$ops_using{$flag}}"; | |
630 | if (!exists $flag_by_op_list{$op_list}) { | |
631 | $flag_by_op_list{$op_list} = $flag; | |
632 | printf $fh " %-23s => %s,\n", $flag , "[qw($op_list)]" | |
633 | } | |
634 | else { | |
635 | $pending .= "\$ops_using{$flag} = " | |
636 | . "\$ops_using{$flag_by_op_list{$op_list}};\n"; | |
637 | } | |
638 | } | |
639 | print $fh ");\n\n$pending"; | |
640 | ||
f3574cc6 DM |
641 | } |
642 | ||
643 | ||
644 | ||
645 | # output the contents of the assorted PL_op_private_*[] tables | |
646 | ||
647 | sub print_PL_op_private_tables { | |
648 | my $fh = shift; | |
649 | ||
650 | my $PL_op_private_labels = ''; | |
651 | my $PL_op_private_valid = ''; | |
652 | my $PL_op_private_bitdef_ix = ''; | |
653 | my $PL_op_private_bitdefs = ''; | |
654 | my $PL_op_private_bitfields = ''; | |
655 | ||
656 | my %label_ix; | |
657 | my %bitfield_ix; | |
658 | ||
659 | # generate $PL_op_private_labels | |
660 | ||
661 | { | |
662 | my %labs; | |
663 | $labs{$_} = 1 for values %LABELS; # de-duplicate labels | |
664 | # add in bit field labels | |
665 | for (values %BITFIELDS) { | |
666 | next unless defined $_->{label}; | |
667 | $labs{$_->{label}} = 1; | |
668 | } | |
669 | ||
670 | my $labels = ''; | |
671 | for my $lab (sort keys %labs) { | |
672 | $label_ix{$lab} = length $labels; | |
673 | $labels .= "$lab\0"; | |
674 | $PL_op_private_labels .= | |
675 | " " | |
676 | . join(',', map("'$_'", split //, $lab)) | |
677 | . ",'\\0',\n"; | |
678 | } | |
679 | } | |
680 | ||
681 | ||
682 | # generate PL_op_private_bitfields | |
683 | ||
684 | { | |
685 | my %bitfields; | |
686 | # stringified-ref to ref mapping | |
687 | $bitfields{$_} = $_ for values %BITFIELDS; | |
688 | ||
689 | my $ix = 0; | |
690 | for my $bitfield_key (sort keys %BITFIELDS) { | |
691 | my $bf = $BITFIELDS{$bitfield_key}; | |
692 | $bitfield_ix{$bf} = $ix; | |
693 | ||
694 | my @b; | |
695 | push @b, $bf->{bitmin}, | |
696 | defined $bf->{label} ? $label_ix{$bf->{label}} : -1; | |
697 | my $enum = $bf->{enum}; | |
698 | if (defined $enum) { | |
699 | my @enum = @$enum; | |
700 | while (@enum) { | |
701 | my $i = shift @enum; | |
702 | my $name = shift @enum; | |
703 | my $label = shift @enum; | |
704 | push @b, $i, $label_ix{$label}; | |
705 | } | |
706 | } | |
707 | push @b, -1; # terminate enum list | |
708 | ||
709 | $PL_op_private_bitfields .= " " . join(', ', @b) .",\n"; | |
710 | $ix += @b; | |
711 | } | |
712 | } | |
713 | ||
714 | ||
715 | # generate PL_op_private_bitdefs, PL_op_private_bitdef_ix | |
716 | ||
717 | { | |
718 | my $bitdef_count = 0; | |
719 | ||
720 | my %not_seen = %FLAGS; | |
dd6eeb56 FC |
721 | my @seen_bitdefs; |
722 | my %seen_bitdefs; | |
f3574cc6 DM |
723 | |
724 | my $opnum = -1; | |
725 | for my $op (sort { $opnum{$a} <=> $opnum{$b} } keys %opnum) { | |
726 | $opnum++; | |
727 | die "panic: opnum misorder: opnum=$opnum opnum{op}=$opnum{$op}" | |
728 | unless $opnum == $opnum{$op}; | |
729 | delete $not_seen{$op}; | |
730 | ||
731 | my @bitdefs; | |
732 | my $entry = $FLAGS{$op}; | |
733 | my $bit; | |
734 | my $index; | |
735 | ||
736 | for ($bit = 7; $bit >= 0; $bit--) { | |
737 | my $e = $entry->{$bit}; | |
738 | next unless defined $e; | |
739 | ||
740 | my $ix; | |
741 | if (ref $e) { | |
742 | $ix = $bitfield_ix{$e}; | |
743 | die "panic: \$bit =\= $e->{bitmax}" | |
744 | unless $bit == $e->{bitmax}; | |
745 | ||
746 | push @bitdefs, ( ($ix << 5) | ($bit << 2) | 2 ); | |
747 | $bit = $e->{bitmin}; | |
748 | } | |
749 | else { | |
750 | $ix = $label_ix{$LABELS{$e}}; | |
751 | die "panic: no label ix for '$e'" unless defined $ix; | |
752 | push @bitdefs, ( ($ix << 5) | ($bit << 2)); | |
753 | } | |
754 | if ($ix > 2047) { | |
755 | die "Too many labels or bitfields (ix=$ix): " | |
756 | . "maybe the type of PL_op_private_bitdefs needs " | |
757 | . "expanding from U16 to U32???"; | |
758 | } | |
759 | } | |
760 | if (@bitdefs) { | |
761 | $bitdefs[-1] |= 1; # stop bit | |
dd6eeb56 FC |
762 | my $key = join(', ', map(sprintf("0x%04x", $_), @bitdefs)); |
763 | if (!$seen_bitdefs{$key}) { | |
764 | $index = $bitdef_count; | |
765 | $bitdef_count += @bitdefs; | |
766 | push @seen_bitdefs, | |
767 | $seen_bitdefs{$key} = [$index, $key]; | |
768 | } | |
769 | else { | |
770 | $index = $seen_bitdefs{$key}[0]; | |
771 | } | |
772 | push @{$seen_bitdefs{$key}}, $op; | |
f3574cc6 DM |
773 | } |
774 | else { | |
775 | $index = -1; | |
776 | } | |
777 | $PL_op_private_bitdef_ix .= sprintf " %4d, /* %s */\n", $index, $op; | |
778 | } | |
779 | if (%not_seen) { | |
780 | die "panic: unprocessed ops: ". join(',', keys %not_seen); | |
781 | } | |
dd6eeb56 FC |
782 | for (@seen_bitdefs) { |
783 | local $" = ", "; | |
784 | $PL_op_private_bitdefs .= " $$_[1], /* @$_[2..$#$_] */\n"; | |
785 | } | |
f3574cc6 DM |
786 | } |
787 | ||
788 | ||
789 | # generate PL_op_private_valid | |
790 | ||
791 | for my $op (@ops) { | |
792 | my $last; | |
793 | my @flags; | |
794 | for my $bit (0..7) { | |
795 | next unless exists $FLAGS{$op}; | |
796 | my $entry = $FLAGS{$op}{$bit}; | |
797 | next unless defined $entry; | |
798 | if (ref $entry) { | |
799 | # skip later entries for the same bit field | |
800 | next if defined $last and $last == $entry; | |
801 | $last = $entry; | |
802 | push @flags, | |
803 | defined $entry->{mask_def} | |
804 | ? $entry->{mask_def} | |
805 | : $entry->{bitmask}; | |
806 | } | |
807 | else { | |
808 | push @flags, $entry; | |
809 | } | |
810 | } | |
811 | ||
812 | # all bets are off | |
813 | @flags = '0xff' if $op eq 'null' or $op eq 'custom'; | |
814 | ||
815 | $PL_op_private_valid .= sprintf " /* %-10s */ (%s),\n", uc($op), | |
816 | @flags ? join('|', @flags): '0'; | |
817 | } | |
818 | ||
819 | print $fh <<EOF; | |
820 | START_EXTERN_C | |
821 | ||
8c3a0f6c | 822 | #ifndef DOINIT |
f3574cc6 DM |
823 | |
824 | /* data about the flags in op_private */ | |
825 | ||
826 | EXTCONST I16 PL_op_private_bitdef_ix[]; | |
827 | EXTCONST U16 PL_op_private_bitdefs[]; | |
828 | EXTCONST char PL_op_private_labels[]; | |
829 | EXTCONST I16 PL_op_private_bitfields[]; | |
830 | EXTCONST U8 PL_op_private_valid[]; | |
831 | ||
8c3a0f6c | 832 | #else |
f3574cc6 DM |
833 | |
834 | ||
835 | /* PL_op_private_labels[]: the short descriptions of private flags. | |
836 | * All labels are concatenated into a single char array | |
837 | * (separated by \\0's) for compactness. | |
838 | */ | |
839 | ||
840 | EXTCONST char PL_op_private_labels[] = { | |
841 | $PL_op_private_labels | |
842 | }; | |
843 | ||
844 | ||
845 | ||
846 | /* PL_op_private_bitfields[]: details about each bit field type. | |
ac5b5e2c | 847 | * Each definition consists of the following list of words: |
f3574cc6 DM |
848 | * bitmin |
849 | * label (index into PL_op_private_labels[]; -1 if no label) | |
850 | * repeat for each enum entry (if any): | |
851 | * enum value | |
852 | * enum label (index into PL_op_private_labels[]) | |
853 | * -1 | |
854 | */ | |
855 | ||
856 | EXTCONST I16 PL_op_private_bitfields[] = { | |
857 | $PL_op_private_bitfields | |
858 | }; | |
859 | ||
860 | ||
861 | /* PL_op_private_bitdef_ix[]: map an op number to a starting position | |
862 | * in PL_op_private_bitdefs. If -1, the op has no bits defined */ | |
863 | ||
864 | EXTCONST I16 PL_op_private_bitdef_ix[] = { | |
865 | $PL_op_private_bitdef_ix | |
866 | }; | |
867 | ||
868 | ||
869 | ||
870 | /* PL_op_private_bitdefs[]: given a starting position in this array (as | |
871 | * supplied by PL_op_private_bitdef_ix[]), each word (until a stop bit is | |
872 | * seen) defines the meaning of a particular op_private bit for a | |
873 | * particular op. Each word consists of: | |
874 | * bit 0: stop bit: this is the last bit def for the current op | |
875 | * bit 1: bitfield: if set, this defines a bit field rather than a flag | |
876 | * bits 2..4: unsigned number in the range 0..7 which is the bit number | |
877 | * bits 5..15: unsigned number in the range 0..2047 which is an index | |
878 | * into PL_op_private_labels[] (for a flag), or | |
879 | * into PL_op_private_bitfields[] (for a bit field) | |
880 | */ | |
881 | ||
882 | EXTCONST U16 PL_op_private_bitdefs[] = { | |
883 | $PL_op_private_bitdefs | |
884 | }; | |
885 | ||
886 | ||
887 | /* PL_op_private_valid: for each op, indexed by op_type, indicate which | |
888 | * flags bits in op_private are legal */ | |
889 | ||
890 | EXTCONST U8 PL_op_private_valid[] = { | |
891 | $PL_op_private_valid | |
892 | }; | |
893 | ||
8c3a0f6c | 894 | #endif /* !DOINIT */ |
f3574cc6 DM |
895 | |
896 | END_EXTERN_C | |
897 | ||
898 | ||
899 | EOF | |
900 | ||
901 | } | |
902 | ||
903 | ||
904 | # ================================================================= | |
905 | ||
906 | ||
907 | package main; | |
908 | ||
909 | # read regen/op_private data | |
910 | # | |
911 | # This file contains Perl code that builds up some data structures | |
912 | # which define what bits in op_private have what meanings for each op. | |
913 | # It populates %LABELS, %DEFINES, %FLAGS, %BITFIELDS. | |
914 | ||
3d7c117d | 915 | require './regen/op_private'; |
f3574cc6 DM |
916 | |
917 | #use Data::Dumper; | |
918 | #print Dumper \%LABELS, \%DEFINES, \%FLAGS, \%BITFIELDS; | |
919 | ||
920 | ||
79072805 LW |
921 | # Emit defines. |
922 | ||
7627e6d0 NC |
923 | { |
924 | my $last_cond = ''; | |
925 | my @unimplemented; | |
926 | ||
927 | sub unimplemented { | |
928 | if (@unimplemented) { | |
2d6469fe | 929 | print $oc "#else\n"; |
7627e6d0 | 930 | foreach (@unimplemented) { |
2d6469fe | 931 | print $oc "#define $_ Perl_unimplemented_op\n"; |
7627e6d0 | 932 | } |
2d6469fe | 933 | print $oc "#endif\n"; |
7627e6d0 NC |
934 | @unimplemented = (); |
935 | } | |
936 | ||
937 | } | |
938 | ||
939 | for (@ops) { | |
940 | my ($impl, $cond) = @{$alias{$_} || ["Perl_pp_$_", '']}; | |
941 | my $op_func = "Perl_pp_$_"; | |
942 | ||
943 | if ($cond ne $last_cond) { | |
944 | # A change in condition. (including to or from no condition) | |
945 | unimplemented(); | |
946 | $last_cond = $cond; | |
947 | if ($last_cond) { | |
2d6469fe | 948 | print $oc "$last_cond\n"; |
7627e6d0 NC |
949 | } |
950 | } | |
951 | push @unimplemented, $op_func if $last_cond; | |
2d6469fe | 952 | print $oc "#define $op_func $impl\n" if $impl ne $op_func; |
7627e6d0 NC |
953 | } |
954 | # If the last op was conditional, we need to close it out: | |
955 | unimplemented(); | |
9561d06f NC |
956 | } |
957 | ||
cc49830d | 958 | print $on "typedef enum opcode {\n"; |
abdd5c84 | 959 | |
d6480c9d | 960 | my $i = 0; |
79072805 | 961 | for (@ops) { |
2d6469fe | 962 | print $on "\t", tab(3,"OP_\U$_"), " = ", $i++, ",\n"; |
79072805 | 963 | } |
2d6469fe | 964 | print $on "\t", tab(3,"OP_max"), "\n"; |
424a4936 NC |
965 | print $on "} opcode;\n"; |
966 | print $on "\n#define MAXO ", scalar @ops, "\n"; | |
6e64f32b | 967 | print $on "#define OP_FREED MAXO\n"; |
79072805 | 968 | |
c07a80fd | 969 | # Emit op names and descriptions. |
79072805 | 970 | |
2d6469fe | 971 | print $oc <<'END'; |
73c4f7a1 GS |
972 | START_EXTERN_C |
973 | ||
79072805 | 974 | #ifndef DOINIT |
27da23d5 | 975 | EXTCONST char* const PL_op_name[]; |
79072805 | 976 | #else |
27da23d5 | 977 | EXTCONST char* const PL_op_name[] = { |
79072805 LW |
978 | END |
979 | ||
980 | for (@ops) { | |
2d6469fe | 981 | print $oc qq(\t"$_",\n); |
c07a80fd | 982 | } |
983 | ||
2d6469fe | 984 | print $oc <<'END'; |
a33a81d0 | 985 | "freed", |
c07a80fd | 986 | }; |
987 | #endif | |
988 | ||
c07a80fd | 989 | #ifndef DOINIT |
27da23d5 | 990 | EXTCONST char* const PL_op_desc[]; |
c07a80fd | 991 | #else |
27da23d5 | 992 | EXTCONST char* const PL_op_desc[] = { |
c07a80fd | 993 | END |
994 | ||
995 | for (@ops) { | |
42d38218 MS |
996 | my($safe_desc) = $desc{$_}; |
997 | ||
a567e93b | 998 | # Have to escape double quotes and escape characters. |
b0c6325e | 999 | $safe_desc =~ s/([\\"])/\\$1/g; |
42d38218 | 1000 | |
2d6469fe | 1001 | print $oc qq(\t"$safe_desc",\n); |
79072805 LW |
1002 | } |
1003 | ||
2d6469fe | 1004 | print $oc <<'END'; |
a33a81d0 | 1005 | "freed op", |
79072805 LW |
1006 | }; |
1007 | #endif | |
1008 | ||
73c4f7a1 | 1009 | END_EXTERN_C |
22c35a8c | 1010 | END |
79072805 | 1011 | |
79072805 LW |
1012 | # Emit ppcode switch array. |
1013 | ||
2d6469fe | 1014 | print $oc <<'END'; |
79072805 | 1015 | |
73c4f7a1 GS |
1016 | START_EXTERN_C |
1017 | ||
27da23d5 | 1018 | EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ |
8c3a0f6c | 1019 | #if defined(DOINIT) |
27da23d5 | 1020 | = { |
79072805 LW |
1021 | END |
1022 | ||
1023 | for (@ops) { | |
7627e6d0 NC |
1024 | my $op_func = "Perl_pp_$_"; |
1025 | my $name = $alias{$_}; | |
1026 | if ($name && $name->[0] ne $op_func) { | |
2d6469fe | 1027 | print $oc "\t$op_func,\t/* implemented by $name->[0] */\n"; |
6faeeb49 MB |
1028 | } |
1029 | else { | |
2d6469fe | 1030 | print $oc "\t$op_func,\n"; |
6faeeb49 | 1031 | } |
79072805 LW |
1032 | } |
1033 | ||
2d6469fe | 1034 | print $oc <<'END'; |
27da23d5 | 1035 | } |
79072805 | 1036 | #endif |
27da23d5 | 1037 | ; |
79072805 | 1038 | |
0850138d | 1039 | EXT Perl_check_t PL_check[] /* or perlvars.h */ |
8c3a0f6c | 1040 | #if defined(DOINIT) |
27da23d5 | 1041 | = { |
79072805 LW |
1042 | END |
1043 | ||
1044 | for (@ops) { | |
2d6469fe | 1045 | print $oc "\t", tab(3, "Perl_$check{$_},"), "\t/* $_ */\n"; |
79072805 LW |
1046 | } |
1047 | ||
2d6469fe | 1048 | print $oc <<'END'; |
0850138d | 1049 | } |
79072805 | 1050 | #endif |
0850138d | 1051 | ; |
27da23d5 | 1052 | |
79072805 | 1053 | #ifndef DOINIT |
1ccb7c8d | 1054 | EXTCONST U32 PL_opargs[]; |
79072805 | 1055 | #else |
1ccb7c8d | 1056 | EXTCONST U32 PL_opargs[] = { |
79072805 LW |
1057 | END |
1058 | ||
2d6469fe NC |
1059 | # Emit allowed argument types. |
1060 | ||
1061 | my $ARGBITS = 32; | |
1062 | ||
d6480c9d NC |
1063 | my %argnum = ( |
1064 | 'S', 1, # scalar | |
1065 | 'L', 2, # list | |
1066 | 'A', 3, # array value | |
1067 | 'H', 4, # hash value | |
1068 | 'C', 5, # code value | |
1069 | 'F', 6, # file value | |
1070 | 'R', 7, # scalar reference | |
79072805 LW |
1071 | ); |
1072 | ||
d6480c9d | 1073 | my %opclass = ( |
db173bac MB |
1074 | '0', 0, # baseop |
1075 | '1', 1, # unop | |
1076 | '2', 2, # binop | |
1077 | '|', 3, # logop | |
1a67a97c SM |
1078 | '@', 4, # listop |
1079 | '/', 5, # pmop | |
350de78d | 1080 | '$', 6, # svop_or_padop |
7934575e | 1081 | '#', 7, # padop |
1a67a97c SM |
1082 | '"', 8, # pvop_or_svop |
1083 | '{', 9, # loop | |
1084 | ';', 10, # cop | |
1085 | '%', 11, # baseop_or_unop | |
1086 | '-', 12, # filestatop | |
1087 | '}', 13, # loopexop | |
b46e009d | 1088 | '.', 14, # methop |
2f7c6295 | 1089 | '+', 15, # unop_aux |
db173bac MB |
1090 | ); |
1091 | ||
c2dedb93 MHM |
1092 | my %opflags = ( |
1093 | 'm' => 1, # needs stack mark | |
1094 | 'f' => 2, # fold constants | |
1095 | 's' => 4, # always produces scalar | |
1096 | 't' => 8, # needs target scalar | |
903fd87c NC |
1097 | 'T' => 8 | 16, # ... which may be lexical |
1098 | 'i' => 0, # always produces integer (unused since e7311069) | |
c2dedb93 | 1099 | 'I' => 32, # has corresponding int op |
e791f90a | 1100 | 'd' => 64, # danger, make temp copy in list assignment |
c2dedb93 MHM |
1101 | 'u' => 128, # defaults to $_ |
1102 | ); | |
1103 | ||
2b420b63 JC |
1104 | my %OP_IS_SOCKET; # /Fs/ |
1105 | my %OP_IS_FILETEST; # /F-/ | |
1106 | my %OP_IS_FT_ACCESS; # /F-+/ | |
1107 | my %OP_IS_NUMCOMPARE; # /S</ | |
332c2eac | 1108 | my %OP_IS_DIRHOP; # /Fd/ |
a9f19d0f | 1109 | my %OP_IS_INFIX_BIT; # /S\|/ |
332c2eac | 1110 | |
903fd87c NC |
1111 | my $OCSHIFT = 8; |
1112 | my $OASHIFT = 12; | |
a85d93d9 | 1113 | |
c2dedb93 | 1114 | for my $op (@ops) { |
d6480c9d | 1115 | my $argsum = 0; |
c2dedb93 MHM |
1116 | my $flags = $flags{$op}; |
1117 | for my $flag (keys %opflags) { | |
1118 | if ($flags =~ s/$flag//) { | |
cb7b5e07 | 1119 | die "Flag collision for '$op' ($flags{$op}, $flag)\n" |
c2dedb93 MHM |
1120 | if $argsum & $opflags{$flag}; |
1121 | $argsum |= $opflags{$flag}; | |
1122 | } | |
1123 | } | |
cb7b5e07 | 1124 | die qq[Opcode '$op' has no class indicator ($flags{$op} => $flags)\n] |
c2dedb93 MHM |
1125 | unless exists $opclass{$flags}; |
1126 | $argsum |= $opclass{$flags} << $OCSHIFT; | |
1127 | my $argshift = $OASHIFT; | |
1128 | for my $arg (split(' ',$args{$op})) { | |
332c2eac JC |
1129 | if ($arg =~ s/^D//) { |
1130 | # handle 1st, just to put D 1st. | |
1131 | $OP_IS_DIRHOP{$op} = $opnum{$op}; | |
1132 | } | |
a85d93d9 | 1133 | if ($arg =~ /^F/) { |
e71197e2 JC |
1134 | # record opnums of these opnames |
1135 | $OP_IS_SOCKET{$op} = $opnum{$op} if $arg =~ s/s//; | |
1136 | $OP_IS_FILETEST{$op} = $opnum{$op} if $arg =~ s/-//; | |
6ecf81d6 | 1137 | $OP_IS_FT_ACCESS{$op} = $opnum{$op} if $arg =~ s/\+//; |
a85d93d9 | 1138 | } |
a9f19d0f | 1139 | elsif ($arg =~ /^S./) { |
2b420b63 | 1140 | $OP_IS_NUMCOMPARE{$op} = $opnum{$op} if $arg =~ s/<//; |
a9f19d0f | 1141 | $OP_IS_INFIX_BIT {$op} = $opnum{$op} if $arg =~ s/\|//; |
2b420b63 | 1142 | } |
d6480c9d | 1143 | my $argnum = ($arg =~ s/\?//) ? 8 : 0; |
c2dedb93 MHM |
1144 | die "op = $op, arg = $arg\n" |
1145 | unless exists $argnum{$arg}; | |
79072805 | 1146 | $argnum += $argnum{$arg}; |
c2dedb93 MHM |
1147 | die "Argument overflow for '$op'\n" |
1148 | if $argshift >= $ARGBITS || | |
1149 | $argnum > ((1 << ($ARGBITS - $argshift)) - 1); | |
1150 | $argsum += $argnum << $argshift; | |
1151 | $argshift += 4; | |
79072805 LW |
1152 | } |
1153 | $argsum = sprintf("0x%08x", $argsum); | |
2d6469fe | 1154 | print $oc "\t", tab(3, "$argsum,"), "/* $op */\n"; |
79072805 LW |
1155 | } |
1156 | ||
2d6469fe | 1157 | print $oc <<'END'; |
79072805 LW |
1158 | }; |
1159 | #endif | |
73c4f7a1 GS |
1160 | |
1161 | END_EXTERN_C | |
79072805 LW |
1162 | END |
1163 | ||
e71197e2 JC |
1164 | # Emit OP_IS_* macros |
1165 | ||
2d6469fe | 1166 | print $on <<'EO_OP_IS_COMMENT'; |
e71197e2 | 1167 | |
332c2eac JC |
1168 | /* the OP_IS_* macros are optimized to a simple range check because |
1169 | all the member OPs are contiguous in regen/opcodes table. | |
1170 | opcode.pl verifies the range contiguity, or generates an OR-equals | |
1171 | expression */ | |
e71197e2 JC |
1172 | EO_OP_IS_COMMENT |
1173 | ||
1174 | gen_op_is_macro( \%OP_IS_SOCKET, 'OP_IS_SOCKET'); | |
1175 | gen_op_is_macro( \%OP_IS_FILETEST, 'OP_IS_FILETEST'); | |
6ecf81d6 | 1176 | gen_op_is_macro( \%OP_IS_FT_ACCESS, 'OP_IS_FILETEST_ACCESS'); |
2b420b63 | 1177 | gen_op_is_macro( \%OP_IS_NUMCOMPARE, 'OP_IS_NUMCOMPARE'); |
332c2eac | 1178 | gen_op_is_macro( \%OP_IS_DIRHOP, 'OP_IS_DIRHOP'); |
a9f19d0f | 1179 | gen_op_is_macro( \%OP_IS_INFIX_BIT, 'OP_IS_INFIX_BIT'); |
e71197e2 JC |
1180 | |
1181 | sub gen_op_is_macro { | |
1182 | my ($op_is, $macname) = @_; | |
1183 | if (keys %$op_is) { | |
1184 | ||
1185 | # get opnames whose numbers are lowest and highest | |
1186 | my ($first, @rest) = sort { | |
1187 | $op_is->{$a} <=> $op_is->{$b} | |
1188 | } keys %$op_is; | |
1189 | ||
1190 | my $last = pop @rest; # @rest slurped, get its last | |
cb7b5e07 | 1191 | die "Invalid range of ops: $first .. $last\n" unless $last; |
6ecf81d6 | 1192 | |
ce716c52 | 1193 | print $on "\n#define $macname(op) \\\n\t("; |
6ecf81d6 | 1194 | |
e71197e2 JC |
1195 | # verify that op-ct matches 1st..last range (and fencepost) |
1196 | # (we know there are no dups) | |
1197 | if ( $op_is->{$last} - $op_is->{$first} == scalar @rest + 1) { | |
1198 | ||
1199 | # contiguous ops -> optimized version | |
2b420b63 JC |
1200 | print $on "(op) >= OP_" . uc($first) |
1201 | . " && (op) <= OP_" . uc($last); | |
e71197e2 JC |
1202 | } |
1203 | else { | |
424a4936 | 1204 | print $on join(" || \\\n\t ", |
2b420b63 | 1205 | map { "(op) == OP_" . uc() } sort keys %$op_is); |
e71197e2 | 1206 | } |
2b420b63 | 1207 | print $on ")\n"; |
e71197e2 | 1208 | } |
a85d93d9 JH |
1209 | } |
1210 | ||
cc49830d NC |
1211 | my $pp = open_new('pp_proto.h', '>', |
1212 | { by => 'opcode.pl', from => 'its data' }); | |
a27f85b3 | 1213 | |
981b7185 NC |
1214 | { |
1215 | my %funcs; | |
1216 | for (@ops) { | |
7627e6d0 | 1217 | my $name = $alias{$_} ? $alias{$_}[0] : "Perl_pp_$_"; |
981b7185 NC |
1218 | ++$funcs{$name}; |
1219 | } | |
1220 | print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs; | |
735e0d5c | 1221 | } |
f3574cc6 DM |
1222 | |
1223 | print $oc "\n\n"; | |
1224 | OP_PRIVATE::print_defines($oc); | |
1225 | OP_PRIVATE::print_PL_op_private_tables($oc); | |
1226 | ||
1227 | OP_PRIVATE::print_B_Op_private($oprivpm); | |
1228 | ||
1229 | foreach ($oc, $on, $pp, $oprivpm) { | |
ce716c52 NC |
1230 | read_only_bottom_close_and_rename($_); |
1231 | } | |
b162f9ea | 1232 |