diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

improve emulataion of backtrackable SWI c-code (request from NF).

Browse Source
This commit is contained in:
Vitor Santos Costa 2010-01-06 11:25:15 -02:00
parent b0df6b25cd
commit 5fc26e1b45
3 changed files with 196 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
C/c_interface.c
View File

@ -1197,6 +1197,105 @@ execute_cargs(PredEntry *pe, CPredicate exec_code)
}
}
typedef Int (*CBPredicate)(struct foreign_context *);
typedef Int (*CBPredicate1)(long,struct foreign_context *);
typedef Int (*CBPredicate2)(long,long,struct foreign_context *);
typedef Int (*CBPredicate3)(long,long,long,struct foreign_context *);
typedef Int (*CBPredicate4)(long,long,long,long,struct foreign_context *);
typedef Int (*CBPredicate5)(long,long,long,long,long,struct foreign_context *);
typedef Int (*CBPredicate6)(long,long,long,long,long,long,struct foreign_context *);
typedef Int (*CBPredicate7)(long,long,long,long,long,long,long,struct foreign_context *);
typedef Int (*CBPredicate8)(long,long,long,long,long,long,long,long,struct foreign_context *);
static Int
execute_cargs_back(PredEntry *pe, CPredicate exec_code, struct foreign_context *ctx)
{
switch (pe->ArityOfPE) {
case 0:
{
CBPredicate code0 = (CBPredicate)exec_code;
return ((code0)(ctx));
}
case 1:
{
CBPredicate1 code1 = (CBPredicate1)exec_code;
return ((code1)(Yap_InitSlot(Deref(ARG1)),
ctx));
}
case 2:
{
CBPredicate2 code2 = (CBPredicate2)exec_code;
return ((code2)(Yap_InitSlot(Deref(ARG1)),
Yap_InitSlot(Deref(ARG2)),
ctx));
}
case 3:
{
CBPredicate3 code3 = (CBPredicate3)exec_code;
return ((code3)(Yap_InitSlot(Deref(ARG1)),
Yap_InitSlot(Deref(ARG2)),
Yap_InitSlot(Deref(ARG3)),
ctx));
}
case 4:
{
CBPredicate4 code4 = (CBPredicate4)exec_code;
return ((code4)(Yap_InitSlot(Deref(ARG1)),
Yap_InitSlot(Deref(ARG2)),
Yap_InitSlot(Deref(ARG3)),
Yap_InitSlot(Deref(ARG4)),
ctx));
}
case 5:
{
CBPredicate5 code5 = (CBPredicate5)exec_code;
return ((code5)(Yap_InitSlot(Deref(ARG1)),
Yap_InitSlot(Deref(ARG2)),
Yap_InitSlot(Deref(ARG3)),
Yap_InitSlot(Deref(ARG4)),
Yap_InitSlot(Deref(ARG5)), ctx));
}
case 6:
{
CBPredicate6 code6 = (CBPredicate6)exec_code;
return ((code6)(Yap_InitSlot(Deref(ARG1)),
Yap_InitSlot(Deref(ARG2)),
Yap_InitSlot(Deref(ARG3)),
Yap_InitSlot(Deref(ARG4)),
Yap_InitSlot(Deref(ARG5)),
Yap_InitSlot(Deref(ARG6)),
ctx));
}
case 7:
{
CBPredicate7 code7 = (CBPredicate7)exec_code;
return ((code7)(Yap_InitSlot(Deref(ARG1)),
Yap_InitSlot(Deref(ARG2)),
Yap_InitSlot(Deref(ARG3)),
Yap_InitSlot(Deref(ARG4)),
Yap_InitSlot(Deref(ARG5)),
Yap_InitSlot(Deref(ARG6)),
Yap_InitSlot(Deref(ARG7)),
ctx));
}
case 8:
{
CBPredicate8 code8 = (CBPredicate8)exec_code;
return ((code8)(Yap_InitSlot(Deref(ARG1)),
Yap_InitSlot(Deref(ARG2)),
Yap_InitSlot(Deref(ARG3)),
Yap_InitSlot(Deref(ARG4)),
Yap_InitSlot(Deref(ARG5)),
Yap_InitSlot(Deref(ARG6)),
Yap_InitSlot(Deref(ARG7)),
Yap_InitSlot(Deref(ARG8)),
ctx));
}
default:
return(FALSE);
}
}
Int
YAP_Execute(PredEntry *pe, CPredicate exec_code)
@ -1223,7 +1322,7 @@ YAP_Execute(PredEntry *pe, CPredicate exec_code)
Int
YAP_ExecuteFirst(PredEntry *pe, CPredicate exec_code)
{
if (pe->PredFlags & SWIEnvPredFlag) {
if (pe->PredFlags & (SWIEnvPredFlag|CArgsPredFlag)) {
Int val;
CPredicateV codev = (CPredicateV)exec_code;
struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1));
@ -1231,7 +1330,11 @@ YAP_ExecuteFirst(PredEntry *pe, CPredicate exec_code)
ctx->control = FRG_FIRST_CALL;
ctx->engine = NULL; //(PL_local_data *)Yap_regp;
ctx->context = NULL;
val = ((codev)((&ARG1)-LCL0,0,ctx));
if (pe->PredFlags & CArgsPredFlag) {
val = execute_cargs_back(pe, exec_code, ctx);
} else {
val = ((codev)((&ARG1)-LCL0,0,ctx));
}
if (val == 0) {
cut_fail();
} else if (val == 1) { /* TRUE */
@ -1241,10 +1344,8 @@ YAP_ExecuteFirst(PredEntry *pe, CPredicate exec_code)
ctx->context = (int *)(val & ~REDO_PTR);
else
ctx->context = (int *)((val & ~REDO_PTR)>>FRG_REDO_BITS);
return TRUE;
}
}
if (pe->PredFlags & CArgsPredFlag) {
return execute_cargs(pe, exec_code);
} else {
return (exec_code)();
}
@ -1260,7 +1361,11 @@ YAP_ExecuteNext(PredEntry *pe, CPredicate exec_code)
struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1));
ctx->control = FRG_REDO;
val = ((codev)((&ARG1)-LCL0,0,ctx));
if (pe->PredFlags & CArgsPredFlag) {
val = execute_cargs_back(pe, exec_code, ctx);
} else {
val = ((codev)((&ARG1)-LCL0,0,ctx));
}
if (val == 0) {
cut_fail();
} else if (val == 1) { /* TRUE */
@ -1271,12 +1376,9 @@ YAP_ExecuteNext(PredEntry *pe, CPredicate exec_code)
else
ctx->context = (int *)((val & ~REDO_PTR)>>FRG_REDO_BITS);
}
return TRUE;
}
if (pe->PredFlags & CArgsPredFlag) {
return execute_cargs(pe, exec_code);
} else {
return (exec_code)();
}
return (exec_code)();
}
X_API Int

