garbage collecting fixes

compile trues at the end of body
fix call_residue/2 so that constraints cannot escape (yet again).


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@30 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

C/alloc.c

@@ -12,7 +12,7 @@
 * Last rev:								 *
 * mods:									 *
 * comments:	allocating space					 *
-* version:$Id: alloc.c,v 1.5 2001-05-07 13:53:19 vsc Exp $		 *
+* version:$Id: alloc.c,v 1.6 2001-05-07 19:56:02 vsc Exp $		 *
 *************************************************************************/
 #ifdef SCCS
 static char SccsId[] = "%W% %G%";
@@ -924,20 +924,20 @@ InitMemory(int Trail, int Heap, int Stack)
 #ifdef DEBUG
 #if SIZEOF_INT_P!=SIZEOF_INT
   if (output_msg) {
-    YP_fprintf(YP_stderr, "HeapBase = %p  GlobalBase = %p\n  LocalBase = %p  TrailTop = %p\n",
+    fprintf(stderr, "HeapBase = %p  GlobalBase = %p\n  LocalBase = %p  TrailTop = %p\n",
 	       HeapBase, GlobalBase, LocalBase, TrailTop);
 #else
   if (output_msg) {
-    YP_fprintf(YP_stderr, "HeapBase = %x  GlobalBase = %x\n  LocalBase = %x  TrailTop = %x\n",
+    fprintf(stderr, "HeapBase = %x  GlobalBase = %x\n  LocalBase = %x  TrailTop = %x\n",
 	       (UInt) HeapBase, (UInt) GlobalBase,
 	       (UInt) LocalBase, (UInt) TrailTop);
 #endif
 
 #if !SHORT_INTS
-    YP_fprintf(YP_stderr, "Heap+Aux: %d\tLocal+Global: %d\tTrail: %d\n",
+    fprintf(stderr, "Heap+Aux: %d\tLocal+Global: %d\tTrail: %d\n",
 	       pm - sa - ta, sa, ta);
 #else /* SHORT_INTS */
-    YP_fprintf(YP_stderr, "Heap+Aux: %ld\tLocal+Global: %ld\tTrail: %ld\n",
+    fprintf(stderr, "Heap+Aux: %ld\tLocal+Global: %ld\tTrail: %ld\n",
 	       pm - sa - ta, sa, ta);
 #endif /* SHORT_INTS */
   }

C/compiler.c

@@ -1107,6 +1107,22 @@ c_functor(Term Goal)
   }
 }
 
+static int
+IsTrueGoal(Term t) {
+  if (IsVarTerm(t)) return(FALSE);
+  if (IsApplTerm(t)) {
+    Functor f = FunctorOfTerm(t);
+    if (f == FunctorModule) {
+      return(IsTrueGoal(ArgOfTerm(2,t)));
+    }
+    if (f == FunctorComma || f == FunctorOr || f == FunctorArrow) {
+      return(IsTrueGoal(ArgOfTerm(1,t)) && IsTrueGoal(ArgOfTerm(2,t)));
+    }
+    return(FALSE);
+  }
+  return(t == MkAtomTerm(AtomTrue));
+}
+
 static void
 c_goal(Term Goal)
 {
@@ -1372,11 +1388,12 @@ c_goal(Term Goal)
     }
     else if (f == FunctorComma) {
       int save = onlast;
+      int t2 = ArgOfTerm(2, Goal);
 
       onlast = FALSE;
       c_goal(ArgOfTerm(1, Goal));
       onlast = save;
-      c_goal(ArgOfTerm(2, Goal));
+      c_goal(t2);
       CurrentModule = save_CurrentModule;
       return;
     }
@@ -1690,8 +1707,16 @@ c_body(Term Body)
   }
   while (IsNonVarTerm(Body) && IsApplTerm(Body)
 	 && FunctorOfTerm(Body) == FunctorComma) {
+    Term t2 = ArgOfTerm(2, Body);
+    if (IsTrueGoal(t2)) {
+      /* optimise the case where some idiot left trues at the end
+	 of the clause.
+      */
+      Body = ArgOfTerm(1, Body);
+      break;
+    }
     c_goal(ArgOfTerm(1, Body));
-    Body = ArgOfTerm(2, Body);
+    Body = t2;
   }
   onlast = TRUE;
   c_goal(Body);

C/heapgc.c

@@ -1300,7 +1300,6 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
 #if  MULTI_ASSIGNMENT_VARIABLES
   while (live_list != NULL) {
     CELL trail_cell = TrailTerm(live_list->trptr-1);
-    printf("multi assignment marking cell %p:%x\n", &TrailTerm(live_list->trptr-1), trail_cell);
     if (HEAP_PTR(trail_cell)) {
       mark_external_reference(&TrailTerm(live_list->trptr-1));
     }
@@ -1327,6 +1326,7 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
 #endif
 
 #ifdef DEBUG
+//#define CHECK_CHOICEPOINTS 1
 #endif
 
 #ifdef CHECK_CHOICEPOINTS
@@ -2328,6 +2328,43 @@ compact_heap(void)
 }
 
 #ifdef HYBRID_SCHEME
+static void
+adjust_cp_hbs(void)
+{
+  choiceptr gc_B = B;
+  CELL_PTR *top = iptop-1, *base = (CELL_PTR *)H;
+
+  while (gc_B != NULL) {
+    CELL *gc_H = gc_B->cp_h;
+    CELL_PTR *nbase = base;
+    if (top[0] <= gc_H) {
+      if (top[0] == gc_H)
+	gc_B->cp_h = H0+(top-base);
+      else
+	gc_B->cp_h = H0+((top+1)-base);
+    } else while (TRUE) {
+      CELL_PTR *nxt = nbase+(top-nbase)/2;
+      if (nxt[0] > gc_H) {
+	top = nxt;
+      } else if (nxt[0] < gc_H && nxt[1] < gc_H) {
+	nbase = nxt+1;
+      } else {
+	if (nxt[0] == gc_H) {
+	  gc_B->cp_h = H0+(nxt-base);
+	  top = nxt;
+	  break;
+	} else {
+	  gc_B->cp_h = H0+((nxt-base)+1);
+	  top = nxt;
+	  break;
+	}
+      } 
+    }
+    gc_B = gc_B->cp_b;
+  }
+}
+
+
 /*
  * move marked objects on the heap upwards over unmarked objects, and reset
  * all pointers to point to new locations 
@@ -2339,8 +2376,6 @@ icompact_heap(void)
 #ifdef DEBUG
   Int             found_marked = 0;
 #endif /* DEBUG */
-  choiceptr        gc_B = B;
- 
 
   /*
    * upward phase - scan heap from high to low, setting marked upward
@@ -2360,7 +2395,6 @@ icompact_heap(void)
       int nofcells = (UNMARK_CELL(*current)-EndSpecials) / sizeof(CELL);
       CELL *ptr = current - nofcells ;
 
-      gc_B = update_B_H(gc_B, current, H0+(iptr-ibase), H0+(iptr-ibase)+1);
       iptr -= nofcells;
 #ifdef DEBUG
       found_marked+=nofcells;
@@ -2373,9 +2407,6 @@ icompact_heap(void)
 	ptr[1] = tmp;
       }
       current = ptr;
-    } else {
-      /* process the functor next */
-      gc_B = update_B_H(gc_B, current, H0+(iptr-ibase), H0+((iptr-ibase)+1));
     }
 #ifdef DEBUG
     found_marked++;
@@ -2555,6 +2586,7 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
     fprintf(stderr,"using pointers (%d)\n", effectiveness);
 #endif
     quicksort((CELL_PTR *)H, 0, (iptop-(CELL_PTR *)H)-1);
+    adjust_cp_hbs();
     icompact_heap();
   } else
 #endif /* HYBRID_SCHEME */

