stackalloc.patch

commit fc3093b45eb9ff0790ca25118825401fb7e1c7e4
Author: Daniel Dragan <bulk88@hotmail.com>
Date: Mon May 19 23:07:26 2014 -0400

WIP replace Perl stack with C style stack on Win32

diff --git a/dump.c b/dump.c
index 354cd57..ddbf65d 100644
--- a/dump.c
+++ b/dump.c
@@ -2385,19 +2385,50 @@ Perl_sv_dump(pTHX_ SV *sv)
PERL_ARGS_ASSERT_SV_DUMP;

if (SvROK(sv))
do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
else
do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
}

+
+static
+DWORD
+S_fix_stack(LPEXCEPTION_POINTERS exceptions) {
+ dTHX;
+ MEMORY_BASIC_INFORMATION mbi;
+ DWORD_PTR newalloc;
+ //this is inefficient, these things should be stored somewhere in interp struct
+ if(VirtualQuery(PL_stack_base,&mbi,sizeof(mbi)) != sizeof(mbi)){
+ DebugBreak();
+ fprintf(stderr, "VQ failed %u\n", GetLastError());
+ exit(1);
+ }
+ newalloc = (DWORD_PTR)mbi.AllocationBase+(DWORD_PTR)mbi.RegionSize;
+ if(!VirtualAlloc(newalloc,
+ 4096,
+ MEM_COMMIT,
+ PAGE_READWRITE|PAGE_GUARD
+ )) {
+ DebugBreak();
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+
+ return EXCEPTION_CONTINUE_EXECUTION;
+}
+
+
+
int
Perl_runops_debug(pTHX)
{
+__try
+{
dVAR;
if (!PL_op) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
return 0;
}

DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
do {
@@ -2425,16 +2456,21 @@ Perl_runops_debug(pTHX)
}

OP_ENTRY_PROBE(OP_NAME(PL_op));
} while ((PL_op = PL_op->op_ppaddr(aTHX)));
DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
PERL_ASYNC_CHECK();

TAINT_NOT;
+}
+//needs bounds checks to make sure the STATUS_GUARD_PAGE_VIOLATION is for Perl stack and not some other c lib doing the same thing
+__except(GetExceptionCode() == STATUS_GUARD_PAGE_VIOLATION ? S_fix_stack(GetExceptionInformation()) : EXCEPTION_CONTINUE_SEARCH) {
+ NOOP;
+}
return 0;
}

I32
Perl_debop(pTHX_ const OP *o)
{
dVAR;

diff --git a/perl.h b/perl.h
index 6da39f3..42ad440 100644
--- a/perl.h
+++ b/perl.h
@@ -197,16 +197,17 @@
#define _CPERLarg
#define PERL_OBJECT_THIS
#define _PERL_OBJECT_THIS
#define PERL_OBJECT_THIS_
#define CALL_FPTR(fptr) (*fptr)
#define MEMBER_TO_FPTR(name) name
#endif /* !PERL_CORE */

+//put call to func that has __try/__catch, then calls PL_runops here?
#define CALLRUNOPS PL_runops

#define CALLREGCOMP(sv, flags) Perl_pregcomp(aTHX_ (sv),(flags))

#define CALLREGCOMP_ENG(prog, sv, flags) (prog)->comp(aTHX_ sv, flags)
#define CALLREGEXEC(prog,stringarg,strend,strbeg,minend,sv,data,flags) \
RX_ENGINE(prog)->exec(aTHX_ (prog),(stringarg),(strend), \
(strbeg),(minend),(sv),(data),(flags))
diff --git a/pp.h b/pp.h
index 97738c2..0d72d2f 100644
--- a/pp.h
+++ b/pp.h
@@ -275,22 +275,22 @@ Does not use C<TARG>. See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
/* Same thing, but update mark register too. */
# define MEXTEND(p,n) STMT_START { \
const int markoff = mark - PL_stack_base; \
sp = stack_grow(sp,p,(SSize_t) (n)); \
mark = PL_stack_base + markoff; \
} STMT_END
#else
# define EXTEND(p,n) (void)(UNLIKELY(PL_stack_max - p < (SSize_t)(n)) && \
- (sp = stack_grow(sp,p, (SSize_t) (n))))
+ (sp = sp))

/* Same thing, but update mark register too. */
# define MEXTEND(p,n) STMT_START {if (UNLIKELY(PL_stack_max - p < (int)(n))) {\
const int markoff = mark - PL_stack_base; \
- sp = stack_grow(sp,p,(SSize_t) (n)); \
+ sp = sp; \
mark = PL_stack_base + markoff; \
} } STMT_END
#endif

#define PUSHs(s) (*++sp = (s))
#define PUSHTARG STMT_START { SvSETMAGIC(TARG); PUSHs(TARG); } STMT_END
#define PUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); PUSHTARG; } STMT_END
#define PUSHn(n) STMT_START { sv_setnv(TARG, (NV)(n)); PUSHTARG; } STMT_END
diff --git a/pp_ctl.c b/pp_ctl.c
index 380a7fe..2d4f8d2 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -996,18 +996,24 @@ PP(pp_mapwhile)
if (shift < count)
shift = count; /* Avoid shifting too often --Ben Tilly */

