From e6c7d06e70a68dfbd410faf035c8fedbc4096476 Mon Sep 17 00:00:00 2001 From: Henry Rich Date: Fri, 4 Oct 2024 10:33:30 -0400 Subject: [PATCH] jtgc bug crossing NTSTACKBLOCK bdy; audits in RETF; use RETF more; zaptstackend() in every[2] --- jsrc/ar.c | 14 +++++++------- jsrc/cu.c | 11 +++++------ jsrc/j.h | 13 +++++++------ jsrc/m.c | 13 ++++++++----- jsrc/p.c | 1 + jsrc/sc.c | 1 - 6 files changed, 28 insertions(+), 25 deletions(-) diff --git a/jsrc/ar.c b/jsrc/ar.c index e0f6c95c0..d22684c48 100644 --- a/jsrc/ar.c +++ b/jsrc/ar.c @@ -827,7 +827,7 @@ TW3(INTX,CEQ)+TW3(INTX,CLT)+TW3(INTX,CLE)+TW3(INTX,CGT)+TW3(INTX,CGE)+TW3(INTX,C #endif static DF1(jtreduce){A z;I d,f,m,n,r,t,wr,*ws,zt; F1PREFIP;ARGCHK1(w); - if(unlikely(ISSPARSE(AT(w))))R reducesp(w,self); // If sparse, go handle it + if(unlikely(ISSPARSE(AT(w))))RETF(reducesp(w,self)); // If sparse, go handle it wr=AR(w); ws=AS(w); // Create r: the effective rank; f: length of frame; n: # items in a CELL of w r=(RANKT)jt->ranks; r=wrfgh[0]); // 0 item: return a neutral using shape and rank. Rank is still set + if(unlikely(n==1))RETF(head(w)); // 1 item: the result is the item. Rank is still set + if(unlikely(n==0))RETF(red0(w,FAV(self)->fgh[0])); // 0 item: return a neutral using shape and rank. Rank is still set if(unlikely(r==1))if(likely(wt&B01+LIT+INT+FL+SBT+C2T+C4T)){ // 2 items: special processing only if the operation is on rank 1: then we avoid loop overheads C id=FAV(FAV(self)->fgh[0])->id; if(unlikely(BETWEENC(id,CSTARCO,CMAX))){ // only boolean results are supported @@ -844,7 +844,7 @@ static DF1(jtreduce){A z;I d,f,m,n,r,t,wr,*ws,zt; #if !SY_64 cwd=(cv>>LGBW)==2?TWV2:cwd; cwd=(cv>>LGBW)==3?TWV3:cwd; #endif - if(likely(((1LL<<(cv&(BW-1)))&cwd)!=0))R jtreduce2(jt,w,cv,f); + if(likely(((1LL<<(cv&(BW-1)))&cwd)!=0))RETF(jtreduce2(jt,w,cv,f)); } } // fall through for 2 items that can't be handled specially } @@ -857,7 +857,7 @@ static DF1(jtreduce){A z;I d,f,m,n,r,t,wr,*ws,zt; // Normal processing for multiple items. Get the routine & flags to process it VARPS adocv; varps(adocv,self,wt,0); // If there is no special routine, go perform general reduce - if(!adocv.f)R redg(w,self); // jt->ranks is still set. redg will clear the ranks + if(!adocv.f)RETF(redg(w,self)); // jt->ranks is still set. redg will clear the ranks // Here for primitive reduce handled by special code. // Calculate m: #cells of w to operate on; d: #atoms in an item of a cell of w (a cell to which u is applied); // zn: #atoms in result @@ -874,11 +874,11 @@ static DF1(jtreduce){A z;I d,f,m,n,r,t,wr,*ws,zt; // Convert inputs if needed if((t=atype(adocv.cv))&&TYPESNE(t,wt))RZ(w=cvt(t,w)); // call the selected reduce routine. - I rc=((AHDRRFN*)adocv.f)(d,n,m,AV(w),AV(z),jt); + I rc=((AHDRRFN*)adocv.f)(d,n,m,AV(w),AV(z),jt); // if return is EWOV, it's an integer overflow and we must restart, after restoring the ranks // EWOV1 means that there was an overflow on a single result, which was calculated accurately and stored as a D. So in that case all we // have to do is change the type of the result. - if(unlikely((255&~EVNOCONV)&rc)){if(unlikely(rc==EVNOCONV))R z; if(jt->jerr==EWOV1){AT(z)=FL;RETF(z);}else {jsignal(rc); RETF(rc>=EWOV?IRS1(w,self,r,jtreduce,z):0);}} else {RETF((adocv.cv&VRI+VRD)&&rc!=EVNOCONV?cvz(adocv.cv,z):z);} + if(unlikely((255&~EVNOCONV)&rc)){if(unlikely(rc==EVNOCONV))RETF(z); if(jt->jerr==EWOV1){AT(z)=FL;RETF(z);}else {jsignal(rc); RETF(rc>=EWOV?IRS1(w,self,r,jtreduce,z):0);}} else {RETF((adocv.cv&VRI+VRD)&&rc!=EVNOCONV?cvz(adocv.cv,z):z);} } /* f/"r w main control */ static A jtredcatsp(J jt,A w,A z,I r){A a,q,x,y;B*b;I c,d,e,f,j,k,m,n,n1,p,*u,*v,wr,*ws,xr;P*wp,*zp; diff --git a/jsrc/cu.c b/jsrc/cu.c index c3560e45d..0d51c1d81 100644 --- a/jsrc/cu.c +++ b/jsrc/cu.c @@ -94,7 +94,7 @@ A jtevery(J jt, A w, A fs){A * RESTRICT wv,x,z,* RESTRICT zv; // prepare the result so that it can be incorporated into the overall boxed result if(likely(!(flags&JTWILLBEOPENED))) { // normal case where we are creating the result box. Must incorp the result - realizeifvirtual(x); razap(x); // Since we are moving the result into a recursive box, we must ra() it. This plus rifv plus pristine removal=INCORPRA. We could save some fetches by bundling this code into the DIRECT path + realizeifvirtual(x); razaptstackend(x); // Since we are moving the result into a recursive box, we must ra() it. This plus rifv plus pristine removal=INCORPRA. We could save some fetches by bundling this code into the DIRECT path // razap OK, because if the result is inplaceable it must be newly created or an input from here; in either case the value is not up the tstack } else { // result will be opened. It is nonrecursive. description in result.h. We don't have to realize or ra @@ -168,7 +168,7 @@ A jtevery2(J jt, A a, A w, A fs){A*av,*wv,x,z,*zv; // Verify agreement ASSERTAGREE(AS(a),AS(w),cf); // frames must agree // Allocate result - GATV(z,BOX,natoms,lr,AS(la)); if(unlikely(!natoms))R z; zv=AAV(z); // make sure we don't fetch outside empty arg + GATV(z,BOX,natoms,lr,AS(la)); if(unlikely(!natoms))RETF(z) zv=AAV(z); // make sure we don't fetch outside empty arg } // If the result will be immediately unboxed, we create a NONrecursive result and we can store virtual blocks in it. This echoes what result.h does. flags|=ACINPLACE|((I)jtinplace&JTWILLBEOPENED)|(AT(w)&BOX)|((AT(a)&BOX)<<1); @@ -222,7 +222,7 @@ A jtevery2(J jt, A a, A w, A fs){A*av,*wv,x,z,*zv; I acbefore=AC(virta);if(((AC(virta)-(flags&ACPERMANENT))&ACINPLACE)<0){ACIPYESLOCAL(virta);AZAPLOC(virta)=av;} // note uses different flag if(unlikely((x=CALL2IP(f2,virta,virtw,fs))==0)){ // run the user's verb - if(likely(flags&BOX))if(likely((I)*wv!=0))ACIPNO(virtw); if(likely(flags&(BOX<<1)))if(likely((I)*av!=0))ACIPNO(virta); R0; // error: restore noninplaceability before we exit + if(likely(flags&BOX))if(likely((I)*wv!=0))ACIPNO(virtw); if(likely(flags&(BOX<<1)))if(likely((I)*av!=0))ACIPNO(virta); R0; // error: restore noninplaceability before we exit } // If x is DIRECT inplaceable, it must be unique and we can inherit them into a pristine result. Otherwise clear pristinity if(likely((AT(x)&DIRECT)>0)){ @@ -244,11 +244,10 @@ A jtevery2(J jt, A a, A w, A fs){A*av,*wv,x,z,*zv; } if(likely(flags&(BOX<<1)))if(likely((I)*av!=0)){ACIPNO(virta); flags|=(((acbefore!=AC(virta))|(x==virta))<<(AFPRISTINEX+1));} - // prepare the result so that it can be incorporated into the overall boxed result if(likely(!(flags&JTWILLBEOPENED))) { // normal case where we are creating the result box. Must incorp the result - realizeifvirtual(x); razap(x); // Since we are moving the result into a recursive box, we must ra() it. This plus rifv plus pristine removal=INCORPRA. We could save some fetches by bundling this code into the DIRECT path + realizeifvirtual(x); razaptstackend(x); // Since we are moving the result into a recursive box, we must ra() it. This plus rifv plus pristine removal=INCORPRA. We could save some fetches by bundling this code into the DIRECT path } else { // result will be opened. It is nonrecursive. description in result.h. We don't have to realize or ra if(AFLAG(x)&AFUNINCORPABLE){RZ(x=clonevirtual(x));} @@ -274,7 +273,7 @@ A jtevery2(J jt, A a, A w, A fs){A*av,*wv,x,z,*zv; // was captured externally could have been repeated in both places. This is not needed if WILLBEOPENED but it doesn't hurt I xfernoprist = flags&(flags>>AFPRISTINEX); xfernoprist|=xfernoprist>>1; // low 2 bits are repeat flags, then combine them AFLAGORLOCAL(z,(flags>>(ACINPLACEX-AFPRISTINEX))&AFPRISTINE&~(xfernoprist<jerr==0)) // execute exp, then return if error #define RZGOTO(exp,lbl) RZSUFF(exp,goto lbl;) #define RNE(exp) {R unlikely(jt->jerr!=0)?0:(exp);} // always return, with exp if no error, 0 if error -#if MEMAUDIT&0xc -#define DEADARG(x) (((I)(x)&~3)?(AFLAG((A)((I)(x)&~3))&LPAR?SEGFAULT:0):0); if(MEMAUDIT&0x10)auditmemchains(); if(MEMAUDIT&0x2)audittstack(jt); +#define AUDITZAP(x) if(((I)x&~3) && !(AFLAG((A)((I)x&~3))&AFVIRTUAL) && AC((A)((I)x&~3))<0 && *AZAPLOC((A)((I)x&~3))!=((A)((I)x&~3)))SEGFAULT; // any inplaceable block should have a ZAPLOC that points back to it +#if MEMAUDIT&0xe +#define DEADARG(x) (((I)(x)&~3)?(AFLAG((A)((I)(x)&~3))&LPAR?SEGFAULT:0):0); if(MEMAUDIT&0x10)auditmemchains(); if(MEMAUDIT&0x2)audittstack(jt); #define ARGCHK1D(x) ARGCHK1(x) // these not needed normally, but useful for debugging #define ARGCHK2D(x,y) ARGCHK2(x,y) #else @@ -2074,10 +2075,10 @@ if(likely(type _i<3)){z=(type _i<1)?1:(type _i==1)?_zzt[0]:_zzt[0]*_zzt[1];}else // RETF is the normal function return. For debugging we hook into it #if AUDITEXECRESULTS && (FORCEVIRTUALINPUTS==2) -#define RETF(exp) A ZZZz = (exp); if (!ZZZz && !jt->jerr) SEGFAULT; auditblock(ZZZz,1,1); ZZZz = virtifnonip(jt,0,ZZZz); R ZZZz +#define RETF(exp) A ZZZz = (exp); if (!ZZZz && !jt->jerr) SEGFAULT; auditblock(ZZZz,1,1); ZZZz = virtifnonip(jt,0,ZZZz); R ZZZz; #else -#if MEMAUDIT&0xc -#define RETF(exp) {A ZZZz = (exp); DEADARG(ZZZz); R ZZZz;} +#if MEMAUDIT&0xe +#define RETF(exp) {A ZZZz = (exp); DEADARG(ZZZz); AUDITZAP(ZZZz) R ZZZz;} #else #if FINDNULLRET // When we return 0, we should always have an error code set. trap if not #define RETF(exp) {A ZZZz = (exp); if(ZZZz==0)R0 R ZZZz;} diff --git a/jsrc/m.c b/jsrc/m.c index 1d8aa06f7..41a6b2328 100644 --- a/jsrc/m.c +++ b/jsrc/m.c @@ -885,11 +885,14 @@ A jtgc(J jt,A w,A* old){ if(old==pushp){if(AC(w)>=0){ra(w); tpush(w);} // if nothing to pop: (a) if inplaceable, make no change (value must be protected up the tstack); (b) otherwise protect the value on the tstack }else if(likely(ISDENSE(AT(w)))){ // sparse blocks cannot simply be left in *old because the contents are farther down the stack and would have to be protected too if(*old==w){ // does the start of tstack point to w? - // w is the first element on the tstack. If it is the ONLY element, we can stand pat; no need to make w recursive - if(old!=pushp-1){ - // there are other elements on tstack, we have to make w recursive because freeing one might otherwise delete contents of w. We can leave inplace status unchanged for w - radescend(w); A *old1=old+1; if(likely(((UI)old1&(NTSTACKBLOCK-1))!=0))tpop(old1); else{*old=0; tpop(old); tpush(w);} // make w recursive; if we can back up to all but the first stack element, do that, leaving w on stack as before; otherwise reinstall - } // raise descendants. Descendants were raised only when w turned from nonrecursive to recursive. Sparse w also descends, but always recurs in tpush + // w is the first element on the tstack. + A *old1=old+1; if(unlikely(((UI)old1&(NTSTACKBLOCK-1))==0)){A *curblk=pushp; while(((A*)*(curblk=(A*)((UI)curblk&-NTSTACKBLOCK))!=old))curblk=(A*)*curblk; old1=curblk+1;} // old1=next element in stack (must exist) + if(unlikely(old1==pushp)); // If w is the ONLY element, we can stand pat; no need to make w recursive. But why did the user bother to call us? + else{radescend(w); tpop(old1);} // there are other elements on tstack, we have to make w recursive (if not already) because freeing one might otherwise delete contents of w. We can leave inplace status unchanged for w +// obsolete if(old!=pushp-1){ +// obsolete // there are other elements on tstack, we have to make w recursive because freeing one might otherwise delete contents of w. We can leave inplace status unchanged for w +// obsolete radescend(w); A *old1=old+1; if(likely(((UI)old1&(NTSTACKBLOCK-1))!=0))tpop(old1); else{*old=0; tpop(old); tpush(w); *old=w;} // make w recursive; if we can back up to all but the first stack element, do that, leaving w on stack as before; otherwise reinstall +// obsolete } // raise descendants. Descendants were raised only when w turned from nonrecursive to recursive. Sparse w also descends, but always recurs in tpush }else if(((UI)REPSGN(AC(w))&(UI)AZAPLOC(w))>=(UI)old && likely((((UI)old^(UI)pushp)&-NTSTACKBLOCK)==0)){ // inplaceable zaploc>=old - but that is valid only when we know pushp and old are in the same stack block // We can see that w is abandoned and is about to be freed. Swap it with *old and proceed, leaving it unpopped on the stack radescend(w); *AZAPLOC(w)=*old; *old=w; AZAPLOC(w)=old; tpop(old+1); // update ZAPLOC to point to new position in stack diff --git a/jsrc/p.c b/jsrc/p.c index bed9dd04b..a409a6a8d 100644 --- a/jsrc/p.c +++ b/jsrc/p.c @@ -763,6 +763,7 @@ RECURSIVERESULTSCHECK auditblock(jt,y,1,1); #endif #if MEMAUDIT&0x2 + audittstack(jt); if(AC(y)==0 || (AC(y)<0 && AC(y)!=ACINPLACE+ACUC1))SEGFAULT; #endif // Make sure the result is recursive. We need this to guarantee that any named value that has been incorporated has its usecount increased, diff --git a/jsrc/sc.c b/jsrc/sc.c index d8890fb37..58f5a69da 100644 --- a/jsrc/sc.c +++ b/jsrc/sc.c @@ -60,7 +60,6 @@ DF2(jtunquote){A z; if(((A)(I)(NAV(thisname)->flag&NMLOC)!=0)){ // most verbs aren't locatives. if no direct locative, leave global unchanged #if 0 // obsolete if(unlikely((explocale=FAV(self)->localuse.lu0.cachedloc)==0)){ // if we have looked it up before, keep the lookup -SEGFAULT; // scaf RZSUFF(explocale=stfind(AN(thisname)-NAV(thisname)->m-2,1+NAV(thisname)->m+NAV(thisname)->s,NAV(thisname)->bucketx),z=0; goto exitname;); // extract locale string, find locale, which must exist FAV(self)->localuse.lu0.cachedloc=explocale; // save named lookup calc for next time }