Merge remote branch 'zefram/zefram/reliable_exception' into blead

Conflicts:
	pp_ctl.c

17 files changed, 750 insertions, 266 deletions

diff --git a/MANIFEST b/MANIFEST
index ad842f72f0..2e2112b7d4 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4383,7 +4383,9 @@ t/op/crypt.t			See if crypt works
 t/op/dbm.t			See if dbmopen/dbmclose work
 t/op/defins.t			See if auto-insert of defined() works
 t/op/delete.t			See if delete works
+t/op/die_except.t		See if die/eval avoids $@ clobberage
 t/op/die_exit.t			See if die and exit status interaction works
+t/op/die_keeperr.t		See if G_KEEPERR works for destructors
 t/op/die.t			See if die works
 t/op/dor.t			See if defined-or (//) works
 t/op/do.t			See if subroutines work
@@ -4510,6 +4512,7 @@ t/op/utftaint.t			See if utf8 and taint work together
 t/op/vec.t			See if vectors work
 t/op/ver.t			See if v-strings and the %v format flag work
 t/op/wantarray.t		See if wantarray works
+t/op/warn.t			See if warn works
 t/op/while_readdir.t		See if while(readdir) works
 t/op/write.t			See if write works (formats work)
 t/op/yadayada.t			See if ... works
diff --git a/cop.h b/cop.h
index f36d5ff855..98478ae7de 100644
--- a/cop.h
+++ b/cop.h
@@ -778,7 +778,7 @@ L<perlcall>.
 				   hash actions codes defined in hv.h */
 #define G_EVAL		8	/* Assume eval {} around subroutine call. */
 #define G_NOARGS       16	/* Don't construct a @_ array. */
-#define G_KEEPERR      32	/* Append errors to $@, don't overwrite it */
+#define G_KEEPERR      32	/* Warn for errors, don't overwrite $@ */
 #define G_NODEBUG      64	/* Disable debugging at toplevel.  */
 #define G_METHOD      128       /* Calling method. */
 #define G_FAKINGEVAL  256	/* Faking an eval context for call_sv or
diff --git a/embed.fnc b/embed.fnc
index 7ae3b9feef..1612fe70ae 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -230,9 +230,10 @@ ApR	|I32	|my_chsize	|int fd|Off_t length
 pR	|OP*	|convert	|I32 optype|I32 flags|NULLOK OP* o
 : Used in op.c and perl.c
 pM	|PERL_CONTEXT*	|create_eval_scope|U32 flags
+Aprd	|void	|croak_sv	|NN SV *baseex
 : croak()'s first parm can be NULL.  Otherwise, mod_perl breaks.
 Afprd	|void	|croak		|NULLOK const char* pat|...
-Apr	|void	|vcroak		|NULLOK const char* pat|NULLOK va_list* args
+Aprd	|void	|vcroak		|NULLOK const char* pat|NULLOK va_list* args
 Aprd	|void	|croak_xs_usage	|NN const CV *const cv \
 				|NN const char *const params
 
@@ -286,12 +287,10 @@ Anp	|char*	|delimcpy	|NN char* to|NN const char* toend|NN const char* from \
 				|NN const char* fromend|int delim|NN I32* retlen
 : Used in op.c, perl.c
 pM	|void	|delete_eval_scope
-Afp	|OP*	|die		|NULLOK const char* pat|...
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-s	|OP*	|vdie		|NULLOK const char* pat|NULLOK va_list* args
-#endif
+Apd	|OP*	|die_sv		|NN SV *baseex
+Afpd	|OP*	|die		|NULLOK const char* pat|...
 : Used in util.c
-pr	|void	|die_where	|NULLOK SV* msv
+pr	|void	|die_unwind	|NN SV* ex
 Ap	|void	|dounwind	|I32 cxix
 : FIXME
 pmb	|bool	|do_aexec	|NULLOK SV* really|NN SV** mark|NN SV** sp
@@ -691,8 +690,9 @@ p	|int	|magic_setcollxfrm|NN SV* sv|NN MAGIC* mg
 : Defined in locale.c, used only in sv.c
 p	|char*	|mem_collxfrm	|NN const char* s|STRLEN len|NN STRLEN* xlen
 #endif
-Afp	|SV*	|mess		|NN const char* pat|...
-Ap	|SV*	|vmess		|NN const char* pat|NULLOK va_list* args
+Afpd	|SV*	|mess		|NN const char* pat|...
+Apd	|SV*	|mess_sv	|NN SV* basemsg|bool consume
+Apd	|SV*	|vmess		|NN const char* pat|NULLOK va_list* args
 : FIXME - either make it public, or stop exporting it. (Data::Alias uses this)
 : Used in gv.c, op.c, toke.c
 EXp	|void	|qerror		|NN SV* err
@@ -1288,8 +1288,9 @@ pR	|UV	|get_hash_seed
 p	|void	|report_evil_fh	|NULLOK const GV *gv|NULLOK const IO *io|I32 op
 : Used in mg.c, pp.c, pp_hot.c, regcomp.c
 XEpd	|void	|report_uninit	|NULLOK const SV *uninit_sv
+Apd	|void	|warn_sv	|NN SV *baseex
 Afpd	|void	|warn		|NN const char* pat|...
-Ap	|void	|vwarn		|NN const char* pat|NULLOK va_list* args
+Apd	|void	|vwarn		|NN const char* pat|NULLOK va_list* args
 Afp	|void	|warner		|U32 err|NN const char* pat|...
 Afp	|void	|ck_warner	|U32 err|NN const char* pat|...
 Afp	|void	|ck_warner_d	|U32 err|NN const char* pat|...
@@ -1956,8 +1957,8 @@ s	|char*	|stdize_locale	|NN char* locs
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
 s	|const COP*|closest_cop	|NN const COP *cop|NULLOK const OP *o
 s	|SV*	|mess_alloc
-s	|SV *|vdie_croak_common|NULLOK const char *pat|NULLOK va_list *args
-s	|bool	|vdie_common	|NULLOK SV *message|bool warn
+s	|SV *|with_queued_errors|NN SV *ex
+s	|bool	|invoke_exception_hook|NULLOK SV *ex|bool warn
 sr	|char *	|write_no_mem
 #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
 sn	|void	|mem_log_common	|enum mem_log_type mlt|const UV n|const UV typesize \
diff --git a/embed.h b/embed.h
index a3f7408b1c..af2350d39c 100644
--- a/embed.h
+++ b/embed.h
@@ -102,6 +102,7 @@
 #define convert			Perl_convert
 #define create_eval_scope	Perl_create_eval_scope
 #endif
+#define croak_sv		Perl_croak_sv
 #define croak			Perl_croak
 #define vcroak			Perl_vcroak
 #define croak_xs_usage		Perl_croak_xs_usage
@@ -154,14 +155,10 @@
 #ifdef PERL_CORE
 #define delete_eval_scope	Perl_delete_eval_scope
 #endif
+#define die_sv			Perl_die_sv
 #define die			Perl_die
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-#ifdef PERL_CORE
-#define vdie			S_vdie
-#endif
-#endif
 #ifdef PERL_CORE
-#define die_where		Perl_die_where
+#define die_unwind		Perl_die_unwind
 #endif
 #define dounwind		Perl_dounwind
 #ifdef PERL_CORE
@@ -523,6 +520,7 @@
 #endif
 #endif
 #define mess			Perl_mess
+#define mess_sv			Perl_mess_sv
 #define vmess			Perl_vmess
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define qerror			Perl_qerror
@@ -1075,6 +1073,7 @@
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define report_uninit		Perl_report_uninit
 #endif
+#define warn_sv			Perl_warn_sv
 #define warn			Perl_warn
 #define vwarn			Perl_vwarn
 #define warner			Perl_warner
@@ -1676,8 +1675,8 @@
 #ifdef PERL_CORE
 #define closest_cop		S_closest_cop
 #define mess_alloc		S_mess_alloc
-#define vdie_croak_common	S_vdie_croak_common
-#define vdie_common		S_vdie_common
+#define with_queued_errors	S_with_queued_errors
+#define invoke_exception_hook	S_invoke_exception_hook
 #define write_no_mem		S_write_no_mem
 #endif
 #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
@@ -2522,6 +2521,7 @@
 #define convert(a,b,c)		Perl_convert(aTHX_ a,b,c)
 #define create_eval_scope(a)	Perl_create_eval_scope(aTHX_ a)
 #endif
+#define croak_sv(a)		Perl_croak_sv(aTHX_ a)
 #define vcroak(a,b)		Perl_vcroak(aTHX_ a,b)
 #define croak_xs_usage(a,b)	Perl_croak_xs_usage(aTHX_ a,b)
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -2557,13 +2557,9 @@
 #ifdef PERL_CORE
 #define delete_eval_scope()	Perl_delete_eval_scope(aTHX)
 #endif
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-#ifdef PERL_CORE
-#define vdie(a,b)		S_vdie(aTHX_ a,b)
-#endif
-#endif
+#define die_sv(a)		Perl_die_sv(aTHX_ a)
 #ifdef PERL_CORE
-#define die_where(a)		Perl_die_where(aTHX_ a)
+#define die_unwind(a)		Perl_die_unwind(aTHX_ a)
 #endif
 #define dounwind(a)		Perl_dounwind(aTHX_ a)
 #ifdef PERL_CORE
@@ -2936,6 +2932,7 @@
 #define mem_collxfrm(a,b,c)	Perl_mem_collxfrm(aTHX_ a,b,c)
 #endif
 #endif
+#define mess_sv(a,b)		Perl_mess_sv(aTHX_ a,b)
 #define vmess(a,b)		Perl_vmess(aTHX_ a,b)
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define qerror(a)		Perl_qerror(aTHX_ a)
@@ -3488,6 +3485,7 @@
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define report_uninit(a)	Perl_report_uninit(aTHX_ a)
 #endif
+#define warn_sv(a)		Perl_warn_sv(aTHX_ a)
 #define vwarn(a,b)		Perl_vwarn(aTHX_ a,b)
 #define vwarner(a,b,c)		Perl_vwarner(aTHX_ a,b,c)
 #ifdef PERL_CORE
@@ -4095,8 +4093,8 @@
 #ifdef PERL_CORE
 #define closest_cop(a,b)	S_closest_cop(aTHX_ a,b)
 #define mess_alloc()		S_mess_alloc(aTHX)
-#define vdie_croak_common(a,b)	S_vdie_croak_common(aTHX_ a,b)
-#define vdie_common(a,b)	S_vdie_common(aTHX_ a,b)
+#define with_queued_errors(a)	S_with_queued_errors(aTHX_ a)
+#define invoke_exception_hook(a,b)	S_invoke_exception_hook(aTHX_ a,b)
 #define write_no_mem()		S_write_no_mem(aTHX)
 #endif
 #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index e7c1545b5e..373a1af907 100644
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -18,11 +18,11 @@ use warnings;
 use strict;
 
 # Test::More doesn't have fresh_perl_is() yet
-# use Test::More tests => 240;
+# use Test::More tests => 342;
 
 BEGIN {
     require '../../t/test.pl';
-    plan(240);
+    plan(342);
     use_ok('XS::APItest')
 };
 
@@ -36,7 +36,6 @@ sub f {
 }
 
 sub d {
-    no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
     die "its_dead_jim\n";
 }
 
@@ -52,7 +51,6 @@ sub Foo::meth {
 }
 
 sub Foo::d {
-    no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
     die "its_dead_jim\n";
 }
 
@@ -92,31 +90,42 @@ for my $test (
 	? [0] : [ undef, 1 ];
     for my $keep (0, G_KEEPERR) {
 	my $desc = $description . ($keep ? ' G_KEEPERR' : '');
-	my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n"
+	my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : "";
+	my $exp_err = $keep ? "before\n"
 			    : "its_dead_jim\n";
+	my $warn;
+	local $SIG{__WARN__} = sub { $warn .= $_[0] };
 	$@ = "before\n";
+	$warn = "";
 	ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
 		    $returnval),
 		    "$desc G_EVAL call_sv('d')");
 	is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
+	is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning");
 
 	$@ = "before\n";
+	$warn = "";
 	ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], 
 		    $returnval),
 		    "$desc G_EVAL call_pv('d')");
 	is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
