speedup meta-calls

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

C/absmi.c

@@ -10,8 +10,11 @@
 *									 *
 * File:		absmi.c							 *
 * comments:	Portable abstract machine interpreter                    *
-* Last rev:     $Date: 2007-11-06 17:02:08 $,$Author: vsc $						 *
+* Last rev:     $Date: 2007-11-07 09:25:27 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.228  2007/11/06 17:02:08  vsc
+* compile ground terms away.
+*
 * Revision 1.227  2007/10/28 11:23:39  vsc
 * fix overflow
 *
@@ -13227,6 +13230,209 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOp();
 
+      BOp(p_execute2, sla);
+      { 
+	PredEntry *pen;
+	Term mod = ARG2;
+
+	deref_head(mod, execute2_unk0);
+    execute2_nvar0:
+	if (!IsAtomTerm(mod)) {
+	  saveregs();
+	  Yap_Error(TYPE_ERROR_ATOM, mod, "call/2");
+	  setregs();
+	}
+	CACHE_Y_AS_ENV(YREG);
+	/* Try to preserve the environment */
+	ENV_YREG = (CELL *) (((char *) YREG) + PREG->u.sla.s);
+#ifdef FROZEN_STACKS
+	{ 
+	  choiceptr top_b = PROTECT_FROZEN_B(B);
+#ifdef SBA
+	  if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b;
+#else
+	  if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b;
+#endif /* SBA */
+	}
+#else
+	if (ENV_YREG > (CELL *) B) {
+	  ENV_YREG = (CELL *) B;
+	}
+#endif /* FROZEN_STACKS */
+	BEGD(d0);
+	d0 = ARG1;
+      restart_execute2:
+	deref_head(d0, execute2_unk);
+      execute2_nvar:
+	if (IsApplTerm(d0)) {
+	  Functor f = FunctorOfTerm(d0);
+	  if (IsExtensionFunctor(f)) {
+	    goto execute2_metacall;
+	  }
+	  pen = RepPredProp(PredPropByFunc(f, mod));
+	  if (pen->PredFlags & (MetaPredFlag|GoalExPredFlag)) {
+	    if (f == FunctorModule) {
+	      Term tmod = ArgOfTerm(1,d0);
+	      if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
+		d0 = ArgOfTerm(2,d0);
+		mod = tmod;
+		goto execute2_nvar;
+	      }
+	    } else if (f == FunctorComma) {
+	      SREG = RepAppl(d0);
+	      BEGD(d1);
+	      d1 = SREG[2];
+	      /* create an to execute2 the call */
+	      deref_head(d1, execute2_comma_unk);
+	    execute2_comma_nvar:
+	      if (IsAtomTerm(d1)) {
+		ENV_YREG[-EnvSizeInCells-2]  = MkIntegerTerm((Int)PredPropByAtom(AtomOfTerm(d1),mod));
+		ENV_YREG[-EnvSizeInCells-3]  = mod;
+	      } else if (IsApplTerm(d1)) {
+		Functor f = FunctorOfTerm(d1);
+		if (IsExtensionFunctor(f)) {
+		  goto execute2_metacall;
+		} else {
+		  if (f == FunctorModule) goto execute2_metacall;
+		  ENV_YREG[-EnvSizeInCells-2]  = MkIntegerTerm((Int)PredPropByFunc(f,mod));
+		  ENV_YREG[-EnvSizeInCells-3]  = mod;
+		}
+	      } else {
+		goto execute2_metacall;
+	      }
+	      ENV_YREG[E_CP] = (CELL)NEXTOP(PREG,sla);
+	      ENV_YREG[E_CB] = (CELL)B;
+	      ENV_YREG[E_E]  = (CELL)ENV;
+#ifdef DEPTH_LIMIT
+	      ENV_YREG[E_DEPTH] = DEPTH;
+#endif	/* DEPTH_LIMIT */
+	      ENV_YREG[-EnvSizeInCells-1]  = d1;
+	      ENV = ENV_YREG;
+	      ENV_YREG -= EnvSizeInCells+3;
+	      PREG = COMMA_CODE;
+	      /* for profiler */
+	      save_pc();
+	      d0 = SREG[1];
+	      goto restart_execute2;
+
+	      BEGP(pt1);
+	      deref_body(d1, pt1, execute2_comma_unk, execute2_comma_nvar);
+	      goto execute2_metacall;
+	      ENDP(pt1);
+	      ENDD(d1);
+	    } else if (mod != CurrentModule) {
+		goto execute2_metacall;
+	    }
+	  }
+	  if (PRED_GOAL_EXPANSION_ALL) {
+	    goto execute2_metacall;
+	  }
+
+	  BEGP(pt1);
+	  pt1 = RepAppl(d0);
+	  BEGD(d2);
+	  for (d2 = ArityOfFunctor(f); d2; d2--) {
+#if SBA
+	    BEGD(d1);
+	    d1 = pt1[d2];
+	    if (d1 == 0) {
+	      XREGS[d2] = (CELL)(pt1+d2);
+	    } else {
+	      XREGS[d2] = d1;
+	    }
+#else
+	    XREGS[d2] = pt1[d2];
+#endif
+	  }
+	  ENDD(d2);
+	  ENDP(pt1);
+	  CACHE_A1();
+	} else if (IsAtomTerm(d0)) {
+	  if (PRED_GOAL_EXPANSION_ALL) {
+	    goto execute2_metacall;
+	  } else {
+	    pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod));
+	  }
+	} else {
+	  goto execute2_metacall;
+	}
+
+      execute2_end:
+	/* code copied from call */
+#ifndef NO_CHECKING
+	check_stack(NoStackPExecute2, H);
+#endif
+	CPREG = NEXTOP(PREG, sla);
+	ALWAYS_LOOKAHEAD(pen->OpcodeOfPred);
+	PREG = pen->CodeOfPred;
+	/* for profiler */
+	save_pc();
+#ifdef DEPTH_LIMIT
+	if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is primitives */
+	  if (pen->ModuleOfPred) {
+	    if (DEPTH == MkIntTerm(0))
+	      FAIL();
+	    else DEPTH = RESET_DEPTH();
+	  }
+	} else if (pen->ModuleOfPred)
+	  DEPTH -= MkIntConstant(2);
+#endif	/* DEPTH_LIMIT */
+#ifdef LOW_LEVEL_TRACER
+	if (Yap_do_low_level_trace)
+	  low_level_trace(enter_pred,pen,XREGS+1);
+#endif	/* LOW_LEVEL_TRACER */
+	WRITEBACK_Y_AS_ENV();
+	/* setup GB */
+	ENV_YREG[E_CB] = (CELL) B;
+#ifdef YAPOR
+	SCH_check_requests();
+#endif	/* YAPOR */
+	CACHE_A1();
+	ALWAYS_GONext();
+	ALWAYS_END_PREFETCH();
+
+	BEGP(pt1);
+	deref_body(d0, pt1, execute2_unk, execute2_nvar);
+       execute2_metacall:
+	ARG1 = ARG3 = d0;
+	pen = PredMetaCall;
+	ARG2 = Yap_cp_as_integer(B);
+	if (mod)
+	  ARG4 = mod;
+	else
+	  ARG4 = TermProlog;
+	goto execute2_end;
+	ENDP(pt1);
+
+	ENDD(d0);
+      NoStackPExecute2:
+	SREG = (CELL *) pen;
+	ASP = ENV_YREG;
+	/* setup GB */
+	WRITEBACK_Y_AS_ENV();
+	YREG[E_CB] = (CELL) B;
+	if (ActiveSignals) {
+	  goto creep_pe;
+	}
+	saveregs_and_ycache();
+	if (!Yap_gc(((PredEntry *)SREG)->ArityOfPE, ENV, NEXTOP(PREG, sla))) {
+	  Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage);
+	}
+	setregs_and_ycache();
+	goto execute2_end;
+	ENDCACHE_Y_AS_ENV();
+
+	BEGP(pt1);
+	deref_body(mod, pt1, execute2_unk0, execute2_nvar0);
+	saveregs();
+	Yap_Error(INSTANTIATION_ERROR, mod, "call/2");
+	setregs();
+	ENDP(pt1);
+	/* Oops, second argument was unbound too */
+	FAIL();
+      }
+      ENDBOp();
+
       BOp(p_execute, sla);
       { 
 	PredEntry *pen;

C/amasm.c

@@ -11,8 +11,11 @@
 * File:		amasm.c							 *
 * comments:	abstract machine assembler				 *
 *									 *
-* Last rev:     $Date: 2007-11-06 17:02:09 $							 *
+* Last rev:     $Date: 2007-11-07 09:25:27 $							 *
 * $Log: not supported by cvs2svn $
+* Revision 1.96  2007/11/06 17:02:09  vsc
+* compile ground terms away.
+*
 * Revision 1.95  2007/06/23 17:31:50  vsc
 * pin cluses with floats.
 *
@@ -1229,6 +1232,8 @@ a_p(op_numbers opcode, clause_info *clinfo, yamop *code_p, int pass_no, struct i
 	} else {
 	  if (RepPredProp(fe)->FunctorOfPred == FunctorExecuteInMod) {
 	    code_p->opc = emit_op(_p_execute);
+	  } else if (RepPredProp(fe)->FunctorOfPred == FunctorExecute2InMod) {
+	    code_p->opc = emit_op(_p_execute2);
 	  } else {
 	    code_p->opc = emit_op(_call_cpred);
 	  }

C/cdmgr.c

@@ -11,8 +11,11 @@
 * File:		cdmgr.c							 *
 * comments:	Code manager						 *
 *									 *
-* Last rev:     $Date: 2007-11-06 17:02:11 $,$Author: vsc $						 *
+* Last rev:     $Date: 2007-11-07 09:25:27 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.209  2007/11/06 17:02:11  vsc
+* compile ground terms away.
+*
 * Revision 1.208  2007/11/01 10:01:35  vsc
 * fix uninitalised lock and reconsult test.
 *
@@ -3998,6 +4001,7 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
       /* instructions type sla */      
     case _p_execute_tail:
     case _p_execute:
+    case _p_execute2:
       clause_code = TRUE;
       pp = RepPredProp(Yap_GetPredPropByFunc(FunctorCall, CurrentModule));
       *startp = (CODEADDR)&(pp->OpcodeOfPred);
@@ -4740,6 +4744,51 @@ p_system_pred(void)
 	 pe->OpcodeOfPred == Yap_opcode(_try_userc));
 }
 
