X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=317ed708976548c79450cf055588d87f80a00f61;hb=462e5cf694f345fbf34a1f95e9a82957e59dcc2b;hp=009d6360999f840b6aceb81aac74ac85d5296b8d;hpb=a1f49e722e7e3f3a14f81e8dd51de229003f2378;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 009d636..317ed70 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -27,7 +27,7 @@
 
 static OP *docatch _((OP *o));
 static OP *doeval _((int gimme));
-static OP *dofindlabel _((OP *op, char *label, OP **opstack, OP **oplimit));
+static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
 static void doparseform _((SV *sv));
 static I32 dopoptoeval _((I32 startingblock));
 static I32 dopoptolabel _((char *label));
@@ -94,7 +94,7 @@ PP(pp_regcomp) {
 	pm->op_pmflags |= PMf_WHITE;
 
     if (pm->op_pmflags & PMf_KEEP) {
-	pm->op_pmflags &= ~PMf_RUNTIME;	/* no point compiling again */
+	pm->op_private &= ~OPpRUNTIME;	/* no point compiling again */
 	hoistmust(pm);
 	cLOGOP->op_first->op_next = op->op_next;
     }
@@ -112,6 +112,8 @@ PP(pp_substcont)
     char *orig = cx->sb_orig;
     register REGEXP *rx = cx->sb_rx;
 
+    rxres_restore(&cx->sb_rxres, rx);
+
     if (cx->sb_iters++) {
 	if (cx->sb_iters > cx->sb_maxiters)
 	    DIE("Substitution loop");
@@ -157,9 +159,75 @@ PP(pp_substcont)
     sv_catpvn(dstr, s, m-s);
     cx->sb_s = rx->endp[0];
     cx->sb_rxtainted |= rx->exec_tainted;
+    rxres_save(&cx->sb_rxres, rx);
     RETURNOP(pm->op_pmreplstart);
 }
 
+void
+rxres_save(rsp, rx)
+void **rsp;
+REGEXP *rx;
+{
+    UV *p = (UV*)*rsp;
+    U32 i;
+
+    if (!p || p[1] < rx->nparens) {
+	i = 6 + rx->nparens * 2;
+	if (!p)
+	    New(501, p, i, UV);
+	else
+	    Renew(p, i, UV);
+	*rsp = (void*)p;
+    }
+
+    *p++ = (UV)rx->subbase;
+    rx->subbase = Nullch;
+
+    *p++ = rx->nparens;
+
+    *p++ = (UV)rx->subbeg;
+    *p++ = (UV)rx->subend;
+    for (i = 0; i <= rx->nparens; ++i) {
+	*p++ = (UV)rx->startp[i];
+	*p++ = (UV)rx->endp[i];
+    }
+}
+
+void
+rxres_restore(rsp, rx)
+void **rsp;
+REGEXP *rx;
+{
+    UV *p = (UV*)*rsp;
+    U32 i;
+
+    Safefree(rx->subbase);
+    rx->subbase = (char*)(*p);
+    *p++ = 0;
+
+    rx->nparens = *p++;
+
+    rx->subbeg = (char*)(*p++);
+    rx->subend = (char*)(*p++);
+    for (i = 0; i <= rx->nparens; ++i) {
+	rx->startp[i] = (char*)(*p++);
+	rx->endp[i] = (char*)(*p++);
+    }
+}
+
+void
+rxres_free(rsp)
+void **rsp;
+{
+    UV *p = (UV*)*rsp;
+
+    if (p) {
+	Safefree((char*)(*p));
+	Safefree(p);
+	*rsp = Null(void*);
+    }
+}
+
 PP(pp_formline)
 {
     dSP; dMARK; dORIGMARK;
@@ -465,8 +533,8 @@ PP(pp_grepstart)
 	RETURNOP(op->op_next->op_next);
     }
     stack_sp = stack_base + *markstack_ptr + 1;
-    pp_pushmark();				/* push dst */
-    pp_pushmark();				/* push src */
+    pp_pushmark(ARGS);				/* push dst */
+    pp_pushmark(ARGS);				/* push src */
     ENTER;					/* enter outer scope */
 
     SAVETMPS;
@@ -481,7 +549,7 @@ PP(pp_grepstart)
 
     PUTBACK;
     if (op->op_type == OP_MAPSTART)
-	pp_pushmark();				/* push top */
+	pp_pushmark(ARGS);			/* push top */
     return ((LOGOP*)op->op_next)->op_other;
 }
 