+	is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning");
 
 	$@ = "before\n";
+	$warn = "";
 	ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
 		    $returnval),
 		    "$desc eval_sv('d()')");
 	is($@, $exp_err, "$desc eval_sv('d()') - \$@");
+	is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning");
 
 	$@ = "before\n";
+	$warn = "";
 	ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
 		    $returnval),
 		    "$desc G_EVAL call_method('d')");
 	is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
+	is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning");
     }
 
     ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
@@ -147,6 +156,40 @@ for my $test (
 
 };
 
+foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
+    foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
+	my $warn;
+	local $SIG{__WARN__} = sub { $warn .= $_[0] };
+	$@ = $outx;
+	$warn = "";
+	call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL);
+	ok ref($@) eq ref($inx) && $@ eq $inx;
+	$warn =~ s/ at [^\n]*\n\z//;
+	is $warn, "";
+	$@ = $outx;
+	$warn = "";
+	call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR);
+	ok ref($@) eq ref($outx) && $@ eq $outx;
+	$warn =~ s/ at [^\n]*\n\z//;
+	is $warn, $inx ? "\t(in cleanup) $inx" : "";
+    }
+}
+
+{
+    no warnings "misc";
+    my $warn = "";
+    local $SIG{__WARN__} = sub { $warn .= $_[0] };
+    call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
+    is $warn, "";
+}
+
+{
+    my $warn = "";
+    local $SIG{__WARN__} = sub { $warn .= $_[0] };
+    call_sv(sub { no warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
+    is $warn, "\t(in cleanup) aa\n";
+}
+
 is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
 is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
 is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
diff --git a/global.sym b/global.sym
index 6f053a6311..4dd25e6a42 100644
--- a/global.sym
+++ b/global.sym
@@ -60,6 +60,7 @@ Perl_cast_i32
 Perl_cast_iv
 Perl_cast_uv
 Perl_my_chsize
+Perl_croak_sv
 Perl_croak
 Perl_vcroak
 Perl_croak_xs_usage
@@ -96,6 +97,7 @@ Perl_debop
 Perl_debstack
 Perl_debstackptrs
 Perl_delimcpy
+Perl_die_sv
 Perl_die
 Perl_dounwind
 Perl_do_aexec
@@ -281,6 +283,7 @@ Perl_grok_numeric_radix
 Perl_grok_oct
 Perl_markstack_grow
 Perl_mess
+Perl_mess_sv
 Perl_vmess
 Perl_qerror
 Perl_sortsv
@@ -639,6 +642,7 @@ Perl_sv_uni_display
 Perl_vivify_defelem
 Perl_seed
 Perl_report_uninit
+Perl_warn_sv
 Perl_warn
 Perl_vwarn
 Perl_warner
diff --git a/mg.c b/mg.c
index 3c5702669f..4be1b3c2e1 100644
--- a/mg.c
+++ b/mg.c
@@ -3004,7 +3004,7 @@ Perl_sighandler(int sig)
 	(void)rsignal(sig, PL_csighandlerp);
 #endif
 #endif /* !PERL_MICRO */
-	Perl_die(aTHX_ NULL);
+	die_sv(ERRSV);
     }
 cleanup:
     if (flags & 1)
diff --git a/pod/perlcall.pod b/pod/perlcall.pod
index 359e097a18..f34a53dbfb 100644
--- a/pod/perlcall.pod
+++ b/pod/perlcall.pod
@@ -321,33 +321,30 @@ See I<Using G_EVAL> for details on using G_EVAL.
 
 =head2 G_KEEPERR
 
-You may have noticed that using the G_EVAL flag described above will
-B<always> clear the C<$@> variable and set it to a string describing
-the error iff there was an error in the called code.  This unqualified
-resetting of C<$@> can be problematic in the reliable identification of
-errors using the C<eval {}> mechanism, because the possibility exists
-that perl will call other code (end of block processing code, for
-example) between the time the error causes C<$@> to be set within
-C<eval {}>, and the subsequent statement which checks for the value of
-C<$@> gets executed in the user's script.
-
-This scenario will mostly be applicable to code that is meant to be
-called from within destructors, asynchronous callbacks, signal
-handlers, C<__DIE__> or C<__WARN__> hooks, and C<tie> functions.  In
-such situations, you will not want to clear C<$@> at all, but simply to
-append any new errors to any existing value of C<$@>.
+Using the G_EVAL flag described above will always set C<$@>: clearing
+it if there was no error, and setting it to describe the error if there
+was an error in the called code.  This is what you want if your intention
+is to handle possible errors, but sometimes you just want to trap errors
+and stop them interfering with the rest of the program.
+
+This scenario will mostly be applicable to code that is meant to be called
+from within destructors, asynchronous callbacks, and signal handlers.
+In such situations, where the code being called has little relation to the
+surrounding dynamic context, the main program needs to be insulated from
+errors in the called code, even if they can't be handled intelligently.
+It may also be useful to do this with code for C<__DIE__> or C<__WARN__>
+hooks, and C<tie> functions.
 
 The G_KEEPERR flag is meant to be used in conjunction with G_EVAL in
 I<call_*> functions that are used to implement such code.  This flag
 has no effect when G_EVAL is not used.
 
-When G_KEEPERR is used, any errors in the called code will be prefixed
-with the string "\t(in cleanup)", and appended to the current value
-of C<$@>.  an error will not be appended if that same error string is
-already at the end of C<$@>.
-
-In addition, a warning is generated using the appended string. This can be
-disabled using C<no warnings 'misc'>.
+When G_KEEPERR is used, any error in the called code will terminate the
+call as usual, and the error will not propagate beyond the call (as usual
+for G_EVAL), but it will not go into C<$@>.  Instead the error will be
+converted into a warning, prefixed with the string "\t(in cleanup)".
+This can be disabled using C<no warnings 'misc'>.  If there is no error,
+C<$@> will not be cleared.
 
 The G_KEEPERR flag was introduced in Perl version 5.002.
 
@@ -986,12 +983,15 @@ version of the call_Subtract example above inside a destructor:
     sub foo { die "foo dies"; }
 
     package main;
-    eval { Foo->new->foo };
+    {
+	my $foo = Foo->new;
+	eval { $foo->foo };
+    }
     print "Saw: $@" if $@;             # should be, but isn't
 
 This example will fail to recognize that an error occurred inside the
 C<eval {}>.  Here's why: the call_Subtract code got executed while perl
-was cleaning up temporaries when exiting the eval block, and because
+was cleaning up temporaries when exiting the outer braced block, and because
 call_Subtract is implemented with I<call_pv> using the G_EVAL
 flag, it promptly reset C<$@>.  This results in the failure of the
 outermost test for C<$@>, and thereby the failure of the error trap.
diff --git a/pp_ctl.c b/pp_ctl.c
index 4fc0bdfe87..37a585c614 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1572,48 +1572,17 @@ Perl_qerror(pTHX_ SV *err)
 }
 
 void
