new version of throw using Bart's idea

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

C/errors.c

@@ -1750,7 +1750,7 @@ Error (yap_error_number type, Term where, char *format,...)
   nt[1] = MkAtomTerm(LookupAtom(p));
   if (serious) {
     choiceptr newb;
-    PredEntry *p = RepPredProp(PredPropByFunc(FunctorThrow,0));
+    PredEntry *p = PredThrow;
       
     CreepFlag = CalculateStackGap();
     ASP--;

C/exec.c

@@ -1253,30 +1253,32 @@ p_clean_ifcp(void) {
 /* This does very nasty stuff!!!!! */
 static Int
 p_jump_env(void) {
-  CELL *env = LCL0-IntegerOfTerm(Deref(ARG1)), *prev = NULL, *cur = ENV;
+  yamop *min = (yamop *)(PredCatch->CodeOfPred);
+  yamop *max = (yamop *)(PredThrow->CodeOfPred);
+  CELL *cur = ENV, *env;
+  yamop *cpe = (yamop *)(cur[E_CP]);
 
-  while (cur != env) {
+  while (cpe < min || cpe > max) {
-    prev = cur;
     cur = (CELL *)cur[E_E];
+    cpe = (yamop *)(cur[E_CP]);
   }
-  if (prev == NULL) {
+  CP = cpe;
-    return(FALSE);
+  env = (CELL *)cur[E_E];
-  }
+  YENV = ENV = (CELL *)(env[E_E]);
-  CP = (yamop *)(prev[E_CP]);
-  YENV = ENV = env;
-  /* force trail reset */
   while (B->cp_b < (choiceptr)env) {
     B = B->cp_b;
   }
-  B->cp_cp = CP;
+  B->cp_cp = (yamop *)(env[E_CP]);
-  B->cp_ap = CP;
+  B->cp_ap = (yamop *)(PredHandleThrow->LastClause);
-  B->cp_env = env;
+  B->cp_env = ENV;
   B->cp_h = H;
-  /* I could do this, but it is easier to leave the unwinding to the emulator */
+  /* I could backtrack here, but it is easier to leave the unwinding
-  env[CP->u.yx.y] = ARG2;
+     to the emulator */
+  B->cp_a3 = Deref(ARG1);
   return(FALSE);
 }
 
+
 void 
 InitExecFs(void)
 {
@@ -1306,6 +1308,6 @@ InitExecFs(void)
   InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag);
   InitCPred("$restore_regs", 2, p_restore_regs2, SafePredFlag);
   InitCPred("$clean_ifcp", 1, p_clean_ifcp, SafePredFlag);
-  InitCPred("$jump_env_and_store_ball", 2, p_jump_env, SafePredFlag);
+  InitCPred("$jump_env_and_store_ball", 1, p_jump_env, SafePredFlag);
 }
 

C/heapgc.c

@@ -2758,7 +2758,7 @@ Int total_gc_time(void)
 static Int
 p_inform_gc(void)
 {
-  Term tn = MkIntegerTerm(tot_gc_time/1000);
+  Term tn = MkIntegerTerm(tot_gc_time);
   Term tt = MkIntegerTerm(gc_calls);
   Term ts = MkIntegerTerm((tot_gc_recovered*sizeof(CELL)));
  

C/init.c

@@ -763,6 +763,8 @@ InitCodes(void)
     AtomStream,
     AtomStreamPos,
     AtomVar;
+  Functor
+    FunctorThrow;
 
 #ifdef YAPOR
   heap_regs->seq_def = TRUE;
@@ -989,7 +991,7 @@ InitCodes(void)
   heap_regs->functor_stream_eOS = MkFunctor (LookupAtom("end_of_stream"), 1);
   heap_regs->functor_change_module = MkFunctor (LookupAtom("$change_module"), 1);
   heap_regs->functor_current_module = MkFunctor (LookupAtom("$current_module"), 1);
-  heap_regs->functor_throw = MkFunctor( LookupAtom("throw"), 1);
+  FunctorThrow = MkFunctor( LookupAtom("throw"), 1);
   heap_regs->functor_u_minus = MkFunctor (heap_regs->atom_minus, 1);
   heap_regs->functor_u_plus = MkFunctor (heap_regs->atom_plus, 1);
   heap_regs->functor_v_bar = MkFunctor(LookupAtom("|"), 2);
@@ -1009,6 +1011,9 @@ InitCodes(void)
   CurrentModule = 0;
   heap_regs->dead_clauses = NULL;
   heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(heap_regs->atom_meta_call,4),0));
+  heap_regs->pred_catch = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("catch"),3),0));
+  heap_regs->pred_throw = RepPredProp(PredPropByFunc(FunctorThrow,0));
+  heap_regs->pred_handle_throw = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("$handle_throw"),3),0));
   ReleaseAtom(AtomOfTerm(heap_regs->term_refound_var));
   {
     /* make sure we know about the module predicate */

C/save.c

@@ -1104,7 +1104,6 @@ restore_codes(void)
   heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS);
   heap_regs->functor_change_module = FuncAdjust(heap_regs->functor_change_module);
   heap_regs->functor_current_module = FuncAdjust(heap_regs->functor_current_module);
