dump.c: dump physical, not logical, AVs

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 5c71fd0..44f8642 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -22,6 +22,10 @@
  * and destroy a perl interpreter, plus the functions used by XS code to
  * call back into perl. Note that it does not contain the actual main()
  * function of the interpreter; that can be found in perlmain.c
+ *
+ * Note that at build time this file is also linked to as perlmini.c,
+ * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is
+ * then used to create the miniperl executable, rather than perl.o.
  */
 
 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
@@ -93,6 +97,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl)
        OP_REFCNT_INIT;
        OP_CHECK_MUTEX_INIT;
        HINTS_REFCNT_INIT;
+        LOCALE_INIT;
        MUTEX_INIT(&PL_dollarzero_mutex);
        MUTEX_INIT(&PL_my_ctx_mutex);
 #  endif
@@ -213,6 +218,26 @@ Initializes a new Perl interpreter.  See L<perlembed>.
 =cut
 */
 
+static void
+S_fixup_platform_bugs(void)
+{
+#if defined(__GLIBC__) && IVSIZE == 8 \
+    && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
+    {
+        IV l =   3;
+        IV r = -10;
+        /* Cannot do this check with inlined IV constants since
+         * that seems to work correctly even with the buggy glibc. */
+        if (l % r == -3) {
+            dTHX;
+            /* Yikes, we have the bug.
+             * Patch in the workaround version. */
+            PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix;
+        }
+    }
+#endif
+}
+
 void
 perl_construct(pTHXx)
 {
@@ -250,6 +275,8 @@ perl_construct(pTHXx)
 
     init_ids();
 
+    S_fixup_platform_bugs();
+
     JMPENV_BOOTSTRAP;
     STATUS_ALL_SUCCESS;
 
@@ -393,6 +420,9 @@ perl_construct(pTHXx)
     PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
     PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
     PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
+#ifdef USE_THREAD_SAFE_LOCALE
+    PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
+#endif
 
     ENTER;
 }
@@ -585,19 +615,41 @@ perl_destruct(pTHXx)
     assert(PL_scopestack_ix == 0);
 
     /* Need to flush since END blocks can produce output */
+    /* flush stdout separately, since we can identify it */
+#ifdef USE_PERLIO
+    {
+        PerlIO *stdo = PerlIO_stdout();
+        if (*stdo && PerlIO_flush(stdo)) {
+            PerlIO_restore_errno(stdo);
+            PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s",
+                          Strerror(errno));
+            if (!STATUS_UNIX)
+                STATUS_ALL_FAILURE;
+        }
+    }
+#endif
     my_fflush_all();
 
 #ifdef PERL_TRACE_OPS
-    /* If we traced all Perl OP usage, report and clean up */
+    /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
+    {
+        const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
+        UV uv;
+
+        if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
+            || !(uv > 0))
+        goto no_trace_out;
+    }
     PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
     for (i = 0; i <= OP_max; ++i) {
-        PerlIO_printf(Perl_debug_log, "  %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
-        PL_op_exec_cnt[i] = 0;
+        if (PL_op_exec_cnt[i])
+            PerlIO_printf(Perl_debug_log, "  %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
     }
     /* Utility slot for easily doing little tracing experiments in the runloop: */
     if (PL_op_exec_cnt[OP_max+1] != 0)
         PerlIO_printf(Perl_debug_log, "  SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
     PerlIO_printf(Perl_debug_log, "\n");
+ no_trace_out:
 #endif
 
 
@@ -1075,6 +1127,16 @@ perl_destruct(pTHXx)
     PL_SB_invlist = NULL;
     PL_WB_invlist = NULL;
 
+#ifdef USE_THREAD_SAFE_LOCALE
+    if (PL_C_locale_obj) {
+        /* Make sure we aren't using the locale space we are about to free */
+        uselocale(LC_GLOBAL_LOCALE);
+
+        freelocale(PL_C_locale_obj);
+        PL_C_locale_obj = (locale_t) NULL;
+    }
+#endif
+
     if (!specialWARN(PL_compiling.cop_warnings))
        PerlMemShared_free(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = NULL;
@@ -1750,6 +1812,9 @@ S_Internals_V(pTHX_ CV *cv)
 #  ifdef PERL_MEM_LOG_NOIMPL
                             " PERL_MEM_LOG_NOIMPL"
 #  endif
+#  ifdef PERL_OP_PARENT
+                            " PERL_OP_PARENT"
+#  endif
 #  ifdef PERL_PERTURB_KEYS_DETERMINISTIC
                             " PERL_PERTURB_KEYS_DETERMINISTIC"
 #  endif
@@ -1771,6 +1836,9 @@ S_Internals_V(pTHX_ CV *cv)
 #  ifdef PERL_USE_SAFE_PUTENV
                             " PERL_USE_SAFE_PUTENV"
 #  endif
+#  ifdef SILENT_NO_TAINT_SUPPORT
+                             " SILENT_NO_TAINT_SUPPORT"
+#  endif
 #  ifdef UNLINK_ALL_VERSIONS
                             " UNLINK_ALL_VERSIONS"
 #  endif
@@ -2780,7 +2848,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
        (void)POPMARK;
         old_cxix = cxstack_ix;
        create_eval_scope(NULL, flags|G_FAKINGEVAL);
-       (void)INCMARK;
+       INCMARK;
 
        JMPENV_PUSH(ret);
 
@@ -3099,6 +3167,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  M  trace smart match resolution\n"
       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
       "  L  trace some locale setting information--for Perl core development\n",
+      "  i  trace PerlIO layer processing\n",
       NULL
     };
     UV uv = 0;
@@ -3107,7 +3176,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
 
     if (isALPHA(**s)) {
        /* if adding extra options, remember to update DEBUG_MASK */
-       static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
+       static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
 
        for (; isWORDCHAR(**s); (*s)++) {
            const char * const d = strchr(debopts,**s);
@@ -4926,7 +4995,7 @@ void
 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 {
     SV *atsv;
-    volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
+    VOL const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
     CV *cv;
     STRLEN len;
     int ret;