Convert rest of PerlIO's memory tables to per-interp and add clone functions

for them. Call explicit cleanup during destruct process.
 - one binmode test is failing
 - also ext/threads/t/basic.t fails under make test, and is noisy under
   harness. (Threads results are intermingled and don't match order expected.)

p4raw-id: //depot/perlio@12547

diff --git a/embedvar.h b/embedvar.h
index 066bec4..2eb5407 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -223,6 +223,7 @@
 #define PL_dbargs              (PERL_GET_INTERP->Idbargs)
 #define PL_debstash            (PERL_GET_INTERP->Idebstash)
 #define PL_debug               (PERL_GET_INTERP->Idebug)
+#define PL_def_layerlist       (PERL_GET_INTERP->Idef_layerlist)
 #define PL_defgv               (PERL_GET_INTERP->Idefgv)
 #define PL_diehook             (PERL_GET_INTERP->Idiehook)
 #define PL_doextract           (PERL_GET_INTERP->Idoextract)
@@ -266,6 +267,7 @@
 #define PL_incgv               (PERL_GET_INTERP->Iincgv)
 #define PL_initav              (PERL_GET_INTERP->Iinitav)
 #define PL_inplace             (PERL_GET_INTERP->Iinplace)
+#define PL_known_layers                (PERL_GET_INTERP->Iknown_layers)
 #define PL_last_lop            (PERL_GET_INTERP->Ilast_lop)
 #define PL_last_lop_op         (PERL_GET_INTERP->Ilast_lop_op)
 #define PL_last_swash_hv       (PERL_GET_INTERP->Ilast_swash_hv)
@@ -512,6 +514,7 @@
 #define PL_dbargs              (vTHX->Idbargs)
 #define PL_debstash            (vTHX->Idebstash)
 #define PL_debug               (vTHX->Idebug)
+#define PL_def_layerlist       (vTHX->Idef_layerlist)
 #define PL_defgv               (vTHX->Idefgv)
 #define PL_diehook             (vTHX->Idiehook)
 #define PL_doextract           (vTHX->Idoextract)
@@ -555,6 +558,7 @@
 #define PL_incgv               (vTHX->Iincgv)
 #define PL_initav              (vTHX->Iinitav)
 #define PL_inplace             (vTHX->Iinplace)
+#define PL_known_layers                (vTHX->Iknown_layers)
 #define PL_last_lop            (vTHX->Ilast_lop)
 #define PL_last_lop_op         (vTHX->Ilast_lop_op)
 #define PL_last_swash_hv       (vTHX->Ilast_swash_hv)
@@ -804,6 +808,7 @@
 #define PL_Idbargs             PL_dbargs
 #define PL_Idebstash           PL_debstash
 #define PL_Idebug              PL_debug
+#define PL_Idef_layerlist      PL_def_layerlist
 #define PL_Idefgv              PL_defgv
 #define PL_Idiehook            PL_diehook
 #define PL_Idoextract          PL_doextract
@@ -847,6 +852,7 @@
 #define PL_Iincgv              PL_incgv
 #define PL_Iinitav             PL_initav
 #define PL_Iinplace            PL_inplace
+#define PL_Iknown_layers       PL_known_layers
 #define PL_Ilast_lop           PL_last_lop
 #define PL_Ilast_lop_op                PL_last_lop_op
 #define PL_Ilast_swash_hv      PL_last_swash_hv

diff --git a/intrpvar.h b/intrpvar.h
index b6b4f07..c224ff7 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -495,6 +495,8 @@ PERLVAR(Icustom_op_descs, HV*)  /* Descriptions of user defined ops */
 
 #ifdef PERLIO_LAYERS
 PERLVARI(Iperlio, PerlIO *,NULL)
+PERLVARI(Iknown_layers, PerlIO_list_t *,NULL)
+PERLVARI(Idef_layerlist, PerlIO_list_t *,NULL)
 #endif
 
 /* New variables must be added to the very end for binary compatibility.

diff --git a/perl.c b/perl.c
index 9eaa7b7..3a11219 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -258,7 +258,7 @@ perl_construct(pTHXx)
     sys_intern_init();
 #endif
 
-    PerlIO_init();                     /* Hook to IO system */
+    PerlIO_init(aTHX);                 /* Hook to IO system */
 
     PL_fdpid = newAV();                        /* for remembering popen pids by fd */
     PL_modglobal = newHV();            /* pointers to per-interpreter module globals */
@@ -498,7 +498,7 @@ perl_destruct(pTHXx)
                  * flag is set in regexec.c:S_regtry
                  */
                 SvFLAGS(resv) &= ~SVf_BREAK;
-            } 
+            }
            else if(SvREPADTMP(resv)) {
              SvREPADTMP_off(resv);
            }
