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