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