@@ -800,6 +800,11 @@ perl_destruct(pTHXx)
     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
        Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
 
+#if 1 && defined(PERLIO_LAYERS)
+    /* No more IO - including error messages ! */
+    PerlIO_cleanup(aTHX);
+#endif
+
     Safefree(PL_origfilename);
     Safefree(PL_reg_start_tmp);
     if (PL_reg_curpm)
@@ -946,7 +951,7 @@ setuid perl scripts securely.\n");
     {
         /* we copy rather than point to argv
          * since perl_clone will copy and perl_destruct
-         * has no way of knowing if we've made a copy or 
+         * has no way of knowing if we've made a copy or
          * just point to argv
          */
         int i = PL_origargc;
@@ -1517,7 +1522,7 @@ perl_run(pTHXx)
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
-       if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && 
+       if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
            PL_endav && !PL_minus_c)
            call_list(oldscope, PL_endav);
 #ifdef MYMALLOC

diff --git a/perlapi.h b/perlapi.h
index ffe9741..2811a44 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -183,6 +183,8 @@ END_EXTERN_C
 #define PL_debstash            (*Perl_Idebstash_ptr(aTHX))
 #undef  PL_debug
 #define PL_debug               (*Perl_Idebug_ptr(aTHX))
+#undef  PL_def_layerlist
+#define PL_def_layerlist       (*Perl_Idef_layerlist_ptr(aTHX))
 #undef  PL_defgv
 #define PL_defgv               (*Perl_Idefgv_ptr(aTHX))
 #undef  PL_diehook
@@ -269,6 +271,8 @@ END_EXTERN_C
 #define PL_initav              (*Perl_Iinitav_ptr(aTHX))
 #undef  PL_inplace
 #define PL_inplace             (*Perl_Iinplace_ptr(aTHX))
+#undef  PL_known_layers
+#define PL_known_layers                (*Perl_Iknown_layers_ptr(aTHX))
 #undef  PL_last_lop
 #define PL_last_lop            (*Perl_Ilast_lop_ptr(aTHX))
 #undef  PL_last_lop_op

diff --git a/perlio.c b/perlio.c
index 793a4e8..0de2829 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -425,7 +425,7 @@ PerlIO_allocate(pTHX)
            }
        }
     }
-    f = PerlMemShared_calloc(PERLIO_TABLE_SIZE, sizeof(PerlIO));
+    Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
     if (!f) {
        return NULL;
     }
@@ -451,25 +451,6 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
 }
 
 void
-PerlIO_clone(pTHX_ PerlIO *proto, CLONE_PARAMS *param)
-{
-    PerlIO **table = &proto;
-    PerlIO *f;
-    PL_perlio = NULL;
-    PerlIO_allocate(aTHX); /* root slot is never used */
-    while ((f = *table)) {
-           int i;
-           table = (PerlIO **) (f++);
-           for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
-               if (*f) {
-                   PerlIO_fdupopen(aTHX_ f, param);
-               }
-               f++;
-           }
-       }
-}
-
-void
 PerlIO_cleantable(pTHX_ PerlIO **tablep)
 {
     PerlIO *table = *tablep;
@@ -482,16 +463,14 @@ PerlIO_cleantable(pTHX_ PerlIO **tablep)
                PerlIO_close(f);
            }
        }
-       PerlMemShared_free(table);
+       Safefree(table);
        *tablep = NULL;
     }
 }
 
