diff options
| -rw-r--r-- | embed.h | 34 | ||||
| -rwxr-xr-x | embed.pl | 24 | ||||
| -rw-r--r-- | embedvar.h | 6 | ||||
| -rw-r--r-- | global.sym | 10 | ||||
| -rw-r--r-- | intrpvar.h | 2 | ||||
| -rw-r--r-- | makedef.pl | 12 | ||||
| -rw-r--r-- | objXSUB.h | 40 | ||||
| -rw-r--r-- | perl.h | 20 | ||||
| -rw-r--r-- | perlapi.c | 44 | ||||
| -rw-r--r-- | proto.h | 20 | ||||
| -rw-r--r-- | sv.c | 211 | ||||
| -rw-r--r-- | win32/perllib.c | 2 |
12 files changed, 276 insertions, 149 deletions
@@ -774,10 +774,10 @@ #if defined(HAVE_INTERP_INTERN) #define sys_intern_dup Perl_sys_intern_dup #endif -#define sv_table_new Perl_sv_table_new -#define sv_table_fetch Perl_sv_table_fetch -#define sv_table_store Perl_sv_table_store -#define sv_table_split Perl_sv_table_split +#define ptr_table_new Perl_ptr_table_new +#define ptr_table_fetch Perl_ptr_table_fetch +#define ptr_table_store Perl_ptr_table_store +#define ptr_table_split Perl_ptr_table_split #endif #if defined(PERL_OBJECT) #endif @@ -2142,10 +2142,10 @@ #if defined(HAVE_INTERP_INTERN) #define sys_intern_dup(a,b) Perl_sys_intern_dup(aTHX_ a,b) #endif -#define sv_table_new() Perl_sv_table_new(aTHX) -#define sv_table_fetch(a,b) Perl_sv_table_fetch(aTHX_ a,b) -#define sv_table_store(a,b,c) Perl_sv_table_store(aTHX_ a,b,c) -#define sv_table_split(a) Perl_sv_table_split(aTHX_ a) +#define ptr_table_new() Perl_ptr_table_new(aTHX) +#define ptr_table_fetch(a,b) Perl_ptr_table_fetch(aTHX_ a,b) +#define ptr_table_store(a,b,c) Perl_ptr_table_store(aTHX_ a,b,c) +#define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a) #endif #if defined(PERL_OBJECT) #endif @@ -4220,14 +4220,16 @@ #define Perl_sys_intern_dup CPerlObj::Perl_sys_intern_dup #define sys_intern_dup Perl_sys_intern_dup #endif -#define Perl_sv_table_new CPerlObj::Perl_sv_table_new -#define sv_table_new Perl_sv_table_new -#define Perl_sv_table_fetch CPerlObj::Perl_sv_table_fetch -#define sv_table_fetch Perl_sv_table_fetch -#define Perl_sv_table_store CPerlObj::Perl_sv_table_store -#define sv_table_store Perl_sv_table_store -#define Perl_sv_table_split CPerlObj::Perl_sv_table_split -#define sv_table_split Perl_sv_table_split +#define Perl_ptr_table_new CPerlObj::Perl_ptr_table_new +#define ptr_table_new Perl_ptr_table_new +#define Perl_ptr_table_fetch CPerlObj::Perl_ptr_table_fetch +#define ptr_table_fetch Perl_ptr_table_fetch +#define Perl_ptr_table_store CPerlObj::Perl_ptr_table_store +#define ptr_table_store Perl_ptr_table_store +#define Perl_ptr_table_split CPerlObj::Perl_ptr_table_split +#define ptr_table_split Perl_ptr_table_split +#define perl_clone CPerlObj::perl_clone +#define perl_clone_using CPerlObj::perl_clone_using #endif #if defined(PERL_OBJECT) #endif @@ -1451,11 +1451,11 @@ no |int |perl_parse |XSINIT_t xsinit \ |int argc|char** argv|char** env #else no |PerlInterpreter* |perl_alloc -no |void |perl_construct |PerlInterpreter* sv_interp -no |void |perl_destruct |PerlInterpreter* sv_interp -no |void |perl_free |PerlInterpreter* sv_interp -no |int |perl_run |PerlInterpreter* sv_interp -no |int |perl_parse |PerlInterpreter* sv_interp|XSINIT_t xsinit \ +no |void |perl_construct |PerlInterpreter* interp +no |void |perl_destruct |PerlInterpreter* interp +no |void |perl_free |PerlInterpreter* interp +no |int |perl_run |PerlInterpreter* interp +no |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ |int argc|char** argv|char** env #if defined(USE_THREADS) p |struct perl_thread* |new_struct_thread|struct perl_thread *t @@ -1784,10 +1784,16 @@ p |SV* |sv_dup |SV* sstr p |void |sys_intern_dup |struct interp_intern* src \ |struct interp_intern* dst #endif -p |SVTBL* |sv_table_new -p |SV* |sv_table_fetch |SVTBL *tbl|SV *sv -p |void |sv_table_store |SVTBL *tbl|SV *oldsv|SV *newsv -p |void |sv_table_split |SVTBL *tbl +p |PTR_TBL_t*|ptr_table_new +p |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv +p |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv +p |void |ptr_table_split|PTR_TBL_t *tbl +no |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags +no |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ + |struct IPerlMem* m|struct IPerlEnv* e \ + |struct IPerlStdIO* io|struct IPerlLIO* lio \ + |struct IPerlDir* d|struct IPerlSock* s \ + |struct IPerlProc* p #endif #if defined(PERL_OBJECT) diff --git a/embedvar.h b/embedvar.h index 566483b383..610f266db2 100644 --- a/embedvar.h +++ b/embedvar.h @@ -350,6 +350,7 @@ #define PL_preambled (PERL_GET_INTERP->Ipreambled) #define PL_preprocess (PERL_GET_INTERP->Ipreprocess) #define PL_profiledata (PERL_GET_INTERP->Iprofiledata) +#define PL_ptr_table (PERL_GET_INTERP->Iptr_table) #define PL_replgv (PERL_GET_INTERP->Ireplgv) #define PL_rsfp (PERL_GET_INTERP->Irsfp) #define PL_rsfp_filters (PERL_GET_INTERP->Irsfp_filters) @@ -376,7 +377,6 @@ #define PL_sv_no (PERL_GET_INTERP->Isv_no) #define PL_sv_objcount (PERL_GET_INTERP->Isv_objcount) #define PL_sv_root (PERL_GET_INTERP->Isv_root) -#define PL_sv_table (PERL_GET_INTERP->Isv_table) #define PL_sv_undef (PERL_GET_INTERP->Isv_undef) #define PL_sv_yes (PERL_GET_INTERP->Isv_yes) #define PL_svref_mutex (PERL_GET_INTERP->Isvref_mutex) @@ -611,6 +611,7 @@ #define PL_preambled (vTHX->Ipreambled) #define PL_preprocess (vTHX->Ipreprocess) #define PL_profiledata (vTHX->Iprofiledata) +#define PL_ptr_table (vTHX->Iptr_table) #define PL_replgv (vTHX->Ireplgv) #define PL_rsfp (vTHX->Irsfp) #define PL_rsfp_filters (vTHX->Irsfp_filters) @@ -637,7 +638,6 @@ #define PL_sv_no (vTHX->Isv_no) #define PL_sv_objcount (vTHX->Isv_objcount) #define PL_sv_root (vTHX->Isv_root) -#define PL_sv_table (vTHX->Isv_table) #define PL_sv_undef (vTHX->Isv_undef) #define PL_sv_yes (vTHX->Isv_yes) #define PL_svref_mutex (vTHX->Isvref_mutex) @@ -874,6 +874,7 @@ #define PL_Ipreambled PL_preambled #define PL_Ipreprocess PL_preprocess #define PL_Iprofiledata PL_profiledata +#define PL_Iptr_table PL_ptr_table #define PL_Ireplgv PL_replgv #define PL_Irsfp PL_rsfp #define PL_Irsfp_filters PL_rsfp_filters @@ -900,7 +901,6 @@ #define PL_Isv_no PL_sv_no #define PL_Isv_objcount PL_sv_objcount #define PL_Isv_root PL_sv_root -#define PL_Isv_table PL_sv_table #define PL_Isv_undef PL_sv_undef #define PL_Isv_yes PL_sv_yes #define PL_Isvref_mutex PL_svref_mutex diff --git a/global.sym b/global.sym index b6596b6d79..d15142263d 100644 --- a/global.sym +++ b/global.sym @@ -683,7 +683,9 @@ Perl_gp_dup Perl_mg_dup Perl_sv_dup Perl_sys_intern_dup -Perl_sv_table_new -Perl_sv_table_fetch -Perl_sv_table_store -Perl_sv_table_split +Perl_ptr_table_new +Perl_ptr_table_fetch +Perl_ptr_table_store +Perl_ptr_table_split +perl_clone +perl_clone_using diff --git a/intrpvar.h b/intrpvar.h index 0e2390504d..c772d797ec 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -380,5 +380,5 @@ PERLVAR(IProc, struct IPerlProc*) #endif #if defined(USE_ITHREADS) -PERLVAR(Isv_table, SVTBL*) +PERLVAR(Iptr_table, PTR_TBL_t*) #endif diff --git a/makedef.pl b/makedef.pl index d9e369a2b3..428bfc38b4 100644 --- a/makedef.pl +++ b/makedef.pl @@ -367,7 +367,7 @@ Perl_magic_mutexfree unless ($define{'USE_ITHREADS'}) { skip_symbols [qw( -PL_sv_table +PL_ptr_table Perl_dirp_dup Perl_fp_dup Perl_gp_dup @@ -376,10 +376,12 @@ Perl_mg_dup Perl_re_dup Perl_sv_dup Perl_sys_intern_dup -Perl_sv_table_fetch -Perl_sv_table_new -Perl_sv_table_split -Perl_sv_table_store +Perl_ptr_table_fetch +Perl_ptr_table_new +Perl_ptr_table_split +Perl_ptr_table_store +perl_clone +perl_clone_using )]; } @@ -366,6 +366,8 @@ #define PL_preprocess (*Perl_Ipreprocess_ptr(aTHXo)) #undef PL_profiledata #define PL_profiledata (*Perl_Iprofiledata_ptr(aTHXo)) +#undef PL_ptr_table +#define PL_ptr_table (*Perl_Iptr_table_ptr(aTHXo)) #undef PL_replgv #define PL_replgv (*Perl_Ireplgv_ptr(aTHXo)) #undef PL_rsfp @@ -418,8 +420,6 @@ #define PL_sv_objcount (*Perl_Isv_objcount_ptr(aTHXo)) #undef PL_sv_root #define PL_sv_root (*Perl_Isv_root_ptr(aTHXo)) -#undef PL_sv_table -#define PL_sv_table (*Perl_Isv_table_ptr(aTHXo)) #undef PL_sv_undef #define PL_sv_undef (*Perl_Isv_undef_ptr(aTHXo)) #undef PL_sv_yes @@ -3568,22 +3568,26 @@ #undef sys_intern_dup #define sys_intern_dup Perl_sys_intern_dup #endif -#undef Perl_sv_table_new -#define Perl_sv_table_new pPerl->Perl_sv_table_new -#undef sv_table_new -#define sv_table_new Perl_sv_table_new -#undef Perl_sv_table_fetch -#define Perl_sv_table_fetch pPerl->Perl_sv_table_fetch -#undef sv_table_fetch -#define sv_table_fetch Perl_sv_table_fetch -#undef Perl_sv_table_store -#define Perl_sv_table_store pPerl->Perl_sv_table_store -#undef sv_table_store -#define sv_table_store Perl_sv_table_store -#undef Perl_sv_table_split -#define Perl_sv_table_split pPerl->Perl_sv_table_split -#undef sv_table_split -#define sv_table_split Perl_sv_table_split +#undef Perl_ptr_table_new +#define Perl_ptr_table_new pPerl->Perl_ptr_table_new +#undef ptr_table_new +#define ptr_table_new Perl_ptr_table_new +#undef Perl_ptr_table_fetch +#define Perl_ptr_table_fetch pPerl->Perl_ptr_table_fetch +#undef ptr_table_fetch +#define ptr_table_fetch Perl_ptr_table_fetch +#undef Perl_ptr_table_store +#define Perl_ptr_table_store pPerl->Perl_ptr_table_store +#undef ptr_table_store +#define ptr_table_store Perl_ptr_table_store +#undef Perl_ptr_table_split +#define Perl_ptr_table_split pPerl->Perl_ptr_table_split +#undef ptr_table_split +#define ptr_table_split Perl_ptr_table_split +#undef perl_clone +#define perl_clone pPerl->perl_clone +#undef perl_clone_using +#define perl_clone_using pPerl->perl_clone_using #endif #if defined(PERL_OBJECT) #endif @@ -1322,8 +1322,8 @@ typedef struct xpvfm XPVFM; typedef struct xpvio XPVIO; typedef struct mgvtbl MGVTBL; typedef union any ANY; -typedef struct svtblent SVTBLENT; -typedef struct svtbl SVTBL; +typedef struct ptr_tbl_ent PTR_TBL_ENT_t; +typedef struct ptr_tbl PTR_TBL_t; #include "handy.h" @@ -1754,16 +1754,16 @@ struct scan_data_t; /* Used in S_* functions in regcomp.c */ typedef I32 CHECKPOINT; -struct svtblent { - struct svtblent* next; - SV* oldval; - SV* newval; +struct ptr_tbl_ent { + struct ptr_tbl_ent* next; + void* oldval; + void* newval; }; -struct svtbl { - struct svtblent** tbl_ary; - UV tbl_max; - UV tbl_items; +struct ptr_tbl { + struct ptr_tbl_ent** tbl_ary; + UV tbl_max; + UV tbl_items; }; #if defined(iAPX286) || defined(M_I286) || defined(I80286) @@ -4915,32 +4915,48 @@ Perl_sys_intern_dup(pTHXo_ struct interp_intern* src, struct interp_intern* dst) } #endif -#undef Perl_sv_table_new -SVTBL* -Perl_sv_table_new(pTHXo) +#undef Perl_ptr_table_new +PTR_TBL_t* +Perl_ptr_table_new(pTHXo) { - return ((CPerlObj*)pPerl)->Perl_sv_table_new(); + return ((CPerlObj*)pPerl)->Perl_ptr_table_new(); } -#undef Perl_sv_table_fetch -SV* -Perl_sv_table_fetch(pTHXo_ SVTBL *tbl, SV *sv) +#undef Perl_ptr_table_fetch +void* +Perl_ptr_table_fetch(pTHXo_ PTR_TBL_t *tbl, void *sv) { - return ((CPerlObj*)pPerl)->Perl_sv_table_fetch(tbl, sv); + return ((CPerlObj*)pPerl)->Perl_ptr_table_fetch(tbl, sv); } -#undef Perl_sv_table_store +#undef Perl_ptr_table_store void -Perl_sv_table_store(pTHXo_ SVTBL *tbl, SV *oldsv, SV *newsv) +Perl_ptr_table_store(pTHXo_ PTR_TBL_t *tbl, void *oldsv, void *newsv) { - ((CPerlObj*)pPerl)->Perl_sv_table_store(tbl, oldsv, newsv); + ((CPerlObj*)pPerl)->Perl_ptr_table_store(tbl, oldsv, newsv); } -#undef Perl_sv_table_split +#undef Perl_ptr_table_split void -Perl_sv_table_split(pTHXo_ SVTBL *tbl) +Perl_ptr_table_split(pTHXo_ PTR_TBL_t *tbl) +{ + ((CPerlObj*)pPerl)->Perl_ptr_table_split(tbl); +} + +#undef perl_clone +PerlInterpreter* +perl_clone(PerlInterpreter* interp, UV flags) { - ((CPerlObj*)pPerl)->Perl_sv_table_split(tbl); + dTHXo; + return ((CPerlObj*)pPerl)->perl_clone(flags); +} + +#undef perl_clone_using +PerlInterpreter* +perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p) +{ + dTHXo; + return ((CPerlObj*)pPerl)->perl_clone_using(interp, flags, m, e, io, lio, d, s, p); } #endif #if defined(PERL_OBJECT) @@ -440,11 +440,11 @@ PERL_CALLCONV int perl_run(void); PERL_CALLCONV int perl_parse(XSINIT_t xsinit, int argc, char** argv, char** env); #else PERL_CALLCONV PerlInterpreter* perl_alloc(void); -PERL_CALLCONV void perl_construct(PerlInterpreter* sv_interp); -PERL_CALLCONV void perl_destruct(PerlInterpreter* sv_interp); -PERL_CALLCONV void perl_free(PerlInterpreter* sv_interp); -PERL_CALLCONV int perl_run(PerlInterpreter* sv_interp); -PERL_CALLCONV int perl_parse(PerlInterpreter* sv_interp, XSINIT_t xsinit, int argc, char** argv, char** env); +PERL_CALLCONV void perl_construct(PerlInterpreter* interp); +PERL_CALLCONV void perl_destruct(PerlInterpreter* interp); +PERL_CALLCONV void perl_free(PerlInterpreter* interp); +PERL_CALLCONV int perl_run(PerlInterpreter* interp); +PERL_CALLCONV int perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env); #if defined(USE_THREADS) PERL_CALLCONV struct perl_thread* Perl_new_struct_thread(pTHX_ struct perl_thread *t); #endif @@ -749,10 +749,12 @@ PERL_CALLCONV SV* Perl_sv_dup(pTHX_ SV* sstr); #if defined(HAVE_INTERP_INTERN) PERL_CALLCONV void Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst); #endif -PERL_CALLCONV SVTBL* Perl_sv_table_new(pTHX); -PERL_CALLCONV SV* Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv); -PERL_CALLCONV void Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *oldsv, SV *newsv); -PERL_CALLCONV void Perl_sv_table_split(pTHX_ SVTBL *tbl); +PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX); +PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv); +PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv); +PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl); +PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags); +PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p); #endif #if defined(PERL_OBJECT) protected: @@ -5665,13 +5665,13 @@ Perl_gp_dup(pTHX_ GP *gp) if (!gp) return (GP*)NULL; /* look for it in the table first */ - ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp); + ret = ptr_table_fetch(PL_ptr_table, gp); if (ret) return ret; /* create anew and remember what it is */ Newz(0, ret, 1, GP); - sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret); + ptr_table_store(PL_ptr_table, gp, ret); /* clone */ ret->gp_refcnt = 0; /* must be before any other dups! */ @@ -5739,21 +5739,21 @@ Perl_mg_dup(pTHX_ MAGIC *mg) return mgret; } -SVTBL * -Perl_sv_table_new(pTHX) +PTR_TBL_t * +Perl_ptr_table_new(pTHX) { - SVTBL *tbl; - Newz(0, tbl, 1, SVTBL); + PTR_TBL_t *tbl; + Newz(0, tbl, 1, PTR_TBL_t); tbl->tbl_max = 511; tbl->tbl_items = 0; - Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*); + Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); return tbl; } -SV * -Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv) +void * +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) { - SVTBLENT *tblent; + PTR_TBL_ENT_t *tblent; UV hash = (UV)sv; assert(tbl); tblent = tbl->tbl_ary[hash & tbl->tbl_max]; @@ -5761,15 +5761,19 @@ Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv) if (tblent->oldval == sv) return tblent->newval; } - return Nullsv; + return (void*)NULL; } void -Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *old, void *new) { - SVTBLENT *tblent, **otblent; + PTR_TBL_ENT_t *tblent, **otblent; + /* XXX this may be pessimal on platforms where pointers aren't good + * hash values e.g. if they grow faster in the most significant + * bits */ UV hash = (UV)old; bool i = 1; + assert(tbl); otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; for (tblent = *otblent; tblent; i=0, tblent = tblent->next) { @@ -5779,30 +5783,30 @@ Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new) return; } } - Newz(0, tblent, 1, SVTBLENT); + Newz(0, tblent, 1, PTR_TBL_ENT_t); tblent->oldval = old; tblent->newval = new; tblent->next = *otblent; *otblent = tblent; tbl->tbl_items++; if (i && tbl->tbl_items > tbl->tbl_max) - sv_table_split(tbl); + ptr_table_split(tbl); } void -Perl_sv_table_split(pTHX_ SVTBL *tbl) +Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) { - SVTBLENT **ary = tbl->tbl_ary; + PTR_TBL_ENT_t **ary = tbl->tbl_ary; UV oldsize = tbl->tbl_max + 1; UV newsize = oldsize * 2; UV i; - Renew(ary, newsize, SVTBLENT*); - Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*); + Renew(ary, newsize, PTR_TBL_ENT_t*); + Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); tbl->tbl_max = --newsize; tbl->tbl_ary = ary; for (i=0; i < oldsize; i++, ary++) { - SVTBLENT **curentp, **entp, *ent; + PTR_TBL_ENT_t **curentp, **entp, *ent; if (!*ary) continue; curentp = ary + oldsize; @@ -5834,7 +5838,7 @@ Perl_sv_dup(pTHX_ SV *sstr) if (!sstr || SvTYPE(sstr) == SVTYPEMASK) return Nullsv; /* look for it in the table first */ - dstr = sv_table_fetch(PL_sv_table, sstr); + dstr = ptr_table_fetch(PL_ptr_table, sstr); if (dstr) return dstr; @@ -5842,7 +5846,7 @@ Perl_sv_dup(pTHX_ SV *sstr) /* create anew and remember what it is */ new_SV(dstr); - sv_table_store(PL_sv_table, sstr, dstr); + ptr_table_store(PL_ptr_table, sstr, dstr); /* clone */ SvFLAGS(dstr) = SvFLAGS(sstr); @@ -6148,7 +6152,7 @@ dup_pvcv: } PerlInterpreter * -perl_clone_using(PerlInterpreter *proto_perl, IV flags, +perl_clone_using(PerlInterpreter *proto_perl, UV flags, struct IPerlMem* ipM, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, @@ -6161,12 +6165,13 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PERL_SET_INTERP(my_perl); #ifdef DEBUGGING - memset(my_perl, 0x0, sizeof(PerlInterpreter)); + memset(my_perl, 0xab, sizeof(PerlInterpreter)); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; PL_retstack = 0; #else + Zero(my_perl, 1, PerlInterpreter); # if 0 Copy(proto_perl, my_perl, 1, PerlInterpreter); # endif @@ -6210,13 +6215,13 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_debug = proto_perl->Idebug; /* create SV map for pointer relocation */ - PL_sv_table = sv_table_new(); + PL_ptr_table = ptr_table_new(); /* initialize these special pointers as early as possible */ SvANY(&PL_sv_undef) = NULL; SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; - sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); SvANY(&PL_sv_no) = new_XPVNV(); SvREFCNT(&PL_sv_no) = (~(U32)0)/2; @@ -6225,7 +6230,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, SvCUR(&PL_sv_no) = 0; SvLEN(&PL_sv_no) = 1; SvNVX(&PL_sv_no) = 0; - sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); SvANY(&PL_sv_yes) = new_XPVNV(); SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; @@ -6234,13 +6239,13 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, SvCUR(&PL_sv_yes) = 1; SvLEN(&PL_sv_yes) = 2; SvNVX(&PL_sv_yes) = 1; - sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); /* create shared string table */ PL_strtab = newHV(); HvSHAREKEYS_off(PL_strtab); hv_ksplit(PL_strtab, 512); - sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab); + ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); PL_compiling = proto_perl->Icompiling; PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv); @@ -6289,7 +6294,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_perl_destruct_level = proto_perl->Iperl_destruct_level; /* magical thingies */ - /* XXX time(&PL_basetime) instead? */ + /* XXX time(&PL_basetime) when asked for? */ PL_basetime = proto_perl->Ibasetime; PL_formfeed = sv_dup(proto_perl->Iformfeed); @@ -6360,12 +6365,15 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_eval_start = proto_perl->Ieval_start; /* runtime control stuff */ - PL_curcopdb = proto_perl->Icurcopdb; + if (proto_perl->Icurcopdb == &proto_perl->Icompiling) + PL_curcopdb = &PL_compiling; + else + PL_curcopdb = proto_perl->Icurcopdb; PL_copline = proto_perl->Icopline; PL_filemode = proto_perl->Ifilemode; PL_lastfd = proto_perl->Ilastfd; - PL_oldname = proto_perl->Ioldname; /* XXX */ + PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ PL_Argv = NULL; PL_Cmd = Nullch; PL_gensym = proto_perl->Igensym; @@ -6389,9 +6397,9 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_exitlist = (PerlExitListEntry*)NULL; PL_modglobal = hv_dup_inc(proto_perl->Imodglobal); - PL_profiledata = NULL; /* XXX */ + PL_profiledata = NULL; PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); - /* XXX PL_rsfp_filters entries have fake IoDIRP() */ + /* PL_rsfp_filters entries have fake IoDIRP() */ PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters); PL_compcv = cv_dup(proto_perl->Icompcv); @@ -6422,9 +6430,9 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_cop_seqmax = proto_perl->Icop_seqmax; PL_op_seqmax = proto_perl->Iop_seqmax; PL_evalseq = proto_perl->Ievalseq; - PL_origenviron = proto_perl->Iorigenviron; /* XXX */ + PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ PL_origalen = proto_perl->Iorigalen; - PL_pidstatus = newHV(); + PL_pidstatus = newHV(); /* XXX flag for cloning? */ PL_osname = SAVEPV(proto_perl->Iosname); PL_sh_path = SAVEPV(proto_perl->Ish_path); PL_sighandlerp = proto_perl->Isighandlerp; @@ -6432,7 +6440,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_runops = proto_perl->Irunops; - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */ + Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); #ifdef CSH PL_cshlen = proto_perl->Icshlen; @@ -6446,8 +6454,8 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_lex_fakebrack = proto_perl->Ilex_fakebrack; PL_lex_dojoin = proto_perl->Ilex_dojoin; PL_lex_starts = proto_perl->Ilex_starts; - PL_lex_stuff = Nullsv; /* XXX */ - PL_lex_repl = Nullsv; /* XXX */ + PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff); + PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl); PL_lex_op = proto_perl->Ilex_op; PL_lex_inpat = proto_perl->Ilex_inpat; PL_lex_inwhat = proto_perl->Ilex_inwhat; @@ -6473,7 +6481,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); PL_pending_ident = proto_perl->Ipending_ident; - PL_sublex_info = proto_perl->Isublex_info; /* XXX */ + PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ PL_expect = proto_perl->Iexpect; @@ -6542,7 +6550,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower); /* swatch cache */ - PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */ + PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0; PL_last_swash_key[0]= '\0'; PL_last_swash_tmps = Nullch; @@ -6558,8 +6566,8 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; - PL_uudmap['M'] = 0; /* reinit on demand */ - PL_bitcount = Nullch; /* reinit on demand */ + PL_uudmap['M'] = 0; /* reinits on demand */ + PL_bitcount = Nullch; /* reinits on demand */ /* thrdvar.h stuff */ @@ -6567,10 +6575,44 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, /* PL_curstackinfo = clone_stackinfo(proto_perl->Tcurstackinfo); clone_stacks(); PL_mainstack = av_dup(proto_perl->Tmainstack); - PL_curstack = av_dup(proto_perl->Tcurstack);*/ /* XXXXXX */ + PL_curstack = av_dup(proto_perl->Tcurstack); + + PL_stack_max = (SV**)0; + PL_stack_base = (SV**)0; + PL_stack_sp = (SV**)0; + + PL_scopestack = (I32*)0; + PL_scopestack_ix = (I32)0; + PL_scopestack_max = (I32)0; + + PL_savestack = (ANY*)0; + PL_savestack_ix = (I32)0; + PL_savestack_max = (I32)0; + + PL_tmps_stack = (SV**)0; + PL_tmps_ix = (I32)-1; + PL_tmps_floor = (I32)-1; + PL_tmps_max = (I32)0; + + PL_markstack = (I32*)0; + PL_markstack_ptr = (I32*)0; + PL_markstack_max = (I32*)0; + + PL_retstack = (OP**)0; + PL_retstack_ix = (I32)0; + PL_retstack_max = (I32)0; +*/ /* XXXXXX */ init_stacks(); + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; + PL_op = proto_perl->Top; + + PL_Sv = Nullsv; + PL_Xpv = (XPV*)NULL; + PL_na = proto_perl->Tna; + PL_statbuf = proto_perl->Tstatbuf; PL_statcache = proto_perl->Tstatcache; PL_statgv = gv_dup(proto_perl->Tstatgv); @@ -6587,7 +6629,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_ofslen = proto_perl->Tofslen; PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen); PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv); - PL_chopset = proto_perl->Tchopset; /* XXX */ + PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget); PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget); PL_formtarget = sv_dup(proto_perl->Tformtarget); @@ -6598,8 +6640,6 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_dirty = proto_perl->Tdirty; PL_localizing = proto_perl->Tlocalizing; - PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ - PL_top_env = &PL_start_env; PL_protect = proto_perl->Tprotect; PL_errors = sv_dup_inc(proto_perl->Terrors); PL_av_fetch_sv = Nullsv; @@ -6608,18 +6648,79 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_modcount = proto_perl->Tmodcount; PL_lastgotoprobe = Nullop; PL_dumpindent = proto_perl->Tdumpindent; + + if (proto_perl->Tsortcop == (OP*)&proto_perl->Icompiling) + PL_sortcop = (OP*)&PL_compiling; + else + PL_sortcop = proto_perl->Tsortcop; PL_sortstash = hv_dup(proto_perl->Tsortstash); PL_firstgv = gv_dup(proto_perl->Tfirstgv); PL_secondgv = gv_dup(proto_perl->Tsecondgv); PL_sortcxix = proto_perl->Tsortcxix; - PL_efloatbuf = Nullch; - PL_efloatsize = 0; + PL_efloatbuf = Nullch; /* reinits on demand */ + PL_efloatsize = 0; /* reinits on demand */ + + /* regex stuff */ PL_screamfirst = NULL; PL_screamnext = NULL; - PL_maxscream = -1; + PL_maxscream = -1; /* reinits on demand */ PL_lastscream = Nullsv; + PL_watchaddr = NULL; + PL_watchok = Nullch; + + PL_regdummy = proto_perl->Tregdummy; + PL_regcomp_parse = Nullch; + PL_regxend = Nullch; + PL_regcode = (regnode*)NULL; + PL_regnaughty = 0; + PL_regsawback = 0; + PL_regprecomp = Nullch; + PL_regnpar = 0; + PL_regsize = 0; + PL_regflags = 0; + PL_regseen = 0; + PL_seen_zerolen = 0; + PL_seen_evals = 0; + PL_regcomp_rx = (regexp*)NULL; + PL_extralen = 0; + PL_colorset = 0; /* reinits PL_colors[] */ + /*PL_colors[6] = {0,0,0,0,0,0};*/ + PL_reg_whilem_seen = 0; + PL_reginput = Nullch; + PL_regbol = Nullch; + PL_regeol = Nullch; + PL_regstartp = (I32*)NULL; + PL_regendp = (I32*)NULL; + PL_reglastparen = (U32*)NULL; + PL_regtill = Nullch; + PL_regprev = '\n'; + PL_reg_start_tmp = (char**)NULL; + PL_reg_start_tmpl = 0; + PL_regdata = (struct reg_data*)NULL; + PL_bostr = Nullch; + PL_reg_flags = 0; + PL_reg_eval_set = 0; + PL_regnarrate = 0; + PL_regprogram = (regnode*)NULL; + PL_regindent = 0; + PL_regcc = (CURCUR*)NULL; + PL_reg_call_cc = (struct re_cc_state*)NULL; + PL_reg_re = (regexp*)NULL; + PL_reg_ganch = Nullch; + PL_reg_sv = Nullsv; + PL_reg_magic = (MAGIC*)NULL; + PL_reg_oldpos = 0; + PL_reg_oldcurpm = (PMOP*)NULL; + PL_reg_curpm = (PMOP*)NULL; + PL_reg_oldsaved = Nullch; + PL_reg_oldsavedlen = 0; + PL_reg_maxiter = 0; + PL_reg_leftiter = 0; + PL_reg_poscache = Nullch; + PL_reg_poscache_size= 0; + /* RE engine - function pointers */ PL_regcompp = proto_perl->Tregcompp; PL_regexecp = proto_perl->Tregexecp; @@ -6627,20 +6728,14 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_regint_string = proto_perl->Tregint_string; PL_regfree = proto_perl->Tregfree; - PL_regindent = 0; PL_reginterp_cnt = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - PL_reg_poscache = Nullch; - - PL_watchaddr = NULL; - PL_watchok = Nullch; + PL_reg_starttry = 0; return my_perl; } PerlInterpreter * -perl_clone(pTHXx_ IV flags) +perl_clone(pTHXx_ UV flags) { return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO, PL_Dir, PL_Sock, PL_Proc); diff --git a/win32/perllib.c b/win32/perllib.c index 2b4d778914..9cd542b9df 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -1564,8 +1564,6 @@ RunPerl(int argc, char **argv, char **env) exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { #ifdef USE_ITHREADS /* XXXXXX testing */ - extern PerlInterpreter * perl_clone(pTHXx_ IV flags); - new_perl = perl_clone(my_perl, 0); Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */ exitstatus = perl_run( new_perl ); |