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

8 files changed, 103 insertions, 88 deletions

diff --git a/embedvar.h b/embedvar.h
index 066bec428c..2eb540791e 100644
--- 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 b6b4f07388..c224ff7c5d 100644
--- 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 9eaa7b7b1f..3a11219227 100644
--- 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 ffe9741047..2811a44650 100644
--- 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 793a4e8637..0de282934f 100644
--- 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 7fa171ba28..381367d1dc 100644
--- 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 8f9e0ea74d..c14e823efe 100644
--- 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 3ab9f057f2..6a6c33bc30 100644
--- 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);