-PerlIO_list_t *PerlIO_known_layers;
-PerlIO_list_t *PerlIO_def_layerlist;
 
 PerlIO_list_t *
-PerlIO_list_alloc(void)
+PerlIO_list_alloc(pTHX)
 {
     PerlIO_list_t *list;
     Newz('L', list, 1, PerlIO_list_t);
@@ -500,12 +479,11 @@ PerlIO_list_alloc(void)
 }
 
 void
-PerlIO_list_free(PerlIO_list_t *list)
+PerlIO_list_free(pTHX_ PerlIO_list_t *list)
 {
     if (list) {
        if (--list->refcnt == 0) {
            if (list->array) {
-               dTHX;
                IV i;
                for (i = 0; i < list->cur; i++) {
                    if (list->array[i].arg)
@@ -519,9 +497,8 @@ PerlIO_list_free(PerlIO_list_t *list)
 }
 
 void
-PerlIO_list_push(PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
+PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
 {
-    dTHX;
     PerlIO_pair_t *p;
     if (list->cur >= list->len) {
        list->len += 8;
@@ -537,20 +514,44 @@ PerlIO_list_push(PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
     }
 }
 
+PerlIO_list_t *
+PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
+{
+    int i;
+    PerlIO_list_t *list = PerlIO_list_alloc(aTHX);
+    for (i=0; i < proto->cur; i++) {
+       SV *arg = Nullsv;
+       if (proto->array[i].arg)
+           arg = sv_dup(proto->array[i].arg,param);
+       PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
+    }
+    return list;
+}
 
 void
-PerlIO_cleanup_layers(pTHX_ void *data)
+PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
 {
-#if 0
-    PerlIO_known_layers = Nullhv;
-    PerlIO_def_layerlist = Nullav;
-#endif
+    PerlIO **table = &proto->Iperlio;
+    PerlIO *f;
+    PL_perlio = NULL;
+    PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
+    PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
+    PerlIO_allocate(aTHX); /* root slot is never used */
+    while ((f = *table)) {
+           int i;
+           table = (PerlIO **) (f++);
+           for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
+               if (*f) {
+                   PerlIO_fdupopen(aTHX_ f, param);
+               }
+               f++;
+           }
+       }
 }
 
 void
-PerlIO_cleanup()
+PerlIO_cleanup(pTHX)
 {
-    dTHX;
     PerlIO_cleantable(aTHX_ &PL_perlio);
 }
 
@@ -578,6 +579,10 @@ PerlIO_destruct(pTHX)
            f++;
        }
     }
+    PerlIO_list_free(aTHX_ PL_known_layers);
+    PL_known_layers = NULL;
+    PerlIO_list_free(aTHX_ PL_def_layerlist);
+    PL_def_layerlist = NULL;
 }
 
 void
@@ -596,7 +601,7 @@ PerlIO_pop(pTHX_ PerlIO *f)
                return;
        }
        *f = l->next;;
-       PerlMemShared_free(l);
+       Safefree(l);
     }
 }
 
@@ -611,15 +616,15 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
     IV i;
     if ((SSize_t) len <= 0)
        len = strlen(name);
