develooper Front page | perl.perl5.porters | Postings from October 2005

RFC: sort / multicall patch

Thread Next
From:
Robin Houston
Date:
October 25, 2005 16:30
Subject:
RFC: sort / multicall patch
Message ID:
20051025232927.GA18540@rpc142.cs.man.ac.uk
Dear p5p,

Below is the first draft of the sort / multicall patch.
The main outstanding tasks are:

 - document the multicall API, in L<perlcall>
 - fix t/op/sort.t, and add tests for the now-fixed bugs
 - add more tests to List::Util, for the now-fixed bugs
 - add some defensive code to List::Util so that it will
   work against older perls (so we can keep the CPAN version
   in sync)
 - do lots more testing

but I wonder if anyone has any comments on what I've done so far?

I haven't had the nerve to actually use the multicall API in
pp_sort() itself, because that code deals with so many different
cases (e.g.  prototyped sort sub, XS sort sub, default sort
order) that it would be rather a pain. But I can look at it if
you think it's important. I have fixed the bugs we've talked
about.

You can still segfault it if you redefine the array that's
being sorted, while it's being sorted, as in bug 7567. Would
it be reasonable to make the array read-only while the sort
is going on?

I'm not sure what to do about bug 7063. It would be easy
to fix, but that would screw anyone who's working around
the current (mis)behaviour. What do you think?

Cheers,

Robin


diff -ru perl-current/cop.h perl-hackery/cop.h
--- perl-current/cop.h	2005-10-04 11:37:01.000000000 +0100
+++ perl-hackery/cop.h	2005-10-25 23:50:58.000000000 +0100
@@ -541,6 +541,10 @@
 #define CXt_BLOCK	5
 #define CXt_FORMAT	6
 
+/* private flags for CXt_SUB and CXt_NULL */
+#define CXp_MULTICALL	0x00000100	/* part of a multicall (so don't
+					   tear down context on exit). */ 
+
 /* private flags for CXt_EVAL */
 #define CXp_REAL	0x00000100	/* truly eval'', not a lookalike */
 #define CXp_TRYBLOCK	0x00000200	/* eval{}, not eval'' or similar */
@@ -555,6 +559,8 @@
 #endif
 
 #define CxTYPE(c)	((c)->cx_type & CXTYPEMASK)
+#define CxMULTICALL(c)	(((c)->cx_type & (CXt_SUB|CXt_NULL|CXp_MULTICALL)) \
+			 >= CXp_MULTICALL)
 #define CxREALEVAL(c)	(((c)->cx_type & (CXt_EVAL|CXp_REAL))		\
 			 == (CXt_EVAL|CXp_REAL))
 #define CxTRYBLOCK(c)	(((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK))	\
@@ -700,3 +706,62 @@
 #define IN_PERL_COMPILETIME	(PL_curcop == &PL_compiling)
 #define IN_PERL_RUNTIME		(PL_curcop != &PL_compiling)
 
+/*
+=head1 Multicall Functions
+
+=for apidoc Ams||dMULTICALL
+Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||PUSH_MULTICALL
+Opening bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||MULTICALL
+Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||POP_MULTICALL
+Closing bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=cut
+*/
+
+#define dMULTICALL \
+    SV **newsp;			/* set by POPBLOCK */			\
+    PERL_CONTEXT *cx;							\
+    CV *cv;								\
+    OP *multicall_cop;							\
+    bool multicall_oldcatch; 
+
+#define PUSH_MULTICALL \
+    STMT_START {							\
+	AV* padlist = CvPADLIST(cv);					\
+	ENTER;								\
+ 	multicall_oldcatch = CATCH_GET;					\
+	SAVETMPS; SAVEVPTR(PL_op);					\
+	CATCH_SET(TRUE);						\
+	PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);		\
+	PUSHSUB(cx);							\
+	if (++CvDEPTH(cv) >= 2) {					\
+	    PERL_STACK_OVERFLOW_CHECK();				\
+	    Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));			\
+	}								\
+	SAVECOMPPAD();							\
+	PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));			\
+	multicall_cop = CvSTART(cv);					\
+    } STMT_END
+
+#define MULTICALL \
+    STMT_START {							\
+	PL_op = multicall_cop;						\
+	CALLRUNOPS(aTHX);						\
+    } STMT_END
+
+#define POP_MULTICALL \
+    STMT_START {							\
+	LEAVESUB(cv);							\
+	CvDEPTH(cv)--;							\
+	POPBLOCK(cx,PL_curpm);						\
+	CATCH_SET(multicall_oldcatch);					\
+	LEAVE;								\
+    } STMT_END
diff -ru perl-current/embed.fnc perl-hackery/embed.fnc
--- perl-current/embed.fnc	2005-10-24 22:48:54.000000000 +0100
+++ perl-hackery/embed.fnc	2005-10-25 23:51:45.000000000 +0100
@@ -1416,7 +1416,7 @@
 pd 	|void	|do_dump_pad	|I32 level|NN PerlIO *file|NULLOK PADLIST *padlist|int full
 pd	|void	|pad_fixup_inner_anons|NN PADLIST *padlist|NN CV *old_cv|NN CV *new_cv
 