-  heap_regs->functor_throw = FuncAdjust(heap_regs->functor_throw);
   heap_regs->functor_u_minus = FuncAdjust(heap_regs->functor_u_minus);
   heap_regs->functor_u_plus = FuncAdjust(heap_regs->functor_u_plus);
   heap_regs->functor_v_bar = FuncAdjust(heap_regs->functor_v_bar);
@@ -1122,6 +1121,12 @@ restore_codes(void)
     (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_goal_expansion);
   heap_regs->pred_meta_call =
     (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_meta_call);
+  heap_regs->pred_catch =
+    (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_catch);
+  heap_regs->pred_throw =
+    (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_throw);
+  heap_regs->pred_handle_throw =
+    (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_handle_throw);
   if (heap_regs->undef_code != NULL)
     heap_regs->undef_code = (PredEntry *)PtoHeapCellAdjust((CELL *)(heap_regs->undef_code));
   if (heap_regs->creep_code != NULL)

H/Heap.h

@@ -10,7 +10,7 @@
 * File:		Heap.h         						 *
 * mods:									 *
 * comments:	Heap Init Structure					 *
-* version:      $Id: Heap.h,v 1.20 2002-01-14 22:25:17 vsc Exp $	 *
+* version:      $Id: Heap.h,v 1.21 2002-01-24 23:55:34 vsc Exp $	 *
 *************************************************************************/
 
 /* information that can be stored in Code Space */
