Permalink
Browse files

preliminary support for perl_clone() (still needs work in

the following areas: SVOPs must indirect via pad; context
stack, scope stack, and runlevels must be cloned; must
hook up the virtualized pseudo-process support provided by
"host"; ...)

p4raw-id: //depot/perl@4538
  • Loading branch information...
Gurusamy Sarathy
Gurusamy Sarathy committed Nov 8, 1999
1 parent 5c831c2 commit d18c61170a30691556a1da7413e13241a92f4e0a
Showing with 1,361 additions and 24 deletions.
  1. +1 −1 av.h
  2. +60 −0 embed.h
  3. +17 −0 embed.pl
  4. +3 −0 embedvar.h
  5. +12 −0 global.sym
  6. +38 −21 hv.c
  7. +10 −0 hv.h
  8. +4 −0 intrpvar.h
  9. +20 −0 makedef.pl
  10. +54 −0 objXSUB.h
  11. +19 −1 perl.h
  12. +88 −0 perlapi.c
  13. +16 −0 proto.h
  14. +996 −0 sv.c
  15. +8 −0 win32/perllib.c
  16. +15 −1 win32/win32.c
View
2 av.h
@@ -10,7 +10,7 @@
struct xpvav {
char* xav_array; /* pointer to first array element */
SSize_t xav_fill; /* Index of last element present */
- SSize_t xav_max; /* Number of elements for which array has space */
+ SSize_t xav_max; /* max index for which array has space */
IV xof_off; /* ptr is incremented by offset */
NV xnv_nv; /* numeric value, if any */
MAGIC* xmg_magic; /* magic for scalar array */
View
60 embed.h
@@ -762,6 +762,22 @@
#define newMYSUB Perl_newMYSUB
#define my_attrs Perl_my_attrs
#define boot_core_xsutils Perl_boot_core_xsutils
+#if defined(USE_ITHREADS)
+#define he_dup Perl_he_dup
+#define re_dup Perl_re_dup
+#define fp_dup Perl_fp_dup
+#define dirp_dup Perl_dirp_dup
+#define gp_dup Perl_gp_dup
+#define mg_dup Perl_mg_dup
+#define sv_dup Perl_sv_dup
+#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
+#endif
#if defined(PERL_OBJECT)
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
@@ -2113,6 +2129,22 @@
#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
#define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b)
#define boot_core_xsutils() Perl_boot_core_xsutils(aTHX)
+#if defined(USE_ITHREADS)
+#define he_dup(a,b) Perl_he_dup(aTHX_ a,b)
+#define re_dup(a) Perl_re_dup(aTHX_ a)
+#define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b)
+#define dirp_dup(a) Perl_dirp_dup(aTHX_ a)
+#define gp_dup(a) Perl_gp_dup(aTHX_ a)
+#define mg_dup(a) Perl_mg_dup(aTHX_ a)
+#define sv_dup(a) Perl_sv_dup(aTHX_ a)
+#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)
+#endif
#if defined(PERL_OBJECT)
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
@@ -4165,6 +4197,34 @@
#define my_attrs Perl_my_attrs
#define Perl_boot_core_xsutils CPerlObj::Perl_boot_core_xsutils
#define boot_core_xsutils Perl_boot_core_xsutils
+#if defined(USE_ITHREADS)
+#define Perl_he_dup CPerlObj::Perl_he_dup
+#define he_dup Perl_he_dup
+#define Perl_re_dup CPerlObj::Perl_re_dup
+#define re_dup Perl_re_dup
+#define Perl_fp_dup CPerlObj::Perl_fp_dup
+#define fp_dup Perl_fp_dup
+#define Perl_dirp_dup CPerlObj::Perl_dirp_dup
+#define dirp_dup Perl_dirp_dup
+#define Perl_gp_dup CPerlObj::Perl_gp_dup
+#define gp_dup Perl_gp_dup
+#define Perl_mg_dup CPerlObj::Perl_mg_dup
+#define mg_dup Perl_mg_dup
+#define Perl_sv_dup CPerlObj::Perl_sv_dup
+#define sv_dup Perl_sv_dup
+#if defined(HAVE_INTERP_INTERN)
+#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
+#endif
#if defined(PERL_OBJECT)
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
View
@@ -1771,6 +1771,23 @@ sub emit_func {
p |void |newMYSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block
p |OP * |my_attrs |OP *o|OP *attrs
p |void |boot_core_xsutils
+#if defined(USE_ITHREADS)
+p |HE* |he_dup |HE* e|bool shared
+p |REGEXP*|re_dup |REGEXP* r
+p |PerlIO*|fp_dup |PerlIO* fp|char type
+p |DIR* |dirp_dup |DIR* dp
+p |GP* |gp_dup |GP* gp
+p |MAGIC* |mg_dup |MAGIC* mg
+p |SV* |sv_dup |SV* sstr
+#if defined(HAVE_INTERP_INTERN)
+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
+#endif
#if defined(PERL_OBJECT)
protected:
View
@@ -376,6 +376,7 @@
#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)
@@ -636,6 +637,7 @@
#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)
@@ -898,6 +900,7 @@
#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
View
@@ -674,3 +674,15 @@ Perl_newATTRSUB
Perl_newMYSUB
Perl_my_attrs
Perl_boot_core_xsutils
+Perl_he_dup
+Perl_re_dup
+Perl_fp_dup
+Perl_dirp_dup
+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
View
59 hv.c
@@ -15,15 +15,6 @@
#define PERL_IN_HV_C
#include "perl.h"
-#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
-# define ARRAY_ALLOC_BYTES(size) ( (size)*sizeof(HE*) )
-#else
-# define MALLOC_OVERHEAD 16
-# define ARRAY_ALLOC_BYTES(size) ( ((size) < 64) \
- ? (size)*sizeof(HE*) \
- : (size)*sizeof(HE*)*2 - MALLOC_OVERHEAD )
-#endif
-
STATIC HE*
S_new_he(pTHX)
{
@@ -82,6 +73,27 @@ Perl_unshare_hek(pTHX_ HEK *hek)
unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
}
+#if defined(USE_ITHREADS)
+HE *
+Perl_he_dup(pTHX_ HE *e, bool shared)
+{
+ HE *ret;
+
+ if (!e)
+ return Nullhe;
+ ret = new_he();
+ HeNEXT(ret) = (HE*)NULL;
+ if (HeKLEN(e) == HEf_SVKEY)
+ HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
+ else if (shared)
+ HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+ else
+ HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+ HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
+ return ret;
+}
+#endif /* USE_ITHREADS */
+
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
* contains an SV* */
@@ -126,7 +138,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
|| (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
#endif
)
- Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ Newz(503, xhv->xhv_array,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
else
return 0;
}
@@ -214,7 +227,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
|| (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
#endif
)
- Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ Newz(503, xhv->xhv_array,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
else
return 0;
}
@@ -304,7 +318,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has
PERL_HASH(hash, key, klen);
if (!xhv->xhv_array)
- Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ Newz(505, xhv->xhv_array,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
@@ -385,7 +400,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
PERL_HASH(hash, key, klen);
if (!xhv->xhv_array)
- Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ Newz(505, xhv->xhv_array,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
@@ -714,21 +730,21 @@ S_hsplit(pTHX_ HV *hv)
PL_nomemok = TRUE;
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
- Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+ Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
return;
}
#else
#define MALLOC_OVERHEAD 16
- New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+ New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
return;
}
Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
- offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
+ offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
Safefree(xhv->xhv_array);
@@ -789,20 +805,20 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
if (a) {
PL_nomemok = TRUE;
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
- Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+ Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
return;
}
#else
- New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+ New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
return;
}
Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
- offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
+ offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
Safefree(xhv->xhv_array);
@@ -811,7 +827,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
}
else {
- Newz(0, a, ARRAY_ALLOC_BYTES(newsize), char);
+ Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
}
xhv->xhv_max = --newsize;
xhv->xhv_array = a;
@@ -1079,7 +1095,8 @@ Perl_hv_iternext(pTHX_ HV *hv)
#endif
if (!xhv->xhv_array)
- Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ Newz(506, xhv->xhv_array,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
if (entry)
entry = HeNEXT(entry);
while (!entry) {
View
10 hv.h
@@ -114,3 +114,13 @@ struct xpvhv {
#define HEK_HASH(hek) (hek)->hek_hash
#define HEK_LEN(hek) (hek)->hek_len
#define HEK_KEY(hek) (hek)->hek_key
+
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+# define PERL_HV_ARRAY_ALLOC_BYTES(size) ((size) * sizeof(HE*))
+#else
+# define MALLOC_OVERHEAD 16
+# define PERL_HV_ARRAY_ALLOC_BYTES(size) \
+ (((size) < 64) \
+ ? (size) * sizeof(HE*) \
+ : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD)
+#endif
View
@@ -378,3 +378,7 @@ PERLVAR(IDir, struct IPerlDir*)
PERLVAR(ISock, struct IPerlSock*)
PERLVAR(IProc, struct IPerlProc*)
#endif
+
+#if defined(USE_ITHREADS)
+PERLVAR(Isv_table, SVTBL*)
+#endif
View
@@ -359,6 +359,26 @@ sub emit_symbols {
Perl_magic_mutexfree
)];
}
+
+unless ($define{'USE_ITHREADS'})
+ {
+ skip_symbols [qw(
+PL_sv_table
+Perl_dirp_dup
+Perl_fp_dup
+Perl_gp_dup
+Perl_he_dup
+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
+)];
+ }
+
unless ($define{'USE_THREADS'} or $define{'PERL_IMPLICIT_CONTEXT'}
or $define{'PERL_OBJECT'})
{
Oops, something went wrong.

0 comments on commit d18c611

Please sign in to comment.