-Perl_die_where(pTHX_ SV *msv)
+Perl_die_unwind(pTHX_ SV *msv)
 {
     dVAR;
+    SV *exceptsv = sv_mortalcopy(msv);
+    U8 in_eval = PL_in_eval;
+    PERL_ARGS_ASSERT_DIE_UNWIND;
 
-    if (PL_in_eval) {
+    if (in_eval) {
 	I32 cxix;
 	I32 gimme;
 
-	if (msv) {
-	    if (PL_in_eval & EVAL_KEEPERR) {
-                static const char prefix[] = "\t(in cleanup) ";
-		SV * const err = ERRSV;
-		const char *e = NULL;
-		if (!SvPOK(err))
-		    sv_setpvs(err,"");
-		else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
-		    STRLEN len;
-		    STRLEN msglen;
-		    const char* message = SvPV_const(msv, msglen);
-		    e = SvPV_const(err, len);
-		    e += len - msglen;
-		    if (*e != *message || strNE(e,message))
-			e = NULL;
-		}
-		if (!e) {
-		    STRLEN start;
-		    SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
-		    sv_catpvn(err, prefix, sizeof(prefix)-1);
-		    sv_catsv(err, msv);
-		    start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
-		    Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
-				   SvPVX_const(err)+start);
-		}
-	    }
-	    else {
-		STRLEN msglen;
-		const char* message = SvPV_const(msv, msglen);
-		sv_setpvn(ERRSV, message, msglen);
-		SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
-	    }
-	}
-
 	while ((cxix = dopoptoeval(cxstack_ix)) < 0
 	       && PL_curstackinfo->si_prev)
 	{
@@ -1633,7 +1602,7 @@ Perl_die_where(pTHX_ SV *msv)
 	    POPBLOCK(cx,PL_curpm);
 	    if (CxTYPE(cx) != CXt_EVAL) {
 		STRLEN msglen;
-		const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
+		const char* message = SvPVx_const(exceptsv, msglen);
 		PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
 		PerlIO_write(Perl_error_log, message, msglen);
 		my_exit(1);
@@ -1654,7 +1623,7 @@ Perl_die_where(pTHX_ SV *msv)
 	    PL_curcop = cx->blk_oldcop;
 
 	    if (optype == OP_REQUIRE) {
-                const char* const msg = SvPVx_nolen_const(ERRSV);
+                const char* const msg = SvPVx_nolen_const(exceptsv);
                 (void)hv_store(GvHVn(PL_incgv),
                                SvPVX_const(namesv), SvCUR(namesv),
                                &PL_sv_undef, 0);
@@ -1665,6 +1634,13 @@ Perl_die_where(pTHX_ SV *msv)
 		DIE(aTHX_ "%sCompilation failed in require",
 		    *msg ? msg : "Unknown error\n");
 	    }
+	    if (in_eval & EVAL_KEEPERR) {
+		Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
+			       SvPV_nolen_const(exceptsv));
+	    }
+	    else {
+		sv_setsv(ERRSV, exceptsv);
+	    }
 	    assert(CxTYPE(cx) == CXt_EVAL);
 	    PL_restartjmpenv = cx->blk_eval.cur_top_env;
 	    PL_restartop = cx->blk_eval.retop;
@@ -1673,7 +1649,7 @@ Perl_die_where(pTHX_ SV *msv)
 	}
     }
 
