This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/C/init.c

1481 lines
42 KiB
C
Raw Normal View History

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: init.c *
* Last rev: *
* mods: *
* comments: initializing a prolog session *
* *
*************************************************************************/
#ifdef SCCS
2016-01-03 01:34:09 +00:00
static char SccsId[] = "%W% %G%";
#endif
/*
2015-02-03 02:36:51 +00:00
* The code from this file is used to initialize the environment for prolog
*
*/
2016-01-03 01:34:09 +00:00
#define __INIT_C__ 1
#include "Yap.h"
2016-03-29 01:55:12 +01:00
#include "alloc.h"
2013-11-25 10:22:44 +00:00
#include "clause.h"
#include "yapio.h"
2016-03-29 01:55:12 +01:00
#include <stdlib.h>
#include "Foreign.h"
#ifdef LOW_LEVEL_TRACER
#include "tracer.h"
#endif
#ifdef YAPOR
2011-06-02 17:01:00 +01:00
#ifdef YAPOR_COW
#include <signal.h>
#endif /* YAPOR_COW */
#include "or.macros.h"
2011-06-02 17:01:00 +01:00
#endif /* YAPOR */
#if defined(YAPOR) || defined(TABLING)
#if HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#if HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
#if HAVE_FCNTL_H
#include <fcntl.h>
#endif
2016-01-03 01:34:09 +00:00
#endif /* YAPOR || TABLING */
#if HAVE_STRING_H
#include <string.h>
#endif
2016-08-04 16:25:56 +01:00
#ifndef YAPOR
2016-08-03 17:14:27 +01:00
Atom AtomFoundVar, AtomFreeTerm, AtomNil, AtomDot;
#endif // !YAPOR
2016-01-03 01:34:09 +00:00
int Yap_output_msg = FALSE;
2013-11-16 00:27:02 +00:00
2013-11-15 18:25:33 +00:00
#if DEBUG
2016-01-03 01:34:09 +00:00
#define LOGFILE "logfile"
#ifdef MACC
2016-01-03 01:34:09 +00:00
static void InTTYLine(char *);
#endif
#endif
2016-01-03 01:34:09 +00:00
static void SetOp(int, int, char *, Term);
static void InitOps(void);
static void InitDebug(void);
static void CleanBack(PredEntry *, CPredicate, CPredicate, CPredicate);
static void InitStdPreds(void);
static void InitCodes(void);
static void InitVersion(void);
void exit(int);
2011-03-11 19:49:32 +00:00
static void InitWorker(int wid);
/************** YAP PROLOG GLOBAL VARIABLES *************************/
/************* variables related to memory allocation ***************/
2009-10-30 23:59:00 +00:00
ADDR Yap_HeapBase;
/************** declarations local to init.c ************************/
2016-01-03 01:34:09 +00:00
static char *optypes[] = {"", "xfx", "xfy", "yfx", "xf", "yf", "fx", "fy"};
/* OS page size for memory allocation */
2015-06-19 01:30:13 +01:00
size_t Yap_page_size;
#if DEBUG
#if COROUTINING
2016-01-03 01:34:09 +00:00
int Yap_Portray_delays = FALSE;
#endif
#endif
2014-09-15 09:13:50 +01:00
/**
@defgroup Operators Summary of YAP Predefined Operators
@ingroup Syntax
@{
2015-02-03 02:36:51 +00:00
2014-09-15 09:13:50 +01:00
The Prolog syntax caters for operators of three main kinds:
+ prefix;
+ infix;
+ postfix.
2015-02-03 02:36:51 +00:00
Each operator has precedence in the range 1 to 1200, and this
precedence is used to disambiguate expressions where the structure of the
term denoted is not made explicit using brackets. The operator of higher
2014-09-15 09:13:50 +01:00
precedence is the main functor.
2015-02-03 02:36:51 +00:00
If there are two operators with the highest precedence, the ambiguity
is solved analyzing the types of the operators. The possible infix types are:
2014-09-15 09:13:50 +01:00
_xfx_, _xfy_, and _yfx_.
2015-02-03 02:36:51 +00:00
With an operator of type _xfx_ both sub-expressions must have lower
precedence than the operator itself, unless they are bracketed (which
assigns to them zero precedence). With an operator type _xfy_ only the
left-hand sub-expression must have lower precedence. The opposite happens
2014-09-15 09:13:50 +01:00
for _yfx_ type.
2015-02-03 02:36:51 +00:00
A prefix operator can be of type _fx_ or _fy_.
A postfix operator can be of type _xf_ or _yf_.
2014-09-15 09:13:50 +01:00
The meaning of the notation is analogous to the above.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a + b * c
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
means
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a + (b * c)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
as + and \* have the following types and precedences:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
:-op(500,yfx,'+').
:-op(400,yfx,'*').
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Now defining
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
:-op(700,xfy,'++').
:-op(700,xfx,'=:=').
a ++ b =:= c
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
means
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a ++ (b =:= c)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following is the list of the declarations of the predefined operators:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
:-op(1200,fx,['?-', ':-']).
:-op(1200,xfx,[':-','-->']).
:-op(1150,fx,[block,dynamic,mode,public,multifile,meta_predicate,
sequential,table,initialization]).
:-op(1100,xfy,[';','|']).
:-op(1050,xfy,->).
:-op(1000,xfy,',').
:-op(999,xfy,'.').
:-op(900,fy,['\+', not]).
:-op(900,fx,[nospy, spy]).
:-op(700,xfx,[@>=,@=<,@<,@>,<,=,>,=:=,=\=,\==,>=,=<,==,\=,=..,is]).
:-op(500,yfx,['\/','/\','+','-']).
:-op(500,fx,['+','-']).
:-op(400,yfx,['<<','>>','//','*','/']).
:-op(300,xfx,mod).
:-op(200,xfy,['^','**']).
:-op(50,xfx,same).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*/
2016-01-03 01:34:09 +00:00
#define xfx 1
#define xfy 2
#define yfx 3
#define xf 4
#define yf 5
#define fx 6
#define fy 7
int Yap_IsOpType(char *type) {
int i;
for (i = 1; i <= 7; ++i)
if (strcmp(type, optypes[i]) == 0)
break;
return (i <= 7);
}
2016-01-03 01:34:09 +00:00
static int OpDec(int p, const char *type, Atom a, Term m) {
int i;
AtomEntry *ae = RepAtom(a);
OpEntry *info;
#if defined(MODULE_INDEPENDENT_OPERATORS_FLAG)
if (booleanFlag(MODULE_INDEPENDENT_OPERATORS_FLAG)) {
2009-11-20 00:33:14 +00:00
m = PROLOG_MODULE;
2016-08-04 16:25:56 +01:00
} else
#endif
{
if (m == TermProlog)
m = PROLOG_MODULE;
else if (m == USER_MODULE)
m = PROLOG_MODULE;
}
for (i = 1; i <= 7; ++i)
if (strcmp(type, optypes[i]) == 0)
break;
if (i > 7) {
2016-01-03 01:34:09 +00:00
Yap_Error(DOMAIN_ERROR_OPERATOR_SPECIFIER, MkAtomTerm(Yap_LookupAtom(type)),
"op/3");
return (FALSE);
}
if (p) {
if (i == 1 || i == 2 || i == 4)
p |= DcrlpFlag;
if (i == 1 || i == 3 || i == 6)
p |= DcrrpFlag;
}
WRITE_LOCK(ae->ARWLock);
info = Yap_GetOpPropForAModuleHavingALock(ae, m);
if (EndOfPAEntr(info)) {
ModEntry *me;
2016-01-03 01:34:09 +00:00
info = (OpEntry *)Yap_AllocAtomSpace(sizeof(OpEntry));
if (!info)
return false;
info->KindOfPE = Ord(OpProperty);
info->NextForME = (me = Yap_GetModuleEntry(m))->OpForME;
me->OpForME = info;
2016-08-04 16:25:56 +01:00
info->OpModule = m;
info->OpName = a;
2016-01-03 01:34:09 +00:00
// LOCK(OpListLock);
info->OpNext = OpList;
OpList = info;
2016-01-03 01:34:09 +00:00
// UNLOCK(OpListLock);
AddPropToAtom(ae, (PropEntry *)info);
INIT_RWLOCK(info->OpRWLock);
WRITE_LOCK(info->OpRWLock);
WRITE_UNLOCK(ae->ARWLock);
info->Prefix = info->Infix = info->Posfix = 0;
} else {
WRITE_LOCK(info->OpRWLock);
WRITE_UNLOCK(ae->ARWLock);
}
if (i <= 3) {
2015-06-18 08:09:31 +01:00
if (trueGlobalPrologFlag(ISO_FLAG) &&
2016-01-03 01:34:09 +00:00
info->Posfix != 0) /* there is a posfix operator */ {
/* ISO dictates */
WRITE_UNLOCK(info->OpRWLock);
2016-01-03 01:34:09 +00:00
Yap_Error(PERMISSION_ERROR_CREATE_OPERATOR, MkAtomTerm(a), "op/3");
return false;
}
info->Infix = p;
} else if (i <= 5) {
2015-06-18 08:09:31 +01:00
if (trueGlobalPrologFlag(ISO_FLAG) &&
2016-01-03 01:34:09 +00:00
info->Infix != 0) /* there is an infix operator */ {
/* ISO dictates */
WRITE_UNLOCK(info->OpRWLock);
2016-01-03 01:34:09 +00:00
Yap_Error(PERMISSION_ERROR_CREATE_OPERATOR, MkAtomTerm(a), "op/3");
return false;
}
info->Posfix = p;
} else {
info->Prefix = p;
}
WRITE_UNLOCK(info->OpRWLock);
return true;
}
2016-01-03 01:34:09 +00:00
int Yap_OpDec(int p, char *type, Atom a, Term m) {
return (OpDec(p, type, a, m));
}
2016-01-03 01:34:09 +00:00
static void SetOp(int p, int type, char *at, Term m) {
2013-11-15 18:25:33 +00:00
#if DEBUG
if (GLOBAL_Option[5])
2016-01-03 01:34:09 +00:00
fprintf(stderr, "[setop %d %s %s]\n", p, optypes[type], at);
#endif
OpDec(p, optypes[type], Yap_LookupAtom(at), m);
}
2016-08-04 16:25:56 +01:00
bool Yap_dup_op(OpEntry *op, ModEntry *she) {
AtomEntry *ae = RepAtom(op->OpName);
OpEntry *info = (OpEntry *)Yap_AllocAtomSpace(sizeof(OpEntry));
if (!info)
return false;
memcpy(info, op, sizeof(OpEntry));
2016-08-04 16:25:56 +01:00
info->NextForME = she->OpForME;
she->OpForME = info;
info->OpModule = MkAtomTerm(she->AtomOfME);
AddPropToAtom(ae, AbsOpProp(info));
INIT_RWLOCK(info->OpRWLock);
return true;
}
/* Gets the info about an operator in a prop */
2016-01-03 01:34:09 +00:00
Atom Yap_GetOp(OpEntry *pp, int *prio, int fix) {
int n;
SMALLUNSGN p;
if (fix == 0) {
p = pp->Prefix;
if (p & DcrrpFlag)
n = 6, *prio = (p ^ DcrrpFlag);
else
n = 7, *prio = p;
} else if (fix == 1) {
p = pp->Posfix;
if (p & DcrlpFlag)
n = 4, *prio = (p ^ DcrlpFlag);
else
n = 5, *prio = p;
} else {
p = pp->Infix;
if ((p & DcrrpFlag) && (p & DcrlpFlag))
n = 1, *prio = (p ^ (DcrrpFlag | DcrlpFlag));
else if (p & DcrrpFlag)
n = 3, *prio = (p ^ DcrrpFlag);
else if (p & DcrlpFlag)
n = 2, *prio = (p ^ DcrlpFlag);
else
n = 4, *prio = p;
}
return Yap_LookupAtom(optypes[n]);
}
typedef struct OPSTRUCT {
2016-01-03 01:34:09 +00:00
char *opName;
short int opType, opPrio;
} Opdef;
static Opdef Ops[] = {{":-", xfx, 1200},
{"-->", xfx, 1200},
{"?-", fx, 1200},
{":-", fx, 1200},
{"dynamic", fx, 1150},
{"thread_local", fx, 1150},
{"initialization", fx, 1150},
{"volatile", fx, 1150},
{"mode", fx, 1150},
{"public", fx, 1150},
{"multifile", fx, 1150},
{"meta_predicate", fx, 1150},
{"module_transparent", fx, 1150},
{"discontiguous", fx, 1150},
#ifdef YAPOR
2016-01-03 01:34:09 +00:00
{"sequential", fx, 1150},
#endif /* YAPOR */
#ifdef TABLING
2016-01-03 01:34:09 +00:00
{"table", fx, 1150},
#endif /* TABLING */
#ifndef UNCUTABLE
2016-01-03 01:34:09 +00:00
{"uncutable", fx, 1150},
#endif /*UNCUTABLE ceh:*/
2016-01-03 01:34:09 +00:00
{"|", xfy, 1105},
{";", xfy, 1100},
/* {";", yf, 1100}, not allowed in ISO */
{"->", xfy, 1050},
{"*->", xfy, 1050},
{",", xfy, 1000},
{".", xfy, 999},
{"\\+", fy, 900},
{"not", fy, 900},
{"=", xfx, 700},
{"\\=", xfx, 700},
{"is", xfx, 700},
{"=..", xfx, 700},
{"==", xfx, 700},
{"\\==", xfx, 700},
{"@<", xfx, 700},
{"@>", xfx, 700},
{"@=<", xfx, 700},
{"@>=", xfx, 700},
{"=@=", xfx, 700},
{"\\=@=", xfx, 700},
{"=:=", xfx, 700},
{"=\\=", xfx, 700},
{"<", xfx, 700},
{">", xfx, 700},
{"=<", xfx, 700},
{">=", xfx, 700},
{"as", xfx, 600},
{":", xfy, 600},
{"+", yfx, 500},
{"-", yfx, 500},
{"/\\", yfx, 500},
{"\\/", yfx, 500},
{"><", yfx, 500},
{"#", yfx, 500},
{"rdiv", yfx, 400},
{"div", yfx, 400},
{"xor", yfx, 400},
{"*", yfx, 400},
{"/", yfx, 400},
{"//", yfx, 400},
{"<<", yfx, 400},
{">>", yfx, 400},
{"mod", yfx, 400},
{"rem", yfx, 400},
{"+", fy, 200},
{"-", fy, 200},
{"\\", fy, 200},
{"//", yfx, 400},
{"**", xfx, 200},
{"^", xfy, 200}};
static void InitOps(void) {
unsigned int i;
for (i = 0; i < sizeof(Ops) / sizeof(*Ops); ++i)
SetOp(Ops[i].opPrio, Ops[i].opType, Ops[i].opName, PROLOG_MODULE);
}
2014-09-15 09:13:50 +01:00
/// @}
2013-11-15 18:25:33 +00:00
#if DEBUG
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#endif
2016-01-03 01:34:09 +00:00
static void InitDebug(void) {
Atom At;
2013-11-15 18:25:33 +00:00
#if DEBUG
int i;
for (i = 1; i < 20; ++i)
GLOBAL_Option[i] = 0;
2011-06-20 14:49:24 +01:00
if (Yap_output_msg) {
2016-01-03 01:34:09 +00:00
char ch;
2016-04-18 01:09:10 +01:00
#if _WIN32
2016-04-22 18:26:37 +01:00
if (!_isatty(_fileno(stdin))) {
2016-04-18 01:09:10 +01:00
return;
}
#elif HAVE_ISATTY
2016-01-03 01:34:09 +00:00
if (!isatty(0)) {
return;
}
#endif
2016-01-03 01:34:09 +00:00
fprintf(stderr, "absmi address:%p\n", FunAdr(Yap_absmi));
fprintf(stderr, "Set Trace Options:\n");
fprintf(stderr, "a getch\t\tb token\t\tc Lookup\td LookupVar\ti Index\n");
fprintf(stderr, "e SetOp\t\tf compile\tg icode\t\th boot\t\tl log\n");
fprintf(stderr, "m Machine\t p parser\n");
2016-04-18 01:09:10 +01:00
while ((ch = putchar(getchar())) != '\n' && ch != '\r') {
if (ch >= 'a' && ch <= 'z')
2016-01-03 01:34:09 +00:00
GLOBAL_Option[ch - 'a' + 1] = 1;
2016-04-18 01:09:10 +01:00
GLOBAL_Option[ch - 'a' + 1] = 1;
}
if (GLOBAL_Option['l' - 96]) {
GLOBAL_logfile = fopen(LOGFILE, "w");
if (GLOBAL_logfile == NULL) {
2016-01-03 01:34:09 +00:00
fprintf(stderr, "can not open %s\n", LOGFILE);
getchar();
exit(0);
}
2016-01-03 01:34:09 +00:00
fprintf(stderr, "logging session to file 'logfile'\n");
#ifdef MAC
Yap_SetTextFile(LOGFILE);
lp = my_line;
curfile = Nill;
#endif
}
}
#endif
/* Set at full leash */
At = AtomLeash;
Yap_PutValue(At, MkIntTerm(15));
}
2016-01-03 01:34:09 +00:00
static UInt update_flags_from_prolog(UInt flags, PredEntry *pe) {
if (pe->PredFlags & MetaPredFlag)
flags |= MetaPredFlag;
if (pe->PredFlags & SourcePredFlag)
flags |= SourcePredFlag;
if (pe->PredFlags & SequentialPredFlag)
flags |= SequentialPredFlag;
if (pe->PredFlags & UDIPredFlag)
flags |= UDIPredFlag;
if (pe->PredFlags & ModuleTransparentPredFlag)
flags |= ModuleTransparentPredFlag;
2015-03-04 09:54:08 +00:00
if (pe->PredFlags & StandardPredFlag)
flags |= StandardPredFlag;
return flags;
}
2016-03-29 01:55:12 +01:00
void Yap_InitCPred(const char *Name, arity_t Arity, CPredicate code,
2016-01-03 01:34:09 +00:00
pred_flags_t flags) {
CACHE_REGS
2016-01-03 01:34:09 +00:00
Atom atom = NIL;
PredEntry *pe = NULL;
yamop *p_code;
StaticClause *cl = NULL;
Functor f = NULL;
while (atom == NIL) {
if (flags & UserCPredFlag)
atom = Yap_LookupAtom(Name);
else
atom = Yap_FullLookupAtom(Name);
if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
}
2016-01-03 01:34:09 +00:00
if (Arity) {
2008-10-07 23:52:26 +01:00
while (!f) {
2016-01-03 01:34:09 +00:00
f = Yap_MkFunctor(atom, Arity);
2008-10-07 23:52:26 +01:00
if (!f && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
2008-10-07 23:52:26 +01:00
}
}
}
while (pe == NULL) {
if (Arity)
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByFunc(f, CurrentModule));
else
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByAtom(atom, CurrentModule));
if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
2015-02-03 02:36:51 +00:00
}
if (pe->PredFlags & CPredFlag) {
/* already exists */
flags = update_flags_from_prolog(flags, pe);
cl = ClauseCodeToStaticClause(pe->CodeOfPred);
2016-01-03 01:34:09 +00:00
if ((flags | StandardPredFlag | CPredFlag) != pe->PredFlags) {
Yap_ClauseSpace -= cl->ClSize;
Yap_FreeCodeSpace((ADDR)cl);
cl = NULL;
}
}
p_code = cl->ClCode;
while (!cl) {
UInt sz;
if (flags & SafePredFlag) {
2016-01-03 01:34:09 +00:00
sz = (CELL)NEXTOP(NEXTOP(NEXTOP(p_code, Osbpp), p), l);
} else {
2016-01-03 01:34:09 +00:00
sz = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(NEXTOP(p_code, e), p), Osbpp), p),
l);
}
cl = (StaticClause *)Yap_AllocCodeSpace(sz);
if (!cl) {
if (!Yap_growheap(FALSE, sz, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
} else {
Yap_ClauseSpace += sz;
cl->ClFlags = StaticMask;
cl->ClNext = NULL;
cl->ClSize = sz;
cl->usc.ClLine = Yap_source_line_no();
p_code = cl->ClCode;
}
}
pe->CodeOfPred = p_code;
pe->PredFlags = flags | StandardPredFlag | CPredFlag;
2016-01-03 01:34:09 +00:00
pe->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1);
pe->cs.f_code = code;
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_allocate);
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, e);
}
if (flags & UserCPredFlag)
p_code->opc = Yap_opcode(_call_usercpred);
else
p_code->opc = Yap_opcode(_call_cpred);
2014-05-30 01:06:09 +01:00
p_code->y_u.Osbpp.bmap = NULL;
p_code->y_u.Osbpp.s = -Signed(RealEnvSize);
2016-01-03 01:34:09 +00:00
p_code->y_u.Osbpp.p = p_code->y_u.Osbpp.p0 = pe;
p_code = NEXTOP(p_code, Osbpp);
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_deallocate);
2014-05-30 01:06:09 +01:00
p_code->y_u.p.p = pe;
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, p);
}
p_code->opc = Yap_opcode(_procceed);
2014-05-30 01:06:09 +01:00
p_code->y_u.p.p = pe;
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, p);
p_code->opc = Yap_opcode(_Ystop);
2014-05-30 01:06:09 +01:00
p_code->y_u.l.l = cl->ClCode;
pe->OpcodeOfPred = pe->CodeOfPred->opc;
}
2016-01-03 01:34:09 +00:00
bool Yap_AddCallToFli(PredEntry *pe, CPredicate call) {
yamop *p_code;
2015-02-09 01:53:28 +00:00
if (pe->PredFlags & BackCPredFlag) {
p_code = (yamop *)(pe->cs.p_code.FirstClause);
p_code->y_u.OtapFs.f = call;
return true;
} else if (pe->PredFlags & CPredFlag) {
pe->cs.f_code = call;
return true;
} else {
return false;
}
}
2016-01-03 01:34:09 +00:00
bool Yap_AddRetryToFli(PredEntry *pe, CPredicate re) {
yamop *p_code;
2015-02-09 01:53:28 +00:00
if (pe->PredFlags & BackCPredFlag) {
p_code = (yamop *)(pe->cs.p_code.FirstClause);
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, OtapFs);
2015-02-09 01:53:28 +00:00
p_code->y_u.OtapFs.f = re;
return true;
} else {
return false;
}
}
2016-01-03 01:34:09 +00:00
bool Yap_AddCutToFli(PredEntry *pe, CPredicate CUT) {
yamop *p_code;
2015-02-09 01:53:28 +00:00
if (pe->PredFlags & BackCPredFlag) {
p_code = (yamop *)(pe->cs.p_code.FirstClause);
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, OtapFs);
p_code = NEXTOP(p_code, OtapFs);
2015-02-09 01:53:28 +00:00
p_code->y_u.OtapFs.f = CUT;
return true;
} else {
return false;
}
}
2016-03-29 01:55:12 +01:00
void Yap_InitCmpPred(const char *Name, arity_t Arity, CmpPredicate cmp_code,
2016-01-03 01:34:09 +00:00
pred_flags_t flags) {
CACHE_REGS
2016-01-03 01:34:09 +00:00
Atom atom = NIL;
PredEntry *pe = NULL;
yamop *p_code = NULL;
StaticClause *cl = NULL;
Functor f = NULL;
while (atom == NIL) {
atom = Yap_FullLookupAtom(Name);
if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
}
2016-01-03 01:34:09 +00:00
if (Arity) {
2008-10-07 23:52:26 +01:00
while (!f) {
2016-01-03 01:34:09 +00:00
f = Yap_MkFunctor(atom, Arity);
2008-10-07 23:52:26 +01:00
if (!f && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
2008-10-07 23:52:26 +01:00
}
}
}
while (pe == NULL) {
if (Arity)
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByFunc(f, CurrentModule));
else
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByAtom(atom, CurrentModule));
if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
2015-02-03 02:36:51 +00:00
}
2014-10-02 14:34:51 +01:00
if (pe->PredFlags & BinaryPredFlag) {
flags = update_flags_from_prolog(flags, pe);
p_code = pe->CodeOfPred;
/* already exists */
} else {
while (!cl) {
2016-01-03 01:34:09 +00:00
UInt sz = sizeof(StaticClause) +
(CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)NULL), plxxs), p), l);
2015-02-03 02:36:51 +00:00
cl = (StaticClause *)Yap_AllocCodeSpace(sz);
if (!cl) {
2016-01-03 01:34:09 +00:00
if (!Yap_growheap(FALSE, sz, NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s",
Name);
return;
}
} else {
2016-01-03 01:34:09 +00:00
Yap_ClauseSpace += sz;
cl->ClFlags = StaticMask | StandardPredFlag;
cl->ClNext = NULL;
cl->ClSize = sz;
cl->usc.ClLine = Yap_source_line_no();
p_code = cl->ClCode;
break;
}
}
}
2016-01-03 01:34:09 +00:00
// pe->PredFlags = flags | StandardPredFlag;
pe->CodeOfPred = p_code;
pe->cs.d_code = cmp_code;
pe->ModuleOfPred = CurrentModule;
p_code->opc = pe->OpcodeOfPred = Yap_opcode(_call_bfunc_xx);
2014-05-30 01:06:09 +01:00
p_code->y_u.plxxs.p = pe;
p_code->y_u.plxxs.f = FAILCODE;
p_code->y_u.plxxs.x1 = Yap_emit_x(1);
p_code->y_u.plxxs.x2 = Yap_emit_x(2);
p_code->y_u.plxxs.flags = Yap_compile_cmp_flags(pe);
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, plxxs);
p_code->opc = Yap_opcode(_procceed);
2014-05-30 01:06:09 +01:00
p_code->y_u.p.p = pe;
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, p);
p_code->opc = Yap_opcode(_Ystop);
2014-05-30 01:06:09 +01:00
p_code->y_u.l.l = cl->ClCode;
}
2016-03-29 01:55:12 +01:00
void Yap_InitAsmPred(const char *Name, arity_t Arity, int code, CPredicate def,
2016-01-03 01:34:09 +00:00
pred_flags_t flags) {
CACHE_REGS
2016-01-03 01:34:09 +00:00
Atom atom = NIL;
PredEntry *pe = NULL;
Functor f = NULL;
2015-02-03 02:36:51 +00:00
while (atom == NIL) {
atom = Yap_FullLookupAtom(Name);
if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
}
2016-01-03 01:34:09 +00:00
if (Arity) {
2008-10-07 23:52:26 +01:00
while (!f) {
2016-01-03 01:34:09 +00:00
f = Yap_MkFunctor(atom, Arity);
2008-10-07 23:52:26 +01:00
if (!f && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
2008-10-07 23:52:26 +01:00
}
}
}
while (pe == NULL) {
if (Arity)
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByFunc(f, CurrentModule));
else
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByAtom(atom, CurrentModule));
if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
2015-02-03 02:36:51 +00:00
}
flags |= AsmPredFlag | StandardPredFlag | (code);
if (pe->PredFlags & AsmPredFlag) {
flags = update_flags_from_prolog(flags, pe);
/* already exists */
}
pe->PredFlags = flags;
2016-01-03 01:34:09 +00:00
pe->cs.f_code = def;
pe->ModuleOfPred = CurrentModule;
if (def != NULL) {
2016-01-03 01:34:09 +00:00
yamop *p_code = ((StaticClause *)NULL)->ClCode;
StaticClause *cl;
if (pe->CodeOfPred == (yamop *)(&(pe->OpcodeOfPred))) {
if (flags & SafePredFlag) {
2016-01-03 01:34:09 +00:00
cl = (StaticClause *)Yap_AllocCodeSpace(
(CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), Osbpp), p), l));
} else {
2016-01-03 01:34:09 +00:00
cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP(
NEXTOP(NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), e), Osbpp), p), p),
l));
2015-02-03 02:36:51 +00:00
}
if (!cl) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "No Heap Space in InitAsmPred");
return;
}
2016-01-03 01:34:09 +00:00
Yap_ClauseSpace +=
(CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), Osbpp), p), l);
} else {
cl = ClauseCodeToStaticClause(pe->CodeOfPred);
}
cl->ClFlags = StaticMask;
cl->ClNext = NULL;
if (flags & SafePredFlag) {
2016-01-03 01:34:09 +00:00
cl->ClSize = (CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), Osbpp), e), e);
} else {
2016-01-03 01:34:09 +00:00
cl->ClSize = (CELL)NEXTOP(
NEXTOP(NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), e), Osbpp), p), e), e);
}
cl->usc.ClLine = Yap_source_line_no();
p_code = cl->ClCode;
pe->CodeOfPred = p_code;
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_allocate);
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, e);
}
2012-05-07 06:53:27 +01:00
p_code->opc = Yap_opcode(_call_cpred);
2014-05-30 01:06:09 +01:00
p_code->y_u.Osbpp.bmap = NULL;
p_code->y_u.Osbpp.s = -Signed(RealEnvSize);
p_code->y_u.Osbpp.p = p_code->y_u.Osbpp.p0 = pe;
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, Osbpp);
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_deallocate);
2014-05-30 01:06:09 +01:00
p_code->y_u.p.p = pe;
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, p);
}
p_code->opc = Yap_opcode(_procceed);
2014-05-30 01:06:09 +01:00
p_code->y_u.p.p = pe;
2016-01-03 01:34:09 +00:00
p_code = NEXTOP(p_code, p);
p_code->opc = Yap_opcode(_Ystop);
2014-05-30 01:06:09 +01:00
p_code->y_u.l.l = cl->ClCode;
2012-05-07 06:53:27 +01:00
pe->OpcodeOfPred = pe->CodeOfPred->opc;
} else {
pe->OpcodeOfPred = Yap_opcode(_undef_p);
2016-01-03 01:34:09 +00:00
pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
}
}
2016-01-03 01:34:09 +00:00
static void CleanBack(PredEntry *pe, CPredicate Start, CPredicate Cont,
CPredicate Cut) {
yamop *code;
if (pe->cs.p_code.FirstClause != pe->cs.p_code.LastClause ||
pe->cs.p_code.TrueCodeOfPred != pe->cs.p_code.FirstClause ||
pe->CodeOfPred != pe->cs.p_code.FirstClause) {
2016-01-03 01:34:09 +00:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"initiating a C Pred with backtracking");
return;
}
code = (yamop *)(pe->cs.p_code.FirstClause);
2014-05-30 01:06:09 +01:00
code->y_u.OtapFs.p = pe;
if (pe->PredFlags & UserCPredFlag)
code->opc = Yap_opcode(_try_userc);
else
code->opc = Yap_opcode(_try_c);
#ifdef YAPOR
INIT_YAMOP_LTT(code, 2);
PUT_YAMOP_SEQ(code);
#endif /* YAPOR */
2014-05-30 01:06:09 +01:00
code->y_u.OtapFs.f = Start;
2016-01-03 01:34:09 +00:00
code = NEXTOP(code, OtapFs);
if (pe->PredFlags & UserCPredFlag)
code->opc = Yap_opcode(_retry_userc);
else
code->opc = Yap_opcode(_retry_c);
#ifdef YAPOR
INIT_YAMOP_LTT(code, 1);
PUT_YAMOP_SEQ(code);
#endif /* YAPOR */
2014-05-30 01:06:09 +01:00
code->y_u.OtapFs.f = Cont;
2016-01-03 01:34:09 +00:00
code = NEXTOP(code, OtapFs);
if (pe->PredFlags & UserCPredFlag)
code->opc = Yap_opcode(_cut_c);
else
code->opc = Yap_opcode(_cut_userc);
2014-05-30 01:06:09 +01:00
code->y_u.OtapFs.p = pe;
code->y_u.OtapFs.f = Cut;
}
2016-03-29 01:55:12 +01:00
void Yap_InitCPredBack(const char *Name, arity_t Arity, arity_t Extra,
CPredicate Call, CPredicate Retry, pred_flags_t flags) {
Yap_InitCPredBack_(Name, Arity, Extra, Call, Retry, NULL, flags);
}
2016-03-29 01:55:12 +01:00
void Yap_InitCPredBackCut(const char *Name, arity_t Arity, arity_t Extra,
2016-01-03 01:34:09 +00:00
CPredicate Start, CPredicate Cont, CPredicate Cut,
pred_flags_t flags) {
Yap_InitCPredBack_(Name, Arity, Extra, Start, Cont, Cut, flags);
}
2016-03-29 01:55:12 +01:00
void Yap_InitCPredBack_(const char *Name, arity_t Arity, arity_t Extra,
2016-01-03 01:34:09 +00:00
CPredicate Start, CPredicate Cont, CPredicate Cut,
pred_flags_t flags) {
CACHE_REGS
2016-01-03 01:34:09 +00:00
PredEntry *pe = NULL;
Atom atom = NIL;
Functor f = NULL;
while (atom == NIL) {
atom = Yap_FullLookupAtom(Name);
if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
}
2016-01-03 01:34:09 +00:00
if (Arity) {
2008-10-07 23:52:26 +01:00
while (!f) {
2016-01-03 01:34:09 +00:00
f = Yap_MkFunctor(atom, Arity);
2008-10-07 23:52:26 +01:00
if (!f && !Yap_growheap(FALSE, 0L, NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
2008-10-07 23:52:26 +01:00
}
}
}
while (pe == NULL) {
if (Arity)
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByFunc(f, CurrentModule));
else
2016-01-03 01:34:09 +00:00
pe = RepPredProp(PredPropByAtom(atom, CurrentModule));
if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
2015-02-03 02:36:51 +00:00
}
2016-01-03 01:34:09 +00:00
if (pe->cs.p_code.FirstClause != NIL) {
flags = update_flags_from_prolog(flags, pe);
CleanBack(pe, Start, Cont, Cut);
} else {
StaticClause *cl;
2016-01-03 01:34:09 +00:00
yamop *code = ((StaticClause *)NULL)->ClCode;
UInt sz =
(CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(code, OtapFs), OtapFs), OtapFs), l);
if (flags & UserCPredFlag)
pe->PredFlags = UserCPredFlag | BackCPredFlag | CompiledPredFlag | flags;
else
2011-08-31 21:59:30 +01:00
pe->PredFlags = CompiledPredFlag | StandardPredFlag | BackCPredFlag;
#ifdef YAPOR
pe->PredFlags |= SequentialPredFlag;
#endif /* YAPOR */
2015-02-03 02:36:51 +00:00
cl = (StaticClause *)Yap_AllocCodeSpace(sz);
2015-02-03 02:36:51 +00:00
if (cl == NULL) {
2016-01-03 01:34:09 +00:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "No Heap Space in InitCPredBack");
return;
}
cl->ClFlags = StaticMask;
cl->ClNext = NULL;
Yap_ClauseSpace += sz;
2015-02-03 02:36:51 +00:00
cl->ClSize =
2016-01-03 01:34:09 +00:00
(CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(code, OtapFs), OtapFs), OtapFs), e);
cl->usc.ClLine = Yap_source_line_no();
code = cl->ClCode;
2016-01-03 01:34:09 +00:00
pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = pe->cs.p_code.FirstClause =
pe->cs.p_code.LastClause = code;
if (flags & UserCPredFlag)
pe->OpcodeOfPred = code->opc = Yap_opcode(_try_userc);
else
pe->OpcodeOfPred = code->opc = Yap_opcode(_try_c);
2014-05-30 01:06:09 +01:00
code->y_u.OtapFs.f = Start;
code->y_u.OtapFs.p = pe;
code->y_u.OtapFs.s = Arity;
code->y_u.OtapFs.extra = Extra;
#ifdef YAPOR
INIT_YAMOP_LTT(code, 2);
PUT_YAMOP_SEQ(code);
#endif /* YAPOR */
2016-01-03 01:34:09 +00:00
code = NEXTOP(code, OtapFs);
if (flags & UserCPredFlag)
code->opc = Yap_opcode(_retry_userc);
else
code->opc = Yap_opcode(_retry_c);
2014-05-30 01:06:09 +01:00
code->y_u.OtapFs.f = Cont;
code->y_u.OtapFs.p = pe;
code->y_u.OtapFs.s = Arity;
code->y_u.OtapFs.extra = Extra;
#ifdef YAPOR
INIT_YAMOP_LTT(code, 1);
PUT_YAMOP_SEQ(code);
#endif /* YAPOR */
2016-01-03 01:34:09 +00:00
code = NEXTOP(code, OtapFs);
if (flags & UserCPredFlag)
code->opc = Yap_opcode(_cut_userc);
else
code->opc = Yap_opcode(_cut_c);
2014-05-30 01:06:09 +01:00
code->y_u.OtapFs.f = Cut;
code->y_u.OtapFs.p = pe;
code->y_u.OtapFs.s = Arity;
code->y_u.OtapFs.extra = Extra;
2016-01-03 01:34:09 +00:00
code = NEXTOP(code, OtapFs);
code->opc = Yap_opcode(_Ystop);
2014-05-30 01:06:09 +01:00
code->y_u.l.l = cl->ClCode;
}
}
2016-01-03 01:34:09 +00:00
static void InitStdPreds(void) {
Yap_InitCPreds();
Yap_InitBackCPreds();
BACKUP_MACHINE_REGS();
2015-06-19 01:30:13 +01:00
Yap_InitFlags(false);
2016-01-31 10:16:31 +00:00
Yap_InitPlIO();
#if HAVE_MPE
2016-01-03 01:34:09 +00:00
Yap_InitMPE();
#endif
}
2016-01-03 01:34:09 +00:00
static void InitPredHash(void) {
UInt i;
2016-01-03 01:34:09 +00:00
PredHash = (PredEntry **)Yap_AllocAtomSpace(sizeof(PredEntry **) *
PredHashInitialSize);
PredHashTableSize = PredHashInitialSize;
if (PredHash == NULL) {
2016-01-03 01:34:09 +00:00
Yap_Error(SYSTEM_ERROR_FATAL, MkIntTerm(0),
"allocating initial predicate hash table");
}
for (i = 0; i < PredHashTableSize; ++i) {
PredHash[i] = NULL;
}
INIT_RWLOCK(PredHashRWLock);
}
2016-01-03 01:34:09 +00:00
static void InitEnvInst(yamop start[2], yamop **instp, op_numbers opc,
PredEntry *pred) {
yamop *ipc = start;
/* make it look like the instruction is preceeded by a call instruction */
ipc->opc = Yap_opcode(_call);
2014-05-30 01:06:09 +01:00
ipc->y_u.Osbpp.s = -Signed(RealEnvSize);
ipc->y_u.Osbpp.bmap = NULL;
ipc->y_u.Osbpp.p = pred;
ipc->y_u.Osbpp.p0 = pred;
ipc = NEXTOP(ipc, Osbpp);
ipc->opc = Yap_opcode(opc);
*instp = ipc;
}
2016-01-03 01:34:09 +00:00
static void InitOtaplInst(yamop start[1], OPCODE opc, PredEntry *pe) {
yamop *ipc = start;
/* this is a place holder, it should not really be used */
ipc->opc = Yap_opcode(opc);
2014-05-30 01:06:09 +01:00
ipc->y_u.Otapl.s = 0;
ipc->y_u.Otapl.p = pe;
ipc->y_u.Otapl.d = NULL;
#ifdef YAPOR
INIT_YAMOP_LTT(ipc, 1);
#endif /* YAPOR */
#ifdef TABLING
2014-05-30 01:06:09 +01:00
ipc->y_u.Otapl.te = NULL;
#endif /* TABLING */
}
2016-01-03 01:34:09 +00:00
static void InitDBErasedMarker(void) {
2016-03-29 01:55:12 +01:00
DBErasedMarker = (DBRef)Yap_AllocCodeSpace(sizeof(DBStruct));
2009-10-28 15:53:23 +00:00
Yap_LUClauseSpace += sizeof(DBStruct);
2016-03-29 01:55:12 +01:00
DBErasedMarker->id = FunctorDBRef;
DBErasedMarker->Flags = ErasedMask;
DBErasedMarker->Code = NULL;
DBErasedMarker->DBT.DBRefs = NULL;
DBErasedMarker->Parent = NULL;
2009-10-28 15:53:23 +00:00
}
2016-01-03 01:34:09 +00:00
static void InitLogDBErasedMarker(void) {
2016-03-29 01:55:12 +01:00
LogDBErasedMarker = (LogUpdClause *)Yap_AllocCodeSpace(
2016-01-03 01:34:09 +00:00
sizeof(LogUpdClause) + (UInt)NEXTOP((yamop *)NULL, e));
Yap_LUClauseSpace += sizeof(LogUpdClause) + (UInt)NEXTOP((yamop *)NULL, e);
2016-03-29 01:55:12 +01:00
LogDBErasedMarker->Id = FunctorDBRef;
LogDBErasedMarker->ClFlags = ErasedMask | LogUpdMask;
LogDBErasedMarker->lusl.ClSource = NULL;
LogDBErasedMarker->ClRefCount = 0;
LogDBErasedMarker->ClExt = NULL;
LogDBErasedMarker->ClPrev = NULL;
LogDBErasedMarker->ClNext = NULL;
LogDBErasedMarker->ClSize = (UInt)NEXTOP(((LogUpdClause *)NULL)->ClCode, e);
LogDBErasedMarker->ClCode->opc = Yap_opcode(_op_fail);
2016-01-06 12:31:53 +00:00
INIT_CLREF_COUNT(LogDBErasedMarker);
2009-10-28 15:53:23 +00:00
}
2016-01-03 01:34:09 +00:00
static void InitEmptyWakeups(void) {}
2013-04-30 21:23:01 +01:00
2016-01-03 01:34:09 +00:00
static void InitAtoms(void) {
2009-10-30 23:59:00 +00:00
int i;
AtomHashTableSize = MaxHash;
2016-01-03 01:34:09 +00:00
HashChain =
(AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxHash);
2009-10-30 23:59:00 +00:00
if (HashChain == NULL) {
2016-01-03 01:34:09 +00:00
Yap_Error(SYSTEM_ERROR_FATAL, MkIntTerm(0),
"allocating initial atom table");
2009-10-30 23:59:00 +00:00
}
for (i = 0; i < MaxHash; ++i) {
INIT_RWLOCK(HashChain[i].AERWLock);
HashChain[i].Entry = NIL;
}
NOfAtoms = 0;
#if 0 && OLD_STYLE_INITIAL_ATOMS
2016-01-03 01:34:09 +00:00
Yap_LookupAtomWithAddress("**", (AtomEntry *)&(SF_STORE->AtFoundVar));
Yap_ReleaseAtom(AtomFoundVar);
Yap_LookupAtomWithAddress("?", (AtomEntry *)&(SF_STORE->AtFreeTerm));
2009-10-30 23:59:00 +00:00
Yap_ReleaseAtom(AtomFreeTerm);
2016-01-03 01:34:09 +00:00
Yap_LookupAtomWithAddress("[]", (AtomEntry *)&(SF_STORE->AtNil));
Yap_LookupAtomWithAddress(".", (AtomEntry *)&(SF_STORE->AtDot));
2015-03-16 17:25:09 +00:00
#else
AtomFoundVar = Yap_LookupAtom("**");
2016-01-03 01:34:09 +00:00
Yap_ReleaseAtom(AtomFoundVar);
AtomFreeTerm = Yap_LookupAtom("?");
2015-03-16 17:25:09 +00:00
Yap_ReleaseAtom(AtomFreeTerm);
AtomNil = Yap_LookupAtom("[]");
AtomDot = Yap_LookupAtom(".");
2015-03-16 17:25:09 +00:00
#endif
2009-10-30 23:59:00 +00:00
}
2016-01-03 01:34:09 +00:00
static void InitWideAtoms(void) {
2009-10-30 23:59:00 +00:00
int i;
WideAtomHashTableSize = MaxWideHash;
2016-01-03 01:34:09 +00:00
WideHashChain =
(AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxWideHash);
2009-10-30 23:59:00 +00:00
if (WideHashChain == NULL) {
2016-01-03 01:34:09 +00:00
Yap_Error(SYSTEM_ERROR_FATAL, MkIntTerm(0), "allocating wide atom table");
2009-10-30 23:59:00 +00:00
}
for (i = 0; i < MaxWideHash; ++i) {
INIT_RWLOCK(WideHashChain[i].AERWLock);
WideHashChain[i].Entry = NIL;
}
NOfWideAtoms = 0;
}
2016-01-03 01:34:09 +00:00
static void InitInvisibleAtoms(void) {
2015-11-05 15:25:58 +00:00
/* initialize invisible chain */
2016-01-03 01:34:09 +00:00
INVISIBLECHAIN.Entry = NIL;
2016-01-06 12:31:53 +00:00
INIT_RWLOCK(INVISIBLECHAIN.AERWLock);
2009-10-30 23:59:00 +00:00
}
#ifdef YAPOR
void Yap_init_yapor_workers(void) {
CACHE_REGS
int proc;
#ifdef YAPOR_THREADS
return;
#endif /* YAPOR_THREADS */
#ifdef YAPOR_COW
2011-06-02 17:01:00 +01:00
GLOBAL_master_worker = getpid();
if (GLOBAL_number_workers > 1) {
int son;
son = fork();
if (son == -1)
2016-01-03 01:34:09 +00:00
Yap_Error(SYSTEM_ERROR_FATAL, TermNil,
"fork error (Yap_init_yapor_workers)");
if (son > 0) {
2016-01-03 01:34:09 +00:00
/* I am the father, I must stay here and wait for my children to all die
*/
struct sigaction sigact;
sigact.sa_handler = SIG_DFL;
sigemptyset(&sigact.sa_mask);
sigact.sa_flags = SA_RESTART;
sigaction(SIGINT, &sigact, NULL);
pause();
exit(0);
} else
GLOBAL_worker_pid(0) = getpid();
}
#endif /* YAPOR_COW */
for (proc = 1; proc < GLOBAL_number_workers; proc++) {
int son;
son = fork();
if (son == -1)
2016-01-03 01:34:09 +00:00
Yap_Error(SYSTEM_ERROR_FATAL, TermNil,
"fork error (Yap_init_yapor_workers)");
2015-02-03 02:36:51 +00:00
if (son == 0) {
/* new worker */
worker_id = proc;
2011-06-02 17:01:00 +01:00
Yap_remap_yapor_memory();
LOCAL = REMOTE(worker_id);
2011-06-02 17:01:00 +01:00
memcpy(REMOTE(worker_id), REMOTE(0), sizeof(struct worker_local));
InitWorker(worker_id);
break;
} else
GLOBAL_worker_pid(proc) = son;
}
}
#endif /* YAPOR */
2016-01-03 01:34:09 +00:00
#ifdef THREADS
static void InitThreadHandle(int wid) {
REMOTE_ThreadHandle(wid).in_use = FALSE;
REMOTE_ThreadHandle(wid).zombie = FALSE;
REMOTE_ThreadHandle(wid).local_preds = NULL;
#ifdef LOW_LEVEL_TRACER
REMOTE_ThreadHandle(wid).thread_inst_count = 0LL;
#endif
2015-02-03 02:36:51 +00:00
pthread_mutex_init(&(REMOTE_ThreadHandle(wid).tlock), NULL);
pthread_mutex_init(&(REMOTE_ThreadHandle(wid).tlock_status), NULL);
REMOTE_ThreadHandle(wid).tdetach = (CELL)0;
REMOTE_ThreadHandle(wid).cmod = (CELL)0;
2014-10-13 12:34:52 +01:00
{
2016-01-03 01:34:09 +00:00
mbox_t *mboxp = &REMOTE_ThreadHandle(wid).mbox_handle;
pthread_mutex_t *mutexp;
pthread_cond_t *condp;
struct idb_queue *msgsp;
mboxp->name = MkIntTerm(0);
condp = &mboxp->cond;
pthread_cond_init(condp, NULL);
mutexp = &mboxp->mutex;
pthread_mutex_init(mutexp, NULL);
msgsp = &mboxp->msgs;
mboxp->nmsgs = 0;
mboxp->nclients = 0;
mboxp->open = true;
Yap_init_tqueue(msgsp);
}
2009-10-30 23:59:00 +00:00
}
2011-03-11 19:49:32 +00:00
2016-01-03 01:34:09 +00:00
int Yap_InitThread(int new_id) {
2011-03-11 19:49:32 +00:00
struct worker_local *new_s;
if (new_id) {
2016-01-03 01:34:09 +00:00
if (!(new_s =
(struct worker_local *)calloc(sizeof(struct worker_local), 1)))
2011-03-11 19:49:32 +00:00
return FALSE;
Yap_local[new_id] = new_s;
if (!((REGSTORE *)pthread_getspecific(Yap_yaamregs_key))) {
2016-01-03 01:34:09 +00:00
REGSTORE *rs = (REGSTORE *)calloc(sizeof(REGSTORE), 1);
pthread_setspecific(Yap_yaamregs_key, (const void *)rs);
REMOTE_ThreadHandle(new_id).default_yaam_regs = rs;
2013-11-15 01:10:25 +00:00
REMOTE_ThreadHandle(new_id).current_yaam_regs = rs;
rs->worker_id_ = new_id;
rs->worker_local_ = REMOTE(new_id);
}
2011-03-11 19:49:32 +00:00
}
InitWorker(new_id);
return TRUE;
}
#endif
2009-10-30 23:59:00 +00:00
2016-01-03 01:34:09 +00:00
static void InitScratchPad(int wid) {
REMOTE_ScratchPad(wid).ptr = NULL;
REMOTE_ScratchPad(wid).sz = SCRATCH_START_SIZE;
REMOTE_ScratchPad(wid).msz = SCRATCH_START_SIZE;
}
2016-01-03 01:34:09 +00:00
static CELL *InitHandles(int wid) {
size_t initial_slots = 1024;
CELL *handles;
2015-02-03 02:36:51 +00:00
REMOTE_CurSlot(wid) = 1;
2016-01-03 01:34:09 +00:00
REMOTE_NSlots(wid) = initial_slots;
handles = calloc(initial_slots, sizeof(CELL));
2015-02-03 02:36:51 +00:00
2016-01-03 01:34:09 +00:00
if (handles == NULL) {
Yap_Error(SYSTEM_ERROR_INTERNAL, 0 /* TermNil */,
"No space for handles at " __FILE__ " : %d", __LINE__);
}
2015-02-03 02:36:51 +00:00
RESET_VARIABLE(handles);
return handles;
}
2016-01-03 01:34:09 +00:00
void Yap_CloseScratchPad(void) {
CACHE_REGS
2011-05-04 10:11:41 +01:00
Yap_FreeCodeSpace(LOCAL_ScratchPad.ptr);
LOCAL_ScratchPad.sz = SCRATCH_START_SIZE;
LOCAL_ScratchPad.msz = SCRATCH_START_SIZE;
}
#include "iglobals.h"
#include "ilocals.h"
2009-10-30 23:59:00 +00:00
2011-04-29 14:59:17 +01:00
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA)
struct global_data *Yap_global;
2011-04-14 19:19:13 +01:00
long Yap_worker_area_size;
2016-01-03 01:34:09 +00:00
#endif
2011-03-24 16:47:34 +00:00
#if defined(THREADS)
2016-01-03 01:34:09 +00:00
struct worker_local *Yap_local[MAX_THREADS];
2011-03-24 16:47:34 +00:00
#elif defined(YAPOR)
2016-01-03 01:34:09 +00:00
struct worker_local *Yap_local;
#else /* !THREADS && !YAPOR */
2016-01-03 01:34:09 +00:00
struct worker_local Yap_local;
#endif
2016-01-03 01:34:09 +00:00
static void InitCodes(void) {
CACHE_REGS
2011-03-11 19:49:32 +00:00
#if THREADS
2011-03-21 17:07:58 +00:00
int wid;
2011-03-24 16:17:18 +00:00
for (wid = 1; wid < MAX_THREADS; wid++) {
Yap_local[wid] = NULL;
2011-03-11 19:49:32 +00:00
}
#endif
#include "ihstruct.h"
#if THREADS
2011-03-11 19:49:32 +00:00
Yap_InitThread(0);
2011-07-26 15:51:52 +01:00
#endif /* THREADS */
InitGlobal();
2011-07-26 15:51:52 +01:00
#if !THREADS
2011-03-11 19:49:32 +00:00
InitWorker(0);
2011-07-26 15:51:52 +01:00
#endif /* THREADS */
Yap_InitFirstWorkerThreadHandle();
/* make sure no one else can use these two atoms */
LOCAL_SourceModule = CurrentModule = 0;
2015-08-18 20:57:53 +01:00
Yap_ReleaseAtom(AtomOfTerm(TermRefoundVar));
2015-06-19 01:30:13 +01:00
/* flags require atom table done, but must be done as soon as possible,
definitely before any predicate initialization */
// Yap_InitFlags(); moved to HEAPFIELDS
/* make sure we have undefp defined */
/* predicates can only be defined after this point */
{
/* make sure we know about the module predicate */
2016-01-03 01:34:09 +00:00
PredEntry *modp = RepPredProp(PredPropByFunc(FunctorModule, PROLOG_MODULE));
modp->PredFlags |= MetaPredFlag;
}
#ifdef YAPOR
2016-01-03 01:34:09 +00:00
Yap_heap_regs->getwork_code->y_u.Otapl.p =
RepPredProp(PredPropByAtom(AtomGetwork, PROLOG_MODULE));
Yap_heap_regs->getwork_seq_code->y_u.Otapl.p =
RepPredProp(PredPropByAtom(AtomGetworkSeq, PROLOG_MODULE));
#endif /* YAPOR */
}
2016-01-03 01:34:09 +00:00
static void InitVersion(void) {
Yap_PutValue(AtomVersionNumber, MkAtomTerm(Yap_LookupAtom(YAP_FULL_VERSION)));
}
2016-04-22 18:26:37 +01:00
const char *Yap_version(void) {
Term t = Yap_GetValue(AtomVersionNumber);
return RepAtom(AtomOfTerm(t))->StrOfAE;
}
2016-01-03 01:34:09 +00:00
void Yap_InitWorkspace(UInt Heap, UInt Stack, UInt Trail, UInt Atts,
UInt max_table_size, int n_workers, int sch_loop,
int delay_load) {
CACHE_REGS
2016-01-03 01:34:09 +00:00
/* initialize system stuff */
#if PUSH_REGS
#ifdef THREADS
2016-01-03 01:34:09 +00:00
if (!(Yap_local[0] =
(struct worker_local *)calloc(sizeof(struct worker_local), 1)))
2011-03-11 19:49:32 +00:00
return;
pthread_key_create(&Yap_yaamregs_key, NULL);
pthread_setspecific(Yap_yaamregs_key, (const void *)&Yap_standard_regs);
GLOBAL_master_thread = pthread_self();
#else
2015-11-05 15:25:58 +00:00
/* In this case we need to initialize the abstract registers */
Yap_regp = &Yap_standard_regs;
2016-01-03 01:34:09 +00:00
/* the emulator will eventually copy them to its own local
register array, but for now they exist */
#endif
#endif /* PUSH_REGS */
#ifdef THREADS
Yap_regp = ((REGSTORE *)pthread_getspecific(Yap_yaamregs_key));
LOCAL = REMOTE(0);
#endif /* THREADS */
2011-10-13 15:04:16 +01:00
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA)
LOCAL = REMOTE(0);
#endif /* YAPOR_COPY || YAPOR_COW || YAPOR_SBA */
if (Heap < MinHeapSpace)
Heap = MinHeapSpace;
Heap = AdjustPageSize(Heap * K);
2013-03-20 02:25:46 +00:00
Heap /= (K);
/* sanity checking for data areas */
if (Trail < MinTrailSpace)
Trail = MinTrailSpace;
Trail = AdjustPageSize(Trail * K);
2013-03-20 02:25:46 +00:00
Trail /= (K);
if (Stack < MinStackSpace)
Stack = MinStackSpace;
Stack = AdjustPageSize(Stack * K);
2013-03-20 02:25:46 +00:00
Stack /= (K);
if (!Atts)
2016-01-03 01:34:09 +00:00
Atts = 2048 * sizeof(CELL);
else
Atts = AdjustPageSize(Atts * K);
2013-03-20 02:25:46 +00:00
Atts /= (K);
2013-10-04 18:18:57 +01:00
#if defined(THREADS) || defined(YAPOR)
worker_id = 0;
#endif /* YAPOR || THREADS */
#ifdef YAPOR
if (n_workers > MAX_WORKERS)
2015-09-25 10:57:26 +01:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "excessive number of workers");
2011-03-30 14:35:10 +01:00
#ifdef YAPOR_COPY
2016-01-03 01:34:09 +00:00
INFORMATION_MESSAGE("YapOr: copy model with %d worker%s", n_workers,
n_workers == 1 ? "" : "s");
2011-03-30 16:39:09 +01:00
#elif YAPOR_COW
2016-01-03 01:34:09 +00:00
INFORMATION_MESSAGE("YapOr: acow model with %d worker%s", n_workers,
n_workers == 1 ? "" : "s");
2011-04-29 14:59:17 +01:00
#elif YAPOR_SBA
2016-01-03 01:34:09 +00:00
INFORMATION_MESSAGE("YapOr: sba model with %d worker%s", n_workers,
n_workers == 1 ? "" : "s");
2011-04-29 14:59:17 +01:00
#elif YAPOR_THREADS
2016-01-03 01:34:09 +00:00
INFORMATION_MESSAGE("YapOr: threads model with %d worker%s", n_workers,
n_workers == 1 ? "" : "s");
2011-04-29 14:59:17 +01:00
#endif /* YAPOR_COPY - YAPOR_COW - YAPOR_SBA - YAPOR_THREADS */
#endif /* YAPOR */
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA)
2016-01-03 01:34:09 +00:00
Yap_init_yapor_stacks_memory(Trail, Heap, Stack + Atts, n_workers);
#else
2016-01-03 01:34:09 +00:00
Yap_InitMemory(Trail, Heap, Stack + Atts);
2011-04-29 14:59:17 +01:00
#endif
#if defined(YAPOR) || defined(TABLING)
Yap_init_global_optyap_data(max_table_size, n_workers, sch_loop, delay_load);
#endif /* YAPOR || TABLING */
Yap_AttsSize = Atts;
2016-04-22 18:26:37 +01:00
/* InitAbsmi must be done before InitCodes */
2016-01-03 01:34:09 +00:00
/* This must be done before initializing predicates */
#ifdef MPW
2016-04-22 18:26:37 +01:00
Yap_InitAbsmi(REGS, FunctorList);
#else
2016-04-22 18:26:37 +01:00
Yap_InitAbsmi();
#endif
InitCodes();
InitOps();
InitDebug();
InitVersion();
#if THREADS
/* make sure we use the correct value of regcache */
2016-01-03 01:34:09 +00:00
regcache = ((REGSTORE *)pthread_getspecific(Yap_yaamregs_key));
#endif
#if USE_SYSTEM_MALLOC
if (Trail < MinTrailSpace)
Trail = MinTrailSpace;
if (Stack < MinStackSpace)
Stack = MinStackSpace;
2016-01-03 01:34:09 +00:00
if (!(LOCAL_GlobalBase = (ADDR)malloc((Trail + Stack) * 1024))) {
Yap_Error(RESOURCE_ERROR_HEAP, 0,
"could not allocate stack space for main thread");
Yap_exit(1);
}
#if THREADS
/* don't forget this is a thread */
2016-01-03 01:34:09 +00:00
LOCAL_ThreadHandle.stack_address = LOCAL_GlobalBase;
LOCAL_ThreadHandle.tsize = Trail;
LOCAL_ThreadHandle.ssize = Stack;
#endif
#endif
2016-07-31 10:28:14 +01:00
GLOBAL_AllowGlobalExpansion = true;
GLOBAL_AllowLocalExpansion = true;
GLOBAL_AllowTrailExpansion = true;
2016-01-03 01:34:09 +00:00
Yap_InitExStacks(0, Trail, Stack);
Yap_InitYaamRegs(0);
InitStdPreds();
/* make sure tmp area is available */
2016-01-03 01:34:09 +00:00
{ Yap_ReleasePreAllocCodeSpace(Yap_PreAllocCodeSpace()); }
}
2016-01-03 01:34:09 +00:00
int Yap_HaltRegisterHook(HaltHookFunc f, void *env) {
struct halt_hook *h;
if (!(h = (struct halt_hook *)Yap_AllocCodeSpace(sizeof(struct halt_hook))))
return FALSE;
h->environment = env;
h->hook = f;
LOCK(GLOBAL_BGL);
h->next = GLOBAL_HaltHooks;
GLOBAL_HaltHooks = h;
UNLOCK(GLOBAL_BGL);
return TRUE;
}
2016-01-03 01:34:09 +00:00
static void run_halt_hooks(int code) {
struct halt_hook *hooke = GLOBAL_HaltHooks;
while (hooke) {
hooke->hook(code, hooke->environment);
hooke = hooke->next;
}
}
2016-01-03 01:34:09 +00:00
void Yap_exit(int value) {
CACHE_REGS
void closeFiles(int all);
2011-04-29 14:59:17 +01:00
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA)
2011-06-02 17:01:00 +01:00
Yap_unmap_yapor_memory();
#endif /* YAPOR_COPY || YAPOR_COW || YAPOR_SBA */
2016-01-03 01:34:09 +00:00
if (!(LOCAL_PrologMode & BootMode)) {
#ifdef LOW_PROF
remove("PROFPREDS");
remove("PROFILING");
#endif
run_halt_hooks(value);
Yap_ShutdownLoadForeign();
}
2016-01-03 01:34:09 +00:00
Yap_CloseStreams(false);
2016-04-19 23:30:02 +01:00
Yap_CloseReadline();
2016-05-20 01:59:17 +01:00
#if USE_SYSTEM_MALLOC
#endif
exit(value);
}