speedup meta-calls

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1976 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2007-11-07 09:25:27 +00:00
parent a5f5f4c237
commit 42048570f3
13 changed files with 296 additions and 11 deletions

208
C/absmi.c
View File

@ -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;

View File

@ -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);
}

View File

@ -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);

View File

@ -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);

View File

@ -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

View File

@ -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);

View File

@ -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);

View File

@ -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

View File

@ -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)

View File

@ -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));

View File

@ -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);

View File

@ -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);

View File

@ -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),