@@ -601,7 +669,7 @@ PP(pp_sort)
 	    sortcop = CvSTART(cv);
 	    SAVESPTR(CvROOT(cv)->op_ppaddr);
 	    CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
-	    
+
 	    SAVESPTR(curpad);
 	    curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 	}
@@ -630,7 +698,7 @@ PP(pp_sort)
 	    bool oldcatch = CATCH_GET;
 
 	    SAVETMPS;
-	    SAVESPTR(op);
+	    SAVEOP();
 
 	    oldstack = curstack;
 	    if (!sortstack) {
@@ -648,7 +716,16 @@ PP(pp_sort)
 
 	    SAVESPTR(GvSV(firstgv));
 	    SAVESPTR(GvSV(secondgv));
+
 	    PUSHBLOCK(cx, CXt_NULL, stack_base);
+	    if (!(op->op_flags & OPf_SPECIAL)) {
+		bool hasargs = FALSE;
+		cx->cx_type = CXt_SUB;
+		cx->blk_gimme = G_SCALAR;
+		PUSHSUB(cx);
+		if (!CvDEPTH(cv))
+		    SvREFCNT_inc(cv);	/* in preparation for POPSUB */
+	    }
 	    sortcxix = cxstack_ix;
 
 	    qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
@@ -772,6 +849,7 @@ static I32
 dopoptolabel(label)
 char *label;
 {
+    dTHR;
     register I32 i;
     register CONTEXT *cx;
 
@@ -818,6 +896,7 @@ dowantarray()
 I32
 block_gimme()
 {
+    dTHR;
     I32 cxix;
 
     cxix = dopoptosub(cxstack_ix);
@@ -840,6 +919,7 @@ static I32
 dopoptosub(startingblock)
 I32 startingblock;
 {
+    dTHR;
     I32 i;
     register CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -860,6 +940,7 @@ static I32
 dopoptoeval(startingblock)
 I32 startingblock;
 {
+    dTHR;
     I32 i;
     register CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -879,6 +960,7 @@ static I32
 dopoptoloop(startingblock)
 I32 startingblock;
 {
+    dTHR;
     I32 i;
     register CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -912,16 +994,20 @@ void
 dounwind(cxix)
 I32 cxix;
 {
+    dTHR;
     register CONTEXT *cx;
     SV **newsp;
     I32 optype;
 
     while (cxstack_ix > cxix) {
-	cx = &cxstack[cxstack_ix--];
-	DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
-		    block_type[cx->cx_type]));
+	cx = &cxstack[cxstack_ix];
+	DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
+			      (long) cxstack_ix+1, block_type[cx->cx_type]));
 	/* Note: we don't need to restore the base context info till the end. */
 	switch (cx->cx_type) {
+	case CXt_SUBST:
+	    POPSUBST(cx);
+	    continue;  /* not break */
 	case CXt_SUB:
 	    POPSUB(cx);
 	    break;
@@ -932,9 +1018,9 @@ I32 cxix;
 	    POPLOOP(cx);
 	    break;
 	case CXt_NULL:
-	case CXt_SUBST:
 	    break;
 	}
+	cxstack_ix--;
     }
 }
 
@@ -942,6 +1028,7 @@ OP *
 die_where(message)
 char *message;
 {
+    dTHR;
     if (in_eval) {
 	I32 cxix;
 	register CONTEXT *cx;
@@ -1040,7 +1127,7 @@ PP(pp_entersubr)
 	mark++;
     }
     *sp = cv;
-    return pp_entersub();
+    return pp_entersub(ARGS);
 }
 #endif
 
@@ -1146,6 +1233,7 @@ sortcv(a, b)
 const void *a;
 const void *b;
 {
+    dTHR;
     SV * const *str1 = (SV * const *)a;
     SV * const *str2 = (SV * const *)b;
     I32 oldsaveix = savestack_ix;
@@ -1184,9 +1272,54 @@ const void *b;
     return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b);
 }
 
+#ifdef USE_THREADS
+static void
+unlock_condpair(svv)
+void *svv;
+{
+    dTHR;
+    MAGIC *mg = mg_find((SV*)svv, 'm');
+    
+    if (!mg)
+	croak("panic: unlock_condpair unlocking non-mutex");
+    MUTEX_LOCK(MgMUTEXP(mg));
+    if (MgOWNER(mg) != thr)
+	croak("panic: unlock_condpair unlocking mutex that we don't own");
+    MgOWNER(mg) = 0;
+    COND_SIGNAL(MgOWNERCONDP(mg));
+    MUTEX_UNLOCK(MgMUTEXP(mg));
+}
+#endif /* USE_THREADS */
+
 PP(pp_reset)
 {
     dSP;
+#ifdef USE_THREADS
+    dTOPss;
+    MAGIC *mg;
+    
+    if (MAXARG < 1)
+	croak("reset requires mutex argument with USE_THREADS");
+    if (SvROK(sv)) {
+	/*
+	 * Kludge to allow lock of real objects without requiring
+	 * to pass in every type of argument by explicit reference.
+	 */
+	sv = SvRV(sv);
+    }
+    mg = condpair_magic(sv);
+    MUTEX_LOCK(MgMUTEXP(mg));
+    if (MgOWNER(mg) == thr)
+	MUTEX_UNLOCK(MgMUTEXP(mg));
+    else {
+	while (MgOWNER(mg))
+	    COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+	MgOWNER(mg) = thr;
+	MUTEX_UNLOCK(MgMUTEXP(mg));
+	save_destructor(unlock_condpair, sv);
+    }
+    RETURN;
+#else
     char *tmps;
 
     if (MAXARG < 1)
@@ -1196,6 +1329,7 @@ PP(pp_reset)
     sv_reset(tmps, curcop->cop_stash);
     PUSHs(&sv_yes);
     RETURN;
+#endif /* USE_THREADS */
 }
 
 PP(pp_lineseq)
@@ -1356,7 +1490,7 @@ PP(pp_return)
     I32 optype = 0;
 
     if (curstack == sortstack) {
-	if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
+	if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
 	    if (cxstack_ix > sortcxix)
 		dounwind(sortcxix);
 	    AvARRAY(curstack)[1] = *SP;
@@ -1554,8 +1688,8 @@ PP(pp_redo)
 static OP* lastgotoprobe;
 
 static OP *
-dofindlabel(op,label,opstack,oplimit)
-OP *op;
+dofindlabel(o,label,opstack,oplimit)
+OP *o;
 char *label;
 OP **opstack;
 OP **oplimit;
@@ -1566,24 +1700,24 @@ OP **oplimit;
 
     if (ops >= oplimit)
 	croak(too_deep);
-    if (op->op_type == OP_LEAVE ||
-	op->op_type == OP_SCOPE ||
-	op->op_type == OP_LEAVELOOP ||
-	op->op_type == OP_LEAVETRY)
+    if (o->op_type == OP_LEAVE ||
+	o->op_type == OP_SCOPE ||
+	o->op_type == OP_LEAVELOOP ||
+	o->op_type == OP_LEAVETRY)
     {
-	*ops++ = cUNOP->op_first;
+	*ops++ = cUNOPo->op_first;
 	if (ops >= oplimit)
 	    croak(too_deep);
     }
     *ops = 0;
-    if (op->op_flags & OPf_KIDS) {
+    if (o->op_flags & OPf_KIDS) {
 	/* First try all the kids at this level, since that's likeliest. */
-	for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 	    if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
 		    kCOP->cop_label && strEQ(kCOP->cop_label, label))
 		return kid;
 	}
-	for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 	    if (kid == lastgotoprobe)
 		continue;
 	    if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
@@ -1591,8 +1725,8 @@ OP **oplimit;
 		 (ops[-1]->op_type != OP_NEXTSTATE &&
 		  ops[-1]->op_type != OP_DBSTATE)))
 		*ops++ = kid;
