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