-pd	|void	|pad_push	|NN PADLIST *padlist|int depth
+pdX	|void	|pad_push	|NN PADLIST *padlist|int depth
 pR	|HV*	|pad_compname_type|const PADOFFSET po
 
 #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
diff -ru perl-current/embedvar.h perl-hackery/embedvar.h
--- perl-current/embedvar.h	2005-06-29 09:41:56.000000000 +0100
+++ perl-hackery/embedvar.h	2005-10-26 00:03:47.000000000 +0100
@@ -138,7 +138,6 @@
 #define PL_screamnext		(vTHX->Tscreamnext)
 #define PL_secondgv		(vTHX->Tsecondgv)
 #define PL_sortcop		(vTHX->Tsortcop)
-#define PL_sortcxix		(vTHX->Tsortcxix)
 #define PL_sortstash		(vTHX->Tsortstash)
 #define PL_stack_base		(vTHX->Tstack_base)
 #define PL_stack_max		(vTHX->Tstack_max)
@@ -861,7 +860,6 @@
 #define PL_Tscreamnext		PL_screamnext
 #define PL_Tsecondgv		PL_secondgv
 #define PL_Tsortcop		PL_sortcop
-#define PL_Tsortcxix		PL_sortcxix
 #define PL_Tsortstash		PL_sortstash
 #define PL_Tstack_base		PL_stack_base
 #define PL_Tstack_max		PL_stack_max
diff -ru perl-current/ext/List/Util/Util.xs perl-hackery/ext/List/Util/Util.xs
--- perl-current/ext/List/Util/Util.xs	2005-05-21 00:00:19.000000000 +0100
+++ perl-hackery/ext/List/Util/Util.xs	2005-10-25 23:48:32.000000000 +0100
@@ -230,52 +230,32 @@
 PROTOTYPE: &@
 CODE:
 {
-    dVAR;
+    dVAR; dMULTICALL;
     SV *ret = sv_newmortal();
     int index;
     GV *agv,*bgv,*gv;
     HV *stash;
-    CV *cv;
-    OP *reducecop;
-    PERL_CONTEXT *cx;
-    SV** newsp;
     I32 gimme = G_SCALAR;
     U8 hasargs = 0;
-    bool oldcatch = CATCH_GET;
 
     if(items <= 1) {
 	XSRETURN_UNDEF;
     }
+    cv = sv_2cv(block, &stash, &gv, 0);
+    PUSH_MULTICALL;
     agv = gv_fetchpv("a", TRUE, SVt_PV);
     bgv = gv_fetchpv("b", TRUE, SVt_PV);
     SAVESPTR(GvSV(agv));
     SAVESPTR(GvSV(bgv));
     GvSV(agv) = ret;
-    cv = sv_2cv(block, &stash, &gv, 0);
-    reducecop = CvSTART(cv);
-    SAVESPTR(CvROOT(cv)->op_ppaddr);
-    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
-    PAD_SET_CUR(CvPADLIST(cv),1);
-#else
-    SAVESPTR(PL_curpad);
-    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
-    SAVETMPS;
-    SAVESPTR(PL_op);
     SvSetSV(ret, ST(1));
-    CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_SUB, SP);
-    PUSHSUB(cx);
     for(index = 2 ; index < items ; index++) {
 	GvSV(bgv) = ST(index);
-	PL_op = reducecop;
-	CALLRUNOPS(aTHX);
+	MULTICALL;
 	SvSetSV(ret, *PL_stack_sp);
     }
+    POP_MULTICALL;
     ST(0) = ret;
-    POPBLOCK(cx,PL_curpm);
-    CATCH_SET(oldcatch);
     XSRETURN(1);
 }
 
