diogo
/
YAProlog
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

just a mirror

This commit is contained in:
Diogo Cordeiro 2018-11-14 19:40:48 +00:00
parent 3209078bda
commit 6798b40dbf
4112 changed files with 2355340 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dev/yap-6.3

@ -1 +0,0 @@
Subproject commit bea2431c3ed833d81f5297e32c3776760c047561

201
dev/yap-6.3/Artistic Normal file
View File

@ -0,0 +1,201 @@
The Artistic License 2.0
Copyright (c) 2000-2006, The Perl Foundation.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
This license establishes the terms under which a given free software
Package may be copied, modified, distributed, and/or redistributed.
The intent is that the Copyright Holder maintains some artistic
control over the development of that Package while still keeping the
Package available as open source and free software.
You are always permitted to make arrangements wholly outside of this
license directly with the Copyright Holder of a given Package. If the
terms of this license do not permit the full use that you propose to
make of the Package, you should contact the Copyright Holder and seek
a different licensing arrangement.
Definitions
"Copyright Holder" means the individual(s) or organization(s)
named in the copyright notice for the entire Package.
"Contributor" means any party that has contributed code or other
material to the Package, in accordance with the Copyright Holder's
procedures.
"You" and "your" means any person who would like to copy,
distribute, or modify the Package.
"Package" means the collection of files distributed by the
Copyright Holder, and derivatives of that collection and/or of
those files. A given Package may consist of either the Standard
Version, or a Modified Version.
"Distribute" means providing a copy of the Package or making it
accessible to anyone else, or in the case of a company or
organization, to others outside of your company or organization.
"Distributor Fee" means any fee that you charge for Distributing
this Package or providing support for this Package to another
party. It does not mean licensing fees.
"Standard Version" refers to the Package if it has not been
modified, or has been modified only in ways explicitly requested
by the Copyright Holder.
"Modified Version" means the Package, if it has been changed, and
such changes were not explicitly requested by the Copyright
Holder.
"Original License" means this Artistic License as Distributed with
the Standard Version of the Package, in its current version or as
it may be modified by The Perl Foundation in the future.
"Source" form means the source code, documentation source, and
configuration files for the Package.
"Compiled" form means the compiled bytecode, object code, binary,
or any other form resulting from mechanical transformation or
translation of the Source form.
Permission for Use and Modification Without Distribution
(1) You are permitted to use the Standard Version and create and use
Modified Versions for any purpose without restriction, provided that
you do not Distribute the Modified Version.
Permissions for Redistribution of the Standard Version
(2) You may Distribute verbatim copies of the Source form of the
Standard Version of this Package in any medium without restriction,
either gratis or for a Distributor Fee, provided that you duplicate
all of the original copyright notices and associated disclaimers. At
your discretion, such verbatim copies may or may not include a
Compiled form of the Package.
(3) You may apply any bug fixes, portability changes, and other
modifications made available from the Copyright Holder. The resulting
Package will still be considered the Standard Version, and as such
will be subject to the Original License.
Distribution of Modified Versions of the Package as Source
(4) You may Distribute your Modified Version as Source (either gratis
or for a Distributor Fee, and with or without a Compiled form of the
Modified Version) provided that you clearly document how it differs
from the Standard Version, including, but not limited to, documenting
any non-standard features, executables, or modules, and provided that
you do at least ONE of the following:
(a) make the Modified Version available to the Copyright Holder
of the Standard Version, under the Original License, so that the
Copyright Holder may include your modifications in the Standard
Version.
(b) ensure that installation of your Modified Version does not
prevent the user installing or running the Standard Version. In
addition, the Modified Version must bear a name that is different
from the name of the Standard Version.
(c) allow anyone who receives a copy of the Modified Version to
make the Source form of the Modified Version available to others
under
(i) the Original License or
(ii) a license that permits the licensee to freely copy,
modify and redistribute the Modified Version using the same
licensing terms that apply to the copy that the licensee
received, and requires that the Source form of the Modified
Version, and of any works derived from it, be made freely
available in that license fees are prohibited but Distributor
Fees are allowed.
Distribution of Compiled Forms of the Standard Version
or Modified Versions without the Source
(5) You may Distribute Compiled forms of the Standard Version without
the Source, provided that you include complete instructions on how to
get the Source of the Standard Version. Such instructions must be
valid at the time of your distribution. If these instructions, at any
time while you are carrying out such distribution, become invalid, you
must provide new instructions on demand or cease further distribution.
If you provide valid instructions or cease distribution within thirty
days after you become aware that the instructions are invalid, then
you do not forfeit any of your rights under this license.
(6) You may Distribute a Modified Version in Compiled form without
the Source, provided that you comply with Section 4 with respect to
the Source of the Modified Version.
Aggregating or Linking the Package
(7) You may aggregate the Package (either the Standard Version or
Modified Version) with other packages and Distribute the resulting
aggregation provided that you do not charge a licensing fee for the
Package. Distributor Fees are permitted, and licensing fees for other
components in the aggregation are permitted. The terms of this license
apply to the use and Distribution of the Standard or Modified Versions
as included in the aggregation.
(8) You are permitted to link Modified and Standard Versions with
other works, to embed the Package in a larger work of your own, or to
build stand-alone binary or bytecode versions of applications that
include the Package, and Distribute the result without restriction,
provided the result does not expose a direct interface to the Package.
Items That are Not Considered Part of a Modified Version
(9) Works (including, but not limited to, modules and scripts) that
merely extend or make use of the Package, do not, by themselves, cause
the Package to be a Modified Version. In addition, such works are not
considered parts of the Package itself, and are not subject to the
terms of this license.
General Provisions
(10) Any use, modification, and distribution of the Standard or
Modified Versions is governed by this Artistic License. By using,
modifying or distributing the Package, you accept this license. Do not
use, modify, or distribute the Package, if you do not accept this
license.
(11) If your Modified Version has been derived from a Modified
Version made by someone other than you, you are nevertheless required
to ensure that your Modified Version complies with the requirements of
this license.
(12) This license does not grant you the right to use any trademark,
service mark, tradename, or logo of the Copyright Holder.
(13) This license includes the non-exclusive, worldwide,
free-of-charge patent license to make, have made, use, offer to sell,
sell, import and otherwise transfer the Package with respect to any
patent claims licensable by the Copyright Holder that are necessarily
infringed by the Package. If you institute patent litigation
(including a cross-claim or counterclaim) against any party alleging
that the Package constitutes direct or contributory patent
infringement, then this Artistic License to you shall terminate on the
date that such litigation is filed.
(14) Disclaimer of Warranty:
THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

295
dev/yap-6.3/BEAM/eam.h Normal file
View File

@ -0,0 +1,295 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: eam compiler data structures and routines *
*************************************************************************/
#define Print_Code 0
/* To help on compiler debuging
1 -> show predicates info
2 -> show YAP abstract machine code (YAAM)
4 -> show YAAM after transformation
8 -> show indexing code
16 -> show EAM intermediate code
32 -> show EAM intermediate code with direct_calls
128 -> show EAM abstrac machine code
*/
#define Variavel 1
#define Lista 2
#define Estrutura 4
#define Constante 8
typedef unsigned long Cell;
typedef struct PCODE{
struct PCODE *nextInst;
int op, new1;
unsigned long new4;
} CInstr;
struct Clauses {
unsigned int idx; /* info for indexing on first arg */
Cell val; /* atom or functor in first arg */
unsigned int nr_vars; /* nr of local vars */
struct Predicates *predi; /* predicate struct */
int side_effects; /* clause has side effects */
Cell *code;
struct Clauses *next; /* next clause within the same predicate */
};
struct HASH_TABLE {
Cell value;
Cell *code;
struct HASH_TABLE *next;
};
struct Predicates { /* To register information about predicates */
unsigned long id;
unsigned char *name;
unsigned int arity;
unsigned int nr_alt; /* nr of alternativas */
unsigned int calls; /* nr of existent calls to this predicate */
struct Clauses *first;
struct Clauses *last;
int idx; /* is code indexed ? 0= needs compilation -1= no indexing possible 1= indexed */
unsigned int idx_var; /* nr clauses with 1st argument var */
unsigned int idx_list; /* nr clauses with 1st argument list */
unsigned int idx_atom; /* nr clauses with 1st argument atom */
unsigned int idx_functor; /* nr clauses with 1st argument functor */
short int eager_split; /* allow eager splitting */
Cell *code; /* try, retry and trust code or Indexing code */
struct HASH_TABLE **atom;
struct HASH_TABLE **functor;
Cell *list;
Cell *vars;
struct Predicates *next;
};
/**************************** EAM TRUE STUFF *************/
struct SUSPENSIONS {
struct AND_BOX *and_box; /* And_box where the variable has suspended */
short int reason; /* suspended before executing call number nr_call */
struct SUSPENSIONS *next; /* Pointer to the next suspention */
struct SUSPENSIONS *prev;
};
struct SUSPENSIONS_VAR {
struct AND_BOX *and_box; /* And_box where the variable has suspended */
struct SUSPENSIONS_VAR *next; /* Pointer to the next suspention */
};
struct PERM_VAR {
Cell value; /* value assigned to the variable */
struct AND_BOX *home; /* pointer to the goal_box structure of the variable */
Cell *yapvar;
struct SUSPENSIONS_VAR *suspensions; /* Pointer to a Suspension List */
struct PERM_VAR *next;
};
struct EXTERNAL_VAR { /* to be used as some kind of trail */
Cell value; /* value assign to the variable */
struct PERM_VAR *var; /* pointer to the local_var struct */
struct EXTERNAL_VAR *next;
};
struct status_and {
struct OR_BOX *call; /* POINTER TO A OR_BOX */
Cell *locals; /* temporary vars vector */
Cell *code; /* Pointer to the start code */
int state; /* State of the OR_BOX */
struct status_and *previous;
struct status_and *next;
};
struct status_or {
struct AND_BOX *alternative; /* POINTER TO A AND_BOX */
Cell *args; /* Saved Arguments */
Cell *code; /* Pointer to Start Code */
int state; /* State of the AND_BOX */
struct status_or *previous;
struct status_or *next;
};
struct OR_BOX {
struct AND_BOX *parent;
struct status_and *nr_call; /* order of this box */
short int nr_all_alternatives; /* number of existing alternatives */
struct status_or *alternatives; /* alternatives of the or_box */
short int eager_split;
};
struct AND_BOX {
struct OR_BOX *parent; /* pointer to the parent or-box */
struct status_or *nr_alternative; /* This box is alternative id */
short int nr_all_calls; /* numger of all goals */
struct PERM_VAR *perms;
struct status_and *calls;
short int level; /* indicates the level in the tree */
struct EXTERNAL_VAR *externals; /* pointer to a list of external_vars */
struct SUSPENSIONS *suspended; /* pointer to a list of suspended boxes */
short int side_effects; /* to mark if are calls to builtins with side_efects (like write) */
};
/* TYPE OF STATES */
#define ZERO 0 /* No State yet */
#define SUCCESS 1
#define FAILS 2
#define READY 4 /* Is ready to start execution */
#define RUNNING 8 /* Is running */
#define RUNAGAIN 16 /* Is running again */
#define SUSPEND 32 /* Has suspended */
#define WAKE 64 /* Was Suspended, but now is Ready again */
#define CHANGED 128 /* Has received some change on it's external variables, needs to re-run */
#define END 256 /* Has suspended on end, on wake up can pass to a success state */
#define WAITING 512 /* The clause is waiting for the previous predicates to leave the Suspended state */
#define FAILED 1024 /* has failed */
#define CUT_RIGHT 2048
#define SKIP_VAR 4096
#define LEFTMOST_PARENT 8192
#define FIRST 16384
#define LEFTMOST 32768
#define WAITING_TO_BE_FIRST (WAITING + FIRST)
#define WAITING_TO_BE_LEFTMOST (WAITING + LEFTMOST)
#define WAITING_TO_BE_LEFTMOST_PARENT (WAITING + LEFTMOST_PARENT)
#define WAITING_TO_CUT (WAITING + CUT_RIGHT)
#define WAITING_SKIP_VAR (WAITING + SKIP_VAR)
#define SUSPEND_END (SUSPEND+END)
#define WAKE_END (WAKE+END)
#define NORMAL_SUSPENSION 0
#define LEFTMOST_SUSPENSION 1
#define WAIT_SUSPENSION 2
#define CUT_SUSPENSION 3
#define WRITE_SUSPENSION 4
#define VAR_SUSPENSION 5
#define YAP_VAR_SUSPENSION 6
/* TYPE OF SIDE_EFFECTS */
#define WRITE 1
#define COMMIT 2
#define VAR 4
#define SEQUENCIAL 8
#define CUT 32 /* Greater than 32 always cut */
/**********************************************************************************/
struct EAM_TEMP {
struct EAM_TEMP *previous;
struct EAM_TEMP *next;
};
struct EAM_Global {
Cell *pc;
Cell *_H;
Cell *_S;
short _Mode; /* read or write mode */
short ES; /* goal shoud do Eager Split yes or no ? */
short MemGoing; /* Direction the that stacks use to grow */
Cell *varlocals; /* local vars to the working AND-BOX */
struct AND_BOX *ABX; /* working AND-BOX */
struct OR_BOX *OBX; /* working OR-BOX */
struct SUSPENSIONS *su; /* list with suspended work */
struct AND_BOX *top;
struct status_and *USE_SAME_ANDBOX; /* when only 1 alternative */
struct status_or *nr_alternative; /* working alternative */
struct status_and *nr_call; /* working goal */
Cell *VAR_TRAIL;
int VAR_TRAIL_NR;
int Mem_FULL; /* if mem_full, then perform GC */
int nr_call_forking; /* number of splits already performed */
unsigned long START_ADDR_HEAP, START_ADDR_BOXES, END_BOX, END_H;
unsigned int nr_gc_heap;
unsigned int nr_gc_boxed;
Cell **IndexFree;
Cell *NextFree;
Cell *sp;
struct PERM_VAR *NextVar;
#if Memory_Stat
unsigned long TOTAL_MEM, MEM_REUSED, TOTAL_TEMPS,TEMPS_REUSED, TOTAL_PERMS, PERMS_REUSED;
unsigned long Memory_STAT[5000][5];
#endif
};
#define beam_X XREGS /* use the same X-Regs as YAP */
#define beam_pc (eamGlobal->pc)
#define beam_H (eamGlobal->_H)
#define beam_S (eamGlobal->_S)
#define beam_Mode (eamGlobal->_Mode)
#define beam_ES (eamGlobal->ES)
#define beam_MemGoing (eamGlobal->MemGoing)
#define beam_varlocals (eamGlobal->varlocals)
#define beam_ABX (eamGlobal->ABX)
#define beam_OBX (eamGlobal->OBX)
#define beam_su (eamGlobal->su)
#define beam_top (eamGlobal->top)
#define beam_USE_SAME_ANDBOX (eamGlobal->USE_SAME_ANDBOX)
#define beam_nr_alternative (eamGlobal->nr_alternative)
#define beam_nr_call (eamGlobal->nr_call)
#define beam_VAR_TRAIL (eamGlobal->VAR_TRAIL)
#define beam_VAR_TRAIL_NR (eamGlobal->VAR_TRAIL_NR)
#define beam_Mem_FULL (eamGlobal->Mem_FULL)
#define beam_nr_call_forking (eamGlobal->nr_call_forking)
#define beam_START_ADDR_HEAP (eamGlobal->START_ADDR_HEAP)
#define beam_START_ADDR_BOXES (eamGlobal->START_ADDR_BOXES)
#define beam_END_BOX (eamGlobal->END_BOX)
#define beam_END_H (eamGlobal->END_H)
#define beam_nr_gc_heap (eamGlobal->nr_gc_heap)
#define beam_nr_gc_boxed (eamGlobal->nr_gc_boxed)
#define beam_IndexFree (eamGlobal->IndexFree)
#define beam_NextFree (eamGlobal->NextFree)
#define beam_sp (eamGlobal->sp)
#define beam_NextVar (eamGlobal->NextVar)
#if Memory_Stat
#define beam_TOTAL_MEM (eamGlobal->TOTAL_MEM)
#define beam_MEM_REUSED (eamGlobal->MEM_REUSED)
#define beam_TOTAL_TEMPS (eamGlobal->TOTAL_TEMPS)
#define beam_TEMPS_REUSED (eamGlobal->TEMPS_REUSED)
#define beam_TOTAL_PERMS (eamGlobal->TOTAL_PERMS)
#define beam_PERMS_REUSED (eamGlobal->PERMS_REUSED)
#define beam_Memory_STAT (eamGlobal->Memory_STAT)
#endif
#define arg1 *(beam_pc+1)
#define arg2 *(beam_pc+2)
#define arg3 *(beam_pc+3)
#define arg4 *(beam_pc+4)
#define CELL_SIZE (sizeof(Cell))
#define POINTER_SIZE (sizeof(Cell *))
#define ANDBOX_SIZE (sizeof(struct AND_BOX))
#define ORBOX_SIZE (sizeof(struct OR_BOX))
#define PERM_VAR_SIZE (sizeof(struct PERM_VAR))
#define EXTERNAL_VAR_SIZE (sizeof(struct EXTERNAL_VAR))
#define SUSPENSIONS_SIZE (sizeof(struct SUSPENSIONS))
#define SUSPENSIONS_VAR_SIZE (sizeof(struct SUSPENSIONS_VAR))
#define STATUS_AND_SIZE (sizeof(struct status_and))
#define STATUS_OR_SIZE (sizeof(struct status_or))

3773
dev/yap-6.3/BEAM/eam_am.c Normal file
View File

File diff suppressed because it is too large Load Diff

498
dev/yap-6.3/BEAM/eam_gc.c Normal file
View File

@ -0,0 +1,498 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: garbage collector routines *
*************************************************************************/
void garbage_collector(void);
struct OR_BOX *move_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call);
struct AND_BOX *move_andbox(struct AND_BOX *a,struct OR_BOX *parent,struct status_or *alt);
Cell refresh_structures(Cell c);
Cell move_structures(Cell c);
void refresh_andbox(struct AND_BOX *a);
void refresh_orbox(struct OR_BOX *o);
Cell refresh_structures(Cell c)
{
Cell *C, OldC;
OldC=deref((Cell) c);
if (isvar(OldC)) {
return(OldC);
}
if (isatom(OldC)) {
return(OldC);
}
if (isappl(OldC)) {
int i,arity;
C=(Cell *) repappl(OldC);
arity = ((int) ArityOfFunctor((Functor) *C));
for(i=0;i<arity ;i++) {
C++;
*C=refresh_structures((Cell) C);
}
return(OldC);
}
/* else if (ispair(c)) { */
C=(Cell *) reppair(OldC);
*C=refresh_structures((Cell) C);
C++;
*C=refresh_structures((Cell) C);
return(OldC);
}
Cell move_structures(Cell c)
{
Cell *NewC, *NewH;
Cell OldC,LOCAL_OldH;
OldC=deref((Cell) c);
/*
if (beam_MemGoing==1 && ((unsigned long) OldC) <beam_START_ADDR_HEAP+beam_MEM_H/2) return(OldC);
if (beam_MemGoing==-1 && ((unsigned long) OldC)>=beam_START_ADDR_HEAP+beam_MEM_H/2 && ((unsigned long) OldC) <beam_START_ADDR_BOXES) return(OldC);
*/
if (isvar(OldC)) {
return(OldC);
}
if (isatom(OldC)) {
return(OldC);
}
LOCAL_OldH=(Cell) beam_H;
NewH=beam_H;
if (isappl(OldC)) {
int i,arity;
NewC=(Cell *) repappl(OldC);
arity = ((int) ArityOfFunctor((Functor) *NewC));
*NewH++=*NewC++;
beam_H+=arity+1;
for(i=0;i<arity ;i++) {
*NewH=move_structures((Cell) NewC);
NewH++;
NewC++;
}
return(absappl(LOCAL_OldH));
}
/* else if (ispair(c)) { */
NewC=(Cell *) reppair(OldC);
beam_H+=2;
*NewH=move_structures((Cell) NewC);
NewC++;
NewH++;
*NewH=move_structures((Cell) NewC);
return(abspair(LOCAL_OldH));
}
void garbage_collector()
{
#if GARBAGE_COLLECTOR==2
struct AND_BOX *new_top;
#endif
if (beam_Mem_FULL & 2) beam_nr_gc_heap++; else beam_nr_gc_boxed++;
#if Debug || Debug_GC
printf("Entering Garbage Collector for the %dth time (Reason=%d)\n",beam_nr_gc_heap+beam_nr_gc_boxed,beam_Mem_FULL);
#endif
#if Debug_Dump_State & 2
dump_eam_state();
printf("--------------------------------------------------------------------\n");
#endif
beam_Mem_FULL=0;
#if Memory_Stat
if (beam_MemGoing==1) {
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][1]=(unsigned long) beam_H-beam_START_ADDR_HEAP;
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][2]=(unsigned long) beam_NextFree-beam_START_ADDR_BOXES;
} else {
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][1]=(unsigned long) beam_H-beam_START_ADDR_HEAP-MEM_H/2;
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][2]=beam_END_BOX- ((unsigned long) beam_NextFree);
}
if (GARBAGE_COLLECTOR==1)
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][2]=beam_END_BOX- ((unsigned long) beam_NextFree);
#endif
#if GARBAGE_COLLECTOR==1
if (beam_MemGoing==1) {
if (beam_H < (Cell *) (beam_START_ADDR_HEAP+MEM_H/2)) beam_H=(Cell *) (beam_START_ADDR_HEAP+MEM_H/2); else beam_H++;
beam_MemGoing=-1;
beam_sp=(Cell *) beam_START_ADDR_HEAP+MEM_H/2;
beam_sp--;
} else {
beam_H=(Cell *) beam_START_ADDR_HEAP;
beam_MemGoing=1;
beam_sp=(Cell *) beam_END_H;
beam_sp--;
}
refresh_andbox(beam_top);
#if Clear_MEMORY
if (beam_MemGoing==-1) {
memset(beam_START_ADDR_HEAP,0,MEM_H/2);
} else {
memset(beam_START_ADDR_HEAP+MEM_H/2,0,MEM_H/2);
}
#endif
#else
memset(beam_IndexFree,0,INDEX_SIZE*POINTER_SIZE);
if (beam_MemGoing==1) {
if (beam_H < (Cell *) (beam_START_ADDR_HEAP+MEM_H/2)) beam_H=(Cell *) (beam_START_ADDR_HEAP+MEM_H/2); else beam_H++;
beam_NextFree=(Cell *) beam_END_BOX;
beam_MemGoing=-1;
beam_sp=(Cell *) beam_START_ADDR_HEAP+MEM_H/2; beam_sp-=2;
} else {
if (beam_H>=(Cell *) beam_START_ADDR_BOXES) beam_NextFree=beam_H+1; else beam_NextFree=(Cell *) beam_START_ADDR_BOXES;
beam_H=(Cell *) beam_START_ADDR_HEAP;
beam_MemGoing=1;
beam_sp=(Cell *) beam_END_H; beam_sp-=2;
}
beam_Mem_FULL=0;
beam_su=NULL;
new_top=move_andbox(beam_top,NULL,NULL);
beam_top=new_top;
#if Clear_MEMORY
if (beam_MemGoing==-1) {
memset((void *) beam_START_ADDR_HEAP,0,MEM_H/2);
memset((void *) beam_START_ADDR_BOXES,0,MEM_BOXES/2);
} else {
memset((void *) beam_START_ADDR_HEAP+MEM_H/2,0,MEM_H/2);
memset((void *) beam_START_ADDR_BOXES+MEM_BOXES/2,0,MEM_BOXES/2);
}
#endif
#endif
#if Memory_Stat
if (beam_MemGoing==1) {
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][3]=(unsigned long) beam_H- beam_START_ADDR_HEAP;
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][4]=(unsigned long) beam_NextFree- beam_START_ADDR_BOXES;
} else {
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][3]=(unsigned long) beam_H- beam_START_ADDR_HEAP-MEM_H/2;
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][4]= beam_END_BOX- ((unsigned long) beam_NextFree);
}
if (GARBAGE_COLLECTOR==1)
beam_Memory_STAT[beam_nr_gc_heap+beam_nr_gc_boxed][4]= beam_END_BOX- ((unsigned long) beam_NextFree);
#endif
#if Debug_Dump_State & 2
dump_eam_state();
#endif
#if Debug
printf("End of Garbage Collector\n");
#endif
}
#if GARBAGE_COLLECTOR!=1
struct OR_BOX *move_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call)
{
struct OR_BOX *new_orbox;
struct status_or *old, *new, *first=NULL, *last=NULL;
Cell *args,*newargs;
if (o==NULL) return(NULL);
#if !Fast_go
if ((Cell *) o<(Cell *) beam_START_ADDR_BOXES || (Cell *) o>(Cell *) beam_END_BOX) return (NULL);
#endif
new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
if (beam_Mem_FULL) abort_eam("Sem Memoria para GC\n");
if (beam_OBX==o) beam_OBX=new_orbox;
new_orbox->parent=parent;
new_orbox->nr_call=nr_call;
new_orbox->nr_all_alternatives=o->nr_all_alternatives;
old=o->alternatives;
while(old!=NULL) {
new=(struct status_or *) request_memory(STATUS_OR_SIZE);
if (beam_Mem_FULL) abort_eam("Sem Memoria para GC\n");
if (beam_nr_alternative==old) beam_nr_alternative=new;
new->args=old->args;
new->code=old->code;
new->state=old->state;
new->alternative=move_andbox(old->alternative,new_orbox,new);
if (first==NULL) first=new;
else last->next=new;
new->previous=last;
new->next=NULL;
last=new;
old=old->next;
}
new_orbox->alternatives=first;
args=NULL;
newargs=NULL;
while(last!=NULL) {
if (last->args==NULL) {
args=NULL;
newargs=NULL;
} else if (args!=last->args) {
int y;
args=last->args;
#if Debug
printf("Request args=%d \n",(int) args[0]);
#endif
newargs=(Cell *)request_memory((args[0])*sizeof(Cell));
if (beam_Mem_FULL) abort_eam("Sem Memoria para GC\n");
newargs[0]=args[0];
for(y=1;y<args[0];y++) newargs[y]=move_structures(args[y]);
}
last->args=newargs;
last=last->previous;
}
return(new_orbox);
}
struct AND_BOX *move_andbox(struct AND_BOX *a,struct OR_BOX *parent, struct status_or *alt )
{
int OLD_VAR_TRAIL_NR;
struct AND_BOX *new_andbox;
struct PERM_VAR *l;
struct EXTERNAL_VAR *old_externals,*externals;
if (a==NULL) return(NULL);
OLD_VAR_TRAIL_NR=beam_VAR_TRAIL_NR;
new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
if (beam_Mem_FULL) abort_eam("Sem Memoria para GC\n");
if (beam_ABX==a) beam_ABX=new_andbox;
new_andbox->parent=parent;
new_andbox->nr_alternative=alt;
new_andbox->level=a->level;
new_andbox->side_effects=a->side_effects;
new_andbox->suspended=NULL;
if (a->suspended) {
new_andbox->suspended=addto_suspensions_list(new_andbox,a->suspended->reason);
}
new_andbox->perms=a->perms;
l=a->perms;
while(l!=NULL) { /* ainda nao estou a fazer GC nas Var Perm */
l->value=move_structures(l->value);
l->home=new_andbox;
l->suspensions=NULL;
l=l->next;
}
old_externals=a->externals;
externals=NULL;
while(old_externals) {
struct EXTERNAL_VAR *e;
struct SUSPENSIONS_VAR *s;
e=(struct EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
e->next=externals;
externals=e;
e->value=move_structures(old_externals->value);
e->var=(struct PERM_VAR *) old_externals->var;
//e->var=(struct PERM_VAR *) old_externals->var; CUIDADO QUANDO FIZER GC PERM_VARS
if (isvar(e->var)) {
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE);
s->and_box=new_andbox;
s->next=e->var->suspensions;
e->var->suspensions=s;
}
old_externals=old_externals->next;
}
new_andbox->externals=externals;
if (beam_Mem_FULL) abort_eam("Sem Memoria para GC\n");
/* CUIDADO: Preciso agora de duplicar os vectores das variaveis locais */
{ struct status_and *calls;
#if !Fast_go
Cell **backup=NULL; int i, counted=0,max=1000;
backup=(Cell **) malloc(max);
#else
Cell *backup[1000]; int i, counted=0;
#endif
calls=a->calls;
while(calls!=NULL) {
if (calls->locals!=NULL) {
/* primeiro vou ver se já foi copiado */
for(i=0;i<counted;i+=2) {
if (backup[i]==calls->locals) {
calls->locals=backup[i+1];
break;
}
}
if (i==counted) { /* afinal ainda nao foi copiado: fazer copia em duas fases*/
Cell *c, *newvars, *oldvars; int nr;
oldvars=calls->locals;
nr=oldvars[-1];
newvars=request_memory_locals(nr);
if (beam_varlocals==oldvars) beam_varlocals=newvars;
calls->locals=newvars;
/* primeiro actualizo as variaveis */
for(i=0;i<nr;i++) {
c=&oldvars[i];
if ((Cell *)*c==c) {
newvars[i]=(Cell) &newvars[i];
*c=newvars[i];
} else {
newvars[i]= (Cell) *c;
*c=(Cell) &newvars[i];
}
}
/* depois copio as estruturas */
for(i=0;i<nr;i++) {
newvars[i]=move_structures(oldvars[i]);
}
#if !Fast_go
if (max<counted+2) {
max+=200;
backup=realloc(backup,max);
if (backup==NULL) abort_eam("No more memory... realloc in gc \n");
}
#else
if (counted>=998) abort_eam("No more memory... realloc in gc \n");
#endif
backup[counted]=oldvars;
backup[counted+1]=newvars;
counted+=2;
}
}
calls=calls->next;
}
#if !Fast_go
free(backup);
#endif
}
new_andbox->nr_all_calls=a->nr_all_calls;
{ struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
calls=a->calls;
while(calls!=NULL){
calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
if (beam_Mem_FULL) abort_eam("Sem Memoria para GC\n");
calls_new->code=calls->code;
calls_new->state=calls->state;
calls_new->locals=calls->locals;
if (beam_nr_call==calls) beam_nr_call=calls_new;
calls_new->call=move_orbox(calls->call,new_andbox,calls_new);
if (first==NULL) first=calls_new;
else last->next=calls_new;
calls_new->previous=last;
calls_new->next=NULL;
last=calls_new;
calls=calls->next;
}
new_andbox->calls=first;
}
return(new_andbox);
}
#else /* used by GC Only on Heap || Keep boxes on same memory */
void refresh_orbox(struct OR_BOX *o)
{
struct status_or *old, *last=NULL;
Cell *args;
if (o==NULL) return;
old=o->alternatives;
while(old!=NULL) {
refresh_andbox(old->alternative);
last=old;
old=old->next;
}
args=NULL;
while(last!=NULL) {
if (last->args==NULL) {
args=NULL;
}else if (args!=last->args) {
int y;
args=last->args;
for(y=1;y<args[0];y++) {
args[y]=move_structures(args[y]);
}
}
last=last->previous;
}
return;
}
void refresh_andbox(struct AND_BOX *a)
{
struct PERM_VAR *l;
struct EXTERNAL_VAR *externals;
struct status_and *calls;
if (a==NULL) return;
l=a->perms;
while(l!=NULL) {
l->value=move_structures(l->value);
l=l->next;
}
externals=a->externals;
while(externals) {
externals->value=move_structures(externals->value);
externals=externals->next;
}
calls=a->calls;
while(calls!=NULL) {
// if (calls->calls!=NULL) {
if (calls->locals!=NULL && ((int) calls->locals[-1]>0) {
int nr,i;
nr=calls->locals[-1];
calls->locals[-1]=-nr;
for(i=0;i<nr;i++) {
calls->locals[i]=move_structures(calls->locals[i]);
}
}
refresh_orbox(calls->call);
// }
calls=calls->next;
}
calls=a->calls;
while(calls!=NULL) {
if (calls->locals!=NULL && ((int) calls->locals[-1])<0) {
int nr;
nr=calls->locals[-1];
calls->locals[-1]=-nr;
}
calls=calls->next;
}
return;
}
#endif

374
dev/yap-6.3/BEAM/eam_showcode.c Normal file
View File

@ -0,0 +1,374 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: eam show abstract machine assembler *
*************************************************************************/
#ifdef BEAM
#include<stdio.h>
#include "Yap.h"
#include "Yatom.h"
#include "eam.h"
#include "eamamasm.h"
void eam_showcode(Cell *code);
extern int am_to_inst(Cell inst);
void eam_showcode(Cell *code)
{
int n;
#define carg1 *(code+1)
#define carg2 *(code+2)
#define carg3 *(code+3)
#define carg4 *(code+4)
printf("--------------------------------------------------\n");
while (1) {
n=am_to_inst(*code);
printf("%ld->",(long) code);
switch(n) {
case(_exit_eam):
printf("_exit\n");
code++;
if (*(code)==-1) return;
break;
case(_top_tree):
printf("_top_tree \n");
code++;
break;
case(_scheduler):
printf("_scheduler \n");
code++;
break;
case(_prepare_tries):
printf("_prepare_tries for %d clauses with arity=%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_prepare_calls ):
printf("_prepare_calls %d \n",(int) carg1);
code+=2;
break;
case(_get_var_X_op ):
printf("_get_var_X_op X%d, X%d\n",(int) carg1,(int) carg2);
code+=3;
break;
case(_get_var_Y_op ):
printf("_get_var_Y_op X%d, Y%d\n",(int) carg1,(int) carg2);
code+=3;
break;
case(_get_val_X_op ):
printf("_get_val_X_op X%d, X%d\n",(int) carg1,(int) carg2);
code+=3;
break;
case(_get_val_Y_op ):
printf("_get_val_Y_op X%d, Y%d\n",(int) carg1,(int) carg2);
code+=3;
break;
case(_get_atom_op ):
printf("_get_atom_op X%d, %d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_get_list_op ):
printf("_get_list_op X%d\n",(int) carg1);
code+=2;
break;
case(_get_struct_op ):
printf("_get_struct_op X%d, %lX/%d\n",(int) carg1,(unsigned long) carg2,(int) carg3);
code+=4;
break;
case(_unify_void_op ):
printf("_unify_void_op\n");
code++;
break;
case(_unify_val_X_op ):
printf("_unify_val_X_op X%d\n",(int) carg1);
code+=2;
break;
case(_unify_val_Y_op ):
printf("_unify_val_Y_op Y%d\n",(int) carg1);
code+=2;
break;
case(_unify_var_X_op ):
printf("_unify_var_X_op X%d\n",(int) carg1);
code+=2;
break;
case(_unify_var_Y_op ):
printf("_unify_var_Y_op Y%d\n",(int) carg1);
code+=2;
break;
case(_unify_atom_op ):
printf("_unify_atom_op 0x%lX\n",(unsigned long) carg1);
code+=2;
break;
case(_unify_list_op ):
printf("_unify_list_op \n");
code++;
break;
case(_unify_last_list_op ):
printf("_unify_last_list_op \n");
code++;
break;
case(_unify_struct_op ):
printf("_unify_struct_op 0x%lX,%d\n",(unsigned long) carg1,(int) carg2);
code+=3;
break;
case(_unify_last_struct_op ):
printf("_unify_last_struct_op 0x%lX,%d\n",(unsigned long) carg1,(int) carg2);
code+=3;
break;
case(_unify_last_atom_op ):
printf("_unify_last_atom_op 0x%lX\n",(unsigned long) carg1);
code+=2;
break;
case(_unify_local_X_op ):
printf("_unify_local_X_op X%d\n",(int) carg1);
code+=2;
break;
case(_unify_local_Y_op ):
printf("_unify_local_Y_op X%d\n",(int) carg1);
code+=2;
break;
case(_put_var_X_op ):
printf("_put_var_X_op X%d,X%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_put_var_Y_op ):
printf("_put_var_Y_op X%d,Y%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_put_var_P_op ):
printf("_put_var_P_op X%d,Y%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_put_val_X_op ):
printf("_put_val_X_op X%d,X%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_put_val_Y_op ):
printf("_put_val_Y_op X%d,Y%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_put_atom_op ):
printf("_put_atom_op X%d, %d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_put_list_op ):
printf("_put_list_op X%d \n",(int) carg1);
code+=2;
break;
case(_put_struct_op ):
printf("_put_struct_op X%d,%d,%d \n",(int) carg1,(int) carg2,(int) carg3);
code+=4;
break;
case(_put_unsafe_op ):
printf("_put_unsafe_op X%d, Y%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_write_void ):
printf("_write_void \n");
code++;
break;
case(_write_var_X_op ):
printf("_write_var_X_op X%d \n",(int) carg1);
code+=2;
break;
case(_write_var_Y_op ):
printf("_write_var_Y_op Y%d \n",(int) carg1);
code+=2;
break;
case(_write_var_P_op ):
printf("_write_var_P_op Y%d \n",(int) carg1);
code+=2;
break;
case(_write_val_X_op ):
printf("_write_val_X_op X%d \n",(int) carg1);
code+=2;
break;
case(_write_val_Y_op ):
printf("_write_val_Y_op Y%d \n",(int) carg1);
code+=2;
break;
case(_write_atom_op ):
printf("_write_atom_op %d \n",(int) carg1);
code+=2;
break;
case(_write_list_op ):
printf("_write_list_op \n");
code++;
break;
case(_write_struct_op ):
printf("_write_struct_op %d,%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_write_last_list_op ):
printf("_write_last_list_op \n");
code++;
break;
case(_write_last_struct_op ):
printf("_write_last_struct_op %d,%d \n",(int) carg1,(int) carg2);
code+=3;
break;
case(_write_local_X_op ):
printf("_write_local_X_op X%d \n",(int) carg1);
code+=2;
break;
case(_write_local_Y_op ):
printf("_write_local_Y_op Y%d \n",(int) carg1);
code+=2;
break;
case(_pop_op ):
printf("_pop_read_op \n");
code++;
break;
case(_jump_op ):
printf("_jump_op %ld\n",(long int) carg1);
code+=4;
break;
case(_proceed_op ):
printf("_proceed_op \n");
code++;
break;
case(_call_op ):
printf("_call_op %s/%d \n", ((PredEntry *) carg1)->beamTable->name,((PredEntry *) carg1)->beamTable->arity);
code+=2;
break;
case(_safe_call_op ):
printf("_safe_call_op %ld \n",(long) carg1);
code+=2;
break;
case(_safe_call_unary_op ):
printf("_safe_call_unary_op %ld \n",(long) carg1);
code+=2;
break;
case(_safe_call_binary_op ):
printf("_safe_call_binary_op %ld \n",(long) carg1);
code+=2;
break;
case(_only_1_clause_op ):
printf("_only_1_clause_op -> Use the same AND_BOX for the %dth clause of predicate %s/%d (Yvars=%d) \n",(int) carg4,((struct Clauses *)carg1)->predi->name,(int) carg2,(int) carg3);
code+=4;
break;
case(_try_me_op ):
printf("_try_me_op (not final)\n");
code+=5;
break;
case(_retry_me_op ):
printf("_retry_me_op (not final)\n");
code+=5;
break;
case(_trust_me_op ):
printf("_trust_me_op (not final)\n");
code+=5;
break;
case(_do_nothing_op ):
printf("do_nothing_op \n");
code++;
break;
case(_direct_safe_call_op ):
printf("_direct_safe_call_op %ld \n",(long) carg1);
code+=2;
break;
case(_direct_safe_call_unary_op ):
printf("_direct_safe_call_unary_op %ld \n",(long) carg1);
code+=2;
break;
case(_direct_safe_call_binary_op ):
printf("_direct_safe_call_binary_op %ld \n",(long) carg1);
code+=2;
break;
case(_skip_while_var ):
printf("_skip_while_var \n");
code++;
break;
case(_wait_while_var ):
printf("_wait_while_var \n");
code++;
break;
case(_force_wait ):
printf("_force_wait \n");
code++;
break;
case(_write_call ):
printf("_write_call \n");
code++;
break;
case(_is_call ):
printf("_is_call \n");
code++;
break;
case(_equal_call ):
printf("_equal_call \n");
code++;
break;
case(_cut_op ):
printf("_cut_op \n");
code++;
break;
case(_commit_op ):
printf("_commit_op \n");
code++;
break;
case(_fail_op ):
printf("_fail_op \n");
code++;
break;
case(_save_b_X_op ):
printf("_save_b_X_op \n");
code++;
break;
case(_save_b_Y_op ):
printf("_save_b_Y_op \n");
code++;
break;
case(_save_appl_X_op ):
printf("_save_appl_X_op \n");
code++;
break;
case(_save_appl_Y_op ):
printf("_save_appl_Y_op \n");
code++;
break;
case(_save_pair_X_op ):
printf("_save_pair_X_op \n");
code++;
break;
case(_save_pair_Y_op ):
printf("_save_pair_Y_op \n");
code++;
break;
case(_either_op ):
printf("_either_op \n");
code++;
break;
case(_orelse_op ):
printf("_orelse_op \n");
code++;
break;
case(_orlast_op ):
printf("_orlast_op \n");
code++;
break;
default:
if (n!=*code) printf("inst(%d)\n",n);
else printf("Label Next Call %d\n",n);
code++;
}
}
}
#endif /* BEAM */

478
dev/yap-6.3/BEAM/eam_split.c Normal file
View File

@ -0,0 +1,478 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: split related functions *
*************************************************************************/
void do_forking_andbox(struct AND_BOX *a);
Cell copy_structures(Cell c);
void replicate_local_variables(struct AND_BOX *a);
struct OR_BOX *copy_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call);
struct AND_BOX *copy_andbox(struct AND_BOX *a,struct OR_BOX *parent);
void do_forking_andbox(struct AND_BOX *a)
{
struct OR_BOX *op,*opp, *new_orbox;
struct AND_BOX *ap, *new_andbox;
int nr_all_alternatives, nr_all_calls;
struct status_and *nr_call,*new_call;
struct status_or *nr_alternative, *alternatives, *new_alternatives;
beam_nr_call_forking++;
op=a->parent; /* or box parent */
ap=op->parent; /* and box parent */
opp=ap->parent; /* or box parent parent */
if (opp==NULL) {
abort_eam("Forking with orbox parent parent NULL, maybe I'm on top ?????");
}
alternatives=opp->alternatives;
nr_all_alternatives=opp->nr_all_alternatives;
nr_alternative=ap->nr_alternative;
nr_all_calls=ap->nr_all_calls;
nr_call=op->nr_call;
new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
new_andbox->parent=opp;
// new_andbox->nr_alternative=nr_alternative; /* seted after creating a new status_or */
new_andbox->nr_all_calls=nr_all_calls;
new_andbox->level=ap->level;
new_andbox->perms=ap->perms;
new_andbox->suspended=NULL;
if (ap->suspended) new_andbox->suspended=addto_suspensions_list(new_andbox,ap->suspended->reason);
new_andbox->side_effects=ap->side_effects;
if (ap->externals) {
struct EXTERNAL_VAR *old_externals, *list=NULL;
old_externals=ap->externals;
while (old_externals) {
struct EXTERNAL_VAR *e;
struct SUSPENSIONS_VAR *s;
e=(struct EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
e->value=old_externals->value;
e->var=(struct PERM_VAR *) old_externals->var;
e->next=list;
list=e;
if (isvar(e->var)) {
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
s->and_box=new_andbox;
s->next=e->var->suspensions;
e->var->suspensions=s;
}
old_externals=old_externals->next;
}
new_andbox->externals=list;
} else new_andbox->externals=NULL;
new_call=(struct status_and *) request_memory(STATUS_AND_SIZE);
new_call->call=new_orbox;
new_call->locals=nr_call->locals;
new_call->code=nr_call->code;
new_call->state=WAKE;
nr_call->state=WAKE; /* NEW PARA TORNAR A CALL NUM WAKE STATE */
new_orbox->parent=new_andbox;
new_orbox->nr_call=new_call;
new_orbox->nr_all_alternatives=1;
new_alternatives=a->nr_alternative;
new_orbox->alternatives=new_alternatives;
/* remove andbox from op */
op->nr_all_alternatives-=1;
if (new_alternatives->previous==NULL) op->alternatives=new_alternatives->next;
else new_alternatives->previous->next=new_alternatives->next;
if (new_alternatives->next!=NULL) new_alternatives->next->previous=new_alternatives->previous;
new_alternatives->next=NULL;
new_alternatives->previous=NULL;
a->parent=new_orbox;
/* increase the nr_alternatives by 1 in opp or_box parent parent and conect new_andbox*/
new_alternatives=(struct status_or *) request_memory(STATUS_OR_SIZE);
new_andbox->nr_alternative=new_alternatives;
new_alternatives->next=nr_alternative;
new_alternatives->previous=nr_alternative->previous;
if (nr_alternative->previous==NULL) opp->alternatives=new_alternatives;
else nr_alternative->previous->next=new_alternatives;
nr_alternative->previous=new_alternatives;
new_alternatives->args=nr_alternative->args;
new_alternatives->code=nr_alternative->code;
new_alternatives->state=nr_alternative->state;
new_alternatives->alternative=new_andbox;
opp->nr_all_alternatives=nr_all_alternatives+1;
/* copy and_box ap to new_and-box */
{ struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
calls=ap->calls;
while(calls!=NULL) {
if (calls==nr_call) {
calls_new=new_call;
} else {
calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
calls_new->code=calls->code;
calls_new->locals=calls->locals;
calls_new->state=calls->state;
calls_new->call=copy_orbox(calls->call,new_andbox,calls_new); /* Do a exact copy of the tree*/
}
if (first==NULL) first=calls_new;
else last->next=calls_new;
calls_new->previous=last;
calls_new->next=NULL;
last=calls_new;
calls=calls->next;
}
new_andbox->calls=first;
}
/* remove and_box a from suspension list on vars */
if (a->externals) {
struct EXTERNAL_VAR *e;
e=a->externals;
while(e) {
if (e->var->home->level>=a->parent->parent->level)
remove_from_perm_var_suspensions(e->var,a);
e=e->next;
}
}
/* Now we have to create new local vars and refresh the external vars to point to those */
if (beam_MemGoing==1) {
beam_VAR_TRAIL=((Cell *) beam_START_ADDR_BOXES)-1;
} else beam_VAR_TRAIL=(Cell *) beam_START_ADDR_HEAP;
beam_VAR_TRAIL_NR=0;
replicate_local_variables(new_andbox);
}
struct OR_BOX *copy_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call)
{
struct OR_BOX *new_orbox;
struct status_or *old,*new,*first=NULL,*last=NULL;
if (o==NULL) return(NULL);
new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
new_orbox->parent=parent;
new_orbox->nr_call=nr_call;
new_orbox->nr_all_alternatives=o->nr_all_alternatives;
old=o->alternatives;
while(old!=NULL) {
new=(struct status_or *) request_memory(STATUS_OR_SIZE);
new->args=old->args;
new->code=old->code;
new->state=old->state;
new->alternative=copy_andbox(old->alternative,new_orbox);
if (new->alternative!=NULL) new->alternative->nr_alternative=new;
if (first==NULL) first=new;
else last->next=new;
new->previous=last;
new->next=NULL;
last=new;
old=old->next;
}
new_orbox->alternatives=first;
return(new_orbox);
}
struct AND_BOX *copy_andbox(struct AND_BOX *a,struct OR_BOX *parent)
{
struct AND_BOX *new_andbox;
if (a==NULL) return(NULL);
new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
new_andbox->parent=parent;
// new_andbox->nr_alternative=a->nr_alternative; /* this is seted in the copy_orbox, after calling copy_andbox */
new_andbox->nr_all_calls=a->nr_all_calls;
new_andbox->level=a->level;
new_andbox->perms=a->perms;
new_andbox->externals=a->externals;
new_andbox->side_effects=a->side_effects;
new_andbox->suspended=NULL;
if (a->suspended) {
new_andbox->suspended=addto_suspensions_list(new_andbox,a->suspended->reason);
}
{ struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
calls=a->calls;
while(calls!=NULL) {
calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
calls_new->code=calls->code;
calls_new->locals=calls->locals;
calls_new->state=calls->state;
calls_new->call=copy_orbox(calls->call,new_andbox,calls_new); /* Do a exact copy of the tree*/
if (first==NULL) first=calls_new;
else last->next=calls_new;
calls_new->previous=last;
calls_new->next=NULL;
last=calls_new;
calls=calls->next;
}
new_andbox->calls=first;
}
return(new_andbox);
}
void replicate_local_variables(struct AND_BOX *a) /* used by fork -ABX is set*/
{
struct PERM_VAR *l,*new_list;
int i,OLD_VAR_TRAIL_NR;
struct EXTERNAL_VAR *old_externals,*externals;
if (a==NULL) return;
OLD_VAR_TRAIL_NR=beam_VAR_TRAIL_NR;
l=a->perms;
new_list=NULL;
while(l) {
struct PERM_VAR *new;
Cell *c;
new=request_permVar(a);
new->yapvar=l->yapvar;
new->next=new_list;
new_list=new;
c=&l->value;
beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) c;
beam_VAR_TRAIL_NR-=beam_MemGoing;
beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) *c;
beam_VAR_TRAIL_NR-=beam_MemGoing;
if ((Cell *)*c==c) {
new->value=(Cell) &new->value;
*c=new->value;
} else {
new->value= (Cell) *c;
*c=(Cell) &new->value;
}
l=l->next;
}
a->perms=new_list;
l=new_list;
while(l) {
l->value=copy_structures(l->value);
l=l->next;
}
/* At this point all old local vars are pointing to the new local vars */
if (a==beam_ABX) { /* Nao preciso de criar um novo vector das externals */
old_externals=a->externals;
while(old_externals) {
if (old_externals->var->home->level>=beam_ABX->parent->parent->level) {
old_externals->value=copy_structures((Cell ) old_externals->value);
old_externals->var=(struct PERM_VAR *) old_externals->var->value;
if (isvar(old_externals->var)) {
struct SUSPENSIONS_VAR *s;
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
s->and_box=a;
s->next=old_externals->var->suspensions;
old_externals->var->suspensions=s;
}
}
old_externals=old_externals->next;
}
} else {
old_externals=a->externals;
externals=NULL;
a->externals=NULL;
while(old_externals) {
struct EXTERNAL_VAR *e;
struct SUSPENSIONS_VAR *s;
e=(struct EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
e->next=externals;
externals=e;
if (old_externals->var->home->level>=beam_ABX->parent->parent->level) {
e->value=copy_structures((Cell ) old_externals->value);
e->var=(struct PERM_VAR *) old_externals->var->value;
} else {
e->value=old_externals->value;
e->var=(struct PERM_VAR *) old_externals->var->value;
}
if (isvar(e->var)) {
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
s->and_box=a;
s->next=e->var->suspensions;
e->var->suspensions=s;
}
old_externals=old_externals->next;
}
a->externals=externals;
}
/* CUIDADO: Preciso agora de duplicar os vectores das variaveis locais */
{ struct status_and *calls;
#if !Fast_go
Cell **backup=NULL; int i, counted=0,max=1000;
backup=(Cell **) malloc(max);
#else
Cell *backup[1000]; int i, counted=0;
#endif
calls=a->calls;
while(calls!=NULL) {
if (calls->locals!=NULL) {
/* primeiro vou ver se já foi copiado */
for(i=0;i<counted;i+=2) {
if (backup[i]==calls->locals) {
calls->locals=backup[i+1];
break;
}
}
if (i==counted) { /* afinal ainda nao foi copiado: fazer copia em duas fases*/
Cell *c, *newvars, *oldvars; int nr;
oldvars=calls->locals;
nr=oldvars[-1];
newvars=request_memory_locals_noinit(nr);
calls->locals=newvars;
/* primeiro actualizo as variaveis */
for(i=0;i<nr;i++) {
c=&oldvars[i];
beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) c;
beam_VAR_TRAIL_NR-=beam_MemGoing;
beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) *c;
beam_VAR_TRAIL_NR-=beam_MemGoing;
if ((Cell *)*c==c) {
newvars[i]=(Cell) &newvars[i];
*c=newvars[i];
} else {
newvars[i]= (Cell) *c;
*c=(Cell) &newvars[i];
}
}
/* depois copio as estruturas */
for(i=0;i<nr;i++) {
newvars[i]=copy_structures(oldvars[i]);
}
#if !Fast_go
if (max<counted+2) {
max+=200;
backup=realloc(backup,max);
if (backup==NULL) abort_eam("No more memory... realloc in gc \n");
}
#else
if (counted>=998) abort_eam("No more memory... realloc in gc \n");
#endif
backup[counted]=oldvars;
backup[counted+1]=newvars;
counted+=2;
}
}
calls=calls->next;
}
#if !Fast_go
free(backup);
#endif
}
/* redo the process to the inner boxes */
{ struct status_and *calls;
calls=a->calls;
while(calls!=NULL) {
if (calls->call!=NULL) {
register struct OR_BOX *o;
register struct status_or *nr;
o=calls->call;
nr=o->alternatives;
while(nr!=NULL) {
replicate_local_variables(nr->alternative);
nr=nr->next;
}
}
calls=calls->next;
}
}
if (beam_MemGoing==1) {
for(i=OLD_VAR_TRAIL_NR;i>beam_VAR_TRAIL_NR;i-=2) {
Cell *c;
c=(Cell *) beam_VAR_TRAIL[i];
*c=(Cell) beam_VAR_TRAIL[i-1];
}
} else {
for(i=OLD_VAR_TRAIL_NR;i<beam_VAR_TRAIL_NR;i+=2) {
Cell *c;
c=(Cell *) beam_VAR_TRAIL[i];
*c=(Cell) beam_VAR_TRAIL[i+1];
}
}
beam_VAR_TRAIL_NR=OLD_VAR_TRAIL_NR;
}
Cell copy_structures(Cell c)
{
Cell *NewC, *NewH;
Cell OldC,LOCAL_OldH;
OldC=deref((Cell) c);
if (isvar(OldC)) {
return(OldC);
}
if (isatom(OldC)) {
return(OldC);
}
LOCAL_OldH=(Cell) beam_H;
NewH=beam_H;
if (isappl(OldC)) {
int i,arity;
NewC=(Cell *) repappl(OldC);
arity = ((int) ArityOfFunctor((Functor) *NewC));
*NewH++=*NewC++;
beam_H+=arity+1;
for(i=0;i<arity ;i++) {
*NewH=copy_structures((Cell) NewC);
NewH++;
NewC++;
}
return(absappl(LOCAL_OldH));
}
/* else if (ispair(c)) { */
NewC=(Cell *) reppair(OldC);
beam_H+=2;
*NewH=copy_structures((Cell) NewC);
NewC++;
NewH++;
*NewH=copy_structures((Cell) NewC);
return(abspair(LOCAL_OldH));
}

588
dev/yap-6.3/BEAM/eamamasm.c Normal file
View File

@ -0,0 +1,588 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: abstract machine assembler *
*************************************************************************/
#ifdef BEAM
#include "Yap.h"
#include "compile.h"
#include "clause.h"
#include "eam.h"
#include "eamamasm.h"
#include <stdio.h>
#include <stdlib.h>
Cell *inst_code;
int pass=0;
Cell *labels[1000];
Cell *Code_Start;
Cell Area_Code[200000];
Cell area_code=0;
extern Cell inst_am(int n);
void emit_inst(long int i);
void emit_par(long int i);
void emit_upar(Cell i);
Cell *get_addr(void);
int Is_X_Var(Ventry *ve);
int Is_P_Var(Ventry *ve);
int X_Var(Ventry *ve);
int Y_Var(Ventry *ve);
void eam_pass(CInstr *ppc);
Cell *eam_assemble(CInstr *code);
int next_not_nop_inst(CInstr *ppc);
extern void *alloc_mem(Cell);
void emit_inst(long int i)
{
if (pass) *inst_code=inst_am(i);
inst_code++;
}
void emit_par(long int i)
{
if (pass) *inst_code=i;
inst_code++;
}
void emit_upar(Cell i)
{
if (pass) *inst_code=i;
inst_code++;
}
Cell *get_addr(void)
{
return(inst_code);
}
int Is_P_Var(Ventry *ve)
{
if (ve->FirstOfVE>0) return (1); /* var aparece pela primeira no corpo da clausula */
return(0);
}
int Is_X_Var(Ventry *ve)
{
if (ve->KindOfVE == PermVar) return(0);
if (ve->KindOfVE == VoidVar) return(0);
return(1);
}
int X_Var(Ventry *ve)
{
int var;
if (ve->KindOfVE == PermVar || ve->KindOfVE == VoidVar ) {
printf("Erro no tipo de variavel X ->eamamas.c \n");
exit(1);
}
var = ((ve->NoOfVE) & MaskVarAdrs);
return (var);
}
extern int nperm;
int Y_Var(Ventry *ve)
{
int var;
if (ve->KindOfVE != PermVar) {
printf("Erro no tipo de variavel Y ->eamamas.c \n");
exit(1);
}
var = ((ve->NoOfVE) & MaskVarAdrs);
return (var);
}
int next_not_nop_inst(CInstr *ppc) {
while(ppc) {
if ((int) ppc->op!=nop_op) return ((int) ppc->op);
ppc = ppc->nextInst;
}
return exit_op;
}
void eam_pass(CInstr *ppc)
{
int alloc_found=0;
int body=0;
while (ppc) {
switch ((int) ppc->op) {
case get_var_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_get_var_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_get_var_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case get_val_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_get_val_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_get_val_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case get_num_op:
case get_atom_op:
emit_inst(_get_atom_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case get_list_op:
emit_inst(_get_list_op);
emit_par(ppc->new1);
break;
case get_struct_op:
emit_inst(_get_struct_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor ) ppc->new4));
break;
case unify_last_local_op:
case unify_local_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_local_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_local_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case unify_last_val_op:
case unify_val_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_val_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_val_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else { emit_inst(_unify_void_op); }
break;
case unify_last_var_op:
case unify_var_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_var_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_var_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else { emit_inst(_unify_void_op); }
break;
case unify_last_atom_op:
case unify_last_num_op:
emit_inst(_unify_last_atom_op);
emit_par(ppc->new4);
break;
case unify_num_op:
case unify_atom_op:
emit_inst(_unify_atom_op);
emit_par(ppc->new4);
break;
case unify_list_op:
emit_inst(_unify_list_op);
break;
case unify_last_list_op:
emit_inst(_unify_last_list_op);
break;
case unify_struct_op:
emit_inst(_unify_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case unify_last_struct_op:
emit_inst(_unify_last_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case put_unsafe_op:
/*
printf("Got a put_unsafe...\n");
emit_inst(_put_unsafe_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
break;
*/
case put_val_op:
/*
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_put_val_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
break;
} else {
emit_inst(_put_val_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
break;
}
*/
case put_var_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_put_var_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_put_var_P_op);
else emit_inst(_put_var_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case put_num_op:
case put_atom_op:
emit_inst(_put_atom_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case put_list_op:
emit_inst(_put_list_op);
emit_par(ppc->new1);
break;
case put_struct_op:
emit_inst(_put_struct_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case write_local_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_local_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_write_local_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case write_val_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_val_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_write_val_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else emit_inst(_write_void);
break;
case write_var_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_var_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_write_var_P_op);
else emit_inst(_write_var_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else emit_inst(_write_void);
break;
case write_num_op:
case write_atom_op:
emit_inst(_write_atom_op);
emit_par(ppc->new4);
break;
case write_list_op:
emit_inst(_write_list_op);
break;
case write_last_list_op:
emit_inst(_write_last_list_op);
break;
case write_struct_op:
emit_inst(_write_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case write_last_struct_op:
emit_inst(_write_last_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case fail_op:
emit_inst(_fail_op);
break;
case cutexit_op:
printf("cutexit \n");
exit(1);
break;
case cut_op:
emit_inst(_cut_op);
break;
case commit_op:
emit_inst(_commit_op);
break;
case procceed_op:
emit_inst(_proceed_op);
break;
case pop_op:
emit_inst(_pop_op);
emit_par(ppc->new4);
break;
case save_b_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_b_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_b_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case save_pair_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_pair_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_pair_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case save_appl_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_appl_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_appl_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case std_base_op:
emit_inst(_std_base+ppc->new4);
break;
case safe_call_op:
if (ppc->new1==1) {
emit_inst(_safe_call_unary_op);
} else if (ppc->new1==2) {
emit_inst(_safe_call_binary_op);
} else {
emit_inst(_safe_call_op);
}
emit_par(ppc->new4);
break;
case direct_safe_call_op:
if (ppc->new1==1) {
emit_inst(_direct_safe_call_unary_op);
} else if (ppc->new1==2) {
emit_inst(_direct_safe_call_binary_op);
} else {
emit_inst(_direct_safe_call_op);
}
emit_par(ppc->new4);
break;
case call_op:
emit_inst(_call_op);
emit_par(ppc->new4);
break;
case skip_while_var_op:
emit_inst(_skip_while_var);
break;
case wait_while_var_op:
emit_inst(_wait_while_var);
break;
case force_wait_op:
emit_inst(_force_wait);
break;
case write_op:
if (ppc->new1=='\n') {
static Atom a=NULL;
if (a==NULL) a=Yap_LookupAtom("\n");
emit_inst(_put_atom_op);
emit_par(1);
emit_par((Cell) MkAtomTerm(a));
}
emit_inst(_write_call);
break;
case is_op:
emit_inst(_is_call);
break;
case equal_op:
emit_inst(_equal_call);
break;
case either_op:
emit_inst(_either_op);
emit_par(ppc->new1);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case orelse_op:
emit_inst(_orelse_op);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case orlast_op:
emit_inst(_orlast_op);
break;
case create_first_box_op:
case create_box_op:
case create_last_box_op:
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
alloc_found=1;
break;
case remove_box_op:
case remove_last_box_op:
break;
case jump_op:
emit_inst(_jump_op);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case label_op:
if (pass==0) labels[ppc->new4] = get_addr();
break;
case run_op:
/* se ficar vazio, retirar no eam_am.c o +5 das linhas pc=clause->code+5 no only_1_clause e no call */
emit_inst(_try_me_op);
emit_par(0);
emit_par(0);
emit_par(0);
emit_par(0);
break;
case only_1_clause_op:
emit_inst(_only_1_clause_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(0); /* Nr da alternativa */
break;
case try_me_op:
emit_inst(_try_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(0); /* Nr da alternativa */
break;
case retry_me_op:
emit_inst(_retry_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(ppc->new1);
break;
case trust_me_op:
emit_inst(_trust_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(ppc->new1);
break;
case body_op:
if (next_not_nop_inst(ppc->nextInst)==procceed_op) {
//emit_inst(_proceed_op);
break;
} else if (next_not_nop_inst(ppc->nextInst)==fail_op) {
//emit_inst(_fail_op);
break;
}
if (ppc->new4!=0) {
emit_inst(_prepare_calls);
emit_par(ppc->new4); /* nr_calls */
}
body=1;
break;
case prepare_tries:
emit_inst(_prepare_tries);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case exit_op:
emit_inst(_exit_eam);
break;
case mark_initialized_pvars_op:
break;
case fetch_args_for_bccall:
case bccall_op:
printf("[ Fatal Error: fetch and bccall instructions not supported ]\n");
exit(1);
break;
case endgoal_op:
case nop_op:
case name_op:
break;
default:
if (pass) {
printf("[ Sorry, there is at least one unsupported instruction in your code... %3d] %d\n",ppc->op,exit_op);
printf("[ please note that beam still does not support a lot of builtins ]\n");
}
emit_inst(_fail_op);
}
ppc = ppc->nextInst;
}
emit_inst(_exit_eam);
emit_par(-1);
}
Cell *eam_assemble(CInstr *code)
{
Code_Start=0;
pass=0;
inst_code=0;
eam_pass(code);
pass=1;
Code_Start=alloc_mem((Cell) inst_code);
inst_code=Code_Start;
eam_pass(code);
return(Code_Start);
}
#endif /* BEAM */

130
dev/yap-6.3/BEAM/eamamasm.h Normal file
View File

@ -0,0 +1,130 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: abstract machine instructions *
*************************************************************************/
#define _exit_eam 0
#define _top_tree 1
#define _scheduler 2
#define _prepare_tries 3
#define _prepare_calls 4
#define _first_get _prepare_calls
#define _get_var_X_op _first_get+1
#define _get_var_Y_op _first_get+2
#define _get_val_X_op _first_get+3
#define _get_val_Y_op _first_get+4
#define _get_atom_op _first_get+5
#define _get_list_op _first_get+6
#define _get_struct_op _first_get+7
#define _first_unify _get_struct_op
#define _unify_void_op _first_unify + 1
#define _unify_val_X_op _first_unify + 2
#define _unify_val_Y_op _first_unify + 3
#define _unify_var_X_op _first_unify + 4
#define _unify_var_Y_op _first_unify + 5
#define _unify_atom_op _first_unify + 6
#define _unify_list_op _first_unify + 7
#define _unify_last_list_op _first_unify + 8
#define _unify_struct_op _first_unify + 9
#define _unify_last_struct_op _first_unify + 10
#define _unify_last_atom_op _first_unify + 11
#define _unify_local_X_op _first_unify + 12
#define _unify_local_Y_op _first_unify + 13
#define _first_put _unify_local_Y_op
#define _put_var_X_op _first_put + 1
#define _put_var_Y_op _first_put + 2
#define _put_val_X_op _first_put + 3
#define _put_val_Y_op _first_put + 4
#define _put_atom_op _first_put + 5
#define _put_list_op _first_put + 6
#define _put_struct_op _first_put + 7
#define _put_unsafe_op _first_put + 8
#define _put_var_P_op _first_put + 9
#define _first_write _put_var_P_op
#define _write_void _first_write + 1
#define _write_var_X_op _first_write + 2
#define _write_var_Y_op _first_write + 3
#define _write_val_X_op _first_write + 4
#define _write_val_Y_op _first_write + 5
#define _write_atom_op _first_write + 6
#define _write_list_op _first_write + 7
#define _write_struct_op _first_write + 8
#define _write_last_list_op _first_write + 9
#define _write_last_struct_op _first_write + 10
#define _write_local_X_op _first_write + 11
#define _write_local_Y_op _first_write + 12
#define _write_var_P_op _first_write + 13
#define _geral _write_var_P_op
#define _pop_op _geral + 1
#define _jump_op _geral + 2
#define _proceed_op _geral + 3
#define _call_op _geral + 4
#define _safe_call_op _geral + 5
#define _safe_call_unary_op _geral + 6
#define _safe_call_binary_op _geral + 7
#define _only_1_clause_op _geral + 8
#define _try_me_op _geral + 9
#define _retry_me_op _geral + 10
#define _trust_me_op _geral + 11
#define _do_nothing_op _geral + 12
#define _direct_safe_call_op _geral + 13
#define _direct_safe_call_unary_op _geral + 14
#define _direct_safe_call_binary_op _geral + 15
#define _skip_while_var _geral + 16
#define _wait_while_var _geral + 17
#define _force_wait _geral + 18
#define _write_call _geral + 19
#define _is_call _geral + 20
#define _equal_call _geral + 21
#define _cut_op _geral + 22
#define _commit_op _geral + 23
#define _fail_op _geral + 24
#define _others _fail_op
#define _save_b_X_op _others + 1
#define _save_b_Y_op _others + 2
#define _comit_b_X_op _others + 3
#define _comit_b_Y_op _others + 4
#define _save_appl_X_op _others + 5
#define _save_appl_Y_op _others + 6
#define _save_pair_X_op _others + 7
#define _save_pair_Y_op _others + 8
#define _either_op _others + 9
#define _orelse_op _others + 10
#define _orlast_op _others + 11
#define _std_base _orlast_op
#define _p_atom (_std_base+1)
#define _p_atomic (_std_base+2)
#define _p_equal (_std_base+3)
#define _p_integer (_std_base+4)
#define _p_nonvar (_std_base+5)
#define _p_number (_std_base+6)
#define _p_var (_std_base+7)
#define _p_db_ref (_std_base+8)
#define _p_primitive (_std_base+9)
#define _p_cut_by (_std_base+10)
#define _p_save_by (_std_base+11)
#define _p_succ (_std_base+12)
#define _p_predc (_std_base+13)
#define _p_plus (_std_base+14)
#define _p_minus (_std_base+15)
#define _p_times (_std_base+16)
#define _p_div (_std_base+17)
#define _p_dif (_std_base+18)
#define _p_eq (_std_base+19)
#define _p_arg (_std_base+20)
#define _p_functor (_std_base+21)

319
dev/yap-6.3/BEAM/eamindex.c Normal file
View File

@ -0,0 +1,319 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: indexing related functions *
*************************************************************************/
#ifdef BEAM
#include "Yap.h"
#include "compile.h"
#include "clause.h"
#include "eam.h"
#include <stdio.h>
#include <stdlib.h>
CInstr *StartCode,*inter_code;
extern void eam_showcode(Cell *code);
extern unsigned int index_of_hash_table_atom(Cell c, int nr);
extern unsigned int index_of_hash_table_appl(Cell c, int nr);
extern CInstr *emit_new(int o, int r1,CELL r4);
Cell *gera_codigo_try(struct Predicates *);
Cell *gera_codigo_try_list(struct Predicates *predi);
Cell *gera_codigo_try_only_vars(struct Predicates *predi);
struct HASH_TABLE **gera_codigo_try_atom(struct Predicates *predi);
struct HASH_TABLE **gera_codigo_try_functor(struct Predicates *predi);
extern Cell *eam_assemble(CInstr *code);
void do_eam_indexing(struct Predicates *p);
void ver_predicados(struct Predicates *p);
int exists_on_table(Cell a,struct HASH_TABLE **table, int i);
int exists_on_table(Cell a,struct HASH_TABLE **table, int i)
{
struct HASH_TABLE *t;
t=table[i];
while(t) {
if (t->value==a) return(1);
t=t->next;
}
return(0);
}
Cell *gera_codigo_try(struct Predicates *predi) /* gerar os try's para o predicado i */
{
struct Clauses *c;
int nr=0;
StartCode=NULL;
inter_code=NULL;
c=predi->first;
emit_new(prepare_tries,predi->nr_alt,predi->arity);
if (predi->nr_alt==1) {
emit_new(only_1_clause_op,0,(unsigned long) c);
} else if (predi->nr_alt>1) {
while(c!=NULL) {
if (nr+1==predi->nr_alt) emit_new(trust_me_op,nr,(unsigned long) c);
else if (nr==0) emit_new(try_me_op,predi->nr_alt,(unsigned long) c);
else emit_new(retry_me_op,nr,(unsigned long) c);
c=c->next;
nr++;
}
} else {
emit_new(fail_op,0,0);
}
return(eam_assemble(StartCode));
}
Cell *gera_codigo_try_list(struct Predicates *predi) /* gerar os try's para o predicado i */
{
struct Clauses *c;
int nr=0,nr_preds;
StartCode=NULL;
inter_code=NULL;
nr_preds=predi->idx_list+predi->idx_var;
c=predi->first;
emit_new(prepare_tries,nr_preds,predi->arity);
if (nr_preds>=1) {
while(c!=NULL) {
if (c->predi==predi && (c->idx==Lista || c->idx==Variavel)) {
if (nr_preds==1) {
emit_new(only_1_clause_op,0,(unsigned long) c);
break;
}
if (nr+1==nr_preds) { emit_new(trust_me_op,nr,(unsigned long) c); break; }
else if (nr==0) emit_new(try_me_op,nr_preds,(unsigned long) c);
else emit_new(retry_me_op,nr,(unsigned long) c);
nr++;
}
c=c->next;
}
} else {
emit_new(fail_op,0,0);
}
return(eam_assemble(StartCode));
}
struct HASH_TABLE **gera_codigo_try_atom(struct Predicates *predi)
{
int j,nr_preds,nr_atoms;
struct HASH_TABLE **table;
struct HASH_TABLE *t;
struct Clauses *cla;
nr_atoms=predi->idx_atom;
nr_preds=nr_atoms+predi->idx_var;
table=malloc(sizeof(struct HASH_TABLE *)*(nr_atoms+1));
for (j=0;j<=nr_atoms;j++) table[j]=NULL;
cla=predi->first;
while(cla) {
if (cla->idx==Constante) {
Cell a;
unsigned int index;
int nr;
a=cla->val;
if (a && nr_atoms) {
index=index_of_hash_table_atom(a,nr_atoms);
} else index=nr_atoms;
/* printf("nr_atoms=%d index=%d -> 0x%X \n",nr_atoms,index,a); */
if (!exists_on_table(a,table,index)) {
CInstr *first,*last=NULL,*prepare;
struct Clauses *cla2;
/* printf("a gerar codigo para atom index=%d value %ld\n",index,cla->val); */
t=malloc(sizeof(struct HASH_TABLE));
t->next=table[index];
table[index]=t;
t->value=a;
StartCode=NULL;
inter_code=NULL;
prepare=emit_new(prepare_tries,0,predi->arity);
cla2=predi->first;
nr=0;
first=NULL;
while(cla2) {
if ((cla2->idx==Constante && cla2->val==a) || cla2->idx==Variavel) {
last=emit_new(retry_me_op,nr,(unsigned long) cla2);
if (first==NULL) first=last;
nr++;
}
cla2=cla2->next;
}
prepare->new1=nr;
if (first==last) {
first->op=only_1_clause_op;
} else {
first->op=try_me_op;
last->op=trust_me_op;
}
t->code=eam_assemble(StartCode);
}
}
cla=cla->next;
}
return(table);
}
struct HASH_TABLE **gera_codigo_try_functor(struct Predicates *predi) /*gerar os try's para o predicado i*/
{
int j,nr_preds,nr_appls;
struct HASH_TABLE **table;
struct HASH_TABLE *t;
struct Clauses *cla;
nr_appls=predi->idx_functor;
nr_preds=nr_appls+predi->idx_var;
table=malloc(sizeof(struct HASH_TABLE *)*(nr_appls+1));
for (j=0;j<=nr_appls;j++) table[j]=NULL;
cla=predi->first;
while(cla) {
if (cla->idx==Estrutura) {
Cell a;
long int index;
int nr;
a=cla->val;
if (a && nr_appls) {
index=index_of_hash_table_appl(a,nr_appls);
} else index=nr_appls;
if (!exists_on_table(a,table,index)) {
CInstr *first,*last=NULL,*prepare;
struct Clauses *cla2;
/* printf("a gerar codigo para appl index=%d value %ld\n",index,cla->val); */
t=malloc(sizeof(struct HASH_TABLE));
t->next=table[index];
table[index]=t;
t->value=a;
StartCode=NULL;
inter_code=NULL;
prepare=emit_new(prepare_tries,0,predi->arity);
cla2=predi->first;
nr=0;
first=NULL;
while(cla2) {
if ((cla2->idx==Estrutura && cla2->val==a) || cla2->idx==Variavel) {
last=emit_new(retry_me_op,nr,(unsigned long) cla2);
if (first==NULL) first=last;
nr++;
}
cla2=cla2->next;
}
prepare->new1=nr;
if (first==last) {
first->op=only_1_clause_op;
} else {
first->op=try_me_op;
last->op=trust_me_op;
}
t->code=eam_assemble(StartCode);
}
}
cla=cla->next;
}
return(table);
}
Cell *gera_codigo_try_only_vars(struct Predicates *predi) /* gerar os try's de Vars para o predicado i */
{
struct Clauses *c;
int nr=0,nr_preds;
StartCode=NULL;
inter_code=NULL;
nr_preds=predi->idx_var;
c=predi->first;
emit_new(prepare_tries,nr_preds,predi->arity);
if (nr_preds>=1) {
while(c!=NULL) {
if (c->predi==predi && c->idx==Variavel) {
if (nr_preds==1) {
emit_new(only_1_clause_op,0,(unsigned long) c);
break;
}
if (nr+1==nr_preds) { emit_new(trust_me_op,nr,(unsigned long) c); break; }
else if (nr==0) emit_new(try_me_op,nr_preds,(unsigned long) c);
else emit_new(retry_me_op,nr,(unsigned long) c);
nr++;
}
c=c->next;
}
} else {
emit_new(fail_op,0,0);
}
return(eam_assemble(StartCode));
}
void do_eam_indexing(struct Predicates *p)
{
p->code=gera_codigo_try(p);
p->idx=-1;
if (p->arity && (p->idx_list || p->idx_atom || p->idx_functor)) {
p->vars=gera_codigo_try_only_vars(p);
p->list=gera_codigo_try_list(p);
p->functor=gera_codigo_try_functor(p);
p->atom=gera_codigo_try_atom(p);
p->idx=1;
}
if((Print_Code & 4) && (Print_Code & 8)) {
printf("General Case :\n");
eam_showcode(p->code);
}
if (Print_Code & 1) ver_predicados(p);
}
void ver_predicados(struct Predicates *p)
{
struct Clauses *c; int i=0;
printf("Predicado %s:%d (ES=%d) tem %d clausulas do tipo V=%d L=%d A=%d F=%d \n",p->name,p->arity,p->eager_split,p->nr_alt,p->idx_var,p->idx_list,p->idx_atom,p->idx_functor);
c=p->first;
while(c!=NULL) {
printf("Clausula %d do tipo %d (%d locals %d args) (val=0x%X)\n",++i,c->idx,c->nr_vars,c->predi->arity, (unsigned )c->val);
c=c->next;
}
}
#endif /* BEAM */

764
dev/yap-6.3/BEAM/toeam.c Normal file
View File

@ -0,0 +1,764 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: eam code compiler *
*************************************************************************/
#ifdef BEAM
#include "eam.h"
#include "eamamasm.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
extern int skip_while_var(void);
extern int wait_while_var(void);
extern int force_wait(void);
extern int p_write(void);
extern int p_is(void);
extern int p_halt(void);
extern int p_halt0(void);
extern int commit(void);
extern int eager_split(void);
extern void eam_showcode(Cell *);
extern Cell *eam_assemble(CInstr *);
extern void ShowCode_new2(int, int, CELL);
extern Cell *gera_codigo_try(int);
extern Cell *gera_codigo_try_list(int);
extern Cell *gera_codigo_try_only_vars(int);
extern struct HASH_TABLE **gera_codigo_try_atom(int);
extern struct HASH_TABLE **gera_codigo_try_functor(int);
/* Novas Definicoes */
compiler_struct *CGLOBS;
int labelno;
extern int nperm;
CInstr *inter_code,*StartCode;
void convert_Yaam(struct Clauses *);
void anota_predicados(struct Clauses *, PredEntry *,unsigned long ,int ,int ,int);
void verifica_predicados(struct Clauses *);
void ShowCode_new(int);
void codigo_eam(compiler_struct *);
void ver_predicados(void);
void eam_instructions(struct Clauses *);
void identify_calls(CInstr *);
int needs_box(Cell);
int is_skip(Cell);
void delay_prepare_calls(void);
int test_for_side_effects(void);
CInstr *insert_inst(CInstr *, int,int,CELL);
CInstr *emit_new(int, int, CELL);
CInstr *new_inst(int, int, CELL);
void *alloc_mem_temp(Cell);
void *alloc_mem(Cell);
/***********************************************************************\
* Aqui estao as novas partes do compilador *
\***********************************************************************/
void anota_predicados(struct Clauses *clause, PredEntry *p, unsigned long a,int b,int info_type,int call)
{
struct Predicates *predi;
if (p->beamTable==NULL) { /*1 vez que aparece, inicializar uma nova estrutura */
predi=(struct Predicates *) alloc_mem(sizeof(struct Predicates));
p->beamTable=predi;
predi->id=a;
predi->name=(char *) RepAtom(AtomOfTerm(MkAtomTerm((Atom) a)))->StrOfAE;
predi->arity=b;
predi->nr_alt=0;
predi->calls=0;
predi->idx_var=0;
predi->idx_list=0;
predi->idx_atom=0;
predi->idx_functor=0;
predi->first=NULL;
predi->last=NULL;
} else predi=p->beamTable;
if (!call) { /* se nao foi chamado por um call, entao anota informacao */
predi->id=a;
predi->nr_alt++;
if (info_type & Variavel ) predi->idx_var++; /* info_type=Lista+Estrutura+Constante; */
if (info_type & Lista ) predi->idx_list++;
if (info_type & Estrutura) predi->idx_functor++;
if (info_type & Constante) predi->idx_atom++;
if (predi->last==NULL) {
predi->first=clause;
predi->last=clause;
clause->next=NULL;
} else {
predi->last->next=clause;
predi->last=clause;
clause->next=NULL;
}
}
return;
}
void identify_calls(CInstr *code) {
PredEntry *p = RepPredProp((Prop) code->new4);
Functor f = p->FunctorOfPred;
int arity=p->ArityOfPE;
char *name;
if ( arity == 0) name=((AtomEntry *) f)->StrOfAE;
else name=((AtomEntry *) NameOfFunctor(f))->StrOfAE;
/*
if (code->op==call_op) printf("call: ");
else if (code->op==safe_call_op) printf("call: ");
else if (code->op==execute_op) printf("execute: ");
printf("->%s/%d...............\n",name,arity);
*/
if (arity==0) {
if (strcmp(name,"/")==0) { code->op=commit_op; return; }
if (strcmp(name,":")==0) { code->op=force_wait_op; return; }
if (strcmp(name,"nl")==0) { code->op=write_op; code->new1='\n'; return; }
if (strcmp(name,"halt")==0) { code->op=exit_op; return; }
} else if (arity==1) {
if (strcmp(name,"wait_while_var")==0) { code->op=wait_while_var_op; return; }
if (strcmp(name,"skip_while_var")==0) { code->op=skip_while_var_op; return; }
if (strcmp(name,"write")==0) { code->op=write_op; return; }
} else if (arity==2) {
if (strcmp(name,"is")==0) { code->op=is_op; return; }
}
/* não é nenhum call conhecido, deve ser um predicado em Prolog */
return;
}
/* no verifica_predicados, vou transformar os calls para */
void verifica_predicados(struct Clauses *clause)
{
CELL Flags;
inter_code=StartCode;
anota_predicados(clause,(CGLOBS->cint).CurrentPred, StartCode->new4,StartCode->new1,clause->idx,0);
while(inter_code!=NULL) {
if (inter_code->op==safe_call_op) { /* new1 deve continuar igual */
Flags = RepPredProp((Prop) (inter_code->new4))->PredFlags;
if (Flags & AsmPredFlag) {
inter_code->op=std_base_op;
inter_code->new4=(Flags &0x7f);
} else {
PredEntry *p=RepPredProp((Prop) inter_code->new4);
inter_code->op=safe_call_op;
inter_code->new4= (unsigned long) p->cs.f_code;
if (Flags & BinaryPredFlag) inter_code->new1=2;
else inter_code->new1=0;
}
}
else if (inter_code->op==call_op || inter_code->op==execute_op) {
PredEntry *p = RepPredProp((Prop) inter_code->new4);
Flags = p->PredFlags;
Functor f = p->FunctorOfPred;
if (Flags & AsmPredFlag) {
int op;
switch (Flags & 0x7f) {
case _equal:
op = _p_equal;
break;
case _dif:
op = _p_dif;
break;
case _eq:
op = _p_eq;
break;
case _arg:
op = _p_arg;
break;
case _functor:
op = _p_functor;
break;
default:
printf("Internal eam assembler error for built-in %d\n",((int) (Flags & 0x7f)));
exit(1);
}
}
if (!(Flags & CPredFlag)) {
if (p->ArityOfPE == 0) f = Yap_MkFunctor((Atom) f, 0);
inter_code->new4=(unsigned long) p;
anota_predicados(clause, p, (unsigned long) NameOfFunctor(f),ArityOfFunctor(f),0,1);
p->beamTable->calls++;
} else {/* safe_call */
inter_code->op=safe_call_op;
inter_code->new4= (unsigned long) p->cs.f_code;
if (Flags & BinaryPredFlag) inter_code->new1=2;
else inter_code->new1=0;
}
}
inter_code=inter_code->nextInst;
}
return;
}
void ShowCode_new(int i)
{
/*
struct intermediates c;
c.CodeStart=StartCode;
Yap_ShowCode(&c);
return;
*/
#ifdef DEBUG
switch(i) {
case 1: printf("\nVer Predicados \n");
break;
case 2: printf("\nVer yaam Original\n");
break;
case 4: printf("\nVer abs machine code\n");
break;
case 8: printf("\nVer o codigo dos trys\n");
break;
case 16: printf("\nVer o codigo yaam ja transformado\n");
break;
case 32: printf("\nver codigo EAM com direct calls\n");
break;
case 128: printf("\nVer codigo EAM final\n");
break;
}
inter_code = StartCode;
while (inter_code) {
ShowCode_new2(inter_code->op, inter_code->new1,inter_code->new4);
inter_code = inter_code->nextInst;
}
printf("\n");
#endif
}
void codigo_eam(compiler_struct *cglobs)
{
struct Clauses *clause;
CGLOBS=cglobs;
labelno=cglobs->labelno;
#ifdef DEBUG
if (Print_Code & 2 ) Yap_ShowCode(&CGLOBS->cint);
#endif
clause=(struct Clauses *) alloc_mem(sizeof(struct Clauses));
convert_Yaam(clause); /* convert into an internal struct code and check IDX */
verifica_predicados(clause); /* check predicates and convert calls */
clause->predi=(CGLOBS->cint).CurrentPred->beamTable;
(CGLOBS->cint).CurrentPred->beamTable->idx=0; /* will need to go by indexing */
if (Print_Code & 4) ShowCode_new(2); /* codigo YAAM */
/* transf os safe_calls em instrucoes eam e verifica se existem side_effects */
clause->side_effects=test_for_side_effects();
eam_instructions(clause);
if (Print_Code & 16) ShowCode_new(16); /* codigo EAM */
inter_code=NULL;
delay_prepare_calls(); /* transforma alguns safe_calls em direct_calls */
if (Print_Code & 32) ShowCode_new(32); /* codigo com direct_callss */
clause->code=eam_assemble(StartCode);
clause->nr_vars=nperm;
if (Print_Code & 128) eam_showcode((Cell *)clause->code);
}
/********************************************************\
* Convert Code *
\********************************************************/
int is_skip(Cell op)
{
if (op==skip_while_var_op) return(1);
if (op==wait_while_var_op) return(1);
return(0);
}
void eam_instructions(struct Clauses *clause)
{
int calls=0,nrcall=0;
CInstr *b_code=NULL;
inter_code=StartCode;
while(inter_code!=NULL){
if (inter_code->op==body_op) calls=0;
if (inter_code->op==procceed_op) inter_code->nextInst=NULL; /* CUIDADO */
if (inter_code->op==allocate_op) inter_code->op=nop_op;
if (inter_code->op==deallocate_op) inter_code->op=nop_op;
if (inter_code->op==cutexit_op) {
inter_code->op=cut_op;
insert_inst(inter_code,procceed_op,0,0);
}
if (inter_code->op==fail_op) insert_inst(inter_code,procceed_op,0,0);
if (inter_code->op==execute_op) {
inter_code->op=call_op;
insert_inst(inter_code,procceed_op,0,0);
}
if (inter_code->op==safe_call_op) {
if ((void *)inter_code->new4==(void *) eager_split) {
inter_code->op=nop_op;
clause->predi->eager_split=1;
}
}
if (needs_box(inter_code->op)) calls++;
inter_code=inter_code->nextInst;
}
if (calls) {
inter_code=StartCode;
while(inter_code!=NULL){
if (inter_code->op==body_op) {
inter_code->new4=calls;
insert_inst(inter_code,create_first_box_op,calls,++labelno);
inter_code=inter_code->nextInst;
}
if (needs_box(inter_code->op)) {
insert_inst(inter_code,remove_box_op,nrcall,0);
inter_code=inter_code->nextInst;
b_code=inter_code;
insert_inst(inter_code,label_op,nrcall,labelno);
inter_code=inter_code->nextInst;
insert_inst(inter_code,create_box_op,++nrcall,++labelno);
}
inter_code=inter_code->nextInst;
}
b_code->op=remove_last_box_op;
b_code->nextInst->nextInst->op=nop_op;
}
}
void delay_prepare_calls(void) {
CInstr *b_code=NULL;
inter_code=StartCode;
while(inter_code!=NULL){
if (inter_code->op==body_op) b_code=inter_code;
if (inter_code->op!=safe_call_op && inter_code->op!=cut_op && (needs_box(inter_code->op) || is_skip(inter_code->op))) break;
if (inter_code->op==safe_call_op) {
inter_code->op=direct_safe_call_op;
b_code->nextInst->op=nop_op;
inter_code->nextInst->op=nop_op;
if (b_code->new4>1) {
inter_code->nextInst->nextInst->op=body_op;
inter_code->nextInst->nextInst->new1=0;
inter_code->nextInst->nextInst->new4=b_code->new4-1;
} else {
inter_code->nextInst->nextInst->op=procceed_op;
inter_code->nextInst->nextInst->new1=0;
inter_code->nextInst->nextInst->new4=0;
}
b_code->op=nop_op;
}
inter_code=inter_code->nextInst;
}
}
int needs_box(Cell op)
{
if (op==safe_call_op) return(1);
if (op==call_op) return(1);
if (op==std_base_op) return(1);
if (op==fail_op) return(1);
if (op==force_wait_op) return(1);
if (op==cut_op) return(1);
if (op==commit_op) return(1);
if (op==cutexit_op) return(1);
if (op==write_op) return(1);
if (op==is_op) return(1);
if (op==equal_op) return(1);
if (op==exit_op) return(1);
return(0);
}
int test_for_side_effects()
{
int side_effects=0;
inter_code=StartCode;
while(inter_code!=NULL){
switch (inter_code->op) {
case write_op:
side_effects+=WRITE;
break;
case cutexit_op:
case commit_op:
case cut_op:
side_effects+=CUT;
break;
case force_wait_op:
side_effects+=SEQUENCIAL;
break;
}
inter_code=inter_code->nextInst;
}
return(side_effects);
}
void convert_Yaam(struct Clauses *clause)
{
PInstr *CodeStart, *ppc;
int calls=0;
clause->val=0;
clause->idx=Variavel;
StartCode=NULL;
inter_code=NULL;
CodeStart=(&CGLOBS->cint)->CodeStart;
ppc=CodeStart;
while(ppc!=NULL){ /* copia o codigo YAAM para poder ser alterado e ve o tipo de indexacao*/
if (ppc->op!=nop_op) {
if (ppc->op==get_var_op && ppc->rnd2==1) { clause->idx=Variavel; clause->val=0; }
if (ppc->op==get_list_op && ppc->rnd2==1) { clause->idx=Lista; clause->val=0; }
if (ppc->op==get_struct_op && ppc->rnd2==1) { clause->idx=Estrutura; clause->val=ppc->rnd1; }
if ((ppc->op==get_atom_op || ppc->op==get_num_op) && ppc->rnd2==1) { clause->idx=Constante; clause->val=ppc->rnd1; }
if (ppc->op==body_op || ppc->op==safe_call_op || ppc->op==call_op || ppc->op==execute_op) calls=1;
if (ppc->op==endgoal_op) {
if (calls==0) emit_new(equal_op, 0, 0);
calls=0;
} else {
emit_new(ppc->op, ppc->rnd2, ppc->rnd1);
if (ppc->op==body_op) calls=1;
if (ppc->op==safe_call_op || ppc->op==call_op || ppc->op==execute_op) {
calls=1; identify_calls(inter_code);
}
}
}
ppc=ppc->nextInst;
}
emit_new(nop_op, 0,0);
emit_new(nop_op, 0,0);
/*
CodeStart->nextInst=NULL;
ppc=CodeStart;
(&CGLOBS->cint)->cpc=CodeStart;
Yap_emit(cut_op,Zero,Zero,&CGLOBS->cint);
Yap_emit(run_op,Zero,(unsigned long) (CGLOBS->cint).CurrentPred,&CGLOBS->cint);
Yap_emit(procceed_op, Zero, Zero, &CGLOBS->cint);
*/
return;
}
CInstr *insert_inst(CInstr *inst, int o,int r1,CELL r4)
{
CInstr *p;
p=new_inst(o,r1,r4);
if (inst==NULL) inst=p;
else {
p->nextInst=inst->nextInst;
inst->nextInst=p;
}
return (p);
}
CInstr *emit_new(int o, int r1,CELL r4)
{
CInstr *p;
p=new_inst(o,r1,r4);
if (inter_code == NULL) {
inter_code = StartCode = p;
}
else {
inter_code->nextInst = p;
inter_code = p;
}
return(inter_code);
}
CInstr *new_inst(int o, int r1,CELL r4)
{
CInstr *p;
p = (CInstr *) alloc_mem_temp(sizeof(CInstr));
p->op = o;
p->new1 = r1;
p->new4 = r4;
p->nextInst = NULL;
return(p);
}
void *alloc_mem(Cell size)
{
void *p;
p=malloc(size);
if (p==NULL) { printf(" Erro, falta de memoria \n"); exit(1); }
// p=Yap_AllocCMem(size,&CGLOBS->cint);
return(p);
}
void *alloc_mem_temp(Cell size) /* memory that will be discard after compiling */
{
void *p;
p=malloc(size);
if (p==NULL) { printf(" Erro, falta de memoria \n"); exit(1); }
// p=Yap_AllocCMem(size,&CGLOBS->cint);
return(p);
}
#ifdef DEBUG
static char *opformat2[] =
{
"nop",
"get_var %1,%4",
"put_var %1,%4",
"get_val %1,%4",
"put_val %1,%4",
"get_atom %1,%4",
"put_atom %1,%4",
"get_num %1,%4",
"put_num %1,%4",
"get_float %1,%4",
"put_float %1,%4",
"align_float %1,%4",
"get_longint %1,%4",
"put_longint %1,%4",
"get_bigint %1,%4",
"put_bigint %1,%4",
"get_list %1,%4",
"put_list %1,%4",
"get_struct %1,%4",
"put_struct %1,%4",
"put_unsafe %1,%4",
"unify_var %1,%4",
"write_var %1,%4",
"unify_val %1,%4",
"write_val %1,%4",
"unify_atom %1,%4",
"write_atom %1,%4",
"unify_num %1,%4",
"write_num %1,%4",
"unify_float %1,%4",
"write_float %1,%4",
"unify_longint %1,%4",
"write_longint %1,%4",
"unify_bigint %1,%4",
"write_bigint %1,%4",
"unify_list %1,%4",
"write_list %1,%4",
"unify_struct %1,%4",
"write_struct %1,%4",
"write_unsafe %1,%4",
"fail %1,%4",
"cut %1,%4",
"cutexit %1,%4",
"allocate %1,%4",
"deallocate %1,%4",
"try_me_else %1,%4",
"jump %1,%4",
"jump %1,%4",
"proceed %1,%4",
"call %1,%4",
"execute %1,%4",
"sys %1,%4",
"%l: %1,%4",
"name %1,%4",
"pop %1,%4",
"retry_me_else %1,%4",
"trust_me_else_fail %1,%4",
"either_me %1,%4",
"or_else %1,%4",
"or_last %1,%4",
"push_or %1,%4",
"pushpop_or %1,%4",
"pop_or %1,%4",
"save_by %1,%4",
"commit_by %1,%4",
"patch_by %1,%4",
"try %1,%4",
"retry %1,%4",
"trust %1,%4",
"try_in %1,%4",
"jump_if_var %1,%4",
"jump_if_nonvar %1,%4",
"cache_arg %1,%4",
"cache_sub_arg %1,%4",
"switch_on_type %1,%4",
"switch_on_constant %1,%4",
"if_constant %1,%4",
"switch_on_functor %1,%4",
"if_functor %1,%4",
"if_not_then %1,%4",
"index_on_dbref %1,%4",
"index_on_blob %1,%4",
"check_var %1,%4",
"save_pair %1,%4",
"save_appl %1,%4",
"fail_label %1,%4",
"unify_local %1,%4",
"write local %1,%4",
"unify_last_list %1,%4",
"write_last_list %1,%4",
"unify_last_struct %1,%4",
"write_last_struct %1,%4",
"unify_last_var %1,%4",
"unify_last_val %1,%4",
"unify_last_local %1,%4",
"unify_last_atom %1,%4",
"unify_last_num %1,%4",
"unify_last_float %1,%4",
"unify_last_longint %1,%4",
"unify_last_bigint %1,%4",
"pvar_bitmap %1,%4",
"pvar_live_regs %1,%4",
"fetch_reg1_reg2 %1,%4",
"fetch_constant_reg %1,%4",
"fetch_reg_constant %1,%4",
"function_to_var %1,%4",
"function_to_al %1,%4",
"enter_profiling %1,%4",
"retry_profiled %1,%4",
"count_call_op %1,%4",
"count_retry_op %1,%4",
"restore_temps %1,%4",
"restore_temps_and_skip %1,%4",
"enter_lu %1,%4",
"empty_call %1,%4",
#ifdef YAPOR
"sync
#endif /* YAPOR */
#ifdef TABLING
"table_new_answer %1,%4",
"table_try_single %1,%4",
#endif /* TABLING */
#ifdef TABLING_INNER_CUTS
"clause_with_cut %1,%4",
#endif /* TABLING_INNER_CUTS */
#ifdef BEAM
"run_op %1,%4",
"body_op %1",
"endgoal_op",
"try_me_op %1,%4",
"retry_me_op %1,%4",
"trust_me_op %1,%4",
"only_1_clause_op %1,%4",
"create_first_box_op %1,%4",
"create_box_op %1,%4",
"create_last_box_op %1,%4",
"remove_box_op %1,%4",
"remove_last_box_op %1,%4",
"prepare_tries",
"std_base_op %1,%4",
"direct_safe_call",
"commit_op",
"skip_while_var_op",
"wait_while_var_op",
"force_wait_op",
"write_op",
"is_op",
"exit",
#endif
"fetch_args_for_bccall %1,%4",
"binary_cfunc %1,%4",
"blob %1,%4",
#ifdef SFUNC
,
"get_s_f_op %1,%4",
"put_s_f_op %1,%4",
"unify_s_f_op %1,%4",
"write_s_f_op %1,%4",
"unify_s_var %1,%4",
"write_s_var %1,%4",
"unify_s_val %1,%4",
"write_s_val %1,%4",
"unify_s_a %1,%4",
"write_s_a %1,%4",
"get_s_end",
"put_s_end",
"unify_s_end",
"write_s_end"
#endif
};
void ShowCode_new2(int op, int new1,CELL new4);
void ShowCode_new2(int op, int new1,CELL new4)
{
char *f,ch;
f=opformat2[op];
while ((ch = *f++) != 0)
{
if (ch == '%')
switch (ch = *f++)
{
case '1':
Yap_plwrite(MkIntTerm(new1), NULL, 30, 0, GLOBAL_MaxPriority);
break;
case '4':
Yap_plwrite(MkIntTerm(new4), NULL, 20, 0, GLOBAL_MaxPriority);
break;
default:
Yap_DebugPutc (LOCAL_c_error_stream,'%');
Yap_DebugPutc (LOCAL_c_error_stream,ch);
}
else
Yap_DebugPutc (LOCAL_c_error_stream,ch);
}
Yap_DebugPutc (LOCAL_c_error_stream,'\n');
}
#endif
#endif /* BEAM */

1895
dev/yap-6.3/C/absmi.c Normal file
View File

File diff suppressed because it is too large Load Diff

86
dev/yap-6.3/C/absmi_insts.h Normal file
View File

@ -0,0 +1,86 @@
/*****************************************************************
* INSTRUCTIONS *
*****************************************************************/
#ifdef INDENT_CODE
{
{
{
#endif /* INDENT_CODE */
BOp(Ystop, l);
SET_ASP(YREG, E_CB*sizeof(CELL));
/* make sure ASP is initialized */
saveregs();
#if PUSH_REGS
restore_absmi_regs(old_regs);
#endif
#if BP_FREE
P1REG = PCBACKUP;
#endif
return 1;
ENDBOp();
BOp(Nstop, e);
SET_ASP(YREG, E_CB*sizeof(CELL));
saveregs();
#if PUSH_REGS
restore_absmi_regs(old_regs);
#endif
#if BP_FREE
P1REG = PCBACKUP;
#endif
return 0;
ENDBOp();
/************************************************************************\
* Native Code Execution *
\************************************************************************/
#if YAP_JIT
static void *OpAddress_JIT[] =
{
#define OPCODE(OP,TYPE) && _##OP
#include "YapOpcodes.h"
#undef OPCODE
};
/* native_me */
BOp(jit_handler, J);
if (!PREG->y_u.J.jh->fi.bcst.c) PREG->y_u.J.jh->mf.isground = IsGround(PREG);
PREG->y_u.J.jh->fi.bcst.c++;
/* Did PREG reach threshold value to become critical? */
if (PREG->y_u.J.jh->fi.bcst.c == (COUNT)(ExpEnv.config_struc.frequency_bound*(ExpEnv.config_struc.profiling_startp)) && !PREG->y_u.J.jh->mf.isground) {
#if YAP_DBG_PREDS
if (ExpEnv.debug_struc.pprint_me.criticals != 0 && ExpEnv.debug_struc.pprint_me.criticals != 0x1) {
fprintf(stderr, "%s:%d\n", __FILE__, __LINE__);
fprintf(stderr, "%s", (char*)ExpEnv.debug_struc.pprint_me.criticals);
}
#endif
traced_absmi();
}
#if YAP_DBG_PREDS
print_main_when_head(PREG, ON_INTERPRETER);
#endif
PREG = NEXTOP(PREG, J);
JMPNext();
ENDBOp();
#endif
#include "cp_absmi_insts.h"
#include "lu_absmi_insts.h"
#include "fail_absmi_insts.h"
#include "control_absmi_insts.h"
#include "unify_absmi_insts.h"
#include "fli_absmi_insts.h"
#include "or_absmi_insts.h"
#include "index_absmi_insts.h"
#include "type_absmi_insts.h"
#include "prim_absmi_insts.h"
#include "meta_absmi_insts.h"

12251
dev/yap-6.3/C/absmi_insts.i Normal file
View File

File diff suppressed because it is too large Load Diff

1389
dev/yap-6.3/C/adtdefs.c Normal file
View File

File diff suppressed because it is too large Load Diff

574
dev/yap-6.3/C/agc.c Normal file
View File

@ -0,0 +1,574 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: agc.c *
* Last rev: *
* mods: *
* comments: reclaim unused atoms and functors *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "@(#)agc.c 1.3 3/15/90";
#endif
#include "absmi.h"
#include "Foreign.h"
#include "alloc.h"
#include "yapio.h"
#include "iopreds.h"
#include "attvar.h"
#ifdef DEBUG
/* #define DEBUG_RESTORE1 1 */
/* #define DEBUG_RESTORE2 1 */
/* #define DEBUG_RESTORE3 1 */
#define errout GLOBAL_stderr
#endif
static void RestoreEntries(PropEntry *, int USES_REGS);
static void CleanCode(PredEntry * USES_REGS);
static void RestoreDBTerm(DBTerm *dbr, int attachments USES_REGS);
#define AtomMarkedBit 1
static inline void
MarkAtomEntry(AtomEntry *ae)
{
CELL c = (CELL)(ae->NextOfAE);
c |= AtomMarkedBit;
ae->NextOfAE = (Atom)c;
}
static inline int
AtomResetMark(AtomEntry *ae)
{
CELL c = (CELL)(ae->NextOfAE);
if (c & AtomMarkedBit) {
c &= ~AtomMarkedBit;
ae->NextOfAE = (Atom)c;
return TRUE;
}
return FALSE;
}
static inline Atom
CleanAtomMarkedBit(Atom a)
{
CELL c = (CELL)a;
c &= ~AtomMarkedBit;
return (Atom)c;
}
static inline Functor
FuncAdjust(Functor f)
{
if (!IsExtensionFunctor(f)) {
AtomEntry *ae = RepAtom(NameOfFunctor(f));
MarkAtomEntry(ae);
}
return(f);
}
static inline Term
AtomTermAdjust(Term t)
{
AtomEntry *ae = RepAtom(AtomOfTerm(t));
MarkAtomEntry(ae);
return(t);
}
static inline Term
TermToGlobalOrAtomAdjust(Term t)
{
if (t && IsAtomTerm(t))
return AtomTermAdjust(t);
return(t);
}
static inline Atom
AtomAdjust(Atom a)
{
AtomEntry *ae;
if (a == NIL) return(a);
ae = RepAtom(a);
MarkAtomEntry(ae);
return(a);
}
#define IsOldCode(P) FALSE
#define IsOldCodeCellPtr(P) FALSE
#define IsOldDelay(P) FALSE
#define IsOldDelayPtr(P) FALSE
#define IsOldLocalInTR(P) FALSE
#define IsOldLocalInTRPtr(P) FALSE
#define IsOldGlobal(P) FALSE
#define IsOldGlobalPtr(P) FALSE
#define IsOldTrail(P) FALSE
#define IsOldTrailPtr(P) FALSE
#define CharP(X) ((char *)(X))
#define REINIT_LOCK(P)
#define REINIT_RWLOCK(P)
#define BlobTypeAdjust(P) (P)
#define NoAGCAtomAdjust(P) (P)
#define OrArgAdjust(P)
#define TabEntryAdjust(P)
#define IntegerAdjust(D) (D)
#define AddrAdjust(P) (P)
#define MFileAdjust(P) (P)
#define CodeVarAdjust(P) (P)
#define ConstantAdjust(P) (P)
#define ArityAdjust(P) (P)
#define DoubleInCodeAdjust(P)
#define IntegerInCodeAdjust(P)
#define OpcodeAdjust(P) (P)
#define ModuleAdjust(P) (P)
#define ExternalFunctionAdjust(P) (P)
#define DBRecordAdjust(P) (P)
#define PredEntryAdjust(P) (P)
#define ModEntryPtrAdjust(P) (P)
#define AtomEntryAdjust(P) (P)
#define GlobalEntryAdjust(P) (P)
#define BlobTermInCodeAdjust(P) (P)
#define CellPtoHeapAdjust(P) (P)
#define PtoAtomHashEntryAdjust(P) (P)
#define CellPtoHeapCellAdjust(P) (P)
#define CellPtoTRAdjust(P) (P)
#define CodeAddrAdjust(P) (P)
#define ConsultObjAdjust(P) (P)
#define DelayAddrAdjust(P) (P)
#define DelayAdjust(P) (P)
#define GlobalAdjust(P) (P)
#define DBRefAdjust(P,REF) (P)
#define DBRefPAdjust(P) (P)
#define DBTermAdjust(P) (P)
#define LUIndexAdjust(P) (P)
#define SIndexAdjust(P) (P)
#define LocalAddrAdjust(P) (P)
#define GlobalAddrAdjust(P) (P)
#define OpListAdjust(P) (P)
#define PtoLUCAdjust(P) (P)
#define PtoStCAdjust(P) (P)
#define PtoArrayEAdjust(P) (P)
#define PtoArraySAdjust(P) (P)
#define PtoGlobalEAdjust(P) (P)
#define PtoDelayAdjust(P) (P)
#define PtoGloAdjust(P) (P)
#define PtoLocAdjust(P) (P)
#define PtoHeapCellAdjust(P) (P)
#define TermToGlobalAdjust(P) (P)
#define PtoOpAdjust(P) (P)
#define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define PtoDBTLAdjust(P) (P)
#define PtoPredAdjust(P) (P)
#define PtoPtoPredAdjust(P) (P)
#define OpRTableAdjust(P) (P)
#define OpEntryAdjust(P) (P)
#define PropAdjust(P) (P)
#define TrailAddrAdjust(P) (P)
#define XAdjust(P) (P)
#define YAdjust(P) (P)
#define HoldEntryAdjust(P) (P)
#define CodeCharPAdjust(P) (P)
#define CodeConstCharPAdjust(P) (P)
#define CodeVoidPAdjust(P) (P)
#define HaltHookAdjust(P) (P)
#define recompute_mask(dbr)
#define rehash(oldcode, NOfE, KindOfEntries)
#define RestoreSWIHash()
static void
AdjustTermFlag(flag_term *tarr, UInt i)
{
CACHE_REGS
if (IsVarTerm(tarr[i].at)) {
RestoreDBTerm( tarr[i].DBT, 0 PASS_REGS );
} else if (IsAtomTerm( tarr[i].at ) )
tarr[i].at = AtomTermAdjust(tarr[i].at);
}
static void RestoreFlags( UInt NFlags )
{
CACHE_REGS
size_t i;
flag_term *tarr = GLOBAL_Flags;
if (worker_id == 0)
for (i=0; i<GLOBAL_flagCount; i++) {
AdjustTermFlag( tarr, i);
}
tarr = LOCAL_Flags;
for (i=0; i<LOCAL_flagCount; i++) {
AdjustTermFlag( tarr, i);
}
}
#include "rheap.h"
static void
RestoreHashPreds( USES_REGS1 )
{
}
static void init_reg_copies(USES_REGS1)
{
LOCAL_OldASP = ASP;
LOCAL_OldLCL0 = LCL0;
LOCAL_OldTR = TR;
LOCAL_OldGlobalBase = (CELL *)LOCAL_GlobalBase;
LOCAL_OldH = HR;
LOCAL_OldH0 = H0;
LOCAL_OldTrailBase = LOCAL_TrailBase;
LOCAL_OldTrailTop = LOCAL_TrailTop;
LOCAL_OldHeapBase = Yap_HeapBase;
LOCAL_OldHeapTop = HeapTop;
}
static void
RestoreAtomList(Atom atm USES_REGS)
{
AtomEntry *at;
at = RepAtom(atm);
if (EndOfPAEntr(at))
return;
do {
RestoreAtom(atm PASS_REGS);
atm = CleanAtomMarkedBit(at->NextOfAE);
at = RepAtom(atm);
} while (!EndOfPAEntr(at));
}
static void
mark_trail(USES_REGS1)
{
register tr_fr_ptr pt;
pt = TR;
/* moving the trail is simple */
while (pt != (tr_fr_ptr)LOCAL_TrailBase) {
CELL reg = TrailTerm(pt-1);
if (!IsVarTerm(reg)) {
if (IsAtomTerm(reg)) {
MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
}
}
pt--;
}
}
static void
mark_registers(USES_REGS1)
{
CELL *pt;
pt = XREGS;
/* moving the trail is simple */
while (pt != XREGS+MaxTemps) {
CELL reg = *pt++;
if (!IsVarTerm(reg)) {
if (IsAtomTerm(reg)) {
MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
}
}
}
}
static void
mark_local(USES_REGS1)
{
CELL *pt;
/* Adjusting the local */
pt = LCL0;
/* moving the trail is simple */
while (pt > ASP) {
CELL reg = *--pt;
if (!IsVarTerm(reg)) {
if (IsAtomTerm(reg)
#ifdef TABLING
/* assume we cannot have atoms on first page,
so this must be an arity
*/
&& reg > Yap_page_size
#endif
) {
MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
}
}
}
}
static CELL *
mark_global_cell(CELL *pt)
{
CELL reg = *pt;
if (IsVarTerm(reg)) {
/* skip bitmaps */
switch(reg) {
case (CELL)FunctorDouble:
#if SIZEOF_DOUBLE == 2*SIZEOF_INT_P
return pt + 4;
#else
return pt + 3;
#endif
case (CELL)FunctorString:
return pt + 3 + pt[1];
case (CELL)FunctorBigInt:
{
Int sz = 3 +
(sizeof(MP_INT)+
(((MP_INT *)(pt+2))->_mp_alloc*sizeof(mp_limb_t)))/sizeof(CELL);
Opaque_CallOnGCMark f;
Opaque_CallOnGCRelocate f2;
Term t = AbsAppl(pt);
if ( (f = Yap_blob_gc_mark_handler(t)) ) {
CELL ar[256];
Int i,n = (f)(Yap_BlobTag(t), Yap_BlobInfo(t), ar, 256);
if (n < 0) {
Yap_Error(RESOURCE_ERROR_HEAP,TermNil,"not enough space for slot internal variables in agc");
}
for (i = 0; i< n; i++) {
CELL *pt = ar+i;
CELL reg = *pt;
if (!IsVarTerm(reg) && IsAtomTerm(reg)) {
*pt = AtomTermAdjust(reg);
}
}
if ( (f2 = Yap_blob_gc_relocate_handler(t)) < 0 ) {
int out = (f2)(Yap_BlobTag(t), Yap_BlobInfo(t), ar, n);
if (out < 0)
Yap_Error(RESOURCE_ERROR_HEAP,TermNil,"bad restore of slot internal variables in agc");
}
}
return pt + sz;
}
case (CELL)FunctorLongInt:
return pt + 3;
break;
}
} else if (IsAtomTerm(reg)) {
MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
return pt+1;
}
return pt+1;
}
static void
mark_global(USES_REGS1)
{
CELL *pt;
/*
* to clean the global now that functors are just variables pointing to
* the code
*/
pt = H0;
while (pt < HR) {
pt = mark_global_cell(pt);
}
}
static void
mark_stacks(USES_REGS1)
{
mark_registers(PASS_REGS1);
mark_trail(PASS_REGS1);
mark_local(PASS_REGS1);
mark_global(PASS_REGS1);
}
static void
clean_atom_list(AtomHashEntry *HashPtr)
{
Atom atm = HashPtr->Entry;
Atom *patm = &(HashPtr->Entry);
while (atm != NIL) {
AtomEntry *at = RepAtom(atm);
if (AtomResetMark(at) ||
( at->PropsOfAE != NIL && !IsBlob(at) ) ||
(GLOBAL_AGCHook != NULL && !GLOBAL_AGCHook(atm))) {
patm = &(at->NextOfAE);
atm = at->NextOfAE;
} else {
NOfAtoms--;
if (IsBlob(atm)) {
YAP_BlobPropEntry *b = RepBlobProp(at->PropsOfAE);
if (b->NextOfPE != NIL) {
patm = &(at->NextOfAE);
atm = at->NextOfAE;
continue;
}
NOfAtoms++;
NOfBlobs--;
Yap_FreeCodeSpace((char *)b);
GLOBAL_agc_collected += sizeof(YAP_BlobPropEntry);
GLOBAL_agc_collected += sizeof(AtomEntry)+sizeof(size_t)+at->rep.blob->length;
} else if (IsWideAtom(atm)) {
#ifdef DEBUG_RESTORE3
fprintf(stderr, "Purged %p:%S\n", at, at->WStrOfAE);
#endif
GLOBAL_agc_collected += sizeof(AtomEntry)+wcslen(at->WStrOfAE);
} else {
#ifdef DEBUG_RESTORE3
fprintf(stderr, "Purged %p:%s patm=%p %p\n", at, at->StrOfAE, patm, at->NextOfAE);
#endif
GLOBAL_agc_collected += sizeof(AtomEntry)+strlen((const char *)at->StrOfAE);
}
*patm = atm = at->NextOfAE;
Yap_FreeCodeSpace((char *)at);
}
}
}
/*
* This is the really tough part, to restore the whole of the heap
*/
static void
clean_atoms(void)
{
AtomHashEntry *HashPtr = HashChain;
register int i;
AtomResetMark(AtomFoundVar);
AtomResetMark(AtomFreeTerm);
for (i = 0; i < AtomHashTableSize; ++i) {
clean_atom_list(HashPtr);
HashPtr++;
}
HashPtr = WideHashChain;
for (i = 0; i < WideAtomHashTableSize; ++i) {
clean_atom_list(HashPtr);
HashPtr++;
}
clean_atom_list(&INVISIBLECHAIN);
{
AtomHashEntry list;
list.Entry = Blobs;
clean_atom_list(&list);
}
}
static void
atom_gc(USES_REGS1)
{
int gc_verbose = Yap_is_gc_verbose();
int gc_trace = 0;
UInt time_start, agc_time;
#if defined(YAPOR) || defined(THREADS)
return;
#endif
if (Yap_GetValue(AtomGcTrace) != TermNil)
gc_trace = 1;
GLOBAL_agc_calls++;
GLOBAL_agc_collected = 0;
if (gc_trace) {
fprintf(stderr, "%% agc:\n");
} else if (gc_verbose) {
fprintf(stderr, "%% Start of atom garbage collection %d:\n", GLOBAL_agc_calls);
}
time_start = Yap_cputime();
/* get the number of active registers */
YAPEnterCriticalSection();
init_reg_copies(PASS_REGS1);
mark_stacks(PASS_REGS1);
restore_codes();
clean_atoms();
NOfBlobsMax = NOfBlobs+(NOfBlobs/2+256< 1024 ? NOfBlobs/2+256 : 1024);
YAPLeaveCriticalSection();
agc_time = Yap_cputime()-time_start;
GLOBAL_tot_agc_time += agc_time;
GLOBAL_tot_agc_recovered += GLOBAL_agc_collected;
if (gc_verbose) {
#ifdef _WIN32
fprintf(stderr, "%% Collected %I64d bytes.\n", GLOBAL_agc_collected);
#else
fprintf(stderr, "%% Collected %lld bytes.\n", GLOBAL_agc_collected);
#endif
fprintf(stderr, "%% GC %d took %g sec, total of %g sec doing GC so far.\n", GLOBAL_agc_calls, (double)agc_time/1000, (double)GLOBAL_tot_agc_time/1000);
}
}
void
Yap_atom_gc(USES_REGS1)
{
atom_gc(PASS_REGS1);
}
static Int
p_atom_gc(USES_REGS1)
{
#ifndef FIXED_STACKS
atom_gc(PASS_REGS1);
#endif /* FIXED_STACKS */
return TRUE;
}
static Int
p_inform_agc(USES_REGS1)
{
Term tn = MkIntegerTerm(GLOBAL_tot_agc_time);
Term tt = MkIntegerTerm(GLOBAL_agc_calls);
Term ts = MkIntegerTerm(GLOBAL_tot_agc_recovered);
return
Yap_unify(tn, ARG2) &&
Yap_unify(tt, ARG1) &&
Yap_unify(ts, ARG3);
}
static Int
p_agc_threshold(USES_REGS1)
{
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
return Yap_unify(ARG1, MkIntegerTerm(GLOBAL_AGcThreshold));
} else if (!IsIntegerTerm(t)) {
Yap_Error(TYPE_ERROR_INTEGER,t,"prolog_flag/2 agc_margin");
return FALSE;
} else {
Int i = IntegerOfTerm(t);
if (i<0) {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,t,"prolog_flag/2 agc_margin");
return FALSE;
} else {
GLOBAL_AGcThreshold = i;
return TRUE;
}
}
}
void
Yap_init_agc(void)
{
Yap_InitCPred("$atom_gc", 0, p_atom_gc, 0);
Yap_InitCPred("$inform_agc", 3, p_inform_agc, 0);
Yap_InitCPred("$agc_threshold", 1, p_agc_threshold, SafePredFlag);
}

1573
dev/yap-6.3/C/alloc.c Normal file
View File

File diff suppressed because it is too large Load Diff

3956
dev/yap-6.3/C/amasm.c Normal file
View File

File diff suppressed because it is too large Load Diff

886
dev/yap-6.3/C/analyst.c Normal file
View File

@ -0,0 +1,886 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: analyst.c *
* Last rev: *
* mods: *
* comments: Tracing the abstract machine *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#ifdef ANALYST
#include "Yatom.h"
#include "yapio.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
static Int p_reset_op_counters(void);
static Int p_show_op_counters(void);
static Int p_show_ops_by_group(void);
static Int
p_reset_op_counters()
{
int i;
for (i = 0; i <= _std_top; ++i)
GLOBAL_opcount[i] = 0;
return TRUE;
}
static void
print_instruction(int inst)
{
int j;
fprintf(GLOBAL_stderr, "%s", Yap_op_names[inst]);
for (j = strlen(Yap_op_names[inst]); j < 25; j++)
putc(' ', GLOBAL_stderr);
j = GLOBAL_opcount[inst];
if (j < 100000000) {
putc(' ', GLOBAL_stderr);
if (j < 10000000) {
putc(' ', GLOBAL_stderr);
if (j < 1000000) {
putc(' ', GLOBAL_stderr);
if (j < 100000) {
putc(' ', GLOBAL_stderr);
if (j < 10000) {
putc(' ', GLOBAL_stderr);
if (j < 1000) {
putc(' ', GLOBAL_stderr);
if (j < 100) {
putc(' ', GLOBAL_stderr);
if (j < 10) {
putc(' ', GLOBAL_stderr);
}
}
}
}
}
}
}
}
fprintf(GLOBAL_stderr, "%llu\n", GLOBAL_opcount[inst]);
}
static Int
p_show_op_counters()
{
int i;
Term t1 = Deref(ARG1);
if (IsVarTerm(t1) || !IsAtomTerm(t1)) {
return FALSE;
} else {
Atom at1 = AtomOfTerm(t1);
if (IsWideAtom(at1)) {
wchar_t *program;
program = RepAtom(at1)->WStrOfAE;
fprintf(GLOBAL_stderr, "\n Instructions Executed in %S\n", program);
} else {
char *program;
program = RepAtom(at1)->StrOfAE;
fprintf(GLOBAL_stderr, "\n Instructions Executed in %s\n", program);
}
}
for (i = 0; i <= _std_top; ++i)
print_instruction(i);
fprintf(GLOBAL_stderr, "\n Control Instructions \n");
print_instruction(_op_fail);
print_instruction(_execute);
print_instruction(_dexecute);
print_instruction(_call);
print_instruction(_fcall);
print_instruction(_call_cpred);
print_instruction(_call_c_wfail);
print_instruction(_procceed);
print_instruction(_allocate);
print_instruction(_deallocate);
fprintf(GLOBAL_stderr, "\n Choice Point Manipulation Instructions\n");
print_instruction(_try_me);
print_instruction(_retry_me);
print_instruction(_trust_me);
print_instruction(_try_clause);
print_instruction(_try_in);
print_instruction(_retry);
print_instruction(_trust);
fprintf(GLOBAL_stderr, "\n Disjunction Instructions\n");
print_instruction(_either);
print_instruction(_or_else);
print_instruction(_or_last);
print_instruction(_jump);
print_instruction(_move_back);
fprintf(GLOBAL_stderr, "\n Dynamic Predicates Choicepoint Instructions\n");
print_instruction(_try_and_mark);
print_instruction(_retry_and_mark);
fprintf(GLOBAL_stderr, "\n C Predicates Choicepoint Instructions\n");
print_instruction(_try_c);
print_instruction(_retry_c);
fprintf(GLOBAL_stderr, "\n Indexing Instructions\n");
fprintf(GLOBAL_stderr, "\n Switch on Type\n");
print_instruction(_switch_on_type);
print_instruction(_switch_list_nl);
print_instruction(_switch_on_arg_type);
print_instruction(_switch_on_sub_arg_type);
fprintf(GLOBAL_stderr, "\n Switch on Value\n");
print_instruction(_if_cons);
print_instruction(_go_on_cons);
print_instruction(_switch_on_cons);
print_instruction(_if_func);
print_instruction(_go_on_func);
print_instruction(_switch_on_func);
fprintf(GLOBAL_stderr, "\n Other Switches\n");
print_instruction(_if_not_then);
fprintf(GLOBAL_stderr, "\n Get Instructions\n");
print_instruction(_get_x_var);
print_instruction(_get_y_var);
print_instruction(_get_x_val);
print_instruction(_get_y_val);
print_instruction(_get_atom);
print_instruction(_get_2atoms);
print_instruction(_get_3atoms);
print_instruction(_get_4atoms);
print_instruction(_get_5atoms);
print_instruction(_get_6atoms);
print_instruction(_get_list);
print_instruction(_get_struct);
fprintf(GLOBAL_stderr, "\n Optimised Get Instructions\n");
print_instruction(_glist_valx);
print_instruction(_glist_valy);
print_instruction(_gl_void_varx);
print_instruction(_gl_void_vary);
print_instruction(_gl_void_valx);
print_instruction(_gl_void_valy);
fprintf(GLOBAL_stderr, "\n Unify Read Instructions\n");
print_instruction(_unify_x_var);
print_instruction(_unify_x_var2);
print_instruction(_unify_y_var);
print_instruction(_unify_x_val);
print_instruction(_unify_y_val);
print_instruction(_unify_x_loc);
print_instruction(_unify_y_loc);
print_instruction(_unify_atom);
print_instruction(_unify_n_atoms);
print_instruction(_unify_n_voids);
print_instruction(_unify_list);
print_instruction(_unify_struct);
fprintf(GLOBAL_stderr, "\n Unify Last Read Instructions\n");
print_instruction(_unify_l_x_var);
print_instruction(_unify_l_x_var2);
print_instruction(_unify_l_y_var);
print_instruction(_unify_l_x_val);
print_instruction(_unify_l_y_val);
print_instruction(_unify_l_x_loc);
print_instruction(_unify_l_y_loc);
print_instruction(_unify_l_atom);
print_instruction(_unify_l_n_voids);
print_instruction(_unify_l_list);
print_instruction(_unify_l_struc);
fprintf(GLOBAL_stderr, "\n Unify Write Instructions\n");
print_instruction(_unify_x_var_write);
print_instruction(_unify_x_var2_write);
print_instruction(_unify_y_var_write);
print_instruction(_unify_x_val_write);
print_instruction(_unify_y_val_write);
print_instruction(_unify_x_loc_write);
print_instruction(_unify_y_loc_write);
print_instruction(_unify_atom_write);
print_instruction(_unify_n_atoms_write);
print_instruction(_unify_n_voids_write);
print_instruction(_unify_list_write);
print_instruction(_unify_struct_write);
fprintf(GLOBAL_stderr, "\n Unify Last Read Instructions\n");
print_instruction(_unify_l_x_var_write);
print_instruction(_unify_l_x_var2_write);
print_instruction(_unify_l_y_var_write);
print_instruction(_unify_l_x_val_write);
print_instruction(_unify_l_y_val_write);
print_instruction(_unify_l_x_loc_write);
print_instruction(_unify_l_y_loc_write);
print_instruction(_unify_l_atom_write);
print_instruction(_unify_l_n_voids_write);
print_instruction(_unify_l_list_write);
print_instruction(_unify_l_struc_write);
fprintf(GLOBAL_stderr, "\n Put Instructions\n");
print_instruction(_put_x_var);
print_instruction(_put_y_var);
print_instruction(_put_x_val);
print_instruction(_put_xx_val);
print_instruction(_put_y_val);
print_instruction(_put_unsafe);
print_instruction(_put_atom);
print_instruction(_put_list);
print_instruction(_put_struct);
fprintf(GLOBAL_stderr, "\n Write Instructions\n");
print_instruction(_write_x_var);
print_instruction(_write_y_var);
print_instruction(_write_x_val);
print_instruction(_write_y_val);
print_instruction(_write_x_loc);
print_instruction(_write_y_loc);
print_instruction(_write_atom);
print_instruction(_write_n_atoms);
print_instruction(_write_n_voids);
print_instruction(_write_list);
print_instruction(_write_struct);
fprintf(GLOBAL_stderr, "\n Last Write Instructions\n");
print_instruction(_write_l_list);
print_instruction(_write_l_struc);
fprintf(GLOBAL_stderr, "\n Miscellaneous Instructions\n");
print_instruction(_cut);
print_instruction(_cut_t);
print_instruction(_cut_e);
print_instruction(_skip);
print_instruction(_pop);
print_instruction(_pop_n);
print_instruction(_trust_fail);
print_instruction(_index_pred);
print_instruction(_lock_pred);
#if THREADS
print_instruction(_thread_local);
#endif
print_instruction(_save_b_x);
print_instruction(_save_b_y);
print_instruction(_save_pair_x);
print_instruction(_save_pair_y);
print_instruction(_save_pair_x_write);
print_instruction(_save_pair_y_write);
print_instruction(_save_appl_x);
print_instruction(_save_appl_y);
print_instruction(_save_appl_x_write);
print_instruction(_save_appl_y_write);
print_instruction(_Ystop);
print_instruction(_Nstop);
return TRUE;
}
typedef struct {
int nxvar, nxval, nyvar, nyval, ncons, nlist, nstru, nmisc;
} uGLOBAL_opcount;
typedef struct {
int ncalls, nexecs, nproceeds, ncallbips, ncuts, nallocs, ndeallocs;
} cGLOBAL_opcount;
typedef struct {
int ntries, nretries, ntrusts;
} ccpcount;
static Int
p_show_ops_by_group(void)
{
uGLOBAL_opcount c_get, c_unify, c_put, c_write;
cGLOBAL_opcount c_control;
ccpcount c_cp;
int gets, unifies, puts, writes, controls, choice_pts, indexes, misc,
total;
Term t1;
Atom at1;
t1 = Deref(ARG1);
if (IsVarTerm(t1) || !IsAtomTerm(t1))
return (FALSE);
at1 = AtomOfTerm(t1);
if (IsWideAtom(at1)) {
wchar_t *program;
program = RepAtom(at1)->WStrOfAE;
fprintf(GLOBAL_stderr, "\n Instructions Executed in %S\n", program);
} else {
char *program;
program = RepAtom(at1)->StrOfAE;
fprintf(GLOBAL_stderr, "\n Instructions Executed in %s\n", program);
}
c_get.nxvar =
GLOBAL_opcount[_get_x_var];
c_get.nyvar =
GLOBAL_opcount[_get_y_var];
c_get.nxval =
GLOBAL_opcount[_get_x_val];
c_get.nyval =
GLOBAL_opcount[_get_y_val];
c_get.ncons =
GLOBAL_opcount[_get_atom]+
GLOBAL_opcount[_get_2atoms]+
GLOBAL_opcount[_get_3atoms]+
GLOBAL_opcount[_get_4atoms]+
GLOBAL_opcount[_get_5atoms]+
GLOBAL_opcount[_get_6atoms];
c_get.nlist =
GLOBAL_opcount[_get_list] +
GLOBAL_opcount[_glist_valx] +
GLOBAL_opcount[_glist_valy] +
GLOBAL_opcount[_gl_void_varx] +
GLOBAL_opcount[_gl_void_vary] +
GLOBAL_opcount[_gl_void_valx] +
GLOBAL_opcount[_gl_void_valy];
c_get.nstru =
GLOBAL_opcount[_get_struct];
gets = c_get.nxvar + c_get.nyvar + c_get.nxval + c_get.nyval +
c_get.ncons + c_get.nlist + c_get.nstru;
c_unify.nxvar =
GLOBAL_opcount[_unify_x_var] +
GLOBAL_opcount[_unify_void] +
GLOBAL_opcount[_unify_n_voids] +
2 * GLOBAL_opcount[_unify_x_var2] +
2 * GLOBAL_opcount[_gl_void_varx] +
GLOBAL_opcount[_gl_void_vary] +
GLOBAL_opcount[_gl_void_valx] +
GLOBAL_opcount[_unify_l_x_var] +
GLOBAL_opcount[_unify_l_void] +
GLOBAL_opcount[_unify_l_n_voids] +
2 * GLOBAL_opcount[_unify_l_x_var2] +
GLOBAL_opcount[_unify_x_var_write] +
GLOBAL_opcount[_unify_void_write] +
GLOBAL_opcount[_unify_n_voids_write] +
2 * GLOBAL_opcount[_unify_x_var2_write] +
GLOBAL_opcount[_unify_l_x_var_write] +
GLOBAL_opcount[_unify_l_void_write] +
GLOBAL_opcount[_unify_l_n_voids_write] +
2 * GLOBAL_opcount[_unify_l_x_var2_write];
c_unify.nyvar =
GLOBAL_opcount[_unify_y_var] +
GLOBAL_opcount[_gl_void_vary] +
GLOBAL_opcount[_unify_l_y_var] +
GLOBAL_opcount[_unify_y_var_write] +
GLOBAL_opcount[_unify_l_y_var_write];
c_unify.nxval =
GLOBAL_opcount[_unify_x_val] +
GLOBAL_opcount[_unify_x_loc] +
GLOBAL_opcount[_glist_valx] +
GLOBAL_opcount[_gl_void_valx] +
GLOBAL_opcount[_unify_l_x_val] +
GLOBAL_opcount[_unify_l_x_loc] +
GLOBAL_opcount[_unify_x_val_write] +
GLOBAL_opcount[_unify_x_loc_write] +
GLOBAL_opcount[_unify_l_x_val_write] +
GLOBAL_opcount[_unify_l_x_loc_write];
c_unify.nyval =
GLOBAL_opcount[_unify_y_val] +
GLOBAL_opcount[_unify_y_loc] +
GLOBAL_opcount[_glist_valy] +
GLOBAL_opcount[_gl_void_valy] +
GLOBAL_opcount[_unify_l_y_val] +
GLOBAL_opcount[_unify_l_y_loc] +
GLOBAL_opcount[_unify_y_val_write] +
GLOBAL_opcount[_unify_y_loc_write] +
GLOBAL_opcount[_unify_l_y_val_write] +
GLOBAL_opcount[_unify_l_y_loc_write];
c_unify.ncons =
GLOBAL_opcount[_unify_atom] +
GLOBAL_opcount[_unify_n_atoms] +
GLOBAL_opcount[_unify_l_atom] +
GLOBAL_opcount[_unify_atom_write] +
GLOBAL_opcount[_unify_n_atoms_write] +
GLOBAL_opcount[_unify_l_atom_write];
c_unify.nlist =
GLOBAL_opcount[_unify_list] +
GLOBAL_opcount[_unify_l_list] +
GLOBAL_opcount[_unify_list_write] +
GLOBAL_opcount[_unify_l_list_write];
c_unify.nstru =
GLOBAL_opcount[_unify_struct] +
GLOBAL_opcount[_unify_l_struc] +
GLOBAL_opcount[_unify_struct_write] +
GLOBAL_opcount[_unify_l_struc_write];
c_unify.nmisc =
GLOBAL_opcount[_pop] +
GLOBAL_opcount[_pop_n];
unifies = c_unify.nxvar + c_unify.nyvar + c_unify.nxval + c_unify.nyval +
c_unify.ncons + c_unify.nlist + c_unify.nstru + c_unify.nmisc;
c_put.nxvar =
GLOBAL_opcount[_put_x_var];
c_put.nyvar =
GLOBAL_opcount[_put_y_var];
c_put.nxval =
GLOBAL_opcount[_put_x_val]+
2*GLOBAL_opcount[_put_xx_val];
c_put.nyval =
GLOBAL_opcount[_put_y_val];
c_put.ncons =
GLOBAL_opcount[_put_atom];
c_put.nlist =
GLOBAL_opcount[_put_list];
c_put.nstru =
GLOBAL_opcount[_put_struct];
puts = c_put.nxvar + c_put.nyvar + c_put.nxval + c_put.nyval +
c_put.ncons + c_put.nlist + c_put.nstru;
c_write.nxvar =
GLOBAL_opcount[_write_x_var] +
GLOBAL_opcount[_write_void] +
GLOBAL_opcount[_write_n_voids];
c_write.nyvar =
GLOBAL_opcount[_write_y_var];
c_write.nxval =
GLOBAL_opcount[_write_x_val];
c_write.nyval =
GLOBAL_opcount[_write_y_val];
c_write.ncons =
GLOBAL_opcount[_write_atom];
c_write.nlist =
GLOBAL_opcount[_write_list];
c_write.nstru =
GLOBAL_opcount[_write_struct];
writes = c_write.nxvar + c_write.nyvar + c_write.nxval + c_write.nyval +
c_write.ncons + c_write.nlist + c_write.nstru;
c_control.nexecs =
GLOBAL_opcount[_execute] +
GLOBAL_opcount[_dexecute];
c_control.ncalls =
GLOBAL_opcount[_call] +
GLOBAL_opcount[_fcall];
c_control.nproceeds =
GLOBAL_opcount[_procceed];
c_control.ncallbips =
GLOBAL_opcount[_call_cpred] +
GLOBAL_opcount[_call_c_wfail] +
GLOBAL_opcount[_try_c] +
GLOBAL_opcount[_retry_c] +
GLOBAL_opcount[_op_fail] +
GLOBAL_opcount[_trust_fail] +
GLOBAL_opcount[_p_atom_x] +
GLOBAL_opcount[_p_atom_y] +
GLOBAL_opcount[_p_atomic_x] +
GLOBAL_opcount[_p_atomic_y] +
GLOBAL_opcount[_p_compound_x] +
GLOBAL_opcount[_p_compound_y] +
GLOBAL_opcount[_p_float_x] +
GLOBAL_opcount[_p_float_y] +
GLOBAL_opcount[_p_integer_x] +
GLOBAL_opcount[_p_integer_y] +
GLOBAL_opcount[_p_nonvar_x] +
GLOBAL_opcount[_p_nonvar_y] +
GLOBAL_opcount[_p_number_x] +
GLOBAL_opcount[_p_number_y] +
GLOBAL_opcount[_p_var_x] +
GLOBAL_opcount[_p_var_y] +
GLOBAL_opcount[_p_db_ref_x] +
GLOBAL_opcount[_p_db_ref_y] +
GLOBAL_opcount[_p_cut_by_x] +
GLOBAL_opcount[_p_cut_by_y] +
GLOBAL_opcount[_p_primitive_x] +
GLOBAL_opcount[_p_primitive_y] +
GLOBAL_opcount[_p_equal] +
GLOBAL_opcount[_p_plus_vv] +
GLOBAL_opcount[_p_plus_vc] +
GLOBAL_opcount[_p_plus_y_vv] +
GLOBAL_opcount[_p_plus_y_vc] +
GLOBAL_opcount[_p_minus_vv] +
GLOBAL_opcount[_p_minus_cv] +
GLOBAL_opcount[_p_minus_y_vv] +
GLOBAL_opcount[_p_minus_y_cv] +
GLOBAL_opcount[_p_times_vv] +
GLOBAL_opcount[_p_times_vc] +
GLOBAL_opcount[_p_times_y_vv] +
GLOBAL_opcount[_p_times_y_vc] +
GLOBAL_opcount[_p_div_vv] +
GLOBAL_opcount[_p_div_vc] +
GLOBAL_opcount[_p_div_cv] +
GLOBAL_opcount[_p_div_y_vv] +
GLOBAL_opcount[_p_div_y_vc] +
GLOBAL_opcount[_p_div_y_cv] +
GLOBAL_opcount[_p_or_vv] +
GLOBAL_opcount[_p_or_vc] +
GLOBAL_opcount[_p_or_y_vv] +
GLOBAL_opcount[_p_or_y_vc] +
GLOBAL_opcount[_p_and_vv] +
GLOBAL_opcount[_p_and_vc] +
GLOBAL_opcount[_p_and_y_vv] +
GLOBAL_opcount[_p_and_y_vc] +
GLOBAL_opcount[_p_sll_vv] +
GLOBAL_opcount[_p_sll_vc] +
GLOBAL_opcount[_p_sll_y_vv] +
GLOBAL_opcount[_p_sll_y_vc] +
GLOBAL_opcount[_p_slr_vv] +
GLOBAL_opcount[_p_slr_vc] +
GLOBAL_opcount[_p_slr_y_vv] +
GLOBAL_opcount[_p_slr_y_vc] +
GLOBAL_opcount[_p_dif] +
GLOBAL_opcount[_p_eq] +
GLOBAL_opcount[_p_arg_vv] +
GLOBAL_opcount[_p_arg_cv] +
GLOBAL_opcount[_p_arg_y_vv] +
GLOBAL_opcount[_p_arg_y_cv] +
GLOBAL_opcount[_p_functor] +
GLOBAL_opcount[_p_func2s_vv] +
GLOBAL_opcount[_p_func2s_cv] +
GLOBAL_opcount[_p_func2s_vc] +
GLOBAL_opcount[_p_func2s_y_vv] +
GLOBAL_opcount[_p_func2s_y_cv] +
GLOBAL_opcount[_p_func2s_y_vc] +
GLOBAL_opcount[_p_func2f_xx] +
GLOBAL_opcount[_p_func2f_xy] +
GLOBAL_opcount[_p_func2f_yx] +
GLOBAL_opcount[_p_func2f_yy];
c_control.ncuts =
GLOBAL_opcount[_cut] +
GLOBAL_opcount[_cut_t] +
GLOBAL_opcount[_cut_e] +
GLOBAL_opcount[_commit_b_x] +
GLOBAL_opcount[_commit_b_y];
c_control.nallocs =
GLOBAL_opcount[_allocate] +
GLOBAL_opcount[_fcall];
c_control.ndeallocs =
GLOBAL_opcount[_dexecute] +
GLOBAL_opcount[_deallocate];
controls =
c_control.nexecs +
c_control.ncalls +
c_control.nproceeds +
c_control.ncuts +
c_control.nallocs +
c_control.ndeallocs +
GLOBAL_opcount[_jump] +
GLOBAL_opcount[_move_back] +
GLOBAL_opcount[_try_in];
c_cp.ntries =
GLOBAL_opcount[_try_me] +
GLOBAL_opcount[_try_and_mark] +
GLOBAL_opcount[_try_c] +
GLOBAL_opcount[_try_clause] +
GLOBAL_opcount[_either];
c_cp.nretries =
GLOBAL_opcount[_retry_me] +
GLOBAL_opcount[_retry_and_mark] +
GLOBAL_opcount[_retry_c] +
GLOBAL_opcount[_retry] +
GLOBAL_opcount[_or_else];
c_cp.ntrusts =
GLOBAL_opcount[_trust_me] +
GLOBAL_opcount[_trust] +
GLOBAL_opcount[_or_last];
choice_pts =
c_cp.ntries +
c_cp.nretries +
c_cp.ntrusts;
indexes =
GLOBAL_opcount[_jump_if_var] +
GLOBAL_opcount[_switch_on_type] +
GLOBAL_opcount[_switch_list_nl] +
GLOBAL_opcount[_switch_on_arg_type] +
GLOBAL_opcount[_switch_on_sub_arg_type] +
GLOBAL_opcount[_switch_on_cons] +
GLOBAL_opcount[_go_on_cons] +
GLOBAL_opcount[_if_cons] +
GLOBAL_opcount[_switch_on_func] +
GLOBAL_opcount[_go_on_func] +
GLOBAL_opcount[_if_func] +
GLOBAL_opcount[_if_not_then];
misc =
c_control.ncallbips +
GLOBAL_opcount[_Ystop] +
GLOBAL_opcount[_Nstop] +
GLOBAL_opcount[_index_pred] +
GLOBAL_opcount[_lock_pred] +
#if THREADS
GLOBAL_opcount[_thread_local] +
#endif
GLOBAL_opcount[_save_b_x] +
GLOBAL_opcount[_save_b_y] +
GLOBAL_opcount[_undef_p] +
GLOBAL_opcount[_spy_pred] +
GLOBAL_opcount[_spy_or_trymark] +
GLOBAL_opcount[_save_pair_x] +
GLOBAL_opcount[_save_pair_y] +
GLOBAL_opcount[_save_pair_x_write] +
GLOBAL_opcount[_save_pair_y_write] +
GLOBAL_opcount[_save_appl_x] +
GLOBAL_opcount[_save_appl_y] +
GLOBAL_opcount[_save_appl_x_write] +
GLOBAL_opcount[_save_appl_y_write];
total = gets + unifies + puts + writes + controls + choice_pts + indexes + misc;
/* for (i = 0; i <= _std_top; ++i)
* print_instruction(i);
*/
fprintf(GLOBAL_stderr, "Groups are\n\n");
fprintf(GLOBAL_stderr, " GET instructions: %8d (%3d%%)\n", gets,
(gets * 100) / total);
fprintf(GLOBAL_stderr, " UNIFY instructions: %8d (%3d%%)\n", unifies,
(unifies * 100) / total);
fprintf(GLOBAL_stderr, " PUT instructions: %8d (%3d%%)\n", puts,
(puts * 100) / total);
fprintf(GLOBAL_stderr, " WRITE instructions: %8d (%3d%%)\n", writes,
(writes * 100) / total);
fprintf(GLOBAL_stderr, " CONTROL instructions: %8d (%3d%%)\n", controls,
(controls * 100) / total);
fprintf(GLOBAL_stderr, " CHOICE POINT instructions: %8d (%3d%%)\n", choice_pts,
(choice_pts * 100) / total);
fprintf(GLOBAL_stderr, " INDEXING instructions: %8d (%3d%%)\n", indexes,
(indexes * 100) / total);
fprintf(GLOBAL_stderr, " MISCELLANEOUS instructions: %8d (%3d%%)\n", misc,
(misc * 100) / total);
fprintf(GLOBAL_stderr, "_______________________________________________\n");
fprintf(GLOBAL_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
(total * 100) / total);
fprintf(GLOBAL_stderr, "\n Analysis of Unification Instructions in %s \n", program);
fprintf(GLOBAL_stderr, " XVAR, YVAR, XVAL, YVAL, CONS, LIST, STRUCT\n");
fprintf(GLOBAL_stderr, " GET: %8d %8d %8d %8d %8d %8d %8d\n",
c_get.nxvar,
c_get.nyvar,
c_get.nxval,
c_get.nyval,
c_get.ncons,
c_get.nlist,
c_get.nstru);
fprintf(GLOBAL_stderr, "UNIFY: %8d %8d %8d %8d %8d %8d %8d\n",
c_unify.nxvar,
c_unify.nyvar,
c_unify.nxval,
c_unify.nyval,
c_unify.ncons,
c_unify.nlist,
c_unify.nstru);
fprintf(GLOBAL_stderr, " PUT: %8d %8d %8d %8d %8d %8d %8d\n",
c_put.nxvar,
c_put.nyvar,
c_put.nxval,
c_put.nyval,
c_put.ncons,
c_put.nlist,
c_put.nstru);
fprintf(GLOBAL_stderr, "WRITE: %8d %8d %8d %8d %8d %8d %8d\n",
c_write.nxvar,
c_write.nyvar,
c_write.nxval,
c_write.nyval,
c_write.ncons,
c_write.nlist,
c_write.nstru);
fprintf(GLOBAL_stderr, " ___________________________________________________\n");
fprintf(GLOBAL_stderr, "TOTAL: %8d %8d %8d %8d %8d %8d %8d\n",
c_get.nxvar + c_unify.nxvar + c_put.nxvar + c_write.nxvar,
c_get.nyvar + c_unify.nyvar + c_put.nyvar + c_write.nyvar,
c_get.nxval + c_unify.nxval + c_put.nxval + c_write.nxval,
c_get.nyval + c_unify.nyval + c_put.nyval + c_write.nyval,
c_get.ncons + c_unify.ncons + c_put.ncons + c_write.ncons,
c_get.nlist + c_unify.nlist + c_put.nlist + c_write.nlist,
c_get.nstru + c_unify.nstru + c_put.nstru + c_write.nstru
);
fprintf(GLOBAL_stderr, "\n Analysis of Unification Instructions in %s \n", program);
fprintf(GLOBAL_stderr, " XVAR, YVAR, XVAL, YVAL, CONS, LIST, STRUCT\n");
fprintf(GLOBAL_stderr, " GET: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_get.nxvar) * 100) / total,
(((double) c_get.nyvar) * 100) / total,
(((double) c_get.nxval) * 100) / total,
(((double) c_get.nyval) * 100) / total,
(((double) c_get.ncons) * 100) / total,
(((double) c_get.nlist) * 100) / total,
(((double) c_get.nstru) * 100) / total);
fprintf(GLOBAL_stderr, "UNIFY: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_unify.nxvar) * 100) / total,
(((double) c_unify.nyvar) * 100) / total,
(((double) c_unify.nxval) * 100) / total,
(((double) c_unify.nyval) * 100) / total,
(((double) c_unify.ncons) * 100) / total,
(((double) c_unify.nlist) * 100) / total,
(((double) c_unify.nstru) * 100) / total);
fprintf(GLOBAL_stderr, " PUT: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_put.nxvar) * 100) / total,
(((double) c_put.nyvar) * 100) / total,
(((double) c_put.nxval) * 100) / total,
(((double) c_put.nyval) * 100) / total,
(((double) c_put.ncons) * 100) / total,
(((double) c_put.nlist) * 100) / total,
(((double) c_put.nstru) * 100) / total);
fprintf(GLOBAL_stderr, "WRITE: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_write.nxvar) * 100) / total,
(((double) c_write.nyvar) * 100) / total,
(((double) c_write.nxval) * 100) / total,
(((double) c_write.nyval) * 100) / total,
(((double) c_write.ncons) * 100) / total,
(((double) c_write.nlist) * 100) / total,
(((double) c_write.nstru) * 100) / total);
fprintf(GLOBAL_stderr, " ___________________________________________________\n");
fprintf(GLOBAL_stderr, "TOTAL: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_get.nxvar + c_unify.nxvar + c_put.nxvar + c_write.nxvar) * 100) / total,
(((double) c_get.nyvar + c_unify.nyvar + c_put.nyvar + c_write.nyvar) * 100) / total,
(((double) c_get.nxval + c_unify.nxval + c_put.nxval + c_write.nxval) * 100) / total,
(((double) c_get.nyval + c_unify.nyval + c_put.nyval + c_write.nyval) * 100) / total,
(((double) c_get.ncons + c_unify.ncons + c_put.ncons + c_write.ncons) * 100) / total,
(((double) c_get.nlist + c_unify.nlist + c_put.nlist + c_write.nlist) * 100) / total,
(((double) c_get.nstru + c_unify.nstru + c_put.nstru + c_write.nstru) * 100) / total
);
fprintf(GLOBAL_stderr, "\n Control Instructions Executed in %s \n", program);
fprintf(GLOBAL_stderr, "Grouped as\n\n");
fprintf(GLOBAL_stderr, " CALL instructions: %8d (%3d%%)\n",
c_control.ncalls, (c_control.ncalls * 100) / total);
fprintf(GLOBAL_stderr, " PROCEED instructions: %8d (%3d%%)\n",
c_control.nproceeds, (c_control.nproceeds * 100) / total);
fprintf(GLOBAL_stderr, " EXECUTE instructions: %8d (%3d%%)\n",
c_control.nexecs, (c_control.nexecs * 100) / total);
fprintf(GLOBAL_stderr, " CUT instructions: %8d (%3d%%)\n",
c_control.ncuts, (c_control.ncuts * 100) / total);
fprintf(GLOBAL_stderr, " CALL_BIP instructions: %8d (%3d%%)\n",
c_control.ncallbips, (c_control.ncallbips * 100) / total);
fprintf(GLOBAL_stderr, " ALLOCATE instructions: %8d (%3d%%)\n",
c_control.nallocs, (c_control.nallocs * 100) / total);
fprintf(GLOBAL_stderr, " DEALLOCATE instructions: %8d (%3d%%)\n",
c_control.ndeallocs, (c_control.ndeallocs * 100) / total);
fprintf(GLOBAL_stderr, "_______________________________________________\n");
fprintf(GLOBAL_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
(total * 100) / total);
fprintf(GLOBAL_stderr, "\n Choice Point Manipulation Instructions Executed in %s \n", program);
fprintf(GLOBAL_stderr, "Grouped as\n\n");
fprintf(GLOBAL_stderr, " TRY instructions: %8d (%3d%%)\n",
c_cp.ntries, (c_cp.ntries * 100) / total);
fprintf(GLOBAL_stderr, " RETRY instructions: %8d (%3d%%)\n",
c_cp.nretries, (c_cp.nretries * 100) / total);
fprintf(GLOBAL_stderr, " TRUST instructions: %8d (%3d%%)\n",
c_cp.ntrusts, (c_cp.ntrusts * 100) / total);
fprintf(GLOBAL_stderr, "_______________________________________________\n");
fprintf(GLOBAL_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
(total * 100) / total);
return TRUE;
}
static Int
p_show_sequences(void)
{
int i, j;
YAP_ULONG_LONG min;
YAP_ULONG_LONG sum = 0;
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "shows_sequences/1");
return FALSE;
}
if (!IsIntegerTerm(t)) {
Yap_Error(TYPE_ERROR_INTEGER, t, "shows_sequences/1");
return FALSE;
}
min = (YAP_ULONG_LONG)IntegerOfTerm(t);
if (min <= 0) {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "shows_sequences/1");
return FALSE;
}
if (min <= 0) {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "shows_sequences/1");
return FALSE;
}
for (i = 0; i <= _std_top; ++i) {
sum += GLOBAL_opcount[i];
}
for (i = 0; i <= _std_top; ++i) {
for (j = 0; j <= _std_top; ++j) {
YAP_ULONG_LONG seqs = Yap_2opcount[i][j];
if (seqs && sum/seqs <= min) {
/*
Term t[3], t0;
Functor f =
t[0] = Yap_MkFloatTerm(((double)seqs*100.0)/sum);
t[1] = Yap_LookupAtom(Yap_op_names[i]);
t[2] = Yap_LookupAtom(Yap_op_names[j]);
t0 = MkApplTerm(
Yap_MkPairTerm(Yap_op_names[i]
*/
fprintf(stderr,"%f -> %s,%s\n",((double)seqs*100.0)/sum,Yap_op_names[i],Yap_op_names[j]);
/* we found one */
}
}
}
return TRUE;
}
void
Yap_InitAnalystPreds(void)
{
Yap_InitCPred("wam_profiler_reset_op_counters", 0, p_reset_op_counters, SafePredFlag |SyncPredFlag);
/** @pred wam_profiler_reset_op_counters
Reinitialize all counters.
*/
Yap_InitCPred("wam_profiler_show_op_counters", 1, p_show_op_counters, SafePredFlag|SyncPredFlag);
/** @pred wam_profiler_show_op_counters(+ _A_)
Display the current value for the counters, using label _A_. The
label must be an atom.
*/
Yap_InitCPred("wam_profiler_show_ops_by_group", 1, p_show_ops_by_group, SafePredFlag |SyncPredFlag);
/** @pred wam_profiler_show_ops_by_group(+ _A_)
Display the current value for the counters, organized by groups, using
label _A_. The label must be an atom.
*/
Yap_InitCPred("wam_profiler_show_sequences", 1, p_show_sequences, SafePredFlag |SyncPredFlag);
}
#endif /* ANALYST */

228
dev/yap-6.3/C/args.c Normal file
View File

@ -0,0 +1,228 @@
#include "Yap.h"
#include "Yatom.h"
/**
* Scan a list of arguments and output results to a pre-processed vector.
*
* @param listl: input list
* @param def parameter definition
*
* @return all arguments, some of them set, some of them not.
*/
static xarg *
matchKey(Atom key, xarg *e0, int n, const param_t *def)
{
int i;
for (i=0; i< n; i++) {
if (!strcmp((char *)def->name, (char *)RepAtom(key)->StrOfAE)) {
return e0;
}
def++;
e0++;
}
return NULL;
}
/**
* Returns the index of an argument key, or -1 if not found.
*
*/
int
Yap_ArgKey(Atom key, const param_t *def, int n)
{
int i;
for (i=0; i< n; i++) {
if (!strcmp((char *)def->name, (char *)RepAtom(key)->StrOfAE)) {
return i;
}
def++;
}
return -1;
}
static xarg *
failed( yap_error_number e, Term t, xarg *a)
{
free( a );
LOCAL_Error_TYPE = e;
LOCAL_Error_Term = t;
return NULL;
}
xarg *
Yap_ArgListToVector (Term listl, const param_t *def, int n)
{
CACHE_REGS
xarg *a = calloc( n , sizeof(xarg) );
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (IsApplTerm(listl) && FunctorOfTerm(listl) == FunctorModule)
listl = ArgOfTerm(2,listl);
if (!IsPairTerm(listl) && listl != TermNil) {
if (IsVarTerm(listl) ) {
return failed( INSTANTIATION_ERROR, listl, a);
}
if (IsAtomTerm(listl) ) {
xarg *na = matchKey( AtomOfTerm(listl), a, n, def);
if (!na) {
return failed( TYPE_ERROR_LIST, listl, a);
}
} else if (IsApplTerm(listl)) {
Functor f = FunctorOfTerm( listl );
if (IsExtensionFunctor(f)) {
return failed( TYPE_ERROR_LIST, listl, a);
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
return failed( TYPE_ERROR_LIST, listl, a);
}
xarg *na = matchKey( NameOfFunctor( f ), a, n, def);
if (!na) {
return failed( TYPE_ERROR_LIST, listl, a);
}
} else {
return failed( TYPE_ERROR_LIST, listl, a);
}
listl = MkPairTerm( listl, TermNil );
}
while (IsPairTerm(listl)) {
Term hd = HeadOfTerm( listl );
listl = TailOfTerm( listl );
if (IsVarTerm(hd) || IsVarTerm(listl)) {
if (IsVarTerm(hd)) {
return failed( INSTANTIATION_ERROR, hd, a);
} else {
return failed( INSTANTIATION_ERROR, listl, a);
}
}
if (IsAtomTerm(hd)) {
xarg *na = matchKey( AtomOfTerm( hd ), a, n, def);
if (!na)
return failed( DOMAIN_ERROR, hd, a);
na->used = true;
na->tvalue = TermNil;
continue;
} else if (IsApplTerm( hd )) {
Functor f = FunctorOfTerm( hd );
if (IsExtensionFunctor(f)) {
return failed( TYPE_ERROR_PARAMETER, hd, a);
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
return failed( DOMAIN_ERROR_OUT_OF_RANGE, hd, a);
}
xarg *na = matchKey( NameOfFunctor( f ), a, n, def);
if (!na) {
return failed( DOMAIN_ERROR, hd, a);
}
na->used = 1;
na->tvalue = ArgOfTerm(1, hd);
} else {
return failed( TYPE_ERROR_PARAMETER, hd, a);
}
}
if (IsVarTerm(listl)) {
return failed( INSTANTIATION_ERROR, listl, a);
} else if (listl != TermNil) {
return failed( TYPE_ERROR_LIST, listl, a);
}
return a;
}
static xarg *
matchKey2(Atom key, xarg *e0, int n, const param2_t *def)
{
int i;
for (i=0; i< n; i++) {
if (!strcmp((char*)def->name, (char*)RepAtom(key)->StrOfAE)) {
return e0;
}
def++;
e0++;
}
return NULL;
}
/// Yap_ArgList2ToVector is much the same as before,
/// but assumes parameters also have something called a
/// scope
xarg *
Yap_ArgList2ToVector (Term listl, const param2_t *def, int n)
{
CACHE_REGS
xarg *a = calloc( n , sizeof(xarg) );
if (!IsPairTerm(listl) && listl != TermNil) {
if (IsVarTerm(listl) ) {
return failed( INSTANTIATION_ERROR, listl, a);
}
if (IsAtomTerm(listl) ) {
xarg *na = matchKey2( AtomOfTerm(listl), a, n, def);
if (!na) {
return failed( DOMAIN_ERROR, listl, a);
}
}
if (IsApplTerm(listl)) {
Functor f = FunctorOfTerm( listl );
if (IsExtensionFunctor(f)) {
return failed( TYPE_ERROR_PARAMETER, listl, a);
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
return failed( TYPE_ERROR_LIST, listl, a);
}
xarg *na = matchKey2( NameOfFunctor( f ), a, n, def);
if (!na) {
return failed( DOMAIN_ERROR, listl, a);
}
} else {
return failed( TYPE_ERROR_LIST, listl, a);
}
listl = MkPairTerm( listl, TermNil );
}
while (IsPairTerm(listl)) {
Term hd = HeadOfTerm( listl );
if (IsVarTerm(hd)) {
return failed( INSTANTIATION_ERROR, hd, a);
}
if (IsAtomTerm(hd)) {
xarg *na = matchKey2( AtomOfTerm( hd ), a, n, def);
if (!na) {
return failed( DOMAIN_ERROR, hd, a);
}
na->used = true;
na->tvalue = TermNil;
continue;
} else if (IsApplTerm( hd )) {
Functor f = FunctorOfTerm( hd );
if (IsExtensionFunctor(f)) {
return failed( TYPE_ERROR_PARAMETER, hd, a);
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
return failed( DOMAIN_ERROR, hd, a);
}
xarg *na = matchKey2( NameOfFunctor( f ), a, n, def);
if (na) {
na->used = 1;
na->tvalue = ArgOfTerm(1, hd);
} else {
return failed( DOMAIN_ERROR, hd, a);
}
} else {
return failed( INSTANTIATION_ERROR, hd, a);
}
listl = TailOfTerm(listl);
}
if (IsVarTerm(listl)) {
return failed( INSTANTIATION_ERROR, listl, a);
}
if (TermNil != listl) {
return failed( TYPE_ERROR_LIST, listl, a);
}
return a;
}

294
dev/yap-6.3/C/arith0.c Normal file
View File

@ -0,0 +1,294 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: eval.c *
* Last rev: *
* mods: *
* comments: arithmetical expression evaluation *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/**
@file arith0.c
*/
//! @{
/**
@defgroup arithmetic_operators Arithmetic Functions
@ingroup arithmetic
YAP implements several arithmetic functions, they are defined as
fields in three enumerations, such that there is one enumeration
per each different arity:
- #arith0_op defines constants and arity 0 arithmetic functions
@copydoc #arith0_op
- #arith1_op defines single argument arithmetic functions
@copydoc #arith1_op
- #arith2_op defines binary arithmetic functions
@copydoc #arith2_op
Arithmetic expressions
in YAP may use the following operators:
- <b>pi [ISO]</b><p> @anchor pi_0
An approximation to the value of <em>pi</em>, that is, the ratio of a circle's circumference to its diameter.
- <b>e</b><p> @anchor e_0
Euler's number, the base of the natural logarithms.
- <b>epsilon</b><p> @anchor epsilon_0
The difference between the float `1.0` and the next largest floating point number.
- <b>inf</b><p> @anchor inf_0
Infinity according to the IEEE Floating-Point standard. Note that evaluating this term will generate a domain error in the `iso` language mode.
Note also that YAP supports `+inf` and `-inf`
- <b>nan (not a number)</b><p> @anchor nan_0
Not-a-number according to the IEEE Floating-Point standard. Note that evaluating this term will generate a domain error in the `iso` language mode.
- <b>random</b><p> @anchor random_0
A "random" floating point number between 0 and 1.
- <b>cputime</b><p> @anchor cputime_0
CPU time since YAP was invoked, in seconds.
- <b>heapused</b><p> @anchor heapused_0
Heap (data-base) space used, in bytes.
- <b>local</b><p> @anchor local_0
Local stack in use, in bytes
- <b>$b</b><p> @anchor b_0
current choicepoint
- <b>$env</b><p> @anchor env_0
Environment
- <b>$tr</b><p> @anchor tr_0
Trail in use
- <b>$free_stack</b><p> @anchor free_stack_0
Amount of free stack space, that is, free space between global and local stacks.
- <b>global</b><p> @anchor global_0
Global stack in use, in bytes.
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "eval.h"
static Term
eval0(Int fi) {
CACHE_REGS
arith0_op fop = fi;
switch (fop) {
case op_pi:
{
RFLOAT(PI);
}
case op_e:
{
RFLOAT(M_E);
}
case op_epsilon:
{
RFLOAT(DBL_EPSILON);
}
case op_inf:
{
#ifdef _MSC_VER /* Microsoft's Visual C++ Compiler */
Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
P = (yamop *)FAILCODE;
RERROR();
#else
if (isoLanguageFlag()) {/* iso */
Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(INFINITY);
}
#endif
}
case op_nan:
{
#ifdef _MSC_VER /* Microsoft's Visual C++ Compi<ler */
Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
RERROR();
#else
if (isoLanguageFlag()) {/* iso */
Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil, "evaluating not-a-number");
RERROR();
} else {
RFLOAT(NAN);
}
#endif
}
case op_random:
{
RFLOAT(Yap_random());
}
case op_cputime:
{
RFLOAT((Float)Yap_cputime()/1000.0);
}
case op_heapused:
/// - heapused
/// Heap (data-base) space used, in bytes.
///
RINT(HeapUsed);
case op_localsp:
/// - local
/// Local stack in use, in bytes
///
#if YAPOR_SBA
RINT((Int)ASP);
#else
RINT(LCL0 - ASP);
#endif
case op_b:
/// - $b
/// current choicepoint
///
#if YAPOR_SBA
RINT((Int)B);
#else
RINT(LCL0 - (CELL *)B);
#endif
case op_env:
/// - $env
/// Environment
///
#if YAPOR_SBA
RINT((Int)YENV);
#else
RINT(LCL0 - YENV);
#endif
case op_tr:
/// - $tr
/// Trail in use
///
#if YAPOR_SBA
RINT(TR);
#else
RINT(((CELL *)TR)-LCL0);
#endif
case op_stackfree:
/// - $free_stack
///
/// Not-a-number according to the IEEE Floating-Point standard. Note that evaluating this term will generate a domain error in the `iso` language mode.
RINT(Unsigned(ASP) - Unsigned(HR));
case op_globalsp:
/// - global
/// Global stack in use, in bytes.
///
#if YAPOR_SBA
RINT((Int)HR);
#else
RINT(HR - H0);
#endif
}
/// end of switch
RERROR();
}
Term Yap_eval_atom(Int f)
{
return eval0(f);
}
typedef struct init_const_eval {
char *OpName;
arith0_op f;
} InitConstEntry;
static InitConstEntry InitConstTab[] = {
{"pi", op_pi},
{"e", op_e},
{"epsilon", op_epsilon},
{"inf", op_inf},
{"nan", op_nan},
{"random", op_random},
{"cputime", op_cputime},
{"heapused", op_heapused},
{"local_sp", op_localsp},
{"global_sp", op_globalsp},
{"$last_choice_pt", op_b},
{"$env", op_env},
{"$tr", op_tr},
{"stackfree", op_stackfree},
};
void
Yap_InitConstExps(void)
{
unsigned int i;
ExpEntry *p;
for (i = 0; i < sizeof(InitConstTab)/sizeof(InitConstEntry); ++i) {
AtomEntry *ae = RepAtom(Yap_LookupAtom(InitConstTab[i].OpName));
if (ae == NULL) {
Yap_EvalError(RESOURCE_ERROR_HEAP,TermNil,"at InitConstExps");
return;
}
WRITE_LOCK(ae->ARWLock);
if (Yap_GetExpPropHavingLock(ae, 0)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
p = (ExpEntry *) Yap_AllocAtomSpace(sizeof(ExpEntry));
p->KindOfPE = ExpProperty;
p->ArityOfEE = 0;
p->ENoOfEE = 0;
p->FOfEE = InitConstTab[i].f;
AddPropToAtom(ae, (PropEntry *)p);
WRITE_UNLOCK(ae->ARWLock);
}
}
/* This routine is called from Restore to make sure we have the same arithmetic operators */
int
Yap_ReInitConstExps(void)
{
return TRUE;
}
/// @}

1078
dev/yap-6.3/C/arith1.c Normal file
View File

File diff suppressed because it is too large Load Diff

1379
dev/yap-6.3/C/arith2.c Normal file
View File

File diff suppressed because it is too large Load Diff

2681
dev/yap-6.3/C/arrays.c Normal file
View File

File diff suppressed because it is too large Load Diff

2435
dev/yap-6.3/C/atomic.c Normal file
View File

File diff suppressed because it is too large Load Diff

1043
dev/yap-6.3/C/attvar.c Normal file
View File

File diff suppressed because it is too large Load Diff

435
dev/yap-6.3/C/bb.c Normal file
View File

@ -0,0 +1,435 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: bb.c *
* Last rev: 12/29/99 *
* mods: *
* comments: YAP's blackboard routines *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/** @defgroup BlackBoard The Blackboard
@ingroup builtins
@{
YAP implements a blackboard in the style of the SICStus Prolog
blackboard. The blackboard uses the same underlying mechanism as the
internal data-base but has several important differences:
+ It is module aware, in contrast to the internal data-base.
+ Keys can only be atoms or integers, and not compound terms.
+ A single term can be stored per key.
+ An atomic update operation is provided; this is useful for
parallelism.
*/
#include "Yap.h"
#include "clause.h"
#ifndef NULL
#define NULL (void *)0
#endif
static BBProp
PutBBProp(AtomEntry *ae, Term mod USES_REGS) /* get BBentry for at; */
{
Prop p0;
BBProp p;
WRITE_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropsOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
p = (BBProp)Yap_AllocAtomSpace(sizeof(*p));
if (p == NULL) {
WRITE_UNLOCK(ae->ARWLock);
Yap_Error(RESOURCE_ERROR_HEAP,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
AddPropToAtom(ae, (PropEntry *)p);
p->ModuleOfBB = mod;
p->Element = 0L;
p->KeyOfBB = AbsAtom(ae);
p->KindOfPE = BBProperty;
INIT_RWLOCK(p->BBRWLock);
}
WRITE_UNLOCK(ae->ARWLock);
return (p);
}
static BBProp
PutIntBBProp(Int key, Term mod USES_REGS) /* get BBentry for at; */
{
Prop p0;
BBProp p;
UInt hash_key;
if (INT_BB_KEYS == NULL) {
INT_BB_KEYS = (Prop *)Yap_AllocCodeSpace(sizeof(Prop)*INT_BB_KEYS_SIZE);
if (INT_BB_KEYS != NULL) {
UInt i = 0;
Prop *pp = INT_BB_KEYS;
for (i = 0; i < INT_BB_KEYS_SIZE; i++) {
pp[0] = NIL;
pp++;
}
} else {
Yap_Error(RESOURCE_ERROR_HEAP,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
}
hash_key = (CELL)key % INT_BB_KEYS_SIZE;
p0 = INT_BB_KEYS[hash_key];
p = RepBBProp(p0);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
key != (Int)(p->KeyOfBB) ||
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
YAPEnterCriticalSection();
p = (BBProp)Yap_AllocAtomSpace(sizeof(*p));
if (p == NULL) {
YAPLeaveCriticalSection();
Yap_Error(RESOURCE_ERROR_HEAP,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
p->ModuleOfBB = mod;
p->Element = 0L;
p->KeyOfBB = (Atom)key;
p->KindOfPE = BBProperty;
p->NextOfPE = INT_BB_KEYS[hash_key];
INT_BB_KEYS[hash_key] = AbsBBProp(p);
YAPLeaveCriticalSection();
}
return (p);
}
static BBProp
GetBBProp(AtomEntry *ae, Term mod) /* get BBentry for at; */
{
Prop p0;
BBProp p;
READ_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropsOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
READ_UNLOCK(ae->ARWLock);
if (p0 == NIL) {
return(NULL);
}
return (p);
}
static BBProp
GetIntBBProp(Int key, Term mod) /* get BBentry for at; */
{
Prop p0;
BBProp p;
UInt hash_key;
if (INT_BB_KEYS == NULL)
return(NULL);
hash_key = (CELL)key % INT_BB_KEYS_SIZE;
p0 = INT_BB_KEYS[hash_key];
p = RepBBProp(p0);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
key != (Int)(p->KeyOfBB) ||
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
return(NULL);
}
return (p);
}
static int
resize_bb_int_keys(UInt new_size) {
CACHE_REGS
Prop *new;
UInt i;
YAPEnterCriticalSection();
if (INT_BB_KEYS == NULL) {
INT_BB_KEYS_SIZE = new_size;
YAPLeaveCriticalSection();
return(TRUE);
}
new = (Prop *)Yap_AllocCodeSpace(sizeof(Prop)*new_size);
if (new == NULL) {
YAPLeaveCriticalSection();
Yap_Error(RESOURCE_ERROR_HEAP,ARG1,"could not allocate space");
return(FALSE);
}
for (i = 0; i < new_size; i++) {
new[i] = NIL;
}
for (i = 0; i < INT_BB_KEYS_SIZE; i++) {
if (INT_BB_KEYS[i] != NIL) {
Prop p0 = INT_BB_KEYS[i];
while (p0 != NIL) {
BBProp p = RepBBProp(p0);
CELL key = (CELL)(p->KeyOfBB);
UInt hash_key = (CELL)key % new_size;
p0 = p->NextOfPE;
p->NextOfPE = new[hash_key];
new[hash_key] = AbsBBProp(p);
}
}
}
Yap_FreeCodeSpace((char *)INT_BB_KEYS);
INT_BB_KEYS = new;
INT_BB_KEYS_SIZE = new_size;
YAPLeaveCriticalSection();
return(TRUE);
}
static BBProp
AddBBProp(Term t1, char *msg, Term mod USES_REGS)
{
BBProp p;
restart:
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, msg);
return(NULL);
} if (IsAtomTerm(t1)) {
p = PutBBProp(RepAtom(AtomOfTerm(t1)), mod PASS_REGS);
} else if (IsIntegerTerm(t1)) {
p = PutIntBBProp(IntegerOfTerm(t1), mod PASS_REGS);
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term tmod = ArgOfTerm(1, t1);
if (!IsVarTerm(tmod) ) {
t1 = ArgOfTerm(2, t1);
mod = tmod;
goto restart;
} else {
Yap_Error(INSTANTIATION_ERROR, t1, msg);
return(NULL);
}
} else {
Yap_Error(TYPE_ERROR_ATOM, t1, msg);
return(NULL);
}
return(p);
}
static BBProp
FetchBBProp(Term t1, char *msg, Term mod)
{
BBProp p;
restart:
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, msg);
return(NULL);
} if (IsAtomTerm(t1)) {
p = GetBBProp(RepAtom(AtomOfTerm(t1)), mod);
} else if (IsIntegerTerm(t1)) {
p = GetIntBBProp(IntegerOfTerm(t1), mod);
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term tmod = ArgOfTerm(1, t1);
if (!IsVarTerm(tmod) ) {
mod = tmod;
t1 = ArgOfTerm(2, t1);
goto restart;
} else {
Yap_Error(INSTANTIATION_ERROR, t1, msg);
return(NULL);
}
} else {
Yap_Error(TYPE_ERROR_ATOM, t1, msg);
return(NULL);
}
return(p);
}
static Term
BBPut(Term t0, Term t2)
{
if (!IsVarTerm(t0) && IsApplTerm(t0)) {
Yap_ErLogUpdCl((LogUpdClause *)DBRefOfTerm(t0));
}
if (IsVarTerm(t2) || IsAtomOrIntTerm(t2)) {
return t2;
} else {
LogUpdClause *cl = Yap_new_ludbe(t2, NULL, 0);
if (cl == NULL) {
return 0L;
}
return MkDBRefTerm((DBRef)cl);
}
}
/** @pred bb_put(+ _Key_,? _Term_)
Store term table _Term_ in the blackboard under key _Key_. If a
previous term was stored under key _Key_ it is simply forgotten.
*/
static Int
p_bb_put( USES_REGS1 )
{
Term t1 = Deref(ARG1);
BBProp p = AddBBProp(t1, "bb_put/2", CurrentModule PASS_REGS);
if (p == NULL) {
return(FALSE);
}
WRITE_LOCK(p->BBRWLock);
/*
if (p->Element)
fprintf(stderr,"putting %p, size %d\n", p, p->Element->NOfCells);
*/
p->Element = BBPut(p->Element, Deref(ARG2));
WRITE_UNLOCK(p->BBRWLock);
return (p->Element != 0L);
}
static Term
BBGet(Term t, UInt arity USES_REGS)
{
if (IsVarTerm(t)) {
return MkVarTerm();
} else if (IsAtomOrIntTerm(t)) {
return t;
} else {
return Yap_LUInstance((LogUpdClause *)DBRefOfTerm(t), arity);
}
}
/** @pred bb_get(+ _Key_,? _Term_)
Unify _Term_ with a term stored in the blackboard under key
_Key_, or fail silently if no such term exists.
*/
static Int
p_bb_get( USES_REGS1 )
{
Term t1 = Deref(ARG1);
BBProp p = FetchBBProp(t1, "bb_get/2", CurrentModule);
Term out, t0;
if (p == NULL || p->Element == 0L)
return(FALSE);
READ_LOCK(p->BBRWLock);
/*
if (p->Element)
fprintf(stderr,"getting %p, size %d\n", p, p->Element->NOfCells);
*/
t0 = p->Element;
READ_UNLOCK(p->BBRWLock);
out = BBGet(t0, 2 PASS_REGS);
return Yap_unify(ARG2,out);
}
/** @pred bb_delete(+ _Key_,? _Term_)
Delete any term stored in the blackboard under key _Key_ and unify
it with _Term_. Fail silently if no such term exists.
*/
static Int
p_bb_delete( USES_REGS1 )
{
Term t1 = Deref(ARG1);
BBProp p;
Term out;
p = FetchBBProp(t1, "bb_delete/2", CurrentModule);
if (p == NULL || p->Element == 0L)
return(FALSE);
WRITE_LOCK(p->BBRWLock);
out = BBGet(p->Element, 2 PASS_REGS);
if (!IsVarTerm(p->Element) && IsApplTerm(p->Element)) {
Yap_ErLogUpdCl((LogUpdClause *)DBRefOfTerm(p->Element));
}
p->Element = 0L;
WRITE_UNLOCK(p->BBRWLock);
return Yap_unify(ARG2,out);
}
/** @pred bb_update( +_Key_, ?_Term_, ?_New_)
Atomically unify a term stored in the blackboard under key _Key_
with _Term_, and if the unification succeeds replace it by
_New_. Fail silently if no such term exists or if unification fails.
*/
static Int
p_bb_update( USES_REGS1 )
{
Term t1 = Deref(ARG1);
BBProp p;
Term out;
p = FetchBBProp(t1, "bb_update/3", CurrentModule);
if (p == NULL || p->Element == 0L)
return FALSE;
WRITE_LOCK(p->BBRWLock);
out = BBGet(p->Element, 3 PASS_REGS);
if (!Yap_unify(out,ARG2)) {
WRITE_UNLOCK(p->BBRWLock);
return FALSE;
}
p->Element = BBPut(p->Element, Deref(ARG3));
WRITE_UNLOCK(p->BBRWLock);
return (p->Element != 0L);
}
static Int
p_resize_bb_int_keys( USES_REGS1 )
{
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
return(Yap_unify(ARG1,MkIntegerTerm((Int)INT_BB_KEYS_SIZE)));
}
if (!IsIntegerTerm(t1)) {
Yap_Error(TYPE_ERROR_INTEGER, t1, "yap_flag(resize_bb_int_keys,T)");
return(FALSE);
}
return(resize_bb_int_keys(IntegerOfTerm(t1)));
}
void
Yap_InitBBPreds(void)
{
Yap_InitCPred("bb_put", 2, p_bb_put, 0);
Yap_InitCPred("bb_get", 2, p_bb_get, 0);
Yap_InitCPred("bb_delete", 2, p_bb_delete, 0);
Yap_InitCPred("bb_update", 3, p_bb_update, 0);
Yap_InitCPred("$resize_bb_int_keys", 1, p_resize_bb_int_keys, SafePredFlag|SyncPredFlag);
}
/**
@}
*/

571
dev/yap-6.3/C/bignum.c Normal file
View File

@ -0,0 +1,571 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: arith1.c *
* Last rev: *
* mods: *
* comments: bignum support through gmp *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#include "YapHeap.h"
#include "YapText.h"
#ifdef USE_GMP
#include "eval.h"
#include "alloc.h"
Term
Yap_MkBigIntTerm(MP_INT *big)
{
CACHE_REGS
Int nlimbs;
MP_INT *dst = (MP_INT *)(HR+2);
CELL *ret = HR;
Int bytes;
if (mpz_fits_slong_p(big)) {
long int out = mpz_get_si(big);
return MkIntegerTerm((Int)out);
}
// bytes = big->_mp_alloc * sizeof(mp_limb_t);
// nlimbs = ALIGN_YAPTYPE(bytes,CELL)/CellSize;
// this works, but it shouldn't need to do this...
nlimbs = big->_mp_alloc;
bytes = nlimbs*sizeof(CELL);
if (nlimbs > (ASP-ret)-1024) {
return TermNil;
}
HR[0] = (CELL)FunctorBigInt;
HR[1] = BIG_INT;
dst->_mp_size = big->_mp_size;
dst->_mp_alloc = nlimbs*(CellSize/sizeof(mp_limb_t));
memmove((void *)(dst+1), (const void *)(big->_mp_d), bytes);
HR = (CELL *)(dst+1)+nlimbs;
HR[0] = EndSpecials;
HR++;
return AbsAppl(ret);
}
MP_INT *
Yap_BigIntOfTerm(Term t)
{
MP_INT *new = (MP_INT *)(RepAppl(t)+2);
new->_mp_d = (mp_limb_t *)(new+1);
return(new);
}
Term
Yap_MkBigRatTerm(MP_RAT *big)
{
CACHE_REGS
Int nlimbs;
MP_INT *dst = (MP_INT *)(HR+2);
MP_INT *num = mpq_numref(big);
MP_INT *den = mpq_denref(big);
MP_RAT *rat;
CELL *ret = HR;
if (mpz_cmp_si(den, 1) == 0)
return Yap_MkBigIntTerm(num);
if ((num->_mp_alloc+den->_mp_alloc)*(sizeof(mp_limb_t)/CellSize) > (ASP-ret)-1024) {
return TermNil;
}
HR[0] = (CELL)FunctorBigInt;
HR[1] = BIG_RATIONAL;
dst->_mp_size = 0;
rat = (MP_RAT *)(dst+1);
rat->_mp_num._mp_size = num->_mp_size;
rat->_mp_num._mp_alloc = num->_mp_alloc;
nlimbs = (num->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
memmove((void *)(rat+1), (const void *)(num->_mp_d), nlimbs*CellSize);
rat->_mp_den._mp_size = den->_mp_size;
rat->_mp_den._mp_alloc = den->_mp_alloc;
HR = (CELL *)(rat+1)+nlimbs;
nlimbs = (den->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
memmove((void *)(HR), (const void *)(den->_mp_d), nlimbs*CellSize);
HR += nlimbs;
dst->_mp_alloc = (HR-(CELL *)(dst+1));
HR[0] = EndSpecials;
HR++;
return AbsAppl(ret);
}
MP_RAT *
Yap_BigRatOfTerm(Term t)
{
MP_RAT *new = (MP_RAT *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
mp_limb_t *nt;
nt = new->_mp_num._mp_d = (mp_limb_t *)(new+1);
nt += new->_mp_num._mp_alloc;
new->_mp_den._mp_d = nt;
return new;
}
Term
Yap_RatTermToApplTerm(Term t)
{
Term ts[2];
MP_RAT *rat = Yap_BigRatOfTerm(t);
ts[0] = Yap_MkBigIntTerm(mpq_numref(rat));
ts[1] = Yap_MkBigIntTerm(mpq_denref(rat));
return Yap_MkApplTerm(FunctorRDiv,2,ts);
}
#endif
Term
Yap_AllocExternalDataInStack(CELL tag, size_t bytes)
{
CACHE_REGS
Int nlimbs;
MP_INT *dst = (MP_INT *)(HR+2);
CELL *ret = HR;
nlimbs = ALIGN_BY_TYPE(bytes,CELL)/CellSize;
if (nlimbs > (ASP-ret)-1024) {
return TermNil;
}
HR[0] = (CELL)FunctorBigInt;
HR[1] = tag;
dst->_mp_size = 0;
dst->_mp_alloc = nlimbs;
HR = (CELL *)(dst+1)+nlimbs;
HR[0] = EndSpecials;
HR++;
if (tag != EXTERNAL_BLOB) {
TrailTerm(TR) = AbsPair(ret);
TR++;
}
return AbsAppl(ret);
}
int Yap_CleanOpaqueVariable(CELL *pt)
{
CELL blob_info, blob_tag;
MP_INT *blobp;
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
blob_tag = pt[1];
if (blob_tag < USER_BLOB_START ||
blob_tag >= USER_BLOB_END) {
Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt), "clean opaque: bad blob with tag " UInt_FORMAT ,blob_tag);
return FALSE;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers)
return FALSE;
blobp = (MP_INT *)(pt+2);
if (!GLOBAL_OpaqueHandlers[blob_info].fail_handler)
return TRUE;
return (GLOBAL_OpaqueHandlers[blob_info].fail_handler)((void *)(blobp+1));
}
Opaque_CallOnWrite
Yap_blob_write_handler(Term t)
{
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
blob_tag = pt[1];
if (blob_tag < USER_BLOB_START ||
blob_tag >= USER_BLOB_END) {
Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt), "clean opaque: bad blob with tag " UInt_FORMAT ,blob_tag);
return FALSE;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers) {
return NULL;
}
return GLOBAL_OpaqueHandlers[blob_info].write_handler;
}
Opaque_CallOnGCMark
Yap_blob_gc_mark_handler(Term t)
{
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
blob_tag = pt[1];
if (blob_tag < USER_BLOB_START ||
blob_tag >= USER_BLOB_END) {
return NULL;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers)
return NULL;
return GLOBAL_OpaqueHandlers[blob_info].gc_mark_handler;
}
Opaque_CallOnGCRelocate
Yap_blob_gc_relocate_handler(Term t)
{
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
blob_tag = pt[1];
if (blob_tag < USER_BLOB_START ||
blob_tag >= USER_BLOB_END) {
Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt), "clean opaque: bad blob with tag " UInt_FORMAT ,blob_tag);
return FALSE;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers)
return NULL;
return GLOBAL_OpaqueHandlers[blob_info].gc_relocate_handler;
}
extern Int Yap_blob_tag(Term t)
{
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
return pt[1];
}
void *
Yap_blob_info(Term t)
{
MP_INT *blobp;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
if (!GLOBAL_OpaqueHandlers)
return FALSE;
blobp = (MP_INT *)(pt+2);
return (void *)(blobp+1);
}
Term
Yap_MkULLIntTerm(YAP_ULONG_LONG n)
{
#if __GNUC__ && USE_GMP
mpz_t new;
char tmp[256];
Term t;
#ifdef _WIN32
snprintf(tmp,256,"%I64u",n);
#elif HAVE_SNPRINTF
snprintf(tmp,256,"%llu",n);
#else
sprintf(tmp,"%llu",n);
#endif
/* try to scan it as a bignum */
mpz_init_set_str (new, tmp, 10);
if (mpz_fits_slong_p(new)) {
CACHE_REGS
return MkIntegerTerm(mpz_get_si(new));
}
t = Yap_MkBigIntTerm(new);
mpz_clear(new);
return t;
#else
CACHE_REGS
return MkIntegerTerm(n);
#endif
}
CELL *
Yap_HeapStoreOpaqueTerm(Term t)
{
CELL *ptr = RepAppl(t);
size_t sz;
void *new;
if (ptr[0] == (CELL)FunctorBigInt) {
sz = sizeof(MP_INT)+2*CellSize+
((MP_INT *)(ptr+2))->_mp_alloc*sizeof(mp_limb_t);
} else { /* string */
sz = sizeof(CELL)*(2+ptr[1]);
}
new = Yap_AllocCodeSpace(sz);
if (!new) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "subgoal_search_loop: no space for %s", StringOfTerm(t) );
} else {
if (ptr[0] == (CELL)FunctorBigInt) {
MP_INT *new = (MP_INT *)(RepAppl(t)+2);
new->_mp_d = (mp_limb_t *)(new+1);
}
memmove(new, ptr, sz);
}
return new;
}
size_t
Yap_OpaqueTermToString(Term t, char *str, size_t max)
{
size_t str_index = 0;
CELL * li = RepAppl(t);
unsigned char *ptr = (unsigned char *)StringOfTerm(AbsAppl(li));
if (li[0] == (CELL)FunctorString) {
str_index += sprintf(& str[str_index], "\"");
do {
utf8proc_int32_t chr;
ptr += get_utf8(ptr, &chr);
if (chr == '\0') break;
str_index += sprintf(str+str_index, "%C", chr);
} while (TRUE);
str_index += sprintf(str+str_index, "\"");
} else {
CELL big_tag = li[1];
if (big_tag == ARRAY_INT || big_tag == ARRAY_FLOAT) {
str_index += sprintf(& str[str_index], "{...}");
#ifdef USE_GMP
} else if (big_tag == BIG_INT) {
MP_INT *big = Yap_BigIntOfTerm(AbsAppl(li));
char *s = mpz_get_str(&str[str_index], 10, big);
str_index += strlen(&s[str_index]);
} else if (big_tag == BIG_RATIONAL) {
MP_RAT *big = Yap_BigRatOfTerm(AbsAppl(li));
char *s = mpq_get_str(&str[str_index], 10, big);
str_index += strlen(&s[str_index]);
#endif
}
/*
else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) {
Opaque_CallOnWrite f;
CELL blob_info;
blob_info = big_tag - USER_BLOB_START;
if (GLOBAL_OpaqueHandlers &&
(f= GLOBAL_OpaqueHandlers[blob_info].write_handler)) {
(f)(wglb->stream, big_tag, ExternalBlobFromTerm(t), 0);
return;
}
} */
str_index += sprintf(& str[str_index], "0");
}
return str_index;
}
static Int
p_is_bignum( USES_REGS1 )
{
#ifdef USE_GMP
Term t = Deref(ARG1);
return(
IsNonVarTerm(t) &&
IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorBigInt &&
RepAppl(t)[1] == BIG_INT
);
#else
return FALSE;
#endif
}
static Int
p_is_string( USES_REGS1 )
{
Term t = Deref(ARG1);
return(
IsNonVarTerm(t) &&
IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorString
);
}
static Int
p_nb_set_bit( USES_REGS1 )
{
#ifdef USE_GMP
Term t = Deref(ARG1);
Term ti = Deref(ARG2);
Int i;
if (!(
IsNonVarTerm(t) &&
IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorBigInt &&
RepAppl(t)[1] == BIG_INT
))
return FALSE;
if (!IsIntegerTerm(ti)) {
return FALSE;
}
if (!IsIntegerTerm(ti)) {
return FALSE;
}
i = IntegerOfTerm(ti);
if (i < 0) {
return FALSE;
}
Yap_gmp_set_bit(i, t);
return TRUE;
#else
return FALSE;
#endif
}
static Int
p_has_bignums( USES_REGS1 )
{
#ifdef USE_GMP
return TRUE;
#else
return FALSE;
#endif
}
static Int
p_is_opaque( USES_REGS1 )
{
Term t = Deref(ARG1);
if (IsVarTerm(t))
return FALSE;
if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
CELL *pt;
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
return ( pt[1] != BIG_RATIONAL || pt[1] != BIG_INT );
}
return FALSE;
}
static Int
p_is_rational( USES_REGS1 )
{
Term t = Deref(ARG1);
if (IsVarTerm(t))
return FALSE;
if (IsIntTerm(t))
return TRUE;
if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
CELL *pt;
if (f == FunctorLongInt)
return TRUE;
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
return ( pt[1] == BIG_RATIONAL || pt[1] == BIG_INT );
}
return FALSE;
}
static Int
p_rational( USES_REGS1 )
{
#ifdef USE_GMP
Term t = Deref(ARG1);
Functor f;
CELL *pt;
MP_RAT *rat;
Term t1, t2;
if (IsVarTerm(t))
return FALSE;
if (!IsApplTerm(t))
return FALSE;
f = FunctorOfTerm(t);
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
if (pt[1] != BIG_RATIONAL)
return FALSE;
rat = Yap_BigRatOfTerm(t);
while ((t1 = Yap_MkBigIntTerm(mpq_numref(rat))) == TermNil ||
(t2 = Yap_MkBigIntTerm(mpq_denref(rat))) == TermNil) {
UInt size =
(mpq_numref(rat)->_mp_alloc)*(sizeof(mp_limb_t)/CellSize) +
(mpq_denref(rat)->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
if (!Yap_gcl(size, 3, ENV, P)) {
Yap_Error(RESOURCE_ERROR_STACK, t, LOCAL_ErrorMessage);
return FALSE;
}
}
return
Yap_unify(ARG2, t1) &&
Yap_unify(ARG3, t2);
#else
return FALSE;
#endif
}
void
Yap_InitBigNums(void)
{
Yap_InitCPred("$has_bignums", 0, p_has_bignums, SafePredFlag);
Yap_InitCPred("$bignum", 1, p_is_bignum, SafePredFlag);
Yap_InitCPred("rational", 3, p_rational, 0);
Yap_InitCPred("rational", 1, p_is_rational, SafePredFlag);
/** @pred rational( _T_)
Checks whether `T` is a rational number.
*/
Yap_InitCPred("string", 1, p_is_string, SafePredFlag);
Yap_InitCPred("opaque", 1, p_is_opaque, SafePredFlag);
Yap_InitCPred("nb_set_bit", 2, p_nb_set_bit, SafePredFlag);
}

286
dev/yap-6.3/C/blobs.c Normal file
View File

@ -0,0 +1,286 @@
//
// blobs.c
// yap
//
// Created by VITOR SANTOS COSTA on 09/05/15.
// Copyright (c) 2015 VITOR SANTOS COSTA. All rights reserved.
//
#include <stdio.h>
#include <string.h>
#include "Yap.h"
#include "Yatom.h"
#include "iopreds.h"
#include "yapio.h"
/* for freeBSD9.1 */
#define _WITH_DPRINTF
#ifdef __APPLE__
#include "fmemopen.h"
#endif
#include "blobs.h"
static blob_type_t unregistered_blob_atom =
{ YAP_BLOB_MAGIC_B,
PL_BLOB_NOCOPY|PL_BLOB_TEXT,
"unregistered"
};
char * Yap_blob_to_string(AtomEntry *ref, const char *s0, size_t sz)
{
int rc;
char *s = (char *)s0;
blob_type_t *type = RepBlobProp(ref->PropsOfAE)->blob_type;
#if HAVE_FMEMOPEN
if (type->write) {
FILE *f = fmemopen( s, sz, "w");
if (f == NULL){
// could not find stream;
return NULL;
}
Atom at = AbsAtom(ref);
rc = type->write(f, at, 0);
if (rc < 0) {
Yap_Error( EVALUATION_ERROR_UNDEFINED, MkAtomTerm(at), "failure in user-defined blob to string code" );
}
fclose(f); // return the final result.
return s;
} else {
#endif
#if __APPLE__
size_t sz0 = strlcpy( s, (char *)RepAtom( AtomSWIStream )->StrOfAE, sz);
#else
size_t sz0;
char *f = (char *)memcpy(s, (char *)RepAtom( AtomSWIStream )->StrOfAE, sz);
f[0]='\0';
sz0 = f-s;
#endif
s = s+sz0;
sz -= sz0;
#if defined(__linux__) || defined(__APPLE__)
snprintf(s+strlen(s), sz0, "(%p)", ref);
#else
snprintf(s+strlen(s), sz0, "(0x%p)", ref);
#endif
return s;
#if HAVE_FMEMOPEN
}
return NULL;
#endif
}
int Yap_write_blob(AtomEntry *ref, FILE *stream)
{
blob_type_t *type = RepBlobProp(ref->PropsOfAE)->blob_type;
if (type->write) {
Atom at = AbsAtom(ref);
return type->write(stream, at, 0);
} else {
#if defined(__linux__) || defined(__APPLE__)
return fprintf(stream, "\'%s\'(%p)", RepAtom(AtomSWIStream)->StrOfAE, ref);
#else
return fprintf(stream, "\'%s\'(0x%p)", RepAtom(AtomSWIStream)->StrOfAE, ref);
#endif
}
return 0;
}
bool
YAP_is_blob(Term t, blob_type_t **type)
{
CACHE_REGS
Term yt = Yap_GetFromSlot(t);
Atom a;
YAP_BlobPropEntry *b;
if (IsVarTerm(yt))
return FALSE;
if (!IsAtomTerm(yt))
return FALSE;
a = AtomOfTerm(yt);
if (!IsBlob(a))
return FALSE;
b = RepBlobProp(a->PropsOfAE);
*type = b->blob_type;
return TRUE;
}
/* void check_chain(void); */
/* void check_chain(void) { */
/* AtomEntry *ae, *old; */
/* ae = Blobs; */
/* old = NULL; */
/* while (ae) { */
/* old = ae; */
/* ae = RepAtom(ae->NextOfAE); */
/* } */
/* } */
AtomEntry *
Yap_lookupBlob(void *blob, size_t len, void *type0, int *new)
{
YAP_BlobPropEntry *b;
AtomEntry *ae;
blob_type_t *type = type0;
if (new)
*new = FALSE;
LOCK(Blobs_Lock);
if (type->flags & PL_BLOB_UNIQUE) {
/* just keep a linked chain for now */
ae = Blobs;
while (ae) {
if (ae->PropsOfAE &&
RepBlobProp(ae->PropsOfAE)->blob_type == type &&
ae->rep.blob->length == len &&
!memcmp(ae->rep.blob->data, blob, len)) {
UNLOCK(Blobs_Lock);
return ae;
}
ae = RepAtom(ae->NextOfAE);
}
}
if (new)
*new = TRUE;
b = (YAP_BlobPropEntry *)Yap_AllocCodeSpace(sizeof(YAP_BlobPropEntry));
if (!b) {
UNLOCK(Blobs_Lock);
return NULL;
}
b->NextOfPE = NIL;
b->KindOfPE = BlobProperty;
b->blob_type = type;
ae = (AtomEntry *)Yap_AllocCodeSpace(sizeof(AtomEntry)+len+sizeof(size_t));
if (!ae) {
UNLOCK(Blobs_Lock);
return NULL;
}
NOfBlobs++;
INIT_RWLOCK(ae->ARWLock);
ae->PropsOfAE = AbsBlobProp(b);
ae->NextOfAE = AbsAtom(Blobs);
ae->rep.blob->length = len;
memcpy(ae->rep.blob->data, blob, len);
Blobs = ae;
if (NOfBlobs > NOfBlobsMax) {
Yap_signal(YAP_CDOVF_SIGNAL);
}
UNLOCK(Blobs_Lock);
return ae;
}
bool
YAP_unify_blob(Term *t, void *blob, size_t len, blob_type_t *type)
{
AtomEntry *ae;
if (!blob)
return FALSE;
ae = Yap_lookupBlob(blob, len, type, NULL);
if (!ae) {
return FALSE;
}
if (type->acquire) {
type->acquire(AbsAtom(ae));
}
*t = MkAtomTerm(AbsAtom(ae));
return true;
}
bool
YAP_get_blob(Term t, void **blob, size_t *len, blob_type_t **type)
{
CACHE_REGS
Atom a;
Term tt;
AtomEntry *ae;
tt = Yap_GetFromSlot(t);
if (IsVarTerm(tt))
return FALSE;
if (!IsAtomTerm(tt))
return FALSE;
a = AtomOfTerm(tt);
if (!IsBlob(a))
return FALSE;
ae = RepAtom(a);
if (type)
*type = RepBlobProp(ae->PropsOfAE)->blob_type;
if (len)
*len = ae->rep.blob[0].length;
if (blob)
*blob = ae->rep.blob[0].data;
return TRUE;
}
void *
YAP_blob_data(Atom x, size_t *len, blob_type_t **type)
{
if (!IsBlob(x)) {
if (IsWideAtom(x)) {
if ( len )
*len = wcslen(x->WStrOfAE);
if ( type )
*type = &unregistered_blob_atom;
return x->WStrOfAE;
}
if ( len )
*len = strlen((char *)x->StrOfAE);
if ( type )
*type = &unregistered_blob_atom;
return x->StrOfAE;
}
if ( len )
*len = x->rep.blob[0].length;
if ( type )
*type = RepBlobProp(x->PropsOfAE)->blob_type;
return x->rep.blob[0].data;
}
void
YAP_register_blob_type(blob_type_t *type)
{
type->next = (void *)BlobTypes;
BlobTypes = (void*)type;
}
blob_type_t*
YAP_find_blob_type(const char* name)
{
AtomEntry *a = RepAtom(Yap_LookupAtom(name));
if (!IsBlob(a)) {
return &unregistered_blob_atom;
}
return RepBlobProp(a->PropsOfAE)->blob_type;
}
bool
YAP_unregister_blob_type(blob_type_t *type)
{
fprintf(stderr,"YAP_unregister_blob_type not implemented yet\n");
return FALSE;
}
void
Yap_install_blobs(void)
{
}
/**
* @}
*/

3452
dev/yap-6.3/C/c_interface.c Normal file
View File

File diff suppressed because it is too large Load Diff

4657
dev/yap-6.3/C/cdmgr.c Normal file
View File

File diff suppressed because it is too large Load Diff

153
dev/yap-6.3/C/clause_list.c Normal file
View File

@ -0,0 +1,153 @@
#include "Yap.h"
#include "clause.h"
#include "tracer.h"
#ifdef YAPOR
#include "or.macros.h"
#endif /* YAPOR */
#include "clause_list.h"
/* need to fix overflow handling */
static void mk_blob(int sz USES_REGS) {
MP_INT *dst;
HR[0] = (CELL)FunctorBigInt;
HR[1] = CLAUSE_LIST;
dst = (MP_INT *)(HR + 2);
dst->_mp_size = 0L;
dst->_mp_alloc = sz;
HR += (1 + sizeof(MP_INT) / sizeof(CELL));
HR[sz] = EndSpecials;
HR += sz + 1;
}
static CELL *extend_blob(CELL *start, int sz USES_REGS) {
UInt osize;
MP_INT *dst;
if (HR + sz > ASP)
return NULL;
dst = (MP_INT *)(start + 2);
osize = dst->_mp_alloc;
start += (1 + sizeof(MP_INT) / sizeof(CELL));
start[sz + osize] = EndSpecials;
dst->_mp_alloc += sz;
HR += sz;
return start + osize;
}
/*init of ClasuseList*/
clause_list_t Yap_ClauseListInit(clause_list_t in) {
CACHE_REGS in->n = 0;
in->start = HR;
mk_blob(0 PASS_REGS);
in->end = HR;
return in;
}
/*add clause to ClauseList
returns FALSE on error*/
int Yap_ClauseListExtend(clause_list_t cl, void *clause, void *pred) {
CACHE_REGS
PredEntry *ap = (PredEntry *)pred;
/* fprintf(stderr,"cl=%p\n",clause); */
if (cl->end != HR)
return FALSE;
if (cl->n == 0) {
void **ptr;
if (!(ptr = (void **)extend_blob(cl->start, 1 PASS_REGS)))
return FALSE;
ptr[0] = clause;
} else if (cl->n == 1) {
yamop **ptr;
yamop *code_p, *fclause;
if (!(ptr = (yamop **)extend_blob(
cl->start, 2 * (CELL)NEXTOP((yamop *)NULL, Otapl) / sizeof(CELL) -
1 PASS_REGS)))
return FALSE;
fclause = ptr[-1];
code_p = (yamop *)(ptr - 1);
code_p->opc = Yap_opcode(_try_clause);
code_p->y_u.Otapl.d = fclause;
code_p->y_u.Otapl.s = ap->ArityOfPE;
code_p->y_u.Otapl.p = ap;
#ifdef TABLING
code_p->y_u.Otapl.te = ap->TableOfPred;
#endif
#ifdef YAPOR
INIT_YAMOP_LTT(code_p, 0);
#endif /* YAPOR */
code_p = NEXTOP(code_p, Otapl);
code_p->opc = Yap_opcode(_trust);
code_p->y_u.Otapl.d = clause;
code_p->y_u.Otapl.s = ap->ArityOfPE;
code_p->y_u.Otapl.p = ap;
#ifdef TABLING
code_p->y_u.Otapl.te = ap->TableOfPred;
#endif
#ifdef YAPOR
INIT_YAMOP_LTT(code_p, 0);
#endif /* YAPOR */
} else {
yamop *code_p;
if (!(code_p = (yamop *)extend_blob(cl->start,
((CELL)NEXTOP((yamop *)NULL, Otapl)) /
sizeof(CELL) PASS_REGS)))
return FALSE;
code_p->opc = Yap_opcode(_trust);
code_p->y_u.Otapl.d = clause;
code_p->y_u.Otapl.s = ap->ArityOfPE;
code_p->y_u.Otapl.p = ap;
#ifdef TABLING
code_p->y_u.Otapl.te = ap->TableOfPred;
#endif
#ifdef YAPOR
INIT_YAMOP_LTT(code_p, 0);
#endif /* YAPOR */
code_p = PREVOP(code_p, Otapl);
code_p->opc = Yap_opcode(_retry);
}
cl->end = HR;
cl->n++;
return TRUE;
}
/*closes the clause list*/
void Yap_ClauseListClose(clause_list_t cl) { /* no need to do nothing */
}
/*destroys the clause list freeing memory*/
int Yap_ClauseListDestroy(clause_list_t cl) {
CACHE_REGS
if (cl->end != HR)
return FALSE;
HR = cl->start;
return TRUE;
}
/*destroys clause list and returns only first clause*/
void *Yap_ClauseListToClause(clause_list_t cl) {
CACHE_REGS
void **ptr;
if (cl->end != HR)
return NULL;
if (cl->n != 1)
return NULL;
if (!(ptr = (void **)extend_blob(cl->start, 0 PASS_REGS)))
return NULL;
return ptr[-1];
}
/*return pointer to start of try-retry-trust sequence*/
void *Yap_ClauseListCode(clause_list_t cl) {
CELL *ptr;
ptr = (CELL *)cl->start;
ptr += (1 + sizeof(MP_INT) / sizeof(CELL));
return (void *)ptr;
}
/* where to fail */
void *Yap_FAILCODE(void) { return (void *)FAILCODE; }

954
dev/yap-6.3/C/cmppreds.c Normal file
View File

@ -0,0 +1,954 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: cmppreds.c *
* Last rev: *
* mods: *
* comments: comparing two prolog terms *
* *
*************************************************************************/
/// @file cmppreds.c
/**
@defgroup Comparing_Terms Comparing Terms
@ingroup builtins
The following predicates are used to compare and order terms, using the
standard ordering:
+
variables come before numbers, numbers come before atoms which in turn
come before compound terms, i.e.: variables @< numbers @< atoms @<
compound terms.
+ Variables are roughly ordered by "age" (the "oldest" variable is put
first);
+
Floating point numbers are sorted in increasing order;
+
Rational numbers are sorted in increasing order;
+
Integers are sorted in increasing order;
+
Atoms are sorted in lexicographic order;
+
Compound terms are ordered first by arity of the main functor, then by
the name of the main functor, and finally by their arguments in
left-to-right order.
@{
*/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "eval.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#include <wchar.h>
static Int compare(Term, Term);
static Int p_compare( USES_REGS1 );
static Int p_acomp( USES_REGS1 );
static Int a_eq(Term,Term);
static Int a_dif(Term,Term);
static Int a_gt(Term, Term);
static Int a_ge(Term,Term);
static Int a_lt(Term,Term);
static Int a_le(Term,Term);
static Int a_noteq(Term,Term);
static Int a_gen_lt(Term,Term);
static Int a_gen_le(Term,Term);
static Int a_gen_gt(Term,Term);
static Int a_gen_ge(Term,Term);
#define rfloat(X) ( X > 0.0 ? 1 : ( X == 0.0 ? 0 : -1))
static int
cmp_atoms(Atom a1, Atom a2)
{
if (IsWideAtom(a1)) {
if (IsWideAtom(a2)) {
return wcscmp((wchar_t *)RepAtom(a1)->StrOfAE,(wchar_t *)RepAtom(a2)->StrOfAE);
} else {
/* The standard does not seem to have nothing on this */
unsigned char *s1 = (unsigned char *)RepAtom(a1)->StrOfAE;
wchar_t *s2 = (wchar_t *)RepAtom(a2)->StrOfAE;
while (*s1 == *s2) {
if (!*s1) return 0;
s1++;
s2++;
}
return *s1-*s2;
}
} else if (IsWideAtom(a2)) {
/* The standard does not seem to have nothing on this */
wchar_t *s1 = (wchar_t *)RepAtom(a1)->StrOfAE;
unsigned char *s2 = (unsigned char *)RepAtom(a2)->StrOfAE;
while (*s1 == *s2) {
if (!*s1) return 0;
s1++;
s2++;
}
return *s1-*s2;
} else {
return strcmp((char *)RepAtom(a1)->StrOfAE,(char *)RepAtom(a2)->StrOfAE);
}
}
static int compare_complex(register CELL *pt0, register CELL *pt0_end, register
CELL *pt1)
{
CACHE_REGS
register CELL **to_visit = (CELL **)HR;
register int out = 0;
loop:
while (pt0 < pt0_end) {
register CELL d0, d1;
++ pt0;
++ pt1;
d0 = Derefa(pt0);
d1 = Derefa(pt1);
if (IsVarTerm(d0)) {
if (IsVarTerm(d1)) {
out = Signed(d0) - Signed(d1);
if (out) goto done;
}
else {
out = -1;
goto done;
}
} else if (IsVarTerm(d1)) {
out = 1;
goto done;
} else {
if (d0 == d1) continue;
else if (IsAtomTerm(d0)) {
if (IsAtomTerm(d1))
out = cmp_atoms(AtomOfTerm(d0), AtomOfTerm(d1));
else if (IsPrimitiveTerm(d1))
out = 1;
else out = -1;
/* I know out must be != 0 */
goto done;
}
else if (IsIntTerm(d0)) {
if (IsIntTerm(d1))
out = IntOfTerm(d0) - IntOfTerm(d1);
else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = IntOfTerm(d0) - LongIntOfTerm(d1);
#ifdef USE_GMP
} else if (IsBigIntTerm(d1)) {
out = Yap_gmp_tcmp_int_big(IntOfTerm(d0), d1);
#endif
} else if (IsRefTerm(d1))
out = 1 ;
else out = -1;
if (out != 0)
goto done;
} else if (IsFloatTerm(d0)) {
if (IsFloatTerm(d1)){
out = rfloat(FloatOfTerm(d0) - FloatOfTerm(d1));
} else if (IsRefTerm(d1)) {
out = 1;
} else {
out = -1;
}
if (out != 0)
goto done;
} else if (IsStringTerm(d0)) {
if (IsStringTerm(d1)){
out = strcmp((char *)StringOfTerm(d0) , (char *)StringOfTerm(d1));
} else if (IsIntTerm(d1))
out = 1;
else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = 1;
#ifdef USE_GMP
} else if (IsBigIntTerm(d1)) {
out = 1;
#endif
} else if (IsRefTerm(d1)) {
out = 1 ;
} else {
out = -1;
}
if (out != 0)
goto done;
} else if (IsLongIntTerm(d0)) {
if (IsIntTerm(d1))
out = LongIntOfTerm(d0) - IntOfTerm(d1);
else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = LongIntOfTerm(d0) - LongIntOfTerm(d1);
#ifdef USE_GMP
} else if (IsBigIntTerm(d1)) {
out = Yap_gmp_tcmp_int_big(LongIntOfTerm(d0), d1);
#endif
} else if (IsRefTerm(d1)) {
out = 1 ;
} else {
out = -1;
}
if (out != 0)
goto done;
}
#ifdef USE_GMP
else if (IsBigIntTerm(d0)) {
if (IsIntTerm(d1)) {
out = Yap_gmp_tcmp_int_big(d0, IntOfTerm(d1));
} else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = Yap_gmp_tcmp_int_big(d0, LongIntOfTerm(d1));
} else if (IsBigIntTerm(d1)) {
out = Yap_gmp_tcmp_big_big(d0, d1);
} else if (IsRefTerm(d1))
out = 1 ;
else out = -1;
if (out != 0)
goto done;
}
#endif
else if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
if (IsApplTerm(d1)) {
Functor f = FunctorOfTerm(d1);
if (IsExtensionFunctor(f))
out = 1;
else if (!(out = 2-ArityOfFunctor(f)))
out = strcmp(".",(char *)RepAtom(NameOfFunctor(f))->StrOfAE);
} else out = 1;
goto done;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
pt1 = RepPair(d1) - 1;
continue;
}
else if (IsRefTerm(d0)) {
if (IsRefTerm(d1))
out = Unsigned(RefOfTerm(d1)) -
Unsigned(RefOfTerm(d0));
else out = -1;
goto done;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
if (!IsApplTerm(d1)) {
out = 1 ;
goto done;
} else {
/* store the terms to visit */
Functor f2;
ap2 = RepAppl(d0);
ap3 = RepAppl(d1);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
out = 1;
goto done;
}
f2 = (Functor)(*ap3);
if (IsExtensionFunctor(f2)) {
out = -1;
goto done;
}
/* compare functors */
if (f != (Functor)*ap3) {
if (!(out = ArityOfFunctor(f)-ArityOfFunctor(f2)))
out = cmp_atoms(NameOfFunctor(f), NameOfFunctor(f2));
goto done;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
}
}
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)HR) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
#endif
goto loop;
}
done:
/* failure */
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)HR) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
}
#endif
return(out);
}
inline static Int
compare(Term t1, Term t2) /* compare terms t1 and t2 */
{
if (t1 == t2)
return 0;
if (IsVarTerm(t1)) {
if (IsVarTerm(t2))
return Signed(t1) - Signed(t2);
return -1;
} else if (IsVarTerm(t2)) {
/* get rid of variables */
return 1;
}
if (IsAtomOrIntTerm(t1)) {
if (IsAtomTerm(t1)) {
if (IsAtomTerm(t2))
return cmp_atoms(AtomOfTerm(t1),AtomOfTerm(t2));
if (IsPrimitiveTerm(t2))
return 1;
if (IsStringTerm(t2))
return 1;
return -1;
} else {
if (IsIntTerm(t2)) {
return IntOfTerm(t1) - IntOfTerm(t2);
}
if (IsApplTerm(t2)) {
Functor fun2 = FunctorOfTerm(t2);
switch ((CELL)fun2) {
case double_e:
return 1;
case long_int_e:
return IntOfTerm(t1) - LongIntOfTerm(t2);
#ifdef USE_GMP
case big_int_e:
return Yap_gmp_tcmp_int_big(IntOfTerm(t1), t2);
#endif
case db_ref_e:
return 1;
case string_e:
return -1;
}
}
return -1;
}
} else if (IsPairTerm(t1)) {
if (IsApplTerm(t2)) {
Functor f = FunctorOfTerm(t2);
if (IsExtensionFunctor(f))
return 1;
else {
int out;
if (!(out = 2-ArityOfFunctor(f)))
out = strcmp(".",(char *)RepAtom(NameOfFunctor(f))->StrOfAE);
return(out);
}
}
if (IsPairTerm(t2)) {
return(compare_complex(RepPair(t1)-1,
RepPair(t1)+1,
RepPair(t2)-1));
}
else return 1;
} else {
/* compound term */
Functor fun1 = FunctorOfTerm(t1);
if (IsExtensionFunctor(fun1)) {
/* float, long, big, dbref */
switch ((CELL)fun1) {
case double_e:
{
if (IsFloatTerm(t2))
return(rfloat(FloatOfTerm(t1) - FloatOfTerm(t2)));
if (IsRefTerm(t2))
return 1;
return -1;
}
case long_int_e:
{
if (IsIntTerm(t2))
return LongIntOfTerm(t1) - IntOfTerm(t2);
if (IsFloatTerm(t2)) {
return 1;
}
if (IsLongIntTerm(t2))
return LongIntOfTerm(t1) - LongIntOfTerm(t2);
#ifdef USE_GMP
if (IsBigIntTerm(t2)) {
return Yap_gmp_tcmp_int_big(LongIntOfTerm(t1), t2);
}
#endif
if (IsRefTerm(t2))
return 1;
return -1;
}
#ifdef USE_GMP
case big_int_e:
{
if (IsIntTerm(t2))
return Yap_gmp_tcmp_big_int(t1, IntOfTerm(t2));
if (IsFloatTerm(t2)) {
return 1;
}
if (IsLongIntTerm(t2))
return Yap_gmp_tcmp_big_int(t1, LongIntOfTerm(t2));
if (IsBigIntTerm(t2)) {
return Yap_gmp_tcmp_big_big(t1, t2);
}
if (IsRefTerm(t2))
return 1;
return -1;
}
#endif
case string_e:
{
if (IsApplTerm(t2)) {
Functor fun2 = FunctorOfTerm(t2);
switch ((CELL)fun2) {
case double_e:
return 1;
case long_int_e:
return 1;
#ifdef USE_GMP
case big_int_e:
return 1;
#endif
case db_ref_e:
return 1;
case string_e:
return strcmp((char *)StringOfTerm(t1), (char *)StringOfTerm(t2));
}
return -1;
}
return -1;
}
case db_ref_e:
if (IsRefTerm(t2))
return Unsigned(RefOfTerm(t2)) -
Unsigned(RefOfTerm(t1));
return -1;
}
}
if (!IsApplTerm(t2)) {
if (IsPairTerm(t2)) {
Int out;
Functor f = FunctorOfTerm(t1);
if (!(out = ArityOfFunctor(f))-2)
out = strcmp((char *)RepAtom(NameOfFunctor(f))->StrOfAE,".");
return out;
}
return 1;
} else {
Functor fun2 = FunctorOfTerm(t2);
Int r;
if (IsExtensionFunctor(fun2)) {
return 1;
}
r = ArityOfFunctor(fun1) - ArityOfFunctor(fun2);
if (r)
return r;
r = cmp_atoms(NameOfFunctor(fun1), NameOfFunctor(fun2));
if (r)
return r;
else
return(compare_complex(RepAppl(t1),
RepAppl(t1)+ArityOfFunctor(fun1),
RepAppl(t2)));
}
}
}
Int Yap_compare_terms(Term d0, Term d1)
{
return compare(Deref(d0),Deref(d1));
}
/** @pred compare( _C_, _X_, _Y_) is iso
As a result of comparing _X_ and _Y_, _C_ may take one of
the following values:
+
`=` if _X_ and _Y_ are identical;
+
`<` if _X_ precedes _Y_ in the defined order;
+
`>` if _Y_ precedes _X_ in the defined order;
*/
Int
p_compare( USES_REGS1 )
{ /* compare(?Op,?T1,?T2) */
Int r = compare(Deref(ARG2), Deref(ARG3));
Atom p;
Term t = Deref(ARG1);
if (r < 0)
p = AtomLT;
else if (r > 0)
p = AtomGT;
else
p = AtomEQ;
if (!IsVarTerm(t)) {
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
if (a == p)
return true;
if (a != AtomLT &&
a != AtomGT &&
a != AtomEq)
Yap_Error(DOMAIN_ERROR_ORDER, ARG1, NULL);
} else {
Yap_Error(TYPE_ERROR_ATOM, ARG1, NULL);
}
return false;
}
return Yap_unify_constant(ARG1, MkAtomTerm(p));
}
/** @pred _X_ \== _Y_ is iso
Terms _X_ and _Y_ are not strictly identical.
*/
static Int
a_noteq(Term t1, Term t2)
{
return (compare(t1, t2) != 0);
}
static Int
a_gen_lt(Term t1, Term t2)
{
return (compare(t1, t2) < 0);
}
/** @pred _X_ @=< _Y_ is iso
Term _X_ does not follow term _Y_ in the standard order.
*/
static Int
a_gen_le(Term t1, Term t2)
{
return (compare(t1, t2) <= 0);
}
/** @pred _X_ @> _Y_ is iso
Term _X_ does not follow term _Y_ in the standard order
*/
static Int
a_gen_gt(Term t1, Term t2)
{
return compare(t1, t2) > 0;
}
/** @pred _X_ @>= _Y_ is iso
Term _X_ does not precede term _Y_ in the standard order.
*/
static Int
a_gen_ge(Term t1, Term t2)
{
return compare(t1, t2) >= 0;
}
/**
@}
*/
/**
@defgroup arithmetic_cmps Arithmetic Comparison Predicates
@ingroup arithmetic
Comparison of Numeric Expressions. Both arguments must be valid ground expressions at time of call.
@{
*/
inline static Int
int_cmp(Int dif)
{
return dif;
}
inline static Int
flt_cmp(Float dif)
{
if (dif < 0.0)
return -1;
if (dif > 0.0)
return 1;
return dif = 0.0;
}
static inline Int
a_cmp(Term t1, Term t2 USES_REGS)
{
LOCAL_ArithError = FALSE;
if (IsVarTerm(t1)) {
LOCAL_ArithError = TRUE;
Yap_Error(INSTANTIATION_ERROR, t1, "=:=/2");
return FALSE;
}
if (IsVarTerm(t2)) {
LOCAL_ArithError = TRUE;
Yap_Error(INSTANTIATION_ERROR, t2, "=:=/2");
return FALSE;
}
if (IsFloatTerm(t1) && IsFloatTerm(t2)) {
return flt_cmp(FloatOfTerm(t1)-FloatOfTerm(t2));
}
if (IsIntegerTerm(t1) && IsIntegerTerm(t2)) {
return int_cmp(IntegerOfTerm(t1)-IntegerOfTerm(t2));
}
t1 = Yap_Eval(t1);
if (!t1) {
return FALSE;
}
if (IsIntegerTerm(t1)) {
Int i1 = IntegerOfTerm(t1);
t2 = Yap_Eval(t2);
if (IsIntegerTerm(t2)) {
Int i2 = IntegerOfTerm(t2);
return int_cmp(i1-i2);
} else if (IsFloatTerm(t2)) {
Float f2 = FloatOfTerm(t2);
#if HAVE_ISNAN
if (isnan(f2)) {
LOCAL_Error_TYPE = EVALUATION_ERROR_UNDEFINED;
LOCAL_Error_Term = t2;
LOCAL_ErrorMessage = "trying to evaluate nan";
LOCAL_ArithError = TRUE;
}
#endif
return flt_cmp(i1-f2);
#ifdef USE_GMP
} else if (IsBigIntTerm(t2)) {
return Yap_gmp_cmp_int_big(i1,t2);
#endif
} else {
return FALSE;
}
} else if (IsFloatTerm(t1)) {
Float f1 = FloatOfTerm(t1);
#if HAVE_ISNAN
if (isnan(f1)) {
LOCAL_Error_TYPE = EVALUATION_ERROR_UNDEFINED;
LOCAL_Error_Term = t1;
LOCAL_ErrorMessage = "trying to evaluate nan";
LOCAL_ArithError = TRUE;
}
#endif
t2 = Yap_Eval(t2);
#if HAVE_ISNAN
if (isnan(f1))
return -1;
#endif
if (IsIntegerTerm(t2)) {
Int i2 = IntegerOfTerm(t2);
return flt_cmp(f1-i2);
} else if (IsFloatTerm(t2)) {
Float f2 = FloatOfTerm(t2);
#if HAVE_ISNAN
if (isnan(f2)) {
LOCAL_Error_TYPE = EVALUATION_ERROR_UNDEFINED;
LOCAL_Error_Term = t2;
LOCAL_ErrorMessage = "trying to evaluate nan";
LOCAL_ArithError = TRUE;
}
#endif
return flt_cmp(f1-f2);
#ifdef USE_GMP
} else if (IsBigIntTerm(t2)) {
return Yap_gmp_cmp_float_big(f1,t2);
#endif
} else {
return FALSE;
}
#ifdef USE_GMP
} else if (IsBigIntTerm(t1)) {
{
t2 = Yap_Eval(t2);
if (IsIntegerTerm(t2)) {
return Yap_gmp_cmp_big_int(t1, IntegerOfTerm(t2));
} else if (IsFloatTerm(t2)) {
Float f2 = FloatOfTerm(t2);
#if HAVE_ISNAN
if (isnan(f2)) {
LOCAL_Error_TYPE = EVALUATION_ERROR_UNDEFINED;
LOCAL_Error_Term = t2;
LOCAL_ErrorMessage = "trying to evaluate nan";
LOCAL_ArithError = TRUE;
}
#endif
return Yap_gmp_cmp_big_float(t1, f2);
} else if (IsBigIntTerm(t2)) {
return Yap_gmp_cmp_big_big(t1, t2);
} else {
return FALSE;
}
}
#endif
} else {
return FALSE;
}
}
Int
Yap_acmp(Term t1, Term t2 USES_REGS)
{
Int out = a_cmp(t1, t2 PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out;
}
static Int
p_acomp( USES_REGS1 )
{ /* $a_compare(?R,+X,+Y) */
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
Int out;
out = a_cmp(t1, t2 PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out;
}
/**
@pred +_X_ =:= _Y_ is iso
Equality of arithmetic expressions
The value of the expression _X_ is equal to the value of expression _Y_.
*/
/// @memberof =:=/2
static Int
a_eq(Term t1, Term t2)
{
CACHE_REGS
/* A =:= B */
Int out;
t1 = Deref(t1);
t2 = Deref(t2);
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "=:=/2");
return(FALSE);
}
if (IsVarTerm(t2)) {
Yap_Error(INSTANTIATION_ERROR, t2, "=:=/2");
return(FALSE);
}
if (IsFloatTerm(t1)) {
if (IsFloatTerm(t2))
return (FloatOfTerm(t1) == FloatOfTerm(t2));
else if (IsIntegerTerm(t2)) {
return (FloatOfTerm(t1) == IntegerOfTerm(t2));
}
}
if (IsIntegerTerm(t1)) {
if (IsIntegerTerm(t2)) {
return (IntegerOfTerm(t1) == IntegerOfTerm(t2));
} else if (IsFloatTerm(t2)) {
return (FloatOfTerm(t2) == IntegerOfTerm(t1));
}
}
out = a_cmp(t1,t2 PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out == 0;
}
/*
@pred +_X_ =\\= _Y_ is iso
Difference of arithmetic expressions
The value of the expression _X_ is different from the value of expression _Y_.
*/
/// @memberof =\\=/2
static Int
a_dif(Term t1, Term t2)
{
CACHE_REGS
Int out = a_cmp(Deref(t1),Deref(t2) PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out != 0;
}
/**
@pred +_X_ \> +_Y_ is iso
Greater than arithmetic expressions
The value of the expression _X_ is less than or equal to the value
of expression _Y_.
*/
static Int
a_gt(Term t1, Term t2)
{ /* A > B */
CACHE_REGS
Int out = a_cmp(Deref(t1),Deref(t2) PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out > 0;
}
/**
@pred +_X_ >= +_Y_ is iso
Greater than or equal to arithmetic expressions
The value of the expression _X_ is greater than or equal to the
value of expression _Y_.
*/
static Int
a_ge(Term t1, Term t2)
{ /* A >= B */
CACHE_REGS
Int out = a_cmp(Deref(t1),Deref(t2) PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out >= 0;
}
/**
@pred +_X_ \< +_Y_ is iso
Lesser than arithmetic expressions
The value of the expression _X_ is less than the value of expression
_Y_.
*/
/// @memberof </2
static Int
a_lt(Term t1, Term t2)
{ /* A < B */
CACHE_REGS
Int out = a_cmp(Deref(t1),Deref(t2) PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out < 0;
}
/**
*
@pred _X_ =< + _Y_
Lesser than or equal to arithmetic expressions
The value of the expression _X_ is less than or equal to the value
of expression _Y_.
*/
/// @memberof =</2
static Int
a_le(Term t1, Term t2)
{ /* A <= B */
CACHE_REGS
Int out = a_cmp(Deref(t1),Deref(t2) PASS_REGS);
if (LOCAL_ArithError) { Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage); return FALSE; }
return out <= 0;
}
/**
@}
*/
void
Yap_InitCmpPreds(void)
{
Yap_InitCmpPred("=:=", 2, a_eq, SafePredFlag | BinaryPredFlag);
Yap_InitCmpPred("=\\=", 2, a_dif, SafePredFlag | BinaryPredFlag);
Yap_InitCmpPred(">", 2, a_gt, SafePredFlag | BinaryPredFlag);
Yap_InitCmpPred("=<", 2, a_le, SafePredFlag | BinaryPredFlag);
Yap_InitCmpPred("<", 2, a_lt, SafePredFlag | BinaryPredFlag);
Yap_InitCmpPred(">=", 2, a_ge, SafePredFlag | BinaryPredFlag);
Yap_InitCPred("$a_compare", 3, p_acomp, TestPredFlag | SafePredFlag);
Yap_InitCmpPred("\\==", 2, a_noteq, BinaryPredFlag | SafePredFlag);
Yap_InitCmpPred("@<", 2, a_gen_lt, BinaryPredFlag | SafePredFlag);
Yap_InitCmpPred("@=<", 2, a_gen_le, BinaryPredFlag | SafePredFlag);
Yap_InitCmpPred("@>", 2, a_gen_gt, BinaryPredFlag | SafePredFlag);
Yap_InitCmpPred("@>=", 2, a_gen_ge, BinaryPredFlag | SafePredFlag);
Yap_InitCPred("compare", 3, p_compare, TestPredFlag | SafePredFlag);
}
/**
@}
*/

3754
dev/yap-6.3/C/compiler.c Normal file
View File

File diff suppressed because it is too large Load Diff

798
dev/yap-6.3/C/computils.c Normal file
View File

@ -0,0 +1,798 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: computils.c *
* comments: some useful routines for YAP's compiler *
* *
* Last rev: $Date: 2007-11-26 23:43:08 $ *
* $Log: not supported by cvs2svn $
* Revision 1.31 2007/11/06 17:02:12 vsc
* compile ground terms away.
*
* Revision 1.30 2006/09/20 20:03:51 vsc
* improve indexing on floats
* fix sending large lists to DB
*
* Revision 1.29 2005/12/05 17:16:10 vsc
* write_depth/3
* overflow handlings and garbage collection
* Several ipdates to CLPBN
* dif/2 could be broken in the presence of attributed variables.
*
* Revision 1.28 2005/09/08 22:06:44 rslopes
* BEAM for YAP update...
*
* Revision 1.27 2005/07/06 15:10:04 vsc
* improvements to compiler: merged instructions and fixes for ->
*
* Revision 1.26 2005/01/04 02:50:21 vsc
* - allow MegaClauses with blobs
* - change Diffs to be thread specific
* - include Christian's updates
*
* Revision 1.25 2004/11/19 17:14:13 vsc
* a few fixes for 64 bit compiling.
*
* Revision 1.24 2004/04/16 19:27:31 vsc
* more bug fixes
*
* Revision 1.23 2004/03/10 14:59:55 vsc
* optimise -> for type tests
* *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This file includes a set of utilities, useful to the several compilation
* modules
*/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "compile.h"
#include "yapio.h"
#if HAVE_STRING_H
#include <string.h>
#endif
/*
* The compiler creates an instruction chain which will be assembled after
* afterwards
*/
typedef struct mem_blk {
union {
struct mem_blk *next;
double fill;
} ublock;
char contents[1];
} MemBlk;
#define CMEM_BLK_SIZE (4*4096)
#define FIRST_CMEM_BLK_SIZE (16*4096)
static char *
AllocCMem (UInt size, struct intermediates *cip)
{
#if SIZEOF_INT_P==8
size = (size + 7) & ((UInt)-8);
#else
size = (size + 3) & ((UInt)0xfffffffc);
#endif
#if USE_SYSTEM_MALLOC
if (!cip->blks || cip->blk_cur+size > cip->blk_top) {
UInt blksz;
struct mem_blk *p;
if (size > CMEM_BLK_SIZE)
blksz = size+sizeof(struct mem_blk);
else
blksz = CMEM_BLK_SIZE;
if (!cip->blks) {
CACHE_REGS
if (LOCAL_CMemFirstBlock) {
p = LOCAL_CMemFirstBlock;
blksz = LOCAL_CMemFirstBlockSz;
p->ublock.next = NULL;
} else {
if (blksz < FIRST_CMEM_BLK_SIZE)
blksz = FIRST_CMEM_BLK_SIZE;
p = (struct mem_blk *)Yap_AllocCodeSpace(blksz);
if (!p) {
LOCAL_Error_Size = size;
save_machine_regs();
siglongjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH);
}
LOCAL_CMemFirstBlock = p;
LOCAL_CMemFirstBlockSz = blksz;
}
} else {
p = (struct mem_blk *)Yap_AllocCodeSpace(blksz);
if (!p) {
CACHE_REGS
LOCAL_Error_Size = size;
save_machine_regs();
siglongjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH);
}
}
p->ublock.next = cip->blks;
cip->blks = p;
cip->blk_cur = p->contents;
cip->blk_top = (char *)p+blksz;
}
{
char *out = cip->blk_cur;
cip->blk_cur += size;
return out;
}
#else
char *p;
if (ASP <= CellPtr (cip->freep) + 256) {
CACHE_REGS
LOCAL_Error_Size = 256+((char *)cip->freep - (char *)HR);
save_machine_regs();
siglongjmp(cip->CompilerBotch, OUT_OF_STACK_BOTCH);
}
p = cip->freep;
cip->freep += size;
return p;
#endif
}
void
Yap_ReleaseCMem (struct intermediates *cip)
{
#if USE_SYSTEM_MALLOC
CACHE_REGS
struct mem_blk *p = cip->blks;
while (p) {
struct mem_blk *nextp = p->ublock.next;
if (p != LOCAL_CMemFirstBlock)
Yap_FreeCodeSpace((ADDR)p);
p = nextp;
}
cip->blks = NULL;
if (cip->label_offset &&
cip->label_offset != LOCAL_LabelFirstArray) {
Yap_FreeCodeSpace((ADDR)cip->label_offset);
}
#endif
cip->label_offset = NULL;
}
char *
Yap_AllocCMem (UInt size, struct intermediates *cip)
{
return AllocCMem(size, cip);
}
static int
is_a_test(Term arg, Term mod)
{
if (IsVarTerm (arg)) {
return FALSE;
}
if (IsVarTerm (arg) || !IsAtomTerm(mod)) {
return FALSE;
}
if (IsAtomTerm (arg)) {
Atom At = AtomOfTerm (arg);
PredEntry *pe = RepPredProp(PredPropByAtom(At, mod));
if (EndOfPAEntr(pe))
return FALSE;
return pe->PredFlags & TestPredFlag;
}
if (IsApplTerm (arg)) {
Functor f = FunctorOfTerm (arg);
if (f == FunctorModule) {
return is_a_test(ArgOfTerm(2,arg), ArgOfTerm(1,arg));
} else if (f == FunctorComma) {
return
is_a_test(ArgOfTerm(1,arg), mod) &&
is_a_test(ArgOfTerm(2,arg), mod);
} else {
PredEntry *pe = RepPredProp(PredPropByFunc(f, mod));
if (EndOfPAEntr(pe))
return FALSE;
if (pe->PredFlags & AsmPredFlag) {
int op = pe->PredFlags & 0x7f;
if (op >= _atom && op <= _eq) {
return TRUE;
}
return FALSE;
}
return pe->PredFlags & (TestPredFlag|BinaryPredFlag);
}
}
return FALSE;
}
int
Yap_is_a_test_pred (Term arg, Term mod)
{
return is_a_test(arg, mod);
}
void
Yap_emit (compiler_vm_op o, Int r1, CELL r2, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->nextInst = NULL;
if (cip->cpc == NIL) {
cip->cpc = cip->CodeStart = p;
} else {
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
void
Yap_emit_3ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
void
Yap_emit_4ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+2*sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->rnd4 = r4;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
void
Yap_emit_5ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+3*sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->rnd4 = r4;
p->rnd5 = r5;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
void
Yap_emit_6ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, CELL r6, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+4*sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->rnd4 = r4;
p->rnd5 = r5;
p->rnd6 = r6;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
void
Yap_emit_7ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, CELL r6, CELL r7, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+5*sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->rnd4 = r4;
p->rnd5 = r5;
p->rnd6 = r6;
p->rnd7 = r7;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
CELL *
Yap_emit_extra_size (compiler_vm_op o, CELL r1, int size, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p) + size - CellSize, cip);
p->op = o;
p->rnd1 = r1;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
return p->arnds;
}
static void
bip_name(Int op, char *s)
{
switch (op) {
case _atom:
strcpy(s,"atom");
break;
case _atomic:
strcpy(s,"atomic");
break;
case _integer:
strcpy(s,"integer");
break;
case _nonvar:
strcpy(s,"nonvar");
break;
case _number:
strcpy(s,"number");
break;
case _var:
strcpy(s,"var");
break;
case _cut_by:
strcpy(s,"cut_by");
break;
case _save_by:
strcpy(s,"save_by");
break;
case _db_ref:
strcpy(s,"db_ref");
break;
case _compound:
strcpy(s,"compound");
break;
case _float:
strcpy(s,"float");
break;
case _primitive:
strcpy(s,"primitive");
break;
case _equal:
strcpy(s,"equal");
break;
case _dif:
strcpy(s,"dif");
break;
case _eq:
strcpy(s,"eq");
break;
case _functor:
strcpy(s,"functor");
break;
case _plus:
strcpy(s,"plus");
break;
case _minus:
strcpy(s,"minus");
break;
case _times:
strcpy(s,"times");
break;
case _div:
strcpy(s,"div");
break;
case _and:
strcpy(s,"and");
break;
case _or:
strcpy(s,"or");
break;
case _sll:
strcpy(s,"sll");
break;
case _slr:
strcpy(s,"slr");
break;
case _arg:
strcpy(s,"arg");
break;
default:
strcpy(s,"");
break;
}
}
void
Yap_bip_name(Int op, char *s) {
bip_name(op,s);
}
#ifdef DEBUG
static void
write_address(CELL address)
{
if (address < (CELL)AtomBase) {
Yap_DebugErrorPutc('L');
Yap_DebugPlWrite(MkIntTerm (address));
} else if (address == (CELL) FAILCODE) {
Yap_DebugPlWrite (MkAtomTerm (AtomFail));
} else {
char buf[32], *p = buf;
#if HAVE_SNPRINTF
snprintf(buf,32,"%p",(void *)address);
#else
sprintf(buf,"%p",(void *)address);
#endif
p[31] = '\0'; /* so that I don't have to worry */
//Yap_DebugErrorPutc('0');
//Yap_DebugErrorPutc('x');
while (*p != '\0') {
Yap_DebugErrorPutc(*p++);
}
}
}
static void
write_special_label(special_label_op arg, special_label_id rn, UInt lab)
{
switch (arg) {
case SPECIAL_LABEL_INIT:
Yap_DebugErrorPuts("init,");
switch (rn) {
case SPECIAL_LABEL_EXCEPTION:
Yap_DebugErrorPuts("exception,");
break;
case SPECIAL_LABEL_SUCCESS:
Yap_DebugErrorPuts("success,");
break;
case SPECIAL_LABEL_FAILURE:
Yap_DebugErrorPuts("fail,");
break;
}
write_address(lab);
case SPECIAL_LABEL_SET:
Yap_DebugErrorPuts("set,");
break;
case SPECIAL_LABEL_CLEAR:
Yap_DebugErrorPuts("clear,");
switch (rn) {
case SPECIAL_LABEL_EXCEPTION:
Yap_DebugErrorPuts("exception");
break;
case SPECIAL_LABEL_SUCCESS:
Yap_DebugErrorPuts("success");
break;
case SPECIAL_LABEL_FAILURE:
Yap_DebugErrorPuts("fail");
break;
}
}
}
static void
write_functor(Functor f)
{
if (IsExtensionFunctor(f)) {
if (f == FunctorDBRef) {
Yap_DebugPlWrite(MkAtomTerm(AtomDBREF));
} else if (f == FunctorLongInt) {
Yap_DebugPlWrite(MkAtomTerm(AtomLONGINT));
} else if (f == FunctorBigInt) {
Yap_DebugPlWrite(MkAtomTerm(AtomLONGINT));
} else if (f == FunctorDouble) {
Yap_DebugPlWrite(MkAtomTerm(AtomDOUBLE));
} else if (f == FunctorString) {
Yap_DebugPlWrite(MkAtomTerm(AtomSTRING));
}
} else {
Yap_DebugPlWrite(MkAtomTerm(NameOfFunctor (f)));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor (f)));
}
}
char *opDesc[] = { mklist(f_arr) };
static void send_pred(PredEntry *p)
{
Functor f = p->FunctorOfPred;
UInt arity = p->ArityOfPE;
Term mod = TermProlog;
if (p->ModuleOfPred) mod = p->ModuleOfPred;
Yap_DebugPlWrite (mod);
Yap_DebugErrorPutc (':');
if (arity == 0)
Yap_DebugPlWrite (MkAtomTerm ((Atom)f));
else
Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f)));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm (arity));
}
static void
ShowOp (compiler_vm_op ic, const char *f, struct PSEUDO *cpc)
{
CACHE_REGS
char ch;
Int arg = cpc->rnd1;
Int rn = cpc->rnd2;
CELL *cptr = cpc->arnds;
if (ic != label_op && ic != label_ctl_op && ic != name_op) {
Yap_DebugErrorPutc ('\t');
}
while ((ch = *f++) != 0)
{
if (ch == '%')
switch (ch = *f++)
{
#ifdef BEAM
case '1':
Yap_DebugPlWrite(MkIntTerm(rn));
break;
case '4':
Yap_DebugPlWrite(MkIntTerm(arg));
break;
#endif
case '2':
{
Ventry *v = (Ventry *) cpc->rnd3;
Yap_DebugErrorPutc (v->KindOfVE == PermVar ? 'Y' : 'X');
Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs));
Yap_DebugErrorPutc (',');
Yap_DebugErrorPutc ('A');
Yap_DebugPlWrite (MkIntegerTerm (cpc->rnd4));
Yap_DebugErrorPutc (',');
send_pred( RepPredProp((Prop)(cpc->rnd5)) );
}
break;
case 'a':
case 'n':
Yap_DebugPlWrite ((Term) arg);
break;
case 'b':
/* write a variable bitmap for a call */
{
int max = arg/(8*sizeof(CELL)), i;
CELL *ptr = cptr;
for (i = 0; i <= max; i++) {
Yap_DebugPlWrite(MkIntegerTerm((Int)(*ptr++)));
}
}
break;
case 'l':
write_address (arg);
break;
case 'L':
write_special_label (arg, rn, cpc->rnd3);
break;
case 'B':
{
char s[32];
bip_name(rn,s);
Yap_DebugPlWrite (MkAtomTerm(Yap_LookupAtom(s)));
}
break;
case 'd':
Yap_DebugPlWrite (MkIntegerTerm (arg));
break;
case 'z':
Yap_DebugPlWrite (MkIntTerm (cpc->rnd3));
break;
case 'v':
{
Ventry *v = (Ventry *) arg;
if (v) {
Yap_DebugErrorPutc (v->KindOfVE == PermVar ? 'Y' : 'X');
Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs));
}
}
break;
case 'N':
{
Ventry *v;
cpc = cpc->nextInst;
arg = cpc->rnd1;
v = (Ventry *) arg;
Yap_DebugErrorPutc (v->KindOfVE == PermVar ? 'Y' : 'X');
Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs));
}
break;
case 'm':
Yap_DebugPlWrite (MkAtomTerm ((Atom) arg));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm (rn));
break;
case 'p':
send_pred( RepPredProp((Prop)(arg) ));
break;
case 'P':
send_pred( RepPredProp((Prop)(rn) ));
break;
case 'f':
write_functor((Functor)arg);
break;
case 'r':
Yap_DebugErrorPutc ('A');
Yap_DebugPlWrite (MkIntTerm (rn));
break;
case 'S':
Yap_DebugErrorPutc ('S');
Yap_DebugPlWrite (MkIntTerm (rn));
break;
case 'h':
{
CELL my_arg = *cptr++;
write_address(my_arg);
}
break;
case 'g':
write_address(arg);
break;
case 'i':
write_address (arg);
break;
case 'j':
{
Functor fun = (Functor)*cptr++;
if (IsExtensionFunctor(fun)) {
if (fun == FunctorDBRef) {
Yap_DebugPlWrite(MkAtomTerm(AtomDBREF));
} else if (fun == FunctorLongInt) {
Yap_DebugPlWrite(MkAtomTerm(AtomLONGINT));
} else if (fun == FunctorDouble) {
Yap_DebugPlWrite(MkAtomTerm(AtomDOUBLE));
} else if (fun == FunctorString) {
Yap_DebugPlWrite(MkAtomTerm(AtomSTRING));
}
} else {
Yap_DebugPlWrite (MkAtomTerm(NameOfFunctor(fun)));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm(ArityOfFunctor(fun)));
}
}
break;
case 'O':
Yap_DebugPlWrite(AbsAppl(cptr));
break;
case 'x':
Yap_DebugPlWrite (MkIntTerm (rn >> 1));
Yap_DebugErrorPutc ('\t');
Yap_DebugPlWrite (MkIntTerm (rn & 1));
break;
case 'w':
Yap_DebugPlWrite (arg);
break;
case 'o':
Yap_DebugPlWrite ((Term) * cptr++);
case 'c':
{
int i;
CELL *ptr = (CELL *)cptr[0];
for (i = 0; i < arg; ++i) {
CELL my_arg;
Yap_DebugErrorPutc('\t');
if (*ptr) {
Yap_DebugPlWrite ((Term) *ptr++);
} else {
Yap_DebugPlWrite (MkIntTerm (0));
ptr++;
}
Yap_DebugErrorPutc ('\t');
my_arg = *ptr++;
write_address (my_arg);
if (i+1 < arg)
Yap_DebugErrorPutc ('\n');
}
}
break;
case 'e':
{
int i;
CELL *ptr = (CELL *)cptr[0];
for (i = 0; i < arg; ++i) {
CELL my_arg = ptr[0], lbl = ptr[1];
Yap_DebugErrorPutc('\t');
if (my_arg) {
write_functor((Functor)my_arg);
} else {
Yap_DebugPlWrite(MkIntTerm (0));
}
Yap_DebugErrorPutc('\t');
write_address(lbl);
ptr += 2;
if (i+1 < arg)
Yap_DebugErrorPutc('\n');
}
}
break;
default:
Yap_DebugErrorPutc ('%');
Yap_DebugErrorPutc (ch);
}
else
Yap_DebugErrorPutc (ch);
}
Yap_DebugErrorPutc ('\n');
}
void
Yap_ShowCode (struct intermediates *cint)
{
CACHE_REGS
struct PSEUDO *cpc;
cpc = cint->CodeStart;
/* MkIntTerm and friends may build terms in the global stack */
HR = (CELL *)cint->freep;
while (cpc) {
compiler_vm_op ic = cpc->op;
if (ic != nop_op) {
ShowOp (ic, opDesc[ic], cpc);
}
cpc = cpc->nextInst;
}
Yap_DebugErrorPutc ('\n');
}
#endif /* DEBUG */

558
dev/yap-6.3/C/control_absmi_insts.h Normal file
View File

@ -0,0 +1,558 @@
/************************************************************************\
* Cut & Commit Instructions *
\************************************************************************/
#ifdef INDENT_CODE
{
{
{
#endif /* INDENT_CODE */
/* cut */
Op(cut, s);
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCut, HR);
ENDCACHE_Y_AS_ENV();
do_cut:
#endif
SET_ASP(YREG, PREG->y_u.s.s);
PREG = NEXTOP(NEXTOP(NEXTOP(PREG, s),Osbpp),l);
/* assume cut is always in stack */
saveregs();
prune((choiceptr)YREG[E_CB] PASS_REGS);
setregs();
GONext();
#ifdef COROUTINING
NoStackCut:
PROCESS_INT(interrupt_cut, do_cut);
#endif
ENDOp();
/* cut_t */
/* cut_t does the same as cut */
Op(cut_t, s);
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCutT, HR);
ENDCACHE_Y_AS_ENV();
do_cut_t:
#endif
SET_ASP(YREG, PREG->y_u.s.s);
/* assume cut is always in stack */
saveregs();
prune((choiceptr)YREG[E_CB] PASS_REGS);
setregs();
PREG = NEXTOP(NEXTOP(NEXTOP(PREG, s),Osbpp),l);
GONext();
#ifdef COROUTINING
NoStackCutT:
PROCESS_INT(interrupt_cut_t, do_cut_t);
#endif
ENDOp();
/* cut_e */
Op(cut_e, s);
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCutE, HR);
ENDCACHE_Y_AS_ENV();
do_cut_e:
#endif
SET_ASP(YREG, PREG->y_u.s.s);
PREG = NEXTOP(NEXTOP(NEXTOP(PREG, s),Osbpp),l);
saveregs();
prune((choiceptr)SREG[E_CB] PASS_REGS);
setregs();
GONext();
#ifdef COROUTINING
NoStackCutE:
PROCESS_INT(interrupt_cut_e, do_cut_e);
#endif
ENDOp();
/* save_b_x Xi */
Op(save_b_x, x);
BEGD(d0);
d0 = PREG->y_u.x.x;
#if defined(YAPOR_SBA) && defined(FROZEN_STACKS)
XREG(d0) = MkIntegerTerm((Int)B);
#else
XREG(d0) = MkIntegerTerm(LCL0-(CELL *) (B));
#endif /* YAPOR_SBA && FROZEN_STACKS */
PREG = NEXTOP(PREG, x);
ENDD(d0);
GONext();
ENDOp();
/* save_b_y Yi */
Op(save_b_y, y);
#if defined(YAPOR_SBA)
INITIALIZE_PERMVAR(YREG+PREG->y_u.y.y,MkIntegerTerm((Int)B));
#else
INITIALIZE_PERMVAR(YREG+PREG->y_u.y.y,MkIntegerTerm(LCL0-(CELL *)(B)));
#endif /* YAPOR_SBA*/
PREG = NEXTOP(PREG, y);
GONext();
ENDOp();
/* commit_b_x Xi */
Op(commit_b_x, xps);
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCommitX, HR);
ENDCACHE_Y_AS_ENV();
do_commit_b_x:
#endif
BEGD(d0);
d0 = XREG(PREG->y_u.xps.x);
deref_head(d0, commit_b_x_unk);
commit_b_x_nvar:
/* skip a void call and a label */
SET_ASP(YREG, PREG->y_u.xps.s);
PREG = NEXTOP(NEXTOP(NEXTOP(PREG, xps),Osbpp),l);
{
choiceptr pt0;
#if defined(YAPOR_SBA) && defined(FROZEN_STACKS)
pt0 = (choiceptr)IntegerOfTerm(d0);
#else
pt0 = (choiceptr)(LCL0-IntegerOfTerm(d0));
#endif /* YAPOR_SBA && FROZEN_STACKS */
saveregs();
prune(pt0 PASS_REGS);
setregs();
}
GONext();
BEGP(pt1);
deref_body(d0, pt1, commit_b_x_unk, commit_b_x_nvar);
ENDP(pt1);
/* never cut to a variable */
/* Abort */
FAIL();
ENDD(d0);
#ifdef COROUTINING
/* Problem: have I got an environment or not? */
NoStackCommitX:
PROCESS_INT(interrupt_commit_x, do_commit_b_x);
#endif
ENDOp();
/* commit_b_y Yi */
Op(commit_b_y, yps);
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCommitY, HR);
ENDCACHE_Y_AS_ENV();
do_commit_b_y:
#endif
BEGD(d0);
d0 = YREG[PREG->y_u.yps.y];
deref_head(d0, commit_b_y_unk);
commit_b_y_nvar:
SET_ASP(YREG, PREG->y_u.yps.s);
PREG = NEXTOP(NEXTOP(NEXTOP(PREG, yps),Osbpp),l);
{
choiceptr pt0;
#if defined(YAPOR_SBA) && defined(FROZEN_STACKS)
pt0 = (choiceptr)IntegerOfTerm(d0);
#else
pt0 = (choiceptr)(LCL0-IntegerOfTerm(d0));
#endif
saveregs();
prune(pt0 PASS_REGS);
setregs();
}
GONext();
BEGP(pt1);
deref_body(d0, pt1, commit_b_y_unk, commit_b_y_nvar);
ENDP(pt1);
/* never cut to a variable */
/* Abort */
FAIL();
ENDD(d0);
#ifdef COROUTINING
/* This is easier: I know there is an environment so I cannot do allocate */
NoStackCommitY:
PROCESS_INT(interrupt_commit_y, do_commit_b_y);
#endif
ENDOp();
/*************************************************************************
* Call / Proceed instructions *
*************************************************************************/
/* Macros for stack trimming */
/* execute Label */
BOp(execute, pp);
{
PredEntry *pt0;
CACHE_Y_AS_ENV(YREG);
pt0 = PREG->y_u.pp.p;
#ifndef NO_CHECKING
check_stack(NoStackExecute, HR);
goto skip_do_execute;
#endif
do_execute:
FETCH_Y_FROM_ENV(YREG);
pt0 = PREG->y_u.pp.p;
skip_do_execute:
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
low_level_trace(enter_pred,pt0,XREGS+1);
}
#endif /* LOW_LEVEL_TRACE */
CACHE_A1();
ALWAYS_LOOKAHEAD(pt0->OpcodeOfPred);
BEGD(d0);
d0 = (CELL)B;
PREG = pt0->CodeOfPred;
/* for profiler */
save_pc();
ENV_YREG[E_CB] = d0;
ENDD(d0);
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is prolog */
if (pt0->ModuleOfPred) {
if (DEPTH == MkIntTerm(0)) {
FAIL();
} else { DEPTH = RESET_DEPTH(); }
}
} else if (pt0->ModuleOfPred)
DEPTH -= MkIntConstant(2);
#endif /* DEPTH_LIMIT */
/* this is the equivalent to setting up the stack */
ALWAYS_GONext();
ALWAYS_END_PREFETCH();
ENDCACHE_Y_AS_ENV();
}
NoStackExecute:
PROCESS_INT(interrupt_execute, do_execute);
ENDBOp();
/* dexecute Label */
/* joint deallocate and execute */
BOp(dexecute, pp);
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace)
low_level_trace(enter_pred,PREG->y_u.pp.p,XREGS+1);
#endif /* LOW_LEVEL_TRACER */
CACHE_Y_AS_ENV(YREG);
{
PredEntry *pt0;
CACHE_A1();
pt0 = PREG->y_u.pp.p;
#ifndef NO_CHECKING
/* check stacks */
check_stack(NoStackDExecute, HR);
goto skip_dexecute;
#endif
continue_dexecute:
FETCH_Y_FROM_ENV(YREG);
pt0 = PREG->y_u.pp.p;
skip_dexecute:
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is primitives */
if (pt0->ModuleOfPred) {
if (DEPTH == MkIntTerm(0)) {
FAIL();
} else {
DEPTH = RESET_DEPTH();
}
}
} else if (pt0->ModuleOfPred)
DEPTH -= MkIntConstant(2);
#endif /* DEPTH_LIMIT */
PREG = pt0->CodeOfPred;
/* for profiler */
save_pc();
ALWAYS_LOOKAHEAD(pt0->OpcodeOfPred);
/* do deallocate */
CPREG = (yamop *) ENV_YREG[E_CP];
ENV_YREG = ENV = (CELL *) ENV_YREG[E_E];
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (ENV_YREG > (CELL *) top_b || ENV_YREG < HR) ENV_YREG = (CELL *) top_b;
#else
if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b;
#endif /* YAPOR_SBA */
else ENV_YREG = (CELL *)((CELL)ENV_YREG + ENV_Size(CPREG));
}
#else
if (ENV_YREG > (CELL *)B) {
ENV_YREG = (CELL *)B;
}
else {
ENV_YREG = (CELL *) ((CELL) ENV_YREG + ENV_Size(CPREG));
}
#endif /* FROZEN_STACKS */
WRITEBACK_Y_AS_ENV();
/* setup GB */
ENV_YREG[E_CB] = (CELL) B;
ALWAYS_GONext();
ALWAYS_END_PREFETCH();
}
ENDCACHE_Y_AS_ENV();
NoStackDExecute:
PROCESS_INT(interrupt_dexecute, continue_dexecute);
ENDBOp();
BOp(fcall, Osbpp);
CACHE_Y_AS_ENV(YREG);
ENV_YREG[E_CP] = (CELL) CPREG;
ENV_YREG[E_E] = (CELL) ENV;
#ifdef DEPTH_LIMIT
ENV_YREG[E_DEPTH] = DEPTH;
#endif /* DEPTH_LIMIT */
ENDCACHE_Y_AS_ENV();
ENDBOp();
BOp(call, Osbpp);
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
low_level_trace(enter_pred,PREG->y_u.Osbpp.p,XREGS+1);
}
#endif /* LOW_LEVEL_TRACER */
CACHE_Y_AS_ENV(YREG);
{
PredEntry *pt;
CACHE_A1();
pt = PREG->y_u.Osbpp.p;
#ifndef NO_CHECKING
check_stack(NoStackCall, HR);
goto skip_call;
#endif
call_body:
/* external jump if we don;t want to creep */
FETCH_Y_FROM_ENV(YREG);
pt = PREG->y_u.Osbpp.p;
skip_call:
ENV = ENV_YREG;
/* Try to preserve the environment */
ENV_YREG = (CELL *) (((char *) ENV_YREG) + PREG->y_u.Osbpp.s);
CPREG = NEXTOP(PREG, Osbpp);
ALWAYS_LOOKAHEAD(pt->OpcodeOfPred);
PREG = pt->CodeOfPred;
/* for profiler */
save_pc();
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is primitives */
if (pt->ModuleOfPred) {
if (DEPTH == MkIntTerm(0)) {
FAIL();
} else {
DEPTH = RESET_DEPTH();
}
}
} else if (pt->ModuleOfPred)
DEPTH -= MkIntConstant(2);
#endif /* DEPTH_LIMIT */
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (ENV_YREG > (CELL *) top_b || ENV_YREG < HR) ENV_YREG = (CELL *) top_b;
#else
if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b;
#endif /* YAPOR_SBA */
}
#else
if (ENV_YREG > (CELL *) B) {
ENV_YREG = (CELL *) B;
}
#endif /* FROZEN_STACKS */
WRITEBACK_Y_AS_ENV();
/* setup GB */
ENV_YREG[E_CB] = (CELL) B;
#ifdef YAPOR
SCH_check_requests();
#endif /* YAPOR */
ALWAYS_GONext();
ALWAYS_END_PREFETCH();
}
ENDCACHE_Y_AS_ENV();
ENDBOp();
BOp(procceed, p);
CACHE_Y_AS_ENV(YREG);
ALWAYS_LOOKAHEAD(CPREG->opc);
PREG = CPREG;
/* for profiler */
save_pc();
ENV_YREG = ENV;
#ifdef DEPTH_LIMIT
DEPTH = ENV_YREG[E_DEPTH];
#endif
WRITEBACK_Y_AS_ENV();
ALWAYS_GONext();
ALWAYS_END_PREFETCH();
ENDCACHE_Y_AS_ENV();
NoStackCall:
PROCESS_INT(interrupt_call, call_body);
ENDBOp();
Op(allocate, e);
CACHE_Y_AS_ENV(YREG);
PREG = NEXTOP(PREG, e);
ENV_YREG[E_CP] = (CELL) CPREG;
ENV_YREG[E_E] = (CELL) ENV;
#ifdef DEPTH_LIMIT
ENV_YREG[E_DEPTH] = DEPTH;
#endif /* DEPTH_LIMIT */
ENV = ENV_YREG;
ENDCACHE_Y_AS_ENV();
GONext();
ENDOp();
Op(deallocate, p);
CACHE_Y_AS_ENV(YREG);
check_trail(TR);
#ifndef NO_CHECKING
/* check stacks */
check_stack(NoStackDeallocate, HR);
#endif
PREG = NEXTOP(PREG, p);
/* other instructions do depend on S being set by deallocate
:-( */
SREG = YREG;
CPREG = (yamop *) ENV_YREG[E_CP];
ENV = ENV_YREG = (CELL *) ENV_YREG[E_E];
#ifdef DEPTH_LIMIT
DEPTH = ENV_YREG[E_DEPTH];
#endif /* DEPTH_LIMIT */
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (ENV_YREG > (CELL *) top_b || ENV_YREG < HR) ENV_YREG = (CELL *) top_b;
#else
if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b;
#endif /* YAPOR_SBA */
else ENV_YREG = (CELL *)((CELL) ENV_YREG + ENV_Size(CPREG));
}
#else
if (ENV_YREG > (CELL *) B)
ENV_YREG = (CELL *) B;
else
ENV_YREG = (CELL *) ((CELL) ENV_YREG + ENV_Size(CPREG));
#endif /* FROZEN_STACKS */
WRITEBACK_Y_AS_ENV();
ENDCACHE_Y_AS_ENV();
GONext();
NoStackDeallocate:
BEGD(d0);
#ifdef SHADOW_S
Yap_REGS.S_ = YREG;
#endif
PREG = NEXTOP(PREG,p);
saveregs();
d0 = interrupt_deallocate( PASS_REGS1 );
setregs();
PREG = PREVOP(PREG,p);
#ifdef SHADOW_S
SREG = Yap_REGS.S_;
#endif
// return to original deallocate
if (!d0) FAIL();
JMPNext();
ENDD(d0);
ENDOp();
/**********************************************
* OPTYap instructions *
**********************************************/
#ifdef YAPOR
#include "or.insts.h"
#endif /* YAPOR */
#ifdef TABLING
#include "tab.insts.h"
#include "tab.tries.insts.h"
#endif /* TABLING */
#ifdef BEAM
extern int eam_am(PredEntry *);
Op(retry_eam, e);
printf("Aqui estou eu..................\n");
if (!eam_am(2)) {
abort_eam("Falhei\n");
FAIL();
}
goto procceed;
PREG = NEXTOP(PREG, e);
GONext();
ENDOp();
Op(run_eam, os);
if (inp==-9000) { /* use indexing to find out valid alternatives */
extern CELL *beam_ALTERNATIVES;
*beam_ALTERNATIVES= (CELL *) PREG->y_u.os.opcw;
beam_ALTERNATIVES++;
if (OLD_B!=B) goto fail;
#if PUSH_REGS
Yap_regp=old_regs;
#endif
return(0);
}
saveregs();
if (!eam_am((PredEntry *) PREG->y_u.os.s)) FAIL();
setregs();
/* cut */
BACKUP_B();
while (POP_CHOICE_POINT(B->cp_b)) {
POP_EXECUTE();
}
B = B->cp_b; /* cut_fail */
HB = B->cp_h; /* cut_fail */
RECOVER_B();
if (0) { register choiceptr ccp;
/* initialize ccp */
#define NORM_CP(CP) ((choiceptr)(CP))
YREG = (CELL *) (NORM_CP(YREG) - 1);
ccp = NORM_CP(YREG);
store_yaam_reg_cpdepth(ccp);
ccp->cp_tr = TR;
ccp->cp_ap = BEAM_RETRY_CODE;
ccp->cp_h = HR;
ccp->cp_b = B;
ccp->cp_env= ENV;
ccp->cp_cp = CPREG;
B = ccp;
SET_BB(B);
}
goto procceed;
PREG = NEXTOP(PREG, os);
GONext();
ENDOp();
#endif

572
dev/yap-6.3/C/corout.c Normal file
View File

@ -0,0 +1,572 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: corout.c *
* Last rev: *
* mods: *
* comments: Co-routining from within YAP *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "heapgc.h"
#include "attvar.h"
#ifndef NULL
#define NULL (void *)0
#endif
#ifdef COROUTINING
/* check if variable was there */
static Term AddVarIfNotThere(Term var, Term dest USES_REGS) {
Term test = dest;
while (test != TermNil) {
if ((RepPair(test))[0] == var)
return (dest);
else
test = (RepPair(test))[1];
}
return (MkPairTerm(var, dest));
}
/* This routine verifies whether two complex structures can unify. */
static int can_unify_complex(register CELL *pt0, register CELL *pt0_end,
register CELL *pt1, Term *Vars USES_REGS) {
/* This is really just unification, folks */
tr_fr_ptr saved_TR;
CELL *saved_HB;
choiceptr saved_B;
register CELL **to_visit = (CELL **)Yap_PreAllocCodeSpace();
CELL **to_visit_base = to_visit;
/* make sure to trail all bindings */
saved_TR = TR;
saved_B = B;
saved_HB = HB;
HB = HR;
loop:
while (pt0 < pt0_end) {
register CELL d0, d1;
++pt0;
++pt1;
d0 = Derefa(pt0);
d1 = Derefa(pt1);
if (IsVarTerm(d0)) {
if (IsVarTerm(d1)) {
if (d0 != d1) {
/* we need to suspend on both variables ! */
*Vars = AddVarIfNotThere(d0, AddVarIfNotThere(d1, *Vars PASS_REGS)
PASS_REGS);
/* bind the two variables, we would have to do that to unify
them */
if (d1 > d0) { /* youngest */
/* we don't want to wake up goals */
Bind_Global_NonAtt((CELL *)d1, d0);
} else {
Bind_Global_NonAtt((CELL *)d0, d1);
}
}
/* continue the loop */
continue;
} else {
/* oh no, some more variables! */
*Vars = AddVarIfNotThere(d0, *Vars PASS_REGS);
}
/* now bind it */
Bind_Global_NonAtt((CELL *)d0, d1);
/* continue the loop */
} else if (IsVarTerm(d1)) {
*Vars = AddVarIfNotThere(d1, *Vars PASS_REGS);
/* and bind it */
Bind_Global_NonAtt((CELL *)d1, d0);
/* continue the loop */
} else {
if (d0 == d1)
continue;
if (IsAtomOrIntTerm(d0) || IsAtomOrIntTerm(d1)) {
if (d0 != d1)
goto comparison_failed;
/* else continue the loop */
} else if (IsPairTerm(d0)) {
if (!IsPairTerm(d1))
goto comparison_failed;
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
pt1 = RepPair(d1) - 1;
continue;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
if (!IsApplTerm(d1)) {
goto comparison_failed;
} else {
/* store the terms to visit */
ap2 = RepAppl(d0);
ap3 = RepAppl(d1);
f = (Functor)(*ap2);
/* compare functors */
if (f != (Functor)*ap3) {
goto comparison_failed;
}
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL) FunctorDBRef:
if (d0 == d1)
continue;
goto comparison_failed;
case (CELL) FunctorLongInt:
if (ap2[1] == ap3[1])
continue;
goto comparison_failed;
case (CELL) FunctorDouble:
if (FloatOfTerm(d0) == FloatOfTerm(d1))
continue;
goto comparison_failed;
case (CELL) FunctorString:
if (strcmp((char *)StringOfTerm(d0), (char *)StringOfTerm(d1)) ==
0)
continue;
goto comparison_failed;
#ifdef USE_GMP
case (CELL) FunctorBigInt:
if (Yap_gmp_tcmp_big_big(d0, d1) == 0)
continue;
goto comparison_failed;
#endif /* USE_GMP */
default:
goto comparison_failed;
}
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
}
}
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)to_visit_base) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
#endif
goto loop;
}
/* success */
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
/* restore B, and later HB */
B = saved_B;
HB = saved_HB;
/* untrail all bindings made by IUnify */
while (TR != saved_TR) {
pt1 = (CELL *)(TrailTerm(--TR));
RESET_VARIABLE(pt1);
}
return (TRUE);
comparison_failed:
/* failure */
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)to_visit_base) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
}
#endif
/* restore B, and later HB */
B = saved_B;
HB = saved_HB;
/* untrail all bindings made by IUnify */
while (TR != saved_TR) {
pt1 = (CELL *)(TrailTerm(--TR));
RESET_VARIABLE(pt1);
}
/* the system will take care of TR for me, no need to worry here! */
return (FALSE);
}
static int can_unify(Term t1, Term t2, Term *Vars USES_REGS) {
t1 = Deref(t1);
t2 = Deref(t2);
if (t1 == t2) {
*Vars = TermNil;
return TRUE;
}
if (IsVarTerm(t1)) {
/* we know for sure they can't be different */
if (IsVarTerm(t2)) {
/* we need to suspend on both variables because otherwise
Y = susp(_) would not wakeup susp ! */
*Vars = MkPairTerm(t1, MkPairTerm(t2, TermNil));
return TRUE;
} else {
*Vars = MkPairTerm(t1, TermNil);
return TRUE;
}
} else if (IsVarTerm(t2)) {
/* wait until t2 is bound */
*Vars = MkPairTerm(t2, TermNil);
return TRUE;
}
/* Two standard terms at last! */
if (IsAtomOrIntTerm(t1) || IsAtomOrIntTerm(t2)) {
/* Two primitive terms can only be equal if they are
the same. If they are, $eq succeeds without further ado.
*/
if (t1 != t2)
return FALSE;
else {
*Vars = TermNil;
return TRUE;
}
} else if (IsPairTerm(t1)) {
if (IsPairTerm(t2)) {
return (can_unify_complex(RepPair(t1) - 1, RepPair(t1) + 1,
RepPair(t2) - 1, Vars PASS_REGS));
} else
return FALSE;
} else {
Functor f = FunctorOfTerm(t1);
if (f != FunctorOfTerm(t2))
return FALSE;
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL) FunctorDBRef:
if (t1 == t2)
return FALSE;
return FALSE;
case (CELL) FunctorLongInt:
if (RepAppl(t1)[1] == RepAppl(t2)[1])
return (TRUE);
return FALSE;
case (CELL) FunctorString:
if (strcmp((char *)StringOfTerm(t1), (char *)StringOfTerm(t2)) == 0)
return (TRUE);
return FALSE;
case (CELL) FunctorDouble:
if (FloatOfTerm(t1) == FloatOfTerm(t2))
return (TRUE);
return FALSE;
#ifdef USE_GMP
case (CELL) FunctorBigInt:
if (Yap_gmp_tcmp_big_big(t1, t2) == 0)
return (TRUE);
return (FALSE);
#endif /* USE_GMP */
default:
return FALSE;
}
}
/* Two complex terms with the same functor */
return can_unify_complex(RepAppl(t1), RepAppl(t1) + ArityOfFunctor(f),
RepAppl(t2), Vars PASS_REGS);
}
}
/* This routine verifies whether a complex has variables. */
static int non_ground_complex(register CELL *pt0, register CELL *pt0_end,
Term *Var USES_REGS) {
register CELL **to_visit = (CELL **)Yap_PreAllocCodeSpace();
CELL **to_visit_base = to_visit;
loop:
while (pt0 < pt0_end) {
register CELL d0;
++pt0;
d0 = Derefa(pt0);
if (IsVarTerm(d0)) {
*Var = d0;
goto var_found;
}
if (IsPairTerm(d0)) {
if (to_visit + 1024 >= (CELL **)AuxSp) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
continue;
}
if (to_visit + 1024 >= (CELL **)AuxSp) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
}
/* just continue the loop */
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)to_visit_base) {
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
#else
to_visit -= 2;
pt0 = to_visit[0];
pt0_end = to_visit[1];
#endif
goto loop;
}
/* the term is ground */
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
return FALSE;
var_found:
/* the term is non-ground */
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)to_visit_base) {
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
}
#endif
/* the system will take care of TR for me, no need to worry here! */
return TRUE;
aux_overflow:
/* unwind stack */
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)to_visit_base) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
return -1;
}
static int non_ground(Term t, Term *Var USES_REGS) {
int out = -1;
while (out < 0) {
t = Deref(t);
if (IsVarTerm(t)) {
/* we found a variable */
*Var = t;
return TRUE;
}
if (IsPrimitiveTerm(t)) {
return FALSE;
} else if (IsPairTerm(t)) {
out = non_ground_complex(RepPair(t) - 1, RepPair(t) + 1, Var PASS_REGS);
if (out >= 0)
return out;
} else {
Functor f = FunctorOfTerm(t);
if (IsExtensionFunctor(f)) {
return FALSE;
}
out = non_ground_complex(RepAppl(t),
RepAppl(t) + ArityOfFunctor(FunctorOfTerm(t)),
Var PASS_REGS);
if (out >= 0)
return out;
}
if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
Yap_Error(RESOURCE_ERROR_AUXILIARY_STACK, ARG1, "overflow in ground");
return FALSE;
}
}
return FALSE;
}
#endif
/* check whether the two terms unify and return what variables should
be bound before the terms are exactly equal */
static Int p_can_unify(USES_REGS1) {
#ifdef COROUTINING
Term r = TermNil;
if (!can_unify(ARG1, ARG2, &r PASS_REGS))
return FALSE;
return Yap_unify(ARG3, r);
#else
return FALSE;
#endif
}
/* if the term is not ground return a variable in the term */
static Int p_non_ground(USES_REGS1) {
#ifdef COROUTINING
Term r = TermNil;
if (!non_ground(ARG1, &r PASS_REGS))
return (FALSE);
return (Yap_unify(ARG2, r));
#else
return (FALSE);
#endif
}
/* if the term is not ground return a variable in the term */
static Int p_coroutining(USES_REGS1) {
#ifdef COROUTINING
return (TRUE);
#else
return (FALSE);
#endif
}
#if COROUTINING
static Term ListOfWokenGoals(USES_REGS1) {
return Yap_ReadTimedVar(LOCAL_WokenGoals);
}
Term Yap_ListOfWokenGoals(void) {
CACHE_REGS
return ListOfWokenGoals(PASS_REGS1);
}
#endif
/* return a list of awoken goals */
static Int p_awoken_goals(USES_REGS1) {
#ifdef COROUTINING
Term WGs = Yap_ReadTimedVar(LOCAL_WokenGoals);
if (WGs == TermNil) {
return (FALSE);
}
WGs = ListOfWokenGoals(PASS_REGS1);
Yap_UpdateTimedVar(LOCAL_WokenGoals, TermNil);
return (Yap_unify(ARG1, WGs));
#else
return (FALSE);
#endif
}
static Int p_yap_has_rational_trees(USES_REGS1) {
#if RATIONAL_TREES
return TRUE;
#else
return FALSE;
#endif
}
static Int p_yap_has_coroutining(USES_REGS1) {
#if COROUTINING
return TRUE;
#else
return FALSE;
#endif
}
void Yap_InitCoroutPreds(void) {
#ifdef COROUTINING
Atom at;
PredEntry *pred;
at = AtomWakeUpGoal;
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 2), 0));
WakeUpCode = pred;
#endif
Yap_InitAttVarPreds();
Yap_InitCPred("$yap_has_rational_trees", 0, p_yap_has_rational_trees,
SafePredFlag);
Yap_InitCPred("$yap_has_coroutining", 0, p_yap_has_coroutining, SafePredFlag);
Yap_InitCPred("$can_unify", 3, p_can_unify, SafePredFlag);
Yap_InitCPred("$non_ground", 2, p_non_ground, SafePredFlag);
Yap_InitCPred("$coroutining", 0, p_coroutining, SafePredFlag);
Yap_InitCPred("$awoken_goals", 1, p_awoken_goals, SafePredFlag);
}

1014
dev/yap-6.3/C/cp_absmi_insts.h Normal file
View File

File diff suppressed because it is too large Load Diff

33
dev/yap-6.3/C/cut_c.c Normal file
View File

@ -0,0 +1,33 @@
#include "Yap.h"
#include "cut_c.h"
#include <stdio.h>
void cut_c_initialize(int wid){
CACHE_REGS
Yap_REGS.CUT_C_TOP=(cut_c_str_ptr)REMOTE_LocalBase(wid);
}
/*Removes a choice_point from the stack*/
void cut_c_pop(void){
CACHE_REGS
cut_c_str_ptr to_delete = NULL;
if (((CELL *)Yap_REGS.CUT_C_TOP) == ((CELL *)LOCAL_LocalBase))
{
return;
}
else
{ /* removes the top element
from the stack */
to_delete = Yap_REGS.CUT_C_TOP;
Yap_REGS.CUT_C_TOP = to_delete->before;
return;
}
}
/*Insert a choice_point in the stack*/
void cut_c_push(cut_c_str_ptr new_top){
CACHE_REGS
new_top->before = Yap_REGS.CUT_C_TOP;
Yap_REGS.CUT_C_TOP=new_top;
return;
}

5409
dev/yap-6.3/C/dbase.c Normal file
View File

File diff suppressed because it is too large Load Diff

94
dev/yap-6.3/C/depth_bound.c Normal file
View File

@ -0,0 +1,94 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: it_deep.c *
* Last rev: *
* mods: *
* comments: Support for Iterative Deepening *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif /* SCCS */
#include <math.h>
#include "Yap.h"
#include "Yatom.h"
#include "eval.h"
#ifdef DEPTH_LIMIT
#include "Yatom.h"
static Int p_get_depth_limit( USES_REGS1 );
static Int p_set_depth_limit( USES_REGS1 );
static Int p_get_depth_limit( USES_REGS1 )
{
Int d = IntOfTerm(DEPTH);
if (d % 2 == 1)
return(Yap_unify(ARG1, MkFloatTerm(INFINITY)));
return(Yap_unify_constant(ARG1, MkIntTerm(d/2)));
}
static Int p_set_depth_limit( USES_REGS1 )
{
Term d = Deref(ARG1);
if (IsVarTerm(d)) {
Yap_Error(INSTANTIATION_ERROR, d, "set-depth_limit");
return(FALSE);
} else if (!IsIntegerTerm(d)) {
if (IsFloatTerm(d) && isinf(FloatOfTerm(d))) {
d = RESET_DEPTH();
} else {
Yap_Error(TYPE_ERROR_INTEGER, d, "set-depth_limit");
return(FALSE);
}
}
d = MkIntTerm(IntegerOfTerm(d)*2);
YENV[E_DEPTH] = d;
DEPTH = d;
return(TRUE);
}
static Int p_set_depth_limit_for_next_call( USES_REGS1 )
{
Term d = Deref(ARG1);
if (IsVarTerm(d)) {
Yap_Error(INSTANTIATION_ERROR, d, "set-depth_limit");
return(FALSE);
} else if (!IsIntegerTerm(d)) {
if (IsFloatTerm(d) && isinf(FloatOfTerm(d))) {
DEPTH = RESET_DEPTH();
return TRUE;
}
Yap_Error(TYPE_ERROR_INTEGER, d, "set-depth_limit");
return(FALSE);
}
d = MkIntTerm(IntegerOfTerm(d)*2);
DEPTH = d;
return(TRUE);
}
void Yap_InitItDeepenPreds(void)
{
Yap_InitCPred("get_depth_limit", 1, p_get_depth_limit, SafePredFlag);
Yap_InitCPred("$set_depth_limit", 1, p_set_depth_limit, 0);
Yap_InitCPred("$set_depth_limit_for_next_call", 1, p_set_depth_limit_for_next_call, 0);
}
#endif

3059
dev/yap-6.3/C/dlmalloc.c Normal file
View File

File diff suppressed because it is too large Load Diff

720
dev/yap-6.3/C/errors.c Normal file
View File

@ -0,0 +1,720 @@
/*************************************************************************
* *
* Yap Prolog *
* *
* Yap Prolog Was Developed At Nccup - Universidade Do Porto *
* *
* Copyright L.Damas, V.S.Costa And Universidade Do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: errors.c *
* Last Rev: *
* Mods: *
* Comments: Yap'S error handlers *
* *
*************************************************************************/
#include "absmi.h"
#include "yapio.h"
#if HAVE_STDARG_H
#include <stdarg.h>
#endif
#include <stdlib.h>
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_STRING_H
#include <string.h>
#endif
#include "Foreign.h"
#if DEBUG
void Yap_PrintPredName(PredEntry *ap) {
CACHE_REGS
Term tmod = ap->ModuleOfPred;
if (!tmod)
tmod = TermProlog;
#if THREADS
Yap_DebugPlWrite(MkIntegerTerm(worker_id));
Yap_DebugPutc(stderr, ' ');
#endif
Yap_DebugPutc(stderr, '>');
Yap_DebugPutc(stderr, '\t');
Yap_DebugPlWrite(tmod);
Yap_DebugPutc(stderr, ':');
if (ap->ModuleOfPred == IDB_MODULE) {
Term t = Deref(ARG1);
if (IsAtomTerm(t)) {
Yap_DebugPlWrite(t);
} else if (IsIntegerTerm(t)) {
Yap_DebugPlWrite(t);
} else {
Functor f = FunctorOfTerm(t);
Atom At = NameOfFunctor(f);
Yap_DebugPlWrite(MkAtomTerm(At));
Yap_DebugPutc(stderr, '/');
Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
}
} else {
if (ap->ArityOfPE == 0) {
Atom At = (Atom)ap->FunctorOfPred;
Yap_DebugPlWrite(MkAtomTerm(At));
} else {
Functor f = ap->FunctorOfPred;
Atom At = NameOfFunctor(f);
Yap_DebugPlWrite(MkAtomTerm(At));
Yap_DebugPutc(stderr, '/');
Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
}
}
char s[1024];
if (ap->PredFlags & StandardPredFlag)
fprintf(stderr, "S");
if (ap->PredFlags & CPredFlag)
fprintf(stderr, "C");
if (ap->PredFlags & UserCPredFlag)
fprintf(stderr, "U");
if (ap->PredFlags & SyncPredFlag)
fprintf(stderr, "Y");
if (ap->PredFlags & LogUpdatePredFlag)
fprintf(stderr, "Y");
if (ap->PredFlags & HiddenPredFlag)
fprintf(stderr, "H");
sprintf(s, " %llx\n", ap->PredFlags);
Yap_DebugPuts(stderr, s);
}
#endif
bool Yap_Warning(const char *s, ...) {
CACHE_REGS
va_list ap;
PredEntry *pred;
bool rc;
Term ts[2];
const char *format;
char tmpbuf[MAXPATHLEN];
if (LOCAL_within_print_message) {
/* error within error */
fprintf(stderr, "%% WARNING WITHIN WARNING\n");
Yap_RestartYap(1);
}
LOCAL_DoingUndefp = true;
LOCAL_within_print_message = true;
pred = RepPredProp(PredPropByFunc(FunctorPrintMessage,
PROLOG_MODULE)); // PROCEDURE_print_message2
va_start(ap, s);
format = va_arg(ap, char *);
if (format != NULL) {
#if HAVE_VSNPRINTF
vsnprintf(tmpbuf, MAXPATHLEN - 1, format, ap);
#else
(void)vsprintf(tmpbuf, format, ap);
#endif
} else
return false;
va_end(ap);
if (pred->OpcodeOfPred == UNDEF_OPCODE||
pred->OpcodeOfPred == FAIL_OPCODE) {
fprintf(stderr, "warning message: %s\n", tmpbuf);
LOCAL_DoingUndefp = false;
LOCAL_within_print_message = false;
return false;
}
ts[1] = MkAtomTerm(AtomWarning);
ts[0] = MkAtomTerm(Yap_LookupAtom(tmpbuf));
rc = Yap_execute_pred(pred, ts, true PASS_REGS);
return rc;
}
bool Yap_PrintWarning(Term twarning) {
CACHE_REGS
PredEntry *pred = RepPredProp(PredPropByFunc(
FunctorPrintMessage, PROLOG_MODULE)); // PROCEDURE_print_message2;
Term cmod = ( CurrentModule == PROLOG_MODULE ? TermProlog : CurrentModule );
bool rc;
Term ts[2];
if (LOCAL_within_print_message) {
/* error within error */
fprintf(stderr, "%% WARNING WITHIN WARNING\n");
Yap_RestartYap(1);
}
LOCAL_DoingUndefp = true;
LOCAL_within_print_message = true;
if (pred->OpcodeOfPred == UNDEF_OPCODE ||
pred->OpcodeOfPred == FAIL_OPCODE
) {
fprintf(stderr, "warning message:\n");
Yap_DebugPlWrite(twarning);
fprintf(stderr, "\n");
LOCAL_DoingUndefp = false;
LOCAL_within_print_message = false;
CurrentModule = cmod;
return false;
}
ts[1] = twarning;
ts[0] = MkAtomTerm(AtomWarning);
HB = B->cp_h = HR;
B->cp_tr = TR;
rc = Yap_execute_pred(pred, ts, true PASS_REGS);
LOCAL_within_print_message = false;
LOCAL_DoingUndefp = false;
return rc;
}
bool Yap_HandleError__(const char *file, const char *function, int lineno, const char *s, ...) {
CACHE_REGS
yap_error_number err = LOCAL_Error_TYPE;
const char *serr;
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (LOCAL_ErrorMessage) {
serr = LOCAL_ErrorMessage;
} else {
serr = s;
}
switch (err) {
case RESOURCE_ERROR_STACK:
if (!Yap_gc(2, ENV, gc_P(P, CP))) {
Yap_Error__(file, function, lineno, RESOURCE_ERROR_STACK, ARG1, serr);
return false;
}
return true;
case RESOURCE_ERROR_AUXILIARY_STACK:
if (LOCAL_MAX_SIZE < (char *)AuxSp - AuxBase) {
LOCAL_MAX_SIZE += 1024;
}
if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
/* crash in flames */
Yap_Error__(file, function, lineno, RESOURCE_ERROR_AUXILIARY_STACK, ARG1, serr);
return false;
}
return true;
case RESOURCE_ERROR_HEAP:
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error__(file, function, lineno, RESOURCE_ERROR_HEAP, ARG2, serr);
return false;
}
default:
Yap_Error__(file, function, lineno, err, LOCAL_Error_Term, serr);
return false;
}
}
int Yap_SWIHandleError(const char *s, ...) {
CACHE_REGS
yap_error_number err = LOCAL_Error_TYPE;
char *serr;
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (LOCAL_ErrorMessage) {
serr = LOCAL_ErrorMessage;
} else {
serr = (char *)s;
}
switch (err) {
case RESOURCE_ERROR_STACK:
if (!Yap_gc(2, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, serr);
return (FALSE);
}
return TRUE;
case RESOURCE_ERROR_AUXILIARY_STACK:
if (LOCAL_MAX_SIZE < (char *)AuxSp - AuxBase) {
LOCAL_MAX_SIZE += 1024;
}
if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
/* crash in flames */
Yap_Error(RESOURCE_ERROR_AUXILIARY_STACK, ARG1, serr);
return FALSE;
}
return TRUE;
case RESOURCE_ERROR_HEAP:
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, ARG2, serr);
return FALSE;
}
default:
Yap_Error(err, LOCAL_Error_Term, serr);
return (FALSE);
}
}
void Yap_RestartYap(int flag) {
CACHE_REGS
#if PUSH_REGS
restore_absmi_regs(&Yap_standard_regs);
#endif
siglongjmp(LOCAL_RestartEnv, 1);
}
static void error_exit_yap(int value) {
CACHE_REGS
if (!(LOCAL_PrologMode & BootMode)) {
#if DEBUG
#endif
}
fprintf(stderr, "\n Exiting ....\n");
Yap_exit(value);
}
/* This needs to be a static because I can't trust the stack (WIN32), and
I can't trust the Yap stacks (error) */
#define YAP_BUF_SIZE 512
static char tmpbuf[YAP_BUF_SIZE];
// error classes: based on OSI errors.
//
// - The extra argument says whether there different instances
//
// - Events are treated within the same pipeline as errors.
//
#undef BEGIN_ERROR_CLASSES
#undef ECLASS
#undef END_ERROR_CLASSES
#undef BEGIN_ERRORS
#undef E0
#undef E
#undef E2
#undef END_ERRORS
#define BEGIN_ERROR_CLASSES() \
static Term mkerrorct(yap_error_class_number c, Term *ts) { \
switch (c) {
#define ECLASS(CL, A, B) \
case CL: \
if (A == 0) \
return MkAtomTerm(Yap_LookupAtom(A)); \
else { \
return Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom(A), B), B, ts); \
}
#define END_ERROR_CLASSES() \
} \
}
#define BEGIN_ERRORS() \
static Term mkerrort(yap_error_number e, Term *ts) { \
switch (e) {
#define E0(A, B) \
case A: \
return mkerrorct(B, ts);
#define E(A, B, C) \
case A: \
ts -= 1; \
ts[0] = MkAtomTerm(Yap_LookupAtom(C)); \
return mkerrorct(B, ts);
#define E2(A, B, C, D) \
case A: \
ts -= 2; \
ts[0] = MkAtomTerm(Yap_LookupAtom(C)); \
ts[1] = MkAtomTerm(Yap_LookupAtom(D)); \
return mkerrorct(B, ts);
#define END_ERRORS() \
} \
}
#include "YapErrors.h"
/**
* @brief Yap_Error
* This function handles errors in the C code. Check errors.yap for the
*corresponding Prolog code.
*
* @param file C source
* @param function C function
* @param lineno C exact line
* @param type the error ID (in YAP this is a single integer)
* @param where the culprit
* @return usually FAILCODE
*
* In a good day, the error handler's job is to generate a throw. This includes:
* - constructing an ISO style error term;
* - constructing a list with all available info on the bug
* - generating the throw
* - forcing backtracking in order to restart.
*
* In a bad day, it has to deal with OOM, abort, and errors within errorts.
*
* The list includes the following options:
* + c=c(file, line, function): where the bug was detected;
*
* + e=p(mod, name, arity, cl, file, lin): where the code was entered;
*
* + p=p(mod, name, arity, cl, file, line): the prolog procedure that caused
*the bug,
*and optionally,
*
* + g=g(Goal): the goal that created this mess
*
* + i=i(Comment): an user-written comment on this bug.
*/
yamop *Yap_Error__(const char *file, const char *function, int lineno,
yap_error_number type, Term where, ...) {
CACHE_REGS
va_list ap;
CELL nt[3];
Functor fun;
bool serious;
Term tf, error_t, comment, culprit = TermNil;
char *format;
char s[MAXPATHLEN];
/* disallow recursive error handling */
if (LOCAL_PrologMode & InErrorMode) {
fprintf(stderr, "%% ERROR WITHIN ERROR %d: %s\n", LOCAL_CurrentError,
tmpbuf);
Yap_RestartYap(1);
}
LOCAL_PrologMode |= InErrorMode;
LOCAL_Error_TYPE = YAP_NO_ERROR;
Yap_ClearExs();
if (where == 0L) {
where = TermNil;
}
// first, obtain current location
sprintf(LOCAL_FileNameBuf, "%s:%d in C-function %s ", file, lineno, function);
tf = MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf));
#if DEBUG_STRICT
if (Yap_heap_regs && !(LOCAL_PrologMode & BootMode))
fprintf(stderr, "***** Processing Error %d (%lx,%x) %s***\n", type,
(unsigned long int)LOCAL_Signals, LOCAL_PrologMode, format);
else
fprintf(stderr, "***** Processing Error %d (%x) %s***\n", type,
LOCAL_PrologMode, format);
#endif
if (type == INTERRUPT_EVENT) {
fprintf(stderr, "%% YAP exiting: cannot handle signal %d\n",
(int)IntOfTerm(where));
LOCAL_PrologMode &= ~InErrorMode;
Yap_exit(1);
}
if (LOCAL_within_print_message) {
/* error within error */
fprintf(stderr, "%% ERROR WITHIN WARNING %d: %s\n", LOCAL_CurrentError,
tmpbuf);
LOCAL_PrologMode &= ~InErrorMode;
Yap_exit(1);
}
va_start(ap, where);
format = va_arg(ap, char *);
if (format != NULL) {
#if HAVE_VSNPRINTF
(void)vsnprintf(s, MAXPATHLEN - 1, format, ap);
#else
(void)vsprintf(s, format, ap);
#endif
// fprintf(stderr, "warning: ");
comment = MkAtomTerm(Yap_LookupAtom(s));
} else if (LOCAL_ErrorSay && LOCAL_ErrorSay[0]) {
comment = MkAtomTerm(Yap_LookupAtom(LOCAL_ErrorSay));
} else {
comment = TermNil;
}
va_end(ap);
if (P == (yamop *)(FAILCODE)) {
LOCAL_PrologMode &= ~InErrorMode;
return P;
}
/* PURE_ABORT may not have set where correctly, BootMode may not have the data
* terms ready */
if (type == ABORT_EVENT || LOCAL_PrologMode & BootMode) {
where = TermNil;
LOCAL_PrologMode &= ~AbortMode;
LOCAL_CurrentError = type;
LOCAL_PrologMode |= InErrorMode;
/* make sure failure will be seen at next port */
// no need to lock & unlock
if (LOCAL_PrologMode & AsyncIntMode)
Yap_signal(YAP_FAIL_SIGNAL);
P = FAILCODE;
} else {
if (IsVarTerm(where)) {
/* we must be careful someone gave us a copy to a local variable */
Term t = MkVarTerm();
Yap_unify(t, where);
where = Deref(where);
}
/* Exit Abort Mode, if we were there */
LOCAL_PrologMode &= ~AbortMode;
LOCAL_CurrentError = type;
LOCAL_PrologMode |= InErrorMode;
if (!(where = Yap_CopyTerm(where))) {
where = TermNil;
}
}
if (LOCAL_PrologMode & BootMode) {
/* crash in flames! */
fprintf(stderr, "%s:%d:0 YAP Fatal Error %d in function %s:\n %s exiting....\n", file, lineno, type, function, s);
error_exit_yap(1);
}
#ifdef DEBUG
// DumpActiveGoals( USES_REGS1 );
#endif /* DEBUG */
if (!IsVarTerm(where) &&
IsApplTerm(where) &&
FunctorOfTerm(where) == FunctorError) {
error_t = where;
Yap_JumpToEnv(error_t);
P = (yamop *)FAILCODE;
LOCAL_PrologMode &= ~InErrorMode;
return P;
}
switch (type) {
case SYSTEM_ERROR_INTERNAL: {
fprintf(stderr, "%% Internal YAP Error: %s exiting....\n", tmpbuf);
serious = TRUE;
if (LOCAL_PrologMode & BootMode) {
fprintf(stderr, "%% YAP crashed while booting %s\n", tmpbuf);
} else {
Yap_detect_bug_location(P, FIND_PRED_FROM_ANYWHERE, YAP_BUF_SIZE);
fprintf(stderr, "%% Bug found while executing %s\n", tmpbuf);
}
error_exit_yap(1);
}
case SYSTEM_ERROR_FATAL: {
fprintf(stderr, "%% Fatal YAP Error: %s exiting....\n", tmpbuf);
error_exit_yap(1);
}
case INTERRUPT_EVENT: {
error_exit_yap(1);
}
case ABORT_EVENT:
nt[0] = MkAtomTerm(AtomDAbort);
fun = FunctorDollarVar;
serious = TRUE;
break;
case CALL_COUNTER_UNDERFLOW_EVENT:
/* Do a long jump */
LOCAL_ReductionsCounterOn = FALSE;
LOCAL_PredEntriesCounterOn = FALSE;
LOCAL_RetriesCounterOn = FALSE;
Yap_JumpToEnv(MkAtomTerm(AtomCallCounter));
P = (yamop *)FAILCODE;
LOCAL_PrologMode &= ~InErrorMode;
return (P);
case PRED_ENTRY_COUNTER_UNDERFLOW_EVENT:
/* Do a long jump */
LOCAL_ReductionsCounterOn = FALSE;
LOCAL_PredEntriesCounterOn = FALSE;
LOCAL_RetriesCounterOn = FALSE;
Yap_JumpToEnv(MkAtomTerm(AtomCallAndRetryCounter));
P = (yamop *)FAILCODE;
LOCAL_PrologMode &= ~InErrorMode;
return (P);
case RETRY_COUNTER_UNDERFLOW_EVENT:
/* Do a long jump */
LOCAL_ReductionsCounterOn = FALSE;
LOCAL_PredEntriesCounterOn = FALSE;
LOCAL_RetriesCounterOn = FALSE;
Yap_JumpToEnv(MkAtomTerm(AtomRetryCounter));
P = (yamop *)FAILCODE;
LOCAL_PrologMode &= ~InErrorMode;
return (P);
default: {
Term ts[3];
ts[2] = where;
nt[0] = mkerrort(type, ts + 2);
}
}
if (type != ABORT_EVENT) {
Term location;
/* This is used by some complex procedures to detect there was an error */
if (IsAtomTerm(nt[0])) {
strncpy(LOCAL_ErrorSay, (char *) RepAtom(AtomOfTerm(nt[0]))->StrOfAE,
MAX_ERROR_MSG_SIZE);
LOCAL_ErrorMessage = LOCAL_ErrorSay;
} else {
strncpy(LOCAL_ErrorSay,
(char *) RepAtom(NameOfFunctor(FunctorOfTerm(nt[0])))->StrOfAE,
MAX_ERROR_MSG_SIZE);
LOCAL_ErrorMessage = LOCAL_ErrorSay;
}
nt[1] = TermNil;
switch (type) {
case RESOURCE_ERROR_HEAP:
case RESOURCE_ERROR_STACK:
case RESOURCE_ERROR_TRAIL:
comment = MkAtomTerm(Yap_LookupAtom(tmpbuf));
default:
if (comment != TermNil)
nt[1] = MkPairTerm(MkPairTerm(MkAtomTerm(Yap_LookupAtom("i")), comment),
nt[1]);
if (file && function) {
Term ts[3], t3;
ts[0] = MkAtomTerm(Yap_LookupAtom(file));
ts[1] = MkIntegerTerm(lineno);
ts[2] = MkAtomTerm(Yap_LookupAtom(function));
t3 = Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("c"), 3), 3, ts);
nt[1] =
MkPairTerm(MkPairTerm(MkAtomTerm(Yap_LookupAtom("c")), t3), nt[1]);
}
if ((location = Yap_pc_location(P, B, ENV)) != TermNil) {
nt[1] = MkPairTerm(MkPairTerm(MkAtomTerm(Yap_LookupAtom("p")), location),
nt[1]);
}
if ((location = Yap_env_location(CP, B, ENV, 0)) != TermNil) {
nt[1] = MkPairTerm(MkPairTerm(MkAtomTerm(Yap_LookupAtom("e")), location),
nt[1]);
}
}
}
/* disable active signals at this point */
LOCAL_Signals = 0;
CalculateStackGap(PASS_REGS1);
LOCAL_PrologMode &= ~InErrorMode;
/* we might be in the middle of a critical region */
if (LOCAL_InterruptsDisabled) {
LOCAL_InterruptsDisabled = 0;
LOCAL_UncaughtThrow = TRUE;
Yap_RestartYap(1);
}
#if DEBUG
// DumpActiveGoals( PASS_REGS1 );
#endif
/* wait if we we are in user code,
it's up to her to decide */
fun = FunctorError;
if (LOCAL_PrologMode & UserCCallMode) {
error_t = Yap_MkApplTerm(fun, 2, nt);
if (!(EX = Yap_StoreTermInDB(error_t, 2))) {
/* fat chance */
Yap_RestartYap(1);
}
} else {
if (type == ABORT_EVENT) {
error_t = MkAtomTerm(AtomDAbort);
} else {
error_t = Yap_MkApplTerm(fun, 2, nt);
}
Yap_JumpToEnv(error_t);
P = (yamop *)FAILCODE;
}
LOCAL_PrologMode &= ~InErrorMode;
return P;
}
static Int
is_boolean( USES_REGS1 )
{
Term t = Deref(ARG1);
//Term Context = Deref(ARG2)Yap_Error(INSTANTIATION_ERROR, t, NULL);;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, NULL);
return false;
}
return t == TermTrue || t == TermFalse;
}
static Int
is_atom( USES_REGS1 )
{
Term t = Deref(ARG1);
//Term Context = Deref(ARG2)Yap_Error(INSTANTIATION_ERROR, t, NULL);;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, NULL);
return false;
}
return IsAtomTerm( t );
}
static Int
is_callable( USES_REGS1 )
{
Term G = Deref(ARG1);
//Term Context = Deref(ARG2);
while (true) {
if (IsVarTerm(G)) {
Yap_Error(INSTANTIATION_ERROR, G, NULL);
return false;
}
if (IsApplTerm(G)) {
Functor f = FunctorOfTerm(G);
if (IsExtensionFunctor(f)) {
Yap_Error(TYPE_ERROR_CALLABLE, G, NULL);
}
if (f == FunctorModule) {
Term tm = ArgOfTerm( 1, G);
if (IsVarTerm(tm)) {
Yap_Error(INSTANTIATION_ERROR, G, NULL);
return false;
}
if (!IsAtomTerm(tm)) {
Yap_Error(TYPE_ERROR_CALLABLE, G, NULL);
return false;
}
G = ArgOfTerm( 2, G );
} else {
return true;
}
} else if (IsPairTerm(G) || IsAtomTerm(G)) {
return true;
} else {
Yap_Error(TYPE_ERROR_CALLABLE, G, NULL);
return false;
}
}
return false;
}
static Int
is_predicate_indicator( USES_REGS1 )
{
Term G = Deref(ARG1);
//Term Context = Deref(ARG2);
Term mod = CurrentModule;
G = Yap_YapStripModule(G, &mod);
if (IsVarTerm(G)) {
Yap_Error(INSTANTIATION_ERROR, G, NULL);
return false;
}
if (!IsVarTerm(mod) && !IsAtomTerm(mod)) {
Yap_Error(TYPE_ERROR_ATOM, G, NULL);
return false;
}
if (IsApplTerm(G)) {
Functor f = FunctorOfTerm(G);
if (IsExtensionFunctor(f)) {
Yap_Error(TYPE_ERROR_PREDICATE_INDICATOR, G, NULL);
}
if (f == FunctorSlash || f == FunctorDoubleSlash) {
return true;
}
}
Yap_Error(TYPE_ERROR_PREDICATE_INDICATOR, G, NULL);
return false;
}
void
Yap_InitErrorPreds( void )
{
CACHE_REGS
Term cm = CurrentModule;
CurrentModule = ERROR_MODULE;
Yap_InitCPred("is_boolean", 2, is_boolean, TestPredFlag);
Yap_InitCPred("is_callable", 2, is_callable, TestPredFlag);
Yap_InitCPred("is_atom", 2, is_atom, TestPredFlag);
Yap_InitCPred("is_predicate_indicator", 2, is_predicate_indicator, TestPredFlag);
CurrentModule = cm;
}

611
dev/yap-6.3/C/eval.c Normal file
View File

@ -0,0 +1,611 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: eval.c *
* Last rev: *
* mods: *
* comments: arithmetical expression evaluation *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
//! @file eval.c
//! @{
/**
@defgroup arithmetic_preds Arithmetic Predicates
@ingroup arithmetic
*/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "eval.h"
#if HAVE_STDARG_H
#include <stdarg.h>
#endif
#include <stdlib.h>
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_FENV_H
#include <fenv.h>
#endif
static Term Eval(Term t1 USES_REGS);
static Term
get_matrix_element(Term t1, Term t2 USES_REGS)
{
if (!IsPairTerm(t2)) {
if (t2 == MkAtomTerm(AtomLength)) {
Int sz = 1;
while (IsApplTerm(t1)) {
Functor f = FunctorOfTerm(t1);
if (NameOfFunctor(f) != AtomNil) {
return MkIntegerTerm(sz);
}
sz *= ArityOfFunctor(f);
t1 = ArgOfTerm(1, t1);
}
return MkIntegerTerm(sz);
}
Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]");
return FALSE;
}
while (IsPairTerm(t2)) {
Int indx;
Term indxt = Eval(HeadOfTerm(t2) PASS_REGS);
if (!IsIntegerTerm(indxt)) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]");
return FALSE;
}
indx = IntegerOfTerm(indxt);
if (!IsApplTerm(t1)) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]");
return FALSE;
} else {
Functor f = FunctorOfTerm(t1);
if (ArityOfFunctor(f) < indx) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]");
return FALSE;
}
}
t1 = ArgOfTerm(indx, t1);
t2 = TailOfTerm(t2);
}
if (t2 != TermNil) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]");
return FALSE;
}
return Eval(t1 PASS_REGS);
}
static Term
Eval(Term t USES_REGS)
{
if (IsVarTerm(t)) {
return Yap_ArithError(INSTANTIATION_ERROR,t,"in arithmetic");
} else if (IsNumTerm(t)) {
return t;
} else if (IsAtomTerm(t)) {
ExpEntry *p;
Atom name = AtomOfTerm(t);
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 0)))) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, takeIndicator(t),
"atom %s in arithmetic expression",
RepAtom(name)->StrOfAE);
}
return Yap_eval_atom(p->FOfEE);
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
if (fun == FunctorString) {
const char *s = (const char*)StringOfTerm(t);
if (s[1] == '\0')
return MkIntegerTerm(s[0]);
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"string in arithmetic expression");
} else if ((Atom)fun == AtomFoundVar) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil,
"cyclic term in arithmetic expression");
} else {
Int n = ArityOfFunctor(fun);
Atom name = NameOfFunctor(fun);
ExpEntry *p;
Term t1, t2;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, n)))) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, takeIndicator(t),
"functor %s/%d for arithmetic expression",
RepAtom(name)->StrOfAE,n);
}
if (p->FOfEE == op_power && p->ArityOfEE == 2) {
t2 = ArgOfTerm(2, t);
if (IsPairTerm(t2)) {
return get_matrix_element(ArgOfTerm(1, t), t2 PASS_REGS);
}
}
*RepAppl(t) = (CELL)AtomFoundVar;
t1 = Eval(ArgOfTerm(1,t) PASS_REGS);
if (t1 == 0L) {
*RepAppl(t) = (CELL)fun;
return FALSE;
}
if (n == 1) {
*RepAppl(t) = (CELL)fun;
return Yap_eval_unary(p->FOfEE, t1);
}
t2 = Eval(ArgOfTerm(2,t) PASS_REGS);
*RepAppl(t) = (CELL)fun;
if (t2 == 0L)
return FALSE;
return Yap_eval_binary(p->FOfEE,t1,t2);
}
} /* else if (IsPairTerm(t)) */ {
if (TailOfTerm(t) != TermNil) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"string must contain a single character to be evaluated as an arithmetic expression");
}
return Eval(HeadOfTerm(t) PASS_REGS);
}
}
Term
Yap_InnerEval__(Term t USES_REGS)
{
return Eval(t PASS_REGS);
}
#ifdef BEAM
Int BEAM_is(void);
Int
BEAM_is(void)
{ /* X is Y */
union arith_ret res;
blob_type bt;
bt = Eval(Deref(XREGS[2]), &res);
if (bt==db_ref_e) return (NULL);
return (EvalToTerm(bt,&res));
}
#endif
/**
@pred is( X:number, + Y:ground) is det
This predicate succeeds iff the result of evaluating the expression
_Y_ unifies with _X_. This is the predicate normally used to
perform evaluation of arithmetic expressions:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
X is 2+3*4
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
succeeds with `X = 14`.
Consult @ref arithmetic_operators for the complete list of arithmetic_operators
*/
/// @memberof is/2
static Int
p_is( USES_REGS1 )
{ /* X is Y */
Term out;
yap_error_number err;
Term t = Deref(ARG2);
if (IsVarTerm(t)) {
Yap_EvalError(INSTANTIATION_ERROR,t, "X is Y");
return(FALSE);
}
Yap_ClearExs();
do {
out = Yap_InnerEval(Deref(ARG2));
if ((err = Yap_FoundArithError()) == YAP_NO_ERROR)
break;
if (err == RESOURCE_ERROR_STACK) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 2, ENV, CP)) {
Yap_EvalError(RESOURCE_ERROR_STACK, ARG2, LOCAL_ErrorMessage);
return FALSE;
}
} else {
Yap_EvalError(err, takeIndicator( ARG2 ), "X is Exp");
return FALSE;
}
} while (TRUE);
return Yap_unify_constant(ARG1,out);
}
/**
@pred isnan(? X:float) is det
Interface to the IEE754 `isnan` test.
*/
/// @memberof isnan/1
static Int
p_isnan( USES_REGS1 )
{ /* X isnan Y */
Term out = 0L;
while (!(out = Eval(Deref(ARG1) PASS_REGS))) {
if (LOCAL_Error_TYPE == RESOURCE_ERROR_STACK) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 1, ENV, CP)) {
Yap_EvalError(RESOURCE_ERROR_STACK, ARG2, LOCAL_ErrorMessage);
return FALSE;
}
} else {
Yap_EvalError(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage);
return FALSE;
}
}
if (IsVarTerm(out)) {
Yap_EvalError(INSTANTIATION_ERROR, out, "isnan/1");
return FALSE;
}
if (!IsFloatTerm(out)) {
Yap_EvalError(TYPE_ERROR_FLOAT, out, "isnan/1");
return FALSE;
}
return isnan(FloatOfTerm(out));
}
/**
@pred isinf(? X:float) is det</b>
Interface to the IEE754 `isinf` test.
*/
/// @memberof isnan/1
static Int
p_isinf( USES_REGS1 )
{ /* X is Y */
Term out = 0L;
while (!(out = Eval(Deref(ARG1) PASS_REGS))) {
if (LOCAL_Error_TYPE == RESOURCE_ERROR_STACK) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 1, ENV, CP)) {
Yap_EvalError(RESOURCE_ERROR_STACK, ARG2, LOCAL_ErrorMessage);
return FALSE;
}
} else {
Yap_EvalError(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage);
return FALSE;
}
}
if (IsVarTerm(out)) {
Yap_EvalError(INSTANTIATION_ERROR, out, "isinf/1");
return FALSE;
}
if (!IsFloatTerm(out)) {
Yap_EvalError(TYPE_ERROR_FLOAT, out, "isinf/1");
return FALSE;
}
return isinf(FloatOfTerm(out));
}
/**
@pred logsum(+ Log1:float, + Log2:float, - Out:float ) is det
True if _Log1_ is the logarithm of the positive number _A1_,
_Log2_ is the logarithm of the positive number _A2_, and
_Out_ is the logarithm of the sum of the numbers _A1_ and
_A2_. Useful in probability computation.
*/
/// @memberof logsum/3
static Int
p_logsum( USES_REGS1 )
{ /* X is Y */
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
int done = FALSE;
Float f1, f2;
while (!done) {
if (IsFloatTerm(t1)) {
f1 = FloatOfTerm(t1);
done = TRUE;
} else if (IsIntegerTerm(t1)) {
f1 = IntegerOfTerm(t1);
done = TRUE;
#if USE_GMP
} else if (IsBigIntTerm(t1)) {
f1 = Yap_gmp_to_float(t1);
done = TRUE;
#endif
} else {
while (!(t1 = Eval(t1 PASS_REGS))) {
if (LOCAL_Error_TYPE == RESOURCE_ERROR_STACK) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 1, ENV, CP)) {
Yap_EvalError(RESOURCE_ERROR_STACK, ARG2, LOCAL_ErrorMessage);
return FALSE;
}
} else {
Yap_EvalError(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage);
return FALSE;
}
}
}
}
done = FALSE;
while (!done) {
if (IsFloatTerm(t2)) {
f2 = FloatOfTerm(t2);
done = TRUE;
} else if (IsIntegerTerm(t2)) {
f2 = IntegerOfTerm(t2);
done = TRUE;
#if USE_GMP
} else if (IsBigIntTerm(t2)) {
f2 = Yap_gmp_to_float(t2);
done = TRUE;
#endif
} else {
while (!(t2 = Eval(t2 PASS_REGS))) {
if (LOCAL_Error_TYPE == RESOURCE_ERROR_STACK) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 2, ENV, CP)) {
Yap_EvalError(RESOURCE_ERROR_STACK, ARG2, LOCAL_ErrorMessage);
return FALSE;
}
} else {
Yap_EvalError(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage);
return FALSE;
}
}
}
}
if (f1 >= f2) {
Float fi = exp(f2-f1);
return Yap_unify(ARG3,MkFloatTerm(f1+log(1+fi)));
} else {
Float fi = exp(f1-f2);
return Yap_unify(ARG3,MkFloatTerm(f2+log(1+fi)));
}
}
Int
Yap_ArithError__(const char *file, const char *function, int lineno, yap_error_number type, Term where,...)
{
CACHE_REGS
va_list ap;
char *format;
if (LOCAL_ArithError)
return 0L;
LOCAL_ArithError = TRUE;
LOCAL_Error_TYPE = type;
LOCAL_Error_File = file;
LOCAL_Error_Function = function;
LOCAL_Error_Lineno = lineno;
LOCAL_Error_Term = where;
if (!LOCAL_ErrorMessage)
LOCAL_ErrorMessage = LOCAL_ErrorSay;
va_start (ap, where);
format = va_arg( ap, char *);
if (format != NULL) {
#if HAVE_VSNPRINTF
(void) vsnprintf(LOCAL_ErrorMessage, MAX_ERROR_MSG_SIZE, format, ap);
#else
(void) vsprintf(LOCAL_ErrorMessage, format, ap);
#endif
} else {
LOCAL_ErrorMessage[0] = '\0';
}
va_end (ap);
return 0L;
}
yamop *
Yap_EvalError__(const char *file, const char *function, int lineno,yap_error_number type, Term where,...)
{
CACHE_REGS
va_list ap;
char *format;
if (LOCAL_ArithError) {
LOCAL_ArithError = YAP_NO_ERROR;
return Yap_Error__(file, function, lineno, LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage);
}
if (!LOCAL_ErrorMessage)
LOCAL_ErrorMessage = LOCAL_ErrorSay;
va_start (ap, where);
format = va_arg(ap, char *);
if (format != NULL) {
#if HAVE_VSNPRINTF
(void) vsnprintf(LOCAL_ErrorMessage, MAX_ERROR_MSG_SIZE, format, ap);
#else
(void) vsprintf(LOCAL_ErrorMessage, format, ap);
#endif
} else {
LOCAL_ErrorMessage[0] = '\0';
}
va_end (ap);
return Yap_Error__(file, function, lineno, type, where, LOCAL_ErrorMessage);
}
/**
@pred between(+ Low:int, + High:int, ? Value:int) is nondet
_Low_ and _High_ are integers, _High_ \>= _Low_. If
_Value_ is an integer, _Low_ =\< _Value_
=\< _High_. When _Value_ is a variable it is successively
bound to all integers between _Low_ and _High_. If
_High_ is inf or infinite between/3 is true iff
_Value_ \>= _Low_, a feature that is particularly interesting
for generating integers from a certain value.
*/
/// @memberof between/3
static Int cont_between( USES_REGS1 )
{
Term t1 = EXTRA_CBACK_ARG(3,1);
Term t2 = EXTRA_CBACK_ARG(3,2);
Yap_unify(ARG3, t1);
if (IsIntegerTerm(t1)) {
Int i1;
Term tn;
if (t1 == t2)
cut_succeed();
i1 = IntegerOfTerm(t1);
tn = add_int(i1, 1 PASS_REGS);
EXTRA_CBACK_ARG(3,1) = tn;
HB = B->cp_h = HR;
return TRUE;
} else {
Term t[2];
Term tn;
Int cmp;
cmp = Yap_acmp(t1, t2 PASS_REGS);
if (cmp == 0)
cut_succeed();
t[0] = t1;
t[1] = MkIntTerm(1);
tn = Eval(Yap_MkApplTerm(FunctorPlus, 2, t) PASS_REGS);
EXTRA_CBACK_ARG(3,1) = tn;
HB = B->cp_h = HR;
return TRUE;
}
}
/// @memberof between/3
static Int
init_between( USES_REGS1 )
{
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
if (IsVarTerm(t1)) {
Yap_EvalError(INSTANTIATION_ERROR, t1, "between/3");
return FALSE;
}
if (IsVarTerm(t2)) {
Yap_EvalError(INSTANTIATION_ERROR, t1, "between/3");
return FALSE;
}
if (!IsIntegerTerm(t1) &&
!IsBigIntTerm(t1)) {
Yap_EvalError(TYPE_ERROR_INTEGER, t1, "between/3");
return FALSE;
}
if (!IsIntegerTerm(t2) &&
!IsBigIntTerm(t2) &&
t2 != MkAtomTerm(AtomInf) &&
t2 != MkAtomTerm(AtomInfinity)) {
Yap_EvalError(TYPE_ERROR_INTEGER, t2, "between/3");
return FALSE;
}
if (IsIntegerTerm(t1) && IsIntegerTerm(t2)) {
Int i1 = IntegerOfTerm(t1);
Int i2 = IntegerOfTerm(t2);
Term t3;
t3 = Deref(ARG3);
if (!IsVarTerm(t3)) {
if (!IsIntegerTerm(t3)) {
if (!IsBigIntTerm(t3)) {
Yap_EvalError(TYPE_ERROR_INTEGER, t3, "between/3");
return FALSE;
}
cut_fail();
} else {
Int i3 = IntegerOfTerm(t3);
if (i3 >= i1 && i3 <= i2)
cut_succeed();
cut_fail();
}
}
if (i1 > i2) cut_fail();
if (i1 == i2) {
Yap_unify(ARG3, t1);
cut_succeed();
}
} else if (IsIntegerTerm(t1) && IsAtomTerm(t2)) {
Int i1 = IntegerOfTerm(t1);
Term t3;
t3 = Deref(ARG3);
if (!IsVarTerm(t3)) {
if (!IsIntegerTerm(t3)) {
if (!IsBigIntTerm(t3)) {
Yap_EvalError(TYPE_ERROR_INTEGER, t3, "between/3");
return FALSE;
}
cut_fail();
} else {
Int i3 = IntegerOfTerm(t3);
if (i3 >= i1)
cut_succeed();
cut_fail();
}
}
} else {
Term t3 = Deref(ARG3);
Int cmp;
if (!IsVarTerm(t3)) {
if (!IsIntegerTerm(t3) && !IsBigIntTerm(t3)) {
Yap_EvalError(TYPE_ERROR_INTEGER, t3, "between/3");
return FALSE;
}
if (Yap_acmp(t3, t1 PASS_REGS) >= 0 && Yap_acmp(t2,t3 PASS_REGS) >= 0 && P != FAILCODE)
cut_succeed();
cut_fail();
}
cmp = Yap_acmp(t1, t2 PASS_REGS);
if (cmp > 0) cut_fail();
if (cmp == 0) {
Yap_unify(ARG3, t1);
cut_succeed();
}
}
EXTRA_CBACK_ARG(3,1) = t1;
EXTRA_CBACK_ARG(3,2) = t2;
return cont_between( PASS_REGS1 );
}
void
Yap_InitEval(void)
{
/* here are the arithmetical predicates */
Yap_InitConstExps();
Yap_InitUnaryExps();
Yap_InitBinaryExps();
Yap_InitCPred("is", 2, p_is, 0L);
Yap_InitCPred("isnan", 1, p_isnan, TestPredFlag);
Yap_InitCPred("isinf", 1, p_isinf, TestPredFlag);
Yap_InitCPred("logsum", 3, p_logsum, TestPredFlag);
Yap_InitCPredBack("between", 3, 2, init_between, cont_between, 0);
}
/**
*
* @}
*/

1899
dev/yap-6.3/C/exec.c Normal file
View File

File diff suppressed because it is too large Load Diff

787
dev/yap-6.3/C/exo.c Normal file
View File

@ -0,0 +1,787 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: exo.c *
* comments: Exo compilation *
* *
* Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ * *
* $Log: not supported by cvs2svn $ *
* *
* *
*************************************************************************/
#include "Yap.h"
#include "clause.h"
#include "yapio.h"
#include "eval.h"
#include "tracer.h"
#ifdef YAPOR
#include "or.macros.h"
#endif /* YAPOR */
#ifdef TABLING
#include "tab.macros.h"
#endif /* TABLING */
#if HAVE_STRING_H
#include <string.h>
#endif
#if HAVE_STRING_H
#include <string.h>
#endif
#if HAVE_STDBOOL_H
#include <stdbool.h>
#endif
bool YAP_NewExo( PredEntry *ap, size_t data, struct udi_info *udi);
bool YAP_AssertTuples( PredEntry *pe, const Term *ts, size_t offset, size_t m);
//static int exo_write=FALSE;
//void do_write(void) { exo_write=TRUE;}
#define MAX_ARITY 256
#if SIZEOF_INT_P==4
#define FNV32_PRIME (16777619UL)
#define FNV32_OFFSET (0x811c9dc5UL)
#define FNV_PRIME FNV32_PRIME
#define FNV_OFFSET FNV32_OFFSET
#elif SIZEOF_INT_P==8
#define FNV64_PRIME (1099511628211)
#if SIZEOF_LONG_INT==4
#define FNV64_OFFSET (14695981039346656037ULL)
#else
#define FNV64_OFFSET (14695981039346656037UL)
#endif
#define FNV_PRIME FNV64_PRIME
#define FNV_OFFSET FNV64_OFFSET
#endif
/*MurmurHash3 from: https://code.google.com/p/smhasher/wiki/MurmurHash3*/
BITS32 rotl32 ( BITS32, int8_t);
inline BITS32 rotl32 ( BITS32 x, int8_t r )
{
return (x << r) | (x >> (32 - r));
}
#define ROTL32(x,y) rotl32(x,y)
//-----------------------------------------------------------------------------
// Finalization mix - force all bits of a hash block to avalanche
BITS32 fmix32 ( BITS32 );
inline BITS32 fmix32 ( BITS32 h )
{
h ^= h >> 16;
h *= 0x85ebca6b;
h ^= h >> 13;
h *= 0xc2b2ae35;
h ^= h >> 16;
return h;
}
//-----------------------------------------------------------------------------
INLINE_ONLY inline BITS32
HASH_MURMUR3_32 (UInt arity, CELL *cl, UInt bnds[], UInt sz);
INLINE_ONLY inline BITS32
HASH_MURMUR3_32 (UInt arity, CELL *cl, UInt bnds[], UInt sz)
{
UInt hash;
UInt j=0;
int len = 0;
const BITS32 c1 = 0xcc9e2d51;
const BITS32 c2 = 0x1b873593;
hash = FNV_OFFSET; /*did not find what seed to use yet*/
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
BITS32 k1 = i[0];
k1 *= c1;
k1 = ROTL32(k1,15);
k1 *= c2;
hash ^= k1;
hash = ROTL32(hash,13);
hash = hash*5+0xe6546b64;
i++;
len++;
}
}
j++;
}
//----------
// tail not used becouse len is block multiple
//----------
// finalization
hash ^= len;
hash = fmix32(hash);
return hash;
}
/*DJB2*/
#define DJB2_OFFSET 5381
INLINE_ONLY inline BITS32
HASH_DJB2(UInt arity, CELL *cl, UInt bnds[], UInt sz);
INLINE_ONLY inline BITS32
HASH_DJB2(UInt arity, CELL *cl, UInt bnds[], UInt sz)
{
BITS32 hash;
UInt j=0;
hash = DJB2_OFFSET;
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
BITS32 h5 = hash << 5;
hash += h5 + i[0]; /* hash * 33 + i[0] */
i++;
}
}
j++;
}
return hash;
}
INLINE_ONLY inline BITS32
HASH_RS(UInt arity, CELL *cl, UInt bnds[], UInt sz);
/* RS Hash Function */
INLINE_ONLY inline BITS32
HASH_RS(UInt arity, CELL *cl, UInt bnds[], UInt sz)
{
UInt hash=0;
UInt j=0;
UInt b = 378551;
UInt a = 63689;
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
hash = hash * a + i[0];
a = a * b;
i++;
}
}
j++;
}
return hash;
}
INLINE_ONLY inline BITS32
HASH_FVN_1A(UInt arity, CELL *cl, UInt bnds[], UInt sz);
/* Simple hash function:
FVN-1A
first component is the base key.
hash0 spreads extensions coming from different elements.
spread over j quadrants.
*/
INLINE_ONLY inline BITS32
HASH_FVN_1A(UInt arity, CELL *cl, UInt bnds[], UInt sz)
{
UInt hash;
UInt j=0;
hash = FNV_OFFSET;
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
hash = hash ^ i[0];
hash = hash * FNV_PRIME;
i++;
}
}
j++;
}
return hash;
}
//#define TEST_HASH_DJB 1
#if defined TEST_HASH_MURMUR
# define HASH(...) HASH_MURMUR3_32(__VA_ARGS__)
#elif defined TEST_HASH_DJB
# define HASH(...) HASH_DJB2(__VA_ARGS__)
#elif defined TEST_HASH_RS
# define HASH(...) HASH_RS(__VA_ARGS__)
#else
/* Default: TEST_HASH_FVN */
# define HASH(...) HASH_FVN_1A(__VA_ARGS__)
# define HASH1(...) HASH_MURMUR3_32(__VA_ARGS__)
#endif
static BITS32
NEXT(UInt arity, CELL *cl, UInt bnds[], UInt sz, BITS32 hash)
{
int i = 0;
BITS32 hash1;
while (bnds[i]==0) i++;
hash1 = HASH1(arity, cl, bnds, sz);
return (hash + hash1 +cl[i]);
}
/* search for matching elements */
static int
MATCH(CELL *clp, CELL *kvp, UInt arity, UInt bnds[])
{
UInt j = 0;
while (j< arity) {
if ( bnds[j] && clp[j] != kvp[j])
return FALSE;
j++;
}
return TRUE;
}
static void
ADD_TO_TRY_CHAIN(CELL *kvp, CELL *cl, struct index_t *it)
{
BITS32 old = EXO_ADDRESS_TO_OFFSET(it, kvp);
BITS32 new = EXO_ADDRESS_TO_OFFSET(it, cl);
BITS32 *links = it->links;
BITS32 tmp = links[old]; /* points to the end of the chain */
if (!tmp) {
links[old] = links[new] = new;
} else {
links[new] = links[tmp];
links[tmp] = new;
links[old] = new;
}
}
/* This is the critical routine, it builds the hash table *
* each HT field stores a key pointer which is actually
* a pointer to the point in the clause where one can find the element.
*
* The cls table indexes all elements that can be reached using that key.
*
* Insert:
* j = first
* not match cij -> insert, open new chain
* match ci..j ck..j -> find j = minarg(cij \= c2j),
* else j = +inf -> c2+ci
* Lookup:
* j= first
* not match cij -> fail
* match ci..j ck..j -> find j = minarg(cij \= c2j)
* else
*/
static int
INSERT(CELL *cl, struct index_t *it, UInt arity, UInt base, UInt bnds[])
{
CELL *kvp;
BITS32 hash;
int coll_count = 0;
hash = HASH(arity, cl, bnds, it->hsize);
next:
kvp = EXO_OFFSET_TO_ADDRESS(it, it->key [hash % it->hsize]);
if (kvp == NULL) {
/* simple case, new entry */
it->nentries++;
it->key[hash % it->hsize ] = EXO_ADDRESS_TO_OFFSET(it, cl);
if (coll_count > it -> max_col_count)
it->max_col_count = coll_count;
return TRUE;
} else if (MATCH(kvp, cl, arity, bnds)) {
it->ntrys++;
ADD_TO_TRY_CHAIN(kvp, cl, it);
return TRUE;
} else {
coll_count++;
it->ncollisions++;
// printf("#");
hash = NEXT(arity, cl, bnds, it->hsize, hash);
//if (exo_write) printf("N=%ld\n", hash);
goto next;
}
}
static yamop *
LOOKUP(struct index_t *it, UInt arity, UInt j, UInt bnds[])
{
CACHE_REGS
CELL *kvp;
BITS32 hash;
/* j is the firs bound element */
/* check if we match */
hash = HASH(arity, XREGS+1, bnds, it->hsize);
next:
/* loop to insert element */
kvp = EXO_OFFSET_TO_ADDRESS(it, it->key[hash % it->hsize]);
if (kvp == NULL) {
/* simple case, no element */
return FAILCODE;
} else if (MATCH(kvp, XREGS+1, arity, bnds)) {
S = kvp;
if (!it->is_key && it->links[EXO_ADDRESS_TO_OFFSET(it, S)])
return it->code;
else
return NEXTOP(NEXTOP(it->code,lp),lp);
} else {
/* collision */
hash = NEXT(arity, XREGS+1, bnds, it->hsize, hash);
goto next;
}
}
static int
fill_hash(UInt bmap, struct index_t *it, UInt bnds[])
{
UInt i;
UInt arity = it->arity;
CELL *cl = it->cls;
for (i=0; i < it->nels; i++) {
if (!INSERT(cl, it, arity, 0, bnds))
return FALSE;
cl += arity;
}
for (i=0; i < it->hsize; i++) {
if (it->key[i]) {
BITS32 offset = it->key[i];
BITS32 last = it->links[offset];
if (last) {
/* the chain used to point straight to the last, and the last back to the original first */
it->links[offset] = it->links[last];
it->links[last] = 0;
}
}
}
return TRUE;
}
static struct index_t *
add_index(struct index_t **ip, UInt bmap, PredEntry *ap, UInt count)
{
CACHE_REGS
UInt ncls = ap->cs.p_code.NOfClauses, j;
CELL *base = NULL;
struct index_t *i;
size_t sz, dsz;
yamop *ptr;
UInt *bnds = LOCAL_ibnds;
sz = (CELL)NEXTOP(NEXTOP((yamop*)NULL,lp),lp)+ap->ArityOfPE*(CELL)NEXTOP((yamop *)NULL,x) +(CELL)NEXTOP(NEXTOP((yamop *)NULL,p),l);
if (!(i = (struct index_t *)Yap_AllocCodeSpace(sizeof(struct index_t)+sz))) {
CACHE_REGS
save_machine_regs();
LOCAL_Error_Size = 3*ncls*sizeof(CELL);
LOCAL_ErrorMessage = "not enough space to index";
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, LOCAL_ErrorMessage);
return NULL;
}
i->is_key = FALSE;
i->next = *ip;
i->prev = NULL;
i->nels = ncls;
i->arity = ap->ArityOfPE;
i->ap = ap;
i->bmap = bmap;
i->is_key = FALSE;
i->hsize = 2*ncls;
dsz = sizeof(BITS32)*(ncls+1+i->hsize);
if (count) {
if (!(base = (CELL *)Yap_AllocCodeSpace(dsz))) {
CACHE_REGS
save_machine_regs();
LOCAL_Error_Size = dsz;
LOCAL_ErrorMessage = "not enough space to generate indices";
Yap_FreeCodeSpace((void *)i);
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, LOCAL_ErrorMessage);
return NULL;
}
memset(base, 0, dsz);
}
i->size = sz+dsz+sizeof(struct index_t);
i->key = (BITS32 *)base;
i->links = (BITS32 *)base+i->hsize;
i->ncollisions = i->nentries = i->ntrys = 0;
i->cls = (CELL *)((ADDR)ap->cs.p_code.FirstClause+2*sizeof(struct index_t *));
i->bcls= i->cls-i->arity;
i->udi_free_args = 0;
i->is_udi = FALSE;
i->udi_arg = 0;
*ip = i;
while (count) {
if (!fill_hash(bmap, i, bnds)) {
size_t sz;
i->hsize += ncls;
if (i->is_key) {
sz = i->hsize*sizeof(BITS32);
} else {
sz = (ncls+1+i->hsize)*sizeof(BITS32);
}
if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, sz))
return FALSE;
memset(base, 0, sz);
i->key = (BITS32 *)base;
i->links = (BITS32 *)(base+i->hsize);
i->ncollisions = i->nentries = i->ntrys = 0;
continue;
}
#if DEBUG
fprintf(stderr, "entries=" UInt_FORMAT " collisions=" UInt_FORMAT" (max=" UInt_FORMAT ") trys=" UInt_FORMAT "\n", i->nentries, i->ncollisions, i->max_col_count, i->ntrys);
#endif
if (!i->ntrys && !i->is_key) {
i->is_key = TRUE;
if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, i->hsize*sizeof(BITS32)))
return FALSE;
}
/* our hash table is just too large */
if (( i->nentries+i->ncollisions )*10 < i->hsize) {
size_t sz;
i->hsize = ( i->nentries+i->ncollisions )*10;
if (i->is_key) {
sz = i->hsize*sizeof(BITS32);
} else {
sz = (ncls+1+i->hsize)*sizeof(BITS32);
}
if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, sz))
return FALSE;
memset(base, 0, sz);
i->key = (BITS32 *)base;
i->links = (BITS32 *)base+i->hsize;
i->ncollisions = i->nentries = i->ntrys = 0;
} else {
break;
}
}
ptr = (yamop *)(i+1);
i->code = ptr;
if (count)
ptr->opc = Yap_opcode(_try_exo);
else
ptr->opc = Yap_opcode(_try_all_exo);
ptr->y_u.lp.l = (yamop *)i;
ptr->y_u.lp.p = ap;
ptr = NEXTOP(ptr, lp);
if (count)
ptr->opc = Yap_opcode(_retry_exo);
else
ptr->opc = Yap_opcode(_retry_all_exo);
ptr->y_u.lp.p = ap;
ptr->y_u.lp.l = (yamop *)i;
ptr = NEXTOP(ptr, lp);
for (j = 0; j < i->arity; j++) {
ptr->opc = Yap_opcode(_get_atom_exo);
#if PRECOMPUTE_REGADDRESS
ptr->y_u.x.x = (CELL) (XREGS + (j+1));
#else
ptr->y_u.x.x = j+1;
#endif
ptr = NEXTOP(ptr, x);
}
ptr->opc = Yap_opcode(_procceed);
ptr->y_u.p.p = ap;
ptr = NEXTOP(ptr, p);
ptr->opc = Yap_opcode(_Ystop);
ptr->y_u.l.l = i->code;
Yap_inform_profiler_of_clause((char *)(i->code), (char *)NEXTOP(ptr,l), ap, GPROF_INDEX);
if (ap->PredFlags & UDIPredFlag) {
Yap_new_udi_clause( ap, NULL, (Term)ip);
} else {
i->is_udi = FALSE;
}
return i;
}
yamop *
Yap_ExoLookup(PredEntry *ap USES_REGS)
{
UInt arity = ap->ArityOfPE;
UInt bmap = 0L, bit = 1, count = 0, j, j0 = 0;
struct index_t **ip = (struct index_t **)(ap->cs.p_code.FirstClause);
struct index_t *i = *ip;
for (j=0; j< arity; j++, bit<<=1) {
Term t = Deref(XREGS[j+1]);
if (!IsVarTerm(t)) {
bmap += bit;
LOCAL_ibnds[j] = TRUE;
if (!count) j0= j;
count++;
} else {
LOCAL_ibnds[j] = FALSE;
}
XREGS[j+1] = t;
}
while (i) {
// if (i->is_key && (i->bmap & bmap) == i->bmap) {
// break;
// }
if (i->bmap == bmap) {
break;
}
ip = &i->next;
i = i->next;
}
if (!i) {
i = add_index(ip, bmap, ap, count);
}
if (count) {
yamop *code = LOOKUP(i, arity, j0, LOCAL_ibnds);
if (code == FAILCODE)
return code;
if (i->is_udi)
return ((CEnterExoIndex)i->udi_first)(i PASS_REGS);
else
return code;
} else if(i->is_udi) {
return ((CEnterExoIndex)i->udi_first)(i PASS_REGS);
} else {
return i->code;
}
}
CELL
Yap_NextExo(choiceptr cptr, struct index_t *it)
{
CACHE_REGS
BITS32 offset = ADDRESS_TO_LINK(it,(BITS32 *)((CELL *)(B+1))[it->arity]);
BITS32 next = it->links[offset];
((CELL *)(B+1))[it->arity] = (CELL)LINK_TO_ADDRESS(it, next);
S = it->cls+it->arity*offset;
return next;
}
static MegaClause *
exodb_get_space( Term t, Term mod, Term tn )
{
UInt arity;
Prop pe;
PredEntry *ap;
MegaClause *mcl;
UInt ncls;
UInt required;
struct index_t **li;
if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
return NULL;
}
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
arity = 0;
pe = PredPropByAtom(a, mod);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
arity = ArityOfFunctor(f);
pe = PredPropByFunc(f, mod);
} else {
return NULL;
}
if (EndOfPAEntr(pe))
return NULL;
ap = RepPredProp(pe);
if (ap->PredFlags & (DynamicPredFlag|LogUpdatePredFlag
#ifdef TABLING
|TabledPredFlag
#endif /* TABLING */
)) {
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE,t,"dbload_get_space/4");
return NULL;
}
if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
return NULL;
}
ncls = IntegerOfTerm(tn);
if (ncls <= 1) {
return NULL;
}
required = ncls*arity*sizeof(CELL)+sizeof(MegaClause)+2*sizeof(struct index_t *);
while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
if (!Yap_growheap(FALSE, required, NULL)) {
/* just fail, the system will keep on going */
return NULL;
}
}
Yap_ClauseSpace += required;
/* cool, it's our turn to do the conversion */
mcl->ClFlags = MegaMask|ExoMask;
mcl->ClSize = required;
mcl->ClPred = ap;
mcl->ClItemSize = arity*sizeof(CELL);
mcl->ClNext = NULL;
li = (struct index_t **)(mcl->ClCode);
li[0] = li[1] = NULL;
ap->cs.p_code.FirstClause =
ap->cs.p_code.LastClause =
mcl->ClCode;
ap->PredFlags |= MegaClausePredFlag;
ap->cs.p_code.NOfClauses = ncls;
if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
ap->OpcodeOfPred = Yap_opcode(_spy_pred);
} else {
ap->OpcodeOfPred = Yap_opcode(_enter_exo);
}
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
return mcl;
}
bool
YAP_NewExo( PredEntry *ap, size_t data, struct udi_info *udi)
{
MegaClause *mcl;
size_t required;
struct index_t **li;
if (data <= ap->ArityOfPE*sizeof(CELL)) {
return false;
}
// data = ncls*arity*sizeof(CELL);
required = data+sizeof(MegaClause)+2*sizeof(struct index_t *);
while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
if (!Yap_growheap(FALSE, required, NULL)) {
/* just fail, the system will keep on going */
return false;
}
}
Yap_ClauseSpace += required;
/* cool, it's our turn to do the conversion */
mcl->ClFlags = MegaMask|ExoMask;
mcl->ClSize = required;
mcl->ClPred = ap;
mcl->ClItemSize = ap->ArityOfPE*sizeof(CELL);
mcl->ClNext = NULL;
li = (struct index_t **)(mcl->ClCode);
li[0] = li[1] = NULL;
ap->cs.p_code.FirstClause =
ap->cs.p_code.LastClause =
mcl->ClCode;
ap->PredFlags |= MegaClausePredFlag;
ap->cs.p_code.NOfClauses = 0;
if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
ap->OpcodeOfPred = Yap_opcode(_spy_pred);
} else {
ap->OpcodeOfPred = Yap_opcode(_enter_exo);
}
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
return true;
}
static Int
p_exodb_get_space( USES_REGS1 )
{ /* '$number_of_clauses'(Predicate,M,N) */
void *mcl;
if ((mcl = exodb_get_space(Deref(ARG1), Deref(ARG2), Deref(ARG3))) == NULL)
return FALSE;
return Yap_unify(ARG4, MkIntegerTerm((Int)mcl));
}
#define DerefAndCheck(t, V) \
t = Deref(V); if(IsVarTerm(t) || !(IsAtomOrIntTerm(t))) Yap_Error(TYPE_ERROR_ATOMIC, t0, "load_db");
static Int
store_exo(yamop *pc, UInt arity, Term t0)
{
Term t;
CELL *tp = RepAppl(t0)+1,
*cpc = (CELL *)pc;
UInt i;
for (i = 0; i< arity; i++) {
DerefAndCheck(t, tp[0]);
*cpc = t;
// Yap_DebugPlWrite(t); fprintf(stderr,"\n");
tp++;
cpc++;
}
//fprintf(stderr,"\n");
return TRUE;
}
bool
YAP_AssertTuples( PredEntry *pe, const Term *ts, size_t offset, size_t m)
{
MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
size_t i;
ADDR base = (ADDR)mcl->ClCode+2*sizeof(struct index_t *);
for (i=0; i<m; i++) {
yamop *ptr = (yamop *)(base+offset*(mcl->ClItemSize));
store_exo( ptr, pe->ArityOfPE, ts[i]);
}
return true;
}
static void
exoassert( void *handle, Int n, Term term )
{ /* '$number_of_clauses'(Predicate,M,N) */
PredEntry *pe;
MegaClause *mcl;
mcl = (MegaClause *) handle;
pe = mcl->ClPred;
store_exo((yamop *)((ADDR)mcl->ClCode+2*sizeof(struct index_t *)+n*(mcl->ClItemSize)),pe->ArityOfPE, term);
}
static Int
p_exoassert( USES_REGS1 )
{ /* '$number_of_clauses'(Predicate,M,N) */
Term thandle = Deref(ARG2);
Term tn = Deref(ARG3);
MegaClause *mcl;
Int n;
if (IsVarTerm(thandle) || !IsIntegerTerm(thandle)) {
return FALSE;
}
mcl = (MegaClause *)IntegerOfTerm(thandle);
if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
return FALSE;
}
n = IntegerOfTerm(tn);
exoassert(mcl,n,Deref(ARG1));
return TRUE;
}
void
Yap_InitExoPreds(void)
{
CACHE_REGS
Term cm = CurrentModule;
CurrentModule = DBLOAD_MODULE;
Yap_InitCPred("exo_db_get_space", 4, p_exodb_get_space, 0L);
Yap_InitCPred("exoassert", 3, p_exoassert, 0L);
CurrentModule = cm;
}

588
dev/yap-6.3/C/exo_udi.c Normal file
View File

@ -0,0 +1,588 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: exo.c *
* comments: Exo compilation *
* *
* Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ * *
* $Log: not supported by cvs2svn $ *
* *
* *
*************************************************************************/
#include "Yap.h"
#include "clause.h"
#include "yapio.h"
#include "eval.h"
#include "tracer.h"
#include "attvar.h"
#ifdef YAPOR
#include "or.macros.h"
#endif /* YAPOR */
#ifdef TABLING
#include "tab.macros.h"
#endif /* TABLING */
#if HAVE_STRING_H
#include <string.h>
#endif
#include <udi.h>
static int
compar(const void *ip0, const void *jp0) {
CACHE_REGS
BITS32 *ip = (BITS32 *)ip0, *jp = (BITS32 *)jp0;
Term i = EXO_OFFSET_TO_ADDRESS(LOCAL_exo_it, *ip)[LOCAL_exo_arg];
Term j = EXO_OFFSET_TO_ADDRESS(LOCAL_exo_it, *jp)[LOCAL_exo_arg];
//fprintf(stderr, "%ld-%ld\n", IntOfTerm(i), IntOfTerm(j));
return IntOfTerm(i)-IntOfTerm(j);
}
static Int
cmp_extra_args(CELL *si, CELL *sj, struct index_t *it)
{
UInt m = it->udi_free_args;
UInt m0 = 1, x;
for (x=0; x< it->arity; x++) {
if (m0 & m) {
if (si[x] != sj[x]) {
if (IsIntTerm(si[x]))
return IntOfTerm(si[x])-IntOfTerm(sj[x]);
return AtomOfTerm(si[x])-AtomOfTerm(sj[x]);
}
m -= m0;
if (m == 0)
return 0;
}
m0 <<= 1;
}
return 0;
}
static int
compar2(const void *ip0, const void *jp0) {
CACHE_REGS
BITS32 *ip = (BITS32 *)ip0, *jp = (BITS32 *)jp0;
struct index_t *it = LOCAL_exo_it;
Term* si = EXO_OFFSET_TO_ADDRESS(it, *ip);
Term* sj = EXO_OFFSET_TO_ADDRESS(it, *jp);
int cmp = cmp_extra_args(si, sj, it);
if (cmp)
return cmp;
return IntOfTerm(si[LOCAL_exo_arg])-IntOfTerm(sj[LOCAL_exo_arg]);
}
static int
compare(const BITS32 *ip, Int j USES_REGS) {
Term i = EXO_OFFSET_TO_ADDRESS(LOCAL_exo_it, *ip)[LOCAL_exo_arg];
//fprintf(stderr, "%ld-%ld\n", IntOfTerm(i), j);
return IntOfTerm(i)-j;
}
static UInt free_args(UInt b[], UInt arity, UInt i) {
UInt j;
UInt rc = 0;
for (j=0; j<arity; j++) {
if (i !=j && b[j] == 0)
rc |= 1<<j;
}
return rc;
}
static BITS32*
NEXT_DIFFERENT(BITS32 *pt0, BITS32 *pte, struct index_t *it)
{
Term* si = EXO_OFFSET_TO_ADDRESS(it, pt0[0]);
Term* sj;
do {
pt0++;
if (pt0 == pte)
return NULL;
sj = EXO_OFFSET_TO_ADDRESS(it, *pt0);
} while (!cmp_extra_args(si, sj, it));
return pt0;
}
static BITS32*
PREV_DIFFERENT(BITS32 *pt0, BITS32 *pte, struct index_t *it)
{
Term* si = EXO_OFFSET_TO_ADDRESS(it, pt0[0]);
Term* sj;
do {
pt0--;
if (pt0 == pte)
return NULL;
sj = EXO_OFFSET_TO_ADDRESS(it, *pt0);
} while (!cmp_extra_args(si, sj, it));
return pt0;
}
static BITS32*
NEXT_MIN(BITS32 *pt0, BITS32 *pte, Term tmin, Term tmax, struct index_t *it)
{
Term* si = EXO_OFFSET_TO_ADDRESS(it, pt0[0]);
int do_min, do_max;
Int min = 0, max = 0;
if (IsVarTerm(tmin)) {
do_min = FALSE;
} else {
do_min = TRUE;
min = IntOfTerm(tmin);
}
if (IsVarTerm(tmax)) {
do_max = FALSE;
} else {
do_max = TRUE;
max = IntOfTerm(tmax);
}
while ((do_min && IntOfTerm(si[it->udi_arg]) < min) ||
(do_max && IntOfTerm(si[it->udi_arg]) > max)) {
pt0++;
if (pt0 == pte)
return NULL;
si = EXO_OFFSET_TO_ADDRESS(it, *pt0);
}
return pt0;
}
static BITS32*
NEXT_MAX(BITS32 *pt0, BITS32 *pte, Term tmin, Term tmax, struct index_t *it)
{
Term* si = EXO_OFFSET_TO_ADDRESS(it, pt0[0]);
int do_min, do_max;
Int min = 0, max = 0;
if (IsVarTerm(tmin)) {
do_min = FALSE;
} else {
do_min = TRUE;
min = IntOfTerm(tmin);
}
if (IsVarTerm(tmax)) {
do_max = FALSE;
} else {
do_max = TRUE;
max = IntOfTerm(tmax);
}
while ((do_min && IntOfTerm(si[it->udi_arg]) < min) ||
(do_max && IntOfTerm(si[it->udi_arg]) > max)) {
pt0--;
if (pt0 == pte)
return NULL;
si = EXO_OFFSET_TO_ADDRESS(it, *pt0);
}
return pt0;
}
static void
IntervalUDIRefitIndex(struct index_t **ip, UInt b[] USES_REGS)
{
size_t sz;
struct index_t *it = *ip;
yamop *code;
/* hard-wired implementation for the Interval case */
Int i = it->udi_arg;
/* it is bound, use hash */
if (it->bmap & b[i]) return;
/* no constraints, nothing to gain */
//if (!IsAttVar(VarOfTerm(Deref(XREGS[i+1])))) return;
LOCAL_exo_it = it;
LOCAL_exo_base = it->bcls;
LOCAL_exo_arity = it->arity;
LOCAL_exo_arg = i;
it->udi_free_args = free_args(b, it->arity, i);
if (!it->key) {
UInt ncls = it->ap->cs.p_code.NOfClauses, i;
BITS32 *sorted;
/* handle ll variables */
sz = sizeof(BITS32)*(ncls);
/* allocate space */
if (!(it->udi_data = (BITS32*)Yap_AllocCodeSpace(sz)))
return;
sorted = (BITS32*)it->udi_data;
for (i=0; i< ncls; i++)
sorted[i] = i;
qsort(sorted, (size_t)ncls, sizeof(BITS32), compar);
it->links = NULL;
} else {
BITS32 *sorted0, *sorted;
/* be conservative */
if (it->udi_free_args)
sz = sizeof(BITS32)*(2*it->ntrys+3*it->nentries);
else
sz = sizeof(BITS32)*(it->ntrys+2*it->nentries);
/* allocate space */
if (!(it->udi_data = (BITS32*)malloc(sz)))
return;
sorted0 = sorted = (BITS32 *)it->udi_data;
sorted++; /* leave an initial hole */
for (i=0; i < it->hsize; i++) {
if (it->key[i]) {
BITS32 *s0 = sorted;
BITS32 offset = it->key[i], offset0 = offset;
*sorted++ = 0;
do {
*sorted++ = offset;
offset = it->links[offset];
} while (offset);
// S = EXO_OFFSET_TO_ADDRESS(it, offset0); Yap_DebugPlWrite(S[0]);
// fprintf(stderr, " key[i]=%d offset=%d %d\n", it->key[i], offset0, (sorted-s0)-1);
if (sorted-s0 == 2) {
it->links[offset0] = 0;
sorted = s0;
} else {
/* number of elements comes first */
*s0 = sorted - (s0+1);
qsort(s0+1, (size_t)*s0, sizeof(BITS32), compar);
it->links[offset0] = s0-sorted0;
if (it->udi_free_args) {
memcpy(sorted, s0+1, sizeof(BITS32)*(*s0));
qsort(sorted, (size_t)*s0, sizeof(BITS32), compar2);
sorted += *s0;
}
}
}
}
sz = sizeof(BITS32)*(sorted-sorted0);
it->udi_data = (BITS32 *)realloc((char *)it->udi_data, sz);
}
it->is_udi = i+1;
code = it->code;
code->opc = Yap_opcode(_try_exo_udi);
code = NEXTOP(code, lp);
code->opc = Yap_opcode(_retry_exo_udi);
}
static BITS32 *
binary_search(BITS32 *start, BITS32 *end, Int x USES_REGS)
{
BITS32 *mid;
while (start < end) {
int cmp;
mid = start + (end-start)/2;
cmp = compare(mid, x PASS_REGS);
if (!cmp)
return mid;
if (cmp > 0) {
end = mid-1;
} else
start = mid+1;
}
return start;
}
static yamop *
Interval(struct index_t *it, Term min, Term max, Term op, BITS32 off USES_REGS)
{
BITS32 *c;
BITS32 n;
BITS32 *pt;
BITS32 *end;
Atom at;
LOCAL_exo_it = it;
LOCAL_exo_base = it->bcls;
LOCAL_exo_arity = it->arity;
LOCAL_exo_arg = it->udi_arg;
if (!it->links) {
c = (BITS32 *)it->udi_data;
n = it->nels;
pt = c;
end = c+(n-1);
} else if (it->links[off]) {
c = (BITS32 *)it->udi_data;
n = c[it->links[off]];
pt = c;
end = c+(it->links[off]+n);
// fprintf(stderr," %d links %d=%d \n", off, it->links[off], n);
} else {
if (!IsVarTerm(min)) {
Int x;
if (!IsIntegerTerm(min)) {
min = Yap_Eval(min);
if (!IsIntegerTerm(min)) {
Yap_Error(TYPE_ERROR_INTEGER, min, "data-base constraint");
return FAILCODE;
}
}
x = IntegerOfTerm(min);
if (x >= IntegerOfTerm(S[LOCAL_exo_arg])) {
return FAILCODE;
}
}
if (!IsVarTerm(max)) {
Int x;
if (!IsIntegerTerm(max)) {
max = Yap_Eval(max);
if (!IsIntegerTerm(max)) {
Yap_Error(TYPE_ERROR_INTEGER, max, "data-base constraint");
return FAILCODE;
}
}
x = IntegerOfTerm(max);
if (x <= IntegerOfTerm(S[LOCAL_exo_arg])) {
return FAILCODE;
}
}
return NEXTOP(NEXTOP(it->code,lp),lp);
}
if (!IsVarTerm(min)) {
Int x;
if (!IsIntegerTerm(min)) {
min = Yap_Eval(min);
if (!IsIntegerTerm(min)) {
Yap_Error(TYPE_ERROR_INTEGER, min, "data-base constraint");
return FAILCODE;
}
}
x = IntegerOfTerm(min);
if (n > 8) {
int cmp;
pt = binary_search(pt, end, x PASS_REGS);
while ( pt < end+1 && (cmp = compare(pt, x PASS_REGS)) <= 0 ) {
if (cmp > 0) break;
pt++;
}
} else {
while ( pt < end+1 && compare(pt, x PASS_REGS) <= 0 ) {
pt++;
}
}
if (pt > end)
return FAILCODE;
}
if (!IsVarTerm(max)) {
Int x;
BITS32 *pt1;
Int n = end-pt;
if (!IsIntegerTerm(max)) {
max = Yap_Eval(max);
if (!IsIntegerTerm(max)) {
Yap_Error(TYPE_ERROR_INTEGER, max, "data-base constraint");
return FAILCODE;
}
}
x = IntegerOfTerm(max);
if (n > 8) {
int cmp;
pt1 = binary_search(pt, end, x PASS_REGS);
while ( pt1 >= pt && (cmp = compare(pt1, x PASS_REGS)) >= 0 ) {
if (cmp < 0) break;
pt1--;
}
} else {
pt1 = end;
while ( pt1 >= pt && compare(pt1, x PASS_REGS) >= 0 ) {
pt1--;
}
}
if (pt1 < pt)
return FAILCODE;
end = pt1;
}
if (IsVarTerm(op)) {
S = EXO_OFFSET_TO_ADDRESS(it, pt[0]);
if (pt < end ) {
YENV[-1] = (CELL)( end );
YENV[-2] = (CELL)( pt+1 );
YENV -= 2;
return it->code;
}
return NEXTOP(NEXTOP(it->code,lp),lp);
}
at = AtomOfTerm(op);
if (at == AtomAny || at == AtomMinimum) {
S = EXO_OFFSET_TO_ADDRESS(it, pt[0]);
} else if (at == AtomMaximum) {
S = EXO_OFFSET_TO_ADDRESS(it, end[0]);
} else if (at == AtomUnique) {
if (end-2 > pt)
return FAILCODE;
S = EXO_OFFSET_TO_ADDRESS(it, pt[0]);
} else if (at == AtomMin) {
S = EXO_OFFSET_TO_ADDRESS(it, pt[0]);
if (it->udi_free_args) {
BITS32 *ptn;
pt = c+(it->links[off]+n+1);
end = pt+n;
pt = NEXT_MIN(pt, end, min, max, it);
if (!pt)
return FAILCODE;
S = EXO_OFFSET_TO_ADDRESS(it, pt[0]);
ptn = NEXT_DIFFERENT(pt, end, it);
if (ptn)
ptn = NEXT_MIN(ptn, end, min, max, it);
if ( ptn ) {
YENV[-1] = min; // what we are doing
YENV[-2] = max; // what we are doing
YENV[-3] = (CELL) end; // what we are doing
YENV[-4] = MkAtomTerm(AtomMin); // what we are doing
YENV[-5] = (CELL)( ptn ); // where we are in pt0 array
YENV -= 5;
return it->code;
}
}
return NEXTOP(NEXTOP(it->code,lp),lp);
} else if (at == AtomMax) {
S = EXO_OFFSET_TO_ADDRESS(it, pt[0]);
if (it->udi_free_args) {
BITS32 *ptn;
end = c+(it->links[off]+n);
pt = end+n;
pt = NEXT_MAX(pt, end, min, max, it);
if (!pt)
return FAILCODE;
S = EXO_OFFSET_TO_ADDRESS(it, pt[0]);
ptn = PREV_DIFFERENT(pt, end, it);
if (ptn)
ptn = NEXT_MAX(ptn, end, min, max, it);
if ( ptn ) {
YENV[-1] = min; // what we are doing
YENV[-2] = max; // what we are doing
YENV[-3] = (CELL) end; // what we are doing
YENV[-4] = MkAtomTerm(AtomMax); // what we are doing
YENV[-5] = (CELL)( ptn ); // where we are in pt0 array
YENV -= 5;
return it->code;
}
}
return NEXTOP(NEXTOP(it->code,lp),lp);
}
return NEXTOP(NEXTOP(it->code,lp),lp);
}
static yamop *
IntervalEnterUDIIndex(struct index_t *it USES_REGS)
{
Int i = it->udi_arg;
Term t = XREGS[i+1], a1;
BITS32 off = EXO_ADDRESS_TO_OFFSET(it, S);
// printf("off=%d it=%p %p---%p\n", off, it, it->cls, S);
attvar_record *attv;
t = Deref(t);
if (!IsVarTerm(t))
return FALSE;
if(!IsAttVar(VarOfTerm(t)))
return Interval(it, MkVarTerm(), MkVarTerm(), MkVarTerm(), off PASS_REGS);
attv = RepAttVar(VarOfTerm(t));
t = attv->Atts;
a1 = ArgOfTerm(2,t);
if (IsVarTerm(a1)) {
Yap_Error(INSTANTIATION_ERROR, t, "executing exo_interval constraints");
return FAILCODE;
} else if (!IsApplTerm(a1)) {
Yap_Error(TYPE_ERROR_COMPOUND, a1, "executing exo_interval constraints");
return FAILCODE;
} else {
return Interval(it, ArgOfTerm(1,a1), ArgOfTerm(2,a1), ArgOfTerm(3,a1), off PASS_REGS);
}
}
static int
IntervalRetryUDIIndex(struct index_t *it USES_REGS)
{
CELL *w = (CELL*)(B+1)+it->arity;
if (IsVarTerm(w[2])) {
BITS32 *end = (BITS32 *) w[2],
*pt = (BITS32 *) w[1];
BITS32 f = *pt;
S = EXO_OFFSET_TO_ADDRESS(it, f);
if (pt++ == end) return FALSE;
w[1] = (CELL)pt;
} else {
BITS32 *pt0 = (BITS32 *)w[1];
BITS32 *pte = (BITS32 *)w[3];
Atom what = AtomOfTerm(w[2]);
Term min = w[5];
Term max = w[4];
S = EXO_OFFSET_TO_ADDRESS(it, pt0[0]);
if ( what == AtomMin ) {
pt0 = NEXT_DIFFERENT(pt0, pte, it);
if (pt0)
pt0 = NEXT_MIN(pt0, pte, min, max, it);
} else {
pt0 = PREV_DIFFERENT(pt0, pte, it);
if (pt0)
pt0 = NEXT_MAX(pt0, pte, min, max, it);
}
if (!pt0) {
return FALSE;
}
w[1] = (CELL)pt0;
}
return TRUE;
}
static struct udi_control_block IntervalCB;
typedef struct exo_udi_access_t {
CRefitExoIndex refit;
} exo_udi_encaps_t;
static struct exo_udi_access_t ExoCB;
static void *
IntervalUdiInit (Term spec, int arg, int arity) {
ExoCB.refit = IntervalUDIRefitIndex;
return (void *)&ExoCB;
}
static void *
IntervalUdiInsert (void *control,
Term term, int arg, void *data)
{
CACHE_REGS
struct index_t **ip = (struct index_t **)term;
(*ip)->udi_arg = arg-1;
(ExoCB.refit)(ip, LOCAL_ibnds PASS_REGS);
(*ip)->udi_first = (void *)IntervalEnterUDIIndex;
(*ip)->udi_next = (void *)IntervalRetryUDIIndex;
return control;
}
static int IntervalUdiDestroy(void *control)
{
return TRUE;
}
void Yap_udi_Interval_init(void) {
UdiControlBlock cb = &IntervalCB;
Atom name = Yap_LookupAtom("exo_interval");
memset((void *) cb,0, sizeof(*cb));
/*TODO: ask vitor why this gives a warning*/
cb->decl= (YAP_Atom)name;
Yap_MkEmptyWakeUp(name);
cb->init= IntervalUdiInit;
cb->insert=IntervalUdiInsert;
cb->search=NULL;
cb->destroy=IntervalUdiDestroy;
Yap_UdiRegister(cb);
}

414
dev/yap-6.3/C/fail_absmi_insts.h Normal file
View File

@ -0,0 +1,414 @@
/*****************************************************************
* Failure *
*****************************************************************/
#ifdef INDENT_CODE
{
{
{
#endif /* INDENT_CODE */
/* trust_fail */
BOp(trust_fail, e);
{
while (POP_CHOICE_POINT(B->cp_b))
{
POP_EXECUTE();
}
}
#ifdef YAPOR
{
choiceptr cut_pt;
cut_pt = B->cp_b;
CUT_prune_to(cut_pt);
B = cut_pt;
}
#else
B = B->cp_b;
#endif /* YAPOR */
goto fail;
ENDBOp();
#ifdef YAPOR
shared_fail:
B = Get_LOCAL_top_cp();
SET_BB(PROTECT_FROZEN_B(B));
goto fail;
#endif /* YAPOR */
/* fail */
PBOp(op_fail, e);
if (PP) {
UNLOCK(PP->PELock);
PP = NULL;
}
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackFail, HR);
ENDCACHE_Y_AS_ENV();
#endif
fail:
{
register tr_fr_ptr pt0 = TR;
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCK(PP->PELock);
PP = NULL;
}
#endif
PREG = B->cp_ap;
save_pc();
CACHE_TR(B->cp_tr);
PREFETCH_OP(PREG);
failloop:
if (pt0 == S_TR) {
SP = SP0;
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
int go_on = true;
yamop *ipc = PREG;
while (go_on) {
op_numbers opnum = Yap_op_from_opcode(ipc->opc);
go_on = false;
switch (opnum) {
#ifdef TABLING
case _table_load_answer:
low_level_trace(retry_table_loader, LOAD_CP(B)->cp_pred_entry, NULL);
break;
case _table_try_answer:
case _table_retry_me:
case _table_trust_me:
case _table_retry:
case _table_trust:
case _table_completion:
#ifdef THREADS_CONSUMER_SHARING
case _table_answer_resolution_completion:
#endif /* THREADS_CONSUMER_SHARING */
#ifdef DETERMINISTIC_TABLING
if (IS_DET_GEN_CP(B))
low_level_trace(retry_table_generator, DET_GEN_CP(B)->cp_pred_entry, NULL);
else
#endif /* DETERMINISTIC_TABLING */
low_level_trace(retry_table_generator, GEN_CP(B)->cp_pred_entry, (CELL *)(GEN_CP(B) + 1));
break;
case _table_answer_resolution:
low_level_trace(retry_table_consumer, CONS_CP(B)->cp_pred_entry, NULL);
break;
case _trie_trust_var:
case _trie_retry_var:
case _trie_trust_var_in_pair:
case _trie_retry_var_in_pair:
case _trie_trust_val:
case _trie_retry_val:
case _trie_trust_val_in_pair:
case _trie_retry_val_in_pair:
case _trie_trust_atom:
case _trie_retry_atom:
case _trie_trust_atom_in_pair:
case _trie_retry_atom_in_pair:
case _trie_trust_null:
case _trie_retry_null:
case _trie_trust_null_in_pair:
case _trie_retry_null_in_pair:
case _trie_trust_pair:
case _trie_retry_pair:
case _trie_trust_appl:
case _trie_retry_appl:
case _trie_trust_appl_in_pair:
case _trie_retry_appl_in_pair:
case _trie_trust_extension:
case _trie_retry_extension:
case _trie_trust_double:
case _trie_retry_double:
case _trie_trust_longint:
case _trie_retry_longint:
case _trie_trust_gterm:
case _trie_retry_gterm:
low_level_trace(retry_table_loader, UndefCode, NULL);
break;
#endif /* TABLING */
case _or_else:
case _or_last:
low_level_trace(retry_or, NULL, NULL);
break;
case _retry2:
case _retry3:
case _retry4:
ipc = NEXTOP(ipc,l);
go_on = true;
break;
case _jump:
ipc = ipc->y_u.l.l;
go_on = true;
break;
case _retry_c:
case _retry_userc:
low_level_trace(retry_pred, ipc->y_u.OtapFs.p, B->cp_args);
break;
case _retry_profiled:
case _count_retry:
ipc = NEXTOP(ipc,p);
go_on = true;
break;
case _retry_me:
case _trust_me:
case _count_retry_me:
case _count_trust_me:
case _profiled_retry_me:
case _profiled_trust_me:
case _retry_and_mark:
case _profiled_retry_and_mark:
case _retry:
case _trust:
low_level_trace(retry_pred, ipc->y_u.Otapl.p, B->cp_args);
break;
case _try_logical:
case _retry_logical:
case _profiled_retry_logical:
case _count_retry_logical:
case _trust_logical:
case _profiled_trust_logical:
case _count_trust_logical:
low_level_trace(retry_pred, ipc->y_u.OtILl.d->ClPred, B->cp_args);
break;
case _Nstop:
case _Ystop:
low_level_trace(retry_pred, NULL, B->cp_args);
break;
default:
break;
}
}
}
#endif /* LOW_LEVEL_TRACER */
#ifdef FROZEN_STACKS
#ifdef YAPOR_SBA
if (pt0 < TR_FZ || pt0 > (ADDR)CurrentTrailTop+MinTrailGap)
#else
if (pt0 < TR_FZ)
#endif /* YAPOR_SBA */
{
TR = TR_FZ;
TRAIL_LINK(pt0);
} else
#endif /* FROZEN_STACKS */
RESTORE_TR();
GONext();
}
BEGD(d1);
d1 = TrailTerm(pt0-1);
pt0--;
if (IsVarTerm(d1)) {
#if defined(YAPOR_SBA) && defined(YAPOR)
/* clean up the trail when we backtrack */
if (Unsigned((Int)(d1)-(Int)(H_FZ)) >
Unsigned((Int)(B_FZ)-(Int)(H_FZ))) {
RESET_VARIABLE(STACK_TO_SBA(d1));
} else
#endif
/* normal variable */
RESET_VARIABLE(d1);
goto failloop;
}
/* pointer to code space */
/* or updatable variable */
#if defined(TERM_EXTENSIONS) || defined(FROZEN_STACKS) || defined(MULTI_ASSIGNMENT_VARIABLES)
if (IsPairTerm(d1))
#endif /* TERM_EXTENSIONS || FROZEN_STACKS || MULTI_ASSIGNMENT_VARIABLES */
{
register CELL flags;
CELL *pt1 = RepPair(d1);
#ifdef LIMIT_TABLING
if ((ADDR) pt1 == LOCAL_TrailBase) {
sg_fr_ptr sg_fr = (sg_fr_ptr) TrailVal(pt0);
TrailTerm(pt0) = AbsPair((CELL *)(pt0 - 1));
SgFr_state(sg_fr)--; /* complete_in_use --> complete : compiled_in_use --> compiled */
insert_into_global_sg_fr_list(sg_fr);
goto failloop;
}
#endif /* LIMIT_TABLING */
#ifdef FROZEN_STACKS /* TRAIL */
/* avoid frozen segments */
if (
#ifdef YAPOR_SBA
(ADDR) pt1 >= HeapTop
#else
IN_BETWEEN(LOCAL_TrailBase, pt1, (ADDR)CurrentTrailTop+MinTrailGap)
#endif /* YAPOR_SBA */
)
{
pt0 = (tr_fr_ptr) pt1;
goto failloop;
} else
#endif /* FROZEN_STACKS */
if (IN_BETWEEN(H0,pt1,HR)) {
if (IsAttVar(pt1)) {
goto failloop;
} else if (*pt1 == (CELL)FunctorBigInt) {
Yap_CleanOpaqueVariable(pt1);
goto failloop;
}
}
#ifdef FROZEN_STACKS /* TRAIL */
/* don't reset frozen variables */
if (pt0 < TR_FZ)
goto failloop;
#endif
flags = *pt1;
#if MULTIPLE_STACKS
if (FlagOn(DBClMask, flags)) {
DBRef dbr = DBStructFlagsToDBStruct(pt1);
int erase;
LOCK(dbr->lock);
DEC_DBREF_COUNT(dbr);
erase = (dbr->Flags & ErasedMask) && (dbr->ref_count == 0);
UNLOCK(dbr->lock);
if (erase) {
saveregs();
Yap_ErDBE(dbr);
setregs();
}
} else {
if (flags & LogUpdMask) {
if (flags & IndexMask) {
LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt1);
int erase;
#if PARALLEL_YAP
PredEntry *ap = cl->ClPred;
#endif
PELOCK(8,ap);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
if (erase) {
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_ErLogUpdIndex(cl);
setregs();
} else if (cl->ClFlags & DirtyMask) {
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_CleanUpIndex(cl);
setregs();
}
UNLOCK(ap->PELock);
} else {
LogUpdClause *cl = ClauseFlagsToLogUpdClause(pt1);
int erase;
#if PARALLEL_YAP
PredEntry *ap = cl->ClPred;
#endif
/* BB support */
if (ap) {
PELOCK(9,ap);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
if (erase) {
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_ErLogUpdCl(cl);
setregs();
}
UNLOCK(ap->PELock);
}
}
} else {
DynamicClause *cl = ClauseFlagsToDynamicClause(pt1);
int erase;
LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
UNLOCK(cl->ClLock);
if (erase) {
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_ErCl(cl);
setregs();
}
}
}
#else
ResetFlag(InUseMask, flags);
*pt1 = flags;
if (FlagOn((ErasedMask|DirtyMask), flags)) {
if (FlagOn(DBClMask, flags)) {
saveregs();
Yap_ErDBE(DBStructFlagsToDBStruct(pt1));
setregs();
} else {
saveregs();
if (flags & LogUpdMask) {
if (flags & IndexMask) {
if (FlagOn(ErasedMask, flags)) {
Yap_ErLogUpdIndex(ClauseFlagsToLogUpdIndex(pt1));
} else {
Yap_CleanUpIndex(ClauseFlagsToLogUpdIndex(pt1));
}
} else {
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(pt1));
}
} else {
Yap_ErCl(ClauseFlagsToDynamicClause(pt1));
}
setregs();
}
}
#endif
goto failloop;
}
#ifdef MULTI_ASSIGNMENT_VARIABLES
else /* if (IsApplTerm(d1)) */ {
CELL *pt = RepAppl(d1);
/* AbsAppl means */
/* multi-assignment variable */
/* so the next cell is the old value */
#ifdef FROZEN_STACKS
--pt0;
pt[0] = TrailVal(pt0);
#else
pt[0] = TrailTerm(pt0-1);
pt0 -= 2;
#endif /* FROZEN_STACKS */
goto failloop;
}
#endif
ENDD(d1);
ENDCACHE_TR();
}
#ifdef COROUTINING
NoStackFail:
BEGD(d0);
#ifdef SHADOW_S
Yap_REGS.S_ = SREG;
#endif
saveregs();
d0 = interrupt_fail( PASS_REGS1 );
setregs();
#ifdef SHADOW_S
SREG = Yap_REGS.S_;
#endif
if (!d0) FAIL();
JMPNext();
ENDD(d0);
#endif /* COROUTINING */
ENDPBOp();

1578
dev/yap-6.3/C/flags.c Normal file
View File

File diff suppressed because it is too large Load Diff

628
dev/yap-6.3/C/fli_absmi_insts.h Normal file
View File

@ -0,0 +1,628 @@
/************************************************************************\
* Call C predicates instructions *
\************************************************************************/
#ifdef INDENT_CODE
{
{
{
#endif /* INDENT_CODE */
BOp(call_cpred, Osbpp);
#if __ANDROID__ && STRONG_DEBUG
char *s; Atom name;
if (PREG->y_u.Osbpp.p->ArityOfPE) {
Functor f = PREG->y_u.Osbpp.p->FunctorOfPred;
name = f->NameOfFE;
} else {
name = (Atom)(PREG->y_u.Osbpp.p->FunctorOfPred);
}
s = name->StrOfAE;
LOG( " %s ", s);
#endif
check_trail(TR);
if (!(PREG->y_u.Osbpp.p->PredFlags & (SafePredFlag|NoTracePredFlag|HiddenPredFlag))) {
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCCall, HR);
ENDCACHE_Y_AS_ENV();
}
do_c_call:
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (YREG > (CELL *) top_b || YREG < HR) ASP = (CELL *)top_b;
#else
if (YREG > (CELL *) top_b) ASP = (CELL *)top_b;
#endif /* YAPOR_SBA */
else ASP = (CELL *)(((char *)YREG) + PREG->y_u.Osbpp.s);
}
#else
SET_ASP(YREG, PREG->y_u.Osbpp.s);
/* for slots to work */
#endif /* FROZEN_STACKS */
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace)
low_level_trace(enter_pred,PREG->y_u.Osbpp.p,XREGS+1);
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
CPredicate f = PREG->y_u.Osbpp.p->cs.f_code;
PREG = NEXTOP(PREG, Osbpp);
saveregs();
d0 = (f)(PASS_REGS1);
setregs();
#ifdef SHADOW_S
SREG = Yap_REGS.S_;
#endif
if (!d0) {
FAIL();
}
CACHE_A1();
ENDD(d0);
JMPNext();
NoStackCCall:
PROCESS_INT(interrupt_call, do_c_call);
ENDBOp();
/* execute Label */
BOp(execute_cpred, pp);
check_trail(TR);
{
PredEntry *pt0;
BEGD(d0);
CACHE_Y_AS_ENV(YREG);
#ifndef NO_CHECKING
check_stack(NoStackExecuteC, HR);
do_executec:
#endif
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (YREG > (CELL *) top_b || YREG < HR) ASP = (CELL *)top_b;
#else
if (YREG > (CELL *) top_b) ASP = (CELL *)top_b;
#endif /* YAPOR_SBA */
else ASP = YREG+E_CB;
}
#else
SET_ASP(YREG, E_CB*sizeof(CELL));
/* for slots to work */
#endif /* FROZEN_STACKS */
pt0 = PREG->y_u.pp.p;
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
low_level_trace(enter_pred,pt0,XREGS+1);
}
#endif /* LOW_LEVEL_TRACE */
CACHE_A1();
BEGD(d0);
d0 = (CELL)B;
/* for profiler */
save_pc();
ENV_YREG[E_CB] = d0;
ENDD(d0);
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is prolog */
if (pt0->ModuleOfPred) {
if (DEPTH == MkIntTerm(0)) {
FAIL();
} else{
DEPTH = RESET_DEPTH();
}
}
} else if (pt0->ModuleOfPred) {
DEPTH -= MkIntConstant(2);
}
#endif /* DEPTH_LIMIT */
/* now call C-Code */
{
CPredicate f = PREG->y_u.pp.p->cs.f_code;
yamop *oldPREG = PREG;
saveregs();
d0 = (f)(PASS_REGS1);
setregs();
#ifdef SHADOW_S
SREG = Yap_REGS.S_;
#endif
if (!d0) {
FAIL();
}
if (oldPREG == PREG) {
/* we did not update PREG */
/* we can proceed */
PREG = CPREG;
ENV_YREG = ENV;
#ifdef DEPTH_LIMIT
DEPTH = ENV_YREG[E_DEPTH];
#endif
WRITEBACK_Y_AS_ENV();
} else {
/* call the new code */
CACHE_A1();
}
}
JMPNext();
ENDCACHE_Y_AS_ENV();
ENDD(d0);
}
NoStackExecuteC:
PROCESS_INT(interrupt_execute, do_executec);
ENDBOp();
/* Like previous, the only difference is that we do not */
/* trust the C-function we are calling and hence we must */
/* guarantee that *all* machine registers are saved and */
/* restored */
BOp(call_usercpred, Osbpp);
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackUserCall, HR);
ENDCACHE_Y_AS_ENV();
do_user_call:
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
low_level_trace(enter_pred,PREG->y_u.Osbpp.p,XREGS+1);
}
#endif /* LOW_LEVEL_TRACE */
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (YREG > (CELL *) top_b || YREG < HR) ASP = (CELL *) top_b;
#else
if (YREG > (CELL *) top_b) ASP = (CELL *) top_b;
#endif /* YAPOR_SBA */
else ASP = (CELL *)(((char *)YREG) + PREG->y_u.Osbpp.s);
}
#else
SET_ASP(YREG, PREG->y_u.Osbpp.s);
/* for slots to work */
#endif /* FROZEN_STACKS */
{
/* make sure that we can still have access to our old PREG after calling user defined goals and backtracking or failing */
yamop *savedP;
LOCAL_PrologMode |= UserCCallMode;
{
PredEntry *p = PREG->y_u.Osbpp.p;
PREG = NEXTOP(PREG, Osbpp);
savedP = PREG;
saveregs();
save_machine_regs();
SREG = (CELL *) YAP_Execute(p, p->cs.f_code);
}
setregs();
LOCAL_PrologMode &= ~UserCCallMode;
restore_machine_regs();
PREG = savedP;
}
if (EX) {
struct DB_TERM *exp = EX;
EX = NULL;
Yap_JumpToEnv(Yap_PopTermFromDB(exp));
SREG = NULL;
}
if (!SREG) {
FAIL();
}
/* in case we call Execute */
YENV = ENV;
YREG = ENV;
JMPNext();
NoStackUserCall:
PROCESS_INT(interrupt_call, do_user_call);
ENDBOp();
BOp(call_c_wfail, slpp);
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
low_level_trace(enter_pred,PREG->y_u.slpp.p,XREGS+1);
}
#endif /* LOW_LEVEL_TRACE */
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (YREG > (CELL *) top_b || YREG < HR) ASP = (CELL *) top_b;
#else
if (YREG > (CELL *) top_b) ASP = (CELL *) top_b;
#endif /* YAPOR_SBA */
else {
BEGD(d0);
d0 = PREG->y_u.slpp.s;
ASP = ((CELL *)YREG) + d0;
ENDD(d0);
}
}
#else
if (YREG > (CELL *) B)
ASP = (CELL *) B;
else {
BEGD(d0);
d0 = PREG->y_u.slpp.s;
ASP = ((CELL *) YREG) + d0;
ENDD(d0);
}
#endif /* FROZEN_STACKS */
{
CPredicate f = PREG->y_u.slpp.p->cs.f_code;
saveregs();
SREG = (CELL *)((f)(PASS_REGS1));
setregs();
}
if (!SREG) {
/* be careful about error handling */
if (PREG != FAILCODE)
PREG = PREG->y_u.slpp.l;
} else {
PREG = NEXTOP(PREG, slpp);
}
CACHE_A1();
JMPNext();
ENDBOp();
BOp(try_c, OtapFs);
#ifdef YAPOR
CUT_wait_leftmost();
#endif /* YAPOR */
CACHE_Y(YREG);
/* Alocate space for the cut_c structure*/
CUT_C_PUSH(NEXTOP(NEXTOP(PREG,OtapFs),OtapFs),S_YREG);
S_YREG = S_YREG - PREG->y_u.OtapFs.extra;
store_args(PREG->y_u.OtapFs.s);
store_yaam_regs(NEXTOP(PREG, OtapFs), 0);
B = B_YREG;
#ifdef YAPOR
SCH_set_load(B_YREG);
#endif /* YAPOR */
SET_BB(B_YREG);
ENDCACHE_Y();
TRYCC:
ASP = (CELL *)B;
{
CPredicate f = (CPredicate)(PREG->y_u.OtapFs.f);
saveregs();
SREG = (CELL *) ((f) (PASS_REGS1));
/* This last instruction changes B B*/
while (POP_CHOICE_POINT(B)){
cut_c_pop();
}
setregs();
}
if (!SREG) {
/* Removes the cut functions from the stack
without executing them because we have fail
and not cuted the predicate*/
while(POP_CHOICE_POINT(B))
cut_c_pop();
FAIL();
}
if ((CELL *) B == YREG && ASP != (CELL *) B) {
/* as Luis says, the predicate that did the try C might
* have left some data on the stack. We should preserve
* it, unless the builtin also did cut */
YREG = ASP;
HBREG = PROTECT_FROZEN_H(B);
SET_BB(B);
}
PREG = CPREG;
YREG = ENV;
JMPNext();
ENDBOp();
BOp(retry_c, OtapFs);
#ifdef YAPOR
CUT_wait_leftmost();
#endif /* YAPOR */
CACHE_Y(B);
CPREG = B_YREG->cp_cp;
ENV = B_YREG->cp_env;
HR = PROTECT_FROZEN_H(B);
#ifdef DEPTH_LIMIT
DEPTH =B->cp_depth;
#endif
HBREG = HR;
restore_args(PREG->y_u.OtapFs.s);
ENDCACHE_Y();
goto TRYCC;
ENDBOp();
BOp(cut_c, OtapFs);
/*This is a phantom instruction. This is not executed by the WAM*/
#ifdef DEBUG
/*If WAM executes this instruction, probably there's an error
when we put this instruction, cut_c, after retry_c*/
printf ("ERROR: Should not print this message FILE: absmi.c %d\n",__LINE__);
#endif /*DEBUG*/
ENDBOp();
BOp(try_userc, OtapFs);
#ifdef YAPOR
CUT_wait_leftmost();
#endif /* YAPOR */
CACHE_Y(YREG);
/* Alocate space for the cut_c structure*/
CUT_C_PUSH(NEXTOP(NEXTOP(PREG,OtapFs),OtapFs),S_YREG);
S_YREG = S_YREG - PREG->y_u.OtapFs.extra;
store_args(PREG->y_u.OtapFs.s);
store_yaam_regs(NEXTOP(PREG, OtapFs), 0);
B = B_YREG;
#ifdef YAPOR
SCH_set_load(B_YREG);
#endif
SET_BB(B_YREG);
ENDCACHE_Y();
LOCAL_PrologMode = UserCCallMode;
ASP = YREG;
saveregs();
save_machine_regs();
SREG = (CELL *) YAP_ExecuteFirst(PREG->y_u.OtapFs.p, (CPredicate)(PREG->y_u.OtapFs.f));
EX = NULL;
restore_machine_regs();
setregs();
LOCAL_PrologMode &= UserMode;
if (!SREG) {
FAIL();
}
if ((CELL *) B == YREG && ASP != (CELL *) B) {
/* as Luis says, the predicate that did the try C might
* have left some data on the stack. We should preserve
* it, unless the builtin also did cut */
YREG = ASP;
HBREG = PROTECT_FROZEN_H(B);
}
PREG = CPREG;
YREG = ENV;
CACHE_A1();
JMPNext();
ENDBOp();
BOp(retry_userc, OtapFs);
#ifdef YAPOR
CUT_wait_leftmost();
#endif /* YAPOR */
CACHE_Y(B);
CPREG = B_YREG->cp_cp;
ENV = B_YREG->cp_env;
HR = PROTECT_FROZEN_H(B);
#ifdef DEPTH_LIMIT
DEPTH =B->cp_depth;
#endif
HBREG = HR;
restore_args(PREG->y_u.OtapFs.s);
ENDCACHE_Y();
LOCAL_PrologMode |= UserCCallMode;
SET_ASP(YREG, E_CB*sizeof(CELL));
saveregs();
save_machine_regs();
SREG = (CELL *) YAP_ExecuteNext(PREG->y_u.OtapFs.p, (CPredicate)(PREG->y_u.OtapFs.f));
EX = NULL;
restore_machine_regs();
setregs();
LOCAL_PrologMode &= ~UserCCallMode;
if (!SREG) {
/* Removes the cut functions from the stack
without executing them because we have fail
and not cuted the predicate*/
while(POP_CHOICE_POINT(B))
cut_c_pop();
FAIL();
}
if ((CELL *) B == YREG && ASP != (CELL *) B) {
/* as Luis says, the predicate that did the try C might
* have left some data on the stack. We should preserve
* it, unless the builtin also did cut */
YREG = ASP;
HBREG = PROTECT_FROZEN_H(B);
}
PREG = CPREG;
YREG = ENV;
CACHE_A1();
JMPNext();
ENDBOp();
BOp(cut_userc, OtapFs);
/*This is a phantom instruction. This is not executed by the WAM*/
#ifdef DEBUG
/*If WAM executes this instruction, probably there's an error
when we put this instruction, cut_userc, after retry_userc*/
printf ("ERROR: Should not print this message FILE: absmi.c %d\n",__LINE__);
#endif /*DEBUG*/
CACHE_A1();
JMPNext();
ENDBOp();
/************************************************************************\
* support instructions *
\************************************************************************/
BOp(lock_pred, e);
{
PredEntry *ap = PredFromDefCode(PREG);
PELOCK(10,ap);
PP = ap;
if (!ap->cs.p_code.NOfClauses) {
UNLOCKPE(11,ap);
FAIL();
}
/*
we do not lock access to the predicate,
we must take extra care here
*/
if (ap->cs.p_code.NOfClauses > 1 &&
!(ap->PredFlags & IndexedPredFlag)) {
/* update ASP before calling IPred */
SET_ASP(YREG, E_CB*sizeof(CELL));
saveregs();
Yap_IPred(ap, 0, CP);
/* IPred can generate errors, it thus must get rid of the lock itself */
setregs();
CACHE_A1();
/* for profiler */
save_pc();
}
PREG = ap->cs.p_code.TrueCodeOfPred;
}
JMPNext();
ENDBOp();
BOp(index_pred, e);
{
PredEntry *ap = PredFromDefCode(PREG);
#if defined(YAPOR) || defined(THREADS)
/*
we do not lock access to the predicate,
we must take extra care here
*/
if (!PP) {
PELOCK(11,ap);
}
if (ap->OpcodeOfPred != INDEX_OPCODE) {
/* someone was here before we were */
if (!PP) {
UNLOCKPE(11,ap);
}
PREG = ap->CodeOfPred;
/* for profiler */
save_pc();
JMPNext();
}
#endif
/* update ASP before calling IPred */
SET_ASP(YREG, E_CB*sizeof(CELL));
saveregs();
Yap_IPred(ap, 0, CP);
/* IPred can generate errors, it thus must get rid of the lock itself */
setregs();
CACHE_A1();
PREG = ap->CodeOfPred;
/* for profiler */
save_pc();
#if defined(YAPOR) || defined(THREADS)
if (!PP)
#endif
UNLOCKPE(14,ap);
}
JMPNext();
ENDBOp();
#if THREADS
BOp(thread_local, e);
{
PredEntry *ap = PredFromDefCode(PREG);
ap = Yap_GetThreadPred(ap PASS_REGS);
PREG = ap->CodeOfPred;
/* for profiler */
save_pc();
}
JMPNext();
ENDBOp();
#endif
BOp(expand_index, e);
{
PredEntry *pe = PredFromExpandCode(PREG);
yamop *pt0;
/* update ASP before calling IPred */
SET_ASP(YREG, E_CB*sizeof(CELL));
#if defined(YAPOR) || defined(THREADS)
if (!PP) {
PELOCK(12,pe);
}
if (!same_lu_block(PREG_ADDR, PREG)) {
PREG = *PREG_ADDR;
if (!PP) {
UNLOCKPE(15,pe);
}
JMPNext();
}
#endif
#ifdef SHADOW_S
S = SREG;
#endif /* SHADOW_S */
saveregs();
pt0 = Yap_ExpandIndex(pe, 0);
/* restart index */
setregs();
#ifdef SHADOW_S
SREG = S;
#endif /* SHADOW_S */
PREG = pt0;
#if defined(YAPOR) || defined(THREADS)
if (!PP) {
UNLOCKPE(12,pe);
}
#endif
JMPNext();
}
ENDBOp();
BOp(expand_clauses, sssllp);
{
PredEntry *pe = PREG->y_u.sssllp.p;
yamop *pt0;
/* update ASP before calling IPred */
SET_ASP(YREG, E_CB*sizeof(CELL));
#if defined(YAPOR) || defined(THREADS)
if (PP == NULL) {
PELOCK(13,pe);
}
if (!same_lu_block(PREG_ADDR, PREG)) {
PREG = *PREG_ADDR;
if (!PP) {
UNLOCKPE(16,pe);
}
JMPNext();
}
#endif
saveregs();
pt0 = Yap_ExpandIndex(pe, 0);
/* restart index */
setregs();
PREG = pt0;
#if defined(YAPOR) || defined(THREADS)
if (!PP) {
UNLOCKPE(18,pe);
}
#endif
JMPNext();
}
ENDBOp();
BOp(undef_p, e);
/* save S for module name */
saveregs();
undef_goal( PASS_REGS1 );
setregs();
/* for profiler */
CACHE_A1();
JMPNext();
ENDBOp();
BOp(spy_pred, e);
saveregs();
spy_goal( PASS_REGS1 );
setregs();
CACHE_A1();
JMPNext();
ENDBOp();

2821
dev/yap-6.3/C/globals.c Normal file
View File

File diff suppressed because it is too large Load Diff

1757
dev/yap-6.3/C/gmp_support.c Normal file
View File

File diff suppressed because it is too large Load Diff

1228
dev/yap-6.3/C/gprof.c Normal file
View File

File diff suppressed because it is too large Load Diff

2111
dev/yap-6.3/C/grow.c Normal file
View File

File diff suppressed because it is too large Load Diff

4342
dev/yap-6.3/C/heapgc.c Normal file
View File

File diff suppressed because it is too large Load Diff

7013
dev/yap-6.3/C/index.c Normal file
View File

File diff suppressed because it is too large Load Diff

458
dev/yap-6.3/C/index_absmi_insts.h Normal file
View File

@ -0,0 +1,458 @@
/************************************************************************\
* Indexing in ARG1 *
\************************************************************************/
#ifdef INDENT_CODE
{
{
#endif /* INDENT_CODE */
BOp(user_switch, lp);
{
yamop *new = Yap_udi_search(PREG->y_u.lp.p);
if (!new) {
PREG = PREG->y_u.lp.l;
JMPNext();
}
PREG = new;
JMPNext();
}
ENDBOp();
BOp(switch_on_type, llll);
BEGD(d0);
d0 = CACHED_A1();
deref_head(d0, swt_unk);
/* nonvar */
swt_nvar:
if (IsPairTerm(d0)) {
/* pair */
SREG = RepPair(d0);
copy_jmp_address(PREG->y_u.llll.l1);
PREG = PREG->y_u.llll.l1;
JMPNext();
}
else if (!IsApplTerm(d0)) {
/* constant */
copy_jmp_address(PREG->y_u.llll.l2);
PREG = PREG->y_u.llll.l2;
I_R = d0;
JMPNext();
}
else {
/* appl */
copy_jmp_address(PREG->y_u.llll.l3);
PREG = PREG->y_u.llll.l3;
SREG = RepAppl(d0);
JMPNext();
}
BEGP(pt0);
deref_body(d0, pt0, swt_unk, swt_nvar);
/* variable */
copy_jmp_address(PREG->y_u.llll.l4);
PREG = PREG->y_u.llll.l4;
JMPNext();
ENDP(pt0);
ENDD(d0);
ENDBOp();
/* specialised case where the arguments may be:
* a list;
* the empty list;
* some other atom;
* a variable;
*
*/
BOp(switch_list_nl, ollll);
ALWAYS_LOOKAHEAD(PREG->y_u.ollll.pop);
BEGD(d0);
d0 = CACHED_A1();
#if UNIQUE_TAG_FOR_PAIRS
deref_list_head(d0, swlnl_unk_p);
swlnl_list_p:
{
#else
deref_head(d0, swlnl_unk_p);
/* non variable */
swlnl_nvar_p:
if (__builtin_expect(IsPairTerm(d0),1)) {
/* pair */
#endif
copy_jmp_address(PREG->y_u.ollll.l1);
PREG = PREG->y_u.ollll.l1;
SREG = RepPair(d0);
ALWAYS_GONext();
}
#if UNIQUE_TAG_FOR_PAIRS
swlnl_nlist_p:
#endif
if (d0 == TermNil) {
/* empty list */
PREG = PREG->y_u.ollll.l2;
JMPNext();
}
else {
/* appl or constant */
if (IsApplTerm(d0)) {
copy_jmp_address(PREG->y_u.ollll.l3);
PREG = PREG->y_u.ollll.l3;
SREG = RepAppl(d0);
JMPNext();
} else {
copy_jmp_address(PREG->y_u.ollll.l3);
PREG = PREG->y_u.ollll.l3;
I_R = d0;
JMPNext();
}
}
BEGP(pt0);
#if UNIQUE_TAG_FOR_PAIRS
swlnl_unk_p:
deref_list_body(d0, pt0, swlnl_list_p, swlnl_nlist_p);
#else
deref_body(d0, pt0, swlnl_unk_p, swlnl_nvar_p);
#endif
ENDP(pt0);
/* variable */
copy_jmp_address(PREG->y_u.ollll.l4);
PREG = PREG->y_u.ollll.l4;
JMPNext();
ENDD(d0);
}
ENDBOp();
BOp(switch_on_arg_type, xllll);
BEGD(d0);
d0 = XREG(PREG->y_u.xllll.x);
deref_head(d0, arg_swt_unk);
/* nonvar */
arg_swt_nvar:
if (IsPairTerm(d0)) {
/* pair */
copy_jmp_address(PREG->y_u.xllll.l1);
PREG = PREG->y_u.xllll.l1;
SREG = RepPair(d0);
JMPNext();
}
else if (!IsApplTerm(d0)) {
/* constant */
copy_jmp_address(PREG->y_u.xllll.l2);
PREG = PREG->y_u.xllll.l2;
I_R = d0;
JMPNext();
}
else {
/* appl */
copy_jmp_address(PREG->y_u.xllll.l3);
PREG = PREG->y_u.xllll.l3;
SREG = RepAppl(d0);
JMPNext();
}
BEGP(pt0);
deref_body(d0, pt0, arg_swt_unk, arg_swt_nvar);
/* variable */
copy_jmp_address(PREG->y_u.xllll.l4);
PREG = PREG->y_u.xllll.l4;
JMPNext();
ENDP(pt0);
ENDD(d0);
ENDBOp();
BOp(switch_on_sub_arg_type, sllll);
BEGD(d0);
d0 = SREG[PREG->y_u.sllll.s];
deref_head(d0, sub_arg_swt_unk);
/* nonvar */
sub_arg_swt_nvar:
if (IsPairTerm(d0)) {
/* pair */
copy_jmp_address(PREG->y_u.sllll.l1);
PREG = PREG->y_u.sllll.l1;
SREG = RepPair(d0);
JMPNext();
}
else if (!IsApplTerm(d0)) {
/* constant */
copy_jmp_address(PREG->y_u.sllll.l2);
PREG = PREG->y_u.sllll.l2;
I_R = d0;
JMPNext();
}
else {
/* appl */
copy_jmp_address(PREG->y_u.sllll.l3);
PREG = PREG->y_u.sllll.l3;
SREG = RepAppl(d0);
JMPNext();
}
BEGP(pt0);
deref_body(d0, pt0, sub_arg_swt_unk, sub_arg_swt_nvar);
/* variable */
copy_jmp_address(PREG->y_u.sllll.l4);
PREG = PREG->y_u.sllll.l4;
JMPNext();
ENDP(pt0);
ENDD(d0);
ENDBOp();
BOp(jump_if_var, l);
BEGD(d0);
d0 = CACHED_A1();
deref_head(d0, jump_if_unk);
/* non var */
jump0_if_nonvar:
PREG = NEXTOP(PREG, l);
JMPNext();
BEGP(pt0);
deref_body(d0, pt0, jump_if_unk, jump0_if_nonvar);
/* variable */
copy_jmp_address(PREG->y_u.l.l);
PREG = PREG->y_u.l.l;
ENDP(pt0);
JMPNext();
ENDD(d0);
ENDBOp();
BOp(jump_if_nonvar, xll);
BEGD(d0);
d0 = XREG(PREG->y_u.xll.x);
deref_head(d0, jump2_if_unk);
/* non var */
jump2_if_nonvar:
copy_jmp_address(PREG->y_u.xll.l1);
PREG = PREG->y_u.xll.l1;
JMPNext();
BEGP(pt0);
deref_body(d0, pt0, jump2_if_unk, jump2_if_nonvar);
/* variable */
PREG = NEXTOP(PREG, xll);
ENDP(pt0);
JMPNext();
ENDD(d0);
ENDBOp();
BOp(if_not_then, clll);
BEGD(d0);
d0 = CACHED_A1();
deref_head(d0, if_n_unk);
if_n_nvar:
/* not variable */
if (d0 == PREG->y_u.clll.c) {
/* equal to test value */
copy_jmp_address(PREG->y_u.clll.l2);
PREG = PREG->y_u.clll.l2;
JMPNext();
}
else {
/* different from test value */
/* the case to optimise */
copy_jmp_address(PREG->y_u.clll.l1);
PREG = PREG->y_u.clll.l1;
JMPNext();
}
BEGP(pt0);
deref_body(d0, pt0, if_n_unk, if_n_nvar);
ENDP(pt0);
/* variable */
copy_jmp_address(PREG->y_u.clll.l3);
PREG = PREG->y_u.clll.l3;
JMPNext();
ENDD(d0);
ENDBOp();
/************************************************************************\
* Indexing on ARG1 *
\************************************************************************/
#define HASH_SHIFT 6
BOp(switch_on_func, sssl);
BEGD(d1);
d1 = *SREG++;
/* we use a very simple hash function to find elements in a
* switch table */
{
CELL
/* first, calculate the mask */
Mask = (PREG->y_u.sssl.s - 1) << 1, /* next, calculate the hash function */
hash = d1 >> (HASH_SHIFT - 1) & Mask;
CELL *base;
base = (CELL *)PREG->y_u.sssl.l;
/* PREG now points at the beginning of the hash table */
BEGP(pt0);
/* pt0 will always point at the item */
pt0 = base + hash;
BEGD(d0);
d0 = pt0[0];
/* a match happens either if we found the value, or if we
* found an empty slot */
if (d0 == d1 || d0 == 0) {
copy_jmp_addressa(pt0+1);
PREG = (yamop *) (pt0[1]);
JMPNext();
}
else {
/* ooops, collision, look for other items */
register CELL d = ((d1 | 1) << 1) & Mask;
while (1) {
hash = (hash + d) & Mask;
pt0 = base + hash;
d0 = pt0[0];
if (d0 == d1 || d0 == 0) {
copy_jmp_addressa(pt0+1);
PREG = (yamop *) pt0[1];
JMPNext();
}
}
}
ENDD(d0);
ENDP(pt0);
}
ENDD(d1);
ENDBOp();
BOp(switch_on_cons, sssl);
BEGD(d1);
d1 = I_R;
/* we use a very simple hash function to find elements in a
* switch table */
{
CELL
/* first, calculate the mask */
Mask = (PREG->y_u.sssl.s - 1) << 1, /* next, calculate the hash function */
hash = d1 >> (HASH_SHIFT - 1) & Mask;
CELL *base;
base = (CELL *)PREG->y_u.sssl.l;
/* PREG now points at the beginning of the hash table */
BEGP(pt0);
/* pt0 will always point at the item */
pt0 = base + hash;
BEGD(d0);
d0 = pt0[0];
/* a match happens either if we found the value, or if we
* found an empty slot */
if (d0 == d1 || d0 == 0) {
copy_jmp_addressa(pt0+1);
PREG = (yamop *) (pt0[1]);
JMPNext();
}
else {
/* ooops, collision, look for other items */
register CELL d = ((d1 | 1) << 1) & Mask;
while (1) {
hash = (hash + d) & Mask;
pt0 = base + hash;
d0 = pt0[0];
if (d0 == d1 || d0 == 0) {
copy_jmp_addressa(pt0+1);
PREG = (yamop *) pt0[1];
JMPNext();
}
}
}
ENDD(d0);
ENDP(pt0);
}
ENDD(d1);
ENDBOp();
BOp(go_on_func, sssl);
BEGD(d0);
{
CELL *pt = (CELL *)(PREG->y_u.sssl.l);
d0 = *SREG++;
if (d0 == pt[0]) {
copy_jmp_addressa(pt+1);
PREG = (yamop *) pt[1];
JMPNext();
} else {
copy_jmp_addressa(pt+3);
PREG = (yamop *) pt[3];
JMPNext();
}
}
ENDD(d0);
ENDBOp();
BOp(go_on_cons, sssl);
BEGD(d0);
{
CELL *pt = (CELL *)(PREG->y_u.sssl.l);
d0 = I_R;
if (d0 == pt[0]) {
copy_jmp_addressa(pt+1);
PREG = (yamop *) pt[1];
JMPNext();
} else {
copy_jmp_addressa(pt+3);
PREG = (yamop *) pt[3];
JMPNext();
}
}
ENDD(d0);
ENDBOp();
BOp(if_func, sssl);
BEGD(d1);
BEGP(pt0);
pt0 = (CELL *) PREG->y_u.sssl.l;
d1 = *SREG++;
while (pt0[0] != d1 && pt0[0] != (CELL)NULL ) {
pt0 += 2;
}
copy_jmp_addressa(pt0+1);
PREG = (yamop *) (pt0[1]);
JMPNext();
ENDP(pt0);
ENDD(d1);
ENDBOp();
BOp(if_cons, sssl);
BEGD(d1);
BEGP(pt0);
pt0 = (CELL *) PREG->y_u.sssl.l;
d1 = I_R;
while (pt0[0] != d1 && pt0[0] != 0L ) {
pt0 += 2;
}
copy_jmp_addressa(pt0+1);
PREG = (yamop *) (pt0[1]);
JMPNext();
ENDP(pt0);
ENDD(d1);
ENDBOp();
Op(index_dbref, e);
PREG = NEXTOP(PREG, e);
I_R = AbsAppl(SREG-1);
GONext();
ENDOp();
Op(index_blob, e);
PREG = NEXTOP(PREG, e);
I_R = Yap_DoubleP_key(SREG);
GONext();
ENDOp();
Op(index_long, e);
PREG = NEXTOP(PREG, e);
I_R = Yap_IntP_key(SREG);
GONext();
ENDOp();

1437
dev/yap-6.3/C/init.c Normal file
View File

File diff suppressed because it is too large Load Diff

1136
dev/yap-6.3/C/inlines.c Normal file
View File

File diff suppressed because it is too large Load Diff

107
dev/yap-6.3/C/load_aix.c Normal file
View File

@ -0,0 +1,107 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dl.c *
* comments: dl based dynamic loaderr of external routines *
* tested on i486-linuxelf *
*************************************************************************/
#ifdef _AIX
#include "Yap.h"
#include "Yatom.h"
#include "yapio.h"
#include "Foreign.h"
#include <stdio.h>
#include <errno.h>
/*
* FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
return NULL;
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
/* not implemented */
return NULL;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
return FALSE;
}
int
Yap_CloseForeignFile(void *handle)
{
return -1;
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
extern char *sys_errlist[ ];
/* load wants to follow the LIBRARY_PATH */
if (ofiles->next != NULL || libs != NULL) {
strcpy(LOCAL_ErrorSay," Load Failed: in AIX you must load a single object file");
return LOAD_FAILLED;
}
if (!Yap_AbsoluteFileInBuffer(AtomName(ofiles->name), LOCAL_FileNameBuf, YAP_FILENAME_MAX, true)) {
strcpy(LOCAL_ErrorSay, " Trying to open unexisting file in LoadForeign ");
return LOAD_FAILLED;
}
/* In AIX, just call load and everything will go in */
if ((*init_proc=((YapInitProc *)load(LOCAL_FileNameBuf,0,NULL))) == NULL) {
strcpy(LOCAL_ErrorSay,sys_errlist[errno]);
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign(void)
{
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif /* _AIX */

288
dev/yap-6.3/C/load_aout.c Normal file
View File

@ -0,0 +1,288 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_aout.c *
* comments: aout based dynamic loader of external routines *
* *
*************************************************************************/
#include "Yap.h"
#include "yapio.h"
#include "Foreign.h"
#ifdef A_OUT
this code is no being maintained anymore
#include <stdio.h>
#if STDC_HEADERS
#include <stdlib.h>
#endif
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_FCNTL_H
#include <fcntl.h>
#endif
#if HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#if HAVE_SYS_FILE_H
#include <sys/file.h>
#endif
#if HAVE_SYS_PARAM_H
#include <sys/param.h>
#endif
#if HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
#include <a.out.h>
#define oktox(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,X_OK))
#define oktow(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFDIR&&0==access(n,W_OK))
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
register char *cp, *cp2;
struct stat stbuf;
cp = (char *)getenv("PATH");
if (cp == NULL)
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
if (*GLOBAL_argv[0] == '/') {
if (oktox(GLOBAL_argv[0])) {
strcpy(LOCAL_FileNameBuf, GLOBAL_argv[0]);
Yap_AbsoluteFileInBuffer(LOCAL_FileNameBuf, true);
strncpy( GLOBAL_Executable, LOCAL_FileNameBuf, YAP_MAXPATHLEN);
return;
}
}
if (*cp == ':')
cp++;
for (; *cp;) {
/*
* copy over current directory and then append
* argv[0]
*/
for (cp2 = LOCAL_FileNameBuf; (*cp) != 0 && (*cp) != ':';)
*cp2++ = *cp++;
*cp2++ = '/';
strcpy(cp2, GLOBAL_argv[0]);
if (*cp)
cp++;
if (!oktox(LOCAL_FileNameBuf))
continue;
Yap_AbsoluteFileInBuffer(Yap_AbsoluteFileInBuffer(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
return;
}
/* one last try for dual systems */
strcpy(LOCAL_FileNameBuf, GLOBAL_argv[0]);
Yap_AbsoluteFileInBuffer(Yap_AbsoluteFileInBuffer(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
if (oktox(GLOBAL_Executable))
return GLOBAL_Executable;
else
Yap_Error(SYSTEM_ERROR_INTERNAL,MkAtomTerm(Yap_LookupAtom(GLOBAL_Executable)),
"cannot find file being executed");
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
/* not implemented */
return NULL;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
return FALSE;
}
int
Yap_CloseForeignFile(void *handle)
{
return -1;
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static int
LoadForeign(StringList ofiles,
StringList libs,
char *proc_name,
YapInitProc *init_proc)
{
char command[2*MAXPATHLEN];
char o_files[1024]; /* list of objects we want to load
*/
char l_files[1024]; /* list of libraries we want to
load */
char tmp_buff[32] = "/tmp/YAP_TMP_XXXXXX"; /* used for
mktemp */
char *tfile; /* name of temporary file */
int fildes; /* temp file descriptor */
struct exec header; /* header for loaded file */
unsigned long loadImageSize, firstloadImSz; /* size of image we will load */
char *FCodeBase; /* where we load foreign code */
/*
* put in a string the names of the files you want to load and of any
* libraries you want to use
*/
/* files first */
*o_files = '\0';
{
StringList tmp = ofiles;
while(tmp != NULL) {
strcat(o_files," ");
strcat(o_files,AtomName(tmp->name));
tmp = tmp->next;
}
}
/* same_trick for libraries */
*l_files = '\0';
{
StringList tmp = libs;
while(tmp != NULL) {
strcat(l_files," ");
strcat(l_files,AtomName(tmp->name));
tmp = tmp->next;
}
}
/* next, create a temp file to serve as loader output */
tfile = mktemp(tmp_buff);
/* prepare the magic */
if (strlen(o_files) + strlen(l_files) + strlen(proc_name) +
strlen(GLOBAL_Executable) > 2*MAXPATHLEN) {
strcpy(LOCAL_ErrorSay, " too many parameters in load_foreign/3 ");
return LOAD_FAILLED;
}
sprintf(command, "/usr/bin/ld -N -A %s -o %s -u _%s %s %s -lc",
GLOBAL_Executable,
tfile, proc_name, o_files, l_files);
/* now, do the magic */
if (system(command) != 0) {
unlink(tfile);
strcpy(LOCAL_ErrorSay," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
/* now check the music has played */
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LOCAL_ErrorSay," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
/* it did, get the mice */
/* first, get the header */
read(fildes, (char *) &header, sizeof(header));
close(fildes);
/* get the full size of what we need to load */
loadImageSize = header.a_text + header.a_data + header.a_bss;
/* add 16 just to play it safe */
loadImageSize += 16;
/* keep this copy */
firstloadImSz = loadImageSize;
/* now fetch the space we need */
if (!(FCodeBase = Yap_AllocCodeSpace((int) loadImageSize))) {
strcpy(LOCAL_ErrorSay," unable to allocate space for external code ");
return LOAD_FAILLED;
}
/* now, a new incantation to load the new foreign code */
sprintf(command, "/usr/bin/ld -N -A %s -T %lx -o %s -u _%s %s %s -lc",
GLOBAL_Executable,
(unsigned long) FCodeBase,
tfile, proc_name, o_files, l_files);
/* and do it */
if (system(command) != 0) {
unlink(tfile);
strcpy(LOCAL_ErrorSay," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LOCAL_ErrorSay," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
read(fildes, (char *) &header, sizeof(header));
loadImageSize = header.a_text + header.a_data + header.a_bss;
if (firstloadImSz < loadImageSize) {
strcpy(LOCAL_ErrorSay," miscalculation in load_foreign/3 ");
return LOAD_FAILLED;
}
/* now search for our init function */
{
char entry_fun[256];
struct nlist func_info[2];
sprintf(entry_fun, "_%s", proc_name);
func_info[0].n_un.n_name = entry_fun;
func_info[1].n_un.n_name = NULL;
if (nlist(tfile, func_info) == -1) {
strcpy(LOCAL_ErrorSay," in nlist(3) ");
return LOAD_FAILLED;
}
if (func_info[0].n_type == 0) {
strcpy(LOCAL_ErrorSay," in nlist(3) ");
return LOAD_FAILLED;
}
*init_proc = (YapInitProc)(func_info[0].n_value);
}
/* ok, we got our init point */
/* now read our text */
lseek(fildes, (long)(N_TXTOFF(header)), 0);
{
unsigned int u1 = header.a_text + header.a_data;
read(fildes, (char *) FCodeBase, u1);
/* zero the BSS segment */
while (u1 < loadImageSize)
FCodeBase[u1++] = 0;
}
close(fildes);
unlink(tfile);
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign(void)
{
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

336
dev/yap-6.3/C/load_coff.c Normal file
View File

@ -0,0 +1,336 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_coff.c *
* comments: coff based dynamic loader of external routines *
* *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "Foreign.h"
#ifdef COFF
this code is no being maintained anymore
#include <stdio.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/file.h>
#include <sys/param.h>
#include <sys/stat.h>
#include <a.out.h>
#define oktox(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,X_OK))
#define oktow(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFDIR&&0==access(n,W_OK))
#ifdef mips
#define MAXSECTIONS 100
#else
#define MAXSECTIONS 20
#endif /* mips */
#ifdef sgi
#include <symbol.h>
#endif /* sgi */
#define N_TXTOFF(x) (sizeof(struct filehdr)+(x).f_opthdr+(x).f_nscns*sizeof(struct scnhdr))
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
register char *cp, *cp2;
struct stat stbuf;
cp = (char *)getenv("PATH");
if (cp == NULL)
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
if (*GLOBAL_argv[0] == '/') {
if (oktox(GLOBAL_argv[0])) {
strcpy(LOCAL_FileNameBuf, GLOBAL_argv[0]);
Yap_TrueFileName(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
return NULL;
}
}
if (*cp == ':')
cp++;
for (; *cp;) {
/*
* copy over current directory and then append
* argv[0]
*/
for (cp2 = LOCAL_FileNameBuf; (*cp) != 0 && (*cp) != ':';)
*cp2++ = *cp++;
*cp2++ = '/';
strcpy(cp2, GLOBAL_argv[0]);
if (*cp)
cp++;
if (!oktox(LOCAL_FileNameBuf))
continue;
Yap_TrueFileName(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
return GLOBAL_Executable;
}
/* one last try for dual systems */
strcpy(LOCAL_FileNameBuf, GLOBAL_argv[0]);
Yap_TrueFileName(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
if (oktox(GLOBAL_Executable))
return GLOBAL_Executable;
else
Yap_Error(SYSTEM_ERROR_INTERNAL,MkAtomTerm(Yap_LookupAtom(GLOBAL_Executable)),
"cannot find file being executed");
return NULL;
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
/* not implemented */
return NULL;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
return FALSE;
}
int
Yap_CloseForeignFile(void *handle)
{
return -1;
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static Int
LoadForeign(StringList ofiles,
StringList libs,
char *proc_name,
YapInitProc *init_proc)
{
char command[2*MAXPATHLEN];
char o_files[1024]; /* list of objects we want to load
*/
char l_files[1024]; /* list of libraries we want to
load */
char tmp_buff[32] = "/tmp/YAP_TMP_XXXXXX"; /* used for
mktemp */
char *tfile; /* name of temporary file */
int fildes; /* temp file descriptor */
struct aouthdr sysHeader;
struct filehdr fileHeader;
struct scnhdr sectionHeader[MAXSECTIONS];
struct exec header; /* header for loaded file */
unsigned long loadImageSize, firstloadImSz; /* size of image we will load */
char *FCodeBase; /* where we load foreign code */
/*
* put in a string the names of the files you want to load and of any
* libraries you want to use
*/
/* files first */
*o_files = '\0';
{
StringList tmp = ofiles;
while(tmp != NULL) {
strcat(o_files," ");
strcat(o_files,AtomName(tmp->name));
tmp = tmp->next;
}
}
/* same_trick for libraries */
*l_files = '\0';
{
StringList tmp = libs;
while(tmp != NULL) {
strcat(l_files," ");
strcat(l_files,AtomName(tmp->name));
tmp = tmp->next;
}
}
/* next, create a temp file to serve as loader output */
tfile = mktemp(tmp_buff);
/* prepare the magic */
if (strlen(o_files) + strlen(l_files) + strlen(proc_name) +
strlen(GLOBAL_Executable) > 2*MAXPATHLEN) {
strcpy(LOCAL_ErrorSay, " too many parameters in load_foreign/3 ");
return LOAD_FAILLED;
}
sprintf(command, "/usr/bin/ld -N -A %s -o %s %s %s -lc",
GLOBAL_Executable,
tfile, o_files, l_files);
/* now, do the magic */
if (system(command) != 0) {
unlink(tfile);
strcpy(LOCAL_ErrorSay," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
/* now check the music has played */
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LOCAL_ErrorSay," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
/* it did, get the mice */
/* first, get the header */
read(fildes, (char *) &fileHeader, sizeof(fileHeader));
read(fildes, (char *) &sysHeader, sizeof(sysHeader));
{ int i;
for (i = 0; i < fileHeader.f_nscns; i++)
read(fildes, (char *) &sectionHeader[i],
sizeof(*sectionHeader));
}
close(fildes);
/* get the full size of what we need to load */
loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize;
#ifdef mips
/* add an extra page in mips machines */
loadImageSize += 4095 + 16;
#else
/* add 16 just to play it safe */
loadImageSize += 16;
#endif
/* keep this copy */
firstloadImSz = loadImageSize;
/* now fetch the space we need */
if (!(FCodeBase = Yap_AllocCodeSpace((int) loadImageSize))
#ifdef pyr
|| activate_code(ForeignCodeBase, u1)
#endif /* pyr */
) {
strcpy(LOCAL_ErrorSay," unable to allocate space for external code ");
return LOAD_FAILLED;
}
#ifdef mips
FCodeBase = (char *) (Unsigned(FCodeBase + PAGESIZE - 1) & ~(PAGESIZE - 1));
#endif
/* now, a new incantation to load the new foreign code */
#ifdef convex
/* No -N flag in the Convex loader */
/* -T option does not want MallocBase bit set */
sprintf(command, "ld -x -A %s -T %lx -o %s -u %s %s %s -lc",
ostabf,
((unsigned long) (((unsigned long) (ForeignCodeBase)) &
((unsigned long) (~Yap_HeapBase))
)
), tfile, entry_point, o_files, l_files);
#else
#ifdef mips
sprintf(command, "ld -systype bsd43 -N -A %s -T %lx -o %s -u %s %s %s -lc",
ostabf,
(unsigned long) ForeignCodeBase,
tfile, entry_point, o_files, l_files);
#else
sprintf(command, "ld -N -A %s -T %lx -o %s -e %s -u _%s %s -lc",
ostabf,
(unsigned long) ForeignCodeBase,
tfile, entry_point, o_files, l_files);
#endif /* mips */
#endif /* convex */
/* and do it */
if (system(command) != 0) {
unlink(tfile);
strcpy(LOCAL_ErrorSay," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LOCAL_ErrorSay," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
read(fildes, (char *) &fileHeader, sizeof(fileHeader));
read(fildes, (char *) &sysHeader, sizeof(sysHeader));
{
int i;
for (i = 0; i < fileHeader.f_nscns; i++)
read(fildes, (char *) &sectionHeader[i], sizeof(*sectionHeader));
}
loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize;
if (firstloadImSz < loadImageSize) {
strcpy(LOCAL_ErrorSay," miscalculation in load_foreign/3 ");
return LOAD_FAILLED;
}
/* now search for our init function */
{
char entry_fun[256];
struct nlist func_info[2];
#if defined(mips) || defined(I386)
char NAME1[128], NAME2[128];
func_info[0].n_name = NAME1;
func_info[1].n_name = NAME2;
#endif /* COFF */
sprintf(entry_fun, "_%s", proc_name);
func_info[0].n_name = entry_fun;
func_info[1].n_name = NULL;
if (nlist(tfile, func_info) == -1) {
strcpy(LOCAL_ErrorSay," in nlist(3) ");
return LOAD_FAILLED;
}
if (func_info[0].n_type == 0) {
strcpy(LOCAL_ErrorSay," in nlist(3) ");
return LOAD_FAILLED;
}
*init_proc = (YapInitProc)(func_info[0].n_value);
}
/* ok, we got our init point */
/* now read our text */
lseek(fildes, (long)(N_TXTOFF(header)), 0);
{
unsigned int u1 = header.a_text + header.a_data;
read(fildes, (char *) FCodeBase, u1);
/* zero the BSS segment */
while (u1 < loadImageSize)
FCodeBase[u1++] = 0;
}
close(fildes);
unlink(tfile);
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign(void)
{
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

321
dev/yap-6.3/C/load_dl.c Normal file
View File

@ -0,0 +1,321 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dl.c *
* comments: dl based dynamic loaderr of external routines *
* tested on i486-linuxelf *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "yapio.h"
#include "Foreign.h"
#if LOAD_DL
// use SWI-Prolog code if all else fails
char *
findExecutable(const char *av0, char *buffer);
#include <stdlib.h>
#include <unistd.h>
#include <dlfcn.h>
#include <string.h>
#include <stdio.h>
#if defined(__APPLE__)
#include <mach-o/dyld.h>
#include <dlfcn.h>
#endif
typedef void (*prismf)(void);
/* only works for dlls */
int
Yap_CallFunctionByName(const char *thing_string);
int
Yap_CallFunctionByName(const char *thing_string)
{
void * handle = dlopen(NULL, RTLD_LAZY
#ifndef __CYGWIN__
#ifdef RTLD_NOLOAD
| RTLD_NOLOAD
#endif
#endif
);
// you could do RTLD_NOW as well. shouldn't matter
if (!handle) {
CACHE_REGS
Yap_Error(SYSTEM_ERROR_INTERNAL, ARG1, "Dynamic linking on main module : %s\n", dlerror());
}
prismf * addr = (prismf *)dlsym(handle, thing_string);
if (addr)
(*addr)();
dlclose(handle);
return TRUE;
}
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
#if HAVE_GETEXECNAME
// Solaris
return getexecname();
#elif __APPLE__
char path[1024];
char *buf;
uint32_t size = sizeof(path);
if (!_NSGetExecutablePath(path, &size)) {
size_t sz = strlen(path);
buf = malloc(sz+1);
strncpy(buf, path, sz);
return buf;
} else {
char *rc = malloc(size+1);
if (_NSGetExecutablePath(rc, &size) == 0)
return "yap";
return rc;
}
#elif defined(__linux__)
enum { BUFFERSIZE = 1024 };
char *buf = malloc(BUFFERSIZE);
ssize_t len = readlink("/proc/self/exe", buf, sizeof(buf)-1);
if (len != -1) {
buf[len] = '\0';
return buf;
}
// follow through to standard method
#elif defined(__FreeBSD__) || defined(__DragonFly__)
enum { BUFFERSIZE = 1024 };
char *buf = malloc(BUFFERSIZE);
ssize_t len = readlink("/proc/curproc/file", buf, sizeof(buf)-1);
if (len != -1) {
buf[len] = '\0';
return buf;
}
int mib[4];
mib[0] = CTL_KERN;
mib[1] = KERN_PROC;
mib[2] = KERN_PROC_PATHNAME;
mib[3] = -1; // current process
size_t cb = BUFFERSIZE;
sysctl(mib, 4, buf, &cb, NULL, 0);
// follow through to standard method
#endif
return
NULL;
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
CACHE_REGS
int dlflag;
void *out;
if (flags & EAGER_LOADING)
dlflag = RTLD_NOW;
else
dlflag = RTLD_LAZY;
if (flags & GLOBAL_LOADING)
dlflag |= RTLD_GLOBAL;
#ifndef __CYGWIN__
else
dlflag |= RTLD_LOCAL;
#endif
if (!Yap_TrueFileName(file, LOCAL_FileNameBuf, true)){
/* use LD_LIBRARY_PATH */
strncpy(LOCAL_FileNameBuf,file, YAP_FILENAME_MAX-1);
strncat(LOCAL_FileNameBuf,".", YAP_FILENAME_MAX-1);
strncat(LOCAL_FileNameBuf, "SO_EXT", YAP_FILENAME_MAX-1);
}
out = (void *)dlopen(LOCAL_FileNameBuf, flags);
if (out == NULL) {
char *m_os = dlerror();
if (m_os) {
LOCAL_ErrorMessage = dlerror();
} else {
LOCAL_ErrorMessage = "dlopen failed";
}
}
return out;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
YapInitProc proc = (YapInitProc) dlsym(handle, f);
if (!proc) {
/* Yap_Error(SYSTEM_ERROR_INTERNAL, ARG1, "dlsym error %s\n", dlerror());*/
return FALSE;
}
(*proc) ();
return TRUE;
}
int
Yap_CloseForeignFile(void *handle)
{
if ( dlclose(handle) < 0) {
CACHE_REGS
Yap_Error(SYSTEM_ERROR_INTERNAL, ARG1, "dlclose error %s\n", dlerror());
return -1;
}
return 0;
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
CACHE_REGS
while (libs) {
if (!Yap_TrueFileName((char *)AtomName(libs->name), LOCAL_FileNameBuf, true)) {
/* use LD_LIBRARY_PATH */
strncpy(LOCAL_FileNameBuf, (char *)AtomName(libs->name), YAP_FILENAME_MAX);
}
#ifdef __osf__
if((libs->handle=dlopen(LOCAL_FileNameBuf,RTLD_LAZY)) == NULL)
#else
if((libs->handle=dlopen(LOCAL_FileNameBuf,RTLD_LAZY|RTLD_GLOBAL)) == NULL)
#endif
{
strcpy(LOCAL_ErrorSay,dlerror());
return LOAD_FAILLED;
}
libs = libs->next;
}
while (ofiles) {
void *handle;
/* load libraries first so that their symbols are available to
other routines */
/* dlopen wants to follow the LD_CONFIG_PATH */
if (!Yap_TrueFileName((char *)AtomName(ofiles->name), LOCAL_FileNameBuf, TRUE)) {
strcpy(LOCAL_ErrorSay, "%% Trying to open unexisting file in LoadForeign");
return LOAD_FAILLED;
}
#ifdef __osf__
if((handle=dlopen(LOCAL_FileNameBuf,RTLD_LAZY)) == 0)
#else
if((handle=dlopen(LOCAL_FileNameBuf,RTLD_LAZY|RTLD_GLOBAL)) == 0)
#endif
{
fprintf(stderr,"dlopen of image %s failed: %s\n", LOCAL_FileNameBuf, dlerror());
/* strcpy(LOCAL_ErrorSay,dlerror());*/
return LOAD_FAILLED;
}
ofiles->handle = handle;
if (proc_name && !*init_proc)
*init_proc = (YapInitProc) dlsym(handle,proc_name);
ofiles = ofiles->next;
}
if(! *init_proc) {
strcpy(LOCAL_ErrorSay,"Could not locate initialization routine");
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign(void)
{
ForeignObj *f_code;
f_code = ForeignCodeLoaded;
while (f_code != NULL) {
StringList objs, libs, old;
ForeignObj *of_code = f_code;
objs = f_code->objs;
while (objs != NULL) {
old = objs;
if (dlclose(objs->handle) != 0)
return; /* ERROR */
objs = objs->next;
Yap_FreeCodeSpace((ADDR)old);
}
libs = f_code->libs;
while (libs != NULL) {
old = libs;
if (dlclose(libs->handle) != 0)
return; /* ERROR */
libs = libs->next;
Yap_FreeCodeSpace((ADDR)old);
}
f_code = f_code->next;
Yap_FreeCodeSpace((ADDR)of_code);
}
/*
make sure that we don't try to close foreign code several times, eg,
from within an error handler
*/
ForeignCodeLoaded = NULL;
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif
#if SIMICS
void dlopen(void)
{
}
void dlclose(void)
{
}
void dlsym(void)
{
}
#endif

131
dev/yap-6.3/C/load_dld.c Normal file
View File

@ -0,0 +1,131 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dld.c *
* comments: dld based dynamic loaderr of external routines *
* tested on i486-linuxaout *
*************************************************************************/
#if defined(linux) && !defined(__ELF__) && !defined(__LCC__)
#include "Foreign.h"
#include <dld.h>
#include <malloc.h>
#include <stdio.h>
this code is no being maintained anymore
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
/* use dld_find_executable */
char *res;
if(name != NULL && (res=dld_find_executable(name))) {
return GLOBAL_Executable;
} else {
return "yap";
}
}
static void *
Yap_LoadForeignFile(char *file, int flags)
{
/* not implemented */
return NULL;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
return FALSE;
}
int
Yap_CloseForeignFile(void *handle)
{
return -1;
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
static int firstTime = 1;
int error;
if(firstTime) {
error = dld_init(GLOBAL_Executable);
if(error) {
strcpy(LOCAL_ErrorSay,dld_strerror(error));
return LOAD_FAILLED;
}
firstTime=0;
}
while (ofiles) {
if((error=dld_link(AtomName(ofiles->name))) !=0) {
strcpy(LOCAL_ErrorSay,dld_strerror(error));
return LOAD_FAILLED;
}
ofiles = ofiles->next;
}
/* TODO: handle libs */
*init_proc = (YapInitProc) dld_get_func(proc_name);
if(! *init_proc) {
strcpy(LOCAL_ErrorSay,"Could not locate initialization routine");
return LOAD_FAILLED;
}
if(!dld_function_executable_p(proc_name)) {
char **undefs = dld_list_undefined_sym();
char **p = undefs;
int k = dld_undefined_sym_count;
strcpy(LOCAL_ErrorSay,"Could not resolve all symbols");
while(k) {
YP_printf("[undefined symbol %s]\n",*p++);
--k;
}
free(undefs);
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign(void)
{
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

153
dev/yap-6.3/C/load_dll.c Normal file
View File

@ -0,0 +1,153 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dl.c *
* comments: dl based dynamic loader of external routines *
* tested on i486-linuxelf *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "yapio.h"
#include "Foreign.h"
#if _WIN32
#include <windows.h>
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
enum { BUFFERSIZE = 1024 };
char *buf = malloc(BUFFERSIZE);
if (!GetModuleFileName(NULL, buf, BUFFERSIZE-1))
return NULL;
return buf;
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
void *ptr= (void *)LoadLibrary(file);
if (!ptr) {
CACHE_REGS
LOCAL_ErrorSay[0]='\0';
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, GetLastError(),
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), LOCAL_ErrorSay, 256,
NULL);
}
return ptr;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
YapInitProc proc = (YapInitProc)GetProcAddress((HMODULE)handle, f);
if (!proc)
return FALSE;
(*proc)();
return TRUE;
}
int
Yap_CloseForeignFile(void *handle)
{
return FreeLibrary((HMODULE)handle);
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
CACHE_REGS
while (ofiles) {
HINSTANCE handle;
if (Yap_TrueFileName(AtomName(ofiles->name), LOCAL_FileNameBuf, TRUE) &&
(handle=LoadLibrary(LOCAL_FileNameBuf)) != 0)
{
LOCAL_ErrorSay[0]=~'\0';
if (*init_proc == NULL)
*init_proc = (YapInitProc)GetProcAddress((HMODULE)handle, proc_name);
} else {
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, GetLastError(),
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), LOCAL_ErrorSay, 256,
NULL);
//fprintf(stderr,"WinError: %s\n", LOCAL_ErrorSay);
}
ofiles = ofiles->next;
}
/* load libraries first so that their symbols are available to
other routines */
while (libs) {
HINSTANCE handle;
const char * s = AtomName(libs->name);
if (s[0] == '-') {
strcat(LOCAL_FileNameBuf,s+2);
strcat(LOCAL_FileNameBuf,".dll");
} else {
strcpy(LOCAL_FileNameBuf,s);
}
if((handle=LoadLibrary(LOCAL_FileNameBuf)) == 0)
{
/* strcpy(LOCAL_ErrorSay,dlerror());*/
return LOAD_FAILLED;
}
if (*init_proc == NULL)
*init_proc = (YapInitProc)GetProcAddress((HMODULE)handle, proc_name);
libs = libs->next;
}
if(*init_proc == NULL) {
strcpy(LOCAL_ErrorSay,"Could not locate initialization routine");
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign(void)
{
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

246
dev/yap-6.3/C/load_dyld.c Normal file
View File

@ -0,0 +1,246 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dyld.c *
* comments: dyld based dynamic loaderr of external routines *
* tested on MacOS *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "yapio.h"
#include "Foreign.h"
#if LOAD_DYLD
#include <string.h>
/* Code originally from Rex A. Dieter's posting in comp.sys.next.programmer
and from dynload_next.c in the Python sources
*/
#import <mach-o/dyld.h>
static char *
mydlerror(void)
{
char *errString;
switch(LOCAL_dl_errno) {
default:
case NSObjectFileImageFailure:
case NSObjectFileImageFormat:
/* for these a message is printed on stderr by dyld */
errString = "Can't create object file image";
break;
case NSObjectFileImageSuccess:
errString = NULL;
break;
case NSObjectFileImageInappropriateFile:
errString = "Inappropriate file type for dynamic loading";
break;
case NSObjectFileImageArch:
errString = "Wrong CPU type in object file";
break;
case NSObjectFileImageAccess:
errString = "Can't read object file (no access)";
break;
}
return(errString);
}
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
char path[1024];
uint32_t size = sizeof(path);
if (_NSGetExecutablePath(path, &size) == 0) {
char *rc = malloc(size+1);
strncpy(rc, path, size);
return rc;
} else {
char *rc = malloc(size+1);
if (_NSGetExecutablePath(rc, &size) == 0)
return "yap";
return rc;
}
}
static void *
mydlopen(char *path)
{
int dyld_result;
NSObjectFileImage ofile;
NSModule handle = NULL;
dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
if (dyld_result != NSObjectFileImageSuccess) {
LOCAL_dl_errno = dyld_result;
} else {
/* NSLinkModule will cause the run to abort on any link error's */
/* not very friendly but the error recovery functionality is limited */
handle = NSLinkModule(ofile, path, TRUE);
}
return handle;
}
static void *
mydlsym(char *symbol)
{
void *addr;
char funcname[256];
#if HAVE_SNPRINTF
snprintf(funcname, sizeof(funcname), "_%.200s", symbol);
#else
sprintf(funcname, "_%.200s", symbol);
#endif
if (NSIsSymbolNameDefined(funcname))
addr = NSAddressOfSymbol(NSLookupAndBindSymbol(funcname));
else
addr = NULL;
return addr;
}
static int
mydlclose(void *handle)
{
NSUnLinkModule(handle, NSUNLINKMODULE_OPTION_NONE);
return TRUE;
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
return (void *)mydlopen(file);
}
int
Yap_CallForeignFile(void *handle, char *f)
{
YapInitProc proc = (YapInitProc) mydlsym(f);
if (!proc)
return FALSE;
(*proc)();
return TRUE;
}
int
Yap_CloseForeignFile(void *handle)
{
return mydlclose(handle);
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
while (ofiles) {
void *handle;
/* mydlopen wants to follow the LD_CONFIG_PATH */
if (!Yap_TrueFileName(AtomName(ofiles->name), LOCAL_FileNameBuf, TRUE)) {
strcpy(LOCAL_ErrorSay, "%% Trying to open unexisting file in LoadForeign");
return LOAD_FAILLED;
}
if((handle=mydlopen(LOCAL_FileNameBuf)) == 0)
{
fprintf(stderr,"calling dlopen with error %s\n", mydlerror());
/* strcpy(LOCAL_ErrorSay,dlerror());*/
return LOAD_FAILLED;
}
ofiles->handle = handle;
ofiles = ofiles->next;
}
/* load libraries first so that their symbols are available to
other routines */
while (libs) {
char *s = AtomName(lib->name);
if (ls[0] == '-') {
strcpy(LOCAL_FileNameBuf,"lib");
strcat(LOCAL_FileNameBuf,s+2);
strcat(LOCAL_FileNameBuf,".so");
} else {
strcpy(LOCAL_FileNameBuf,s);
}
if((libs->handle=mydlopen(LOCAL_FileNameBuf)) == NULL)
{
strcpy(LOCAL_ErrorSay,mydlerror());
return LOAD_FAILLED;
}
libs = libs->next;
}
*init_proc = (YapInitProc) mydlsym(proc_name);
if(! *init_proc) {
strcpy(LOCAL_ErrorSay,"Could not locate initialization routine");
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign(void)
{
ForeignObj *f_code;
f_code = ForeignCodeLoaded;
while (f_code != NULL) {
StringList objs, libs;
objs = f_code->objs;
while (objs != NULL) {
if (mydlclose(objs->handle) != 0)
return; /* ERROR */
objs = objs->next;
}
libs = f_code->libs;
while (libs != NULL) {
if (mydlclose(libs->handle) != 0)
return; /* ERROR */
objs = libs->next;
}
f_code = f_code->next;
}
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

274
dev/yap-6.3/C/load_foreign.c Normal file
View File

@ -0,0 +1,274 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_foreign.c *
* comments: dynamic loader of external routines *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%.2";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "yapio.h"
#include "YapText.h"
#include <stdlib.h>
#if HAVE_STRING_H
#include <string.h>
#endif
#include "Foreign.h"
#if _WIN32 || defined(__CYGWIN__)
#ifndef SO_EXT
#define SO_EXT "dll"
#endif
#endif
Int p_load_foreign( USES_REGS1 );
Int
p_load_foreign( USES_REGS1 )
{
StringList ofiles = NULL;
StringList libs = NULL;
char *InitProcName;
YapInitProc InitProc = NULL;
Term t, t1;
StringList new;
Int returncode = FALSE;
yhandle_t CurSlot = Yap_StartSlots();
strcpy(LOCAL_ErrorSay,"Invalid arguments");
// Yap_DebugPlWrite(ARG1); printf("%s\n", " \n");
//Yap_DebugPlWrite(ARG2); printf("%s\n", " \n");
//ap_DebugPlWrite(ARG3); printf("%s\n", " \n");
/* collect the list of object files */
t = Deref(ARG1);
while(1) {
if (t == TermNil) break;
t1 = HeadOfTerm(t);
t = TailOfTerm(t);
new = (StringList) Yap_AllocCodeSpace(sizeof(StringListItem));
new->next = ofiles;
new->name = AtomOfTerm(t1);
ofiles = new;
}
/* collect the list of library files */
t = Deref(ARG2);
while(1) {
if (t == TermNil) break;
t1 = HeadOfTerm(t);
t = TailOfTerm(t);
new = (StringList) Yap_AllocCodeSpace(sizeof(StringListItem));
new->next = libs;
new->name = AtomOfTerm(t1);
libs = new;
}
/* get the initialization function name */
t1 = Deref(ARG3);
InitProcName = (char *)RepAtom(AtomOfTerm(t1))->StrOfAE;
/* call the OS specific function for dynamic loading */
if(Yap_LoadForeign(ofiles,libs,InitProcName,&InitProc)==LOAD_SUCCEEDED) {
Yap_StartSlots( );
(*InitProc)();
Yap_CloseSlots(CurSlot);
returncode = TRUE;
}
/* I should recover space if load foreign fails */
if (returncode == TRUE) {
ForeignObj *f_code = (ForeignObj *)Yap_AllocCodeSpace(sizeof(ForeignObj));
f_code->objs = ofiles;
f_code->libs = libs;
f_code->f = AtomOfTerm(t1);
f_code->next = ForeignCodeLoaded;
f_code->module = CurrentModule;
ForeignCodeLoaded = f_code;
} else {
while (ofiles) {
new = ofiles->next;
Yap_FreeCodeSpace((ADDR)ofiles);
ofiles = new;
}
while (libs) {
new = libs->next;
Yap_FreeCodeSpace((ADDR)libs);
libs = new;
}
}
return returncode;
}
static Int
p_open_shared_object( USES_REGS1 ) {
Term t = Deref(ARG1);
Term tflags = Deref(ARG2);
char *s;
void *handle;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"open_shared_object/3");
return FALSE;
}
if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM,t,"open_shared_object/3");
return FALSE;
}
if (IsVarTerm(tflags)) {
Yap_Error(INSTANTIATION_ERROR,tflags,"open_shared_object/3");
return FALSE;
}
if (!IsIntegerTerm(tflags)) {
Yap_Error(TYPE_ERROR_INTEGER,tflags,"open_shared_object/3");
return FALSE;
}
s = (char *)RepAtom(AtomOfTerm(t))->StrOfAE;
if ((handle = Yap_LoadForeignFile(s, IntegerOfTerm(tflags)))==NULL) {
Yap_Error(EXISTENCE_ERROR_SOURCE_SINK,t,"open_shared_object_failed for %s with %s\n", s, LOCAL_ErrorSay);
return FALSE;
} else {
return Yap_unify(MkIntegerTerm((Int)handle),ARG3);
}
}
static Int
p_close_shared_object( USES_REGS1 ) {
Term t = Deref(ARG1);
void *handle;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"close_shared_object/1");
return FALSE;
}
if (!IsIntegerTerm(t)) {
Yap_Error(TYPE_ERROR_INTEGER,t,"close_shared_object/1");
return FALSE;
}
handle = (char *)IntegerOfTerm(t);
return Yap_CloseForeignFile(handle);
}
static Int
p_call_shared_object_function( USES_REGS1 ) {
Term t = Deref(ARG1);
Term tfunc = Deref(ARG2);
Term tmod;
void *handle;
Term OldCurrentModule = CurrentModule;
Int res;
tmod = CurrentModule;
restart:
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"call_shared_object_function/2");
return FALSE;
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
if (fun == FunctorModule) {
tmod = ArgOfTerm(1, t);
if (IsVarTerm(tmod) ) {
Yap_Error(INSTANTIATION_ERROR,t,"call_shared_object_function/2");
return FALSE;
}
if (!IsAtomTerm(tmod) ) {
Yap_Error(TYPE_ERROR_ATOM,ARG1,"call_shared_object_function/2");
return FALSE;
}
t = ArgOfTerm(2, t);
goto restart;
}
} else if (!IsIntegerTerm(t)) {
Yap_Error(TYPE_ERROR_INTEGER,t,"call_shared_object_function/2");
return FALSE;
}
handle = (void *)IntegerOfTerm(t);
if (IsVarTerm(tfunc)) {
Yap_Error(INSTANTIATION_ERROR,t,"call_shared_object_function/2");
return FALSE;
}
if (!IsAtomTerm(tfunc)) {
Yap_Error(TYPE_ERROR_ATOM,t,"call_shared_object_function/2/3");
return FALSE;
}
CurrentModule = tmod;
res = Yap_CallForeignFile(handle, (char *)RepAtom(AtomOfTerm(tfunc))->StrOfAE);
CurrentModule = OldCurrentModule;
return res;
}
static Int
p_obj_suffix( USES_REGS1 ) {
return Yap_unify(Yap_CharsToListOfCodes(SO_EXT, ENC_ISO_LATIN1 PASS_REGS),ARG1);
}
static Int
p_open_shared_objects( USES_REGS1 ) {
#ifdef SO_EXT
return TRUE;
#else
return FALSE;
#endif
}
void
Yap_InitLoadForeign( void )
{
Yap_InitCPred("$load_foreign_files", 3, p_load_foreign, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$open_shared_objects", 0, p_open_shared_objects, SafePredFlag);
Yap_InitCPred("$open_shared_object", 3, p_open_shared_object, SyncPredFlag);
Yap_InitCPred("close_shared_object", 1, p_close_shared_object, SyncPredFlag|SafePredFlag);
/** @pred close_shared_object(+ _Handle_)
Detach the shared object identified by _Handle_.
*/
Yap_InitCPred("$call_shared_object_function", 2, p_call_shared_object_function, SyncPredFlag);
Yap_InitCPred("$obj_suffix", 1, p_obj_suffix, SafePredFlag);
}
void
Yap_ReOpenLoadForeign(void)
{
CACHE_REGS
ForeignObj *f_code = ForeignCodeLoaded;
Term OldModule = CurrentModule;
while (f_code != NULL) {
YapInitProc InitProc = NULL;
CurrentModule = f_code->module;
if(Yap_ReLoadForeign(f_code->objs,f_code->libs,(char *)RepAtom(f_code->f)->StrOfAE,&InitProc)==LOAD_SUCCEEDED) {
if (InitProc)
(*InitProc)();
}
f_code = f_code->next;
}
CurrentModule = OldModule;
}

88
dev/yap-6.3/C/load_none.c Normal file
View File

@ -0,0 +1,88 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_none.c *
* comments: dummy dynamic loaderr of external routines *
*************************************************************************/
#include "Yap.h"
#include "Foreign.h"
#include "Yatom.h"
#include "YapHeap.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef NO_DYN
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
return NULL;
}
/*
* LoadForeign(file_name,proc_name,init_proc) dynamically loads a foreign
* code file and locates an initialization routine
*/
static Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
strcpy(LOCAL_ErrorSay,"load_foreign not supported in this version of Yap");
return LOAD_FAILLED;
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
/* not implemented */
return NULL;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
return FALSE;
}
int
Yap_CloseForeignFile(void *handle)
{
return -1;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
void
Yap_ShutdownLoadForeign(void)
{
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

174
dev/yap-6.3/C/load_shl.c Normal file
View File

@ -0,0 +1,174 @@
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "yapio.h"
#include "Foreign.h"
#if LOAD_SHL
#include <dl.h>
#include <malloc.h>
#include <stdio.h>
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char * Yap_FindExecutable(void)
{
}
void *
Yap_LoadForeignFile(char *file, int flags)
{
/* not implemented */
return NULL;
}
int
Yap_CallForeignFile(void *handle, char *f)
{
return FALSE;
}
int
Yap_CloseForeignFile(void *handle)
{
return -1;
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
static Int
LoadForeign( StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc )
{
/* *init_proc is initialized to NULL in load_foreign.c */
int init_missing = -1;
int n, i;
struct shl_symbol *p;
while( ofiles ) {
int valid_fname;
/* shl_load wants to follow the LD_CONFIG_PATH */
valid_fname = Yap_TrueFileName( AtomName(ofiles->name), LOCAL_FileNameBuf, TRUE );
if( !valid_fname ) {
strcpy( LOCAL_ErrorSay, "%% Trying to open non-existing file in LoadForeign" );
return LOAD_FAILLED;
}
ofiles->handle = Yap_AllocCodeSpace( sizeof(shl_t) );
*(shl_t *)ofiles->handle = shl_load( LOCAL_FileNameBuf, BIND_DEFERRED, 0 );
if( *(shl_t *)ofiles->handle == NULL ) {
strncpy( LOCAL_ErrorSay, strerror(errno), MAX_ERROR_MSG_SIZE );
return LOAD_FAILLED;
}
if( init_missing ) {
init_missing = shl_findsym( ofiles->handle, proc_name,
TYPE_PROCEDURE, init_proc );
}
ofiles = ofiles->next;
}
if( init_missing ) {
strcpy( LOCAL_ErrorSay, "Could not locate initialization routine" );
return LOAD_FAILLED;
}
while( libs ) {
char *s = AtomName(lib->s);
if( s[0] == '-' ) {
strcpy( LOCAL_FileNameBuf, "lib" );
strcat( LOCAL_FileNameBuf, s+2 );
strcat( LOCAL_FileNameBuf, ".sl" );
}
else {
strcpy( LOCAL_FileNameBuf, s );
}
*(shl_t *)libs->handle = shl_load( LOCAL_FileNameBuf, BIND_DEFERRED, 0 );
if( *(shl_t *)libs->handle == NULL ) {
strncpy( LOCAL_ErrorSay, strerror(errno), MAX_ERROR_MSG_SIZE );
return LOAD_FAILLED;
}
libs = libs->next;
}
return LOAD_SUCCEEDED;
}
Int
Yap_LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return LoadForeign(ofiles, libs, proc_name, init_proc);
}
void
Yap_ShutdownLoadForeign( void )
{
ForeignObj *f_code;
int err;
f_code = ForeignCodeLoaded;
while( f_code != NULL ) {
StringList objs, libs;
objs = f_code->objs;
while( objs ) {
err = shl_unload( *(shl_t *)objs->handle );
if( err ) {
/* dunno how to properly report an error here */
perror( NULL );
return;
}
Yap_FreeCodeSpace( objs->handle );
objs = objs->next;
}
libs = f_code->libs;
while( libs ) {
err = shl_unload( *(shl_t *)libs->handle );
if( err ) {
/* dunno how to properly report an error here */
perror( NULL );
return;
}
Yap_FreeCodeSpace( libs->handle );
libs = libs->next;
}
f_code = f_code->next;
}
}
Int
Yap_ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
ShutdownLoadForeign();
return( LoadForeign( ofiles, libs, proc_name, init_proc ) );
}
/*
dunno what this one is supposed to do, no load_* defines it
void ReOpenLoadForeign(void);
*/
#endif

771
dev/yap-6.3/C/lu_absmi_insts.h Normal file
View File

@ -0,0 +1,771 @@
/************************************************************************\
* Logical Updates *
\************************************************************************/
#ifdef INDENT_CODE
{
{
#endif /* INDENT_CODE */
/************************************************************************\
* Logical Updates *
\************************************************************************/
/* enter logical pred */
BOp(enter_lu_pred, Illss);
check_trail(TR);
/* mark the indexing code */
{
LogUpdIndex *cl = PREG->y_u.Illss.I;
PredEntry *ap = cl->ClPred;
if (!cl) { FAIL(); } /* in case the index is empty */
if (ap->LastCallOfPred != LUCALL_EXEC) {
/*
only increment time stamp if we are working on current time
stamp
*/
if (ap->TimeStampOfPred >= TIMESTAMP_RESET)
Yap_UpdateTimestamps(ap);
ap->TimeStampOfPred++;
ap->LastCallOfPred = LUCALL_EXEC;
/* fprintf(stderr,"R %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
}
*--YREG = MkIntegerTerm(ap->TimeStampOfPred);
/* fprintf(stderr,"> %p/%p %d %d\n",cl,ap,ap->TimeStampOfPred,PREG->y_u.Illss.s);*/
PREG = PREG->y_u.Illss.l1;
/* indicate the indexing code is being used */
#if MULTIPLE_STACKS
/* just store a reference */
INC_CLREF_COUNT(cl);
TRAIL_CLREF(cl);
#else
if (!(cl->ClFlags & InUseMask)) {
cl->ClFlags |= InUseMask;
TRAIL_CLREF(cl);
}
#endif
}
JMPNext();
ENDBOp();
BOp(profiled_retry_logical, OtaLl);
check_trail(TR);
{
UInt timestamp;
CACHE_Y(B);
#if defined(YAPOR) || defined(THREADS)
if (PP != PREG->y_u.OtaLl.d->ClPred) {
if (PP) UNLOCKPE(15,PP);
PP = PREG->y_u.OtaLl.d->ClPred;
PELOCK(15,PP);
}
#endif
timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[PREG->y_u.OtaLl.s]);
if (!VALID_TIMESTAMP(timestamp, PREG->y_u.OtaLl.d)) {
/* jump to next instruction */
PREG=PREG->y_u.OtaLl.n;
JMPNext();
}
restore_yaam_regs(PREG->y_u.OtaLl.n);
restore_args(PREG->y_u.OtaLl.s);
LOCK(PREG->y_u.OtaLl.d->ClPred->StatisticsForPred->lock);
PREG->y_u.OtaLl.d->ClPred->StatisticsForPred->NOfRetries++;
UNLOCK(PREG->y_u.OtaLl.d->ClPred->StatisticsForPred->lock);
#ifdef THREADS
PP = PREG->y_u.OtaLl.d->ClPred;
#endif
PREG = PREG->y_u.OtaLl.d->ClCode;
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
set_cut(S_YREG, B->cp_b);
#else
set_cut(S_YREG, B_YREG->cp_b);
#endif /* FROZEN_STACKS */
SET_BB(B_YREG);
ENDCACHE_Y();
}
JMPNext();
ENDBOp();
BOp(profiled_trust_logical, OtILl);
CACHE_Y(B);
{
LogUpdIndex *cl = PREG->y_u.OtILl.block;
PredEntry *ap = cl->ClPred;
LogUpdClause *lcl = PREG->y_u.OtILl.d;
UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]);
#if defined(YAPOR) || defined(THREADS)
if (PP != ap) {
if (PP) UNLOCKPE(16,PP);
PP = ap;
PELOCK(16,PP);
}
#endif
if (!VALID_TIMESTAMP(timestamp, lcl)) {
/* jump to next alternative */
PREG = FAILCODE;
} else {
LOCK(ap->StatisticsForPred->lock);
ap->StatisticsForPred->NOfRetries++;
UNLOCK(ap->StatisticsForPred->lock);
PREG = lcl->ClCode;
}
/* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */
#if MULTIPLE_STACKS
DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */
B->cp_tr--;
TR = B->cp_tr;
/* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
if (PREG != FAILCODE) {
/* I am the last one using this clause, hence I don't need a lock
to dispose of it
*/
if (lcl->ClRefCount == 1) {
/* make sure the clause isn't destroyed */
/* always add an extra reference */
INC_CLREF_COUNT(lcl);
TRAIL_CLREF(lcl);
}
}
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
}
#else
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) {
cl->ClFlags &= ~InUseMask;
--B->cp_tr;
#if FROZEN_STACKS
if (B->cp_tr > TR_FZ)
#endif
{
TR = B->cp_tr;
}
/* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) {
if (PREG != FAILCODE) {
/* make sure we don't erase the clause we are jumping to,
notice that we can erase a number of refs in one go. */
if (!(lcl->ClFlags & InUseMask)) {
lcl->ClFlags |= InUseMask;
TRAIL_CLREF(lcl);
}
}
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
}
}
#endif
#ifdef YAPOR
if (SCH_top_shared_cp(B)) {
SCH_last_alternative(PREG, B_YREG);
restore_args(ap->ArityOfPE);
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#else
S_YREG++;
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B->cp_b);
} else
#endif /* YAPOR */
{
pop_yaam_regs();
pop_args(ap->ArityOfPE);
S_YREG--;
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B);
}
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
}
ENDBOp();
BOp(try_logical, OtaLl);
check_trail(TR);
{
UInt timestamp;
CACHE_Y(YREG);
timestamp = IntegerOfTerm(S_YREG[0]);
/* fprintf(stderr,"+ %p/%p %d %d %d--%u\n",PREG,PREG->y_u.OtaLl.d->ClPred,timestamp,PREG->y_u.OtaLl.d->ClPred->TimeStampOfPred,PREG->y_u.OtaLl.d->ClTimeStart,PREG->y_u.OtaLl.d->ClTimeEnd);*/
/* Point AP to the code that follows this instruction */
/* always do this, even if we are not going to use it */
store_args(PREG->y_u.OtaLl.s);
store_yaam_regs(PREG->y_u.OtaLl.n, 0);
set_cut(S_YREG, B);
B = B_YREG;
#ifdef YAPOR
SCH_set_load(B_YREG);
#endif /* YAPOR */
#ifdef YAPOR
PP = PREG->y_u.OtaLl.d->ClPred;
#endif /* YAPOR */
if (!VALID_TIMESTAMP(timestamp, PREG->y_u.OtaLl.d)) {
/* jump to next alternative */
PREG=PREG->y_u.OtaLl.n;
} else {
PREG = PREG->y_u.OtaLl.d->ClCode;
}
SET_BB(B_YREG);
ENDCACHE_Y();
}
JMPNext();
ENDBOp();
BOp(count_retry_logical, OtaLl);
check_trail(TR);
{
UInt timestamp;
CACHE_Y(B);
#if defined(YAPOR) || defined(THREADS)
if (PP != PREG->y_u.OtaLl.d->ClPred) {
if (PP) UNLOCKPE(15,PP);
PP = PREG->y_u.OtaLl.d->ClPred;
PELOCK(15,PP);
}
#endif
timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[PREG->y_u.OtaLl.s]);
if (!VALID_TIMESTAMP(timestamp, PREG->y_u.OtaLl.d)) {
/* jump to next instruction */
PREG=PREG->y_u.OtaLl.n;
JMPNext();
}
restore_yaam_regs(PREG->y_u.OtaLl.n);
restore_args(PREG->y_u.OtaLl.s);
LOCAL_RetriesCounter--;
if (LOCAL_RetriesCounter == 0) {
saveregs();
Yap_NilError(RETRY_COUNTER_UNDERFLOW_EVENT,"");
setregs();
JMPNext();
}
LOCAL_PredEntriesCounter--;
if (LOCAL_PredEntriesCounter == 0) {
saveregs();
Yap_NilError(PRED_ENTRY_COUNTER_UNDERFLOW_EVENT,"");
setregs();
JMPNext();
}
LOCK(PREG->y_u.OtaLl.d->ClPred->StatisticsForPred->lock);
PREG->y_u.OtaLl.d->ClPred->StatisticsForPred->NOfRetries++;
UNLOCK(PREG->y_u.OtaLl.d->ClPred->StatisticsForPred->lock);
#ifdef THREADS
PP = PREG->y_u.OtaLl.d->ClPred;
#endif
PREG = PREG->y_u.OtaLl.d->ClCode;
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
set_cut(S_YREG, B->cp_b);
#else
set_cut(S_YREG, B_YREG->cp_b);
#endif /* FROZEN_STACKS */
SET_BB(B_YREG);
ENDCACHE_Y();
}
JMPNext();
ENDBOp();
BOp(count_trust_logical, OtILl);
CACHE_Y(B);
{
LogUpdIndex *cl = PREG->y_u.OtILl.block;
PredEntry *ap = cl->ClPred;
LogUpdClause *lcl = PREG->y_u.OtILl.d;
UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]);
#if defined(YAPOR) || defined(THREADS)
if (PP != ap) {
if (PP) UNLOCKPE(16,PP);
PP = ap;
PELOCK(16,PP);
}
#endif
if (!VALID_TIMESTAMP(timestamp, lcl)) {
/* jump to next alternative */
PREG = FAILCODE;
} else {
LOCAL_RetriesCounter--;
if (LOCAL_RetriesCounter == 0) {
saveregs();
Yap_NilError(RETRY_COUNTER_UNDERFLOW_EVENT,"");
setregs();
JMPNext();
}
LOCAL_PredEntriesCounter--;
if (LOCAL_PredEntriesCounter == 0) {
saveregs();
Yap_NilError(PRED_ENTRY_COUNTER_UNDERFLOW_EVENT,"");
setregs();
JMPNext();
}
LOCK(ap->StatisticsForPred->lock);
ap->StatisticsForPred->NOfRetries++;
UNLOCK(ap->StatisticsForPred->lock);
PREG = lcl->ClCode;
}
/* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */
#if MULTIPLE_STACKS
PELOCK(2, ap);
PP = ap;
DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */
--B->cp_tr;
TR = B->cp_tr;
/* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
if (PREG != FAILCODE) {
/* I am the last one using this clause, hence I don't need a lock
to dispose of it
*/
if (lcl->ClRefCount == 1) {
/* make sure the clause isn't destroyed */
/* always add an extra reference */
INC_CLREF_COUNT(lcl);
TRAIL_CLREF(lcl);
}
}
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
}
#else
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) {
cl->ClFlags &= ~InUseMask;
--B->cp_tr;
#if FROZEN_STACKS
if (B->cp_tr > TR_FZ)
#endif
{
TR = B->cp_tr;
}
/* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) {
if (PREG != FAILCODE) {
/* make sure we don't erase the clause we are jumping too */
if (!(lcl->ClFlags & InUseMask)) {
lcl->ClFlags |= InUseMask;
TRAIL_CLREF(lcl);
}
}
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
}
}
#endif
#ifdef YAPOR
if (SCH_top_shared_cp(B)) {
SCH_last_alternative(PREG, B_YREG);
restore_args(ap->ArityOfPE);
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#else
S_YREG++;
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B->cp_b);
} else
#endif /* YAPOR */
{
pop_yaam_regs();
pop_args(ap->ArityOfPE);
S_YREG--;
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B);
}
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
}
ENDBOp();
BOp(retry_logical, OtaLl);
check_trail(TR);
{
UInt timestamp;
CACHE_Y(B);
#if defined(YAPOR) || defined(THREADS)
if (PP != PREG->y_u.OtaLl.d->ClPred) {
if (PP) UNLOCKPE(15,PP);
PP = PREG->y_u.OtaLl.d->ClPred;
PELOCK(15,PP);
}
#endif
timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[PREG->y_u.OtaLl.s]);
/* fprintf(stderr,"^ %p/%p %d %d %d--%u\n",PREG,PREG->y_u.OtaLl.d->ClPred,timestamp,PREG->y_u.OtaLl.d->ClPred->TimeStampOfPred,PREG->y_u.OtaLl.d->ClTimeStart,PREG->y_u.OtaLl.d->ClTimeEnd);*/
if (!VALID_TIMESTAMP(timestamp, PREG->y_u.OtaLl.d)) {
/* jump to next instruction */
PREG=PREG->y_u.OtaLl.n;
JMPNext();
}
restore_yaam_regs(PREG->y_u.OtaLl.n);
restore_at_least_one_arg(PREG->y_u.OtaLl.s);
#ifdef THREADS
PP = PREG->y_u.OtaLl.d->ClPred;
#endif
PREG = PREG->y_u.OtaLl.d->ClCode;
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
set_cut(S_YREG, B->cp_b);
#else
set_cut(S_YREG, B_YREG->cp_b);
#endif /* FROZEN_STACKS */
SET_BB(B_YREG);
ENDCACHE_Y();
}
JMPNext();
ENDBOp();
BOp(trust_logical, OtILl);
CACHE_Y(B);
{
LogUpdIndex *cl = PREG->y_u.OtILl.block;
PredEntry *ap = cl->ClPred;
LogUpdClause *lcl = PREG->y_u.OtILl.d;
UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]);
/* fprintf(stderr,"- %p/%p %d %d %p\n",PREG,ap,timestamp,ap->TimeStampOfPred,PREG->y_u.OtILl.d->ClCode);*/
#if defined(YAPOR) || defined(THREADS)
if (PP != ap) {
if (PP) UNLOCKPE(16,PP);
PP = ap;
PELOCK(16,PP);
}
#endif
if (!VALID_TIMESTAMP(timestamp, lcl)) {
/* jump to next alternative */
PREG = FAILCODE;
} else {
PREG = lcl->ClCode;
}
/* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */
#if MULTIPLE_STACKS
DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */
B->cp_tr--;
TR = B->cp_tr;
/* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
if (PREG != FAILCODE) {
if (lcl->ClRefCount == 1) {
/* make sure the clause isn't destroyed */
/* always add an extra reference */
INC_CLREF_COUNT(lcl);
TRAIL_CLREF(lcl);
B->cp_tr = TR;
}
}
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
}
#else
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) {
cl->ClFlags &= ~InUseMask;
B->cp_tr--;
#if FROZEN_STACKS
if (B->cp_tr > TR_FZ)
#endif
{
TR = B->cp_tr;
}
/* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) {
if (PREG != FAILCODE) {
/* make sure we don't erase the clause we are jumping too */
if (!(lcl->ClFlags & InUseMask)) {
lcl->ClFlags |= InUseMask;
TRAIL_CLREF(lcl);
B->cp_tr = TR;
}
}
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
}
}
#endif
#ifdef YAPOR
if (SCH_top_shared_cp(B)) {
SCH_last_alternative(PREG, B_YREG);
restore_args(ap->ArityOfPE);
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#else
S_YREG++;
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B->cp_b);
} else
#endif /* YAPOR */
{
pop_yaam_regs();
pop_args(ap->ArityOfPE);
S_YREG--;
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B);
}
SET_BB(B_YREG);
ENDCACHE_Y();
#if defined(YAPOR) || defined(THREADS)
if (PREG == FAILCODE) {
UNLOCKPE(26,PP);
PP = NULL;
}
#endif
JMPNext();
}
ENDBOp();
/*****************************************************************
* enter a logical semantics dynamic predicate *
*****************************************************************/
/* only meaningful with THREADS on! */
/* lock logical updates predicate. */
Op(lock_lu, p);
#if PARALLEL_YAP
if (PP) {
GONext();
}
PP = PREG->y_u.p.p;
PELOCK(3, PP);
#endif
PREG = NEXTOP(PREG, p);
GONext();
ENDOp();
/* only meaningful with THREADS on! */
/* lock logical updates predicate. */
Op(unlock_lu, e);
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCKPE(1,PP);
PP = NULL;
}
#endif
PREG = NEXTOP(PREG, e);
GONext();
ENDOp();
/* enter logical pred */
BOp(alloc_for_logical_pred, L);
check_trail(TR);
/* say that an environment is using this clause */
/* we have our own copy for the clause */
#if MULTIPLE_STACKS
{
LogUpdClause *cl = PREG->y_u.L.ClBase;
#if PARALLEL_YAP
PredEntry *ap = cl->ClPred;
#endif
/* always add an extra reference */
INC_CLREF_COUNT(cl);
TRAIL_CLREF(cl);
UNLOCKPE(2,ap);
PP = NULL;
}
#else
{
LogUpdClause *cl = (LogUpdClause *)PREG->y_u.L.ClBase;
if (!(cl->ClFlags & InUseMask)) {
cl->ClFlags |= InUseMask;
TRAIL_CLREF(cl);
}
}
#endif
PREG = NEXTOP(PREG, L);
JMPNext();
ENDBOp();
/* copy database term */
BOp(copy_idb_term, e);
{
LogUpdClause *cl = ClauseCodeToLogUpdClause(PREG);
Term t;
SET_ASP(YREG, E_CB*sizeof(CELL));
saveregs();
while ((t = Yap_FetchTermFromDB(cl->lusl.ClSource)) == 0L) {
if (PP) UNLOCKPE(3,PP);
#if defined(YAPOR) || defined(THREADS)
PP = NULL;
#endif
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_NilError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, LOCAL_ErrorMessage);
FAIL();
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gc(3, ENV, CP)) {
Yap_NilError(RESOURCE_ERROR_STACK, LOCAL_ErrorMessage);
FAIL();
}
}
#if defined(YAPOR) || defined(THREADS)
PELOCK(5,ClauseCodeToLogUpdClause(PREG)->ClPred);
PP = ClauseCodeToLogUpdClause(PREG)->ClPred;
#endif
}
if (!Yap_IUnify(ARG2, t)) {
setregs();
#if defined(YAPOR) || defined(THREADS)
if (PP) UNLOCKPE(6,PP);
PP = NULL;
#endif
FAIL();
}
if (!Yap_IUnify(ARG3, MkDBRefTerm((DBRef)cl))) {
setregs();
#if defined(YAPOR) || defined(THREADS)
if (PP) UNLOCKPE(5,PP);
PP = NULL;
#endif
FAIL();
}
setregs();
#if MULTIPLE_STACKS
/* always add an extra reference */
INC_CLREF_COUNT(cl);
TRAIL_CLREF(cl);
if (PP) UNLOCKPE(7,PP);
PP = NULL;
#else
if (!(cl->ClFlags & InUseMask)) {
/* Clause *cl = (Clause *)PREG->y_u.EC.ClBase;
PREG->y_u.EC.ClTrail = TR-(tr_fr_ptr)LOCAL_TrailBase;
PREG->y_u.EC.ClENV = LCL0-YREG;*/
cl->ClFlags |= InUseMask;
TRAIL_CLREF(cl);
}
#endif
}
PREG = CPREG;
YREG = ENV;
#ifdef DEPTH_LIMIT
DEPTH = YREG[E_DEPTH];
#endif
JMPNext();
ENDBOp();
/* unify with database term */
BOp(unify_idb_term, e);
{
LogUpdClause *cl = ClauseCodeToLogUpdClause(PREG);
saveregs();
if (!Yap_IUnify(ARG2, cl->lusl.ClSource->Entry)) {
setregs();
UNLOCKPE(8,PP);
#if defined(YAPOR) || defined(THREADS)
PP = NULL;
#endif
FAIL();
}
if (!Yap_IUnify(ARG3, MkDBRefTerm((DBRef)cl))) {
setregs();
UNLOCKPE(9,PP);
#if defined(YAPOR) || defined(THREADS)
PP = NULL;
#endif
FAIL();
}
setregs();
/* say that an environment is using this clause */
/* we have our own copy for the clause */
#if MULTIPLE_STACKS
/* always add an extra reference */
INC_CLREF_COUNT(cl);
TRAIL_CLREF(cl);
UNLOCKPE(10,PP);
PP = NULL;
#else
if (!(cl->ClFlags & InUseMask)) {
/* Clause *cl = (Clause *)PREG->y_u.EC.ClBase;
PREG->y_u.EC.ClTrail = TR-(tr_fr_ptr)LOCAL_TrailBase;
PREG->y_u.EC.ClENV = LCL0-YREG;*/
cl->ClFlags |= InUseMask;
TRAIL_CLREF(cl);
}
#endif
}
PREG = CPREG;
YREG = ENV;
#ifdef DEPTH_LIMIT
DEPTH = YREG[E_DEPTH];
#endif
JMPNext();
ENDBOp();

361
dev/yap-6.3/C/mavar.c Normal file
View File

@ -0,0 +1,361 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: mavar.c *
* Last rev: *
* mods: *
* comments: support from multiple assignment variables in YAP *
* *
*************************************************************************/
/**
@file mavar.c
@defgroup Term_Modification Term Modification
@ingroup builtins
It is sometimes useful to change the value of instantiated
variables. Although, this is against the spirit of logic programming, it
is sometimes useful. As in other Prolog systems, YAP has
several primitives that allow updating Prolog terms. Note that these
primitives are also backtrackable.
The setarg/3 primitive allows updating any argument of a Prolog
compound terms. The _mutable_ family of predicates provides
<em>mutable variables</em>. They should be used instead of setarg/3,
as they allow the encapsulation of accesses to updatable
variables. Their implementation can also be more efficient for long
deterministic computations.
@{
*/
#include "Yap.h"
#ifdef MULTI_ASSIGNMENT_VARIABLES
#include "Yatom.h"
#include "YapHeap.h"
#include "eval.h"
static Int p_setarg( USES_REGS1 );
static Int p_create_mutable( USES_REGS1 );
static Int p_get_mutable( USES_REGS1 );
static Int p_update_mutable( USES_REGS1 );
static Int p_is_mutable( USES_REGS1 );
/** @pred setarg(+ _I_,+ _S_,? _T_)
Set the value of the _I_th argument of term _S_ to term _T_.
*/
static Int
p_setarg( USES_REGS1 )
{
CELL ti = Deref(ARG1), ts = Deref(ARG2), t3 = Deref(ARG3);
Int i;
if (IsVarTerm(t3) &&
VarOfTerm(t3) > HR &&VarOfTerm(t3) < ASP) {
/* local variable */
Term tn = MkVarTerm();
Bind_Local(VarOfTerm(t3), tn);
t3 = tn;
}
if (IsVarTerm(ti)) {
Yap_Error(INSTANTIATION_ERROR,ti,"setarg/3");
return FALSE;
} else {
if (IsIntTerm(ti))
i = IntOfTerm(ti);
else {
Term te = Yap_Eval(ti);
if (IsIntegerTerm(te)) {
i = IntegerOfTerm(te);
} else {
Yap_Error(TYPE_ERROR_INTEGER,ti,"setarg/3");
return FALSE;
}
}
}
if (IsVarTerm(ts)) {
Yap_Error(INSTANTIATION_ERROR,ts,"setarg/3");
} else if(IsApplTerm(ts)) {
CELL *pt;
if (IsExtensionFunctor(FunctorOfTerm(ts))) {
Yap_Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
return FALSE;
}
if (i < 1 || i > (Int)ArityOfFunctor(FunctorOfTerm(ts))) {
if (i<0)
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return FALSE;
if (i==0)
Yap_Error(DOMAIN_ERROR_NOT_ZERO,ts,"setarg/3");
return FALSE;
}
pt = RepAppl(ts)+i;
/* the evil deed is to be done now */
MaBind(pt, t3);
} else if(IsPairTerm(ts)) {
CELL *pt;
if (i < 1 || i > 2) {
if (i<0)
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return FALSE;
}
pt = RepPair(ts)+i-1;
/* the evil deed is to be done now */
MaBind(pt, t3);
} else {
Yap_Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
return FALSE;
}
return TRUE;
}
/* One problem with MAVars is that they you always trail on
non-determinate bindings. This is not cool if you have a long
determinate computation. One alternative could be to use
timestamps.
Because of !, the only timestamp one can trust is the trailpointer
(ouch..). The trail is not reclaimed after cuts. Also, if there was
a conditional binding, the trail is sure to have been increased
since the last choicepoint. For maximum effect, we can actually
store the current value of TR in the timestamp field, giving a way
to actually follow a link of all trailings for these variables.
*/
/* create and initialize a new timed var. The problem is: how to set
the clock?
If I give it the current value of B->TR, we may have trouble if no
non-determinate bindings are made before the next
choice-point. Just to make sure this doesn't cause trouble, if (TR
== B->TR) we will add a little something ;-).
*/
static Term
NewTimedVar(CELL val USES_REGS)
{
Term out;
timed_var *tv;
if (IsVarTerm(val) &&
VarOfTerm(val) > HR) {
Term nval = MkVarTerm();
Bind_Local(VarOfTerm(val), nval);
val = nval;
}
out = AbsAppl(HR);
*HR++ = (CELL)FunctorMutable;
tv = (timed_var *)HR;
RESET_VARIABLE(&(tv->clock));
tv->value = val;
HR += sizeof(timed_var)/sizeof(CELL);
return(out);
}
Term
Yap_NewTimedVar(CELL val)
{
CACHE_REGS
return NewTimedVar(val PASS_REGS);
}
Term
Yap_NewEmptyTimedVar( void )
{
CACHE_REGS
Term out = AbsAppl(HR);
timed_var *tv;
*HR++ = (CELL)FunctorMutable;
tv = (timed_var *)HR;
RESET_VARIABLE(&(tv->clock));
RESET_VARIABLE(&(tv->value));
HR += sizeof(timed_var)/sizeof(CELL);
return(out);
}
static Term
ReadTimedVar(Term inv)
{
timed_var *tv = (timed_var *)(RepAppl(inv)+1);
return(tv->value);
}
Term
Yap_ReadTimedVar(Term inv)
{
return ReadTimedVar(inv);
}
/* update a timed var with a new value */
static Term
UpdateTimedVar(Term inv, Term new USES_REGS)
{
timed_var *tv = (timed_var *)(RepAppl(inv)+1);
CELL t = tv->value;
CELL* timestmp = (CELL *)(tv->clock);
if (IsVarTerm(new) &&
VarOfTerm(new) > HR) {
Term nnew = MkVarTerm();
Bind_Local(VarOfTerm(new), nnew);
new = nnew;
}
if (timestmp > B->cp_h
#if FROZEN_STACKS
&& timestmp > H_FZ
#endif
) {
/* last assignment more recent than last B */
#if YAPOR_SBA
if (Unsigned((Int)(tv)-(Int)(H_FZ)) >
Unsigned((Int)(B_FZ)-(Int)(H_FZ)))
*STACK_TO_SBA(&(tv->value)) = new;
else
#endif
tv->value = new;
} else {
Term nclock = (Term)HR;
MaBind(&(tv->value), new);
*HR++ = TermFoundVar;
MaBind(&(tv->clock), nclock);
}
return(t);
}
/* update a timed var with a new value */
Term
Yap_UpdateTimedVar(Term inv, Term new)
{
CACHE_REGS
return UpdateTimedVar(inv, new PASS_REGS);
}
/** @pred create_mutable(+ _D_,- _M_)
Create new mutable variable _M_ with initial value _D_.
*/
static Int
p_create_mutable( USES_REGS1 )
{
Term t = NewTimedVar(Deref(ARG1) PASS_REGS);
return(Yap_unify(ARG2,t));
}
/** @pred get_mutable(? _D_,+ _M_)
Unify the current value of mutable term _M_ with term _D_.
*/
static Int
p_get_mutable( USES_REGS1 )
{
Term t = Deref(ARG2);
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "get_mutable/3");
return(FALSE);
}
if (!IsApplTerm(t)) {
Yap_Error(TYPE_ERROR_COMPOUND,t,"get_mutable/3");
return(FALSE);
}
if (FunctorOfTerm(t) != FunctorMutable) {
Yap_Error(DOMAIN_ERROR_MUTABLE,t,"get_mutable/3");
return(FALSE);
}
t = ReadTimedVar(t);
return(Yap_unify(ARG1, t));
}
/** @pred update_mutable(+ _D_,+ _M_)
Set the current value of mutable term _M_ to term _D_.
*/
static Int
p_update_mutable( USES_REGS1 )
{
Term t = Deref(ARG2);
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "update_mutable/3");
return(FALSE);
}
if (!IsApplTerm(t)) {
Yap_Error(TYPE_ERROR_COMPOUND,t,"update_mutable/3");
return(FALSE);
}
if (FunctorOfTerm(t) != FunctorMutable) {
Yap_Error(DOMAIN_ERROR_MUTABLE,t,"update_mutable/3");
return(FALSE);
}
UpdateTimedVar(t, Deref(ARG1) PASS_REGS);
return(TRUE);
}
/** @pred is_mutable(? _D_)
Holds if _D_ is a mutable term.
*/
static Int
p_is_mutable( USES_REGS1 )
{
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
return(FALSE);
}
if (!IsApplTerm(t)) {
return(FALSE);
}
if (FunctorOfTerm(t) != FunctorMutable) {
return(FALSE);
}
return(TRUE);
}
#endif
void
Yap_InitMaVarCPreds(void)
{
#ifdef MULTI_ASSIGNMENT_VARIABLES
Yap_InitCPred("setarg", 3, p_setarg, SafePredFlag);
Yap_InitCPred("create_mutable", 2, p_create_mutable, SafePredFlag);
Yap_InitCPred("get_mutable", 2, p_get_mutable, SafePredFlag);
Yap_InitCPred("update_mutable", 2, p_update_mutable, SafePredFlag);
Yap_InitCPred("is_mutable", 1, p_is_mutable, SafePredFlag);
#endif
}
/**
@}
*/

300
dev/yap-6.3/C/meta_absmi_insts.h Normal file
View File

@ -0,0 +1,300 @@
#ifdef INDENT_CODE
{
{
{
#endif /* INDENT_CODE */
/* join all the meta-call code into a single procedure with three entry points */
{
CACHE_Y_AS_ENV(YREG);
BEGD(d0); /* term to be meta-called */
Term mod; /* module to be used */
PredEntry *pen; /* predicate */
choiceptr b_ptr; /* cut point */
Functor f;
/* we are doing the rhs of a , */
BOp(p_execute_tail, Osbmp);
FETCH_Y_FROM_ENV(YREG);
/* place to cut to */
b_ptr = (choiceptr)ENV_YREG[E_CB];
/* original goal */
d0 = ENV_YREG[-EnvSizeInCells-1];
/* predicate we had used */
pen = RepPredProp((Prop)IntegerOfTerm(ENV_YREG[-EnvSizeInCells-2]));
/* current module at the time */
mod = ENV_YREG[-EnvSizeInCells-3];
/* set YREG */
/* Try to preserve the environment */
ENV_YREG = (CELL *) (((char *) YREG) + PREG->y_u.Osbmp.s);
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (ENV_YREG > (CELL *) top_b || ENV_YREG < HR) ENV_YREG = (CELL *) top_b;
#else
if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b;
#endif /* YAPOR_SBA */
}
#else
if (ENV_YREG > (CELL *) B) {
ENV_YREG = (CELL *) B;
}
#endif /* FROZEN_STACKS */
/* now, jump to actual execution */
if (pen->ArityOfPE) {
f = pen->FunctorOfPred;
/* reuse environment if we are continuining a comma, ie, (g1,g2,g3) */
/* can only do it deterministically */
/* broken
if (f == FunctorComma && (CELL *)B >= ENV) {
ENV_YREG = ENV;
ENV = (CELL *)ENV[E_E];
}
*/
goto execute_pred_f;
} else
goto execute_pred_a;
ENDBOp();
/* fetch the module from ARG2 */
BOp(p_execute2, Osbpp);
mod = ARG2;
deref_head(mod, execute2_unk0);
execute2_nvar0:
if (!IsAtomTerm(mod)) {
saveregs();
Yap_Error(TYPE_ERROR_ATOM, mod, "call/2");
setregs();
}
goto start_execute;
BEGP(pt1);
deref_body(mod, pt1, execute2_unk0, execute2_nvar0);
saveregs();
Yap_Error(INSTANTIATION_ERROR, mod, "call/2");
setregs();
ENDP(pt1);
/* Oops, second argument was unbound too */
FAIL();
ENDBOp();
BOp(p_execute, Osbmp);
/* fetch the module from PREG */
mod = PREG->y_u.Osbmp.mod;
start_execute:
/* place to cut to */
b_ptr = B;
/* we have mod, and ARG1 has the goal, let us roll */
/* Try to preserve the environment */
ENV_YREG = (CELL *) (((char *) YREG) + PREG->y_u.Osbmp.s);
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (ENV_YREG > (CELL *) top_b || ENV_YREG < HR) ENV_YREG = (CELL *) top_b;
#else
if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b;
#endif /* YAPOR_SBA */
}
#else
if (ENV_YREG > (CELL *) B) {
ENV_YREG = (CELL *) B;
}
#endif /* FROZEN_STACKS */
d0 = ARG1;
restart_execute:
deref_head(d0, execute_unk);
execute_nvar:
if (IsApplTerm(d0)) {
f = FunctorOfTerm(d0);
if (IsExtensionFunctor(f)) {
goto execute_metacall;
}
pen = RepPredProp(PredPropByFunc(f, mod));
execute_pred_f:
if (pen->PredFlags & MetaPredFlag) {
/* just strip all of M:G */
if (f == FunctorModule) {
Term tmod = ArgOfTerm(1,d0);
/* loop on modules */
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
d0 = ArgOfTerm(2,d0);
mod = tmod;
goto execute_nvar;
}
goto execute_metacall;
}
if (f == FunctorComma) {
Term nmod = mod;
/* optimise conj */
SREG = RepAppl(d0);
BEGD(d1);
d1 = SREG[2];
/* create an environment to execute the call */
deref_head(d1, execute_comma_unk);
execute_comma_nvar:
if (IsAtomTerm(d1)) {
/* atomic goal is simpler */
ENV_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByAtom(AtomOfTerm(d1),nmod));
} else if (IsApplTerm(d1)) {
Functor f1 = FunctorOfTerm(d1);
if (IsExtensionFunctor(f1)) {
goto execute_metacall;
} else {
/* check for modules when looking up */
if (f1 == FunctorModule) {
Term tmod = ArgOfTerm(1,d1);
/* loop on modules */
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
d1 = ArgOfTerm(2,d1);
nmod = tmod;
goto execute_comma_nvar;
}
goto execute_metacall;
}
ENV_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByFunc(f1,nmod));
}
} else {
goto execute_metacall;
}
ENV_YREG[-EnvSizeInCells-3] = mod;
/* now, we can create the new environment for the meta-call */
/* notice that we are at a call, so we should ignore CP */
ENV_YREG[E_CP] = (CELL)NEXTOP(PREG,Osbmp);
ENV_YREG[E_CB] = (CELL)b_ptr;
ENV_YREG[E_E] = (CELL)ENV;
#ifdef DEPTH_LIMIT
ENV_YREG[E_DEPTH] = DEPTH;
#endif /* DEPTH_LIMIT */
ENV_YREG[-EnvSizeInCells-1] = d1;
ENV = ENV_YREG;
ENV_YREG -= EnvSizeInCells+3;
CPREG = NEXTOP(PREG, Osbmp);
PREG = COMMA_CODE;
/* for profiler */
save_pc();
d0 = SREG[1];
goto restart_execute;
BEGP(pt1);
deref_body(d1, pt1, execute_comma_unk, execute_comma_nvar);
goto execute_metacall;
ENDP(pt1);
ENDD(d1);
} else if (mod != CurrentModule) {
goto execute_metacall;
}
}
/* copy arguments of meta-call to XREGS */
BEGP(pt1);
pt1 = RepAppl(d0);
BEGD(d2);
for (d2 = ArityOfFunctor(f); d2; d2--) {
#ifdef YAPOR_SBA
BEGD(d1);
d1 = pt1[d2];
if (d1 == 0) {
XREGS[d2] = (CELL)(pt1+d2);
} else {
XREGS[d2] = d1;
}
#else
XREGS[d2] = pt1[d2];
#endif
}
ENDD(d2);
ENDP(pt1);
CACHE_A1();
} else if (IsAtomTerm(d0)) {
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod));
execute_pred_a:
/* handle extra pruning */
if (pen->FunctorOfPred == (Functor)AtomCut) {
if (b_ptr != B) {
saveregs();
prune(b_ptr PASS_REGS);
setregs();
}
}
} else {
goto execute_metacall;
}
/* execute, but test first for interrupts */
execute_end:
/* code copied from call */
#ifndef NO_CHECKING
check_stack(NoStackPExecute, HR);
#endif
execute_stack_checked:
CPREG = NEXTOP(PREG, Osbmp);
ALWAYS_LOOKAHEAD(pen->OpcodeOfPred);
PREG = pen->CodeOfPred;
/* for profiler */
save_pc();
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is primitives */
if (pen->ModuleOfPred) {
if (DEPTH == MkIntTerm(0)) {
FAIL();
} else {
DEPTH = RESET_DEPTH();
}
}
} else if (pen->ModuleOfPred)
DEPTH -= MkIntConstant(2);
#endif /* DEPTH_LIMIT */
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace)
low_level_trace(enter_pred,pen,XREGS+1);
#endif /* LOW_LEVEL_TRACER */
WRITEBACK_Y_AS_ENV();
/* setup GB */
ENV_YREG[E_CB] = (CELL) B;
#ifdef YAPOR
SCH_check_requests();
#endif /* YAPOR */
CACHE_A1();
ALWAYS_GONext();
ALWAYS_END_PREFETCH();
/* meta-call: Prolog to the rescue */
BEGP(pt1);
deref_body(d0, pt1, execute_unk, execute_nvar);
execute_metacall:
ARG1 = ARG3 = d0;
pen = PredMetaCall;
ARG2 = Yap_cp_as_integer(b_ptr);
if (mod)
ARG4 = mod;
else
ARG4 = TermProlog;
goto execute_end;
ENDP(pt1);
/* at this point, we have the arguments all set in the argument registers, pen says who is the current predicate. don't remove. */
NoStackPExecute:
WRITEBACK_Y_AS_ENV();
#ifdef SHADOW_S
Yap_REGS.S_ = SREG;
#endif
saveregs_and_ycache();
d0 = interrupt_pexecute( pen PASS_REGS );
setregs_and_ycache();
#ifdef SHADOW_S
SREG = Yap_REGS.S_;
#endif
if (!d0) FAIL();
if (d0 == 2) goto execute_stack_checked;
goto execute_end;
ENDBOp();
ENDD(d0);
ENDCACHE_Y_AS_ENV();
}

552
dev/yap-6.3/C/modules.c Normal file
View File

@ -0,0 +1,552 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
File: modules.c *
* Last rev: *
* mods: *
* comments: module support *
* *
*************************************************************************/
#ifdef SCCSLookupSystemModule
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
static Int current_module(USES_REGS1);
static Int current_module1(USES_REGS1);
static ModEntry *LookupModule(Term a);
static ModEntry *LookupSystemModule(Term a);
static ModEntry *GetModuleEntry(Atom at);
static ModEntry *FetchModuleEntry(Atom at);
/**
* initialize module data-structure
*
* @param to parent module (CurrentModule)
* @param ae module name.
*
* @return a new module structure
*//** */
static ModEntry *
initMod( AtomEntry *toname, AtomEntry *ae) {
CACHE_REGS
ModEntry *n, *parent;
if (toname == NULL)
parent = NULL;
else {
parent = FetchModuleEntry( toname );
}
n = (ModEntry *)Yap_AllocAtomSpace(sizeof(*n));
INIT_RWLOCK(n->ModRWLock);
n->KindOfPE = ModProperty;
n->PredForME = NULL;
n->NextME = CurrentModules;
CurrentModules = n;
n->AtomOfME = ae;
n->OwnerFile = Yap_ConsultingFile( PASS_REGS1);
AddPropToAtom(ae, (PropEntry *)n);
Yap_setModuleFlags(n, parent);
return n;
}
/**
* get predicate entry for ap/arity; create it if neccessary
*
* @param[in] at
*
* @return module descriptorxs
*/
static ModEntry *GetModuleEntry(Atom at)
{
Prop p0;
AtomEntry *ae = RepAtom(at);
READ_LOCK(ae->ARWLock);
p0 = ae->PropsOfAE;
while (p0) {
ModEntry *me = RepModProp(p0);
if (me->KindOfPE == ModProperty) {
READ_UNLOCK(ae->ARWLock);
return me;
}
p0 = me->NextOfPE;
}
READ_UNLOCK(ae->ARWLock);
return initMod( ( CurrentModule == PROLOG_MODULE ? NULL : AtomOfTerm( CurrentModule ) ), at );
}
/** get entry for ap/arity; assumes one is there. */
static ModEntry *FetchModuleEntry(Atom at)
{
Prop p0;
AtomEntry *ae = RepAtom(at);
READ_LOCK(ae->ARWLock);
p0 = ae->PropsOfAE;
while (p0) {
ModEntry *me = RepModProp(p0);
if (me->KindOfPE == ModProperty) {
READ_UNLOCK(ae->ARWLock);
return me;
}
p0 = me->NextOfPE;
}
READ_UNLOCK(ae->ARWLock);
return NULL;
}
Term Yap_getUnknownModule(ModEntry *m) {
if (m && m->flags & UNKNOWN_ERROR) {
return TermError;
} else if (m && m->flags & UNKNOWN_WARNING) {
return TermWarning;
} else if (m && m->flags & UNKNOWN_FAST_FAIL) {
return TermFastFail;
} else {
return TermFail;
}
}
bool Yap_getUnknown ( Term mod) {
ModEntry *m = LookupModule( mod );
return Yap_getUnknownModule( m );
}
bool Yap_CharacterEscapes(Term mt) {
if (mt == PROLOG_MODULE) mt = TermProlog;
return GetModuleEntry(AtomOfTerm(mt))->flags & M_CHARESCAPE;
}
#define ByteAdr(X) ((char *)&(X))
Term Yap_Module_Name(PredEntry *ap) {
CACHE_REGS
Term mod;
if (!ap)
return TermUser;
if (!ap->ModuleOfPred)
/* If the system predicate is a meta-call I should return the
module for the metacall, which I will suppose has to be
reachable from the current module anyway.
So I will return the current module in case the system
predicate is a meta-call. Otherwise it will still work.
*/
return TermProlog;
else {
return ap->ModuleOfPred;
}
}
static ModEntry *LookupSystemModule(Term a) {
CACHE_REGS
Atom at;
ModEntry *me;
/* prolog module */
if (a == 0) {
a = TermProlog;
}
at = AtomOfTerm(a);
me = GetModuleEntry(at);
if (!me)
return NULL;
me->flags |= M_SYSTEM;
me->OwnerFile = Yap_ConsultingFile( PASS_REGS1 );
return me;
}
static ModEntry *LookupModule(Term a) {
Atom at;
ModEntry *me;
/* prolog module */
if (a == 0) {
return GetModuleEntry(AtomProlog);
}
at = AtomOfTerm(a);
me = GetModuleEntry(at);
return me;
}
bool Yap_isSystemModule(Term a) {
ModEntry *me = LookupModule(a);
return
me != NULL &&
me->flags & M_SYSTEM;
}
Term Yap_Module(Term tmod) {
LookupModule(tmod);
return tmod;
}
ModEntry *Yap_GetModuleEntry(Term mod) {
ModEntry *me;
if (!(me = LookupModule(mod)))
return NULL;
return me;
}
Term Yap_GetModuleFromEntry(ModEntry *me) {
return MkAtomTerm(me->AtomOfME);
;
}
struct pred_entry *Yap_ModulePred(Term mod) {
ModEntry *me;
if (!(me = LookupModule(mod)))
return NULL;
return me->PredForME;
}
void Yap_NewModulePred(Term mod, struct pred_entry *ap) {
ModEntry *me;
if (!(me = LookupModule(mod)))
return;
WRITE_LOCK(me->ModRWLock);
ap->NextPredOfModule = me->PredForME;
me->PredForME = ap;
WRITE_UNLOCK(me->ModRWLock);
}
static Int
current_module(USES_REGS1) { /* $current_module(Old,N) */
Term t;
if (CurrentModule) {
if (!Yap_unify_constant(ARG1, CurrentModule))
return FALSE;
} else {
if (!Yap_unify_constant(ARG1, TermProlog))
return FALSE;
}
t = Deref(ARG2);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (t == TermProlog) {
CurrentModule = PROLOG_MODULE;
} else {
// make it very clear that t inherits from cm.
LookupModule(t);
CurrentModule = t;
}
LOCAL_SourceModule = CurrentModule;
return TRUE;
}
static Int change_module(USES_REGS1) { /* $change_module(N) */
Term mod = Deref(ARG1);
LookupModule(mod);
CurrentModule = mod;
LOCAL_SourceModule = mod;
return TRUE;
}
static Int current_module1(USES_REGS1) { /* $current_module(Old)
*/
if (CurrentModule)
return Yap_unify_constant(ARG1, CurrentModule);
return Yap_unify_constant(ARG1, TermProlog);
}
static Int cont_current_module(USES_REGS1) {
ModEntry *imod = AddressOfTerm(EXTRA_CBACK_ARG(1, 1)), *next;
Term t = MkAtomTerm(imod->AtomOfME);
next = imod->NextME;
/* ARG1 is unbound */
Yap_unify(ARG1, t);
if (!next)
cut_succeed();
EXTRA_CBACK_ARG(1, 1) = MkAddressTerm(next);
return TRUE;
}
static Int init_current_module(
USES_REGS1) { /* current_module(?ModuleName) */
Term t = Deref(ARG1);
if (!IsVarTerm(t)) {
if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM, t, "module name must be an atom");
return FALSE;
}
if (FetchModuleEntry(AtomOfTerm(t)) != NULL)
cut_succeed();
cut_fail();
}
EXTRA_CBACK_ARG(1, 1) = MkIntegerTerm((Int)CurrentModules);
return cont_current_module(PASS_REGS1);
}
static Int cont_ground_module(USES_REGS1) {
ModEntry *imod = AddressOfTerm(EXTRA_CBACK_ARG(3, 1)), *next;
Term t2 = MkAtomTerm(imod->AtomOfME);
next = imod->NextME;
/* ARG2 is unbound */
if (!next)
cut_succeed();
EXTRA_CBACK_ARG(3, 1) = MkAddressTerm(next);
return Yap_unify(ARG2, t2);
}
static Int init_ground_module(USES_REGS1) {
/* current_module(?ModuleName) */
Term t1 = Deref(ARG1), tmod = CurrentModule, t3;
if (tmod == PROLOG_MODULE) {
tmod = TermProlog;
}
t3 = Yap_YapStripModule(t1, &tmod);
if (!t3) {
Yap_Error(TYPE_ERROR_CALLABLE, t3, "trying to obtain module");
return FALSE;
}
if (!IsVarTerm(tmod)) {
if (!IsAtomTerm(tmod)) {
Yap_Error(TYPE_ERROR_ATOM, tmod, "module name must be an atom");
cut_fail();
}
if (FetchModuleEntry(AtomOfTerm(tmod)) != NULL && Yap_unify(tmod, ARG2) &&
Yap_unify(t3, ARG3)) {
cut_succeed();
}
cut_fail();
}
if (!Yap_unify(ARG2, tmod) ||
!Yap_unify(ARG3, t3) ) {
cut_fail();
}
// make sure we keep the binding
B->cp_tr = TR;
B->cp_h = HR;
EXTRA_CBACK_ARG(3, 1) = MkAddressTerm(CurrentModules);
return cont_ground_module(PASS_REGS1);
}
/**
* @pred system_module( + _Mod_)
*
* @param module
*
* @return
*/
static Int is_system_module( USES_REGS1 )
{
Term t;
if (IsVarTerm(t = Deref (ARG1))) {
return false;
}
if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM, t, "load_files/2");
return false;
}
return Yap_isSystemModule( t );
}
static Int new_system_module( USES_REGS1 )
{
ModEntry *me;
Term t;
if (IsVarTerm(t = Deref (ARG1))) {
Yap_Error( INSTANTIATION_ERROR, t, NULL);
return false;
}
if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM, t, NULL);
return false;
}
if ((me = LookupSystemModule( t ) ))
me->OwnerFile = Yap_ConsultingFile( PASS_REGS1);
return me != NULL;
}
static Int strip_module(USES_REGS1) {
Term t1 = Deref(ARG1), tmod = CurrentModule;
if (tmod == PROLOG_MODULE) {
tmod = TermProlog;
}
t1 = Yap_StripModule(t1, &tmod);
if (!t1) {
Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE;
}
return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod);
}
Term Yap_YapStripModule(Term t, Term *modp) {
CACHE_REGS
Term tmod;
if (modp)
tmod = *modp;
else {
tmod = CurrentModule;
if (tmod == PROLOG_MODULE) {
tmod = TermProlog;
}
}
restart:
if (IsVarTerm(t) || !IsApplTerm(t)) {
if (modp)
*modp = tmod;
return t;
} else {
Functor fun = FunctorOfTerm(t);
if (fun == FunctorModule) {
Term t1 = ArgOfTerm(1, t);
tmod = t1;
if (!IsVarTerm(tmod) && !IsAtomTerm(tmod)) {
return 0L;
}
t = ArgOfTerm(2, t);
goto restart;
}
if (modp)
*modp = tmod;
return t;
}
return 0L;
}
static Int yap_strip_module(USES_REGS1) {
Term t1 = Deref(ARG1), tmod = CurrentModule;
if (tmod == PROLOG_MODULE) {
tmod = TermProlog;
}
t1 = Yap_YapStripModule(t1, &tmod);
if (!t1) {
Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE;
}
return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod);
}
static Int context_module(USES_REGS1) {
yamop *parentcp = P;
CELL *yenv;
PredEntry *ap = EnvPreg(parentcp);
if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = CP;
yenv = ENV;
do {
ap = EnvPreg(parentcp);
if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = (yamop *)yenv[E_CP];
yenv = (CELL *)yenv[E_E];
} while (yenv);
return Yap_unify(ARG1, CurrentModule);
}
/**
* @pred source_module(-Mod)
*
* @param Mod is the current text source module.
*
* : _Mod_ is the current read-in or source module.
*/
static Int source_module(USES_REGS1) {
if (LOCAL_SourceModule == PROLOG_MODULE) {
return Yap_unify(ARG1, TermProlog);
}
return Yap_unify(ARG1, LOCAL_SourceModule);
}
Term Yap_StripModule(Term t, Term *modp) {
CACHE_REGS
Term tmod;
if (modp)
tmod = *modp;
else {
tmod = CurrentModule;
if (tmod == PROLOG_MODULE) {
tmod = TermProlog;
}
}
restart:
if (IsVarTerm(t) || !IsApplTerm(t)) {
if (modp)
*modp = tmod;
return t;
} else {
Functor fun = FunctorOfTerm(t);
if (fun == FunctorModule) {
Term t1 = ArgOfTerm(1, t);
if (IsVarTerm(t1)) {
*modp = tmod;
return t;
}
tmod = t1;
if (!IsVarTerm(tmod) && !IsAtomTerm(tmod)) {
return 0L;
}
t = ArgOfTerm(2, t);
goto restart;
}
if (modp)
*modp = tmod;
return t;
}
return 0L;
}
void Yap_InitModulesC(void) {
Yap_InitCPred("$current_module", 2, current_module,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$current_module", 1, current_module1,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$change_module", 1, change_module,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("strip_module", 3, strip_module, SafePredFlag | SyncPredFlag);
Yap_InitCPred("source_module", 1, source_module, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$yap_strip_module", 3, yap_strip_module,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("context_module", 1, context_module, 0);
Yap_InitCPred("$is_system_module", 1, is_system_module, SafePredFlag);
Yap_InitCPred("new_system_module", 1, new_system_module, SafePredFlag);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module,
cont_current_module, SafePredFlag | SyncPredFlag);
Yap_InitCPredBack("$ground_module", 3, 1, init_ground_module,
cont_ground_module, SafePredFlag | SyncPredFlag);
}
void Yap_InitModules(void) {
CACHE_REGS
LookupSystemModule(MkAtomTerm(AtomProlog));
LOCAL_SourceModule = MkAtomTerm(AtomProlog);
LookupModule(USER_MODULE);
LookupModule(IDB_MODULE);
LookupModule(ATTRIBUTES_MODULE);
LookupSystemModule(CHARSIO_MODULE);
LookupSystemModule(TERMS_MODULE);
LookupSystemModule(SYSTEM_MODULE);
LookupSystemModule(READUTIL_MODULE);
LookupSystemModule(HACKS_MODULE);
LookupModule(ARG_MODULE);
LookupSystemModule(GLOBALS_MODULE);
LookupSystemModule(DBLOAD_MODULE);
LookupSystemModule(RANGE_MODULE);
CurrentModule = PROLOG_MODULE;
}

192
dev/yap-6.3/C/or_absmi_insts.h Normal file
View File

@ -0,0 +1,192 @@
/************************************************************************ \
* Instructions for implemeting 'or;' *
\************************************************************************/
#ifdef INDENT_CODE
{
{
{
#endif /* INDENT_CODE */
BOp(jump, l);
PREG = PREG->y_u.l.l;
JMPNext();
ENDBOp();
/* This instruction is called when the previous goal
was interrupted when waking up goals
*/
BOp(move_back, l);
PREG = (yamop *)(((char *)PREG)-(Int)(NEXTOP((yamop *)NULL,Osbpp)));
JMPNext();
ENDBOp();
/* This instruction is called when the previous goal
was interrupted when waking up goals
*/
BOp(skip, l);
PREG = NEXTOP(PREG,l);
JMPNext();
ENDBOp();
Op(either, Osblp);
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
low_level_trace(try_or, PREG->y_u.Osblp.p0, NULL);
}
#endif
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackEither, HR);
ENDCACHE_Y_AS_ENV();
either_notest:
#endif
BEGD(d0);
/* Try to preserve the environment */
d0 = PREG->y_u.Osblp.s;
BEGCHO(pt1);
pt1 = (choiceptr) ((char *) YREG + (yslot) d0);
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (pt1 > top_b || pt1 < (choiceptr)HR) pt1 = top_b;
#else
if (pt1 > top_b) pt1 = top_b;
#endif /* YAPOR_SBA */
}
#else
if (pt1 > B) {
pt1 = B;
}
#endif /* FROZEN_STACKS */
pt1 = (choiceptr)(((CELL *) pt1)-1);
*(CELL **) pt1 = YREG;
store_yaam_regs_for_either(PREG->y_u.Osblp.l, PREG);
SREG = (CELL *) (B = pt1);
#ifdef YAPOR
SCH_set_load(pt1);
#endif /* YAPOR */
SET_BB(pt1);
ENDCHO(pt1);
/* skip the current instruction plus the next one */
PREG = NEXTOP(NEXTOP(PREG, Osblp),l);
GONext();
ENDD(d0);
#ifdef COROUTINING
NoStackEither:
PROCESS_INT(interrupt_either, either_notest);
#endif
ENDOp();
Op(or_else, Osblp);
HR = HBREG = PROTECT_FROZEN_H(B);
ENV = B->cp_env;
B->cp_cp = PREG;
#ifdef DEPTH_LIMIT
DEPTH = B->cp_depth;
#endif /* DEPTH_LIMIT */
SET_BB(PROTECT_FROZEN_B(B));
#ifdef YAPOR
if (SCH_top_shared_cp(B)) {
SCH_new_alternative(PREG, PREG->y_u.Osblp.l);
} else
#endif /* YAPOR */
B->cp_ap = PREG->y_u.Osblp.l;
PREG = NEXTOP(PREG, Osblp);
YREG = (CELL *) B->cp_a1;
GONext();
ENDOp();
#ifdef YAPOR
Op(or_last, Osblp);
#else
Op(or_last, p);
#endif /* YAPOR */
BEGCHO(pt0);
pt0 = B;
#ifdef YAPOR
if (SCH_top_shared_cp(B)) {
HR = HBREG = PROTECT_FROZEN_H(pt0);
YREG = (CELL *) pt0->cp_a1;
ENV = pt0->cp_env;
#ifdef DEPTH_LIMIT
DEPTH = pt0->cp_depth;
#endif /* DEPTH_LIMIT */
SCH_new_alternative(PREG, NULL);
}
else
#endif /* YAPOR */
{
B = pt0->cp_b;
HR = PROTECT_FROZEN_H(pt0);
YREG = (CELL *) pt0->cp_a1;
ENV = pt0->cp_env;
#ifdef DEPTH_LIMIT
DEPTH = pt0->cp_depth;
#endif /* DEPTH_LIMIT */
HBREG = PROTECT_FROZEN_H(B);
}
#ifdef YAPOR
PREG = NEXTOP(PREG, Osblp);
#else
PREG = NEXTOP(PREG, p);
#endif /* YAPOR */
SET_BB(PROTECT_FROZEN_B(B));
GONext();
ENDCHO(pt0);
ENDOp();
/************************************************************************\
* Pop operations *
\************************************************************************/
OpRW(pop_n, s);
/* write mode might have been called from read mode */
BEGD(d0);
d0 = PREG->y_u.os.s;
SP = (CELL *) (((char *) SP) + d0);
ENDD(d0);
BEGD(d0);
d0 = SP[0];
if (d0) {
START_PREFETCH(s);
SREG = (CELL *) (SP[1]);
SP += 2;
PREG = NEXTOP(PREG, s);
GONext();
END_PREFETCH();
}
else {
START_PREFETCH_W(s);
SREG = (CELL *) (SP[1]);
SP += 2;
PREG = NEXTOP(PREG, s);
GONextW();
END_PREFETCH_W();
}
ENDD(d0);
ENDOpRW();
OpRW(pop, e);
BEGD(d0);
d0 = SP[0];
SREG = (CELL *) (SP[1]);
SP += 2;
if (d0) {
START_PREFETCH(e);
PREG = NEXTOP(PREG, e);
GONext();
END_PREFETCH();
}
else {
START_PREFETCH_W(e);
PREG = NEXTOP(PREG, e);
GONextW();
END_PREFETCH_W();
}
ENDD(d0);
ENDOpRW();

127
dev/yap-6.3/C/other.c Normal file
View File

@ -0,0 +1,127 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: other.c *
* Last rev: Dec/90 *
* mods: *
* comments: extra routines *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#if HAVE_STRING_H
#include <string.h>
#endif
/* exile Yap_standard_regs here, otherwise WIN32 linkers may complain */
REGSTORE Yap_standard_regs;
#if PUSH_REGS
#ifdef THREADS
/* PushRegs always on */
pthread_key_t Yap_yaamregs_key;
#else
REGSTORE *Yap_regp;
#endif
#else /* !PUSH_REGS */
REGSTORE Yap_REGS;
#endif
Term
Yap_MkNewPairTerm(void)
{
CACHE_REGS
register CELL *p = HR;
RESET_VARIABLE(HR);
RESET_VARIABLE(HR+1);
HR+=2;
return (AbsPair(p));
}
/** compound term constructor, builds a compound term with functor f and n
* args.
*
*
* Room for the new term is allocated from the heap: the functor and arguments are copied there.
*
*/
Term
Yap_MkApplTerm(Functor f, arity_t n, const Term *a)
{
CACHE_REGS
CELL *t = HR;
if (n == 0)
return (MkAtomTerm(NameOfFunctor(f)));
if (f == FunctorList)
return MkPairTerm(a[0], a[1]);
*HR++ = (CELL) f;
while (n--)
*HR++ = * a++;
return (AbsAppl(t));
}
Term
Yap_MkNewApplTerm(Functor f, arity_t n)
/* build compound term with functor f and n
* args a */
{
CACHE_REGS
CELL *t = HR;
if (n == 0)
return (MkAtomTerm(NameOfFunctor(f)));
if (f == FunctorList) {
RESET_VARIABLE(HR);
RESET_VARIABLE(HR+1);
HR+=2;
return (AbsPair(t));
}
*HR++ = (CELL) f;
while (n--) {
RESET_VARIABLE(HR);
HR++;
}
return (AbsAppl(t));
}
Term
Yap_Globalise(Term t)
{
CACHE_REGS
CELL *vt;
Term tn;
if (!IsVarTerm(t))
return t;
vt = VarOfTerm(t);
if (vt <= HR && vt > H0)
return t;
tn = MkVarTerm();
Yap_unify(t, tn);
return tn;
}

1102
dev/yap-6.3/C/parser.c Normal file
View File

File diff suppressed because it is too large Load Diff

3817
dev/yap-6.3/C/prim_absmi_insts.h Normal file
View File

File diff suppressed because it is too large Load Diff

1191
dev/yap-6.3/C/qlyr.c Normal file
View File

File diff suppressed because it is too large Load Diff

981
dev/yap-6.3/C/qlyw.c Normal file
View File

@ -0,0 +1,981 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V. Santos Costa and Universidade do Porto 1985-- *
* *
**************************************************************************
* *
* File: qlyw.c *
* comments: quick saver/loader *
* *
* Last rev: $Date: 2011-08-29$,$Author: vsc $ *
* $Log: not supported by cvs2svn $ *
* *
*************************************************************************/
#include "absmi.h"
#include "Foreign.h"
#include "alloc.h"
#include "yapio.h"
#include "iopreds.h"
#include "attvar.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#include "qly.h"
static void RestoreEntries(PropEntry *, int USES_REGS);
static void CleanCode(PredEntry * USES_REGS);
static void
GrowAtomTable(void) {
CACHE_REGS
UInt size = LOCAL_ExportAtomHashTableSize;
export_atom_hash_entry_t *p, *newt, *oldt = LOCAL_ExportAtomHashChain;
UInt new_size = size + (size > 1024 ? size : 1024);
UInt i;
newt = (export_atom_hash_entry_t *)calloc(new_size,sizeof(export_atom_hash_entry_t));
if (!newt) {
return;
}
p = oldt;
for (i = 0 ; i < size ; p++,i++) {
Atom a = p->val;
export_atom_hash_entry_t *newp;
CELL hash;
const unsigned char *apt;
if (!a) continue;
apt = RepAtom(a)->UStrOfAE;
hash = HashFunction(apt)/(2*sizeof(CELL)) % new_size;
newp = newt+hash;
while (newp->val) {
newp++;
if (newp == newt+new_size)
newp = newt;
}
newp->val = a;
}
LOCAL_ExportAtomHashChain = newt;
LOCAL_ExportAtomHashTableSize = new_size;
free(oldt);
}
static void
LookupAtom(Atom at)
{
CACHE_REGS
const unsigned char *p = RepAtom(at)->UStrOfAE;
CELL hash = HashFunction(p) % LOCAL_ExportAtomHashTableSize;
export_atom_hash_entry_t *a;
a = LOCAL_ExportAtomHashChain+hash;
while (a->val) {
if (a->val == at) {
return;
}
a++;
if (a == LOCAL_ExportAtomHashChain+LOCAL_ExportAtomHashTableSize)
a = LOCAL_ExportAtomHashChain;
}
a->val = at;
LOCAL_ExportAtomHashTableNum++;
if (LOCAL_ExportAtomHashTableNum >
LOCAL_ExportAtomHashTableSize/2
) {
GrowAtomTable();
if (!LOCAL_ExportAtomHashChain) {
return;
}
}
}
static void
GrowFunctorTable(void) {
CACHE_REGS
UInt size = LOCAL_ExportFunctorHashTableSize;
export_functor_hash_entry_t *p, *newt, *oldt = LOCAL_ExportFunctorHashChain;
UInt new_size = size + (size > 1024 ? size : 1024);
UInt i;
newt = (export_functor_hash_entry_t *)calloc(new_size,sizeof(export_functor_hash_entry_t));
if (!newt) {
return;
}
p = oldt;
for (i = 0 ; i < size ; p++,i++) {
Functor f = p->val;
export_functor_hash_entry_t *newp;
CELL hash;
if (!f) continue;
hash = ((CELL)(f))/(2*sizeof(CELL)) % new_size;
newp = newt+hash;
while (newp->val) {
newp++;
if (newp == newt+new_size)
newp = newt;
}
newp->val = p->val;
newp->arity = p->arity;
newp->name = p->name;
}
LOCAL_ExportFunctorHashChain = newt;
LOCAL_ExportFunctorHashTableSize = new_size;
free(oldt);
}
static void
LookupFunctor(Functor fun)
{
CACHE_REGS
CELL hash = ((CELL)(fun))/(2*sizeof(CELL)) % LOCAL_ExportFunctorHashTableSize;
export_functor_hash_entry_t *f;
Atom name = NameOfFunctor(fun);
UInt arity = ArityOfFunctor(fun);
f = LOCAL_ExportFunctorHashChain+hash;
while (f->val) {
if (f->val == fun) {
return;
}
f++;
if (f == LOCAL_ExportFunctorHashChain+LOCAL_ExportFunctorHashTableSize)
f = LOCAL_ExportFunctorHashChain;
}
LookupAtom(name);
f->val = fun;
f->name = name;
f->arity = arity;
LOCAL_ExportFunctorHashTableNum++;
if (LOCAL_ExportFunctorHashTableNum >
LOCAL_ExportFunctorHashTableSize/2
) {
GrowFunctorTable();
if (!LOCAL_ExportFunctorHashChain) {
return;
}
}
}
static void
GrowPredTable(void) {
CACHE_REGS
UInt size = LOCAL_ExportPredEntryHashTableSize;
export_pred_entry_hash_entry_t *p, *newt, *oldt = LOCAL_ExportPredEntryHashChain;
UInt new_size = size + (size > 1024 ? size : 1024);
UInt i;
newt = (export_pred_entry_hash_entry_t *)calloc(new_size,sizeof(export_pred_entry_hash_entry_t));
if (!newt) {
return;
}
p = oldt;
for (i = 0 ; i < size ; p++,i++) {
PredEntry *pe = p->val;
export_pred_entry_hash_entry_t *newp;
CELL hash;
if (!pe) continue;
hash = ((CELL)(pe))/(2*sizeof(CELL)) % new_size;
newp = newt+hash;
while (newp->val) {
newp++;
if (newp == newt+new_size)
newp = newt;
}
newp->val = p->val;
newp->arity = p->arity;
newp->u_af.f = p->u_af.f;
newp->module = p->module;
}
LOCAL_ExportPredEntryHashChain = newt;
LOCAL_ExportPredEntryHashTableSize = new_size;
free(oldt);
}
static void
LookupPredEntry(PredEntry *pe)
{
CACHE_REGS
CELL hash = (((CELL)(pe))/(2*sizeof(CELL))) % LOCAL_ExportPredEntryHashTableSize;
export_pred_entry_hash_entry_t *p;
UInt arity = pe->ArityOfPE;
p = LOCAL_ExportPredEntryHashChain+hash;
while (p->val) {
if (p->val == pe) {
return;
}
p++;
if (p == LOCAL_ExportPredEntryHashChain+LOCAL_ExportPredEntryHashTableSize)
p = LOCAL_ExportPredEntryHashChain;
}
p->arity = arity;
p->val = pe;
if (pe->ModuleOfPred != IDB_MODULE) {
if (arity) {
p->u_af.f = pe->FunctorOfPred;
LookupFunctor(pe->FunctorOfPred);
} else {
p->u_af.a = (Atom)(pe->FunctorOfPred);
LookupAtom((Atom)(pe->FunctorOfPred));
}
} else {
if (pe->PredFlags & AtomDBPredFlag) {
p->u_af.a = (Atom)(pe->FunctorOfPred);
p->arity = (CELL)(-2);
LookupAtom((Atom)(pe->FunctorOfPred));
} else if (!(pe->PredFlags & NumberDBPredFlag)) {
p->u_af.f = pe->FunctorOfPred;
p->arity = (CELL)(-1);
LookupFunctor(pe->FunctorOfPred);
} else {
p->u_af.f = pe->FunctorOfPred;
}
}
if (pe->ModuleOfPred) {
p->module = AtomOfTerm(pe->ModuleOfPred);
} else {
p->module = AtomProlog;
}
LookupAtom(p->module);
LOCAL_ExportPredEntryHashTableNum++;
if (LOCAL_ExportPredEntryHashTableNum >
LOCAL_ExportPredEntryHashTableSize/2
) {
GrowPredTable();
if (!LOCAL_ExportPredEntryHashChain) {
return;
}
}
}
static void
GrowDBRefTable(void) {
CACHE_REGS
UInt size = LOCAL_ExportDBRefHashTableSize;
export_dbref_hash_entry_t *p, *newt, *oldt = LOCAL_ExportDBRefHashChain;
UInt new_size = size + (size > 1024 ? size : 1024);
UInt i;
newt = (export_dbref_hash_entry_t *)calloc(new_size,sizeof(export_dbref_hash_entry_t));
if (!newt) {
return;
}
p = oldt;
for (i = 0 ; i < size ; p++,i++) {
DBRef dbr = p->val;
export_dbref_hash_entry_t *newp;
CELL hash;
if (!dbr) continue;
hash = ((CELL)(dbr))/(2*sizeof(CELL)) % new_size;
newp = newt+hash;
while (newp->val) {
newp++;
if (newp == newt+new_size)
newp = newt;
}
newp->val = p->val;
newp->sz = p->sz;
newp->refs = p->refs;
}
LOCAL_ExportDBRefHashChain = newt;
LOCAL_ExportDBRefHashTableSize = new_size;
free(oldt);
}
static void
LookupDBRef(DBRef ref)
{
CACHE_REGS
CELL hash = ((CELL)(ref))/(2*sizeof(CELL)) % LOCAL_ExportDBRefHashTableSize;
export_dbref_hash_entry_t *a;
a = LOCAL_ExportDBRefHashChain+hash;
while (a->val) {
if (a->val == ref) {
a->refs++;
return;
}
a++;
if (a == LOCAL_ExportDBRefHashChain+LOCAL_ExportDBRefHashTableSize)
a = LOCAL_ExportDBRefHashChain;
}
a->val = ref;
a->sz = ((LogUpdClause *)ref)->ClSize;
a->refs = 1;
LOCAL_ExportDBRefHashTableNum++;
if (LOCAL_ExportDBRefHashTableNum >
LOCAL_ExportDBRefHashTableSize/2
) {
GrowDBRefTable();
if (!LOCAL_ExportDBRefHashChain) {
return;
}
}
}
static void
InitHash(void)
{
CACHE_REGS
LOCAL_ExportFunctorHashTableNum = 0;
LOCAL_ExportFunctorHashTableSize = EXPORT_FUNCTOR_TABLE_SIZE;
LOCAL_ExportFunctorHashChain = (export_functor_hash_entry_t *)calloc(LOCAL_ExportFunctorHashTableSize, sizeof(export_functor_hash_entry_t ));
LOCAL_ExportAtomHashTableNum = 0;
LOCAL_ExportAtomHashTableSize = EXPORT_ATOM_TABLE_SIZE;
LOCAL_ExportAtomHashChain = (export_atom_hash_entry_t *)calloc( LOCAL_ExportAtomHashTableSize, sizeof(export_atom_hash_entry_t));
LOCAL_ExportPredEntryHashTableNum = 0;
LOCAL_ExportPredEntryHashTableSize = EXPORT_PRED_ENTRY_TABLE_SIZE;
LOCAL_ExportPredEntryHashChain = (export_pred_entry_hash_entry_t *)calloc(LOCAL_ExportPredEntryHashTableSize, sizeof(export_pred_entry_hash_entry_t));
LOCAL_ExportDBRefHashTableNum = 0;
LOCAL_ExportDBRefHashTableSize = EXPORT_DBREF_TABLE_SIZE;
LOCAL_ExportDBRefHashChain = (export_dbref_hash_entry_t *)calloc(EXPORT_DBREF_TABLE_SIZE, sizeof(export_dbref_hash_entry_t));
}
static void
CloseHash(void)
{
CACHE_REGS
LOCAL_ExportFunctorHashTableNum = 0;
LOCAL_ExportFunctorHashTableSize = 0L;
free(LOCAL_ExportFunctorHashChain);
LOCAL_ExportAtomHashTableNum = 0;
LOCAL_ExportAtomHashTableSize = 0L;
free(LOCAL_ExportAtomHashChain);
LOCAL_ExportPredEntryHashTableNum = 0;
LOCAL_ExportPredEntryHashTableSize = 0L;
free(LOCAL_ExportPredEntryHashChain);
LOCAL_ExportDBRefHashTableNum = 0;
LOCAL_ExportDBRefHashTableSize = 0L;
free(LOCAL_ExportDBRefHashChain);
}
static inline Atom
AtomAdjust(Atom a)
{
LookupAtom(a);
return a;
}
static inline Functor
FuncAdjust(Functor f)
{
LookupFunctor(f);
return f;
}
static inline Term
AtomTermAdjust(Term t)
{
LookupAtom(AtomOfTerm(t));
return t;
}
static inline Term
TermToGlobalOrAtomAdjust(Term t)
{
if (t && IsAtomTerm(t))
return AtomTermAdjust(t);
return t;
}
#define IsOldCode(P) FALSE
#define IsOldCodeCellPtr(P) FALSE
#define IsOldDelay(P) FALSE
#define IsOldDelayPtr(P) FALSE
#define IsOldLocalInTR(P) FALSE
#define IsOldLocalInTRPtr(P) FALSE
#define IsOldGlobal(P) FALSE
#define IsOldGlobalPtr(P) FALSE
#define IsOldTrail(P) FALSE
#define IsOldTrailPtr(P) FALSE
#define CharP(X) ((char *)(X))
#define REINIT_LOCK(P)
#define REINIT_RWLOCK(P)
#define BlobTypeAdjust(P) (P)
#define NoAGCAtomAdjust(P) (P)
#define OrArgAdjust(P)
#define TabEntryAdjust(P)
#define IntegerAdjust(D) (D)
#define AddrAdjust(P) (P)
#define MFileAdjust(P) (P)
#define CodeVarAdjust(P) (P)
#define ConstantAdjust(P) (P)
#define ArityAdjust(P) (P)
#define DoubleInCodeAdjust(P)
#define IntegerInCodeAdjust(P)
#define OpcodeAdjust(P) (P)
static inline Term
ModuleAdjust(Term t)
{
if (!t) return t;
return AtomTermAdjust(t);
}
static inline PredEntry *
PredEntryAdjust(PredEntry *pe)
{
LookupPredEntry(pe);
return pe;
}
static inline PredEntry *
PtoPredAdjust(PredEntry *pe)
{
LookupPredEntry(pe);
return pe;
}
#define ExternalFunctionAdjust(P) (P)
#define DBRecordAdjust(P) (P)
#define ModEntryPtrAdjust(P) (P)
#define AtomEntryAdjust(P) (P)
#define GlobalEntryAdjust(P) (P)
#define BlobTermInCodeAdjust(P) (P)
#define CellPtoHeapAdjust(P) (P)
#define PtoAtomHashEntryAdjust(P) (P)
#define CellPtoHeapCellAdjust(P) (P)
#define CellPtoTRAdjust(P) (P)
#define CodeAddrAdjust(P) (P)
#define ConsultObjAdjust(P) (P)
#define DelayAddrAdjust(P) (P)
#define DelayAdjust(P) (P)
#define GlobalAdjust(P) (P)
#define DBRefAdjust(P,DoRef) DBRefAdjust__(P PASS_REGS)
static inline DBRef
DBRefAdjust__ (DBRef dbt USES_REGS)
{
LookupDBRef(dbt);
return dbt;
}
#define DBRefPAdjust(P) (P)
#define DBTermAdjust(P) (P)
#define LUIndexAdjust(P) (P)
#define SIndexAdjust(P) (P)
#define LocalAddrAdjust(P) (P)
#define GlobalAddrAdjust(P) (P)
#define OpListAdjust(P) (P)
#define PtoLUCAdjust(P) (P)
#define PtoStCAdjust(P) (P)
#define PtoArrayEAdjust(P) (P)
#define PtoArraySAdjust(P) (P)
#define PtoGlobalEAdjust(P) (P)
#define PtoDelayAdjust(P) (P)
#define PtoGloAdjust(P) (P)
#define PtoLocAdjust(P) (P)
#define PtoHeapCellAdjust(P) (P)
#define TermToGlobalAdjust(P) (P)
#define PtoOpAdjust(P) (P)
#define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define PtoDBTLAdjust(P) (P)
#define PtoPtoPredAdjust(P) (P)
#define OpRTableAdjust(P) (P)
#define OpEntryAdjust(P) (P)
#define PropAdjust(P) (P)
#define TrailAddrAdjust(P) (P)
#define XAdjust(P) (P)
#define YAdjust(P) (P)
#define HoldEntryAdjust(P) (P)
#define CodeCharPAdjust(P) (P)
#define CodeConstCharPAdjust(P) (P)
#define CodeVoidPAdjust(P) (P)
#define HaltHookAdjust(P) (P)
#define recompute_mask(dbr)
#define rehash(oldcode, NOfE, KindOfEntries)
#define RestoreSWIHash()
static void RestoreFlags( UInt NFlags )
{
}
#include "rheap.h"
static void
RestoreHashPreds( USES_REGS1 )
{
}
static void
RestoreAtomList(Atom atm USES_REGS)
{
}
static size_t save_bytes(FILE *stream, void *ptr, size_t sz)
{
return fwrite(ptr, sz, 1, stream);
}
static size_t save_byte(FILE *stream, int byte)
{
fputc(byte, stream);
return 1;
}
static size_t save_bits16(FILE *stream, BITS16 val)
{
BITS16 v = val;
return save_bytes(stream, &v, sizeof(BITS16));
}
static size_t save_UInt(FILE *stream, UInt val)
{
UInt v = val;
return save_bytes(stream, &v, sizeof(UInt));
}
static size_t save_Int(FILE *stream, Int val)
{
Int v = val;
return save_bytes(stream, &v, sizeof(Int));
}
static size_t save_tag(FILE *stream, qlf_tag_t tag)
{
return save_byte(stream, tag);
}
static size_t save_predFlags(FILE *stream, pred_flags_t predFlags)
{
pred_flags_t v = predFlags;
return save_bytes(stream, &v, sizeof(pred_flags_t));
}
static int
SaveHash(FILE *stream)
{
CACHE_REGS
UInt i;
/* first, current opcodes */
CHECK(save_tag(stream, QLY_START_X));
save_UInt(stream, (UInt)&ARG1);
CHECK(save_tag(stream, QLY_START_OPCODES));
save_Int(stream, _std_top);
for (i= 0; i <= _std_top; i++) {
save_UInt(stream, (UInt)Yap_opcode(i));
}
CHECK(save_tag(stream, QLY_START_ATOMS));
CHECK(save_UInt(stream, LOCAL_ExportAtomHashTableNum));
for (i = 0; i < LOCAL_ExportAtomHashTableSize; i++) {
export_atom_hash_entry_t *a = LOCAL_ExportAtomHashChain+i;
if (a->val) {
Atom at = a->val;
CHECK(save_UInt(stream, (UInt)at));
if (IsWideAtom(at)) {
CHECK(save_tag(stream, QLY_ATOM_WIDE));
CHECK(save_UInt(stream, wcslen(RepAtom(at)->WStrOfAE)));
CHECK(save_bytes(stream, at->WStrOfAE, (wcslen(at->WStrOfAE)+1)*sizeof(wchar_t)));
} else {
CHECK(save_tag(stream, QLY_ATOM));
CHECK(save_UInt(stream, strlen((char *)RepAtom(at)->StrOfAE)));
CHECK(save_bytes(stream, (char *)at->StrOfAE, (strlen((char *)at->StrOfAE)+1)*sizeof(char)));
}
}
}
save_tag(stream, QLY_START_FUNCTORS);
save_UInt(stream, LOCAL_ExportFunctorHashTableNum);
for (i = 0; i < LOCAL_ExportFunctorHashTableSize; i++) {
export_functor_hash_entry_t *f = LOCAL_ExportFunctorHashChain+i;
if (!(f->val))
continue;
CHECK(save_UInt(stream, (UInt)(f->val)));
CHECK(save_UInt(stream, f->arity));
CHECK(save_UInt(stream, (CELL)(f->name)));
}
save_tag(stream, QLY_START_PRED_ENTRIES);
save_UInt(stream, LOCAL_ExportPredEntryHashTableNum);
for (i = 0; i < LOCAL_ExportPredEntryHashTableSize; i++) {
export_pred_entry_hash_entry_t *p = LOCAL_ExportPredEntryHashChain+i;
if (!(p->val))
continue;
CHECK(save_UInt(stream, (UInt)(p->val)));
CHECK(save_UInt(stream, p->arity));
CHECK(save_UInt(stream, (UInt)p->module));
CHECK(save_UInt(stream, (UInt)p->u_af.f));
}
save_tag(stream, QLY_START_DBREFS);
save_UInt(stream, LOCAL_ExportDBRefHashTableNum);
for (i = 0; i < LOCAL_ExportDBRefHashTableSize; i++) {
export_dbref_hash_entry_t *p = LOCAL_ExportDBRefHashChain+i;
if (p->val) {
CHECK(save_UInt(stream, (UInt)(p->val)));
CHECK(save_UInt(stream, p->sz));
CHECK(save_UInt(stream, p->refs));
}
}
save_tag(stream, QLY_FAILCODE);
save_UInt(stream, (UInt)FAILCODE);
return 1;
}
static size_t
save_clauses(FILE *stream, PredEntry *pp) {
yamop *FirstC, *LastC;
FirstC = pp->cs.p_code.FirstClause;
LastC = pp->cs.p_code.LastClause;
if (FirstC == NULL && LastC == NULL) {
return 1;
}
if (pp->PredFlags & LogUpdatePredFlag) {
LogUpdClause *cl = ClauseCodeToLogUpdClause(FirstC);
while (cl != NULL) {
if (IN_BETWEEN(cl->ClTimeStart, pp->TimeStampOfPred, cl->ClTimeEnd)) {
UInt size = cl->ClSize;
CHECK(save_tag(stream, QLY_START_LU_CLAUSE));
CHECK(save_UInt(stream, (UInt)cl));
CHECK(save_UInt(stream, size));
CHECK(save_bytes(stream, cl, size));
}
cl = cl->ClNext;
}
CHECK(save_tag(stream, QLY_END_LU_CLAUSES));
} else if (pp->PredFlags & MegaClausePredFlag) {
MegaClause *cl = ClauseCodeToMegaClause(FirstC);
UInt size = cl->ClSize;
CHECK(save_UInt(stream, (UInt)cl));
CHECK(save_UInt(stream, (UInt)(cl->ClFlags)));
CHECK(save_UInt(stream, size));
CHECK(save_bytes(stream, cl, size));
} else if (pp->PredFlags & DynamicPredFlag) {
yamop *cl = FirstC;
do {
DynamicClause *dcl = ClauseCodeToDynamicClause(cl);
UInt size = dcl->ClSize;
CHECK(save_UInt(stream, (UInt)cl));
CHECK(save_UInt(stream, size));
CHECK(save_bytes(stream, dcl, size));
if (cl == LastC) return 1;
cl = NextDynamicClause(cl);
} while (TRUE);
} else {
StaticClause *cl = ClauseCodeToStaticClause(FirstC);
if (pp->PredFlags & SYSTEM_PRED_FLAGS) {
return 1;
}
do {
UInt size = cl->ClSize;
CHECK(save_UInt(stream, (UInt)cl));
CHECK(save_UInt(stream, size));
CHECK(save_bytes(stream, cl, size));
if (cl->ClCode == LastC) return 1;
cl = cl->ClNext;
} while (TRUE);
}
return 1;
}
static size_t
save_pred(FILE *stream, PredEntry *ap) {
CHECK(save_UInt(stream, (UInt)ap));
CHECK(save_predFlags(stream, ap->PredFlags));
if (ap->PredFlags & ForeignPredFlags)
return 1;
CHECK(save_UInt(stream, ap->cs.p_code.NOfClauses));
CHECK(save_UInt(stream, ap->src.IndxId));
CHECK(save_UInt(stream, ap->TimeStampOfPred));
return save_clauses(stream, ap);
}
static int
clean_pred(PredEntry *pp USES_REGS) {
if (pp->PredFlags & ForeignPredFlags) {
return true;
} else {
CleanClauses(pp->cs.p_code.FirstClause, pp->cs.p_code.LastClause, pp PASS_REGS);
}
return TRUE;
}
static size_t
mark_pred(PredEntry *ap)
{
CACHE_REGS
if (ap->ModuleOfPred != IDB_MODULE) {
if (ap->ArityOfPE) {
FuncAdjust(ap->FunctorOfPred);
} else {
AtomAdjust((Atom)(ap->FunctorOfPred));
}
} else {
if (ap->PredFlags & AtomDBPredFlag) {
AtomAdjust((Atom)(ap->FunctorOfPred));
} else if (!(ap->PredFlags & NumberDBPredFlag)) {
FuncAdjust(ap->FunctorOfPred);
}
}
if (!(ap->PredFlags & (MultiFileFlag|NumberDBPredFlag)) &&
ap->src.OwnerFile) {
AtomAdjust(ap->src.OwnerFile);
}
CHECK(clean_pred(ap PASS_REGS));
return 1;
}
static size_t
mark_ops(FILE *stream, Term mod) {
OpEntry *op = OpList;
while (op) {
if (!mod || op->OpModule == mod) {
AtomAdjust(op->OpName);
if (op->OpModule)
AtomTermAdjust(op->OpModule);
}
op = op->OpNext;
}
return 1;
}
static size_t
save_ops(FILE *stream, Term mod) {
OpEntry *op = OpList;
while (op) {
if (!mod || op->OpModule == mod) {
CHECK(save_tag(stream, QLY_NEW_OP));
save_UInt(stream, (UInt)op->OpName);
save_UInt(stream, (UInt)op->OpModule);
save_bits16(stream, op->Prefix);
save_bits16(stream, op->Infix);
save_bits16(stream, op->Posfix);
}
op = op->OpNext;
}
CHECK(save_tag(stream, QLY_END_OPS));
return 1;
}
static int
save_header(FILE *stream, char type[])
{
char msg[256];
sprintf(msg, "#!/bin/sh\nexec_dir=${YAPBINDIR:-%s}\nexec $exec_dir/yap $0 \"$@\"\n%s %s\n", YAP_BINDIR, type, YAP_FULL_VERSION);
return save_bytes(stream, msg, strlen(msg)+1);
}
static size_t
save_module(FILE *stream, Term mod) {
PredEntry *ap = Yap_ModulePred(mod);
save_header( stream, "saved module," );
InitHash();
ModuleAdjust(mod);
while (ap) {
ap = PredEntryAdjust(ap);
CHECK(mark_pred(ap));
ap = ap->NextPredOfModule;
}
/* just to make sure */
mark_ops(stream, mod);
SaveHash(stream);
CHECK(save_tag(stream, QLY_START_MODULE));
CHECK(save_UInt(stream, (UInt)mod));
ap = Yap_ModulePred(mod);
while (ap) {
CHECK(save_tag(stream, QLY_START_PREDICATE));
CHECK(save_pred(stream, ap));
ap = ap->NextPredOfModule;
}
CHECK(save_tag(stream, QLY_END_PREDICATES));
CHECK(save_tag(stream, QLY_END_MODULES));
save_ops(stream, mod);
CloseHash();
return 1;
}
static size_t
save_program(FILE *stream) {
ModEntry *me = CurrentModules;
InitHash();
save_header( stream, "saved state," );
/* should we allow the user to see hidden predicates? */
while (me) {
PredEntry *pp;
pp = me->PredForME;
AtomAdjust(me->AtomOfME);
while (pp != NULL) {
#if DEBUG
// Yap_PrintPredName( pp );
#endif
pp = PredEntryAdjust(pp);
CHECK(mark_pred(pp));
pp = pp->NextPredOfModule;
}
me = me->NextME;
}
/* just to make sure */
mark_ops(stream, 0);
SaveHash(stream);
me = CurrentModules;
while (me) {
PredEntry *pp;
pp = me->PredForME;
CHECK(save_tag(stream, QLY_START_MODULE));
CHECK(save_UInt(stream, (UInt)MkAtomTerm(me->AtomOfME)));
while (pp != NULL) {
CHECK(save_tag(stream, QLY_START_PREDICATE));
CHECK(save_pred(stream, pp));
pp = pp->NextPredOfModule;
}
CHECK(save_tag(stream, QLY_END_PREDICATES));
me = me->NextME;
}
CHECK(save_tag(stream, QLY_END_MODULES));
save_ops(stream, 0);
CloseHash();
return 1;
}
static size_t
save_file(FILE *stream, Atom FileName) {
ModEntry *me = CurrentModules;
InitHash();
save_header( stream, "saved file," );
/* should we allow the user to see hidden predicates? */
while (me) {
PredEntry *pp;
pp = me->PredForME;
AtomAdjust(me->AtomOfME);
while (pp != NULL) {
pp = PredEntryAdjust(pp);
if (pp &&
!(pp->PredFlags & (MultiFileFlag|NumberDBPredFlag|AtomDBPredFlag|CPredFlag|AsmPredFlag|UserCPredFlag)) &&
pp->ModuleOfPred != IDB_MODULE &&
pp->src.OwnerFile == FileName) {
CHECK(mark_pred(pp));
}
pp = pp->NextPredOfModule;
}
me = me->NextME;
}
/* just to make sure */
mark_ops(stream, 0);
SaveHash(stream);
me = CurrentModules;
while (me) {
PredEntry *pp;
pp = me->PredForME;
CHECK(save_tag(stream, QLY_START_MODULE));
CHECK(save_UInt(stream, (UInt)MkAtomTerm(me->AtomOfME)));
while (pp != NULL) {
if (pp &&
!(pp->PredFlags & (MultiFileFlag|NumberDBPredFlag|AtomDBPredFlag|CPredFlag|AsmPredFlag|UserCPredFlag)) &&
pp->src.OwnerFile == FileName) {
CHECK(save_tag(stream, QLY_START_PREDICATE));
CHECK(save_pred(stream, pp));
}
pp = pp->NextPredOfModule;
}
CHECK(save_tag(stream, QLY_END_PREDICATES));
me = me->NextME;
}
CHECK(save_tag(stream, QLY_END_MODULES));
save_ops(stream, 0);
CloseHash();
return 1;
}
static Int
qsave_module_preds( USES_REGS1 )
{
FILE *stream;
Term tmod = Deref(ARG2);
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR,t1,"save_module/3");
return FALSE;
}
if (!IsAtomTerm(t1)) {
Yap_Error(TYPE_ERROR_ATOM,t1,"save_module/3");
return(FALSE);
}
if (!(stream = Yap_GetOutputStream(t1, "save_module") )){
return FALSE;
}
if (IsVarTerm(tmod)) {
Yap_Error(INSTANTIATION_ERROR,tmod,"save_module/2");
return FALSE;
}
if (!IsAtomTerm(tmod)) {
Yap_Error(TYPE_ERROR_ATOM,tmod,"save_module/2");
return FALSE;
}
return save_module(stream, tmod) != 0;
}
static Int
qsave_program( USES_REGS1 )
{
FILE *stream;
Term t1 = Deref(ARG1);
if (!(stream = Yap_GetOutputStream(t1,"save_program")) ) {
return FALSE;
}
return save_program(stream) != 0;
}
static Int
qsave_file( USES_REGS1 )
{
FILE *stream;
Term t1 = Deref(ARG1);
Term tfile = Deref(ARG2);
if (!(stream = Yap_GetOutputStream(t1, "save_file/2") ) ) {
return FALSE;
}
if (IsVarTerm(tfile)) {
Yap_Error(INSTANTIATION_ERROR,tfile,"save_file/2");
return FALSE;
}
if (!IsAtomTerm(tfile)) {
Yap_Error(TYPE_ERROR_ATOM,tfile,"save_file/2");
return FALSE;
}
return save_file(stream, AtomOfTerm(tfile) ) != 0;
}
void Yap_InitQLY(void)
{
Yap_InitCPred("$qsave_module_preds", 2, qsave_module_preds, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$qsave_program", 1, qsave_program, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$qsave_file_preds", 2, qsave_file, SyncPredFlag|UserCPredFlag);
if (FALSE) {
restore_codes();
}
}

129
dev/yap-6.3/C/range.c Normal file
View File

@ -0,0 +1,129 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V. Santos Costa and Universidade do Porto 1985-- *
* *
**************************************************************************
* *
* File: range.c *
* comments: Arithmetic interval computation *
* *
* *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "eval.h"
static Int
p_in_range( USES_REGS1 ) {
Term t;
double i,j;
double d1;
double d2;
double d3;
t = Deref(ARG1);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(ARG4);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
d1 = i-j;
t = Deref(ARG2);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(ARG5);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
d2 = i-j;
t = Deref(ARG3);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(ARG6);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
d3 = i-j;
t = Deref(ARG7);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(ARG8);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
return fabs(sqrt(d1*d1 + d2*d2 + d3*d3)-i) <= j;
}
static Int
p_in_range2( USES_REGS1 ) {
CELL *p1, *p2;
Term t;
double i,j;
double d1;
double d2;
double d3;
UInt arity;
p1 = RepAppl(Deref(ARG1));
arity = ArityOfFunctor((Functor)*p1);
p1 += arity-2;
p2 = RepAppl(Deref(ARG2))+(arity-2);;
t = Deref(p1[0]);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(p2[0]);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
d1 = i-j;
t = Deref(p1[1]);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(p2[1]);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
d2 = i-j;
t = Deref(p1[2]);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(p2[2]);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
d3 = i-j;
t = Deref(ARG3);
if (IsFloatTerm(t)) i = FloatOfTerm(t); else i = IntegerOfTerm(t);
t = Deref(ARG4);
if (IsFloatTerm(t)) j = FloatOfTerm(t); else j = IntegerOfTerm(t);
return fabs(sqrt(d1*d1 + d2*d2 + d3*d3)-i) <= j;
}
static Int
p_euc_dist( USES_REGS1 ) {
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
double d1 = (double)(IntegerOfTerm(ArgOfTerm(1,t1))-IntegerOfTerm(ArgOfTerm(1,t2)));
double d2 = (double)(IntegerOfTerm(ArgOfTerm(2,t1))-IntegerOfTerm(ArgOfTerm(2,t2)));
double d3 = (double)(IntegerOfTerm(ArgOfTerm(3,t1))-IntegerOfTerm(ArgOfTerm(3,t2)));
Int result = (Int)sqrt(d1*d1+d2*d2+d3*d3);
return(Yap_unify(ARG3,MkIntegerTerm(result)));
}
#if DEBUG
volatile int loop_counter = 0;
static Int
p_loop( USES_REGS1 ) {
while (loop_counter == 0);
return(TRUE);
}
#endif
void
Yap_InitRange(void)
{
CACHE_REGS
Term cm = CurrentModule;
CurrentModule = RANGE_MODULE;
Yap_InitCPred("euclidean_distance", 3, p_euc_dist, SafePredFlag);
#ifdef DEBUG
Yap_InitCPred("loop", 0, p_loop, SafePredFlag);
#endif
Yap_InitCPred("in_range", 8, p_in_range, TestPredFlag|SafePredFlag);
Yap_InitCPred("in_range", 4, p_in_range2, TestPredFlag|SafePredFlag);
CurrentModule = cm;
}

178
dev/yap-6.3/C/realpath.c Normal file
View File

@ -0,0 +1,178 @@
<html>
<head>
<title>/var/www/vhosts/netmite.com/android/mydroid/bionic/libc/bionic/realpath.c</title>
</head>
<body bgcolor="#ffffff" text="#000000">
<pre>
<font color="#444444">/*
* Copyright (c) 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Jan-Simon Pendry.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*/</font>
<font color="0000ff"><strong>#if defined(LIBC_SCCS) &amp;&amp; !defined(lint)</strong></font>
<strong>static</strong> <strong>char</strong> <font color="#2040a0">sccsid</font><font color="4444FF">[</font><font color="4444FF">]</font> <font color="4444FF">=</font> <font color="#008000">&quot;@(#)realpath.c 8.1 (Berkeley) 2/16/94&quot;</font><font color="4444FF">;</font>
<strong>static</strong> <strong>char</strong> <font color="#2040a0">rcsid</font><font color="4444FF">[</font><font color="4444FF">]</font> <font color="4444FF">=</font>
<font color="#008000">&quot;$FreeBSD: /repoman/r/ncvs/src/lib/libc/stdlib/realpath.c,v 1.6.2.1 2003/08/03 23:47:39 nectar Exp $&quot;</font><font color="4444FF">;</font>
<font color="0000ff"><strong>#endif<font color="#444444"> /* LIBC_SCCS and not lint */</font></strong></font>
<font color="0000ff"><strong>#include <font color="#008000">&lt;sys/param.h&gt;</font></strong></font>
<font color="0000ff"><strong>#include <font color="#008000">&lt;sys/stat.h&gt;</font></strong></font>
<font color="0000ff"><strong>#include <font color="#008000">&lt;errno.h&gt;</font></strong></font>
<font color="0000ff"><strong>#include <font color="#008000">&lt;fcntl.h&gt;</font></strong></font>
<font color="0000ff"><strong>#include <font color="#008000">&lt;stdlib.h&gt;</font></strong></font>
<font color="0000ff"><strong>#include <font color="#008000">&lt;string.h&gt;</font></strong></font>
<font color="0000ff"><strong>#include <font color="#008000">&lt;unistd.h&gt;</font></strong></font>
<font color="#444444">/*
* char *realpath(const char *path, char resolved_path[MAXPATHLEN]);
*
* Find the real name of path, by removing all &quot;.&quot;, &quot;..&quot; and symlink
* components. Returns (resolved) on success, or (NULL) on failure,
* in which case the path which caused trouble is left in (resolved).
*/</font>
<strong>char</strong> <font color="4444FF">*</font>
<font color="#2040a0">realpath</font><font color="4444FF">(</font><font color="#2040a0">path</font>, <font color="#2040a0">resolved</font><font color="4444FF">)</font>
<strong>const</strong> <strong>char</strong> <font color="4444FF">*</font><font color="#2040a0">path</font><font color="4444FF">;</font>
<strong>char</strong> <font color="4444FF">*</font><font color="#2040a0">resolved</font><font color="4444FF">;</font>
<font color="4444FF"><strong>{</strong></font>
<strong>struct</strong> <font color="#2040a0">stat</font> <font color="#2040a0">sb</font><font color="4444FF">;</font>
<strong>int</strong> <font color="#2040a0">fd</font>, <font color="#2040a0">n</font>, <font color="#2040a0">rootd</font>, <font color="#2040a0">serrno</font><font color="4444FF">;</font>
<strong>char</strong> <font color="4444FF">*</font><font color="#2040a0">p</font>, <font color="4444FF">*</font><font color="#2040a0">q</font>, <font color="#2040a0">wbuf</font><font color="4444FF">[</font><font color="#2040a0">MAXPATHLEN</font><font color="4444FF">]</font><font color="4444FF">;</font>
<strong>int</strong> <font color="#2040a0">symlinks</font> <font color="4444FF">=</font> <font color="#FF0000">0</font><font color="4444FF">;</font>
<font color="#444444">/* Save the starting point. */</font>
<strong>if</strong> <font color="4444FF">(</font><font color="4444FF">(</font><font color="#2040a0">fd</font> <font color="4444FF">=</font> <font color="#2040a0">open</font><font color="4444FF">(</font><font color="#008000">&quot;.&quot;</font>, <font color="#2040a0">O_RDONLY</font><font color="4444FF">)</font><font color="4444FF">)</font> <font color="4444FF">&lt;</font> <font color="#FF0000">0</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">strcpy</font><font color="4444FF">(</font><font color="#2040a0">resolved</font>, <font color="#008000">&quot;.&quot;</font><font color="4444FF">)</font><font color="4444FF">;</font>
<strong>return</strong> <font color="4444FF">(</font><font color="#2040a0">NULL</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<font color="#444444">/*
* Find the dirname and basename from the path to be resolved.
* Change directory to the dirname component.
* lstat the basename part.
* if it is a symlink, read in the value and loop.
* if it is a directory, then change to that directory.
* get the current directory name and append the basename.
*/</font>
<font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">strncpy</font><font color="4444FF">(</font><font color="#2040a0">resolved</font>, <font color="#2040a0">path</font>, <font color="#2040a0">MAXPATHLEN</font> <font color="4444FF">-</font> <font color="#FF0000">1</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="#2040a0">resolved</font><font color="4444FF">[</font><font color="#2040a0">MAXPATHLEN</font> <font color="4444FF">-</font> <font color="#FF0000">1</font><font color="4444FF">]</font> <font color="4444FF">=</font> <font color="#008000">'<font color="#77dd77">\0</font>'</font><font color="4444FF">;</font>
<font color="#2040a0">loop</font><font color="4444FF">:</font>
<font color="#2040a0">q</font> <font color="4444FF">=</font> <font color="#2040a0">strrchr</font><font color="4444FF">(</font><font color="#2040a0">resolved</font>, <font color="#008000">'/'</font><font color="4444FF">)</font><font color="4444FF">;</font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">q</font> <font color="4444FF">!</font><font color="4444FF">=</font> <font color="#2040a0">NULL</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<font color="#2040a0">p</font> <font color="4444FF">=</font> <font color="#2040a0">q</font> <font color="4444FF">+</font> <font color="#FF0000">1</font><font color="4444FF">;</font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">q</font> <font color="4444FF">=</font><font color="4444FF">=</font> <font color="#2040a0">resolved</font><font color="4444FF">)</font>
<font color="#2040a0">q</font> <font color="4444FF">=</font> <font color="#008000">&quot;/&quot;</font><font color="4444FF">;</font>
<strong>else</strong> <font color="4444FF"><strong>{</strong></font>
<strong>do</strong> <font color="4444FF"><strong>{</strong></font>
<font color="4444FF">-</font><font color="4444FF">-</font><font color="#2040a0">q</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font> <strong>while</strong> <font color="4444FF">(</font><font color="#2040a0">q</font> <font color="4444FF">&gt;</font> <font color="#2040a0">resolved</font> <font color="4444FF">&amp;</font><font color="4444FF">&amp;</font> <font color="4444FF">*</font><font color="#2040a0">q</font> <font color="4444FF">=</font><font color="4444FF">=</font> <font color="#008000">'/'</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="#2040a0">q</font><font color="4444FF">[</font><font color="#FF0000">1</font><font color="4444FF">]</font> <font color="4444FF">=</font> <font color="#008000">'<font color="#77dd77">\0</font>'</font><font color="4444FF">;</font>
<font color="#2040a0">q</font> <font color="4444FF">=</font> <font color="#2040a0">resolved</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">chdir</font><font color="4444FF">(</font><font color="#2040a0">q</font><font color="4444FF">)</font> <font color="4444FF">&lt;</font> <font color="#FF0000">0</font><font color="4444FF">)</font>
<strong>goto</strong> <font color="#2040a0">err1</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font> <strong>else</strong>
<font color="#2040a0">p</font> <font color="4444FF">=</font> <font color="#2040a0">resolved</font><font color="4444FF">;</font>
<font color="#444444">/* Deal with the last component. */</font>
<strong>if</strong> <font color="4444FF">(</font><font color="4444FF">*</font><font color="#2040a0">p</font> <font color="4444FF">!</font><font color="4444FF">=</font> <font color="#008000">'<font color="#77dd77">\0</font>'</font> <font color="4444FF">&amp;</font><font color="4444FF">&amp;</font> <font color="#2040a0">lstat</font><font color="4444FF">(</font><font color="#2040a0">p</font>, <font color="4444FF">&amp;</font><font color="#2040a0">sb</font><font color="4444FF">)</font> <font color="4444FF">=</font><font color="4444FF">=</font> <font color="#FF0000">0</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">S_ISLNK</font><font color="4444FF">(</font><font color="#2040a0">sb</font>.<font color="#2040a0">st_mode</font><font color="4444FF">)</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<strong>if</strong> <font color="4444FF">(</font><font color="4444FF">+</font><font color="4444FF">+</font><font color="#2040a0">symlinks</font> <font color="4444FF">&gt;</font> <font color="#2040a0">MAXSYMLINKS</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<font color="#2040a0">errno</font> <font color="4444FF">=</font> <font color="#2040a0">ELOOP</font><font color="4444FF">;</font>
<strong>goto</strong> <font color="#2040a0">err1</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<font color="#2040a0">n</font> <font color="4444FF">=</font> <font color="#2040a0">readlink</font><font color="4444FF">(</font><font color="#2040a0">p</font>, <font color="#2040a0">resolved</font>, <font color="#2040a0">MAXPATHLEN</font> <font color="4444FF">-</font> <font color="#FF0000">1</font><font color="4444FF">)</font><font color="4444FF">;</font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">n</font> <font color="4444FF">&lt;</font> <font color="#FF0000">0</font><font color="4444FF">)</font>
<strong>goto</strong> <font color="#2040a0">err1</font><font color="4444FF">;</font>
<font color="#2040a0">resolved</font><font color="4444FF">[</font><font color="#2040a0">n</font><font color="4444FF">]</font> <font color="4444FF">=</font> <font color="#008000">'<font color="#77dd77">\0</font>'</font><font color="4444FF">;</font>
<strong>goto</strong> <font color="#2040a0">loop</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">S_ISDIR</font><font color="4444FF">(</font><font color="#2040a0">sb</font>.<font color="#2040a0">st_mode</font><font color="4444FF">)</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">chdir</font><font color="4444FF">(</font><font color="#2040a0">p</font><font color="4444FF">)</font> <font color="4444FF">&lt;</font> <font color="#FF0000">0</font><font color="4444FF">)</font>
<strong>goto</strong> <font color="#2040a0">err1</font><font color="4444FF">;</font>
<font color="#2040a0">p</font> <font color="4444FF">=</font> <font color="#008000">&quot;&quot;</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<font color="4444FF"><strong>}</strong></font>
<font color="#444444">/*
* Save the last component name and get the full pathname of
* the current directory.
*/</font>
<font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">strcpy</font><font color="4444FF">(</font><font color="#2040a0">wbuf</font>, <font color="#2040a0">p</font><font color="4444FF">)</font><font color="4444FF">;</font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">getcwd</font><font color="4444FF">(</font><font color="#2040a0">resolved</font>, <font color="#2040a0">MAXPATHLEN</font><font color="4444FF">)</font> <font color="4444FF">=</font><font color="4444FF">=</font> <font color="#FF0000">0</font><font color="4444FF">)</font>
<strong>goto</strong> <font color="#2040a0">err1</font><font color="4444FF">;</font>
<font color="#444444">/*
* Join the two strings together, ensuring that the right thing
* happens if the last component is empty, or the dirname is root.
*/</font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">resolved</font><font color="4444FF">[</font><font color="#FF0000">0</font><font color="4444FF">]</font> <font color="4444FF">=</font><font color="4444FF">=</font> <font color="#008000">'/'</font> <font color="4444FF">&amp;</font><font color="4444FF">&amp;</font> <font color="#2040a0">resolved</font><font color="4444FF">[</font><font color="#FF0000">1</font><font color="4444FF">]</font> <font color="4444FF">=</font><font color="4444FF">=</font> <font color="#008000">'<font color="#77dd77">\0</font>'</font><font color="4444FF">)</font>
<font color="#2040a0">rootd</font> <font color="4444FF">=</font> <font color="#FF0000">1</font><font color="4444FF">;</font>
<strong>else</strong>
<font color="#2040a0">rootd</font> <font color="4444FF">=</font> <font color="#FF0000">0</font><font color="4444FF">;</font>
<strong>if</strong> <font color="4444FF">(</font><font color="4444FF">*</font><font color="#2040a0">wbuf</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">strlen</font><font color="4444FF">(</font><font color="#2040a0">resolved</font><font color="4444FF">)</font> <font color="4444FF">+</font> <font color="#2040a0">strlen</font><font color="4444FF">(</font><font color="#2040a0">wbuf</font><font color="4444FF">)</font> <font color="4444FF">+</font> <font color="4444FF">(</font><font color="#FF0000">1</font><font color="4444FF">-</font><font color="#2040a0">rootd</font><font color="4444FF">)</font> <font color="4444FF">+</font> <font color="#FF0000">1</font> <font color="4444FF">&gt;</font>
<font color="#2040a0">MAXPATHLEN</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<font color="#2040a0">errno</font> <font color="4444FF">=</font> <font color="#2040a0">ENAMETOOLONG</font><font color="4444FF">;</font>
<strong>goto</strong> <font color="#2040a0">err1</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">rootd</font> <font color="4444FF">=</font><font color="4444FF">=</font> <font color="#FF0000">0</font><font color="4444FF">)</font>
<font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">strcat</font><font color="4444FF">(</font><font color="#2040a0">resolved</font>, <font color="#008000">&quot;/&quot;</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">strcat</font><font color="4444FF">(</font><font color="#2040a0">resolved</font>, <font color="#2040a0">wbuf</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<font color="#444444">/* Go back to where we came from. */</font>
<strong>if</strong> <font color="4444FF">(</font><font color="#2040a0">fchdir</font><font color="4444FF">(</font><font color="#2040a0">fd</font><font color="4444FF">)</font> <font color="4444FF">&lt;</font> <font color="#FF0000">0</font><font color="4444FF">)</font> <font color="4444FF"><strong>{</strong></font>
<font color="#2040a0">serrno</font> <font color="4444FF">=</font> <font color="#2040a0">errno</font><font color="4444FF">;</font>
<strong>goto</strong> <font color="#2040a0">err2</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
<font color="#444444">/* It's okay if the close fails, what's an fd more or less? */</font>
<font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">close</font><font color="4444FF">(</font><font color="#2040a0">fd</font><font color="4444FF">)</font><font color="4444FF">;</font>
<strong>return</strong> <font color="4444FF">(</font><font color="#2040a0">resolved</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="#2040a0">err1</font><font color="4444FF">:</font> <font color="#2040a0">serrno</font> <font color="4444FF">=</font> <font color="#2040a0">errno</font><font color="4444FF">;</font>
<font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">fchdir</font><font color="4444FF">(</font><font color="#2040a0">fd</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="#2040a0">err2</font><font color="4444FF">:</font> <font color="4444FF">(</font><strong>void</strong><font color="4444FF">)</font><font color="#2040a0">close</font><font color="4444FF">(</font><font color="#2040a0">fd</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="#2040a0">errno</font> <font color="4444FF">=</font> <font color="#2040a0">serrno</font><font color="4444FF">;</font>
<strong>return</strong> <font color="4444FF">(</font><font color="#2040a0">NULL</font><font color="4444FF">)</font><font color="4444FF">;</font>
<font color="4444FF"><strong>}</strong></font>
</pre>
<hr>
syntax highlighted by <a href="http://www.palfrader.org/code2html">Code2HTML</a>, v. 0.9.1
</body>
</html>

1740
dev/yap-6.3/C/save.c Normal file
View File

File diff suppressed because it is too large Load Diff

2077
dev/yap-6.3/C/scanner.c Normal file
View File

File diff suppressed because it is too large Load Diff

434
dev/yap-6.3/C/signals.c Normal file
View File

@ -0,0 +1,434 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V. Santos Costa and Universidade do Porto 1985-- *
* *
**************************************************************************
* *
* File: signal.c *
* comments: Signal Handling & Debugger Support *
* *
* *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#define HAS_CACHE_REGS 1
#include "Yap.h"
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if _WIN32
#include <stdio.h>
#include <io.h>
#endif
#include "Yatom.h"
#include "YapHeap.h"
#include "eval.h"
#include "yapio.h"
#ifdef TABLING
#include "tab.macros.h"
#endif /* TABLING */
#include <stdlib.h>
#include <stdio.h>
#if HAVE_STRING_H
#include <string.h>
#endif
#if HAVE_STRINGS_H
#include <strings.h>
#endif
#if HAVE_MALLOC_H
#include <malloc.h>
#endif
#include <wchar.h>
#ifdef LOW_LEVEL_TRACER
#include <tracer.h>
#endif
/*
* The InteractSIGINT function is called after a normal interrupt had been
* caught.
* It allows 6 possibilities: abort, continue, trace, debug, help, exit.
*/
static yap_signals InteractSIGINT(int ch) {
#ifdef HAVE_SETBUF
/* make sure we are not waiting for the end of line */
setbuf(stdin, NULL);
#endif
switch (ch) {
case 'a':
/* abort computation */
return YAP_ABORT_SIGNAL;
case 'b':
/* continue */
return YAP_BREAK_SIGNAL;
case 'c':
/* continue */
return YAP_NO_SIGNAL;
case 'd':
/* enter debug mode */
return YAP_DEBUG_SIGNAL;
case 'e':
/* exit */
Yap_exit(1);
return YAP_EXIT_SIGNAL;
case 'g':
/* stack dump */
return YAP_STACK_DUMP_SIGNAL;
case 't':
/* start tracing */
return YAP_TRACE_SIGNAL;
#ifdef LOW_LEVEL_TRACER
case 'T':
toggle_low_level_trace();
return YAP_NO_SIGNAL;
#endif
case 's':
/* show some statistics */
return YAP_STATISTICS_SIGNAL;
case EOF:
return YAP_NO_SIGNAL;
case 'h':
case '?':
default:
/* show an helpful message */
fprintf(stderr, "Please press one of:\n");
fprintf(stderr, " a for abort\n c for continue\n d for debug\n");
fprintf(stderr, " e for exit\n g for stack dump\n s for statistics\n t "
"for trace\n");
fprintf(stderr, " b for break\n");
return YAP_NO_SIGNAL;
}
}
/*
This function talks to the user about a signal. We assume we are in
the context of the main Prolog thread (trivial in Unix, but hard in WIN32)
*/
static yap_signals ProcessSIGINT(void) {
CACHE_REGS
int ch, out;
#if _WIN32
if (!_isatty(0)) {
return YAP_INT_SIGNAL;
}
#elif HAVE_ISATTY
if (!isatty(0)) {
return YAP_INT_SIGNAL;
}
#endif
LOCAL_PrologMode |= AsyncIntMode;
do {
ch = Yap_GetCharForSIGINT();
} while (!(out = InteractSIGINT(ch)));
LOCAL_PrologMode &= ~AsyncIntMode;
return (out);
}
inline static void do_signal(int wid, yap_signals sig USES_REGS) {
#if THREADS
__sync_fetch_and_or(&REMOTE(wid)->Signals_, SIGNAL_TO_BIT(sig));
if (!REMOTE_InterruptsDisabled(wid)) {
REMOTE_ThreadHandle(wid).current_yaam_regs->CreepFlag_ =
Unsigned(REMOTE_ThreadHandle(wid).current_yaam_regs->LCL0_);
}
#else
LOCAL_Signals |= SIGNAL_TO_BIT(sig);
if (!LOCAL_InterruptsDisabled) {
CreepFlag = Unsigned(LCL0);
}
#endif
}
inline static bool get_signal(yap_signals sig USES_REGS) {
#if THREADS
uint64_t old;
// first, clear the Creep Flag, now if someone sets it it is their problem
CalculateStackGap(PASS_REGS1);
// reset the flag
if ((old = __sync_fetch_and_and(&LOCAL_Signals, ~SIGNAL_TO_BIT(sig))) !=
SIGNAL_TO_BIT(sig)) {
if (!LOCAL_InterruptsDisabled && LOCAL_Signals != 0) {
CreepFlag = (CELL)LCL0;
}
if (!(old & SIGNAL_TO_BIT(sig))) {
// not there?
return FALSE;
}
// more likely case, we have other interrupts.
return TRUE;
}
// success, we are good
return TRUE;
// should we set the flag?
#else
if (LOCAL_Signals & SIGNAL_TO_BIT(sig)) {
LOCAL_Signals &= ~SIGNAL_TO_BIT(sig);
if (!LOCAL_InterruptsDisabled && LOCAL_Signals != 0) {
CreepFlag = (CELL)LCL0;
} else {
CalculateStackGap(PASS_REGS1);
}
return TRUE;
} else {
return FALSE;
}
#endif
}
/**
Function called to handle delayed interrupts.
*/
int Yap_HandleInterrupts(void) {
CACHE_REGS
yap_signals sig;
if (get_signal(YAP_INT_SIGNAL PASS_REGS)) {
if ((sig = ProcessSIGINT()) != YAP_NO_SIGNAL)
do_signal(worker_id, sig PASS_REGS);
LOCAL_PrologMode &= ~InterruptMode;
return 1;
}
return 0;
}
static Int p_creep(USES_REGS1) {
Atom at;
PredEntry *pred;
at = AtomCreep;
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1), 0));
CreepCode = pred;
do_signal(worker_id, YAP_CREEP_SIGNAL PASS_REGS);
return TRUE;
}
static Int p_creep_fail(USES_REGS1) {
Atom at;
PredEntry *pred;
at = AtomCreep;
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1), 0));
CreepCode = pred;
do_signal(worker_id, YAP_CREEP_SIGNAL PASS_REGS);
return FALSE;
}
static Int stop_creeping(USES_REGS1) {
if (get_signal(YAP_CREEP_SIGNAL PASS_REGS)) {
return Yap_unify(ARG1, TermTrue);
}
return Yap_unify(ARG1, TermFalse);
}
static Int disable_debugging(USES_REGS1) {
get_signal(YAP_CREEP_SIGNAL PASS_REGS);
return true;
}
static Int creep_allowed(USES_REGS1) {
if (PP != NULL) {
get_signal(YAP_CREEP_SIGNAL PASS_REGS);
return true;
}
return false;
}
void Yap_signal(yap_signals sig) {
CACHE_REGS
do_signal(worker_id, sig PASS_REGS);
}
#ifdef DEBUG
static Int p_debug(USES_REGS1);
#endif
void Yap_external_signal(int wid, yap_signals sig) {
#if THREADS
REGSTORE *regcache = REMOTE_ThreadHandle(wid).current_yaam_regs;
#endif
do_signal(wid, sig PASS_REGS);
LOCAL_PrologMode &= ~InterruptMode;
}
int Yap_get_signal__(yap_signals sig USES_REGS) {
return get_signal(sig PASS_REGS);
}
// the caller holds the lock.
int Yap_has_signals__(yap_signals sig1, yap_signals sig2 USES_REGS) {
return LOCAL_Signals & (SIGNAL_TO_BIT(sig1) | SIGNAL_TO_BIT(sig2));
}
int Yap_only_has_signals__(yap_signals sig1, yap_signals sig2 USES_REGS) {
uint64_t sigs = LOCAL_Signals;
return sigs & (SIGNAL_TO_BIT(sig1) | SIGNAL_TO_BIT(sig2)) &&
!(sigs & ~(SIGNAL_TO_BIT(sig1) | SIGNAL_TO_BIT(sig2)));
}
#ifdef DEBUG
volatile int volat = 0;
static Int p_debug(USES_REGS1) { /* $debug(+Flag) */
int i = IntOfTerm(Deref(ARG1));
while (volat == 0) {
}
if (i >= 'a' && i <= 'z')
GLOBAL_Option[i - 96] = !GLOBAL_Option[i - 96];
return 1;
}
void Yap_loop(void);
void Yap_debug_end_loop(void);
void Yap_loop(void) {
while (volat == 0)
;
}
void Yap_debug_end_loop(void) { volat = 1; }
#endif
static Int first_signal(USES_REGS1) {
Atom at;
yap_signals sig;
while (TRUE) {
uint64_t mask = LOCAL_Signals;
if (mask == 0)
return FALSE;
#if HAVE___BUILTIN_FFSLL
sig = __builtin_ffsll(mask);
#elif HAVE_FFSLL
sig = ffsll(mask);
#else
sig = Yap_msb(mask PASS_REGS) + 1;
#endif
if (get_signal(sig PASS_REGS)) {
break;
}
}
loop:
switch (sig) {
case YAP_INT_SIGNAL:
sig = ProcessSIGINT();
if (sig == YAP_INT_SIGNAL) {
at = AtomSigInt;
break;
}
if (sig != YAP_NO_SIGNAL)
goto loop;
return FALSE;
case YAP_ABORT_SIGNAL:
/* abort computation */
LOCAL_PrologMode &= ~AsyncIntMode;
if (LOCAL_PrologMode & (GCMode | ConsoleGetcMode | CritMode)) {
LOCAL_PrologMode |= AbortMode;
return -1;
} else {
Yap_Error(ABORT_EVENT, TermNil, "abort from console");
}
Yap_RestartYap(1);
return FALSE;
case YAP_CREEP_SIGNAL:
at = AtomSigCreep;
break;
case YAP_TRACE_SIGNAL:
at = AtomSigTrace;
break;
case YAP_DEBUG_SIGNAL:
at = AtomSigDebug;
break;
case YAP_BREAK_SIGNAL:
at = AtomSigBreak;
break;
case YAP_FAIL_SIGNAL:
at = AtomFail;
break;
case YAP_STACK_DUMP_SIGNAL:
at = AtomSigStackDump;
break;
case YAP_STATISTICS_SIGNAL:
at = AtomSigStatistics;
break;
#ifdef SIGALRM
case YAP_ALARM_SIGNAL:
#endif
case YAP_WINTIMER_SIGNAL:
at = AtomSigAlarm;
break;
#ifdef SIGVTALRM
case YAP_VTALARM_SIGNAL:
at = AtomSigVTAlarm;
break;
#endif
case YAP_EXIT_SIGNAL:
Yap_exit(1);
return FALSE;
case YAP_WAKEUP_SIGNAL:
at = AtomSigWakeUp;
break;
case YAP_ITI_SIGNAL:
at = AtomSigIti;
break;
#ifdef SIGPIPE
case YAP_PIPE_SIGNAL:
at = AtomSigPipe;
break;
#endif
#ifdef SIGHUP
case YAP_HUP_SIGNAL:
at = AtomSigHup;
break;
#endif
#ifdef SIGUSR1
case YAP_USR1_SIGNAL:
at = AtomSigUsr1;
break;
#endif
#ifdef SIGUSR2
case YAP_USR2_SIGNAL:
at = AtomSigUsr2;
break;
#endif
#ifdef SIGFPE
case YAP_FPE_SIGNAL:
at = AtomSigFPE;
break;
#endif
default:
return FALSE;
}
return Yap_unify(ARG1, MkAtomTerm(at));
}
static Int continue_signals(USES_REGS1) { return first_signal(PASS_REGS1); }
void Yap_InitSignalCPreds(void) {
/* Basic predicates for the debugger */
Yap_InitCPred("$creep", 0, p_creep, SafePredFlag);
Yap_InitCPred("$creep_fail", 0, p_creep_fail, SafePredFlag);
Yap_InitCPred("$stop_creeping", 1, stop_creeping,
NoTracePredFlag | HiddenPredFlag | SafePredFlag);
Yap_InitCPred("$disable_debugging", 0, disable_debugging,
NoTracePredFlag | HiddenPredFlag | SafePredFlag);
Yap_InitCPred("$first_signal", 1, first_signal, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$continue_signals", 0, continue_signals,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("creep_allowed", 0, creep_allowed, 0);
#ifdef DEBUG
Yap_InitCPred("sys_debug", 1, p_debug, SafePredFlag | SyncPredFlag);
#endif
}
void *Yap_InitSignals(int wid) {
void *ptr = (void *)malloc(sizeof(UInt) * REMOTE_MaxActiveSignals(wid));
return ptr;
}

421
dev/yap-6.3/C/sort.c Normal file
View File

@ -0,0 +1,421 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: sort.c *
* Last rev: *
* mods: *
* comments: sorting in Prolog *
* *
*************************************************************************/
/* for the moment, follow Prolog's traditional mergesort */
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#ifndef NULL
#define NULL (void *)0
#endif
/* fill in the even or the odd elements */
#define M_EVEN 0
#define M_ODD 1
static Int build_new_list(CELL *, Term CACHE_TYPE);
static void simple_mergesort(CELL *, Int, int);
static Int compact_mergesort(CELL *, Int, int);
static int key_mergesort(CELL *, Int, int, Functor);
static void adjust_vector(CELL *, Int);
static Int p_sort( USES_REGS1 );
static Int p_msort( USES_REGS1 );
static Int p_ksort( USES_REGS1 );
/* copy to a new list of terms */
static Int
build_new_list(CELL *pt, Term t USES_REGS)
{
Int out = 0;
if (IsVarTerm(t))
return(-1);
if (t == TermNil)
return(0);
restart:
while (IsPairTerm(t)) {
out++;
pt[0] = HeadOfTerm(t);
t = TailOfTerm(t);
if (IsVarTerm(t))
return(-1);
if (t == TermNil) {
return(out);
}
pt += 2;
if (pt > ASP - 4096) {
if (!Yap_gcl((ASP-HR)*sizeof(CELL), 2, ENV, gc_P(P,CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
pt = HR;
out = 0;
goto restart;
}
}
return(-1);
}
/* copy to a new list of terms */
static
void simple_mergesort(CELL *pt, Int size, int my_p)
{
if (size > 2) {
Int half_size = size / 2;
CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
int left_p, right_p;
pt_right = pt + half_size*2;
left_p = my_p^1;
right_p = my_p;
simple_mergesort(pt, half_size, left_p);
simple_mergesort(pt_right, size-half_size, right_p);
/* now implement a simple merge routine */
/* pointer to after the end of the list */
end_pt = pt + 2*size;
/* pointer to the element after the last element to the left */
end_pt_left = pt+half_size*2;
/* where is left list */
pt_left = pt+left_p;
/* where is right list */
pt_right += right_p;
/* where is new list */
pt += my_p;
/* while there are elements in the left or right vector do compares */
while (pt_left < end_pt_left && pt_right < end_pt) {
/* if the element to the left is larger than the one to the right */
if (Yap_compare_terms(pt_left[0], pt_right[0]) <= 0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
pt_left += 2;
} else {
/* otherwise, copy the one to the right */
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
/* if any elements were left in the left vector just copy them */
while (pt_left < end_pt_left) {
pt[0] = pt_left[0];
pt += 2;
pt_left += 2;
}
/* if any elements were left in the right vector
and they are in the wrong place, just copy them */
if (my_p != right_p) {
while(pt_right < end_pt) {
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
} else {
if (size > 1 && (Yap_compare_terms(pt[0],pt[2]) > 0)) {
CELL t = pt[2];
pt[2+my_p] = pt[0];
pt[my_p] = t;
} else if (my_p) {
pt[1] = pt[0];
if (size > 1)
pt[3] = pt[2];
}
}
}
/* copy to a new list of terms */
static
int key_mergesort(CELL *pt, Int size, int my_p, Functor FuncDMinus)
{
if (size > 2) {
Int half_size = size / 2;
CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
int left_p, right_p;
pt_right = pt + half_size*2;
left_p = my_p^1;
right_p = my_p;
if (!key_mergesort(pt, half_size, left_p, FuncDMinus))
return(FALSE);
if (!key_mergesort(pt_right, size-half_size, right_p, FuncDMinus))
return(FALSE);
/* now implement a simple merge routine */
/* pointer to after the end of the list */
end_pt = pt + 2*size;
/* pointer to the element after the last element to the left */
end_pt_left = pt+half_size*2;
/* where is left list */
pt_left = pt+left_p;
/* where is right list */
pt_right += right_p;
/* where is new list */
pt += my_p;
/* while there are elements in the left or right vector do compares */
while (pt_left < end_pt_left && pt_right < end_pt) {
/* if the element to the left is larger than the one to the right */
Term t0 = pt_left[0] , t1 = pt_right[0];
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
return(FALSE);
t0 = ArgOfTerm(1,t0);
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
return(FALSE);
t1 = ArgOfTerm(1,t1);
if (Yap_compare_terms(t0, t1) <= 0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
pt_left += 2;
} else {
/* otherwise, copy the one to the right */
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
/* if any elements were left in the left vector just copy them */
while (pt_left < end_pt_left) {
pt[0] = pt_left[0];
pt += 2;
pt_left += 2;
}
/* if any elements were left in the right vector
and they are in the wrong place, just copy them */
if (my_p != right_p) {
while(pt_right < end_pt) {
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
} else {
if (size > 1) {
Term t0 = pt[0], t1 = pt[2];
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
return(FALSE);
t0 = ArgOfTerm(1,t0);
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
return(FALSE);
t1 = ArgOfTerm(1,t1);
if (Yap_compare_terms(t0,t1) > 0) {
CELL t = pt[2];
pt[2+my_p] = pt[0];
pt[my_p] = t;
} else if (my_p) {
pt[1] = pt[0];
pt[3] = pt[2];
}
} else {
if (my_p)
pt[1] = pt[0];
}
}
return(TRUE);
}
/* copy to a new list of terms and compress duplicates */
static
Int compact_mergesort(CELL *pt, Int size, int my_p)
{
if (size > 2) {
Int half_size = size / 2;
CELL *pt_left, *pt_right, *end_pt_right, *end_pt_left;
int left_p, right_p;
Int lsize, rsize;
pt_right = pt + half_size*2;
left_p = my_p^1;
right_p = my_p;
lsize = compact_mergesort(pt, half_size, left_p);
rsize = compact_mergesort(pt_right, size-half_size, right_p);
/* now implement a simple merge routine */
/* where is left list */
pt_left = pt+left_p;
/* pointer to the element after the last element to the left */
end_pt_left = pt+2*lsize;
/* where is right list */
pt_right += right_p;
/* pointer to after the end of the list */
end_pt_right = pt_right + 2*rsize;
/* where is new list */
pt += my_p;
size = 0;
/* while there are elements in the left or right vector do compares */
while (pt_left < end_pt_left && pt_right < end_pt_right) {
/* if the element to the left is larger than the one to the right */
Int cmp = Yap_compare_terms(pt_left[0], pt_right[0]);
if (cmp < (Int)0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
size ++;
pt_left += 2;
} else if (cmp == (Int)0) {
/* otherwise, just skip one of them, anyone */
pt_left += 2;
} else {
/* otherwise, copy the one to the right */
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
size++;
}
}
/* if any elements were left in the left vector just copy them */
while (pt_left < end_pt_left) {
pt[0] = pt_left[0];
pt += 2;
pt_left += 2;
size++;
}
/* if any elements were left in the right vector
and they are in the wrong place, just copy them */
while(pt_right < end_pt_right) {
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
size++;
}
return(size);
} else if (size == 2) {
Int cmp = Yap_compare_terms(pt[0],pt[2]);
if (cmp > 0) {
/* swap */
CELL t = pt[2];
pt[2+my_p] = pt[0];
pt[my_p] = t;
return(2);
} else if (cmp == 0) {
if (my_p)
pt[1] = pt[0];
return(1);
} else {
if (my_p) {
pt[1] = pt[0];
pt[3] = pt[2];
}
return(2);
}
} else {
/* size = 1 */
if (my_p)
pt[1] = pt[0];
return(1);
}
}
static void
adjust_vector(CELL *pt, Int size)
{
/* the elements are where they should be */
CELL *ptf = pt + 2*(size-1);
pt ++;
while (pt < ptf) {
pt[0] = AbsPair(pt+1);
pt += 2;
}
/* close the list */
pt[0] = TermNil;
}
static Int
p_sort( USES_REGS1 )
{
/* use the heap to build a new list */
CELL *pt = HR;
Term out;
/* list size */
Int size;
size = build_new_list(pt, Deref(ARG1) PASS_REGS);
if (size < 0)
return(FALSE);
if (size < 2)
return(Yap_unify(ARG1, ARG2));
pt = HR; /* because of possible garbage collection */
/* make sure no one writes on our temp data structure */
HR += size*2;
/* reserve the necessary space */
size = compact_mergesort(pt, size, M_EVEN);
/* reajust space */
HR = pt+size*2;
adjust_vector(pt, size);
out = AbsPair(pt);
return(Yap_unify(out, ARG2));
}
static Int
p_msort( USES_REGS1 )
{
/* use the heap to build a new list */
CELL *pt = HR;
Term out;
/* list size */
Int size;
size = build_new_list(pt, Deref(ARG1) PASS_REGS);
if (size < 0)
return(FALSE);
if (size < 2)
return(Yap_unify(ARG1, ARG2));
pt = HR; /* because of possible garbage collection */
/* reserve the necessary space */
HR += size*2;
simple_mergesort(pt, size, M_EVEN);
adjust_vector(pt, size);
out = AbsPair(pt);
return(Yap_unify(out, ARG2));
}
static Int
p_ksort( USES_REGS1 )
{
/* use the heap to build a new list */
CELL *pt = HR;
Term out;
/* list size */
Int size;
size = build_new_list(pt, Deref(ARG1) PASS_REGS);
if (size < 0)
return(FALSE);
if (size < 2)
return(Yap_unify(ARG1, ARG2));
/* reserve the necessary space */
pt = HR; /* because of possible garbage collection */
HR += size*2;
if (!key_mergesort(pt, size, M_EVEN, FunctorMinus))
return(FALSE);
adjust_vector(pt, size);
out = AbsPair(pt);
return(Yap_unify(out, ARG2));
}
void
Yap_InitSortPreds(void)
{
Yap_InitCPred("$sort", 2, p_sort, 0);
Yap_InitCPred("$msort", 2, p_msort, 0);
Yap_InitCPred("$keysort", 2, p_ksort, 0);
}

2023
dev/yap-6.3/C/stack.c Normal file
View File

File diff suppressed because it is too large Load Diff

1159
dev/yap-6.3/C/stackinfo.c Normal file
View File

File diff suppressed because it is too large Load Diff

1620
dev/yap-6.3/C/stdpreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

1427
dev/yap-6.3/C/text.c Normal file
View File

File diff suppressed because it is too large Load Diff

1853
dev/yap-6.3/C/threads.c Normal file
View File

File diff suppressed because it is too large Load Diff

14572
dev/yap-6.3/C/traced_absmi_insts.h Normal file
View File

File diff suppressed because it is too large Load Diff

517
dev/yap-6.3/C/tracer.c Normal file
View File

@ -0,0 +1,517 @@
/*************************************************************************
* *
* YAP Prolog @(#)amidefs.h 1.3 3/15/90
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: tracer.h *
* Last rev: *
* mods: *
* comments: definitions for low level tracer *
* *
*************************************************************************/
#include "Yap.h"
#ifdef LOW_LEVEL_TRACER
#include "Yatom.h"
#include "YapHeap.h"
#include "attvar.h"
#include "yapio.h"
#include "clause.h"
#include "tracer.h"
static void send_tracer_message(char *start, char *name, Int arity, char *mname,
CELL *args) {
if (name == NULL) {
#ifdef YAPOR
fprintf(stderr, "(%d)%s", worker_id, start);
#else
fprintf(stderr, "%s", start);
#endif
} else {
int i;
if (arity) {
if (args)
fprintf(stderr, "%s %s:%s(", start, mname, name);
else
fprintf(stderr, "%s %s:%s/%lu", start, mname, name,
(unsigned long int)arity);
} else {
fprintf(stderr, "%s %s:%s", start, mname, name);
}
if (args) {
for (i = 0; i < arity; i++) {
if (i > 0)
fprintf(stderr, ",");
Yap_plwrite(args[i], NULL, 15, Handle_vars_f | AttVar_Portray_f,
GLOBAL_MaxPriority);
}
if (arity) {
fprintf(stderr, ")");
}
}
}
fprintf(stderr, "\n");
}
#if defined(__GNUC__)
unsigned long long vsc_count;
#else
unsigned long vsc_count;
#endif
#if THREADS
static int thread_trace;
#endif
/*
static int
check_trail_consistency(void) {
tr_fr_ptr ptr = TR;
while (ptr > (CELL *)LOCAL_TrailBase) {
ptr = --ptr;
if (!IsVarTerm(TrailTerm(ptr))) {
if (IsApplTerm(TrailTerm(ptr))) {
CELL *cptr = (CELL *)ptr;
ptr = (tr_fr_ptr)(cptr-1);
} else {
if (IsPairTerm(TrailTerm(ptr))) {
CELL *p = RepPair(TrailTerm(ptr));
if IsAttVar(p) continue;
}
printf("Oops at call %ld, B->cp(%p) TR(%p) pt(%p)\n",
vsc_count,B->cp_tr, TR, ptr);
return(FALSE);
}
}
}
return(TRUE);
}
*/
volatile int v;
CELL old_value = 0L, old_value2 = 0L;
void jmp_deb(int), jmp_deb2(void);
void jmp_deb2(void) { fprintf(stderr, "Here\n"); }
void jmp_deb(int i) {
if (i)
printf("Here we go %ld\n", old_value++);
if (old_value == 716)
jmp_deb2();
}
struct various_codes *sc;
/*
CELL array[332];
int found = FALSE;
static void
check_area(void)
{
int i, first = -1;
for (i= 0; i < 332; i++) {
if (array[i] !=((CELL *)0x187a800)[i]) {
if (first != -1) {
first = i;
found = TRUE;
}
fprintf(stderr,"%lld changed %d\n",vsc_count,i);
}
array[i] = ((CELL *)0x187a800)[i];
}
if (first != -1)
jmp_deb(i);
}
*/
//PredEntry *old_p[10000];
//Term old_x1[10000], old_x2[10000], old_x3[10000];
// static CELL oldv;
void low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) {
CACHE_REGS
char *s;
char *mname;
Int arity;
/* extern int gc_calls; */
vsc_count++;
// if (HR < ASP ) return;
// fif (vsc_count == 12534) jmp_deb( 2 );
#if __ANDROID__ && 0
PredEntry *ap = pred;
if (pred && port == enter_pred) {
UInt flags = ap->PredFlags;
if (ap->ArityOfPE && ap->ModuleOfPred != IDB_MODULE)
__android_log_print(ANDROID_LOG_INFO, "YAP ", " %s/%ld %lx\n",
NameOfFunctor(ap->FunctorOfPred)->StrOfAE,
ap->ArityOfPE, flags);
/* printf(" %s/%ld %lx\n", NameOfFunctor(ap->FunctorOfPred)->StrOfAE,
* ap->ArityOfPE, flags); */
else if (ap->ModuleOfPred != IDB_MODULE)
__android_log_print(ANDROID_LOG_INFO, "YAP ", " %s/%ld %lx\n",
((Atom)(ap->FunctorOfPred))->StrOfAE, ap->ArityOfPE,
flags);
/* printf(" %s/%ld %lx\n", ((Atom)(ap->FunctorOfPred))->StrOfAE,
* ap->ArityOfPE, flags); */
__android_log_print(ANDROID_LOG_INFO, "YAP ", " %x ", ap->src.OwnerFile);
}
return;
#endif
// if (!worker_id) return;
LOCK(Yap_low_level_trace_lock);
sc = Yap_heap_regs;
// if (vsc_count == 161862) jmp_deb(1);
#ifdef THREADS
LOCAL_ThreadHandle.thread_inst_count++;
#endif
#ifdef COMMENTED
fprintf(stderr, "in %p\n");
CELL *gc_ENV = ENV;
while (gc_ENV != NULL) { /* no more environments */
fprintf(stderr, "%ld\n", LCL0 - gc_ENV);
gc_ENV = (CELL *)gc_ENV[E_E]; /* link to prev
* environment */
}
return;
{
choiceptr b_p = B;
while (b_p) {
fprintf(stderr, "%p %ld\n", b_p, Yap_op_from_opcode(b_p->cp_ap->opc));
b_p = b_p->cp_b;
}
}
{
choiceptr myB = B;
while (myB)
myB = myB->cp_b;
}
//*(H0+(0xb65f2850-0xb64b2008)/sizeof(CELL))==0xc ||
// 0x4fd4d
if (vsc_count > 1388060LL && vsc_count < 1388070LL) {
if (vsc_count == 1388061LL)
jmp_deb(1);
if (vsc_count % 1LL == 0) {
UInt sz = Yap_regp->H0_[17];
UInt end = sizeof(MP_INT) / sizeof(CELL) + sz + 1;
fprintf(stderr, "VAL %lld %d %x/%x\n", vsc_count, sz, H0[16],
H0[16 + end]);
}
} else
return;
{
tr_fr_ptr pt = (tr_fr_ptr)LOCAL_TrailBase;
if (pt[140].term == 0 && pt[140].value != 0)
jmp_deb(1);
}
if (worker_id != 04 || worker_id != 03)
return;
// if (vsc_count == 218280)
// vsc_xstop = 1;
if (vsc_count < 1468068888) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (port != enter_pred || !pred || pred->ArityOfPE != 4 ||
strcmp(RepAtom(NameOfFunctor(pred->FunctorOfPred))->StrOfAE,
"in_between_target_phrases")) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (vsc_count < 1246949400LL) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (vsc_count == 1246949493LL)
vsc_xstop = TRUE;
if (vsc_count < 5646100000LL) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (vsc_count == 5646100441LL)
vsc_xstop = TRUE;
if (vsc_count < 2923351500LL) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (vsc_count == 123536441LL)
vsc_xstop = 1;
if (vsc_count < 5530257LL) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (vsc_count == 9414280LL) {
vsc_xstop = TRUE;
}
if (vsc_count < 3399741LL) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (TR_FZ > TR)
jmp_deb(1);
{
tr_fr_ptr pt = (tr_fr_ptr)LOCAL_TrailBase;
if (pt[153].term == 0 && pt[153].value == 0 && pt[154].term != 0 &&
pt[154].value != 0 && (TR > pt + 154 || TR_FZ > pt + 154))
jmp_deb(2);
if (pt[635].term == 0 && pt[635].value == 0 && pt[636].term != 0 &&
pt[636].value != 0 && (TR > pt + 636 || TR_FZ > pt + 636))
jmp_deb(3);
if (pt[138].term == 0 && pt[138].value == 0 && pt[139].term != 0 &&
pt[139].value != 0 && (TR > pt + 138 || TR_FZ > pt + 138))
jmp_deb(4);
}
if (vsc_count == 287939LL)
jmp_deb(1);
if (vsc_count == 173118LL)
jmp_deb(1);
if (!(vsc_count >= 287934LL && vsc_count <= 287939LL) &&
!(vsc_count >= 173100LL && vsc_count <= 173239LL) && vsc_count != -1)
return;
if (vsc_count == 51021) {
printf("Here I go\n");
}
if (vsc_count < 52000) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (vsc_count > 52000)
exit(0);
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
if (vsc_count == 837074) {
printf("Here I go\n");
}
if (gc_calls < 1) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
{
CELL *env_ptr = ENV;
PredEntry *p;
while (env_ptr) {
PredEntry *pe = EnvPreg(env_ptr[E_CP]);
printf("%p->", env_ptr, pe);
if (vsc_count == 52LL)
printf("\n");
if (p == pe) {
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
}
if (env_ptr != NULL)
env_ptr = (CELL *)(env_ptr[E_E]);
}
printf("\n");
}
#endif
fprintf(stderr, "%lld %ld ", vsc_count, LCL0 - (CELL *)B);
#if defined(THREADS) || defined(YAPOR)
fprintf(stderr, "(%d)", worker_id);
#endif
/* check_trail_consistency(); */
if (pred == NULL) {
UNLOCK(Yap_low_level_trace_lock);
return;
}
if (pred->ModuleOfPred == PROLOG_MODULE) {
if (!LOCAL_do_trace_primitives) {
UNLOCK(Yap_low_level_trace_lock);
return;
}
mname = "prolog";
} else {
mname = RepAtom(AtomOfTerm(Yap_Module_Name(pred)))->StrOfAE;
}
switch (port) {
case enter_pred:
arity = pred->ArityOfPE;
if (arity == 0) {
s = (char *)RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
} else {
s = (char *)RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
}
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("CALL: ", s, arity, mname, args);
break;
case try_or:
send_tracer_message("TRY_OR ", NULL, 0, NULL, args);
break;
case retry_or:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
send_tracer_message("RETRY_OR ", NULL, 0, NULL, args);
break;
case retry_table_generator:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
mname = (char *)RepAtom(AtomOfTerm(Yap_Module_Name(pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0)
s = (char *)RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
s = (char *)RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
send_tracer_message("RETRY GENERATOR: ", s, arity, mname, args);
break;
case retry_table_consumer:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
mname = (char *)RepAtom(AtomOfTerm(Yap_Module_Name(pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0) {
s = (char *)RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
send_tracer_message("RETRY CONSUMER: ", s, 0, mname, NULL);
} else {
s = (char *)RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
send_tracer_message("RETRY CONSUMER: ", s, pred->ArityOfPE, mname, NULL);
}
break;
case retry_table_loader:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
if (pred == UndefCode) {
send_tracer_message("RETRY LOADER ", NULL, 0, NULL, NULL);
} else {
mname = (char *)RepAtom(AtomOfTerm(Yap_Module_Name(pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0)
s = (char *)RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
s = (char *)RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
send_tracer_message("RETRY LOADER: ", s, 0, mname, NULL);
}
break;
case retry_pred:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
if (pred != NULL) {
mname = (char *)RepAtom(AtomOfTerm(Yap_Module_Name(pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (pred->ModuleOfPred == IDB_MODULE) {
s = "recorded";
arity = 3;
} else if (arity == 0) {
s = (char *)RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
} else {
s = (char *)RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
}
send_tracer_message("RETRY: ", s, arity, mname, args);
}
break;
}
fflush(NULL);
UNLOCK(Yap_low_level_trace_lock);
}
void toggle_low_level_trace(void) {
Yap_do_low_level_trace = !Yap_do_low_level_trace;
}
static Int start_low_level_trace(USES_REGS1) {
Yap_do_low_level_trace = TRUE;
return (TRUE);
}
static Int total_choicepoints(USES_REGS1) {
return Yap_unify(MkIntegerTerm(LOCAL_total_choicepoints), ARG1);
}
static Int reset_total_choicepoints(USES_REGS1) {
LOCAL_total_choicepoints = 0;
return TRUE;
}
static Int show_low_level_trace(USES_REGS1) {
fprintf(stderr, "Call counter=%lld\n", vsc_count);
return (TRUE);
}
#ifdef THREADS
static Int start_low_level_trace2(USES_REGS1) {
thread_trace = IntegerOfTerm(Deref(ARG1)) + 1;
Yap_do_low_level_trace = TRUE;
return (TRUE);
}
#endif
#include <stdio.h>
/** @pred stop_low_level_trace
Stop displaying messages at procedure entry and retry.
Note that using this compile-time option will slow down execution, even if
messages are
not being output.
*/
static Int stop_low_level_trace(USES_REGS1) {
Yap_do_low_level_trace = FALSE;
LOCAL_do_trace_primitives = TRUE;
#if DEBUG_LOCKS
debug_locks = TRUE;
#endif
return (TRUE);
}
volatile int v_wait;
static Int vsc_wait(USES_REGS1) {
while (!v_wait)
;
return true;
}
static Int vsc_go(USES_REGS1) {
v_wait = 1;
return true;
}
void Yap_InitLowLevelTrace(void) {
Yap_InitCPred("start_low_level_trace", 0, start_low_level_trace,
SafePredFlag);
Yap_InitCPred("$start_low_level_trace", 0, start_low_level_trace,
SafePredFlag);
/** @pred start_low_level_trace
Begin display of messages at procedure entry and retry.
*/
#if THREADS
Yap_InitCPred("start_low_level_trace", 1, start_low_level_trace2,
SafePredFlag);
#endif
Yap_InitCPred("stop_low_level_trace", 0, stop_low_level_trace, SafePredFlag);
Yap_InitCPred("show_low_level_trace", 0, show_low_level_trace, SafePredFlag);
Yap_InitCPred("$stop_low_level_trace", 0, stop_low_level_trace, SafePredFlag);
Yap_InitCPred("total_choicepoints", 1, total_choicepoints, SafePredFlag);
Yap_InitCPred("reset_total_choicepoints", 0, reset_total_choicepoints,
SafePredFlag);
Yap_InitCPred("vsc_wait", 0, vsc_wait, SafePredFlag);
Yap_InitCPred("vsc_go", 0, vsc_go, SafePredFlag);
}
#else
static null(USES_REGS1) { return true; }
void Yap_InitLowLevelTrace(void) {
Yap_InitCPred("$start_low_level_trace", 0, null,
SafePredFlag | HiddenPredFlag);
Yap_InitCPred("$stop_low_level_trace", 0, null,
SafePredFlag | HiddenPredFlag);
}
#endif

551
dev/yap-6.3/C/type_absmi_insts.h Normal file
View File

@ -0,0 +1,551 @@
#if 0
{
{
#endif
/************************************************************************ \
* Basic Primitive Predicates *
\************************************************************************/
Op(p_atom_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, atom_x_unk);
atom_x_nvar:
if (IsAtomTerm(d0) && !IsBlob(AtomOfTerm(d0))) {
PREG = NEXTOP(PREG, xl);
GONext();
}
else {
PREG = PREG->y_u.xl.F;
GONext();
}
BEGP(pt0);
deref_body(d0, pt0, atom_x_unk, atom_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_atom_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, atom_y_unk);
atom_y_nvar:
if (IsAtomTerm(d0) && !IsBlob(AtomOfTerm(d0))) {
PREG = NEXTOP(PREG, yl);
GONext();
}
else {
PREG = PREG->y_u.yl.F;
GONext();
}
derefa_body(d0, pt0, atom_y_unk, atom_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_atomic_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, atomic_x_unk);
atomic_x_nvar:
/* non variable */
if (IsAtomicTerm(d0)) {
PREG = NEXTOP(PREG, xl);
GONext();
}
else {
PREG = PREG->y_u.xl.F;
GONext();
}
BEGP(pt0);
deref_body(d0, pt0, atomic_x_unk, atomic_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_atomic_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, atomic_y_unk);
atomic_y_nvar:
/* non variable */
if (IsAtomicTerm(d0)) {
PREG = NEXTOP(PREG, yl);
GONext();
}
else {
PREG = PREG->y_u.yl.F;
GONext();
}
derefa_body(d0, pt0, atomic_y_unk, atomic_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_integer_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, integer_x_unk);
integer_x_nvar:
/* non variable */
if (IsIntTerm(d0)) {
PREG = NEXTOP(PREG, xl);
GONext();
}
if (IsApplTerm(d0)) {
Functor f0 = FunctorOfTerm(d0);
if (IsExtensionFunctor(f0)) {
switch ((CELL)f0) {
case (CELL)FunctorBigInt:
{ CELL *pt = RepAppl(d0);
if ( pt[1] != BIG_INT ) {
PREG = PREG->y_u.xl.F;
GONext();
}
}
PREG = NEXTOP(PREG, xl);
GONext();
break;
case (CELL)FunctorLongInt:
PREG = NEXTOP(PREG, xl);
GONext();
break;
default:
PREG = PREG->y_u.xl.F;
GONext();
}
}
}
PREG = PREG->y_u.xl.F;
GONext();
BEGP(pt0);
deref_body(d0, pt0, integer_x_unk, integer_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_integer_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, integer_y_unk);
integer_y_nvar:
/* non variable */
if (IsIntTerm(d0)) {
PREG = NEXTOP(PREG, yl);
GONext();
}
if (IsApplTerm(d0)) {
Functor f0 = FunctorOfTerm(d0);
if (IsExtensionFunctor(f0)) {
switch ((CELL)f0) {
case (CELL)FunctorBigInt:
{ CELL *pt = RepAppl(d0);
if ( pt[1] != BIG_INT ) {
PREG = PREG->y_u.yl.F;
GONext();
}
}
PREG = NEXTOP(PREG, yl);
GONext();
break;
case (CELL)FunctorLongInt:
PREG = NEXTOP(PREG, yl);
GONext();
break;
default:
PREG = PREG->y_u.yl.F;
GONext();
}
}
}
PREG = PREG->y_u.yl.F;
GONext();
derefa_body(d0, pt0, integer_y_unk, integer_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_nonvar_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, nonvar_x_unk);
nonvar_x_nvar:
PREG = NEXTOP(PREG, xl);
GONext();
BEGP(pt0);
deref_body(d0, pt0, nonvar_x_unk, nonvar_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_nonvar_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, nonvar_y_unk);
nonvar_y_nvar:
PREG = NEXTOP(PREG, yl);
GONext();
derefa_body(d0, pt0, nonvar_y_unk, nonvar_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_number_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, number_x_unk);
number_x_nvar:
/* non variable */
if (IsIntTerm(d0)) {
PREG = NEXTOP(PREG, xl);
GONext();
}
if (IsApplTerm(d0)) {
Functor f0 = FunctorOfTerm(d0);
if (IsExtensionFunctor(f0)) {
switch ((CELL)f0) {
case (CELL)FunctorBigInt:
{ CELL *pt = RepAppl(d0);
if ( pt[1] != BIG_RATIONAL || pt[1] != BIG_INT ) {
PREG = PREG->y_u.xl.F;
GONext();
}
}
case (CELL)FunctorLongInt:
case (CELL)FunctorDouble:
PREG = NEXTOP(PREG, xl);
GONext();
break;
default:
PREG = PREG->y_u.xl.F;
GONext();
}
}
}
PREG = PREG->y_u.xl.F;
GONext();
BEGP(pt0);
deref_body(d0, pt0, number_x_unk, number_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_number_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, number_y_unk);
number_y_nvar:
/* non variable */
/* non variable */
if (IsIntTerm(d0)) {
PREG = NEXTOP(PREG, xl);
GONext();
}
if (IsApplTerm(d0)) {
Functor f0 = FunctorOfTerm(d0);
if (IsExtensionFunctor(f0)) {
switch ((CELL)f0) {
case (CELL)FunctorBigInt:
{ CELL *pt = RepAppl(d0);
if ( pt[1] != BIG_RATIONAL || pt[1] != BIG_INT ) {
PREG = PREG->y_u.yl.F;
GONext();
}
}
break;
case (CELL)FunctorLongInt:
case (CELL)FunctorDouble:
PREG = NEXTOP(PREG, yl);
GONext();
break;
default:
PREG = PREG->y_u.yl.F;
GONext();
}
}
}
PREG = PREG->y_u.yl.F;
GONext();
derefa_body(d0, pt0, number_y_unk, number_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_var_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, var_x_unk);
var_x_nvar:
/* non variable */
PREG = PREG->y_u.xl.F;
GONext();
BEGP(pt0);
deref_body(d0, pt0, var_x_unk, var_x_nvar);
PREG = NEXTOP(PREG, xl);
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_var_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, var_y_unk);
var_y_nvar:
/* non variable */
PREG = PREG->y_u.yl.F;
GONext();
derefa_body(d0, pt0, var_y_unk, var_y_nvar);
PREG = NEXTOP(PREG, yl);
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_db_ref_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, dbref_x_unk);
dbref_x_nvar:
/* non variable */
if (IsDBRefTerm(d0)) {
/* only allow references to the database, not general references
* to go through. */
PREG = NEXTOP(PREG, xl);
GONext();
}
else {
PREG = PREG->y_u.xl.F;
GONext();
}
BEGP(pt0);
deref_body(d0, pt0, dbref_x_unk, dbref_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_db_ref_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, dbref_y_unk);
dbref_y_nvar:
/* non variable */
if (IsDBRefTerm(d0)) {
/* only allow references to the database, not general references
* to go through. */
PREG = NEXTOP(PREG, yl);
GONext();
}
else {
PREG = PREG->y_u.yl.F;
GONext();
}
derefa_body(d0, pt0, dbref_y_unk, dbref_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_primitive_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, primi_x_unk);
primi_x_nvar:
/* non variable */
if (IsPrimitiveTerm(d0)) {
PREG = NEXTOP(PREG, xl);
GONext();
}
else {
PREG = PREG->y_u.xl.F;
GONext();
}
BEGP(pt0);
deref_body(d0, pt0, primi_x_unk, primi_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_primitive_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, primi_y_unk);
primi_y_nvar:
/* non variable */
if (IsPrimitiveTerm(d0)) {
PREG = NEXTOP(PREG, yl);
GONext();
}
else {
PREG = PREG->y_u.yl.F;
GONext();
}
derefa_body(d0, pt0, primi_y_unk, primi_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_compound_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, compound_x_unk);
compound_x_nvar:
/* non variable */
if (IsPairTerm(d0)) {
PREG = NEXTOP(PREG, xl);
GONext();
}
else if (IsApplTerm(d0)) {
if (IsExtensionFunctor(FunctorOfTerm(d0))) {
PREG = PREG->y_u.xl.F;
GONext();
}
PREG = NEXTOP(PREG, xl);
GONext();
}
else {
PREG = PREG->y_u.xl.F;
GONext();
}
BEGP(pt0);
deref_body(d0, pt0, compound_x_unk, compound_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_compound_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, compound_y_unk);
compound_y_nvar:
/* non variable */
if (IsPairTerm(d0)) {
PREG = NEXTOP(PREG, yl);
GONext();
}
else if (IsApplTerm(d0)) {
if (IsExtensionFunctor(FunctorOfTerm(d0))) {
PREG = PREG->y_u.yl.F;
GONext();
}
PREG = NEXTOP(PREG, yl);
GONext();
}
else {
PREG = PREG->y_u.yl.F;
GONext();
}
derefa_body(d0, pt0, compound_y_unk, compound_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_float_x, xl);
BEGD(d0);
d0 = XREG(PREG->y_u.xl.x);
deref_head(d0, float_x_unk);
float_x_nvar:
/* non variable */
if (IsFloatTerm(d0)) {
PREG = NEXTOP(PREG, xl);
GONext();
}
PREG = PREG->y_u.xl.F;
GONext();
BEGP(pt0);
deref_body(d0, pt0, float_x_unk, float_x_nvar);
PREG = PREG->y_u.xl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(p_float_y, yl);
BEGD(d0);
BEGP(pt0);
pt0 = YREG + PREG->y_u.yl.y;
d0 = *pt0;
deref_head(d0, float_y_unk);
float_y_nvar:
/* non variable */
if (IsFloatTerm(d0)) {
PREG = NEXTOP(PREG, yl);
GONext();
}
PREG = PREG->y_u.yl.F;
GONext();
derefa_body(d0, pt0, float_y_unk, float_y_nvar);
PREG = PREG->y_u.yl.F;
GONext();
ENDP(pt0);
ENDD(d0);
ENDOp();

255
dev/yap-6.3/C/udi.c Normal file
View File

@ -0,0 +1,255 @@
#include <stdio.h>
#include <assert.h>
#include "Yap.h"
#include "YapInterface.h"
#include "clause.h"
#include "udi_private.h"
/* to keep an array with the registered udi indexers */
UT_icd udicb_icd = {sizeof(UdiControlBlock), NULL, NULL, NULL};
UT_array *indexing_structures;
/*
* Register a new user indexer
*/
void
Yap_UdiRegister(UdiControlBlock cb){
/*TODO: check structure integrity and duplicates */
utarray_push_back(indexing_structures, &cb);
}
/*
* New user indexed predicate:
* the first argument is the term.
*/
static YAP_Int
p_new_udi( USES_REGS1 )
{
Term spec = Deref(ARG1);
PredEntry *p;
UdiInfo blk;
int info;
/* get the predicate from the spec, copied from cdmgr.c */
if (IsVarTerm(spec)) {
Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1");
return FALSE;
} else if (!IsApplTerm(spec)) {
Yap_Error(TYPE_ERROR_COMPOUND,spec,"new user index/1");
return FALSE;
} else {
Functor fun = FunctorOfTerm(spec);
Term tmod = CurrentModule;
while (fun == FunctorModule) {
tmod = ArgOfTerm(1,spec);
if (IsVarTerm(tmod) ) {
Yap_Error(INSTANTIATION_ERROR, spec, "new user index/1");
return FALSE;
}
if (!IsAtomTerm(tmod) ) {
Yap_Error(TYPE_ERROR_ATOM, spec, "new user index/1");
return FALSE;
}
spec = ArgOfTerm(2, spec);
fun = FunctorOfTerm(spec);
}
p = RepPredProp(PredPropByFunc(fun, tmod));
}
if (!p)
return FALSE;
/* boring, boring, boring! */
if ((p->PredFlags
& (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag))
|| (p->ModuleOfPred == PROLOG_MODULE)) {
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, spec, "udi/2");
return FALSE;
}
if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|TabledPredFlag)) {
Yap_Error(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, spec, "udi/2");
return FALSE;
}
/* TODO: remove AtomRTree from atom list */
/* this is the real work */
blk = (UdiInfo) Yap_AllocCodeSpace(sizeof(struct udi_info));
memset((void *) blk,0, sizeof(struct udi_info));
if (!blk) {
Yap_Error(RESOURCE_ERROR_HEAP, spec, "new user index/1");
return FALSE;
}
/*Init UdiInfo */
utarray_new(blk->args, &arg_icd);
utarray_new(blk->clauselist, &cl_icd);
blk->p = p;
/*Now Init args list*/
info = p_udi_args_init(spec, p->ArityOfPE, blk);
if (!info)
{
utarray_free(blk->args);
utarray_free(blk->clauselist);
Yap_FreeCodeSpace((char *) blk);
return FALSE;
}
/*Push into the hash*/
HASH_ADD_UdiInfo(UdiControlBlocks, p, blk);
p->PredFlags |= UDIPredFlag;
return TRUE;
}
/*
* Here we initialize the arguments indexing
*/
YAP_Int
p_udi_args_init(Term spec, int arity, UdiInfo blk)
{
int i;
Term arg;
Atom idxtype;
UdiControlBlock *cb;
struct udi_p_args p_arg;
for (i = 1; i <= arity; i++) {
arg = ArgOfTerm(i,spec);
if (IsAtomTerm(arg)) {
idxtype = AtomOfTerm(arg);
if (idxtype == AtomMinus) //skip this argument
continue;
p_arg.control = NULL;
cb = NULL;
while ((cb = (UdiControlBlock *) utarray_next(indexing_structures, cb))) {
if (idxtype == (*cb)->decl){
p_arg.arg = i;
p_arg.control = *cb;
p_arg.idxstr = (*cb)->init(spec, i, arity);
utarray_push_back(blk->args, &p_arg);
}
}
if (p_arg.control == NULL){ /* not "-" and not found */
fprintf(stderr, "Invalid Spec (%s)\n", AtomName(idxtype));
return FALSE;
}
}
}
return TRUE;
}
/*
* From now on this is called in several places of yap
* when the predicate has the UDIPredFlag
* and is what actually triggers the insert/search/abolish of indexing structures
*/
/*
* Init Yap udi interface
*/
void
Yap_udi_init(void)
{
UdiControlBlocks = NULL;
/*init indexing structures array*/
utarray_new(indexing_structures, &udicb_icd);
Yap_InitCPred("$udi_init", 1, p_new_udi, 0);
/* TODO: decide if udi.yap should be loaded automaticaly in init.yap */
}
/* called from cdmgr.c
*
* for each assert of a udipredicate
* to pass info to user structure
*/
int
Yap_new_udi_clause(PredEntry *p, yamop *cl, Term t)
{
int i;
UdiPArg parg;
UdiInfo info;
YAP_Int index;
/* try to find our structure */
HASH_FIND_UdiInfo(UdiControlBlocks,p,info);
if (!info)
return FALSE;
/* insert into clauselist */
utarray_push_back(info->clauselist, &cl);
for (i = 0; i < utarray_len(info->args) ; i++) {
parg = (UdiPArg) utarray_eltptr(info->args,i);
index = (YAP_Int) utarray_len(info->clauselist);
parg->idxstr = parg->control->insert(parg->idxstr, t,
parg->arg,
(void *) index);
}
return TRUE;
}
/* index, called from absmi.c
*
* Returns:
* NULL (yap fallback) No usable indexing available
*
* Yap_FAILCODE() (fail) No result found
* Yap_CauseListToClause(cl) 1 solution found
* Yap_ClauseListCode(cl) 2+ solutions found
*/
yamop *
Yap_udi_search(PredEntry *p)
{
int r;
struct ClauseList clauselist;
UdiPArg parg;
UdiInfo info;
/* find our structure*/
HASH_FIND_UdiInfo(UdiControlBlocks,p,info);
if (!info || utarray_len(info->args) == 0)
return NULL;
if (utarray_len(info->args) == 1){ //simple case no intersection needed
struct si_callback_h c;
c.cl = Yap_ClauseListInit(&clauselist);
c.clauselist = info->clauselist;
c.pred = info->p;
if (!c.cl)
return NULL;
parg = (UdiPArg) utarray_eltptr(info->args,0);
r = parg->control->search(parg->idxstr, parg->arg, si_callback, (void *) &c);
Yap_ClauseListClose(c.cl);
if (r == -1) {
Yap_ClauseListDestroy(c.cl);
return NULL;
}
if (Yap_ClauseListCount(c.cl) == 0) {
Yap_ClauseListDestroy(c.cl);
return Yap_FAILCODE();
}
#if 0
} else {//intersection needed using Judy
Yap_udi_join( &clauselist, parg, info );
#endif
}
if (Yap_ClauseListCount(&clauselist) == 1)
return Yap_ClauseListToClause(&clauselist);
return Yap_ClauseListCode(&clauselist);
}
/* index, called from absmi.c */
void
Yap_udi_abolish(PredEntry *p)
{
/* tell the predicate destroy */
}

1064
dev/yap-6.3/C/unify.c Normal file
View File

File diff suppressed because it is too large Load Diff

3583
dev/yap-6.3/C/unify_absmi_insts.h Normal file
View File

File diff suppressed because it is too large Load Diff

698
dev/yap-6.3/C/userpreds.c Normal file
View File

@ -0,0 +1,698 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: userpreds.c *
* Last rev: *
* mods: *
* comments: an entry for user defined predicates *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This file is an entry for user defined C-predicates.
*
* There are two sorts of C-Predicates: deterministic - which should be defined
* in the function InitUserCPreds().
*
* backtrackable - they include a start and a continuation function, the first
* one called by the first invocation, the last one called after a fail. This
* can be seen as: pred :- init ; repeat, cont. These predicates should be
* defined in the function InitUserBacks()
*
* These two functions are called after any "restore" operation.
*
* The function InitUserExtensions() is called once, when starting the execution
* of the program, and should be used to initialize any user-defined
* extensions (like the execution environment or interfaces to other
* programs).
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#if EUROTRA
#include "yapio.h"
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#endif
/* You should include here the prototypes for all static functions */
#ifdef EUROTRA
static int p_clean(void);
static int p_namelength(void);
static int p_getpid(void);
static int p_exit(void);
static int p_incrcounter(void);
static int p_setcounter(void);
static int p_trapsignal(void);
static int subsumes(Term, Term);
static int p_subsumes(void);
static int p_grab_tokens(void);
#endif
#ifdef MACYAP
static typedef int (*SignalProc)();
static SignalProc skel_signal(int, SignalProc);
static int chdir(char *);
#endif
#ifdef SFUNC
static int p_softfunctor(void);
#endif /* SFUNC */
#ifdef USERPREDS
/* These are some examples of user-defined functions */
/*
* unify(A,B) --> unification with occurs-check it uses the functions
* full_unification and occurs_in
*
* occurs_check(V,S) :- var(S), !, S \== V. occurs_check(V,S) :- primitive(S),
* !. occurs_check(V,[H|T]) :- !, occurs_check(V,H), occurs_check(V,T).
* occurs_check(V,St) :- functor(T,_,N), occurs_check_struct(N,V,St).
*
* occurs_check_struct(1,V,T) :- !, arg(1,T,A), occurs_check(V,A).
* occurs_check_struct(N,V,T) :- N1 is N-1, occurs_check_structure(N1,V,T),
* arg(N,T,A), occurs_check(V,A).
*
* unify(X,Y) :- var(X), var(Y), !, X = Y. unify(X,Y) :- var(X), !,
* occurs_check(X,Y), X = Y. unify(X,Y) :- var(Y), !, occurs_check(Y,X), X =
* Y. unify([H0|T0],[H1|T1]) :- !, unify(H0,H1), unify(T0,T1). unify(X,Y) :-
* functor(X,A,N), functor(Y,A,N), unify_structs(N,X,Y).
*
* unify_structs(1,X,Y) :- !, arg(1,X,A), arg(1,Y,B), unify(A,B).
* unify_structs(N,Y,Z) :- N1 is N-1, unify_structs(N1,X,Y), arg(N,X,A),
* arg(N,Y,B), unify(A,B).
*/
/* occurs-in --> checks if the variable V occurs in term S */
static int occurs_check(V, T) Term V, T;
{
/* V and S are always derefed */
if (IsVarTerm(T)) {
return (V != T);
} else if (IsPrimitiveTerm(T)) {
return (TRUE);
} else if (IsPairTerm(T)) {
return (occurs_check(V, HeadOfTerm(T)) && occurs_check(V, TailOfTerm(T)));
} else if (IsApplTerm(T)) {
unsigned int i;
unsigned int arity = ArityOfFunctor(FunctorOfTerm(T));
for (i = 1; i <= arity; ++i)
if (!occurs_check(V, ArgOfTerm(i, T)))
return (FALSE);
return (TRUE);
}
return (FALSE);
}
/*
If you worry about coroutining the routine must receive the
arguments before dereferencing, otherwise unify() won't be
to wake possible bound variables
*/
static int full_unification(T1, T2) Term T1, T2;
{
Term t1 = Deref(T1);
Term t2 = Deref(T2);
if (IsVarTerm(t1)) {/* Testing for variables should be done first */
if (IsVarTerm(t2) || IsPrimitiveTerm(t2))
return (Yap_unify(T1, t2));
if (occurs_check(t1, t2))
return (Yap_unify(T1, t2));
return (FALSE);
}
if (IsVarTerm(t2)) {
if (occurs_check(t2, t1))
return (Yap_unify(T2, t1));
return (FALSE);
}
if (IsPrimitiveTerm(t1)) {
if (IsFloatTerm(t1))
return (IsFloatTerm(t2) && FloatOfTerm(t1) == FloatOfTerm(t2));
else if (IsRefTerm(t1))
return (IsRefTerm(t2) && RefOfTerm(t1) == RefOfTerm(t2));
if (IsLongIntTerm(t1))
return (IsLongIntTerm(t2) && LongIntOfTerm(t1) == LongIntOfTerm(t2));
else
return (t1 == t2);
}
if (IsPairTerm(t1)) {
if (!IsPairTerm(t2))
return (FALSE);
return (full_unification(HeadOfTermCell(t1), HeadOfTermCell(t2)) &&
full_unification(TailOfTermCell(t1), TailOfTermCell(t2)));
}
if (IsApplTerm(t1)) {
unsigned int i, arity;
if (!IsApplTerm(t2))
return (FALSE);
if (FunctorOfTerm(t1) != FunctorOfTerm(t2))
return (FALSE);
arity = ArityOfFunctor(FunctorOfTerm(t1));
for (i = 1; i <= arity; ++i)
if (!full_unification(ArgOfTermCell(i, t1), ArgOfTerm(i, t2)))
return (FALSE);
return (TRUE);
}
#ifdef lint
return (FALSE);
#endif
}
static int p_occurs_check() { /* occurs_check(?,?) */
return (occurs_check(Deref(ARG1), Deref(DARG2)));
}
/* Out of date, use unify_with_occurs_check instead*/
static int p_unify() { /* unify(?,?) */
/* routines that perform unification must receive the original arguments */
return (full_unification(ARG1, ARG2));
}
/*
* One example of a counter using the atom value functions counter(Atom,M,N)
*
* If the second argument is uninstantiated, then it will be unified with the
* current value of the counter, otherwyse the counter will be set to its
* value. The third argument then be unified with the next integer, which
* will become the current counter value.
*/
static int p_counter() { /* counter(+Atom,?Number,?Next) */
Term TCount, TNext, T1, T2;
Atom a;
/* Int -> an YAP integer */
Int val;
T1 = Deref(ARG1);
ARG2 = Deref(ARG2);
/* No need to deref ARG3, we don't want to know what's in there */
if (IsVarTerm(T1) || !IsAtomTerm(T1))
return (FALSE);
a = AtomOfTerm(T1);
if (IsVarTerm(T2)) {
TCount = Yap_GetValue(a);
if (!IsIntTerm(TCount))
return (FALSE);
Yap_unify_constant(ARG2, TCount); /* always succeeds */
val = IntOfTerm(TCount);
} else {
if (!IsIntTerm(T2))
return (FALSE);
val = IntOfTerm(T2);
}
val++;
/* The atom will now take the incremented value */
Yap_PutValue(a, TNext = MkIntTerm(val));
return (Yap_unify_constant(ARG3, TNext));
}
/*
* Concatenate an instantiated list to another list, and unify with third
* argument
*/
/*
* In order to be more efficient, iconcat instead of unifying the terms in
* the old structure with the ones in the new one just copies them. This is a
* dangerous behaviour, though acceptable in this case, and you should try to
* avoid it whenever possible
*/
#ifdef COMMENT
static int p_iconcat() { /* iconcat(+L1,+L2,-L) */
Term Tkeep[1025]; /* Will do it just for lists less
* than 1024 elements long */
register Term *Tkp = Tkeep;
register Term L0, L1;
Term T2;
L0 = Deref(ARG1);
*Tkp++ = Unsigned(0);
L1 = TermNil;
while (L0 != L1) {
/*
* Usually you should test if L1 a var, if (!IsPairTerm(L0))
* return(FALSE);
*/
*Tkp++ = HeadOfTerm(L0);
L0 = TailOfTerm(L0);
}
L1 = Deref(ARG2);
while (L0 = *--Tkp)
L1 = MkPairTerm(L0, L1);
T2 = L1;
return (Yap_unify(T2, ARG3));
}
#endif /* COMMENT */
static int p_iconcat() { /* iconcat(+L1,+L2,-L) */
register Term *Tkp = H, *tp;
register Term L0, L1;
Term T2;
L0 = Deref(ARG1);
L1 = TermNil;
while (L0 != L1) {
/* if (!IsPairTerm(L0)) return(FALSE); */
tp = Tkp;
*tp = AbsPair(++Tkp);
*Tkp++ = HeadOfTerm(L0);
L0 = TailOfTerm(L0);
}
*Tkp++ = Deref(ARG2);
T2 = *H;
H = Tkp;
return (Yap_unify(T2, ARG3));
}
#endif /* USERPREDS */
#ifdef EUROTRA
static int p_clean() /* predicate clean for ets */
/*
* clean(FB,CFB) :- FB =.. [fb|L],!, clean1(L,CL), CFB =.. [fb|CL].
* clean(FB,CFB) :- var(FB).
*
* clean1([],[]) :- !. clean1([H|T],[CH|CT]) :- H==$u,!, clean1(T,CT).
* clean1([H|T],[H|CT]) :- clean1(T,CT).
*/
{
unsigned int arity, i;
Term t, Args[255];
Term t1 = Deref(ARG1);
if (IsVarTerm(t1))
return (TRUE);
if (!(IsApplTerm(t1) && NameOfFunctor(FunctorOfTerm(t1)) == AtomFB))
return (FALSE);
arity = ArityOfFunctor(FunctorOfTerm(t1));
#ifdef SFUNC
if (arity == SFArity) {
CELL *pt = H, *ntp = ArgsOfSFTerm(t1);
Term tn = AbsAppl(H);
*pt++ = FunctorOfTerm(t1);
RESET_VARIABLE(pt);
pt++;
while (*pt++ = *ntp++)
if ((*pt++ = *ntp++) == MkAtomTerm(AtomDollarUndef))
pt -= 2;
H = pt;
return (Yap_unify(tn, ARG2));
}
#endif
for (i = 1; i <= arity; ++i) {
if ((t = ArgOfTerm(i, t1)) == TermDollarU)
t = MkVarTerm();
Args[i - 1] = t;
}
t = Yap_MkApplTerm(FunctorOfTerm(t1), arity, Args);
return (Yap_unify(ARG2, t));
}
static Term *subs_table;
static int subs_entries;
#define SUBS_TABLE_SIZE 500
static int subsumes(T1, T2) Term T1, T2;
{
int i;
if (IsVarTerm(T1)) {
if (!IsVarTerm(T2))
return (FALSE);
if (T1 == T2)
return (TRUE);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T2)
return (FALSE);
if (T2 < T1) {/* T1 gets instantiated with T2 */
Yap_unify(T1, T2);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T1) {
subs_table[i] = T2;
return (TRUE);
}
subs_table[subs_entries++] = T2;
return (TRUE);
}
/* T2 gets instantiated with T1 */
Yap_unify(T1, T2);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T1)
return (TRUE);
subs_table[subs_entries++] = T1;
return (TRUE);
}
if (IsVarTerm(T2)) {
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T2)
return (FALSE);
return (Yap_unify(T1, T2));
}
if (IsPrimitiveTerm(T1)) {
if (IsFloatTerm(T1))
return (IsFloatTerm(T2) && FloatOfTerm(T1) == FloatOfTerm(T2));
else if (IsRefTerm(T1))
return (IsRefTerm(T2) && RefOfTerm(T1) == RefOfTerm(T2));
else if (IsLongIntTerm(T1))
return (IsLongIntTerm(T2) && LongIntOfTerm(T1) == LongIntOfTerm(T2));
else
return (T1 == T2);
}
if (IsPairTerm(T1)) {
if (!IsPairTerm(T2))
return (FALSE);
return (subsumes(HeadOfTerm(T1), HeadOfTerm(T2)) &&
subsumes(TailOfTerm(T1), TailOfTerm(T2)));
}
if (IsApplTerm(T1)) {
int arity;
if (!IsApplTerm(T2))
return (FALSE);
if (FunctorOfTerm(T1) != FunctorOfTerm(T2))
return (FALSE);
arity = ArityOfFunctor(FunctorOfTerm(T1));
#ifdef SFUNC
if (arity == SFArity) {
CELL *a1a = ArgsOfSFTerm(T1), *a2a = ArgsOfSFTerm(T2);
CELL *a1p = a1a - 1, *a2p = a2a - 1;
CELL *pt = H;
int flags = 0;
Term t1, t2;
*pt++ = FunctorOfTerm(T1);
RESET_VARIABLE(pt);
pt++;
while (1) {
if (*a2a < *a1a || *a1a == 0) {
if (*a2a) {
*pt++ = *a2a++;
t2 = Derefa(a2a);
++a2a;
if (!IsVarTerm(t2))
return (FALSE);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == t2)
return (FALSE);
subs_table[subs_entries++] = t2;
*pt++ = t2;
flags |= 1;
} else { /* T2 is finished */
if ((flags & 1) == 0) {/* containned in first */
*a2p = Unsigned(a1p - 1);
if (a2p < HB)
*TR++ = Unsigned(a2p);
return (TRUE);
}
while ((*pt++ = *a1a++))
;
*a1p = Unsigned(H);
if (a1p < HB)
*TR++ = Unsigned(a1p);
*a2p = Unsigned(H);
if (a2p < HB)
*TR++ = Unsigned(a2p);
H = pt;
return (TRUE);
}
} else if (*a2a > *a1a || *a2a == 0) {
*pt++ = *a1a++;
t1 = Derefa(a1a);
++a1a;
if (IsVarTerm(t1)) {
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == t1)
break;
if (i >= subs_entries)
subs_table[subs_entries++] = t1;
}
*pt++ = t1;
flags |= 2;
} else if (*a1a == *a2a) {
*pt++ = *a1a++;
++a2a;
t1 = Derefa(a1a);
++a1a;
t2 = Derefa(a2a);
++a2a;
*pt++ = t1;
if (!subsumes(t1, t2))
return (FALSE);
}
}
}
#endif
for (i = 1; i <= arity; ++i)
if (!subsumes(ArgOfTerm(i, T1), ArgOfTerm(i, T2)))
return (FALSE);
return (TRUE);
}
return (FALSE);
}
static int p_subsumes() {
Term work_space[SUBS_TABLE_SIZE];
subs_table = work_space;
subs_entries = 0;
return (subsumes(Deref(ARG1), Deref(ARG2)));
}
static int p_namelength() {
register Term t = Deref(ARG1);
Term tf;
if (IsVarTerm(t)) {
return (FALSE);
}
if (IsAtomTerm(t)) {
Term tf = MkIntTerm(strlen(RepAtom(AtomOfTerm(t))->StrOfAE));
return (Yap_unify_constant(ARG2, tf));
} else if (IsIntTerm(t)) {
register int i = 1, k = IntOfTerm(t);
if (k < 0)
++i, k = -k;
while (k > 10)
++i, k /= 10;
tf = MkIntTerm(i);
return (Yap_unify_constant(ARG2, tf));
} else
return (FALSE);
}
static int p_getpid() {
#ifndef MPW
Term t = MkIntTerm(getpid());
#else
Term t = MkIntTerm(1);
#endif
return (Yap_unify_constant(ARG1, t));
}
static int p_exit() {
register Term t = Deref(ARG1);
if (IsVarTerm(t) || !IsIntTerm(t))
return (FALSE);
Yap_exit((int)IntOfTerm(t));
return (FALSE);
}
static int current_pos;
static int p_incrcounter() {
register Term t = Deref(ARG1);
if (IsVarTerm(t) || !IsIntTerm(t))
return (FALSE);
current_pos += IntOfTerm(t);
return (TRUE);
}
static int p_setcounter() {
register Term t = Deref(ARG1);
if (IsVarTerm(t) || !IsIntTerm(t)) {
return (Yap_unify_constant(ARG1, MkIntTerm(current_pos)));
} else {
current_pos = IntOfTerm(t);
return (TRUE);
}
}
#include <signal.h>
#ifdef MACYAP
#define signal(A, B) skel_signal(A, B)
#endif
#ifndef EOF
#define EOF -1
#endif
static int p_trapsignal(void) {
#ifndef MPW
signal(SIGINT, SIG_IGN);
#endif
return (TRUE);
}
#define varstarter(ch) ((ch >= 'A' && ch <= 'Z') || ch == '_')
#define idstarter(ch) (ch >= 'a' && ch <= 'z')
#define idchar(ch) \
((ch >= '0' && ch <= '9') || (ch >= 'A' && ch <= 'Z') || \
(ch >= 'a' && ch <= 'z') || ch == '_')
static int p_grab_tokens() {
Term *p = ASP - 20, *p0, t;
Functor IdFunctor, VarFunctor;
char ch, IdChars[256], *chp;
IdFunctor = FunctorId;
VarFunctor = FunctorDollarVar;
p0 = p;
ch = Yap_PlGetchar();
while (1) {
while (ch <= ' ' && ch != EOF)
ch = Yap_PlGetchar();
if (ch == '.' || ch == EOF)
break;
if (ch == '%') {
while ((ch = Yap_PlGetchar()) != 10)
;
ch = Yap_PlGetchar();
continue;
}
if (ch == '\'') {
chp = IdChars;
while (1) {
ch = Yap_PlGetchar();
if (ch == '\'')
break;
*chp++ = ch;
}
*chp = 0;
t = MkAtomTerm(Yap_LookupAtom(IdChars));
*p-- = Yap_MkApplTerm(IdFunctor, 1, &t);
ch = Yap_PlGetchar();
continue;
}
if (varstarter(ch)) {
chp = IdChars;
*chp++ = ch;
while (1) {
ch = Yap_PlGetchar();
if (!idchar(ch))
break;
*chp++ = ch;
}
*chp = 0;
t = MkAtomTerm(Yap_LookupAtom(IdChars));
*p-- = Yap_MkApplTerm(VarFunctor, 1, &t);
continue;
}
if (idstarter(ch)) {
chp = IdChars;
*chp++ = ch;
while (1) {
ch = Yap_PlGetchar();
if (!idchar(ch))
break;
*chp++ = ch;
}
*chp = 0;
t = MkAtomTerm(Yap_LookupAtom(IdChars));
*p-- = Yap_MkApplTerm(IdFunctor, 1, &t);
continue;
}
IdChars[0] = ch;
IdChars[1] = 0;
*p-- = MkAtomTerm(Yap_LookupAtom(IdChars));
ch = Yap_PlGetchar();
}
t = MkAtomTerm(AtomNil);
while (p != p0) {
t = MkPairTerm(*++p, t);
}
return (Yap_unify(ARG1, t));
}
#endif /* EUROTRA */
#ifdef SFUNC
static p_softfunctor() {
Term nilvalue = 0;
SFEntry *pe;
Prop p0;
Atom a;
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
if (IsAtomTerm(t2))
nilvalue = t2;
if (!IsAtomTerm(t1))
return (FALSE);
a = AtomOfTerm(t1);
WRITE_LOCK(RepAtom(a)->ARWLock);
if ((p0 = Yap_GetAProp(a, SFProperty)) == NIL) {
pe = (SFEntry *)Yap_AllocAtomSpace(sizeof(*pe));
pe->KindOfPE = SFProperty;
AddPropToAtom(RepAtom(a), (PropEntry *)pe);
} else
pe = RepSFProp(p0);
WRITE_UNLOCK(RepAtom(a)->ARWLock);
pe->NilValue = nilvalue;
return (TRUE);
}
#endif /* SFUNC */
#include <math.h>
/*
static Int
p_matching_distances(void)
{
return(fabs(FloatOfTerm(Deref(ARG1))-FloatOfTerm(Deref(ARG2))) <=
FloatOfTerm(Deref(ARG3)));
}
*/
void Yap_InitUserCPreds(void) {
#ifdef XINTERFACE
Yap_InitXPreds();
#endif
#ifdef EUROTRA
Yap_InitCPred("clean", 2, p_clean, SafePredFlag | SyncPredFlag);
Yap_InitCPred("name_length", 2, p_namelength, SafePredFlag | SyncPredFlag);
Yap_InitCPred("get_pid", 1, p_getpid, SafePredFlag);
Yap_InitCPred("exit", 1, p_exit, SafePredFlag | SyncPredFlag);
Yap_InitCPred("incr_counter", 1, p_incrcounter, SafePredFlag | SyncPredFlag);
Yap_InitCPred("set_counter", 1, p_setcounter, SafePredFlag | SyncPredFlag);
Yap_InitCPred("trap_signal", 0, p_trapsignal, SafePredFlag | SyncPredFlag);
Yap_InitCPred("mark2_grab_tokens", 1, p_grab_tokens,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("subsumes", 2, p_subsumes, SafePredFlag);
#endif
#ifdef SFUNC
Yap_InitCPred("sparse_functor", 2, p_softfunctor, SafePredFlag);
#endif /* SFUNC */
/* Yap_InitCPred("match_distances", 3, p_matching_distances, SafePredFlag);
*/
/* Yap_InitCPred("unify",2,p_unify,SafePredFlag); */
/* Yap_InitCPred("occurs_check",2,p_occurs_check,SafePredFlag); */
/* Yap_InitCPred("counter",3,p_counter,SafePredFlag); */
/* Yap_InitCPred("iconcat",3,p_iconcat,SafePredFlag); */
}
void Yap_InitUserBacks(void) {}

5433
dev/yap-6.3/C/utilpreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

1298
dev/yap-6.3/C/write.c Normal file
View File

File diff suppressed because it is too large Load Diff

562
dev/yap-6.3/C/yap-args.c Normal file
View File

@ -0,0 +1,562 @@
/*************************************************************************
* *
* Yap Prolog *
* *
* Yap Prolog Was Developed At Nccup - Universidade Do Porto *
* *
* Copyright L.Damas, V.S.Costa And Universidade Do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: Yap.C *
* Last Rev: *
* Mods: *
* Comments: Yap's Main File: parse arguments *
* *
*************************************************************************/
/* static char SccsId[] = "X 4.3.3"; */
#include "config.h"
#include "Yap.h"
#include "YapHeap.h"
#include "YapInterface.h"
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_STDINT_H
#include <stdint.h>
#endif
#include <stdlib.h>
#include <stddef.h>
#ifdef _MSC_VER /* Microsoft's Visual C++ Compiler */
#ifdef HAVE_UNISTD_H
#undef HAVE_UNISTD_H
#endif
#endif
#include <stdio.h>
#if HAVE_STRING_H
#include <string.h>
#endif
#if HAVE_ERRNO_H
#include <errno.h>
#endif
#if HAVE_DIRECT_H
#include <direct.h>
#endif
#if (DefTrailSpace < MinTrailSpace)
#undef DefTrailSpace
#define DefTrailSpace MinTrailSpace
#endif
#if (DefStackSpace < MinStackSpace)
#undef DefStackSpace
#define DefStackSpace MinStackSpace
#endif
#if (DefHeapSpace < MinHeapSpace)
#undef DefHeapSpace
#define DefHeapSpace MinHeapSpace
#endif
#define DEFAULT_NUMBERWORKERS 1
#define DEFAULT_SCHEDULERLOOP 10
#define DEFAULT_DELAYEDRELEASELOAD 3
static void print_usage(void) {
fprintf(stderr, "\n[ Valid switches for command line arguments: ]\n");
fprintf(stderr, " -? Shows this screen\n");
fprintf(stderr, " -b Boot file \n");
fprintf(stderr, " -dump-runtime-variables\n");
fprintf(stderr, " -f initialization file or \"none\"\n");
fprintf(stderr, " -g Run Goal Before Top-Level \n");
fprintf(stderr, " -z Run Goal Before Top-Level \n");
fprintf(stderr, " -q start with informational messages off\n");
fprintf(stderr, " -l load Prolog file\n");
fprintf(stderr, " -L run Prolog file and exit\n");
fprintf(stderr, " -p extra path for file-search-path\n");
fprintf(stderr, " -hSize Heap area in Kbytes (default: %d, minimum: %d)\n",
DefHeapSpace, MinHeapSpace);
fprintf(stderr,
" -sSize Stack area in Kbytes (default: %d, minimum: %d)\n",
DefStackSpace, MinStackSpace);
fprintf(stderr,
" -tSize Trail area in Kbytes (default: %d, minimum: %d)\n",
DefTrailSpace, MinTrailSpace);
fprintf(stderr, " -GSize Max Area for Global Stack\n");
fprintf(stderr,
" -LSize Max Area for Local Stack (number must follow L)\n");
fprintf(stderr, " -TSize Max Area for Trail (number must follow L)\n");
fprintf(stderr, " -nosignals disable signal handling from Prolog\n");
fprintf(stderr, "\n[Execution Modes]\n");
fprintf(stderr, " -J0 Interpreted mode (default)\n");
fprintf(stderr, " -J1 Mixed mode only for user predicates\n");
fprintf(stderr, " -J2 Mixed mode for all predicates\n");
fprintf(stderr, " -J3 Compile all user predicates\n");
fprintf(stderr, " -J4 Compile all predicates\n");
#ifdef TABLING
fprintf(stderr,
" -ts Maximum table space area in Mbytes (default: unlimited)\n");
#endif /* TABLING */
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA) || \
defined(YAPOR_THREADS)
fprintf(stderr, " -w Number of workers (default: %d)\n",
DEFAULT_NUMBERWORKERS);
fprintf(stderr, " -sl Loop scheduler executions before look for hiden "
"shared work (default: %d)\n",
DEFAULT_SCHEDULERLOOP);
fprintf(stderr, " -d Value of delayed release of load (default: %d)\n",
DEFAULT_DELAYEDRELEASELOAD);
#endif /* YAPOR_COPY || YAPOR_COW || YAPOR_SBA || YAPOR_THREADS */
/* nf: Preprocessor */
/* fprintf(stderr," -DVar=Name Persistent definition\n"); */
fprintf(stderr, "\n");
}
static int myisblank(int c) {
switch (c) {
case ' ':
case '\t':
case '\n':
case '\r':
return TRUE;
default:
return FALSE;
}
}
static char *add_end_dot(char arg[]) {
int sz = strlen(arg), i;
i = sz;
while (i && myisblank(arg[--i]))
;
if (i && arg[i] != ',') {
char *p = (char *)malloc(sz + 2);
if (!p)
return NULL;
strncpy(p, arg, sz);
p[sz] = '.';
p[sz + 1] = '\0';
return p;
}
return arg;
}
static int dump_runtime_variables(void) {
fprintf(stdout, "CC=\"%s\"\n", C_CC);
fprintf(stdout, "YAP_ROOTDIR=\"%s\"\n", YAP_ROOTDIR);
fprintf(stdout, "YAP_LIBS=\"%s\"\n", C_LIBS);
fprintf(stdout, "YAP_SHLIB_SUFFIX=\"%s\"\n", SO_EXT);
fprintf(stdout, "YAP_VERSION=%s\n", YAP_NUMERIC_VERSION);
exit(0);
return 1;
}
X_API int YAP_parse_yap_arguments(int argc, char *argv[], YAP_init_args *iap) {
char *p;
int BootMode = YAP_BOOT_FROM_SAVED_CODE;
unsigned long int *ssize;
iap->SavedState = NULL;
iap->HeapSize = 0;
iap->StackSize = 0;
iap->TrailSize = 0;
iap->AttsSize = 0;
iap->MaxAttsSize = 0;
iap->MaxHeapSize = 0;
iap->MaxStackSize = 0;
iap->MaxGlobalSize = 0;
iap->MaxTrailSize = 0;
iap->YapLibDir = NULL;
iap->YapPrologBootFile = NULL;
iap->YapPrologInitFile = NULL;
iap->YapPrologRCFile = NULL;
iap->YapPrologGoal = NULL;
iap->YapPrologTopLevelGoal = NULL;
iap->YapPrologAddPath = NULL;
iap->HaltAfterConsult = FALSE;
iap->FastBoot = FALSE;
iap->MaxTableSpaceSize = 0;
iap->NumberWorkers = DEFAULT_NUMBERWORKERS;
iap->SchedulerLoop = DEFAULT_SCHEDULERLOOP;
iap->DelayedReleaseLoad = DEFAULT_DELAYEDRELEASELOAD;
iap->PrologShouldHandleInterrupts = TRUE;
iap->ExecutionMode = YAPC_INTERPRETED;
iap->Argc = argc;
iap->Argv = argv;
iap->def_c = 0;
iap->ErrorNo = 0;
iap->ErrorCause = NULL;
iap->QuietMode = FALSE;
while (--argc > 0) {
p = *++argv;
if (*p == '-')
switch (*++p) {
case 'b':
BootMode = YAP_BOOT_FROM_PROLOG;
iap->YapPrologBootFile = *++argv;
argc--;
break;
case '?':
print_usage();
exit(EXIT_SUCCESS);
case 'q':
iap->QuietMode = TRUE;
break;
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA) || \
defined(YAPOR_THREADS)
case 'w':
ssize = &(iap->NumberWorkers);
goto GetSize;
case 'd':
if (!strcmp("dump-runtime-variables", p))
return dump_runtime_variables();
ssize = &(iap->DelayedReleaseLoad);
goto GetSize;
#else
case 'd':
if (!strcmp("dump-runtime-variables", p))
return dump_runtime_variables();
#endif /* YAPOR_COPY || YAPOR_COW || YAPOR_SBA || YAPOR_THREADS */
case 'F':
/* just ignore for now */
argc--;
argv++;
break;
case 'f':
iap->FastBoot = TRUE;
if (argc > 1 && argv[1][0] != '-') {
argc--;
argv++;
if (strcmp(*argv, "none")) {
iap->YapPrologRCFile = *argv;
}
break;
}
break;
// execution mode
case 'J':
switch (p[1]) {
case '0':
iap->ExecutionMode = YAPC_INTERPRETED;
break;
case '1':
iap->ExecutionMode = YAPC_MIXED_MODE_USER;
break;
case '2':
iap->ExecutionMode = YAPC_MIXED_MODE_ALL;
break;
case '3':
iap->ExecutionMode = YAPC_COMPILE_USER;
break;
case '4':
iap->ExecutionMode = YAPC_COMPILE_ALL;
break;
default:
fprintf(stderr, "[ YAP unrecoverable error: unknown switch -%c%c ]\n",
*p, p[1]);
exit(EXIT_FAILURE);
}
p++;
break;
case 'G':
ssize = &(iap->MaxGlobalSize);
goto GetSize;
break;
case 's':
case 'S':
ssize = &(iap->StackSize);
#if defined(YAPOR_COPY) || defined(YAPOR_COW) || defined(YAPOR_SBA) || \
defined(YAPOR_THREADS)
if (p[1] == 'l') {
p++;
ssize = &(iap->SchedulerLoop);
}
#endif /* YAPOR_COPY || YAPOR_COW || YAPOR_SBA || YAPOR_THREADS */
goto GetSize;
case 'a':
case 'A':
ssize = &(iap->AttsSize);
goto GetSize;
case 'T':
ssize = &(iap->MaxTrailSize);
goto get_trail_size;
case 't':
ssize = &(iap->TrailSize);
#ifdef TABLING
if (p[1] == 's') {
p++;
ssize = &(iap->MaxTableSpaceSize);
}
#endif /* TABLING */
get_trail_size:
if (*++p == '\0') {
if (argc > 1)
--argc, p = *++argv;
else {
fprintf(stderr,
"[ YAP unrecoverable error: missing size in flag %s ]",
argv[0]);
print_usage();
exit(EXIT_FAILURE);
}
}
{
unsigned long int i = 0, ch;
while ((ch = *p++) >= '0' && ch <= '9')
i = i * 10 + ch - '0';
switch (ch) {
case 'M':
case 'm':
i *= 1024;
ch = *p++;
break;
case 'g':
i *= 1024 * 1024;
ch = *p++;
break;
case 'k':
case 'K':
ch = *p++;
break;
}
if (ch) {
iap->YapPrologTopLevelGoal = add_end_dot(*argv);
} else {
*ssize = i;
}
}
break;
case 'h':
case 'H':
ssize = &(iap->HeapSize);
GetSize:
if (*++p == '\0') {
if (argc > 1)
--argc, p = *++argv;
else {
fprintf(stderr,
"[ YAP unrecoverable error: missing size in flag %s ]",
argv[0]);
print_usage();
exit(EXIT_FAILURE);
}
}
{
unsigned long int i = 0, ch;
while ((ch = *p++) >= '0' && ch <= '9')
i = i * 10 + ch - '0';
switch (ch) {
case 'M':
case 'm':
i *= 1024;
ch = *p++;
break;
case 'g':
case 'G':
i *= 1024 * 1024;
ch = *p++;
break;
case 'k':
case 'K':
ch = *p++;
break;
}
if (ch) {
fprintf(
stderr,
"[ YAP unrecoverable error: illegal size specification %s ]",
argv[-1]);
Yap_exit(1);
}
*ssize = i;
}
break;
#ifdef DEBUG
case 'P':
YAP_SetOutputMessage();
if (p[1] != '\0') {
while (p[1] != '\0') {
int ch = p[1];
if (ch >= 'A' && ch <= 'Z')
ch += ('a' - 'A');
if (ch >= 'a' && ch <= 'z')
GLOBAL_Option[ch - 96] = 1;
}
}
break;
#endif
case 'L':
if (p[1] && p[1] >= '0' &&
p[1] <= '9') /* hack to emulate SWI's L local option */
{
ssize = &(iap->MaxStackSize);
goto GetSize;
}
iap->QuietMode = TRUE;
iap->HaltAfterConsult = TRUE;
case 'l':
p++;
if (!*++argv) {
fprintf(stderr,
"%% YAP unrecoverable error: missing load file name\n");
exit(1);
} else if (!strcmp("--", *argv)) {
/* shell script, the next entry should be the file itself */
iap->YapPrologRCFile = argv[1];
argc = 1;
break;
} else {
iap->YapPrologRCFile = *argv;
argc--;
}
if (*p) {
/* we have something, usually, of the form:
-L --
FileName
ExtraArgs
*/
/* being called from a script */
while (*p && (*p == ' ' || *p == '\t'))
p++;
if (p[0] == '-' && p[1] == '-') {
/* ignore what is next */
argc = 1;
}
}
break;
/* run goal before top-level */
case 'g':
if ((*argv)[0] == '\0')
iap->YapPrologGoal = *argv;
else {
argc--;
if (argc == 0) {
fprintf(stderr, " [ YAP unrecoverable error: missing "
"initialization goal for option 'g' ]\n");
exit(EXIT_FAILURE);
}
argv++;
iap->YapPrologGoal = *argv;
}
break;
/* run goal as top-level */
case 'z':
if ((*argv)[0] == '\0')
iap->YapPrologTopLevelGoal = *argv;
else {
argc--;
if (argc == 0) {
fprintf(
stderr,
" [ YAP unrecoverable error: missing goal for option 'z' ]\n");
exit(EXIT_FAILURE);
}
argv++;
iap->YapPrologTopLevelGoal = add_end_dot(*argv);
}
break;
case 'n':
if (!strcmp("nosignals", p)) {
iap->PrologShouldHandleInterrupts = FALSE;
break;
}
break;
case '-':
if (!strcmp("-nosignals", p)) {
iap->PrologShouldHandleInterrupts = FALSE;
break;
} else if (!strncmp("-home=", p, strlen("-home="))) {
GLOBAL_Home = p + strlen("-home=");
} else if (!strncmp("-cwd=", p, strlen("-cwd="))) {
#if __WINDOWS__
if (_chdir(p + strlen("-cwd=")) < 0) {
#else
if (chdir(p + strlen("-cwd=")) < 0) {
#endif
fprintf(stderr, " [ YAP unrecoverable error in setting cwd: %s ]\n",
strerror(errno));
}
} else if (!strncmp("-stack=", p, strlen("-stack="))) {
ssize = &(iap->StackSize);
p += strlen("-stack=");
goto GetSize;
} else if (!strncmp("-trail=", p, strlen("-trail="))) {
ssize = &(iap->TrailSize);
p += strlen("-trail=");
goto GetSize;
} else if (!strncmp("-heap=", p, strlen("-heap="))) {
ssize = &(iap->HeapSize);
p += strlen("-heap=");
goto GetSize;
} else if (!strncmp("-goal=", p, strlen("-goal="))) {
iap->YapPrologGoal = p + strlen("-goal=");
} else if (!strncmp("-top-level=", p, strlen("-top-level="))) {
iap->YapPrologTopLevelGoal = p + strlen("-top-level=");
} else if (!strncmp("-table=", p, strlen("-table="))) {
ssize = &(iap->MaxTableSpaceSize);
p += strlen("-table=");
goto GetSize;
} else if (!strncmp("-", p, strlen("-="))) {
ssize = &(iap->MaxTableSpaceSize);
p += strlen("-table=");
/* skip remaining arguments */
argc = 1;
}
break;
case 'p':
if ((*argv)[0] == '\0')
iap->YapPrologAddPath = *argv;
else {
argc--;
if (argc == 0) {
fprintf(
stderr,
" [ YAP unrecoverable error: missing paths for option 'p' ]\n");
exit(EXIT_FAILURE);
}
argv++;
iap->YapPrologAddPath = *argv;
}
break;
/* nf: Begin preprocessor code */
case 'D': {
char *var, *value;
++p;
var = p;
if (var == NULL || *var == '\0')
break;
while (*p != '=' && *p != '\0')
++p;
if (*p == '\0')
break;
*p = '\0';
++p;
value = p;
if (*value == '\0')
break;
if (iap->def_c == YAP_MAX_YPP_DEFS)
break;
iap->def_var[iap->def_c] = var;
iap->def_value[iap->def_c] = value;
++(iap->def_c);
break;
}
/* End preprocessor code */
default: {
fprintf(stderr, "[ YAP unrecoverable error: unknown switch -%c ]\n",
*p);
print_usage();
exit(EXIT_FAILURE);
}
}
else {
iap->SavedState = p;
}
}
//___androidlog_print(ANDROID_LOG_INFO, "YAP ", "boot mode %d", BootMode);
return BootMode;
}

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