523fae9544
process overflows as high-level as possible; introduce overflow related errors ExpandWorkSpace should never call Error: use ErrorMessage instead, format_putc should never release memory, causes memory corruption, Linux does not like MAP_FIXED, it can overwrite the actual program code. condor: twick configure to disable readline with condor. ---------------------------------------------------------------------- git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@632 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
1426 lines
38 KiB
C
1426 lines
38 KiB
C
/*************************************************************************
|
|
* *
|
|
* Yap Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: index.c *
|
|
* Last rev: 5/2/88 *
|
|
* mods: *
|
|
* comments: Indexing a Prolog predicate *
|
|
* *
|
|
*************************************************************************/
|
|
#ifdef SCCS
|
|
static char SccsId[] = "%W% %G%";
|
|
#endif
|
|
|
|
/*
|
|
* This file compiles and removes the indexation code for the prolog compiler
|
|
*
|
|
* Some remarks: *try_me always point to inside the code;
|
|
* try always points to outside
|
|
*
|
|
*/
|
|
|
|
#include "Yap.h"
|
|
#include "compile.h"
|
|
#include "clause.h"
|
|
#include "index.h"
|
|
#ifdef YAPOR
|
|
#include "or.macros.h"
|
|
#endif /* YAPOR */
|
|
#ifdef DEBUG
|
|
#include "yapio.h"
|
|
#endif
|
|
#ifndef NULL
|
|
#define NULL (void *)0
|
|
#endif
|
|
|
|
int IPredArity;
|
|
|
|
STATIC_PROTO(int clause_has_cut, (yamop *));
|
|
STATIC_PROTO(int followed_by_cut, (yamop *));
|
|
STATIC_PROTO(void emit_tr, (compiler_vm_op, yamop *, int, int));
|
|
STATIC_PROTO(void emit_try, (compiler_vm_op, int, yamop *, int, int));
|
|
STATIC_PROTO(yamop * Body, (yamop *));
|
|
STATIC_PROTO(yamop * SecB, (yamop *));
|
|
STATIC_PROTO(yamop * SecLB, (yamop *));
|
|
STATIC_PROTO(yamop * ThiB, (yamop *));
|
|
STATIC_PROTO(yamop * ThiLB, (yamop *));
|
|
STATIC_PROTO(void emit_cp_inst, (compiler_vm_op, yamop *, int, int));
|
|
STATIC_PROTO(CELL emit_space, (compiler_vm_op, int, int));
|
|
STATIC_PROTO(CELL emit_go, (int, Term));
|
|
STATIC_PROTO(void emit_if_not, (Term, CELL, CELL));
|
|
STATIC_PROTO(void fill_go, (CELL *, CELL));
|
|
STATIC_PROTO(void fill_switch_slots, (CELL *, CELL, CELL, CELL, CELL, int));
|
|
STATIC_PROTO(void ClrSpace, (CELL *, int));
|
|
STATIC_PROTO(int NGroupsIn, (PredEntry *));
|
|
STATIC_PROTO(void CountGroups, (GroupDef *, int));
|
|
STATIC_PROTO(yamop *FindFirst, (int, int));
|
|
STATIC_PROTO(int SizeTable, (int));
|
|
STATIC_PROTO(void BuildHash, (CELL *, int, int, int));
|
|
STATIC_PROTO(void BuildIfTable, (CELL *, int));
|
|
STATIC_PROTO(void TreatEntry, (EntryDef *, int, int, GroupDef *));
|
|
STATIC_PROTO(CELL DealFixed, (ClauseDef *, int, compiler_vm_op, int, GroupDef *));
|
|
STATIC_PROTO(CELL DealFixedWithBips, (ClauseDef *, int, int, GroupDef *));
|
|
STATIC_PROTO(CELL DealCons, (int));
|
|
STATIC_PROTO(CELL DealAppl, (int));
|
|
STATIC_PROTO(CELL StartList, (int));
|
|
STATIC_PROTO(CELL DealLAt, (ClauseDef *, int, int));
|
|
STATIC_PROTO(CELL DealLAppl, (ClauseDef *, int, int));
|
|
STATIC_PROTO(CELL DealLList, (ClauseDef *, int, int, int));
|
|
STATIC_PROTO(int NoHeadVar, (ClauseDef *, int));
|
|
STATIC_PROTO(CELL DealList, (int));
|
|
STATIC_PROTO(CELL GetFailToGo, (int));
|
|
STATIC_PROTO(int IsExtendedSingle, (int));
|
|
STATIC_PROTO(int gr_has_cuts, (GroupDef *));
|
|
STATIC_PROTO(void EmitGrSwitch, (int));
|
|
STATIC_PROTO(int IndexNonVarGr, (int));
|
|
STATIC_PROTO(void IndexVarGr, (int));
|
|
STATIC_PROTO(int SimpleCase, (void));
|
|
STATIC_PROTO(int ComplexCase, (void));
|
|
STATIC_PROTO(int SpecialCases, (void));
|
|
|
|
static int NClauses, NGroups;
|
|
|
|
static ClauseDef *ArOfCl;
|
|
|
|
static GroupDef *Groups;
|
|
|
|
static EntryDef *Entries;
|
|
|
|
static CELL labelno;
|
|
|
|
static int ExtendedSingle, AtomsOnlyNil;
|
|
|
|
static yamop *FailAddress;
|
|
|
|
static CELL *StorePoint;
|
|
|
|
static yamop * FirstCl;
|
|
|
|
static int RemovedCl; /* There were some clauses removed */
|
|
|
|
static yamop * indexed_code_for_cut = NIL;
|
|
|
|
static CELL log_update;
|
|
|
|
static inline int
|
|
clause_has_cut(yamop * C)
|
|
{
|
|
#ifdef YAPOR
|
|
return(YAMOP_CUT(C));
|
|
#else
|
|
return(FALSE);
|
|
#endif /* YAPOR */
|
|
}
|
|
|
|
/*
|
|
Detect whether the next instruction is a cut.
|
|
Only useful for try and friends.
|
|
*/
|
|
static int followed_by_cut(yamop * code)
|
|
{
|
|
register yamop *p = code;
|
|
while (TRUE)
|
|
{
|
|
if (p->opc == opcode(_get_x_var))
|
|
p = NEXTOP(p,xx);
|
|
if (p->opc == opcode(_get_y_var))
|
|
p = NEXTOP(p,yx);
|
|
else if (p->opc == opcode(_allocate))
|
|
p = NEXTOP(p,e);
|
|
else if (p->opc == opcode(_unify_x_var))
|
|
p = NEXTOP(p,ox);
|
|
else if (p->opc == opcode(_unify_y_var))
|
|
p = NEXTOP(p,oy);
|
|
else if (p->opc == opcode(_unify_l_x_var))
|
|
p = NEXTOP(p,ox);
|
|
else if (p->opc == opcode(_unify_l_y_var))
|
|
p = NEXTOP(p,oy);
|
|
else if (p->opc == opcode(_unify_void))
|
|
p = NEXTOP(p,o);
|
|
else if (p->opc == opcode(_unify_n_voids))
|
|
p = NEXTOP(p,os);
|
|
else if (p->opc == opcode(_unify_l_void))
|
|
p = NEXTOP(p,o);
|
|
else if (p->opc == opcode(_unify_l_n_voids))
|
|
p = NEXTOP(p,os);
|
|
else if (p->opc == opcode(_cut))
|
|
return(TRUE);
|
|
else if (p->opc == opcode(_cut_t))
|
|
return(TRUE);
|
|
else if (p->opc == opcode(_cut_e))
|
|
return(TRUE);
|
|
else return(FALSE);
|
|
}
|
|
/* make lcc happy */
|
|
return(FALSE);
|
|
}
|
|
|
|
|
|
/* emits an opcode followed by an adress */
|
|
inline static void
|
|
emit_tr(compiler_vm_op op, yamop * Address, int NClauses, int HasCut)
|
|
{
|
|
emit(op, Unsigned(Address), (NClauses << 1) + HasCut);
|
|
}
|
|
|
|
/* emits an opcode followed by an adress */
|
|
static void
|
|
emit_try(compiler_vm_op op, int op_offset, yamop * Address, int NClauses, int HasCut)
|
|
{
|
|
if (op == try_op) {
|
|
/* if a try, then try to use cuts if possible */
|
|
indexed_code_for_cut = NIL;
|
|
if (followed_by_cut(Address)) {
|
|
indexed_code_for_cut = Address;
|
|
return;
|
|
}
|
|
}
|
|
emit((compiler_vm_op)((int)op + op_offset), Unsigned(Address), (NClauses << 1) + HasCut);
|
|
}
|
|
|
|
/*
|
|
* compute address of first instruction of clause: try addr,n
|
|
*/
|
|
inline static yamop *
|
|
Body(yamop * Arg)
|
|
{
|
|
return (NEXTOP(Arg,ld));
|
|
}
|
|
|
|
/*
|
|
* compute address of instruction after get_atom or get_struct try
|
|
* addr,n get_atom atom,reg
|
|
*/
|
|
inline static yamop *
|
|
SecB(yamop * Arg)
|
|
{
|
|
yamop *pc = NEXTOP(Arg,ld);
|
|
if (pc->opc == opcode(_get_struct))
|
|
return (NEXTOP(pc,xf));
|
|
else
|
|
return (NEXTOP(pc,xc));
|
|
}
|
|
|
|
/*
|
|
* compute address of instruction after get_list try addr,n
|
|
* et_list reg
|
|
*/
|
|
inline static yamop *
|
|
SecLB(yamop * Arg)
|
|
{
|
|
return (NEXTOP(NEXTOP(Arg,ld),x));
|
|
}
|
|
|
|
/*
|
|
* compute address of instruction after get_list and unify try
|
|
* addr,n get_list reg
|
|
* nify_atom atom
|
|
*/
|
|
inline static yamop *
|
|
ThiB(yamop * Arg)
|
|
{
|
|
yamop *pc = NEXTOP(NEXTOP(Arg,ld),x);
|
|
if (pc->opc == opcode(_unify_struct))
|
|
return (NEXTOP(pc,of));
|
|
else
|
|
return (NEXTOP(pc,oc));
|
|
}
|
|
|
|
/*
|
|
* compute address of instruction after get_list unify_list try
|
|
* addr,n get_list reg unify_list
|
|
*/
|
|
inline static yamop *
|
|
ThiLB(yamop * Arg)
|
|
{
|
|
return ( NEXTOP(NEXTOP(NEXTOP(Arg,ld),x),o));
|
|
}
|
|
|
|
/* emits a try, retry or trust, optimizing for a particular case */
|
|
static void
|
|
emit_cp_inst(compiler_vm_op op, yamop * Address, int Flag, int NClausesAfter)
|
|
{
|
|
int HasCut = clause_has_cut(Address);
|
|
|
|
indexed_code_for_cut = NIL;
|
|
if (op != try_op && profiling)
|
|
emit(retry_profiled_op, Unsigned(CurrentPred), Zero);
|
|
else if (op != try_op && call_counting)
|
|
emit(count_retry_op, Unsigned(CurrentPred), Zero);
|
|
if (NGroups == 1)
|
|
Flag = Flag | LoneGroup;
|
|
else if (Flag & LastGroup) {
|
|
if (op == try_op) {
|
|
Flag &= (FirstIndex | LastFoundList | HeadIndex | IsAtom);
|
|
switch (Flag) {
|
|
case 0:
|
|
emit_tr(trylf_op, Body(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex | LastFoundList:
|
|
emit_tr(trylf_op, SecLB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex | IsAtom:
|
|
emit_tr(retry_op, SecB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex:
|
|
emit_tr(trylf_op, SecB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex | LastFoundList:
|
|
emit_tr(trylh_op, ThiLB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex | IsAtom:
|
|
emit_tr(trylf_op, ThiB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex:
|
|
emit_tr(trylh_op, ThiB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
}
|
|
} else
|
|
Flag ^= LastGroup;
|
|
Flag |= LoneGroup;
|
|
}
|
|
if (ExtendedSingle) {
|
|
if (op == trust_op) {
|
|
emit_cp_inst(retry_op, Address, Flag, NClausesAfter);
|
|
emit_tr(trust_op, FailAddress, NClausesAfter-1, HasCut);
|
|
return;
|
|
}
|
|
Flag |= LoneGroup;
|
|
}
|
|
switch (Flag) {
|
|
case 0:
|
|
emit_try(op, tryin_op - try_op, Body(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case LoneGroup:
|
|
emit_try(op, try_op - try_op, Body(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex:
|
|
emit_try(op, tryfin_op - try_op, SecB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex | IsAtom:
|
|
emit_try(op, tryin_op - try_op, SecB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex | LastFoundList:
|
|
emit_try(op, tryfin_op - try_op, SecLB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex | LoneGroup:
|
|
emit_try(op, tryf_op - try_op, SecB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex | LoneGroup | IsAtom:
|
|
emit_try(op, try_op - try_op, SecB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case FirstIndex | LoneGroup | LastFoundList:
|
|
emit_try(op, tryf_op - try_op, SecLB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex:
|
|
emit_try(op, tryhin_op - try_op, ThiB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex | LastFoundList:
|
|
emit_try(op, tryhin_op - try_op, ThiLB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex | IsAtom:
|
|
emit_try(op, trytin_op - try_op, ThiB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex | LoneGroup:
|
|
emit_try(op, tryh_op - try_op, ThiB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex | LoneGroup | LastFoundList:
|
|
emit_try(op, tryh_op - try_op, ThiLB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
case HeadIndex | LoneGroup | IsAtom:
|
|
emit_try(op, tryt_op - try_op, ThiB(Address), NClausesAfter, HasCut);
|
|
return;
|
|
default:
|
|
return;
|
|
}
|
|
}
|
|
|
|
|
|
/* emits a large switch instruction */
|
|
static CELL
|
|
emit_space(compiler_vm_op op, int space, int nof)
|
|
{
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
StorePoint = emit_extra_size(op, Unsigned(nof), space);
|
|
return (labelno);
|
|
}
|
|
|
|
/* emits a go instruction */
|
|
static CELL
|
|
emit_go(int Gender, Term Name)
|
|
{
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
if (Gender == ApplCl)
|
|
StorePoint = emit_extra_size(go_f_op, Zero, 3 * CellSize);
|
|
else
|
|
StorePoint = emit_extra_size(go_c_op, Zero, 3 * CellSize);
|
|
*StorePoint++ = Unsigned(Name);
|
|
StorePoint[1] = (CELL)FailAddress;
|
|
return (labelno);
|
|
}
|
|
|
|
|
|
/* emits an if_not_then instruction */
|
|
static void
|
|
emit_if_not(Term T1, CELL Ad1, CELL Ad2)
|
|
{
|
|
StorePoint = emit_extra_size(if_not_op, Zero, 3 * CellSize);
|
|
*StorePoint++ = Unsigned(T1);
|
|
*StorePoint++ = Unsigned(Ad1);
|
|
StorePoint[0] = Unsigned(Ad2);
|
|
}
|
|
|
|
|
|
/* places the code where to go in a go instruction */
|
|
static void
|
|
fill_go(CELL *LCons, CELL Code)
|
|
{
|
|
LCons[0] = Code;
|
|
}
|
|
|
|
|
|
/* fills a space after a first instruction with four addresses */
|
|
static void
|
|
fill_switch_slots(CELL *WhereTo, CELL FAddr, CELL SecAddr, CELL ThirdAddr, CELL ThourthAddr, int NOf)
|
|
{
|
|
*WhereTo++ = FAddr;
|
|
*WhereTo++ = SecAddr;
|
|
*WhereTo++ = ThirdAddr;
|
|
if (NOf > 3)
|
|
*WhereTo = ThourthAddr;
|
|
}
|
|
|
|
/* Places in a space pairs 0 -> Fail */
|
|
static void
|
|
ClrSpace(CELL *StSpace, int NBytes)
|
|
{
|
|
int i;
|
|
|
|
NBytes /= 2 * CellSize;
|
|
for (i = 0; i < NBytes; i++) {
|
|
*StSpace++ = Zero;
|
|
*StSpace++ = (CELL)FailAddress;
|
|
}
|
|
}
|
|
|
|
/* Evaluates the number of groups and builds the clause and group arrays */
|
|
static int
|
|
NGroupsIn(PredEntry *ap)
|
|
{
|
|
int x, y, PresentGroup;
|
|
ClauseDef *ActualCl = ArOfCl, *LastClauses[MaxOptions];
|
|
GroupDef *Group = Groups;
|
|
yamop *q = (yamop *)(ap->FirstClause), *LastOne = (yamop *)(ap->LastClause);
|
|
|
|
NGroups = 1;
|
|
LastClauses[VarCl] = NIL;
|
|
LastClauses[AtCl] = NIL;
|
|
LastClauses[ApplCl] = NIL;
|
|
LastClauses[ListCl] = NIL;
|
|
Group = Groups;
|
|
NClauses = 0;
|
|
while (IsVarClause(q)) {
|
|
RemovedCl = TRUE;
|
|
if (q == LastOne)
|
|
return (NGroups);
|
|
else
|
|
q = (yamop *)NextClause(q);
|
|
}
|
|
x = KindOfArg(q);
|
|
if (NonVarCl(x))
|
|
PresentGroup = 1;
|
|
else
|
|
PresentGroup = 0;
|
|
LastClauses[x] = Group->Start = ActualCl;
|
|
Group->NCl = 0;
|
|
Group->First = q;
|
|
Group->Type[VarCl] = 0;
|
|
Group->Type[AtCl] = 0;
|
|
Group->Type[ApplCl] = 0;
|
|
Group->Type[ListCl] = 0;
|
|
Group->SInfo = OnlyNils;
|
|
do {
|
|
while (IsVarClause(q)) {
|
|
RemovedCl = TRUE;
|
|
if (q == LastOne)
|
|
return (NGroups);
|
|
else
|
|
q = (yamop *)NextClause(q);
|
|
}
|
|
x = KindOfArg(q);
|
|
NClauses++;
|
|
ActualCl->Kind = x;
|
|
ActualCl->Code = q;
|
|
if (x == ListCl) {
|
|
ActualCl->Name = HeadOfList(q);
|
|
y = 1;
|
|
} else if (NonVarCl(x)) {
|
|
ActualCl->Name = TermOfCl(q);
|
|
y = 1;
|
|
} else {
|
|
y = 0;
|
|
}
|
|
if (y != PresentGroup) {
|
|
Group++->Last = (ActualCl - 1)->Code;
|
|
NGroups++;
|
|
if ((ADDR)Group > TrailTop-1024)
|
|
growtrail(64 * 1024L);
|
|
Group->First = q;
|
|
Group->Start = ActualCl;
|
|
Group->NCl = 0;
|
|
Group->Type[VarCl] = 0;
|
|
Group->Type[AtCl] = 0;
|
|
Group->Type[ApplCl] = 0;
|
|
Group->Type[ListCl] = 0;
|
|
Group->SInfo = OnlyNils;
|
|
LastClauses[VarCl] = NIL;
|
|
LastClauses[AtCl] = NIL;
|
|
LastClauses[ApplCl] = NIL;
|
|
LastClauses[ListCl] = NIL;
|
|
PresentGroup = y;
|
|
}
|
|
if (x == AtCl) {
|
|
if (ActualCl->Name != MkAtomTerm(AtomNil))
|
|
Group->SInfo &= ~OnlyNils;
|
|
if (KindOfBipArg(q) & (FIsAtom|FIsNum|FIsPrimi)) {
|
|
Group->SInfo |= UsesBips;
|
|
ActualCl->Name = 0x0;
|
|
}
|
|
}
|
|
ActualCl->Next = NIL;
|
|
if (LastClauses[x] != NIL)
|
|
LastClauses[x]->Next = ActualCl;
|
|
LastClauses[x] = ActualCl++;
|
|
/* check for overflow in case we have a really big database */
|
|
if (ASP <= CellPtr (ActualCl) + 256) {
|
|
freep = (char *)ActualCl;
|
|
save_machine_regs();
|
|
longjmp(CompilerBotch, 3);
|
|
}
|
|
(Group->Type[x])++;
|
|
(Group->NCl)++;
|
|
if (q == LastOne)
|
|
q = NIL;
|
|
else
|
|
q = (yamop *)NextClause(q);
|
|
} while (q != NIL);
|
|
return (NGroups);
|
|
}
|
|
|
|
/* for each group find out how many clauses follow that group */
|
|
static void
|
|
CountGroups(GroupDef *Gr, int NGr)
|
|
{
|
|
GroupDef *grp = Gr+NGr;
|
|
int cls = 0;
|
|
do {
|
|
grp--;
|
|
grp->NofClausesAfter = cls;
|
|
cls += grp->NCl;
|
|
} while(grp > Gr);
|
|
}
|
|
|
|
/* Finds the first clause whose arg is neither a list or a var */
|
|
static yamop *
|
|
FindFirst(int i, int kind)
|
|
{
|
|
ClauseDef *GrClaus = Groups[i].Start;
|
|
|
|
while (GrClaus->Kind != kind)
|
|
GrClaus++;
|
|
if (AtomsOnlyNil)
|
|
return (SecB(GrClaus->Code));
|
|
return (Body(GrClaus->Code));
|
|
}
|
|
|
|
/* evaluates the size (power of two) necessary for a table */
|
|
static int
|
|
SizeTable(int Cases)
|
|
{
|
|
register int i = 2;
|
|
|
|
if (Cases <= MinHashEntries)
|
|
return (Cases);
|
|
while ((Cases /= 2) > 0)
|
|
i *= 2;
|
|
return (i * 2);
|
|
}
|
|
|
|
|
|
#define HASH_SHIFT 6
|
|
|
|
/*
|
|
* creates the hash table works if TableSize is a power of two
|
|
*/
|
|
static void
|
|
BuildHash(CELL *WhereTo, int NOfEntries, int TableSize, int Gend)
|
|
{
|
|
register int hash;
|
|
register int i;
|
|
#ifdef DEBUG
|
|
#ifdef CLASHES
|
|
int clashes = 0;
|
|
#endif /* CLASHES */
|
|
#endif /* DEBUG */
|
|
Term WorkTerm;
|
|
EntryDef *EntryP = Entries;
|
|
yamop *Base = (yamop *)CodePtr(WhereTo);
|
|
yamop *EndSpace = (yamop *)((char *)Base + TableSize * 2 * CellSize);
|
|
|
|
ClrSpace(WhereTo, ((int) ((char *)EndSpace - (char *)Base)));
|
|
TableSize--;
|
|
for (i = 0; i < NOfEntries; ++i) {
|
|
register Int d;
|
|
CELL *hentry;
|
|
|
|
WorkTerm = EntryP->Class;
|
|
hash = (Unsigned(WorkTerm) >> HASH_SHIFT) & TableSize;
|
|
hentry = (CELL *)Base + hash * 2;
|
|
d = TableSize & (Unsigned(WorkTerm) | 1);
|
|
while (*hentry) {
|
|
#ifdef DEBUG
|
|
#ifdef CLASHES
|
|
++clashes;
|
|
#endif /* CLASHES */
|
|
#endif /* DEBUG */
|
|
hash = (hash + d) & TableSize;
|
|
hentry = (CELL *)Base + hash * 2;
|
|
}
|
|
hentry[0] = Unsigned(WorkTerm);
|
|
hentry[1] = (CELL)((EntryP++)->Code);
|
|
}
|
|
#ifdef DEBUG
|
|
#ifdef CLASHES
|
|
YP_fprintf(YP_stderr,"hash table clashes: %d %d\n", clashes, NOfEntries);
|
|
#endif /* CLASHES */
|
|
#endif /* DEBUG */
|
|
}
|
|
|
|
|
|
static void
|
|
BuildIfTable(CELL *WhereTo, int NOfEntries)
|
|
{
|
|
register EntryDef *EntryP = Entries;
|
|
register int j;
|
|
|
|
*WhereTo++ = (CELL)FailAddress;
|
|
for (j = 0; j < NOfEntries; ++j) {
|
|
*WhereTo++ = Unsigned(EntryP->Class);
|
|
*WhereTo++ = (CELL)((EntryP++)->Code);
|
|
}
|
|
}
|
|
|
|
|
|
/* Creates the code for each entry in a group */
|
|
static void
|
|
TreatEntry(EntryDef *Entrance, int Gender, int PositionFlag, GroupDef *Gr)
|
|
{
|
|
if (Entrance->Last == Entrance->First) {
|
|
if (PositionFlag & LastGroup) {
|
|
/* last group, meaning we already have a choice point set */
|
|
register yamop * k = (Entrance->First)->Code;
|
|
labelno += 2;
|
|
emit(label_op, Entrance->Code = labelno, Zero);
|
|
if (PositionFlag & HeadIndex) {
|
|
emit_tr(trust_op, ThiB(k), 1, clause_has_cut(k));
|
|
} else {
|
|
/* we cannot emit to SecLB because switch might have already
|
|
set SREG :-(, hence making us jump one step ahead. This
|
|
is not a problem with a direct jump, in this case the
|
|
work on S will just have been squandered */
|
|
emit_tr(trust_op, Body(k), 1, clause_has_cut(k));
|
|
}
|
|
} else if (ExtendedSingle) {
|
|
/* a single alternative and a catchall clause */
|
|
register yamop * k = (Entrance->First)->Code;
|
|
labelno += 2;
|
|
emit(label_op, Entrance->Code = labelno, Zero);
|
|
/* if we are in a list */
|
|
if (PositionFlag & HeadIndex) {
|
|
/* we cannot emit to SecLB because switch might have already
|
|
set SREG :-( */
|
|
emit_try(try_op, 0, Body(k), 1, clause_has_cut(k));
|
|
if (indexed_code_for_cut != NIL) {
|
|
Entrance->Code =
|
|
(CELL)indexed_code_for_cut;
|
|
} else {
|
|
emit_tr(trust_op, FailAddress, 1, clause_has_cut(k));
|
|
Entrance->Code = labelno;
|
|
}
|
|
} else {
|
|
emit_try(try_op, 0, SecB(k), 2, clause_has_cut(k));
|
|
if (indexed_code_for_cut != NIL) {
|
|
Entrance->Code =
|
|
(CELL)indexed_code_for_cut;
|
|
} else {
|
|
emit_tr(trust_op, FailAddress, 1, clause_has_cut(k));
|
|
Entrance->Code = labelno;
|
|
}
|
|
}
|
|
} else if (PositionFlag & HeadIndex) {
|
|
/* single clause in the middle of code, no need to worry about
|
|
choicepoints */
|
|
Entrance->Code = Unsigned(ThiB((Entrance->First)->Code));
|
|
} else {
|
|
Entrance->Code = Unsigned(SecB((Entrance->First)->Code));
|
|
}
|
|
} else {
|
|
ClauseDef *k = Entrance->First;
|
|
int nofentries = 1, nofalts;
|
|
|
|
while (k != Entrance->Last) {
|
|
nofentries++;
|
|
k = k->Next;
|
|
}
|
|
|
|
nofalts = Gr->NofClausesAfter+nofentries;
|
|
k = Entrance->First;
|
|
labelno += 2;
|
|
emit(label_op, (Entrance->Code = labelno), Zero);
|
|
emit_cp_inst(try_op, k->Code, PositionFlag, nofalts);
|
|
nofalts--;
|
|
if (indexed_code_for_cut != NIL) {
|
|
Entrance->Code = (CELL)indexed_code_for_cut;
|
|
} else {
|
|
while ((k = k->Next) != Entrance->Last) {
|
|
emit_cp_inst(retry_op, k->Code, PositionFlag, nofalts);
|
|
nofalts--;
|
|
}
|
|
emit_cp_inst(trust_op, k->Code, PositionFlag, nofalts);
|
|
/* emit a jump with the place to jump to after finishing this group */
|
|
if (NGroups > 1 && !(PositionFlag & LastGroup) && !ExtendedSingle)
|
|
emit(jump_op, (CELL)((Gr+1)->First), Zero);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* Creates the code for either appl or atomic cases */
|
|
static CELL
|
|
DealFixed(ClauseDef *j, int Gender, compiler_vm_op op, int Flag, GroupDef *Gr)
|
|
{
|
|
int NDiffTerms = 1;
|
|
int TableSize, k;
|
|
ClauseDef *NextInChain;
|
|
Term HeadName;
|
|
CELL LFixed;
|
|
CELL *WhereToStore;
|
|
EntryDef *Entry = Entries;
|
|
|
|
Entry->Class = j->Name;
|
|
Entry->Last = Entry->First = j;
|
|
do {
|
|
int l = 0;
|
|
|
|
HeadName = j->Name;
|
|
NextInChain = j->Next;
|
|
j->Next = NIL;
|
|
Entry = Entries;
|
|
while (l < NDiffTerms && Entry->Class != HeadName)
|
|
Entry++, l++;
|
|
if (l == NDiffTerms) {
|
|
if ((ADDR)Entry > TrailTop-1024)
|
|
growtrail(64 * 1024L);
|
|
Entry->Class = HeadName;
|
|
Entry->Last = Entry->First = j;
|
|
NDiffTerms++;
|
|
} else {
|
|
(Entry->Last)->Next = j;
|
|
Entry->Last = j;
|
|
}
|
|
} while ((j = NextInChain) != NIL && j->Name != 0x0);
|
|
Entry = Entries;
|
|
if (NDiffTerms == 1) {
|
|
CELL *WhereToStore;
|
|
|
|
if (AtomsOnlyNil) {
|
|
TreatEntry(Entry, Gender, Flag, Gr);
|
|
return ((CELL)(Entry->Code));
|
|
}
|
|
LFixed = emit_go(Gender, Entry->Class);
|
|
WhereToStore = StorePoint;
|
|
TreatEntry(Entry, Gender, Flag, Gr);
|
|
fill_go(WhereToStore, (CELL)(Entry->Code));
|
|
return (LFixed);
|
|
}
|
|
TableSize = SizeTable(NDiffTerms);
|
|
if (NDiffTerms <= MinHashEntries) {
|
|
if (op == switch_c_op)
|
|
op = if_c_op;
|
|
else
|
|
op = if_f_op;
|
|
LFixed = emit_space(op, CellSize + TableSize * 2 * CellSize, TableSize);
|
|
} else
|
|
LFixed = emit_space(op, TableSize * 2 * CellSize, TableSize);
|
|
WhereToStore = StorePoint;
|
|
for (k = 0; k < NDiffTerms; k++) {
|
|
TreatEntry(Entry, Gender, Flag, Gr);
|
|
Entry++;
|
|
}
|
|
if (NDiffTerms > MinHashEntries)
|
|
BuildHash(WhereToStore, NDiffTerms, TableSize, Gender);
|
|
else
|
|
BuildIfTable(WhereToStore, NDiffTerms);
|
|
return (LFixed);
|
|
}
|
|
|
|
/*
|
|
If atom(X) and friends are around, and for the moment, just forget
|
|
about doing indexing for constants and generate a traditional try,
|
|
retry chain.
|
|
*/
|
|
static CELL
|
|
DealFixedWithBips(ClauseDef *j, int NClauses, int Flag, GroupDef *Gr)
|
|
{
|
|
int i = 2;
|
|
CELL my_labelno;
|
|
int nofalts = Gr->NofClausesAfter+NClauses;
|
|
|
|
labelno += 2;
|
|
my_labelno = labelno;
|
|
emit(label_op, labelno, Zero);
|
|
#ifdef AGRESSIVE_BIPS
|
|
if (j->Name != 0x0 && j->Next->Name != 0x0) {
|
|
/*
|
|
we've got a sequence of i clauses with known argument. Can
|
|
index as normal for them
|
|
*/
|
|
CELL old_labelno;
|
|
yamop *old_FailAddress;
|
|
int old_ExtendedSingle, old_NAlts;
|
|
ClauseDef *j0 = j;
|
|
|
|
labelno += 2;
|
|
old_labelno = labelno;
|
|
old_FailAddress = FailAddress;
|
|
FailAddress = labelno;
|
|
/* the clauses behaves as if a new group */
|
|
NGroups++;
|
|
old_ExtendedSingle = ExtendedSingle;
|
|
ExtendedSingle = FALSE;
|
|
j = j->Next;
|
|
old_NAlts = Gr->NofClausesAfter;
|
|
while (j->Name != 0x0) i++, j = j->Next;
|
|
Gr->NofClausesAfter = old_NAlts + G->NCl - i;
|
|
DealFixed(j0, AtCl, switch_c_op, FirstIndex | IsAtom, Gr);
|
|
emit(label_op, old_labelno, Zero);
|
|
FailAddress = old_FailAddress;
|
|
ExtendedSingle = old_ExtendedSingle;
|
|
Gr->NofClausesAfter = old_NAlts;
|
|
NGroups--;
|
|
} else {
|
|
#endif /* AGRESSIVE_BIPS */
|
|
emit_cp_inst(try_op, j->Code, Flag, nofalts);
|
|
|
|
if (indexed_code_for_cut != NIL) {
|
|
/* Unfortunately, this is bound never to happen */
|
|
return((CELL)indexed_code_for_cut);
|
|
}
|
|
else j = j->Next;
|
|
nofalts--;
|
|
#ifdef AGRESSIVE_BIPS
|
|
}
|
|
#endif /* AGRESSIVE_BIPS */
|
|
/* we handled a group */
|
|
for (; i < NClauses; i++) {
|
|
emit_cp_inst(retry_op, j->Code, Flag, nofalts);
|
|
j = j->Next;
|
|
nofalts--;
|
|
}
|
|
emit_cp_inst(trust_op, j->Code, Flag, nofalts);
|
|
/* emit a jump with the place to jump to after finishing this group */
|
|
if (NGroups > 1 && !(Flag & LastGroup) && !ExtendedSingle)
|
|
emit(jump_op, (CELL)((Gr+1)->First), Zero);
|
|
return(my_labelno);
|
|
}
|
|
|
|
static CELL
|
|
DealCons(int i)
|
|
{
|
|
int NAtCl = Groups[i].Type[AtCl];
|
|
ClauseDef *Cla = Groups[i].Start;
|
|
|
|
if (NAtCl == 1) {
|
|
if (FinalGr(i)) {
|
|
yamop * Cl = FindFirst(i, AtCl);
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
emit_tr(trust_op, Cl, 1, clause_has_cut(Cl));
|
|
return (labelno);
|
|
} else if (ExtendedSingle) {
|
|
yamop * Cl = FindFirst(i, AtCl);
|
|
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
emit_tr(try_op, Cl, 2, clause_has_cut(Cl));
|
|
emit_tr(trust_op, FailAddress, 1, clause_has_cut(FailAddress));
|
|
return (labelno);
|
|
}
|
|
return ((CELL)FindFirst(i, AtCl));
|
|
|
|
} else if (NAtCl == 0)
|
|
return ((CELL)FailAddress);
|
|
|
|
while (Cla->Kind != AtCl)
|
|
Cla++;
|
|
|
|
if (FinalGr(i)) {
|
|
if (Groups[i].SInfo & UsesBips)
|
|
return(DealFixedWithBips(Cla, NAtCl, LastGroup, Groups+i));
|
|
else
|
|
return (DealFixed(Cla, AtCl, switch_c_op,
|
|
FirstIndex | IsAtom | LastGroup, Groups+i));
|
|
} else {
|
|
if (Groups[i].SInfo & UsesBips)
|
|
return(DealFixedWithBips(Cla, NAtCl, 0, Groups+i));
|
|
else
|
|
return (DealFixed(Cla, AtCl, switch_c_op,
|
|
FirstIndex | IsAtom, Groups+i));
|
|
}
|
|
}
|
|
|
|
static CELL
|
|
DealAppl(int i)
|
|
{
|
|
int NApCl = Groups[i].Type[ApplCl];
|
|
ClauseDef *Cla = Groups[i].Start;
|
|
|
|
if (NApCl == 1) {
|
|
if (FinalGr(i)) {
|
|
yamop * Cl = FindFirst(i, ApplCl);
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
emit_tr(trust_op, Cl, 1, clause_has_cut(Cl));
|
|
return (labelno);
|
|
} else if (ExtendedSingle) {
|
|
yamop * Cl = FindFirst(i, ApplCl);
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
emit_tr(try_op, Cl, 2, clause_has_cut(Cl));
|
|
emit_tr(trust_op, FailAddress, 1, clause_has_cut(FailAddress));
|
|
return (labelno);
|
|
}
|
|
return ((CELL)FindFirst(i, ApplCl));
|
|
|
|
} else if (NApCl == 0)
|
|
return ((CELL)FailAddress);
|
|
while (Cla->Kind != ApplCl)
|
|
Cla++;
|
|
if (FinalGr(i)) {
|
|
int Flag = FirstIndex | LastGroup;
|
|
return (DealFixed(Cla, ApplCl, switch_f_op, Flag, Groups+i));
|
|
}
|
|
return (DealFixed(Cla, ApplCl, switch_f_op, FirstIndex, Groups+i));
|
|
}
|
|
|
|
/* Finds the body of the first clause of a group whose first arg is a list */
|
|
static CELL
|
|
StartList(int i)
|
|
{
|
|
ClauseDef *j = Groups[i].Start;
|
|
|
|
while (j->Kind != ListCl)
|
|
j++;
|
|
if (FinalGr(i)) {
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
emit_tr(trust_op, SecLB(j->Code), 1, clause_has_cut(j->Code));
|
|
return (labelno);
|
|
} else if (ExtendedSingle) {
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
emit_tr(try_op, SecLB(j->Code), 2, clause_has_cut(j->Code));
|
|
emit_tr(trust_op, FailAddress, 1, clause_has_cut(FailAddress));
|
|
return (labelno);
|
|
} else {
|
|
return (Unsigned(SecLB(j->Code)));
|
|
}
|
|
}
|
|
|
|
static CELL
|
|
DealLAt(ClauseDef *Cla, int NOfClau, int NG)
|
|
{
|
|
if (NOfClau == 0)
|
|
return ((CELL)FailAddress);
|
|
if (FinalGr(NG)) {
|
|
int Flag = HeadIndex | IsAtom | LastGroup;
|
|
return (DealFixed(Cla, AtCl, switch_c_op, Flag, Groups+NG));
|
|
}
|
|
return (DealFixed(Cla, AtCl, switch_c_op, HeadIndex | IsAtom, Groups+NG));
|
|
}
|
|
|
|
static CELL
|
|
DealLAppl(ClauseDef *Cla, int NOfClauses, int NG)
|
|
{
|
|
if (NOfClauses == 0)
|
|
return ((CELL)FailAddress);
|
|
if (FinalGr(NG)) {
|
|
int Flag = HeadIndex | LastGroup;
|
|
|
|
return (DealFixed(Cla, ApplCl, switch_f_op, Flag, Groups+NG));
|
|
}
|
|
return (DealFixed(Cla, ApplCl, switch_f_op, HeadIndex, Groups+NG));
|
|
}
|
|
|
|
static CELL
|
|
DealLList(ClauseDef *j, int NOfClauses, int PositionFlag, int NG)
|
|
{
|
|
int k, nofalts = 1;
|
|
|
|
if (NOfClauses == 0)
|
|
return ((CELL)FailAddress);
|
|
else if (NOfClauses == 1) {
|
|
if (FinalGr(NG)) {
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
if (PositionFlag & FirstIndex)
|
|
emit_tr(trust_op, SecLB(j->Code), 1, clause_has_cut(j->Code));
|
|
else
|
|
emit_tr(trust_op, ThiLB(j->Code), 1, clause_has_cut(j->Code));
|
|
return (labelno);
|
|
} else if (ExtendedSingle) {
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
if (PositionFlag & FirstIndex)
|
|
emit_tr(try_op, SecLB(j->Code), 2, clause_has_cut(j->Code));
|
|
else
|
|
emit_tr(try_op, ThiLB(j->Code), 2, clause_has_cut(j->Code));
|
|
emit_tr(trust_op, FailAddress, 1, clause_has_cut(FailAddress));
|
|
return (labelno);
|
|
}
|
|
if (PositionFlag & FirstIndex)
|
|
return (Unsigned(SecLB(j->Code)));
|
|
return (Unsigned(ThiLB(j->Code)));
|
|
}
|
|
if (FinalGr(NG))
|
|
PositionFlag |= LastGroup;
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
nofalts = Groups[NG].NofClausesAfter+NOfClauses;
|
|
emit_cp_inst(try_op, j->Code, PositionFlag, nofalts);
|
|
nofalts--;
|
|
if (indexed_code_for_cut != NIL) {
|
|
return((CELL)indexed_code_for_cut);
|
|
} else {
|
|
j = j->Next;
|
|
for (k = 2; k < NOfClauses; ++k) {
|
|
emit_cp_inst(retry_op, j->Code, PositionFlag, nofalts);
|
|
nofalts--;
|
|
j = j->Next;
|
|
}
|
|
emit_cp_inst(trust_op, j->Code, PositionFlag, nofalts);
|
|
/* emit a jump with the place to jump to after finishing this group */
|
|
if (NGroups > 1 && !(PositionFlag & LastGroup) && !ExtendedSingle)
|
|
emit(jump_op, (CELL)(Groups[NG+1].First), Zero);
|
|
return (labelno);
|
|
}
|
|
}
|
|
|
|
|
|
static int
|
|
NoHeadVar(ClauseDef *CInfo, int NClauses)
|
|
{
|
|
while (NClauses--) {
|
|
if (KindOfListArg(CInfo->Code) == VarCl)
|
|
return (FALSE);
|
|
CInfo = CInfo->Next;
|
|
}
|
|
return (TRUE);
|
|
}
|
|
|
|
/* Creates code when several clauses first arg is a list */
|
|
static CELL
|
|
DealList(int i)
|
|
{
|
|
int k;
|
|
ClauseDef *j;
|
|
CELL LLFirst;
|
|
CELL *WhereToStore;
|
|
int NListCl = Groups[i].Type[ListCl];
|
|
int VFlags;
|
|
int nofalts = Groups[i].NofClausesAfter+NListCl;
|
|
|
|
if (NListCl == 0)
|
|
return ((CELL)FailAddress);
|
|
if (NListCl == 1)
|
|
return (StartList(i));
|
|
j = Groups[i].Start;
|
|
while (j->Kind != ListCl)
|
|
j++;
|
|
if (NoHeadVar(j, NListCl)) {
|
|
CELL LLVar, LLAt, LLList, LLAppl;
|
|
ClauseDef *Firsts[MaxOptions], *Lasts[MaxOptions];
|
|
int NOfSameCl[MaxOptions], l;
|
|
|
|
NOfSameCl[AtCl] = 0;
|
|
NOfSameCl[VarCl] = 0;
|
|
NOfSameCl[ListCl] = 0;
|
|
NOfSameCl[ApplCl] = 0;
|
|
LLFirst = emit_space(switch_h_op, 4 * CellSize, 0);
|
|
WhereToStore = StorePoint;
|
|
LLVar = DealLList(j, NListCl, LastFoundList | FirstIndex, i);
|
|
for (l = 0; l < NListCl; ++l) {
|
|
int z = KindOfListArg(j->Code);
|
|
if (NOfSameCl[z] != 0)
|
|
Lasts[z]->Next = j;
|
|
else
|
|
Firsts[z] = j;
|
|
Lasts[z] = j;
|
|
(NOfSameCl[z])++;
|
|
j = j->Next;
|
|
}
|
|
if (NOfSameCl[AtCl])
|
|
Lasts[AtCl]->Next = NIL;
|
|
if (NOfSameCl[VarCl])
|
|
Lasts[VarCl]->Next = NIL;
|
|
if (NOfSameCl[ListCl])
|
|
Lasts[ListCl]->Next = NIL;
|
|
if (NOfSameCl[ApplCl])
|
|
Lasts[ApplCl]->Next = NIL;
|
|
LLAppl = DealLAppl(Firsts[ApplCl], NOfSameCl[ApplCl], i);
|
|
LLAt = DealLAt(Firsts[AtCl], NOfSameCl[AtCl], i);
|
|
LLList = DealLList(Firsts[ListCl], NOfSameCl[ListCl],
|
|
LastFoundList | HeadIndex, i);
|
|
fill_switch_slots(WhereToStore, LLList, LLAt, LLAppl, LLVar, 4);
|
|
return (LLFirst);
|
|
}
|
|
if (FinalGr(i))
|
|
VFlags = FirstIndex | LastFoundList | LastGroup;
|
|
else
|
|
VFlags = FirstIndex | LastFoundList;
|
|
labelno += 2;
|
|
emit(label_op, labelno, Zero);
|
|
emit_cp_inst(try_op, j->Code, VFlags, nofalts);
|
|
nofalts--;
|
|
if (indexed_code_for_cut != NIL) {
|
|
return((CELL)indexed_code_for_cut);
|
|
} else {
|
|
j = j->Next;
|
|
for (k = 2; k < NListCl; ++k) {
|
|
emit_cp_inst(retry_op, j->Code, VFlags, nofalts);
|
|
j = j->Next;
|
|
nofalts--;
|
|
}
|
|
emit_cp_inst(trust_op, j->Code, VFlags, nofalts);
|
|
/* emit a jump with the place to jump to after finishing this group */
|
|
if (NGroups > 1 && !(VFlags & LastGroup) && !ExtendedSingle)
|
|
emit(jump_op, (CELL)(Groups[i+1].First), Zero);
|
|
return (labelno);
|
|
}
|
|
}
|
|
|
|
|
|
/* Finds the place where to go if we have a flop */
|
|
static CELL
|
|
GetFailToGo(int NG)
|
|
{
|
|
if (NGroups == 1)
|
|
return (Unsigned(FAILCODE));
|
|
if (FinalGr(NG))
|
|
return (Unsigned(TRUSTFAILCODE));
|
|
if (ExtendedSingle)
|
|
return (Unsigned(Body(Groups[NG + 1].Start->Code)));
|
|
return (Unsigned(FAILCODE));
|
|
}
|
|
|
|
|
|
/* Verifies if we have a group and a var first clause (catchall, usually) */
|
|
static int
|
|
IsExtendedSingle(int NG)
|
|
{
|
|
if (NGroups == 2 && NG == 0 && Groups[1].NCl == 1 &&
|
|
NClauses <= CLAUSES_FOR_EXTENDED_SINGLE)
|
|
return (TRUE);
|
|
return (FALSE);
|
|
}
|
|
|
|
static int
|
|
gr_has_cuts(GroupDef *gr)
|
|
{
|
|
return(0);
|
|
}
|
|
|
|
static void
|
|
EmitGrSwitch(int Count)
|
|
{
|
|
GroupDef Gr;
|
|
|
|
Gr = Groups[Count];
|
|
if (!Gr.Type[ApplCl] && (Gr.SInfo & OnlyNils)) {
|
|
AtomsOnlyNil = TRUE;
|
|
if (FinalGr(Count)) {
|
|
emit_space(switch_ll_op, 3 * CellSize,
|
|
((Gr.NCl) << 1)+gr_has_cuts(Groups+Count));
|
|
} else if (NGroups == 1 || ExtendedSingle)
|
|
emit_space(switch_lnl_op, 4 * CellSize, 0);
|
|
else
|
|
emit_space(switch_nvl_op, 3 * CellSize, 0);
|
|
} else {
|
|
AtomsOnlyNil = FALSE;
|
|
if (FinalGr(Count))
|
|
emit_space(switch_l_op, 3 * CellSize,
|
|
((Gr.NCl) << 1)+gr_has_cuts(Groups+Count));
|
|
else if (NGroups == 1 || ExtendedSingle)
|
|
emit_space(switch_t_op, 4 * CellSize, 0);
|
|
else
|
|
emit_space(switch_nv_op, 3 * CellSize, 0);
|
|
}
|
|
}
|
|
|
|
/* Creates the indexation code for a non var group */
|
|
static int
|
|
IndexNonVarGr(int Count)
|
|
{
|
|
CELL LVar, LCons, LA, LL;
|
|
GroupDef Gr;
|
|
CELL *WhereToStore;
|
|
|
|
Gr = Groups[Count];
|
|
ExtendedSingle = IsExtendedSingle(Count);
|
|
FailAddress = (yamop *)GetFailToGo(Count);
|
|
if (NGroups > 1 && !(ExtendedSingle) && Count < NGroups - 1) {
|
|
labelno += 2;
|
|
Groups[Count + 1].First = (yamop *)labelno;
|
|
}
|
|
if (Gr.NCl == 1) {
|
|
yamop * Cl = (Gr.Start)->Code;
|
|
if (Count == 0)
|
|
emit_tr(try_op, Body(Cl), Gr.NofClausesAfter+1, clause_has_cut(Cl));
|
|
else if (FinalGr(Count))
|
|
emit_tr(trust_op, Body(Cl), Gr.NofClausesAfter+1, clause_has_cut(Cl));
|
|
else
|
|
emit_tr(retry_op, Body(Cl), Gr.NofClausesAfter+1, clause_has_cut(Cl));
|
|
return (FALSE); /* Indexation is not necessary */
|
|
}
|
|
if (NGroups > 1 && !(ExtendedSingle) && Count < NGroups - 1) {
|
|
if (Count == 0)
|
|
emit_tr(tryme_op, (yamop *) labelno,
|
|
Gr.NofClausesAfter+1, clause_has_cut((Gr.Start)->Code));
|
|
else
|
|
emit_tr(retryme_op, (yamop *) labelno,
|
|
Gr.NofClausesAfter+1, clause_has_cut((Gr.Start)->Code));
|
|
}
|
|
EmitGrSwitch(Count);
|
|
WhereToStore = StorePoint;
|
|
LCons = DealCons(Count);
|
|
AtomsOnlyNil = FALSE;
|
|
LA = DealAppl(Count);
|
|
LL = DealList(Count);
|
|
if (log_update) {
|
|
LVar = log_update;
|
|
} else
|
|
LVar = Unsigned(FirstCl);
|
|
if (NGroups == 1 || ExtendedSingle)
|
|
fill_switch_slots(WhereToStore, LL, LCons, LA, LVar, 4);
|
|
else
|
|
fill_switch_slots(WhereToStore, LL, LCons, LA, LVar, 3);
|
|
return (TRUE);
|
|
}
|
|
|
|
static void
|
|
IndexVarGr(int Count)
|
|
{
|
|
GroupDef *Gr;
|
|
ClauseDef *Cla;
|
|
int j;
|
|
int nofalts;
|
|
|
|
Gr = Groups + Count;
|
|
Cla = Gr->Start;
|
|
nofalts = Gr->NofClausesAfter+Gr->NCl;
|
|
if (Count == 0) {
|
|
emit_tr(try_op, Body((Cla)->Code), nofalts, clause_has_cut(Cla->Code));
|
|
Cla++;
|
|
nofalts--;
|
|
} else if (Count == NGroups - 1 && Gr->NCl == 1) {
|
|
emit(label_op, Unsigned(Gr->First), Zero);
|
|
emit_tr(trust_op, Body((Cla)->Code), 1, clause_has_cut(Cla->Code));
|
|
return;
|
|
} else {
|
|
emit(label_op, Unsigned(Gr->First), Zero);
|
|
emit_tr(retry_op, Body((Cla)->Code), nofalts, clause_has_cut(Cla->Code));
|
|
Cla++;
|
|
nofalts--;
|
|
}
|
|
for (j = 2; j < Gr->NCl; ++j) {
|
|
emit_tr(retry_op, Body((Cla)->Code), nofalts, clause_has_cut(Cla->Code));
|
|
Cla++;
|
|
nofalts--;
|
|
}
|
|
if (Gr->NCl > 1) {
|
|
if (Count == NGroups - 1)
|
|
emit_tr(trust_op, Body(Cla->Code), 1, clause_has_cut(Cla->Code));
|
|
else
|
|
emit_tr(retry_op, Body(Cla->Code), nofalts, clause_has_cut(Cla->Code));
|
|
}
|
|
}
|
|
|
|
|
|
static int
|
|
SimpleCase(void)
|
|
{
|
|
if (Groups[0].Type[VarCl] != 0)
|
|
return (FALSE);
|
|
return (IndexNonVarGr(0));
|
|
}
|
|
|
|
static int
|
|
ComplexCase(void)
|
|
{
|
|
int Indexable = FALSE, i;
|
|
|
|
if (IsExtendedSingle(0))
|
|
return (SimpleCase());
|
|
emit(jump_v_op, (CELL) FirstCl, Zero);
|
|
if (Groups[0].Type[VarCl] == 0)
|
|
i = 0;
|
|
else {
|
|
IndexVarGr(0);
|
|
i = 1;
|
|
}
|
|
for (; i < NGroups; i += 2) {
|
|
Indexable |= IndexNonVarGr(i);
|
|
if (i < NGroups - 1)
|
|
IndexVarGr(i + 1);
|
|
}
|
|
return (Indexable);
|
|
}
|
|
|
|
|
|
static int
|
|
SpecialCases(void)
|
|
{
|
|
CELL LVar;
|
|
|
|
if (log_update) {
|
|
LVar = log_update;
|
|
} else {
|
|
LVar = (CELL)(ArOfCl->Code);
|
|
}
|
|
/* Clear what was left before */
|
|
freep = (char *) (ArOfCl + NClauses);
|
|
CodeStart = cpc = NIL;
|
|
/* For now just a special case */
|
|
if (NGroups == 2 && NClauses == 2 && Groups[0].Type[AtCl] == 1 &&
|
|
!RemovedCl && !(Groups[0].SInfo & UsesBips)) {
|
|
emit_if_not(ArOfCl->Name, Unsigned(Body(ArOfCl[1].Code)),
|
|
LVar);
|
|
return (TRUE);
|
|
} else
|
|
return (FALSE);
|
|
}
|
|
|
|
CODEADDR
|
|
PredIsIndexable(PredEntry *ap)
|
|
{
|
|
int NGr, Indexable = 0;
|
|
CODEADDR indx_out = NIL;
|
|
log_update = 0;
|
|
|
|
if (setjmp(CompilerBotch) == 3) {
|
|
/* just duplicate the stack */
|
|
restore_machine_regs();
|
|
gc(ap->ArityOfPE, ENV, CP);
|
|
}
|
|
restart_index:
|
|
ErrorMessage = NULL;
|
|
labelno = 1;
|
|
RemovedCl = FALSE;
|
|
FirstCl = (yamop *)(ap->FirstClause);
|
|
CurrentPred = ap;
|
|
if (CurrentPred->PredFlags & ProfiledPredFlag)
|
|
profiling = TRUE;
|
|
else if (CurrentPred->PredFlags & CountPredFlag)
|
|
call_counting = TRUE;
|
|
else
|
|
profiling = FALSE;
|
|
IPredArity = ap->ArityOfPE;
|
|
/* Store the clauses in the Global */
|
|
ArOfCl = (ClauseDef *) H;
|
|
/* and the groups in the Auxiliary */
|
|
Groups = (GroupDef *) TR;
|
|
NGr = NGroupsIn(ap);
|
|
CountGroups(Groups, NGr);
|
|
/* store entries after groups */
|
|
Entries = (EntryDef *) (Groups + NGroups);
|
|
CodeStart = cpc = NIL;
|
|
freep = (char *) (ArOfCl + NClauses);
|
|
if (ErrorMessage != NULL) {
|
|
return (NIL);
|
|
}
|
|
if (CurrentPred->PredFlags & LogUpdatePredFlag) {
|
|
log_update = labelno;
|
|
labelno += 2;
|
|
}
|
|
if (NClauses == 0) {
|
|
Indexable = FALSE;
|
|
return(NIL);
|
|
} else {
|
|
if (NGr == 1)
|
|
Indexable = SimpleCase();
|
|
else
|
|
Indexable = ComplexCase();
|
|
if (!Indexable)
|
|
Indexable = SpecialCases();
|
|
}
|
|
if (CellPtr(freep) >= ASP) {
|
|
Error(SYSTEM_ERROR, TermNil, "out of stack space while indexing");
|
|
return(NIL);
|
|
}
|
|
if (log_update && NClauses > 1) {
|
|
int i;
|
|
Clause *cl;
|
|
|
|
Indexable = TRUE;
|
|
emit(label_op, log_update, Zero);
|
|
emit(try_op, Unsigned(Body(ArOfCl[0].Code)), Zero);
|
|
cl = ClauseCodeToClause(ArOfCl[0].Code);
|
|
if (cl->ClFlags & LogUpdRuleMask) {
|
|
cl->u2.ClExt->u.EC.ClRefs++;
|
|
} else {
|
|
cl->u2.ClUse++;
|
|
}
|
|
for (i = 1; i < NClauses-1; i++) {
|
|
emit(retry_op, Unsigned(Body(ArOfCl[i].Code)), Zero);
|
|
cl = ClauseCodeToClause(ArOfCl[0].Code);
|
|
if (cl->ClFlags & LogUpdRuleMask) {
|
|
cl->u2.ClExt->u.EC.ClRefs++;
|
|
} else {
|
|
cl->u2.ClUse++;
|
|
}
|
|
}
|
|
emit(trust_op, Unsigned(Body(ArOfCl[i].Code)), Zero);
|
|
cl = ClauseCodeToClause(ArOfCl[i].Code);
|
|
if (cl->ClFlags & LogUpdRuleMask) {
|
|
cl->u2.ClExt->u.EC.ClRefs++;
|
|
} else {
|
|
cl->u2.ClUse++;
|
|
}
|
|
}
|
|
if (!Indexable) {
|
|
return (NIL);
|
|
} else {
|
|
#ifdef DEBUG
|
|
if (Option['i' - 'a' + 1]) {
|
|
ShowCode();
|
|
}
|
|
#endif
|
|
if ((indx_out = assemble(ASSEMBLING_INDEX)) == NIL) {
|
|
if (!growheap(FALSE)) {
|
|
Error(SYSTEM_ERROR, TermNil, ErrorMessage);
|
|
return(FALSE);
|
|
}
|
|
goto restart_index;
|
|
}
|
|
}
|
|
return(indx_out);
|
|
}
|