Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

opcode.pl@ 3439

Visit:

Last change on this file since 3439 was 3181, checked in by bird, 19 years ago
perl 5.8.8
File size: 24.8 KB

Line
1	#!/usr/bin/perl
2	BEGIN {
3	# Get function prototypes
4	require 'regen_lib.pl';
5	}
6
7	$opcode_new = 'opcode.h-new';
8	$opname_new = 'opnames.h-new';
9	open(OC, ">$opcode_new") \|\| die "Can't create $opcode_new: $!\n";
10	binmode OC;
11	open(ON, ">$opname_new") \|\| die "Can't create $opname_new: $!\n";
12	binmode ON;
13	select OC;
14
15	# Read data.
16
17	while (<DATA>) {
18	chop;
19	next unless $_;
20	next if /^#/;
21	($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5);
22
23	warn qq[Description "$desc" duplicates $seen{$desc}\n] if $seen{$desc};
24	die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key};
25	$seen{$desc} = qq[description of opcode "$key"];
26	$seen{$key} = qq[opcode "$key"];
27
28	push(@ops, $key);
29	$desc{$key} = $desc;
30	$check{$key} = $check;
31	$ckname{$check}++;
32	$flags{$key} = $flags;
33	$args{$key} = $args;
34	}
35
36	# Emit defines.
37
38	$i = 0;
39	print <<"END";
40	/* -- buffer-read-only: t --
41	*
42	* opcode.h
43	*
44	* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
45	* 2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others
46	*
47	* You may distribute under the terms of either the GNU General Public
48	* License or the Artistic License, as specified in the README file.
49	*
50	* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
51	* This file is built by opcode.pl from its data. Any changes made here
52	* will be lost!
53	*/
54
55	#define Perl_pp_i_preinc Perl_pp_preinc
56	#define Perl_pp_i_predec Perl_pp_predec
57	#define Perl_pp_i_postinc Perl_pp_postinc
58	#define Perl_pp_i_postdec Perl_pp_postdec
59
60	END
61
62	print ON <<"END";
63	/* -- buffer-read-only: t --
64	*
65	* opnames.h
66	*
67	* Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
68	* by Larry Wall and others
69	*
70	* You may distribute under the terms of either the GNU General Public
71	* License or the Artistic License, as specified in the README file.
72	*
73	*
74	* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
75	* This file is built by opcode.pl from its data. Any changes made here
76	* will be lost!
77	*/
78
79	typedef enum opcode {
80	END
81
82	for (@ops) {
83	print ON "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n";
84	}
85	print ON "\t", &tab(3,"OP_max"), "\n";
86	print ON "} opcode;\n";
87	print ON "\n#define MAXO ", scalar @ops, "\n";
88	print ON "#define OP_phoney_INPUT_ONLY -1\n";
89	print ON "#define OP_phoney_OUTPUT_ONLY -2\n\n";
90
91	# Emit op names and descriptions.
92
93	print <<END;
94
95	START_EXTERN_C
96
97
98	#define OP_NAME(o) ((o)->op_type == OP_CUSTOM ? custom_op_name(o) : \\
99	PL_op_name[(o)->op_type])
100	#define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \\
101	PL_op_desc[(o)->op_type])
102
103	#ifndef DOINIT
104	EXT char *PL_op_name[];
105	#else
106	EXT char *PL_op_name[] = {
107	END
108
109	for (@ops) {
110	print qq(\t"$_",\n);
111	}
112
113	print <<END;
114	};
115	#endif
116
117	END
118
119	print <<END;
120	#ifndef DOINIT
121	EXT char *PL_op_desc[];
122	#else
123	EXT char *PL_op_desc[] = {
124	END
125
126	for (@ops) {
127	my($safe_desc) = $desc{$_};
128
129	# Have to escape double quotes and escape characters.
130	$safe_desc =~ s/(^\|[^\\])([\\"])/$1\\$2/g;
131
132	print qq(\t"$safe_desc",\n);
133	}
134
135	print <<END;
136	};
137	#endif
138
139	END_EXTERN_C
140
141	END
142
143	# Emit function declarations.
144
145	#for (sort keys %ckname) {
146	# print "OP \t", &tab(3,$_),"(pTHX_ OP o);\n";
147	#}
148	#
149	#print "\n";
150	#
151	#for (@ops) {
152	# print "OP *\t", &tab(3, "pp_$_"), "(pTHX);\n";
153	#}
154
155	# Emit ppcode switch array.
156
157	print <<END;
158
159	START_EXTERN_C
160
161	#ifndef DOINIT
162	EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX);
163	#else
164	EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = {
165	END
166
167	for (@ops) {
168	print "\tMEMBER_TO_FPTR(Perl_pp_$_),\n" unless $_ eq "custom";
169	}
170
171	print <<END;
172	};
173	#endif
174
175	END
176
177	# Emit check routines.
178
179	print <<END;
180	#ifndef DOINIT
181	EXT OP * (CPERLscope(PL_check)[]) (pTHX_ OP op);
182	#else
183	EXT OP * (CPERLscope(PL_check)[]) (pTHX_ OP op) = {
184	END
185
186	for (@ops) {
187	print "\t", &tab(3, "MEMBER_TO_FPTR(Perl_$check{$_}),"), "\t/* $_ */\n";
188	}
189
190	print <<END;
191	};
192	#endif
193
194	END
195
196	# Emit allowed argument types.
197
198	print <<END;
199	#ifndef DOINIT
200	EXT U32 PL_opargs[];
201	#else
202	EXT U32 PL_opargs[] = {
203	END
204
205	%argnum = (
206	S, 1, # scalar
207	L, 2, # list
208	A, 3, # array value
209	H, 4, # hash value
210	C, 5, # code value
211	F, 6, # file value
212	R, 7, # scalar reference
213	);
214
215	%opclass = (
216	'0', 0, # baseop
217	'1', 1, # unop
218	'2', 2, # binop
219	'\|', 3, # logop
220	'@', 4, # listop
221	'/', 5, # pmop
222	'$', 6, # svop_or_padop
223	'#', 7, # padop
224	'"', 8, # pvop_or_svop
225	'{', 9, # loop
226	';', 10, # cop
227	'%', 11, # baseop_or_unop
228	'-', 12, # filestatop
229	'}', 13, # loopexop
230	);
231
232	my %OP_IS_SOCKET;
233	my %OP_IS_FILETEST;
234
235	for (@ops) {
236	$argsum = 0;
237	$flags = $flags{$_};
238	$argsum \|= 1 if $flags =~ /m/; # needs stack mark
239	$argsum \|= 2 if $flags =~ /f/; # fold constants
240	$argsum \|= 4 if $flags =~ /s/; # always produces scalar
241	$argsum \|= 8 if $flags =~ /t/; # needs target scalar
242	$argsum \|= (8\|256) if $flags =~ /T/; # ... which may be lexical
243	$argsum \|= 16 if $flags =~ /i/; # always produces integer
244	$argsum \|= 32 if $flags =~ /I/; # has corresponding int op
245	$argsum \|= 64 if $flags =~ /d/; # danger, unknown side effects
246	$argsum \|= 128 if $flags =~ /u/; # defaults to $_
247	$flags =~ /([\W\d_])/ or die qq[Opcode "$_" has no class indicator];
248	$argsum \|= $opclass{$1} << 9;
249	$mul = 0x2000; # 2 ^ OASHIFT
250	for $arg (split(' ',$args{$_})) {
251	if ($arg =~ /^F/) {
252	$OP_IS_SOCKET{$_} = 1 if $arg =~ s/s//;
253	$OP_IS_FILETEST{$_} = 1 if $arg =~ s/-//;
254	}
255	$argnum = ($arg =~ s/\?//) ? 8 : 0;
256	die "op = $_, arg = $arg\n" unless length($arg) == 1;
257	$argnum += $argnum{$arg};
258	warn "# Conflicting bit 32 for '$_'.\n"
259	if $argnum & 8 and $mul == 0x10000000;
260	$argsum += $argnum * $mul;
261	$mul <<= 4;
262	}
263	$argsum = sprintf("0x%08x", $argsum);
264	print "\t", &tab(3, "$argsum,"), "/* $_ */\n";
265	}
266
267	print <<END;
268	};
269	#endif
270
271	END_EXTERN_C
272	END
273
274	if (keys %OP_IS_SOCKET) {
275	print ON "\n#define OP_IS_SOCKET(op) \\\n\t(";
276	print ON join(" \|\| \\\n\t ",
277	map { "(op) == OP_" . uc() } sort keys %OP_IS_SOCKET);
278	print ON ")\n\n";
279	}
280
281	if (keys %OP_IS_FILETEST) {
282	print ON "\n#define OP_IS_FILETEST(op) \\\n\t(";
283	print ON join(" \|\| \\\n\t ",
284	map { "(op) == OP_" . uc() } sort keys %OP_IS_FILETEST);
285	print ON ")\n\n";
286	}
287
288	print OC "/* ex: set ro: */\n";
289	print ON "/* ex: set ro: */\n";
290
291	close OC or die "Error closing opcode.h: $!";
292	close ON or die "Error closing opnames.h: $!";
293
294	foreach ('opcode.h', 'opnames.h') {
295	safer_rename_silent $_, "$_-old";
296	}
297	safer_rename $opcode_new, 'opcode.h';
298	safer_rename $opname_new, 'opnames.h';
299
300	$pp_proto_new = 'pp_proto.h-new';
301	$pp_sym_new = 'pp.sym-new';
302
303	open PP, ">$pp_proto_new" or die "Error creating $pp_proto_new: $!";
304	binmode PP;
305	open PPSYM, ">$pp_sym_new" or die "Error creating $pp_sym_new: $!";
306	binmode PPSYM;
307
308	print PP <<"END";
309	/* -- buffer-read-only: t --
310	!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
311	This file is built by opcode.pl from its data. Any changes made here
312	will be lost!
313	*/
314
315	END
316
317	print PPSYM <<"END";
318	# -- buffer-read-only: t --
319	#
320	# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
321	# This file is built by opcode.pl from its data. Any changes made here
322	# will be lost!
323	#
324
325	END
326
327
328	for (sort keys %ckname) {
329	print PP "PERL_CKDEF(Perl_$_)\n";
330	print PPSYM "Perl_$_\n";
331	#OP \t", &tab(3,$_),"(OP o);\n";
332	}
333
334	print PP "\n\n";
335
336	for (@ops) {
337	next if /^i_(pre\|post)(inc\|dec)$/;
338	next if /^custom$/;
339	print PP "PERL_PPDEF(Perl_pp_$_)\n";
340	print PPSYM "Perl_pp_$_\n";
341	}
342	print PP "\n/* ex: set ro: */\n";
343	print PPSYM "\n# ex: set ro:\n";
344
345	close PP or die "Error closing pp_proto.h: $!";
346	close PPSYM or die "Error closing pp.sym: $!";
347
348	foreach ('pp_proto.h', 'pp.sym') {
349	safer_rename_silent $_, "$_-old";
350	}
351	safer_rename $pp_proto_new, 'pp_proto.h';
352	safer_rename $pp_sym_new, 'pp.sym';
353
354	END {
355	foreach ('opcode.h', 'opnames.h', 'pp_proto.h', 'pp.sym') {
356	1 while unlink "$_-old";
357	}
358	}
359
360	###########################################################################
361	sub tab {
362	local($l, $t) = @_;
363	$t .= "\t" x ($l - (length($t) + 1) / 8);
364	$t;
365	}
366	###########################################################################
367
368	# Some comments about 'T' opcode classifier:
369
370	# Safe to set if the ppcode uses:
371	# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG,
372	# SETs(TARG), XPUSHn, XPUSHu,
373
374	# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES\|NO\|UNDEF]
375
376	# lt and friends do SETs (including ncmp, but not scmp)
377
378	# Additional mode of failure: the opcode can modify TARG before it "used"
379	# all the arguments (or may call an external function which does the same).
380	# If the target coincides with one of the arguments ==> kaboom.
381
382	# pp.c pos substr each not OK (RETPUSHUNDEF)
383	# substr vec also not OK due to LV to target (are they???)
384	# ref not OK (RETPUSHNO)
385	# trans not OK (dTARG; TARG = sv_newmortal();)
386	# ucfirst etc not OK: TMP arg processed inplace
387	# quotemeta not OK (unsafe when TARG == arg)
388	# each repeat not OK too due to list context
389	# pack split - unknown whether they are safe
390	# sprintf: is calling do_sprintf(TARG,...) which can act on TARG
391	# before other args are processed.
392
393	# Suspicious wrt "additional mode of failure" (and only it):
394	# schop, chop, postinc/dec, bit_and etc, negate, complement.
395
396	# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack.
397
398	# substr/vec: doing TAINT_off()???
399
400	# pp_hot.c
401	# readline - unknown whether it is safe
402	# match subst not OK (dTARG)
403	# grepwhile not OK (not always setting)
404	# join not OK (unsafe when TARG == arg)
405
406	# Suspicious wrt "additional mode of failure": concat (dealt with
407	# in ck_sassign()), join (same).
408
409	# pp_ctl.c
410	# mapwhile flip caller not OK (not always setting)
411
412	# pp_sys.c
413	# backtick glob warn die not OK (not always setting)
414	# warn not OK (RETPUSHYES)
415	# open fileno getc sysread syswrite ioctl accept shutdown
416	# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF)
417	# umask select not OK (XPUSHs(&PL_sv_undef);)
418	# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC"))
419	# sselect shm* sem* msg* syscall - unknown whether they are safe
420	# gmtime not OK (list context)
421
422	# Suspicious wrt "additional mode of failure": warn, die, select.
423
424	__END__
425
426	# New ops always go at the end, just before 'custom'
427
428	# A recapitulation of the format of this file:
429	# The file consists of five columns: the name of the op, an English
430	# description, the name of the "check" routine used to optimize this
431	# operation, some flags, and a description of the operands.
432
433	# The flags consist of options followed by a mandatory op class signifier
434
435	# The classes are:
436	# baseop - 0 unop - 1 binop - 2
437	# logop - \| listop - @ pmop - /
438	# padop/svop - $ padop - # (unused) loop - {
439	# baseop/unop - % loopexop - } filestatop - -
440	# pvop/svop - " cop - ;
441
442	# Other options are:
443	# needs stack mark - m
444	# needs constant folding - f
445	# produces a scalar - s
446	# produces an integer - i
447	# needs a target - t
448	# target can be in a pad - T
449	# has a corresponding integer version - I
450	# has side effects - d
451	# uses $_ if no argument given - u
452
453	# Values for the operands are:
454	# scalar - S list - L array - A
455	# hash - H sub (CV) - C file - F
456	# socket - Fs filetest - F- reference - R
457	# "?" denotes an optional operand.
458
459	# Nothing.
460
461	null null operation ck_null 0
462	stub stub ck_null 0
463	scalar scalar ck_fun s% S
464
465	# Pushy stuff.
466
467	pushmark pushmark ck_null s0
468	wantarray wantarray ck_null is0
469
470	const constant item ck_svconst s$
471
472	gvsv scalar variable ck_null ds$
473	gv glob value ck_null ds$
474	gelem glob elem ck_null d2 S S
475	padsv private variable ck_null ds0
476	padav private array ck_null d0
477	padhv private hash ck_null d0
478	padany private value ck_null d0
479
480	pushre push regexp ck_null d/
481
482	# References and stuff.
483
484	rv2gv ref-to-glob cast ck_rvconst ds1
485	rv2sv scalar dereference ck_rvconst ds1
486	av2arylen array length ck_null is1
487	rv2cv subroutine dereference ck_rvconst d1
488	anoncode anonymous subroutine ck_anoncode $
489	prototype subroutine prototype ck_null s% S
490	refgen reference constructor ck_spair m1 L
491	srefgen single ref constructor ck_null fs1 S
492	ref reference-type operator ck_fun stu% S?
493	bless bless ck_fun s@ S S?
494
495	# Pushy I/O.
496
497	backtick quoted execution (``, qx) ck_open t%
498	# glob defaults its first arg to $_
499	glob glob ck_glob t@ S?
500	readline <HANDLE> ck_null t% F?
501	rcatline append I/O operator ck_null t$
502
503	# Bindable operators.
504
505	regcmaybe regexp internal guard ck_fun s1 S
506	regcreset regexp internal reset ck_fun s1 S
507	regcomp regexp compilation ck_null s\| S
508	match pattern match (m//) ck_match d/
509	qr pattern quote (qr//) ck_match s/
510	subst substitution (s///) ck_null dis/ S
511	substcont substitution iterator ck_null dis\|
512	trans transliteration (tr///) ck_null is" S
513
514	# Lvalue operators.
515	# sassign is special-cased for op class
516
517	sassign scalar assignment ck_sassign s0
518	aassign list assignment ck_null t2 L L
519
520	chop chop ck_spair mts% L
521	schop scalar chop ck_null stu% S?
522	chomp chomp ck_spair mTs% L
523	schomp scalar chomp ck_null sTu% S?
524	defined defined operator ck_defined isu% S?
525	undef undef operator ck_lfun s% S?
526	study study ck_fun su% S?
527	pos match position ck_lfun stu% S?
528
529	preinc preincrement (++) ck_lfun dIs1 S
530	i_preinc integer preincrement (++) ck_lfun dis1 S
531	predec predecrement (--) ck_lfun dIs1 S
532	i_predec integer predecrement (--) ck_lfun dis1 S
533	postinc postincrement (++) ck_lfun dIst1 S
534	i_postinc integer postincrement (++) ck_lfun disT1 S
535	postdec postdecrement (--) ck_lfun dIst1 S
536	i_postdec integer postdecrement (--) ck_lfun disT1 S
537
538	# Ordinary operators.
539
540	pow exponentiation (**) ck_null fsT2 S S
541
542	multiply multiplication (*) ck_null IfsT2 S S
543	i_multiply integer multiplication (*) ck_null ifsT2 S S
544	divide division (/) ck_null IfsT2 S S
545	i_divide integer division (/) ck_null ifsT2 S S
546	modulo modulus (%) ck_null IifsT2 S S
547	i_modulo integer modulus (%) ck_null ifsT2 S S
548	repeat repeat (x) ck_repeat mt2 L S
549
550	add addition (+) ck_null IfsT2 S S
551	i_add integer addition (+) ck_null ifsT2 S S
552	subtract subtraction (-) ck_null IfsT2 S S
553	i_subtract integer subtraction (-) ck_null ifsT2 S S
554	concat concatenation (.) or string ck_concat fsT2 S S
555	stringify string ck_fun fsT@ S
556
557	left_shift left bitshift (<<) ck_bitop fsT2 S S
558	right_shift right bitshift (>>) ck_bitop fsT2 S S
559
560	lt numeric lt (<) ck_null Iifs2 S S
561	i_lt integer lt (<) ck_null ifs2 S S
562	gt numeric gt (>) ck_null Iifs2 S S
563	i_gt integer gt (>) ck_null ifs2 S S
564	le numeric le (<=) ck_null Iifs2 S S
565	i_le integer le (<=) ck_null ifs2 S S
566	ge numeric ge (>=) ck_null Iifs2 S S
567	i_ge integer ge (>=) ck_null ifs2 S S
568	eq numeric eq (==) ck_null Iifs2 S S
569	i_eq integer eq (==) ck_null ifs2 S S
570	ne numeric ne (!=) ck_null Iifs2 S S
571	i_ne integer ne (!=) ck_null ifs2 S S
572	ncmp numeric comparison (<=>) ck_null Iifst2 S S
573	i_ncmp integer comparison (<=>) ck_null ifst2 S S
574
575	slt string lt ck_null ifs2 S S
576	sgt string gt ck_null ifs2 S S
577	sle string le ck_null ifs2 S S
578	sge string ge ck_null ifs2 S S
579	seq string eq ck_null ifs2 S S
580	sne string ne ck_null ifs2 S S
581	scmp string comparison (cmp) ck_null ifst2 S S
582
583	bit_and bitwise and (&) ck_bitop fst2 S S
584	bit_xor bitwise xor (^) ck_bitop fst2 S S
585	bit_or bitwise or (\|) ck_bitop fst2 S S
586
587	negate negation (-) ck_null Ifst1 S
588	i_negate integer negation (-) ck_null ifsT1 S
589	not not ck_null ifs1 S
590	complement 1's complement (~) ck_bitop fst1 S
591
592	# High falutin' math.
593
594	atan2 atan2 ck_fun fsT@ S S
595	sin sin ck_fun fsTu% S?
596	cos cos ck_fun fsTu% S?
597	rand rand ck_fun sT% S?
598	srand srand ck_fun s% S?
599	exp exp ck_fun fsTu% S?
600	log log ck_fun fsTu% S?
601	sqrt sqrt ck_fun fsTu% S?
602
603	# Lowbrow math.
604
605	int int ck_fun fsTu% S?
606	hex hex ck_fun fsTu% S?
607	oct oct ck_fun fsTu% S?
608	abs abs ck_fun fsTu% S?
609
610	# String stuff.
611
612	length length ck_lengthconst isTu% S?
613	substr substr ck_substr st@ S S S? S?
614	vec vec ck_fun ist@ S S S
615
616	index index ck_index isT@ S S S?
617	rindex rindex ck_index isT@ S S S?
618
619	sprintf sprintf ck_fun mst@ S L
620	formline formline ck_fun ms@ S L
621	ord ord ck_fun ifsTu% S?
622	chr chr ck_fun fsTu% S?
623	crypt crypt ck_fun fsT@ S S
624	ucfirst ucfirst ck_fun fstu% S?
625	lcfirst lcfirst ck_fun fstu% S?
626	uc uc ck_fun fstu% S?
627	lc lc ck_fun fstu% S?
628	quotemeta quotemeta ck_fun fstu% S?
629
630	# Arrays.
631
632	rv2av array dereference ck_rvconst dt1
633	aelemfast constant array element ck_null s$ A S
634	aelem array element ck_null s2 A S
635	aslice array slice ck_null m@ A L
636
637	# Hashes.
638
639	each each ck_fun % H
640	values values ck_fun t% H
641	keys keys ck_fun t% H
642	delete delete ck_delete % S
643	exists exists ck_exists is% S
644	rv2hv hash dereference ck_rvconst dt1
645	helem hash element ck_null s2@ H S
646	hslice hash slice ck_null m@ H L
647
648	# Explosives and implosives.
649
650	unpack unpack ck_fun @ S S
651	pack pack ck_fun mst@ S L
652	split split ck_split t@ S S S
653	join join or string ck_join mst@ S L
654
655	# List operators.
656
657	list list ck_null m@ L
658	lslice list slice ck_null 2 H L L
659	anonlist anonymous list ([]) ck_fun ms@ L
660	anonhash anonymous hash ({}) ck_fun ms@ L
661
662	splice splice ck_fun m@ A S? S? L
663	push push ck_fun imsT@ A L
664	pop pop ck_shift s% A?
665	shift shift ck_shift s% A?
666	unshift unshift ck_fun imsT@ A L
667	sort sort ck_sort m@ C? L
668	reverse reverse ck_fun mt@ L
669
670	grepstart grep ck_grep dm@ C L
671	grepwhile grep iterator ck_null dt\|