+static Int			/* $system_predicate(P) */
+p_all_system_pred(void)
+{
+  PredEntry      *pe;
+
+  Term t1 = Deref(ARG1);
+  Term mod = Deref(ARG2);
+
+ restart_system_pred:
+  if (IsVarTerm(t1))
+    return TRUE;
+  if (IsAtomTerm(t1)) {
+    pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
+  } else if (IsApplTerm(t1)) {
+    Functor         funt = FunctorOfTerm(t1);
+    if (IsExtensionFunctor(funt)) {
+      return FALSE;
+    } 
+    if (funt == FunctorModule) {
+      Term nmod = ArgOfTerm(1, t1);
+      if (IsVarTerm(nmod)) {
+	Yap_Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
+	return FALSE;
+      } 
+      if (!IsAtomTerm(nmod)) {
+	Yap_Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
+	return FALSE;
+      }
+      t1 = ArgOfTerm(2, t1);
+      goto restart_system_pred;
+    }
+    pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
+  } else if (IsPairTerm(t1)) {
+    return TRUE;
+  } else
+    return FALSE;
+  if (EndOfPAEntr(pe))
+    return FALSE;
+  return(!pe->ModuleOfPred || /* any predicate in prolog module */
+	 /* any C-pred */
+	 pe->PredFlags & (UserCPredFlag|CPredFlag|BinaryTestPredFlag|AsmPredFlag|TestPredFlag) ||
+	 /* any weird user built-in */
+	 pe->OpcodeOfPred == Yap_opcode(_try_userc));
+}
+
 static Int			/* $system_predicate(P) */
 p_hide_predicate(void)
 {
@@ -6021,6 +6070,7 @@ Yap_InitCdMgr(void)
   Yap_InitCPred("$set_pred_module", 2, p_set_pred_module, SafePredFlag|HiddenPredFlag);
   Yap_InitCPred("$parent_pred", 3, p_parent_pred, SafePredFlag|HiddenPredFlag);
   Yap_InitCPred("$system_predicate", 2, p_system_pred, SafePredFlag|HiddenPredFlag);
+  Yap_InitCPred("$all_system_predicate", 2, p_all_system_pred, SafePredFlag|HiddenPredFlag);
   Yap_InitCPred("$hide_predicate", 2, p_hide_predicate, SafePredFlag|HiddenPredFlag);
   Yap_InitCPred("$hidden_predicate", 2, p_hidden_predicate, SafePredFlag|HiddenPredFlag);
   Yap_InitCPred("$pred_for_code", 5, p_pred_for_code, SyncPredFlag|HiddenPredFlag);

C/exec.c

@@ -2039,6 +2039,7 @@ Yap_InitExecFs(void)
   Yap_InitCPred("$execute", 11, p_execute11, HiddenPredFlag);
   Yap_InitCPred("$execute", 12, p_execute12, HiddenPredFlag);
   Yap_InitCPred("$execute_in_mod", 2, p_execute_in_mod, HiddenPredFlag);
+  Yap_InitCPred("$execute_wo_mod", 2, p_execute_in_mod, HiddenPredFlag);
   Yap_InitCPred("$call_with_args", 2, p_execute_0, HiddenPredFlag);
   Yap_InitCPred("$call_with_args", 3, p_execute_1, HiddenPredFlag);
   Yap_InitCPred("$call_with_args", 4, p_execute_2, HiddenPredFlag);

C/index.c

@@ -11,8 +11,11 @@
 * File:		index.c							 *
 * comments:	Indexing a Prolog predicate				 *
 *									 *
-* Last rev:     $Date: 2007-11-06 17:02:12 $,$Author: vsc $						 *
+* Last rev:     $Date: 2007-11-07 09:25:27 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.189  2007/11/06 17:02:12  vsc
+* compile ground terms away.
+*
 * Revision 1.188  2007/10/28 11:23:40  vsc
 * fix overflow
 *
@@ -1044,6 +1047,7 @@ has_cut(yamop *pc)
       break;
       /* instructions type sla */
     case _p_execute:
+    case _p_execute2:
     case _fcall:
     case _call:
 #ifdef YAPOR
@@ -1721,6 +1725,7 @@ add_info(ClauseDef *clause, UInt regno)
       clause->Tag = (CELL)NULL;
       return;
     case _p_execute:
+    case _p_execute2:
     case _fcall:
     case _call:
 #ifdef YAPOR

C/init.c

@@ -1180,6 +1180,7 @@ InitCodes(void)
   Yap_heap_regs->functor_csult = Yap_MkFunctor(AtomCsult, 1);
   Yap_heap_regs->functor_eq = Yap_MkFunctor(AtomEq, 2);
   Yap_heap_regs->functor_execute_in_mod = Yap_MkFunctor(Yap_FullLookupAtom("$execute_in_mod"), 2);
+  Yap_heap_regs->functor_execute2_in_mod = Yap_MkFunctor(Yap_FullLookupAtom("$execute_wo_mod"), 2);
   Yap_heap_regs->functor_execute_within = Yap_MkFunctor(Yap_FullLookupAtom("$execute_within"), 1);
   Yap_heap_regs->functor_g_atom = Yap_MkFunctor(Yap_LookupAtom("atom"), 1);
   Yap_heap_regs->functor_g_atomic = Yap_MkFunctor(Yap_LookupAtom("atomic"), 1);

C/tracer.c

@@ -162,6 +162,9 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
   sc = Yap_heap_regs;
   vsc_count++;
 #ifdef COMMENTED
+  if (vsc_count == 40650191LL)
+    jmp_deb(1);
+  return;
   if (vsc_count > 1388060LL && vsc_count < 1388070LL) {
     if (vsc_count==1388061LL)
       jmp_deb(1);

H/Heap.h

@@ -10,7 +10,7 @@
 * File:		Heap.h         						 *
 * mods:									 *
 * comments:	Heap Init Structure					 *
-* version:      $Id: Heap.h,v 1.119 2007-11-06 17:02:12 vsc Exp $	 *
+* version:      $Id: Heap.h,v 1.120 2007-11-07 09:25:27 vsc Exp $	 *
 *************************************************************************/
 
 /* information that can be stored in Code Space */
@@ -445,6 +445,7 @@ typedef struct various_codes {
     functor_cut_by,
     functor_eq,
     functor_execute_in_mod,
+    functor_execute2_in_mod,
     functor_execute_within,
     functor_g_atom,
     functor_g_atomic,
@@ -750,6 +751,7 @@ struct various_codes *Yap_heap_regs;
 #define  FunctorCutBy             Yap_heap_regs->functor_cut_by
 #define  FunctorEq                Yap_heap_regs->functor_eq
 #define  FunctorExecuteInMod      Yap_heap_regs->functor_execute_in_mod
+#define  FunctorExecute2InMod     Yap_heap_regs->functor_execute2_in_mod
 #define  FunctorExecuteWithin     Yap_heap_regs->functor_execute_within
 #define  FunctorGAtom             Yap_heap_regs->functor_g_atom
 #define  FunctorGAtomic           Yap_heap_regs->functor_g_atomic

H/YapOpcodes.h

@@ -11,8 +11,11 @@
 * File:		YapOpcodes.h						 *
 * comments:	Central Table with all YAP opcodes                       *
 *									 *
-* Last rev:     $Date: 2007-11-06 17:02:12 $							 *
+* Last rev:     $Date: 2007-11-07 09:25:27 $							 *
 * $Log: not supported by cvs2svn $
+* Revision 1.41  2007/11/06 17:02:12  vsc
+* compile ground terms away.
+*
 * Revision 1.40  2006/10/10 14:08:17  vsc
 * small fixes on threaded implementation.
 *
@@ -481,6 +484,7 @@
     OPCODE(p_func2f_yx             ,yxx),
     OPCODE(p_func2f_yy             ,yyx),
     OPCODE(p_execute               ,sla),
+    OPCODE(p_execute2              ,sla),
     OPCODE(p_execute_tail          ,e)
 
 

H/Yatom.h

@@ -1328,7 +1328,7 @@ EXTERN inline UInt STD_PROTO(PRED_HASH, (FunctorEntry *, Term, UInt));
 EXTERN inline UInt
 PRED_HASH(FunctorEntry *fe, Term cur_mod, UInt size)
 {
-  return ((CELL)fe+cur_mod) % size;
+  return (((CELL)fe+cur_mod)>>2) % size;
 }
 
 EXTERN inline Prop STD_PROTO(GetPredPropByFuncHavingLock, (FunctorEntry *, Term));

H/rclause.h

@@ -12,8 +12,11 @@
 * File:		rclause.h						 *
 * comments:	walk through a clause					 *
 *									 *
-* Last rev:     $Date: 2007-11-06 17:02:12 $,$Author: vsc $						 *
+* Last rev:     $Date: 2007-11-07 09:25:27 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.19  2007/11/06 17:02:12  vsc
+* compile ground terms away.
+*
 * Revision 1.18  2006/11/27 17:42:03  vsc
 * support for UNICODE, and other bug fixes.
 *
@@ -380,6 +383,7 @@ restore_opcodes(yamop *pc)
       /* instructions type sla */      
     case _p_execute_tail:
     case _p_execute:
+    case _p_execute2:
       pc->u.sla.sla_u.p = PtoPredAdjust(pc->u.sla.sla_u.p);
       if (pc->u.sla.sla_u.mod != 0) {
 	pc->u.sla.sla_u.mod = AtomTermAdjust(pc->u.sla.sla_u.mod);

H/rheap.h

@@ -11,8 +11,11 @@
 * File:		rheap.h							 *
 * comments:	walk through heap code					 *
 *									 *
-* Last rev:     $Date: 2007-11-06 17:02:12 $,$Author: vsc $						 *
+* Last rev:     $Date: 2007-11-07 09:25:27 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.78  2007/11/06 17:02:12  vsc
+* compile ground terms away.
+*
 * Revision 1.77  2007/10/10 09:44:24  vsc
 * some more fixes to make YAP swi compatible
 * fix absolute_file_name (again)
@@ -678,6 +681,7 @@ restore_codes(void)
   Yap_heap_regs->functor_csult = FuncAdjust(Yap_heap_regs->functor_csult);
   Yap_heap_regs->functor_eq = FuncAdjust(Yap_heap_regs->functor_eq);
   Yap_heap_regs->functor_execute_in_mod = FuncAdjust(Yap_heap_regs->functor_execute_in_mod);
+  Yap_heap_regs->functor_execute2_in_mod = FuncAdjust(Yap_heap_regs->functor_execute2_in_mod);
   Yap_heap_regs->functor_execute_within = FuncAdjust(Yap_heap_regs->functor_execute_within);
   Yap_heap_regs->functor_g_atom = FuncAdjust(Yap_heap_regs->functor_g_atom);
   Yap_heap_regs->functor_g_atomic = FuncAdjust(Yap_heap_regs->functor_g_atomic);

pl/modules.yap

@@ -257,7 +257,7 @@ module(N) :-
 '$module_expansion'(false,false,false,_,_,_,_) :- !.
 % if I don't know what the module is, I cannot do anything to the goal,
 % so I just put a call for later on.
-'$module_expansion'(M:G,call(M:G),call(M:G),_,_,_,_) :- var(M), !.
+'$module_expansion'(M:G,call(M:G),'$execute_wo_mod'(G,M),_,_,_,_) :- var(M), !.
 '$module_expansion'(M:G,G1,GO,_,_,TM,HVars) :-
 	'$module_expansion'(G,G1,GO,M,M,TM,HVars).
 % if M1 is given explicitly process G within M1's context.
@@ -308,7 +308,7 @@ module(N) :-
 	user:goal_expansion(G,M,GI), !,
 	'$module_expansion'(GI,G1,G2,M,CM,TM,HVars).
 '$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars) :-
-	'$system_predicate'(G,M), !,
+	'$all_system_predicate'(G,M), !,
 	'$c_built_in'(G,M,Gi),
 	(Gi \== G ->
 	   '$module_expansion'(Gi,_,G2,M,CM,TM,HVars),