-    write_to_stderr( msv ? msv : ERRSV );
+    write_to_stderr(exceptsv);
     my_failure_exit();
     /* NOTREACHED */
 }
@@ -3939,7 +3915,7 @@ PP(pp_leaveeval)
 			G_DISCARD);
 	retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
 			       SVfARG(namesv));
-	/* die_where() did LEAVE, or we won't be here */
+	/* die_unwind() did LEAVE, or we won't be here */
     }
     else {
 	LEAVE_with_name("eval");
diff --git a/pp_sys.c b/pp_sys.c
index 8dd8bc0635..f57bd1a57f 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -403,100 +403,91 @@ PP(pp_rcatline)
 PP(pp_warn)
 {
     dVAR; dSP; dMARK;
-    SV *tmpsv;
-    const char *tmps;
+    SV *exsv;
+    const char *pv;
     STRLEN len;
     if (SP - MARK > 1) {
 	dTARGET;
 	do_join(TARG, &PL_sv_no, MARK, SP);
-	tmpsv = TARG;
+	exsv = TARG;
 	SP = MARK + 1;
     }
     else if (SP == MARK) {
-	tmpsv = &PL_sv_no;
+	exsv = &PL_sv_no;
 	EXTEND(SP, 1);
 	SP = MARK + 1;
     }
     else {
-	tmpsv = TOPs;
-    }
-    tmps = SvPV_const(tmpsv, len);
-    if ((!tmps || !len) && PL_errgv) {
-  	SV * const error = ERRSV;
-	SvUPGRADE(error, SVt_PV);
-	if (SvPOK(error) && SvCUR(error))
-	    sv_catpvs(error, "\t...caught");
-	tmpsv = error;
-	tmps = SvPV_const(tmpsv, len);
+	exsv = TOPs;
     }
-    if (!tmps || !len)
-	tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
 
-    Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
+    if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
+	/* well-formed exception supplied */
+    }
+    else if (SvROK(ERRSV)) {
+	exsv = ERRSV;
+    }
+    else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
+	exsv = sv_mortalcopy(ERRSV);
+	sv_catpvs(exsv, "\t...caught");
+    }
+    else {
+	exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
+    }
+    warn_sv(exsv);
     RETSETYES;
 }
 
 PP(pp_die)
 {
     dVAR; dSP; dMARK;
-    const char *tmps;
-    SV *tmpsv;
+    SV *exsv;
+    const char *pv;
     STRLEN len;
-    bool multiarg = 0;
 #ifdef VMS
     VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
 #endif
     if (SP - MARK != 1) {
 	dTARGET;
 	do_join(TARG, &PL_sv_no, MARK, SP);
-	tmpsv = TARG;
-	tmps = SvPV_const(tmpsv, len);
-	multiarg = 1;
+	exsv = TARG;
 	SP = MARK + 1;
     }
     else {
-	tmpsv = TOPs;
-        tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
-    }
-    if (!tmps || !len) {
-	SV * const error = ERRSV;
-	SvUPGRADE(error, SVt_PV);
-	if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
-	    if (!multiarg)
-		SvSetSV(error,tmpsv);
-	    else if (sv_isobject(error)) {
-		HV * const stash = SvSTASH(SvRV(error));
-		GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
-		if (gv) {
-		    SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
-		    SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
-		    EXTEND(SP, 3);
-		    PUSHMARK(SP);
-		    PUSHs(error);
-		    PUSHs(file);
- 		    PUSHs(line);
-		    PUTBACK;
-		    call_sv(MUTABLE_SV(GvCV(gv)),
-			    G_SCALAR|G_EVAL|G_KEEPERR);
-		    sv_setsv(error,*PL_stack_sp--);
-		}
+	exsv = TOPs;
+    }
+
+    if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
+	/* well-formed exception supplied */
+    }
+    else if (SvROK(ERRSV)) {
+	exsv = ERRSV;
+	if (sv_isobject(exsv)) {
+	    HV * const stash = SvSTASH(SvRV(exsv));
+	    GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
+	    if (gv) {
+		SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
+		SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+		EXTEND(SP, 3);
+		PUSHMARK(SP);
+		PUSHs(exsv);
+		PUSHs(file);
+		PUSHs(line);
+		PUTBACK;
+		call_sv(MUTABLE_SV(GvCV(gv)),
+			G_SCALAR|G_EVAL|G_KEEPERR);
+		exsv = sv_mortalcopy(*PL_stack_sp--);
 	    }
-	    DIE(aTHX_ NULL);
-	}
-	else {
-	    if (SvPOK(error) && SvCUR(error))
-		sv_catpvs(error, "\t...propagated");
-	    tmpsv = error;
-	    if (SvOK(tmpsv))
-		tmps = SvPV_const(tmpsv, len);
-	    else
-		tmps = NULL;
 	}
     }
-    if (!tmps || !len)
-	tmpsv = newSVpvs_flags("Died", SVs_TEMP);
-
-    DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
+    else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
+	exsv = sv_mortalcopy(ERRSV);
+	sv_catpvs(exsv, "\t...propagated");
+    }
+    else {
+	exsv = newSVpvs_flags("Died", SVs_TEMP);
+    }
+    die_sv(exsv);
     RETURN;
 }
 