EXTEND(SP,shift);
src = SP;
dst = (SP += shift);
PL_markstack_ptr[-1] += shift;
*PL_markstack_ptr += shift;
- while (count--)
- *dst-- = *src--;
+ //copy upwards not downwards
+ if(count) {
+ SV** dst1 = dst;
+ SV** src1 = src;
+ dst1 -= (count-1);
+ src1 -= (count-1);
+ memcpy(dst1, src1, sizeof(SV**)*count);
+ }
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
if (gimme == G_ARRAY) {
/* add returned items to the collection (making mortal copies
* if necessary), then clear the current temps stack frame
* *except* for those items. We do this splicing the items
* into the start of the tmps frame (so some items may be on
diff --git a/run.c b/run.c
index ff3bc93..f5343d1 100644
--- a/run.c
+++ b/run.c
@@ -28,28 +28,64 @@
/*
* 'Away now, Shadowfax! Run, greatheart, run as you have never run before!
* Now we are come to the lands where you were foaled, and every stone you
* know. Run now! Hope is in speed!' --Gandalf
*
* [p.600 of _The Lord of the Rings_, III/xi: "The Palantír"]
*/

+
+static
+DWORD
+S_fix_stack(LPEXCEPTION_POINTERS exceptions) {
+ dTHX;
+ MEMORY_BASIC_INFORMATION mbi;
+ DWORD_PTR newalloc;
+ //this is inefficient, these things should be stored somewhere in interp struct
+ if(VirtualQuery(PL_stack_base,&mbi,sizeof(mbi)) != sizeof(mbi)){
+ DebugBreak();
+ fprintf(stderr, "VQ failed %u\n", GetLastError());
+ exit(1);
+ }
+ newalloc = (DWORD_PTR)mbi.AllocationBase+(DWORD_PTR)mbi.RegionSize;
+ if(!VirtualAlloc(newalloc,
+ 4096,
+ MEM_COMMIT,
+ PAGE_READWRITE|PAGE_GUARD
+ )) {
+ DebugBreak();
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+
+ return EXCEPTION_CONTINUE_EXECUTION;
+}
+
+
+
int
Perl_runops_standard(pTHX)
{
+__try
+{
dVAR;
OP *op = PL_op;
OP_ENTRY_PROBE(OP_NAME(op));
while ((PL_op = op = op->op_ppaddr(aTHX))) {
OP_ENTRY_PROBE(OP_NAME(op));
}
PERL_ASYNC_CHECK();

TAINT_NOT;
+}
+//needs bounds checks to make sure the STATUS_GUARD_PAGE_VIOLATION is for Perl stack and not some other c lib doing the same thing
+__except(GetExceptionCode() == STATUS_GUARD_PAGE_VIOLATION ? S_fix_stack(GetExceptionInformation()) : EXCEPTION_CONTINUE_SEARCH) {
+ NOOP;
+}
return 0;
}

/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
* indent-tabs-mode: nil
diff --git a/scope.c b/scope.c
index 07f24b7..b0768b9 100644
--- a/scope.c
+++ b/scope.c
@@ -48,20 +48,64 @@ Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
#define GROW(old) ((old) + 1)
#endif

PERL_SI *
Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
{
dVAR;
PERL_SI *si;
+ void *avarr;
+ void * avarr2;
+ void * toalloc;
Newx(si, 1, PERL_SI);
si->si_stack = newAV();
AvREAL_off(si->si_stack);
- av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
+ //av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
+ Safefree(AvALLOC(si->si_stack));
+ AvALLOC(si->si_stack) = NULL;
+ AvARRAY(si->si_stack) = NULL;
+ AvMAX(si->si_stack) = SSize_t_MAX/sizeof(SV*);
+ fprintf(stderr, "stack alloc NSI av=%x\n", si->si_stack);
+ avarr = VirtualAlloc(
+ NULL,
+ 33554432, //2^25 32 MB
+ MEM_RESERVE,
+ PAGE_NOACCESS
+ );
+ if(!avarr) {
+ DWORD e = GetLastError();
+ DebugBreak();
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+ //4096 (page size) should be constant or runtime lookup from Win32 API, for
+ //constant research 32 and 64 bit behavior and meaning of "large pages"
+ if(! (avarr2 = VirtualAlloc(avarr,
+ 4096,
+ MEM_COMMIT,
+ PAGE_READWRITE
+ ))) {
+ DebugBreak();
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+ (DWORD_PTR)toalloc = (DWORD_PTR)avarr+(DWORD_PTR)4096;
+ if(!VirtualAlloc(toalloc,
+ 4096,
+ MEM_COMMIT,
+ PAGE_READWRITE|PAGE_GUARD
+ )) {
+ DebugBreak();
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+ AvALLOC(si->si_stack) = (SV**)avarr;
+ AvARRAY(si->si_stack) = (SV**)avarr;
+
AvALLOC(si->si_stack)[0] = &PL_sv_undef;
AvFILLp(si->si_stack) = 0;
si->si_prev = 0;
si->si_next = 0;
si->si_cxmax = cxitems - 1;
si->si_cxix = -1;
si->si_type = PERLSI_UNDEF;
Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
diff --git a/sv.c b/sv.c
index b43fadf..7301b24 100644
--- a/sv.c
+++ b/sv.c
@@ -6427,17 +6427,30 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
if (AvREAL(av) && AvFILLp(av) > -1) {
next_sv = AvARRAY(av)[AvFILLp(av)--];
/* save old iter_sv in top-most slot of AV,
* and pray that it doesn't get wiped in the meantime */
AvARRAY(av)[AvMAX(av)] = iter_sv;
iter_sv = sv;
goto get_next_sv; /* process this new sv */
}
- Safefree(AvALLOC(av));
+ if(!AvREAL((const AV *)av) && AvMAX((const AV *)av) == SSize_t_MAX/sizeof(SV*)) {
+ fprintf(stderr, "stack dealloc av=%x\n", av);
+ if(!VirtualFree(
+ AvALLOC(av),
+ 0,
+ MEM_RELEASE
+ )) {
+ fprintf(stderr, "VF failed %u\n", GetLastError());
+ exit(1);
+ }
+ }
+ else {
+ Safefree(AvALLOC(av));
+ }
}

break;
case SVt_PVLV:
if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
@@ -6771,23 +6784,28 @@ Perl_sv_free(pTHX_ SV *const sv)
{
SvREFCNT_dec(sv);
}


/* Private helper function for SvREFCNT_dec().
* Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */

+SV * watch_sv;
+
void
Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
{
dVAR;

PERL_ARGS_ASSERT_SV_FREE2;

+ if( sv == watch_sv) {
+ DebugBreak();
+ }
if (LIKELY( rc == 1 )) {
/* normal case */
SvREFCNT(sv) = 0;

#ifdef DEBUGGING
if (SvTEMP(sv)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
"Attempt to free temp prematurely: SV 0x%"UVxf
@@ -12675,32 +12693,74 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
break;
case SVt_PVAV:
/* avoid cloning an empty array */
if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
SV **dst_ary, **src_ary;
SSize_t items = AvFILLp((const AV *)sstr) + 1;

src_ary = AvARRAY((const AV *)sstr);
- Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
+ if(!AvREAL((const AV *)sstr) && AvMAX((const AV *)sstr) == SSize_t_MAX/sizeof(SV*)) {
+ MEMORY_BASIC_INFORMATION mbi;
+ void * avarr;
+ DWORD_PTR toalloc;
+ void * avarr2;
+ fprintf(stderr, "stack alloc S_sv_dup_common src av=%x dst av=%x\n", sstr, dstr);
+ if(VirtualQuery(src_ary,&mbi,sizeof(mbi)) != sizeof(mbi)){
+ DebugBreak();
+ fprintf(stderr, "VQ failed %u\n", GetLastError());
+ exit(1);
+ }
+ avarr = VirtualAlloc(
+ NULL,
+ 33554432, //2^25 32 MB
+ MEM_RESERVE,
+ PAGE_NOACCESS
+ );
+ if(!avarr) {
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+ if(! (avarr2 = VirtualAlloc(avarr,
+ mbi.RegionSize,
+ MEM_COMMIT,
+ PAGE_READWRITE
+ ))) {
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+ toalloc = (DWORD_PTR) avarr + mbi.RegionSize;
+ if(!VirtualAlloc(toalloc,
+ 4096,
+ MEM_COMMIT,
+ PAGE_READWRITE|PAGE_GUARD
+ )) {
+ fprintf(stderr, "VA failed %u\n", GetLastError());
+ exit(1);
+ }
+ dst_ary = avarr;
+ } else {
+ Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
+ }
ptr_table_store(PL_ptr_table, src_ary, dst_ary);
AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
AvALLOC((const AV *)dstr) = dst_ary;
if (AvREAL((const AV *)sstr)) {
dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
param);
}
else {
while (items-- > 0)
*dst_ary++ = sv_dup(*src_ary++, param);
}
- items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
- while (items-- > 0) {
- *dst_ary++ = &PL_sv_undef;
- }
+ //is this really needed? This is uninit space I think
+ // items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
+ // while (items-- > 0) {
+ // *dst_ary++ = &PL_sv_undef;
+ // }
}
else {
AvARRAY(MUTABLE_AV(dstr)) = NULL;
AvALLOC((const AV *)dstr) = (SV**)NULL;
AvMAX( (const AV *)dstr) = -1;
AvFILLp((const AV *)dstr) = -1;
}
break;