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 | |
af001346 | 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 | |
f8a58b02 NC |
48 | open OPS, 'regen/opcodes' or die $!; |
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] |
4c5bab50 | 58 | if $seen{$desc} and $key !~ "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 | ||
1d5774de NC |
74 | # Set up aliases |
75 | ||
76 | my %alias; | |
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'}, | |
17058fe0 | 133 | Perl_pp_preinc => ['i_preinc', 'predec', 'i_predec'], |
c22c99bc | 134 | Perl_pp_postinc => ['i_postinc', 'postdec', 'i_postdec'], |
720d5dbf NC |
135 | Perl_pp_ehostent => [qw(enetent eprotoent eservent |
136 | spwent epwent sgrent egrent)], | |
396166e1 | 137 | Perl_pp_shostent => [qw(snetent sprotoent sservent)], |
93bad3fd | 138 | Perl_pp_aelemfast => ['aelemfast_lex'], |
21b66d1c | 139 | Perl_pp_grepstart => ['mapstart'], |
605b9385 | 140 | ); |
1d5774de NC |
141 | |
142 | while (my ($func, $names) = splice @raw_alias, 0, 2) { | |
7627e6d0 NC |
143 | if (ref $names eq 'ARRAY') { |
144 | foreach (@$names) { | |
145 | $alias{$_} = [$func, '']; | |
146 | } | |
147 | } else { | |
148 | while (my ($opname, $cond) = each %$names) { | |
149 | $alias{$opname} = [$func, $cond]; | |
150 | } | |
916e4025 | 151 | } |
1d5774de NC |
152 | } |
153 | ||
7627e6d0 NC |
154 | foreach my $sock_func (qw(socket bind listen accept shutdown |
155 | ssockopt getpeername)) { | |
156 | $alias{$sock_func} = ["Perl_pp_$sock_func", '#ifdef HAS_SOCKET'], | |
157 | } | |
158 | ||
f3574cc6 DM |
159 | |
160 | ||
161 | # ================================================================= | |
162 | # | |
163 | # Functions for processing regen/op_private data. | |
164 | # | |
165 | # Put them in a separate package so that croak() does the right thing | |
166 | ||
167 | package OP_PRIVATE; | |
168 | ||
169 | use Carp; | |
170 | ||
171 | ||
172 | # the vars holding the global state built up by all the calls to addbits() | |
173 | ||
174 | ||
175 | # map OPpLVAL_INTRO => LVINTRO | |
176 | my %LABELS; | |
177 | ||
178 | ||
179 | # the numeric values of flags - what will get output as a #define | |
180 | my %DEFINES; | |
181 | ||
182 | # %BITFIELDS: the various bit field types. The key is the concatenation of | |
183 | # all the field values that make up a bit field hash; the values are bit | |
184 | # field hash refs. This allows us to de-dup identical bit field defs | |
185 | # across different ops, and thus make the output tables more compact (esp | |
186 | # important for the C version) | |
187 | my %BITFIELDS; | |
188 | ||
189 | # %FLAGS: the main data structure. Indexed by op name, then bit index: | |
190 | # single bit flag: | |
191 | # $FLAGS{rv2av}{2} = 'OPpSLICEWARNING'; | |
192 | # bit field (bits 5 and 6): | |
193 | # $FLAGS{rv2av}{5} = $FLAGS{rv2av}{6} = { .... }; | |
194 | my %FLAGS; | |
195 | ||
196 | ||
197 | # do, with checking, $LABELS{$name} = $label | |
198 | ||
199 | sub add_label { | |
200 | my ($name, $label) = @_; | |
201 | if (exists $LABELS{$name} and $LABELS{$name} ne $label) { | |
202 | croak "addbits(): label for flag '$name' redefined:\n" | |
203 | . " was '$LABELS{$name}', now '$label'"; | |
204 | } | |
205 | $LABELS{$name} = $label; | |
206 | } | |
207 | ||
208 | # | |
209 | # do, with checking, $DEFINES{$name} = $val | |
210 | ||
211 | sub add_define { | |
212 | my ($name, $val) = @_; | |
213 | if (exists $DEFINES{$name} && $DEFINES{$name} != $val) { | |
214 | croak "addbits(): value for flag '$name' redefined:\n" | |
215 | . " was $DEFINES{$name}, now $val"; | |
216 | } | |
217 | $DEFINES{$name} = $val; | |
218 | } | |
219 | ||
220 | ||
221 | # intended to be called from regen/op_private; see that file for details | |
222 | ||
223 | sub ::addbits { | |
224 | my @args = @_; | |
225 | ||
226 | croak "too few arguments for addbits()" unless @args >= 3; | |
227 | my $op = shift @args; | |
228 | croak "invalid op name: '$op'" unless exists $opnum{$op}; | |
229 | ||
230 | while (@args) { | |
231 | my $bits = shift @args; | |
232 | if ($bits =~ /^[0-7]$/) { | |
233 | # single bit | |
234 | croak "addbits(): too few arguments for single bit flag" | |
235 | unless @args >= 2; | |
236 | my $flag_name = shift @args; | |
237 | my $flag_label = shift @args; | |
238 | add_label($flag_name, $flag_label); | |
239 | croak "addbits(): bit $bits of $op already specified" | |
240 | if defined $FLAGS{$op}{$bits}; | |
241 | $FLAGS{$op}{$bits} = $flag_name; | |
242 | add_define($flag_name, (1 << $bits)); | |
243 | } | |
244 | elsif ($bits =~ /^([0-7])\.\.([0-7])$/) { | |
245 | # bit range | |
246 | my ($bitmin, $bitmax) = ($1,$2); | |
247 | ||
248 | croak "addbits(): min bit > max bit in bit range '$bits'" | |
249 | unless $bitmin <= $bitmax; | |
250 | croak "addbits(): bit field argument missing" | |
251 | unless @args >= 1; | |
252 | ||
253 | my $arg_hash = shift @args; | |
254 | croak "addbits(): arg to $bits must be a hash ref" | |
255 | unless defined $arg_hash and ref($arg_hash) =~ /HASH/; | |
256 | ||
257 | my %valid_keys; | |
258 | @valid_keys{qw(baseshift_def bitcount_def mask_def label enum)} = (); | |
259 | for (keys %$arg_hash) { | |
260 | croak "addbits(): unrecognised bifield key: '$_'" | |
261 | unless exists $valid_keys{$_}; | |
262 | } | |
263 | ||
264 | my $bitmask = 0; | |
265 | $bitmask += (1 << $_) for $bitmin..$bitmax; | |
266 | ||
267 | my $enum_id =''; | |
268 | ||
269 | if (defined $arg_hash->{enum}) { | |
270 | my $enum = $arg_hash->{enum}; | |
271 | croak "addbits(): arg to enum must be an array ref" | |
272 | unless defined $enum and ref($enum) =~ /ARRAY/; | |
273 | croak "addbits(): enum list must be in triplets" | |
274 | unless @$enum % 3 == 0; | |
275 | ||
276 | my $max_id = (1 << ($bitmax - $bitmin + 1)) - 1; | |
277 | ||
278 | my @e = @$enum; | |
279 | while (@e) { | |
280 | my $enum_ix = shift @e; | |
281 | my $enum_name = shift @e; | |
282 | my $enum_label = shift @e; | |
283 | croak "addbits(): enum index must be a number: '$enum_ix'" | |
284 | unless $enum_ix =~ /^\d+$/; | |
285 | croak "addbits(): enum index too big: '$enum_ix'" | |
286 | unless $enum_ix <= $max_id; | |
287 | add_label($enum_name, $enum_label); | |
288 | add_define($enum_name, $enum_ix << $bitmin); | |
289 | $enum_id .= "($enum_ix:$enum_name:$enum_label)"; | |
290 | } | |
291 | } | |
292 | ||
293 | # id is a fingerprint of all the content of the bit field hash | |
294 | my $id = join ':', map defined() ? $_ : "-undef-", | |
295 | $bitmin, $bitmax, | |
296 | $arg_hash->{label}, | |
297 | $arg_hash->{mask_def}, | |
298 | $arg_hash->{baseshift_def}, | |
299 | $arg_hash->{bitcount_def}, | |
300 | $enum_id; | |
301 | ||
302 | unless (defined $BITFIELDS{$id}) { | |
303 | ||
304 | if (defined $arg_hash->{mask_def}) { | |
305 | add_define($arg_hash->{mask_def}, $bitmask); | |
306 | } | |
307 | ||
308 | if (defined $arg_hash->{baseshift_def}) { | |
309 | add_define($arg_hash->{baseshift_def}, $bitmin); | |
310 | } | |
311 | ||
312 | if (defined $arg_hash->{bitcount_def}) { | |
313 | add_define($arg_hash->{bitcount_def}, $bitmax-$bitmin+1); | |
314 | } | |
315 | ||
316 | # create deep copy | |
317 | ||
318 | my $copy = {}; | |
319 | for (qw(baseshift_def bitcount_def mask_def label)) { | |
320 | $copy->{$_} = $arg_hash->{$_} if defined $arg_hash->{$_}; | |
321 | } | |
322 | if (defined $arg_hash->{enum}) { | |
323 | $copy->{enum} = [ @{$arg_hash->{enum}} ]; | |
324 | } | |
325 | ||
326 | # and add some extra fields | |
327 | ||
328 | $copy->{bitmask} = $bitmask; | |
329 | $copy->{bitmin} = $bitmin; | |
330 | $copy->{bitmax} = $bitmax; | |
331 | ||
332 | $BITFIELDS{$id} = $copy; | |
333 | } | |
334 | ||
335 | for my $bit ($bitmin..$bitmax) { | |
336 | croak "addbits(): bit $bit of $op already specified" | |
337 | if defined $FLAGS{$op}{$bit}; | |
338 | $FLAGS{$op}{$bit} = $BITFIELDS{$id}; | |
339 | } | |
340 | } | |
341 | else { | |
342 | croak "addbits(): invalid bit specifier '$bits'"; | |
343 | } | |
344 | } | |
345 | } | |
346 | ||
347 | ||
348 | # intended to be called from regen/op_private; see that file for details | |
349 | ||
350 | sub ::ops_with_flag { | |
351 | my $flag = shift; | |
352 | return grep $flags{$_} =~ /\Q$flag/, sort keys %flags; | |
353 | } | |
354 | ||
355 | ||
356 | # intended to be called from regen/op_private; see that file for details | |
357 | ||
358 | sub ::ops_with_check { | |
359 | my $c = shift; | |
360 | return grep $check{$_} eq $c, sort keys %check; | |
361 | } | |
362 | ||
363 | ||
364 | # intended to be called from regen/op_private; see that file for details | |
365 | ||
366 | sub ::ops_with_arg { | |
367 | my ($i, $arg_type) = @_; | |
368 | my @ops; | |
369 | for my $op (sort keys %args) { | |
370 | my @args = split(' ',$args{$op}); | |
371 | push @ops, $op if defined $args[$i] and $args[$i] eq $arg_type; | |
372 | } | |
373 | @ops; | |
374 | } | |
375 | ||
376 | ||
377 | # output '#define OPpLVAL_INTRO 0x80' etc | |
378 | ||
379 | sub print_defines { | |
380 | my $fh = shift; | |
381 | ||
382 | for (sort { $DEFINES{$a} <=> $DEFINES{$b} || $a cmp $b } keys %DEFINES) { | |
383 | printf $fh "#define %-23s 0x%02x\n", $_, $DEFINES{$_}; | |
384 | } | |
385 | } | |
386 | ||
387 | ||
388 | # Generate the content of B::Op_private | |
389 | ||
390 | sub print_B_Op_private { | |
391 | my $fh = shift; | |
392 | ||
393 | my $header = <<'EOF'; | |
394 | @=head1 NAME | |
395 | @ | |
396 | @B::Op_private - OP op_private flag definitions | |
397 | @ | |
398 | @=head1 SYNOPSIS | |
399 | @ | |
400 | @ use B::Op_private; | |
401 | @ | |
402 | @ # flag details for bit 7 of OP_AELEM's op_private: | |
403 | @ my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO | |
404 | @ my $value = $B::Op_private::defines{$name}; # 128 | |
405 | @ my $label = $B::Op_private::labels{$name}; # LVINTRO | |
406 | @ | |
407 | @ # the bit field at bits 5..6 of OP_AELEM's op_private: | |
408 | @ my $bf = $B::Op_private::bits{aelem}{6}; | |
409 | @ my $mask = $bf->{bitmask}; # etc | |
410 | @ | |
411 | @=head1 DESCRIPTION | |
412 | @ | |
dc1230de | 413 | @This module provides four global hashes: |
f3574cc6 DM |
414 | @ |
415 | @ %B::Op_private::bits | |
416 | @ %B::Op_private::defines | |
417 | @ %B::Op_private::labels | |
dc1230de | 418 | @ %B::Op_private::ops_using |
f3574cc6 DM |
419 | @ |
420 | @which contain information about the per-op meanings of the bits in the | |
421 | @op_private field. | |
422 | @ | |
423 | @=head2 C<%bits> | |
424 | @ | |
425 | @This is indexed by op name and then bit number (0..7). For single bit flags, | |
426 | @it returns the name of the define (if any) for that bit: | |
427 | @ | |
428 | @ $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO'; | |
429 | @ | |
430 | @For bit fields, it returns a hash ref containing details about the field. | |
431 | @The same reference will be returned for all bit positions that make | |
432 | @up the bit field; so for example these both return the same hash ref: | |
433 | @ | |
434 | @ $bitfield = $B::Op_private::bits{aelem}{5}; | |
435 | @ $bitfield = $B::Op_private::bits{aelem}{6}; | |
436 | @ | |
437 | @The general format of this hash ref is | |
438 | @ | |
439 | @ { | |
440 | @ # The bit range and mask; these are always present. | |
441 | @ bitmin => 5, | |
442 | @ bitmax => 6, | |
443 | @ bitmask => 0x60, | |
444 | @ | |
445 | @ # (The remaining keys are optional) | |
446 | @ | |
447 | @ # The names of any defines that were requested: | |
448 | @ mask_def => 'OPpFOO_MASK', | |
449 | @ baseshift_def => 'OPpFOO_SHIFT', | |
450 | @ bitcount_def => 'OPpFOO_BITS', | |
451 | @ | |
452 | @ # If present, Concise etc will display the value with a 'FOO=' | |
cdb679b6 FC |
453 | @ # prefix. If it equals '-', then Concise will treat the bit |
454 | @ # field as raw bits and not try to interpret it. | |
f3574cc6 DM |
455 | @ label => 'FOO', |
456 | @ | |
2febb45a FC |
457 | @ # If present, specifies the names of some defines and the |
458 | @ # display labels that are used to assign meaning to particu- | |
459 | @ # lar integer values within the bit field; e.g. 3 is dis- | |
460 | @ # played as 'C'. | |
f3574cc6 DM |
461 | @ enum => [ qw( |
462 | @ 1 OPpFOO_A A | |
463 | @ 2 OPpFOO_B B | |
464 | @ 3 OPpFOO_C C | |
465 | @ )], | |
466 | @ | |
467 | @ }; | |
468 | @ | |
469 | @ | |
470 | @=head2 C<%defines> | |
471 | @ | |
472 | @This gives the value of every C<OPp> define, e.g. | |
473 | @ | |
474 | @ $B::Op_private::defines{OPpLVAL_INTRO} == 128; | |
475 | @ | |
476 | @=head2 C<%labels> | |
477 | @ | |
478 | @This gives the short display label for each define, as used by C<B::Concise> | |
479 | @and C<perl -Dx>, e.g. | |
480 | @ | |
481 | @ $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO'; | |
482 | @ | |
483 | @If the label equals '-', then Concise will treat the bit as a raw bit and | |
484 | @not try to display it symbolically. | |
485 | @ | |
dc1230de FC |
486 | @=head2 C<%ops_using> |
487 | @ | |
488 | @For each define, this gives a reference to an array of op names that use | |
489 | @the flag. | |
490 | @ | |
491 | @ @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} }; | |
492 | @ | |
f3574cc6 DM |
493 | @=cut |
494 | ||
495 | package B::Op_private; | |
496 | ||
497 | our %bits; | |
498 | ||
499 | EOF | |
500 | # remove podcheck.t-defeating leading char | |
501 | $header =~ s/^\@//gm; | |
502 | print $fh $header; | |
99275276 DM |
503 | my $v = (::perl_version())[3]; |
504 | print $fh qq{\nour \$VERSION = "$v";\n\n}; | |
f3574cc6 | 505 | |
dc1230de FC |
506 | my %ops_using; |
507 | ||
f3574cc6 DM |
508 | # for each flag/bit combination, find the ops which use it |
509 | my %combos; | |
510 | for my $op (sort keys %FLAGS) { | |
511 | my $entry = $FLAGS{$op}; | |
512 | for my $bit (0..7) { | |
513 | my $e = $entry->{$bit}; | |
514 | next unless defined $e; | |
515 | next if ref $e; # bit field, not flag | |
516 | push @{$combos{$e}{$bit}}, $op; | |
dc1230de | 517 | push @{$ops_using{$e}}, $op; |
f3574cc6 DM |
518 | } |
519 | } | |
520 | ||
521 | # dump flags used by multiple ops | |
522 | for my $flag (sort keys %combos) { | |
523 | for my $bit (sort keys %{$combos{$flag}}) { | |
524 | my $ops = $combos{$flag}{$bit}; | |
525 | next unless @$ops > 1; | |
526 | my @o = sort @$ops; | |
527 | print $fh "\$bits{\$_}{$bit} = '$flag' for qw(@o);\n"; | |
528 | } | |
529 | } | |
530 | ||
531 | # dump bit field definitions | |
532 | ||
533 | my %bitfield_ix; | |
534 | { | |
535 | my %bitfields; | |
536 | # stringified-ref to ref mapping | |
537 | $bitfields{$_} = $_ for values %BITFIELDS; | |
538 | my $ix = -1; | |
539 | my $s = "\nmy \@bf = (\n"; | |
540 | for my $bitfield_key (sort keys %BITFIELDS) { | |
541 | my $bitfield = $BITFIELDS{$bitfield_key}; | |
542 | $ix++; | |
543 | $bitfield_ix{$bitfield} = $ix; | |
544 | ||
545 | $s .= " {\n"; | |
546 | for (qw(label mask_def baseshift_def bitcount_def)) { | |
547 | next unless defined $bitfield->{$_}; | |
548 | $s .= sprintf " %-9s => '%s',\n", | |
549 | $_, $bitfield->{$_}; | |
550 | } | |
551 | for (qw(bitmin bitmax bitmask)) { | |
552 | croak "panic" unless defined $bitfield->{$_}; | |
553 | $s .= sprintf " %-9s => %d,\n", | |
554 | $_, $bitfield->{$_}; | |
555 | } | |
556 | if (defined $bitfield->{enum}) { | |
557 | $s .= " enum => [\n"; | |
558 | my @enum = @{$bitfield->{enum}}; | |
559 | while (@enum) { | |
560 | my $i = shift @enum; | |
561 | my $name = shift @enum; | |
562 | my $label = shift @enum; | |
563 | $s .= sprintf " %d, %-10s, %s,\n", | |
564 | $i, "'$name'", "'$label'"; | |
565 | } | |
566 | $s .= " ],\n"; | |
567 | } | |
568 | $s .= " },\n"; | |
569 | ||
570 | } | |
571 | $s .= ");\n"; | |
572 | print $fh "$s\n"; | |
573 | } | |
574 | ||
575 | # dump bitfields and remaining labels | |
576 | ||
577 | for my $op (sort keys %FLAGS) { | |
578 | my @indices; | |
579 | my @vals; | |
580 | my $entry = $FLAGS{$op}; | |
581 | my $bit; | |
582 | ||
583 | for ($bit = 7; $bit >= 0; $bit--) { | |
584 | next unless defined $entry->{$bit}; | |
585 | my $e = $entry->{$bit}; | |
586 | if (ref $e) { | |
587 | my $ix = $bitfield_ix{$e}; | |
588 | for (reverse $e->{bitmin}..$e->{bitmax}) { | |
589 | push @indices, $_; | |
590 | push @vals, "\$bf[$ix]"; | |
591 | } | |
592 | $bit = $e->{bitmin}; | |
593 | } | |
594 | else { | |
595 | next if @{$combos{$e}{$bit}} > 1; # already output | |
596 | push @indices, $bit; | |
597 | push @vals, "'$e'"; | |
598 | } | |
599 | } | |
600 | if (@indices) { | |
601 | my $s = ''; | |
602 | $s = '@{' if @indices > 1; | |
603 | $s .= "\$bits{$op}"; | |
604 | $s .= '}' if @indices > 1; | |
605 | $s .= '{' . join(',', @indices) . '} = '; | |
606 | $s .= '(' if @indices > 1; | |
607 | $s .= join ', ', @vals; | |
608 | $s .= ')' if @indices > 1; | |
609 | print $fh "$s;\n"; | |
610 | } | |
611 | } | |
612 | ||
613 | # populate %defines and %labels | |
614 | ||
615 | print $fh "\n\nour %defines = (\n"; | |
616 | printf $fh " %-23s => %3d,\n", $_ , $DEFINES{$_} for sort keys %DEFINES; | |
617 | print $fh ");\n\nour %labels = (\n"; | |
618 | printf $fh " %-23s => '%s',\n", $_ , $LABELS{$_} for sort keys %LABELS; | |
619 | print $fh ");\n"; | |
620 | ||
dc1230de FC |
621 | # %ops_using |
622 | print $fh "\n\nour %ops_using = (\n"; | |
623 | # Save memory by using the same array wherever possible. | |
624 | my %flag_by_op_list; | |
625 | my $pending = ''; | |
626 | for my $flag (sort keys %ops_using) { | |
627 | my $op_list = $ops_using{$flag} = "@{$ops_using{$flag}}"; | |
628 | if (!exists $flag_by_op_list{$op_list}) { | |
629 | $flag_by_op_list{$op_list} = $flag; | |
630 | printf $fh " %-23s => %s,\n", $flag , "[qw($op_list)]" | |
631 | } | |
632 | else { | |
633 | $pending .= "\$ops_using{$flag} = " | |
634 | . "\$ops_using{$flag_by_op_list{$op_list}};\n"; | |
635 | } | |
636 | } | |
637 | print $fh ");\n\n$pending"; | |
638 | ||
f3574cc6 DM |
639 | } |
640 | ||
641 | ||
642 | ||
643 | # output the contents of the assorted PL_op_private_*[] tables | |
644 | ||
645 | sub print_PL_op_private_tables { | |
646 | my $fh = shift; | |
647 | ||
648 | my $PL_op_private_labels = ''; | |
649 | my $PL_op_private_valid = ''; | |
650 | my $PL_op_private_bitdef_ix = ''; | |
651 | my $PL_op_private_bitdefs = ''; | |
652 | my $PL_op_private_bitfields = ''; | |
653 | ||
654 | my %label_ix; | |
655 | my %bitfield_ix; | |
656 | ||
657 | # generate $PL_op_private_labels | |
658 | ||
659 | { | |
660 | my %labs; | |
661 | $labs{$_} = 1 for values %LABELS; # de-duplicate labels | |
662 | # add in bit field labels | |
663 | for (values %BITFIELDS) { | |
664 | next unless defined $_->{label}; | |
665 | $labs{$_->{label}} = 1; | |
666 | } | |
667 | ||
668 | my $labels = ''; | |
669 | for my $lab (sort keys %labs) { | |
670 | $label_ix{$lab} = length $labels; | |
671 | $labels .= "$lab\0"; | |
672 | $PL_op_private_labels .= | |
673 | " " | |
674 | . join(',', map("'$_'", split //, $lab)) | |
675 | . ",'\\0',\n"; | |
676 | } | |
677 | } | |
678 | ||
679 | ||
680 | # generate PL_op_private_bitfields | |
681 | ||
682 | { | |
683 | my %bitfields; | |
684 | # stringified-ref to ref mapping | |
685 | $bitfields{$_} = $_ for values %BITFIELDS; | |
686 | ||
687 | my $ix = 0; | |
688 | for my $bitfield_key (sort keys %BITFIELDS) { | |
689 | my $bf = $BITFIELDS{$bitfield_key}; | |
690 | $bitfield_ix{$bf} = $ix; | |
691 | ||
692 | my @b; | |
693 | push @b, $bf->{bitmin}, | |
694 | defined $bf->{label} ? $label_ix{$bf->{label}} : -1; | |
695 | my $enum = $bf->{enum}; | |
696 | if (defined $enum) { | |
697 | my @enum = @$enum; | |
698 | while (@enum) { | |
699 | my $i = shift @enum; | |
700 | my $name = shift @enum; | |
701 | my $label = shift @enum; | |
702 | push @b, $i, $label_ix{$label}; | |
703 | } | |
704 | } | |
705 | push @b, -1; # terminate enum list | |
706 | ||
707 | $PL_op_private_bitfields .= " " . join(', ', @b) .",\n"; | |
708 | $ix += @b; | |
709 | } | |
710 | } | |
711 | ||
712 | ||
713 | # generate PL_op_private_bitdefs, PL_op_private_bitdef_ix | |
714 | ||
715 | { | |
716 | my $bitdef_count = 0; | |
717 | ||
718 | my %not_seen = %FLAGS; | |
dd6eeb56 FC |
719 | my @seen_bitdefs; |
720 | my %seen_bitdefs; | |
f3574cc6 DM |
721 | |
722 | my $opnum = -1; | |
723 | for my $op (sort { $opnum{$a} <=> $opnum{$b} } keys %opnum) { | |
724 | $opnum++; | |
725 | die "panic: opnum misorder: opnum=$opnum opnum{op}=$opnum{$op}" | |
726 | unless $opnum == $opnum{$op}; | |
727 | delete $not_seen{$op}; | |
728 | ||
729 | my @bitdefs; | |
730 | my $entry = $FLAGS{$op}; | |
731 | my $bit; | |
732 | my $index; | |
733 | ||
734 | for ($bit = 7; $bit >= 0; $bit--) { | |
735 | my $e = $entry->{$bit}; | |
736 | next unless defined $e; | |
737 | ||
738 | my $ix; | |
739 | if (ref $e) { | |
740 | $ix = $bitfield_ix{$e}; | |
741 | die "panic: \$bit =\= $e->{bitmax}" | |
742 | unless $bit == $e->{bitmax}; | |
743 | ||
744 | push @bitdefs, ( ($ix << 5) | ($bit << 2) | 2 ); | |
745 | $bit = $e->{bitmin}; | |
746 | } | |
747 | else { | |
748 | $ix = $label_ix{$LABELS{$e}}; | |
749 | die "panic: no label ix for '$e'" unless defined $ix; | |
750 | push @bitdefs, ( ($ix << 5) | ($bit << 2)); | |
751 | } | |
752 | if ($ix > 2047) { | |
753 | die "Too many labels or bitfields (ix=$ix): " | |
754 | . "maybe the type of PL_op_private_bitdefs needs " | |
755 | . "expanding from U16 to U32???"; | |
756 | } | |
757 | } | |
758 | if (@bitdefs) { | |
759 | $bitdefs[-1] |= 1; # stop bit | |
dd6eeb56 FC |
760 | my $key = join(', ', map(sprintf("0x%04x", $_), @bitdefs)); |
761 | if (!$seen_bitdefs{$key}) { | |
762 | $index = $bitdef_count; | |
763 | $bitdef_count += @bitdefs; | |
764 | push @seen_bitdefs, | |
765 | $seen_bitdefs{$key} = [$index, $key]; | |
766 | } | |
767 | else { | |
768 | $index = $seen_bitdefs{$key}[0]; | |
769 | } | |
770 | push @{$seen_bitdefs{$key}}, $op; | |
f3574cc6 DM |
771 | } |
772 | else { | |
773 | $index = -1; | |
774 | } | |
775 | $PL_op_private_bitdef_ix .= sprintf " %4d, /* %s */\n", $index, $op; | |
776 | } | |
777 | if (%not_seen) { | |
778 | die "panic: unprocessed ops: ". join(',', keys %not_seen); | |
779 | } | |
dd6eeb56 FC |
780 | for (@seen_bitdefs) { |
781 | local $" = ", "; | |
782 | $PL_op_private_bitdefs .= " $$_[1], /* @$_[2..$#$_] */\n"; | |
783 | } | |
f3574cc6 DM |
784 | } |
785 | ||
786 | ||
787 | # generate PL_op_private_valid | |
788 | ||
789 | for my $op (@ops) { | |
790 | my $last; | |
791 | my @flags; | |
792 | for my $bit (0..7) { | |
793 | next unless exists $FLAGS{$op}; | |
794 | my $entry = $FLAGS{$op}{$bit}; | |
795 | next unless defined $entry; | |
796 | if (ref $entry) { | |
797 | # skip later entries for the same bit field | |
798 | next if defined $last and $last == $entry; | |
799 | $last = $entry; | |
800 | push @flags, | |
801 | defined $entry->{mask_def} | |
802 | ? $entry->{mask_def} | |
803 | : $entry->{bitmask}; | |
804 | } | |
805 | else { | |
806 | push @flags, $entry; | |
807 | } | |
808 | } | |
809 | ||
810 | # all bets are off | |
811 | @flags = '0xff' if $op eq 'null' or $op eq 'custom'; | |
812 | ||
813 | $PL_op_private_valid .= sprintf " /* %-10s */ (%s),\n", uc($op), | |
814 | @flags ? join('|', @flags): '0'; | |
815 | } | |
816 | ||
817 | print $fh <<EOF; | |
818 | START_EXTERN_C | |
819 | ||
820 | #ifndef PERL_GLOBAL_STRUCT_INIT | |
821 | ||
822 | # ifndef DOINIT | |
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 | ||
832 | # else | |
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 | ||
894 | # endif /* !DOINIT */ | |
895 | #endif /* !PERL_GLOBAL_STRUCT_INIT */ | |
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 | ||
916 | require 'regen/op_private'; | |
917 | ||
918 | #use Data::Dumper; | |
919 | #print Dumper \%LABELS, \%DEFINES, \%FLAGS, \%BITFIELDS; | |
920 | ||
921 | ||
79072805 LW |
922 | # Emit defines. |
923 | ||
cc49830d | 924 | print $oc "#ifndef PERL_GLOBAL_STRUCT_INIT\n\n"; |
9561d06f | 925 | |
7627e6d0 NC |
926 | { |
927 | my $last_cond = ''; | |
928 | my @unimplemented; | |
929 | ||
930 | sub unimplemented { | |
931 | if (@unimplemented) { | |
2d6469fe | 932 | print $oc "#else\n"; |
7627e6d0 | 933 | foreach (@unimplemented) { |
2d6469fe | 934 | print $oc "#define $_ Perl_unimplemented_op\n"; |
7627e6d0 | 935 | } |
2d6469fe | 936 | print $oc "#endif\n"; |
7627e6d0 NC |
937 | @unimplemented = (); |
938 | } | |
939 | ||
940 | } | |
941 | ||
942 | for (@ops) { | |
943 | my ($impl, $cond) = @{$alias{$_} || ["Perl_pp_$_", '']}; | |
944 | my $op_func = "Perl_pp_$_"; | |
945 | ||
946 | if ($cond ne $last_cond) { | |
947 | # A change in condition. (including to or from no condition) | |
948 | unimplemented(); | |
949 | $last_cond = $cond; | |
950 | if ($last_cond) { | |
2d6469fe | 951 | print $oc "$last_cond\n"; |
7627e6d0 NC |
952 | } |
953 | } | |
954 | push @unimplemented, $op_func if $last_cond; | |
2d6469fe | 955 | print $oc "#define $op_func $impl\n" if $impl ne $op_func; |
7627e6d0 NC |
956 | } |
957 | # If the last op was conditional, we need to close it out: | |
958 | unimplemented(); | |
9561d06f NC |
959 | } |
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'; |
a33a81d0 | 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'; |
a33a81d0 | 1008 | "freed op", |
79072805 LW |
1009 | }; |
1010 | #endif | |
1011 | ||
73c4f7a1 GS |
1012 | END_EXTERN_C |
1013 | ||
27da23d5 | 1014 | #endif /* !PERL_GLOBAL_STRUCT_INIT */ |
22c35a8c | 1015 | END |
79072805 | 1016 | |
79072805 LW |
1017 | # Emit ppcode switch array. |
1018 | ||
2d6469fe | 1019 | print $oc <<'END'; |
79072805 | 1020 | |
73c4f7a1 GS |
1021 | START_EXTERN_C |
1022 | ||
27da23d5 | 1023 | #ifdef PERL_GLOBAL_STRUCT_INIT |
97aff369 | 1024 | # define PERL_PPADDR_INITED |
27da23d5 | 1025 | static const Perl_ppaddr_t Gppaddr[] |
79072805 | 1026 | #else |
27da23d5 | 1027 | # ifndef PERL_GLOBAL_STRUCT |
97aff369 | 1028 | # define PERL_PPADDR_INITED |
27da23d5 JH |
1029 | EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ |
1030 | # endif | |
1031 | #endif /* PERL_GLOBAL_STRUCT */ | |
1032 | #if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT) | |
97aff369 | 1033 | # define PERL_PPADDR_INITED |
27da23d5 | 1034 | = { |
79072805 LW |
1035 | END |
1036 | ||
1037 | for (@ops) { | |
7627e6d0 NC |
1038 | my $op_func = "Perl_pp_$_"; |
1039 | my $name = $alias{$_}; | |
1040 | if ($name && $name->[0] ne $op_func) { | |
2d6469fe | 1041 | print $oc "\t$op_func,\t/* implemented by $name->[0] */\n"; |
6faeeb49 MB |
1042 | } |
1043 | else { | |
2d6469fe | 1044 | print $oc "\t$op_func,\n"; |
6faeeb49 | 1045 | } |
79072805 LW |
1046 | } |
1047 | ||
2d6469fe | 1048 | print $oc <<'END'; |
27da23d5 | 1049 | } |
79072805 | 1050 | #endif |
97aff369 | 1051 | #ifdef PERL_PPADDR_INITED |
27da23d5 | 1052 | ; |
97aff369 | 1053 | #endif |
79072805 | 1054 | |
27da23d5 | 1055 | #ifdef PERL_GLOBAL_STRUCT_INIT |
97aff369 | 1056 | # define PERL_CHECK_INITED |
27da23d5 | 1057 | static const Perl_check_t Gcheck[] |
79072805 | 1058 | #else |
27da23d5 | 1059 | # ifndef PERL_GLOBAL_STRUCT |
97aff369 | 1060 | # define PERL_CHECK_INITED |
27da23d5 JH |
1061 | EXT Perl_check_t PL_check[] /* or perlvars.h */ |
1062 | # endif | |
1063 | #endif | |
1064 | #if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT) | |
97aff369 | 1065 | # define PERL_CHECK_INITED |
27da23d5 | 1066 | = { |
79072805 LW |
1067 | END |
1068 | ||
1069 | for (@ops) { | |
2d6469fe | 1070 | print $oc "\t", tab(3, "Perl_$check{$_},"), "\t/* $_ */\n"; |
79072805 LW |
1071 | } |
1072 | ||
2d6469fe | 1073 | print $oc <<'END'; |
27da23d5 | 1074 | } |
79072805 | 1075 | #endif |
97aff369 | 1076 | #ifdef PERL_CHECK_INITED |
27da23d5 | 1077 | ; |
97aff369 | 1078 | #endif /* #ifdef PERL_CHECK_INITED */ |
79072805 | 1079 | |
27da23d5 JH |
1080 | #ifndef PERL_GLOBAL_STRUCT_INIT |
1081 | ||
79072805 | 1082 | #ifndef DOINIT |
1ccb7c8d | 1083 | EXTCONST U32 PL_opargs[]; |
79072805 | 1084 | #else |
1ccb7c8d | 1085 | EXTCONST U32 PL_opargs[] = { |
79072805 LW |
1086 | END |
1087 | ||
2d6469fe NC |
1088 | # Emit allowed argument types. |
1089 | ||
1090 | my $ARGBITS = 32; | |
1091 | ||
d6480c9d NC |
1092 | my %argnum = ( |
1093 | 'S', 1, # scalar | |
1094 | 'L', 2, # list | |
1095 | 'A', 3, # array value | |
1096 | 'H', 4, # hash value | |
1097 | 'C', 5, # code value | |
1098 | 'F', 6, # file value | |
1099 | 'R', 7, # scalar reference | |
79072805 LW |
1100 | ); |
1101 | ||
d6480c9d | 1102 | my %opclass = ( |
db173bac MB |
1103 | '0', 0, # baseop |
1104 | '1', 1, # unop | |
1105 | '2', 2, # binop | |
1106 | '|', 3, # logop | |
1a67a97c SM |
1107 | '@', 4, # listop |
1108 | '/', 5, # pmop | |
350de78d | 1109 | '$', 6, # svop_or_padop |
7934575e | 1110 | '#', 7, # padop |
1a67a97c SM |
1111 | '"', 8, # pvop_or_svop |
1112 | '{', 9, # loop | |
1113 | ';', 10, # cop | |
1114 | '%', 11, # baseop_or_unop | |
1115 | '-', 12, # filestatop | |
1116 | '}', 13, # loopexop | |
b46e009d | 1117 | '.', 14, # methop |
2f7c6295 | 1118 | '+', 15, # unop_aux |
db173bac MB |
1119 | ); |
1120 | ||
c2dedb93 MHM |
1121 | my %opflags = ( |
1122 | 'm' => 1, # needs stack mark | |
1123 | 'f' => 2, # fold constants | |
1124 | 's' => 4, # always produces scalar | |
1125 | 't' => 8, # needs target scalar | |
903fd87c NC |
1126 | 'T' => 8 | 16, # ... which may be lexical |
1127 | 'i' => 0, # always produces integer (unused since e7311069) | |
c2dedb93 | 1128 | 'I' => 32, # has corresponding int op |
e791f90a | 1129 | 'd' => 64, # danger, make temp copy in list assignment |
c2dedb93 MHM |
1130 | 'u' => 128, # defaults to $_ |
1131 | ); | |
1132 | ||
2b420b63 JC |
1133 | my %OP_IS_SOCKET; # /Fs/ |
1134 | my %OP_IS_FILETEST; # /F-/ | |
1135 | my %OP_IS_FT_ACCESS; # /F-+/ | |
1136 | my %OP_IS_NUMCOMPARE; # /S</ | |
332c2eac | 1137 | my %OP_IS_DIRHOP; # /Fd/ |
a9f19d0f | 1138 | my %OP_IS_INFIX_BIT; # /S\|/ |
332c2eac | 1139 | |
903fd87c NC |
1140 | my $OCSHIFT = 8; |
1141 | my $OASHIFT = 12; | |
a85d93d9 | 1142 | |
c2dedb93 | 1143 | for my $op (@ops) { |
d6480c9d | 1144 | my $argsum = 0; |
c2dedb93 MHM |
1145 | my $flags = $flags{$op}; |
1146 | for my $flag (keys %opflags) { | |
1147 | if ($flags =~ s/$flag//) { | |
cb7b5e07 | 1148 | die "Flag collision for '$op' ($flags{$op}, $flag)\n" |
c2dedb93 MHM |
1149 | if $argsum & $opflags{$flag}; |
1150 | $argsum |= $opflags{$flag}; | |
1151 | } | |
1152 | } | |
cb7b5e07 | 1153 | die qq[Opcode '$op' has no class indicator ($flags{$op} => $flags)\n] |
c2dedb93 MHM |
1154 | unless exists $opclass{$flags}; |
1155 | $argsum |= $opclass{$flags} << $OCSHIFT; | |
1156 | my $argshift = $OASHIFT; | |
1157 | for my $arg (split(' ',$args{$op})) { | |
332c2eac JC |
1158 | if ($arg =~ s/^D//) { |
1159 | # handle 1st, just to put D 1st. | |
1160 | $OP_IS_DIRHOP{$op} = $opnum{$op}; | |
1161 | } | |
a85d93d9 | 1162 | if ($arg =~ /^F/) { |
e71197e2 JC |
1163 | # record opnums of these opnames |
1164 | $OP_IS_SOCKET{$op} = $opnum{$op} if $arg =~ s/s//; | |
1165 | $OP_IS_FILETEST{$op} = $opnum{$op} if $arg =~ s/-//; | |
6ecf81d6 | 1166 | $OP_IS_FT_ACCESS{$op} = $opnum{$op} if $arg =~ s/\+//; |
a85d93d9 | 1167 | } |
a9f19d0f | 1168 | elsif ($arg =~ /^S./) { |
2b420b63 | 1169 | $OP_IS_NUMCOMPARE{$op} = $opnum{$op} if $arg =~ s/<//; |
a9f19d0f | 1170 | $OP_IS_INFIX_BIT {$op} = $opnum{$op} if $arg =~ s/\|//; |
2b420b63 | 1171 | } |
d6480c9d | 1172 | my $argnum = ($arg =~ s/\?//) ? 8 : 0; |
c2dedb93 MHM |
1173 | die "op = $op, arg = $arg\n" |
1174 | unless exists $argnum{$arg}; | |
79072805 | 1175 | $argnum += $argnum{$arg}; |
c2dedb93 MHM |
1176 | die "Argument overflow for '$op'\n" |
1177 | if $argshift >= $ARGBITS || | |
1178 | $argnum > ((1 << ($ARGBITS - $argshift)) - 1); | |
1179 | $argsum += $argnum << $argshift; | |
1180 | $argshift += 4; | |
79072805 LW |
1181 | } |
1182 | $argsum = sprintf("0x%08x", $argsum); | |
2d6469fe | 1183 | print $oc "\t", tab(3, "$argsum,"), "/* $op */\n"; |
79072805 LW |
1184 | } |
1185 | ||
2d6469fe | 1186 | print $oc <<'END'; |
79072805 LW |
1187 | }; |
1188 | #endif | |
73c4f7a1 | 1189 | |
bae1192d JH |
1190 | #endif /* !PERL_GLOBAL_STRUCT_INIT */ |
1191 | ||
73c4f7a1 | 1192 | END_EXTERN_C |
79072805 LW |
1193 | END |
1194 | ||
e71197e2 JC |
1195 | # Emit OP_IS_* macros |
1196 | ||
2d6469fe | 1197 | print $on <<'EO_OP_IS_COMMENT'; |
e71197e2 | 1198 | |
332c2eac JC |
1199 | /* the OP_IS_* macros are optimized to a simple range check because |
1200 | all the member OPs are contiguous in regen/opcodes table. | |
1201 | opcode.pl verifies the range contiguity, or generates an OR-equals | |
1202 | expression */ | |
e71197e2 JC |
1203 | EO_OP_IS_COMMENT |
1204 | ||
1205 | gen_op_is_macro( \%OP_IS_SOCKET, 'OP_IS_SOCKET'); | |
1206 | gen_op_is_macro( \%OP_IS_FILETEST, 'OP_IS_FILETEST'); | |
6ecf81d6 | 1207 | gen_op_is_macro( \%OP_IS_FT_ACCESS, 'OP_IS_FILETEST_ACCESS'); |
2b420b63 | 1208 | gen_op_is_macro( \%OP_IS_NUMCOMPARE, 'OP_IS_NUMCOMPARE'); |
332c2eac | 1209 | gen_op_is_macro( \%OP_IS_DIRHOP, 'OP_IS_DIRHOP'); |
a9f19d0f | 1210 | gen_op_is_macro( \%OP_IS_INFIX_BIT, 'OP_IS_INFIX_BIT'); |
e71197e2 JC |
1211 | |
1212 | sub gen_op_is_macro { | |
1213 | my ($op_is, $macname) = @_; | |
1214 | if (keys %$op_is) { | |
1215 | ||
1216 | # get opnames whose numbers are lowest and highest | |
1217 | my ($first, @rest) = sort { | |
1218 | $op_is->{$a} <=> $op_is->{$b} | |
1219 | } keys %$op_is; | |
1220 | ||
1221 | my $last = pop @rest; # @rest slurped, get its last | |
cb7b5e07 | 1222 | die "Invalid range of ops: $first .. $last\n" unless $last; |
6ecf81d6 | 1223 | |
ce716c52 | 1224 | print $on "\n#define $macname(op) \\\n\t("; |
6ecf81d6 | 1225 | |
e71197e2 JC |
1226 | # verify that op-ct matches 1st..last range (and fencepost) |
1227 | # (we know there are no dups) | |
1228 | if ( $op_is->{$last} - $op_is->{$first} == scalar @rest + 1) { | |
1229 | ||
1230 | # contiguous ops -> optimized version | |
2b420b63 JC |
1231 | print $on "(op) >= OP_" . uc($first) |
1232 | . " && (op) <= OP_" . uc($last); | |
e71197e2 JC |
1233 | } |
1234 | else { | |
424a4936 | 1235 | print $on join(" || \\\n\t ", |
2b420b63 | 1236 | map { "(op) == OP_" . uc() } sort keys %$op_is); |
e71197e2 | 1237 | } |
2b420b63 | 1238 | print $on ")\n"; |
e71197e2 | 1239 | } |
a85d93d9 JH |
1240 | } |
1241 | ||
cc49830d NC |
1242 | my $pp = open_new('pp_proto.h', '>', |
1243 | { by => 'opcode.pl', from => 'its data' }); | |
a27f85b3 | 1244 | |
981b7185 NC |
1245 | { |
1246 | my %funcs; | |
1247 | for (@ops) { | |
7627e6d0 | 1248 | my $name = $alias{$_} ? $alias{$_}[0] : "Perl_pp_$_"; |
981b7185 NC |
1249 | ++$funcs{$name}; |
1250 | } | |
1251 | print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs; | |
735e0d5c | 1252 | } |
f3574cc6 DM |
1253 | |
1254 | print $oc "\n\n"; | |
1255 | OP_PRIVATE::print_defines($oc); | |
1256 | OP_PRIVATE::print_PL_op_private_tables($oc); | |
1257 | ||
1258 | OP_PRIVATE::print_B_Op_private($oprivpm); | |
1259 | ||
1260 | foreach ($oc, $on, $pp, $oprivpm) { | |
ce716c52 NC |
1261 | read_only_bottom_close_and_rename($_); |
1262 | } | |
b162f9ea | 1263 |