diff --git a/proto.h b/proto.h
index bbb1e3ae12..2593a1c556 100644
--- a/proto.h
+++ b/proto.h
@@ -321,6 +321,12 @@ PERL_CALLCONV OP*	Perl_convert(pTHX_ I32 optype, I32 flags, OP* o)
 			__attribute__warn_unused_result__;
 
 PERL_CALLCONV PERL_CONTEXT*	Perl_create_eval_scope(pTHX_ U32 flags);
+PERL_CALLCONV void	Perl_croak_sv(pTHX_ SV *baseex)
+			__attribute__noreturn__
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CROAK_SV	\
+	assert(baseex)
+
 PERL_CALLCONV void	Perl_croak(pTHX_ const char* pat, ...)
 			__attribute__noreturn__
 			__attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
@@ -523,14 +529,19 @@ PERL_CALLCONV char*	Perl_delimcpy(char* to, const char* toend, const char* from,
 	assert(to); assert(toend); assert(from); assert(fromend); assert(retlen)
 
 PERL_CALLCONV void	Perl_delete_eval_scope(pTHX);
+PERL_CALLCONV OP*	Perl_die_sv(pTHX_ SV *baseex)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DIE_SV	\
+	assert(baseex)
+
 PERL_CALLCONV OP*	Perl_die(pTHX_ const char* pat, ...)
 			__attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
 
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-STATIC OP*	S_vdie(pTHX_ const char* pat, va_list* args);
-#endif
-PERL_CALLCONV void	Perl_die_where(pTHX_ SV* msv)
-			__attribute__noreturn__;
+PERL_CALLCONV void	Perl_die_unwind(pTHX_ SV* ex)
+			__attribute__noreturn__
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DIE_UNWIND	\
+	assert(ex)
 
 PERL_CALLCONV void	Perl_dounwind(pTHX_ I32 cxix);
 /* PERL_CALLCONV bool	Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp)
@@ -1932,6 +1943,11 @@ PERL_CALLCONV SV*	Perl_mess(pTHX_ const char* pat, ...)
 #define PERL_ARGS_ASSERT_MESS	\
 	assert(pat)
 
+PERL_CALLCONV SV*	Perl_mess_sv(pTHX_ SV* basemsg, bool consume)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MESS_SV	\
+	assert(basemsg)
+
 PERL_CALLCONV SV*	Perl_vmess(pTHX_ const char* pat, va_list* args)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_VMESS	\
@@ -3825,6 +3841,11 @@ PERL_CALLCONV UV	Perl_get_hash_seed(pTHX)
 
 PERL_CALLCONV void	Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op);
 PERL_CALLCONV void	Perl_report_uninit(pTHX_ const SV *uninit_sv);
+PERL_CALLCONV void	Perl_warn_sv(pTHX_ SV *baseex)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WARN_SV	\
+	assert(baseex)
+
 PERL_CALLCONV void	Perl_warn(pTHX_ const char* pat, ...)
 			__attribute__format__(__printf__,pTHX_1,pTHX_2)
 			__attribute__nonnull__(pTHX_1);
@@ -6056,8 +6077,12 @@ STATIC const COP*	S_closest_cop(pTHX_ const COP *cop, const OP *o)
 	assert(cop)
 
 STATIC SV*	S_mess_alloc(pTHX);
-STATIC SV *	S_vdie_croak_common(pTHX_ const char *pat, va_list *args);
-STATIC bool	S_vdie_common(pTHX_ SV *message, bool warn);
+STATIC SV *	S_with_queued_errors(pTHX_ SV *ex)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS	\
+	assert(ex)
+
+STATIC bool	S_invoke_exception_hook(pTHX_ SV *ex, bool warn);
 STATIC char *	S_write_no_mem(pTHX)
 			__attribute__noreturn__;
 
diff --git a/t/lib/warnings/pp_ctl b/t/lib/warnings/pp_ctl
index afaf0a78db..9b3f2982e4 100644
--- a/t/lib/warnings/pp_ctl
+++ b/t/lib/warnings/pp_ctl
@@ -205,6 +205,24 @@ DESTROY { die "@{$_[0]} foo bar" }
 { bless ['B'], 'Foo' for 1..10 }
 EXPECT
 	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
 	(in cleanup) B foo bar at - line 4.
 ########
 # pp_ctl.c
diff --git a/t/op/die_except.t b/t/op/die_except.t
new file mode 100644
index 0000000000..b0fcadb8c8
--- /dev/null
+++ b/t/op/die_except.t
@@ -0,0 +1,81 @@
+#!./perl
+
+print "1..12\n";
+my $test_num = 0;
+sub ok {
+    print $_[0] ? "" : "not ", "ok ", ++$test_num, "\n";
+}
+
+{
+    package End;
+    sub DESTROY { $_[0]->() }
+    sub main::end(&) {
+	my($cleanup) = @_;
+	return bless(sub { $cleanup->() }, "End");
+    }
+}
+
+my($val, $err);
+
+$@ = "t0\n";
+$val = eval {
+	$@ = "t1\n";
+	1;
+}; $err = $@;
+ok $val == 1;
+ok $err eq "";
+
+$@ = "t0\n";
+$val = eval {
+	$@ = "t1\n";
+	do {
+		die "t3\n";
+	};
+	1;
+}; $err = $@;
+ok !defined($val);
+ok $err eq "t3\n";
+
+$@ = "t0\n";
+$val = eval {
+	$@ = "t1\n";
+	local $@ = "t2\n";
+	1;
+}; $err = $@;
+ok $val == 1;
+ok $err eq "";
+
+$@ = "t0\n";
+$val = eval {
+	$@ = "t1\n";
+	local $@ = "t2\n";
+	do {
+		die "t3\n";
+	};
+	1;
+}; $err = $@;
+ok !defined($val);
+ok $err eq "t3\n";
+
+$@ = "t0\n";
+$val = eval {
+	$@ = "t1\n";
+	my $c = end { $@ = "t2\n"; };
+	1;
+}; $err = $@;
+ok $val == 1;
+ok $err eq "";
+
+$@ = "t0\n";
+$val = eval {
+	$@ = "t1\n";
+	my $c = end { $@ = "t2\n"; };
+	do {
+		die "t3\n";
+	};
+	1;
+}; $err = $@;
+ok !defined($val);
+ok $err eq "t3\n";
+
+1;
diff --git a/t/op/die_keeperr.t b/t/op/die_keeperr.t
new file mode 100644
index 0000000000..9b41cb5935
--- /dev/null
+++ b/t/op/die_keeperr.t
@@ -0,0 +1,45 @@
+#!perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    require 'test.pl';
+    plan(20);
+}
+
+sub End::DESTROY { $_[0]->() }
+
+sub end(&) {
+    my($c) = @_;
+    return bless(sub { $c->() }, "End");
+}
+
+foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
+    foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
+	my $warn = "";
+	local $SIG{__WARN__} = sub { $warn .= $_[0] };
+	{
+	    $@ = $outx;
+	    my $e = end { die $inx if $inx };
+	}
+	ok ref($@) eq ref($outx) && $@ eq $outx;
+	$warn =~ s/ at [^\n]*\n\z//;
+	is $warn, $inx ? "\t(in cleanup) $inx" : "";
+    }
+}
+
+{
+    no warnings "misc";
+    my $warn = "";
+    local $SIG{__WARN__} = sub { $warn .= $_[0] };
+    { my $e = end { die "aa\n"; }; }
+    is $warn, "";
+}
+
+{
+    my $warn = "";
+    local $SIG{__WARN__} = sub { $warn .= $_[0] };
+    { my $e = end { no warnings "misc"; die "aa\n"; }; }
+    is $warn, "\t(in cleanup) aa\n";
+}
+
+1;
diff --git a/t/op/eval.t b/t/op/eval.t
index 98fbc1e51c..ff5004eae5 100644
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -526,6 +526,8 @@ if (eval "use Devel::Peek; 1;") {
         my $in = <IN>;
         my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2);
         $first =~ s/,pNOK//;
+        s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
+        s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
         $ok = 1 if ($first eq $second);
       }
     }
diff --git a/t/op/warn.t b/t/op/warn.t
new file mode 100644
index 0000000000..ec3b9ca67f
--- /dev/null
+++ b/t/op/warn.t
@@ -0,0 +1,108 @@
+#!./perl
+#line 3 warn.t
+
+print "1..18\n";
+my $test_num = 0;
+sub ok {
+    print $_[0] ? "" : "not ", "ok ", ++$test_num, "\n";
+}
+
+my @warnings;
+my $wa = []; my $ea = [];
+$SIG{__WARN__} = sub { push @warnings, $_[0] };
+
+@warnings = ();
+$@ = "";
+warn "foo\n";
+ok @warnings==1 && $warnings[0] eq "foo\n";
+
+@warnings = ();
+$@ = "";
+warn "foo", "bar\n";
+ok @warnings==1 && $warnings[0] eq "foobar\n";
+
+@warnings = ();
+$@ = "";
+warn "foo";
+ok @warnings==1 && $warnings[0] eq "foo at warn.t line 26.\n";
+
+@warnings = ();
+$@ = "";
+warn $wa;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
+
+@warnings = ();
+$@ = "";
+warn "";
+ok @warnings==1 &&
+    $warnings[0] eq "Warning: something's wrong at warn.t line 36.\n";
+
+@warnings = ();
+$@ = "";
+warn;
+ok @warnings==1 &&
+    $warnings[0] eq "Warning: something's wrong at warn.t line 42.\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn "foo\n";
+ok @warnings==1 && $warnings[0] eq "foo\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn "foo", "bar\n";
+ok @warnings==1 && $warnings[0] eq "foobar\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn "foo";
+ok @warnings==1 && $warnings[0] eq "foo at warn.t line 58.\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn $wa;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
+
+@warnings = ();
+$@ = "ERR\n";
+warn "";
+ok @warnings==1 &&
+    $warnings[0] eq "ERR\n\t...caught at warn.t line 68.\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn;
+ok @warnings==1 &&
+    $warnings[0] eq "ERR\n\t...caught at warn.t line 74.\n";
+
+@warnings = ();
+$@ = $ea;
+warn "foo\n";
+ok @warnings==1 && $warnings[0] eq "foo\n";
+
+@warnings = ();
+$@ = $ea;
+warn "foo", "bar\n";
+ok @warnings==1 && $warnings[0] eq "foobar\n";
+
+@warnings = ();
+$@ = $ea;
+warn "foo";
+ok @warnings==1 && $warnings[0] eq "foo at warn.t line 90.\n";
+
+@warnings = ();
+$@ = $ea;
+warn $wa;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
+
+@warnings = ();
+$@ = $ea;
+warn "";
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
+
+@warnings = ();
+$@ = $ea;
+warn;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
+
+1;
diff --git a/util.c b/util.c
index a1a71df126..2eb2cc14cd 100644
--- a/util.c
+++ b/util.c
@@ -1124,6 +1124,21 @@ Perl_vform(pTHX_ const char *pat, va_list *args)
     return SvPVX(sv);
 }
 
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 SV *
 Perl_mess_nocontext(const char *pat, ...)
@@ -1186,15 +1201,57 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     return NULL;
 }
 
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+Expands a message, intended for the user, to include an indication of
+the current location in the code, if the message does not already appear
+to be complete.
+
+C<basemsg> is the initial message or object.  If it is a reference, it
+will be used as-is and will be the result of this function.  Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution.  The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function.  If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
 SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 {
     dVAR;
-    SV * const sv = mess_alloc();
+    SV *sv;
 
-    PERL_ARGS_ASSERT_VMESS;
+    PERL_ARGS_ASSERT_MESS_SV;
+
+    if (SvROK(basemsg)) {
+	if (consume) {
+	    sv = basemsg;
+	}
+	else {
+	    sv = mess_alloc();
+	    sv_setsv(sv, basemsg);
+	}
+	return sv;
+    }
+
+    if (SvPOK(basemsg) && consume) {
+	sv = basemsg;
+    }
+    else {
+	sv = mess_alloc();
+	sv_copypv(sv, basemsg);
+    }
 
-    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
 	/*
 	 * Try and find the file and line for PL_op.  This will usually be
@@ -1228,6 +1285,34 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
     return sv;
 }
 
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+    dVAR;
+    SV * const sv = mess_alloc();
+
+    PERL_ARGS_ASSERT_VMESS;
+
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+    return mess_sv(sv, 1);
+}
+
 void
 Perl_write_to_stderr(pTHX_ SV* msv)
 {
@@ -1279,10 +1364,26 @@ Perl_write_to_stderr(pTHX_ SV* msv)
     }
 }
 
-/* Common code used by vcroak, vdie, vwarn and vwarner  */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+    PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+    if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+	sv_catsv(PL_errors, ex);
+	ex = sv_mortalcopy(PL_errors);
+	SvCUR_set(PL_errors, 0);
+    }
+    return ex;
+}
 
 STATIC bool
