jtgc bug crossing NTSTACKBLOCK bdy; audits in RETF; use RETF more; za…

…ptstackend() in every[2]

jsrc/ar.c

@@ -827,24 +827,24 @@ 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=wr<r?wr:r; f=wr-r; SETICFR(w,f,r,n);  // no RESETRANK
  // Handle the special cases: neutrals, single items, lists of length 2
  I wt=AT(w); wt=AN(w)?wt:B01;   // Treat empty as Boolean type
 
  if(unlikely(n<=2)){
-  if(unlikely(n==1))R head(w);   // 1 item: the result is the item.  Rank is still set
-  if(unlikely(n==0))R red0(w,FAV(self)->fgh[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
     I cv=BR2CASE(CTTZ(wt),id); UI cwd=TWV0; cwd=(cv>>LGBW)==1?TWV1:cwd;  // figure the case, and see if it is one of those in the big macros above
 #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;

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<<AFPRISTINEX))   // could synthesize rather than loading from z
-R z;
+ RETF(z);
 }
 
 // apply f2 on items of a or w against the entirety of the other argument.  Pass on rank of f2 to reduce rank nesting

jsrc/j.h

@@ -735,7 +735,7 @@ struct jtimespec jmtfclk(void); //'fast clock'; maybe less inaccurate; intended
 
 // Use MEMAUDIT to sniff out errant memory alloc/free
 #ifndef MEMAUDIT
-#define MEMAUDIT 0x00 // Bitmask for memory audits: 
+#define MEMAUDIT 0x00   // Bitmask for memory audits: 
 //        1:  make sure chains are valid (check headers)
 //        2:  full audit of tpush/tpop
 //            detect double-frees before they happen,
@@ -2052,8 +2052,9 @@ if(likely(type _i<3)){z=(type _i<1)?1:(type _i==1)?_zzt[0]:_zzt[0]*_zzt[1];}else
 #define RE(exp)         RZ(((exp),jt->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;}

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

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,

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
       }