Browse files

B-C-1.04_20

git-svn-id: http://perl-compiler.googlecode.com/svn/trunk@23 ed534f1a-1453-0410-ab30-dfc593a8b23c
  • Loading branch information...
1 parent 09c1df9 commit 855afd14ff8b92f9ba5312df35b9b5c32d76fcea @rurban committed Jul 28, 2008
Showing with 1,017 additions and 449 deletions.
  1. +131 −0 Artistic
  2. +15 −4 ByteLoader/ByteLoader.pm
  3. +17 −5 ByteLoader/bytecode.h
  4. +12 −12 ByteLoader/byterun.c
  5. +17 −0 Changes
  6. +248 −0 Copying
  7. +2 −1 MANIFEST
  8. +1 −1 META.yml
  9. +5 −1 Makefile.PL
  10. +73 −38 STATUS
  11. +1 −1 Todo
  12. +18 −21 bytecode.pl
  13. +10 −13 lib/B/Asmdata.pm
  14. +7 −4 lib/B/Assembler.pm
  15. +20 −6 lib/B/Bytecode.pm
  16. +116 −98 lib/B/C.pm
  17. +38 −34 lib/B/CC.pm
  18. +18 −19 perlcompile.pod
  19. +29 −22 perloptreeguts.pod
  20. +1 −1 script/assemble
  21. +13 −15 script/cc_harness
  22. +24 −24 t/TESTS
  23. +29 −23 t/bytecode.t
  24. +12 −16 t/c.t
  25. +9 −13 t/cc.t
  26. +1 −1 t/o.t
  27. +3 −1 t/stash.t
  28. +69 −29 t/testc.sh
  29. +78 −46 t/testplc.sh