-S_vdie_common(pTHX_ SV *message, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 {
     dVAR;
     HV *stash;
@@ -1292,7 +1393,8 @@ S_vdie_common(pTHX_ SV *message, bool warn)
     /* sv_2cv might call Perl_croak() or Perl_warner() */
     SV * const oldhook = *hook;
 
-    assert(oldhook);
+    if (!oldhook)
+	return FALSE;
 
     ENTER;
     SAVESPTR(*hook);
@@ -1301,7 +1403,7 @@ S_vdie_common(pTHX_ SV *message, bool warn)
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
 	dSP;
-	SV *msg;
+	SV *exarg;
 
 	ENTER;
 	save_re_context();
@@ -1309,18 +1411,13 @@ S_vdie_common(pTHX_ SV *message, bool warn)
 	    SAVESPTR(*hook);
 	    *hook = NULL;
 	}
-	if (warn || message) {
-	    msg = newSVsv(message);
-	    SvREADONLY_on(msg);
-	    SAVEFREESV(msg);
-	}
-	else {
-	    msg = ERRSV;
-	}
+	exarg = newSVsv(ex);
+	SvREADONLY_on(exarg);
+	SAVEFREESV(exarg);
 
 	PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
 	PUSHMARK(SP);
-	XPUSHs(msg);
+	XPUSHs(exarg);
 	PUTBACK;
 	call_sv(MUTABLE_SV(cv), G_DISCARD);
 	POPSTACK;
@@ -1330,81 +1427,147 @@ S_vdie_common(pTHX_ SV *message, bool warn)
     return FALSE;
 }
 
