/************************************************************************* * * * 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 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 == Yap_opcode(_get_x_var)) p = NEXTOP(p,xx); if (p->opc == Yap_opcode(_get_y_var)) p = NEXTOP(p,yx); else if (p->opc == Yap_opcode(_allocate)) p = NEXTOP(p,e); else if (p->opc == Yap_opcode(_unify_x_var)) p = NEXTOP(p,ox); else if (p->opc == Yap_opcode(_unify_y_var)) p = NEXTOP(p,oy); else if (p->opc == Yap_opcode(_unify_l_x_var)) p = NEXTOP(p,ox); else if (p->opc == Yap_opcode(_unify_l_y_var)) p = NEXTOP(p,oy); else if (p->opc == Yap_opcode(_unify_void)) p = NEXTOP(p,o); else if (p->opc == Yap_opcode(_unify_n_voids)) p = NEXTOP(p,os); else if (p->opc == Yap_opcode(_unify_l_void)) p = NEXTOP(p,o); else if (p->opc == Yap_opcode(_unify_l_n_voids)) p = NEXTOP(p,os); else if (p->opc == Yap_opcode(_cut)) return(TRUE); else if (p->opc == Yap_opcode(_cut_t)) return(TRUE); else if (p->opc == Yap_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) { Yap_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; } } Yap_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 == Yap_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 == Yap_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) Yap_emit(retry_profiled_op, Unsigned(CurrentPred), Zero); else if (op != try_op && call_counting) Yap_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; Yap_emit(label_op, labelno, Zero); StorePoint = Yap_emit_extra_size(op, Unsigned(nof), space); return (labelno); } /* emits a go instruction */ static CELL emit_go(int Gender, Term Name) { labelno += 2; Yap_emit(label_op, labelno, Zero); if (Gender == ApplCl) StorePoint = Yap_emit_extra_size(go_f_op, Zero, 3 * CellSize); else StorePoint = Yap_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 = Yap_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 = ap->cs.p_code.FirstClause, *LastOne = ap->cs.p_code.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 > Yap_TrailTop-1024) Yap_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(Yap_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 fprintf(Yap_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; Yap_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; Yap_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; Yap_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) Yap_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 > Yap_TrailTop-1024) Yap_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; Yap_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); Yap_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) Yap_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; Yap_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; Yap_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; Yap_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; Yap_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; Yap_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; Yap_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; Yap_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; Yap_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; Yap_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) Yap_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; Yap_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) Yap_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) { Yap_emit(label_op, Unsigned(Gr->First), Zero); emit_tr(trust_op, Body((Cla)->Code), 1, clause_has_cut(Cla->Code)); return; } else { Yap_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()); Yap_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); } yamop * Yap_PredIsIndexable(PredEntry *ap) { int NGr, Indexable = 0; yamop *indx_out = NULL; log_update = 0; if (setjmp(Yap_CompilerBotch) == 3) { /* just duplicate the stack */ restore_machine_regs(); Yap_gc(ap->ArityOfPE, ENV, CP); } restart_index: Yap_ErrorMessage = NULL; labelno = 1; RemovedCl = FALSE; FirstCl = ap->cs.p_code.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 (Yap_ErrorMessage != NULL) { return NULL; } if (CurrentPred->PredFlags & LogUpdatePredFlag) { log_update = labelno; labelno += 2; } if (NClauses == 0) { Indexable = FALSE; return NULL; } else { if (NGr == 1) Indexable = SimpleCase(); else Indexable = ComplexCase(); if (!Indexable) Indexable = SpecialCases(); } if (CellPtr(freep) >= ASP) { Yap_Error(SYSTEM_ERROR, TermNil, "out of stack space while indexing"); return NULL; } if (log_update && NClauses > 1) { int i; Clause *cl; Indexable = TRUE; Yap_emit(label_op, log_update, Zero); Yap_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++) { Yap_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++; } } Yap_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 NULL; } else { #ifdef DEBUG if (Yap_Option['i' - 'a' + 1]) { Yap_ShowCode(); } #endif if ((indx_out = Yap_assemble(ASSEMBLING_INDEX)) == NIL) { if (!Yap_growheap(FALSE)) { Yap_Error(SYSTEM_ERROR, TermNil, Yap_ErrorMessage); return NULL; } goto restart_index; } } return(indx_out); }