-    for (i = 0; i < PerlIO_known_layers->cur; i++) {
-       PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
+    for (i = 0; i < PL_known_layers->cur; i++) {
+       PerlIO_funcs *f = PL_known_layers->array[i].funcs;
        if (memEQ(f->name, name, len)) {
            PerlIO_debug("%.*s => %p\n", (int) len, name, f);
            return f;
        }
     }
-    if (load && PL_subname && PerlIO_def_layerlist
-       && PerlIO_def_layerlist->cur >= 2) {
+    if (load && PL_subname && PL_def_layerlist
+       && PL_def_layerlist->cur >= 2) {
        SV *pkgsv = newSVpvn("PerlIO", 6);
        SV *layer = newSVpvn(name, len);
        ENTER;
@@ -742,9 +747,9 @@ XS(XS_PerlIO__Layer__find)
 void
 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 {
-    if (!PerlIO_known_layers)
-       PerlIO_known_layers = PerlIO_list_alloc();
-    PerlIO_list_push(PerlIO_known_layers, tab, Nullsv);
+    if (!PL_known_layers)
+       PL_known_layers = PerlIO_list_alloc(aTHX);
+    PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
     PerlIO_debug("define %s %p\n", tab->name, tab);
 }
 
@@ -819,7 +824,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                    PerlIO_funcs *layer =
                        PerlIO_find_layer(aTHX_ s, llen, 1);
                    if (layer) {
-                       PerlIO_list_push(av, layer,
+                       PerlIO_list_push(aTHX_ av, layer,
                                         (as) ? newSVpvn(as,
                                                         alen) :
                                         &PL_sv_undef);
@@ -850,7 +855,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
        }
     }
     PerlIO_debug("Pushing %s\n", tab->name);
-    PerlIO_list_push(av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
+    PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
                     &PL_sv_undef);
 }
 
@@ -876,10 +881,10 @@ PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
 PerlIO_list_t *
 PerlIO_default_layers(pTHX)
 {
-    if (!PerlIO_def_layerlist) {
+    if (!PL_def_layerlist) {
        const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
        PerlIO_funcs *osLayer = &PerlIO_unix;
-       PerlIO_def_layerlist = PerlIO_list_alloc();
+       PL_def_layerlist = PerlIO_list_alloc(aTHX);
        PerlIO_define_layer(aTHX_ & PerlIO_unix);
 #if defined(WIN32) && !defined(UNDER_CE)
        PerlIO_define_layer(aTHX_ & PerlIO_win32);
@@ -896,20 +901,20 @@ PerlIO_default_layers(pTHX)
 #endif
        PerlIO_define_layer(aTHX_ & PerlIO_utf8);
        PerlIO_define_layer(aTHX_ & PerlIO_byte);
-       PerlIO_list_push(PerlIO_def_layerlist,
+       PerlIO_list_push(aTHX_ PL_def_layerlist,
                         PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
                         &PL_sv_undef);
        if (s) {
-           PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist, s);
+           PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
        }
        else {
-           PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
+           PerlIO_default_buffer(aTHX_ PL_def_layerlist);
        }
     }
-    if (PerlIO_def_layerlist->cur < 2) {
-       PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
+    if (PL_def_layerlist->cur < 2) {
+       PerlIO_default_buffer(aTHX_ PL_def_layerlist);
     }
-    return PerlIO_def_layerlist;
+    return PL_def_layerlist;
 }
 
 void
@@ -949,7 +954,7 @@ PerlIO *
 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
 {
     PerlIOl *l = NULL;
-    l = PerlMemShared_calloc(tab->size, sizeof(char));
+    Newc('L',l,tab->size,char,PerlIOl);
     if (l) {
        Zero(l, tab->size, char);
        l->next = *f;
@@ -1035,12 +1040,12 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 {
     int code = 0;
     if (names) {
-       PerlIO_list_t *layers = PerlIO_list_alloc();
+       PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
        code = PerlIO_parse_layers(aTHX_ layers, names);
        if (code == 0) {
            code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
        }
-       PerlIO_list_free(layers);
+       PerlIO_list_free(aTHX_ layers);
     }
     return code;
 }
@@ -1179,8 +1184,8 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
        if (SvROK(arg) && !sv_isobject(arg)) {
            PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
            if (handler) {
-               def = PerlIO_list_alloc();
-               PerlIO_list_push(def, handler, &PL_sv_undef);
+               def = PerlIO_list_alloc(aTHX);
+               PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
                incdef = 0;
            }
            /*
@@ -1196,9 +1201,9 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
        PerlIO_list_t *av;
        if (incdef) {
            IV i = def->cur;
-           av = PerlIO_list_alloc();
+           av = PerlIO_list_alloc(aTHX);
            for (i = 0; i < def->cur; i++) {
-               PerlIO_list_push(av, def->array[i].funcs,
+               PerlIO_list_push(aTHX_ av, def->array[i].funcs,
                                 def->array[i].arg);
            }
        }
@@ -1237,12 +1242,12 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
             * yet
             */
            PerlIOl *l = *f;
-           layera = PerlIO_list_alloc();
+           layera = PerlIO_list_alloc(aTHX);
            while (l) {
                SV *arg =
                    (l->tab->Getarg) ? (*l->tab->
                                        Getarg) (&l) : &PL_sv_undef;
-               PerlIO_list_push(layera, l->tab, arg);
+               PerlIO_list_push(aTHX_ layera, l->tab, arg);
                l = *PerlIONext(&l);
            }
        }
@@ -1283,7 +1288,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
                }
            }
        }
-       PerlIO_list_free(layera);
+       PerlIO_list_free(aTHX_ layera);
     }
     return f;
 }
@@ -3076,7 +3081,7 @@ PerlIOBuf_close(PerlIO *f)
     IV code = PerlIOBase_close(f);
     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
-       safefree(b->buf);
+       Safefree(b->buf);
     }
     b->buf = NULL;
     b->ptr = b->end = b->buf;
