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

Merge branch 'master' of git.dcc.fc.up.pt:yap-6.3

Browse Source
This commit is contained in:
Ubuntu32 2011-11-18 14:35:43 -08:00
commit 2d699b0c04
165 changed files with 25253 additions and 2297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
C/absmi.c
View File

@ -10257,7 +10257,7 @@ Yap_absmi(int inp)
if (IsIntTerm(d0) && IsIntTerm(d1)) {
Int i2 = IntOfTerm(d1);
if (i2 < 0)
d0 = MkIntegerTerm(IntOfTerm(d0) >> -i2);
d0 = MkIntegerTerm(SLR(IntOfTerm(d0), -i2));
else
d0 = do_sll(IntOfTerm(d0),i2);
}
@ -10343,7 +10343,7 @@ Yap_absmi(int inp)
if (IsIntTerm(d0)) {
Int i2 = IntOfTerm(d0);
if (i2 < 0)
d0 = MkIntegerTerm(d1 >> -i2);
d0 = MkIntegerTerm(SLR(d1, -i2));
else
d0 = do_sll(d1,i2);
}
@ -10388,7 +10388,7 @@ Yap_absmi(int inp)
if (IsIntTerm(d0) && IsIntTerm(d1)) {
Int i2 = IntOfTerm(d1);
if (i2 < 0)
d0 = MkIntegerTerm(IntOfTerm(d0) >> -i2);
d0 = MkIntegerTerm(SLR(IntOfTerm(d0), -i2));
else
d0 = do_sll(IntOfTerm(d0),i2);
}
@ -10481,7 +10481,7 @@ Yap_absmi(int inp)
if (IsIntTerm(d0)) {
Int i2 = IntOfTerm(d0);
if (i2 < 0)
d0 = MkIntegerTerm(d1 >> -i2);
d0 = MkIntegerTerm(SLR(d1, -i2));
else
d0 = do_sll(d1,i2);
}
@ -10531,7 +10531,7 @@ Yap_absmi(int inp)
if (i2 < 0)
d0 = do_sll(IntOfTerm(d0), -i2);
else
d0 = MkIntTerm(IntOfTerm(d0) >> i2);
d0 = MkIntTerm(SLR(IntOfTerm(d0), i2));
}
else {
saveregs();
@ -10576,7 +10576,7 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.xxn.c;
if (IsIntTerm(d0)) {
d0 = MkIntTerm(IntOfTerm(d0) >> d1);
d0 = MkIntTerm(SLR(IntOfTerm(d0), d1));
}
else {
saveregs();
@ -10617,7 +10617,7 @@ Yap_absmi(int inp)
if (i2 < 0)
d0 = do_sll(d1, -i2);
else
d0 = MkIntegerTerm(d1 >> i2);
d0 = MkIntegerTerm(SLR(d1, i2));
}
else {
saveregs();
@ -10662,7 +10662,7 @@ Yap_absmi(int inp)
if (i2 < 0)
d0 = do_sll(IntOfTerm(d0), -i2);
else
d0 = MkIntTerm(IntOfTerm(d0) >> i2);
d0 = MkIntTerm(SLR(IntOfTerm(d0), i2));
}
else {
saveregs();
@ -10710,7 +10710,7 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.yxn.c;
if (IsIntTerm(d0)) {
d0 = MkIntTerm(IntOfTerm(d0) >> d1);
d0 = MkIntTerm(SLR(IntOfTerm(d0), d1));
}
else {
saveregs();
@ -10753,7 +10753,7 @@ Yap_absmi(int inp)
if (i2 < 0)
d0 = do_sll(d1, -i2);
else
d0 = MkIntegerTerm(d1 >> i2);
d0 = MkIntegerTerm(SLR(d1, i2));
}
else {
saveregs();

39
C/c_interface.c
View File

@ -412,6 +412,7 @@ X_API int STD_PROTO(YAP_IsWideAtom,(Atom));
X_API char *STD_PROTO(YAP_AtomName,(Atom));
X_API wchar_t *STD_PROTO(YAP_WideAtomName,(Atom));
X_API Term STD_PROTO(YAP_MkPairTerm,(Term,Term));
X_API Term STD_PROTO(YAP_MkListFromTerms,(Term *,Int));
X_API Term STD_PROTO(YAP_MkNewPairTerm,(void));
X_API Term STD_PROTO(YAP_HeadOfTerm,(Term));
X_API Term STD_PROTO(YAP_TailOfTerm,(Term));
@ -982,6 +983,44 @@ YAP_MkPairTerm(Term t1, Term t2)
return t;
}
X_API Term
YAP_MkListFromTerms(Term *ta, Int sz)
{
CACHE_REGS
Term t;
CELL *h;
if (sz == 0)
return TermNil;
BACKUP_H();
if (H+sz*2 > ASP-1024) {
Int sl1 = Yap_InitSlot((CELL)ta PASS_REGS);
RECOVER_H();
if (!dogc( PASS_REGS1 )) {
return TermNil;
}
BACKUP_H();
ta = (CELL *)Yap_GetFromSlot(sl1 PASS_REGS);
Yap_RecoverSlots(1 PASS_REGS);
}
h = H;
t = AbsPair(h);
while (sz--) {
Term ti = *ta++;
if (IsVarTerm(ti)) {
RESET_VARIABLE(h);
Yap_unify(ti, h[0]);
} else {
h[0] = ti;
}
h[1] = AbsPair(h+2);
h += 2;
}
h[-1] = TermNil;
H = h;
RECOVER_H();
return t;
}
X_API Term
YAP_MkNewPairTerm()
{

2
C/cdmgr.c
View File

@ -3113,7 +3113,7 @@ p_undefined( USES_REGS1 )
if (EndOfPAEntr(pe))
return TRUE;
PELOCK(36,pe);
if (pe->PredFlags & (CPredFlag|UserCPredFlag|TestPredFlag|AsmPredFlag|DynamicPredFlag|LogUpdatePredFlag)) {
if (pe->PredFlags & (CPredFlag|UserCPredFlag|TestPredFlag|AsmPredFlag|DynamicPredFlag|LogUpdatePredFlag|TabledPredFlag)) {
UNLOCKPE(57,pe);
return FALSE;
}

8
C/gmp_support.c
View File

@ -377,16 +377,16 @@ Yap_gmp_sll_big_int(Term t, Int i)
MP_INT *b = Yap_BigIntOfTerm(t);
if (i > 0) {
mpz_init_set(&new, b);
mpz_mul_2exp(&new, &new, i);
mpz_init(&new);
mpz_mul_2exp(&new, b, i);
} else if (i == 0) {
return t;
} else {
mpz_init_set(&new, b);
mpz_init(&new);
if (i == Int_MIN) {
return Yap_ArithError(RESOURCE_ERROR_HUGE_INT, MkIntegerTerm(i), "<</2");
}
mpz_tdiv_q_2exp(&new, &new, -i);
mpz_fdiv_q_2exp(&new, b, -i);
}
return MkBigAndClose(&new);
} else {

22
C/utilpreds.c
View File

@ -4514,17 +4514,27 @@ unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow, int share
if (ASP-(max+1) <= H) {
goto overflow;
}
/* we found this before */
*ptf++ = ASP[-id-1];
/* we found this before? */
if (ASP[-id-1])
*ptf++ = ASP[-id-1];
else {
RESET_VARIABLE(ptf);
ASP[-id-1] = (CELL)ptf;
ptf++;
}
continue;
}
max = id;
if (ASP-(max+1) <= H) {
/* alloc more space */
if (ASP-(id+1) <= H) {
goto overflow;
}
while (id > max) {
ASP[-(id+1)] = 0L;
max++;
}
/* new variable */
RESET_VARIABLE(ptf);
ASP[-id-1] = (CELL)ptf;
ASP[-(id+1)] = (CELL)ptf;
ptf++;
continue;
}
@ -4723,7 +4733,7 @@ Yap_UnNumberTerm(Term inp, int share) {
static Int
p_unnumbervars( USES_REGS1 ) {
/* this should be a standard Prolog term, so we allow sharing? */
return Yap_unify(Yap_UnNumberTerm(ARG1, FALSE PASS_REGS), ARG2);
return Yap_unify(UnnumberTerm(ARG1, 2, FALSE PASS_REGS), ARG2);
}
void Yap_InitUtilCPreds(void)

2
H/Regs.h
View File

@ -15,6 +15,7 @@
/********* abstract machine registers **********************************/
#ifdef YAP_H
#ifdef CUT_C
#include "cut_c.h"
#endif
@ -22,6 +23,7 @@
#if defined MYDDAS_ODBC || defined MYDDAS_MYSQL
#include "myddas.h"
#endif
#endif
#define MaxTemps 512
#define MaxArithms 32

8
H/TermExt.h
View File

@ -64,7 +64,7 @@ inline EXTERN int IsAttVar (CELL *pt);
inline EXTERN int
IsAttVar (CELL *pt)
{
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
CACHE_REGS
return (pt)[-1] == (CELL)attvar_e
&& pt < H;
@ -148,7 +148,7 @@ exts;
#endif
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
/* make sure that these data structures are the first thing to be allocated
in the heap when we start the system */
@ -294,7 +294,7 @@ IsFloatTerm (Term t)
/* extern Functor FunctorLongInt; */
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN Term MkLongIntTerm (Int);
inline EXTERN Term
@ -604,7 +604,7 @@ IsAttachedTerm (Term t)
#endif
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL));

6
H/YapTags.h
View File

@ -184,7 +184,7 @@ IsUnboundVar (Term * t)
#else
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN Term MkVarTerm__ ( USES_REGS1 );
@ -316,7 +316,7 @@ IsIntTerm (Term t)
}
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
EXTERN inline Term STD_PROTO (MkPairTerm__, (Term, Term CACHE_TYPE) );
EXTERN inline Term
@ -367,7 +367,7 @@ MkPairTerm__ (Term head, Term tail USES_REGS)
#define IsAccessFunc(func) ((func) == FunctorAccess)
#ifdef _YAP_NOT_INSTALLED_
#ifdef YAP_H
inline EXTERN Term MkIntegerTerm (Int);
inline EXTERN Term

3
H/YapTerm.h
View File

@ -13,12 +13,11 @@
* version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ *
*************************************************************************/
#ifndef _YAP_NOT_INSTALLED_
#ifndef YAP_H
#include "YapTermConfig.h"
typedef void *Functor;
typedef void *Atom;
#endif
#ifndef EXTERN

86
H/arith2.h
View File

@ -69,6 +69,12 @@ sub_int(Int i, Int j)
#endif
}
inline static Int
SLR(Int i, Int shift)
{
return (shift < sizeof(Int)*8-1 ? i >> shift : (i >= 0 ? 0 : -1));
}
#ifdef __GNUC__
#ifdef __i386__
#define DO_MULTI() { Int tmp1; \
@ -114,28 +120,56 @@ times_int(Int i1, Int i2) {
}
#if USE_GMP
static inline int
sl_overflow(Int i,Int j)
#ifndef __GNUC__X
static int
clrsb(Int i)
{
Int x = (8*sizeof(CELL)-2)-j;
CELL t = (1<<x)-1;
Int j=0;
if (x < 0) return TRUE;
t = (1<<x)-1;
return (t & i) != i;
if (i < 0) {
if (i == Int_MIN)
return 1;
i = -i;
}
#if SIZEOF_INT_P == 8
if (i < (Int)(0x100000000)) { j += 32;}
else i >>= 32;
#endif
if (i < (Int)(0x10000)) {j += 16;}
else i >>= 16;
if (i < (Int)(0x100)) {j += 8;}
else i >>= 8;
if (i < (Int)(0x10)) {j += 4;}
else i >>= 4;
if (i < (Int)(0x4)) {j += 2;}
else i >>= 2;
if (i < (Int)(0x2)) j++;
return j;
}
#endif
inline static Term
do_sll(Int i, Int j)
do_sll(Int i, Int j) /* j > 0 */
{
Int k;
#ifdef USE_GMP
if (sl_overflow(i,j)) {
return Yap_gmp_sll_ints(i, j);
}
if (
#ifdef __GNUC__X
#if SIZEOF_LONG_INT < SIZEOF_INT_P
__builtin_clrsbll(i)
#else
__builtin_clrsbl(i)
#endif
#else
clrsb(i)
#endif
> j)
RINT(i << j);
return Yap_gmp_sll_ints(i, j);
#else
RINT(i << j);
#endif
}
@ -459,14 +493,16 @@ p_sll(Term t1, Term t2) {
switch (ETypeOfTerm(t2)) {
case long_int_e:
/* two integers */
if (IntegerOfTerm(t2) < 0) {
Int i2 = IntegerOfTerm(t2);
if (i2 == Int_MIN) {
return Yap_ArithError(RESOURCE_ERROR_HUGE_INT, t2, ">>/2");
{ Int i2 = IntegerOfTerm(t2);
if (i2 <= 0) {
if (i2 == Int_MIN) {
return Yap_ArithError(RESOURCE_ERROR_HUGE_INT, t2, ">>/2");
}
RINT(SLR(IntegerOfTerm(t1), -i2));
}
RINT(IntegerOfTerm(t1) >> -i2);
return do_sll(IntegerOfTerm(t1),i2);
}
return do_sll(IntegerOfTerm(t1),IntegerOfTerm(t2));
case double_e:
return Yap_ArithError(TYPE_ERROR_INTEGER, t2, "<</2");
case big_int_e:
@ -505,14 +541,16 @@ p_slr(Term t1, Term t2) {
switch (ETypeOfTerm(t2)) {
case long_int_e:
/* two integers */
if (IntegerOfTerm(t2) < 0) {
Int i2 = IntegerOfTerm(t2);
if (i2 == Int_MIN) {
return Yap_ArithError(RESOURCE_ERROR_HUGE_INT, t2, ">>/2");
{ Int i2 = IntegerOfTerm(t2);
if (i2 < 0) {
if (i2 == Int_MIN) {
return Yap_ArithError(RESOURCE_ERROR_HUGE_INT, t2, ">>/2");
}
return do_sll(IntegerOfTerm(t1), -i2);
}
return do_sll(IntegerOfTerm(t1), -i2);
RINT(SLR(IntegerOfTerm(t1), i2));
}
RINT(IntegerOfTerm(t1) >> IntegerOfTerm(t2));
case double_e:
return Yap_ArithError(TYPE_ERROR_INTEGER, t2, ">>/2");
case big_int_e:

10
Makefile.in
View File

@ -129,7 +129,7 @@ INTERFACE_HEADERS = \
IOLIB_HEADERS=$(srcdir)/os/pl-buffer.h \
$(srcdir)/os/pl-ctype.h \
$(srcdir)/H/pl-codelist.h \
$(srcdir)/os/pl-codelist.h \
$(srcdir)/os/pl-dtoa.h \
$(srcdir)/os/dtoa.c \
$(srcdir)/H/pl-incl.h \
@ -138,7 +138,6 @@ IOLIB_HEADERS=$(srcdir)/os/pl-buffer.h \
$(srcdir)/os/pl-option.h \
$(srcdir)/os/pl-os.h \
$(srcdir)/os/pl-privitf.h \
$(srcdir)/os/pl-stream.h \
$(srcdir)/os/pl-table.h \
$(srcdir)/os/pl-text.h \
$(srcdir)/os/pl-utf8.h \
@ -710,6 +709,7 @@ all: startup.yss
@ENABLE_CPLINT@ (cd packages/cplint/approx/simplecuddLPADs; $(MAKE))
@ENABLE_CPLINT@ (cd packages/cplint; $(MAKE))
@ENABLE_CPLINT@ (cd packages/cplint/slipcase; $(MAKE))
@ENABLE_PRISM@ (cd packages/prism/src/c; $(MAKE))
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd; $(MAKE))
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd_lfi; $(MAKE))
@ENABLE_JPL@ @INSTALL_DLLS@ (cd packages/jpl; $(MAKE))
@ -786,6 +786,8 @@ install_unix: startup.yss libYap.a
$(INSTALL) YapTermConfig.h $(DESTDIR)$(INCLUDEDIR)
@ENABLE_CPLINT@ (cd packages/cplint; $(MAKE) install)
@ENABLE_CPLINT@ (cd packages/cplint/approx/simplecuddLPADs; $(MAKE) install)
@ENABLE_PRISM@ (cd packages/prism/src/c; $(MAKE) install)
@ENABLE_PRISM@ (cd packages/prism/src/prolog; $(MAKE) install)
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd; $(MAKE) install)
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd_lfi; $(MAKE) install)
@ -836,6 +838,8 @@ install_win32: startup.yss @ENABLE_WINCONSOLE@ pl-yap@EXEC_SUFFIX@
@ENABLE_JPL@ (cd packages/jpl ; $(MAKE) install)
@ENABLE_MINISAT@ (cd packages/swi-minisat2/C; $(MAKE) install)
@ENABLE_CPLINT@ (cd packages/cplint; $(MAKE) install)
@ENABLE_PRISM@ (cd packages/prism/src/c; $(MAKE) install)
@ENABLE_PRISM@ (cd packages/prism/src/prolog; $(MAKE) install)
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd; $(MAKE) install)
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd_lfi; $(MAKE) install)
@ -895,6 +899,8 @@ clean: clean_docs
@ENABLE_MINISAT@ (cd packages/swi-minisat2; $(MAKE) clean)
@ENABLE_CLPBN_BP@ (cd packages/CLPBN/clpbn/bp; $(MAKE) clean)
@ENABLE_ZLIB@ @INSTALL_DLLS@ (cd packages/zlib; $(MAKE) clean)
@ENABLE_PRISM@ (cd packages/prism/src/c; $(MAKE) clean)
@ENABLE_PRISM@ (cd packages/prism/src/prolog; $(MAKE) clean)
@ENABLE_CPLINT@ (cd packages/cplint/approx/simplecuddLPADs; $(MAKE) clean)
@ENABLE_CPLINT@ (cd packages/cplint; $(MAKE) clean)
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd; $(MAKE) clean)

248
OPTYap/opt.config.h
View File

@ -16,17 +16,16 @@
/************************************************************************
** General Configuration Parameters **
************************************************************************/
#define MODE_DIRECTED_TABLING
/******************************************************************************************
** use shared pages memory alloc scheme for OPTYap data structures? (optional) **
******************************************************************************************/
/* #define USE_PAGES_MALLOC 1 */
/************************************************************************
** TABLING Configuration Parameters **
** Tabling Configuration Parameters **
************************************************************************/
/****************************
@ -40,6 +39,11 @@
#define BFZ_TRAIL_SCHEME 1
/* #define BBREG_TRAIL_SCHEME 1 */
/*********************************************************
** support mode directed tabling ? (optional) **
*********************************************************/
#define MODE_DIRECTED_TABLING 1
/****************************************************
** support early completion ? (optional) **
****************************************************/
@ -78,7 +82,7 @@
/************************************************************************
** YAPOR Configuration Parameters **
** YapOr Configuration Parameters **
************************************************************************/
/****************************
@ -102,42 +106,57 @@
/************************************************************************
** OPTYAP Configuration Parameters **
** OPTYap Configuration Parameters **
************************************************************************/
/****************************
** default sizes **
****************************/
#define TABLE_LOCK_BUCKETS 512
#define TG_ANSWER_SLOTS 20
#define TRIE_LOCK_BUCKETS 512
/***********************************************************
** tries locking scheme (mandatory, define one) **
************************************************************
** The TABLE_LOCK_AT_ENTRY_LEVEL scheme locks the access **
** to the table space in the entry data structure. It **
** restricts the number of lock operations needed to go **
** through the table data structures. **
** **
** The TABLE_LOCK_AT_NODE_LEVEL scheme locks each data **
** structure before accessing it. It decreases **
** concurrrency for workers accessing commom parts of the **
** table space. **
** **
** The TABLE_LOCK_AT_WRITE_LEVEL scheme is an hibrid **
** scheme, it only locks a table data structure when it **
** is going to update it. You can use ALLOC_BEFORE_CHECK **
** with this scheme to allocate a node before checking **
** if it will be necessary. **
***********************************************************/
/* #define TABLE_LOCK_AT_ENTRY_LEVEL 1 */
/* #define TABLE_LOCK_AT_NODE_LEVEL 1 */
#define TABLE_LOCK_AT_WRITE_LEVEL 1
/* #define ALLOC_BEFORE_CHECK 1 */
/*************************************************************************
** tries locking scheme (mandatory, define one per trie type) **
**************************************************************************
** The (TRIE_TYPE)_LOCK_AT_ENTRY_LEVEL scheme locks the access to the **
** table space in the entry data structure. It restricts the number of **
** lock operations needed to go through the table data structures. **
** **
** The (TRIE_TYPE)_LOCK_AT_NODE_LEVEL scheme locks each data structure **
** before accessing it. It decreases concurrrency for workers accessing **
** commom parts of the table space. **
** **
** The (TRIE_TYPE)_LOCK_AT_WRITE_LEVEL scheme is an hibrid scheme, it **
** only locks a table data structure when it is going to update it. You **
** can use (TRIE_TYPE)_ALLOC_BEFORE_CHECK with this scheme to allocate **
** a node before checking if it will be necessary. **
*************************************************************************/
/* #define SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL 1 */
#define SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL 1
/* #define SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL 1 */
/* #define SUBGOAL_TRIE_ALLOC_BEFORE_CHECK 1 */
/**********************************************
** support inner cuts ? (optional) **
**********************************************/
/* #define ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL 1 */
#define ANSWER_TRIE_LOCK_AT_NODE_LEVEL 1
/* #define ANSWER_TRIE_LOCK_AT_WRITE_LEVEL 1 */
/* #define ANSWER_TRIE_ALLOC_BEFORE_CHECK 1 */
#define GLOBAL_TRIE_LOCK_AT_NODE_LEVEL 1
/* #define GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL 1 */
/* #define GLOBAL_TRIE_ALLOC_BEFORE_CHECK 1 */
/*******************************************************************
** tries locking data structure (mandatory, define one) **
********************************************************************
** Data structure to be used for locking the trie when using the **
** (TRIE_TYPE)_LOCK_AT_[NODE|WRITE]_LEVEL schemes **
*******************************************************************/
#define TRIE_LOCK_USING_NODE_FIELD 1
/* #define TRIE_LOCK_USING_GLOBAL_ARRAY 1 */
/******************************************************
** support tabling inner cuts ? (optional) **
******************************************************/
#define TABLING_INNER_CUTS 1
/*********************************************************
@ -153,73 +172,138 @@
#ifndef USE_PAGES_MALLOC
#undef LIMIT_TABLING
#endif /* !USE_PAGES_MALLOC */
#endif /* ! USE_PAGES_MALLOC */
#ifdef TABLING
#if !defined(BFZ_TRAIL_SCHEME) && !defined(BBREG_TRAIL_SCHEME)
#error Define a trail scheme
#endif
#if defined(BFZ_TRAIL_SCHEME) && defined(BBREG_TRAIL_SCHEME)
#error Do not define multiple trail schemes
#endif
#else /* ! TABLING */
#undef BFZ_TRAIL_SCHEME
#undef BBREG_TRAIL_SCHEME
#undef MODE_DIRECTED_TABLING
#undef TABLING_EARLY_COMPLETION
#undef TRIE_COMPACT_PAIRS
#undef GLOBAL_TRIE_FOR_SUBTERMS
#undef INCOMPLETE_TABLING
#undef LIMIT_TABLING
#undef DETERMINISTIC_TABLING
#undef DEBUG_TABLING
#endif /* TABLING */
#ifdef YAPOR
#ifdef i386 /* For i386 machines we use shared memory segments */
#undef MMAP_MEMORY_MAPPING_SCHEME
#define SHM_MEMORY_MAPPING_SCHEME
#endif /* i386 */
#endif
#if !defined(MMAP_MEMORY_MAPPING_SCHEME) && !defined(SHM_MEMORY_MAPPING_SCHEME)
#error Define a memory mapping scheme
#endif /* !MMAP_MEMORY_MAPPING_SCHEME && !SHM_MEMORY_MAPPING_SCHEME */
#endif
#if defined(MMAP_MEMORY_MAPPING_SCHEME) && defined(SHM_MEMORY_MAPPING_SCHEME)
#error Do not define multiple memory mapping schemes
#endif /* MMAP_MEMORY_MAPPING_SCHEME && SHM_MEMORY_MAPPING_SCHEME */
#endif
#undef LIMIT_TABLING
#else /* ! YAPOR */
#undef MMAP_MEMORY_MAPPING_SCHEME
#undef SHM_MEMORY_MAPPING_SCHEME
#undef DEBUG_YAPOR
#endif /* YAPOR */
#ifdef TABLING
#if !defined(BFZ_TRAIL_SCHEME) && !defined(BBREG_TRAIL_SCHEME)
#error Define a trail scheme
#endif /* !BFZ_TRAIL_SCHEME && !BBREG_TRAIL_SCHEME */
#if defined(BFZ_TRAIL_SCHEME) && defined(BBREG_TRAIL_SCHEME)
#error Do not define multiple trail schemes
#endif /* BFZ_TRAIL_SCHEME && BBREG_TRAIL_SCHEME */
#endif /* TABLING */
#if defined(YAPOR) && defined(TABLING)
#if !defined(TABLE_LOCK_AT_ENTRY_LEVEL) && !defined(TABLE_LOCK_AT_NODE_LEVEL) && !defined(TABLE_LOCK_AT_WRITE_LEVEL)
#error Define a table lock scheme
#endif /* !TABLE_LOCK_AT_ENTRY_LEVEL && !TABLE_LOCK_AT_NODE_LEVEL && !TABLE_LOCK_AT_WRITE_LEVEL */
#if defined(TABLE_LOCK_AT_ENTRY_LEVEL)
#if defined(TABLE_LOCK_AT_NODE_LEVEL) || defined(TABLE_LOCK_AT_WRITE_LEVEL)
#error Do not define multiple table lock schemes
#endif /* TABLE_LOCK_AT_NODE_LEVEL || TABLE_LOCK_AT_WRITE_LEVEL */
#endif /* TABLE_LOCK_AT_ENTRY_LEVEL */
#if defined(TABLE_LOCK_AT_NODE_LEVEL) && defined(TABLE_LOCK_AT_WRITE_LEVEL)
#error Do not define multiple table lock schemes
#endif /* TABLE_LOCK_AT_NODE_LEVEL || TABLE_LOCK_AT_WRITE_LEVEL */
#ifndef TABLE_LOCK_AT_WRITE_LEVEL
#undef ALLOC_BEFORE_CHECK
#endif /* !TABLE_LOCK_AT_WRITE_LEVEL */
#else
#undef TABLE_LOCK_AT_ENTRY_LEVEL
#undef TABLE_LOCK_AT_NODE_LEVEL
#undef TABLE_LOCK_AT_WRITE_LEVEL
#undef ALLOC_BEFORE_CHECK
#endif /* YAPOR && TABLING */
#if !defined(TABLING) || !defined(YAPOR)
/* SUBGOAL_TRIE_LOCK_LEVEL */
#if !defined(SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL) && !defined(SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL) && !defined(SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL)
#error Define a subgoal trie lock scheme
#endif
#if defined(SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL) && defined(SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL)
#error Do not define multiple subgoal trie lock schemes
#endif
#if defined(SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL) && defined(SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL)
#error Do not define multiple subgoal trie lock schemes
#endif
#if defined(SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL) && defined(SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL)
#error Do not define multiple subgoal trie lock schemes
#endif
#ifndef SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL
#undef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
#endif
/* ANSWER_TRIE_LOCK_LEVEL */
#if !defined(ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL) && !defined(ANSWER_TRIE_LOCK_AT_NODE_LEVEL) && !defined(ANSWER_TRIE_LOCK_AT_WRITE_LEVEL)
#error Define a answer trie lock scheme
#endif
#if defined(ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL) && defined(ANSWER_TRIE_LOCK_AT_NODE_LEVEL)
#error Do not define multiple answer trie lock schemes
#endif
#if defined(ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL) && defined(ANSWER_TRIE_LOCK_AT_WRITE_LEVEL)
#error Do not define multiple answer trie lock schemes
#endif
#if defined(ANSWER_TRIE_LOCK_AT_NODE_LEVEL) && defined(ANSWER_TRIE_LOCK_AT_WRITE_LEVEL)
#error Do not define multiple answer trie lock schemes
#endif
#ifndef ANSWER_TRIE_LOCK_AT_WRITE_LEVEL
#undef ANSWER_TRIE_ALLOC_BEFORE_CHECK
#endif
/* GLOBAL_TRIE_LOCK_LEVEL */
#if !defined(GLOBAL_TRIE_LOCK_AT_NODE_LEVEL) && !defined(GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL)
#error Define a global trie lock scheme
#endif
#if defined(GLOBAL_TRIE_LOCK_AT_NODE_LEVEL) && defined(GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL)
#error Do not define multiple global trie lock schemes
#endif
#ifndef GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL
#undef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
#endif
/* TRIE_LOCK_USING_NODE_FIELD / TRIE_LOCK_USING_GLOBAL_ARRAY */
#if !defined(TRIE_LOCK_USING_NODE_FIELD) && !defined(TRIE_LOCK_USING_GLOBAL_ARRAY)
#error Define a trie lock data structure
#endif
#if defined(TRIE_LOCK_USING_NODE_FIELD) && defined(TRIE_LOCK_USING_GLOBAL_ARRAY)
#error Do not define multiple trie lock data structures
#endif
#ifdef TRIE_LOCK_USING_NODE_FIELD
#if defined(SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL) || defined(SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL)
#define SUBGOAL_TRIE_LOCK_USING_NODE_FIELD 1
#endif
#if defined(ANSWER_TRIE_LOCK_AT_NODE_LEVEL) || defined(ANSWER_TRIE_LOCK_AT_WRITE_LEVEL)
#define ANSWER_TRIE_LOCK_USING_NODE_FIELD 1
#endif
#if defined(GLOBAL_TRIE_LOCK_AT_NODE_LEVEL) || defined(GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL)
#define GLOBAL_TRIE_LOCK_USING_NODE_FIELD 1
#endif
#elif TRIE_LOCK_USING_GLOBAL_ARRAY
#if defined(SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL) || defined(SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL)
#define SUBGOAL_TRIE_LOCK_USING_GLOBAL_ARRAY 1
#endif
#if defined(ANSWER_TRIE_LOCK_AT_NODE_LEVEL) || defined(ANSWER_TRIE_LOCK_AT_WRITE_LEVEL)
#define ANSWER_TRIE_LOCK_USING_GLOBAL_ARRAY 1
#endif
#if defined(GLOBAL_TRIE_LOCK_AT_NODE_LEVEL) || defined(GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL)
#define GLOBAL_TRIE_LOCK_USING_GLOBAL_ARRAY 1
#endif
#endif
#else /* ! TABLING || ! YAPOR */
#undef SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL
#undef SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL
#undef SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL
#undef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
#undef ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL
#undef ANSWER_TRIE_LOCK_AT_NODE_LEVEL
#undef ANSWER_TRIE_LOCK_AT_WRITE_LEVEL
#undef ANSWER_TRIE_ALLOC_BEFORE_CHECK
#undef GLOBAL_TRIE_LOCK_AT_NODE_LEVEL
#undef GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL
#undef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
#undef TRIE_LOCK_USING_NODE_FIELD
#undef TRIE_LOCK_USING_GLOBAL_ARRAY
#undef TABLING_INNER_CUTS
#undef TIMESTAMP_CHECK
#endif /* !TABLING || !YAPOR */
#endif /* YAPOR && TABLING */
#ifndef YAPOR
#undef DEBUG_YAPOR
#endif /* !YAPOR */
#ifndef TABLING
#undef BFZ_TRAIL_SCHEME
#undef BBREG_TRAIL_SCHEME
#undef TABLING_EARLY_COMPLETION
#undef TRIE_COMPACT_PAIRS
#undef GLOBAL_TRIE_FOR_SUBTERMS
#undef DETERMINISTIC_TABLING
#undef LIMIT_TABLING
#undef INCOMPLETE_TABLING
#undef DEBUG_TABLING
#endif /* !TABLING */
#if defined(DEBUG_YAPOR) && defined(DEBUG_TABLING)
#define DEBUG_OPTYAP

8
OPTYap/opt.init.c
View File

@ -147,10 +147,10 @@ void Yap_init_global_optyap_data(int max_table_size, int n_workers, int sch_loop
CELL *pt = GLOBAL_table_var_enumerator_addr(i);
RESET_VARIABLE(pt);
}
#ifdef TABLE_LOCK_AT_WRITE_LEVEL
for (i = 0; i < TABLE_LOCK_BUCKETS; i++)
INIT_LOCK(GLOBAL_table_lock(i));
#endif /* TABLE_LOCK_AT_WRITE_LEVEL */
#ifdef TRIE_LOCK_USING_GLOBAL_ARRAY
for (i = 0; i < TRIE_LOCK_BUCKETS; i++)
INIT_LOCK(GLOBAL_trie_locks(i));
#endif /* TRIE_LOCK_USING_GLOBAL_ARRAY */
#endif /* TABLING */
return;

616
OPTYap/opt.macros.h
View File

@ -46,389 +46,289 @@ extern int Yap_page_size;
#ifdef USE_SYSTEM_MALLOC
/*************************************************************************************************
** USE_SYSTEM_MALLOC **
*************************************************************************************************/
#define ALLOC_BLOCK(STR, SIZE, STR_TYPE) \
if ((STR = (STR_TYPE *) malloc(SIZE)) == NULL) \
/**************************************************************************************
** USE_SYSTEM_MALLOC **
**************************************************************************************/
#define ALLOC_BLOCK(STR, SIZE, STR_TYPE) \
if ((STR = (STR_TYPE *) malloc(SIZE)) == NULL) \
Yap_Error(FATAL_ERROR, TermNil, "ALLOC_BLOCK: malloc error")
#define FREE_BLOCK(STR) \
#define FREE_BLOCK(STR) \
free(STR)
#else
/*************************************************************************************************
** ! USE_SYSTEM_MALLOC **
*************************************************************************************************/
#define ALLOC_BLOCK(STR, SIZE, STR_TYPE) \
{ char *block_ptr; \
if ((block_ptr = Yap_AllocCodeSpace(SIZE + sizeof(CELL))) != NULL) \
*block_ptr = 'y'; \
else if ((block_ptr = (char *) malloc(SIZE + sizeof(CELL))) != NULL) \
*block_ptr = 'm'; \
else \
Yap_Error(FATAL_ERROR, TermNil, "ALLOC_BLOCK: malloc error"); \
block_ptr += sizeof(CELL); \
STR = (STR_TYPE *) block_ptr; \
/**************************************************************************************
** ! USE_SYSTEM_MALLOC **
**************************************************************************************/
#define ALLOC_BLOCK(STR, SIZE, STR_TYPE) \
{ char *block_ptr; \
if ((block_ptr = Yap_AllocCodeSpace(SIZE + sizeof(CELL))) != NULL) \
*block_ptr = 'y'; \
else if ((block_ptr = (char *) malloc(SIZE + sizeof(CELL))) != NULL) \
*block_ptr = 'm'; \
else \
Yap_Error(FATAL_ERROR, TermNil, "ALLOC_BLOCK: malloc error"); \
block_ptr += sizeof(CELL); \
STR = (STR_TYPE *) block_ptr; \
}
#define FREE_BLOCK(STR) \
{ char *block_ptr = (char *)(STR) - sizeof(CELL); \
if (block_ptr[0] == 'y') \
Yap_FreeCodeSpace(block_ptr); \
else \
free(block_ptr); \
#define FREE_BLOCK(STR) \
{ char *block_ptr = (char *)(STR) - sizeof(CELL); \
if (block_ptr[0] == 'y') \
Yap_FreeCodeSpace(block_ptr); \
else \
free(block_ptr); \
}
#endif /*****************************************************************************************/
#ifdef USE_PAGES_MALLOC
/*************************************************************************************************
** USE_PAGES_MALLOC **
*************************************************************************************************/
#define FREE_PAGE(PG_HD) \
LOCK(Pg_lock(GLOBAL_pages_void)); \
UPDATE_STATS(Pg_str_in_use(GLOBAL_pages_void), -1); \
PgHd_next(PG_HD) = Pg_free_pg(GLOBAL_pages_void); \
Pg_free_pg(GLOBAL_pages_void) = PG_HD; \
UNLOCK(Pg_lock(GLOBAL_pages_void))
#define FREE_STRUCT(STR, STR_PAGES, STR_TYPE) \
{ pg_hd_ptr pg_hd; \
pg_hd = PAGE_HEADER(STR); \
LOCK(Pg_lock(STR_PAGES)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), -1); \
if (--PgHd_str_in_use(pg_hd) == 0) { \
UPDATE_STATS(Pg_pg_alloc(STR_PAGES), -1); \
if (PgHd_previous(pg_hd)) { \
if ((PgHd_next(PgHd_previous(pg_hd)) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = PgHd_previous(pg_hd); \
} else { \
if ((Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = NULL; \
} \
UNLOCK(Pg_lock(STR_PAGES)); \
FREE_PAGE(pg_hd); \
} else { \
if ((STRUCT_NEXT(STR) = (STR_TYPE *) PgHd_free_str(pg_hd)) == NULL) { \
PgHd_previous(pg_hd) = NULL; \
if ((PgHd_next(pg_hd) = Pg_free_pg(STR_PAGES)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = pg_hd; \
Pg_free_pg(STR_PAGES) = pg_hd; \
} \
PgHd_free_str(pg_hd) = (void *) STR; \
UNLOCK(Pg_lock(STR_PAGES)); \
} \
}
#ifdef LIMIT_TABLING
/*************************************************************************************************
** USE_PAGES_MALLOC && LIMIT_TABLING **
*************************************************************************************************/
#define INIT_PAGE(PG_HD, STR_PAGES, STR_TYPE) \
{ int i; \
STR_TYPE *aux_str; \
PgHd_str_in_use(PG_HD) = 0; \
PgHd_previous(PG_HD) = NULL; \
aux_str = (STR_TYPE *) (PG_HD + 1); \
PgHd_free_str(PG_HD) = (void *) aux_str; \
for (i = 1; i < Pg_str_per_pg(STR_PAGES); i++) { \
STRUCT_NEXT(aux_str) = aux_str + 1; \
aux_str++; \
} \
STRUCT_NEXT(aux_str) = NULL; \
LOCK(Pg_lock(STR_PAGES)); \
if ((PgHd_next(PG_HD) = Pg_free_pg(STR_PAGES)) != NULL) \
PgHd_previous(PgHd_next(PG_HD)) = PG_HD; \
Pg_free_pg(STR_PAGES) = PG_HD; \
UPDATE_STATS(Pg_pg_alloc(STR_PAGES), 1); \
}
#define ALLOC_PAGE(PG_HD) \
{ int i, shmid; \
pg_hd_ptr aux_pg_hd; \
if ((shmid = shmget(IPC_PRIVATE, SHMMAX, SHM_R|SHM_W)) == -1) \
Yap_Error(FATAL_ERROR, TermNil, "shmget error (ALLOC_PAGE)"); \
if ((PG_HD = (pg_hd_ptr) shmat(shmid, NULL, 0)) == (void *) -1) \
Yap_Error(FATAL_ERROR, TermNil, "shmat error (ALLOC_PAGE)"); \
if (shmctl(shmid, IPC_RMID, 0) != 0) \
Yap_Error(FATAL_ERROR, TermNil, "shmctl error (ALLOC_PAGE)"); \
aux_pg_hd = (pg_hd_ptr)(((void *)PG_HD) + Yap_page_size); \
Pg_free_pg(GLOBAL_pages_void) = aux_pg_hd; \
for (i = 2; i < SHMMAX / Yap_page_size; i++) { \
PgHd_next(aux_pg_hd) = (pg_hd_ptr)(((void *)aux_pg_hd) + Yap_page_size); \
aux_pg_hd = PgHd_next(aux_pg_hd); \
} \
PgHd_next(aux_pg_hd) = NULL; \
UPDATE_STATS(Pg_pg_alloc(GLOBAL_pages_void), SHMMAX / Yap_page_size); \
}
#define RECOVER_UNUSED_SPACE(STR_PAGES) \
{ sg_fr_ptr sg_fr = GLOBAL_check_sg_fr; \
do { \
if (sg_fr) \
sg_fr = SgFr_next(sg_fr); \
else \
sg_fr = GLOBAL_first_sg_fr; \
if (sg_fr == NULL) \
Yap_Error(FATAL_ERROR, TermNil, "no space left (RECOVER_UNUSED_SPACE)"); \
/* see function 'InteractSIGINT' in file 'sysbits.c' */ \
/* Yap_Error(PURE_ABORT, TermNil, ""); */ \
/* restore_absmi_regs(&Yap_standard_regs); */ \
/* siglongjmp (LOCAL_RestartEnv, 1); */ \
if (SgFr_first_answer(sg_fr) && \
SgFr_first_answer(sg_fr) != SgFr_answer_trie(sg_fr)) { \
SgFr_state(sg_fr) = ready; \
free_answer_hash_chain(SgFr_hash_chain(sg_fr)); \
SgFr_hash_chain(sg_fr) = NULL; \
SgFr_first_answer(sg_fr) = NULL; \
SgFr_last_answer(sg_fr) = NULL; \
free_answer_trie(TrNode_child(SgFr_answer_trie(sg_fr)), \
TRAVERSE_MODE_NORMAL, TRAVERSE_POSITION_FIRST); \
TrNode_child(SgFr_answer_trie(sg_fr)) = NULL; \
} \
} while (Pg_free_pg(GLOBAL_pages_void) == Pg_free_pg(STR_PAGES)); \
GLOBAL_check_sg_fr = sg_fr; \
}
#define ALLOC_STRUCT(STR, STR_PAGES, STR_TYPE) \
{ pg_hd_ptr pg_hd; \
LOCK(Pg_lock(STR_PAGES)); \
pg_hd = Pg_free_pg(STR_PAGES); \
while (pg_hd == NULL) { \
UNLOCK(Pg_lock(STR_PAGES)); \
LOCK(Pg_lock(GLOBAL_pages_void)); \
if (Pg_free_pg(GLOBAL_pages_void)) { \
pg_hd = Pg_free_pg(GLOBAL_pages_void); \
Pg_free_pg(GLOBAL_pages_void) = PgHd_next(pg_hd); \
UPDATE_STATS(Pg_str_in_use(GLOBAL_pages_void), 1); \
UNLOCK(Pg_lock(GLOBAL_pages_void)); \
INIT_PAGE(pg_hd, STR_PAGES, STR_TYPE); \
} else if ( GLOBAL_max_pages != Pg_pg_alloc(GLOBAL_pages_void)) { \
ALLOC_PAGE(pg_hd); \
UPDATE_STATS(Pg_str_in_use(GLOBAL_pages_void), 1); \
UNLOCK(Pg_lock(GLOBAL_pages_void)); \
INIT_PAGE(pg_hd, STR_PAGES, STR_TYPE); \
} else { \
UNLOCK(Pg_lock(GLOBAL_pages_void)); \
RECOVER_UNUSED_SPACE(STR_PAGES); \
LOCK(Pg_lock(STR_PAGES)); \
pg_hd = Pg_free_pg(STR_PAGES); \
} \
} \
PgHd_str_in_use(pg_hd)++; \
STR = (STR_TYPE *) PgHd_free_str(pg_hd); \
if ((PgHd_free_str(pg_hd) = (void *) STRUCT_NEXT(STR)) == NULL) \
if ((Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = NULL; \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), 1); \
UNLOCK(Pg_lock(STR_PAGES)); \
}
#define ALLOC_NEXT_FREE_STRUCT(STR, STR_PAGES, STR_TYPE) \
if ((STR = LOCAL_next_free_ans_node) == NULL) { \
pg_hd_ptr pg_hd; \
LOCK(Pg_lock(STR_PAGES)); \
pg_hd = Pg_free_pg(STR_PAGES); \
while (pg_hd == NULL) { \
UNLOCK(Pg_lock(STR_PAGES)); \
LOCK(Pg_lock(GLOBAL_pages_void)); \
if (Pg_free_pg(GLOBAL_pages_void)) { \
pg_hd = Pg_free_pg(GLOBAL_pages_void); \
Pg_free_pg(GLOBAL_pages_void) = PgHd_next(pg_hd); \
UPDATE_STATS(Pg_str_in_use(GLOBAL_pages_void), 1); \
UNLOCK(Pg_lock(GLOBAL_pages_void)); \
INIT_PAGE(pg_hd, STR_PAGES, STR_TYPE); \
} else if ( GLOBAL_max_pages != Pg_pg_alloc(GLOBAL_pages_void)) { \
ALLOC_PAGE(pg_hd); \
UPDATE_STATS(Pg_str_in_use(GLOBAL_pages_void), 1); \
UNLOCK(Pg_lock(GLOBAL_pages_void)); \
INIT_PAGE(pg_hd, STR_PAGES, STR_TYPE); \
} else { \
UNLOCK(Pg_lock(GLOBAL_pages_void)); \
RECOVER_UNUSED_SPACE(STR_PAGES); \
LOCK(Pg_lock(STR_PAGES)); \
pg_hd = Pg_free_pg(STR_PAGES); \
} \
} \
PgHd_str_in_use(pg_hd) = Pg_str_per_pg(STR_PAGES); \
STR = (STR_TYPE *) PgHd_free_str(pg_hd); \
PgHd_free_str(pg_hd) = NULL; \
Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), -PgHd_str_in_use(pg_hd)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), Pg_str_per_pg(STR_PAGES)); \
UNLOCK(Pg_lock(STR_PAGES)); \
} \
LOCAL_next_free_ans_node = STRUCT_NEXT(STR)
#else
/*************************************************************************************************
** USE_PAGES_MALLOC && ! LIMIT_TABLING **
*************************************************************************************************/
#define ALLOC_PAGE(PG_HD) \
LOCK(Pg_lock(GLOBAL_pages_void)); \
if (Pg_free_pg(GLOBAL_pages_void) == NULL) { \
int i, shmid; \
pg_hd_ptr pg_hd, aux_pg_hd; \
if ((shmid = shmget(IPC_PRIVATE, SHMMAX, SHM_R|SHM_W)) == -1) \
Yap_Error(FATAL_ERROR, TermNil, "shmget error (ALLOC_PAGE)"); \
if ((pg_hd = (pg_hd_ptr) shmat(shmid, NULL, 0)) == (void *) -1) \
Yap_Error(FATAL_ERROR, TermNil, "shmat error (ALLOC_PAGE)"); \
if (shmctl(shmid, IPC_RMID, 0) != 0) \
Yap_Error(FATAL_ERROR, TermNil, "shmctl error (ALLOC_PAGE)"); \
Pg_free_pg(GLOBAL_pages_void) = pg_hd; \
for (i = 1; i < SHMMAX / Yap_page_size; i++) { \
aux_pg_hd = (pg_hd_ptr)(((void *)pg_hd) + Yap_page_size); \
PgHd_next(pg_hd) = aux_pg_hd; \
pg_hd = aux_pg_hd; \
} \
PgHd_next(pg_hd) = NULL; \
UPDATE_STATS(Pg_pg_alloc(GLOBAL_pages_void), SHMMAX / Yap_page_size); \
} \
UPDATE_STATS(Pg_str_in_use(GLOBAL_pages_void), 1); \
PG_HD = Pg_free_pg(GLOBAL_pages_void); \
Pg_free_pg(GLOBAL_pages_void) = PgHd_next(PG_HD); \
UNLOCK(Pg_lock(GLOBAL_pages_void))
#define ALLOC_STRUCT(STR, STR_PAGES, STR_TYPE) \
{ pg_hd_ptr pg_hd; \
LOCK(Pg_lock(STR_PAGES)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), 1); \
if (Pg_free_pg(STR_PAGES)) { \
pg_hd = Pg_free_pg(STR_PAGES); \
PgHd_str_in_use(pg_hd)++; \
STR = (STR_TYPE *) PgHd_free_str(pg_hd); \
if ((PgHd_free_str(pg_hd) = (void *) STRUCT_NEXT(STR)) == NULL) \
if ((Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = NULL; \
UNLOCK(Pg_lock(STR_PAGES)); \
} else { \
int i; \
UPDATE_STATS(Pg_pg_alloc(STR_PAGES), 1); \
UNLOCK(Pg_lock(STR_PAGES)); \
ALLOC_PAGE(pg_hd); \
PgHd_str_in_use(pg_hd) = 1; \
PgHd_previous(pg_hd) = NULL; \
STR = (STR_TYPE *) (pg_hd + 1); \
PgHd_free_str(pg_hd) = (void *) ++STR; \
for (i = Pg_str_per_pg(STR_PAGES); i != 2; i--) { \
STRUCT_NEXT(STR) = STR + 1; \
STR++; \
} \
STRUCT_NEXT(STR) = NULL; \
STR = (STR_TYPE *) (pg_hd + 1); \
LOCK(Pg_lock(STR_PAGES)); \
if ((PgHd_next(pg_hd) = Pg_free_pg(STR_PAGES)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = pg_hd; \
Pg_free_pg(STR_PAGES) = pg_hd; \
UNLOCK(Pg_lock(STR_PAGES)); \
} \
}
#define ALLOC_NEXT_FREE_STRUCT(STR, STR_PAGES, STR_TYPE) \
if ((STR = LOCAL_next_free_ans_node) == NULL) { \
pg_hd_ptr pg_hd; \
LOCK(Pg_lock(STR_PAGES)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), Pg_str_per_pg(STR_PAGES)); \
if (Pg_free_pg(STR_PAGES)) { \
pg_hd = Pg_free_pg(STR_PAGES); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), -PgHd_str_in_use(pg_hd)); \
PgHd_str_in_use(pg_hd) = Pg_str_per_pg(STR_PAGES); \
STR = (STR_TYPE *) PgHd_free_str(pg_hd); \
PgHd_free_str(pg_hd) = NULL; \
Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd); \
UNLOCK(Pg_lock(STR_PAGES)); \
} else { \
int i; \
UPDATE_STATS(Pg_pg_alloc(STR_PAGES), 1); \
UNLOCK(Pg_lock(STR_PAGES)); \
ALLOC_PAGE(pg_hd); \
PgHd_str_in_use(pg_hd) = Pg_str_per_pg(STR_PAGES); \
PgHd_free_str(pg_hd) = NULL; \
PgHd_previous(pg_hd) = NULL; \
PgHd_next(pg_hd) = NULL; \
STR = (STR_TYPE *) (pg_hd + 1); \
for (i = Pg_str_per_pg(STR_PAGES); i != 1; i--) { \
STRUCT_NEXT(STR) = STR + 1; \
STR++; \
} \
STRUCT_NEXT(STR) = NULL; \
STR = (STR_TYPE *) (pg_hd + 1); \
} \
} \
LOCAL_next_free_ans_node = STRUCT_NEXT(STR)
#endif /* LIMIT_TABLING */
#else /* ! USE_PAGES_MALLOC */
/*************************************************************************************************
** ! USE_PAGES_MALLOC **
*************************************************************************************************/
#define ALLOC_STRUCT(STR, STR_PAGES, STR_TYPE) \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), 1); \
ALLOC_BLOCK(STR, sizeof(STR_TYPE), STR_TYPE)
#define ALLOC_NEXT_FREE_STRUCT(STR, STR_PAGES, STR_TYPE) \
ALLOC_STRUCT(STR, STR_PAGES, STR_TYPE)
#define FREE_STRUCT(STR, STR_PAGES, STR_TYPE) \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), -1); \
FREE_BLOCK(STR)
#endif /*****************************************************************************************/
#define ALLOC_HASH_BUCKETS(BUCKET_PTR, NUM_BUCKETS) \
{ int i; void **bucket_ptr; \
ALLOC_BLOCK(bucket_ptr, NUM_BUCKETS * sizeof(void *), void *); \
BUCKET_PTR = (void *) bucket_ptr; \
for (i = NUM_BUCKETS; i != 0; i--) \
*bucket_ptr++ = NULL; \
#endif /******************************************************************************/
#define ALLOC_HASH_BUCKETS(BUCKET_PTR, NUM_BUCKETS) \
{ int i; void **bucket_ptr; \
ALLOC_BLOCK(bucket_ptr, NUM_BUCKETS * sizeof(void *), void *); \
BUCKET_PTR = (void *) bucket_ptr; \
for (i = NUM_BUCKETS; i != 0; i--) \
*bucket_ptr++ = NULL; \
}
#define FREE_HASH_BUCKETS(BUCKET_PTR) FREE_BLOCK(BUCKET_PTR)
#define ALLOC_OR_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_or_fr , struct or_frame)
#define FREE_OR_FRAME(STR) FREE_STRUCT(STR, GLOBAL_pages_or_fr , struct or_frame)
#define ALLOC_QG_SOLUTION_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_qg_sol_fr , struct query_goal_solution_frame)
#define FREE_QG_SOLUTION_FRAME(STR) FREE_STRUCT(STR, GLOBAL_pages_qg_sol_fr , struct query_goal_solution_frame)
#define ALLOC_QG_ANSWER_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_qg_ans_fr, struct query_goal_answer_frame)
#define FREE_QG_ANSWER_FRAME(STR) FREE_STRUCT(STR, GLOBAL_pages_qg_ans_fr, struct query_goal_answer_frame)
#ifndef USE_PAGES_MALLOC
/**************************************************************************************
** ! USE_PAGES_MALLOC **
**************************************************************************************/
#define ALLOC_STRUCT(STR, STR_TYPE, STR_PAGES, VOID_PAGES) \
LOCK(Pg_lock(STR_PAGES)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), 1); \
UNLOCK(Pg_lock(STR_PAGES)); \
ALLOC_BLOCK(STR, sizeof(STR_TYPE), STR_TYPE)
#define LOCAL_NEXT_ALLOC_STRUCT(STR, LOCAL_STR, STR_TYPE, STR_PAGES, VOID_PAGES) \
ALLOC_STRUCT(STR, STR_TYPE, STR_PAGES, VOID_PAGES)
#define FREE_STRUCT(STR, STR_TYPE, STR_PAGES, VOID_PAGES) \
LOCK(Pg_lock(STR_PAGES)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), -1); \
UNLOCK(Pg_lock(STR_PAGES)); \
FREE_BLOCK(STR)
#else
/**************************************************************************************
** USE_PAGES_MALLOC && ! LIMIT_TABLING **
**************************************************************************************/
#ifndef LIMIT_TABLING
#define ALLOC_STRUCT_TEST_PAGE if
#define ALLOC_STRUCT_RECOVER_SPACE(PG_HD, STR_PAGES, VOID_PAGES)
#else
/**************************************************************************************
** USE_PAGES_MALLOC && LIMIT_TABLING **
**************************************************************************************/
#define ALLOC_STRUCT_TEST_PAGE while
#define ALLOC_STRUCT_RECOVER_SPACE(PG_HD, STR_PAGES, VOID_PAGES) \
if (Pg_free_pg(VOID_PAGES) == NULL && \
GLOBAL_max_pages == Pg_pg_alloc(VOID_PAGES)) { \
sg_fr_ptr sg_fr = GLOBAL_check_sg_fr; \
UNLOCK(Pg_lock(VOID_PAGES)); \
do { \
if (sg_fr) \
sg_fr = SgFr_next(sg_fr); \
else \
sg_fr = GLOBAL_first_sg_fr; \
if (sg_fr == NULL) \
Yap_Error(FATAL_ERROR, TermNil, "no space left (RECOVER_SPACE)"); \
/* see function 'InteractSIGINT' in file 'sysbits.c' */ \
/* Yap_Error(PURE_ABORT, TermNil, ""); */ \
/* restore_absmi_regs(&Yap_standard_regs); */ \
/* siglongjmp (LOCAL_RestartEnv, 1); */ \
if (SgFr_first_answer(sg_fr) && \
SgFr_first_answer(sg_fr) != SgFr_answer_trie(sg_fr)) { \
SgFr_state(sg_fr) = ready; \
free_answer_hash_chain(SgFr_hash_chain(sg_fr)); \
SgFr_hash_chain(sg_fr) = NULL; \
SgFr_first_answer(sg_fr) = NULL; \
SgFr_last_answer(sg_fr) = NULL; \
free_answer_trie(TrNode_child(SgFr_answer_trie(sg_fr)), \
TRAVERSE_MODE_NORMAL, TRAVERSE_POSITION_FIRST); \
TrNode_child(SgFr_answer_trie(sg_fr)) = NULL; \
} \
} while (Pg_free_pg(VOID_PAGES) == Pg_free_pg(STR_PAGES)); \
GLOBAL_check_sg_fr = sg_fr; \
LOCK(Pg_lock(STR_PAGES)); \
PG_HD = Pg_free_pg(STR_PAGES); \
} else
#endif
/**************************************************************************************
** USE_PAGES_MALLOC **
**************************************************************************************/
#define ALLOC_VOID_PAGES(PG_HD, VOID_PAGES) \
{ int i, shmid; \
pg_hd_ptr aux_pg_hd; \
if ((shmid = shmget(IPC_PRIVATE, SHMMAX, SHM_R|SHM_W)) == -1) \
Yap_Error(FATAL_ERROR, TermNil, "shmget error (ALLOC_VOID_PAGES)"); \
if ((PG_HD = (pg_hd_ptr) shmat(shmid, NULL, 0)) == (void *) -1) \
Yap_Error(FATAL_ERROR, TermNil, "shmat error (ALLOC_VOID_PAGES)"); \
if (shmctl(shmid, IPC_RMID, 0) != 0) \
Yap_Error(FATAL_ERROR, TermNil, "shmctl error (ALLOC_VOID_PAGES)"); \
aux_pg_hd = (pg_hd_ptr)(((void *)PG_HD) + Yap_page_size); \
Pg_free_pg(VOID_PAGES) = aux_pg_hd; \
for (i = 2; i < SHMMAX / Yap_page_size; i++) { \
PgHd_next(aux_pg_hd) = (pg_hd_ptr)(((void *)aux_pg_hd) + Yap_page_size); \
aux_pg_hd = PgHd_next(aux_pg_hd); \
} \
PgHd_next(aux_pg_hd) = NULL; \
UPDATE_STATS(Pg_pg_alloc(VOID_PAGES), SHMMAX / Yap_page_size); \
UPDATE_STATS(Pg_str_in_use(VOID_PAGES), 1); \
}
#define ALLOC_TG_SOLUTION_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_tg_sol_fr, struct table_subgoal_solution_frame)
#define FREE_TG_SOLUTION_FRAME(STR) FREE_STRUCT(STR, GLOBAL_pages_tg_sol_fr, struct table_subgoal_solution_frame)
#define INIT_PAGE(PG_HD, STR_TYPE, STR_PAGES) \
{ int i; \
STR_TYPE *aux_str; \
PgHd_str_in_use(PG_HD) = 0; \
PgHd_previous(PG_HD) = NULL; \
PgHd_next(PG_HD) = NULL; \
PgHd_free_str(PG_HD) = (void *) (PG_HD + 1); \
aux_str = (STR_TYPE *) PgHd_free_str(PG_HD); \
for (i = 1; i < Pg_str_per_pg(STR_PAGES); i++) { \
STRUCT_NEXT(aux_str) = aux_str + 1; \
aux_str++; \
} \
STRUCT_NEXT(aux_str) = NULL; \
}
#define ALLOC_TG_ANSWER_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_tg_ans_fr, struct table_subgoal_answer_frame)
#define FREE_TG_ANSWER_FRAME(STR) FREE_STRUCT(STR, GLOBAL_pages_tg_ans_fr, struct table_subgoal_answer_frame)
#define ALLOC_STRUCT_TEST_ALLOC_PAGE(PG_HD, STR_TYPE, STR_PAGES, VOID_PAGES) \
ALLOC_STRUCT_TEST_PAGE (PG_HD == NULL) { /* if / while */ \
UNLOCK(Pg_lock(STR_PAGES)); \
LOCK(Pg_lock(VOID_PAGES)); \
/* if (...) { ... */ \
ALLOC_STRUCT_RECOVER_SPACE(PG_HD, STR_PAGES, VOID_PAGES) \
/* } else */ \
{ \
PG_HD = Pg_free_pg(VOID_PAGES); \
if (PG_HD == NULL) { \
ALLOC_VOID_PAGES(PG_HD, VOID_PAGES); \
} else { \
Pg_free_pg(VOID_PAGES) = PgHd_next(PG_HD); \
UPDATE_STATS(Pg_str_in_use(VOID_PAGES), 1); \
} \
UNLOCK(Pg_lock(VOID_PAGES)); \
INIT_PAGE(PG_HD, STR_TYPE, STR_PAGES); \
LOCK(Pg_lock(STR_PAGES)); \
if ((PgHd_next(PG_HD) = Pg_free_pg(STR_PAGES)) != NULL) \
PgHd_previous(PgHd_next(PG_HD)) = PG_HD; \
Pg_free_pg(STR_PAGES) = PG_HD; \
UPDATE_STATS(Pg_pg_alloc(STR_PAGES), 1); \
} \
}
#define ALLOC_TABLE_ENTRY(STR) ALLOC_STRUCT(STR, GLOBAL_pages_tab_ent, struct table_entry)
#define FREE_TABLE_ENTRY(STR) FREE_STRUCT(STR, GLOBAL_pages_tab_ent, struct table_entry)
#define ALLOC_STRUCT(STR, STR_TYPE, STR_PAGES, VOID_PAGES) \
{ pg_hd_ptr pg_hd; \
LOCK(Pg_lock(STR_PAGES)); \
pg_hd = Pg_free_pg(STR_PAGES); \
ALLOC_STRUCT_TEST_ALLOC_PAGE(pg_hd, STR_TYPE, STR_PAGES, VOID_PAGES); \
STR = (STR_TYPE *) PgHd_free_str(pg_hd); \
if ((PgHd_free_str(pg_hd) = (void *) STRUCT_NEXT(STR)) == NULL) \
if ((Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = NULL; \
UPDATE_STATS(PgHd_str_in_use(pg_hd), 1); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), 1); \
UNLOCK(Pg_lock(STR_PAGES)); \
}
#define ALLOC_SUBGOAL_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_sg_fr, struct subgoal_frame)
#define FREE_SUBGOAL_FRAME(STR) FREE_STRUCT(STR, GLOBAL_pages_sg_fr, struct subgoal_frame)
#define LOCAL_NEXT_ALLOC_STRUCT(STR, LOCAL_STR, STR_TYPE, STR_PAGES, VOID_PAGES) \
STR = LOCAL_STR; \
if (STR == NULL) { \
pg_hd_ptr pg_hd; \
LOCK(Pg_lock(STR_PAGES)); \
pg_hd = Pg_free_pg(STR_PAGES); \
ALLOC_STRUCT_TEST_ALLOC_PAGE(pg_hd, STR_TYPE, STR_PAGES, VOID_PAGES); \
if ((Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = NULL; \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), -PgHd_str_in_use(pg_hd)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), Pg_str_per_pg(STR_PAGES)); \
UNLOCK(Pg_lock(STR_PAGES)); \
STR = (STR_TYPE *) PgHd_free_str(pg_hd); \
PgHd_free_str(pg_hd) = NULL; \
PgHd_str_in_use(pg_hd) = Pg_str_per_pg(STR_PAGES); \
} \
LOCAL_STR = STRUCT_NEXT(STR)
#define ALLOC_DEPENDENCY_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_dep_fr, struct dependency_frame)
#define FREE_DEPENDENCY_FRAME(STR) FREE_STRUCT(STR, GLOBAL_pages_dep_fr, struct dependency_frame)
#define FREE_PAGE(PG_HD, VOID_PAGES) \
LOCK(Pg_lock(VOID_PAGES)); \
PgHd_next(PG_HD) = Pg_free_pg(VOID_PAGES); \
Pg_free_pg(VOID_PAGES) = PG_HD; \
UPDATE_STATS(Pg_str_in_use(VOID_PAGES), -1); \
UNLOCK(Pg_lock(VOID_PAGES))
#define ALLOC_SUSPENSION_FRAME(STR) ALLOC_STRUCT(STR, GLOBAL_pages_susp_fr, struct suspension_frame)
#define FREE_SUSPENSION_FRAME(STR) FREE_BLOCK(SuspFr_global_start(STR)); \
FREE_STRUCT(STR, GLOBAL_pages_susp_fr, struct suspension_frame)
#define FREE_STRUCT(STR, STR_TYPE, STR_PAGES, VOID_PAGES) \
{ pg_hd_ptr pg_hd; \
pg_hd = PAGE_HEADER(STR); \
LOCK(Pg_lock(STR_PAGES)); \
UPDATE_STATS(Pg_str_in_use(STR_PAGES), -1); \
if (--PgHd_str_in_use(pg_hd) == 0) { \
UPDATE_STATS(Pg_pg_alloc(STR_PAGES), -1); \
if (PgHd_previous(pg_hd)) { \
if ((PgHd_next(PgHd_previous(pg_hd)) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = PgHd_previous(pg_hd); \
} else { \
if ((Pg_free_pg(STR_PAGES) = PgHd_next(pg_hd)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = NULL; \
} \
UNLOCK(Pg_lock(STR_PAGES)); \
FREE_PAGE(pg_hd, VOID_PAGES); \
} else { \
if ((STRUCT_NEXT(STR) = (STR_TYPE *) PgHd_free_str(pg_hd)) == NULL) { \
PgHd_previous(pg_hd) = NULL; \
if ((PgHd_next(pg_hd) = Pg_free_pg(STR_PAGES)) != NULL) \
PgHd_previous(PgHd_next(pg_hd)) = pg_hd; \
Pg_free_pg(STR_PAGES) = pg_hd; \
} \
PgHd_free_str(pg_hd) = (void *) STR; \
UNLOCK(Pg_lock(STR_PAGES)); \
} \
}
#endif /******************************************************************************/
#define ALLOC_GLOBAL_TRIE_NODE(STR) ALLOC_STRUCT(STR, GLOBAL_pages_gt_node, struct global_trie_node)
#define FREE_GLOBAL_TRIE_NODE(STR) FREE_STRUCT(STR, GLOBAL_pages_gt_node, struct global_trie_node)
#define ALLOC_OR_FRAME(STR) ALLOC_STRUCT(STR, struct or_frame, GLOBAL_pages_or_fr, GLOBAL_pages_void)
#define FREE_OR_FRAME(STR) FREE_STRUCT(STR, struct or_frame, GLOBAL_pages_or_fr, GLOBAL_pages_void)
#define ALLOC_SUBGOAL_TRIE_NODE(STR) ALLOC_STRUCT(STR, GLOBAL_pages_sg_node, struct subgoal_trie_node)
#define FREE_SUBGOAL_TRIE_NODE(STR) FREE_STRUCT(STR, GLOBAL_pages_sg_node, struct subgoal_trie_node)
#define ALLOC_QG_SOLUTION_FRAME(STR) ALLOC_STRUCT(STR, struct query_goal_solution_frame, GLOBAL_pages_qg_sol_fr, GLOBAL_pages_void)
#define FREE_QG_SOLUTION_FRAME(STR) FREE_STRUCT(STR, struct query_goal_solution_frame, GLOBAL_pages_qg_sol_fr, GLOBAL_pages_void)
#define ALLOC_QG_ANSWER_FRAME(STR) ALLOC_STRUCT(STR, struct query_goal_answer_frame, GLOBAL_pages_qg_ans_fr, GLOBAL_pages_void)
#define FREE_QG_ANSWER_FRAME(STR) FREE_STRUCT(STR, struct query_goal_answer_frame, GLOBAL_pages_qg_ans_fr, GLOBAL_pages_void)
#define ALLOC_TG_SOLUTION_FRAME(STR) ALLOC_STRUCT(STR, struct table_subgoal_solution_frame, GLOBAL_pages_tg_sol_fr, GLOBAL_pages_void)
#define FREE_TG_SOLUTION_FRAME(STR) FREE_STRUCT(STR, struct table_subgoal_solution_frame, GLOBAL_pages_tg_sol_fr, GLOBAL_pages_void)
#define ALLOC_TG_ANSWER_FRAME(STR) ALLOC_STRUCT(STR, struct table_subgoal_answer_frame, GLOBAL_pages_tg_ans_fr, GLOBAL_pages_void)
#define FREE_TG_ANSWER_FRAME(STR) FREE_STRUCT(STR, struct table_subgoal_answer_frame, GLOBAL_pages_tg_ans_fr, GLOBAL_pages_void)
#define ALLOC_TABLE_ENTRY(STR) ALLOC_STRUCT(STR, struct table_entry, GLOBAL_pages_tab_ent, GLOBAL_pages_void)
#define FREE_TABLE_ENTRY(STR) FREE_STRUCT(STR, struct table_entry, GLOBAL_pages_tab_ent, GLOBAL_pages_void)
#define ALLOC_SUBGOAL_FRAME(STR) ALLOC_STRUCT(STR, struct subgoal_frame, GLOBAL_pages_sg_fr, GLOBAL_pages_void)
#define FREE_SUBGOAL_FRAME(STR) FREE_STRUCT(STR, struct subgoal_frame, GLOBAL_pages_sg_fr, GLOBAL_pages_void)
#define ALLOC_DEPENDENCY_FRAME(STR) ALLOC_STRUCT(STR, struct dependency_frame, GLOBAL_pages_dep_fr, GLOBAL_pages_void)
#define FREE_DEPENDENCY_FRAME(STR) FREE_STRUCT(STR, struct dependency_frame, GLOBAL_pages_dep_fr, GLOBAL_pages_void)
#define ALLOC_SUSPENSION_FRAME(STR) ALLOC_STRUCT(STR, struct suspension_frame, GLOBAL_pages_susp_fr, GLOBAL_pages_void)
#define FREE_SUSPENSION_FRAME(STR) FREE_BLOCK(SuspFr_global_start(STR)); \
FREE_STRUCT(STR, struct suspension_frame, GLOBAL_pages_susp_fr, GLOBAL_pages_void)
#define ALLOC_GLOBAL_TRIE_NODE(STR) ALLOC_STRUCT(STR, struct global_trie_node, GLOBAL_pages_gt_node, GLOBAL_pages_void)
#define FREE_GLOBAL_TRIE_NODE(STR) FREE_STRUCT(STR, struct global_trie_node, GLOBAL_pages_gt_node, GLOBAL_pages_void)
#define ALLOC_SUBGOAL_TRIE_NODE(STR) ALLOC_STRUCT(STR, struct subgoal_trie_node, GLOBAL_pages_sg_node, GLOBAL_pages_void)
#define FREE_SUBGOAL_TRIE_NODE(STR) FREE_STRUCT(STR, struct subgoal_trie_node, GLOBAL_pages_sg_node, GLOBAL_pages_void)
#ifdef YAPOR
#define ALLOC_ANSWER_TRIE_NODE(STR) ALLOC_NEXT_FREE_STRUCT(STR, GLOBAL_pages_ans_node, struct answer_trie_node)
#define ALLOC_ANSWER_TRIE_NODE(STR) LOCAL_NEXT_ALLOC_STRUCT(STR, LOCAL_next_free_ans_node, struct answer_trie_node, GLOBAL_pages_ans_node, GLOBAL_pages_void)
#else /* TABLING */
#define ALLOC_ANSWER_TRIE_NODE(STR) ALLOC_STRUCT(STR, GLOBAL_pages_ans_node, struct answer_trie_node)
#define ALLOC_ANSWER_TRIE_NODE(STR) ALLOC_STRUCT(STR, struct answer_trie_node, GLOBAL_pages_ans_node, GLOBAL_pages_void)
#endif /* YAPOR - TABLING */
#define FREE_ANSWER_TRIE_NODE(STR) FREE_STRUCT(STR, GLOBAL_pages_ans_node, struct answer_trie_node)
#define FREE_ANSWER_TRIE_NODE(STR) FREE_STRUCT(STR, struct answer_trie_node, GLOBAL_pages_ans_node, GLOBAL_pages_void)
#define ALLOC_GLOBAL_TRIE_HASH(STR) ALLOC_STRUCT(STR, GLOBAL_pages_gt_hash, struct global_trie_hash)
#define FREE_GLOBAL_TRIE_HASH(STR) FREE_STRUCT(STR, GLOBAL_pages_gt_hash, struct global_trie_hash)
#define ALLOC_GLOBAL_TRIE_HASH(STR) ALLOC_STRUCT(STR, struct global_trie_hash, GLOBAL_pages_gt_hash, GLOBAL_pages_void)
#define FREE_GLOBAL_TRIE_HASH(STR) FREE_STRUCT(STR, struct global_trie_hash, GLOBAL_pages_gt_hash, GLOBAL_pages_void)
#define ALLOC_SUBGOAL_TRIE_HASH(STR) ALLOC_STRUCT(STR, GLOBAL_pages_sg_hash, struct subgoal_trie_hash)
#define FREE_SUBGOAL_TRIE_HASH(STR) FREE_STRUCT(STR, GLOBAL_pages_sg_hash, struct subgoal_trie_hash)
#define ALLOC_SUBGOAL_TRIE_HASH(STR) ALLOC_STRUCT(STR, struct subgoal_trie_hash, GLOBAL_pages_sg_hash, GLOBAL_pages_void)
#define FREE_SUBGOAL_TRIE_HASH(STR) FREE_STRUCT(STR, struct subgoal_trie_hash, GLOBAL_pages_sg_hash, GLOBAL_pages_void)
#define ALLOC_ANSWER_TRIE_HASH(STR) ALLOC_STRUCT(STR, GLOBAL_pages_ans_hash, struct answer_trie_hash)
#define FREE_ANSWER_TRIE_HASH(STR) FREE_STRUCT(STR, GLOBAL_pages_ans_hash, struct answer_trie_hash)
#define ALLOC_ANSWER_TRIE_HASH(STR) ALLOC_STRUCT(STR, struct answer_trie_hash, GLOBAL_pages_ans_hash, GLOBAL_pages_void)
#define FREE_ANSWER_TRIE_HASH(STR) FREE_STRUCT(STR, struct answer_trie_hash, GLOBAL_pages_ans_hash, GLOBAL_pages_void)

203
OPTYap/opt.preds.c
View File

@ -39,9 +39,6 @@ static Int p_wake_choice_point( USES_REGS1 );
static Int p_abolish_frozen_choice_points_until( USES_REGS1 );
static Int p_abolish_frozen_choice_points_all( USES_REGS1 );
static Int p_table( USES_REGS1 );
#ifdef MODE_DIRECTED_TABLING
static Int p_table_mode_directed( USES_REGS1 );
#endif /*MODE_DIRECTED_TABLING*/
static Int p_tabling_mode( USES_REGS1 );
static Int p_abolish_table( USES_REGS1 );
static Int p_abolish_all_tables( USES_REGS1 );
@ -124,10 +121,7 @@ void Yap_init_optyap_preds(void) {
Yap_InitCPred("wake_choice_point", 1, p_wake_choice_point, SafePredFlag|SyncPredFlag);
Yap_InitCPred("abolish_frozen_choice_points", 1, p_abolish_frozen_choice_points_until, SafePredFlag|SyncPredFlag);
Yap_InitCPred("abolish_frozen_choice_points", 0, p_abolish_frozen_choice_points_all, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$c_table", 2, p_table, SafePredFlag|SyncPredFlag|HiddenPredFlag);
#ifdef MODE_DIRECTED_TABLING
Yap_InitCPred("$c_table_mode_directed", 3, p_table_mode_directed, SafePredFlag|SyncPredFlag|HiddenPredFlag);
#endif /*MODE_DIRECTED_TABLING*/
Yap_InitCPred("$c_table", 3, p_table, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$c_tabling_mode", 3, p_tabling_mode, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$c_abolish_table", 2, p_abolish_table, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("abolish_all_tables", 0, p_abolish_all_tables, SafePredFlag|SyncPredFlag);
@ -204,147 +198,18 @@ static Int p_abolish_frozen_choice_points_all( USES_REGS1 ) {
static Int p_table( USES_REGS1 ) {
Term mod, t;
PredEntry *pe;
Atom at;
int arity;
tab_ent_ptr tab_ent;
mod = Deref(ARG1);
t = Deref(ARG2);
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
pe = RepPredProp(PredPropByAtom(at, mod));
arity = 0;
} else if (IsApplTerm(t)) {
at = NameOfFunctor(FunctorOfTerm(t));
pe = RepPredProp(PredPropByFunc(FunctorOfTerm(t), mod));
arity = ArityOfFunctor(FunctorOfTerm(t));
} else
return (FALSE);
if (pe->PredFlags & TabledPredFlag)
return (TRUE); /* predicate already tabled */
if (pe->cs.p_code.FirstClause)
return (FALSE); /* predicate already compiled */
pe->PredFlags |= TabledPredFlag;
#ifdef MODE_DIRECTED_TABLING
new_table_entry(tab_ent, pe, at, arity, NULL);
#else
new_table_entry(tab_ent, pe, at, arity);
#endif /*MODE_DIRECTED_TABLING*/
pe->TableOfPred = tab_ent;
return (TRUE);
}
#ifdef MODE_DIRECTED_TABLING
static Int p_table_mode_directed( USES_REGS1 ) {
Term mod, t, list;
PredEntry *pe;
Atom at;
int arity;
tab_ent_ptr tab_ent;
#ifdef MODE_DIRECTED_TABLING
int* mode_directed = NULL;
#endif /* MODE_DIRECTED_TABLING */
mod = Deref(ARG1);
t = Deref(ARG2);
list = ARG3;
Functor f = FunctorOfTerm(t);
arity=ArityOfFunctor(f);
int* aux;
int* vec;
int i=0,n_index=0,n_agreg=0,n_nindex=0,n_all=0,n_last=0;
ALLOC_BLOCK(vec,arity*sizeof(int),int);
ALLOC_BLOCK(aux,arity*sizeof(int),int);
while(IsPairTerm(list)){
char *str_val = &RepAtom(AtomOfTerm(HeadOfTerm(list)))->StrOfAE;
//printf("----2 %s %d\n",str_val,i);
if(! strcmp(str_val ,"index")){
vec[i] = MODE_DIRECTED_INDEX;
n_index++;
}
else if (! strcmp(str_val ,"all")){
vec[i] = MODE_DIRECTED_ALL;
n_all++;
}
else if(!strcmp(str_val,"last")){
vec[i] = MODE_DIRECTED_LAST;
n_last++;
}
else if(!strcmp(str_val,"min")){
vec[i] = MODE_DIRECTED_MIN;
n_agreg++;
}
else if(!strcmp(str_val,"max")){
vec[i] = MODE_DIRECTED_MAX;
n_agreg++;
}
else if(!strcmp(str_val,"first")){
vec[i] = MODE_DIRECTED_NINDEX;
}
list=TailOfTerm(list);
i++;
}
n_nindex = n_index + n_agreg + n_all + n_last;
n_last = n_index + n_agreg + n_all;
n_all = n_index + n_agreg;
n_agreg = n_index;
n_index = 0;
for(i = 0;i < arity; i++){
if(vec[i]==MODE_DIRECTED_MAX){
aux[n_agreg]= i << MODE_DIRECTED_TAGBITS;
aux[n_agreg]= aux[n_agreg] + MODE_DIRECTED_MAX;
n_agreg++;
}
else if(vec[i]==MODE_DIRECTED_MIN){
aux[n_agreg]= i << MODE_DIRECTED_TAGBITS;
aux[n_agreg]= aux[n_agreg] + MODE_DIRECTED_MIN;
n_agreg++;
}
else if(vec[i]==MODE_DIRECTED_INDEX){
aux[n_index]= i << MODE_DIRECTED_TAGBITS;
aux[n_index]= aux[n_index] + MODE_DIRECTED_INDEX;
n_index++;
}
else if(vec[i]==MODE_DIRECTED_NINDEX){
aux[n_nindex]= i << MODE_DIRECTED_TAGBITS;
aux[n_nindex]= aux[n_nindex] + MODE_DIRECTED_NINDEX;
n_nindex++;
}
else if(vec[i]==MODE_DIRECTED_ALL){
aux[n_all]= i << MODE_DIRECTED_TAGBITS;
aux[n_all]= aux[n_all] + MODE_DIRECTED_ALL;
n_all++;
}
else if(vec[i]==MODE_DIRECTED_LAST){
aux[n_last]= i << MODE_DIRECTED_TAGBITS;
aux[n_last]= aux[n_last] + MODE_DIRECTED_LAST;
n_last++;
}
}
/*
i=0;
while(i < arity){
printf("aux[%d] %p \n",i,aux[i]);
i ++;
}
*/
list = Deref(ARG3);
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
@ -356,18 +221,68 @@ i=0;
arity = ArityOfFunctor(FunctorOfTerm(t));
} else
return (FALSE);
if (list != TermNil) { /* non-empty list */
#ifndef MODE_DIRECTED_TABLING
Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "invalid tabling declaration for %s/%d (mode directed tabling not enabled)", AtomName(at), arity);
return(FALSE);
#else
int pos_index = 0;
int pos_agreg = 0; /* min/max */
int pos_first = 0;
int pos_all = 0;
int pos_last = 0;
int i;
int *aux_mode_directed;
aux_mode_directed = malloc(arity * sizeof(int));
ALLOC_BLOCK(mode_directed, arity * sizeof(int), int);
for (i = 0; i < arity; i++) {
int mode = IntOfTerm(HeadOfTerm(list));
if (mode == MODE_DIRECTED_INDEX)
pos_index++;
else if (mode == MODE_DIRECTED_ALL)
pos_all++;
else if (mode == MODE_DIRECTED_LAST)
pos_last++;
else if (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)
pos_agreg++;
aux_mode_directed[i] = mode;
list = TailOfTerm(list);
}
pos_first = pos_index + pos_agreg + pos_all + pos_last;
pos_last = pos_index + pos_agreg + pos_all;
pos_all = pos_index + pos_agreg;
pos_agreg = pos_index;
pos_index = 0;
for (i = 0; i < arity; i++) {
int aux_pos = 0;
if (aux_mode_directed[i] == MODE_DIRECTED_MAX)
aux_pos = pos_agreg++;
else if (aux_mode_directed[i] == MODE_DIRECTED_MIN)
aux_pos = pos_agreg++;
else if (aux_mode_directed[i] == MODE_DIRECTED_INDEX)
aux_pos = pos_index++;
else if(aux_mode_directed[i] == MODE_DIRECTED_FIRST)
aux_pos = pos_first++;
else if (aux_mode_directed[i] == MODE_DIRECTED_ALL)
aux_pos = pos_all++;
else if (aux_mode_directed[i] == MODE_DIRECTED_LAST)
aux_pos = pos_last++;
mode_directed[aux_pos] = MODE_DIRECTED_SET(i, aux_mode_directed[i]);
}
free(aux_mode_directed);
#endif /* MODE_DIRECTED_TABLING */
}
if (pe->PredFlags & TabledPredFlag)
return (TRUE); /* predicate already tabled */
if (pe->cs.p_code.FirstClause)
return (FALSE); /* predicate already compiled */
pe->PredFlags |= TabledPredFlag;
new_table_entry(tab_ent, pe, at, arity, aux);
new_table_entry(tab_ent, pe, at, arity, mode_directed);
pe->TableOfPred = tab_ent;
return (TRUE);
}
#endif /*MODE_DIRECTED_TABLING*/
static Int p_tabling_mode( USES_REGS1 ) {
Term mod, t, tvalue;

3
OPTYap/opt.proto.h
View File

@ -45,6 +45,9 @@ void finish_yapor(void);
#ifdef TABLING
sg_fr_ptr subgoal_search(yamop *, CELL **);
ans_node_ptr answer_search(sg_fr_ptr, CELL *);
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr mode_directed_answer_search(sg_fr_ptr, CELL *);
#endif /* MODE_DIRECTED_TABLING */
void load_answer(ans_node_ptr, CELL *);
CELL *exec_substitution(gt_node_ptr, CELL *);
void update_answer_trie(sg_fr_ptr);

8
OPTYap/opt.structs.h
View File

@ -213,9 +213,9 @@ struct global_optyap_data {
struct dependency_frame *root_dependency_frame;
#endif /* YAPOR */
CELL table_var_enumerator[MAX_TABLE_VARS];
#ifdef TABLE_LOCK_AT_WRITE_LEVEL
lockvar table_lock[TABLE_LOCK_BUCKETS];
#endif /* TABLE_LOCK_AT_WRITE_LEVEL */
#ifdef TRIE_LOCK_USING_GLOBAL_ARRAY
lockvar trie_locks[TRIE_LOCK_BUCKETS];
#endif /* TRIE_LOCK_USING_GLOBAL_ARRAY */
#ifdef TIMESTAMP_CHECK
long timestamp;
#endif /* TIMESTAMP_CHECK */
@ -282,7 +282,7 @@ struct global_optyap_data {
#define GLOBAL_root_dep_fr (GLOBAL_optyap_data.root_dependency_frame)
#define GLOBAL_table_var_enumerator(index) (GLOBAL_optyap_data.table_var_enumerator[index])
#define GLOBAL_table_var_enumerator_addr(index) (GLOBAL_optyap_data.table_var_enumerator + (index))
#define GLOBAL_table_lock(index) (GLOBAL_optyap_data.table_lock[index])
#define GLOBAL_trie_locks(index) (GLOBAL_optyap_data.trie_locks[index])
#define GLOBAL_timestamp (GLOBAL_optyap_data.timestamp)

2
OPTYap/or.copy_engine.c
View File

@ -47,7 +47,7 @@ static void share_private_nodes(int worker_q);
#if INCREMENTAL_COPY
#define COMPUTE_SEGMENTS_TO_COPY_TO(Q) \
if (REMOTE_top_cp(Q) == GLOBAL_root_cp) \
REMOTE_start_global_copy(Q) = (CELL) (H0); \
REMOTE_start_global_copy(Q) = (CELL) (H0); \
else \
REMOTE_start_global_copy(Q) = (CELL) (REMOTE_top_cp(Q)->cp_h); \
REMOTE_end_global_copy(Q) = (CELL) (B->cp_h); \

160
OPTYap/tab.insts.i
View File

@ -865,19 +865,19 @@
}
}
#endif /* DEBUG_TABLING && !DETERMINISTIC_TABLING */
#ifdef TABLE_LOCK_AT_ENTRY_LEVEL
LOCK(SgFr_lock(sg_fr));
#endif /* TABLE_LOCK_LEVEL */
ans_node = answer_search(sg_fr, subs_ptr);
LOCK_ANSWER_TRIE(sg_fr);
#ifdef MODE_DIRECTED_TABLING
if(ans_node == NULL)
goto fail;
#endif /*MODE_DIRECTED_TABLING*/
#if defined(TABLE_LOCK_AT_NODE_LEVEL)
LOCK(TrNode_lock(ans_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
LOCK_TABLE(ans_node);
#endif /* TABLE_LOCK_LEVEL */
if (SgFr_mode_directed(sg_fr)) {
ans_node = mode_directed_answer_search(sg_fr, subs_ptr);
if (ans_node == NULL) {
/* no answer inserted */
UNLOCK_ANSWER_TRIE(sg_fr);
goto fail;
}
} else
#endif /* MODE_DIRECTED_TABLING */
ans_node = answer_search(sg_fr, subs_ptr);
LOCK_ANSWER_NODE(ans_node);
if (! IS_ANSWER_LEAF_NODE(ans_node)) {
/* new answer */
#ifdef TABLING_INNER_CUTS
@ -903,13 +903,8 @@
EQUAL_OR_YOUNGER_CP(Get_LOCAL_top_cp(), REMOTE_pruning_scope(i))) {
leftmost_or_fr = LOCAL_top_or_fr;
pending_table_new_answer:
#if defined(TABLE_LOCK_AT_ENTRY_LEVEL)
UNLOCK(SgFr_lock(sg_fr));
#elif defined(TABLE_LOCK_AT_NODE_LEVEL)
UNLOCK(TrNode_lock(ans_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
UNLOCK_TABLE(ans_node);
#endif /* TABLE_LOCK_LEVEL */
UNLOCK_ANSWER_NODE(ans_node);
UNLOCK_ANSWER_TRIE(sg_fr);
LOCK_OR_FRAME(leftmost_or_fr);
if (Get_LOCAL_prune_request()) {
UNLOCK_OR_FRAME(leftmost_or_fr);
@ -996,24 +991,16 @@
/* check for prune requests */
if (Get_LOCAL_prune_request()) {
#if defined(TABLE_LOCK_AT_ENTRY_LEVEL)
UNLOCK(SgFr_lock(sg_fr));
#elif defined(TABLE_LOCK_AT_NODE_LEVEL)
UNLOCK(TrNode_lock(ans_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
UNLOCK_TABLE(ans_node);
#endif /* TABLE_LOCK_LEVEL */
UNLOCK_ANSWER_NODE(ans_node);
UNLOCK_ANSWER_TRIE(sg_fr);
SCHEDULER_GET_WORK();
}
#endif /* TABLING_INNER_CUTS */
TAG_AS_ANSWER_LEAF_NODE(ans_node);
#if defined(TABLE_LOCK_AT_NODE_LEVEL)
UNLOCK(TrNode_lock(ans_node));
UNLOCK_ANSWER_NODE(ans_node);
#ifndef ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL
LOCK(SgFr_lock(sg_fr));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
UNLOCK_TABLE(ans_node);
LOCK(SgFr_lock(sg_fr));
#endif /* TABLE_LOCK_LEVEL */
#endif /* ! ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL */
if (SgFr_first_answer(sg_fr) == NULL)
SgFr_first_answer(sg_fr) = ans_node;
else
@ -1072,13 +1059,8 @@
}
} else {
/* repeated answer */
#if defined(TABLE_LOCK_AT_ENTRY_LEVEL)
UNLOCK(SgFr_lock(sg_fr));
#elif defined(TABLE_LOCK_AT_NODE_LEVEL)
UNLOCK(TrNode_lock(ans_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
UNLOCK_TABLE(ans_node);
#endif /* TABLE_LOCK_LEVEL */
UNLOCK_ANSWER_NODE(ans_node);
UNLOCK_ANSWER_TRIE(sg_fr);
goto fail;
}
ENDPBOp();
@ -1107,18 +1089,20 @@
dep_fr = CONS_CP(B)->cp_dep_fr;
LOCK(DepFr_lock(dep_fr));
ans_node = DepFr_last_answer(dep_fr);
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node)) {
/* unconsumed answer */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
/* unconsumed answers */
#ifdef MODE_DIRECTED_TABLING
if (IS_INVALID_LEAF_NODE(TrNode_child(ans_node))) {
ans_node_ptr old_ans_node;
old_ans_node = ans_node;
ans_node = TrNode_child(ans_node);
do {
ans_node = TrNode_child(ans_node);
} while (IS_INVALID_LEAF_NODE(ans_node));
TrNode_child(old_ans_node) = ans_node;
} else
#endif /* MODE_DIRECTED_TABLING */
ans_node = TrNode_child(ans_node);
DepFr_last_answer(dep_fr) = ans_node;
UNLOCK(DepFr_lock(dep_fr));
consume_answer_and_procceed(dep_fr, ans_node);
@ -1164,18 +1148,21 @@
while (YOUNGER_CP(DepFr_cons_cp(dep_fr), chain_cp)) {
LOCK(DepFr_lock(dep_fr));
ans_node = DepFr_last_answer(dep_fr);
if (TrNode_child(ans_node)) {
/* dependency frame with unconsumed answers */
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node))
/* dependency frame with unconsumed answers */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
if (IS_INVALID_LEAF_NODE(TrNode_child(ans_node))) {
ans_node_ptr old_ans_node;
old_ans_node = ans_node;
ans_node = TrNode_child(ans_node);
do {
ans_node = TrNode_child(ans_node);
} while (IS_INVALID_LEAF_NODE(ans_node));
TrNode_child(old_ans_node) = ans_node;
} else
#endif /* MODE_DIRECTED_TABLING */
ans_node = TrNode_child(ans_node);
DepFr_last_answer(dep_fr) = ans_node;
#ifdef YAPOR
if (YOUNGER_CP(DepFr_backchain_cp(dep_fr), top_chain_cp))
#endif /* YAPOR */
@ -1415,18 +1402,21 @@
while (YOUNGER_CP(DepFr_cons_cp(dep_fr), B)) {
LOCK(DepFr_lock(dep_fr));
ans_node = DepFr_last_answer(dep_fr);
if (TrNode_child(ans_node)) {
/* dependency frame with unconsumed answers */
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node))
/* dependency frame with unconsumed answers */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
if (IS_INVALID_LEAF_NODE(TrNode_child(ans_node))) {
ans_node_ptr old_ans_node;
old_ans_node = ans_node;
ans_node = TrNode_child(ans_node);
do {
ans_node = TrNode_child(ans_node);
} while (IS_INVALID_LEAF_NODE(ans_node));
TrNode_child(old_ans_node) = ans_node;
} else
#endif /* MODE_DIRECTED_TABLING */
ans_node = TrNode_child(ans_node);
DepFr_last_answer(dep_fr) = ans_node;
if (B->cp_ap) {
#ifdef YAPOR
if (YOUNGER_CP(DepFr_backchain_cp(dep_fr), B))
@ -1581,20 +1571,22 @@
LOCK_OR_FRAME(LOCAL_top_or_fr);
LOCK(DepFr_lock(LOCAL_top_dep_fr));
ans_node = DepFr_last_answer(LOCAL_top_dep_fr);
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node)) {
/* unconsumed answer */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
/* unconsumed answers */
UNLOCK_OR_FRAME(LOCAL_top_or_fr);
ans_node = DepFr_last_answer(LOCAL_top_dep_fr) = TrNode_child(ans_node);
#ifdef MODE_DIRECTED_TABLING
if (IS_INVALID_LEAF_NODE(TrNode_child(ans_node))) {
ans_node_ptr old_ans_node;
old_ans_node = ans_node;
ans_node = TrNode_child(ans_node);
do {
ans_node = TrNode_child(ans_node);
} while (IS_INVALID_LEAF_NODE(ans_node));
TrNode_child(old_ans_node) = ans_node;
} else
#endif /* MODE_DIRECTED_TABLING */
ans_node = TrNode_child(ans_node);
DepFr_last_answer(LOCAL_top_dep_fr) = ans_node;
UNLOCK(DepFr_lock(LOCAL_top_dep_fr));
consume_answer_and_procceed(LOCAL_top_dep_fr, ans_node);
}

415
OPTYap/tab.macros.h
View File

@ -106,6 +106,19 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
#define TRAVERSE_POSITION_FIRST 1
#define TRAVERSE_POSITION_LAST 2
/* mode directed tabling */
#define MODE_DIRECTED_TAGBITS 0xF
#define MODE_DIRECTED_NUMBER_TAGBITS 4
#define MODE_DIRECTED_INDEX 1
#define MODE_DIRECTED_FIRST 2
#define MODE_DIRECTED_ALL 3
#define MODE_DIRECTED_MAX 4
#define MODE_DIRECTED_MIN 5
#define MODE_DIRECTED_LAST 6
#define MODE_DIRECTED_SET(ARG,MODE) (((ARG) << MODE_DIRECTED_NUMBER_TAGBITS) + MODE)
#define MODE_DIRECTED_GET_ARG(X) ((X) >> MODE_DIRECTED_NUMBER_TAGBITS)
#define MODE_DIRECTED_GET_MODE(X) ((X) & MODE_DIRECTED_TAGBITS)
/* LowTagBits is 3 for 32 bit-machines and 7 for 64 bit-machines */
#define NumberOfLowTagBits (LowTagBits == 3 ? 2 : 3)
#define MakeTableVarTerm(INDEX) ((INDEX) << NumberOfLowTagBits)
@ -122,6 +135,7 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
#define CompactPairEndList AbsPair((Term *) (2*(LowTagBits + 1)))
#endif /* TRIE_COMPACT_PAIRS */
/* choice points */
#define NORM_CP(CP) ((choiceptr)(CP))
#define GEN_CP(CP) ((struct generator_choicept *)(CP))
#define CONS_CP(CP) ((struct consumer_choicept *)(CP))
@ -135,13 +149,17 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
#define IS_BATCHED_GEN_CP(CP) (GEN_CP(CP)->cp_dep_fr == NULL)
#endif /* DETERMINISTIC_TABLING */
/* leaf nodes */
#define TAG_AS_SUBGOAL_LEAF_NODE(NODE) TrNode_child(NODE) = (sg_node_ptr)((unsigned long int) TrNode_child(NODE) | 0x1)
#define UNTAG_SUBGOAL_LEAF_NODE(NODE) ((sg_fr_ptr)((unsigned long int) (NODE) & ~(0x1)))
#define IS_SUBGOAL_LEAF_NODE(NODE) ((unsigned long int) TrNode_child(NODE) & 0x1)
#define TAG_AS_ANSWER_LEAF_NODE(NODE) TrNode_parent(NODE) = (ans_node_ptr)((unsigned long int) TrNode_parent(NODE) | 0x1)
#define UNTAG_ANSWER_LEAF_NODE(NODE) ((ans_node_ptr)((unsigned long int) (NODE) & ~(0x1)))
#define IS_ANSWER_LEAF_NODE(NODE) ((unsigned long int) TrNode_parent(NODE) & 0x1)
#define TAG_AS_INVALID_LEAF_NODE(NODE) TrNode_parent(NODE) = (ans_node_ptr)((unsigned long int) TrNode_parent(NODE) | 0x2)
#define IS_INVALID_LEAF_NODE(NODE) ((unsigned long int) TrNode_parent(NODE) & 0x2)
/* trie hashes */
#define MAX_NODES_PER_TRIE_LEVEL 8
#define MAX_NODES_PER_BUCKET (MAX_NODES_PER_TRIE_LEVEL / 2)
#define BASE_HASH_BUCKETS 64
@ -152,26 +170,26 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
#define IS_ANSWER_TRIE_HASH(NODE) (TrNode_instr(NODE) == ANSWER_TRIE_HASH_MARK)
#define GLOBAL_TRIE_HASH_MARK ((Term) MakeTableVarTerm(MAX_TABLE_VARS))
#define IS_GLOBAL_TRIE_HASH(NODE) (TrNode_entry(NODE) == GLOBAL_TRIE_HASH_MARK)
#define HASH_TRIE_LOCK(NODE) GLOBAL_trie_locks((((unsigned long int) (NODE)) >> 5) & (TRIE_LOCK_BUCKETS - 1))
#define HASH_TABLE_LOCK(NODE) ((((unsigned long int) (NODE)) >> 5) & (TABLE_LOCK_BUCKETS - 1))
#define LOCK_TABLE(NODE) LOCK(GLOBAL_table_lock(HASH_TABLE_LOCK(NODE)))
#define UNLOCK_TABLE(NODE) UNLOCK(GLOBAL_table_lock(HASH_TABLE_LOCK(NODE)))
#define STACK_PUSH_UP(ITEM, STACK) *--(STACK) = (CELL)(ITEM)
#define STACK_POP_UP(STACK) *--(STACK)
#define STACK_PUSH_DOWN(ITEM, STACK) *(STACK)++ = (CELL)(ITEM)
#define STACK_POP_DOWN(STACK) *(STACK)++
#define STACK_NOT_EMPTY(STACK, STACK_BASE) (STACK) != (STACK_BASE)
#define AUX_STACK_CHECK_EXPAND(STACK, STACK_LIMIT) if ((STACK_LIMIT) >= (STACK)) EXPAND_AUX_STACK(STACK)
#define STACK_CHECK_EXPAND(STACK, STACK_LIMIT) if ((STACK_LIMIT) >= (STACK)+4096) EXPAND_STACK(STACK)
/* auxiliary stack */
#define STACK_PUSH_UP(ITEM, STACK) *--(STACK) = (CELL)(ITEM)
#define STACK_POP_UP(STACK) *--(STACK)
#define STACK_PUSH_DOWN(ITEM, STACK) *(STACK)++ = (CELL)(ITEM)
#define STACK_POP_DOWN(STACK) *(STACK)++
#define STACK_NOT_EMPTY(STACK, STACK_BASE) (STACK) != (STACK_BASE)
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA)
#define EXPAND_AUX_STACK(STACK) Yap_Error(INTERNAL_ERROR, TermNil, "stack full (AUX_STACK_CHECK_EXPAND)");
#define EXPAND_STACK(STACK) Yap_Error(INTERNAL_ERROR, TermNil, "stack full (STACK_CHECK_EXPAND)");
#define AUX_STACK_CHECK_EXPAND(STACK, STACK_LIMIT) \
if ((STACK_LIMIT) >= (STACK)) \
Yap_Error(INTERNAL_ERROR, TermNil, "stack full (AUX_STACK_CHECK_EXPAND)")
#else /* YAPOR_THREADS */
#define EXPAND_AUX_STACK(STACK) STACK = expand_auxiliary_stack(STACK)
#define EXPAND_STACK(STACK) Yap_Error(INTERNAL_ERROR, TermNil, "stack full (STACK_CHECK_EXPAND)");
#define AUX_STACK_CHECK_EXPAND(STACK, STACK_LIMIT) \
if ((STACK_LIMIT) >= (STACK)) \
STACK = expand_auxiliary_stack(STACK)
#endif /* YAPOR */
#define OPTYAP_ERROR_MESSAGE(OP, COND)
#define STACK_CHECK_EXPAND(STACK, STACK_LIMIT) \
if ((STACK_LIMIT) >= (STACK) + 4096) \
Yap_Error(INTERNAL_ERROR, TermNil, "stack full (STACK_CHECK_EXPAND)")
@ -239,111 +257,125 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
#define DepFr_init_yapor_fields(DEP_FR, DEP_ON_STACK, TOP_OR_FR)
#endif /* YAPOR */
#ifdef TABLE_LOCK_AT_ENTRY_LEVEL
#define TabEnt_init_lock_field(TAB_ENT) \
INIT_LOCK(TabEnt_lock(TAB_ENT))
#ifdef MODE_DIRECTED_TABLING
#define TabEnt_init_mode_directed(TAB_ENT, MODE_ARRAY) \
TabEnt_mode_directed(TAB_ENT) = MODE_ARRAY
#define SgFr_init_mode_directed(SG_FR, MODE_ARRAY) \
SgFr_invalid_chain(SG_FR) = NULL; \
SgFr_mode_directed(SG_FR) = MODE_ARRAY
#define AnsHash_init_previous_field(HASH, SG_FR) \
if (SgFr_hash_chain(SG_FR)) \
Hash_previous(SgFr_hash_chain(SG_FR)) = HASH; \
Hash_previous(HASH) = NULL
#else
#define TabEnt_init_mode_directed(TAB_ENT, MODE_ARRAY)
#define SgFr_init_mode_directed(SG_FR, MODE_ARRAY)
#define AnsHash_init_previous_field(HASH, SG_FR)
#endif /* MODE_DIRECTED_TABLING */
#ifdef SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL
#define LOCK_SUBGOAL_TRIE(TAB_ENT) LOCK(TabEnt_lock(TAB_ENT))
#define UNLOCK_SUBGOAL_TRIE(TAB_ENT) UNLOCK(TabEnt_lock(TAB_ENT))
#define SgHash_init_next_field(HASH, TAB_ENT) \
Hash_next(HASH) = TabEnt_hash_chain(TAB_ENT); \
TabEnt_hash_chain(TAB_ENT) = HASH
#define AnsHash_init_next_field(HASH, SG_FR) \
Hash_next(HASH) = SgFr_hash_chain(SG_FR); \
SgFr_hash_chain(SG_FR) = HASH
#else
#define TabEnt_init_lock_field(TAB_ENT)
#define LOCK_SUBGOAL_TRIE(TAB_ENT)
#define UNLOCK_SUBGOAL_TRIE(TAB_ENT)
#define SgHash_init_next_field(HASH, TAB_ENT) \
LOCK(TabEnt_lock(TAB_ENT)); \
Hash_next(HASH) = TabEnt_hash_chain(TAB_ENT); \
TabEnt_hash_chain(TAB_ENT) = HASH; \
UNLOCK(TabEnt_lock(TAB_ENT))
#define AnsHash_init_next_field(HASH, SG_FR) \
LOCK(SgFr_lock(SG_FR)); \
Hash_next(HASH) = SgFr_hash_chain(SG_FR); \
SgFr_hash_chain(SG_FR) = HASH; \
#endif /* SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL */
#ifdef ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL
#define LOCK_ANSWER_TRIE(SG_FR) LOCK(SgFr_lock(SG_FR))
#define UNLOCK_ANSWER_TRIE(SG_FR) UNLOCK(SgFr_lock(SG_FR))
#define AnsHash_init_chain_fields(HASH, SG_FR) \
AnsHash_init_previous_field(HASH, SG_FR); \
Hash_next(HASH) = SgFr_hash_chain(SG_FR); \
SgFr_hash_chain(SG_FR) = HASH
#else
#define LOCK_ANSWER_TRIE(SG_FR)
#define UNLOCK_ANSWER_TRIE(SG_FR)
#define AnsHash_init_chain_fields(HASH, SG_FR) \
LOCK(SgFr_lock(SG_FR)); \
AnsHash_init_previous_field(HASH, SG_FR); \
Hash_next(HASH) = SgFr_hash_chain(SG_FR); \
SgFr_hash_chain(SG_FR) = HASH; \
UNLOCK(SgFr_lock(SG_FR))
#endif /* TABLE_LOCK_AT_ENTRY_LEVEL */
#endif /* ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL */
#ifdef TABLE_LOCK_AT_NODE_LEVEL
#define TrNode_init_lock_field(NODE) \
INIT_LOCK(TrNode_lock(NODE))
#ifdef SUBGOAL_TRIE_LOCK_USING_NODE_FIELD
#define LOCK_SUBGOAL_NODE(NODE) LOCK(TrNode_lock(NODE))
#define UNLOCK_SUBGOAL_NODE(NODE) UNLOCK(TrNode_lock(NODE))
#define SgNode_init_lock_field(NODE) INIT_LOCK(TrNode_lock(NODE))
#elif SUBGOAL_TRIE_LOCK_USING_GLOBAL_ARRAY
#define LOCK_SUBGOAL_NODE(NODE) LOCK(HASH_TRIE_LOCK(NODE))
#define UNLOCK_SUBGOAL_NODE(NODE) UNLOCK(HASH_TRIE_LOCK(NODE))
#define SgNode_init_lock_field(NODE)
#else
#define TrNode_init_lock_field(NODE)
#endif /* TABLE_LOCK_AT_NODE_LEVEL */
#define LOCK_SUBGOAL_NODE(NODE)
#define UNLOCK_SUBGOAL_NODE(NODE)
#define SgNode_init_lock_field(NODE)
#endif /* SUBGOAL_TRIE_LOCK_LEVEL */
#ifdef MODE_DIRECTED_TABLING
#ifdef ANSWER_TRIE_LOCK_USING_NODE_FIELD
#define LOCK_ANSWER_NODE(NODE) LOCK(TrNode_lock(NODE))
#define UNLOCK_ANSWER_NODE(NODE) UNLOCK(TrNode_lock(NODE))
#define AnsNode_init_lock_field(NODE) INIT_LOCK(TrNode_lock(NODE))
#elif ANSWER_TRIE_LOCK_USING_GLOBAL_ARRAY
#define LOCK_ANSWER_NODE(NODE) LOCK(HASH_TRIE_LOCK(NODE))
#define UNLOCK_ANSWER_NODE(NODE) UNLOCK(HASH_TRIE_LOCK(NODE))
#define AnsNode_init_lock_field(NODE)
#else
#define LOCK_ANSWER_NODE(NODE)
#define UNLOCK_ANSWER_NODE(NODE)
#define AnsNode_init_lock_field(NODE)
#endif /* ANSWER_TRIE_LOCK_LEVEL */
#define new_table_entry(TAB_ENT, PRED_ENTRY, ATOM, ARITY, MODE_DIRECTED_ARRAY)\
{ register sg_node_ptr sg_node; \
new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); \
ALLOC_TABLE_ENTRY(TAB_ENT); \
TabEnt_init_lock_field(TAB_ENT); \
TabEnt_pe(TAB_ENT) = PRED_ENTRY; \
TabEnt_atom(TAB_ENT) = ATOM; \
TabEnt_arity(TAB_ENT) = ARITY; \
TabEnt_flags(TAB_ENT) = 0; \
SetMode_Batched(TabEnt_flags(TAB_ENT)); \
SetMode_ExecAnswers(TabEnt_flags(TAB_ENT)); \
SetMode_LocalTrie(TabEnt_flags(TAB_ENT)); \
TabEnt_mode(TAB_ENT) = TabEnt_flags(TAB_ENT); \
if (IsMode_Local(yap_flags[TABLING_MODE_FLAG])) \
SetMode_Local(TabEnt_mode(TAB_ENT)); \
if (IsMode_LoadAnswers(yap_flags[TABLING_MODE_FLAG])) \
SetMode_LoadAnswers(TabEnt_mode(TAB_ENT)); \
if (IsMode_GlobalTrie(yap_flags[TABLING_MODE_FLAG])) \
SetMode_GlobalTrie(TabEnt_mode(TAB_ENT)); \
TabEnt_subgoal_trie(TAB_ENT) = sg_node; \
TabEnt_hash_chain(TAB_ENT) = NULL; \
TabEnt_next(TAB_ENT) = GLOBAL_root_tab_ent; \
GLOBAL_root_tab_ent = TAB_ENT; \
TabEnt_mode_directed_array(TAB_ENT) = MODE_DIRECTED_ARRAY; \
#ifdef GLOBAL_TRIE_LOCK_USING_NODE_FIELD
#define LOCK_GLOBAL_NODE(NODE) LOCK(TrNode_lock(NODE))
#define UNLOCK_GLOBAL_NODE(NODE) UNLOCK(TrNode_lock(NODE))
#define GtNode_init_lock_field(NODE) INIT_LOCK(TrNode_lock(NODE))
#elif GLOBAL_TRIE_LOCK_USING_GLOBAL_ARRAY
#define LOCK_GLOBAL_NODE(NODE) LOCK(HASH_TRIE_LOCK(NODE))
#define UNLOCK_GLOBAL_NODE(NODE) UNLOCK(HASH_TRIE_LOCK(NODE))
#define GtNode_init_lock_field(NODE)
#else
#define LOCK_GLOBAL_NODE(NODE)
#define UNLOCK_GLOBAL_NODE(NODE)
#define GtNode_init_lock_field(NODE)
#endif /* GLOBAL_TRIE_LOCK_LEVEL */
#define new_table_entry(TAB_ENT, PRED_ENTRY, ATOM, ARITY, MODE_ARRAY) \
{ register sg_node_ptr sg_node; \
new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); \
ALLOC_TABLE_ENTRY(TAB_ENT); \
INIT_LOCK(TabEnt_lock(TAB_ENT)); \
TabEnt_pe(TAB_ENT) = PRED_ENTRY; \
TabEnt_atom(TAB_ENT) = ATOM; \
TabEnt_arity(TAB_ENT) = ARITY; \
TabEnt_flags(TAB_ENT) = 0; \
SetMode_Batched(TabEnt_flags(TAB_ENT)); \
SetMode_ExecAnswers(TabEnt_flags(TAB_ENT)); \
SetMode_LocalTrie(TabEnt_flags(TAB_ENT)); \
TabEnt_mode(TAB_ENT) = TabEnt_flags(TAB_ENT); \
if (IsMode_Local(yap_flags[TABLING_MODE_FLAG])) \
SetMode_Local(TabEnt_mode(TAB_ENT)); \
if (IsMode_LoadAnswers(yap_flags[TABLING_MODE_FLAG])) \
SetMode_LoadAnswers(TabEnt_mode(TAB_ENT)); \
if (IsMode_GlobalTrie(yap_flags[TABLING_MODE_FLAG])) \
SetMode_GlobalTrie(TabEnt_mode(TAB_ENT)); \
TabEnt_init_mode_directed(TAB_ENT, MODE_ARRAY); \
TabEnt_subgoal_trie(TAB_ENT) = sg_node; \
TabEnt_hash_chain(TAB_ENT) = NULL; \
TabEnt_next(TAB_ENT) = GLOBAL_root_tab_ent; \
GLOBAL_root_tab_ent = TAB_ENT; \
}
#else
#define new_table_entry(TAB_ENT, PRED_ENTRY, ATOM, ARITY) \
{ register sg_node_ptr sg_node; \
new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); \
ALLOC_TABLE_ENTRY(TAB_ENT); \
TabEnt_init_lock_field(TAB_ENT); \
TabEnt_pe(TAB_ENT) = PRED_ENTRY; \
TabEnt_atom(TAB_ENT) = ATOM; \
TabEnt_arity(TAB_ENT) = ARITY; \
TabEnt_flags(TAB_ENT) = 0; \
SetMode_Batched(TabEnt_flags(TAB_ENT)); \
SetMode_ExecAnswers(TabEnt_flags(TAB_ENT)); \
SetMode_LocalTrie(TabEnt_flags(TAB_ENT)); \
TabEnt_mode(TAB_ENT) = TabEnt_flags(TAB_ENT); \
if (IsMode_Local(yap_flags[TABLING_MODE_FLAG])) \
SetMode_Local(TabEnt_mode(TAB_ENT)); \
if (IsMode_LoadAnswers(yap_flags[TABLING_MODE_FLAG])) \
SetMode_LoadAnswers(TabEnt_mode(TAB_ENT)); \
if (IsMode_GlobalTrie(yap_flags[TABLING_MODE_FLAG])) \
SetMode_GlobalTrie(TabEnt_mode(TAB_ENT)); \
TabEnt_subgoal_trie(TAB_ENT) = sg_node; \
TabEnt_hash_chain(TAB_ENT) = NULL; \
TabEnt_next(TAB_ENT) = GLOBAL_root_tab_ent; \
GLOBAL_root_tab_ent = TAB_ENT; \
}
#endif /*MODE_DIRECTED_TABLING*/
#ifdef MODE_DIRECTED_TABLING
#define new_subgoal_frame(SG_FR, CODE, N_VARS_OPERATOR_ARRAY) \
{ register ans_node_ptr ans_node; \
new_answer_trie_node(ans_node, 0,N_VARS_OPERATOR_ARRAY, NULL, NULL, NULL); \
ALLOC_SUBGOAL_FRAME(SG_FR); \
INIT_LOCK(SgFr_lock(SG_FR)); \
SgFr_code(SG_FR) = CODE; \
SgFr_state(SG_FR) = ready; \
SgFr_hash_chain(SG_FR) = NULL; \
SgFr_answer_trie(SG_FR) = ans_node; \
SgFr_first_answer(SG_FR) = NULL; \
SgFr_last_answer(SG_FR) = NULL; \
SgFr_del_node(SG_FR) = NULL; \
}
#else
#define new_subgoal_frame(SG_FR, CODE) \
#define new_subgoal_frame(SG_FR, CODE, MODE_ARRAY) \
{ register ans_node_ptr ans_node; \
new_answer_trie_node(ans_node, 0, 0, NULL, NULL, NULL); \
ALLOC_SUBGOAL_FRAME(SG_FR); \
@ -354,8 +386,8 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
SgFr_answer_trie(SG_FR) = ans_node; \
SgFr_first_answer(SG_FR) = NULL; \
SgFr_last_answer(SG_FR) = NULL; \
SgFr_init_mode_directed(SG_FR, MODE_ARRAY); \
}
#endif /*MODE_DIRECTED_TABLING*/
#define init_subgoal_frame(SG_FR) \
{ SgFr_init_yapor_fields(SG_FR); \
@ -377,48 +409,49 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
(unsigned long int) (&TrNode_child((ans_node_ptr)DEP_FR))); \
DepFr_next(DEP_FR) = NEXT
#define new_suspension_frame(SUSP_FR, TOP_OR_FR_ON_STACK, TOP_DEP, TOP_SG, \
H_REG, B_REG, TR_REG, H_SIZE, B_SIZE, TR_SIZE) \
ALLOC_SUSPENSION_FRAME(SUSP_FR); \
SuspFr_top_or_fr_on_stack(SUSP_FR) = TOP_OR_FR_ON_STACK; \
SuspFr_top_dep_fr(SUSP_FR) = TOP_DEP; \
SuspFr_top_sg_fr(SUSP_FR) = TOP_SG; \
SuspFr_global_reg(SUSP_FR) = (void *) (H_REG); \
SuspFr_local_reg(SUSP_FR) = (void *) (B_REG); \
SuspFr_trail_reg(SUSP_FR) = (void *) (TR_REG); \
ALLOC_BLOCK(SuspFr_global_start(SUSP_FR), H_SIZE + B_SIZE + TR_SIZE, void *); \
SuspFr_local_start(SUSP_FR) = SuspFr_global_start(SUSP_FR) + H_SIZE; \
SuspFr_trail_start(SUSP_FR) = SuspFr_local_start(SUSP_FR) + B_SIZE; \
SuspFr_global_size(SUSP_FR) = H_SIZE; \
SuspFr_local_size(SUSP_FR) = B_SIZE; \
SuspFr_trail_size(SUSP_FR) = TR_SIZE; \
memcpy(SuspFr_global_start(SUSP_FR), SuspFr_global_reg(SUSP_FR), H_SIZE); \
memcpy(SuspFr_local_start(SUSP_FR), SuspFr_local_reg(SUSP_FR), B_SIZE); \
#define new_suspension_frame(SUSP_FR, TOP_OR_FR_ON_STACK, TOP_DEP, TOP_SG, \
H_REG, B_REG, TR_REG, H_SIZE, B_SIZE, TR_SIZE) \
ALLOC_SUSPENSION_FRAME(SUSP_FR); \
SuspFr_top_or_fr_on_stack(SUSP_FR) = TOP_OR_FR_ON_STACK; \
SuspFr_top_dep_fr(SUSP_FR) = TOP_DEP; \
SuspFr_top_sg_fr(SUSP_FR) = TOP_SG; \
SuspFr_global_reg(SUSP_FR) = (void *) (H_REG); \
SuspFr_local_reg(SUSP_FR) = (void *) (B_REG); \
SuspFr_trail_reg(SUSP_FR) = (void *) (TR_REG); \
ALLOC_BLOCK(SuspFr_global_start(SUSP_FR), H_SIZE + B_SIZE + TR_SIZE, void *); \
SuspFr_local_start(SUSP_FR) = SuspFr_global_start(SUSP_FR) + H_SIZE; \
SuspFr_trail_start(SUSP_FR) = SuspFr_local_start(SUSP_FR) + B_SIZE; \
SuspFr_global_size(SUSP_FR) = H_SIZE; \
SuspFr_local_size(SUSP_FR) = B_SIZE; \
SuspFr_trail_size(SUSP_FR) = TR_SIZE; \
memcpy(SuspFr_global_start(SUSP_FR), SuspFr_global_reg(SUSP_FR), H_SIZE); \
memcpy(SuspFr_local_start(SUSP_FR), SuspFr_local_reg(SUSP_FR), B_SIZE); \
memcpy(SuspFr_trail_start(SUSP_FR), SuspFr_trail_reg(SUSP_FR), TR_SIZE)
#define new_subgoal_trie_node(NODE, ENTRY, CHILD, PARENT, NEXT) \
ALLOC_SUBGOAL_TRIE_NODE(NODE); \
TrNode_entry(NODE) = ENTRY; \
TrNode_init_lock_field(NODE); \
TrNode_child(NODE) = CHILD; \
TrNode_parent(NODE) = PARENT; \
TrNode_next(NODE) = NEXT
TrNode_next(NODE) = NEXT; \
SgNode_init_lock_field(NODE)
#define new_answer_trie_node(NODE, INSTR, ENTRY, CHILD, PARENT, NEXT) \
ALLOC_ANSWER_TRIE_NODE(NODE); \
TrNode_instr(NODE) = INSTR; \
TrNode_entry(NODE) = ENTRY; \
TrNode_init_lock_field(NODE); \
TrNode_child(NODE) = CHILD; \
TrNode_parent(NODE) = PARENT; \
TrNode_next(NODE) = NEXT
TrNode_next(NODE) = NEXT; \
AnsNode_init_lock_field(NODE)
#define new_global_trie_node(NODE, ENTRY, CHILD, PARENT, NEXT) \
ALLOC_GLOBAL_TRIE_NODE(NODE); \
TrNode_entry(NODE) = ENTRY; \
TrNode_child(NODE) = CHILD; \
TrNode_parent(NODE) = PARENT; \
TrNode_next(NODE) = NEXT
TrNode_next(NODE) = NEXT; \
GtNode_init_lock_field(NODE)
#define new_subgoal_trie_hash(HASH, NUM_NODES, TAB_ENT) \
ALLOC_SUBGOAL_TRIE_HASH(HASH); \
@ -434,7 +467,7 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
Hash_num_buckets(HASH) = BASE_HASH_BUCKETS; \
ALLOC_HASH_BUCKETS(Hash_buckets(HASH), BASE_HASH_BUCKETS); \
Hash_num_nodes(HASH) = NUM_NODES; \
AnsHash_init_next_field(HASH, SG_FR)
AnsHash_init_chain_fields(HASH, SG_FR)
#define new_global_trie_hash(HASH, NUM_NODES) \
ALLOC_GLOBAL_TRIE_HASH(HASH); \
@ -533,42 +566,38 @@ static inline void adjust_freeze_registers(void) {
static inline void mark_as_completed(sg_fr_ptr sg_fr) {
LOCK(SgFr_lock(sg_fr));
#ifdef MODE_DIRECTED_TABLING
//printf("complete\n");
ans_node_ptr answer, valid_answer, elim_answer;
answer = SgFr_first_answer(sg_fr);
while(answer && IS_INVALID_ANSWER_LEAF_NODE(answer))
answer = TrNode_child(answer);
SgFr_first_answer(sg_fr) = answer;
valid_answer = answer;
if(answer!= NULL)
answer = TrNode_child(valid_answer);
while(answer != NULL){
if (!IS_INVALID_ANSWER_LEAF_NODE(answer)){
TrNode_child(valid_answer) = answer;
valid_answer = answer;
}
answer = TrNode_child(answer);
}
//TrNode_child(valid_answer) = NULL;
SgFr_last_answer(sg_fr) = valid_answer;
elim_answer = SgFr_del_node(sg_fr);
while(elim_answer){
answer= TrNode_next(elim_answer);
FREE_ANSWER_TRIE_NODE(elim_answer);
elim_answer = answer;
}
#endif /*MODE_DIRECTED_TABLING*/
SgFr_state(sg_fr) = complete;
UNLOCK(SgFr_lock(sg_fr));
#ifdef MODE_DIRECTED_TABLING
if (SgFr_invalid_chain(sg_fr)) {
ans_node_ptr current_node, next_node;
/* find first valid answer */
current_node = SgFr_first_answer(sg_fr);
while (IS_INVALID_LEAF_NODE(current_node))
current_node = TrNode_child(current_node);
SgFr_first_answer(sg_fr) = current_node;
/* chain next valid answers */
next_node = TrNode_child(current_node);
while (next_node) {
if (! IS_INVALID_LEAF_NODE(next_node)) {
TrNode_child(current_node) = next_node;
current_node = next_node;
}
next_node = TrNode_child(next_node);
}
SgFr_last_answer(sg_fr) = current_node;
#ifndef YAPOR
/* free invalid answer nodes */
current_node = SgFr_invalid_chain(sg_fr);
SgFr_invalid_chain(sg_fr) = NULL;
while (current_node) {
next_node = TrNode_next(current_node);
FREE_ANSWER_TRIE_NODE(current_node);
current_node = next_node;
}
#endif /* ! YAPOR */
}
#endif /* MODE_DIRECTED_TABLING */
return;
}
@ -774,8 +803,42 @@ static inline void abolish_incomplete_subgoals(choiceptr prune_cp) {
#ifdef INCOMPLETE_TABLING
SgFr_state(sg_fr) = incomplete;
UNLOCK(SgFr_lock(sg_fr));
#ifdef MODE_DIRECTED_TABLING
if (SgFr_invalid_chain(sg_fr)) {
ans_node_ptr current_node, next_node;
/* find first valid answer */
current_node = SgFr_first_answer(sg_fr);
while (IS_INVALID_LEAF_NODE(current_node))
current_node = TrNode_child(current_node);
SgFr_first_answer(sg_fr) = current_node;
/* chain next valid answers */
next_node = TrNode_child(current_node);
while (next_node) {
if (! IS_INVALID_LEAF_NODE(next_node)) {
TrNode_child(current_node) = next_node;
current_node = next_node;
}
next_node = TrNode_child(next_node);
}
SgFr_last_answer(sg_fr) = current_node;
#ifndef YAPOR
/* free invalid answer nodes */
current_node = SgFr_invalid_chain(sg_fr);
SgFr_invalid_chain(sg_fr) = NULL;
while (current_node) {
next_node = TrNode_next(invalid_node);
FREE_ANSWER_TRIE_NODE(current_node);
current_node = node_node;
}
#endif /* ! YAPOR */
}
#endif /* MODE_DIRECTED_TABLING */
#else
ans_node_ptr node;
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr invalid_node = SgFr_invalid_chain(sg_fr);
SgFr_invalid_chain(sg_fr) = NULL;
#endif /* MODE_DIRECTED_TABLING */
SgFr_state(sg_fr) = ready;
free_answer_hash_chain(SgFr_hash_chain(sg_fr));
SgFr_hash_chain(sg_fr) = NULL;
@ -785,6 +848,14 @@ static inline void abolish_incomplete_subgoals(choiceptr prune_cp) {
TrNode_child(SgFr_answer_trie(sg_fr)) = NULL;
UNLOCK(SgFr_lock(sg_fr));
free_answer_trie(node, TRAVERSE_MODE_NORMAL, TRAVERSE_POSITION_FIRST);
#if defined(MODE_DIRECTED_TABLING) && ! defined(YAPOR)
/* free invalid answer nodes */
while (invalid_node) {
node = TrNode_next(invalid_node);
FREE_ANSWER_TRIE_NODE(invalid_node);
invalid_node = node;
}
#endif /* MODE_DIRECTED_TABLING && ! YAPOR */
#endif /* INCOMPLETE_TABLING */
}
#ifdef LIMIT_TABLING
@ -986,13 +1057,8 @@ static inline void CUT_validate_tg_answers(tg_sol_fr_ptr valid_solutions) {
slots = TgAnsFr_free_slot(valid_answers);
do {
ans_node = TgAnsFr_answer(valid_answers, --slots);
#if defined(TABLE_LOCK_AT_ENTRY_LEVEL)
LOCK(SgFr_lock(sg_fr));
#elif defined(TABLE_LOCK_AT_NODE_LEVEL)
LOCK(TrNode_lock(ans_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
LOCK_TABLE(ans_node);
#endif /* TABLE_LOCK_LEVEL */
LOCK_ANSWER_TRIE(sg_fr);
LOCK_ANSWER_NODE(ans_node);
if (! IS_ANSWER_LEAF_NODE(ans_node)) {
TAG_AS_ANSWER_LEAF_NODE(ans_node);
if (first_answer == NULL)
@ -1001,13 +1067,8 @@ static inline void CUT_validate_tg_answers(tg_sol_fr_ptr valid_solutions) {
TrNode_child(last_answer) = ans_node;
last_answer = ans_node;
}
#if defined(TABLE_LOCK_AT_ENTRY_LEVEL)
UNLOCK(SgFr_lock(sg_fr));
#elif defined(TABLE_LOCK_AT_NODE_LEVEL)
UNLOCK(TrNode_lock(ans_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
UNLOCK_TABLE(ans_node);
#endif /* TABLE_LOCK_LEVEL */
UNLOCK_ANSWER_NODE(ans_node);
UNLOCK_ANSWER_TRIE(sg_fr);
} while (slots);
free_answer = valid_answers;
valid_answers = TgAnsFr_next(valid_answers);

96
OPTYap/tab.structs.h
View File

@ -28,26 +28,24 @@ typedef struct table_entry {
int pred_arity;
short pred_flags;
short execution_mode; /* combines yap_flags with pred_flags */
struct subgoal_trie_node *subgoal_trie;
struct subgoal_trie_hash *hash_chain;
#ifdef MODE_DIRECTED_TABLING
int* mode_directed_array;
#endif /*MODE_DIRECTED_TABLING*/
struct subgoal_trie_node *subgoal_trie;
struct subgoal_trie_hash *hash_chain;
struct table_entry *next;
} *tab_ent_ptr;
#define TabEnt_lock(X) ((X)->lock)
#define TabEnt_pe(X) ((X)->pred_entry)
#define TabEnt_atom(X) ((X)->pred_atom)
#define TabEnt_arity(X) ((X)->pred_arity)
#define TabEnt_flags(X) ((X)->pred_flags)
#define TabEnt_mode(X) ((X)->execution_mode)
#define TabEnt_subgoal_trie(X) ((X)->subgoal_trie)
#define TabEnt_hash_chain(X) ((X)->hash_chain)
#ifdef MODE_DIRECTED_TABLING
#define TabEnt_mode_directed_array(X) ((X)->mode_directed_array)
#endif /*MODE_DIRECTED_TABLING*/
#define TabEnt_next(X) ((X)->next)
#define TabEnt_lock(X) ((X)->lock)
#define TabEnt_pe(X) ((X)->pred_entry)
#define TabEnt_atom(X) ((X)->pred_atom)
#define TabEnt_arity(X) ((X)->pred_arity)
#define TabEnt_flags(X) ((X)->pred_flags)
#define TabEnt_mode(X) ((X)->execution_mode)
#define TabEnt_mode_directed(X) ((X)->mode_directed_array)
#define TabEnt_subgoal_trie(X) ((X)->subgoal_trie)
#define TabEnt_hash_chain(X) ((X)->hash_chain)
#define TabEnt_next(X) ((X)->next)
@ -60,9 +58,9 @@ typedef struct subgoal_trie_node {
struct subgoal_trie_node *parent;
struct subgoal_trie_node *child;
struct subgoal_trie_node *next;
#ifdef TABLE_LOCK_AT_NODE_LEVEL
#ifdef SUBGOAL_TRIE_LOCK_USING_NODE_FIELD
lockvar lock;
#endif /* TABLE_LOCK_AT_NODE_LEVEL */
#endif /* SUBGOAL_TRIE_LOCK_USING_NODE_FIELD */
} *sg_node_ptr;
typedef struct answer_trie_node {
@ -74,9 +72,9 @@ typedef struct answer_trie_node {
struct answer_trie_node *parent;
struct answer_trie_node *child;
struct answer_trie_node *next;
#ifdef TABLE_LOCK_AT_NODE_LEVEL
#ifdef ANSWER_TRIE_LOCK_USING_NODE_FIELD
lockvar lock;
#endif /* TABLE_LOCK_AT_NODE_LEVEL */
#endif /* ANSWER_TRIE_LOCK_USING_NODE_FIELD */
} *ans_node_ptr;
typedef struct global_trie_node {
@ -84,9 +82,9 @@ typedef struct global_trie_node {
struct global_trie_node *parent;
struct global_trie_node *child;
struct global_trie_node *next;
#ifdef TABLE_LOCK_AT_NODE_LEVEL
#ifdef GLOBAL_TRIE_LOCK_USING_NODE_FIELD
lockvar lock;
#endif /* TABLE_LOCK_AT_NODE_LEVEL */
#endif /* GLOBAL_TRIE_LOCK_USING_NODE_FIELD */
} *gt_node_ptr;
#define TrNode_instr(X) ((X)->trie_instruction)
@ -97,9 +95,7 @@ typedef struct global_trie_node {
#define TrNode_sg_fr(X) ((X)->child)
#define TrNode_next(X) ((X)->next)
#define TrNode_lock(X) ((X)->lock)
#ifdef MODE_DIRECTED_TABLING
#define TrNode_mode_directed_array(X) ((X)->entry)
#endif /*MODE_DIRECTED_TABLING */
/***********************************************************************
@ -123,10 +119,10 @@ typedef struct answer_trie_hash {
int number_of_buckets;
struct answer_trie_node **buckets;
int number_of_nodes;
struct answer_trie_hash *next;
#ifdef MODE_DIRECTED_TABLING
struct answer_trie_hash *previous;
#endif /*MODE_DIRECTED_TABLING*/
struct answer_trie_hash *next;
} *ans_hash_ptr;
typedef struct global_trie_hash {
@ -147,10 +143,9 @@ typedef struct global_trie_hash {
#define Hash_buckets(X) ((X)->buckets)
#define Hash_bucket(X,N) ((X)->buckets + N)
#define Hash_num_nodes(X) ((X)->number_of_nodes)
#define Hash_previous(X) ((X)->previous)
#define Hash_next(X) ((X)->next)
#ifdef MODE_DIRECTED_TABLING
#define Hash_previous(X) ((X)->previous)
#endif /*MODE_DIRECTED_TABLING*/
/************************************************************************
@ -225,6 +220,10 @@ typedef struct subgoal_frame {
struct answer_trie_node *answer_trie;
struct answer_trie_node *first_answer;
struct answer_trie_node *last_answer;
#ifdef MODE_DIRECTED_TABLING
int* mode_directed_array;
struct answer_trie_node *invalid_chain;
#endif /*MODE_DIRECTED_TABLING*/
#ifdef INCOMPLETE_TABLING
struct answer_trie_node *try_answer;
#endif /* INCOMPLETE_TABLING */
@ -232,9 +231,6 @@ typedef struct subgoal_frame {
struct subgoal_frame *previous;
#endif /* LIMIT_TABLING */
struct subgoal_frame *next;
#ifdef MODE_DIRECTED_TABLING
struct answer_trie_node *del_node;
#endif /*MODE_DIRECTED_TABLING*/
} *sg_fr_ptr;
#define SgFr_lock(X) ((X)->lock)
@ -249,12 +245,12 @@ struct answer_trie_node *del_node;
#define SgFr_answer_trie(X) ((X)->answer_trie)
#define SgFr_first_answer(X) ((X)->first_answer)
#define SgFr_last_answer(X) ((X)->last_answer)
#define SgFr_mode_directed(X) ((X)->mode_directed_array)
#define SgFr_invalid_chain(X) ((X)->invalid_chain)
#define SgFr_try_answer(X) ((X)->try_answer)
#define SgFr_previous(X) ((X)->previous)
#define SgFr_next(X) ((X)->next)
#ifdef MODE_DIRECTED_TABLING
#define SgFr_del_node(X) ((X)->del_node)
#endif /*MODE_DIRECTED_TABLING*/
/**************************************************************************************************
SgFr_lock: spin-lock to modify the frame fields.
@ -273,6 +269,8 @@ struct answer_trie_node *del_node;
It is used to check for/insert new answers.
SgFr_first_answer: a pointer to the bottom answer trie node of the first available answer.
SgFr_last_answer: a pointer to the bottom answer trie node of the last available answer.
SgFr_mode_directed: a pointer to the mode directed array.
SgFr_invalid_chain: a pointer to the first invalid leaf node when using mode directed tabling.
SgFr_try_answer: a pointer to the bottom answer trie node of the last tried answer.
It is used when a subgoal was not completed during the previous evaluation.
Not completed subgoals start by trying the answers already found.
@ -369,35 +367,3 @@ typedef struct suspension_frame {
#define SuspFr_trail_start(X) ((X)->trail_block.block_start)
#define SuspFr_trail_size(X) ((X)->trail_block.block_size)
#define SuspFr_next(X) ((X)->next)
/* ---------------------------- **
** MODE_DIRECTED_TABLING flags **
** ---------------------------- */
#ifdef MODE_DIRECTED_TABLING
#define MODE_DIRECTED_TAGBITS 4
/*indexing*/
#define MODE_DIRECTED_INDEX 6
#define MODE_DIRECTED_NINDEX 1
#define MODE_DIRECTED_ALL 2
/*agregation*/
#define MODE_DIRECTED_MAX 3
#define MODE_DIRECTED_MIN 4
#define MODE_DIRECTED_SUM 5
#define MODE_DIRECTED_LAST 0
/* Macros */
#define MODE_DIRECTED_index(X) ((X) >> MODE_DIRECTED_TAGBITS)
#define MODE_DIRECTED_n_vars(X) ((X) >> MODE_DIRECTED_TAGBITS)
#define MODE_DIRECTED_operator(X) ((((X) >> MODE_DIRECTED_TAGBITS) << MODE_DIRECTED_TAGBITS) ^ (X))
#define TAG_AS_INVALID_ANSWER_LEAF_NODE(NODE,SG_FR) TrNode_parent(NODE) = (ans_node_ptr)((unsigned long int)TrNode_parent(NODE) | 0x2); \
TrNode_next(NODE) = SgFr_del_node(SG_FR);\
SgFr_del_node(SG_FR) = NODE
#define IS_INVALID_ANSWER_LEAF_NODE(NODE) ((unsigned long int)TrNode_parent(NODE) & 0x2)
#endif /*MODE_DIRECTED_TABLING*/

696
OPTYap/tab.tries.c
View File

@ -21,9 +21,6 @@
#include "YapHeap.h"
#include "tab.macros.h"
#ifdef MODE_DIRECTED_TABLING
static inline ans_node_ptr answer_search_loop2(sg_fr_ptr, ans_node_ptr, Term, int *,int);
#endif /*MODE_DIRECTED_TABLING*/
static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr, sg_node_ptr, Term);
static inline sg_node_ptr subgoal_trie_check_insert_gt_entry(tab_ent_ptr, sg_node_ptr, Term);
static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr, ans_node_ptr, Term, int);
@ -62,7 +59,6 @@ static void free_global_trie_branch(gt_node_ptr, int);
static void free_global_trie_branch(gt_node_ptr);
#endif /* GLOBAL_TRIE_FOR_SUBTERMS */
static void traverse_subgoal_trie(sg_node_ptr, char *, int, int *, int, int);
static void traverse_answer_trie(ans_node_ptr, char *, int, int *, int, int, int);
static void traverse_global_trie(gt_node_ptr, char *, int, int *, int, int);
@ -70,446 +66,8 @@ static void traverse_global_trie_for_term(gt_node_ptr, char *, int *, int *, int
static inline void traverse_trie_node(Term, char *, int *, int *, int *, int);
static inline void traverse_update_arity(char *, int *, int *);
//----------------------------------------------------------------------------------
#ifdef MODE_DIRECTED_TABLING
//#define INCLUDE_ANSWER_TRIE_CHECK_INSERT
//#define INCLUDE_ANSWER_SEARCH_LOOP
#define ANSWER_CHECK_INSERT_ENTRY(SG_FR, NODE, ENTRY, INSTR) \
NODE = answer_trie_check_insert_entry(SG_FR, NODE, ENTRY, INSTR)
void invalidate_answer(ans_node_ptr node,sg_fr_ptr sg_fr) {
if(node == NULL)
return;
if(IS_ANSWER_LEAF_NODE(node)){
TAG_AS_INVALID_ANSWER_LEAF_NODE(node,sg_fr);
return;
}
if( IS_ANSWER_TRIE_HASH(node)){
ans_hash_ptr hash;
ans_node_ptr *bucket, *last_bucket, *first_bucket;
hash = (ans_hash_ptr) node;
first_bucket = bucket = Hash_buckets(hash);
last_bucket = bucket + Hash_num_buckets(hash);
do {
invalidate_answer(*bucket,sg_fr);
} while (++bucket != last_bucket);
Hash_next(Hash_previous(hash)) = Hash_next(hash);
FREE_HASH_BUCKETS(first_bucket);
FREE_ANSWER_TRIE_HASH(hash);
}
else{
if (! IS_ANSWER_LEAF_NODE(node))
invalidate_answer(TrNode_child(node),sg_fr);
if (TrNode_next(node))
invalidate_answer(TrNode_next(node),sg_fr);
FREE_ANSWER_TRIE_NODE(node);
return;
}
}
static inline ans_node_ptr answer_search_loop2(sg_fr_ptr sg_fr, ans_node_ptr current_node, Term t, int *vars_arity_ptr,int mode) {
CACHE_REGS
#ifdef MODE_GLOBAL_TRIE_LOOP
gt_node_ptr current_node = GLOBAL_root_gt;
#endif /* MODE_GLOBAL_TRIE_LOOP */
int vars_arity = *vars_arity_ptr;
#if ! defined(MODE_GLOBAL_TRIE_LOOP) || ! defined(GLOBAL_TRIE_FOR_SUBTERMS)
CELL *stack_terms = (CELL *) LOCAL_TrailTop;
#endif /* ! MODE_GLOBAL_TRIE_LOOP || ! GLOBAL_TRIE_FOR_SUBTERMS */
CELL *stack_vars_base = (CELL *) TR;
#define stack_terms_limit (stack_vars_base + vars_arity)
#ifdef TRIE_COMPACT_PAIRS
int in_pair = 0;
#else
#define in_pair 0
#endif /* TRIE_COMPACT_PAIRS */
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr child_node;
Term child_term;
#endif /*MODE_DIRECTED_TABLING*/
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 1); /* + 1 because initially we stiil haven't done any STACK_POP_DOWN */
STACK_PUSH_UP(NULL, stack_terms);
#if defined(MODE_GLOBAL_TRIE_LOOP)
/* for the global trie, it is safe to skip the IsVarTerm() and IsAtomOrIntTerm() tests in the first iteration */
goto answer_search_loop_non_atomic;
#endif /* MODE_GLOBAL_TRIE_LOOP */
if(mode == MODE_DIRECTED_NINDEX && TrNode_child(current_node))
return NULL;
if(mode == MODE_DIRECTED_LAST && TrNode_child(current_node)){
invalidate_answer(TrNode_child(current_node),sg_fr);
TrNode_child(current_node) = NULL;
}
do {
if (IsVarTerm(t)) {
t = Deref(t);
if (IsTableVarTerm(t)) {
t = MakeTableVarTerm(VarIndexOfTerm(t));
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair);
} else {
if (vars_arity == MAX_TABLE_VARS)
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: MAX_TABLE_VARS exceeded");
stack_vars_base[vars_arity] = t;
*((CELL *)t) = GLOBAL_table_var_enumerator(vars_arity);
t = MakeTableVarTerm(vars_arity);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair);
vars_arity = vars_arity + 1;
}
#ifdef TRIE_COMPACT_PAIRS
in_pair = 0;
#endif /* TRIE_COMPACT_PAIRS */
} else if (IsAtomOrIntTerm(t)) {
#ifdef MODE_DIRECTED_TABLING
child_node = TrNode_child(current_node);
if(child_node && IsIntTerm(t) && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){
Int it = IntOfTerm(t);
if(IsIntTerm(TrNode_entry(child_node))){
child_term = TrNode_entry(child_node);
Int tt = IntOfTerm(child_term);
if((mode == MODE_DIRECTED_MIN && it < tt ) || (mode == MODE_DIRECTED_MAX && it > tt) ){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
}
else if((mode == MODE_DIRECTED_MIN && it > tt) || (mode == MODE_DIRECTED_MAX && it < tt) ){
return NULL;
}
else if (it == tt){
current_node = TrNode_child(current_node);
}
}
if(IsApplTerm(TrNode_entry(child_node))){
if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){
Int tt = TrNode_entry(TrNode_child(child_node));
if((mode == MODE_DIRECTED_MIN && it < tt ) || (mode == MODE_DIRECTED_MAX && it > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
}
else if(it == tt){
current_node = TrNode_child(TrNode_child(child_node));
}
else if((mode == MODE_DIRECTED_MIN && it > tt) || (mode == MODE_DIRECTED_MAX && it < tt) )
return NULL;
}
else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} u;
u.t_dbl[0] = TrNode_entry(TrNode_child(child_node));
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node)));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
if((mode == MODE_DIRECTED_MIN && it < u.dbl ) || (mode == MODE_DIRECTED_MAX && it > u.dbl)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
}
else if(it == u.dbl){
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
current_node = TrNode_child(TrNode_child(TrNode_child(child_node)));
#else
current_node = TrNode_child(TrNode_child(child_node));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
}
else if((mode == MODE_DIRECTED_MIN && it > u.dbl) || (mode == MODE_DIRECTED_MAX && it < u.dbl))
return NULL;
}
}
}
else
#endif /*MODE_DIRECTED_TABLING*/
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
#ifdef TRIE_COMPACT_PAIRS
in_pair = 0;
#endif /* TRIE_COMPACT_PAIRS */
#ifdef MODE_TERMS_LOOP
} else {
gt_node_ptr entry_node;
#ifdef GLOBAL_TRIE_FOR_SUBTERMS
entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
#else
entry_node = answer_search_global_trie_loop(t, &vars_arity);
#endif /* GLOBAL_TRIE_FOR_SUBTERMS */
current_node = answer_trie_check_insert_gt_entry(sg_fr, current_node, (Term) entry_node, _trie_retry_gterm + in_pair);
#else /* ! MODE_TERMS_LOOP */
} else
#if defined(MODE_GLOBAL_TRIE_LOOP)
/* for the global trie, it is safe to start here in the first iteration */
answer_search_loop_non_atomic:
#endif /* MODE_GLOBAL_TRIE_LOOP */
#ifdef TRIE_COMPACT_PAIRS
if (IsPairTerm(t)) {
CELL *aux_pair = RepPair(t);
if (aux_pair == PairTermMark) {
t = STACK_POP_DOWN(stack_terms);
if (IsPairTerm(t)) {
aux_pair = RepPair(t);
t = Deref(aux_pair[1]);
if (t == TermNil) {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair);
} else {
/* AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 2); */
/* AUX_STACK_CHECK_EXPAND is not necessary here because the situation of pushing **
** up 3 terms has already initially checked for the CompactPairInit term */
STACK_PUSH_UP(t, stack_terms);
STACK_PUSH_UP(AbsPair(PairTermMark), stack_terms);
in_pair = 4;
}
STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms);
} else {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndTerm, _trie_retry_null);
STACK_PUSH_UP(t, stack_terms);
}
#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS)
} else if (current_node != GLOBAL_root_gt) {
gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node);
#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */
} else {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairInit, _trie_retry_null + in_pair);
t = Deref(aux_pair[1]);
if (t == TermNil) {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair);
in_pair = 0;
} else {
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 2);
STACK_PUSH_UP(t, stack_terms);
STACK_PUSH_UP(AbsPair(PairTermMark), stack_terms);
in_pair = 4;
}
STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms);
}
#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS)
} else if (current_node != GLOBAL_root_gt) {
gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node);
#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */
#else /* ! TRIE_COMPACT_PAIRS */
#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS)
if (current_node != GLOBAL_root_gt) {
gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node);
} else
#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */
if (IsPairTerm(t)) {
CELL *aux_pair = RepPair(t);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsPair(NULL), _trie_retry_pair);
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 1);
STACK_PUSH_UP(Deref(aux_pair[1]), stack_terms);
STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms);
#endif /* TRIE_COMPACT_PAIRS */
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
if (f == FunctorDouble) {
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} u;
u.dbl = FloatOfTerm(t);
#ifdef MODE_DIRECTED_TABLING
child_node = TrNode_child(current_node);
if(child_node && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){
if(IsApplTerm(TrNode_entry(child_node))){
if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){
Int tt = TrNode_entry(TrNode_child(child_node));
if(( mode == MODE_DIRECTED_MIN && u.dbl < tt) || ( mode == MODE_DIRECTED_MAX && u.dbl > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
}
else if(tt == u.dbl){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && u.dbl > tt) || ( mode == MODE_DIRECTED_MAX && u.dbl < tt))
return NULL;
}
else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} ans_u;
ans_u.t_dbl[0] = TrNode_entry(TrNode_child(child_node));
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ans_u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node)));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
if(( mode == MODE_DIRECTED_MIN && u.dbl < ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && u.dbl > ans_u.dbl)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
}
else if(ans_u.dbl == u.dbl){
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
current_node = TrNode_child(TrNode_child(TrNode_child(child_node)));
#else
current_node = TrNode_child(TrNode_child(child_node));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
}
else if(( mode == MODE_DIRECTED_MIN && u.dbl > ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && u.dbl < ans_u.dbl))
return NULL;
}
}
else if(IsIntTerm(TrNode_entry(child_node))){
Int tt = IntOfTerm(child_node);
if(( mode == MODE_DIRECTED_MIN && u.dbl < tt) || ( mode == MODE_DIRECTED_MAX && u.dbl > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
}
else if(IntOfTerm(child_node) == u.dbl){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && u.dbl > tt) || ( mode == MODE_DIRECTED_MAX && u.dbl < tt))
return NULL;
}
}
else {
#endif /*MODE_DIRECTED_TABLING*/
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
#ifdef MODE_DIRECTED_TABLING
}
#endif /*MODE_DIRECTED_TABLING*/
} else if (f == FunctorLongInt) {
Int li = LongIntOfTerm (t);
child_node = TrNode_child(current_node);
#ifdef MODE_DIRECTED_TABLING
if(child_node && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){
if(IsApplTerm(TrNode_entry(child_node))){
if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){
Int tt = TrNode_entry(TrNode_child(child_node));
if(( mode == MODE_DIRECTED_MIN && li < tt) || ( mode == MODE_DIRECTED_MAX && li > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
}
else if(li == tt){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && li > tt) || ( mode == MODE_DIRECTED_MAX && li < tt))
return NULL;
}
else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} ans_u;
ans_u.t_dbl[0] = TrNode_entry(TrNode_child(child_node));
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ans_u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node)));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
if(( mode == MODE_DIRECTED_MIN && li < ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && li > ans_u.dbl)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
}
else if(ans_u.dbl == li){
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
current_node = TrNode_child(TrNode_child(TrNode_child(child_node)));
#else
current_node = TrNode_child(TrNode_child(child_node));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
}
else if(( mode == MODE_DIRECTED_MIN && li > ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && li < ans_u.dbl))
return NULL;
}
}
else if(IsIntTerm(TrNode_entry(child_node))){
Int tt = IntOfTerm(child_node);
if(( mode == MODE_DIRECTED_MIN && li < tt) || ( mode == MODE_DIRECTED_MAX && li > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
}
else if(li == tt){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && li > tt) || ( mode == MODE_DIRECTED_MAX && li < tt))
return NULL;
}
}else{
#endif /*MODE_DIRECTED_TABLING*/
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
#ifdef MODE_DIRECTED_TABLING
}
#endif/*MODE_DIRECTED_TABLING*/
} else if (f == FunctorDBRef) {
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorDBRef");
} else if (f == FunctorBigInt) {
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorBigInt");
} else {
int i;
CELL *aux_appl = RepAppl(t);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_appl + in_pair);
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + ArityOfFunctor(f) - 1);
for (i = ArityOfFunctor(f); i >= 1; i--)
STACK_PUSH_UP(Deref(aux_appl[i]), stack_terms);
}
#ifdef TRIE_COMPACT_PAIRS
in_pair = 0;
#endif /* TRIE_COMPACT_PAIRS */
} else {
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unknown type tag");
#endif /* MODE_TERMS_LOOP */
}
t = STACK_POP_DOWN(stack_terms);
} while (t);
*vars_arity_ptr = vars_arity;
return current_node;
#undef stack_terms_limit
#ifndef TRIE_COMPACT_PAIRS
#undef in_pair
#endif /* TRIE_COMPACT_PAIRS */
}
//#undef INCLUDE_ANSWER_TRIE_CHECK_INSERT
//#undef INCLUDE_ANSWER_SEARCH_LOOP
#endif /* MODE_DIRECTED_TABLING*/
//-----------------------------------------------------------------------------------------------------------------
/*******************************
** Structs & Macros **
*******************************/
@ -621,6 +179,13 @@ static struct trie_statistics{
#undef INCLUDE_SUBGOAL_SEARCH_LOOP
#undef MODE_GLOBAL_TRIE_LOOP
#ifdef MODE_DIRECTED_TABLING
#define INCLUDE_ANSWER_SEARCH_MODE_DIRECTED
#include "tab.tries.i" /* answer_search_min_max + invalidate_answer_trie */
#undef INCLUDE_ANSWER_SEARCH_MODE_DIRECTED
#endif /* MODE_DIRECTED_TABLING */
static inline CELL *exec_substitution_loop(gt_node_ptr current_node, CELL **stack_vars_ptr, CELL *stack_terms) {
/************************************************************************
@ -1413,58 +978,51 @@ static inline void traverse_update_arity(char *str, int *str_index_ptr, int *ari
*******************************/
sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
// printf("subgoal_search\n");
CACHE_REGS
CELL *stack_vars;
int i, subs_arity, pred_arity;
tab_ent_ptr tab_ent;
sg_fr_ptr sg_fr;
sg_node_ptr current_sg_node;
#ifdef MODE_DIRECTED_TABLING
int *mode_directed, aux_mode_directed[MAX_TABLE_VARS];
int subs_pos = 0;
#endif /* MODE_DIRECTED_TABLING */
stack_vars = *Yaddr;
subs_arity = 0;
pred_arity = preg->u.Otapl.s;
tab_ent = preg->u.Otapl.te;
current_sg_node = TabEnt_subgoal_trie(tab_ent);
#ifdef TABLE_LOCK_AT_ENTRY_LEVEL
LOCK(TabEnt_lock(tab_ent));
#endif /* TABLE_LOCK_LEVEL */
LOCK_SUBGOAL_TRIE(tab_ent);
#ifdef MODE_DIRECTED_TABLING
int* mode_directed_array = TabEnt_mode_directed_array(tab_ent);
int* n_vars_operator_array = NULL;
int j, old_subs_arity=0;
if(mode_directed_array)
ALLOC_BLOCK(n_vars_operator_array,pred_arity*sizeof(int),int);
// ALLOC_BLOCK(number_vars,sizeof(int),int);
//for(i=0;i<pred_arity;i++)
// printf("sub_search %p\n",mode_directed_array[i]);
#endif /*MODE_DIRECTED_TABLING*/
mode_directed = TabEnt_mode_directed(tab_ent);
if (mode_directed) {
int old_subs_arity = subs_arity;
for (i = 1; i <= pred_arity; i++) {
int j = MODE_DIRECTED_GET_ARG(mode_directed[i-1]) + 1;
current_sg_node = subgoal_search_loop(tab_ent, current_sg_node, Deref(XREGS[j]), &subs_arity, &stack_vars);
if (subs_arity != old_subs_arity) {
if (subs_pos && MODE_DIRECTED_GET_MODE(aux_mode_directed[subs_pos-1]) == MODE_DIRECTED_GET_MODE(mode_directed[i-1])) {
/* same mode as before -> use the current entry in the aux_mode_directed[] array */
aux_mode_directed[subs_pos-1] += MODE_DIRECTED_SET(subs_arity - old_subs_arity, 0);
} else {
/* new mode -> init a new entry in the aux_mode_directed[] array */
aux_mode_directed[subs_pos] = MODE_DIRECTED_SET(subs_arity - old_subs_arity, MODE_DIRECTED_GET_MODE(mode_directed[i-1]));
subs_pos++;
}
old_subs_arity = subs_arity;
}
}
} else
#endif /* MODE_DIRECTED_TABLING */
if (IsMode_GlobalTrie(TabEnt_mode(tab_ent))) {
for (i = 1; i <= pred_arity; i++)
current_sg_node = subgoal_search_terms_loop(tab_ent, current_sg_node, Deref(XREGS[i]), &subs_arity, &stack_vars);
} else {
for (i = 1; i <= pred_arity; i++){
#ifdef MODE_DIRECTED_TABLING
if(mode_directed_array){
j = MODE_DIRECTED_index(mode_directed_array[i-1])+1;
}
else
j = i;
current_sg_node = subgoal_search_loop(tab_ent, current_sg_node, Deref(XREGS[j]), &subs_arity, &stack_vars);
if(mode_directed_array){
n_vars_operator_array[i-1] = subs_arity - old_subs_arity;
//printf("vars %d\n", subs_arity);
old_subs_arity = subs_arity;
n_vars_operator_array[i-1] = (n_vars_operator_array[i-1]<< MODE_DIRECTED_TAGBITS) + MODE_DIRECTED_operator(mode_directed_array[i-1]);
}
#else
for (i = 1; i <= pred_arity; i++)
current_sg_node = subgoal_search_loop(tab_ent, current_sg_node, Deref(XREGS[i]), &subs_arity, &stack_vars);
#endif /*MODE_DIRECTED_TABLING*/
}
}
STACK_PUSH_UP(subs_arity, stack_vars);
@ -1474,19 +1032,18 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
Term t = STACK_POP_DOWN(stack_vars);
RESET_VARIABLE(t);
}
// for(i=0;i<pred_arity;i++)
//printf("2sub_search %p\n",n_vars_operator_array[i]);
#if defined(TABLE_LOCK_AT_NODE_LEVEL)
LOCK(TrNode_lock(current_sg_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
LOCK_TABLE(current_sg_node);
#endif /* TABLE_LOCK_LEVEL */
LOCK_SUBGOAL_NODE(current_sg_node);
if (TrNode_sg_fr(current_sg_node) == NULL) {
/* new tabled subgoal */
#ifdef MODE_DIRECTED_TABLING
new_subgoal_frame(sg_fr, preg,n_vars_operator_array);
#endif /*MODE_DIRECTED_TABLING*/
if (subs_pos) {
ALLOC_BLOCK(mode_directed, subs_pos*sizeof(int), int);
memcpy((void *)mode_directed, (void *)aux_mode_directed, subs_pos*sizeof(int));
} else
mode_directed = NULL;
#endif /* MODE_DIRECTED_TABLING */
new_subgoal_frame(sg_fr, preg, mode_directed);
TrNode_sg_fr(current_sg_node) = (sg_node_ptr) sg_fr;
TAG_AS_SUBGOAL_LEAF_NODE(current_sg_node);
} else {
@ -1497,13 +1054,8 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
}
#endif /* LIMIT_TABLING */
}
#if defined(TABLE_LOCK_AT_ENTRY_LEVEL)
UNLOCK(TabEnt_lock(tab_ent));
#elif defined(TABLE_LOCK_AT_NODE_LEVEL)
UNLOCK(TrNode_lock(current_sg_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
UNLOCK_TABLE(current_sg_node);
#endif /* TABLE_LOCK_LEVEL */
UNLOCK_SUBGOAL_NODE(current_sg_node);
UNLOCK_SUBGOAL_TRIE(tab_ent);
return sg_fr;
}
@ -1517,43 +1069,15 @@ ans_node_ptr answer_search(sg_fr_ptr sg_fr, CELL *subs_ptr) {
vars_arity = 0;
current_ans_node = SgFr_answer_trie(sg_fr);
#ifdef MODE_DIRECTED_TABLING
int* n_vars_operator_array = TrNode_mode_directed_array(current_ans_node);
int j=0,n_vars=0, mode=-1;
// for(i=0;i<3;i++)
//printf("sub_search %p\n",n_vars_operator_array[i]);
#endif /*MODE_DIRECTED_TABLING*/
if (IsMode_GlobalTrie(TabEnt_mode(SgFr_tab_ent(sg_fr)))) {
for (i = subs_arity; i >= 1; i--) {
TABLING_ERROR_CHECKING(answer search, IsNonVarTerm(subs_ptr[i]));
TABLING_ERROR_CHECKING(answer_search, IsNonVarTerm(subs_ptr[i]));
current_ans_node = answer_search_terms_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity);
}
} else {
for (i = subs_arity; i >= 1; i--) {
TABLING_ERROR_CHECKING(answer search, IsNonVarTerm(subs_ptr[i]));
#ifdef MODE_DIRECTED_TABLING
if(n_vars_operator_array){
while(!MODE_DIRECTED_n_vars(n_vars_operator_array[j]))
j++;
if(!(n_vars < MODE_DIRECTED_n_vars(n_vars_operator_array[j]))){
j++;
while(!MODE_DIRECTED_n_vars(n_vars_operator_array[j]))
j++;
n_vars = 0;
}
mode = MODE_DIRECTED_operator(n_vars_operator_array[j]);
//printf("operador %d\n",mode);
n_vars++;
}
current_ans_node = answer_search_loop2(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity, mode);
if(current_ans_node == NULL)
break;
#else
TABLING_ERROR_CHECKING(answer_search, IsNonVarTerm(subs_ptr[i]));
current_ans_node = answer_search_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity);
#endif /*MODE_DIRECTED_TABLING*/
}
}
@ -1569,6 +1093,91 @@ ans_node_ptr answer_search(sg_fr_ptr sg_fr, CELL *subs_ptr) {
}
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr mode_directed_answer_search(sg_fr_ptr sg_fr, CELL *subs_ptr) {
#define subs_arity *subs_ptr
CACHE_REGS
CELL *stack_vars;
int i, j, vars_arity;
ans_node_ptr current_ans_node, invalid_ans_node;
int *mode_directed;
vars_arity = 0;
current_ans_node = SgFr_answer_trie(sg_fr);
invalid_ans_node = NULL;
mode_directed = SgFr_mode_directed(sg_fr);
j = 0;
i = subs_arity;
while (i) {
int mode = MODE_DIRECTED_GET_MODE(mode_directed[j]);
int n_subs = MODE_DIRECTED_GET_ARG(mode_directed[j]);
do {
TABLING_ERROR_CHECKING(answer_search, IsNonVarTerm(subs_ptr[i]));
if (mode == MODE_DIRECTED_INDEX || mode == MODE_DIRECTED_ALL) {
current_ans_node = answer_search_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity);
} else {
LOCK_ANSWER_NODE(current_ans_node);
if (TrNode_child(current_ans_node) == NULL) {
#ifdef YAPOR
struct answer_trie_node virtual_ans_node;
ans_node_ptr parent_ans_node = current_ans_node;
TrNode_init_lock_field(&virtual_ans_node);
TrNode_parent(&virtual_ans_node) = NULL;
TrNode_child(&virtual_ans_node) = NULL;
current_ans_node = answer_search_loop(sg_fr, &virtual_ans_node, Deref(subs_ptr[i]), &vars_arity);
TrNode_child(parent_ans_node) = TrNode_child(&virtual_ans_node);
#else
current_ans_node = answer_search_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity);
#endif /* YAPOR */
} else if (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX) {
ans_node_ptr parent_ans_node = current_ans_node;
invalid_ans_node = TrNode_child(parent_ans_node); /* by default, assume a better answer */
current_ans_node = answer_search_min_max(sg_fr, current_ans_node, Deref(subs_ptr[i]), mode);
if (invalid_ans_node == TrNode_child(parent_ans_node)) /* worse or equal answer */
invalid_ans_node = NULL;
} else if (mode == MODE_DIRECTED_FIRST)
current_ans_node = NULL;
else { /* mode == MODE_DIRECTED_LAST */
#ifdef YAPOR
struct answer_trie_node virtual_ans_node;
ans_node_ptr parent_ans_node = current_ans_node;
invalid_ans_node = TrNode_child(parent_ans_node);
TrNode_init_lock_field(&virtual_ans_node);
TrNode_parent(&virtual_ans_node) = NULL;
TrNode_child(&virtual_ans_node) = NULL;
current_ans_node = answer_search_loop(sg_fr, &virtual_ans_node, Deref(subs_ptr[i]), &vars_arity);
TrNode_child(parent_ans_node) = TrNode_child(&virtual_ans_node);
#else
invalid_ans_node = TrNode_child(current_ans_node);
TrNode_child(current_ans_node) = NULL;
current_ans_node = answer_search_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity);
#endif /* YAPOR */
}
UNLOCK_ANSWER_NODE(current_ans_node);
}
n_subs--;
i--;
} while (n_subs && current_ans_node);
if (current_ans_node == NULL) /* no answer inserted */
break;
j++;
}
if (invalid_ans_node)
invalidate_answer_trie(invalid_ans_node, sg_fr, TRAVERSE_POSITION_FIRST);
/* reset variables */
stack_vars = (CELL *) TR;
while (vars_arity--) {
Term t = STACK_POP_DOWN(stack_vars);
RESET_VARIABLE(t);
}
return current_ans_node;
#undef subs_arity
}
#endif /* MODE_DIRECTED_TABLING */
void load_answer(ans_node_ptr current_ans_node, CELL *subs_ptr) {
CACHE_REGS
#define subs_arity *subs_ptr
@ -1671,6 +1280,18 @@ void free_subgoal_trie(sg_node_ptr current_node, int mode, int position) {
if (TrNode_child(ans_node))
free_answer_trie(TrNode_child(ans_node), TRAVERSE_MODE_NORMAL, TRAVERSE_POSITION_FIRST);
FREE_ANSWER_TRIE_NODE(ans_node);
#if defined(MODE_DIRECTED_TABLING) && defined(YAPOR)
if (SgFr_invalid_chain(sg_fr)) {
ans_node_ptr next_node, invalid_node = SgFr_invalid_chain(sg_fr);
SgFr_invalid_chain(sg_fr) = NULL;
/* free invalid answer nodes */
while (invalid_node) {
next_node = TrNode_next(invalid_node);
FREE_ANSWER_TRIE_NODE(invalid_node);
invalid_node = next_node;
}
}
#endif /* MODE_DIRECTED_TABLING && YAPOR */
#ifdef LIMIT_TABLING
remove_from_global_sg_fr_list(sg_fr);
#endif /* LIMIT_TABLING */
@ -1814,10 +1435,37 @@ void show_table(tab_ent_ptr tab_ent, int show_mode, IOSTREAM *out) {
#endif /* TABLING_INNER_CUTS */
TrStat_ans_nodes = 0;
TrStat_gt_refs = 0;
Sfprintf(TrStat_out, "Table statistics for predicate '%s/%d'\n", AtomName(TabEnt_atom(tab_ent)), TabEnt_arity(tab_ent));
Sfprintf(TrStat_out, "Table statistics for predicate '%s", AtomName(TabEnt_atom(tab_ent)));
} else { /* SHOW_MODE_STRUCTURE */
Sfprintf(TrStat_out, "Table structure for predicate '%s/%d'\n", AtomName(TabEnt_atom(tab_ent)), TabEnt_arity(tab_ent));
Sfprintf(TrStat_out, "Table structure for predicate '%s", AtomName(TabEnt_atom(tab_ent)));
}
#ifdef MODE_DIRECTED_TABLING
if (TabEnt_mode_directed(tab_ent)) {
int i, *mode_directed = TabEnt_mode_directed(tab_ent);
Sfprintf(TrStat_out, "(");
for (i = 0; i < TabEnt_arity(tab_ent); i++) {
int mode = MODE_DIRECTED_GET_MODE(mode_directed[i]);
if (mode == MODE_DIRECTED_INDEX) {
Sfprintf(TrStat_out, "index");
} else if (mode == MODE_DIRECTED_FIRST) {
Sfprintf(TrStat_out, "first");
} else if (mode == MODE_DIRECTED_ALL) {
Sfprintf(TrStat_out, "all");
} else if (mode == MODE_DIRECTED_MAX) {
Sfprintf(TrStat_out, "max");
} else if (mode == MODE_DIRECTED_MIN) {
Sfprintf(TrStat_out, "min");
} else /* MODE_DIRECTED_LAST */
Sfprintf(TrStat_out, "last");
if (i != MODE_DIRECTED_GET_ARG(mode_directed[i]))
Sfprintf(TrStat_out, "(ARG%d)", MODE_DIRECTED_GET_ARG(mode_directed[i]) + 1);
if (i + 1 != TabEnt_arity(tab_ent))
Sfprintf(TrStat_out, ",");
}
Sfprintf(TrStat_out, ")'\n");
} else
#endif /* MODE_DIRECTED_TABLING */
Sfprintf(TrStat_out, "/%d'\n", TabEnt_arity(tab_ent));
sg_node = TrNode_child(TabEnt_subgoal_trie(tab_ent));
if (sg_node) {
if (TabEnt_arity(tab_ent)) {

603
OPTYap/tab.tries.i
View File

@ -15,15 +15,6 @@
** Macros **
*********************/
#undef INCREMENT_GLOBAL_TRIE_REFERENCE
#undef NEW_SUBGOAL_TRIE_NODE
#undef NEW_ANSWER_TRIE_NODE
#undef NEW_GLOBAL_TRIE_NODE
#undef SUBGOAL_CHECK_INSERT_ENTRY
#undef ANSWER_CHECK_INSERT_ENTRY
#undef LOCK_NODE
#undef UNLOCK_NODE
#ifdef MODE_GLOBAL_TRIE_ENTRY
#define INCREMENT_GLOBAL_TRIE_REFERENCE(ENTRY) \
{ register gt_node_ptr entry_node = (gt_node_ptr) (ENTRY); \
@ -61,25 +52,13 @@
#endif /* MODE_GLOBAL_TRIE_LOOP */
#if defined(TABLE_LOCK_AT_WRITE_LEVEL)
#define LOCK_NODE(NODE) LOCK_TABLE(NODE)
#define UNLOCK_NODE(NODE) UNLOCK_TABLE(NODE)
#elif defined(TABLE_LOCK_AT_NODE_LEVEL)
#define LOCK_NODE(NODE) TRIE_LOCK(TrNode_lock(NODE))
#define UNLOCK_NODE(NODE) UNLOCK(TrNode_lock(NODE))
#else /* TABLE_LOCK_AT_ENTRY_LEVEL || ! YAPOR */
#define LOCK_NODE(NODE)
#define UNLOCK_NODE(NODE)
#endif /* TABLE_LOCK_LEVEL */
/************************************************************************
** subgoal_trie_check_insert_(gt)_entry **
************************************************************************/
#ifdef INCLUDE_SUBGOAL_TRIE_CHECK_INSERT
#ifndef TABLE_LOCK_AT_WRITE_LEVEL /* TABLE_LOCK_AT_ENTRY_LEVEL || TABLE_LOCK_AT_NODE_LEVEL || ! YAPOR */
#ifndef SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL /* SUBGOAL_TRIE_LOCK_AT_ENTRY_LEVEL || SUBGOAL_TRIE_LOCK_AT_NODE_LEVEL || ! YAPOR */
#ifdef MODE_GLOBAL_TRIE_ENTRY
static inline sg_node_ptr subgoal_trie_check_insert_gt_entry(tab_ent_ptr tab_ent, sg_node_ptr parent_node, Term t) {
#else
@ -87,12 +66,12 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
#endif /* MODE_GLOBAL_TRIE_ENTRY */
sg_node_ptr child_node;
LOCK_NODE(parent_node);
LOCK_SUBGOAL_NODE(parent_node);
child_node = TrNode_child(parent_node);
if (child_node == NULL) {
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, NULL);
TrNode_child(parent_node) = child_node;
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
@ -100,7 +79,7 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
int count_nodes = 0;
do {
if (TrNode_entry(child_node) == t) {
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
count_nodes++;
@ -125,7 +104,7 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
} else {
TrNode_child(parent_node) = child_node;
}
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
@ -138,7 +117,7 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
child_node = *bucket;
while (child_node) {
if (TrNode_entry(child_node) == t) {
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
count_nodes++;
@ -171,11 +150,11 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
} while (old_bucket != first_old_bucket);
FREE_HASH_BUCKETS(first_old_bucket);
}
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
}
#else /* TABLE_LOCK_AT_WRITE_LEVEL */
#else /* SUBGOAL_TRIE_LOCK_AT_WRITE_LEVEL */
#ifdef MODE_GLOBAL_TRIE_ENTRY
static inline sg_node_ptr subgoal_trie_check_insert_gt_entry(tab_ent_ptr tab_ent, sg_node_ptr parent_node, Term t) {
#else
@ -186,40 +165,40 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
child_node = TrNode_child(parent_node);
if (child_node == NULL) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, NULL);
#endif /* ALLOC_BEFORE_CHECK */
LOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
LOCK_SUBGOAL_NODE(parent_node);
if (TrNode_child(parent_node)) {
sg_node_ptr chain_node = TrNode_child(parent_node);
if (IS_SUBGOAL_TRIE_HASH(chain_node)) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
FREE_SUBGOAL_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_SUBGOAL_NODE(parent_node);
hash = (sg_hash_ptr) chain_node;
goto subgoal_trie_hash;
}
do {
if (TrNode_entry(chain_node) == t) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
FREE_SUBGOAL_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_SUBGOAL_NODE(parent_node);
return chain_node;
}
chain_node = TrNode_next(chain_node);
} while (chain_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = TrNode_child(parent_node);
#else
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, TrNode_child(parent_node));
} else {
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, NULL);
#endif /* ALLOC_BEFORE_CHECK */
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
}
TrNode_child(parent_node) = child_node;
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
@ -227,44 +206,43 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
sg_node_ptr first_node = child_node;
int count_nodes = 0;
do {
if (TrNode_entry(child_node) == t) {
if (TrNode_entry(child_node) == t)
return child_node;
}
count_nodes++;
child_node = TrNode_next(child_node);
} while (child_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
LOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
LOCK_SUBGOAL_NODE(parent_node);
if (first_node != TrNode_child(parent_node)) {
sg_node_ptr chain_node = TrNode_child(parent_node);
if (IS_SUBGOAL_TRIE_HASH(chain_node)) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
FREE_SUBGOAL_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_SUBGOAL_NODE(parent_node);
hash = (sg_hash_ptr) chain_node;
goto subgoal_trie_hash;
}
do {
if (TrNode_entry(chain_node) == t) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
FREE_SUBGOAL_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_SUBGOAL_NODE(parent_node);
return chain_node;
}
count_nodes++;
chain_node = TrNode_next(chain_node);
} while (chain_node != first_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = TrNode_child(parent_node);
#else
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, TrNode_child(parent_node));
} else {
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
}
count_nodes++;
if (count_nodes >= MAX_NODES_PER_TRIE_LEVEL) {
@ -283,7 +261,7 @@ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr tab_ent, s
} else {
TrNode_child(parent_node) = child_node;
}
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
@ -297,44 +275,43 @@ subgoal_trie_hash:
bucket = Hash_bucket(hash, HASH_ENTRY(t, seed));
first_node = child_node = *bucket;
while (child_node) {
if (TrNode_entry(child_node) == t) {
if (TrNode_entry(child_node) == t)
return child_node;
}
count_nodes++;
child_node = TrNode_next(child_node);
}
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
LOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
LOCK_SUBGOAL_NODE(parent_node);
if (seed != Hash_seed(hash)) {
/* the hash has been expanded */
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
FREE_SUBGOAL_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_SUBGOAL_NODE(parent_node);
goto subgoal_trie_hash;
}
if (first_node != *bucket) {
sg_node_ptr chain_node = *bucket;
do {
if (TrNode_entry(chain_node) == t) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
FREE_SUBGOAL_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_SUBGOAL_NODE(parent_node);
return chain_node;
}
count_nodes++;
chain_node = TrNode_next(chain_node);
} while (chain_node != first_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef SUBGOAL_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = *bucket;
#else
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, *bucket);
} else {
NEW_SUBGOAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
#endif /* SUBGOAL_TRIE_ALLOC_BEFORE_CHECK */
}
*bucket = child_node;
Hash_num_nodes(hash)++;
@ -361,11 +338,11 @@ subgoal_trie_hash:
} while (old_bucket != first_old_bucket);
FREE_HASH_BUCKETS(first_old_bucket);
}
UNLOCK_NODE(parent_node);
UNLOCK_SUBGOAL_NODE(parent_node);
return child_node;
}
}
#endif /* TABLE_LOCK_LEVEL */
#endif /* SUBGOAL_TRIE_LOCK_LEVEL */
#endif /* INCLUDE_SUBGOAL_TRIE_CHECK_INSERT */
@ -375,7 +352,7 @@ subgoal_trie_hash:
************************************************************************/
#ifdef INCLUDE_ANSWER_TRIE_CHECK_INSERT
#ifndef TABLE_LOCK_AT_WRITE_LEVEL /* TABLE_LOCK_AT_ENTRY_LEVEL || TABLE_LOCK_AT_NODE_LEVEL || ! YAPOR */
#ifndef ANSWER_TRIE_LOCK_AT_WRITE_LEVEL /* ANSWER_TRIE_LOCK_AT_ENTRY_LEVEL || ANSWER_TRIE_LOCK_AT_NODE_LEVEL || ! YAPOR */
#ifdef MODE_GLOBAL_TRIE_ENTRY
static inline ans_node_ptr answer_trie_check_insert_gt_entry(sg_fr_ptr sg_fr, ans_node_ptr parent_node, Term t, int instr) {
#else
@ -384,12 +361,12 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
ans_node_ptr child_node;
TABLING_ERROR_CHECKING(answer_trie_check_insert_(gt)_entry, IS_ANSWER_LEAF_NODE(parent_node));
LOCK_NODE(parent_node);
LOCK_ANSWER_NODE(parent_node);
child_node = TrNode_child(parent_node);
if (child_node == NULL) {
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, NULL);
TrNode_child(parent_node) = child_node;
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
@ -397,7 +374,7 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
int count_nodes = 0;
do {
if (TrNode_entry(child_node) == t) {
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
count_nodes++;
@ -422,7 +399,7 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
} else {
TrNode_child(parent_node) = child_node;
}
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
@ -435,7 +412,7 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
child_node = *bucket;
while (child_node) {
if (TrNode_entry(child_node) == t) {
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
count_nodes++;
@ -468,11 +445,11 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
} while (old_bucket != first_old_bucket);
FREE_HASH_BUCKETS(first_old_bucket);
}
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
}
#else
#else /* ANSWER_TRIE_LOCK_AT_WRITE_LEVEL */
#ifdef MODE_GLOBAL_TRIE_ENTRY
static inline ans_node_ptr answer_trie_check_insert_gt_entry(sg_fr_ptr sg_fr, ans_node_ptr parent_node, Term t, int instr) {
#else
@ -484,40 +461,40 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
TABLING_ERROR_CHECKING(answer_trie_check_insert_(gt)_entry, IS_ANSWER_LEAF_NODE(parent_node));
child_node = TrNode_child(parent_node);
if (child_node == NULL) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, NULL);
#endif /* ALLOC_BEFORE_CHECK */
LOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
LOCK_ANSWER_NODE(parent_node);
if (TrNode_child(parent_node)) {
ans_node_ptr chain_node = TrNode_child(parent_node);
if (IS_ANSWER_TRIE_HASH(chain_node)) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
FREE_ANSWER_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_ANSWER_NODE(parent_node);
hash = (ans_hash_ptr) chain_node;
goto answer_trie_hash;
}
do {
if (TrNode_entry(chain_node) == t) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
FREE_ANSWER_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_ANSWER_NODE(parent_node);
return chain_node;
}
chain_node = TrNode_next(chain_node);
} while (chain_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = TrNode_child(parent_node);
#else
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, TrNode_child(parent_node));
} else {
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, NULL);
#endif /* ALLOC_BEFORE_CHECK */
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
}
TrNode_child(parent_node) = child_node;
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
@ -525,44 +502,43 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
ans_node_ptr first_node = child_node;
int count_nodes = 0;
do {
if (TrNode_entry(child_node) == t) {
if (TrNode_entry(child_node) == t)
return child_node;
}
count_nodes++;
child_node = TrNode_next(child_node);
} while (child_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
LOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
LOCK_ANSWER_NODE(parent_node);
if (first_node != TrNode_child(parent_node)) {
ans_node_ptr chain_node = TrNode_child(parent_node);
if (IS_ANSWER_TRIE_HASH(chain_node)) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
FREE_ANSWER_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_ANSWER_NODE(parent_node);
hash = (ans_hash_ptr) chain_node;
goto answer_trie_hash;
}
do {
if (TrNode_entry(chain_node) == t) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
FREE_ANSWER_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_ANSWER_NODE(parent_node);
return chain_node;
}
count_nodes++;
chain_node = TrNode_next(chain_node);
} while (chain_node != first_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = TrNode_child(parent_node);
#else
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, TrNode_child(parent_node));
} else {
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
}
count_nodes++;
if (count_nodes >= MAX_NODES_PER_TRIE_LEVEL) {
@ -581,7 +557,7 @@ static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr sg_fr, ans_n
} else {
TrNode_child(parent_node) = child_node;
}
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
@ -595,44 +571,43 @@ answer_trie_hash:
bucket = Hash_bucket(hash, HASH_ENTRY(t, seed));
first_node = child_node = *bucket;
while (child_node) {
if (TrNode_entry(child_node) == t) {
if (TrNode_entry(child_node) == t)
return child_node;
}
count_nodes++;
child_node = TrNode_next(child_node);
}
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
LOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
LOCK_ANSWER_NODE(parent_node);
if (seed != Hash_seed(hash)) {
/* the hash has been expanded */
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
FREE_ANSWER_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_ANSWER_NODE(parent_node);
goto answer_trie_hash;
}
if (first_node != *bucket) {
ans_node_ptr chain_node = *bucket;
do {
if (TrNode_entry(chain_node) == t) {
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
FREE_ANSWER_TRIE_NODE(child_node);
#endif /* ALLOC_BEFORE_CHECK */
UNLOCK_NODE(parent_node);
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_ANSWER_NODE(parent_node);
return chain_node;
}
count_nodes++;
chain_node = TrNode_next(chain_node);
} while (chain_node != first_node);
#ifdef ALLOC_BEFORE_CHECK
#ifdef ANSWER_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = *bucket;
#else
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, *bucket);
} else {
NEW_ANSWER_TRIE_NODE(child_node, instr, t, NULL, parent_node, first_node);
#endif /* ALLOC_BEFORE_CHECK */
#endif /* ANSWER_TRIE_ALLOC_BEFORE_CHECK */
}
*bucket = child_node;
Hash_num_nodes(hash)++;
@ -659,11 +634,11 @@ answer_trie_hash:
} while (old_bucket != first_old_bucket);
FREE_HASH_BUCKETS(first_old_bucket);
}
UNLOCK_NODE(parent_node);
UNLOCK_ANSWER_NODE(parent_node);
return child_node;
}
}
#endif /* TABLE_LOCK_LEVEL */
#endif /* ANSWER_TRIE_LOCK_LEVEL */
#endif /* INCLUDE_ANSWER_TRIE_CHECK_INSERT */
@ -673,6 +648,7 @@ answer_trie_hash:
************************************************************************/
#ifdef INCLUDE_GLOBAL_TRIE_CHECK_INSERT
#ifndef GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL /* GLOBAL_TRIE_LOCK_AT_NODE_LEVEL || ! YAPOR */
#ifdef MODE_GLOBAL_TRIE_ENTRY
static inline gt_node_ptr global_trie_check_insert_gt_entry(gt_node_ptr parent_node, Term t) {
#else
@ -680,12 +656,12 @@ static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr parent_node
#endif /* MODE_GLOBAL_TRIE_ENTRY */
gt_node_ptr child_node;
LOCK_NODE(parent_node);
LOCK_GLOBAL_NODE(parent_node);
child_node = TrNode_child(parent_node);
if (child_node == NULL) {
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, NULL);
TrNode_child(parent_node) = child_node;
UNLOCK_NODE(parent_node);
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
@ -693,7 +669,7 @@ static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr parent_node
int count_nodes = 0;
do {
if (TrNode_entry(child_node) == t) {
UNLOCK_NODE(parent_node);
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
count_nodes++;
@ -718,7 +694,7 @@ static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr parent_node
} else {
TrNode_child(parent_node) = child_node;
}
UNLOCK_NODE(parent_node);
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
@ -731,7 +707,7 @@ static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr parent_node
child_node = *bucket;
while (child_node) {
if (TrNode_entry(child_node) == t) {
UNLOCK_NODE(parent_node);
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
count_nodes++;
@ -764,10 +740,199 @@ static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr parent_node
} while (old_bucket != first_old_bucket);
FREE_HASH_BUCKETS(first_old_bucket);
}
UNLOCK_NODE(parent_node);
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
}
#else /* GLOBAL_TRIE_LOCK_AT_WRITE_LEVEL */
#ifdef MODE_GLOBAL_TRIE_ENTRY
static inline gt_node_ptr global_trie_check_insert_gt_entry(gt_node_ptr parent_node, Term t) {
#else
static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr parent_node, Term t) {
#endif /* MODE_GLOBAL_TRIE_ENTRY */
gt_node_ptr child_node;
gt_hash_ptr hash;
child_node = TrNode_child(parent_node);
if (child_node == NULL) {
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, NULL);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
LOCK_GLOBAL_NODE(parent_node);
if (TrNode_child(parent_node)) {
gt_node_ptr chain_node = TrNode_child(parent_node);
if (IS_GLOBAL_TRIE_HASH(chain_node)) {
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
FREE_GLOBAL_TRIE_NODE(child_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_GLOBAL_NODE(parent_node);
hash = (gt_hash_ptr) chain_node;
goto global_trie_hash;
}
do {
if (TrNode_entry(chain_node) == t) {
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
FREE_GLOBAL_TRIE_NODE(child_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_GLOBAL_NODE(parent_node);
return chain_node;
}
chain_node = TrNode_next(chain_node);
} while (chain_node);
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = TrNode_child(parent_node);
#else
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, TrNode_child(parent_node));
} else {
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, NULL);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
}
TrNode_child(parent_node) = child_node;
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
if (! IS_GLOBAL_TRIE_HASH(child_node)) {
gt_node_ptr first_node = child_node;
int count_nodes = 0;
do {
if (TrNode_entry(child_node) == t)
return child_node;
count_nodes++;
child_node = TrNode_next(child_node);
} while (child_node);
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
LOCK_GLOBAL_NODE(parent_node);
if (first_node != TrNode_child(parent_node)) {
gt_node_ptr chain_node = TrNode_child(parent_node);
if (IS_GLOBAL_TRIE_HASH(chain_node)) {
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
FREE_GLOBAL_TRIE_NODE(child_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_GLOBAL_NODE(parent_node);
hash = (gt_hash_ptr) chain_node;
goto global_trie_hash;
}
do {
if (TrNode_entry(chain_node) == t) {
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
FREE_GLOBAL_TRIE_NODE(child_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_GLOBAL_NODE(parent_node);
return chain_node;
}
count_nodes++;
chain_node = TrNode_next(chain_node);
} while (chain_node != first_node);
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = TrNode_child(parent_node);
#else
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, TrNode_child(parent_node));
} else {
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
}
count_nodes++;
if (count_nodes >= MAX_NODES_PER_TRIE_LEVEL) {
/* alloc a new hash */
gt_node_ptr chain_node, next_node, *bucket;
new_answer_trie_hash(hash, count_nodes, sg_fr);
chain_node = child_node;
do {
bucket = Hash_bucket(hash, HASH_ENTRY(TrNode_entry(chain_node), BASE_HASH_BUCKETS - 1));
next_node = TrNode_next(chain_node);
TrNode_next(chain_node) = *bucket;
*bucket = chain_node;
chain_node = next_node;
} while (chain_node);
TrNode_child(parent_node) = (gt_node_ptr) hash;
} else {
TrNode_child(parent_node) = child_node;
}
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
hash = (gt_hash_ptr) child_node;
global_trie_hash:
{ /* trie nodes with hashing */
gt_node_ptr *bucket, first_node;
int seed, count_nodes = 0;
seed = Hash_seed(hash);
bucket = Hash_bucket(hash, HASH_ENTRY(t, seed));
first_node = child_node = *bucket;
while (child_node) {
if (TrNode_entry(child_node) == t)
return child_node;
count_nodes++;
child_node = TrNode_next(child_node);
}
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
LOCK_GLOBAL_NODE(parent_node);
if (seed != Hash_seed(hash)) {
/* the hash has been expanded */
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
FREE_GLOBAL_TRIE_NODE(child_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_GLOBAL_NODE(parent_node);
goto global_trie_hash;
}
if (first_node != *bucket) {
gt_node_ptr chain_node = *bucket;
do {
if (TrNode_entry(chain_node) == t) {
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
FREE_GLOBAL_TRIE_NODE(child_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
UNLOCK_GLOBAL_NODE(parent_node);
return chain_node;
}
count_nodes++;
chain_node = TrNode_next(chain_node);
} while (chain_node != first_node);
#ifdef GLOBAL_TRIE_ALLOC_BEFORE_CHECK
TrNode_next(child_node) = *bucket;
#else
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, *bucket);
} else {
NEW_GLOBAL_TRIE_NODE(child_node, t, NULL, parent_node, first_node);
#endif /* GLOBAL_TRIE_ALLOC_BEFORE_CHECK */
}
*bucket = child_node;
Hash_num_nodes(hash)++;
count_nodes++;
if (count_nodes >= MAX_NODES_PER_BUCKET && Hash_num_nodes(hash) > Hash_num_buckets(hash)) {
/* expand current hash */
gt_node_ptr chain_node, next_node, *first_old_bucket, *old_bucket;
first_old_bucket = Hash_buckets(hash);
old_bucket = first_old_bucket + Hash_num_buckets(hash);
Hash_num_buckets(hash) *= 2;
ALLOC_HASH_BUCKETS(Hash_buckets(hash), Hash_num_buckets(hash));
seed = Hash_seed(hash);
do {
if (*--old_bucket) {
chain_node = *old_bucket;
do {
bucket = Hash_bucket(hash, HASH_ENTRY(TrNode_entry(chain_node), seed));
next_node = TrNode_next(chain_node);
TrNode_next(chain_node) = *bucket;
*bucket = chain_node;
chain_node = next_node;
} while (chain_node);
}
} while (old_bucket != first_old_bucket);
FREE_HASH_BUCKETS(first_old_bucket);
}
UNLOCK_GLOBAL_NODE(parent_node);
return child_node;
}
}
#endif /* GLOBAL_TRIE_LOCK_LEVEL */
#endif /* INCLUDE_GLOBAL_TRIE_CHECK_INSERT */
@ -1068,7 +1233,7 @@ static inline ans_node_ptr answer_search_loop(sg_fr_ptr sg_fr, ans_node_ptr curr
stack_vars_base[vars_arity] = t;
*((CELL *)t) = GLOBAL_table_var_enumerator(vars_arity);
t = MakeTableVarTerm(vars_arity);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_var + in_pair);
vars_arity = vars_arity + 1;
}
#ifdef TRIE_COMPACT_PAIRS
@ -1103,7 +1268,7 @@ static inline ans_node_ptr answer_search_loop(sg_fr_ptr sg_fr, ans_node_ptr curr
aux_pair = RepPair(t);
t = Deref(aux_pair[1]);
if (t == TermNil) {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair);
} else {
/* AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 2); */
/* AUX_STACK_CHECK_EXPAND is not necessary here because the situation of pushing **
@ -1208,6 +1373,177 @@ static inline ans_node_ptr answer_search_loop(sg_fr_ptr sg_fr, ans_node_ptr curr
/**************************************************************
** answer_search_min_max **
**************************************************************/
#ifdef INCLUDE_ANSWER_SEARCH_MODE_DIRECTED
#define ANSWER_SAFE_INSERT_ENTRY(NODE, ENTRY, INSTR) \
{ ans_node_ptr new_node; \
NEW_ANSWER_TRIE_NODE(new_node, INSTR, ENTRY, NULL, NODE, NULL); \
TrNode_child(NODE) = new_node; \
NODE = new_node; \
}
static inline ans_node_ptr answer_search_min_max(sg_fr_ptr sg_fr, ans_node_ptr current_node, Term t, int mode) {
ans_node_ptr child_node;
Term child_term;
Float trie_value, term_value;
/* start by computing the current value on the trie (trie_value) */
child_node = TrNode_child(current_node);
child_term = TrNode_entry(child_node);
if (IsIntTerm(child_term)) {
trie_value = (Float) IntOfTerm(child_term);
} else if (IsApplTerm(child_term)) {
Functor f = (Functor) RepAppl(child_term);
child_node = TrNode_child(child_node);
if (f == FunctorLongInt) {
trie_value = (Float) TrNode_entry(child_node);
} else if (f == FunctorDouble) {
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} u;
u.t_dbl[0] = TrNode_entry(child_node);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
child_node = TrNode_child(child_node);
u.t_dbl[1] = TrNode_entry(child_node);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
trie_value = u.dbl;
} else
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_min_max: invalid arithmetic value");
child_node = TrNode_child(child_node);
}
/* then compute the value for the new term (term_value) */
if (IsAtomOrIntTerm(t))
term_value = (Float) IntOfTerm(t);
else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
if (f == FunctorLongInt)
term_value = (Float) LongIntOfTerm(t);
else if (f == FunctorDouble)
term_value = FloatOfTerm(t);
else
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_min_max: invalid arithmetic value");
}
/* worse answer */
if ((mode == MODE_DIRECTED_MIN && term_value > trie_value) || (mode == MODE_DIRECTED_MAX && term_value < trie_value))
return NULL;
/* equal answer */
if (term_value == trie_value)
return child_node;
/* better answer */
if (IsAtomOrIntTerm(t)) {
ANSWER_SAFE_INSERT_ENTRY(current_node, t, _trie_retry_atom);
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
if (f == FunctorDouble) {
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} u;
u.dbl = FloatOfTerm(t);
ANSWER_SAFE_INSERT_ENTRY(current_node, AbsAppl((Term *)f), _trie_retry_null);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_SAFE_INSERT_ENTRY(current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_SAFE_INSERT_ENTRY(current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_SAFE_INSERT_ENTRY(current_node, AbsAppl((Term *)f), _trie_retry_double);
} else if (f == FunctorLongInt) {
Int li = LongIntOfTerm(t);
ANSWER_SAFE_INSERT_ENTRY(current_node, AbsAppl((Term *)f), _trie_retry_null);
ANSWER_SAFE_INSERT_ENTRY(current_node, li, _trie_retry_extension);
ANSWER_SAFE_INSERT_ENTRY(current_node, AbsAppl((Term *)f), _trie_retry_longint);
}
}
return current_node;
}
#endif /* INCLUDE_ANSWER_SEARCH_MODE_DIRECTED */
/***************************************************************
** invalidate_answer_trie **
***************************************************************/
#ifdef INCLUDE_ANSWER_SEARCH_MODE_DIRECTED
#ifdef YAPOR
#define INVALIDATE_ANSWER_TRIE_NODE(NODE, SG_FR) \
TrNode_next(NODE) = SgFr_invalid_chain(SG_FR); \
SgFr_invalid_chain(SG_FR) = NODE
#else
#define INVALIDATE_ANSWER_TRIE_NODE(NODE, SG_FR) \
FREE_ANSWER_TRIE_NODE(NODE)
#endif /* YAPOR */
#define INVALIDATE_ANSWER_TRIE_LEAF_NODE(NODE, SG_FR) \
TAG_AS_INVALID_LEAF_NODE(NODE); \
TrNode_next(NODE) = SgFr_invalid_chain(SG_FR); \
SgFr_invalid_chain(SG_FR) = NODE
static void invalidate_answer_trie(ans_node_ptr current_node, sg_fr_ptr sg_fr, int position) {
if (IS_ANSWER_TRIE_HASH(current_node)) {
ans_hash_ptr hash;
ans_node_ptr *bucket, *last_bucket;
hash = (ans_hash_ptr) current_node;
bucket = Hash_buckets(hash);
last_bucket = bucket + Hash_num_buckets(hash);
do {
current_node = *bucket;
if (current_node) {
ans_node_ptr next_node = TrNode_next(current_node);
if (IS_ANSWER_LEAF_NODE(current_node)) {
INVALIDATE_ANSWER_TRIE_LEAF_NODE(current_node, sg_fr);
} else {
invalidate_answer_trie(TrNode_child(current_node), sg_fr, TRAVERSE_POSITION_FIRST);
INVALIDATE_ANSWER_TRIE_NODE(current_node, sg_fr);
}
while (next_node) {
current_node = next_node;
next_node = TrNode_next(current_node);
invalidate_answer_trie(current_node, sg_fr, TRAVERSE_POSITION_NEXT);
}
}
} while (++bucket != last_bucket);
if (Hash_next(hash))
Hash_previous(Hash_next(hash)) = Hash_previous(hash);
if (Hash_previous(hash))
Hash_next(Hash_previous(hash)) = Hash_next(hash);
else
SgFr_hash_chain(sg_fr) = Hash_next(hash);
FREE_HASH_BUCKETS(Hash_buckets(hash));
FREE_ANSWER_TRIE_HASH(hash);
} else {
if (position == TRAVERSE_POSITION_FIRST) {
ans_node_ptr next_node = TrNode_next(current_node);
if (IS_ANSWER_LEAF_NODE(current_node)) {
INVALIDATE_ANSWER_TRIE_LEAF_NODE(current_node, sg_fr);
} else {
invalidate_answer_trie(TrNode_child(current_node), sg_fr, TRAVERSE_POSITION_FIRST);
INVALIDATE_ANSWER_TRIE_NODE(current_node, sg_fr);
}
while (next_node) {
current_node = next_node;
next_node = TrNode_next(current_node);
invalidate_answer_trie(current_node, sg_fr, TRAVERSE_POSITION_NEXT);
}
} else {
if (IS_ANSWER_LEAF_NODE(current_node)) {
INVALIDATE_ANSWER_TRIE_LEAF_NODE(current_node, sg_fr);
} else {
invalidate_answer_trie(TrNode_child(current_node), sg_fr, TRAVERSE_POSITION_FIRST);
INVALIDATE_ANSWER_TRIE_NODE(current_node, sg_fr);
}
}
}
return;
}
#endif /* INCLUDE_ANSWER_SEARCH_MODE_DIRECTED */
/************************************************************************
** load_(answer|substitution)_loop **
************************************************************************/
@ -1358,3 +1694,16 @@ static inline CELL *load_answer_loop(ans_node_ptr current_node) {
#endif /* TRIE_COMPACT_PAIRS */
}
#endif /* INCLUDE_LOAD_ANSWER_LOOP */
/***************************
** Undef Macros **
***************************/
#undef INCREMENT_GLOBAL_TRIE_REFERENCE
#undef NEW_SUBGOAL_TRIE_NODE
#undef NEW_ANSWER_TRIE_NODE
#undef NEW_GLOBAL_TRIE_NODE
#undef SUBGOAL_CHECK_INSERT_ENTRY
#undef ANSWER_CHECK_INSERT_ENTRY

1260
configure vendored
View File

File diff suppressed because it is too large Load Diff

113
configure.in Normal file → Executable file
View File

@ -58,6 +58,25 @@ AC_SUBST(C_INTERF_FLAGS)
AC_SUBST(C_PARSER_FLAGS)
AC_LANG(C)
AC_CANONICAL_SYSTEM
AC_DEFINE_UNQUOTED(HOST_ALIAS,"${target}")
case "$target_cpu" in
i*86*)
YAP_TARGET=i386
;;
x86*)
YAP_TARGET=amd64
;;
sparc*)
YAP_TARGET=sparc
;;
*)
YAP_TARGET=unknown
;;
esac
dnl Gecode support
AC_CHECK_HEADER(gecode/support/config.hpp,
have_gecode=yes, have_gecode=no)
@ -94,7 +113,7 @@ AC_COMPILE_IFELSE([
AC_ARG_ENABLE(tabling,
[ --enable-tabling support tabling ],
tabling="$enableval", tabling=no)
tabling="$enableval", tabling=yes)
AC_ARG_ENABLE(or-parallelism,
[ --enable-or-parallelism support or-parallelism as: copy,sba,a-cow,threads ],
orparallelism="$enableval", orparallelism=no)
@ -134,6 +153,9 @@ AC_ARG_ENABLE(eam,
AC_ARG_ENABLE(cygwin,
[ --enable-cygwin use cygwin library in WIN32 ],
cygwin="$enableval", cygwin=no)
AC_ARG_ENABLE(prism,
[ --enable-prism use PRISM system in YAP ],
prism="$enableval", prism=yes)
AC_ARG_ENABLE(dynamic_loading,
[ --enable-dynamic-loading compile YAP as a DLL ],
dynamic_loading="$enableval", dynamic_loading=no)
@ -142,7 +164,7 @@ AC_ARG_ENABLE(static_compilation,
static_compilation="$enableval", static_compilation=no)
AC_ARG_ENABLE(use-malloc,
[ --enable-use-malloc use malloc to allocate memory ],
use_malloc="$enableval", use_malloc=no)
use_malloc="$enableval", use_malloc=yes)
AC_ARG_ENABLE(condor,
[ --enable-condor allow YAP to be used from condor ],
use_condor="$enableval", use_condor=no)
@ -190,7 +212,6 @@ AC_ARG_WITH(gmp,
AC_ARG_WITH(yapr,
[ --with-yapr[=DIR] interface to R language, R installed in DIR],
if test "$withval" = yes; then
YAPR_INCLUDES="-I/usr/share/R/include"
yap_cv_yapr=yes
elif test "$withval" = no; then
yap_cv_yapr=no
@ -420,10 +441,6 @@ AC_SUBST(DefHeapSpace)
AC_SUBST(DefStackSpace)
AC_SUBST(DefTrailSpace)
AC_CANONICAL_SYSTEM
AC_DEFINE_UNQUOTED(HOST_ALIAS,"${target}")
if test "$or-parallelism" = no
then
AC_DEFINE(MAX_WORKERS,1)
@ -439,6 +456,13 @@ else
fi
if test "$yap_cv_prism" = no
then
INSTALL_PRISM="@# "
else
INSTALL_PRISM=""
fi
dnl condor does not like dynamic linking on Linux, DEC, and HP-UX platforms.
if test "$yap_cv_matlab" = no
then
@ -693,13 +717,46 @@ then
then
case "$target_os" in
*darwin*)
YAPR_INCLUDES="-I/Library/Frameworks/R.framework/Headers"
EXTRA_LIBS_FOR_DLLS="$EXTRA_LIBS_FOR_DLLS -framework R -L /Library/Frameworks/R.framework/Libraries"
YAPR_INCLUDES="-I/Library/Frameworks/R.framework/Headers"
EXTRA_LIBS_FOR_R="-framework R -L /Library/Frameworks/R.framework/Libraries -lR"
;;
**)
dnl one of the two may work (Fedora vs Ubuntu)
YAPR_INCLUDES="-I/usr/include/R -I/usr/share/R/include"
dnl R is spread all over the place
dnl one of the two may work (Fedora/Ubuntu)
if test -n "$R_HOME" ; then
YAPR_INCLUDES="-I$R_HOME/include"
elif test "$YAP_TARGET" = amd64 -a -d /usr/lib64/R/include ; then
YAPR_INCLUDES="-I/usr/lib64/R/include"
elif test -d /usr/include/R; then
YAPR_INCLUDES="-I/usr/include/R"
elif test -d /usr/share/R/include; then
YAPR_INCLUDES="-I/usr/share/R/include"
fi
echo $YAP_TARGET
if test -n "$R_HOME" ; then
EXTRA_LIBS_FOR_R="-I$R_HOME/lib -lR"
elif test "$YAP_TARGET" = amd64 -a -d /usr/lib64/R/lib; then
EXTRA_LIBS_FOR_R="-L /usr/lib64/R/lib -lR"
elif test -d /usr/lib/R; then
EXTRA_LIBS_FOR_R="-L /usr/lib/R/lib -lR"
fi
;;
esac
else
case "$target_os" in
*cygwin*|*mingw*)
YAPR_INCLUDES="-I\"$yap_cv_yapr/include\""
if test "$YAP_TARGET" = i386; then
EXTRA_LIBS_FOR_R="\"$yap_cv_yapr/bin/i386/R.dll\""
else
EXTRA_LIBS_FOR_R="\"$yap_cv_yapr/bin/x64/R.dll\""
fi
;;
*)
YAPR_INCLUDES="-I$yap_cv_yapr/include"
EXTRA_LIBS_FOR_R="-L $yap_cv_yapr/lib -lR"
;;
esac
fi
AC_CHECK_LIB(R,main)
fi
@ -796,6 +853,13 @@ else
fi
AC_SUBST(ENABLE_GECODE)
if test "$use_prism" = no; then
ENABLE_PRISM="@# "
else
ENABLE_PRISM=""
fi
AC_SUBST(ENABLE_PRISM)
if test "$use_chr" = no; then
ENABLE_CHR="@# "
elif test -e "$srcdir"/packages/chr/Makefile.in; then
@ -898,18 +962,7 @@ elif test -e "$srcdir"/packages/jpl/Makefile.in; then
JAVAINCPATH="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/solaris"
;;
esac
case "$target_cpu" in
i*86*)
JAVA_TARGET=i386
;;
x86*)
JAVA_TARGET=amd64
;;
sparc*)
JAVA_TARGET=sparc
;;
esac
JAVALIBPATH="-L$JAVA_HOME/jre/lib/$JAVA_TARGET -L$JAVA_HOME/jre/lib/$JAVA_TARGET/client -L$JAVA_HOME/jre/lib/$JAVA_TARGET/server -Wl,-R,$JAVA_HOME/jre/lib/$JAVA_TARGET -ljava -lverify -ljvm "
JAVALIBPATH="-L$JAVA_HOME/jre/lib/$YAP_TARGET -L$JAVA_HOME/jre/lib/$YAP_TARGET/client -L$JAVA_HOME/jre/lib/$YAP_TARGET/server -Wl,-R,$JAVA_HOME/jre/lib/$YAP_TARGET -ljava -lverify -ljvm "
;;
esac
if test "$yap_cv_java" = ""; then
@ -1665,8 +1718,10 @@ AC_SUBST(CUDD_CPPFLAGS)
AC_SUBST(ENABLE_MINISAT)
AC_SUBST(ENABLE_YAPR)
AC_SUBST(YAPR_INCLUDES)
AC_SUBST(EXTRA_LIBS_FOR_R)
AC_SUBST(INSTALL_MATLAB)
AC_SUBST(MATLAB_INCLUDE)
AC_SUBST(INSTALL_PRISM)
dnl check for threaded code
AC_MSG_CHECKING(for gcc threaded code)
@ -2163,6 +2218,13 @@ mkdir -p packages/PLStream
mkdir -p packages/PLStream/libtai
mkdir -p packages/pldoc
mkdir -p packages/plunit
mkdir -p packages/prism
mkdir -p packages/prism/src
mkdir -p packages/prism/src/c
mkdir -p packages/prism/src/c/core
mkdir -p packages/prism/src/c/mp
mkdir -p packages/prism/src/c/up
mkdir -p packages/prism/src/prolog
mkdir -p packages/ProbLog
mkdir -p packages/ProbLog/simplecudd
mkdir -p packages/ProbLog/simplecudd_lfi
@ -2270,5 +2332,10 @@ if test "$ENABLE_GECODE" = ""; then
AC_CONFIG_FILES([library/gecode/Makefile])
fi
if test "$ENABLE_PRISM" = ""; then
AC_CONFIG_FILES([packages/prism/src/c/Makefile])
AC_CONFIG_FILES([packages/prism/src/prolog/Makefile])
fi
AC_OUTPUT()

11
docs/yap.tex
View File

@ -16351,6 +16351,7 @@ hook on garbage collection:
@findex YAP_MkNewPairTerm (C-Interface function)
@findex YAP_HeadOfTerm (C-Interface function)
@findex YAP_TailOfTerm (C-Interface function)
@findex YAP_MkListFromTerms (C-Interface function)
A @i{pair} is a Prolog term which consists of a tuple of two Prolog
terms designated as the @i{head} and the @i{tail} of the term. Pairs are
most often used to build @emph{lists}. The following primitives can be
@ -16360,11 +16361,18 @@ used to manipulate pairs:
YAP_Term YAP_MkNewPairTerm(void)
YAP_Term YAP_HeadOfTerm(YAP_Term @var{t})
YAP_Term YAP_TailOfTerm(YAP_Term @var{t})
YAP_Term YAP_MkListFromTerms(YAP_Term *@var{pt}, YAP_Int *@var{sz})
@end example
One can construct a new pair from two terms, or one can just build a
pair whose head and tail are new unbound variables. Finally, one can
fetch the head or the tail.
The last function supports the common operation of constructing a list from an
array of terms of size @var{sz} in a simple sweep.
Notice that the list constructors can call the garbage collector if
there is not enough space in the global stack.
@findex YAP_MkApplTerm (C-Interface function)
@findex YAP_MkNewApplTerm (C-Interface function)
@findex YAP_ArgOfTerm (C-Interface function)
@ -16392,6 +16400,9 @@ to a compound term. @code{argno} should be greater or equal to 1 and
less or equal to the arity of the functor. @code{YAP_ArgsOfTerm}
returns a pointer to an array of arguments.
Notice that the compound term constructors can call the garbage
collector if there is not enough space in the global stack.
YAP allows one to manipulate the functors of compound term. The function
@code{YAP_FunctorOfTerm} allows one to obtain a variable of type
@code{YAP_Functor} with the functor to a term. The following functions

2
include/SWI-Prolog.h
View File

@ -35,7 +35,7 @@ extern "C" {
#include "YapInterface.h"
#else
#include <Yap/config.h>
#include <Yap/src/config.h>
#if USE_GMP
#include <gmp.h>
#endif

2
include/YapInterface.h
View File

@ -181,6 +181,8 @@ extern X_API CONST wchar_t *PROTO(YAP_WideAtomName,(YAP_Atom));
/* YAP_Term MkPairTerm(YAP_Term Head, YAP_Term Tail) */
extern X_API YAP_Term PROTO(YAP_MkPairTerm,(YAP_Term,YAP_Term));
extern X_API YAP_Term PROTO(YAP_MkListFromTerms,(YAP_Term *,YAP_Int));
/* YAP_Term MkNewPairTerm(void) */
extern X_API YAP_Term PROTO(YAP_MkNewPairTerm,(void));

4
include/YapRegs.h
View File

@ -23,6 +23,10 @@ typedef char *ADDR;
#define RESET_VARIABLE(X) (*(X) = (CELL)(X))
#ifdef _YAP_NOT_INSTALLED_
#include "Regs.h"
#else
#include "src/Regs.h"
#endif
#endif

8
library/dialect/bprolog/actionrules.pl
View File

@ -396,7 +396,8 @@ ar_expand(Head, []) :-
ar_expand(end_of_file, FinalProgram) :-
prolog_load_context(file,File),
compile_ar(File, DetProgram),
compile_nondet_ar(File, FinalProgram, DetProgram).
compile_nondet_ar(File, FinalProgram, DetProgram),
FinalProgram = [_|_].
compile_ar(File, FinalProgram) :-
findall(T, retract(ar_term(File,T)), ARs),
@ -404,11 +405,14 @@ compile_ar(File, FinalProgram) :-
prolog_load_context(module, Module),
ar_translate(ARs, Module, FinalProgram, Errors),
!, % just to make sure there are no choice points left
% vsc: also, allow for nondet rules.
(Errors == [] ->
true
;
report_errors(Errors)
).
compile_ar(_File, []).
compile_nondet_ar(File, FinalProgram, StartProgram) :-
findall(T, retract(nondet_ar_term(File,T)), ARs),
ARs \== [],
@ -420,6 +424,8 @@ compile_nondet_ar(File, FinalProgram, StartProgram) :-
;
report_errors(Errors)
).
compile_nondet_ar(_File, FinalProgram, FinalProgram).
report_errors(Errors) :- throw(action_rule_error(Errors)). % for now

29
library/dialect/swi/fli/swi.c
View File

@ -111,33 +111,11 @@ static void
UserCPredicate(char *a, CPredicate def, unsigned long int arity, Term mod, int flags)
{
CACHE_REGS
PredEntry *pe;
Term cm = CurrentModule;
/* fprintf(stderr,"doing %s:%s/%d\n", RepAtom(AtomOfTerm(mod))->StrOfAE, a,arity); */
CurrentModule = mod;
Yap_InitCPred(a, arity, def, (UserCPredFlag|CArgsPredFlag|flags));
if (arity == 0) {
Atom at;
while ((at = Yap_LookupAtom(a)) == NULL) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return;
}
}
pe = RepPredProp(PredPropByAtom(at,mod));
} else {
Atom at;
Functor f;
while ((at = Yap_LookupAtom(a)) == NULL) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return;
}
}
f = Yap_MkFunctor(at, arity);
pe = RepPredProp(PredPropByFunc(f,mod));
}
CurrentModule = cm;
}
@ -932,7 +910,7 @@ X_API int PL_put_int64(term_t t, int64_t n)
{
CACHE_REGS
#if SIZEOF_INT_P==8
Yap_PutInSlot(t,MkIntegerTerm(n));
Yap_PutInSlot(t,MkIntegerTerm(n) PASS_REGS);
return TRUE;
#elif USE_GMP
char s[64];
@ -2032,10 +2010,9 @@ PL_strip_module(term_t raw, module_t *m, term_t plain)
X_API atom_t PL_module_name(module_t m)
{
Term t;
Atom at = AtomOfTerm((Term)m);
WRITE_LOCK(RepAtom(at)->ARWLock);
t = Yap_Module(MkAtomTerm(at));
Yap_Module(MkAtomTerm(at));
WRITE_UNLOCK(RepAtom(at)->ARWLock);
return AtomToSWIAtom(at);
}

2
library/varnumbers.yap
View File

@ -31,4 +31,4 @@ max_var_numberl(I0,Ar,T,Max0,Max) :-
).
varnumbers(GT, VT) :-
unnumber_vars(GT, VT).
unnumbervars(GT, VT).

1
packages/Dialect.defs.in
View File

@ -25,7 +25,6 @@ PLLIBDIR=$(PLBASE)/share/Yap
SOLIBDIR=$(PLBASE)/lib/Yap
PKGDOCDIR=$(PLBASE)/share/doc/Yap/packages
PKGEXDIR=$(PLBASE)/share/doc/Yap//packages/examples
PKGCFLAGS=
#
# YAP internal stuff

2
packages/YapR

@ -1 +1 @@
Subproject commit a6646d0be1d1d63782e0c1395dd449183fdd8988
Subproject commit f218eaacc9ef3922829ff4a8c5cd64cca9c19dc7

2
packages/clib

@ -1 +1 @@
Subproject commit e5f6f249be41f7169ab527d0c5a5f40e1c556bde
Subproject commit f0e208de69f5303648fe1d035e2bfa164411d42d

93
packages/prism/LICENSE Normal file
View File

@ -0,0 +1,93 @@
LICENSE AGREEMENT OF THE PRISM SYSTEM
Copyright (c) 2009,
Taisuke Sato, Neng-Fa Zhou, Yoshitaka Kameya, Yusuke Izumi
All rights reserved.
The PRISM system ("the Software") is built on top of B-Prolog
(http://www.probp.com/), which is provided by Afany Software.
The Software is developed subject to the C source code license
of B-Prolog (http://www.probp.com/license.htm) and distributed
with the permission from Afany Software.
The PRISM development team, which consists of the members from
Tokyo Institute of Technology and from Afany Software, hereby
grants a non-exclusive and non-transferable license to the
person who uses the Software ("the User"), subject to this
agreement.
1. RELATION WITH B-PROLOG. The Software consists of the
standard routines of B-Prolog ("the B-Prolog part") and the
extensional routines by the PRISM development team ("the PRISM
part"). The User must agree that the use of the B-Prolog part
is also restricted by the license agreement of B-Prolog with
the exception stated in Paragraphs 3 and 4.
2. RIGHT TO USE. The User may use the Software provided
that the User has right to use B-Prolog according to the User's
license agreement of B-Prolog. Given the license agreement of
B-Prolog as of the release date of the Software, the User may
use the Software free of charge for academic and non-commercial
purposes, and must purchase a license for other use.
3. DISTRIBUTION. The User may distribute the Software, only
for non-commercial purposes, provided that the Software is
distributed along with this agreement.
4. SOURCE CODE AND DERIVED SOFTWARE. The PRISM development
team may make the source code of the PRISM part ("the Public
Source Code") publicly available under a separate license ("the
Additional License"), along with a minimal set of source and
binary files coming from the B-Prolog part and required to build
the Software ("the Build Kit"). The User may use and distribute
the Public Source Code and the Build Kit subject to the
following subparagraphs.
4.1. SOURCE CODE. The User may use and distribute the
Public Source Code, entirely or in part, subject to the
Additional License.
4.2. BUILD KIT. The User may use and distribute the Build
Kit according to the remaining subparagraphs, provided that
the User has right to use B-Prolog the User's license agreement
of B-Prolog. The Additional License shall not apply to the
Build Kit.
4.3. DERIVED SOFTWARE. The User may build software ("the
Derived Software") from the Public Source Code, modified or
unmodified, along with the Build Kit provided that (a) the User
has right to use the Build Kit as stated in Subparagraph 4.2,
and that (b) the Derived Software presents the following
message in the same way as the Software.
This edition of B-Prolog is for evaluation, learning, and
non-profit research purposes only, and a license is needed for
any other uses. Please visit http://www.probp.com/license.htm
for the detail.
4.4. DISTRIBUTION OF DERIVED SOFTWARE. The User may distribute
the Derived Software built according to Subparagraph 4.3, only
for non-commercial purposes, provided that the Derived Software
is distributed (a) along with this agreement and (b) under the
license consistent with this agreement.
5. COPYRIGHT. The B-Prolog part is copyrighted by Afany
Software and the PRISM part is copyrighted by the PRISM
development team. The Software contains several public domain
modules as listed in the B-Prolog's manual and the implementation
of Mersenne Twister copyrighted by its authors
(http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html), and
some portion of code in the PRISM part is based on the SPECFUN
library available in the NETLIB repository (http://www.netlib.org/).
The User shall own the copyright for the modified part of the
Software according to Subparagraph 3.3.
6. NO WARRANTY. The Software is provided "as-is", without
any warranties express or implied. The User may report any
defects of the Software to the PRISM development team, but
there is no guarantee for those defects to be fixed. The User
who purchased a license from Afany Software might receive a
warranty according to the license agreement of B-Prolog, only
when the defects obviously originate from the B-Prolog part.
Neither Afany Software nor the PRISM development team is
responsible for any damages caused by the use of the Software.

39
packages/prism/LICENSE.src Normal file
View File

@ -0,0 +1,39 @@
The following license agreement is referred to as the "Additional
License" in Paragraph 4 of a license agreement on the use of the
software, which is titled "LICENSE AGREEMENT OF THE PRISM SYSTEM."
--------------------------------------------------------------------
SOURCE CODE LICENSE AGREEMENT OF THE PRISM SYSTEM
Copyright (c) 2009,
Taisuke Sato, Neng-Fa Zhou, Yoshitaka Kameya, Yusuke Izumi
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* None of the name of Tokyo Institute of Technology, the name of
City University of New York, nor the names of its contributors
may be used to endorse or promote products derived from this
software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

24
packages/prism/README Normal file
View File

@ -0,0 +1,24 @@
========================== README (top) ==========================
This is a software package of PRISM version 2.0, a logic-based
programming system for statistical modeling, which is built
on top of B-Prolog (http://www.probp.com/). Since version 2.0,
the source code of the PRISM part is included in the released
package. Please use PRISM based on the agreement described in
LICENSE and LICENSE.src.
LICENSE ... license agreement of PRISM
LICENSE.src ... additional license agreement on the source
code of PRISM
bin/ ... executables
doc/ ... documents
src/ ... source code
exs/ ... example programs
exs_fail/ ... example programs for generative modeling
with failure
exs_foc/ ... additional examples that demonstrate the
First Order Compiler
For the files under each directory, please read the README file
in the directory. For the papers or additional information
on PRISM, please visit http://sato-www.cs.titech.ac.jp/prism/ .

65
packages/prism/exs/README Normal file
View File

@ -0,0 +1,65 @@
========================== README (exs) ==========================
Files/Directories:
README ... this file
direction.psm ... the first example in the user's manual
dcoin.psm ... simple program modeling two Bernoulli trial processes
bloodABO.psm ... ABO blood type program (ABO gene model)
bloodAaBb.psm ... ABO blood type program (AaBb gene model)
bloodtype.dat ... data file for bloodABO.psm and bloodAaBb.psm
alarm.psm ... Bayesian network program
sbn.psm ... Singly connected Bayesian network program
hmm.psm ... discrete hidden Markov model
phmm.psm ... profile hmm for the alignment of amino-acid sequences
phmm.dat ... data file for phmm.psm
pdcg.psm ... PCFG program for top-down parsing
pdcg_c.psm ... PCFG program for Charniak's example
plc.psm ... probabilistic left-corner parsing
votes.psm ... cross-validation of naive Bayes with the `votes' data
jtree/ ... Bayesian network program in a junction-tree form
noisy_or/ ... Bayesian network program using noisy OR
How to use:
All programs are self-contained, hopefully. Try first a sample
session in each program to get familiar with a model.
Comment:
The above programs contain no negation. When a program contains
negation, you have to compile away negation by FOC (first order
compiler). For PRISM programs with negation, see ../exs_fail.
References:
(PRISM)
Parameter Learning of Logic Programs for Symbolic-statistical Modeling,
Sato,T. and Kameya,Y.,
Journal of Artificial Intelligence Research 15, pp.391-454, 2001.
New advances in logic-based probabilistic modeling by PRISM,
Sato,T. and Kameya,Y.,
Probabilistic Inductive Logic Programming, LNCS 4911, Springer,
pp.118-155, 2008.
(PCFGs)
Foundations of Statistical Natural Language Processing,
Manning,C.D. and Schutze,H.,
The MIT Press, 1999.
A Separate-and-Learn Approach to EM Learning of PCFGs
Sato,T., Abe,S., Kameya,Y. and Shirai,K.,
Proc. of the 6th Natural Language Processing Pacific Rim Symposium
(NLRPS-2001), pp.255-262, 2001.
(BNs)
Probabilistic Reasoning in Intelligent Systems,
Pearl,J.,
Morgan Kaufmann, 1988.
Expert Systems and Probabilistic Network Models,
Castillo,E., Gutierrez,J.M. and Hadi,A.S.,
Springer-Verlag, 1997.
(HMMs)
Foundations of Speech Recognition,
Rabiner,L.R. and Juang,B.,
Prentice-Hall, 1993.

122
packages/prism/exs/alarm.psm Normal file
View File

@ -0,0 +1,122 @@
%%%%
%%%% Bayesian networks (1) -- alarm.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is borrowed from:
%% Poole, D., Probabilistic Horn abduction and Bayesian networks,
%% In Proc. of Artificial Intelligence 64, pp.81-129, 1993.
%%
%% (Fire) (Tampering)
%% / \ /
%% ((Smoke)) (Alarm)
%% |
%% (Leaving) (( )) -- observable node
%% | ( ) -- hidden node
%% ((Report))
%%
%% In this network, we assume that all rvs (random variables)
%% take on {yes,no} and also assume that only two nodes, `Smoke'
%% and `Report', are observable.
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(alarm),go. % Learn parameters from randomly generated
%% % 100 samples
%%
%% Get the probability and the explanation graph:
%% ?- prob(world(yes,no)).
%% ?- probf(world(yes,no)).
%%
%% Get the most likely explanation and its probability:
%% ?- viterbif(world(yes,no)).
%% ?- viterbi(world(yes,no)).
%%
%% Compute conditional hindsight probabilities:
%% ?- chindsight(world(yes,no)).
%% ?- chindsight_agg(world(yes,no),world(_,_,query,yes,_,no)).
go:- alarm_learn(100).
%%-------------------------------------
%% Declarations:
:- set_prism_flag(data_source,file('world.dat')).
% When we run learn/0, the data are supplied
% from `world.dat'.
values(_,[yes,no]). % We declare multiary random switch msw(.,V)
% used in this program such that V (outcome)
% is one of {yes,no}. Note that '_' is
% an anonymous logical variable in Prolog.
% The distribution of V is specified by
% set_params below.
%%------------------------------------
%% Modeling part:
%%
%% The above BN defines a joint distribution
%% P(Fire,Tapering,Smoke,Alarm,Leaving,Report).
%% We assume `Smoke' and `Report' are observable while others are not.
%% Our modeling simulates random sampling of the BN from top nodes
%% using msws. For each rv, say `Fire', we introduce a corresponding
%% msw, say msw(fi,Fi) such that
%% msw(fi,Fi) <=> sampling msw named fi yields the outcome Fi.
%% Here fi is a constant intended for the name of rv `Fire.'
%%
world(Fi,Ta,Al,Sm,Le,Re) :-
%% Define a distribution for world/5 such that e.g.
%% P(Fire=yes,Tapering=yes,Smoke=no,Alarm=no,Leaving=no,Report=no)
%% = P(world(yes,yes,no,no,no,no))
msw(fi,Fi), % P(Fire)
msw(ta,Ta), % P(Tampering)
msw(sm(Fi),Sm), % CPT P(Smoke | Fire)
msw(al(Fi,Ta),Al), % CPT P(Alarm | Fire,Tampering)
msw(le(Al),Le), % CPT P(Leaving | Alarm)
msw(re(Le),Re). % CPT P(Report | Leaving)
world(Sm,Re):-
%% Define marginal distribution for `Smoke' and `Report'
world(_,_,_,Sm,_,Re).
%%------------------------------------
%% Utility part:
alarm_learn(N) :-
unfix_sw(_), % Make all parameters changeable
set_params, % Set parameters as you specified
get_samples(N,world(_,_),Gs), % Get N samples
fix_sw(fi), % Preserve the parameter values
learn(Gs). % for {msw(fi,yes), msw(fi,no)}
% alarm_learn(N) :-
% %% generate teacher data and write them to `world.dat'
% %% before learn/0 is called.
% write_world(N,'world.dat'),
% learn.
set_params :-
set_sw(fi,[0.1,0.9]),
set_sw(ta,[0.15,0.85]),
set_sw(sm(yes),[0.95,0.05]),
set_sw(sm(no),[0.05,0.95]),
set_sw(al(yes,yes),[0.50,0.50]),
set_sw(al(yes,no),[0.90,0.10]),
set_sw(al(no,yes),[0.85,0.15]),
set_sw(al(no,no),[0.05,0.95]),
set_sw(le(yes),[0.88,0.12]),
set_sw(le(no),[0.01,0.99]),
set_sw(re(yes),[0.75,0.25]),
set_sw(re(no),[0.10,0.90]).
write_world(N,File) :-
get_samples(N,world(_,_),Gs),tell(File),write_world(Gs),told.
write_world([world(Sm,Re)|Gs]) :-
write(world(Sm,Re)),write('.'),nl,write_world(Gs).
write_world([]).

111
packages/prism/exs/bloodABO.psm Normal file
View File

@ -0,0 +1,111 @@
%%%%
%%%% ABO blood type --- bloodABO.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% ABO blood type consists of A, B, O and AB. They are observable
%% (phenotypes) and determined by a pair of blood type genes (geneotypes).
%% There are three ABO genes, namely a, b and o located on the 9th
%% chromosome of a human being. There are 6 geneotypes ({a,a},{a,b},{a,o},
%% {b,b},{b,o},{o,o}) and each determines a blood type. For example {a,b}
%% gives blood type AB etc. Our task is to estimate frequencies of ABO
%% genes from a random sample of ABO blood type, assuming random mate.
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(bloodABO),go,print_blood.
%% % Learn parameters from randomly generated
%% % 100 samples with A:B:O:AB = 38:22:31:9
%%
%% ?- sample(bloodtype(X)).
%% % Pick up a person with blood type X randomly
%% % acccording to the currrent parameter settings
%%
%% ?- get_samples(100,bloodtype(X),_Gs),countlist(_Gs,Cs).
%% % Pick up 100 persons and get the frequencies
%% % of their blood types
%%
%% ?- probf(bloodtype(ab),E),print_graph(E).
%% % Print all explanations for blooodtype(ab) in
%% % a compressed form
%%
%% ?- prob(bloodtype(ab),P).
%% % P is the probability of bloodtype(ab) being true
%%
%% ?- viterbif(bloodtype(ab)).
%% ?- viterbif(bloodtype(ab),P,E),print_graph(E).
%% ?- viterbi(bloodtype(ab),P).
%% % P is the probability of a most likely
%% % explanation E for bloodtype(ab).
%%
%% ?- viterbit(bloodtype(ab)).
%% % Print the most likely explanation for
%% % bloodtype(ab) in a tree form.
go:- learn_bloodtype(100).
%%-------------------------------------
%% Declarations:
:- set_prism_flag(data_source,file('bloodtype.dat')).
% When we run learn/0, the data are supplied
% by `bloodtype.dat'.
values(gene,[a,b,o],[0.5,0.2,0.3]).
% We declare msw(gene,V) s.t. V takes on
% one of the genes {a,b,o} when executed,
% with the freq.: a 50%, b 20%, o 30%.
%%------------------------------------
%% Modeling part:
bloodtype(P) :-
genotype(X,Y),
( X=Y -> P=X
; X=o -> P=Y
; Y=o -> P=X
; P=ab
).
genotype(X,Y) :- msw(gene,X),msw(gene,Y).
% We assume random mate. Note that msw(gene,X)
% and msw(gene,Y) are i.i.d. (independent and
% identically distributed) random variables
% in Prism because they have the same id but
% different subgoals.
%%------------------------------------
%% Utility part:
learn_bloodtype(N) :- % Learn parameters from N observations
random_set_seed(214857), % Set seed of the random number generator
gen_bloodtype(N,Gs),!, % Sample bloodtype/1 of size N
learn(Gs). % Perform search and graphical EM learning
% learn. % <= when using the file `bloodtype.dat'
gen_bloodtype(N,Gs) :-
N > 0,
random_select([a,b,o,ab],[0.38,0.22,0.31,0.09],X),
Gs = [bloodtype(X)|Gs1], % Sample a blood type with an empirical
N1 is N-1,!, % ratio for Japanese people.
gen_bloodtype(N1,Gs1).
gen_bloodtype(0,[]).
print_blood :-
prob(bloodtype(a),PA),prob(bloodtype(b),PB),
prob(bloodtype(o),PO),prob(bloodtype(ab),PAB),
nl,
format("P(A) = ~6f~n",[PA]),
format("P(B) = ~6f~n",[PB]),
format("P(O) = ~6f~n",[PO]),
format("P(AB) = ~6f~n",[PAB]).
print_gene :-
get_sw(gene,[_,[a,b,o],[GA,GB,GO]]),
nl,
format("P(a) = ~6f~n",[GA]),
format("P(b) = ~6f~n",[GB]),
format("P(o) = ~6f~n",[GO]).

114
packages/prism/exs/bloodAaBb.psm Normal file
View File

@ -0,0 +1,114 @@
%%%%
%%%% Another hypothesis on ABO blood type inheritance --- bloodAaBb.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% ABO blood type consists of A, B, O and AB. They are observable
%% (phenotypes) and determined by a pair of blood type genes (geneotypes).
%% At present, it is known that there are three ABO genes, namely a, b and
%% o located on the 9th chromosome of a human being, but in early 20th
%% century, there was another hypothesis that we have two loci for ABO
%% blood type with dominant alleles A/a and B/b. That is, genotypes aabb,
%% A*bb, aaB* and A*B* correspond to the blood types (phenotypes) O, A, B
%% and AB, respectively, where * stands for a don't care symbol. We call
%% this hypothesis the AaBb gene model, and assume random mating.
%%-------------------------------------
%% Quick start : sample session -- the same as that of bloodABO.psm
%%
%% ?- prism(bloodAaBb),go,print_blood.
%% % Learn parameters from randomly generated
%% % 100 samples with A:B:O:AB = 38:22:31:9
%%
%% ?- probf(bloodtype(ab),E),print_graph(E).
%% ?- prob(bloodtype(ab),P).
%%
%% ?- viterbif(bloodtype(ab),P,E),print_graph(E).
%% ?- viterbi(bloodtype(ab),P).
%% % P is the probability of a most likely
%% % explanation E for bloodtype(ab).
go:- learn_bloodtype(100).
%%-------------------------------------
%% Session for model selection:
%%
%% -- we try to evaluate the plausibilities of the correct model (ABO
%% gene model) and this AaBb gene model according to the data in
%% `bloodtype.dat'. The data file `bloodtype.dat' contains 38
%% persons of blood type A, 22 persons of blood type B, 31 persons
%% of blood type O, and 9 persons of blood type AB (the ratio is
%% almost the same as that in Japanese people).
%%
%% 1. Modify bloodABO.psm and bloodAaBb.psm:
%% - Use learn/0 instead of learn/1.
%%
%% 2. Get the BIC value for the ABO gene model (bloodABO.psm)
%% ?- prism(bloodABO).
%% ?- learn.
%% ?- learn_statistics(bic,BIC).
%%
%% 3. Get the BIC value for the AaBb gene model (this file)
%% ?- prism(bloodAaBb).
%% ?- learn.
%% ?- learn_statistics(bic,BIC).
%%
:- set_prism_flag(data_source,file('bloodtype.dat')).
% When we run learn/0, the data are supplied
% by `bloodtype.dat'.
values(locus1,['A',a]).
values(locus2,['B',b]).
%%------------------------------------
%% Modeling part:
bloodtype(P) :-
genotype(locus1,X1,Y1),
genotype(locus2,X2,Y2),
( X1=a, Y1=a, X2=b, Y2=b -> P=o
; ( X1='A' ; Y1='A' ), X2=b, Y2=b -> P=a
; X1=a, Y1=a, ( X2='B' ; Y2='B') -> P=b
; P=ab
).
genotype(L,X,Y) :- msw(L,X),msw(L,Y).
%%------------------------------------
%% Utility part:
%% (the same as that in bloodABO.psm)
learn_bloodtype(N) :- % Learn parameters from N observations
random_set_seed(214857), % Set seed of the random number generator
gen_bloodtype(N,Gs),!, % Sample bloodtype/1 of size N
learn(Gs). % Perform search and graphical EM learning
% learn. % <= when using the file `bloodtype.dat'
gen_bloodtype(N,Gs) :-
N > 0,
random_select([a,b,o,ab],[0.38,0.22,0.31,0.09],X),
Gs = [bloodtype(X)|Gs1], % Sample a blood type with an empirical
N1 is N-1,!, % ratio for Japanese people.
gen_bloodtype(N1,Gs1).
gen_bloodtype(0,[]).
print_blood :-
prob(bloodtype(a),PA),prob(bloodtype(b),PB),
prob(bloodtype(o),PO),prob(bloodtype(ab),PAB),
nl,
format("P(A) = ~6f~n",[PA]),
format("P(B) = ~6f~n",[PB]),
format("P(O) = ~6f~n",[PO]),
format("P(AB) = ~6f~n",[PAB]).
print_gene :-
get_sw(locus1,[_,['A',a],[GA,Ga]]),
get_sw(locus2,[_,['B',b],[GB,Gb]]),
nl,
format("P(A) = ~6f~n",[GA]),
format("P(a) = ~6f~n",[Ga]),
format("P(B) = ~6f~n",[GB]),
format("P(b) = ~6f~n",[Gb]).

100
packages/prism/exs/bloodtype.dat Normal file
View File

@ -0,0 +1,100 @@
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(a).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(b).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(o).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).
bloodtype(ab).

72
packages/prism/exs/dcoin.psm Normal file
View File

@ -0,0 +1,72 @@
%%%%
%%%% Double coin tossing --- dcoin.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% A sequential mixture of two Bernoulli trials processes.
%% We have two coins, coin(1) and coin(2).
%% Start with coin(1), we keep flipping a coin and observe the outcome.
%% We change coins according to the rule in the process.
%% If the outcome is "head", the next coin to flip is coin(2).
%% If the outcome is "tail", the next coin to flip is coin(1).
%% The learning task is to estimate parameters for coin(1) and coin(2),
%% observing a sequence of outcomes.
%% As there is no hidden variable in this model, EM learning is just
%% ML estimation from complete data.
%%-------------------------------------
%% Quick start : sample session
%%
%% (1) load this program
%% ?- prism(dcoin).
%%
%% (2) sampling and probability computations
%% ?- sample(dcoin(10,X)),prob(dcoin(10,X)).
%% ?- sample(dcoin(10,X)),probf(dcoin(10,X)).
%%
%% (3) EM learning
%% ?- go.
go:- dcoin_learn(500).
%%------------------------------------
%% Declarations:
values(coin(1),[head,tail],[0.5,0.5]).
% Declare msw(coin(1),V) s.t. V = head or
% V = tail, where P(msw(coin(1),head)) = 0.5
% and P(msw(coin(1),tail)) = 0.5.
values(coin(2),[head,tail],[0.7,0.3]).
% Declare msw(coin(2),V) s.t. V = head or
% V = tail, where P(msw(coin(2),head)) = 0.7
% and P(msw(coin(2),tail)) = 0.3.
%%------------------------------------
%% Modeling part:
dcoin(N,Rs) :- % Rs is a list with length N of outcomes
dcoin(N,coin(1),Rs). % from two Bernoulli trials processes.
dcoin(N,Coin,[R|Rs]) :-
N > 0,
msw(Coin,R),
( R == head, NextCoin = coin(2)
; R == tail, NextCoin = coin(1) ),
N1 is N-1,
dcoin(N1,NextCoin,Rs).
dcoin(0,_,[]).
%%------------------------------------
%% Utility part:
dcoin_learn(N) :-
set_params, % Set parameters.
sample(dcoin(N,Rs)), % Get a sample Rs of size N.
Goals = [dcoin(N,Rs)], % Estimate the parameters from Rs.
learn(Goals).
set_params :-
set_sw(coin(1),[0.5,0.5]),
set_sw(coin(2),[0.7,0.3]).

46
packages/prism/exs/direction.psm Normal file
View File

@ -0,0 +1,46 @@
%%%%
%%%% Decision of the direction by a coin tossing -- direction.psm
%%%%
%%%% This program has just one random switch named `coin'.
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%%-------------------------------------
%% Sample session
%%
%% (1) Load this program:
%% ?- prism(direction).
%%
%% (2) Get a sample:
%% ?- sample(direction(D)).
%%
%% (3) Display the information about the switch `coin':
%% ?- show_sw.
%%
%% (4) Set the probability distribution to the switch `coin':
%% ?- set_sw(coin,[0.7,0.3]).
%%
%% (5) Display the switch information again with the distribution set
%% at step 4:
%% ?- show_sw.
%%
%% (6) Get a sample again with the distribution set at step 4:
%% ?- sample(direction(D)).
%%
%% [Note1]
%% Since 1.9, without any extra settings, the probability distribution
%% of every switch is set to a uniform distribution.
%%
%% [Note2]
%% If you go (3) with skipping (2), nothing should be displayed. This
%% is because any random switch will not be registered by the system until
%% it is explicitly used or referred to.
values(coin,[head,tail]). % The switch `coin' takes `head' or `tail' as its value
direction(D):-
msw(coin,Face), % Make a coin tossing
( Face==head -> D=left ; D=right). % Decide the direction according to
% the result of coin tossing

99
packages/prism/exs/hmm.psm Normal file
View File

@ -0,0 +1,99 @@
%%%%
%%%% Hidden Markov model --- hmm.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% [state diagram:] (2 states and 2 output symbols)
%%
%% +--------+ +--------+
%% | | | |
%% | +------+ +------+ |
%% | | |------->| | |
%% +---->| s0 | | s1 |<----+
%% | |<-------| |
%% +------+ +------+
%%
%% - In each state, possible output symbols are `a' and `b'.
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(hmm),hmm_learn(100). % Learn parameters from 100 randomly
%% % generated samples
%%
%% ?- show_sw. % Confirm the learned parameter
%%
%% ?- prob(hmm([a,a,a,a,a,b,b,b,b,b])). % Calculate the probability
%% ?- probf(hmm([a,a,a,a,a,b,b,b,b,b])). % Get the explanation graph
%%
%% ?- viterbi(hmm([a,a,a,a,a,b,b,b,b,b])). % Run the Viterbi computation
%% ?- viterbif(hmm([a,a,a,a,a,b,b,b,b,b])). % Get the Viterbi explanation
%%
%% ?- hindsight(hmm([a,a,a,a,a,b,b,b,b,b])). % Get hindsight probabilities
%%------------------------------------
%% Declarations:
values(init,[s0,s1]). % state initialization
values(out(_),[a,b]). % symbol emission
values(tr(_),[s0,s1]). % state transition
% :- set_prism_flag(default_sw_d,1.0).
% :- set_prism_flag(epsilon,1.0e-2).
% :- set_prism_flag(restart,10).
% :- set_prism_flag(log_scale,on).
%%------------------------------------
%% Modeling part:
hmm(L):- % To observe a string L:
str_length(N), % Get the string length as N
msw(init,S), % Choose an initial state randomly
hmm(1,N,S,L). % Start stochastic transition (loop)
hmm(T,N,_,[]):- T>N,!. % Stop the loop
hmm(T,N,S,[Ob|Y]) :- % Loop: current state is S, current time is T
msw(out(S),Ob), % Output Ob at the state S
msw(tr(S),Next), % Transit from S to Next.
T1 is T+1, % Count up time
hmm(T1,N,Next,Y). % Go next (recursion)
str_length(10). % String length is 10
%%------------------------------------
%% Utility part:
hmm_learn(N):-
set_params,!, % Set parameters manually
get_samples(N,hmm(_),Gs),!, % Get N samples
learn(Gs). % Learn with the samples
set_params:-
set_sw(init, [0.9,0.1]),
set_sw(tr(s0), [0.2,0.8]),
set_sw(tr(s1), [0.8,0.2]),
set_sw(out(s0),[0.5,0.5]),
set_sw(out(s1),[0.6,0.4]).
%% prism_main/1 is a special predicate for batch execution.
%% The following command conducts learning from 50 randomly
%% generated samples:
%% > upprism hmm 50
prism_main([Arg]):-
parse_atom(Arg,N), % Convert an atom ('50') to a number (50)
hmm_learn(N). % Learn with N samples
%% viterbi_states(Os,Ss) returns the most probable sequence Ss
%% of state transitions for an output sequence Os.
%%
%% | ?- viterbi_states([a,a,a,a,a,b,b,b,b,b],States).
%%
%% States = [s0,s1,s0,s1,s0,s1,s0,s1,s0,s1,s0] ?
viterbi_states(Outputs,States):-
viterbif(hmm(Outputs),_,E),
viterbi_subgoals(E,E1),
maplist(hmm(_,_,S,_),S,true,E1,States).

8
packages/prism/exs/jtree/README Normal file
View File

@ -0,0 +1,8 @@
================== README (exs/jtree) ==========================
Files:
README ... This file
asia.psm ... BN for Asia network (naive)
jasia.psm ... BN for Asia network (junction-tree; evidences kept in D-list)
jasia_a.psm ... BN for Asia network (junction-tree; evidences asserted first)
bn2prism/ ... Java translator from BNs to join-tree PRISM programs

84
packages/prism/exs/jtree/asia.psm Normal file
View File

@ -0,0 +1,84 @@
%%%%
%%%% Bayesian networks for Asia network -- asia.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is known as the Asia network, and was borrowed from:
%% S. L. Lauritzen and D. J. Spiegelhalter (1988).
%% Local computations with probabilities on graphical structures
%% and their application to expert systems.
%% Journal of Royal Statistical Society, Vol.B50, No.2, pp.157-194.
%%
%% ((Smoking[S]))
%% ((Visit to Asia[A])) / \
%% | / \
%% v v \
%% (Tuberculosis[T]) (Lang cancer[L]) \
%% \ / \
%% \ / v
%% v v (Bronchinitis[B])
%% (Tuberculosis or lang cancer[TL]) /
%% / \ /
%% / \ /
%% v \ /
%% ((X-ray[X])) v v
%% ((Dyspnea[D]))
%%
%% We assume that the nodes A, S, X and D are observable. This
%% program provides a naive representation of the Asia network, as
%% shown in ../alarm.psm. The junction-tree version of the Asia
%% network program is given in jasia.psm
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(asia),go.
go:- chindsight_agg(world(f,_,_,t),world(f,query,_,_,_,_,_,t)).
% we compute a conditional distribution P(T | A=false, D=true)
%%-------------------------------------
%% Declarations:
values(bn(_,_),[t,f]). % each switch takes on true or false
%%-------------------------------------
%% Modeling part:
world(A,S,X,D):- world(A,_,S,_,_,X,_,D).
world(A,T,S,L,TL,X,B,D) :-
msw(bn(a,[]),A),msw(bn(t,[A]),T),
msw(bn(s,[]),S),msw(bn(l,[S]),L),
incl_or(T,L,TL),
msw(bn(x,[TL]),X),msw(bn(b,[S]),B),
msw(bn(d,[TL,B]),D).
% inclusive OR
incl_or(t,t,t).
incl_or(t,f,t).
incl_or(f,t,t).
incl_or(f,f,f).
%%-------------------------------------
%% Utility part:
:- set_params.
set_params:-
set_sw(bn(a,[]),[0.01,0.99]),
set_sw(bn(t,[t]),[0.05,0.95]),
set_sw(bn(t,[f]),[0.01,0.99]),
set_sw(bn(s,[]),[0.5,0.5]),
set_sw(bn(l,[t]),[0.1,0.9]),
set_sw(bn(l,[f]),[0.01,0.99]),
set_sw(bn(x,[t]),[0.98,0.02]),
set_sw(bn(x,[f]),[0.05,0.95]),
set_sw(bn(b,[t]),[0.60,0.40]),
set_sw(bn(b,[f]),[0.30,0.70]),
set_sw(bn(d,[t,t]),[0.90,0.10]),
set_sw(bn(d,[t,f]),[0.70,0.30]),
set_sw(bn(d,[f,t]),[0.80,0.20]),
set_sw(bn(d,[f,f]),[0.10,0.90]).

153
packages/prism/exs/jtree/jasia.psm Normal file
View File

@ -0,0 +1,153 @@
%%%%
%%%% Join-tree PRISM program for Asia network -- jasia.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is known as the Asia network, and was borrowed from:
%% S. L. Lauritzen and D. J. Spiegelhalter (1988).
%% Local computations with probabilities on graphical structures
%% and their application to expert systems.
%% Journal of Royal Statistical Society, Vol.B50, No.2, pp.157-194.
%%
%% ((Smoking[S]))
%% ((Visit to Asia[A])) / \
%% | / \
%% v v \
%% (Tuberculosis[T]) (Lang cancer[L]) \
%% \ / \
%% \ / v
%% v v (Bronchinitis[B])
%% (Tuberculosis or lang cancer[TL]) /
%% / \ /
%% / \ /
%% v \ /
%% ((X-ray[X])) v v
%% ((Dyspnea[D]))
%%
%% We assume that the nodes A, S, X and D are observable. One may
%% notice that this network is multiply-connected (there are undirected
%% loop: S-L-TL-D-B-S). To perform efficient probabilistic inferences,
%% one popular method is the join-tree (JT) algorithm. In the JT
%% algorithm, we first convert the original network (DAG) into a tree-
%% structured undirected graph, called join tree (junction tree), in
%% which a node corresponds to a set of nodes in the original network.
%% Then we compute the conditional probabilities based on the join
%% tree. For example, the above network is converted into the
%% following join tree:
%%
%% node4(A,T) node2(S,L,B)
%% \ \
%% [T] [L,B]
%% \ \ node1
%% node3(T,L,TL)--[L,TL]--(L,TL,B)
%% /
%% [TL,B]
%% node6 /
%% (TL,X)--[TL]--(TL,B,D)
%% node5
%%
%% where (...) corresponds to a node and [...] corresponds to a
%% separator. In this join tree, node2 corresponds to a set {S,L,B} of
%% the original nodes. We consider that node1 is the root of this join
%% tree.
%%
%% Here we write a PRISM program that represents the above join tree.
%% The predicate named msg_i_j corresponds to the edge from node i to
%% node j in the join tree. The predicate named node_i corresponds to
%% node i.
%%
%% The directory `bn2prism' in the same directory contains BN2Prism, a
%% Java translator from a Bayesian network to a PRISM program in join-
%% tree style, like the one shown here.
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(jasia),go.
go:- chindsight_agg(world([(a,f),(d,t)]),node_4(_,query,_)).
% we compute a conditional distribution P(T | A=false, D=true)
go2:- prob(world([(a,f),(d,t)])).
% we compute a marginal probability P(A=false, D=true)
%%-------------------------------------
%% Declarations:
values(bn(_,_),[t,f]). % each switch takes on true or false
%%-------------------------------------
%% Modeling part:
%%
%% [Note]
%% Evidences are kept in a difference list in the last argument of
%% the msg_i_j and the node_i predicates. For simplicity, it is
%% assumed that the evidences are given in the same order as that
%% of appearances of msw/2 in the top-down execution of world/1.
world(E):- msg_1_0(E-[]).
msg_1_0(E0-E1) :- node_1(_L,_TL,_B,E0-E1).
msg_2_1(L,B,E0-E1 ):- node_2(_S,L,B,E0-E1).
msg_3_1(L,TL,E0-E1):- node_3(_T,L,TL,E0-E1).
msg_4_3(T,E0-E1) :- node_4(_A,T,E0-E1).
msg_5_1(TL,B,E0-E1):- node_5(TL,B,_D,E0-E1).
msg_6_5(TL,E0-E1) :- node_6(TL,_X,E0-E1).
node_1(L,TL,B,E0-E1):-
msg_2_1(L,B,E0-E2),
msg_3_1(L,TL,E2-E3),
msg_5_1(TL,B,E3-E1).
node_2(S,L,B,E0-E1):-
cpt(s,[],S,E0-E2),
cpt(l,[S],L,E2-E3),
cpt(b,[S],B,E3-E1).
node_3(T,L,TL,E0-E1):-
incl_or(L,T,TL),
msg_4_3(T,E0-E1).
node_4(A,T,E0-E1):-
cpt(a,[],A,E0-E2),
cpt(t,[A],T,E2-E1).
node_5(TL,B,D,E0-E1):-
cpt(d,[TL,B],D,E0-E2),
msg_6_5(TL,E2-E1).
node_6(TL,X,E0-E1):-
cpt(x,[TL],X,E0-E1).
cpt(X,Par,V,E0-E1):-
( E0=[(X,V)|E1] -> true ; E0=E1 ),
msw(bn(X,Par),V).
% inclusive OR
incl_or(t,t,t).
incl_or(t,f,t).
incl_or(f,t,t).
incl_or(f,f,f).
%%-------------------------------------
%% Utility part:
:- set_params.
set_params:-
set_sw(bn(a,[]),[0.01,0.99]),
set_sw(bn(t,[t]),[0.05,0.95]),
set_sw(bn(t,[f]),[0.01,0.99]),
set_sw(bn(s,[]),[0.5,0.5]),
set_sw(bn(l,[t]),[0.1,0.9]),
set_sw(bn(l,[f]),[0.01,0.99]),
set_sw(bn(x,[t]),[0.98,0.02]),
set_sw(bn(x,[f]),[0.05,0.95]),
set_sw(bn(b,[t]),[0.60,0.40]),
set_sw(bn(b,[f]),[0.30,0.70]),
set_sw(bn(d,[t,t]),[0.90,0.10]),
set_sw(bn(d,[t,f]),[0.70,0.30]),
set_sw(bn(d,[f,t]),[0.80,0.20]),
set_sw(bn(d,[f,f]),[0.10,0.90]).

167
packages/prism/exs/jtree/jasia_a.psm Normal file
View File

@ -0,0 +1,167 @@
%%%%
%%%% Join-tree PRISM program for Asia network -- jasia.psm
%%%%
%%%% Copyright (C) 2009
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is known as the Asia network, and was borrowed from:
%% S. L. Lauritzen and D. J. Spiegelhalter (1988).
%% Local computations with probabilities on graphical structures
%% and their application to expert systems.
%% Journal of Royal Statistical Society, Vol.B50, No.2, pp.157-194.
%%
%% ((Smoking[S]))
%% ((Visit to Asia[A])) / \
%% | / \
%% v v \
%% (Tuberculosis[T]) (Lang cancer[L]) \
%% \ / \
%% \ / v
%% v v (Bronchinitis[B])
%% (Tuberculosis or lang cancer[TL]) /
%% / \ /
%% / \ /
%% v \ /
%% ((X-ray[X])) v v
%% ((Dyspnea[D]))
%%
%% We assume that the nodes A, S, X and D are observable. One may
%% notice that this network is multiply-connected (there are undirected
%% loop: S-L-TL-D-B-S). To perform efficient probabilistic inferences,
%% one popular method is the join-tree (JT) algorithm. In the JT
%% algorithm, we first convert the original network (DAG) into a tree-
%% structured undirected graph, called join tree (junction tree), in
%% which a node corresponds to a set of nodes in the original network.
%% Then we compute the conditional probabilities based on the join
%% tree. For example, the above network is converted into the
%% following join tree:
%%
%% node4(A,T) node2(S,L,B)
%% \ \
%% [T] [L,B]
%% \ \ node1
%% node3(T,L,TL)--[L,TL]--(L,TL,B)
%% /
%% [TL,B]
%% node6 /
%% (TL,X)--[TL]--(TL,B,D)
%% node5
%%
%% where (...) corresponds to a node and [...] corresponds to a
%% separator. In this join tree, node2 corresponds to a set {S,L,B} of
%% the original nodes. We consider that node1 is the root of this join
%% tree.
%%
%% Here we write a PRISM program that represents the above join tree.
%% The predicate named msg_i_j corresponds to the edge from node i to
%% node j in the join tree. The predicate named node_i corresponds to
%% node i.
%%
%% The directory `bn2prism' in the same directory contains BN2Prism, a
%% Java translator from a Bayesian network to a PRISM program in join-
%% tree style, like the one shown here.
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(jasia_a),go.
go:- chindsight_agg(world([(a,f),(d,t)]),node_4(_,query)).
% we compute a conditional distribution P(T | A=false, D=true)
go2:- prob(world([(a,f),(d,t)])).
% we compute a marginal probability P(A=false, D=true)
%%-------------------------------------
%% Declarations:
values(bn(_,_),[t,f]). % each switch takes on true or false
%%-------------------------------------
%% Modeling part:
%%
%% [Note]
%% Evidences are added first into the Prolog database. This is a
%% simpler method than keeping the evidences in difference list
%% (as done in jasia.psm). However, in learning, the subgoals are
%% inappropriately shared among the observed goals, each of which
%% is associated with a different set of evidences (This optimization
%% is called inter-goal sharing, and unconditionally enabled in the
%% current PRISM system). An ad-hoc workaround is to introduce an
%% ID for each set of evidences and keep the ID through the arguments
%% (e.g. we define world(ID,E), msg_2_1(ID,L,B), and so on).
world(E):- assert_evid(E),msg_1_0.
msg_1_0 :- node_1(_L,_TL,_B).
msg_2_1(L,B) :- node_2(_S,L,B).
msg_3_1(L,TL):- node_3(_T,L,TL).
msg_4_3(T) :- node_4(_A,T).
msg_5_1(TL,B):- node_5(TL,B,_D).
msg_6_5(TL) :- node_6(TL,_X).
node_1(L,TL,B):-
msg_2_1(L,B),
msg_3_1(L,TL),
msg_5_1(TL,B).
node_2(S,L,B):-
cpt(s,[],S),
cpt(l,[S],L),
cpt(b,[S],B).
node_3(T,L,TL):-
incl_or(L,T,TL),
msg_4_3(T).
node_4(A,T):-
cpt(a,[],A),
cpt(t,[A],T).
node_5(TL,B,D):-
cpt(d,[TL,B],D),
msg_6_5(TL).
node_6(TL,X):-
cpt(x,[TL],X).
cpt(X,Par,V):-
( evid(X,V) -> true ; true ),
msw(bn(X,Par),V).
% inclusive OR
incl_or(t,t,t).
incl_or(t,f,t).
incl_or(f,t,t).
incl_or(f,f,f).
% adding evidences to Prolog database
assert_evid(Es):-
retractall(evid(_,_)),
assert_evid0(Es).
assert_evid0([]).
assert_evid0([(X,V)|Es]):-
assert(evid(X,V)),!,
assert_evid0(Es).
%%-------------------------------------
%% Utility part:
:- set_params.
set_params:-
set_sw(bn(a,[]),[0.01,0.99]),
set_sw(bn(t,[t]),[0.05,0.95]),
set_sw(bn(t,[f]),[0.01,0.99]),
set_sw(bn(s,[]),[0.5,0.5]),
set_sw(bn(l,[t]),[0.1,0.9]),
set_sw(bn(l,[f]),[0.01,0.99]),
set_sw(bn(x,[t]),[0.98,0.02]),
set_sw(bn(x,[f]),[0.05,0.95]),
set_sw(bn(b,[t]),[0.60,0.40]),
set_sw(bn(b,[f]),[0.30,0.70]),
set_sw(bn(d,[t,t]),[0.90,0.10]),
set_sw(bn(d,[t,f]),[0.70,0.30]),
set_sw(bn(d,[f,t]),[0.80,0.20]),
set_sw(bn(d,[f,f]),[0.10,0.90]).

7
packages/prism/exs/noisy_or/README Normal file
View File

@ -0,0 +1,7 @@
================== README (exs/noisy_or) ==========================
Files:
README ... this file
alarm_nor_basic.psm ... BN program using noisy OR (network-specific)
alarm_nor_generic.psm ... BN program using noisy OR (network-independent)
noisy_or.psm ... library for noisy OR

160
packages/prism/exs/noisy_or/alarm_nor_basic.psm Normal file
View File

@ -0,0 +1,160 @@
%%%%
%%%% Bayesian networks using noisy OR (1) -- alarm_nor_basic.psm
%%%%
%%%% Copyright (C) 2004,2006,2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is borrowed from:
%% Poole, D., Probabilistic Horn abduction and Bayesian networks,
%% In Proc. of Artificial Intelligence 64, pp.81-129, 1993.
%%
%% (Fire) (Tampering)
%% / \ /
%% ((Smoke)) (Alarm)
%% |
%% (Leaving) (( )) -- observable node
%% | ( ) -- hidden node
%% ((Report))
%%
%% In this network, we assume that all rvs (random variables) take on
%% {yes,no} and also assume that only two nodes, `Smoke' and `Report', are
%% observable.
%%
%% Furthermore, in this program, we consider that the Alarm variable's CPT
%% (conditional probability table) given through the noisy-OR rule. That is,
%% let us assume that we have the following inhibition probabilities:
%%
%% P(Alarm=no | Fire=yes, Tampering=no) = 0.3
%% P(Alarm=no | Fire=no, Tampering=yes) = 0.2
%%
%% The CPT for the Alarm variable is then constructed from these inhibition
%% probabilities and the noisy-OR rule:
%%
%% +------+-----------+--------------------+----------------+
%% | Fire | Tampering | P(Alarm=yes) | P(Alarm=no) |
%% +------+-----------+--------------------+----------------+
%% | yes | yes | 0.94 = 1 - 0.3*0.2 | 0.06 = 0.3*0.2 |
%% | yes | no | 0.7 = 1 - 0.3 | 0.3 |
%% | no | yes | 0.8 = 1 - 0.2 | 0.2 |
%% | no | no | 0 | 1.0 |
%% +------+-----------+--------------------+----------------+
%%
%% cpt_al/3 in this program implements the above CPT with random switches.
%% The key step is to consider the generation process underlying the noisy-OR
%% rule. One may notice that this program is written in a network-specific
%% form, but a more generic, network-independent program is given in
%% alarm_nor_generic.psm.
%%
%% Please note that this program shares a considerably large part with
%% ../alarm.psm, so some comments are omitted for simplicity.
%%-------------------------------------
%% Quick start:
%%
%% ?- prism(alarm_nor_basic).
%%
%% Print the CPT of the Alarm variable constructed from the noisy OR rule:
%% ?- print_dist_al.
%%
%% Print logical formulas that express the probabilistic behavior of
%% the noisy OR rule for Alarm:
%% ?- print_expl_al.
%%
%% Get the probability and the explanation graph:
%% ?- prob(world(yes,no)).
%% ?- probf(world(yes,no)).
%%
%% Get the most likely explanation and its probability:
%% ?- viterbif(world(yes,no)).
%% ?- viterbi(world(yes,no)).
%%
%% Compute conditional hindsight probabilities:
%% ?- chindsight(world(yes,no),world(_,_,_,_,_,_)).
%% ?- chindsight_agg(world(yes,no),world(_,_,query,yes,_,no)).
%%
%% Learn parameters from randomly generated 100 samples
%% ?- alarm_learn(100).
go:- alarm_learn(100).
%%-------------------------------------
%% Declarations:
values(_,[yes,no]).
%%------------------------------------
%% Modeling part:
world(Sm,Re):- world(_,_,_,Sm,_,Re).
world(Fi,Ta,Al,Sm,Le,Re) :-
cpt_fi(Fi), % P(Fire)
cpt_ta(Ta), % P(Tampering)
cpt_sm(Fi,Sm), % CPT P(Smoke | Fire)
cpt_al(Fi,Ta,Al), % CPT P(Alarm | Fire,Tampering)
cpt_le(Al,Le), % CPT P(Leaving | Alarm)
cpt_re(Le,Re). % CPT P(Report | Leaving)
cpt_fi(Fi):- msw(fi,Fi).
cpt_ta(Ta):- msw(ta,Ta).
cpt_sm(Fi,Sm):- msw(sm(Fi),Sm).
cpt_al(Fi,Ta,Al):- % implementation of noisy OR:
( Fi = yes, Ta = yes ->
msw(cause_al_fi,N_Al_Fi),
msw(cause_al_ta,N_Al_Ta),
( N_Al_Fi = no, N_Al_Ta = no -> Al = no
; Al = yes
)
; Fi = yes, Ta = no -> msw(cause_al_fi,Al)
; Fi = no, Ta = yes -> msw(cause_al_ta,Al)
; Fi = no, Ta = no -> Al = no
).
cpt_le(Al,Le):- msw(le(Al),Le).
cpt_re(Le,Re):- msw(re(Le),Re).
%%------------------------------------
%% Utility part:
alarm_learn(N) :-
unfix_sw(_), % Make all parameters changeable
set_params, % Set parameters as you specified
get_samples(N,world(_,_),Gs), % Get N samples
fix_sw(fi), % Preserve the parameter values
learn(Gs). % for {msw(fi,yes), msw(fi,no)}
set_params :-
set_sw(fi,[0.1,0.9]),
set_sw(ta,[0.15,0.85]),
set_sw(sm(yes),[0.95,0.05]),
set_sw(sm(no),[0.05,0.95]),
set_sw(le(yes),[0.88,0.12]),
set_sw(le(no),[0.01,0.99]),
set_sw(re(yes),[0.75,0.25]),
set_sw(re(no),[0.10,0.90]),
set_sw(cause_al_fi,[0.7,0.3]), % switch for an inhibition prob
set_sw(cause_al_ta,[0.8,0.2]). % switch for an inhibition prob
:- set_params.
%% Check routine for Noisy-OR
print_dist_al:-
set_params,
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
prob(cpt_al(Fi,Ta,Al),P),
format("P(al=~w | fi=~w, ta=~w):~t~6f~n",[Al,Fi,Ta,P]),
fail
; true
).
print_expl_al:-
set_params,
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
probf(cpt_al(Fi,Ta,Al)),
fail
; true
).

174
packages/prism/exs/noisy_or/alarm_nor_generic.psm Normal file
View File

@ -0,0 +1,174 @@
%%%%
%%%% Bayesian networks using noisy OR (2) -- alarm_nor_generic.psm
%%%%
%%%% Copyright (C) 2004,2006,2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example is borrowed from:
%% Poole, D., Probabilistic Horn abduction and Bayesian networks,
%% In Proc. of Artificial Intelligence 64, pp.81-129, 1993.
%%
%% (Fire) (Tampering)
%% / \ /
%% ((Smoke)) (Alarm)
%% |
%% (Leaving) (( )) -- observable node
%% | ( ) -- hidden node
%% ((Report))
%%
%% In this network, we assume that all rvs (random variables) take on
%% {yes,no} and also assume that only two nodes, `Smoke' and `Report', are
%% observable.
%%
%% Furthermore, as did in alarm_nor_basic.psm, we consider that the Alarm
%% variable's CPT given through the noisy-OR rule. That is, we have the
%% following inhibition probabilities:
%%
%% P(Alarm=no | Fire=yes, Tampering=no) = 0.3
%% P(Alarm=no | Fire=no, Tampering=yes) = 0.2
%%
%% The CPT for the Alarm variable is then constructed from these inhibition
%% probabilities and the noisy-OR rule:
%%
%% +------+-----------+--------------------+----------------+
%% | Fire | Tampering | P(Alarm=yes) | P(Alarm=no) |
%% +------+-----------+--------------------+----------------+
%% | yes | yes | 0.94 = 1 - 0.3*0.2 | 0.06 = 0.3*0.2 |
%% | yes | no | 0.7 = 1 - 0.3 | 0.3 |
%% | no | yes | 0.8 = 1 - 0.2 | 0.2 |
%% | no | no | 0 | 1.0 |
%% +------+-----------+--------------------+----------------+
%%
%% While alarm_nor_basic.psm uses network-specific implementation, in this
%% program, we attempt to introduce a more generic routine that can handle
%% noisy OR. To be more concrete:
%%
%% - We specify noisy OR nodes in a declarative form (with noisy_or/3).
%% - We introduce generic probabilistic predicates that make probabilistic
%% choices, following the specifications of noisy OR nodes.
%%
%% The definition of these generic probabilistic predicates are given in
%% noisy_or.psm, and we will include noisy_or.psm into this program.
%%
%%-------------------------------------
%% Quick start (the same as those listed in alarm_nor_basic.psm):
%%
%% ?- prism(alarm_nor_generic).
%%
%% Print the CPT of the Alarm variable constructed from the noisy OR rule:
%% ?- print_dist_al.
%%
%% Print logical formulas that express the probabilistic behavior of
%% the noisy OR rule for Alarm:
%% ?- print_expl_al.
%%
%% Get the probability and the explanation graph:
%% ?- prob(world(yes,no)).
%% ?- probf(world(yes,no)).
%%
%% Get the most likely explanation and its probability:
%% ?- viterbif(world(yes,no)).
%% ?- viterbi(world(yes,no)).
%%
%% Compute conditional hindsight probabilities:
%% ?- chindsight(world(yes,no),world(_,_,_,_,_,_)).
%% ?- chindsight_agg(world(yes,no),world(_,_,query,yes,_,no)).
%%
%% Learn parameters from randomly generated 100 samples
%% ?- alarm_learn(100).
%%-------------------------------------
%% Declarations:
values(_,[yes,no]).
:- include('noisy_or.psm').
% We include generic probabilistic predicates that can handle
% noisy-OR. The following predicates will be available:
%
% - cpt(X,PaVs,V) represents a probabilistic choice where a
% random variable X given instantiations PaVs of parents
% takes a value V. If X is an ordinary node, a random
% switch bn(X,PaVs) will be used. On the other hand, if
% X is a noisy-OR node, switch cause(X,Y) will be used,
% where Y is one of parents of X.
%
% - set_nor_params/0 sets inhibition probabilisties (i.e.
% the parameters of switches cause(X,Y)) according to
% the specifications for noisy-OR nodes with noisy_or/3.
%%------------------------------------
%% Modeling part:
world(Sm,Re):- world(_,_,_,Sm,_,Re).
world(Fi,Ta,Al,Sm,Le,Re) :-
cpt(fi,[],Fi), % P(Fire)
cpt(ta,[],Ta), % P(Tampering)
cpt(sm,[Fi],Sm), % CPT P(Smoke | Fire)
cpt(al,[Fi,Ta],Al), % CPT P(Alarm | Fire,Tampering)
cpt(le,[Al],Le), % CPT P(Leaving | Alarm)
cpt(re,[Le],Re). % CPT P(Report | Leaving)
% declarations for noisy OR nodes:
noisy_or(al,[fi,ta],[[0.7,0.3],[0.8,0.2]]).
%%------------------------------------
%% Utility part:
alarm_learn(N) :-
unfix_sw(_), % Make all parameters changeable
set_params, % Set ordinary parameters
set_nor_params, % Set inhibition parameters
get_samples(N,world(_,_),Gs), % Get N samples
fix_sw(bn(fi,[])), % Preserve the parameter values
learn(Gs). % for {msw(bn(fi,[]),yes), msw(bn(fi,[]),no)}
:- set_params.
:- set_nor_params.
set_params:-
set_sw(bn(fi,[]),[0.1,0.9]),
set_sw(bn(ta,[]),[0.15,0.85]),
set_sw(bn(sm,[yes]),[0.95,0.05]),
set_sw(bn(sm,[no]),[0.05,0.95]),
set_sw(bn(le,[yes]),[0.88,0.12]),
set_sw(bn(le,[no]),[0.01,0.99]),
set_sw(bn(re,[yes]),[0.75,0.25]),
set_sw(bn(re,[no]),[0.10,0.90]).
%% Check routine for Noisy-OR
print_dist_al:-
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
get_cpt_prob(al,[Fi,Ta],Al,P),
format("P(al=~w | fi=~w, ta=~w):~t~6f~n",[Al,Fi,Ta,P]),
fail
; true
).
print_expl_al:-
( member(Fi,[yes,no]),
member(Ta,[yes,no]),
member(Al,[yes,no]),
get_cpt_probf(al,[Fi,Ta],Al),
fail
; true
).
%% [Note] prob/1 and probf/1 will fail if its argument fails
get_cpt_prob(X,PaVs,V,P):-
( prob(cpt(X,PaVs,V),P)
; P = 0.0
),!.
get_cpt_probf(X,PaVs,V):-
( probf(cpt(X,PaVs,V))
; format("cpt(~w,~w,~w): always false~n",[X,PaVs,V])
),!.

65
packages/prism/exs/noisy_or/noisy_or.psm Normal file
View File

@ -0,0 +1,65 @@
%%%%
%%%% Library for generic noisy OR predicates --- noisy_or.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% When this file included, the following predicates will be available:
%%
%% - cpt(X,PaVs,V) represents a probabilistic choice where a
%% random variable X given instantiations PaVs of parents
%% takes a value V. If X is an ordinary node, a random
%% switch bn(X,PaVs) will be used. On the other hand, if
%% X is a noisy-OR node, switch cause(X,Y) will be used,
%% where Y is one of parents of X.
%%
%% - set_nor_params/0 sets inhibition probabilisties (i.e.
%% the parameters of switches cause(X,Y)) according to
%% the specifications for noisy-OR nodes with noisy_or/3.
%%---------------------------------------
%% Declarations:
% added just for making the results of probabilistic inference
% simple and readable:
:- p_not_table choose_noisy_or/4, choose_noisy_or/6.
%%---------------------------------------
%% Modeling part:
cpt(X,PaVs,V):-
( noisy_or(X,Pa,_) -> choose_noisy_or(X,Pa,PaVs,V) % for noisy OR nodes
; msw(bn(X,PaVs),V) % for ordinary nodes
).
choose_noisy_or(X,Pa,PaVs,V):- choose_noisy_or(X,Pa,PaVs,no,no,V).
choose_noisy_or(_,[],[],yes,V,V).
choose_noisy_or(_,[],[],no,_,no).
choose_noisy_or(X,[Y|Pa],[PaV|PaVs],PaHasYes0,ValHasYes0,V):-
( PaV=yes ->
msw(cause(X,Y),V0),
PaHasYes=yes,
( ValHasYes0=no, V0=no -> ValHasYes=no
; ValHasYes=yes
)
; PaHasYes=PaHasYes0,
ValHasYes=ValHasYes0
), % do not insert the cut symbol here
choose_noisy_or(X,Pa,PaVs,PaHasYes,ValHasYes,V).
%%---------------------------------------
%% Utility part:
set_nor_params:-
( noisy_or(X,Pa,DistList), % spec for a noisy OR node
set_nor_params(X,Pa,DistList),
fail
; true
).
set_nor_params(_,[],[]).
set_nor_params(X,[Y|Pa],[Dist|DistList]):-
set_sw(cause(X,Y),Dist),!,
set_nor_params(X,Pa,DistList).

89
packages/prism/exs/pdcg.psm Normal file
View File

@ -0,0 +1,89 @@
%%%%
%%%% Probabilistic DCG --- pdcg.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% PCFGs (probabilistic contex free grammars) are a stochastic extension
%% of CFG grammar such that in a (leftmost) derivation, each production
%% rule is selected probabilistically and applied. Look at the following
%% sample PCFG in which S is a start symbol and {a,b} are terminals.
%%
%% Rule 1: S -> SS (0.4)
%% Rule 2: S -> a (0.5)
%% Rule 3: S -> b (0.1)
%%
%% When S is expanded, three rules, Rule 1, 2 and 3 are applicable.
%% To determine a rule to apply, probabilistic selection is made in
%% such a way that Rule 1 is selected with probability 0.4, Rule 2
%% with probability 0.5 and Rule 3 with probability 0.1, respectively.
%% The probability of a derivation tree is defined to be the product
%% of probabilities associated with rules used in the derivation,
%% and that of a sentence is defined to be the sum of proabibities of
%% derivations for the sentence.
%%
%% When modeling PCFGs, we follow DCG (definite clause grammar)
%% formalism. So we write down a top-down parser using difference
%% list which represents the rest of the sentence to parse. Note that
%% the grammar is left-recursive, and hence running the program below
%% without a tabling mechanism goes into an infinite loop.
%%-------------------------------------
%% Quick start : learning experiment with the sample grammar
%%
%% ?- prism(pdcg),go. % Learn parameters of the PCFG above from
%% % randomly generated 100 samples
%%
%% ?- prob(pdcg([a,b,b])).
%% ?- prob(pdcg([a,b,b]),P).
%% ?- probf(pdcg([a,b,b])).
%% ?- probf(pdcg([a,b,b]),E),print_graph(E).
%% ?- sample(pdcg(X)).
%%
%% ?- viterbi(pdcg([a,b,b]),P). % P is the prob. of the most likely
%% ?- viterbif(pdcg([a,b,b]),P,E). % explanation E for pdcg([a,b,b])
%% ?- viterbif(pdcg([a,b,b]),P,E),print_graph(E).
go:- pdcg_learn(100).
max_str_len(20). % Maximum string length is 20.
%%------------------------------------
%% Declarations:
values('S',[['S','S'],a,b],[0.4,0.5,0.1]).
% We use a msw of the form msw('S',V) such
% that V is one of { ['S','S'], a, b },
% and when msw('S',V) is executed, the prob.
% of V=['S','S'] is 0.4, that of V=a is 0.5
% and that of V=b is 0.1.
%%------------------------------------
%% Modeling part:
start_symbol('S'). % Start symbol is S
pdcg(L):-
start_symbol(I),
pdcg2(I,L-[]).
% I is a category to expand.
pdcg2(I,L0-L2):- % L0-L2 is a list for I to span.
msw(I,RHS), % Choose a rule I -> RHS probabilistically.
( RHS == ['S','S'],
pdcg2('S',L0-L1),
pdcg2('S',L1-L2)
; RHS == a,
L0 = [RHS | L2]
; RHS == b,
L0 = [RHS | L2] ).
%%------------------------------------
%% Utility part:
pdcg_learn(N):-
max_str_len(MaxStrL),
get_samples_c(N,pdcg(X),(length(X,Y),Y =< MaxStrL),Goals,[Ns,_]),
format("#sentences= ~d~n",[Ns]),
unfix_sw('S'), % Make parameters of msw('S',.) changable
learn(Goals). % Conduct ML estimation by graphical EM learning

121
packages/prism/exs/pdcg_c.psm Normal file
View File

@ -0,0 +1,121 @@
%%%%
%%%% Probabilistic DCG for Charniak's example --- pdcg_c.psm
%%%%
%%%% Copyright (C) 2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% As described in the comments in pdcg.psm, PCFGs (probabilistic context-
%% free grammars) are a stochastic extension of CFG grammar such that in a
%% (leftmost) derivation, each production rule is selected probabilistically
%% and applied. This program presents an implementation of an example from
%% Charniak's textbook (Statistical Language Learning, The MIT Press, 1993):
%%
%% s --> np vp (0.8) | verb --> swat (0.2)
%% s --> vp (0.2) | verb --> flies (0.4)
%% np --> noun (0.4) | verb --> like (0.4)
%% np --> noun pp (0.4) | noun --> swat (0.05)
%% np --> noun np (0.2) | noun --> flies (0.45)
%% vp --> verb (0.3) | noun --> ants (0.5)
%% vp --> verb np (0.3) | prep --> like (1.0)
%% vp --> verb pp (0.2) |
%% vp --> verb np pp (0.2) |
%% pp --> prep np (1.0) |
%% (`s' is the start symbol)
%%
%% This program has a grammar-independent part (pcfg/1-2 and proj/2),
%% which can work with any underlying CFG which has no epsilon rules
%% and produces no unit cycles.
%%----------------------------------
%% Quick start:
%%
%% ?- prism(pdcg_c).
%%
%% ?- prob(pcfg([swat,flies,like,ants])).
%% % get the generative probability of a sentence
%% % "swat flies like ants"
%%
%% ?- sample(pcfg(_X)),viterbif(pcfg(_X)).
%% % parse a sampled sentence
%%
%% ?- get_samples(50,pcfg(X),_Gs),learn(_Gs),show_sw.
%% % conduct an artificial learning experiments
%%
%% ?- viterbif(pcfg([swat,flies,like,ants])).
%% % get the most probabile parse for "swat flies like ants"
%%
%% ?- n_viterbif(3,pcfg([swat,flies,like,ants])).
%% % get top 3 ranked parses for "swat flies like ants"
%%
%% ?- viterbit(pcfg([swat,flies,like,ants])).
%% % print the most probabile parse for "swat flies like ants" in
%% % a tree form.
%%
%% ?- viterbit(pcfg([swat,flies,like,ants]),P,E), build_tree(E,T).
%% % get the most probabile parse for "swat flies like ants" in a
%% % tree form, and convert it to a more readable Prolog term.
%%
%% ?- probfi(pcfg([swat,flies,like,ants])).
%% % print the parse forest with inside probabilities
%%
%%----------------------------------
%% Declarations:
values(s,[[np,vp],[vp]]).
values(np,[[noun],[noun,pp],[noun,np]]).
values(vp,[[verb],[verb,np],[verb,pp],[verb,np,pp]]).
values(pp,[[prep,np]]).
values(verb,[[swat],[flies],[like]]).
values(noun,[[swat],[flies],[ants]]).
values(prep,[[like]]).
:- p_not_table proj/2. % This declaration is introduced just for
% making the results of probabilistic inferences
% simple and readable.
%%----------------------------------
%% Modeling part:
pcfg(L):- pcfg(s,L-[]).
pcfg(LHS,L0-L1):-
( nonterminal(LHS) -> msw(LHS,RHS),proj(RHS,L0-L1)
; L0 = [LHS|L1]
).
proj([],L-L).
proj([X|Xs],L0-L1):-
pcfg(X,L0-L2),proj(Xs,L2-L1).
nonterminal(s).
nonterminal(np).
nonterminal(vp).
nonterminal(pp).
nonterminal(verb).
nonterminal(noun).
nonterminal(prep).
%%----------------------------------
%% Utility part:
% set the rule probabilities:
:- set_sw(s,[0.8,0.2]).
:- set_sw(np,[0.4,0.4,0.2]).
:- set_sw(vp,[0.3,0.3,0.2,0.2]).
:- set_sw(pp,[1.0]).
:- set_sw(verb,[0.2,0.4,0.4]).
:- set_sw(noun,[0.05,0.45,0.5]).
:- set_sw(prep,[1.0]).
% build_tree(E,T):-
% Build a parse tree T from a tree-formed explanation E.
build_tree([],[]).
build_tree([pcfg(_),Gs],T) :- build_tree(Gs,T).
build_tree([pcfg(Sym,_)|Gs],T) :- build_tree1(Gs,T0),T=..[Sym|T0].
build_tree1([],[]).
build_tree1([pcfg(Sym,_)|Gs],[Sym|T]) :- !,build_tree1(Gs,T).
build_tree1([msw(_,_)|Gs],T) :- !, build_tree1(Gs,T).
build_tree1([G|Gs],[T0|T]) :- build_tree(G,T0),!,build_tree1(Gs,T).

44
packages/prism/exs/phmm.dat Normal file
View File

@ -0,0 +1,44 @@
%% This data was created by Rose.
%% see http://bibiserv.techfak.uni-bielefeld.de/rose
%% Rose
%% Copyright (c) 1997-2000 University of Bielefeld, Germany and
%% Deutsches Krebsforschungszentrum (DKFZ) Heidelberg, Germany.
%% All rights reserved.
%%
%% correct alignments
%%
%% HLKIANRKDK----HHNKEFGGHHLA
%% HLKATHRKDQ----HHNREFGGHHLA
%% VLKFANRKSK----HHNKEMGAHHLA
%% HKKGAT---------------PVNVS
%% HKKGATATG-----------NPKHVC
%% QFKVAAAVGK----HQDASRGVHHID
%% SFKGQGAVSK----HQDPEWGVHHID
%% SFKGQGAVSV----PQAPAWGINHID
%% HFKSQAEVNK----HDRPEWGLNQID
%% HFRSQAEVNQRQFNHHRPQWSFNQIG
%% SFNVVKGASK----RENGGMGAEPVD
%% KFKKVDGLGK----KEHPALGVH---
%% KFMVGGKDGK----NRKDAHAHRKVE
%% KYKVPEKDGK----KRTNAHSHRKVE
%% RYKIPESDGK----KRTNSHRHRKVE
%% RYKIASMDGK----KRYAEHKHKKLE
observe( ['H','L','K','I','A','N','R','K','D','K','H','H','N','K','E','F','G','G','H','H','L','A'] ).
observe( ['H','L','K','A','T','H','R','K','D','Q','H','H','N','R','E','F','G','G','H','H','L','A'] ).
observe( ['V','L','K','F','A','N','R','K','S','K','H','H','N','K','E','M','G','A','H','H','L','A'] ).
observe( ['H','K','K','G','A','T','P','V','N','V','S'] ).
observe( ['H','K','K','G','A','T','A','T','G','N','P','K','H','V','C'] ).
observe( ['Q','F','K','V','A','A','A','V','G','K','H','Q','D','A','S','R','G','V','H','H','I','D'] ).
observe( ['S','F','K','G','Q','G','A','V','S','K','H','Q','D','P','E','W','G','V','H','H','I','D'] ).
observe( ['S','F','K','G','Q','G','A','V','S','V','P','Q','A','P','A','W','G','I','N','H','I','D'] ).
observe( ['H','F','K','S','Q','A','E','V','N','K','H','D','R','P','E','W','G','L','N','Q','I','D'] ).
observe( ['H','F','R','S','Q','A','E','V','N','Q','R','Q','F','N','H','H','R','P','Q','W','S','F','N','Q','I','G'] ).
observe( ['S','F','N','V','V','K','G','A','S','K','R','E','N','G','G','M','G','A','E','P','V','D'] ).
observe( ['K','F','K','K','V','D','G','L','G','K','K','E','H','P','A','L','G','V','H'] ).
observe( ['K','F','M','V','G','G','K','D','G','K','N','R','K','D','A','H','A','H','R','K','V','E'] ).
observe( ['K','Y','K','V','P','E','K','D','G','K','K','R','T','N','A','H','S','H','R','K','V','E'] ).
observe( ['R','Y','K','I','P','E','S','D','G','K','K','R','T','N','S','H','R','H','R','K','V','E'] ).
observe( ['R','Y','K','I','A','S','M','D','G','K','K','R','Y','A','E','H','K','H','K','K','L','E'] ).

263
packages/prism/exs/phmm.psm Normal file
View File

@ -0,0 +1,263 @@
%%%%
%%%% Profile HMM --- phmm.psm
%%%%
%%%% Copyright (C) 2004,2006,2007,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% Profile HMMs are a variant of HMMs that have three types of states,
%% i.e. `match state',`insert state' and `delete state.' Match states
%% constitute an HMM that outputs a `true' string. Insertion states
%% emit a symbol additionally to the `true' string whereas delete (skip)
%% states emit no symbol.
%%
%% Profile HMMs are used to align amino-acid sequences by inserting
%% and skipping symbols as well as matching symbols. For example
%% amino-acid sequences below
%%
%% HLKIANRKDKHHNKEFGGHHLA
%% HLKATHRKDQHHNREFGGHHLA
%% VLKFANRKSKHHNKEMGAHHLA
%% ...
%%
%% are aligned by the profile HMM program in this file as follows.
%%
%% -HLKIA-NRKDK-H-H----NKEFGGHH-LA
%% -HLK-A-T-HRK-DQHHN--R-EFGGHH-LA
%% -VLKFA-NRKSK-H-H----NKEMGAHH-LA
%% ...
%%-------------------------------------
%% Quick start : sample session, align the sample data in phmm.dat.
%%
%% To run on an interactive session:
%% ?- prism(phmm),go. (ML/MAP)
%% ?- prism(phmm),go_vb. (variational Bayes)
%%
%% To perform a batch execution:
%% > upprism phmm
go :-
read_goals(Gs,'phmm.dat'), % Read the sequence data from phmm.dat.
learn(Gs), % Learn parameters from the data.
wmag(Gs). % Compute viterbi paths using the learned
% parameters and aligns sequences in Gs.
% To enable variational Bayes, we need some additional flag settings:
go_vb :-
set_prism_flag(learn_mode,both),
set_prism_flag(viterbi_mode,hparams),
set_prism_flag(reset_hparams,on),
go.
prism_main :- go.
%prism_main :- go_vb.
%%%--------------------- model ---------------------
observe(Sequence) :- hmm(Sequence,start).
hmm([],end).
hmm(Sequence,State) :-
State \== end,
msw(move_from(State),NextState),
msw(emit_at(State), Symbol),
( Symbol = epsilon ->
hmm( Sequence, NextState )
; Sequence = [Symbol|TailSeq],
hmm( TailSeq , NextState )
).
amino_acids(['A','C','D','E','F','G','H','I','K','L','M','N','P','Q','R',
'S','T','V','W','X','Y']).
hmm_len(17).
%%%--------------------- values ---------------------
values(move_from(State),Values) :-
hmm_len(Len),
get_index(State,X),
( 0 =< X, X < Len ->
Y is X + 1,
Values = [insert(X),match(Y),delete(Y)]
; Values = [insert(X),end] ).
values(emit_at(State),Vs) :-
((State = insert(_) ; State = match(_)) ->
amino_acids(Vs)
; Vs = [epsilon] ).
%%%--------------------- set_sw ---------------------
:- init_set_sw.
init_set_sw :-
% tell('/dev/null'), % Suppress output (on Linux only)
set_sw( move_from(start) ),
set_sw( move_from(insert(0)) ),
set_sw( emit_at(start) ),
set_sw( emit_at(insert(0)) ),
hmm_len(Len),
% told,
init_set_sw(Len).
init_set_sw(0).
init_set_sw(X) :-
X > 0,
set_sw( move_from(insert(X)) ),
set_sw( move_from(match(X)) ),
set_sw( move_from(delete(X)) ),
set_sw( emit_at(insert(X)) ),
set_sw( emit_at(match(X)) ),
set_sw( emit_at(delete(X)) ),
Y is X - 1,
init_set_sw(Y).
%%%--------------------- estimation ---------------------
%% most likely path
%% mlpath(['A','E'],Path) => Path = [start,match(1),end]
mlpath(Sequence,Path):-
mlpath(Sequence,Path,_).
mlpath(Sequence,Path,Prob):-
viterbif(hmm(Sequence,start),Prob,Nodes),
nodes2path(Nodes,Path).
nodes2path([Node|Nodes],[State|Path]):-
Node = node(hmm(_,State),_),
nodes2path(Nodes,Path).
nodes2path([],[]).
mlpaths([Seq|Seqs],[Path|Paths], X):-
mlpath(Seq,Path),
X= [P|_], writeln(P),
stop_low_level_trace,
mlpaths(Seqs,Paths, X).
mlpaths([],[],_).
%%%--------------------- alignment ---------------------
wmag(Gs):-
seqs2goals(S,Gs),wma(S).
wma(Seqs):-
write_multiple_alignments(Seqs).
write_multiple_alignments(Seqs):-
nl,
write('search Viterbi paths...'),nl,
mlpaths(Seqs,Paths,Paths),
write('done.'),
nl,
write('------------ALIGNMENTS------------'),
nl,
write_multiple_alignments( Seqs, Paths ),
write('----------------------------------'),
nl.
make_max_length_list([Path|Paths],MaxLenList) :-
make_max_length_list(Paths, TmpLenList),
make_length_list(Path,LenList),
marge_len_list(LenList,TmpLenList,MaxLenList).
make_max_length_list([Path],MaxLenList) :-
!,make_length_list(Path,MaxLenList).
marge_len_list([H1|T1],[H2|T2],[MargedH|MargedT]) :-
max(MargedH,[H1,H2]),
marge_len_list(T1,T2,MargedT).
marge_len_list([],[],[]).
%% make_length_list([start,insert(0),match(1),end],LenList)
%% -> LenList = [2,1]
%% make_length_list([start,delete(1),insert(1),insert(1),end],LenList)
%% -> LenList = [1,1]
make_length_list(Path,[Len|LenList]) :-
count_emission(Path,Len,NextIndexPath),
make_length_list(NextIndexPath,LenList).
make_length_list([end],[]).
count_emission(Path,Count,NextIndexPath) :-
Path = [State|_],
get_index(State,Index),
count_emission2(Path,Count,Index,NextIndexPath).
%% count_emission2([start,insert(0),match(1),end],Count,0,NextIndexPath)
%% -> Count = 2, NextIndexPath = [match(1),end]
%% count_emission2([delete(1),insert(1),insert(1),end],Count,1,NextIndexPath)
%% -> Count = 2, NextIndexPath = [end]
count_emission2([State|Path],Count,Index,NextIndexPath) :-
( get_index(State,Index) ->
count_emission2( Path, Count2, Index, NextIndexPath ),
( (State = delete(_); State==start) ->
Count = Count2
; Count is Count2 + 1 )
; Count = 0,
NextIndexPath = [State|Path]
).
write_multiple_alignments(Seqs,Paths) :-
make_max_length_list(Paths,LenList),
write_multiple_alignments(Seqs,Paths,LenList).
write_multiple_alignments([Seq|Seqs],[Path|Paths],LenList) :-
write_alignment(Seq,Path,LenList),
write_multiple_alignments(Seqs,Paths,LenList).
write_multiple_alignments([],[],_).
write_alignment(Seq,Path,LenList) :-
write_alignment(Seq,Path,LenList,0).
write_alignment([],[end],[],_):- !,nl.
write_alignment(Seq,[State|Path],LenList,Index) :-
get_index(State,Index),!,
( (State = delete(_) ; State == start) ->
write_alignment( Seq, Path, LenList, Index )
; Seq = [Symbol|Seq2],
LenList = [Len|LenList2],
write(Symbol),
Len2 is Len - 1,
write_alignment(Seq2,Path,[Len2|LenList2],Index)
).
write_alignment(Seq,[State|Path],LenList,Index) :-
LenList = [Len|LenList2],
Index2 is Index + 1,
pad(Len),
write_alignment(Seq,[State|Path],LenList2,Index2).
pad(Len) :-
Len > 0,
write('-'),
Len2 is Len - 1,!,
pad(Len2).
pad(0).
%%%--------------------- utility ---------------------
get_index(State,Index) :-
(State=match(_),!,State=match(Index));
(State=insert(_),!,State=insert(Index));
(State=delete(_),!,State=delete(Index));
(State=start,!,Index=0);
(State=end,!,hmm_len(X),Index is X+1).
seqs2goals([Seq|Seqs],[Goal|Goals]) :-
Goal = observe(Seq),
seqs2goals(Seqs,Goals).
seqs2goals([],[]).
max(Max,[Head|Tail]) :-
max(Tmp,Tail),!,
( Tmp > Head -> Max = Tmp ; Max = Head ).
max(Max,[Max]).
read_goals(Goals,FileName) :-
see(FileName),
read_goals(Goals),
seen.
read_goals(Goals) :-
read(Term),
( Term = end_of_file ->
Goals = []
; Goals = [Term|Goals1],
read_goals(Goals1)
).

60
packages/prism/exs/plc.dat Normal file
View File

@ -0,0 +1,60 @@
pslc([adv,n,p,v,n,adv,adv,adv,adv,v,n,p,v]).
pslc([v,n,c,v,n,p,v,n,c,n,p,v]).
pslc([adv,n,p,v,n,adv,adv,v,n,p,v,n,c,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,p,v,n,c,adv,adv,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,n,c,n,p,v,n,p,v,n,p,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,c,adv,v,n,p,v]).
pslc([n,p,v]).
pslc([v,n,c,adv,v,n,c,n,p,v,n,p,v]).
pslc([v,n,c,n,c,v,n,p,v]).
pslc([adv,adv,v,n,c,adv,v,n,c,adv,n,p,v,n,c,n,p,v,n,v,n,p,v]).
pslc([n,p,v]).
pslc([adv,n,p,v,n,c,v,n,p,v,n,v,n,p,v]).
pslc([v,n,c,n,p,v,n,p,v]).
pslc([n,c,v,n,c,n,c,n,p,v,n,p,v,n,p,v]).
pslc([v,n,c,n,p,v,n,c,adv,adv,v,n,p,v]).
pslc([adv,adv,v,n,c,v,n,p,v]).
pslc([n,p,v,n,c,adv,v,n,v,n,p,v]).
pslc([v,n,c,n,p,v,n,c,v,n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([v,n,p,v]).
pslc([adv,adv,adv,n,p,v,n,p,v,n,c,v,n,v,n,c,v,n,p,v,n,c,n,p,v,n,c,n,p,v]).
pslc([v,n,p,v,n,p,v]).
pslc([v,n,p,v]).
pslc([n,c,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([adv,adv,v,n,v,n,c,adv,v,n,n,p,v,n,c,n,c,n,p,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([n,p,v,n,p,v]).
pslc([adv,n,adv,adv,v]).
pslc([adv,v,n,p,v,n,v,n,c,v,n,c,v,n,c,n,p,v,n,p,v,n,c,v,n,c,v,n,p,v]).
pslc([adv,adv,v,n,p,v,n,c,v,n,c,v,n,c,adv,v,n,p,v,n,p,v,n,p,v]).
pslc([n,p,v,n,p,v,n,p,v]).
pslc([n,p,v,n,c,adv,adv,v,n,p,v,n,v,n,p,v]).
pslc([adv,v,n,p,v,n,p,v]).
pslc([adv,adv,v,n,p,v]).
pslc([adv,adv,v,n,p,v,n,p,v]).
pslc([v,n,p,v]).
pslc([adv,n,p,v,n,c,adv,adv,v,n,v,n,n,p,v]).
pslc([n,p,v]).
pslc([adv,n,p,v,n,p,v]).
pslc([adv,n,p,v,n,adv,adv,v,n,c,n,p,v,n,p,v,n,c,v,n,p,v]).
pslc([n,p,v]).
pslc([n,c,v,n,c,n,p,v,n,c,adv,v,n,v,n,p,v]).
pslc([n,p,v,n,p,v,n,p,v,n,p,v]).
pslc([v,n,p,v,n,p,v]).
pslc([v,n,c,adv,v,n,c,n,p,v,n,p,v,n,c,adv,adv,v,n,p,v,n,p,v]).
pslc([n,p,v]).
pslc([v,n,p,v,n,p,v,n,c,adv,adv,v,n,p,v,n,v,n,p,v,n,p,v,n,p,v,n,p,v]).
pslc([v,n,p,v]).
pslc([n,p,v]).
pslc([n,c,adv,adv,v,n,p,v]).
pslc([n,p,v]).

215
packages/prism/exs/plc.psm Normal file
View File

@ -0,0 +1,215 @@
%%%%
%%%% Probablistic left corner grammar --- plc.psm
%%%%
%%%% Copyright (C) 2004,2006,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This is a PRISM program modeling a probabilistic left-corner
%% parser (stack version) described in
%%
%% "Probabilistic Parsing using left corner language models",
%% C.D.Manning,
%% Proc. of the 5th Int'l Conf. on Parsing Technologies (IWPT-97),
%% MIT Press, pp.147-158.
%%
%% Note that this program defines a distribution over sentences
%% procedurally, i.e. the derivation process is described in terms
%% of stack operations. Also note that we automatically get
%% a correctness-guaranteed EM procedure for probablistic
%% left-corner grammars.
%%-------------------------------------
%% Quick start : sample session with Grammar_1 (attached below)
%%
%% (1) Move to a directory where this program is placed.
%% (2) Start PRISM (no options needed since 1.10)
%%
%% > prism
%%
%% (3) Load this program (by default, every msw is given a uniform
%% distribution)
%%
%% ?- prism(plc).
%%
%% (4) Use uitilities, e.g.
%% (4-1) Computing explanation (support) graphs and probabilities
%%
%% ?- prob(pslc([n,p,v])).
%% ?- probf(pslc([n,p,v])).
%% ?- probf(pslc([n,p,v]),E),print_graph(E).
%% ?- prob(pslc([adv,adv,n,c,n,p,v])).
%% ?- probf(pslc([adv,adv,n,c,n,p,v])).
%% ?- probf(pslc([adv,adv,n,c,n,p,v]),E),print_graph(E).
%%
%% Pv is prob. of a most likely explanation E for pslc([adv,...,v])
%% ?- viterbif(pslc([adv,adv,n,c,n,p,v]),Pv,E).
%% ?- viterbi(pslc([adv,adv,n,c,n,p,v]),Pv).
%%
%% (4-2) Sampling
%%
%% ?- sample(pslc(X)), sample(pslc(Y)), sample(pslc(Z)).
%%
%% (4-3) Graphical EM learning for Grammar_1 (wait for some time)
%%
%% ?- go.
go:- plc_learn(50). % Generate randomly 50 sentences and learn
max_str_len(30). % Sentence length <= 30
%%------------------------------------
%% Modeling part:
pslc(Ws) :-
start_symbol(C), % asserted in Grammar_1
pslc(Ws,[g(C)]). % C is a top-goal category
pslc([],[]).
pslc(L0,Stack0) :-
process(Stack0,Stack,L0,L),
pslc(L,Stack).
%% shift operation
process([g(A)|Rest],Stack,[Wd|L],L):- % g(A) is a goal category
( terminal(A), % Stack given = [g(A),g(F),D...] created
A = Wd, Stack = Rest % by e.g. projection using E -> D,A,F
; \+ terminal(A), % Select probabilistically one of first(A)
( get_values(first(A),[Wd]) % No choice if the first set is a singleton
; get_values(first(A),[_,_|_]), % Select 1st word by msw
msw(first(A),Wd) ),
Stack = [Wd,g(A)|Rest]
).
%% projection and attachment
process([A|Rest],Stack,L,L):- % a subtree with top=A is completed
\+ A = g(_), % A's right neighbor has the form g(_)
Rest = [g(C)|Stack0], % => A is not a terminal
( A == C, % g(A) is waiting for an A-tree
( get_values(lc(A,A),_), % lc(X,Y) means X - left-corner -> Y
msw(attach(A),Op), % A must have a chance of not attaching
( Op == attach, Stack = Stack0 % attachment
; Op == project, next_Stack(A,Rest,Stack) ) % projection
; \+ get_values(lc(A,A),_),
Stack = Stack0 ) % forcible attachment for nonterminal
; A \== C,
next_Stack(A,Rest,Stack) ).
%% projection % subtree A completed, waited for by g(C)
next_Stack(A,[g(C)|Rest2],Stack) :- % rule I -> A J K
( get_values(lc(C,A),[_,_|_]), % => Stack=[g(J),g(K),I,g(C)...]
msw(lc(C,A),rule(LHS,[A|RHS2])) % if C - left-corner -> A
; get_values(lc(C,A),[rule(LHS,[A|RHS2])]) ), % no other rules for projection
predict(RHS2,[LHS,g(C)|Rest2],Stack).
predict([],L,L).
predict([A|Ls],L2,[g(A)|NewLs]):-
predict(Ls,L2,NewLs).
%%------------------------------------
%% Utility part:
plc_learn(N):-
gen_plc(N,Goals),
learn(Goals).
gen_plc(0,[]).
gen_plc(N,Goals):-
N > 0,
N1 is N-1,
sample(pslc(L)),
length(L,K),
max_str_len(StrL),
( K > StrL,
Goals = G2
; Goals=[pslc(L)|G2],
format(" G = ~w~n",[pslc(L)])
),!,
gen_plc(N1,G2).
%%--------------- Grammar_1 -----------------
start_symbol(s).
rule(s,[pp,v]).
rule(s,[ap,vp]).
rule(vp,[pp,v]).
rule(vp,[ap,v]).
rule(np,[vp,n]).
rule(np,[v,n]).
rule(np,[n]).
rule(np,[np,c,np]).
rule(np,[ap,np]).
rule(pp,[np,p]).
rule(pp,[n,p]).
rule(ap,[adv,adv]).
rule(ap,[adv]).
rule(ap,[adv,np]).
terminal(v).
terminal(n).
terminal(c).
terminal(p).
terminal(adv).
%% first set computed from Grammar_1
first(vp,v).
first(np,v).
first(pp,v).
first(s,v).
first(vp,n).
first(np,n).
first(pp,n).
first(s,n).
first(vp,adv).
first(ap,adv).
first(np,adv).
first(pp,adv).
first(s,adv).
%%------------------------------------
%% Declarations:
%%
%% created from Grammar_1
values(lc(s,pp),[rule(s,[pp,v]),rule(vp,[pp,v])]).
values(lc(s,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(s,vp),[rule(np,[vp,n])]).
values(lc(pp,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(pp,vp),[rule(np,[vp,n])]).
values(lc(pp,pp),[rule(vp,[pp,v])]).
values(lc(np,vp),[rule(np,[vp,n])]).
values(lc(np,pp),[rule(vp,[pp,v])]).
values(lc(np,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(vp,pp),[rule(vp,[pp,v])]).
values(lc(vp,np),[rule(np,[np,c,np]),rule(pp,[np,p])]).
values(lc(vp,vp),[rule(np,[vp,n])]).
values(lc(vp,ap),[rule(np,[ap,np]),rule(vp,[ap,v])]).
values(lc(vp,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(ap,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(vp,v),[rule(np,[v,n])]).
values(lc(vp,n),[rule(np,[n]),rule(pp,[n,p])]).
values(lc(np,v),[rule(np,[v,n])]).
values(lc(np,n),[rule(np,[n]),rule(pp,[n,p])]).
values(lc(np,ap),[rule(np,[ap,np]),rule(vp,[ap,v])]).
values(lc(np,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(pp,n),[rule(np,[n]),rule(pp,[n,p])]).
values(lc(pp,ap),[rule(np,[ap,np]),rule(vp,[ap,v])]).
values(lc(pp,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(pp,v),[rule(np,[v,n])]).
values(lc(s,ap),[rule(np,[ap,np]),rule(s,[ap,vp]),rule(vp,[ap,v])]).
values(lc(s,adv),[rule(ap,[adv]),rule(ap,[adv,adv]),rule(ap,[adv,np])]).
values(lc(s,v),[rule(np,[v,n])]).
values(lc(s,n),[rule(np,[n]),rule(pp,[n,p])]).
values(first(s),[adv,n,v]).
values(first(vp),[adv,n,v]).
values(first(np),[adv,n,v]).
values(first(pp),[adv,n,v]).
values(first(ap),[adv]).
values(attach(s),[attach,project]).
values(attach(vp),[attach,project]).
values(attach(np),[attach,project]).
values(attach(pp),[attach,project]).
values(attach(ap),[attach,project]).

130
packages/prism/exs/sbn.psm Normal file
View File

@ -0,0 +1,130 @@
%%%%
%%%% Bayesian networks (2) -- sbn.psm
%%%%
%%%% Copyright (C) 2004,2008
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% This example shows how to simulate Pearl's message passing
%% (without normalization) for singly connected BNs (Bayesian networks).
%%
%% Suppose that we have a Bayesian network in Fiugre 1 and that
%% we wish to compute marginal probabilites P(B) of B.
%% The distribution defined by the BN in Figure 1 is expressed
%% by a BN program in Figure 3. We transform it into another
%% program that defines the same marginal distribuion for B.
%%
%% Original graph Transformed graph
%%
%% A B B
%% / \ / |
%% / \ / v
%% C D ==> D
%% / \ / | \
%% / \ / v v
%% E F A E F
%% /
%% v
%% C
%% (Figure 1) (Figure 2)
%%
%% Original BN program for Figure 1
%%
world(VA,VB,VC,VD,VE,VF):-
msw(par('A',[]),VA), msw(par('B',[]),VB),
msw(par('C',[VA]),VC), msw(par('D',[VA,VB]),VD),
msw(par('E',[VD]),VE), msw(par('F',[VD]),VF).
check_B(VB):- world(_,VB,_,_,_,_).
%%
%% (Figure 3)
%%
%% Transformation:
%% [Step 1] Transform the orignal BN in Figure 1 into Figure 2 by letting
%% B be the top node and other nodes dangle from B.
%% [Step 2] Construct a program that calls nodes in Figure 2 from the top
%% node to leaves. For example for D, add clause
%%
%% call_BD(VB):- call_DA(VA),call_DE(VE),call_DF(VF).
%%
%% while inserting an msw expressing the CPT P(D|A,B) in the body. Here,
%%
%% call_XY(V) <=>
%% node Y is called from X with ground term V (=X's realization)
%%
%% It can be proved by unfolding that the transformed program is equivalent
%% in distribution semantics to the original program in Figure 3.
%% => Both programs compute the same marginal distribution for B.
%% Confirm by ?- prob(ask_B(2),X),prob(check_B(2),Y).
%%-------------------------------------
%% Quick start : sample session
%%
%% ?- prism(sbn),go. % Learn parameters from randomly generated
%% % 100 samples while preserving the marginal
%% % disribution P(B)
%%
%% ?- prob(ask_B(2)).
%% ?- prob(ask_B(2),X),prob(check_B(2),Y). % => X=Y
%% ?- probf(ask_B(2)).
%% ?- sample(ask_B(X)).
%%
%% ?- viterbi(ask_B(2)).
%% ?- viterbif(ask_B(2),P,E),print_graph(E).
go:- sbn_learn(100).
%%------------------------------------
%% Declarations:
values(par('A',[]), [0,1]). % Declare msw(par('A',[]),VA) where
values(par('B',[]), [2,3]). % VA is one of {0,1}
values(par('C',[_]), [4,5]).
values(par('D',[_,_]),[6,7]). % Declare msw(par('D',[VA,VB]),VD) where
values(par('E',[_]), [8,9]). % VD is one of {6,7}
values(par('F',[_]), [10,11]).
set_params:- % Call set_sw/2 built-in
set_sw(par('A',[]), [0.3,0.7]),
set_sw(par('B',[]), uniform), % => [0.5,0.5]
set_sw(par('C',[0]), f_geometric(3,asc)), % => [0.25,0.75]
set_sw(par('C',[1]), f_geometric(3,desc)), % => [0.75,0.25]
set_sw(par('D',[0,2]),f_geometric(3)), % => [0.75,0.25]
set_sw(par('D',[1,2]),f_geometric(2)), % => [0.666...,0.333...]
set_sw(par('D',[0,3]),f_geometric), % => [0.666...,0.333...]
set_sw(par('D',[1,3]),[0.3,0.7]),
set_sw(par('E',[6]), [0.3,0.7]),
set_sw(par('E',[7]), [0.1,0.9]),
set_sw(par('F',[6]), [0.3,0.7]),
set_sw(par('F',[7]), [0.1,0.9]).
:- set_params.
%%------------------------------------
%% Modeling part: transformed program defining P(B)
ask_B(VB) :- % ?- prob(ask_B(2),X)
msw(par('B',[]),VB), % => X = P(B=2)
call_BD(VB).
call_BD(VB):- % msw's Id must be ground
call_DA(VA), % => VA must be ground
msw(par('D',[VA,VB]),VD), % => call_DA(VA)
call_DE(VD), % before msw(par('D',[VA,VB]),VD)
call_DF(VD).
call_DA(VA):-
msw(par('A',[]),VA),
call_AC(VA).
call_AC(VA):-
msw(par('C',[VA]),_VC).
call_DE(VD):-
msw(par('E',[VD]),_VE).
call_DF(VD):-
msw(par('F',[VD]),_VF).
%%------------------------------------
%% Utility part:
sbn_learn(N):- % Learn parameters (CPTs) from a list of
random_set_seed(123456), % N randomly generated ask_B(.) atoms
set_params,
get_samples(N,ask_B(_),Goals),
learn(Goals).

112
packages/prism/exs/votes.psm Normal file
View File

@ -0,0 +1,112 @@
%%%%
%%%% Evaluation of a naive Bayes classifier for `votes' dataset
%%%% --- votes.psm
%%%%
%%%% Copyright (C) 2009
%%%% Sato Laboratory, Dept. of Computer Science,
%%%% Tokyo Institute of Technology
%% In this program, we conduct n-fold cross validation of a naive Bayes
%% classifier. This program was created to demonstrate the usefulness of
%% the built-in predicates introduced since version 1.12. The target
%% dataset is the congressional voting records (`votes') dataset, which
%% is available from UCI machine learning repository (http://archive.ics.
%% uci.edu/ml/).
%%
%% From this program, it is seen that, using new built-in predicates such
%% as maplist/5, avglist/2, random_shuffle/2, and so on, we can make the
%% utility part compact, as well as the modeling part. Also one may find
%% that we only combine general-purpose built-ins to implement n-fold cross
%% validation.
%%-------------------------------------
%% Quick start : sample session
%%
%% (Preparation: Download the data file `house-votes-84.data' from UCI ML
%% repository, and put it `as-is' on the current directly)
%%
%% ?- prism(votes),votes_learn. % Learn parameters from the whole dataset
%%
%% ?- prism(votes),votes_cv(10). % Conduct 10-fold cross validation
%%
%%-------------------------------------
%% Declarations
values(class,[democrat,republican]). % class labels
values(attr(_,_),[y,n]). % all attributes have two values: y or n
%%-------------------------------------
%% Modeling part (a naive Bayes model)
%%
%% [Note]
%% According to `house-votes-84.names', a data description file for the
%% `votes' dataset, '?' simply denotes that the value is not "yea" nor
%% "nay". On the other hand, in this program, we consider '?' as a missing
%% value just for demonstration purpose.
nbayes(C,Vals):- msw(class,C),nbayes(1,C,Vals).
nbayes(_,_,[]).
nbayes(J,C,[V|Vals]):-
choose(J,C,V),
J1 is J+1,
nbayes(J1,C,Vals).
choose(J,C,V):-
( V == '?' -> msw(attr(J,C),_) % handling '?' as a missing value
; msw(attr(J,C),V0),
V = V0
).
%%-------------------------------------
%% Utility part:
%% Batch routine for a simple learning
votes_learn:-
load_data_file(Gs),
learn(Gs).
%% Batch routine for N-fold cross validation
votes_cv(N):-
random_set_seed(81729), % Fix the random seed to keep the same splitting
load_data_file(Gs0), % Load the entire data
random_shuffle(Gs0,Gs), % Randomly reorder the data
numlist(1,N,Ks), % Get Ks = [1,...,N] (B-Prolog built-in)
maplist(K,Rate,votes_cv(Gs,K,N,Rate),Ks,Rates),
% Call votes_cv/2 for K=1...N
avglist(Rates,AvgRate), % Get the avg. of the precisions
maplist(K,Rate,format("Test #~d: ~2f%~n",[K,Rate*100]),Ks,Rates),
format("Average: ~2f%~n",[AvgRate*100]).
%% Subroutine for learning and testing for K-th split data (K = 1...N)
votes_cv(Gs,K,N,Rate):-
format("<<<< Test #~d >>>>~n",[K]),
separate_data(Gs,K,N,Gs0,Gs1), % Gs0: training data, Gs1: test data
learn(Gs0), % Learn by PRISM's built-in
maplist(nbayes(C,Vs),R,(viterbig(nbayes(C0,Vs)),(C0==C->R=1;R=0)),Gs1,Rs),
% Predict the class by viterbig/1 for each test example
% and evaluate it with the answer class label
avglist(Rs,Rate), % Get the accuracy for the K-th splitting
format("Done (~2f%).~n~n",[Rate*100]).
%% Split the entire data (Data) into the training data (Train)
%% and the test data (Test) for the K-th evaluation (K=1...N)
separate_data(Data,K,N,Train,Test):-
length(Data,L),
L0 is L*(K-1)//N, % L0: offset of the test data (// - integer division)
L1 is L*(K-0)//N-L0, % L1: size of the test data
splitlist(Train0,Rest,Data,L0), % Length of Train0 = L0
splitlist(Test,Train1,Rest,L1), % Length of Test = L1
append(Train0,Train1,Train).
%% Load the `votes' data in CSV form and convert it to suitable
%% Prolog terms
load_data_file(Gs):-
load_csv('house-votes-84.data',Gs0),
maplist(csvrow([C|Vs]),nbayes(C,Vs),true,Gs0,Gs).

16
packages/prism/src/README Normal file
View File

@ -0,0 +1,16 @@
========================== README (src) ==========================
This directory contains the source files of the PRISM part, along
with a minimal set of source and binary files from B-Prolog,
required to build the PRISM system:
c/ ... C code
prolog/ ... Prolog code
Please use/modify/distribute the source code based on the license
agreements described $(TOP)/LICENSE and $(TOP)/LICENSE.src, where
$(TOP) is the top directory in the unfolded package.
To build the PRISM system, we need to compile both C and Prolog
source files. Please follow the instructions described in READMEs
at the `c' and `prolog' directories.

93
packages/prism/src/c/Makefile.in Normal file
View File

@ -0,0 +1,93 @@
# -*- Makefile -*-
#
# default base directory for YAP installation
# (EROOT for architecture-dependent files)
#
prefix = @prefix@
exec_prefix = @exec_prefix@
ROOTDIR = $(prefix)
EROOTDIR = @exec_prefix@
abs_top_builddir = @abs_top_builddir@
#
# where the binary should be
#
BINDIR = $(EROOTDIR)/bin
#
# where YAP should look for libraries
#
TARGETS= prism.@SO@
LIBDIR=@libdir@
YAPLIBDIR=@libdir@/Yap
YAP_EXTRAS=@YAP_EXTRAS@ -D_YAP_NOT_INSTALLED_=1 -D__YAP_PROLOG__=1
#
#
CC=@CC@
CFLAGS= @SHLIB_CFLAGS@ $(YAP_EXTRAS) $(DEFS) -I$(srcdir) -I../../../.. -I$(srcdir)/../../../../include -I$(srcdir)/../../../../H -I$(srcdir)/../../../../library/dialect/bprolog/fli
LDFLAGS=@LDFLAGS@
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
SHELL=/bin/sh
RANLIB=@RANLIB@
srcdir=@srcdir@
SO=@SO@
#4.1VPATH=@srcdir@:@srcdir@/OPTYap
CWD=$(PWD)
#
RM=rm -f
##----------------------------------------------------------------------
ifeq ($(PROCTYPE),mp)
SUBDIRS += $(MP_DIR)
OBJS += $(MP_OBJS)
endif
##----------------------------------------------------------------------
include $(srcdir)/makefiles/Makefile.files
S=/
O=o
SOBJS=prism.@SO@
#in some systems we just create a single object, in others we need to
# create a libray
all: $(SOBJS)
core/%.o: $(srcdir)/core/%.c
$(CC) -c $(CFLAGS) $< -o $@
up/%.o: $(srcdir)/up/%.c
$(CC) -c $(CFLAGS) $< -o $@
mp/%.o: $(srcdir)/mp/%.c
$(CC) -c $(CFLAGS) $< -o $@
@DO_SECOND_LD@prism.@SO@: $(OBJS)
@DO_SECOND_LD@ @SHLIB_LD@ $(LDFLAGS) -o $@ $(OBJS) @EXTRA_LIBS_FOR_DLLS@
all: $(TARGETS)
install: $(TARGETS)
$(INSTALL_PROGRAM) $(SOBJS) $(DESTDIR)$(YAPLIBDIR)
clean: clean_subdirs
$(RM) $(TARGET)
clean_subdirs:
for i in $(SUBDIRS); do \
$(RM) $$i/*.o; \
done
##----------------------------------------------------------------------
.PHONY: all install clean $(SUBDIRS)
##----------------------------------------------------------------------

401
packages/prism/src/c/core/bpx.c Normal file
View File

@ -0,0 +1,401 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <assert.h>
#include "core/bpx.h"
#include "core/vector.h"
/*--------------------------------------------------------------------*/
#define REQUIRE_HEAP(n) \
( heap_top + (n) <= local_top ? \
(void)(0) : myquit(STACK_OVERFLOW, "stack + heap") )
/*--------------------------------------------------------------------*/
/* Functions from B-Prolog */
/* cpred.c */
int bp_string_2_term(const char *, TERM, TERM);
char* bp_term_2_string(TERM);
int bp_call_term(TERM);
int bp_mount_query_term(TERM);
int bp_next_solution(void);
/* file.c */
void write_term(TERM);
/* float1.c */
double floatval(TERM);
TERM encodefloat1(double);
/* loader.c */
SYM_REC_PTR insert(const char *, int, int);
/* mic.c */
NORET quit(const char *);
NORET myquit(int, const char *);
/* unify.c */
int unify(TERM, TERM);
int is_UNIFIABLE(TERM, TERM);
int is_IDENTICAL(TERM, TERM);
/* prism.c */
NORET bp4p_quit(int);
/*--------------------------------------------------------------------*/
static NORET bpx_raise(const char *fmt, ...)
{
va_list ap;
fprintf(curr_out, "*** {PRISM BPX ERROR: ");
va_start(ap, fmt);
vfprintf(curr_out, fmt, ap);
va_end(ap);
fprintf(curr_out, "}\n");
bp4p_quit(1);
}
/*--------------------------------------------------------------------*/
bool bpx_is_var(TERM t)
{
XDEREF(t);
return ISREF(t);
}
bool bpx_is_atom(TERM t)
{
XDEREF(t);
return ISATOM(t);
}
bool bpx_is_integer(TERM t)
{
XDEREF(t);
return ISINT(t);
}
bool bpx_is_float(TERM t)
{
XDEREF(t);
return ISNUM(t);
}
bool bpx_is_nil(TERM t)
{
XDEREF(t);
return ISNIL(t);
}
bool bpx_is_list(TERM t)
{
XDEREF(t);
return ISLIST(t);
}
bool bpx_is_structure(TERM t)
{
XDEREF(t);
return ISSTRUCT(t);
}
bool bpx_is_compound(TERM t)
{
XDEREF(t);
return ISCOMPOUND(t);
}
bool bpx_is_unifiable(TERM t1, TERM t2)
{
XDEREF(t1);
XDEREF(t2);
return (bool)(is_UNIFIABLE(t1, t2));
}
bool bpx_is_identical(TERM t1, TERM t2)
{
XDEREF(t1);
XDEREF(t2);
return (bool)(is_IDENTICAL(t1, t2));
}
/*--------------------------------------------------------------------*/
TERM bpx_get_call_arg(BPLONG i, BPLONG arity)
{
if (i < 1 || i > arity) {
bpx_raise("index out of range");
}
return ARG(i, arity);
}
BPLONG bpx_get_integer(TERM t)
{
XDEREF(t);
if (ISINT(t)) {
return INTVAL(t);
}
else {
bpx_raise("integer expected");
}
}
double bpx_get_float(TERM t)
{
XDEREF(t);
if (ISINT(t)) {
return (double)(INTVAL(t));
}
else if (ISFLOAT(t)) {
return floatval(t);
}
else {
bpx_raise("integer or floating number expected");
}
}
const char * bpx_get_name(TERM t)
{
XDEREF(t);
switch (XTAG(t)) {
case STR:
return GET_NAME_STR(GET_STR_SYM_REC(t));
case ATM:
return GET_NAME_ATOM(GET_ATM_SYM_REC(t));
case LST:
return ".";
default:
bpx_raise("callable expected");
}
}
int bpx_get_arity(TERM t)
{
XDEREF(t);
switch (XTAG(t)) {
case STR:
return GET_ARITY_STR(GET_STR_SYM_REC(t));
case ATM:
return GET_ARITY_ATOM(GET_ATM_SYM_REC(t));
case LST:
return 2;
default:
bpx_raise("callable expected");
}
}
TERM bpx_get_arg(BPLONG i, TERM t)
{
BPLONG n, j;
XDEREF(t);
switch (XTAG(t)) {
case STR:
n = GET_ARITY_STR(GET_STR_SYM_REC(t));
j = 0;
break;
case LST:
n = 2;
j = 1;
break;
default:
bpx_raise("compound expected");
}
if (i < 1 || i > n) {
bpx_raise("bad argument index");
}
return GET_ARG(t, i - j);
}
TERM bpx_get_car(TERM t)
{
XDEREF(t);
if (ISLIST(t)) {
return GET_CAR(t);
}
else {
bpx_raise("list expected");
}
}
TERM bpx_get_cdr(TERM t)
{
XDEREF(t);
if (ISLIST(t)) {
return GET_CDR(t);
}
else {
bpx_raise("list expected");
}
}
/*--------------------------------------------------------------------*/
TERM bpx_build_var(void)
{
TERM term;
REQUIRE_HEAP(1);
term = (TERM)(heap_top);
NEW_HEAP_FREE;
return term;
}
TERM bpx_build_integer(BPLONG n)
{
return MAKEINT(n);
}
TERM bpx_build_float(double x)
{
REQUIRE_HEAP(4);
return encodefloat1(x);
}
TERM bpx_build_atom(const char *name)
{
SYM_REC_PTR sym;
sym = insert(name, strlen(name), 0);
return ADDTAG(sym, ATM);
}
TERM bpx_build_list(void)
{
TERM term;
REQUIRE_HEAP(2);
term = ADDTAG(heap_top, LST);
NEW_HEAP_FREE;
NEW_HEAP_FREE;
return term;
}
TERM bpx_build_nil(void)
{
return nil_sym;
}
TERM bpx_build_structure(const char *name, BPLONG arity)
{
SYM_REC_PTR sym;
TERM term;
REQUIRE_HEAP(arity + 1);
term = ADDTAG(heap_top, STR);
sym = insert(name, strlen(name), arity);
NEW_HEAP_NODE((TERM)(sym));
while (--arity >= 0) {
NEW_HEAP_FREE;
}
return term;
}
/*--------------------------------------------------------------------*/
bool bpx_unify(TERM t1, TERM t2)
{
return (bool)(unify(t1, t2));
}
/*--------------------------------------------------------------------*/
TERM bpx_string_2_term(const char *s)
{
TERM term, vars;
int result;
REQUIRE_HEAP(2);
term = (TERM)(heap_top);
NEW_HEAP_FREE;
vars = (TERM)(heap_top);
NEW_HEAP_FREE;
result = bp_string_2_term(s, term, vars);
if (result != BP_TRUE) {
bpx_raise("parsing failed -- %s", s);
}
return term;
}
const char * bpx_term_2_string(TERM t)
{
XDEREF(t);
return bp_term_2_string(t);
}
/*--------------------------------------------------------------------*/
int bpx_call_term(TERM t)
{
XDEREF(t);
return bp_call_term(t);
}
int bpx_call_string(const char *s)
{
return bp_call_term(bpx_string_2_term(s));
}
int bpx_mount_query_term(TERM t)
{
XDEREF(t);
return bp_mount_query_term(t);
}
int bpx_mount_query_string(const char *s)
{
return bp_mount_query_term(bpx_string_2_term(s));
}
int bpx_next_solution(void)
{
if (curr_toam_status == TOAM_NOTSET) {
bpx_raise("no goal mounted");
}
return bp_next_solution();
}
/*--------------------------------------------------------------------*/
void bpx_write(TERM t)
{
XDEREF(t);
write_term(t);
}
/*--------------------------------------------------------------------*/
int bpx_printf(const char *fmt, ...)
{
va_list ap;
int r;
va_start(ap, fmt);
r = vfprintf(curr_out, fmt, ap);
va_end(ap);
return r;
}
/*--------------------------------------------------------------------*/
#ifdef __YAP_PROLOG__
BPLONG toam_signal_vec;
BPLONG illegal_arguments;
BPLONG failure_atom;
BPLONG number_var_exception;
#endif

323
packages/prism/src/c/core/bpx.h Normal file
View File

@ -0,0 +1,323 @@
#ifndef BPX_H
#define BPX_H
#include "bprolog.h"
#include "stuff.h"
#ifdef __YAP_PROLOG__
#include <stdio.h>
#include <stdlib.h>
#include <YapTerm.h>
#include <YapTags.h>
#include <YapRegs.h>
typedef void *SYM_REC_PTR;
#define heap_top H
#define local_top ASP
#define trail_top TR
#define trail_up_addr ((tr_fr_ptr)LCL0)
#define UNDO_TRAILING while (TR > (tr_fr_ptr)trail_top0) { RESET_VARIABLE(VarOfTerm(TrailTerm(TR--))); }
#define NEW_HEAP_NODE(x) (*heap_top++ = (x))
#define STACK_OVERFLOW 1
/*====================================================================*/
#define ARG(X,Y) XREGS[X]
#define XDEREF(T) while (IsVarTerm(T)) { CELL *next = VarOfTerm(T); if (IsUnboundVar(next)) break; (T) = *next; }
#define MAKEINT(I) bp_build_integer(I)
#define INTVAL(T) bp_get_integer(T)
#define MAX_ARITY 256
#define BP_MALLOC(X,Y,Z) ( X = malloc((Y)*sizeof(BPLONG)) )
#define NULL_TERM ((TERM)(0))
#define REF0 0x0L
#define REF1 0x1L
#define SUSP 0x2L
#define LST 0x4L
#define ATM 0x8L
#define INT 0x10L
#define STR 0x20L
#define NVAR (LST|ATM|INT|STR)
#define GET_STR_SYM_REC(p) ((SYM_REC_PTR)*RepAppl(p))
#define GET_ATM_SYM_REC(p) ((SYM_REC_PTR)AtomOfTerm(p))
#define GET_ARITY_STR(s) YAP_ArityOfFunctor((YAP_Functor)(s))
#define GET_ARITY_ATOM(s) 0
#define GET_NAME_STR(f) YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(f)))
#define GET_NAME_ATOM(a) YAP_AtomName((YAP_Atom)(a))
static inline
long int XTAG(TERM t)
{
switch(YAP_TagOfTerm(t)) {
case YAP_TAG_UNBOUND:
return REF0;
case YAP_TAG_ATT:
return SUSP;
case YAP_TAG_REF:
return REF1;
case YAP_TAG_PAIR:
return LST;
case YAP_TAG_ATOM:
return ATM;
case YAP_TAG_INT:
return INT;
case YAP_TAG_LONG_INT:
return INT;
case YAP_TAG_APPL:
default:
return STR;
}
}
extern inline TERM ADDTAG(void * t,int tag) {
if (tag == ATM)
return MkAtomTerm((Atom)t);
if (tag == LST)
return AbsPair((CELL *)t);
return AbsAppl((CELL *)t);
}
#define ISREF(t) IsVarTerm(t)
#define ISATOM(t) IsAtomTerm(t)
#define ISINT(t) IsIntegerTerm(t)
#define ISNUM(t) YAP_IsNumberTerm(t)
#define ISNIL(t) YAP_IsTermNil(t)
#define ISLIST(t) IsPairTerm(t)
#define ISSTRUCT(t) IsApplTerm(t)
#define ISFLOAT(t) IsFloatTerm(t)
#define ISCOMPOUND(t) YAP_IsCompoundTerm(t)
#define floatval FloatOfTerm
#define encodefloat1 MkFloatTerm
extern inline int is_UNIFIABLE(TERM t1, TERM t2)
{
return YAP_Unifiable(t1, t2);
}
extern inline int is_IDENTICAL(TERM t1, TERM t2)
{
return YAP_ExactlyEqual(t1, t2);
}
#define SWITCH_OP(T,NDEREF,VCODE,ACODE,LCODE,SCODE,SUCODE) \
switch (XTAG((T))) { \
case REF0: \
VCODE \
case LST: \
LCODE \
case SUSP: \
SUCODE \
case STR: \
SCODE \
default: \
ACODE \
}
#define XNDEREF(X,LAB)
#define GET_ARG(A,I) YAP_ArgOfTerm((I),(A))
#define GET_CAR(A) YAP_HeadOfTerm(A)
#define GET_CDR(A) YAP_TailOfTerm(A)
#define MAKE_NVAR(id) ( (YAP_Term)(id) )
#define float_psc ((YAP_Functor)FunctorDouble)
#define NEW_HEAP_FREE (*H = (CELL)H); H++
#define nil_sym YAP_TermNil()
extern BPLONG illegal_arguments;
extern BPLONG failure_atom;
extern BPLONG number_var_exception;
extern BPLONG toam_signal_vec;
#define unify YAP_Unify
extern inline char *
bp_term_2_string(TERM t)
{
char *buf = malloc(256);
if (!buf) return NULL;
YAP_WriteBuffer(t, buf, 256, 0);
return buf;
}
// char *bp_get_name(TERM t)
extern inline int
bp_string_2_term(const char *s, TERM to, TERM tv)
{
TERM t0 = YAP_ReadBuffer(s, NULL);
TERM t1 = YAP_TermNil(); // for now
return unify(t0, to) && unify(t1,tv);
}
extern inline SYM_REC_PTR
insert(const char *name, int size, int arity)
{
if (!arity) {
return (SYM_REC_PTR)YAP_LookupAtom(name);
}
return (SYM_REC_PTR)YAP_MkFunctor(YAP_LookupAtom(name), arity);
}
extern inline int
compare(TERM t1, TERM t2)
{
// compare terms??
return YAP_CompareTerms(t1,t2);
}
extern inline void
write_term(TERM t)
{
YAP_Write(t,NULL,0);
}
static NORET quit(const char *s)
{
fprintf(stderr,"PRISM QUIT: %s\n",s);
exit(0);
}
static NORET myquit(int i, const char *s)
{
fprintf(stderr,"PRISM QUIT: %s\n",s);
exit(i);
}
// vsc: why two arguments?
static inline int
list_length(BPLONG t1, BPLONG t2)
{
return YAP_ListLength((TERM)t1);
}
#define PRE_NUMBER_VAR(X)
static inline void
numberVarTermOpt(TERM t)
{
YAP_NumberVars(t, 0);
}
static inline TERM
unnumberVarTerm(TERM t, BPLONG_PTR pt1, BPLONG_PTR pt2)
{
return YAP_UnNumberVars(t);
}
extern inline int
unifyNumberedTerms(TERM t1, TERM t2)
{
if (YAP_Unify(t1,t2))
return TRUE;
return FALSE;
}
#define IsNumberedVar YAP_IsNumberedVariable
#else
#define GET_ARITY_ATOM GET_ARITY
#define GET_ARITY_STR GET_ARITY
#define GET_NAME_STR GET_NAME
#define GET_NAME_ATOM GET_NAME
/*====================================================================*/
#define NULL_TERM ((TERM)(0))
/*--------------------------------*/
/* These are the safer versions of DEREF and NDEREF macros. */
#define XDEREF(op) \
do { if(TAG(op) || (op) == FOLLOW(op)) { break; } (op) = FOLLOW(op); } while(1)
#define XNDEREF(op, label) \
do { if(TAG(op) || (op) == FOLLOW(op)) { break; } (op) = FOLLOW(op); goto label; } while(1)
/*--------------------------------*/
/* This low-level macro provides more detailed information about the */
/* type of a given term than TAG(op). */
#define XTAG(op) ((op) & TAG_MASK)
#define REF0 0x0L
#define REF1 TOP_BIT
#define INT INT_TAG
#define NVAR TAG_MASK
/*--------------------------------*/
/* The following macros are the same as IsNumberedVar and NumberVar */
/* respectively, provided just for more consistent naming. */
#define IS_NVAR(op) ( ((op) & TAG_MASK) == NVAR )
#define MAKE_NVAR(id) ( (((BPLONG)(id)) << 2) | NVAR )
/*--------------------------------*/
/* This macro is redefined to reduce warnings on GCC 4.x. */
#if defined LINUX && ! defined M64BITS
#undef UNTAGGED_ADDR
#define UNTAGGED_ADDR(op) ( (((BPLONG)(op)) & VAL_MASK0) | addr_top_bit )
#endif
/*====================================================================*/
#endif /* YAP */
bool bpx_is_var(TERM);
bool bpx_is_atom(TERM);
bool bpx_is_integer(TERM);
bool bpx_is_float(TERM);
bool bpx_is_nil(TERM);
bool bpx_is_list(TERM);
bool bpx_is_structure(TERM);
bool bpx_is_compound(TERM);
bool bpx_is_unifiable(TERM, TERM);
bool bpx_is_identical(TERM, TERM);
TERM bpx_get_call_arg(BPLONG, BPLONG);
BPLONG bpx_get_integer(TERM);
double bpx_get_float(TERM);
const char* bpx_get_name(TERM);
int bpx_get_arity(TERM);
TERM bpx_get_arg(BPLONG, TERM);
TERM bpx_get_car(TERM);
TERM bpx_get_cdr(TERM);
TERM bpx_build_var(void);
TERM bpx_build_integer(BPLONG);
TERM bpx_build_float(double);
TERM bpx_build_atom(const char *);
TERM bpx_build_list(void);
TERM bpx_build_nil(void);
TERM bpx_build_structure(const char *, BPLONG);
bool bpx_unify(TERM, TERM);
TERM bpx_string_2_term(const char *);
const char* bpx_term_2_string(TERM);
#endif /* BPX_H */

108
packages/prism/src/c/core/error.c Normal file
View File

@ -0,0 +1,108 @@
#include <stdarg.h>
#include "bprolog.h"
#include "core/bpx.h"
/*--------------------------------------------------------------------*/
#ifndef __YAP_PROLOG__
TERM bpx_build_atom(const char *);
#endif
/*--------------------------------------------------------------------*/
TERM err_runtime;
TERM err_internal;
TERM err_cycle_detected;
TERM err_invalid_likelihood;
TERM err_invalid_free_energy;
TERM err_invalid_numeric_value;
TERM err_invalid_goal_id;
TERM err_invalid_switch_instance_id;
TERM err_underflow;
TERM err_overflow;
TERM err_ctrl_c_pressed;
TERM ierr_invalid_likelihood;
TERM ierr_invalid_free_energy;
TERM ierr_function_not_implemented;
TERM ierr_unmatched_branches;
/*--------------------------------------------------------------------*/
TERM build_runtime_error(const char *s)
{
TERM t;
if (s == NULL) return bpx_build_atom("prism_runtime_error");
t = bpx_build_structure("prism_runtime_error",1);
bpx_unify(bpx_get_arg(1,t),bpx_build_atom(s));
return t;
}
TERM build_internal_error(const char *s)
{
TERM t;
if (s == NULL) return bpx_build_atom("prism_internal_error");
t = bpx_build_structure("prism_internal_error",1);
bpx_unify(bpx_get_arg(1,t),bpx_build_atom(s));
return t;
}
/*--------------------------------------------------------------------*/
void register_prism_errors(void)
{
err_runtime = build_runtime_error(NULL);
err_internal = build_internal_error(NULL);
err_cycle_detected = build_runtime_error("cycle_detected");
err_invalid_likelihood = build_runtime_error("invalid_likelihood");
err_invalid_free_energy = build_runtime_error("invalid_free_energy");
err_invalid_numeric_value = build_runtime_error("invalid_numeric_value");
err_invalid_goal_id = build_runtime_error("invalid_goal_id");
err_invalid_switch_instance_id = build_runtime_error("invalid_switch_instance_id");
err_underflow = build_runtime_error("underflow");
err_overflow = build_runtime_error("overflow");
err_ctrl_c_pressed = build_runtime_error("ctrl_c_pressed");
ierr_invalid_likelihood = build_internal_error("invalid_likelihood");
ierr_invalid_free_energy = build_internal_error("invalid_free_energy");
ierr_function_not_implemented = build_internal_error("function_not_implemented");
ierr_unmatched_branches = build_internal_error("unmatched_branches");
}
/*--------------------------------------------------------------------*/
void emit_error(const char *fmt, ...)
{
va_list ap;
fprintf(curr_out, "*** PRISM ERROR: ");
va_start(ap, fmt);
vfprintf(curr_out, fmt, ap);
va_end(ap);
fprintf(curr_out, "\n");
fflush(curr_out);
}
void emit_internal_error(const char *fmt, ...)
{
va_list ap;
fprintf(curr_out, "*** PRISM INTERNAL ERROR: ");
va_start(ap, fmt);
vfprintf(curr_out, fmt, ap);
va_end(ap);
fprintf(curr_out, "\n");
fflush(curr_out);
}
/*--------------------------------------------------------------------*/

66
packages/prism/src/c/core/error.h Normal file
View File

@ -0,0 +1,66 @@
#ifndef ERROR_H
#define ERROR_H
/*--------------------------------------------------------------------*/
#define RET_ERR(err) \
do { \
exception = (err); \
return BP_ERROR; \
} while (0)
#define RET_RUNTIME_ERR \
do { \
exception = err_runtime; \
return BP_ERROR; \
} while (0)
#define RET_INTERNAL_ERR \
do { \
exception = err_internal; \
return BP_ERROR; \
} while (0)
#define RET_ON_ERR(expr) \
do { \
if ((expr) == BP_ERROR) return BP_ERROR; \
} while (0)
#define RET_ERR_ON_ERR(expr,err) \
do { \
if ((expr) == BP_ERROR) { \
exception = (err); \
return BP_ERROR; \
} \
} while (0)
/*--------------------------------------------------------------------*/
extern TERM err_runtime;
extern TERM err_internal;
extern TERM err_cycle_detected;
extern TERM err_invalid_likelihood;
extern TERM err_invalid_free_energy;
extern TERM err_invalid_numeric_value;
extern TERM err_invalid_goal_id;
extern TERM err_invalid_switch_instance_id;
extern TERM err_underflow;
extern TERM err_overflow;
extern TERM err_ctrl_c_pressed;
extern TERM ierr_invalid_likelihood;
extern TERM ierr_invalid_free_energy;
extern TERM ierr_function_not_implemented;
extern TERM ierr_unmatched_branches;
/*--------------------------------------------------------------------*/
TERM build_runtime_error(const char *);
TERM build_internal_error(const char *);
void emit_error(const char *, ...);
void emit_internal_error(const char *, ...);
/*--------------------------------------------------------------------*/
#endif /* ERROR_H */

11
packages/prism/src/c/core/fputil.c Normal file
View File

@ -0,0 +1,11 @@
#include "core/fputil.h"
double fputil_snan(void)
{
return +sqrt(-1);
}
double fputil_qnan(void)
{
return -sqrt(-1);
}

51
packages/prism/src/c/core/fputil.h Normal file
View File

@ -0,0 +1,51 @@
#ifndef FPUTIL_H
#define FPUTIL_H
/*--------------------------------------------------------------------*/
#include <math.h>
#ifdef __STDC_VERSION__
#if __STDC_VERSION__ >= 199901L
#define C99
#endif
#endif
/*--------------------------------------------------------------------*/
#if defined C99
/* (empty) */
#elif defined _MSC_VER
#include <float.h>
#define isfinite _finite
#define isnan _isnan
#define INFINITY HUGE_VAL
#elif defined LINUX
# ifndef isfinite
# define isfinite finite
# endif
# ifndef isnan
# define isnan isnan
# endif
# ifndef INFINITY
# define INFINITY HUGE_VAL
# endif
#elif defined DARWIN
/* (empty) */
#else
#define isfinite(x) (0.0 * (x) != 0.0)
#define isnan(x) ((x) != (x))
#define INFINITY HUGE_VAL
#endif
#define SNAN fputil_snan()
#define QNAN fputil_qnan()
/*--------------------------------------------------------------------*/
double fputil_snan(void);
double fputil_qnan(void);
/*--------------------------------------------------------------------*/
#endif /* FPUTIL_H */

306
packages/prism/src/c/core/gamma.c Normal file
View File

@ -0,0 +1,306 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*-
This file contains a portable implementation for a couple of gamma-
family functions, originally written for the PRISM programming system
<http://sato-www.cs.titech.ac.jp/prism/>.
The code is based on SPECFUN (Fortran program collection for special
functions by W. J. Cody et al. at Argonne National Laboratory), which
is available in public domain at <http://www.netlib.org/specfun/>.
Here is the license terms for this file (just provided to explicitly
state that the code can be used for any purpose):
------------------------------------------------------------------------------
Copyright (c) 2007-2009 Yusuke Izumi
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
------------------------------------------------------------------------------
*/
#include <math.h>
#include "core/gamma.h"
#define PI (3.14159265358979323846) /* pi */
#define PI_2 (1.57079632679489661923) /* pi / 2 */
#define PI_4 (0.78539816339744830962) /* pi / 4 */
#define LN_SQRT2PI (0.91893853320467274178) /* ln(sqrt(2 * pi)) */
/**
* Computes ln(|Gamma(x)|).
*/
double lngamma(double x)
{
/* Constants for [0.5,1.5) -------------------------------------------*/
const double D1 = -5.772156649015328605195174e-01;
const double P1[] = {
+4.945235359296727046734888e+00, +2.018112620856775083915565e+02,
+2.290838373831346393026739e+03, +1.131967205903380828685045e+04,
+2.855724635671635335736389e+04, +3.848496228443793359990269e+04,
+2.637748787624195437963534e+04, +7.225813979700288197698961e+03
};
const double Q1[] = {
+6.748212550303777196073036e+01, +1.113332393857199323513008e+03,
+7.738757056935398733233834e+03, +2.763987074403340708898585e+04,
+5.499310206226157329794414e+04, +6.161122180066002127833352e+04,
+3.635127591501940507276287e+04, +8.785536302431013170870835e+03
};
/* Constants for [1.5,4.0) -------------------------------------------*/
const double D2 = +4.227843350984671393993777e-01;
const double P2[] = {
+4.974607845568932035012064e+00, +5.424138599891070494101986e+02,
+1.550693864978364947665077e+04, +1.847932904445632425417223e+05,
+1.088204769468828767498470e+06, +3.338152967987029735917223e+06,
+5.106661678927352456275255e+06, +3.074109054850539556250927e+06
};
const double Q2[] = {
+1.830328399370592604055942e+02, +7.765049321445005871323047e+03,
+1.331903827966074194402448e+05, +1.136705821321969608938755e+06,
+5.267964117437946917577538e+06, +1.346701454311101692290052e+07,
+1.782736530353274213975932e+07, +9.533095591844353613395747e+06
};
/* Constants for [4.0,12.0) ------------------------------------------*/
const double D4 = +1.791759469228055000094023e+00;
const double P4[] = {
+1.474502166059939948905062e+04, +2.426813369486704502836312e+06,
+1.214755574045093227939592e+08, +2.663432449630976949898078e+09,
+2.940378956634553899906876e+10, +1.702665737765398868392998e+11,
+4.926125793377430887588120e+11, +5.606251856223951465078242e+11
};
const double Q4[] = {
+2.690530175870899333379843e+03, +6.393885654300092398984238e+05,
+4.135599930241388052042842e+07, +1.120872109616147941376570e+09,
+1.488613728678813811542398e+10, +1.016803586272438228077304e+11,
+3.417476345507377132798597e+11, +4.463158187419713286462081e+11
};
/* Constants for [12.0,Infinity) -------------------------------------*/
const double C[] = {
-2.955065359477124231624146e-02, +6.410256410256410034009811e-03,
-1.917526917526917633674555e-03, +8.417508417508417139715760e-04,
-5.952380952380952917890600e-04, +7.936507936507936501052685e-04,
-2.777777777777777883788657e-03, +8.333333333333332870740406e-02
};
/*--------------------------------------------------------------------*/
const double EPS = 2.22e-16;
const double P68 = 87.0 / 128.0;
const double BIG = 2.25e+76;
/*--------------------------------------------------------------------*/
double p, q, y;
int i, n;
if (x != x) /* NaN */
return x;
else if (0 * x != 0) /* Infinity */
return HUGE_VAL;
else if (x <= 0.0) {
q = modf(-2.0 * x, &p);
n = (int)(p);
q = sin(PI_2 * (n % 2 == 0 ? q : 1.0 - q));
return log(PI / q) - lngamma(1.0 - x);
}
else if (x < EPS)
return -log(x);
else if (x < 0.5) {
p = 0.0;
q = 1.0;
y = x;
for (i = 0; i < 8; i++) {
p = p * y + P1[i];
q = q * y + Q1[i];
}
return x * (D1 + y * (p / q)) - log(x);
}
else if (x < P68) {
p = 0.0;
q = 1.0;
y = x - 1.0;
for (i = 0; i < 8; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
return y * (D2 + y * (p / q)) - log(x);
}
else if (x < 1.5) {
p = 0.0;
q = 1.0;
y = x - 1.0;
for (i = 0; i < 8; i++) {
p = p * y + P1[i];
q = q * y + Q1[i];
}
return y * (D1 + y * (p / q));
}
else if (x < 4.0) {
p = 0.0;
q = 1.0;
y = x - 2.0;
for (i = 0; i < 8; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
return y * (D2 + y * (p / q));
}
else if (x < 12.0) {
p = 0.0;
q = -1.0;
y = x - 4.0;
for (i = 0; i < 8; i++) {
p = p * y + P4[i];
q = q * y + Q4[i];
}
return D4 + y * (p / q);
}
else if (x < BIG) {
p = 0.0;
q = log(x);
y = 1.0 / (x * x);
for (i = 0; i < 8; i++) {
p = p * y + C[i];
}
return p / x + LN_SQRT2PI - 0.5 * q + x * (q - 1.0);
}
else {
q = log(x);
return LN_SQRT2PI - 0.5 * q + x * (q - 1.0);
}
/*--------------------------------------------------------------------*/
}
/**
* Computes Psi(x) = (d/dx)(ln(Gamma(x)))
*/
double digamma(double x)
{
/* Constants for [0.5,3.0] -------------------------------------------*/
const double P1[] = {
+4.5104681245762934160e-03, +5.4932855833000385356e+00,
+3.7646693175929276856e+02, +7.9525490849151998065e+03,
+7.1451595818951933210e+04, +3.0655976301987365674e+05,
+6.3606997788964458797e+05, +5.8041312783537569993e+05,
+1.6585695029761022321e+05
};
const double Q1[] = {
+9.6141654774222358525e+01, +2.6287715790581193330e+03,
+2.9862497022250277920e+04, +1.6206566091533671639e+05,
+4.3487880712768329037e+05, +5.4256384537269993733e+05,
+2.4242185002017985252e+05, +6.4155223783576225996e-08
};
/* Constants for (3.0,Infinity) --------------------------------------*/
const double P2[] = {
-2.7103228277757834192e+00, -1.5166271776896121383e+01,
-1.9784554148719218667e+01, -8.8100958828312219821e+00,
-1.4479614616899842986e+00, -7.3689600332394549911e-02,
-6.5135387732718171306e-21
};
const double Q2[] = {
+4.4992760373789365846e+01, +2.0240955312679931159e+02,
+2.4736979003315290057e+02, +1.0742543875702278326e+02,
+1.7463965060678569906e+01, +8.8427520398873480342e-01
};
/*--------------------------------------------------------------------*/
const double MIN = 2.23e-308;
const double MAX = 4.50e+015;
const double SMALL = 5.80e-009;
const double LARGE = 2.71e+014;
const double X01 = 187.0 / 128.0;
const double X02 = 6.9464496836234126266e-04;
/*--------------------------------------------------------------------*/
double p, q, y, sgn;
int i, n;
sgn = (x > 0.0) ? +1.0 : -1.0;
y = fabs(x);
if (x != x) /* NaN */
return x;
else if (x < -MAX || y < MIN)
return -1.0 * sgn * HUGE_VAL;
else if (y < SMALL)
return digamma(1.0 - x) - 1.0 / x;
else if (x < 0.5) {
q = modf(4.0 * y, &p);
n = (int)(p);
switch (n % 4) {
case 0:
return digamma(1.0 - x) - sgn * PI / tan(PI_4 * q);
case 1:
return digamma(1.0 - x) - sgn * PI * tan(PI_4 * (1.0 - q));
case 2:
return digamma(1.0 - x) + sgn * PI * tan(PI_4 * q);
case 3:
return digamma(1.0 - x) + sgn * PI / tan(PI_4 * (1.0 - q));
}
}
else if (x <= 3.0) {
p = 0.0;
q = 1.0;
for (i = 0; i < 8; i++) {
p = p * x + P1[i];
q = q * x + Q1[i];
}
p = p * x + P1[8];
return p / q * ((x - X01) - X02);
}
else if (x < LARGE) {
p = 0.0;
q = 1.0;
y = 1.0 / (x * x);
for (i = 0; i < 6; i++) {
p = p * y + P2[i];
q = q * y + Q2[i];
}
p = p * y + P2[6];
return p / q - 0.5 / x + log(x);
}
return log(x);
}

7
packages/prism/src/c/core/gamma.h Normal file
View File

@ -0,0 +1,7 @@
#ifndef GAMMA_H
#define GAMMA_H
double lngamma(double);
double digamma(double);
#endif /* GAMMA_H */

197
packages/prism/src/c/core/glue.c Normal file
View File

@ -0,0 +1,197 @@
#include <stdlib.h>
/*--------------------------------------------------------------------*/
#define REGISTER_CPRED(p,n) \
do { extern int pc_ ## p ## _ ## n (void); insert_cpred("$pc_" #p, n, pc_ ## p ## _ ## n); } while (0)
/*--------------------------------------------------------------------*/
typedef struct sym_rec * SYM_REC_PTR;
typedef long int TERM;
SYM_REC_PTR insert_cpred(const char *, int, int(*)(void));
void exit(int);
#ifdef __YAP_PROLOG__
int YAP_UserCpredicate(const char *s, int (*f)(void), unsigned long int n);
SYM_REC_PTR insert_cpred(const char *s, int n, int(*f)(void))
{
YAP_UserCPredicate(s, f, n);
return NULL;
}
#endif
/*--------------------------------------------------------------------*/
void register_prism_errors(void);
#ifdef MPI
void mp_init(int *argc, char **argv[]);
void mp_done(void);
void mp_quit(int);
#endif
/*--------------------------------------------------------------------*/
void bp4p_init(int *argc, char **argv[])
{
#ifdef MPI
mp_init(argc, argv);
#endif
}
void bp4p_exit(int status)
{
#ifdef MPI
mp_done();
#endif
exit(status);
}
void bp4p_quit(int status)
{
#ifdef MPI
mp_quit(status);
#else
exit(status);
#endif
}
void bp4p_register_preds(void)
{
/* core/idtable.c */
REGISTER_CPRED(prism_id_table_init,0);
REGISTER_CPRED(prism_goal_id_register,2);
REGISTER_CPRED(prism_sw_id_register,2);
REGISTER_CPRED(prism_sw_ins_id_register,2);
REGISTER_CPRED(prism_goal_id_get,2);
REGISTER_CPRED(prism_sw_id_get,2);
REGISTER_CPRED(prism_sw_ins_id_get,2);
REGISTER_CPRED(prism_goal_count,1);
REGISTER_CPRED(prism_sw_count,1);
REGISTER_CPRED(prism_sw_ins_count,1);
REGISTER_CPRED(prism_goal_term,2);
REGISTER_CPRED(prism_sw_term,2);
REGISTER_CPRED(prism_sw_ins_term,2);
/* core/random.c */
REGISTER_CPRED(random_auto_seed, 1);
REGISTER_CPRED(random_init_by_seed, 1);
REGISTER_CPRED(random_init_by_list, 1);
REGISTER_CPRED(random_float, 1);
REGISTER_CPRED(random_gaussian, 1);
REGISTER_CPRED(random_int, 2);
REGISTER_CPRED(random_int, 3);
REGISTER_CPRED(random_get_state, 1);
REGISTER_CPRED(random_set_state, 1);
/* core/util.c */
REGISTER_CPRED(lngamma, 2);
/* up/em_preds.c */
REGISTER_CPRED(prism_prepare,4);
REGISTER_CPRED(prism_em,6);
REGISTER_CPRED(prism_vbem,2);
REGISTER_CPRED(prism_both_em,2);
REGISTER_CPRED(compute_inside,2);
REGISTER_CPRED(compute_probf,1);
/* up/viterbi.c */
REGISTER_CPRED(compute_viterbi,5);
REGISTER_CPRED(compute_n_viterbi,3);
REGISTER_CPRED(compute_n_viterbi_rerank,4);
/* up/hindsight.c */
REGISTER_CPRED(compute_hindsight,4);
/* up/graph.c */
REGISTER_CPRED(alloc_egraph,0);
REGISTER_CPRED(clean_base_egraph,0);
REGISTER_CPRED(clean_egraph,0);
REGISTER_CPRED(export_switch,2);
REGISTER_CPRED(add_egraph_path,3);
REGISTER_CPRED(alloc_sort_egraph,1);
REGISTER_CPRED(clean_external_tables,0);
REGISTER_CPRED(export_sw_info,1);
REGISTER_CPRED(import_sorted_graph_size,1);
REGISTER_CPRED(import_sorted_graph_gid,2);
REGISTER_CPRED(import_sorted_graph_paths,2);
REGISTER_CPRED(get_gnode_inside,2);
REGISTER_CPRED(get_gnode_outside,2);
REGISTER_CPRED(get_gnode_viterbi,2);
REGISTER_CPRED(get_snode_inside,2);
REGISTER_CPRED(get_snode_expectation,2);
REGISTER_CPRED(import_occ_switches,3);
REGISTER_CPRED(import_graph_stats,4);
/* up/flags.c */
REGISTER_CPRED(set_daem,1);
REGISTER_CPRED(set_em_message,1);
REGISTER_CPRED(set_em_progress,1);
REGISTER_CPRED(set_error_on_cycle,1);
REGISTER_CPRED(set_explicit_empty_expls,1);
REGISTER_CPRED(set_fix_init_order,1);
REGISTER_CPRED(set_init_method,1);
REGISTER_CPRED(set_itemp_init,1);
REGISTER_CPRED(set_itemp_rate,1);
REGISTER_CPRED(set_log_scale,1);
REGISTER_CPRED(set_max_iterate,1);
REGISTER_CPRED(set_num_restart,1);
REGISTER_CPRED(set_prism_epsilon,1);
REGISTER_CPRED(set_show_itemp,1);
REGISTER_CPRED(set_std_ratio,1);
REGISTER_CPRED(set_verb_em,1);
REGISTER_CPRED(set_verb_graph,1);
REGISTER_CPRED(set_warn,1);
REGISTER_CPRED(set_debug_level,1);
/* up/util.c */
REGISTER_CPRED(mp_mode,0);
REGISTER_CPRED(get_term_depth,2);
REGISTER_CPRED(mtrace,0);
REGISTER_CPRED(muntrace,0);
REGISTER_CPRED(sleep,1);
#ifdef MPI
/* mp/mp_preds.c */
REGISTER_CPRED(mp_size,1);
REGISTER_CPRED(mp_rank,1);
REGISTER_CPRED(mp_master,0);
REGISTER_CPRED(mp_abort,0);
REGISTER_CPRED(mp_wtime,1);
REGISTER_CPRED(mp_sync,2);
REGISTER_CPRED(mp_send_goal,1);
REGISTER_CPRED(mp_recv_goal,1);
REGISTER_CPRED(mpm_bcast_command,1);
REGISTER_CPRED(mps_bcast_command,1);
REGISTER_CPRED(mps_revert_stdout,0);
/* mp/mp_em_preds.c */
REGISTER_CPRED(mpm_prism_em,6);
REGISTER_CPRED(mps_prism_em,0);
REGISTER_CPRED(mpm_prism_vbem,2);
REGISTER_CPRED(mps_prism_vbem,0);
REGISTER_CPRED(mpm_prism_both_em,2);
REGISTER_CPRED(mps_prism_both_em,0);
REGISTER_CPRED(mpm_import_graph_stats,4);
REGISTER_CPRED(mps_import_graph_stats,0);
/* mp/mp_sw.c */
REGISTER_CPRED(mp_send_switches,0);
REGISTER_CPRED(mp_recv_switches,0);
REGISTER_CPRED(mp_send_swlayout,0);
REGISTER_CPRED(mp_recv_swlayout,0);
REGISTER_CPRED(mpm_alloc_occ_switches,0);
/* mp/mp_flags.c */
REGISTER_CPRED(mpm_share_prism_flags,0);
REGISTER_CPRED(mps_share_prism_flags,0);
#endif
/* up/error.c; FIXME: There would be a better place to call */
register_prism_errors();
}
/*--------------------------------------------------------------------*/

9
packages/prism/src/c/core/glue.h Normal file
View File

@ -0,0 +1,9 @@
#ifndef GLUE_H
#define GLUE_H
void bp4p_init(void);
void bp4p_exit(int);
void bp4p_quit(int);
void bp4p_register_preds(void);
#endif /* GLUE_H */

175
packages/prism/src/c/core/idtable.c Normal file
View File

@ -0,0 +1,175 @@
#include "core/xmalloc.h"
#include "core/vector.h"
#include "core/termpool.h"
#include "core/idtable.h"
#include "core/stuff.h"
/*--------------------------------------------------------------------*/
/* table.c */
TERM unnumberVarTerm(TERM, BPLONG_PTR, BPLONG_PTR);
/*--------------------------------------------------------------------*/
struct id_table {
TERM_POOL *store;
struct id_table_entry *elems;
IDNUM *bucks;
IDNUM nbucks;
};
struct id_table_entry {
TERM term;
IDNUM next;
};
/*--------------------------------------------------------------------*/
static void id_table_rehash(ID_TABLE *this)
{
IDNUM *bucks, nbucks, i, j;
nbucks = 2 * this->nbucks + 1;
/* find the next prime number */
for (i = 3; i * i <= nbucks; ) {
if (nbucks % i == 0) {
nbucks += 2;
i = 3;
}
else {
i += 2;
}
}
bucks = MALLOC(sizeof(struct hash_entry *) * nbucks);
for (i = 0; i < nbucks; i++)
bucks[i] = ID_NONE;
for (i = 0; i < VECTOR_SIZE(this->elems); i++) {
j = (IDNUM)((BPULONG)(this->elems[i].term) % nbucks);
this->elems[i].next = bucks[j];
bucks[j] = i;
}
FREE(this->bucks);
this->nbucks = nbucks;
this->bucks = bucks;
}
static IDNUM id_table_search(const ID_TABLE *this, TERM term)
{
BPULONG hash;
IDNUM i;
hash = (BPULONG)(term);
i = this->bucks[hash % this->nbucks];
while (i != ID_NONE) {
if (term == this->elems[i].term) {
return i;
}
i = this->elems[i].next;
}
return ID_NONE;
}
static IDNUM id_table_insert(ID_TABLE *this, TERM term)
{
BPULONG hash;
IDNUM n;
const char *bpx_term_2_string(TERM);
hash = (BPULONG)(term);
n = (IDNUM)(VECTOR_SIZE(this->elems));
if (n >= this->nbucks) {
id_table_rehash(this);
}
VECTOR_PUSH_NONE(this->elems);
this->elems[n].term = term;
this->elems[n].next = this->bucks[hash % this->nbucks];
this->bucks[hash % this->nbucks] = n;
/* fprintf(curr_out,">> TERM: %s = %d\n",bpx_term_2_string(term),n); */
return n;
}
/*--------------------------------------------------------------------*/
ID_TABLE * id_table_create(void)
{
ID_TABLE *this;
IDNUM i;
this = MALLOC(sizeof(struct id_table));
this->elems = NULL;
this->nbucks = 17; /* prime number */
this->bucks = MALLOC(sizeof(IDNUM) * this->nbucks);
this->store = term_pool_create();
for (i = 0; i < this->nbucks; i++)
this->bucks[i] = ID_NONE;
VECTOR_INIT(this->elems);
return this;
}
void id_table_delete(ID_TABLE *this)
{
VECTOR_FREE(this->elems);
FREE(this->bucks);
term_pool_delete(this->store);
FREE(this);
}
/*--------------------------------------------------------------------*/
TERM id_table_id2term(const ID_TABLE *this, IDNUM i)
{
return this->elems[i].term; /* numbered */
}
IDNUM id_table_retrieve(const ID_TABLE *this, TERM term)
{
term = term_pool_retrieve(this->store, term);
return id_table_search(this, term);
}
IDNUM id_table_register(ID_TABLE *this, TERM term)
{
BPULONG hash;
IDNUM i;
term = term_pool_register(this->store, term);
hash = (BPULONG)(term);
i = id_table_search(this, term);
if (i == ID_NONE) {
i = id_table_insert(this, term);
}
return i;
}
int id_table_count(const ID_TABLE *this)
{
return (int)VECTOR_SIZE(this->elems);
}
/*--------------------------------------------------------------------*/
TERM unnumber_var_term(TERM term)
{
BPLONG mvn = -1;
return unnumberVarTerm(term, local_top, &mvn);
}

29
packages/prism/src/c/core/idtable.h Normal file
View File

@ -0,0 +1,29 @@
#ifndef IDTABLE_H
#define IDTABLE_H
#include "bpx.h"
/*--------------------------------------------------------------------*/
#define ID_NONE ((IDNUM)(-1))
/*--------------------------------------------------------------------*/
typedef struct id_table ID_TABLE;
typedef unsigned int IDNUM;
/*--------------------------------------------------------------------*/
ID_TABLE * id_table_create(void);
void id_table_delete(ID_TABLE *);
TERM id_table_id2term(const ID_TABLE *, IDNUM);
IDNUM id_table_retrieve(const ID_TABLE *, TERM);
IDNUM id_table_register(ID_TABLE *, TERM);
int id_table_count(const ID_TABLE *);
TERM unnumber_var_term(TERM);
/*--------------------------------------------------------------------*/
#endif /* IDTABLE_H */

249
packages/prism/src/c/core/idtable_preds.c Normal file
View File

@ -0,0 +1,249 @@
#include <string.h>
#include "core/idtable.h"
/*--------------------------------------------------------------------*/
static ID_TABLE *g_table = NULL; /* goals */
static ID_TABLE *s_table = NULL; /* switches */
static ID_TABLE *i_table = NULL; /* switch instances */
/*--------------------------------------------------------------------*/
/* cpreds.c */
char * bp_term_2_string(TERM);
/* unify.c */
int unify(TERM, TERM);
/*--------------------------------------------------------------------*/
int prism_goal_id_register(TERM term)
{
return id_table_register(g_table, term);
}
int prism_sw_id_register(TERM term)
{
return id_table_register(s_table, term);
}
int prism_sw_ins_id_register(TERM term)
{
return id_table_register(i_table, term);
}
int prism_goal_id_get(TERM term)
{
return id_table_retrieve(g_table, term);
}
int prism_sw_id_get(TERM term)
{
return id_table_retrieve(s_table, term);
}
int prism_sw_ins_id_get(TERM term)
{
return id_table_retrieve(i_table, term);
}
int prism_goal_count(void)
{
return id_table_count(g_table);
}
int prism_sw_count(void)
{
return id_table_count(s_table);
}
int prism_sw_ins_count(void)
{
return id_table_count(i_table);
}
TERM prism_goal_term(IDNUM i)
{
return id_table_id2term(g_table, i);
}
TERM prism_sw_term(IDNUM i)
{
return id_table_id2term(s_table, i);
}
TERM prism_sw_ins_term(IDNUM i)
{
return id_table_id2term(i_table, i);
}
char * prism_goal_string(IDNUM i)
{
return bp_term_2_string(prism_goal_term(i));
}
char * prism_sw_string(IDNUM i)
{
return bp_term_2_string(prism_sw_term(i));
}
char * prism_sw_ins_string(IDNUM i)
{
return bp_term_2_string(prism_sw_ins_term(i));
}
/* Note: the strings returned by strdup() should be released by the caller. */
char * copy_prism_goal_string(IDNUM i)
{
return strdup(prism_goal_string(i));
}
char * copy_prism_sw_string(IDNUM i)
{
return strdup(prism_sw_string(i));
}
char * copy_prism_sw_ins_string(IDNUM i)
{
return strdup(prism_sw_ins_string(i));
}
/*--------------------------------------------------------------------*/
int pc_prism_id_table_init_0(void)
{
if (g_table != NULL) id_table_delete(g_table);
if (s_table != NULL) id_table_delete(s_table);
if (i_table != NULL) id_table_delete(i_table);
g_table = id_table_create();
s_table = id_table_create();
i_table = id_table_create();
return BP_TRUE;
}
int pc_prism_goal_id_register_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_goal_id_register(term);
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_id_register_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_id_register(term);
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_ins_id_register_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_ins_id_register(term);
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_goal_id_get_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_goal_id_get(term);
if (id == ID_NONE) return BP_FALSE;
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_id_get_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_id_get(term);
if (id == ID_NONE) return BP_FALSE;
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_sw_ins_id_get_2(void)
{
TERM term;
IDNUM id;
term = ARG(1,2);
XDEREF(term);
id = prism_sw_ins_id_get(term);
if (id == ID_NONE) return BP_FALSE;
return unify(MAKEINT(id), ARG(2,2));
}
int pc_prism_goal_count_1(void)
{
return unify(MAKEINT(prism_goal_count()), ARG(1,1));
}
int pc_prism_sw_count_1(void)
{
return unify(MAKEINT(prism_sw_count()), ARG(1,1));
}
int pc_prism_sw_ins_count_1(void)
{
return unify(MAKEINT(prism_sw_ins_count()), ARG(1,1));
}
int pc_prism_goal_term_2(void)
{
TERM id, term;
id = ARG(1,2);
XDEREF(id);
term = unnumber_var_term(prism_goal_term((IDNUM)INTVAL(id)));
return unify(term, ARG(2,2));
}
int pc_prism_sw_term_2(void)
{
TERM id, term;
id = ARG(1,2);
XDEREF(id);
term = unnumber_var_term(prism_sw_term((IDNUM)INTVAL(id)));
return unify(term, ARG(2,2));
}
int pc_prism_sw_ins_term_2(void)
{
TERM id, term;
id = ARG(1,2);
XDEREF(id);
term = unnumber_var_term(prism_sw_ins_term((IDNUM)INTVAL(id)));
return unify(term, ARG(2,2));
}

41
packages/prism/src/c/core/idtable_preds.h Normal file
View File

@ -0,0 +1,41 @@
#ifndef IDTABLE_AUX_H
#define IDTABLE_AUX_H
/*--------------------------------------------------------------------*/
int prism_goal_id_register(TERM);
int prism_sw_id_register(TERM);
int prism_sw_ins_id_register(TERM);
int prism_goal_id_get(TERM);
int prism_sw_id_get(TERM);
int prism_sw_ins_id_get(TERM);
int prism_goal_count(void);
int prism_sw_id_count(void);
int prism_sw_ins_id_count(void);
TERM prism_goal_term(IDNUM);
TERM prism_sw_term(IDNUM);
TERM prism_sw_ins_term(IDNUM);
char * prism_goal_string(IDNUM);
char * prism_sw_string(IDNUM);
char * prism_sw_ins_string(IDNUM);
char * copy_prism_goal_string(IDNUM);
char * copy_prism_sw_string(IDNUM);
char * copy_prism_sw_ins_string(IDNUM);
int pc_prism_id_table_init(void);
int pc_prism_goal_id_register(void);
int pc_prism_sw_id_register(void);
int pc_prism_sw_ins_id_register(void);
int pc_prism_goal_id_get(void);
int pc_prism_sw_id_get(void);
int pc_prism_sw_ins_id_get(void);
int pc_prism_goal_count(void);
int pc_prism_sw_count(void);
int pc_prism_sw_ins_count(void);
int pc_prism_goal_term(void);
int pc_prism_sw_term(void);
int pc_prism_sw_ins_term(void);
/*--------------------------------------------------------------------*/
#endif /* IDTABLE_AUX_H */

360
packages/prism/src/c/core/random.c Normal file
View File

@ -0,0 +1,360 @@
/*
This source module contains reduced (and slightly modified) version
of mt19937ar.c implemented by Makoto Matsumoto and Takuji Nishimura.
The original file is available in the following website:
http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
Here is the original copyright notice.
========================================================================
Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The names of its contributors may not be used to endorse or promote
products derived from this software without specific prior written
permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
========================================================================
*/
/***********[ REDUCED VERSION OF MT19937AR.C STARTS HERE ]***********/
/* Period parameters */
#define N 624
#define M 397
#define MATRIX_A 0x9908b0dfUL /* constant vector a */
#define UPPER_MASK 0x80000000UL /* most significant w-r bits */
#define LOWER_MASK 0x7fffffffUL /* least significant r bits */
static unsigned long mt[N]; /* the array for the state vector */
static int mti=N+1; /* mti==N+1 means mt[N] is not initialized */
/* initializes mt[N] with a seed */
static void init_genrand(unsigned long s)
{
mt[0]= s & 0xffffffffUL;
for (mti=1; mti<N; mti++) {
mt[mti] =
(1812433253UL * (mt[mti-1] ^ (mt[mti-1] >> 30)) + mti);
/* See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. */
/* In the previous versions, MSBs of the seed affect */
/* only MSBs of the array mt[]. */
/* 2002/01/09 modified by Makoto Matsumoto */
mt[mti] &= 0xffffffffUL;
/* for >32 bit machines */
}
}
/* initialize by an array with array-length */
/* init_key is the array for initializing keys */
/* key_length is its length */
/* slight change for C++, 2004/2/26 */
void init_by_array(unsigned long init_key[], int key_length)
{
int i, j, k;
init_genrand(19650218UL);
i=1;
j=0;
k = (N>key_length ? N : key_length);
for (; k; k--) {
mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1664525UL))
+ init_key[j] + j; /* non linear */
mt[i] &= 0xffffffffUL; /* for WORDSIZE > 32 machines */
i++;
j++;
if (i>=N) {
mt[0] = mt[N-1];
i=1;
}
if (j>=key_length) j=0;
}
for (k=N-1; k; k--) {
mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1566083941UL))
- i; /* non linear */
mt[i] &= 0xffffffffUL; /* for WORDSIZE > 32 machines */
i++;
if (i>=N) {
mt[0] = mt[N-1];
i=1;
}
}
mt[0] = 0x80000000UL; /* MSB is 1; assuring non-zero initial array */
}
/* generates a random number on [0,0xffffffff]-interval */
static unsigned long genrand_int32(void)
{
unsigned long y;
static unsigned long mag01[2]={0x0UL, MATRIX_A};
/* mag01[x] = x * MATRIX_A for x=0,1 */
if (mti >= N) { /* generate N words at one time */
int kk;
if (mti == N+1) /* if init_genrand() has not been called, */
init_genrand(5489UL); /* a default initial seed is used */
for (kk=0;kk<N-M;kk++) {
y = (mt[kk]&UPPER_MASK)|(mt[kk+1]&LOWER_MASK);
mt[kk] = mt[kk+M] ^ (y >> 1) ^ mag01[y & 0x1UL];
}
for (;kk<N-1;kk++) {
y = (mt[kk]&UPPER_MASK)|(mt[kk+1]&LOWER_MASK);
mt[kk] = mt[kk+(M-N)] ^ (y >> 1) ^ mag01[y & 0x1UL];
}
y = (mt[N-1]&UPPER_MASK)|(mt[0]&LOWER_MASK);
mt[N-1] = mt[M-1] ^ (y >> 1) ^ mag01[y & 0x1UL];
mti = 0;
}
y = mt[mti++];
/* Tempering */
y ^= (y >> 11);
y ^= (y << 7) & 0x9d2c5680UL;
y ^= (y << 15) & 0xefc60000UL;
y ^= (y >> 18);
return y;
}
/* generates a random number on [0,1) with 53-bit resolution */
static double genrand_res53(void)
{
unsigned long a=genrand_int32()>>5, b=genrand_int32()>>6;
return(a*67108864.0+b)*(1.0/9007199254740992.0);
}
/* These real versions are due to Isaku Wada, 2002/01/09 added */
/***********[ REDUCED VERSION OF MT19937AR.C ENDS HERE ]***********/
/*--------------------------------------------------------------------*/
#include <math.h>
#include <time.h>
#include <string.h>
#include <assert.h>
#include "core/bpx.h"
#include "core/random.h"
#include "core/vector.h"
#ifndef M_PI
#define M_PI (3.14159265358979324)
#endif
static int gauss_flag = 0;
/*--------------------------------------------------------------------*/
int random_int(int n)
{
unsigned long p, q, r;
assert(n > 0);
if (n == 1) {
return 0;
}
p = 0xFFFFFFFFul - (0xFFFFFFFFul % n + 1) % n;
q = p / n + 1;
while ((r = genrand_int32()) > p) ;
return (int)(r / q);
}
double random_float(void)
{
return genrand_res53();
}
/* Box-Muller method */
double random_gaussian(double mu, double sigma)
{
double u1, u2;
static double g1, g2;
gauss_flag = !(gauss_flag);
if (gauss_flag) {
u1 = genrand_res53();
u2 = genrand_res53();
g1 = sqrt(-2.0 * log(u1)) * cos(2.0 * M_PI * u2);
g2 = sqrt(-2.0 * log(u1)) * sin(2.0 * M_PI * u2);
return sigma * g1 + mu;
}
else {
return sigma * g2 + mu;
}
}
/* N(0,1)-version:
double random_gaussian(void)
{
double u1, u2;
static double next;
gauss_flag = !(gauss_flag);
if (gauss_flag) {
do {
u1 = genrand_res53();
}
while (u1 == 0.0);
do {
u2 = genrand_res53();
}
while (u2 == 0.0);
next = sqrt(-2.0 * log(u1)) * sin(2.0 * M_PI * u2);
return sqrt(-2.0 * log(u1)) * cos(2.0 * M_PI * u2);
}
else {
return next;
}
}
*/
/*--------------------------------------------------------------------*/
int pc_random_auto_seed_1(void)
{
BPLONG seed = (BPLONG)(time(NULL));
return bpx_unify(ARG(1,1), bpx_build_integer(seed));
}
int pc_random_init_by_seed_1(void)
{
init_genrand((unsigned long)(bpx_get_integer(ARG(1,1))));
return BP_TRUE;
}
int pc_random_init_by_list_1(void)
{
unsigned long *seed;
TERM t, u;
VECTOR_INIT(seed);
t = ARG(1,1);
while (! bpx_is_nil(t)) {
u = bpx_get_car(t);
t = bpx_get_cdr(t);
VECTOR_PUSH(seed, (unsigned long)(bpx_get_integer(u)));
}
init_by_array(seed, VECTOR_SIZE(seed));
return BP_TRUE;
}
int pc_random_float_1(void)
{
return bpx_unify(ARG(1,1), bpx_build_float(random_float()));
}
int pc_random_gaussian_1(void)
{
return bpx_unify(ARG(1,1), bpx_build_float(random_gaussian(0.0,1.0)));
}
int pc_random_int_2(void)
{
int n_max = bpx_get_integer(ARG(1,2));
int n_out = random_int(n_max);
return bpx_unify(ARG(2,2), bpx_build_integer((BPLONG)(n_out)));
}
int pc_random_int_3(void)
{
int n_min = bpx_get_integer(ARG(1,3));
int n_max = bpx_get_integer(ARG(2,3));
int n_out = random_int(n_max - n_min + 1) + n_min;
return bpx_unify(ARG(3,3), bpx_build_integer((BPLONG)(n_out)));
}
/*--------------------------------------------------------------------*/
int pc_random_get_state_1(void)
{
int i, j;
TERM t, u;
unsigned long temp;
t = bpx_build_structure("$randstate", 4 * N / 3 + 1);
bpx_unify(bpx_get_arg(1, t), bpx_build_integer(mti));
for (i = 0; i < 4 * N / 3; i++) {
j = i / 4 * 3;
temp = 0;
if (i % 4 > 0) {
temp |= mt[j + i % 4 - 1] << (8 * (3 - i % 4));
}
if (i % 4 < 3) {
temp |= mt[j + i % 4 - 0] >> (8 * (1 + i % 4));
}
temp &= 0xFFFFFF; /* == 2^24 - 1 */
u = bpx_get_arg(i + 2, t);
bpx_unify(u, bpx_build_integer(temp));
}
return bpx_unify(ARG(1,1), t);
}
int pc_random_set_state_1(void)
{
int i, j;
TERM term;
unsigned long temp;
term = ARG(1,1);
assert(strcmp(bpx_get_name(term), "$randstate") == 0);
assert(bpx_get_arity(term) == 4 * N / 3 + 1);
mti = bpx_get_integer(bpx_get_arg(1, term));
for (i = 0; i < N; i++) {
j = i / 3 * 4;
mt[i] = 0;
temp = bpx_get_integer(bpx_get_arg(j + i % 3 + 2, term));
mt[i] |= temp << (8 * (1 + i % 3));
temp = bpx_get_integer(bpx_get_arg(j + i % 3 + 3, term));
mt[i] |= temp >> (8 * (2 - i % 3));
mt[i] &= 0xFFFFFFFF;
}
return BP_TRUE;
}
/*--------------------------------------------------------------------*/

14
packages/prism/src/c/core/random.h Normal file
View File

@ -0,0 +1,14 @@
#ifndef RANDOM_H
#define RANDOM_H
#include <stddef.h>
/*--------------------------------------------------------------------*/
int random_int(int);
double random_float(void);
double random_gaussian(double, double);
/*--------------------------------------------------------------------*/
#endif /* RANDOM_H */

23
packages/prism/src/c/core/stuff.h Normal file
View File

@ -0,0 +1,23 @@
#ifndef STUFF_H
#define STUFF_H
/*--------------------------------------------------------------------*/
typedef enum { false, true } bool;
/*--------------------------------------------------------------------*/
#if defined _MSC_VER
#define NORET void __declspec(noreturn)
#define PRINTF_LIKE_FUNC(m, n) /* empty */
#elif defined __GNUC__
#define NORET void __attribute__((noreturn))
#define PRINTF_LIKE_FUNC(m, n) __attribute__((format(printf, m, n)))
#else /* other */
#define NORET void
#define PRINTF_LIKE_FUNC(m, n) /* empty */
#endif
/*--------------------------------------------------------------------*/
#endif /* STUFF_H */

424
packages/prism/src/c/core/termpool.c Normal file
View File

@ -0,0 +1,424 @@
#include <assert.h>
#include "core/termpool.h"
#include "core/xmalloc.h"
#include "core/vector.h"
#include "core/stuff.h"
/* FIXME */
#define prism_quit(msg) quit("*** {PRISM FATAL ERROR: " msg "}\n")
NORET quit(const char *);
/*--------------------------------------------------------------------*/
/* [04 Apr 2009, by yuizumi]
* This value should be sufficiently large enough to have malloc(3)
* return an address with its top bit set on 32-bit Linux systems.
*/
#define BLOCK_SIZE 1048576
/*--------------------------------------------------------------------*/
/* [05 Apr 2009, by yuizumi]
* The area referred by this variable is shared by prism_hash_value()
* and term_pool_store(), under the assumption that BPLONG values and
* BPLONG_PTR values (i.e. pointers) are aligned in the same way even
* without cast operations.
*/
static BPLONG_PTR work;
/*--------------------------------------------------------------------*/
struct term_pool {
BPLONG_PTR head;
BPLONG_PTR curr;
BPLONG_PTR tail;
struct hash_entry **bucks;
size_t nbucks;
size_t count;
};
struct hash_entry {
TERM term;
BPULONG hash;
struct hash_entry *next;
};
/*--------------------------------------------------------------------*/
/* Functions from B-Prolog */
/* mic.c */
void c_STATISTICS(void);
/* table.c */
void numberVarTermOpt(TERM);
TERM unnumberVarTerm(TERM, BPLONG_PTR, BPLONG_PTR);
/* unify.c */
int unifyNumberedTerms(TERM, TERM);
/*--------------------------------------------------------------------*/
static ptrdiff_t trail_pos0 = 0;
static void number_vars(TERM term)
{
assert(trail_pos0 == 0);
trail_pos0 = trail_up_addr - trail_top;
PRE_NUMBER_VAR(0);
numberVarTermOpt(term);
if (number_var_exception != 0) {
prism_quit("suspension variables not supported in Prism");
}
}
static void revert_vars(void)
{
BPLONG_PTR trail_top0;
assert(trail_pos0 != 0);
trail_top0 = trail_up_addr - trail_pos0;
UNDO_TRAILING;
trail_pos0 = 0;
}
/* [29 Mar 2009, by yuizumi]
* See Also: "Algorithms in C, Third Edition," by Robert Sedgewick,
* Addison-Wesley, 1998.
*/
static BPULONG prism_hash_value(TERM term)
{
TERM t, *rest;
BPLONG i, n;
SYM_REC_PTR sym;
BPULONG a = 2130563839ul;
BPULONG b = 1561772629ul;
BPULONG h = 0;
BPULONG u;
rest = (TERM *)work;
VECTOR_PUSH(rest, term);
while (! VECTOR_EMPTY(rest)) {
t = VECTOR_POP(rest);
nderef_loop:
switch (XTAG(t)) {
case REF0:
case REF1:
XNDEREF(t, nderef_loop);
assert(false); /* numbered by number_vars() */
case ATM:
case INT:
case NVAR:
u = (BPULONG)t;
break;
case LST:
VECTOR_PUSH(rest, GET_CDR(t));
VECTOR_PUSH(rest, GET_CAR(t));
u = (BPULONG)LST;
break;
case STR:
sym = GET_STR_SYM_REC(t);
n = GET_ARITY_STR(sym);
for (i = n; i >= 1; i--) {
VECTOR_PUSH(rest, GET_ARG(t, i));
}
u = (BPULONG)ADDTAG(sym, STR);
break;
case SUSP:
assert(false); /* rejected by number_vars() */
default:
assert(false);
}
h = (a * h) + (BPULONG)(u);
a *= b;
}
work = (BPLONG *)rest;
return h;
}
/*--------------------------------------------------------------------*/
static BPLONG_PTR term_pool_allocate(TERM_POOL *this, size_t size)
{
BPLONG_PTR p_tmp;
assert(size <= MAX_ARITY + 1);
if (this->head == NULL || this->curr + size > this->tail) {
BP_MALLOC(p_tmp, BLOCK_SIZE, "(prism part)");
*p_tmp = (BPLONG)(this->head);
this->head = p_tmp + 0;
this->curr = p_tmp + 1;
this->tail = p_tmp + BLOCK_SIZE;
}
p_tmp = this->curr;
this->curr += size;
return p_tmp;
}
/*--------------------------------------------------------------------*/
static TERM term_pool_store(TERM_POOL *this, TERM term)
{
TERM *p, *q, **rest;
BPLONG i, n;
SYM_REC_PTR sym;
rest = (void *)(work);
VECTOR_PUSH(rest, &term);
while (! VECTOR_EMPTY(rest)) {
p = VECTOR_POP(rest);
nderef_loop:
switch (XTAG(*p)) {
case REF0:
case REF1:
XNDEREF(*p, nderef_loop);
assert(false); /* numbered by number_vars() */
case ATM:
case INT:
case NVAR:
break;
case LST:
q = term_pool_allocate(this, 2);
*(q + 1) = GET_CDR(*p);
VECTOR_PUSH(rest, q + 1);
*(q + 0) = GET_CAR(*p);
VECTOR_PUSH(rest, q + 0);
*p = ADDTAG(q, LST);
break;
case STR:
sym = GET_STR_SYM_REC(*p);
n = GET_ARITY_STR(sym);
q = term_pool_allocate(this, n + 1);
*q = (TERM)(sym);
for (i = n; i >= 1; i--) {
*(q + i) = GET_ARG(*p, i);
VECTOR_PUSH(rest, q + i);
}
*p = ADDTAG(q, STR);
break;
case SUSP:
assert(false); /* rejected by number_vars() */
default:
assert(false);
}
}
work = (void *)(rest);
return term;
}
/*--------------------------------------------------------------------*/
static void term_pool_rehash(TERM_POOL *this)
{
struct hash_entry **bucks, *p, *q;
size_t nbucks, i;
nbucks = 2 * this->nbucks + 1;
/* find the next prime number */
for (i = 3; i * i <= nbucks; ) {
if (nbucks % i == 0) {
nbucks += 2;
i = 3;
}
else {
i += 2;
}
}
bucks = MALLOC(sizeof(struct hash_entry *) * nbucks);
for (i = 0; i < nbucks; i++)
bucks[i] = NULL;
for (i = 0; i < this->nbucks; i++) {
p = this->bucks[i];
while (p != NULL) {
q = p;
p = p->next;
q->next = bucks[q->hash % nbucks];
bucks[q->hash % nbucks] = q;
}
}
FREE(this->bucks);
this->nbucks = nbucks;
this->bucks = bucks;
}
/*--------------------------------------------------------------------*/
static TERM term_pool_search(const TERM_POOL *this, TERM term, BPULONG hash)
{
struct hash_entry *p;
p = this->bucks[hash % this->nbucks];
while (p != NULL) {
if (hash == p->hash) {
if (unifyNumberedTerms(term, p->term)) {
return p->term;
}
}
p = p->next;
}
return NULL_TERM;
}
static TERM term_pool_insert(TERM_POOL *this, TERM term, BPULONG hash)
{
struct hash_entry *entry;
if (++(this->count) >= this->nbucks)
term_pool_rehash(this);
entry = MALLOC(sizeof(struct hash_entry));
entry->term = term_pool_store(this, term);
entry->hash = hash;
entry->next = this->bucks[hash % this->nbucks];
this->bucks[hash % this->nbucks] = entry;
return entry->term;
}
/*--------------------------------------------------------------------*/
static TERM term_pool_intern(const TERM_POOL *this1, TERM_POOL *this2, TERM term)
{
BPULONG hash;
TERM rval;
assert(this2 == NULL || this2 == this1);
nderef_loop:
switch (XTAG(term)) {
case REF0:
case REF1:
XNDEREF(term, nderef_loop);
return MAKE_NVAR(0);
case ATM:
case INT:
case NVAR:
return term;
case LST:
case STR:
break;
case SUSP:
prism_quit("suspension variables not supported in Prism");
default:
assert(false);
}
number_vars(term);
hash = prism_hash_value(term);
rval = term_pool_search(this1, term, hash);
if (rval == NULL_TERM && this2 != NULL) {
rval = term_pool_insert(this2, term, hash);
}
revert_vars();
return rval;
}
/*--------------------------------------------------------------------*/
TERM_POOL * term_pool_create(void)
{
TERM_POOL *this;
int i;
this = MALLOC(sizeof(struct term_pool));
this->head = NULL;
this->curr = NULL;
this->tail = NULL;
this->nbucks = 17;
this->count = 0;
this->bucks = MALLOC(sizeof(struct hash_entry *) * this->nbucks);
for (i = 0; i < this->nbucks; i++)
this->bucks[i] = NULL;
if (work == NULL) {
VECTOR_INIT_CAPA(work, 4096);
}
return this;
}
/*--------------------------------------------------------------------*/
void term_pool_delete(TERM_POOL *this)
{
BPLONG_PTR p1, p2;
struct hash_entry *q1, *q2;
int i;
p1 = this->head;
while (p1 != NULL) {
p2 = p1;
p1 = (BPLONG_PTR)(*p1);
FREE(p2);
}
for (i = 0; i < this->nbucks; i++) {
q1 = this->bucks[i];
while (q1 != NULL) {
q2 = q1;
q1 = q1->next;
FREE(q2);
}
}
FREE(this->bucks);
FREE(this);
}
/*--------------------------------------------------------------------*/
TERM term_pool_retrieve(const TERM_POOL *this, TERM term)
{
return term_pool_intern(this, NULL, term);
}
TERM term_pool_register(TERM_POOL *this, TERM term)
{
return term_pool_intern(this, this, term);
}
/*--------------------------------------------------------------------*/

20
packages/prism/src/c/core/termpool.h Normal file
View File

@ -0,0 +1,20 @@
#ifndef TERMPOOL_H
#define TERMPOOL_H
#include "bpx.h"
/*--------------------------------------------------------------------*/
typedef struct term_pool TERM_POOL;
/*--------------------------------------------------------------------*/
TERM_POOL * term_pool_create(void);
void term_pool_delete(TERM_POOL *);
TERM term_pool_retrieve(const TERM_POOL *, TERM);
TERM term_pool_register(TERM_POOL *, TERM);
/*--------------------------------------------------------------------*/
#endif /* TERMPOOL_H */

87
packages/prism/src/c/core/vector.c Normal file
View File

@ -0,0 +1,87 @@
#include "core/xmalloc.h"
#include "core/vector.h"
#include <assert.h>
/*--------------------------------------------------------------------*/
#define INITIAL_CAPA 16
#undef VECTOR_SIZE
#undef VECTOR_CAPA
/* allow these to be L-values */
#define VECTOR_SIZE(v) (((size_t *)(v))[-1])
#define VECTOR_CAPA(v) (((size_t *)(v))[-2])
/*--------------------------------------------------------------------*/
void * vector_create(size_t unit, size_t size, size_t capa)
{
void *ptr, *vec;
ptr = MALLOC(sizeof(size_t) * 2 + unit * capa);
vec = ((size_t *)(ptr)) + 2;
VECTOR_SIZE(vec) = size;
VECTOR_CAPA(vec) = capa;
return vec;
}
void vector_delete(void *vec)
{
free(((size_t *)(vec)) - 2);
}
void * vector_expand(void *vec, size_t unit)
{
size_t capa;
if (VECTOR_SIZE(vec) >= VECTOR_CAPA(vec)) {
capa = VECTOR_CAPA(vec) * 2;
if (capa < INITIAL_CAPA) {
capa = INITIAL_CAPA;
}
vec = vector_realloc(vec, unit, capa);
}
++(VECTOR_SIZE(vec));
return vec;
}
void * vector_reduce(void *vec)
{
assert(VECTOR_SIZE(vec) > 0);
--(VECTOR_SIZE(vec));
return vec;
}
void * vector_resize(void *vec, size_t unit, size_t size)
{
vec = vector_reserve(vec, unit, size);
VECTOR_SIZE(vec) = size;
return vec;
}
void * vector_reserve(void *vec, size_t unit, size_t capa)
{
if (VECTOR_CAPA(vec) < capa) {
vec = vector_realloc(vec, unit, capa);
}
return vec;
}
void * vector_realloc(void *vec, size_t unit, size_t capa)
{
void *ptr;
if (VECTOR_CAPA(vec) == capa)
return vec;
assert(VECTOR_SIZE(vec) <= capa);
ptr = ((size_t *)(vec)) - 2;
ptr = REALLOC(ptr, sizeof(size_t) * 2 + unit * capa);
vec = ((size_t *)(ptr)) + 2;
VECTOR_CAPA(vec) = capa;
return vec;
}
/*--------------------------------------------------------------------*/

59
packages/prism/src/c/core/vector.h Normal file
View File

@ -0,0 +1,59 @@
#ifndef VECTOR_H
#define VECTOR_H
#include "stddef.h"
/*--------------------------------------------------------------------*/
#define VECTOR_INIT(v) \
((v) = vector_create(sizeof(*(v)), 0, 0))
#define VECTOR_INIT_SIZE(v, n) \
((v) = vector_create(sizeof(*(v)), n, n))
#define VECTOR_INIT_CAPA(v, m) \
((v) = vector_create(sizeof(*(v)), 0, m))
#define VECTOR_FREE(v) \
((v) = (vector_delete(v), NULL))
/*--------------------------------------------------------------------*/
#define VECTOR_SIZE(v) \
((size_t)(((const size_t *)(v))[-1]))
#define VECTOR_CAPA(v) \
((size_t)(((const size_t *)(v))[-2]))
#define VECTOR_PUSH(v, x) \
((v) = vector_expand(v, sizeof(*(v))), (v)[VECTOR_SIZE(v) - 1] = (x))
#define VECTOR_POP(v) \
((v) = vector_reduce(v), (v)[VECTOR_SIZE(v)])
#define VECTOR_PUSH_NONE(v) \
((v) = vector_expand(v, sizeof(*(v))))
#define VECTOR_RESIZE(v, n) \
((v) = vector_resize(v, sizeof(*(v)), n))
#define VECTOR_RESERVE(v, m) \
((v) = vector_reserve(v, sizeof(*(v)), m))
#define VECTOR_STRIP(v) \
((v) = vector_realloc(v, sizeof(*(v)), VECTOR_SIZE(v)))
#define VECTOR_CLEAR(v) \
((void)(((const size_t *)(v))[-1] = 0))
#define VECTOR_EMPTY(v) \
(VECTOR_SIZE(v) == 0)
/*--------------------------------------------------------------------*/
void * vector_create(size_t, size_t, size_t);
void vector_delete(void *);
void * vector_expand(void *, size_t);
void * vector_reduce(void *);
void * vector_resize(void *, size_t, size_t);
void * vector_reserve(void *, size_t, size_t);
void * vector_realloc(void *, size_t, size_t);
/*--------------------------------------------------------------------*/
#endif /* VECTOR_H */

35
packages/prism/src/c/core/xmalloc.c Normal file
View File

@ -0,0 +1,35 @@
#include <stdio.h>
#include <stdlib.h>
#include "core/xmalloc.h"
/*--------------------------------------------------------------------*/
void * xmalloc
(size_t size, const char *file, unsigned int line)
{
void *ptr;
ptr = malloc(size);
if (ptr == NULL) {
fprintf(stderr, "Out of memory in %s(%u)\n", file, line);
exit(1); /* FIXME */
}
return ptr;
}
void * xrealloc
(void *oldptr, size_t size, const char *file, unsigned int line)
{
void *newptr;
newptr = realloc(oldptr, size);
if (newptr == NULL && size > 0) {
fprintf(stderr, "Out of memory in %s(%u)\n", file, line);
exit(1); /* FIXME */
}
return newptr;
}
/*--------------------------------------------------------------------*/

25
packages/prism/src/c/core/xmalloc.h Normal file
View File

@ -0,0 +1,25 @@
#ifndef XMALLOC_H
#define XMALLOC_H
#include <stdlib.h>
/*--------------------------------------------------------------------*/
void * xmalloc(size_t, const char *, unsigned int);
void * xrealloc(void *, size_t, const char *, unsigned int);
/*--------------------------------------------------------------------*/
#ifdef MALLOC_TRACE
# define MALLOC(size) malloc((size))
# define REALLOC(oldptr,size) realloc((oldptr),(size))
# define FREE(ptr) (free(ptr), (ptr) = NULL)
#else
# define MALLOC(size) xmalloc((size), __FILE__, __LINE__)
# define REALLOC(oldptr,size) xrealloc((oldptr), (size), __FILE__, __LINE__)
# define FREE(ptr) (free(ptr), (ptr) = NULL)
#endif
/*--------------------------------------------------------------------*/
#endif /* XMALLOC_H */

56
packages/prism/src/c/makefiles/Makefile.files Normal file
View File

@ -0,0 +1,56 @@
# -*- Makefile -*-
##----------------------------------------------------------------------
CORE_OBJS = core$(S)glue.$(O) \
core$(S)bpx.$(O) \
core$(S)idtable.$(O) \
core$(S)idtable_preds.$(O) \
core$(S)termpool.$(O) \
core$(S)vector.$(O) \
core$(S)random.$(O) \
core$(S)gamma.$(O) \
core$(S)xmalloc.$(O) \
core$(S)fputil.$(O) \
core$(S)error.$(O)
UP_OBJS = up$(S)graph.$(O) \
up$(S)graph_aux.$(O) \
up$(S)em_preds.$(O) \
up$(S)em_ml.$(O) \
up$(S)em_vb.$(O) \
up$(S)em_aux.$(O) \
up$(S)em_aux_ml.$(O) \
up$(S)em_aux_vb.$(O) \
up$(S)viterbi.$(O) \
up$(S)hindsight.$(O) \
up$(S)flags.$(O) \
up$(S)util.$(O)
MP_OBJS = mp$(S)mp_core.$(O) \
mp$(S)mp_em_aux.$(O) \
mp$(S)mp_em_ml.$(O) \
mp$(S)mp_em_preds.$(O) \
mp$(S)mp_em_vb.$(O) \
mp$(S)mp_flags.$(O) \
mp$(S)mp_preds.$(O) \
mp$(S)mp_sw.$(O)
OBJS = $(CORE_OBJS) $(UP_OBJS)
##----------------------------------------------------------------------
INSTALLDIR = ..$(S)..$(S)bin
CORE_DIR = core
UP_DIR = up
MP_DIR = mp
SUBDIRS = $(CORE_DIR) $(UP_DIR)
##----------------------------------------------------------------------
#BP4P_A = bp4prism$(S)lib$(S)bp4prism-$(PLATFORM).$(A)
BP4P_A =
##----------------------------------------------------------------------

11
packages/prism/src/c/makefiles/README Normal file
View File

@ -0,0 +1,11 @@
===================== README (src/c/makefiles) =====================
This directory contains the Makefiles which are included into the
Makefiles in the above directory:
Makefile.opts.gmake ... settings for GNU make
Makefile.opts.nmake ... settings for nmake (MSVC++)
Makefile.files ... source file names
If you would like to change the default settings, please modify
these Makefiles.

21
packages/prism/src/c/mp/mp.h Normal file
View File

@ -0,0 +1,21 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_H
#define MP_H
/*-------------------------------------------------------------------------*/
#include <mpi.h>
/*-------------------------------------------------------------------------*/
#define TAG_GOAL_REQ (1)
#define TAG_GOAL_LEN (2)
#define TAG_GOAL_STR (3)
#define TAG_SWITCH_REQ (4)
#define TAG_SWITCH_RES (5)
/*-------------------------------------------------------------------------*/
#endif /* MP_H */

101
packages/prism/src/c/mp/mp_core.c Normal file
View File

@ -0,0 +1,101 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
/* [27 Aug 2007, by yuizumi]
* FIXME: mp_debug() is currently platform-dependent.
*/
#ifdef MPI
#include "up/up.h"
#include "mp/mp.h"
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <sys/time.h>
#include <unistd.h> /* STDOUT_FILENO */
#include <mpi.h>
/* Currently mpprism works only on Linux systems. */
#define DEV_NULL "/dev/null"
/*-------------------------------------------------------------------------*/
int fd_dup_stdout = -1;
int mp_size;
int mp_rank;
/*-------------------------------------------------------------------------*/
static void close_stdout(void)
{
fd_dup_stdout = dup(STDOUT_FILENO);
if (fd_dup_stdout < 0)
return;
if (freopen(DEV_NULL, "w", stdout) == NULL) {
close(fd_dup_stdout);
fd_dup_stdout = -1;
}
}
/*-------------------------------------------------------------------------*/
void mp_init(int *argc, char **argv[])
{
MPI_Init(argc, argv);
MPI_Comm_size(MPI_COMM_WORLD, &mp_size);
MPI_Comm_rank(MPI_COMM_WORLD, &mp_rank);
if (mp_size < 2) {
printf("Two or more processes required to run mpprism.\n");
MPI_Finalize();
exit(1);
}
if (mp_rank > 0) {
close_stdout();
}
}
void mp_done(void)
{
MPI_Finalize();
}
NORET mp_quit(int status)
{
fprintf(stderr, "The system is aborted by Rank #%d.\n", mp_rank);
MPI_Abort(MPI_COMM_WORLD, status);
exit(status); /* should not reach here */
}
/*-------------------------------------------------------------------------*/
void mp_debug(const char *fmt, ...)
{
#ifdef MP_DEBUG
char str[1024];
va_list ap;
struct timeval tv;
int s, u;
va_start(ap, fmt);
vsnprintf(str, sizeof(str), fmt, ap);
va_end(ap);
gettimeofday(&tv, NULL);
s = tv.tv_sec;
u = tv.tv_usec;
fprintf(stderr, "[RANK:%d] %02d:%02d:%02d.%03d -- %s\n",
mp_rank, (s / 3600) % 24, (s / 60) % 60, s % 60, u / 1000, str);
#endif
}
/*-------------------------------------------------------------------------*/
#endif /* MPI */

19
packages/prism/src/c/mp/mp_core.h Normal file
View File

@ -0,0 +1,19 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_CORE_H
#define MP_CORE_H
/*-------------------------------------------------------------------------*/
extern int mp_size;
extern int mp_rank;
extern int fd_dup_stdout;
/*-------------------------------------------------------------------------*/
void mp_debug(const char *, ...);
NORET mp_quit(int);
/*-------------------------------------------------------------------------*/
#endif /* MP_CORE_H */

256
packages/prism/src/c/mp/mp_em_aux.c Normal file
View File

@ -0,0 +1,256 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/em.h"
#include "up/graph.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_sw.h"
#include <stdlib.h>
/*------------------------------------------------------------------------*/
int sw_msg_size = 0;
static void * sw_msg_send = NULL;
static void * sw_msg_recv = NULL;
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
NORET quit(const char *);
/*------------------------------------------------------------------------*/
void alloc_sw_msg_buffers(void)
{
sw_msg_send = MALLOC(sizeof(double) * sw_msg_size);
sw_msg_recv = MALLOC(sizeof(double) * sw_msg_size);
}
void release_sw_msg_buffers(void)
{
free(sw_msg_send);
sw_msg_send = NULL;
free(sw_msg_recv);
sw_msg_recv = NULL;
}
/*------------------------------------------------------------------------*/
void mpm_bcast_fixed(void)
{
SW_INS_PTR sw_ins_ptr;
char *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = (!!sw_ins_ptr->fixed) | ((!!sw_ins_ptr->fixed_h) << 1);
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_CHAR, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_fixed");
}
void mps_bcast_fixed(void)
{
SW_INS_PTR sw_ins_ptr;
char *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_CHAR, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_fixed");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->fixed = !!(*meg_ptr & 1);
sw_ins_ptr->fixed_h = !!(*meg_ptr & 2);
meg_ptr++;
}
}
}
void mpm_bcast_inside(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->inside;
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_inside");
}
void mps_bcast_inside(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_inside");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->inside = *(meg_ptr++);
}
}
}
void mpm_bcast_inside_h(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->inside_h;
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_inside_h");
}
void mps_bcast_inside_h(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_inside_h");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->inside_h = *(meg_ptr++);
}
}
}
void mpm_bcast_smooth(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
meg_ptr = sw_msg_send;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->smooth;
}
}
MPI_Bcast(sw_msg_send, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mpm_bcast_smooth");
}
void mps_bcast_smooth(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Bcast(sw_msg_recv, sw_msg_size, MPI_DOUBLE, 0, MPI_COMM_WORLD);
mp_debug("mps_bcast_smooth");
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->smooth = *(meg_ptr++);
}
}
}
/*------------------------------------------------------------------------*/
void clear_sw_msg_send(void)
{
double *meg_ptr;
double *end_ptr;
meg_ptr = sw_msg_send;
end_ptr = meg_ptr + sw_msg_size;
while (meg_ptr != end_ptr) {
*(meg_ptr++) = 0.0;
}
}
void mpm_share_expectation(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
MPI_Allreduce(sw_msg_send, sw_msg_recv, sw_msg_size, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
meg_ptr = sw_msg_recv;
for (i = 0; i < occ_switch_tab_size; i++) {
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->total_expect = *(meg_ptr++);
}
}
}
void mps_share_expectation(void)
{
SW_INS_PTR sw_ins_ptr;
double *meg_ptr;
int i;
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_send;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
*(meg_ptr++) = sw_ins_ptr->total_expect;
}
}
MPI_Allreduce(sw_msg_send, sw_msg_recv, sw_msg_size, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
for (i = 0; i < occ_switch_tab_size; i++) {
meg_ptr = sw_msg_recv;
meg_ptr += occ_position[i];
for (sw_ins_ptr = occ_switches[i]; sw_ins_ptr != NULL; sw_ins_ptr = sw_ins_ptr->next) {
sw_ins_ptr->total_expect = *(meg_ptr++);
}
}
}
double mp_sum_value(double value)
{
double g_value;
MPI_Allreduce(&value, &g_value, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
return g_value;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

29
packages/prism/src/c/mp/mp_em_aux.h Normal file
View File

@ -0,0 +1,29 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_AUX_H
#define MP_EM_AUX_H
/*-------------------------------------------------------------------------*/
extern int sw_msg_size;
/*-------------------------------------------------------------------------*/
void alloc_sw_msg_buffers(void);
void release_sw_msg_buffers(void);
void mpm_bcast_fixed(void);
void mps_bcast_fixed(void);
void mpm_bcast_inside(void);
void mps_bcast_inside(void);
void mpm_bcast_inside_h(void);
void mps_bcast_inside_h(void);
void mpm_bcast_smooth(void);
void mps_bcast_smooth(void);
void clear_sw_msg_send(void);
void mpm_share_expectation(void);
void mps_share_expectation(void);
double mp_sum_value(double);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_AUX_H */

265
packages/prism/src/c/mp/mp_em_ml.c Normal file
View File

@ -0,0 +1,265 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "core/error.h"
#include "up/up.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/em_ml.h"
#include "up/graph.h"
#include "up/flags.h"
#include "up/util.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_em_aux.h"
#include <mpi.h>
/*------------------------------------------------------------------------*/
void mpm_share_preconds_em(int *smooth)
{
int ivals[4];
int ovals[4];
ivals[0] = sw_msg_size;
ivals[1] = 0;
ivals[2] = 0;
ivals[3] = *smooth;
MPI_Allreduce(ivals, ovals, 4, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
*smooth = ovals[3];
mp_debug("msgsize=%d, #goals=%d, failure=%s, smooth = %s",
sw_msg_size, num_goals, failure_observed ? "on" : "off", *smooth ? "on" : "off");
alloc_sw_msg_buffers();
mpm_bcast_fixed();
if (*smooth) {
mpm_bcast_smooth();
}
}
void mps_share_preconds_em(int *smooth)
{
int ivals[4];
int ovals[4];
ivals[0] = 0;
ivals[1] = num_goals;
ivals[2] = failure_observed;
ivals[3] = 0;
MPI_Allreduce(ivals, ovals, 4, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
*smooth = ovals[3];
mp_debug("msgsize=%d, #goals=%d, failure=%s, smooth = %s",
sw_msg_size, num_goals, failure_observed ? "on" : "off", *smooth ? "on" : "off");
alloc_sw_msg_buffers();
mps_bcast_fixed();
if (*smooth) {
mps_bcast_smooth();
}
}
/*------------------------------------------------------------------------*/
int mpm_run_em(EM_ENG_PTR emptr)
{
int r, iterate, old_valid, converged, saved=0;
double likelihood, log_prior;
double lambda, old_lambda=0.0;
config_em(emptr);
for (r = 0; r < num_restart; r++) {
SHOW_PROGRESS_HEAD("#em-iters", r);
initialize_params();
mpm_bcast_inside();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
if (daem) {
SHOW_PROGRESS_TEMP(itemp);
}
old_valid = 0;
while (1) {
if (CTRLC_PRESSED) {
SHOW_PROGRESS_INTR();
RET_ERR(err_ctrl_c_pressed);
}
if (failure_observed) {
inside_failure = mp_sum_value(0.0);
}
log_prior = emptr->smooth ? emptr->compute_log_prior() : 0.0;
lambda = mp_sum_value(log_prior);
likelihood = lambda - log_prior;
mp_debug("local lambda = %.9f, lambda = %.9f", log_prior, lambda);
if (verb_em) {
if (emptr->smooth) {
prism_printf("Iteration #%d:\tlog_likelihood=%.9f\tlog_prior=%.9f\tlog_post=%.9f\n", iterate, likelihood, log_prior, lambda);
}
else {
prism_printf("Iteration #%d:\tlog_likelihood=%.9f\n", iterate, likelihood);
}
}
if (!isfinite(lambda)) {
emit_internal_error("invalid log likelihood or log post: %s (at iterateion #%d)",
isnan(lambda) ? "NaN" : "infinity", iterate);
RET_ERR(ierr_invalid_likelihood);
}
if (old_valid && old_lambda - lambda > prism_epsilon) {
emit_error("log likelihood or log post decreased [old: %.9f, new: %.9f] (at iteration #%d)",
old_lambda, lambda, iterate);
RET_ERR(err_invalid_likelihood);
}
if (itemp == 1.0 && likelihood > 0.0) {
emit_error("log likelihood greater than zero [value: %.9f] (at iteration #%d)",
likelihood, iterate);
RET_ERR(err_invalid_likelihood);
}
converged = (old_valid && lambda - old_lambda <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_lambda = lambda;
old_valid = 1;
mpm_share_expectation();
SHOW_PROGRESS(iterate);
RET_ON_ERR(emptr->update_params());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
SHOW_PROGRESS_TAIL(converged, iterate, lambda);
if (r == 0 || lambda > emptr->lambda) {
emptr->lambda = lambda;
emptr->likelihood = likelihood;
emptr->iterate = iterate;
saved = (r < num_restart - 1);
if (saved) {
save_params();
}
}
}
if (saved) {
restore_params();
}
emptr->bic = compute_bic(emptr->likelihood);
emptr->cs = emptr->smooth ? compute_cs(emptr->likelihood) : 0.0;
return BP_TRUE;
}
int mps_run_em(EM_ENG_PTR emptr)
{
int r, iterate, old_valid, converged, saved=0;
double likelihood;
double lambda, old_lambda=0.0;
config_em(emptr);
for (r = 0; r < num_restart; r++) {
mps_bcast_inside();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
old_valid = 0;
while (1) {
RET_ON_ERR(emptr->compute_inside());
RET_ON_ERR(emptr->examine_inside());
if (failure_observed) {
inside_failure = mp_sum_value(inside_failure);
}
likelihood = emptr->compute_likelihood();
lambda = mp_sum_value(likelihood);
mp_debug("local lambda = %.9f, lambda = %.9f", likelihood, lambda);
converged = (old_valid && lambda - old_lambda <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_lambda = lambda;
old_valid = 1;
RET_ON_ERR(emptr->compute_expectation());
mps_share_expectation();
RET_ON_ERR(emptr->update_params());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
if (r == 0 || lambda > emptr->lambda) {
emptr->lambda = lambda;
saved = (r < num_restart - 1);
if (saved) {
save_params();
}
}
}
if (saved) {
restore_params();
}
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

15
packages/prism/src/c/mp/mp_em_ml.h Normal file
View File

@ -0,0 +1,15 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_ML_H
#define MP_EM_ML_H
/*-------------------------------------------------------------------------*/
void mpm_share_preconds_em(int *);
void mps_share_preconds_em(int *);
int mpm_run_em(EM_ENG_PTR);
int mps_run_em(EM_ENG_PTR);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_ML_H */

167
packages/prism/src/c/mp/mp_em_preds.c Normal file
View File

@ -0,0 +1,167 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_ml.h"
#include "up/em_aux_vb.h"
#include "up/graph.h"
#include "up/flags.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_em_aux.h"
#include "mp/mp_em_ml.h"
#include "mp/mp_em_vb.h"
#include "mp/mp_sw.h"
#include <mpi.h>
/*------------------------------------------------------------------------*/
/* mic.c (B-Prolog) */
NORET myquit(int, const char *);
/*------------------------------------------------------------------------*/
int pc_mpm_prism_em_6(void)
{
struct EM_Engine em_eng;
/* [28 Aug 2007, by yuizumi]
* occ_switches[] will be freed in pc_import_occ_switches/1.
* occ_position[] is not allocated.
*/
RET_ON_ERR(check_smooth(&em_eng.smooth));
mpm_share_preconds_em(&em_eng.smooth);
RET_ON_ERR(mpm_run_em(&em_eng));
release_sw_msg_buffers();
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,6), bpx_build_integer(em_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,6), bpx_build_float(em_eng.lambda)) &&
bpx_unify(bpx_get_call_arg(3,6), bpx_build_float(em_eng.likelihood)) &&
bpx_unify(bpx_get_call_arg(4,6), bpx_build_float(em_eng.bic)) &&
bpx_unify(bpx_get_call_arg(5,6), bpx_build_float(em_eng.cs)) &&
bpx_unify(bpx_get_call_arg(6,6), bpx_build_integer(em_eng.smooth));
}
int pc_mps_prism_em_0(void)
{
struct EM_Engine em_eng;
mps_share_preconds_em(&em_eng.smooth);
RET_ON_ERR(mps_run_em(&em_eng));
release_sw_msg_buffers();
release_occ_switches();
release_num_sw_vals();
release_occ_position();
return BP_TRUE;
}
int pc_mpm_prism_vbem_2(void)
{
struct VBEM_Engine vb_eng;
RET_ON_ERR(check_smooth_vb());
mpm_share_preconds_vbem();
RET_ON_ERR(mpm_run_vbem(&vb_eng));
release_sw_msg_buffers();
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,2), bpx_build_integer(vb_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,2), bpx_build_float(vb_eng.free_energy));
}
int pc_mps_prism_vbem_0(void)
{
struct VBEM_Engine vb_eng;
mps_share_preconds_vbem();
RET_ON_ERR(mps_run_vbem(&vb_eng));
release_sw_msg_buffers();
release_occ_switches();
release_num_sw_vals();
release_occ_position();
return BP_TRUE;
}
int pc_mpm_prism_both_em_2(void)
{
struct VBEM_Engine vb_eng;
RET_ON_ERR(check_smooth_vb());
mpm_share_preconds_vbem();
RET_ON_ERR(mpm_run_vbem(&vb_eng));
get_param_means();
release_sw_msg_buffers();
release_num_sw_vals();
return
bpx_unify(bpx_get_call_arg(1,2), bpx_build_integer(vb_eng.iterate)) &&
bpx_unify(bpx_get_call_arg(2,2), bpx_build_float(vb_eng.free_energy));
}
int pc_mps_prism_both_em_0(void)
{
struct VBEM_Engine vb_eng;
mps_share_preconds_vbem();
RET_ON_ERR(mps_run_vbem(&vb_eng));
get_param_means();
release_sw_msg_buffers();
release_occ_switches();
release_num_sw_vals();
release_occ_position();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
int pc_mpm_import_graph_stats_4(void)
{
int dummy[4] = { 0 };
int stats[4];
double avg_shared;
MPI_Reduce(dummy, stats, 4, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD);
avg_shared = (double)(stats[3]) / stats[0];
return
bpx_unify(bpx_get_call_arg(1,4), bpx_build_integer(stats[0])) &&
bpx_unify(bpx_get_call_arg(2,4), bpx_build_integer(stats[1])) &&
bpx_unify(bpx_get_call_arg(3,4), bpx_build_integer(stats[2])) &&
bpx_unify(bpx_get_call_arg(4,4), bpx_build_float(avg_shared));
}
int pc_mps_import_graph_stats_0(void)
{
int dummy[4];
int stats[4];
graph_stats(stats);
MPI_Reduce(stats, dummy, 4, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD);
mp_debug("# subgoals = %d", stats[0]);
mp_debug("# goal nodes = %d", stats[1]);
mp_debug("# switch nodes = %d", stats[2]);
mp_debug("# sharings = %d", stats[3]);
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

19
packages/prism/src/c/mp/mp_em_preds.h Normal file
View File

@ -0,0 +1,19 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_PREDS_H
#define MP_EM_PREDS_H
/*-------------------------------------------------------------------------*/
int pc_mpm_prism_em_6(void);
int pc_mps_prism_em_0(void);
int pc_mpm_prism_vbem_2(void);
int pc_mps_prism_vbem_0(void);
int pc_mpm_prism_both_em_7(void);
int pc_mps_prism_both_em_0(void);
int pc_mpm_import_graph_stats_4(void);
int pc_mps_import_graph_stats_0(void);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_PREDS_H */

256
packages/prism/src/c/mp/mp_em_vb.c Normal file
View File

@ -0,0 +1,256 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifdef MPI
/*------------------------------------------------------------------------*/
#include "bprolog.h"
#include "up/up.h"
#include "up/em.h"
#include "up/em_aux.h"
#include "up/em_aux_vb.h"
#include "up/em_vb.h"
#include "up/graph.h"
#include "up/flags.h"
#include "up/util.h"
#include "mp/mp.h"
#include "mp/mp_core.h"
#include "mp/mp_em_aux.h"
#include <mpi.h>
/*------------------------------------------------------------------------*/
void mpm_share_preconds_vbem(void)
{
int ivals[3];
int ovals[3];
ivals[0] = sw_msg_size;
ivals[1] = 0;
ivals[2] = 0;
MPI_Allreduce(ivals, ovals, 3, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
mp_debug("msgsize=%d, #goals=%d, failure=%s",
sw_msg_size, num_goals, failure_observed ? "on" : "off");
alloc_sw_msg_buffers();
mpm_bcast_fixed();
}
void mps_share_preconds_vbem(void)
{
int ivals[3];
int ovals[3];
ivals[0] = 0;
ivals[1] = num_goals;
ivals[2] = failure_observed;
MPI_Allreduce(ivals, ovals, 3, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
sw_msg_size = ovals[0];
num_goals = ovals[1];
failure_observed = ovals[2];
mp_debug("msgsize=%d, #goals=%d, failure=%s",
sw_msg_size, num_goals, failure_observed ? "on" : "off");
alloc_sw_msg_buffers();
mps_bcast_fixed();
}
/*------------------------------------------------------------------------*/
int mpm_run_vbem(VBEM_ENG_PTR vbptr)
{
int r, iterate, old_valid, converged, saved=0;
double free_energy, old_free_energy=0.0;
double l0, l1;
config_vbem(vbptr);
for (r = 0; r < num_restart; r++) {
SHOW_PROGRESS_HEAD("#vbem-iters", r);
initialize_hyperparams();
mpm_bcast_inside_h();
mpm_bcast_smooth();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
if (daem) {
SHOW_PROGRESS_TEMP(itemp);
}
old_valid = 0;
while (1) {
if (CTRLC_PRESSED) {
SHOW_PROGRESS_INTR();
RET_ERR(err_ctrl_c_pressed);
}
RET_ON_ERR(vbptr->compute_pi());
if (failure_observed) {
inside_failure = mp_sum_value(0.0);
}
l0 = vbptr->compute_free_energy_l0();
l1 = vbptr->compute_free_energy_l1();
free_energy = mp_sum_value(l0 - l1);
mp_debug("local free_energy = %.9f, free_energy = %.9f", l0 - l1, free_energy);
if (verb_em) {
prism_printf("Iteration #%d:\tfree_energy=%.9f\n", iterate, free_energy);
}
if (!isfinite(free_energy)) {
emit_internal_error("invalid variational free energy: %s (at iteration #%d)",
isnan(free_energy) ? "NaN" : "infinity", iterate);
RET_ERR(err_invalid_free_energy);
}
if (old_valid && old_free_energy - free_energy > prism_epsilon) {
emit_error("variational free energy decreased [old: %.9f, new: %.9f] (at iteration #%d)",
old_free_energy, free_energy, iterate);
RET_ERR(err_invalid_free_energy);
}
if (itemp == 1.0 && free_energy > 0.0) {
emit_error("variational free energy greater than zero [value: %.9f] (at iteration #%d)",
free_energy, iterate);
RET_ERR(err_invalid_free_energy);
}
converged = (old_valid && free_energy - old_free_energy <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_free_energy = free_energy;
old_valid = 1;
mpm_share_expectation();
SHOW_PROGRESS(iterate);
RET_ON_ERR(vbptr->update_hyperparams());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
SHOW_PROGRESS_TAIL(converged, iterate, free_energy);
if (r == 0 || free_energy > vbptr->free_energy) {
vbptr->free_energy = free_energy;
vbptr->iterate = iterate;
saved = (r < num_restart - 1);
if (saved) {
save_hyperparams();
}
}
}
if (saved) {
restore_hyperparams();
}
transfer_hyperparams();
return BP_TRUE;
}
int mps_run_vbem(VBEM_ENG_PTR vbptr)
{
int r, iterate, old_valid, converged, saved=0;
double free_energy, old_free_energy=0.0;
double l2;
config_vbem(vbptr);
for (r = 0; r < num_restart; r++) {
mps_bcast_inside_h();
mps_bcast_smooth();
clear_sw_msg_send();
itemp = daem ? itemp_init : 1.0;
iterate = 0;
while (1) {
old_valid = 0;
while (1) {
RET_ON_ERR(vbptr->compute_pi());
RET_ON_ERR(vbptr->compute_inside());
RET_ON_ERR(vbptr->examine_inside());
if (failure_observed) {
inside_failure = mp_sum_value(inside_failure);
}
l2 = vbptr->compute_likelihood() / itemp;
free_energy = mp_sum_value(l2);
mp_debug("local free_energy = %.9f, free_energy = %.9f", l2, free_energy);
converged = (old_valid && free_energy - old_free_energy <= prism_epsilon);
if (converged || REACHED_MAX_ITERATE(iterate)) {
break;
}
old_free_energy = free_energy;
old_valid = 1;
RET_ON_ERR(vbptr->compute_expectation());
mps_share_expectation();
RET_ON_ERR(vbptr->update_hyperparams());
iterate++;
}
if (itemp == 1.0) {
break;
}
itemp *= itemp_rate;
if (itemp >= 1.0) {
itemp = 1.0;
}
}
if (r == 0 || free_energy > vbptr->free_energy) {
vbptr->free_energy = free_energy;
saved = (r < num_restart - 1);
if (saved) {
save_hyperparams();
}
}
}
if (saved) {
restore_hyperparams();
}
transfer_hyperparams();
return BP_TRUE;
}
/*------------------------------------------------------------------------*/
#endif /* MPI */

15
packages/prism/src/c/mp/mp_em_vb.h Normal file
View File

@ -0,0 +1,15 @@
/* -*- c-basic-offset: 4 ; tab-width: 4 -*- */
#ifndef MP_EM_VB_H
#define MP_EM_VB_H
/*-------------------------------------------------------------------------*/
void mpm_share_preconds_vbem(void);
void mps_share_preconds_vbem(void);
int mpm_run_vbem(VBEM_ENG_PTR);
int mps_run_vbem(VBEM_ENG_PTR);
/*-------------------------------------------------------------------------*/
#endif /* MP_EM_VB_H */

Some files were not shown because too many files have changed in this diff Show More