C/init.c

@@ -488,26 +488,22 @@ InitDebug(void)
   if (output_msg) {
     char            ch;
     opcode(_Ystop);
-#if !SHORT_INTS
+    fprintf(stderr,"absmi address:%p\n", FunAdr(absmi));
-    YP_fprintf(YP_stderr,"absmi address:%x\n", Unsigned(FunAdr(absmi)));
+    fprintf(stderr,"Set	Trace Options:\n");
-#else
+    fprintf(stderr,"a getch\t\tb token\t\tc Lookup\td LookupVar\ti Index\n");
-    YP_fprintf(YP_stderr,"absmi address:%lx\n", Unsigned(FunAdr(absmi)));
+    fprintf(stderr,"e SetOp\t\tf compile\tg icode\t\th boot\t\tl log\n");
-#endif
+    fprintf(stderr,"m Machine\n");
-    YP_fprintf(YP_stderr,"Set	Trace Options:\n");
-    YP_fprintf(YP_stderr,"a getch\t\tb token\t\tc Lookup\td LookupVar\ti Index\n");
-    YP_fprintf(YP_stderr,"e SetOp\t\tf compile\tg icode\t\th boot\t\tl log\n");
-    YP_fprintf(YP_stderr,"m Machine\n");
     while ((ch = YP_putchar(YP_getchar())) != '\n')
       if (ch >= 'a' && ch <= 'z')
 	Option[ch - 'a' + 1] = 1;
     if (Option['l' - 96]) {
-      logfile = YP_fopen(LOGFILE, "w");
+      logfile = fopen(LOGFILE, "w");
       if (logfile == Nill) {
-	YP_fprintf(YP_stderr,"can not open %s\n", LOGFILE);
+	fprintf(stderr,"can not open %s\n", LOGFILE);
-	YP_getchar();
+	getchar();
 	exit(0);
       }
-      YP_fprintf(YP_stderr,"logging session to file 'logfile'\n");
+      fprintf(stderr,"logging session to file 'logfile'\n");
 #ifdef MAC
       SetTextFile(LOGFILE);
       lp = my_line;

changes4.3.html

@@ -6,6 +6,9 @@
 
 <H2 ALIGN=CENTER>Yap-4.3.19:</H2>
 <UL>
+      <LI> FIXED: call_residue/2 should not allow constraints to
+      escape (use copy_term_no_variables/2 to avoid this).
+      <LI> SPEEDUP: optimise away true/0 at the end of a clause.
       <LI> FIXED: do not short circuit trail entries.
       <LI> FIXED: Patches for memory allocation in Apple's OS/X..
       <LI> FIXED: checked whether mmap work right in alloc.c.

pl/corout.yap

@@ -541,8 +541,7 @@ call_residue(Goal,Residue) :-
 	  '$execute'(NGoal),
 	  '$call_residue_continuation'(NGoal,NResidue),
 	    ( '$set_svar_list'(OldList,OldAttsList),
-	       Goal = NGoal,
+	       '$copy_term_but_not_constraints'(NGoal+NResidue, Goal+Residue)
-	       Residue = NResidue
 		;
 		'$set_svar_list'(CurrentList,CurrentAttsList), fail
 	    )

pl/errors.yap

@@ -284,6 +284,9 @@ print_message(help,M) :-
 '$output_error_message'(system_error, Where) :-
 	format(user_error,"[ SYSTEM ERROR- ~w ]~n",
 	[Where]).
+'$output_error_message'(type_error(T,_,Err,M), Where) :-
+	format(user_error,"[ TYPE ERROR- ~w: expected ~w, got ~w ]~n",
+	[T,Err,M]).
 '$output_error_message'(type_error(array,W), Where) :-
 	format(user_error,"[ TYPE ERROR- ~w: expected array, got ~w ]~n",
 	[Where,W]).