@@ -3226,7 +3231,7 @@ PerlIOPending_flush(PerlIO *f)
     dTHX;
     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
-       PerlMemShared_free(b->buf);
+       Safefree(b->buf);
        b->buf = NULL;
     }
     PerlIO_pop(aTHX_ f);
@@ -3914,17 +3919,9 @@ PerlIO_funcs PerlIO_mmap = {
 #endif                         /* HAS_MMAP */
 
 void
-PerlIO_init(void)
+PerlIO_init(pTHX)
 {
-    dTHX;
-#ifndef WIN32
-    call_atexit(PerlIO_cleanup_layers, NULL);
-#endif
-    if (!PL_perlio) {
-#ifndef WIN32
-       atexit(&PerlIO_cleanup);
-#endif
-    }
+ /* Place holder for stdstreams call ??? */
 }
 
 #undef PerlIO_stdin

diff --git a/perlio.h b/perlio.h
index 7fa171b..381367d 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -93,7 +93,7 @@ extern PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name, STRLEN len,
 extern PerlIO *PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab,
                           const char *mode, SV *arg);
 extern void PerlIO_pop(pTHX_ PerlIO *f);
-extern void PerlIO_clone(pTHX_ PerlIO *proto, CLONE_PARAMS *param);
+extern void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param);
 
 #endif                         /* PerlIO */
 
@@ -185,7 +185,7 @@ START_EXTERN_C
 #endif
 #endif
 #ifndef PerlIO_init
-extern void PerlIO_init(void);
+extern void PerlIO_init(pTHX);
 #endif
 #ifndef PerlIO_stdoutf
 extern int PerlIO_stdoutf(const char *, ...)
@@ -349,11 +349,12 @@ extern void PerlIO_destruct(pTHX);
 
 extern int PerlIO_intmode2str(int rawmode, char *mode, int *writing);
 
-#ifndef PERLIO_IS_STDIO
-
-extern void PerlIO_cleanup(void);
+#ifdef PERLIO_LAYERS
+extern void PerlIO_cleanup(pTHX);
 
 extern void PerlIO_debug(const char *fmt, ...);
+typedef struct PerlIO_list_s PerlIO_list_t;
+
 
 #endif
 

diff --git a/perliol.h b/perliol.h
index 8f9e0ea..c14e823 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -6,12 +6,12 @@ typedef struct {
     SV *arg;
 } PerlIO_pair_t;
 
-typedef struct {
+struct PerlIO_list_s {
     IV refcnt;
     IV cur;
     IV len;
     PerlIO_pair_t *array;
-} PerlIO_list_t;
+};
 
 struct _PerlIO_funcs {
     char *name;

diff --git a/sv.c b/sv.c
index 3ab9f05..6a6c33b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -9768,8 +9768,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     param->stashes      = newAV();  /* Setup array of objects to call clone on */
 
 #ifdef PERLIO_LAYERS
-    /* Clone PerlIO table as soon as we can handle general xx_dup() */
-    PerlIO_clone(aTHX_ proto_perl->Iperlio, param);
+    /* Clone PerlIO tables as soon as we can handle general xx_dup() */
+    PerlIO_clone(aTHX_ proto_perl, param);
 #endif
 
     PL_envgv           = gv_dup(proto_perl->Ienvgv, param);