-	    if (op = dofindlabel(kid, label, ops, oplimit))
-		return op;
+	    if (o = dofindlabel(kid, label, ops, oplimit))
+		return o;
 	}
     }
     *ops = 0;
@@ -1803,9 +1937,6 @@ PP(pp_goto)
 	for (ix = cxstack_ix; ix >= 0; ix--) {
 	    cx = &cxstack[ix];
 	    switch (cx->cx_type) {
-	    case CXt_SUB:
-		gotoprobe = CvROOT(cx->blk_sub.cv);
-		break;
 	    case CXt_EVAL:
 		gotoprobe = eval_root; /* XXX not good for nested eval */
 		break;
@@ -1820,6 +1951,12 @@ PP(pp_goto)
 		else
 		    gotoprobe = main_root;
 		break;
+	    case CXt_SUB:
+		if (CvDEPTH(cx->blk_sub.cv)) {
+		    gotoprobe = CvROOT(cx->blk_sub.cv);
+		    break;
+		}
+		/* FALL THROUGH */
 	    case CXt_NULL:
 		DIE("Can't \"goto\" outside a block");
 	    default:
@@ -1856,7 +1993,7 @@ PP(pp_goto)
 	    OP *oldop = op;
 	    for (ix = 1; enterops[ix]; ix++) {
 		op = enterops[ix];
-		(*op->op_ppaddr)();
+		(*op->op_ppaddr)(ARGS);
 	    }
 	    op = oldop;
 	}
@@ -1974,6 +2111,7 @@ static OP *
 docatch(o)
 OP *o;
 {
+    dTHR;
     int ret;
     I32 oldrunlevel = runlevel;
     OP *oldop = op;
@@ -2014,12 +2152,21 @@ static OP *
 doeval(gimme)
 int gimme;
 {
+    dTHR;
     dSP;
     OP *saveop = op;
     HV *newstash;
     CV *caller;
     AV* comppadlist;
 
+#ifdef USE_THREADS
+    MUTEX_LOCK(&eval_mutex);
+    if (eval_owner && eval_owner != thr)
+	while (eval_owner)
+	    COND_WAIT(&eval_cond, &eval_mutex);
+    eval_owner = thr;
+    MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
     in_eval = 1;
 
     PUSHMARK(SP);
@@ -2039,10 +2186,20 @@ int gimme;
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
     CvUNIQUE_on(compcv);
+#ifdef USE_THREADS
+    CvOWNER(compcv) = 0;
+    New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
+    MUTEX_INIT(CvMUTEXP(compcv));
+    New(666, CvCONDP(compcv), 1, pthread_cond_t);
+    COND_INIT(CvCONDP(compcv));
+#endif /* USE_THREADS */
 
     comppad = newAV();
     comppad_name = newAV();
     comppad_name_fill = 0;
+#ifdef USE_THREADS
+    av_store(comppad_name, 0, newSVpv("@_", 2));
+#endif /* USE_THREADS */
     min_intro_pending = 0;
     av_push(comppad, Nullsv);
     curpad = AvARRAY(comppad);
@@ -2135,8 +2292,14 @@ int gimme;
     /* compiled okay, so do it */
 
     CvDEPTH(compcv) = 1;
-
     SP = stack_base + POPMARK;		/* pop original mark */
+#ifdef USE_THREADS
+    MUTEX_LOCK(&eval_mutex);
+    eval_owner = 0;
+    COND_SIGNAL(&eval_cond);
+    MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
+
     RETURNOP(eval_start);
 }