@@ -285,51 +265,30 @@
 PROTOTYPE: &@
 CODE:
 {
-    dVAR;
+    dVAR; dMULTICALL;
     int index;
     GV *gv;
     HV *stash;
-    CV *cv;
-    OP *reducecop;
-    PERL_CONTEXT *cx;
-    SV** newsp;
     I32 gimme = G_SCALAR;
     U8 hasargs = 0;
-    bool oldcatch = CATCH_GET;
 
     if(items <= 1) {
 	XSRETURN_UNDEF;
     }
-    SAVESPTR(GvSV(PL_defgv));
     cv = sv_2cv(block, &stash, &gv, 0);
-    reducecop = CvSTART(cv);
-    SAVESPTR(CvROOT(cv)->op_ppaddr);
-    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
-    PAD_SET_CUR(CvPADLIST(cv),1);
-#else
-    SAVESPTR(PL_curpad);
-    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
-    SAVETMPS;
-    SAVESPTR(PL_op);
-    CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_SUB, SP);
-    PUSHSUB(cx);
+    PUSH_MULTICALL;
+    SAVESPTR(GvSV(PL_defgv));
 
     for(index = 1 ; index < items ; index++) {
 	GvSV(PL_defgv) = ST(index);
-	PL_op = reducecop;
-	CALLRUNOPS(aTHX);
+	MULTICALL;
 	if (SvTRUE(*PL_stack_sp)) {
 	  ST(0) = ST(index);
-	  POPBLOCK(cx,PL_curpm);
-	  CATCH_SET(oldcatch);
+	  POP_MULTICALL;
 	  XSRETURN(1);
 	}
     }
-    POPBLOCK(cx,PL_curpm);
-    CATCH_SET(oldcatch);
+    POP_MULTICALL;
     XSRETURN_UNDEF;
 }
 
diff -ru perl-current/ext/List/Util/lib/List/Util.pm perl-hackery/ext/List/Util/lib/List/Util.pm
--- perl-current/ext/List/Util/lib/List/Util.pm	2005-05-23 15:20:38.000000000 +0100
+++ perl-hackery/ext/List/Util/lib/List/Util.pm	2005-10-25 20:34:33.000000000 +0100
@@ -10,7 +10,7 @@
 
 @ISA        = qw(Exporter);
 @EXPORT_OK  = qw(first min max minstr maxstr reduce sum shuffle);
-$VERSION    = "1.17";
+$VERSION    = "1.18";
 $XS_VERSION = $VERSION;
 $VERSION    = eval $VERSION;
 
diff -ru perl-current/global.sym perl-hackery/global.sym
--- perl-current/global.sym	2005-10-24 22:48:54.000000000 +0100
+++ perl-hackery/global.sym	2005-10-26 00:03:46.000000000 +0100
@@ -681,6 +681,7 @@
 Perl_PerlIO_stdin
 Perl_PerlIO_stdout
 Perl_PerlIO_stderr
+Perl_pad_push
 Perl_save_set_svflags
 Perl_hv_assert
 Perl_hv_scalar
diff -ru perl-current/makedef.pl perl-hackery/makedef.pl
--- perl-current/makedef.pl	2005-10-24 22:48:54.000000000 +0100
+++ perl-hackery/makedef.pl	2005-10-26 00:01:49.000000000 +0100
@@ -250,7 +250,6 @@
 		     PL_linestart
 		     PL_modcount
 		     PL_pending_ident
-		     PL_sortcxix
 		     PL_sublex_info
 		     PL_timesbuf
 		     main
@@ -308,7 +307,6 @@
 		     PL_linestart
 		     PL_modcount
 		     PL_pending_ident
-		     PL_sortcxix
 		     PL_sublex_info
 		     PL_timesbuf
 		     PL_collation_ix
@@ -509,7 +507,6 @@
 			PL_linestart
 			PL_modcount
 			PL_pending_ident
-			PL_sortcxix
 			PL_sublex_info
 			PL_timesbuf
 			main
diff -ru perl-current/op.c perl-hackery/op.c
--- perl-current/op.c	2005-10-24 16:48:18.000000000 +0100
+++ perl-hackery/op.c	2005-10-25 18:44:05.000000000 +0100
@@ -4361,9 +4361,6 @@
 		SAVEFREESV(PL_compcv);
 		goto done;
 	    }