-STATIC SV *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args)
-{
-    dVAR;
-    SV *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
 
-    if (pat) {
-	SV * const msv = vmess(pat, args);
-	if (PL_errors && SvCUR(PL_errors)) {
-	    sv_catsv(PL_errors, msv);
-	    message = sv_mortalcopy(PL_errors);
-	    SvCUR_set(PL_errors, 0);
-	}
-	else
-	    message = msv;
-    }
-    else {
-	message = NULL;
-    }
+Behaves the same as L</croak_sv>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
 
-    if (PL_diehook) {
-	S_vdie_common(aTHX_ message, FALSE);
-    }
-    return message;
-}
+=cut
+*/
 
-static OP *
-S_vdie(pTHX_ const char* pat, va_list *args)
+OP *
+Perl_die_sv(pTHX_ SV *baseex)
 {
-    dVAR;
-    SV *message;
-
-    message = vdie_croak_common(pat, args);
-
-    die_where(message);
+    PERL_ARGS_ASSERT_DIE_SV;
+    croak_sv(baseex);
     /* NOTREACHED */
     return NULL;
 }
 
+/*
+=for apidoc Am|OP *|die|const char *pat|...
+
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 OP *
 Perl_die_nocontext(const char* pat, ...)
 {
     dTHX;
-    OP *o;
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
-    return o;
+    return NULL;
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
 {
-    OP *o;
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
-    return o;
+    return NULL;
 }
 
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
+
+This is an XS interface to Perl's C<die> function.
+
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
+
 void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
+Perl_croak_sv(pTHX_ SV *baseex)
 {
-    dVAR;
-    SV *msv;
+    SV *ex = with_queued_errors(mess_sv(baseex, 0));
+    PERL_ARGS_ASSERT_CROAK_SV;
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
+}
+
+/*
+=for apidoc Am|void|vcroak|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<die> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
 
-    msv = S_vdie_croak_common(aTHX_ pat, args);
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
 
-    die_where(msv);
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
+{
+    SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
 }
 
+/*
+=for apidoc Am|void|croak|const char *pat|...
+
+This is an XS interface to Perl's C<die> function.
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
 Perl_croak_nocontext(const char *pat, ...)
@@ -1418,51 +1581,89 @@ Perl_croak_nocontext(const char *pat, ...)
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+    va_list args;
+    va_start(args, pat);
+    vcroak(pat, &args);
+    /* NOTREACHED */
+    va_end(args);
+}
+
 /*
-=head1 Warning and Dieing
+=for apidoc Am|void|warn_sv|SV *baseex
 
-=for apidoc croak
+This is an XS interface to Perl's C<warn> function.
 
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function.  Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
 
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<NULL> to croak():
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
 
-   errsv = get_sv("@", GV_ADD);
-   sv_setsv(errsv, exception_object);
-   croak(NULL);
+To warn with a simple string message, the L</warn> function may be
+more convenient.
 
 =cut
 */
 
 void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_warn_sv(pTHX_ SV *baseex)
 {
-    va_list args;
-    va_start(args, pat);
-    vcroak(pat, &args);
-    /* NOTREACHED */
-    va_end(args);
+    SV *ex = mess_sv(baseex, 0);
+    PERL_ARGS_ASSERT_WARN_SV;
+    if (!invoke_exception_hook(ex, TRUE))
+	write_to_stderr(ex);
 }
 
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
 void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