26
include/SWI-Prolog.h
View File

@ -479,6 +479,32 @@ X_API int PL_error(const char *pred, int arity, const char *msg, int id, ...);
X_API int PL_warning(const char *msg, ...);
/********************************
* NON-DETERMINISTIC CALL/RETURN *
*********************************/
/* Note 1: Non-deterministic foreign functions may also use the deterministic
return methods PL_succeed and PL_fail.
Note 2: The argument to PL_retry is a sizeof(ptr)-2 bits signed
integer (use type intptr_t).
*/
#define PL_FIRST_CALL (0)
#define PL_CUTTED (1)
#define PL_REDO (2)
#define PL_retry(n) return _PL_retry(n)
#define PL_retry_address(a) return _PL_retry_address(a)
PL_EXPORT(foreign_t) _PL_retry(intptr_t);
PL_EXPORT(foreign_t) _PL_retry_address(void *);
PL_EXPORT(int) PL_foreign_control(control_t);
PL_EXPORT(intptr_t) PL_foreign_context(control_t);
PL_EXPORT(void *) PL_foreign_context_address(control_t);
#ifdef __cplusplus
}
#endif

57
library/yap2swi/yap2swi.c
View File

@ -2258,6 +2258,63 @@ PL_eval_expression_to_int64_ex(term_t t, int64_t *val)
return FALSE;
}
foreign_t
_PL_retry(intptr_t n)
{
/* first we need to get the pointer to the predicate */
PredEntry *pe = B->cp_ap->u.OtapFs.p;
struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1));
ctx->context = n;
return LCL0-(CELL *)ctx;
}
foreign_t
_PL_retry_address(void *addr)
{
/* first we need to get the pointer to the predicate */
PredEntry *pe = B->cp_ap->u.OtapFs.p;
struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1));
ctx->context = (intptr_t)addr;
return LCL0-(CELL *)ctx;
}
int
PL_foreign_control(control_t ctx)
{
switch (ctx->control) {
case FRG_REDO:
return PL_REDO;
case FRG_FIRST_CALL:
return PL_FIRST_CALL;
default:
return PL_CUTTED;
}
}
intptr_t
PL_foreign_context(control_t ctx)
{
switch (ctx->control) {
case FRG_FIRST_CALL:
return 0L;
default:
return (intptr_t)(ctx->context);
}
}
void *
PL_foreign_context_address(control_t ctx)
{
switch (ctx->control) {
case FRG_FIRST_CALL:
return NULL;
default:
return (void *)(ctx->context);
}
}
static int
SWI_ctime(void)