View
131 Artistic
@@ -0,0 +1,131 @@
+
+
+
+
+ The "Artistic License"
+
+ Preamble
+
+The intent of this document is to state the conditions under which a
+Package may be copied, such that the Copyright Holder maintains some
+semblance of artistic control over the development of the package,
+while giving the users of the package the right to use and distribute
+the Package in a more-or-less customary fashion, plus the right to make
+reasonable modifications.
+
+Definitions:
+
+ "Package" refers to the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection of files
+ created through textual modification.
+
+ "Standard Version" refers to such a Package if it has not been
+ modified, or has been modified in accordance with the wishes
+ of the Copyright Holder as specified below.
+
+ "Copyright Holder" is whoever is named in the copyright or
+ copyrights for the package.
+
+ "You" is you, if you're thinking about copying or distributing
+ this Package.
+
+ "Reasonable copying fee" is whatever you can justify on the
+ basis of media cost, duplication charges, time of people involved,
+ and so on. (You will not be required to justify it to the
+ Copyright Holder, but only to the computing community at large
+ as a market that must bear the fee.)
+
+ "Freely Available" means that no fee is charged for the item
+ itself, though there may be fees involved in handling the item.
+ It also means that recipients of the item may redistribute it
+ under the same conditions they received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications
+derived from the Public Domain or from the Copyright Holder. A Package
+modified in such a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided
+that you insert a prominent notice in each changed file stating how and
+when you changed that file, and provided that you do at least ONE of the
+following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or
+ an equivalent medium, or placing the modifications on a major archive
+ site such as uunet.uu.net, or by allowing the Copyright Holder to include
+ your modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict
+ with standard executables, which must also be provided, and provide
+ a separate manual page for each non-standard executable that clearly
+ documents how it differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or
+executable form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where
+ to get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of
+ the Package with your modifications.
+
+ c) give non-standard executables non-standard names, and clearly
+ document the differences in manual pages (or equivalent), together
+ with instructions on where to get the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this
+Package. You may not charge a fee for this Package itself. However,
+you may distribute this Package in aggregate with other (possibly
+commercial) programs as part of a larger (possibly commercial) software
+distribution provided that you do not advertise this Package as a
+product of your own. You may embed this Package's interpreter within
+an executable of yours (by linking); this shall be construed as a mere
+form of aggregation, provided that the complete Standard Version of the
+interpreter is so embedded.
+
+6. The scripts and library files supplied as input to or produced as
+output from the programs of this Package do not automatically fall
+under the copyright of this Package, but belong to whoever generated
+them, and may be sold commercially, and may be aggregated with this
+Package. If such scripts or library files are aggregated with this
+Package via the so-called "undump" or "unexec" methods of producing a
+binary executable image, then distribution of such an image shall
+neither be construed as a distribution of this Package nor shall it
+fall under the restrictions of Paragraphs 3 and 4, provided that you do
+not represent such an executable image as a Standard Version of this
+Package.
+
+7. C subroutines (or comparably compiled subroutines in other
+languages) supplied by you and linked into this Package in order to
+emulate subroutines and variables of the language defined by this
+Package shall not be considered part of this Package, but are the
+equivalent of input as in Paragraph 6, provided these subroutines do
+not change the language in any way that would cause it to fail the
+regression tests for the language.
+
+8. Aggregation of this Package with a commercial distribution is always
+permitted provided that the use of this Package is embedded; that is,
+when no overt attempt is made to make this Package's interfaces visible
+to the end user of the commercial distribution. Such use shall not be
+construed as a distribution of this Package.
+
+9. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+ The End
View
19 ByteLoader/ByteLoader.pm
@@ -1,17 +1,28 @@
package ByteLoader;
use XSLoader ();
-
our $VERSION = '0.06_05';
# XSLoader problem:
# ByteLoader version 0.0601 required--this is only version 0.06_01 at ./bytecode2.plc line 2.
# on use ByteLoader $ByteLoader::VERSION;
# Fixed with use ByteLoader '$ByteLoader::VERSION';
# Next problem on perl-5.8.3: invalid floating constant suffix _03"
-if ($] < 5.009) {
- # need to check if ByteLoader is not already linked statically
- XSLoader::load 'ByteLoader'; # fake the old backwards compatible version
+if ($] < 5.009004) {
+ # Need to check if ByteLoader is not already linked statically.
+ # Before 5.6 byterun was in CORE, so we have no name clash.
+ require Config; Config->import();
+ if ($Config{static_ext} =~ /\bByteLoader\b/) {
+ # We overrode the static module with our site_perl version. Which version?
+ # We can only check the perl version and guess from that. From Module::CoreList
+ $VERSION = '0.03' if $] >= 5.006;
+ $VERSION = '0.04' if $] >= 5.006001;
+ $VERSION = '0.05' if $] >= 5.008001;
+ $VERSION = '0.06' if $] >= 5.009003;
+ $VERSION = '0.06' if $] >= 5.008008 and $] < 5.009;
+ } else {
+ XSLoader::load 'ByteLoader'; # fake the old backwards compatible version
+ }
} else {
XSLoader::load 'ByteLoader', $VERSION;
}
View
22 ByteLoader/bytecode.h
@@ -6,7 +6,7 @@ typedef int comment_t;
typedef SV *svindex;
typedef OP *opindex;
typedef char *pvindex;
-typedef HEK *hekindex;
+/*typedef HEK *hekindex;*/
typedef IV IV64;
/* need to swab bytes to the target byteorder */
@@ -161,7 +161,7 @@ static int bget_swab = 0;
} STMT_END
#define BGET_svindex(arg) BGET_objindex(arg, svindex)
#define BGET_opindex(arg) BGET_objindex(arg, opindex)
-#define BGET_hekindex(arg) BGET_objindex(arg, hekindex)
+/*#define BGET_hekindex(arg) BGET_objindex(arg, hekindex)*/
#define BGET_pvindex(arg) STMT_START { \
BGET_objindex(arg, pvindex); \
arg = arg ? savepv(arg) : arg; \
@@ -286,9 +286,8 @@ static int bget_swab = 0;
/* | PMf_COMPILETIME removed from op_pmflags to fix substr crashes with empty check_substr */
#define BSET_pregcomp(o, arg) \
STMT_START { \
- SV* repointer; \
REGEXP* rx = arg ? \
- CALLREGCOMP(aTHX_ newSVpvn(arg, strlen(arg)), \
+ CALLREGCOMP(newSVpvn(arg, strlen(arg)), \
cPMOPx(o)->op_pmflags) \
: Null(REGEXP*); \
PM_SETRE(((PMOP*)o), rx); \
@@ -524,6 +523,18 @@ static int bget_swab = 0;
} \
} STMT_END
#endif
+
+#if PERL_VERSION < 10
+#define BSET_gp_sv(gv, arg) GvSV((GV*)gv) = arg
+#else
+#define BSET_gp_sv(gv, arg) \
+ isGV_with_GP_on((GV*)gv); \
+ GvSVn((GV*)gv) = arg
+#endif
+
+#if PERL_VERSION < 10
+#define BSET_gp_file(gv, file) GvFILE((GV*)gv) = file
+#else
#define BSET_gp_file(gv, file) \
STMT_START { \
STRLEN len = strlen(file); \
@@ -532,9 +543,10 @@ static int bget_swab = 0;
if(GvFILE_HEK(gv)) { \
Perl_unshare_hek(aTHX_ GvFILE_HEK(gv)); \
} \
- GvGP(gv)->gp_file_hek = share_hek(file, len, hash); \
+ GvFILE_HEK(gv) = share_hek(file, len, hash); \
Safefree(file); \
} STMT_END
+#endif
/* NOTE: The bytecode header only sanity-checks the bytecode. If a script cares about
* what version of Perl it's being called under, it should do a 'use 5.006_001' or
View
24 ByteLoader/byterun.c
@@ -70,7 +70,7 @@ int bytecode_header_check(pTHX_ struct byteloader_state *bstate, U32 *isjit) {
}
}
BGET_strconst(str,80); /* archname */
- /* relaxed strictness, only check for ithread in archflag */
+ /* just warn. relaxed strictness, only check for ithread in archflag */
if (strNE(str, ARCHNAME)) {
HEADER_WARN2("wrong architecture (want %s, you have %s)", str, ARCHNAME);
}
@@ -187,9 +187,6 @@ byterun(pTHX_ struct byteloader_state *bstate)
while ((insn = BGET_FGETC()) != EOF) {
CopLINE(PL_curcop) = bstate->bs_fdata->next_out;
-#ifdef DEBUG_t_TEST_
- if (PL_op && DEBUG_t_TEST_) debop(PL_op);
-#endif
switch (insn) {
case INSN_COMMENT: /* 35 */
{
@@ -887,8 +884,8 @@ byterun(pTHX_ struct byteloader_state *bstate)
svindex arg;
BGET_svindex(arg);
DEBUG_v(Perl_deb(aTHX_ "(insn %3d) gp_sv svindex:0x%x, ix:%d\n", insn, arg, ix));
- GvSV(bstate->bs_sv) = arg;
- DEBUG_v(Perl_deb(aTHX_ " GvSV(bstate->bs_sv) = arg;\n"));
+ BSET_gp_sv(bstate->bs_sv, arg);
+ DEBUG_v(Perl_deb(aTHX_ " BSET_gp_sv(bstate->bs_sv, arg)\n"));
break;
}
case INSN_GP_REFCNT: /* 79 */
@@ -938,11 +935,11 @@ byterun(pTHX_ struct byteloader_state *bstate)
}
case INSN_GP_FILE: /* 84 */
{
- hekindex arg;
- BGET_hekindex(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) gp_file hekindex:0x%x, ix:%d\n", insn, arg, ix));
- GvFILE_HEK(bstate->bs_sv) = arg;
- DEBUG_v(Perl_deb(aTHX_ " GvFILE_HEK(bstate->bs_sv) = arg;\n"));
+ pvindex arg;
+ BGET_pvindex(arg);
+ DEBUG_v(Perl_deb(aTHX_ "(insn %3d) gp_file pvindex:\"%s\"\n", insn, arg, ix));
+ BSET_gp_file(bstate->bs_sv, arg);
+ DEBUG_v(Perl_deb(aTHX_ " BSET_gp_file(bstate->bs_sv, arg)\n"));
break;
}
case INSN_GP_IO: /* 85 */
@@ -1475,9 +1472,12 @@ byterun(pTHX_ struct byteloader_state *bstate)
break;
}
default:
- Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn);
+ Perl_croak(aTHX_ "Illegal bytecode instruction %d. Version incompatibility.\n", insn);
/* NOTREACHED */
}
+#ifdef DEBUG_t_TEST_
+ if (PL_op && DEBUG_t_TEST_) debop(PL_op);
+#endif
}
}
return 0;
View
17 Changes
@@ -2,6 +2,23 @@
Started on CPAN with B-C-1.04_12. The perl compiler was in CORE from alpha4
until Perl 5.9.4.
+1.04_20 2008-06-25 rurban
+ * t/TESTS: numbered.
+ * t/TESTS: added sub FETCHSIZE to test 16. required now
+ * C.pm, CC.pm: change debug globals to hash.
+ * C.pm: Fix B::RV::save for 5.10
+ * CC.pm: 5.10 fixed GvSV to GvSVn (PERL_DONT_CREATE_GVSV), fix cc test 3+4 crash
+ * Artistic, Copying: added. Clarified perl license.
+ * Bytecode.pm: fixed IO=>PVNV problem in test 15.
+ * bytecode.pl, bytecode.h: rewrote gp_sv and gp_file setters
+ with x (special setters). Fixes unshare hek assert in test 15, and force
+ creation of GVSV.
+ * Assembler.pm 0.07_05: cygwin text-mount fixes with \r\n
+ * t/testplc.sh, t/testc.sh: require bash, accept testnumber args
+ * Asmdata.pm: fix PORTABILITY docs
+ * t/testc.sh: -Bdynamic: link to shared libperl
+ * cc_harness: simplify. fixed for -Bdynamic -E
+
1.04_19 2008-06-08 rurban
* CC.pm: CXt_LOOP check rewrite, use now CxTYPE_no_LOOP()
* CC.pm, t/*.t: useithreads, not usethreads
View
248 Copying
@@ -0,0 +1,248 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
View
3 MANIFEST
@@ -1,10 +1,10 @@
+Artistic
lib/B/Asmdata.pm
lib/B/Assembler.pm
lib/B/Bblock.pm
lib/B/Bytecode.pm
lib/B/C.pm
lib/B/CC.pm
-lib/B/Debug.pm
lib/B/Disassembler.pm
lib/B/Stackobj.pm
lib/B/Stash.pm
@@ -19,6 +19,7 @@ ByteLoader/Makefile.PL
ByteLoader/ppport.h
C.xs
Changes
+Copying
hints/darwin.pl
hints/openbsd.pl
Makefile.PL
View
2 META.yml
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: B-C
-version: 1.04_19
+version: 1.04_20
version_from: lib/B/C.pm
installdirs: site
requires:
View
6 Makefile.PL
@@ -1,7 +1,7 @@
use ExtUtils::MakeMaker;
use Config;
use File::Spec;
-#use 5.008;
+use 5.008;
my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV;
@@ -14,6 +14,10 @@ WriteMakefile(
'B' => '1.0901'},
'AUTHOR' => 'Malcolm Beattie <mbeattie@sable.ox.ac.uk>',
'ABSTRACT' => 'perl compiler',
+ ($ExtUtils::MakeMaker::VERSION gt '6.31' ?
+ ('EXTRA_META' => "recommends:\n" .
+ " B::Debug: 1.06\n"
+ ) : ()),
clean => { FILES => "bytecode[1-9]* cccode[1-9]* ccode[1-9]* *.core *.stackdump ".
"a.out *.cee *.c *.asm *.dbg *.plc *.concise *~"},
);
View
111 STATUS
@@ -14,6 +14,30 @@ B:C Problems:
Modification of a read-only value attempted - save_context ?
5.11 regex pad wrong
+5.00505 i686-linux
+t/bytecode.t all ok
+t/c.t Fail 14-16
+Can't call method "our" on an undefined value at ccode14.pl line 1.
+not ok 14 # wanted: "ok", $? = 65280, got: ""
+not ok 15 # wanted: "a
+b", got: ""
+not ok 16 # wanted: "1", $? = 65280, got: "ccode16.pl syntax OK
+Walking tree
+Can't locate object method "FETCHSIZE" via package "main" at
+/usr/local/lib/perl5/5.00505/i686-linux/B/C.pm line 728.
+END failed--cleanup aborted."
+t/cc.t Fail 14-16 18-19
+Can't call method "our" on an undefined value.
+not ok 14 # wanted: "ok", $? = 65280, got: ""
+not ok 15 # wanted: "a
+b", got: ""
+not ok 16 # wanted: "1", $? = 65280, got: "cccode16.pl syntax OK
+Can't locate object method "FETCHSIZE" via package "main" at /usr/local/lib/perl5/5.00505/i686-linux/B/C.pm line 728.
+END failed--cleanup aborted.
+"
+not ok 18 # wanted: "ba", $? = 11, got: ""
+not ok 19 # wanted: "431", $? = 11, got: ""
+
5.6.2 i386-linux-thread-multi:
t/b.t 0 11 57 106 185.96% 5-57
t/bytecode.t 19 19 100.00% 1-19
@@ -38,32 +62,24 @@ t/testplc.sh: line 66: 5975 Segmentation fault
5.8.8:
t/bytecode.t
-cygwin only (caused by some vendor patch):
- not ok 2 #TODO wanted: 123, $? = 65280, got: Can't coerce ARRAY to integer in pattern match (m//) at bytecode2.plc line 125.
- not ok 3 #TODO wanted: zzz2y2y2, $? = 65280, got: Can't coerce ARRAY to integer in substitution (s///) at bytecode3.plc line 281.
- not ok 4 #TODO wanted: z2y2y2, $? = 65280, got: Can't coerce ARRAY to integer in substitution (s///) at bytecode4.plc line 253.
- not ok 5 #TODO wanted: bnnrm, $? = 65280, got: Can't coerce ARRAY to integer in push regexp at bytecode5.plc line 266.
- not ok 7 #TODO wanted: brnfg, $? = 65280, got: Can't coerce ARRAY to integer in push regexp at bytecode7.plc line 322.
-linux: all pass (no MYMALLOC PERL_DONT_CREATE_GVSV USE_64_BIT_INT,
- no vendor patches: debian 40r0)
-
+ cygwin: ok
+ linux: ok (no MYMALLOC PERL_DONT_CREATE_GVSV USE_64_BIT_INT)
t/c.t (Wstat: 0 Tests: 19 Failed: 6)
FAILED tests 8-10, 14-16
Undefined subroutine &main::a called at ccode8.pl line 1.
Modification of a read-only value attempted at ccode10.pl line 2.
-t/cc.t (Wstat: 0 Tests: 19 Failed: 13)
- Failed tests: 8-10 12 14-16 18-19
+t/cc.t (Wstat: 0 Tests: 19 Failed: 12)
+ Failed tests: 8-10 14-16 18-19
In function `pp_main': cccode12.c:276: error: too few arguments to function
(Bug#55302, fixed with B-C-1.04_18)
5.8.8d:
- TODO failed: 20 (bc op coverage)
-t/bytecode.t: All ok
-t/c.t (Wstat: 0 Tests: 19 Failed: 5)
- FAILED tests 11-12 17-19
+t/bytecode.t: ok
+t/c.t (Wstat: 0 Tests: 19 Failed: 13)
+ FAILED tests 5, 7-12, 14-19 (was: 11-12 17-19)
panic: invalid pad in pad_sv: 0x8c1760[0x8de3b8]
-t/cc.t (Wstat: 0 Tests: 19 Failed: 5)
- Failed tests: 11-12 17-19
+t/cc.t (Wstat: 0 Tests: 19 Failed: 13)
+ FAILED tests 5, 7-12, 14-19 (was: 11-12 17-19)
5.8.9d:
t/bytecode.t: all ok
@@ -81,7 +97,7 @@ t/cc.t (Wstat: 0 Tests: 19 Failed: 9)
8-10 12 14-16 18-19
5.10.0d:
-t/bytecode (Wstat: 0 Tests: 19 Failed: 6)
+t/bytecode (Wstat: 0 Tests: 19 Failed: 9)
FAILED tests 2-5, 7, 11, 15 (was: 2-5, 7, 9-12, 15)
Assertion (((PMOP*)(*Perl_Iop_ptr(my_perl))))->op_pmflags & 0x0002
Modification of a read-only value attempted
@@ -92,23 +108,21 @@ t/c.t (Wstat: 0 Tests: 19 Failed: 6)
t/cc.t (Wstat: 0 Tests: 19 Failed: 9)
Failed tests: 2-4, 6, 11-12, 17-19 (was: 8-10, 12, 14-16, 18-19)
-5.10.0-nt (not threaded):
-t/bytecode (Wstat: 0 Tests: 19 Failed: 9)
- FAILED tests: 9-10, 12
-t/c.t (Wstat: 0 Tests: 19 Failed: 10)
- FAILED tests: 8-10, 14-16 (was: 2-4, 6, 11-12, 17-19)
- invalid pad in pad_sv, pad_new, save_clearsv - writing to PL_curpad at save_context
-t/cc.t (Wstat: 0 Tests: 19 Failed: 8)
- Failed tests: 2-4 6 11-12 17-19 (was: 2-4 6 11-12 17-19)
-
+5.10.0-nt (not threaded):
+t/bytecode.t (Wstat: 0 Tests: 19 Failed: 5)
+ Failed tests: 7, 9-12
+t/c.t (Wstat: 0 Tests: 19 Failed: 17)
+ Failed tests: 2-12, 14-19
+t/cc.t (Wstat: 0 Tests: 19 Failed: 17)
+ Failed tests: 2-12, 14-19
-5.11 @33673 -D
-t/bytecode.t (Wstat: 0 Tests: 20 Failed: 7)
- Failed tests: 4, 9-12, 15-16 (all segfaulting in REGEX)
-t/c.t (Wstat: 0 Tests: 19 Failed: 6)
- Failed tests: 8-10, 14-16
+5.11d@34005
+t/bytecode.t (Wstat: 0 Tests: 19 Failed: 6)
+ Failed tests: 4, 9-12, 16
+t/c.t (Wstat: 0 Tests: 19 Failed: 10)
+ Failed tests: 6, 8-10, 12, 14, 16-19 (was: 8-10, 14-16)
t/cc.t (Wstat: 0 Tests: 19 Failed: 11)
- Failed tests: 1-4, 6, 11-13, 17-19
+ Failed tests: 2-19 (was 1-4, 6, 11-13, 17-19)
5.11 @33704 i386-linux-thread-multi
t/bytecode.t (Wstat: 0 Tests: 20 Failed: 10)
@@ -120,25 +134,39 @@ t/cc.t (Wstat: 0 Tests: 19 Failed: 11)
5.10, 5.11 status
-----------------
-With DEBUGGING
- panic: illegal pad in pad_new: 0x18c4368[0x18cf6e8]
+panic: illegal pad in pad_new: 0x18c4368[0x18cf6e8] with DEBUGGING only
CvPADLIST: curpad<=>comppad
+
pvx: seems to be fixed now in bc, and c
With the move of the pvx field from xpv to the sv, we have to solve
that differently for the Bytecode and C backend.
Bytecode can simply mimic the old XPV behaviour of a 3 field struct
(pvx, cur, len) to simplify pv handling.
+
hv: crash at invalid entry in hv_store in B::HV::save fixed
+
hek: new implementation
+
regexp: new and still broken for 5.11, regex_pad wrong and ignored on 5.11
-bc 10: padv+sassign => Modification of a read-only value attempted at bytecode10.pl line 1.
+
+bc 10: padv+sassign => Modification of a read-only value attempted at
+bytecode10.pl line 1. Only on cygwin, not on linux!
+The bytecode is exactly the same, it must be pp_entersub() with &$cv()
+Is FAKE flag of the padsv is missing or should we check for readonly pads?
+ g <1> entersub[t4] vKS/TARG,1
+ => Perl_sv_force_normal_flags()
+ if (SvREADONLY(sv) && (!SvFAKE(sv)) && (IN_PERL_RUNTIME)) => die
+ SV = NULL(0x0) at 0x12207c0
+ REFCNT = 2147483129
+ FLAGS = (READONLY)
+-Dt crash fixed by core patch pl-dump-const.patch
5.8 status
----------
I've restored 5.8 backwards compatibility, mainly for test comparison.
CPAN installations will still abort, but that can be easily overridden.
-ByteLoader is now backwards compatible: Accepts lower versions also,
-but opcode compat version table missing for loading older bc.
+ByteLoader is now platform compatible, backwards compatible not yet.
+opcode compat version table missing for loading older bc.
Details:
@@ -157,6 +185,13 @@ $2 = {sv_any = 0x14d1d48, sv_refcnt = 3, sv_flags = 32777 (0x8009), sv_u = {
svu_rv = 0x14db2c8, svu_pv = 0x14db2c8 "��E\001", svu_array = 0x14db2c8,
svu_hash = 0x14db2c8, svu_gp = 0x14db2c8}}
+cccode3.c - 5.11 dstr assert
+ XPUSHs(GvSV(PL_curpad[1])); /* oops, this GV is empty */
+ /* stack = */
+ /* BINOP (0x15ec140) sassign [OPf_STACKED] */
+ dst = POPs; src = TOPs; /* empty var dst at stack ! */
+ MAYBE_TAINT_SASSIGN_SRC(src);
+ SvSetSV(dst, src);
ccode3 - 5.10
-------------
View
2 Todo
@@ -1,6 +1,6 @@
* Fixes
-CvPADOFFSET failures
+pad panics
ByteLoader compatibility: version, platform. eventually Bytecode version portability
CC backend: goto, sort with non-default comparison. last for non-loop blocks.
improve XSUB handling (both static and dynamic)
View
39 bytecode.pl
@@ -147,7 +147,7 @@ package B::Asmdata;
}
}
BGET_strconst(str,80); /* archname */
- /* relaxed strictness, only check for ithread in archflag */
+ /* just warn. relaxed strictness, only check for ithread in archflag */
if (strNE(str, ARCHNAME)) {
HEADER_WARN2("wrong architecture (want %s, you have %s)", str, ARCHNAME);
}
@@ -266,9 +266,6 @@ package B::Asmdata;
while ((insn = BGET_FGETC()) != EOF) {
CopLINE(PL_curcop) = bstate->bs_fdata->next_out;
-#ifdef DEBUG_t_TEST_
- if (PL_op && DEBUG_t_TEST_) debop(PL_op);
-#endif
switch (insn) {
EOT
@@ -370,9 +367,12 @@ package B::Asmdata;
#
print BYTERUN_C <<'EOT';
default:
- Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn);
+ Perl_croak(aTHX_ "Illegal bytecode instruction %d. Version incompatibility.\n", insn);
/* NOTREACHED */
}
+#ifdef DEBUG_t_TEST_
+ if (PL_op && DEBUG_t_TEST_) debop(PL_op);
+#endif
}
}
return 0;
@@ -609,27 +609,24 @@ =head1 DESCRIPTION
=back
-=head1 PORTABILITY (TODO)
+=head1 PORTABILITY
All bytecode values are already portable.
-Cross-platform and cross-version portability is just not implemented yet.
-Cross-version portability will be very limited, cross-platform will
-do with the same threading model.
+Cross-platform portability is implemented, cross-version not yet.
+Cross-version portability will be very limited, cross-platform only
+for the same threading model.
-=head2 CROSS-PLATFORM PORTABILITY (TODO)
+=head2 CROSS-PLATFORM PORTABILITY
-For different endian-ness there are ByteLoader converters planned.
+For different endian-ness there are ByteLoader converters in effect.
Header entry: byteorder.
64int - 64all - 32int is portable. Header entry: ivsize
-Threading: unsolvable. Header entry: archname has "-thread"
-
-Cross-platform portability will be available only if threading
-is on or off on both perls (compiler and runner). TODO: Check in
-bytecode_header_check().
+ITHREADS are unportable.
+Header entry: archflag - bitflag 1.
-=head2 CROSS-VERSION PORTABILITY (TODO)
+=head2 CROSS-VERSION PORTABILITY (TODO - HARD)
Bytecode ops:
We can only reliably load bytecode from previous versions and promise
@@ -665,8 +662,8 @@ =head1 AUTHOR
chmod 0444, @targets;
# TODO 5.10:
-# stpv
-# pv_free: free the bs_pv and the SvPVX?
+# stpv (?)
+# pv_free: free the bs_pv and the SvPVX? (?)
__END__
# First set instruction ord("#") to read comment to end-of-line (sneaky)
@@ -770,14 +767,14 @@ =head1 AUTHOR
0 gv_fetchpvx bstate->bs_sv strconst 128x
0 gv_stashpv bstate->bs_sv strconst 128x
0 gv_stashpvx bstate->bs_sv strconst 128x
-0 gp_sv GvSV(bstate->bs_sv) svindex
+0 gp_sv bstate->bs_sv svindex x
0 gp_refcnt GvREFCNT(bstate->bs_sv) U32
0 gp_refcnt_add GvREFCNT(bstate->bs_sv) I32 x
0 gp_av *(SV**)&GvAV(bstate->bs_sv) svindex
0 gp_hv *(SV**)&GvHV(bstate->bs_sv) svindex
0 gp_cv *(SV**)&GvCV(bstate->bs_sv) svindex
<9 gp_file GvFILE(bstate->bs_sv) pvindex
-9 gp_file GvFILE_HEK(bstate->bs_sv) hekindex
+9 gp_file bstate->bs_sv pvindex x
0 gp_io *(SV**)&GvIOp(bstate->bs_sv) svindex
0 gp_form *(SV**)&GvFORM(bstate->bs_sv) svindex
0 gp_cvgen GvCVGEN(bstate->bs_sv) U32
View
23 lib/B/Asmdata.pm
@@ -108,7 +108,7 @@ $insn_data{gp_refcnt_add} = [80, \&PUT_I32, "GET_I32"];
$insn_data{gp_av} = [81, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_hv} = [82, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_cv} = [83, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_file} = [84, \&PUT_hekindex, "GET_hekindex"];
+$insn_data{gp_file} = [84, \&PUT_pvindex, "GET_pvindex"];
$insn_data{gp_io} = [85, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_form} = [86, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_cvgen} = [87, \&PUT_U32, "GET_U32"];
@@ -246,27 +246,24 @@ Since Perl version 5.10 defined in L<B>.
=back
-=head1 PORTABILITY (TODO)
+=head1 PORTABILITY
All bytecode values are already portable.
-Cross-platform and cross-version portability is just not implemented yet.
-Cross-version portability will be very limited, cross-platform will
-do with the same threading model.
+Cross-platform portability is implemented, cross-version not yet.
+Cross-version portability will be very limited, cross-platform only
+for the same threading model.
-=head2 CROSS-PLATFORM PORTABILITY (TODO)
+=head2 CROSS-PLATFORM PORTABILITY
-For different endian-ness there are ByteLoader converters planned.
+For different endian-ness there are ByteLoader converters in effect.
Header entry: byteorder.
64int - 64all - 32int is portable. Header entry: ivsize
-Threading: unsolvable. Header entry: archname has "-thread"
+ITHREADS are unportable.
+Header entry: archflag - bitflag 1.
-Cross-platform portability will be available only if threading
-is on or off on both perls (compiler and runner). TODO: Check in
-bytecode_header_check().
-
-=head2 CROSS-VERSION PORTABILITY (TODO)
+=head2 CROSS-VERSION PORTABILITY (TODO - HARD)
Bytecode ops:
We can only reliably load bytecode from previous versions and promise
View
11 lib/B/Assembler.pm
@@ -17,7 +17,7 @@ no warnings; # XXX
@ISA = qw(Exporter);
@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm maxopix maxsvix);
-$VERSION = '0.07_04';
+$VERSION = '0.07_05';
use strict;
my %opnumber;
@@ -197,7 +197,7 @@ sub strip_comments {
\s*(.*)$
}sx; # Keep only the instruction and optional argument.
my ($line, $comment) = ($1, $2);
- # $line ~= s/\t$//; if $comment;
+ # $line =~ s/\t$// if $comment;
return ($line, $comment);
}
@@ -217,9 +217,11 @@ sub gen_header {
$header .= B::Asmdata::PUT_strconst(qq["$version"]);
$header .= B::Asmdata::PUT_U32($Config{ivsize});
$header .= B::Asmdata::PUT_U32($Config{ptrsize});
- $header .= B::Asmdata::PUT_U32($Config{longsize});
+ if ($version ge "0.06_03") {
+ $header .= B::Asmdata::PUT_U32($Config{longsize});
+ }
$header .= B::Asmdata::PUT_strconst('"'.$Config{byteorder}.'"');
- if ($version gt "0.06_04") {
+ if ($version ge "0.06_05") {
my $archflag = 0;
$archflag += 1 if $Config{useithreads};
$header .= B::Asmdata::PUT_U16($archflag);
@@ -308,6 +310,7 @@ sub assemble {
my ($insn, $arg, $comment);
$linenum++;
chomp $line;
+ $line =~ s/\cM$//;
if ($debug) {
my $quotedline = $line;
$quotedline =~ s/\\/\\\\/g;
View
26 lib/B/Bytecode.pm
@@ -147,7 +147,7 @@ sub B::GV::ix {
eval "require B::Debug;";
$gv->B::GV::debug;
}
- if (($PERL510 and $gv->isGV_with_GP) or
+ if (($PERL510 and $gv->isGV_with_GP) or
(!$PERL510 and $gv->GP))
{ # only gv with gp
my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
@@ -202,6 +202,7 @@ sub B::GV::ix {
$svtab{$$gv} = $varix = $ix = $tix++;
$gv->B::PVMG::bsave($ix);
if (!$PERL510) {
+ #GV_without_GP has no flags?
asm "xgv_flags", $gv->GvFLAGS;
}
if (!$PERL510 and $gv->STASH) {
@@ -331,6 +332,7 @@ sub B::PVNV::bsave {
return if $sv->isa('B::CV');
return if $sv->isa('B::FM');
return if $sv->isa('B::GV');
+ return if $sv->isa('B::IO');
}
asm "xnv", sprintf "%.40g", $sv->NVX;
}
@@ -464,7 +466,7 @@ sub B::GV::desired {
my ($cv, $form);
if ($debug{G} and !$PERL510) {
eval "require B::Debug;";
- $gv->B::GV::debug;
+ $gv->debug;
}
$files{$gv->FILE} && $gv->LINE
|| ${$cv = $gv->CV} && $files{$cv->FILE}
@@ -497,6 +499,7 @@ sub B::HV::bwalk {
sub B::OP::bsave_thin {
my ($op, $ix) = @_;
+ bwarn(B::peekop($op), ", ix: $ix") if $debug{o};
my $next = $op->next;
my $nextix = $optab{$$next};
$nextix = 0, push @cloop, $op unless defined $nextix;
@@ -560,6 +563,7 @@ sub B::BINOP::bsave {
sub B::LISTOP::bsave {
my ($op, $ix) = @_;
+ bwarn($op->peekop, ", ix: $ix") if $debug{o};
my $name = $op->name;
sub blocksort() { OPf_SPECIAL|OPf_STACKED }
if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
@@ -614,6 +618,7 @@ sub B::BINOP::bsave_fat {
my ($op,$ix) = @_;
my $last = $op->last;
my $lastix = $op->last->ix;
+ bwarn(B::peekop($op), ", ix: $ix $last: $last, lastix: $lastix") if $debug{o};
if (!$PERL510 && $op->name eq 'aassign' && $last->name eq 'null') {
asm "ldop", $lastix unless $lastix == $opix;
asm "op_targ", $last->targ;
@@ -626,6 +631,7 @@ sub B::BINOP::bsave_fat {
sub B::LOGOP::bsave {
my ($op,$ix) = @_;
my $otherix = $op->other->ix;
+ bwarn(B::peekop($op), ", ix: $ix") if $debug{o};
$op->B::UNOP::bsave($ix);
asm "op_other", $otherix;
@@ -637,7 +643,7 @@ sub B::PMOP::bsave {
# my $pmnextix = $op->pmnext->ix; # XXX
- bwarn(B::peekop($op), ", ix: $ix") if $debug{M};
+ bwarn(B::peekop($op), ", ix: $ix") if $debug{M} or $debug{o};
if (ITHREADS) {
if ($op->name eq 'subst') {
$rrop = "op_pmreplroot";
@@ -709,7 +715,7 @@ sub B::PADOP::bsave {
$op->B::OP::bsave($ix);
# crashed in 5.11
#if ($PERL511) {
- asm "op_padix", $op->padix;
+ asm "op_padix", $op->padix;
#}
}
@@ -849,7 +855,7 @@ sub compile {
*nice = sub ($) { print "\n# @_\n" unless $quiet;};
} elsif (/^-v/) {
warn "conflicting -q ignored" if $quiet;
- *nice = sub ($) { print STDERR "@_\n" };
+ *nice = sub ($) { print "\n# @_\n"; print STDERR "@_\n" };
} elsif (/^-H/) {
require ByteLoader;
my $version = $ByteLoader::VERSION;
@@ -869,7 +875,7 @@ use ByteLoader '$ByteLoader::VERSION';
$scan = length($1) ? $1 : $0;
} elsif (/^-b/) {
$savebegins = 1;
- # this is here for the testsuite
+ # this is here for the testsuite
} elsif (/^-TI/) {
$T_inhinc = 1;
} elsif (/^-TF(.*)/) {
@@ -987,6 +993,14 @@ Without -q the assembler source is commented.
Be quiet.
+=item B<-v>
+
+Be verbose.
+
+=item B<-Do>
+
+OPs, prints each OP as it's processed
+
=item B<-D>I<M>
Set debugging flag for more verbose STDERR output.
View
214 lib/B/C.pm
@@ -9,7 +9,7 @@
package B::C;
-our $VERSION = '1.04_19';
+our $VERSION = '1.04_20';
package B::C::Section;
@@ -207,8 +207,7 @@ my $optimize_warn_sv = 0;
my $use_perl_script_name = 0;
my $save_data_fh = 0;
my $save_sig = 0;
-# -Dc -DA -DC -DM -DS -DG -Dp
-my ($debug_cops, $debug_av, $debug_cv, $debug_mg, $debug_sv, $debug_gv, $debug_pkg);
+my %debug;
my $max_string_len;
my $ITHREADS = $Config{useithreads};
@@ -248,7 +247,7 @@ my $OP_THREADSV = opnumber('threadsv');
# special handling for nullified COP's.
my %OP_COP = ( opnumber('nextstate') => 1, opnumber('setstate') => 1 );
$OP_COP{ opnumber('dbstate') } = 1 unless $PERL511;
-warn %OP_COP if $debug_cops;
+warn %OP_COP if $debug{cops};
sub savesym {
my ($obj, $value) = @_;
@@ -288,7 +287,7 @@ sub savere {
"0,0,0,0,NULL,0,0,NULL,0,0, NULL,NULL,NULL,0,0,0", $len, $pvmax));
$resect->add(sprintf("&orange_list[%d], 1, %d, %s", $orangesect->index, $flags, cstring($re)));
$sym = sprintf("re_list[%d]", $resect->index);
- warn sprintf("Saving RE $sym->orangesect[%d] $re\n", $orangesect->index) if $debug_sv;
+ warn sprintf("Saving RE $sym->orangesect[%d] $re\n", $orangesect->index) if $debug{sv};
} elsif ($PERL510) {
#$sym = sprintf("re_list[%d]", $re_index++);
#$resect->add(sprintf("0,0,0,%s", cstring($re)));
@@ -378,7 +377,7 @@ sub B::OP::fake_ppaddr {
: ($verbose ? sprintf("/*OP_%s*/NULL", uc( $_[0]->name )) : "NULL");
}
-# This pair is needed becase B::FAKEOP::save doesn't scalar dereference
+# This pair is needed because B::FAKEOP::save doesn't scalar dereference
# $op->next and $op->sibling
my $opsect_common = "next, sibling, ppaddr, ".($MAD?"madprop, ":"")."targ, type, ";
{
@@ -404,9 +403,10 @@ my $opsect_common = "next, sibling, ppaddr, ".($MAD?"madprop, ":"")."targ, type,
# 5.9.4: unsigned op_opt:1; unsigned op_static:1; unsigned op_spare:5;
# 5.10: unsigned op_opt:1; unsigned op_latefree:1; unsigned op_latefreed:1; unsigned op_attached:1; unsigned op_spare:3;
my $static;
- if ($] < 5.009004) { $static = sprintf "%u", 65535; $opsect_common .= "seq"; } # seq
- elsif ($] < 5.010) { $static = '0, 1, 0'; $opsect_common .= "opt, static, spare"; } # opt static spare
- else { $static = '0, 1, 0, 0, 0'; $opsect_common .= "opt, latefree, latefreed, attached, spare"; } # opt latefree latefreed attached spare
+ if ($] < 5.009004) { $static = sprintf "%u", 65535; $opsect_common .= "seq"; }
+ elsif ($] < 5.010) { $static = '0, 1, 0'; $opsect_common .= "opt, static, spare"; }
+ else { $static = '0, 1, 0, 0, 0';
+ $opsect_common .= "opt, latefree, latefreed, attached, spare"; }
sub B::OP::_save_common_middle {
my $op = shift;
my $madprop = $MAD ? "/*madprop*/0," : "";
@@ -436,7 +436,7 @@ sub B::OP::save {
}
# since 5.10 nullified cops free their additional fields
if ($PERL510 and !$type and $OP_COP{$op->targ}) {
- warn sprintf("Null COP: %d\n", $op->targ) if $verbose or $debug_cops;
+ warn sprintf("Null COP: %d\n", $op->targ) if $verbose or $debug{cops};
if ($PERL511) {
$copsect->comment("$opsect_common, line, stash, file, hints, seq, warnings, hints_hash");
$copsect->add(sprintf("%s, 0, NULL, ".
@@ -605,7 +605,8 @@ sub B::PADOP::save {
my $ix = $padopsect->index;
$init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
unless $optimize_ppaddr;
-# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
+ # padix already initialized
+ # $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix)); # was commented
savesym($op, "(OP*)&padop_list[$ix]");
}
@@ -615,7 +616,7 @@ sub B::COP::save {
return $sym if defined $sym;
# TODO: if it is a nullified COP we must save it with all cop fields!
warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
- if $debug_cops;
+ if $debug{cops};
# shameless cut'n'paste from B::Deparse
my $warn_sv;
my $warnings = $op->warnings;
@@ -672,8 +673,9 @@ sub B::COP::save {
unless $optimize_ppaddr;
$init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
unless $optimize_warn_sv;
- # TODO: Trim the .pl extension?
- $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
+ # Trim the .pl extension, to print the executable name only.
+ my $file = $op->file; $file =~ s/\.pl$//;
+ $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($file)),
sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
savesym($op, "(OP*)&cop_list[$ix]");
@@ -699,7 +701,7 @@ sub B::PMOP::save {
# of a substitution syntax tree. We don't want to walk that...
if ($op->name eq "pushre") {
$gvsym = $replroot->save;
- warn "PMOP::save saving a pp_pushre with GV $gvsym\n" if $debug_gv;
+ warn "PMOP::save saving a pp_pushre with GV $gvsym\n" if $debug{gv};
$replrootfield = 0;
} else {
$replstartfield = saveoptree("*ignore*", $replroot, $replstart);
@@ -729,9 +731,11 @@ sub B::PMOP::save {
if (defined($re)) {
my( $resym, $relen ) = savere( $re, 0 );
if ($PERL510) {
- $init->add(sprintf("PM_SETRE(&$pm, CALLREGCOMP(aTHX_ $resym, %u));", $op->pmflags));
+ $init->add(sprintf("PM_SETRE(&$pm, CALLREGCOMP($resym, %u));", $op->pmflags));
} else {
- $init->add(sprintf("PM_SETRE(&$pm, pregcomp($resym, $resym + %u, &$pm));", $relen));
+ $init->add(sprintf("PM_SETRE(&$pm, CALLREGCOMP(aTHX_ $resym, $resym + %u, &$pm));",
+ $relen));
+ # $init->add(sprintf("PM_SETRE(&$pm, pregcomp($resym, $resym + %u, &$pm));", $relen));
}
}
if ($gvsym and !$PERL510) {
@@ -757,13 +761,13 @@ sub B::NULL::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
- warn "Saving SVt_NULL SV\n" if $debug_sv;
+ warn "Saving SVt_NULL SV\n" if $debug{sv};
# debug
if ($$sv == 0) {
warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n" if $verbose;
return savesym($sv, "(void*)Nullsv /* XXX */");
}
- $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
+ $svsect->add(sprintf("0, %lu, 0x%x", $sv->REFCNT , $sv->FLAGS));
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}
@@ -775,7 +779,7 @@ sub B::IV::save {
$svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
$xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
warn sprintf("Saving IV %d to xpviv_list[%d], sv_list[%d]\n", $sv->IVX,
- $xpvivsect->index, $svsect->index) if $debug_sv;
+ $xpvivsect->index, $svsect->index) if $debug{sv};
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}
@@ -793,7 +797,7 @@ sub B::NV::save {
$svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
$xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
warn sprintf("Saving NV %d %s to xpvnv_list[%d], sv_list[%d]", $sv->IVX, $val,
- $xpvnvsect->index, $svsect->index) if $debug_sv;
+ $xpvnvsect->index, $svsect->index) if $debug{sv};
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}
@@ -812,10 +816,10 @@ sub savepvn {
$offset += length $str;
}
push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
- warn sprintf("Copying overlong PV %s to %s\n", cstring($pv), $dest) if $debug_sv;
+ warn sprintf("Copying overlong PV %s to %s\n", cstring($pv), $dest) if $debug{sv};
}
else {
- warn sprintf("Saving PV %s to %s\n", cstring($pv), $dest) if $debug_sv;
+ warn sprintf("Saving PV %s to %s\n", cstring($pv), $dest) if $debug{sv};
push @res, sprintf("%s = savepvn(%s, %u);", $dest,
cstring($pv), length($pv));
}
@@ -959,12 +963,12 @@ sub B::PVMG::save {
sub B::PVMG::save_magic {
my ($sv) = @_;
- warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv) if $debug_mg;
+ warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv) if $debug{mg};
my $stash = $sv->SvSTASH;
$stash->save;
if ($$stash) {
warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
- if $debug_mg;
+ if $debug{mg};
# XXX Hope stash is already going to be saved.
$init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
}
@@ -974,10 +978,10 @@ sub B::PVMG::save_magic {
$type = $mg->TYPE;
$ptr = $mg->PTR;
$len=$mg->LENGTH;
- if ($debug_mg) {
- warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
+ if ($debug{mg}) {
+ eval { warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
class($sv), $$sv, class($obj), $$obj,
- cchar($type), cstring($ptr));
+ cchar($type), cstring($ptr)); };
}
unless ( $type eq 'r' ) {
@@ -1020,28 +1024,37 @@ CODE
}
}
-# TODO: 5.10 tests and changes (SV -> IV)
+# TODO: Test 5.11 changes (SV -> IV)
sub B::RV::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
my $rv = save_rv( $sv );
- # GVs need to be handled at runtime
- if( ref( $sv->RV ) eq 'B::GV' ) {
+ if ($PERL510) {
+ # 5.10 has no struct xrv anymore, just sv_u.svu_rv. Set all at runtime.
+ $svsect->add(sprintf("0, %lu, 0x%x",
+ $sv->REFCNT , $sv->FLAGS));
+ $init->add(sprintf("sv_list[%d].sv_u.svu_rv = (SV*)%s;\n", $svsect->index, $rv));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+
+ } else {
+ # GVs need to be handled at runtime
+ if( ref( $sv->RV ) eq 'B::GV' ) {
$xrvsect->add( "(SV*)Nullgv" );
$init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
- }
- # and stashes, too
- elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
+ }
+ # and stashes, too
+ elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
$xrvsect->add( "(SV*)Nullhv" );
$init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
- }
- else {
+ }
+ else {
$xrvsect->add($rv);
+ }
+ $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
+ $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}
- $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
- $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}
sub try_autoload {
@@ -1128,7 +1141,7 @@ sub B::CV::save {
if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
IO::Seekable IO::Poll);
}
- warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
+ warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug{cv};
return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
}
if ($cvxsub && $cvname eq "INIT") {
@@ -1141,7 +1154,7 @@ sub B::CV::save {
$xpvcvsect->add("XPVCVIX$xpvcv_ix");
# Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
$sym = savesym($cv, "&sv_list[$sv_ix]");
- warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
+ warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug{cv};
if (!$$root && !$cvxsub) {
if (try_autoload($cvstashname, $cvname)) {
# Recalculate root and xsub
@@ -1159,7 +1172,7 @@ sub B::CV::save {
my $xsubany = "Nullany";
if ($$root) {
warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
- $$cv, $$root) if $debug_cv;
+ $$cv, $$root) if $debug{cv};
my $ppname = "";
if ($$gv) {
my $stashname = $gv->STASH->NAME;
@@ -1181,13 +1194,13 @@ sub B::CV::save {
}
$startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
- $$cv, $ppname, $$root) if $debug_cv;
+ $$cv, $ppname, $$root) if $debug{cv};
if ($$padlist) {
warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
- $$padlist, $$cv) if $debug_cv;
+ $$padlist, $$cv) if $debug{cv};
$padlist->save;
warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
- $$padlist, $$cv) if $debug_cv;
+ $$padlist, $$cv) if $debug{cv};
}
}
else {
@@ -1227,7 +1240,7 @@ sub B::CV::save {
$gv->save;
$init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
warn sprintf("done saving GV 0x%x for CV 0x%x\n",
- $$gv, $$cv) if $debug_cv;
+ $$gv, $$cv) if $debug{cv};
}
if( $ITHREADS ) {
$init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
@@ -1240,7 +1253,7 @@ sub B::CV::save {
$stash->save;
$init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
- $$stash, $$cv) if $debug_cv;
+ $$stash, $$cv) if $debug{cv};
}
$symsect->add(sprintf("SVIX%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
$sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
@@ -1251,24 +1264,24 @@ sub B::GV::save {
my ($gv) = @_;
my $sym = objsym($gv);
if (defined($sym)) {
- warn sprintf("GV 0x%x already saved as $sym\n", $$gv) if $debug_gv;
+ warn sprintf("GV 0x%x already saved as $sym\n", $$gv) if $debug{gv};
return $sym;
} else {
my $ix = $gv_index++;
$sym = savesym($gv, "gv_list[$ix]");
- warn sprintf("Saving GV 0x%x as $sym\n", $$gv) if $debug_gv;
+ warn sprintf("Saving GV 0x%x as $sym\n", $$gv) if $debug{gv};
}
my $is_empty = $gv->is_empty;
my $gvname = $gv->NAME;
my $fullname = $gv->STASH->NAME . "::" . $gvname;
my $name = cstring($fullname);
- warn "GV name is $name\n" if $debug_gv;
+ warn "GV name is $name\n" if $debug{gv};
my $egvsym;
unless ($is_empty) {
my $egv = $gv->EGV;
if ($$gv != $$egv) {
#warn(sprintf("EGV name is %s, saving it now\n",
- # $egv->STASH->NAME . "::" . $egv->NAME)) if $debug_gv;
+ # $egv->STASH->NAME . "::" . $egv->NAME)) if $debug{gv};
$egvsym = $egv->save;
}
}
@@ -1278,21 +1291,21 @@ sub B::GV::save {
my $svflags = $gv->FLAGS;
if ($PERL510 and $gv->isGV_with_GP and $is_empty) {
warn(sprintf("gv[$name]_with_GP: 0x%x %s %s %s\n", $gv->FLAGS,
- $gv->FILE, $gv->FILEGV, $gv->GP)) if $debug_gv;
+ $gv->FILE, $gv->FILEGV, $gv->GP)) if $debug{gv};
$svflags = $gv->FLAGS && 0x8000 ? $gv->FLAGS - 0x8000 : $gv->FLAGS;
- warn("Removing empty GP from $name\n") if $debug_gv;
+ warn("Removing empty GP from $name\n") if $debug{gv};
} elsif ($PERL510 and !$is_empty) {
$init->add(sprintf("GvGP($sym) = Perl_newGP(aTHX_ $sym); /* 0x%x */", $gv->GP));
# $svflags = $gv->FLAGS && 0x400 ? $gv->FLAGS : $gv->FLAGS + 0x400;
#warn(sprintf("Setting GvGP of $name: 0x%x %s %s %s\n", $svflags,
- # $gv->FILE, $gv->FILEGV, $gv->GP)) if $debug_gv;
+ # $gv->FILE, $gv->FILEGV, $gv->GP)) if $debug{gv};
}
$init->add(sprintf("SvFLAGS($sym) = 0x%x;", $svflags ),
sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
$init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
# XXX hack for when Perl accesses PVX of GVs, only if SvPOK
#if (!($svflags && 0x400)) { # defer to run-time (0x400 -> SvPOK) for convenience
- $init->add("if (SvPOK($sym)) SvPVX($sym) = emptystring;\n") unless $is_empty;
+ $init->add("if (SvPOK($sym)) SvPVX($sym) = emptystring;") unless $is_empty;
#}
# Shouldn't need to do save_magic since gv_fetchpv handles that
#$gv->save_magic;
@@ -1335,24 +1348,24 @@ sub B::GV::save {
"GvGP($sym) = GvGP($egvsym);");
} elsif ($savefields) {
# Don't save subfields of special GVs (*_, *1, *# and so on)
- warn "GV::save saving subfields\n" if $debug_gv;
+ warn "GV::save saving subfields\n" if $debug{gv};
my $gvsv = $gv->SV;
if ($$gvsv && $savefields&Save_SV) {
$gvsv->save;
- $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
- warn "GV::save \$$name\n" if $debug_gv;
+ $init->add(sprintf("GvSVn($sym) = s\\_%x;", $$gvsv));
+ warn "GV::save \$$name\n" if $debug{gv};
}
my $gvav = $gv->AV;
if ($$gvav && $savefields&Save_AV) {
$gvav->save;
$init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
- warn "GV::save \@$name\n" if $debug_gv;
+ warn "GV::save \@$name\n" if $debug{gv};
}
my $gvhv = $gv->HV;
if ($$gvhv && $savefields&Save_HV) {
$gvhv->save;
$init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
- warn "GV::save \%$name\n" if $debug_gv;
+ warn "GV::save \%$name\n" if $debug{gv};
}
my $gvcv = $gv->CV;
if ($$gvcv && $savefields&Save_CV) {
@@ -1367,24 +1380,26 @@ sub B::GV::save {
$init->add("}");
} else {
$init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
- warn "GV::save &$name\n" if $debug_gv;
+ warn "GV::save &$name\n" if $debug{gv};
}
}
if ($] > 5.009) {
my $file = cstring($gv->FILE);
- my $heksym = $heksect->add($file);
- $init->add(sprintf("GvFILE_HEK($sym) = share_hek(%s,%u,0);",
- $file, length($file)));
- warn "GV::save GvFILE_HEK(*$name) = share_hek($file)\n" if $debug_gv;
+ #my $heksym = $heksect->add($file);
+ $init->add(sprintf("{ U32 hash; PERL_HASH(hash,%s,%u);",
+ $file, length($file)-2),
+ sprintf(" GvFILE_HEK($sym) = share_hek(%s,%u,hash);}",
+ $file, length($file)-2));
+ warn "GV::save GvFILE_HEK(*$name) = share_hek($file)\n" if $debug{gv};
} else {
$init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
- warn "GV::save GvFILE(*$name) = ".cstring($gv->FILE)."\n" if $debug_gv;
+ warn "GV::save GvFILE(*$name) = ".cstring($gv->FILE)."\n" if $debug{gv};
}
my $gvform = $gv->FORM;
if ($$gvform && $savefields&Save_FORM) {
$gvform->save;
$init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
- warn "GV::save GvFORM(*$name)\n" if $debug_gv;
+ warn "GV::save GvFORM(*$name)\n" if $debug{gv};
}
my $gvio = $gv->IO;
if ($$gvio && $savefields&Save_IO) {
@@ -1396,8 +1411,9 @@ sub B::GV::save {
use strict 'refs';
$gvio->save_data( $fullname, <$fh> ) if $fh->opened;
}
- warn "GV::save GvIO(*$name)\n" if $debug_gv;
+ warn "GV::save GvIO(*$name)\n" if $debug{gv};
}
+ $init->add("");
}
return $sym;
}
@@ -1407,21 +1423,24 @@ sub B::AV::save {
my $sym = objsym($av);
return $sym if defined $sym;
my $line;
- if ($] < 5.009) {
+ if ($PERL510) {
+ # 5.9.4+: nv fill max iv mg stash
+ $line = "0.0, -1, -1, 0, 0, Nullhv";
+ } else {
# 5.8: array fill max off nv mg stash alloc arylen flags
$line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0";
$line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009;
- } else {
- # 5.9.4+: nv fill max iv mg stash
- $line = "0.0, -1, -1, 0, 0, Nullhv";
}
$xpvavsect->add($line);
$svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
$xpvavsect->index, $av->REFCNT, $av->FLAGS));
my $sv_list_index = $svsect->index;
- my $fill = $av->FILL;
$av->save_magic;
- if ($debug_av) {
+ # cornercase: tied array without FETCHSIZE
+ my $fill;
+ eval { $fill = $av->FILL; };
+ $fill = -1 if $@; # catch error in tie magic
+ if ($debug{av}) {
$line = sprintf("saving AV 0x%x FILL=$fill", $$av);
$line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009;
warn $line;
@@ -1430,7 +1449,7 @@ sub B::AV::save {
#if ($fill > -1 && ($avflags & AVf_REAL)) {
if ($fill > -1) {
my @array = $av->ARRAY;
- if ($debug_av) {
+ if ($debug{av}) {
my $el;
my $i = 0;
foreach $el (@array) {
@@ -1454,15 +1473,13 @@ sub B::AV::save {
foreach my $i ( 0..$#array ) {
$acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
}
- $acc .= "\n";
-
$init->no_split;
$init->add("{",
"\tSV **svp;",
"\tAV *av = (AV*)&sv_list[$sv_list_index];",
"\tav_extend(av, $fill);",
"\tsvp = AvARRAY(av);" );
- $init->add($acc);
+ $init->add(substr($acc,0,-2));
$init->add("\tAvFILLp(av) = $fill;",
"}");
$init->split;
@@ -1551,7 +1568,7 @@ sub B::IO::save_data {
{
GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
SV* sv = $sym;
- GvSV( gv ) = sv;
+ GvSVn( gv ) = sv;
}
CODE
# for PerlIO::scalar
@@ -1854,7 +1871,7 @@ EOT
print <<EOT;
if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
- tmpsv = GvSV(tmpgv);
+ tmpsv = GvSVn(tmpgv);
sv_setpv(tmpsv, ${dollar_0});
SvSETMAGIC(tmpsv);
}
@@ -1863,7 +1880,7 @@ EOT
else {
print <<EOT;
if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
- tmpsv = GvSV(tmpgv);
+ tmpsv = GvSVn(tmpgv);
sv_setpv(tmpsv, argv[0]);
SvSETMAGIC(tmpsv);
}
@@ -1872,7 +1889,7 @@ EOT
print <<'EOT';
if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
- tmpsv = GvSV(tmpgv);
+ tmpsv = GvSVn(tmpgv);
#ifdef WIN32
sv_setpv(tmpsv,"perl.exe");
#else
@@ -2066,7 +2083,7 @@ sub should_save
my $package = shift;
$package =~ s/::$//;
return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
- warn "Considering $package\n" if $debug_pkg;
+ warn "Considering $package\n" if $debug{pkg};
foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
{
# If this package is a prefix to something we are saving, traverse it
@@ -2077,7 +2094,7 @@ sub should_save
}
if (exists $unused_sub_packages{$package})
{
- warn "Cached $package is ".$unused_sub_packages{$package}."\n" if $debug_pkg;
+ warn "Cached $package is ".$unused_sub_packages{$package}."\n" if $debug{pkg};
delete_unsaved_hashINC($package) unless $unused_sub_packages{$package};
return $unused_sub_packages{$package};
}
@@ -2095,7 +2112,7 @@ sub should_save
{
if (UNIVERSAL::can($package, $m))
{
- warn "$package has method $m: saving package\n" if $debug_pkg;
+ warn "$package has method $m: saving package\n" if $debug{pkg};
return mark_package($package);
}
}
@@ -2106,7 +2123,7 @@ sub delete_unsaved_hashINC{
my $packname=shift;
$packname =~ s/\:\:/\//g;
$packname .= '.pm';
- warn "deleting $packname\n" if $INC{$packname} and $debug_pkg;
+ warn "deleting $packname\n" if $INC{$packname} and $debug{pkg};
delete $INC{$packname};
}
sub walkpackages
@@ -2176,7 +2193,7 @@ sub save_main {
warn "Walking tree\n" if $verbose;
seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
$verbose ? walkoptree_slow(main_root, "save") : walkoptree(main_root, "save");
- warn "done main optree, walking symtable for extras\n" if $debug_cv;
+ warn "done main optree, walking symtable for extras\n" if $verbose or $debug{cv};
save_unused_subs();
# XSLoader was used, force saving of XSLoader::load
if( $use_xsloader ) {
@@ -2305,19 +2322,19 @@ sub compile {
if ($arg eq "o") {
B->debug(1);
} elsif ($arg eq "c") {
- $debug_cops = 1;
+ $debug{cops}++;
} elsif ($arg eq "A") {
- $debug_av = 1;
+ $debug{av}++;
} elsif ($arg eq "C") {
- $debug_cv = 1;
+ $debug{cv}++;
} elsif ($arg eq "M") {
- $debug_mg = 1;
+ $debug{mg}++;
} elsif ($arg eq "G") {
- $debug_gv = 1;
+ $debug{gv}++;
} elsif ($arg eq "S") {
- $debug_sv = 1;
+ $debug{sv}++;
} elsif ($arg eq "p") {
- $debug_pkg = 1;
+ $debug{pkg}++;
} else {
warn "ignoring unknown debug option: $arg\n";
}
@@ -2409,7 +2426,7 @@ Output to filename instead of STDOUT
=item B<-v>
-Verbose compilation (currently gives a few compilation statistics).
+Verbose compilation. Currently gives a few compilation statistics.
=item B<-->
@@ -2547,13 +2564,14 @@ help make use of this compiler.
Plenty. Current status: experimental.
- 5.10+5.11: unresolved dynamic boot_ syms (cygwin only!)
+ 5.10+5.11:
failing pregcomp()
- pad panics
+ pad panics and assertions
+ tie FETCH error
=head1 AUTHOR
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>.
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>,
Reini Urban, C<rurban@cpan.org>
=cut
View
72 lib/B/CC.pm
@@ -66,9 +66,7 @@ BEGIN {
}
}
-my ($module_name);
-my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
- $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
+my ($module_name, %debug);
# Optimisation options. On the command line, use hyphens instead of
# underscores for compatibility with gcc-style options. We use
@@ -129,7 +127,7 @@ sub init_hash { map { $_ => 1 } @_ }
pp_enter pp_method);
sub debug {
- if ($debug_runtime) {
+ if ($debug{runtime}) {
warn(@_);
} else {
my @tmp=@_;
@@ -144,7 +142,7 @@ sub declare {
sub push_runtime {
push(@$runtime_list_ref, @_);
- warn join("\n", @_) . "\n" if $debug_runtime;
+ warn join("\n", @_) . "\n" if $debug{runtime};
}
sub save_runtime {
@@ -216,7 +214,7 @@ sub init_pp {
map { declare("SV", "*$_") } qw(sv src dst left right);
declare("MAGIC", "*mg");
$decl->add("static OP * $ppname (pTHX);");
- debug "init_pp: $ppname\n" if $debug_queue;
+ debug "init_pp: $ppname\n" if $debug{queue};
}
# Initialise runtime_callback function for Stackobj class
@@ -226,15 +224,15 @@ BEGIN { B::Stackobj::set_callback(\&runtime) }
sub cc_queue {
my ($name, $root, $start, @pl) = @_;
debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
- if $debug_queue;
+ if $debug{queue};
if ($name eq "*ignore*") {
$name = 0;
} else {
push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
}
my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
$start = $fakeop->save;
- debug "cc_queue: name $name returns $start\n" if $debug_queue;
+ debug "cc_queue: name $name returns $start\n" if $debug{queue};
return $start;
}
BEGIN { B::C::set_callback(\&cc_queue) }
@@ -268,7 +266,7 @@ sub pop_bool {
sub write_back_lexicals {
my $avoid = shift || 0;
debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
- if $debug_shadow;
+ if $debug{shadow};
my $lex;
foreach $lex (@pad) {
next unless ref($lex);
@@ -315,7 +313,7 @@ sub write_back_stack {
sub invalidate_lexicals {
my $avoid = shift || 0;
debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
- if $debug_shadow;
+ if $debug{shadow};
my $lex;
foreach $lex (@pad) {
next unless ref($lex);
@@ -417,7 +415,7 @@ sub dopoptoloop {
while ($cxix >= 0 && CxTYPE_no_LOOP($cxstack[$cxix])) {
$cxix--;
}
- debug "dopoptoloop: returning $cxix" if $debug_cxstack;
+ debug "dopoptoloop: returning $cxix" if $debug{cxstack};
return $cxix;
}
@@ -429,7 +427,7 @@ sub dopoptolabel {
$cxstack[$cxix]->{label} ne $label)) {
$cxix--;
}
- debug "dopoptolabel: returning $cxix" if $debug_cxstack;
+ debug "dopoptolabel: returning $cxix" if $debug{cxstack};
return $cxix;
}
@@ -460,7 +458,7 @@ sub load_pad {
my @valuelist = $valuelistav->ARRAY;
my $ix;
@pad = ();
- debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
+ debug "load_pad: $#namelist names, $#valuelist values\n" if $debug{pad};
# Temporary lexicals don't get named so it's possible for @valuelist
# to be strictly longer than @namelist. We count $ix up to the end of
# @valuelist but index into @namelist for the name. Any temporaries which
@@ -492,7 +490,7 @@ sub load_pad {
$pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
"i_$name", "d_$name");
- debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
+ debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug{pad};
}
}
@@ -667,7 +665,7 @@ sub pp_nextstate {
my $op = shift;
$curcop->load($op);
@stack = ();
- debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
+ debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug{lineno};
runtime("TAINT_NOT;") unless $omit_taint;
runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
if ($freetmps_each_bblock || $freetmps_each_loop) {
@@ -695,7 +693,7 @@ sub pp_dbstate {
sub pp_rv2gv{
my $op =shift;
$curcop->write_back;
- write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_lexicals()unless $skip_lexicals{$ppname};
write_back_stack() unless $skip_stack{$ppname};
my $sym=doop($op);
if ($op->private & OPpDEREF) {
@@ -745,7 +743,10 @@ sub pp_gvsv {
my $op = shift;
my $gvsym;
if ($ITHREADS) {
+ #debug(sprintf("OP name=%s, class=%s",$op->name,class($op))) if $debug{pad};
+ debug(sprintf("GVSV->padix = %d",$op->padix)) if $debug{pad};
$gvsym = $pad[$op->padix]->as_sv;
+ debug(sprintf("GVSV->private = 0x%x",$op->private)) if $debug{pad};
}
else {
$gvsym = $op->gv->save;
@@ -754,7 +755,7 @@ sub pp_gvsv {
if ($op->private & OPpLVAL_INTRO) {
runtime("XPUSHs(save_scalar($gvsym));");
} else {
- runtime("XPUSHs(GvSV($gvsym));");
+ $PERL510 ? runtime("XPUSHs(GvSVn($gvsym));") : runtime("XPUSHs(GvSV($gvsym));");
}
return $op