-    dVAR;
-    SV * const msv = vmess(pat, args);
-
+    SV *ex = vmess(pat, args);
     PERL_ARGS_ASSERT_VWARN;
+    if (!invoke_exception_hook(ex, TRUE))
+	write_to_stderr(ex);
+}
 
-    if (PL_warnhook) {
-	if (vdie_common(msv, TRUE))
-	    return;
-    }
+/*
+=for apidoc Am|void|warn|const char *pat|...
 
-    write_to_stderr(msv);
-}
+This is an XS interface to Perl's C<warn> function.
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
@@ -1477,15 +1678,6 @@ Perl_warn_nocontext(const char *pat, ...)
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
-/*
-=for apidoc warn
-
-This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
-function the same way you call the C C<printf> function.  See C<croak>.
-
-=cut
-*/
-
 void
 Perl_warn(pTHX_ const char *pat, ...)
 {
@@ -1553,11 +1745,8 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
 	SV * const msv = vmess(pat, args);
 
-	if (PL_diehook) {
-	    assert(msv);
-	    S_vdie_common(aTHX_ msv, FALSE);
-	}
-	die_where(msv);
+	invoke_exception_hook(msv, FALSE);
+	die_unwind(msv);
     }
     else {
 	Perl_vwarn(aTHX_ pat, args);