-	    /* ahem, death to those who redefine active sort subs */
-	    if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
-		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
 	    if (block) {
 		if (ckWARN(WARN_REDEFINE)
 		    || (CvCONST(cv)
diff -ru perl-current/perlapi.h perl-hackery/perlapi.h
--- perl-current/perlapi.h	2005-06-29 09:41:56.000000000 +0100
+++ perl-hackery/perlapi.h	2005-10-26 00:03:47.000000000 +0100
@@ -910,8 +910,6 @@
 #define PL_secondgv		(*Perl_Tsecondgv_ptr(aTHX))
 #undef  PL_sortcop
 #define PL_sortcop		(*Perl_Tsortcop_ptr(aTHX))
-#undef  PL_sortcxix
-#define PL_sortcxix		(*Perl_Tsortcxix_ptr(aTHX))
 #undef  PL_sortstash
 #define PL_sortstash		(*Perl_Tsortstash_ptr(aTHX))
 #undef  PL_stack_base
diff -ru perl-current/pod/perldiag.pod perl-hackery/pod/perldiag.pod
--- perl-current/pod/perldiag.pod	2005-10-21 14:54:36.000000000 +0100
+++ perl-hackery/pod/perldiag.pod	2005-10-25 20:12:31.000000000 +0100
@@ -954,13 +954,6 @@
 or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not
 searched.
 
-=item Can't redefine active sort subroutine %s
-
-(F) Perl optimizes the internal handling of sort subroutines and keeps
-pointers into them.  You tried to redefine one such sort subroutine when
-it was currently active, which is not allowed.  If you really want to do
-this, you should write C<sort { &func } @x> instead of C<sort func @x>.
-
 =item Can't "redo" outside a loop block
 
 (F) A "redo" statement was executed to restart the current block, but
diff -ru perl-current/pp_ctl.c perl-hackery/pp_ctl.c
--- perl-current/pp_ctl.c	2005-10-19 09:46:58.000000000 +0100
+++ perl-hackery/pp_ctl.c	2005-10-25 21:48:11.000000000 +0100
@@ -1963,24 +1963,21 @@
     SV *sv;
     OP *retop;
 
-    if (PL_curstackinfo->si_type == PERLSI_SORT) {
-	if (cxstack_ix == PL_sortcxix
-	    || dopoptosub(cxstack_ix) <= PL_sortcxix)
-	{
-	    if (cxstack_ix > PL_sortcxix)
-		dounwind(PL_sortcxix);
-	    AvARRAY(PL_curstack)[1] = *SP;
-	    PL_stack_sp = PL_stack_base + 1;
+    cxix = dopoptosub(cxstack_ix);
+    if (cxix < 0) {
+	if (CxMULTICALL(cxstack))   /* In this case we must be in a
+				     * sort (or similar) block, which
+				     * is a CXt_NULL not a CXt_SUB */
 	    return 0;
-	}
+	else
+	    DIE(aTHX_ "Can't return outside a subroutine");
     }
-
-    cxix = dopoptosub(cxstack_ix);
-    if (cxix < 0)
-	DIE(aTHX_ "Can't return outside a subroutine");
     if (cxix < cxstack_ix)
 	dounwind(cxix);
 
+    if (CxMULTICALL(&cxstack[cxix]))
+	return 0;
+
     POPBLOCK(cx,newpm);
     switch (CxTYPE(cx)) {
     case CXt_SUB:
@@ -2549,7 +2546,7 @@
 		    gotoprobe = PL_main_root;
 		break;
 	    case CXt_SUB:
-		if (CvDEPTH(cx->blk_sub.cv)) {
+		if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
 		    gotoprobe = CvROOT(cx->blk_sub.cv);
 		    break;
 		}
diff -ru perl-current/pp_hot.c perl-hackery/pp_hot.c
--- perl-current/pp_hot.c	2005-10-19 09:46:58.000000000 +0100
+++ perl-hackery/pp_hot.c	2005-10-25 18:44:05.000000000 +0100
@@ -2331,6 +2331,9 @@
     register PERL_CONTEXT *cx;
     SV *sv;
 
+    if (CxMULTICALL(&cxstack[cxstack_ix]))
+	return 0;
+
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
 
@@ -2391,6 +2394,9 @@
     register PERL_CONTEXT *cx;
     SV *sv;
 
+    if (CxMULTICALL(&cxstack[cxstack_ix]))
+	return 0;
+
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
 
diff -ru perl-current/pp_sort.c perl-hackery/pp_sort.c
--- perl-current/pp_sort.c	2005-10-14 00:31:31.000000000 +0100
+++ perl-hackery/pp_sort.c	2005-10-26 00:02:32.000000000 +0100
@@ -1542,14 +1542,8 @@
 
 	    if (is_xsub)
 		PL_sortcop = (OP*)cv;
-	    else {
+	    else
 		PL_sortcop = CvSTART(cv);
-		SAVEVPTR(CvROOT(cv)->op_ppaddr);
-		CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-
-		SAVECOMPPAD();
-		PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
-            }
 	}
     }
     else {
@@ -1661,23 +1655,39 @@
 		cx->cx_type = CXt_SUB;
 		cx->blk_gimme = G_SCALAR;
 		PUSHSUB(cx);
-	    }
-	    PL_sortcxix = cxstack_ix;
+		if (!is_xsub) {
+		    AV* padlist = CvPADLIST(cv);
 
-	    if (hasargs && !is_xsub) {
-		/* This is mostly copied from pp_entersub */
-		AV *av = (AV*)PAD_SVl(0);
-
-		cx->blk_sub.savearray = GvAV(PL_defgv);
-		GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-		CX_CURPAD_SAVE(cx->blk_sub);
-		cx->blk_sub.argarray = av;
+		    if (++CvDEPTH(cv) >= 2) {
+			PERL_STACK_OVERFLOW_CHECK();
+			pad_push(padlist, CvDEPTH(cv));
+		    }
+		    SAVECOMPPAD();
+		    PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
+
+		    if (hasargs) {
+			/* This is mostly copied from pp_entersub */
+			AV *av = (AV*)PAD_SVl(0);
+
+			cx->blk_sub.savearray = GvAV(PL_defgv);
+			GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+			CX_CURPAD_SAVE(cx->blk_sub);
+			cx->blk_sub.argarray = av;
+		    }
+
+		}
 	    }
+	    cx->cx_type |= CXp_MULTICALL;
 	    
 	    start = p1 - max;
 	    sortsvp(aTHX_ start, max,
 		    is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 
+	    if (!(flags & OPf_SPECIAL)) {
+		LEAVESUB(cv);
+		if (!is_xsub)
+		    CvDEPTH(cv)--;
+	    }
 	    POPBLOCK(cx,PL_curpm);
 	    PL_stack_sp = newsp;
 	    POPSTACK;
diff -ru perl-current/sv.c perl-hackery/sv.c
--- perl-current/sv.c	2005-10-19 09:46:59.000000000 +0100
+++ perl-hackery/sv.c	2005-10-26 00:02:44.000000000 +0100
@@ -3866,11 +3866,6 @@
 		GvNAMELEN(dstr) = len;
 		SvFAKE_on(dstr);	/* can coerce to non-glob */
 	    }
-	    /* ahem, death to those who redefine active sort subs */
-	    else if (PL_curstackinfo->si_type == PERLSI_SORT
-		     && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
-		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
-		      GvNAME(dstr));
 
 #ifdef GV_UNIQUE_CHECK
                 if (GvUNIQUE((GV*)dstr)) {
@@ -3973,13 +3968,6 @@
 			    if (!GvCVGEN((GV*)dstr) &&
 				(CvROOT(cv) || CvXSUB(cv)))
 			    {
-				/* ahem, death to those who redefine
-				 * active sort subs */
-				if (PL_curstackinfo->si_type == PERLSI_SORT &&
-				      PL_sortcop == CvSTART(cv))
-				    Perl_croak(aTHX_
-				    "Can't redefine active sort subroutine %s",
-					  GvENAME((GV*)dstr));
  				/* Redefining a sub - warning is mandatory if
  				   it was a const and its value changed. */
  				if (ckWARN(WARN_REDEFINE)
@@ -11906,7 +11894,6 @@
     PL_sortstash	= hv_dup(proto_perl->Tsortstash, param);
     PL_firstgv		= gv_dup(proto_perl->Tfirstgv, param);
     PL_secondgv		= gv_dup(proto_perl->Tsecondgv, param);
-    PL_sortcxix		= proto_perl->Tsortcxix;
     PL_efloatbuf	= Nullch;		/* reinits on demand */
     PL_efloatsize	= 0;			/* reinits on demand */
 
diff -ru perl-current/thrdvar.h perl-hackery/thrdvar.h
--- perl-current/thrdvar.h	2005-06-02 09:07:41.000000000 +0100
+++ perl-hackery/thrdvar.h	2005-10-26 00:03:43.000000000 +0100
@@ -147,7 +147,6 @@
 PERLVAR(Tsortstash,	HV *)		/* which is in some package or other */
 PERLVAR(Tfirstgv,	GV *)		/* $a */
 PERLVAR(Tsecondgv,	GV *)		/* $b */
-PERLVAR(Tsortcxix,	I32)		/* from pp_ctl.c */
 
 /* float buffer */
 PERLVAR(Tefloatbuf,	char*)

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About