@@ -256,7 +256,6 @@ typedef struct various_codes {
     functor_stream_eOS,
     functor_change_module,
     functor_current_module,
-    functor_throw,
     functor_u_minus,
     functor_u_plus,
     functor_v_bar,
@@ -270,6 +269,9 @@ typedef struct various_codes {
   void *last_wtime;
   PredEntry *pred_goal_expansion;
   PredEntry *pred_meta_call;
+  PredEntry *pred_catch;
+  PredEntry *pred_throw;
+  PredEntry *pred_handle_throw;
   UInt n_of_file_aliases;
   UInt sz_of_file_aliases;
   struct AliasDescS * file_aliases;
@@ -298,6 +300,7 @@ typedef struct various_codes {
 #define  ANSWER_RESOLUTION        ((yamop *)&(heap_regs->tableanswerresolutioncode ))
 #endif /* TABLING */
 #define  FAILCODE                 ((CODEADDR)&(heap_regs->failcode       ))
+#define  FAILCODE                 ((CODEADDR)&(heap_regs->failcode       ))
 #define  TRUSTFAILCODE            ((CODEADDR)&(heap_regs->trustfailcode  ))
 #define  YESCODE                  ((CODEADDR)&(heap_regs->yescode        ))
 #define  NOCODE                   ((CODEADDR)&(heap_regs->nocode         ))
@@ -447,7 +450,6 @@ typedef struct various_codes {
 #define  FunctorChangeModule      heap_regs->functor_change_module
 #define  FunctorCurrentModule     heap_regs->functor_current_module
 #define  FunctorModSwitch         heap_regs->functor_mod_switch
-#define  FunctorThrow             heap_regs->functor_throw
 #define  FunctorUMinus            heap_regs->functor_u_minus
 #define  FunctorUPlus             heap_regs->functor_u_plus
 #define  FunctorVBar              heap_regs->functor_v_bar
@@ -457,6 +459,9 @@ typedef struct various_codes {
 #define  TermReFoundVar           heap_regs->term_refound_var
 #define  PredGoalExpansion        heap_regs->pred_goal_expansion
 #define  PredMetaCall             heap_regs->pred_meta_call
+#define  PredCatch                heap_regs->pred_catch
+#define  PredThrow                heap_regs->pred_throw
+#define  PredHandleThrow          heap_regs->pred_handle_throw
 #define  NOfFileAliases           heap_regs->n_of_file_aliases
 #define  SzOfFileAliases          heap_regs->sz_of_file_aliases
 #define  FileAliases              heap_regs->file_aliases

pl/boot.yap

@@ -44,7 +44,6 @@ read_sig.
 
 '$init_system' :-
         % do catch as early as possible
-        '$init_catch',
 	(
 	 '$access_yap_flags'(15, 0) ->
 	  '$version'
@@ -1161,21 +1160,10 @@ expand_term(Term,Expanded) :-
 % what is ball;
 % where was the previous catch	
 catch(G, C, A) :-
-	'$mark_tr'(Ball),
+	'$mark_tr'(C,A,_),
-	array_element('$catch', 0, OldEnv),
+	'$execute'(G).
-	Env is '$env',
-	update_array('$catch', 0, Env),
-	'$execute'(G),
-	'$force_to_1st'(Ball),
-	( var(Ball) ->
-	    % no throw, just get rid of this.
-	    update_array('$catch', 0, OldEnv)
-	;
-	    % jmp_env will reset both fields  for me!
-	    !, '$handle_throw'(C, A, Ball)
-	).
 
-%
+				%
 % system_catch is like catch, but it avoids the overhead of a full
 % meta-call by calling '$execute0' instead of $execute.
 % This way it
@@ -1183,30 +1171,26 @@ catch(G, C, A) :-
 %
 '$system_catch'(G, M, C, A) :-
 	% check current trail
-	'$mark_tr'(Ball),
+	'$mark_tr'(C,A,_),
-	% update current catch handler
+	'$execute0'(G, M).
-	array_element('$catch', 0, OldEnv),
-	Env is '$env',
-	update_array('$catch', 0, Env),
-	'$execute0'(G, M),
-	% this says where Ball is, for the benefit of jump_env
-	'$force_to_1st'(Ball),
-	(
-	  var(Ball) ->
-	    % no throw, just get rid of this.
-	    update_array('$catch', 0, OldEnv)
-	;
-	    % process the throw, if we can.
-	    !, '$handle_throw'(C, A, Ball)
-	).
 
+%
+% throw has to be *exactly* after system catch!
+%
+throw(Ball) :-
+	% get this off the unwound computation.
+	copy_term(Ball,NewBall),
+	% get current jump point
+	'$jump_env_and_store_ball'(NewBall).
+
+
+	
 % just create a choice-point
-'$mark_tr'(_).
+'$mark_tr'(_,_,_).
-'$mark_tr'(_) :- fail.
+'$mark_tr'(_,_,_) :- fail.
 
-'$force_to_1st'(_).
+'$handle_throw'(_, _, _).
-
+'$handle_throw'(C, A, Ball) :-
-'$handle_throw'(C, A, '$ball'(Ball)) :-
         % reset info 
 	(C = Ball ->
 	    '$execute'(A)
@@ -1214,22 +1198,6 @@ catch(G, C, A) :-
 	    throw(Ball)
 	).
 
-throw(Ball) :-
-	% get this off the unwound computation.
-	copy_term(Ball,NewBall),
-	% get current jump point
-	array_element('$catch', 0, Env),
-	'$do_throw'(NewBall, Env).
-
-'$do_throw'(NewBall,Env) :-
-	% jump
-	'$jump_env_and_store_ball'(Env, '$ball'(NewBall)).
-% restore bindings.
-'$do_throw'(_,_).
-
-'$init_catch' :-
-	'$create_array'('$catch', 1).
-
 '$exec_initialisation_goals' :-
 	'$recorded'('$blocking_code',_,R),
 	erase(R),

pl/utils.yap

@@ -406,8 +406,9 @@ statistics :-
 	OvfTime is TotHOTime+TotSOTime+TotTOTime,
 	'$format'(user_error,"~n~t~3f~12+ sec. for ~w code, ~w stack, and ~w trail space overflows~n",
 	       [OvfTime,NOfHO,NOfSO,NOfTO]),
+	TotGCTimeF is float(TotGCTime)/1000,
 	'$format'(user_error,"~t~3f~12+ sec. for ~w garbage collections which collected ~d bytes~n",
-	       [TotGCTime,NOfGC,TotGCSize]),
+	       [TotGCTimeF,NOfGC,TotGCSize]),
 	RTime is float(Runtime)/1000,
 	'$format'(user_error,"~t~3f~12+ sec. runtime~n", [RTime]),
 	CPUTime is float(CPUtime)/1000,