3608 lines
99 KiB
C
Executable File
3608 lines
99 KiB
C
Executable File
/*************************************************************************
|
|
* *
|
|
* YAP Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: compiler.c *
|
|
* comments: Clause compiler *
|
|
* *
|
|
* Last rev: $Date: 2008-08-06 17:32:18 $,$Author: vsc $ *
|
|
* $Log: not supported by cvs2svn $
|
|
* Revision 1.88 2008/03/13 14:37:58 vsc
|
|
* update chr
|
|
*
|
|
* Revision 1.87 2007/12/18 17:46:58 vsc
|
|
* purge_clauses does not need to do anything if there are no clauses
|
|
* fix gprof bugs.
|
|
*
|
|
* Revision 1.86 2007/11/26 23:43:08 vsc
|
|
* fixes to support threads and assert correctly, even if inefficiently.
|
|
*
|
|
* Revision 1.85 2007/11/06 17:02:11 vsc
|
|
* compile ground terms away.
|
|
*
|
|
* Revision 1.84 2007/03/27 13:48:51 vsc
|
|
* fix number of overflows (comments by Bart Demoen).
|
|
*
|
|
* Revision 1.83 2007/03/26 15:18:43 vsc
|
|
* debugging and clause/3 over tabled predicates would kill YAP.
|
|
*
|
|
* Revision 1.82 2006/11/06 18:35:03 vsc
|
|
* 1estranha
|
|
*
|
|
* Revision 1.81 2006/10/11 15:08:03 vsc
|
|
* fix bb entries
|
|
* comment development code for timestamp overflow.
|
|
*
|
|
* Revision 1.80 2006/09/20 20:03:51 vsc
|
|
* improve indexing on floats
|
|
* fix sending large lists to DB
|
|
*
|
|
* Revision 1.79 2006/08/01 13:14:17 vsc
|
|
* fix compilation of |
|
|
*
|
|
* Revision 1.78 2006/07/27 19:04:56 vsc
|
|
* fix nasty overflows in and add some very preliminary support for very large
|
|
* clauses with lots
|
|
* of disjuncts (eg, query packs).
|
|
*
|
|
* Revision 1.77 2006/05/19 14:31:31 vsc
|
|
* get rid of IntArrays and FloatArray code.
|
|
* include holes when calculating memory usage.
|
|
*
|
|
* Revision 1.76 2006/05/19 13:48:11 vsc
|
|
* help to make Yap work with dynamic libs
|
|
*
|
|
* Revision 1.75 2006/05/16 18:37:30 vsc
|
|
* WIN32 fixes
|
|
* compiler bug fixes
|
|
* extend interface
|
|
*
|
|
* Revision 1.74 2006/04/13 02:04:24 vsc
|
|
* fix debugging typo
|
|
*
|
|
* Revision 1.73 2006/04/12 20:08:51 vsc
|
|
* make it sure that making vars safe does not propagate across branches of disjunctions.
|
|
*
|
|
* Revision 1.72 2006/04/05 00:16:54 vsc
|
|
* Lots of fixes (check logfile for details
|
|
*
|
|
* Revision 1.71 2006/03/24 17:13:41 rslopes
|
|
* New update to BEAM engine.
|
|
* BEAM now uses YAP Indexing (JITI)
|
|
*
|
|
* Revision 1.70 2005/12/17 03:25:39 vsc
|
|
* major changes to support online event-based profiling
|
|
* improve error discovery and restart on scanner.
|
|
*
|
|
* Revision 1.69 2005/09/08 22:06:44 rslopes
|
|
* BEAM for YAP update...
|
|
*
|
|
* Revision 1.68 2005/07/06 15:10:03 vsc
|
|
* improvements to compiler: merged instructions and fixes for ->
|
|
*
|
|
* Revision 1.67 2005/05/25 21:43:32 vsc
|
|
* fix compiler bug in 1 << X, found by Nuno Fonseca.
|
|
* compiler internal errors get their own message.
|
|
*
|
|
* Revision 1.66 2005/05/12 03:36:32 vsc
|
|
* debugger was making predicates meta instead of testing
|
|
* fix handling of dbrefs in facts and in subarguments.
|
|
*
|
|
* Revision 1.65 2005/04/10 04:01:10 vsc
|
|
* bug fixes, I hope!
|
|
*
|
|
* Revision 1.64 2005/03/13 06:26:10 vsc
|
|
* fix excessive pruning in meta-calls
|
|
* fix Term->int breakage in compiler
|
|
* improve JPL (at least it does something now for amd64).
|
|
*
|
|
* Revision 1.63 2005/03/04 20:30:11 ricroc
|
|
* bug fixes for YapTab support
|
|
*
|
|
* Revision 1.62 2005/02/21 16:49:39 vsc
|
|
* amd64 fixes
|
|
* library fixes
|
|
*
|
|
* Revision 1.61 2005/01/28 23:14:35 vsc
|
|
* move to Yap-4.5.7
|
|
* Fix clause size
|
|
*
|
|
* Revision 1.60 2005/01/14 20:55:16 vsc
|
|
* improve register liveness calculations.
|
|
*
|
|
* Revision 1.59 2005/01/04 02:50:21 vsc
|
|
* - allow MegaClauses with blobs
|
|
* - change Diffs to be thread specific
|
|
* - include Christian's updates
|
|
*
|
|
* Revision 1.58 2005/01/03 17:06:03 vsc
|
|
* fix discontiguous stack overflows in parser
|
|
*
|
|
* Revision 1.57 2004/12/20 21:44:57 vsc
|
|
* more fixes to CLPBN
|
|
* fix some Yap overflows.
|
|
*
|
|
* Revision 1.56 2004/12/16 05:57:32 vsc
|
|
* fix overflows
|
|
*
|
|
* Revision 1.55 2004/12/05 05:01:23 vsc
|
|
* try to reduce overheads when running with goal expansion enabled.
|
|
* CLPBN fixes
|
|
* Handle overflows when allocating big clauses properly.
|
|
*
|
|
* Revision 1.54 2004/11/19 22:08:41 vsc
|
|
* replace SYSTEM_ERROR by out OUT_OF_WHATEVER_ERROR whenever appropriate.
|
|
*
|
|
* Revision 1.53 2004/09/03 03:11:08 vsc
|
|
* memory management fixes
|
|
*
|
|
* Revision 1.52 2004/07/15 17:20:23 vsc
|
|
* fix error message
|
|
* change makefile and configure for clpbn
|
|
*
|
|
* Revision 1.51 2004/06/29 19:04:41 vsc
|
|
* fix multithreaded version
|
|
* include new version of Ricardo's profiler
|
|
* new predicat atomic_concat
|
|
* allow multithreaded-debugging
|
|
* small fixes
|
|
*
|
|
* Revision 1.50 2004/04/22 20:07:04 vsc
|
|
* more fixes for USE_SYSTEM_MEMORY
|
|
*
|
|
* Revision 1.49 2004/03/10 16:27:39 vsc
|
|
* skip compilation steps for ground facts.
|
|
*
|
|
* Revision 1.48 2004/03/08 19:31:01 vsc
|
|
* move to 4.5.3
|
|
* *
|
|
* *
|
|
*************************************************************************/
|
|
#ifdef SCCS
|
|
static char SccsId[] = "%W% %G%";
|
|
|
|
#endif /* SCCS */
|
|
#include "Yap.h"
|
|
#include "compile.h"
|
|
#include "clause.h"
|
|
#include "alloc.h"
|
|
#include "yapio.h"
|
|
#if HAVE_STRING_H
|
|
#include <string.h>
|
|
#endif
|
|
|
|
#ifdef BEAM
|
|
extern int EAM;
|
|
//extern PInstr *CodeStart, *ppc, *ppc1, *BodyStart, *ppc_body;
|
|
#endif
|
|
|
|
typedef struct branch_descriptor {
|
|
int id; /* the branch id */
|
|
Term cm; /* if a banch is associated with a commit */
|
|
} branch;
|
|
|
|
typedef struct compiler_struct_struct {
|
|
branch parent_branches[256];
|
|
branch *branch_pointer;
|
|
PInstr *BodyStart;
|
|
Ventry *vtable;
|
|
CExpEntry *common_exps;
|
|
int is_a_fact;
|
|
int hasdbrefs;
|
|
int n_common_exps;
|
|
int goalno;
|
|
int onlast;
|
|
int onhead;
|
|
int onbranch;
|
|
int curbranch;
|
|
Int space_used;
|
|
PInstr *space_op;
|
|
Prop current_p0;
|
|
#ifdef TABLING_INNER_CUTS
|
|
PInstr *cut_mark;
|
|
#endif /* TABLING_INNER_CUTS */
|
|
#ifdef DEBUG
|
|
int pbvars;
|
|
#endif /* DEBUG */
|
|
int nvars;
|
|
UInt labelno;
|
|
int or_found;
|
|
UInt max_args;
|
|
int MaxCTemps;
|
|
UInt tmpreg;
|
|
Int vreg;
|
|
Int vadr;
|
|
Int *Uses;
|
|
Term *Contents;
|
|
int needs_env;
|
|
CIntermediates cint;
|
|
} compiler_struct;
|
|
|
|
STATIC_PROTO(int active_branch, (int, int));
|
|
STATIC_PROTO(void c_var, (Term, Int, unsigned int, unsigned int, compiler_struct *));
|
|
STATIC_PROTO(void reset_vars, (Ventry *));
|
|
STATIC_PROTO(Term optimize_ce, (Term, unsigned int, unsigned int, compiler_struct *));
|
|
STATIC_PROTO(void c_arg, (Int, Term, unsigned int, unsigned int, compiler_struct *));
|
|
STATIC_PROTO(void c_args, (Term, unsigned int, compiler_struct *));
|
|
STATIC_PROTO(void c_eq, (Term, Term, compiler_struct *));
|
|
STATIC_PROTO(void c_test, (Int, Term, compiler_struct *));
|
|
STATIC_PROTO(void c_bifun, (basic_preds, Term, Term, Term, Term, Term, compiler_struct *));
|
|
STATIC_PROTO(void c_goal, (Term, Term, compiler_struct *));
|
|
STATIC_PROTO(void c_body, (Term, Term, compiler_struct *));
|
|
STATIC_PROTO(void c_head, (Term, compiler_struct *));
|
|
STATIC_PROTO(int usesvar, (compiler_vm_op));
|
|
STATIC_PROTO(CELL *init_bvarray, (int, compiler_struct *));
|
|
#ifdef DEBUG
|
|
STATIC_PROTO(void clear_bvarray, (int, CELL *, compiler_struct *));
|
|
#else
|
|
STATIC_PROTO(void clear_bvarray, (int, CELL *));
|
|
#endif
|
|
STATIC_PROTO(void add_bvarray_op, (PInstr *,CELL *, int, compiler_struct *));
|
|
STATIC_PROTO(void AssignPerm, (PInstr *, compiler_struct *));
|
|
STATIC_PROTO(void CheckUnsafe, (PInstr *, compiler_struct *));
|
|
STATIC_PROTO(void CheckVoids, (compiler_struct *));
|
|
STATIC_PROTO( int checktemp, (Int, Int, compiler_vm_op, compiler_struct *));
|
|
STATIC_PROTO( Int checkreg, (Int, Int, compiler_vm_op, int, compiler_struct *));
|
|
STATIC_PROTO(void c_layout, (compiler_struct *));
|
|
STATIC_PROTO(void c_optimize, (PInstr *));
|
|
#ifdef SFUNC
|
|
STATIC_PROTO(void compile_sf_term, (Term, int));
|
|
#endif
|
|
|
|
static void
|
|
push_branch(int id, Term cmvar, compiler_struct *cglobs) {
|
|
cglobs->branch_pointer->id = id;
|
|
cglobs->branch_pointer->cm = cmvar;
|
|
cglobs->branch_pointer++;
|
|
}
|
|
|
|
static int
|
|
pop_branch(compiler_struct *cglobs) {
|
|
cglobs->branch_pointer--;
|
|
return(cglobs->branch_pointer->id);
|
|
}
|
|
|
|
#ifdef TABLING
|
|
#define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
|
|
#endif /* TABLING */
|
|
|
|
static inline int
|
|
active_branch(int i, int onbranch)
|
|
{
|
|
/* register int *bp;*/
|
|
|
|
return (i == onbranch);
|
|
/* bp = cglobs->branch_pointer;
|
|
while (bp > parent_branches) {
|
|
if (*--bp == onbranch)
|
|
return (TRUE);
|
|
}
|
|
return(i==onbranch);*/
|
|
}
|
|
|
|
#define FAIL(M,T,E) { Yap_ErrorMessage=M; Yap_Error_TYPE = T; Yap_Error_Term = E; return; }
|
|
|
|
#if USE_SYSTEM_MALLOC
|
|
#define IsNewVar(v) ((CELL *)(v) >= H0 && (CELL *)(v) < LCL0)
|
|
#else
|
|
#define IsNewVar(v) (Addr(v)<cglobs->cint.freep0 || Addr(v)>cglobs->cint.freep)
|
|
#endif
|
|
|
|
inline static void pop_code(unsigned int, compiler_struct *);
|
|
|
|
inline static void
|
|
pop_code(unsigned int level, compiler_struct *cglobs)
|
|
{
|
|
if (level == 0)
|
|
return;
|
|
if (cglobs->cint.cpc->op == pop_op)
|
|
++(cglobs->cint.cpc->rnd1);
|
|
else {
|
|
Yap_emit(pop_op, One, Zero, &cglobs->cint);
|
|
}
|
|
}
|
|
|
|
static void
|
|
adjust_current_commits(compiler_struct *cglobs) {
|
|
branch *bp = cglobs->branch_pointer;
|
|
while (bp > cglobs->parent_branches) {
|
|
bp--;
|
|
if (bp->cm != TermNil) {
|
|
c_var(bp->cm, patch_b_flag, 1, 0, cglobs);
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
static int
|
|
check_var(Term t, unsigned int level, Int argno, compiler_struct *cglobs) {
|
|
int flags, new = FALSE;
|
|
Ventry *v = (Ventry *)t;
|
|
|
|
if (IsNewVar(v)) { /* new var */
|
|
v = (Ventry *) Yap_AllocCMem(sizeof(*v), &cglobs->cint);
|
|
#if SBA
|
|
v->SelfOfVE = 0;
|
|
#else
|
|
v->SelfOfVE = (CELL) v;
|
|
#endif
|
|
v->AdrsOfVE = t;
|
|
*CellPtr(t) = (CELL) v;
|
|
v->KindOfVE = v->NoOfVE = Unassigned;
|
|
flags = 0;
|
|
/* Be careful with eithers. I may make a variable global in a branch,
|
|
and not in another.
|
|
a :- (b([X]) ; c), go(X).
|
|
This variable will not be globalised if we are coming from
|
|
the second branch.
|
|
|
|
I also need to protect the onhead because Luis uses that to
|
|
optimise unification in the body of a clause, eg
|
|
a :- (X = 2 ; c), go(X).
|
|
|
|
And, yes, there is code like this...
|
|
*/
|
|
if (((level > 0 || cglobs->onhead) && cglobs->curbranch == 0)
|
|
|| argno == save_pair_flag ||
|
|
argno == save_appl_flag)
|
|
flags |= SafeVar;
|
|
if ((level > 0 && cglobs->curbranch == 0) || argno == save_pair_flag ||
|
|
argno == save_appl_flag)
|
|
flags |= GlobalVal;
|
|
v->FlagsOfVE = flags;
|
|
v->BranchOfVE = cglobs->onbranch;
|
|
v->NextOfVE = cglobs->vtable;
|
|
v->RCountOfVE = 0;
|
|
v->AgeOfVE = v->FirstOfVE = cglobs->goalno;
|
|
new = TRUE;
|
|
cglobs->vtable = v;
|
|
} else {
|
|
v->FlagsOfVE |= NonVoid;
|
|
if (v->BranchOfVE > 0) {
|
|
if (!active_branch(v->BranchOfVE, cglobs->onbranch)) {
|
|
v->AgeOfVE = v->FirstOfVE = 1;
|
|
new = FALSE;
|
|
v->FlagsOfVE |= BranchVar;
|
|
/* set the original instruction correctly */
|
|
switch (v->FirstOpForV->op) {
|
|
case get_var_op:
|
|
v->FirstOpForV->op = get_val_op;
|
|
break;
|
|
case unify_var_op:
|
|
v->FirstOpForV->op = unify_val_op;
|
|
break;
|
|
case unify_last_var_op:
|
|
v->FirstOpForV->op = unify_last_val_op;
|
|
break;
|
|
case put_var_op:
|
|
v->FirstOpForV->op = put_val_op;
|
|
break;
|
|
case write_var_op:
|
|
v->FirstOpForV->op = write_val_op;
|
|
break;
|
|
default:
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if (cglobs->onhead)
|
|
v->FlagsOfVE |= OnHeadFlag;
|
|
return new;
|
|
}
|
|
|
|
static void
|
|
tag_var(Term t, int new, compiler_struct *cglobs)
|
|
{
|
|
Ventry *v = (Ventry *) t;
|
|
|
|
if (new) {
|
|
v->FirstOpForV = cglobs->cint.cpc;
|
|
}
|
|
v->LastOpForV = cglobs->cint.cpc;
|
|
++(v->RCountOfVE);
|
|
if (cglobs->onlast)
|
|
v->FlagsOfVE |= OnLastGoal;
|
|
if (v->AgeOfVE < cglobs->goalno)
|
|
v->AgeOfVE = cglobs->goalno;
|
|
}
|
|
|
|
static void
|
|
c_var(Term t, Int argno, unsigned int arity, unsigned int level, compiler_struct *cglobs)
|
|
{
|
|
int new = check_var(Deref(t), level, argno, cglobs);
|
|
t = Deref(t);
|
|
|
|
switch (argno) {
|
|
case save_b_flag:
|
|
Yap_emit(save_b_op, t, Zero, &cglobs->cint);
|
|
break;
|
|
case commit_b_flag:
|
|
Yap_emit(commit_b_op, t, Zero, &cglobs->cint);
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
break;
|
|
case patch_b_flag:
|
|
Yap_emit(patch_b_op, t, 0, &cglobs->cint);
|
|
break;
|
|
case save_pair_flag:
|
|
Yap_emit(save_pair_op, t, 0, &cglobs->cint);
|
|
break;
|
|
case save_appl_flag:
|
|
Yap_emit(save_appl_op, t, 0, &cglobs->cint);
|
|
break;
|
|
case f_flag:
|
|
if (new) {
|
|
++cglobs->nvars;
|
|
Yap_emit(f_var_op, t, (CELL)arity, &cglobs->cint);
|
|
} else {
|
|
Yap_emit(f_val_op, t, (CELL)arity, &cglobs->cint);
|
|
}
|
|
break;
|
|
case bt1_flag:
|
|
Yap_emit(fetch_args_for_bccall, t, 0, &cglobs->cint);
|
|
break;
|
|
case bt2_flag:
|
|
Yap_emit(bccall_op, t, (CELL)cglobs->current_p0, &cglobs->cint);
|
|
break;
|
|
default:
|
|
#ifdef SFUNC
|
|
if (argno < 0) {
|
|
if (new)
|
|
Yap_emit((cglobs->onhead ? unify_s_var_op : write_s_var_op), v, -argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? unify_s_val_op : write_s_val_op), v, -argno, &cglobs->cint);
|
|
} else
|
|
#endif
|
|
if (cglobs->onhead) {
|
|
cglobs->space_used ++;
|
|
if (level == 0)
|
|
Yap_emit((new ? (++cglobs->nvars, get_var_op) : get_val_op), t, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((new ? (++cglobs->nvars, (argno == (Int)arity ?
|
|
unify_last_var_op :
|
|
unify_var_op)) :
|
|
(argno == (Int)arity ? unify_last_val_op :
|
|
unify_val_op)),
|
|
t, Zero, &cglobs->cint);
|
|
}
|
|
else {
|
|
if (level == 0)
|
|
Yap_emit((new ? (++cglobs->nvars, put_var_op) : put_val_op), t, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((new ? (++cglobs->nvars, write_var_op) : write_val_op), t, Zero, &cglobs->cint);
|
|
}
|
|
}
|
|
tag_var(t, new, cglobs);
|
|
}
|
|
|
|
static void
|
|
reset_vars(Ventry *vtable)
|
|
{
|
|
Ventry *v = vtable;
|
|
CELL *t;
|
|
|
|
while (v != NIL) {
|
|
t = (CELL *) v->AdrsOfVE;
|
|
RESET_VARIABLE(t);
|
|
v = v->NextOfVE;
|
|
}
|
|
}
|
|
|
|
static Term
|
|
optimize_ce(Term t, unsigned int arity, unsigned int level, compiler_struct *cglobs)
|
|
{
|
|
CExpEntry *p = cglobs->common_exps;
|
|
int cmp = 0;
|
|
|
|
#ifdef BEAM
|
|
if (EAM) return t;
|
|
#endif
|
|
|
|
if (IsApplTerm(t) && IsExtensionFunctor(FunctorOfTerm(t)))
|
|
return (t);
|
|
while (p != NULL) {
|
|
CELL *oldH = H;
|
|
H = (CELL *)cglobs->cint.freep;
|
|
cmp = Yap_compare_terms(t, (p->TermOfCE));
|
|
H = oldH;
|
|
|
|
if (cmp) {
|
|
p = p->NextCE;
|
|
} else {
|
|
break;
|
|
}
|
|
}
|
|
if (p != NULL) { /* already there */
|
|
return (p->VarOfCE);
|
|
}
|
|
/* first occurrence */
|
|
if (cglobs->onbranch || level > 1) {
|
|
return t;
|
|
}
|
|
++(cglobs->n_common_exps);
|
|
p = (CExpEntry *) Yap_AllocCMem(sizeof(CExpEntry), &cglobs->cint);
|
|
|
|
p->TermOfCE = t;
|
|
p->VarOfCE = MkVarTerm();
|
|
if (H >= (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
p->NextCE = cglobs->common_exps;
|
|
cglobs->common_exps = p;
|
|
if (IsApplTerm(t))
|
|
c_var(p->VarOfCE, save_appl_flag, arity, level, cglobs);
|
|
else if (IsPairTerm(t))
|
|
c_var(p->VarOfCE, save_pair_flag, arity, level, cglobs);
|
|
return (t);
|
|
}
|
|
|
|
#ifdef SFUNC
|
|
static void
|
|
compile_sf_term(Term t, int argno, int level)
|
|
{
|
|
Functor f = FunctorOfTerm(t);
|
|
CELL *p = ArgsOfSFTerm(t) - 1;
|
|
SFEntry *pe = RepSFProp(Yap_GetAProp(NameOfFunctor(f), SFProperty));
|
|
Term nullvalue = pe->NilValue;
|
|
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_s_f_op : put_s_f_op), f, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? unify_s_f_op : write_s_f_op), f, Zero, &cglobs->cint);
|
|
++level;
|
|
while ((argno = *++p)) {
|
|
t = Derefa(++p);
|
|
if (t != nullvalue) {
|
|
if (IsAtomicTerm(t))
|
|
Yap_emit((cglobs->onhead ? unify_s_a_op : write_s_a_op), t, (CELL) argno, &cglobs->cint);
|
|
else if (!IsVarTerm(t)) {
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "illegal argument of soft functor";
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
|
|
}
|
|
else
|
|
c_var(t, -argno, arity, level, cglobs);
|
|
}
|
|
}
|
|
--level;
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_s_end_op : put_s_end_op), Zero, Zero, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? unify_s_end_op : write_s_end_op), Zero, Zero, &cglobs->cint);
|
|
}
|
|
#endif
|
|
|
|
inline static void
|
|
c_args(Term app, unsigned int level, compiler_struct *cglobs)
|
|
{
|
|
Functor f = FunctorOfTerm(app);
|
|
unsigned int Arity = ArityOfFunctor(f);
|
|
unsigned int i;
|
|
|
|
if (level == 0) {
|
|
if (Arity >= MaxTemps) {
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "exceed maximum arity of compiled goal";
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
|
|
}
|
|
if (Arity > cglobs->max_args)
|
|
cglobs->max_args = Arity;
|
|
}
|
|
for (i = 1; i <= Arity; ++i)
|
|
c_arg(i, ArgOfTerm(i, app), Arity, level, cglobs);
|
|
}
|
|
|
|
static int
|
|
try_store_as_dbterm(Term t, Int argno, unsigned int arity, int level, compiler_struct *cglobs)
|
|
{
|
|
DBTerm *dbt;
|
|
int g;
|
|
CELL *h0 = H;
|
|
|
|
while ((g=Yap_SizeGroundTerm(t,TRUE)) < 0) {
|
|
/* oops, too deep a term */
|
|
save_machine_regs();
|
|
Yap_Error_Size = 0;
|
|
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH);
|
|
}
|
|
if (g < 16)
|
|
return FALSE;
|
|
/* store ground term away */
|
|
H = CellPtr(cglobs->cint.freep);
|
|
if ((dbt = Yap_StoreTermInDB(t, -1)) == NULL) {
|
|
H = h0;
|
|
switch(Yap_Error_TYPE) {
|
|
case OUT_OF_STACK_ERROR:
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_STACK_BOTCH);
|
|
case OUT_OF_TRAIL_ERROR:
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TRAIL_BOTCH);
|
|
case OUT_OF_HEAP_ERROR:
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_HEAP_BOTCH);
|
|
case OUT_OF_AUXSPACE_ERROR:
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_AUX_BOTCH);
|
|
default:
|
|
siglongjmp(cglobs->cint.CompilerBotch,COMPILER_ERR_BOTCH);
|
|
}
|
|
}
|
|
H = h0;
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_dbterm_op : put_dbterm_op), dbt->Entry, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_dbterm_op
|
|
: unify_dbterm_op) :
|
|
write_dbterm_op), dbt->Entry, Zero, &cglobs->cint);
|
|
return TRUE;
|
|
}
|
|
|
|
static void
|
|
c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct *cglobs)
|
|
{
|
|
restart:
|
|
if (IsVarTerm(t))
|
|
c_var(t, argno, arity, level, cglobs);
|
|
else if (IsAtomTerm(t)) {
|
|
if (level == 0) {
|
|
Yap_emit((cglobs->onhead ? get_atom_op : put_atom_op), (CELL) t, argno, &cglobs->cint);
|
|
} else
|
|
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_atom_op
|
|
: unify_atom_op) :
|
|
write_atom_op), (CELL) t, Zero, &cglobs->cint);
|
|
} else if (IsIntegerTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t)) {
|
|
if (!IsIntTerm(t)) {
|
|
if (IsFloatTerm(t)) {
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_float_op : put_float_op), t, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_float_op
|
|
: unify_float_op) :
|
|
write_float_op), t, Zero, &cglobs->cint);
|
|
} else if (IsLongIntTerm(t)) {
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_longint_op : put_longint_op), t, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_longint_op
|
|
: unify_longint_op) :
|
|
write_longint_op), t, Zero, &cglobs->cint);
|
|
} else {
|
|
/* we are taking a blob, that is a binary that is supposed to be
|
|
guarded in the clause itself. Possible examples include
|
|
floats, long ints, bignums, bitmaps.... */
|
|
CELL l1 = ++cglobs->labelno;
|
|
CELL *src = RepAppl(t);
|
|
PInstr *ocpc = cglobs->cint.cpc, *OCodeStart = cglobs->cint.CodeStart;
|
|
Int sz = 2*sizeof(CELL)+
|
|
sizeof(MP_INT)+
|
|
((((MP_INT *)(RepAppl(t)+2))->_mp_alloc)*sizeof(mp_limb_t));
|
|
CELL *dest;
|
|
|
|
/* use a special list to store the blobs */
|
|
cglobs->cint.cpc = cglobs->cint.icpc;
|
|
/* if (IsFloatTerm(t)) {
|
|
Yap_emit(align_float_op, Zero, Zero, &cglobs->cint);
|
|
}*/
|
|
Yap_emit(label_op, l1, Zero, &cglobs->cint);
|
|
dest =
|
|
Yap_emit_extra_size(blob_op, sz/CellSize, sz, &cglobs->cint);
|
|
|
|
/* copy the bignum */
|
|
memcpy(dest, src, sz);
|
|
/* note that we don't need to copy size info, unless we wanted
|
|
to garbage collect clauses ;-) */
|
|
cglobs->cint.icpc = cglobs->cint.cpc;
|
|
if (cglobs->cint.BlobsStart == NULL)
|
|
cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
|
|
cglobs->cint.cpc = ocpc;
|
|
cglobs->cint.CodeStart = OCodeStart;
|
|
/* The argument to pass to the structure is now the label for
|
|
where we are storing the blob */
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_bigint_op : put_bigint_op), l1, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_bigint_op
|
|
: unify_bigint_op) :
|
|
write_bigint_op), l1, Zero, &cglobs->cint);
|
|
}
|
|
/* That's it folks! */
|
|
return;
|
|
}
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_num_op : put_num_op), (CELL) t, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_num_op
|
|
: unify_num_op) :
|
|
write_num_op), (CELL) t, Zero, &cglobs->cint);
|
|
} else if (IsPairTerm(t)) {
|
|
cglobs->space_used += 2;
|
|
if (optimizer_on && level < 6) {
|
|
#if !defined(THREADS)
|
|
/* discard code sharing because we cannot write on shared stuff */
|
|
if (!(cglobs->cint.CurrentPred->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
|
|
if (try_store_as_dbterm(t, argno, arity, level, cglobs))
|
|
return;
|
|
}
|
|
#endif
|
|
t = optimize_ce(t, arity, level, cglobs);
|
|
if (IsVarTerm(t)) {
|
|
c_var(t, argno, arity, level, cglobs);
|
|
return;
|
|
}
|
|
}
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_list_op : put_list_op), Zero, argno, &cglobs->cint);
|
|
else if (argno == (Int)arity)
|
|
Yap_emit((cglobs->onhead ? unify_last_list_op : write_last_list_op), Zero, Zero, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? unify_list_op : write_list_op), Zero, Zero, &cglobs->cint);
|
|
++level;
|
|
c_arg(1, HeadOfTerm(t), 2, level, cglobs);
|
|
if (argno == (Int)arity) {
|
|
/* optimise for tail recursion */
|
|
t = TailOfTerm(t);
|
|
goto restart;
|
|
}
|
|
c_arg(2, TailOfTerm(t), 2, level, cglobs);
|
|
--level;
|
|
if (argno != (Int)arity) {
|
|
pop_code(level, cglobs);
|
|
}
|
|
} else if (IsRefTerm(t)) {
|
|
PELOCK(40,cglobs->cint.CurrentPred);
|
|
if (!(cglobs->cint.CurrentPred->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
FAIL("can not compile data base reference",TYPE_ERROR_CALLABLE,t);
|
|
} else {
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
cglobs->hasdbrefs = TRUE;
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_atom_op : put_atom_op), (CELL) t, argno, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_atom_op
|
|
: unify_atom_op) :
|
|
write_atom_op), (CELL) t, Zero, &cglobs->cint);
|
|
}
|
|
} else {
|
|
|
|
#ifdef SFUNC
|
|
if (SFTerm(t)) {
|
|
compile_sf_term(t, argno);
|
|
return;
|
|
}
|
|
#endif
|
|
|
|
if (optimizer_on) {
|
|
if (!(cglobs->cint.CurrentPred->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
|
|
if (try_store_as_dbterm(t, argno, arity, level, cglobs))
|
|
return;
|
|
}
|
|
t = optimize_ce(t, arity, level, cglobs);
|
|
if (IsVarTerm(t)) {
|
|
c_var(t, argno, arity, level, cglobs);
|
|
return;
|
|
}
|
|
}
|
|
cglobs->space_used += 1+arity;
|
|
if (level == 0)
|
|
Yap_emit((cglobs->onhead ? get_struct_op : put_struct_op),
|
|
(CELL) FunctorOfTerm(t), argno, &cglobs->cint);
|
|
else if (argno == (Int)arity)
|
|
Yap_emit((cglobs->onhead ? unify_last_struct_op : write_last_struct_op),
|
|
(CELL) FunctorOfTerm(t), Zero, &cglobs->cint);
|
|
else
|
|
Yap_emit((cglobs->onhead ? unify_struct_op : write_struct_op),
|
|
(CELL) FunctorOfTerm(t), Zero, &cglobs->cint);
|
|
++level;
|
|
c_args(t, level, cglobs);
|
|
--level;
|
|
if (argno != (Int)arity) {
|
|
pop_code(level, cglobs);
|
|
}
|
|
}
|
|
}
|
|
|
|
static void
|
|
c_eq(Term t1, Term t2, compiler_struct *cglobs)
|
|
{
|
|
if (t1 == t2) {
|
|
Yap_emit(nop_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
if (IsNonVarTerm(t1)) {
|
|
if (IsVarTerm(t2)) {
|
|
Term t = t1;
|
|
t1 = t2;
|
|
t2 = t;
|
|
} else {
|
|
/* compile unification */
|
|
if (IsAtomicTerm(t1)) {
|
|
/* just check if they unify */
|
|
if (!IsAtomicTerm(t2) || !Yap_unify(t1,t2)) {
|
|
/* they don't */
|
|
Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
/* they do */
|
|
Yap_emit(nop_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
} else if (IsPairTerm(t1)) {
|
|
/* just check if they unify */
|
|
if (!IsPairTerm(t2)) {
|
|
/* they don't */
|
|
Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
/* they might */
|
|
c_eq(HeadOfTerm(t1), HeadOfTerm(t2), cglobs);
|
|
c_eq(TailOfTerm(t1), TailOfTerm(t2), cglobs);
|
|
return;
|
|
} else if (IsRefTerm(t1)) {
|
|
/* just check if they unify */
|
|
if (t1 != t2) {
|
|
/* they don't */
|
|
Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
/* they do */
|
|
Yap_emit(nop_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
} else {
|
|
/* compound terms */
|
|
Functor f = FunctorOfTerm(t1);
|
|
UInt i, max;
|
|
/* just check if they unify */
|
|
if (!IsApplTerm(t2) ||
|
|
FunctorOfTerm(t2) != f) {
|
|
/* they don't */
|
|
Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
/* they might */
|
|
max = ArityOfFunctor(f);
|
|
for (i=0; i < max; i++) {
|
|
c_eq(ArgOfTerm(i+1,t1), ArgOfTerm(i+1,t2), cglobs);
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
/* first argument is an unbound var */
|
|
if (IsNewVar(t1) && !(cglobs->cint.CurrentPred->PredFlags & TabledPredFlag)) {
|
|
Int v;
|
|
if (IsVarTerm(t2)) {
|
|
v = 0;
|
|
c_var(t2, v, 0, 0, cglobs);
|
|
cglobs->onhead = TRUE;
|
|
c_var(t1, v, 0, 0, cglobs);
|
|
cglobs->onhead = FALSE;
|
|
} else {
|
|
v = --cglobs->tmpreg;
|
|
c_arg(v, t2, 0, 0, cglobs);
|
|
cglobs->onhead = TRUE;
|
|
c_var(t1, v, 0, 0, cglobs);
|
|
cglobs->onhead = FALSE;
|
|
}
|
|
} else {
|
|
if (IsVarTerm(t2)) {
|
|
c_var(t1, 0, 0, 0, cglobs);
|
|
cglobs->onhead = TRUE;
|
|
c_var(t2, 0, 0, 0, cglobs);
|
|
} else {
|
|
Int v = --cglobs->tmpreg;
|
|
c_var(t1, v, 0, 0, cglobs);
|
|
cglobs->onhead = TRUE;
|
|
c_arg(v, t2, 0, 0, cglobs);
|
|
}
|
|
cglobs->onhead = FALSE;
|
|
}
|
|
}
|
|
|
|
static void
|
|
c_test(Int Op, Term t1, compiler_struct *cglobs) {
|
|
Term t = Deref(t1);
|
|
|
|
if (!IsVarTerm(t) || IsNewVar(t)) {
|
|
Term tn = MkVarTerm();
|
|
c_eq(t, tn, cglobs);
|
|
t = tn;
|
|
}
|
|
if (Op == _cut_by)
|
|
c_var(t, commit_b_flag, 1, 0, cglobs);
|
|
else
|
|
c_var(t, f_flag,(unsigned int)Op, 0, cglobs);
|
|
}
|
|
|
|
/* Arithmetic builtins will be compiled in the form:
|
|
|
|
fetch_args_vv Xi,Xj
|
|
put_val Xi,Ri
|
|
put_val Xj,Rj
|
|
put_var Xk,Ak
|
|
bip_body Op,Xk
|
|
|
|
The put_var should always be disposable, and the put_vals can be disposed of if R is an X.
|
|
This, in the best case, Ri and Rj are WAM temp registers and this will reduce to:
|
|
|
|
bip Op,Ak,Ri,Rj
|
|
|
|
meaning a single WAM op will call the clause.
|
|
|
|
|
|
If one of the arguments is a constant, the result will be:
|
|
|
|
fetch_args_vc Xi,C
|
|
put_val Xi,Ri
|
|
put_var Xk,Ak
|
|
bip_body Op,Xk
|
|
|
|
and this should reduce to :
|
|
|
|
bip_cons Op,Xk,Ri,C
|
|
|
|
*/
|
|
static void
|
|
c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler_struct *cglobs)
|
|
{
|
|
/* compile Z = X Op Y arithmetic function */
|
|
/* first we fetch the arguments */
|
|
|
|
if (IsVarTerm(t1)) {
|
|
if (IsVarTerm(t2)) {
|
|
/* first temp */
|
|
Int v1 = --cglobs->tmpreg;
|
|
/* second temp */
|
|
Int v2 = --cglobs->tmpreg;
|
|
|
|
Yap_emit(fetch_args_vv_op, Zero, Zero, &cglobs->cint);
|
|
/* these should be the arguments */
|
|
c_var(t1, v1, 0, 0, cglobs);
|
|
c_var(t2, v2, 0, 0, cglobs);
|
|
/* now we know where the arguments are */
|
|
} else {
|
|
if (Op == _arg) {
|
|
/* we know the second argument is bound */
|
|
if (IsPrimitiveTerm(t2) || IsNumTerm(t2)) {
|
|
Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
} else {
|
|
Term tn = MkVarTerm();
|
|
Int v1 = --cglobs->tmpreg;
|
|
Int v2 = --cglobs->tmpreg;
|
|
|
|
c_eq(t2, tn, cglobs);
|
|
Yap_emit(fetch_args_vv_op, Zero, Zero, &cglobs->cint);
|
|
/* these should be the arguments */
|
|
c_var(t1, v1, 0, 0, cglobs);
|
|
c_var(tn, v2, 0, 0, cglobs);
|
|
}
|
|
/* it has to be either an integer or a floating point */
|
|
} else if (IsIntegerTerm(t2)) {
|
|
/* first temp */
|
|
Int v1 = 0;
|
|
|
|
Yap_emit(fetch_args_vi_op, IntegerOfTerm(t2), 0L, &cglobs->cint);
|
|
/* these should be the arguments */
|
|
c_var(t1, v1, 0, 0, cglobs);
|
|
/* now we know where the arguments are */
|
|
} else {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_NUMBER;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2 with output bound", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
}
|
|
} else { /* t1 is bound */
|
|
/* it has to be either an integer or a floating point */
|
|
if (IsVarTerm(t2)) {
|
|
if (IsNewVar(t2)) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = INSTANTIATION_ERROR;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/3",s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
} else {
|
|
if (Op == _functor) {
|
|
/* both arguments are bound, we must perform unification */
|
|
Int i2;
|
|
|
|
if (!IsIntegerTerm(t2)) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_INTEGER;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling functor/3");
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
i2 = IntegerOfTerm(t2);
|
|
if (i2 < 0) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = DOMAIN_ERROR_NOT_LESS_THAN_ZERO;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling functor/3");
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
if (IsNumTerm(t1)) {
|
|
/* we will always fail */
|
|
if (i2)
|
|
c_goal(MkAtomTerm(AtomFalse), mod, cglobs);
|
|
} else if (!IsAtomTerm(t1)) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_ATOM;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling functor/3");
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
if (i2 == 0)
|
|
c_eq(t1, t3, cglobs);
|
|
else {
|
|
CELL *hi = H;
|
|
Int i;
|
|
|
|
if (t1 == TermDot && i2 == 2) {
|
|
if (H+2 >= (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
RESET_VARIABLE(H);
|
|
RESET_VARIABLE(H+1);
|
|
H += 2;
|
|
c_eq(AbsPair(H-2),t3, cglobs);
|
|
} else if (i2 < 256 && IsAtomTerm(t1)) {
|
|
*H++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1),i2);
|
|
for (i=0; i < i2; i++) {
|
|
if (H >= (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
RESET_VARIABLE(H);
|
|
H++;
|
|
}
|
|
c_eq(AbsAppl(hi),t3, cglobs);
|
|
} else {
|
|
/* compile as default */
|
|
Functor f = FunctorOfTerm(Goal);
|
|
Prop p0 = PredPropByFunc(f, mod);
|
|
if (EndOfPAEntr(p0)) {
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
|
|
}
|
|
c_args(Goal, 0, cglobs);
|
|
Yap_emit(safe_call_op, (CELL)p0 , Zero, &cglobs->cint);
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
}
|
|
} else if (Op == _arg) {
|
|
Int i1;
|
|
if (IsIntegerTerm(t1))
|
|
i1 = IntegerOfTerm(t1);
|
|
else {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_INTEGER;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
if (IsAtomicTerm(t2) ||
|
|
(IsApplTerm(t2) && IsExtensionFunctor(FunctorOfTerm(t2)))) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_COMPOUND;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
} else if (IsApplTerm(t2)) {
|
|
Functor f = FunctorOfTerm(t2);
|
|
if (i1 < 1 || i1 > ArityOfFunctor(f)) {
|
|
c_goal(MkAtomTerm(AtomFalse), mod, cglobs);
|
|
} else {
|
|
c_eq(ArgOfTerm(i1, t2), t3, cglobs);
|
|
}
|
|
return;
|
|
} else if (IsPairTerm(t2)) {
|
|
switch (i1) {
|
|
case 1:
|
|
c_eq(HeadOfTerm(t2), t3, cglobs);
|
|
return;
|
|
case 2:
|
|
c_eq(TailOfTerm(t2), t3, cglobs);
|
|
return;
|
|
default:
|
|
c_goal(MkAtomTerm(AtomFalse), mod, cglobs);
|
|
return;
|
|
}
|
|
}
|
|
} else {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_INTEGER;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
}
|
|
if (Op == _functor) {
|
|
if (!IsAtomicTerm(t1)) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_ATOM;
|
|
Yap_Error_Term = t1;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
} else {
|
|
if (!IsVarTerm(t2)) {
|
|
Int arity;
|
|
|
|
/* We actually have the term ready, so let's just do the unification now */
|
|
if (!IsIntegerTerm(t2)) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_INTEGER;
|
|
Yap_Error_Term = t2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
arity = IntOfTerm(t2);
|
|
if (arity < 0) {
|
|
/* fail straight away */
|
|
Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
|
|
}
|
|
if (arity) {
|
|
Term tnew;
|
|
if (!IsAtomTerm(t1)) {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_ATOM;
|
|
Yap_Error_Term = t1;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
if (H+1+arity >= (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
tnew = AbsAppl(H);
|
|
*H++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1),arity);
|
|
while (arity--) {
|
|
RESET_VARIABLE(H);
|
|
H++;
|
|
}
|
|
c_eq(tnew, t3, cglobs);
|
|
} else {
|
|
/* just unify the two arguments */
|
|
c_eq(t1,t3, cglobs);
|
|
}
|
|
return;
|
|
} else {
|
|
/* first temp */
|
|
Int v1 = 0;
|
|
Yap_emit(fetch_args_cv_op, t1, Zero, &cglobs->cint);
|
|
/* these should be the arguments */
|
|
c_var(t2, v1, 0, 0, cglobs);
|
|
/* now we know where the arguments are */
|
|
}
|
|
}
|
|
} else if (IsIntegerTerm(t1)) {
|
|
/* first temp */
|
|
Int v1 = 0;
|
|
Yap_emit(fetch_args_iv_op, IntegerOfTerm(t1), 0L, &cglobs->cint);
|
|
/* these should be the arguments */
|
|
c_var(t2, v1, 0, 0, cglobs);
|
|
/* now we know where the arguments are */
|
|
} else {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_VARIABLE;
|
|
Yap_Error_Term = t1;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2 with output bound", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
}
|
|
/* then we compile the opcode/result */
|
|
if (!IsVarTerm(t3)) {
|
|
if (Op == _arg) {
|
|
Term tmpvar = MkVarTerm();
|
|
if (H == (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
c_var(tmpvar,f_flag,(unsigned int)Op, 0, cglobs);
|
|
c_eq(tmpvar,t3, cglobs);
|
|
} else {
|
|
char s[32];
|
|
|
|
Yap_Error_TYPE = TYPE_ERROR_VARIABLE;
|
|
Yap_Error_Term = t3;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_bip_name(Op, s);
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2 with input unbound", s);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
} else if (IsNewVar(t3) && cglobs->curbranch == 0 && cglobs->cint.CurrentPred->PredFlags & TabledPredFlag) {
|
|
Term nv = MkVarTerm();
|
|
c_var(nv,f_flag,(unsigned int)Op, 0, cglobs);
|
|
if (Op == _functor) {
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
}
|
|
/* make sure that we first get the true t3, and then bind it to nv. That way it will be confitional */
|
|
c_eq(t3, nv, cglobs);
|
|
} else if (IsNewVar(t3) && cglobs->curbranch == 0 /* otherwise you may have trouble with z(X) :- ( Z is X*2 ; write(Z)) */) {
|
|
c_var(t3,f_flag,(unsigned int)Op, 0, cglobs);
|
|
if (Op == _functor) {
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
}
|
|
} else {
|
|
/* generate code for a temp and then unify temp with previous variable */
|
|
Yap_emit(f_0_op, 0, (unsigned int)Op, &cglobs->cint);
|
|
/* I have to do it here, before I do the unification */
|
|
if (Op == _functor) {
|
|
Yap_emit(empty_call_op, Zero, (unsigned int)Op, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
}
|
|
cglobs->onhead = TRUE;
|
|
c_var(t3, 0, 0, 0, cglobs);
|
|
cglobs->onhead = FALSE;
|
|
}
|
|
}
|
|
|
|
static void
|
|
c_functor(Term Goal, Term mod, compiler_struct *cglobs)
|
|
{
|
|
Term t1 = ArgOfTerm(1, Goal);
|
|
Term t2 = ArgOfTerm(2, Goal);
|
|
Term t3 = ArgOfTerm(3, Goal);
|
|
|
|
if (IsVarTerm(t1) && IsNewVar(t1)) {
|
|
c_bifun(_functor, t2, t3, t1, Goal, mod, cglobs);
|
|
} else if (IsNonVarTerm(t1)) {
|
|
/* just split the structure */
|
|
if (IsAtomicTerm(t1)) {
|
|
c_eq(t1,t2, cglobs);
|
|
c_eq(t3,MkIntTerm(0), cglobs);
|
|
} else if (IsApplTerm(t1)) {
|
|
Functor f = FunctorOfTerm(t1);
|
|
c_eq(t2,MkAtomTerm(NameOfFunctor(f)), cglobs);
|
|
c_eq(t3,MkIntegerTerm(ArityOfFunctor(f)), cglobs);
|
|
} else /* list */ {
|
|
c_eq(t2,TermDot, cglobs);
|
|
c_eq(t3,MkIntTerm(2), cglobs);
|
|
}
|
|
} else if (IsVarTerm(t2) && IsNewVar(t2) &&
|
|
IsVarTerm(t3) && IsNewVar(t3)) {
|
|
Int v1 = --cglobs->tmpreg;
|
|
Yap_emit(fetch_args_vi_op, Zero, Zero, &cglobs->cint);
|
|
c_var(t1, v1, 0, 0, cglobs);
|
|
c_var(t2,f_flag,(unsigned int)_functor, 0, cglobs);
|
|
c_var(t3,f_flag,(unsigned int)_functor, 0, cglobs);
|
|
} else {
|
|
Functor f = FunctorOfTerm(Goal);
|
|
Prop p0 = PredPropByFunc(f, mod);
|
|
|
|
if (EndOfPAEntr(p0)) {
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
|
|
}
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero, &cglobs->cint);
|
|
else if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)RepPredProp(p0), Zero, &cglobs->cint);
|
|
c_args(Goal, 0, cglobs);
|
|
Yap_emit(safe_call_op, (CELL)p0 , Zero, &cglobs->cint);
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
}
|
|
}
|
|
|
|
static int
|
|
IsTrueGoal(Term t) {
|
|
if (IsVarTerm(t)) return(FALSE);
|
|
if (IsApplTerm(t)) {
|
|
Functor f = FunctorOfTerm(t);
|
|
if (f == FunctorModule) {
|
|
return(IsTrueGoal(ArgOfTerm(2,t)));
|
|
}
|
|
if (f == FunctorComma || f == FunctorOr || f == FunctorVBar || f == FunctorArrow) {
|
|
return(IsTrueGoal(ArgOfTerm(1,t)) && IsTrueGoal(ArgOfTerm(2,t)));
|
|
}
|
|
return(FALSE);
|
|
}
|
|
return(t == MkAtomTerm(AtomTrue));
|
|
}
|
|
|
|
static void
|
|
emit_special_label(Term Goal, compiler_struct *cglobs)
|
|
{
|
|
special_label_op lab_op = IntOfTerm(ArgOfTerm(1,Goal));
|
|
special_label_id lab_id = IntOfTerm(ArgOfTerm(2,Goal));
|
|
UInt label_name;
|
|
|
|
switch (lab_op) {
|
|
case SPECIAL_LABEL_INIT:
|
|
label_name = ++cglobs->labelno;
|
|
switch (lab_id) {
|
|
case SPECIAL_LABEL_EXCEPTION:
|
|
cglobs->cint.exception_handler = label_name;
|
|
break;
|
|
case SPECIAL_LABEL_SUCCESS:
|
|
cglobs->cint.success_handler = label_name;
|
|
break;
|
|
case SPECIAL_LABEL_FAILURE:
|
|
cglobs->cint.failure_handler = label_name;
|
|
break;
|
|
}
|
|
Yap_emit_3ops(label_ctl_op, lab_op, lab_id, label_name, &cglobs->cint);
|
|
break;
|
|
case SPECIAL_LABEL_SET:
|
|
switch (lab_id) {
|
|
case SPECIAL_LABEL_EXCEPTION:
|
|
Yap_emit(label_op, cglobs->cint.exception_handler, Zero, &cglobs->cint);
|
|
break;
|
|
case SPECIAL_LABEL_SUCCESS:
|
|
Yap_emit(label_op, cglobs->cint.success_handler, Zero, &cglobs->cint);
|
|
break;
|
|
case SPECIAL_LABEL_FAILURE:
|
|
Yap_emit(label_op, cglobs->cint.failure_handler, Zero, &cglobs->cint);
|
|
break;
|
|
}
|
|
case SPECIAL_LABEL_CLEAR:
|
|
switch (lab_id) {
|
|
case SPECIAL_LABEL_EXCEPTION:
|
|
cglobs->cint.exception_handler = 0L;
|
|
break;
|
|
case SPECIAL_LABEL_SUCCESS:
|
|
cglobs->cint.success_handler = 0L;
|
|
break;
|
|
case SPECIAL_LABEL_FAILURE:
|
|
cglobs->cint.failure_handler = 0L;
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
|
|
static void
|
|
c_goal(Term Goal, Term mod, compiler_struct *cglobs)
|
|
{
|
|
Functor f;
|
|
PredEntry *p;
|
|
Prop p0;
|
|
|
|
if (IsVarTerm(Goal)) {
|
|
Goal = Yap_MkApplTerm(FunctorCall, 1, &Goal);
|
|
}
|
|
if (IsApplTerm(Goal) && FunctorOfTerm(Goal) == FunctorModule) {
|
|
Term M = ArgOfTerm(1, Goal);
|
|
|
|
if (IsVarTerm(M) || !IsAtomTerm(M)) {
|
|
if (IsVarTerm(M)) {
|
|
Yap_Error_TYPE = INSTANTIATION_ERROR;
|
|
} else {
|
|
Yap_Error_TYPE = TYPE_ERROR_ATOM;
|
|
}
|
|
Yap_Error_Term = M;
|
|
Yap_ErrorMessage = "in module name";
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
|
|
}
|
|
Goal = ArgOfTerm(2, Goal);
|
|
mod = M;
|
|
}
|
|
if (IsVarTerm(Goal)) {
|
|
Goal = Yap_MkApplTerm(FunctorCall, 1, &Goal);
|
|
} else if (IsNumTerm(Goal)) {
|
|
FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal);
|
|
} else if (IsRefTerm(Goal)) {
|
|
Yap_Error_TYPE = TYPE_ERROR_DBREF;
|
|
Yap_Error_Term = Goal;
|
|
FAIL("goal argument in static procedure can not be a data base reference", TYPE_ERROR_CALLABLE, Goal);
|
|
}
|
|
else if (IsPairTerm(Goal)) {
|
|
Goal = Yap_MkApplTerm(FunctorCall, 1, &Goal);
|
|
}
|
|
if (IsAtomTerm(Goal)) {
|
|
Atom atom = AtomOfTerm(Goal);
|
|
|
|
if (atom == AtomFail || atom == AtomFalse) {
|
|
Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
else if (atom == AtomTrue || atom == AtomOtherwise) {
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(41,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
return;
|
|
}
|
|
else if (atom == AtomCut) {
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomCut,0)), Zero, &cglobs->cint);
|
|
else if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)RepPredProp(PredPropByAtom(AtomCut,0)), Zero, &cglobs->cint);
|
|
if (cglobs->onlast) {
|
|
/* never a problem here with a -> b, !, c ; d */
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(42,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred)) {
|
|
Yap_emit_3ops(cut_op, Zero, Zero, Zero, &cglobs->cint);
|
|
/* needs to adjust previous commits */
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
}
|
|
else
|
|
#endif /* TABLING */
|
|
{
|
|
Yap_emit_3ops(cutexit_op, Zero, Zero, Zero, &cglobs->cint);
|
|
/* needs to adjust previous commits */
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
}
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
else {
|
|
Yap_emit_3ops(cut_op, Zero, Zero, Zero, &cglobs->cint);
|
|
/* needs to adjust previous commits */
|
|
Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
|
|
adjust_current_commits(cglobs);
|
|
}
|
|
return;
|
|
}
|
|
#ifndef YAPOR
|
|
else if (atom == AtomRepeat) {
|
|
CELL l1 = ++cglobs->labelno;
|
|
CELL l2 = ++cglobs->labelno;
|
|
|
|
/* I need an either_me */
|
|
cglobs->needs_env = TRUE;
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomRepeat,0)), Zero, &cglobs->cint);
|
|
else if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)RepPredProp(PredPropByAtom(AtomRepeat,0)), Zero, &cglobs->cint);
|
|
cglobs->or_found = TRUE;
|
|
push_branch(cglobs->onbranch, TermNil, cglobs);
|
|
cglobs->curbranch++;
|
|
cglobs->onbranch = cglobs->curbranch;
|
|
if (cglobs->onlast)
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit_3ops(push_or_op, l1, Zero, Zero, &cglobs->cint);
|
|
Yap_emit_3ops(either_op, l1, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(jump_op, l2, Zero, &cglobs->cint);
|
|
Yap_emit(label_op, l1, Zero, &cglobs->cint);
|
|
Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit_3ops(orelse_op, l1, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(label_op, l2, Zero, &cglobs->cint);
|
|
if (cglobs->onlast) {
|
|
#ifdef TABLING
|
|
PELOCK(43,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
else
|
|
++cglobs->goalno;
|
|
cglobs->onbranch = pop_branch(cglobs);
|
|
Yap_emit(pop_or_op, Zero, Zero, &cglobs->cint);
|
|
/* --cglobs->onbranch; */
|
|
return;
|
|
}
|
|
#endif /* YAPOR */
|
|
p = RepPredProp(p0 = Yap_PredPropByAtomNonThreadLocal(atom, mod));
|
|
if (EndOfPAEntr(p0)) {
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
|
|
}
|
|
/* if we are profiling, make sure we register we entered this predicate */
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
|
|
if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
|
|
}
|
|
else {
|
|
f = FunctorOfTerm(Goal);
|
|
p = RepPredProp(p0 = Yap_PredPropByFunctorNonThreadLocal(f, mod));
|
|
if (EndOfPAEntr(p0)) {
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
|
|
}
|
|
if (f == FunctorOr || f == FunctorVBar) {
|
|
Term arg;
|
|
CELL l = ++cglobs->labelno;
|
|
CELL m = ++cglobs->labelno;
|
|
int save = cglobs->onlast;
|
|
int savegoalno = cglobs->goalno;
|
|
int frst = TRUE;
|
|
int commitflag = 0;
|
|
int looking_at_commit = FALSE;
|
|
int optimizing_commit = FALSE;
|
|
Term commitvar = 0;
|
|
PInstr *FirstP = cglobs->cint.cpc, *savecpc, *savencpc;
|
|
|
|
push_branch(cglobs->onbranch, TermNil, cglobs);
|
|
++cglobs->curbranch;
|
|
cglobs->onbranch = cglobs->curbranch;
|
|
cglobs->or_found = TRUE;
|
|
do {
|
|
arg = ArgOfTerm(1, Goal);
|
|
looking_at_commit = IsApplTerm(arg) &&
|
|
FunctorOfTerm(arg) == FunctorArrow;
|
|
if (frst) {
|
|
if (optimizing_commit) {
|
|
Yap_emit(label_op, l, Zero, &cglobs->cint);
|
|
l = ++cglobs->labelno;
|
|
}
|
|
Yap_emit_3ops(push_or_op, l, Zero, Zero, &cglobs->cint);
|
|
if (looking_at_commit &&
|
|
Yap_is_a_test_pred(ArgOfTerm(1, arg), mod)) {
|
|
/*
|
|
* let them think they are still the
|
|
* first
|
|
*/
|
|
// Yap_emit(commit_opt_op, l, Zero, &cglobs->cint);
|
|
optimizing_commit = TRUE;
|
|
Yap_emit_3ops(label_ctl_op, SPECIAL_LABEL_INIT, SPECIAL_LABEL_FAILURE, l, &cglobs->cint);
|
|
}
|
|
else {
|
|
optimizing_commit = FALSE;
|
|
cglobs->needs_env = TRUE;
|
|
Yap_emit_3ops(either_op, l, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_op, Zero, Zero, &cglobs->cint);
|
|
frst = FALSE;
|
|
}
|
|
}
|
|
else {
|
|
optimizing_commit = FALSE;
|
|
Yap_emit(label_op, l, Zero, &cglobs->cint);
|
|
Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit_3ops(orelse_op, l = ++cglobs->labelno, Zero, Zero, &cglobs->cint);
|
|
cglobs->needs_env = TRUE;
|
|
}
|
|
/*
|
|
* if(IsApplTerm(arg) &&
|
|
* FunctorOfTerm(arg)==FunctorArrow) {
|
|
*/
|
|
if (looking_at_commit) {
|
|
if (!optimizing_commit && !commitflag) {
|
|
/* This instruction is placed before
|
|
* the disjunction. This means that
|
|
* the program counter must point
|
|
* correctly, and also that the age
|
|
* of variable is older than the
|
|
* current branch.
|
|
*/
|
|
int my_goalno = cglobs->goalno;
|
|
|
|
cglobs->goalno = savegoalno;
|
|
commitflag = cglobs->labelno;
|
|
commitvar = MkVarTerm();
|
|
if (H == (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
savecpc = cglobs->cint.cpc;
|
|
savencpc = FirstP->nextInst;
|
|
cglobs->cint.cpc = FirstP;
|
|
cglobs->onbranch = pop_branch(cglobs);
|
|
c_var(commitvar, save_b_flag, 1, 0, cglobs);
|
|
push_branch(cglobs->onbranch, commitvar, cglobs);
|
|
cglobs->onbranch = cglobs->curbranch;
|
|
cglobs->cint.cpc->nextInst = savencpc;
|
|
cglobs->cint.cpc = savecpc;
|
|
cglobs->goalno = my_goalno;
|
|
}
|
|
save = cglobs->onlast;
|
|
cglobs->onlast = FALSE;
|
|
c_goal(ArgOfTerm(1, arg), mod, cglobs);
|
|
if (!optimizing_commit) {
|
|
c_var((Term) commitvar, commit_b_flag,
|
|
1, 0, cglobs);
|
|
} else {
|
|
Yap_emit_3ops(label_ctl_op, SPECIAL_LABEL_CLEAR, SPECIAL_LABEL_FAILURE, l, &cglobs->cint);
|
|
}
|
|
cglobs->onlast = save;
|
|
c_goal(ArgOfTerm(2, arg), mod, cglobs);
|
|
}
|
|
else {
|
|
/* standard disjunction */
|
|
c_goal(ArgOfTerm(1, Goal), mod, cglobs);
|
|
}
|
|
if (!cglobs->onlast) {
|
|
Yap_emit(jump_op, m, Zero, &cglobs->cint);
|
|
} else {
|
|
|
|
}
|
|
if (!optimizing_commit || !cglobs->onlast) {
|
|
cglobs->goalno = savegoalno + 1;
|
|
}
|
|
Goal = ArgOfTerm(2, Goal);
|
|
++cglobs->curbranch;
|
|
cglobs->onbranch = cglobs->curbranch;
|
|
} while (IsNonVarTerm(Goal) && IsApplTerm(Goal)
|
|
&& (FunctorOfTerm(Goal) == FunctorOr
|
|
|| FunctorOfTerm(Goal) == FunctorVBar));
|
|
Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(label_op, l, Zero, &cglobs->cint);
|
|
if (!optimizing_commit) {
|
|
Yap_emit(orlast_op, Zero, Zero, &cglobs->cint);
|
|
} else {
|
|
optimizing_commit = FALSE; /* not really necessary */
|
|
}
|
|
c_goal(Goal, mod, cglobs);
|
|
/* --cglobs->onbranch; */
|
|
cglobs->onbranch = pop_branch(cglobs);
|
|
if (!cglobs->onlast) {
|
|
Yap_emit(label_op, m, Zero, &cglobs->cint);
|
|
if ((cglobs->onlast = save))
|
|
c_goal(MkAtomTerm(AtomTrue), mod, cglobs);
|
|
}
|
|
Yap_emit(pop_or_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
else if (f == FunctorComma) {
|
|
int save = cglobs->onlast;
|
|
Term t2 = ArgOfTerm(2, Goal);
|
|
|
|
cglobs->onlast = FALSE;
|
|
c_goal(ArgOfTerm(1, Goal), mod, cglobs);
|
|
cglobs->onlast = save;
|
|
c_goal(t2, mod, cglobs);
|
|
return;
|
|
}
|
|
else if (f == FunctorNot || f == FunctorAltNot) {
|
|
CELL label = (cglobs->labelno += 2);
|
|
CELL end_label = (cglobs->labelno += 2);
|
|
int save = cglobs->onlast;
|
|
Term commitvar;
|
|
|
|
/* for now */
|
|
cglobs->needs_env = TRUE;
|
|
commitvar = MkVarTerm();
|
|
if (H == (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
push_branch(cglobs->onbranch, commitvar, cglobs);
|
|
++cglobs->curbranch;
|
|
cglobs->onbranch = cglobs->curbranch;
|
|
cglobs->or_found = TRUE;
|
|
cglobs->onlast = FALSE;
|
|
c_var(commitvar, save_b_flag, 1, 0, cglobs);
|
|
Yap_emit_3ops(push_or_op, label, Zero, Zero, &cglobs->cint);
|
|
Yap_emit_3ops(either_op, label, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(restore_tmps_op, Zero, Zero, &cglobs->cint);
|
|
c_goal(ArgOfTerm(1, Goal), mod, cglobs);
|
|
c_var(commitvar, commit_b_flag, 1, 0, cglobs);
|
|
cglobs->onlast = save;
|
|
Yap_emit(fail_op, end_label, Zero, &cglobs->cint);
|
|
Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(label_op, label, Zero, &cglobs->cint);
|
|
Yap_emit(orlast_op, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(label_op, end_label, Zero, &cglobs->cint);
|
|
cglobs->onlast = save;
|
|
/* --cglobs->onbranch; */
|
|
cglobs->onbranch = pop_branch(cglobs);
|
|
c_goal(MkAtomTerm(AtomTrue), mod, cglobs);
|
|
++cglobs->goalno;
|
|
Yap_emit(pop_or_op, Zero, Zero, &cglobs->cint);
|
|
return;
|
|
}
|
|
else if (f == FunctorArrow) {
|
|
Term commitvar;
|
|
int save = cglobs->onlast;
|
|
|
|
commitvar = MkVarTerm();
|
|
if (H == (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
cglobs->onlast = FALSE;
|
|
c_var(commitvar, save_b_flag, 1, 0, cglobs);
|
|
c_goal(ArgOfTerm(1, Goal), mod, cglobs);
|
|
c_var(commitvar, commit_b_flag, 1, 0, cglobs);
|
|
cglobs->onlast = save;
|
|
c_goal(ArgOfTerm(2, Goal), mod, cglobs);
|
|
return;
|
|
}
|
|
else if (f == FunctorEq) {
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
|
|
else if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
|
|
c_eq(ArgOfTerm(1, Goal), ArgOfTerm(2, Goal), cglobs);
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(44,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
return;
|
|
}
|
|
else if (f == FunctorSafe) {
|
|
Ventry *v = (Ventry *)ArgOfTerm(1, Goal);
|
|
/* This variable must be known before */
|
|
v->FlagsOfVE |= SafeVar;
|
|
return;
|
|
}
|
|
else if (p->PredFlags & AsmPredFlag) {
|
|
basic_preds op = p->PredFlags & 0x7f;
|
|
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
|
|
else if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
|
|
if (op >= _atom && op <= _primitive) {
|
|
c_test(op, ArgOfTerm(1, Goal), cglobs);
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(45,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
return;
|
|
}
|
|
else if (op >= _plus && op <= _functor) {
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
|
|
else if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
|
|
if (op == _functor) {
|
|
c_functor(Goal, mod, cglobs);
|
|
}
|
|
else {
|
|
c_bifun(op,
|
|
ArgOfTerm(1, Goal),
|
|
ArgOfTerm(2, Goal),
|
|
ArgOfTerm(3, Goal),
|
|
Goal,
|
|
mod,
|
|
cglobs);
|
|
}
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(46,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
return;
|
|
} else if (op == _p_label_ctl) {
|
|
emit_special_label(Goal, cglobs);
|
|
return;
|
|
} else {
|
|
c_args(Goal, 0, cglobs);
|
|
}
|
|
}
|
|
#ifdef BEAM
|
|
else if (p->PredFlags & BinaryPredFlag && !EAM) {
|
|
#else
|
|
else if (p->PredFlags & BinaryPredFlag) {
|
|
#endif
|
|
Term a1 = ArgOfTerm(1,Goal);
|
|
|
|
if (IsVarTerm(a1) && !IsNewVar(a1)) {
|
|
Term a2 = ArgOfTerm(2,Goal);
|
|
if (IsVarTerm(a2) && !IsNewVar(a2)) {
|
|
if (IsNewVar(a2)) {
|
|
Yap_Error_TYPE = INSTANTIATION_ERROR;
|
|
Yap_Error_Term = a2;
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
sprintf(Yap_ErrorMessage, "compiling %s/2 with second arg unbound", RepAtom(NameOfFunctor(p->FunctorOfPred))->StrOfAE);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,1);
|
|
}
|
|
c_var(a1, bt1_flag, 2, 0, cglobs);
|
|
cglobs->current_p0 = p0;
|
|
c_var(a2, bt2_flag, 2, 0, cglobs);
|
|
}
|
|
else {
|
|
Term t2 = MkVarTerm();
|
|
if (H == (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
c_eq(t2, a2, cglobs);
|
|
c_var(a1, bt1_flag, 2, 0, cglobs);
|
|
cglobs->current_p0 = p0;
|
|
c_var(t2, bt2_flag, 2, 0, cglobs);
|
|
}
|
|
} else {
|
|
Term a2 = ArgOfTerm(2,Goal);
|
|
Term t1 = MkVarTerm();
|
|
if (H == (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
c_eq(t1, a1, cglobs);
|
|
|
|
if (IsVarTerm(a2) && !IsNewVar(a2)) {
|
|
c_var(t1, bt1_flag, 2, 0, cglobs);
|
|
cglobs->current_p0 = p0;
|
|
c_var(a2, bt2_flag, 2, 0, cglobs);
|
|
}
|
|
else {
|
|
Term t2 = MkVarTerm();
|
|
if (H == (CELL *)cglobs->cint.freep0) {
|
|
/* oops, too many new variables */
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
|
|
}
|
|
c_eq(t2, a2, cglobs);
|
|
c_var(t1, bt1_flag, 2, 0, cglobs);
|
|
cglobs->current_p0 = p0;
|
|
c_var(t2, bt2_flag, 2, 0, cglobs);
|
|
}
|
|
}
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(47,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
return;
|
|
} else {
|
|
if (profiling)
|
|
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
|
|
else if (call_counting)
|
|
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
|
|
if (f == FunctorExecuteInMod) {
|
|
/* compile the first argument only */
|
|
c_arg(1, ArgOfTerm(1,Goal), 1, 0, cglobs);
|
|
} else {
|
|
c_args(Goal, 0, cglobs);
|
|
}
|
|
}
|
|
}
|
|
|
|
if (p->PredFlags & SafePredFlag
|
|
#ifdef YAPOR
|
|
/* synchronisation means saving the state, so it is never safe in YAPOR */
|
|
&& !(p->PredFlags & SyncPredFlag)
|
|
#endif /* YAPOR */
|
|
) {
|
|
Yap_emit(safe_call_op, (CELL) p0, Zero, &cglobs->cint);
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(48,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
}
|
|
else {
|
|
if ((p->PredFlags & (AsmPredFlag |
|
|
ModuleTransparentPredFlag |
|
|
UserCPredFlag)) ||
|
|
p->FunctorOfPred == FunctorExecuteInMod) {
|
|
#ifdef YAPOR
|
|
if (p->PredFlags & SyncPredFlag)
|
|
Yap_emit(sync_op, (CELL)p, (CELL)(p->ArityOfPE), &cglobs->cint);
|
|
#endif /* YAPOR */
|
|
if (p->FunctorOfPred == FunctorExecuteInMod) {
|
|
cglobs->needs_env = TRUE;
|
|
Yap_emit_4ops(call_op, (CELL) p0, Zero, Zero, ArgOfTerm(2,Goal), &cglobs->cint);
|
|
} else {
|
|
cglobs->needs_env = TRUE;
|
|
Yap_emit_3ops(call_op, (CELL) p0, Zero, Zero, &cglobs->cint);
|
|
}
|
|
/* functor is allowed to call the garbage collector */
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
cglobs->or_found = TRUE;
|
|
#ifdef TABLING
|
|
PELOCK(49,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
}
|
|
else {
|
|
if (cglobs->onlast) {
|
|
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
PELOCK(50,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred)) {
|
|
cglobs->needs_env = TRUE;
|
|
Yap_emit_3ops(call_op, (CELL) p0, Zero, Zero, &cglobs->cint);
|
|
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
|
|
}
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(execute_op, (CELL) p0, Zero, &cglobs->cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
else {
|
|
cglobs->needs_env = TRUE;
|
|
Yap_emit_3ops(call_op, (CELL) p0, Zero, Zero, &cglobs->cint);
|
|
}
|
|
}
|
|
if (!cglobs->onlast)
|
|
++cglobs->goalno;
|
|
}
|
|
}
|
|
|
|
static void
|
|
c_body(Term Body, Term mod, compiler_struct *cglobs)
|
|
{
|
|
cglobs->onhead = FALSE;
|
|
cglobs->BodyStart = cglobs->cint.cpc;
|
|
cglobs->goalno = 1;
|
|
while (IsNonVarTerm(Body) && IsApplTerm(Body)
|
|
&& FunctorOfTerm(Body) == FunctorComma) {
|
|
Term t2 = ArgOfTerm(2, Body);
|
|
if (!cglobs->cint.success_handler && IsTrueGoal(t2)) {
|
|
/* optimise the case where some idiot left trues at the end
|
|
of the clause.
|
|
*/
|
|
Body = ArgOfTerm(1, Body);
|
|
break;
|
|
}
|
|
c_goal(ArgOfTerm(1, Body), mod, cglobs);
|
|
Body = t2;
|
|
#ifdef BEAM
|
|
if (EAM) Yap_emit(endgoal_op, Zero, Zero, &cglobs->cint);
|
|
#endif
|
|
|
|
}
|
|
cglobs->onlast = TRUE;
|
|
c_goal(Body, mod, cglobs);
|
|
#ifdef BEAM
|
|
if (EAM && cglobs->goalno > 1) {
|
|
if (cglobs->cint.cpc->op==procceed_op) {
|
|
cglobs->cint.cpc->op=endgoal_op;
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
|
|
} else
|
|
Yap_emit(endgoal_op, Zero, Zero, &cglobs->cint);
|
|
}
|
|
#endif
|
|
}
|
|
|
|
static void
|
|
c_head(Term t, compiler_struct *cglobs)
|
|
{
|
|
Functor f;
|
|
|
|
cglobs->goalno = 0;
|
|
cglobs->onhead = TRUE;
|
|
cglobs->onlast = FALSE;
|
|
cglobs->curbranch = cglobs->onbranch = 0;
|
|
cglobs->branch_pointer = cglobs->parent_branches;
|
|
cglobs->space_used = 0;
|
|
cglobs->space_op = NULL;
|
|
if (IsAtomTerm(t)) {
|
|
Yap_emit(name_op, (CELL) AtomOfTerm(t), Zero, &cglobs->cint);
|
|
#ifdef BEAM
|
|
if (EAM) {
|
|
Yap_emit(run_op,Zero,(UInt) cglobs->cint.CurrentPred,&cglobs->cint);
|
|
}
|
|
#endif
|
|
return;
|
|
}
|
|
Yap_emit(ensure_space_op, Zero , Zero, &cglobs->cint);
|
|
cglobs->space_op = cglobs->cint.cpc;
|
|
f = FunctorOfTerm(t);
|
|
Yap_emit(name_op, (CELL) NameOfFunctor(f), ArityOfFunctor(f), &cglobs->cint);
|
|
#ifdef BEAM
|
|
if (EAM) {
|
|
Yap_emit(run_op,Zero,(UInt) cglobs->cint.CurrentPred,&cglobs->cint);
|
|
}
|
|
#endif
|
|
if (Yap_ExecutionMode == MIXED_MODE_USER)
|
|
Yap_emit(native_op, 0, 0, &cglobs->cint);
|
|
c_args(t, 0, cglobs);
|
|
}
|
|
|
|
/* number of permanent variables in the clause */
|
|
#ifdef BEAM
|
|
int nperm;
|
|
#else
|
|
static int nperm;
|
|
#endif
|
|
|
|
|
|
inline static int
|
|
usesvar(compiler_vm_op ic)
|
|
{
|
|
if (ic >= get_var_op && ic <= put_val_op)
|
|
return TRUE;
|
|
switch (ic) {
|
|
case save_b_op:
|
|
case commit_b_op:
|
|
case patch_b_op:
|
|
case save_appl_op:
|
|
case save_pair_op:
|
|
case f_val_op:
|
|
case f_var_op:
|
|
case fetch_args_for_bccall:
|
|
case bccall_op:
|
|
return TRUE;
|
|
default:
|
|
break;
|
|
}
|
|
#ifdef SFUNC
|
|
if (ic >= unify_s_var_op && ic <= write_s_val_op)
|
|
return TRUE;
|
|
#endif
|
|
return ((ic >= unify_var_op && ic <= write_val_op)
|
|
||
|
|
(ic >= unify_last_var_op && ic <= unify_last_val_op));
|
|
}
|
|
|
|
/*
|
|
* Do as in the traditional WAM and make sure voids are in
|
|
* environments
|
|
*/
|
|
#define LOCALISE_VOIDS 1
|
|
|
|
#ifdef LOCALISE_VOIDS
|
|
typedef struct env_tmp {
|
|
Ventry * Var;
|
|
struct env_tmp *Next;
|
|
} EnvTmp;
|
|
#endif
|
|
|
|
static void
|
|
AssignPerm(PInstr *pc, compiler_struct *cglobs)
|
|
{
|
|
int uses_var;
|
|
PInstr *opc = NULL;
|
|
#ifdef LOCALISE_VOIDS
|
|
EnvTmp *EnvTmps = NULL;
|
|
#endif
|
|
|
|
/* The WAM tries to keep voids on the
|
|
* environment. Traditionally, YAP liberally globalises
|
|
* voids.
|
|
*
|
|
* The new version goes to some length to keep void variables
|
|
* in environments, but it is dubious that improves
|
|
* performance, and may actually slow down the system
|
|
*/
|
|
while (pc != NULL) {
|
|
PInstr *tpc = pc->nextInst;
|
|
#ifdef LOCALISE_VOIDS
|
|
if (pc->op == put_var_op) {
|
|
Ventry *v = (Ventry *) (pc->rnd1);
|
|
if (v->AgeOfVE == v->FirstOfVE
|
|
&& !(v->FlagsOfVE & (GlobalVal|OnHeadFlag|OnLastGoal|NonVoid)) ) {
|
|
EnvTmp *x = (EnvTmp *)Yap_AllocCMem(sizeof(*x), &cglobs->cint);
|
|
x->Next = EnvTmps;
|
|
x->Var = v;
|
|
EnvTmps = x;
|
|
}
|
|
} else
|
|
#endif
|
|
if (pc->op == call_op || pc->op == either_op || pc->op == orelse_op || pc->op == push_or_op) {
|
|
#ifdef LOCALISE_VOIDS
|
|
pc->ops.opseqt[1] = (CELL)EnvTmps;
|
|
if (EnvTmps)
|
|
EnvTmps = NULL;
|
|
#endif
|
|
}
|
|
pc->nextInst = opc;
|
|
opc = pc;
|
|
pc = tpc;
|
|
}
|
|
pc = opc;
|
|
opc = NULL;
|
|
do {
|
|
PInstr *npc = pc->nextInst;
|
|
|
|
pc->nextInst = opc;
|
|
uses_var = usesvar(pc->op);
|
|
if (uses_var) {
|
|
Ventry *v = (Ventry *) (pc->rnd1);
|
|
|
|
#ifdef BEAM
|
|
if (EAM) {
|
|
if (v->NoOfVE == Unassigned || v->KindOfVE!=PermVar) {
|
|
v->NoOfVE = PermVar | (nperm++);
|
|
v->KindOfVE = PermVar;
|
|
v->FlagsOfVE |= PermFlag;
|
|
}
|
|
}
|
|
#endif
|
|
if (v->NoOfVE == Unassigned) {
|
|
if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE))
|
|
|| v->KindOfVE == PermVar /*
|
|
* * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE &
|
|
* * OnHeadFlag))
|
|
*/ ) {
|
|
v->NoOfVE = PermVar | (nperm++);
|
|
v->KindOfVE = PermVar;
|
|
v->FlagsOfVE |= PermFlag;
|
|
} else {
|
|
v->NoOfVE = v->KindOfVE = TempVar;
|
|
}
|
|
}
|
|
} else if (pc->op == empty_call_op) {
|
|
pc->rnd2 = nperm;
|
|
} else if (pc->op == call_op || pc->op == either_op || pc->op == orelse_op || pc->op == push_or_op) {
|
|
#ifdef LOCALISE_VOIDS
|
|
EnvTmps = (EnvTmp *)(pc->ops.opseqt[1]);
|
|
while (EnvTmps) {
|
|
Ventry *v = EnvTmps->Var;
|
|
v->NoOfVE = PermVar | (nperm++);
|
|
v->KindOfVE = PermVar;
|
|
v->FlagsOfVE |= (PermFlag|SafeVar);
|
|
EnvTmps = EnvTmps->Next;
|
|
}
|
|
#endif
|
|
pc->rnd2 = nperm;
|
|
} else if (pc->op == cut_op ||
|
|
pc->op == cutexit_op ||
|
|
pc->op == commit_b_op) {
|
|
pc->rnd2 = nperm;
|
|
}
|
|
opc = pc;
|
|
pc = npc;
|
|
} while (pc != NULL);
|
|
}
|
|
|
|
static CELL *
|
|
init_bvarray(int nperm, compiler_struct *cglobs)
|
|
{
|
|
CELL *vinfo = NULL;
|
|
size_t sz = sizeof(CELL)*(1+nperm/(8*sizeof(CELL)));
|
|
vinfo = (CELL *)Yap_AllocCMem(sz, &cglobs->cint);
|
|
memset((void *)vinfo, 0, sz);
|
|
return vinfo;
|
|
}
|
|
|
|
static void
|
|
clear_bvarray(int var, CELL *bvarray
|
|
#ifdef DEBUG
|
|
, compiler_struct *cglobs
|
|
#endif
|
|
)
|
|
{
|
|
int max = 8*sizeof(CELL);
|
|
CELL nbit;
|
|
|
|
/* get to the array position */
|
|
while (var >= max) {
|
|
bvarray++;
|
|
var -= max;
|
|
}
|
|
/* now put a 0 on it, from now on the variable is initialised */
|
|
nbit = ((CELL)1 << var);
|
|
#ifdef DEBUG
|
|
if (*bvarray & nbit) {
|
|
/* someone had already marked this variable: complain */
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "compiler internal error: variable initialised twice";
|
|
fprintf(stderr," vsc: compiling7\n");
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
|
|
}
|
|
cglobs->pbvars++;
|
|
#endif
|
|
*bvarray |= nbit;
|
|
}
|
|
|
|
/* copy the current state of the perm variable state array to code space */
|
|
static void
|
|
add_bvarray_op(PInstr *cp, CELL *bvarray, int env_size, compiler_struct *cglobs)
|
|
{
|
|
int i, size = env_size/(8*sizeof(CELL));
|
|
CELL *dest;
|
|
|
|
dest =
|
|
Yap_emit_extra_size(mark_initialised_pvars_op, (CELL)env_size, (size+1)*sizeof(CELL), &cglobs->cint);
|
|
/* copy the cells to dest */
|
|
for (i = 0; i <= size; i++)
|
|
*dest++ = *bvarray++;
|
|
}
|
|
|
|
/* vsc: this code is not working, as it is too complex */
|
|
|
|
typedef struct {
|
|
int lab;
|
|
int last;
|
|
PInstr *pc;
|
|
} bventry;
|
|
|
|
#define MAX_DISJUNCTIONS 128
|
|
static bventry *bvstack;
|
|
static int bvindex = 0;
|
|
|
|
static void
|
|
push_bvmap(int label, PInstr *pcpc, compiler_struct *cglobs)
|
|
{
|
|
if (bvindex == MAX_DISJUNCTIONS) {
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "Too many embedded disjunctions";
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
|
|
}
|
|
/* the label instruction */
|
|
bvstack[bvindex].lab = label;
|
|
bvstack[bvindex].last = -1;
|
|
/* where we have the code */
|
|
bvstack[bvindex].pc = pcpc;
|
|
bvindex++;
|
|
}
|
|
|
|
static void
|
|
reset_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs)
|
|
{
|
|
int size, size1, env_size, i;
|
|
CELL *source;
|
|
|
|
if (bvarray == NULL)
|
|
|
|
if (bvindex == 0) {
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "No embedding in disjunctions";
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
|
|
}
|
|
env_size = (bvstack[bvindex-1].pc)->rnd1;
|
|
size = env_size/(8*sizeof(CELL));
|
|
size1 = nperm/(8*sizeof(CELL));
|
|
source = (bvstack[bvindex-1].pc)->arnds;
|
|
for (i = 0; i <= size; i++)
|
|
*bvarray++ = *source++;
|
|
for (i = size+1; i<= size1; i++)
|
|
*bvarray++ = (CELL)(0);
|
|
}
|
|
|
|
static void
|
|
pop_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs)
|
|
{
|
|
if (bvindex == 0) {
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "Too few embedded disjunctions";
|
|
/* save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); */
|
|
}
|
|
reset_bvmap(bvarray, nperm, cglobs);
|
|
bvindex--;
|
|
}
|
|
|
|
typedef struct {
|
|
PInstr *p;
|
|
Ventry *v;
|
|
} UnsafeEntry;
|
|
|
|
/* extend to also support variable usage bitmaps for garbage collection */
|
|
static void
|
|
CheckUnsafe(PInstr *pc, compiler_struct *cglobs)
|
|
{
|
|
int pending = 0;
|
|
|
|
/* say that all variables are yet to initialise */
|
|
CELL *vstat = init_bvarray(nperm, cglobs);
|
|
UnsafeEntry *UnsafeStack =
|
|
(UnsafeEntry *) Yap_AllocCMem(nperm * sizeof(UnsafeEntry), &cglobs->cint);
|
|
/* keep a copy of previous cglobs->cint.cpc and CodeStart */
|
|
PInstr *opc = cglobs->cint.cpc;
|
|
PInstr *OldCodeStart = cglobs->cint.CodeStart;
|
|
|
|
cglobs->cint.CodeStart = cglobs->cint.BlobsStart;
|
|
cglobs->cint.cpc = cglobs->cint.icpc;
|
|
bvindex = 0;
|
|
bvstack = (bventry *)Yap_AllocCMem(MAX_DISJUNCTIONS * sizeof(bventry), &cglobs->cint);
|
|
while (pc != NIL) {
|
|
switch(pc->op) {
|
|
case put_val_op:
|
|
{
|
|
Ventry *v = (Ventry *) (pc->rnd1);
|
|
if ((v->FlagsOfVE & PermFlag) && !(v->FlagsOfVE & SafeVar)) {
|
|
UnsafeStack[pending].p = pc;
|
|
UnsafeStack[pending++].v = v;
|
|
v->FlagsOfVE |= SafeVar;
|
|
}
|
|
break;
|
|
}
|
|
case put_var_op:
|
|
case get_var_op:
|
|
case save_b_op:
|
|
case unify_var_op:
|
|
case unify_last_var_op:
|
|
case write_var_op:
|
|
case save_appl_op:
|
|
case save_pair_op:
|
|
case f_var_op:
|
|
{
|
|
Ventry *v = (Ventry *) (pc->rnd1);
|
|
|
|
if (v->FlagsOfVE & PermFlag && pc == v->FirstOpForV) {
|
|
/* the second condition covers cases such as save_b_op
|
|
in a disjunction */
|
|
clear_bvarray((v->NoOfVE & MaskVarAdrs), vstat
|
|
#ifdef DEBUG
|
|
, cglobs
|
|
#endif
|
|
);
|
|
}
|
|
}
|
|
break;
|
|
case push_or_op:
|
|
Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
|
|
pc->ops.opseqt[1] = (CELL)cglobs->labelno;
|
|
add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
|
|
push_bvmap((CELL)cglobs->labelno, cglobs->cint.cpc, cglobs);
|
|
break;
|
|
case either_op:
|
|
/* add a first entry to the array */
|
|
Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
|
|
pc->ops.opseqt[1] = (CELL)cglobs->labelno;
|
|
add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
|
|
break;
|
|
case pushpop_or_op:
|
|
reset_bvmap(vstat, nperm, cglobs);
|
|
goto reset_safe_map;
|
|
case orelse_op:
|
|
Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
|
|
pc->ops.opseqt[1] = (CELL)cglobs->labelno;
|
|
add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
|
|
break;
|
|
case pop_or_op:
|
|
pop_bvmap(vstat, nperm, cglobs);
|
|
goto reset_safe_map;
|
|
break;
|
|
case empty_call_op:
|
|
/* just get ourselves a label describing how
|
|
many permanent variables are alive */
|
|
Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
|
|
pc->rnd1 = (CELL)cglobs->labelno;
|
|
add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
|
|
break;
|
|
case cut_op:
|
|
case cutexit_op:
|
|
/* just get ourselves a label describing how
|
|
many permanent variables are alive */
|
|
Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
|
|
pc->rnd1 = (CELL)cglobs->labelno;
|
|
add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
|
|
break;
|
|
case call_op:
|
|
Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
|
|
pc->ops.opseqt[1] = (CELL)cglobs->labelno;
|
|
add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
|
|
case deallocate_op:
|
|
reset_safe_map:
|
|
{
|
|
int n = pc->op == call_op ? pc->rnd2 : 0;
|
|
int no;
|
|
|
|
while (pending) {
|
|
Ventry *v = UnsafeStack[--pending].v;
|
|
|
|
v->FlagsOfVE &= ~SafeVar;
|
|
no = (v->NoOfVE) & MaskVarAdrs;
|
|
if (no >= n)
|
|
UnsafeStack[pending].p->op = put_unsafe_op;
|
|
}
|
|
}
|
|
default:
|
|
break;
|
|
}
|
|
pc = pc->nextInst;
|
|
}
|
|
cglobs->cint.icpc = cglobs->cint.cpc;
|
|
cglobs->cint.cpc = opc;
|
|
cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
|
|
cglobs->cint.CodeStart = OldCodeStart;
|
|
}
|
|
|
|
static void
|
|
CheckVoids(compiler_struct *cglobs)
|
|
{ /* establish voids in the head and initial
|
|
* uses */
|
|
Ventry *ve;
|
|
compiler_vm_op ic;
|
|
struct PSEUDO *cpc;
|
|
|
|
cpc = cglobs->cint.CodeStart;
|
|
while ((ic = cpc->op) != allocate_op) {
|
|
switch (ic) {
|
|
case get_var_op:
|
|
case unify_var_op:
|
|
case unify_last_var_op:
|
|
#ifdef SFUNC
|
|
case unify_s_var_op:
|
|
#endif
|
|
case save_pair_op:
|
|
case save_appl_op:
|
|
ve = ((Ventry *) cpc->rnd1);
|
|
if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1) {
|
|
ve->NoOfVE = ve->KindOfVE = VoidVar;
|
|
if (ic == get_var_op || ic ==
|
|
save_pair_op || ic == save_appl_op
|
|
#ifdef SFUNC
|
|
|| ic == unify_s_var_op
|
|
#endif
|
|
) {
|
|
cpc->op = nop_op;
|
|
break;
|
|
}
|
|
}
|
|
if (ic != get_var_op)
|
|
break;
|
|
case get_val_op:
|
|
case get_atom_op:
|
|
case get_num_op:
|
|
case get_float_op:
|
|
case get_dbterm_op:
|
|
case get_longint_op:
|
|
case get_bigint_op:
|
|
case get_list_op:
|
|
case get_struct_op:
|
|
cglobs->Uses[cpc->rnd2] = 1;
|
|
default:
|
|
break;
|
|
}
|
|
cpc = cpc->nextInst;
|
|
}
|
|
}
|
|
|
|
static int
|
|
checktemp(Int arg, Int rn, compiler_vm_op ic, compiler_struct *cglobs)
|
|
{
|
|
Ventry *v = (Ventry *) arg;
|
|
PInstr *q;
|
|
Int Needed[MaxTemps];
|
|
Int r, target1, target2;
|
|
Int n, *np, *rp;
|
|
CELL *cp;
|
|
Int vadr;
|
|
Int vreg;
|
|
|
|
|
|
cglobs->vadr = vadr = (v->NoOfVE);
|
|
cglobs->vreg = vreg = vadr & MaskVarAdrs;
|
|
if (v->KindOfVE == PermVar || v->KindOfVE == VoidVar)
|
|
return 0;
|
|
if (v->RCountOfVE == 1)
|
|
return 0;
|
|
if (vreg) {
|
|
--cglobs->Uses[vreg];
|
|
return 1;
|
|
}
|
|
/* follow the life of the variable */
|
|
q = cglobs->cint.cpc;
|
|
/*
|
|
* for(r=0; r<cglobs->MaxCTemps; ++r) Needed[r] = cglobs->Uses[r]; might be written
|
|
* as:
|
|
*/
|
|
np = Needed;
|
|
rp = cglobs->Uses;
|
|
for (r = 0; r < cglobs->MaxCTemps; ++r)
|
|
*np++ = *rp++;
|
|
if (rn > 0 && (ic == get_var_op || ic == put_var_op)) {
|
|
if (ic == put_var_op)
|
|
Needed[rn] = 1;
|
|
target1 = rn; /* try to leave it where it is */
|
|
}
|
|
else
|
|
target1 = cglobs->MaxCTemps;
|
|
target2 = cglobs->MaxCTemps;
|
|
n = v->RCountOfVE - 1;
|
|
while (q != v->LastOpForV && (q = q->nextInst) != NIL) {
|
|
if (q->rnd2 <= 0); /* don't try to reuse REGISTER 0 */
|
|
else if (usesvar(ic = q->op) && arg == q->rnd1) {
|
|
--n;
|
|
if (ic == put_val_op) {
|
|
if (target1 == cglobs->MaxCTemps && Needed[q->rnd2] == 0)
|
|
target1 = q->rnd2;
|
|
else if (target1 != (r = q->rnd2)) {
|
|
if (target2 == cglobs->MaxCTemps && Needed[r] == 0)
|
|
target2 = r;
|
|
else if (target2 > r && cglobs->Uses[r] == 0 && Needed[r] == 0)
|
|
target2 = r;
|
|
}
|
|
}
|
|
}
|
|
#ifdef SFUNC
|
|
else if ((ic >= get_var_op && ic <= put_unsafe_op)
|
|
|| ic == get_s_f_op || ic == put_s_f_op)
|
|
Needed[q->rnd2] = 1;
|
|
#else
|
|
else if (ic >= get_var_op && ic <= put_unsafe_op)
|
|
Needed[q->rnd2] = 1;
|
|
#endif
|
|
if ((ic == call_op || ic == safe_call_op) && n == 0)
|
|
break;
|
|
}
|
|
if (target2 < target1) {
|
|
r = target2;
|
|
target2 = target1;
|
|
target1 = r;
|
|
}
|
|
if (target1 == cglobs->MaxCTemps || cglobs->Uses[target1] || Needed[target1])
|
|
if ((target1 = target2) == cglobs->MaxCTemps || cglobs->Uses[target1] || Needed[target1]) {
|
|
target1 = cglobs->MaxCTemps;
|
|
do
|
|
--target1;
|
|
while (target1 && cglobs->Uses[target1] == 0 && Needed[target1] == 0);
|
|
++target1;
|
|
}
|
|
if (target1 == cglobs->MaxCTemps) {
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "too many temporaries";
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
|
|
}
|
|
v->NoOfVE = cglobs->vadr = vadr = TempVar | target1;
|
|
v->KindOfVE = TempVar;
|
|
cglobs->Uses[cglobs->vreg = vreg = target1] = v->RCountOfVE - 1;
|
|
/*
|
|
* for(r=0; r<cglobs->MaxCTemps; ++r) if(cglobs->Contents[r]==vadr) cglobs->Contents[r] =
|
|
* NIL;
|
|
*/
|
|
cp = cglobs->Contents;
|
|
for (r = 0; r < cglobs->MaxCTemps; ++r)
|
|
if (*cp++ == (Term)vadr)
|
|
cp[-1] = NIL;
|
|
cglobs->Contents[vreg] = vadr;
|
|
return 1;
|
|
}
|
|
|
|
static Int
|
|
checkreg(Int arg, Int rn, compiler_vm_op ic, int var_arg, compiler_struct *cglobs)
|
|
{
|
|
PInstr *p = cglobs->cint.cpc;
|
|
Int vreg;
|
|
|
|
if (rn >= 0)
|
|
return rn;
|
|
if (var_arg) {
|
|
Ventry *v = (Ventry *) arg;
|
|
|
|
vreg = (v->NoOfVE) & MaskVarAdrs;
|
|
if (v->KindOfVE == PermVar)
|
|
vreg = 0;
|
|
else if (vreg == 0) {
|
|
checktemp(arg, rn, ic, cglobs);
|
|
vreg = (v->NoOfVE) & MaskVarAdrs;
|
|
++cglobs->Uses[vreg];
|
|
}
|
|
if (!vreg) {
|
|
vreg = 1;
|
|
while (cglobs->Uses[vreg] != 0) {
|
|
++vreg;
|
|
}
|
|
cglobs->Uses[vreg] = v->RCountOfVE;
|
|
}
|
|
} else {
|
|
vreg = 1;
|
|
while (cglobs->Uses[vreg] != 0) {
|
|
++vreg;
|
|
}
|
|
}
|
|
while (p) {
|
|
if (p->op >= get_var_op && p->op <= put_unsafe_op && p->rnd2 == rn)
|
|
p->rnd2 = vreg;
|
|
/* only copy variables until you reach a call */
|
|
if (p->op == procceed_op || p->op == call_op || p->op == push_or_op || p->op == pushpop_or_op)
|
|
break;
|
|
p = p->nextInst;
|
|
}
|
|
return vreg;
|
|
}
|
|
|
|
/* Create a bitmap with all live variables */
|
|
static CELL
|
|
copy_live_temps_bmap(int max, compiler_struct *cglobs)
|
|
{
|
|
unsigned int size = AdjustSize((max|7)/8+1);
|
|
int i;
|
|
CELL *dest = Yap_emit_extra_size(mark_live_regs_op, max, size, &cglobs->cint);
|
|
CELL *ptr=dest;
|
|
*ptr = 0L;
|
|
for (i=1; i <= max; i++) {
|
|
/* move to next cell */
|
|
if (i%(8*CellSize) == 0) {
|
|
ptr++;
|
|
*ptr = 0L;
|
|
}
|
|
/* set the register live bit */
|
|
if (cglobs->Contents[i]) {
|
|
int j = i%(8*CellSize);
|
|
*ptr |= (1<<j);
|
|
}
|
|
}
|
|
return((CELL)dest);
|
|
}
|
|
|
|
static void
|
|
c_layout(compiler_struct *cglobs)
|
|
{
|
|
PInstr *savepc = cglobs->BodyStart->nextInst;
|
|
register Ventry *v = cglobs->vtable;
|
|
Int *up = cglobs->Uses, Arity;
|
|
CELL *cop = cglobs->Contents;
|
|
/* tell put_values used in bip optimisation */
|
|
int rn_kills = 0;
|
|
Int rn_to_kill[2];
|
|
int needs_either = 0;
|
|
|
|
rn_to_kill[0] = rn_to_kill[1] = 0;
|
|
cglobs->cint.cpc = cglobs->BodyStart;
|
|
/*
|
|
#ifdef BEAM
|
|
if (!cglobs->is_a_fact || EAM) {
|
|
#else
|
|
*/
|
|
if (!cglobs->is_a_fact) {
|
|
while (v != NIL) {
|
|
if (v->FlagsOfVE & BranchVar) {
|
|
v->AgeOfVE = v->FirstOfVE + 1; /* force permanent */
|
|
++(v->RCountOfVE);
|
|
Yap_emit(put_var_op, (CELL) v, Zero, &cglobs->cint);
|
|
v->FlagsOfVE &= ~GlobalVal;
|
|
v->FirstOpForV = cglobs->cint.cpc;
|
|
}
|
|
v = v->NextOfVE;
|
|
}
|
|
cglobs->cint.cpc->nextInst = savepc;
|
|
|
|
#ifdef BEAM
|
|
if (cglobs->needs_env || EAM) {
|
|
#else
|
|
if (cglobs->needs_env) {
|
|
#endif
|
|
nperm = 0;
|
|
AssignPerm(cglobs->cint.CodeStart, cglobs);
|
|
#ifdef DEBUG
|
|
cglobs->pbvars = 0;
|
|
#endif
|
|
CheckUnsafe(cglobs->cint.CodeStart, cglobs);
|
|
#ifdef DEBUG
|
|
if (cglobs->pbvars != nperm) {
|
|
Yap_Error_TYPE = INTERNAL_COMPILER_ERROR;
|
|
Yap_Error_Term = TermNil;
|
|
Yap_ErrorMessage = "wrong number of variables found in bitmap";
|
|
save_machine_regs();
|
|
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
|
|
}
|
|
#endif
|
|
}
|
|
}
|
|
|
|
cglobs->MaxCTemps = cglobs->nvars + cglobs->max_args - cglobs->tmpreg + cglobs->n_common_exps + 2;
|
|
if (cglobs->MaxCTemps >= MaxTemps)
|
|
cglobs->MaxCTemps = MaxTemps;
|
|
{
|
|
Int rn;
|
|
for (rn = 0; rn < cglobs->MaxCTemps; ++rn) {
|
|
/* cglobs->Uses[rn] = 0; cglobs->Contents[rn] = NIL; */
|
|
*up++ = 0;
|
|
*cop++ = NIL;
|
|
}
|
|
}
|
|
|
|
CheckVoids(cglobs);
|
|
|
|
/* second scan: allocate registers */
|
|
cglobs->cint.cpc = cglobs->cint.CodeStart;
|
|
while (cglobs->cint.cpc) {
|
|
compiler_vm_op ic = cglobs->cint.cpc->op;
|
|
Int arg = cglobs->cint.cpc->rnd1;
|
|
Int rn = cglobs->cint.cpc->rnd2;
|
|
switch (ic) {
|
|
case pop_or_op:
|
|
if (needs_either)
|
|
needs_either--;
|
|
case either_op:
|
|
needs_either++;
|
|
break;
|
|
#ifdef TABLING_INNER_CUTS
|
|
case cut_op:
|
|
case cutexit_op:
|
|
cglobs->cut_mark->op = clause_with_cut_op;
|
|
break;
|
|
#endif /* TABLING_INNER_CUTS */
|
|
case allocate_op:
|
|
case deallocate_op:
|
|
if (!cglobs->needs_env) {
|
|
cglobs->cint.cpc->op = nop_op;
|
|
} else {
|
|
#ifdef TABLING
|
|
PELOCK(51,cglobs->cint.CurrentPred);
|
|
if (is_tabled(cglobs->cint.CurrentPred))
|
|
cglobs->cint.cpc->op = nop_op;
|
|
else
|
|
#endif /* TABLING */
|
|
if (cglobs->goalno == 1 && !cglobs->or_found && nperm == 0)
|
|
cglobs->cint.cpc->op = nop_op;
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs->cint.CurrentPred->PELock);
|
|
#endif
|
|
}
|
|
break;
|
|
case pop_op:
|
|
ic = (cglobs->cint.cpc->nextInst)->op;
|
|
if (ic >= get_var_op && ic <= put_unsafe_op)
|
|
cglobs->cint.cpc->op = nop_op;
|
|
break;
|
|
case get_var_op:
|
|
--cglobs->Uses[rn];
|
|
if (checktemp(arg, rn, ic, cglobs)) {
|
|
#ifdef BEAM
|
|
if (cglobs->vreg == rn && !EAM)
|
|
#else
|
|
if (cglobs->vreg == rn)
|
|
#endif
|
|
cglobs->cint.cpc->op = nop_op;
|
|
}
|
|
if (!cglobs->Uses[rn])
|
|
cglobs->Contents[rn] = cglobs->vadr;
|
|
break;
|
|
case get_val_op:
|
|
--cglobs->Uses[rn];
|
|
checktemp(arg, rn, ic, cglobs);
|
|
if (!cglobs->Uses[rn])
|
|
cglobs->Contents[rn] = cglobs->vadr;
|
|
break;
|
|
case f_0_op:
|
|
if (rn_to_kill[0]) --cglobs->Uses[rn_to_kill[0]];
|
|
rn_to_kill[1]=rn_to_kill[0]=0;
|
|
break;
|
|
case f_var_op:
|
|
if (rn_to_kill[0]) --cglobs->Uses[rn_to_kill[0]];
|
|
rn_to_kill[1]=rn_to_kill[0]=0;
|
|
case unify_var_op:
|
|
case unify_val_op:
|
|
case unify_last_var_op:
|
|
case unify_last_val_op:
|
|
#ifdef SFUNC
|
|
case unify_s_var_op:
|
|
case unify_s_val_op:
|
|
#endif
|
|
case fetch_args_for_bccall:
|
|
case bccall_op:
|
|
checktemp(arg, rn, ic, cglobs);
|
|
break;
|
|
case get_atom_op:
|
|
case get_num_op:
|
|
case get_float_op:
|
|
case get_longint_op:
|
|
case get_dbterm_op:
|
|
case get_bigint_op:
|
|
--cglobs->Uses[rn];
|
|
/* This is not safe if we are in the middle of a disjunction and there
|
|
is something ahead.
|
|
*/
|
|
if (!cglobs->Uses[rn])
|
|
cglobs->Contents[rn] = arg;
|
|
break;
|
|
case get_list_op:
|
|
case get_struct_op:
|
|
--cglobs->Uses[rn];
|
|
if (!cglobs->Uses[rn])
|
|
cglobs->Contents[rn] = NIL;
|
|
break;
|
|
case put_var_op:
|
|
case put_unsafe_op:
|
|
rn = checkreg(arg, rn, ic, TRUE, cglobs);
|
|
checktemp(arg, rn, ic, cglobs);
|
|
cglobs->Contents[rn] = cglobs->vadr;
|
|
++cglobs->Uses[rn];
|
|
break;
|
|
case put_val_op:
|
|
rn = checkreg(arg, rn, ic, TRUE, cglobs);
|
|
checktemp(arg, rn, ic, cglobs);
|
|
#ifdef BEAM
|
|
if (rn && cglobs->Contents[rn] == (Term)cglobs->vadr && !EAM)
|
|
#else
|
|
if (rn && cglobs->Contents[rn] == (Term)cglobs->vadr)
|
|
#endif
|
|
{
|
|
cglobs->cint.cpc->op = nop_op;
|
|
}
|
|
cglobs->Contents[rn] = cglobs->vadr;
|
|
++cglobs->Uses[rn];
|
|
if (rn_kills) {
|
|
rn_kills--;
|
|
rn_to_kill[rn_kills]=rn;
|
|
}
|
|
break;
|
|
case fetch_args_cv_op:
|
|
case fetch_args_vc_op:
|
|
case fetch_args_iv_op:
|
|
case fetch_args_vi_op:
|
|
rn_to_kill[1]=rn_to_kill[0]=0;
|
|
if (cglobs->cint.cpc->nextInst &&
|
|
cglobs->cint.cpc->nextInst->op == put_val_op &&
|
|
cglobs->cint.cpc->nextInst->nextInst &&
|
|
(cglobs->cint.cpc->nextInst->nextInst->op == f_var_op ||
|
|
cglobs->cint.cpc->nextInst->nextInst->op == f_0_op) )
|
|
rn_kills = 1;
|
|
break;
|
|
case f_val_op:
|
|
#ifdef SFUNC
|
|
case write_s_var_op:
|
|
{
|
|
Ventry *ve = (Ventry *) arg;
|
|
|
|
if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1)
|
|
cglobs->cint.cpc->op = nop_op;
|
|
}
|
|
break;
|
|
case write_s_val_op:
|
|
#endif
|
|
case write_var_op:
|
|
case write_val_op:
|
|
checktemp(arg, rn, ic, cglobs);
|
|
break;
|
|
#ifdef SFUNC
|
|
case put_s_f_op:
|
|
cglobs->Contents[rn] = arg;
|
|
++cglobs->Uses[rn];
|
|
break;
|
|
#endif
|
|
case put_atom_op:
|
|
case put_num_op:
|
|
case put_float_op:
|
|
case put_longint_op:
|
|
case put_dbterm_op:
|
|
case put_bigint_op:
|
|
rn = checkreg(arg, rn, ic, FALSE, cglobs);
|
|
if (cglobs->Contents[rn] == arg)
|
|
cglobs->cint.cpc->op = nop_op;
|
|
cglobs->Contents[rn] = arg;
|
|
++cglobs->Uses[rn];
|
|
break;
|
|
case put_list_op:
|
|
case put_struct_op:
|
|
rn = checkreg(arg, rn, ic, FALSE, cglobs);
|
|
cglobs->Contents[rn] = NIL;
|
|
++cglobs->Uses[rn];
|
|
break;
|
|
case commit_b_op:
|
|
#ifdef TABLING_INNER_CUTS
|
|
cglobs->cut_mark->op = clause_with_cut_op;
|
|
#endif /* TABLING_INNER_CUTS */
|
|
case save_b_op:
|
|
case patch_b_op:
|
|
case save_appl_op:
|
|
case save_pair_op:
|
|
checktemp(arg, rn, ic, cglobs);
|
|
break;
|
|
case safe_call_op:
|
|
Arity = RepPredProp((Prop) arg)->ArityOfPE;
|
|
/*
|
|
vsc: The variables will be in use after this!!!!
|
|
for (rn = 1; rn <= Arity; ++rn)
|
|
--cglobs->Uses[rn];
|
|
*/
|
|
break;
|
|
case call_op:
|
|
case orelse_op:
|
|
case orlast_op:
|
|
{
|
|
up = cglobs->Uses;
|
|
cop = cglobs->Contents;
|
|
for (rn = 1; rn < cglobs->MaxCTemps; ++rn) {
|
|
*up++ = *cop++ = NIL;
|
|
}
|
|
}
|
|
break;
|
|
case label_op:
|
|
{
|
|
up = cglobs->Uses;
|
|
cop = cglobs->Contents;
|
|
for (rn = 0; rn < cglobs->MaxCTemps; ++rn) {
|
|
if (*cop != (TempVar | rn)) {
|
|
*up++ = *cop++ = NIL;
|
|
} else {
|
|
up++;
|
|
cop++;
|
|
}
|
|
}
|
|
}
|
|
break;
|
|
case cut_op:
|
|
case cutexit_op:
|
|
{
|
|
int i, max;
|
|
|
|
max = 0;
|
|
for (i = 1; i < cglobs->MaxCTemps; ++i) {
|
|
if (cglobs->Contents[i]) max = i;
|
|
}
|
|
cglobs->cint.cpc->ops.opseqt[1] = max;
|
|
}
|
|
break;
|
|
case restore_tmps_and_skip_op:
|
|
case restore_tmps_op:
|
|
/*
|
|
This instruction is required by the garbage collector to find out
|
|
how many temporaries are live right now. It is also useful when
|
|
waking up goals before an either or ! instruction.
|
|
*/
|
|
{
|
|
PInstr *mycpc = cglobs->cint.cpc, *oldCodeStart = cglobs->cint.CodeStart;
|
|
int i, max;
|
|
|
|
/* instructions must be placed at BlobsStart */
|
|
cglobs->cint.CodeStart = cglobs->cint.BlobsStart;
|
|
cglobs->cint.cpc = cglobs->cint.icpc;
|
|
max = 0;
|
|
for (i = 1; i < cglobs->MaxCTemps; ++i) {
|
|
if (cglobs->Contents[i]) max = i;
|
|
}
|
|
Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
|
|
mycpc->rnd1 = cglobs->labelno;
|
|
rn = copy_live_temps_bmap(max, cglobs);
|
|
cglobs->cint.icpc = cglobs->cint.cpc;
|
|
cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
|
|
cglobs->cint.cpc = mycpc;
|
|
cglobs->cint.CodeStart = oldCodeStart;
|
|
}
|
|
default:
|
|
break;
|
|
}
|
|
if (cglobs->cint.cpc->nextInst)
|
|
cglobs->cint.cpc = cglobs->cint.cpc->nextInst;
|
|
else return;
|
|
}
|
|
}
|
|
|
|
static void
|
|
push_allocate(PInstr *pc, PInstr *oldpc)
|
|
{
|
|
/*
|
|
The idea is to push an allocate forward as much as we can. This
|
|
delays work in the emulated code, and in the best case we may get rid of
|
|
allocates altogether.
|
|
*/
|
|
/* we can push the allocate */
|
|
int safe = TRUE;
|
|
PInstr *initial = oldpc, *dealloc_founds[16];
|
|
int d_founds = 0;
|
|
int level = 0;
|
|
|
|
while (pc) {
|
|
switch (pc->op) {
|
|
case jump_op:
|
|
return;
|
|
case call_op:
|
|
case safe_call_op:
|
|
if (!safe)
|
|
return;
|
|
else {
|
|
PInstr *where = initial->nextInst->nextInst;
|
|
while (d_founds)
|
|
dealloc_founds[--d_founds]->op = nop_op;
|
|
if (where == pc || oldpc == initial->nextInst)
|
|
return;
|
|
oldpc->nextInst = initial->nextInst;
|
|
initial->nextInst->nextInst = pc;
|
|
initial->nextInst = where;
|
|
return;
|
|
}
|
|
case push_or_op:
|
|
/* we cannot just put an allocate here, because it may never be executed */
|
|
level++;
|
|
safe = FALSE;
|
|
break;
|
|
case pushpop_or_op:
|
|
/* last branch and we did not need an allocate so far, cool! */
|
|
level--;
|
|
if (!level)
|
|
safe = TRUE;
|
|
break;
|
|
case cut_op:
|
|
case either_op:
|
|
case execute_op:
|
|
return;
|
|
case deallocate_op:
|
|
dealloc_founds[d_founds++] = pc;
|
|
if (d_founds == 16)
|
|
return;
|
|
default:
|
|
break;
|
|
}
|
|
oldpc = pc;
|
|
pc = pc->nextInst;
|
|
}
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
c_optimize(PInstr *pc)
|
|
{
|
|
char onTail;
|
|
Ventry *v;
|
|
PInstr *opc = NULL;
|
|
PInstr *inpc = pc;
|
|
|
|
pc = inpc;
|
|
opc = NULL;
|
|
/* first reverse the pointers */
|
|
while (pc != NULL) {
|
|
PInstr *tpc = pc->nextInst;
|
|
pc->nextInst = opc;
|
|
opc = pc;
|
|
pc = tpc;
|
|
}
|
|
pc = opc;
|
|
opc = NULL;
|
|
onTail = 1;
|
|
do {
|
|
PInstr *npc = pc->nextInst;
|
|
pc->nextInst = opc;
|
|
switch (pc->op) {
|
|
case get_var_op:
|
|
/* handle clumsy either branches */
|
|
if (npc->op == f_0_op) {
|
|
npc->rnd1 = pc->rnd1;
|
|
npc->op = f_var_op;
|
|
pc->op = nop_op;
|
|
break;
|
|
}
|
|
case put_val_op:
|
|
case get_val_op:
|
|
{
|
|
Ventry *ve = (Ventry *) pc->rnd1;
|
|
|
|
if (ve->KindOfVE == TempVar) {
|
|
UInt argno = ve->NoOfVE & MaskVarAdrs;
|
|
if (argno && argno == pc->rnd2) {
|
|
pc->op = nop_op;
|
|
}
|
|
}
|
|
}
|
|
onTail = 1;
|
|
break;
|
|
case save_pair_op:
|
|
{
|
|
Term ve = (Term) pc->rnd1;
|
|
PInstr *npc = pc->nextInst;
|
|
|
|
if (((Ventry *) ve)->RCountOfVE <= 1)
|
|
pc->op = nop_op;
|
|
else {
|
|
*pc = *npc;
|
|
pc->nextInst = npc;
|
|
npc->op = save_pair_op;
|
|
npc->rnd1 = (CELL) ve;
|
|
}
|
|
}
|
|
break;
|
|
case save_appl_op:
|
|
{
|
|
Term ve = (Term) pc->rnd1;
|
|
PInstr *npc = pc->nextInst;
|
|
|
|
if (((Ventry *) ve)->RCountOfVE <= 1)
|
|
pc->op = nop_op;
|
|
else {
|
|
*pc = *npc;
|
|
pc->nextInst = npc;
|
|
npc->op = save_appl_op;
|
|
npc->rnd1 = (CELL) ve;
|
|
}
|
|
break;
|
|
}
|
|
case nop_op:
|
|
break;
|
|
case unify_var_op:
|
|
case unify_last_var_op:
|
|
#ifdef OLD_SYSTEM
|
|
/* In the good old days Yap would remove lots of small void
|
|
* instructions for a structure. This is not such a
|
|
* good idea nowadays, as we need to know where we
|
|
* finish the structure for the last instructions to
|
|
* work correctly. Instead, we will use unify_void
|
|
* with very little overhead */
|
|
v = (Ventry *) (pc->rnd1);
|
|
if (v->KindOfVE == VoidVar && onTail) {
|
|
pc->op = nop_op;
|
|
}
|
|
else
|
|
#endif /* OLD_SYSTEM */
|
|
onTail = 0;
|
|
break;
|
|
case unify_val_op:
|
|
v = (Ventry *) (pc->rnd1);
|
|
if (!(v->FlagsOfVE & GlobalVal))
|
|
pc->op = unify_local_op;
|
|
onTail = 0;
|
|
break;
|
|
case unify_last_val_op:
|
|
v = (Ventry *) (pc->rnd1);
|
|
if (!(v->FlagsOfVE & GlobalVal))
|
|
pc->op = unify_last_local_op;
|
|
onTail = 0;
|
|
break;
|
|
case write_val_op:
|
|
v = (Ventry *) (pc->rnd1);
|
|
if (!(v->FlagsOfVE & GlobalVal))
|
|
pc->op = write_local_op;
|
|
onTail = 0;
|
|
break;
|
|
case pop_op:
|
|
if (FALSE && onTail == 1) {
|
|
pc->op = nop_op;
|
|
onTail = 1;
|
|
break;
|
|
}
|
|
else {
|
|
PInstr *p = pc->nextInst;
|
|
|
|
while (p != NIL && p->op == nop_op)
|
|
p = p->nextInst;
|
|
if (p != NIL && p->op == pop_op) {
|
|
pc->rnd1 += p->rnd1;
|
|
pc->nextInst = p->nextInst;
|
|
}
|
|
onTail = 2;
|
|
break;
|
|
}
|
|
case write_var_op:
|
|
case unify_atom_op:
|
|
case unify_last_atom_op:
|
|
case write_atom_op:
|
|
case unify_num_op:
|
|
case unify_last_num_op:
|
|
case write_num_op:
|
|
case unify_float_op:
|
|
case unify_last_float_op:
|
|
case write_float_op:
|
|
case unify_longint_op:
|
|
case unify_bigint_op:
|
|
case unify_last_longint_op:
|
|
case unify_last_bigint_op:
|
|
case write_longint_op:
|
|
case write_bigint_op:
|
|
case unify_list_op:
|
|
case write_list_op:
|
|
case unify_struct_op:
|
|
case write_struct_op:
|
|
case write_unsafe_op:
|
|
case unify_last_list_op:
|
|
case write_last_list_op:
|
|
case unify_last_struct_op:
|
|
case write_last_struct_op:
|
|
#ifdef SFUNC
|
|
case unify_s_f_op:
|
|
case write_s_f_op:
|
|
#endif
|
|
onTail = 0;
|
|
break;
|
|
default:
|
|
onTail = 1;
|
|
break;
|
|
}
|
|
opc = pc;
|
|
pc = npc;
|
|
} while (pc != NULL);
|
|
pc = inpc;
|
|
opc = NULL;
|
|
while (pc != NULL) {
|
|
if (pc->op == allocate_op) {
|
|
push_allocate(pc, opc);
|
|
break;
|
|
}
|
|
opc = pc;
|
|
pc = pc->nextInst;
|
|
}
|
|
}
|
|
|
|
yamop *
|
|
Yap_cclause(volatile Term inp_clause, Int NOfArgs, Term mod, volatile Term src)
|
|
{ /* compile a prolog clause, copy of clause myst be in ARG1 */
|
|
/* returns address of code for clause */
|
|
Term head, body;
|
|
yamop *acode;
|
|
Term my_clause;
|
|
|
|
volatile int maxvnum = 512;
|
|
int botch_why;
|
|
/* may botch while doing a different module */
|
|
/* first, initialise cglobs->cint.CompilerBotch to handle all cases of interruptions */
|
|
compiler_struct cglobs;
|
|
|
|
/* make sure we know there was no error yet */
|
|
Yap_ErrorMessage = NULL;
|
|
if ((botch_why = sigsetjmp(cglobs.cint.CompilerBotch, 0))) {
|
|
restore_machine_regs();
|
|
reset_vars(cglobs.vtable);
|
|
Yap_ReleaseCMem(&cglobs.cint);
|
|
switch(botch_why) {
|
|
case OUT_OF_STACK_BOTCH:
|
|
/* out of local stack, just duplicate the stack */
|
|
{
|
|
Int osize = 2*sizeof(CELL)*(ASP-H);
|
|
ARG1 = inp_clause;
|
|
ARG3 = src;
|
|
|
|
YAPLeaveCriticalSection();
|
|
if (!Yap_gcl(Yap_Error_Size, NOfArgs, ENV, gc_P(P,CP))) {
|
|
Yap_Error_TYPE = OUT_OF_STACK_ERROR;
|
|
Yap_Error_Term = inp_clause;
|
|
}
|
|
if (osize > ASP-H) {
|
|
if (!Yap_growstack(2*sizeof(CELL)*(ASP-H))) {
|
|
Yap_Error_TYPE = OUT_OF_STACK_ERROR;
|
|
Yap_Error_Term = inp_clause;
|
|
}
|
|
}
|
|
YAPEnterCriticalSection();
|
|
src = ARG3;
|
|
inp_clause = ARG1;
|
|
}
|
|
break;
|
|
case OUT_OF_AUX_BOTCH:
|
|
/* out of local stack, just duplicate the stack */
|
|
YAPLeaveCriticalSection();
|
|
ARG1 = inp_clause;
|
|
ARG3 = src;
|
|
if (!Yap_ExpandPreAllocCodeSpace(Yap_Error_Size, NULL, TRUE)) {
|
|
Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
|
|
Yap_Error_Term = inp_clause;
|
|
}
|
|
YAPEnterCriticalSection();
|
|
src = ARG3;
|
|
inp_clause = ARG1;
|
|
break;
|
|
case OUT_OF_TEMPS_BOTCH:
|
|
/* out of temporary cells */
|
|
if (maxvnum < 16*1024) {
|
|
maxvnum *= 2;
|
|
} else {
|
|
maxvnum += 4096;
|
|
}
|
|
break;
|
|
case OUT_OF_HEAP_BOTCH:
|
|
/* not enough heap */
|
|
ARG1 = inp_clause;
|
|
ARG3 = src;
|
|
YAPLeaveCriticalSection();
|
|
if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
|
|
Yap_Error_TYPE = OUT_OF_HEAP_ERROR;
|
|
Yap_Error_Term = inp_clause;
|
|
return NULL;
|
|
}
|
|
YAPEnterCriticalSection();
|
|
src = ARG3;
|
|
inp_clause = ARG1;
|
|
break;
|
|
case OUT_OF_TRAIL_BOTCH:
|
|
/* not enough trail */
|
|
ARG1 = inp_clause;
|
|
ARG3 = src;
|
|
YAPLeaveCriticalSection();
|
|
if (!Yap_growtrail(Yap_TrailTop-(ADDR)TR, FALSE)) {
|
|
Yap_Error_TYPE = OUT_OF_TRAIL_ERROR;
|
|
Yap_Error_Term = inp_clause;
|
|
return NULL;
|
|
}
|
|
YAPEnterCriticalSection();
|
|
src = ARG3;
|
|
inp_clause = ARG1;
|
|
break;
|
|
default:
|
|
return NULL;
|
|
}
|
|
}
|
|
my_clause = inp_clause;
|
|
HB = H;
|
|
Yap_ErrorMessage = NULL;
|
|
Yap_Error_Size = 0;
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
/* initialize variables for code generation */
|
|
|
|
cglobs.cint.CodeStart = cglobs.cint.cpc = NULL;
|
|
cglobs.cint.BlobsStart = cglobs.cint.icpc = NULL;
|
|
cglobs.cint.dbterml = NULL;
|
|
cglobs.cint.blks = NULL;
|
|
cglobs.cint.label_offset = NULL;
|
|
cglobs.cint.freep =
|
|
cglobs.cint.freep0 =
|
|
(char *) (H + maxvnum+(sizeof(Int)/sizeof(CELL))*MaxTemps+MaxTemps);
|
|
cglobs.cint.success_handler = 0L;
|
|
if (ASP <= CellPtr (cglobs.cint.freep) + 256) {
|
|
cglobs.vtable = NULL;
|
|
Yap_Error_Size = (256+maxvnum)*sizeof(CELL);
|
|
save_machine_regs();
|
|
siglongjmp(cglobs.cint.CompilerBotch,3);
|
|
}
|
|
cglobs.Uses = (Int *)(H+maxvnum);
|
|
cglobs.Contents = (Term *)(H+maxvnum+(sizeof(Int)/sizeof(CELL))*MaxTemps);
|
|
cglobs.curbranch = cglobs.onbranch = 0;
|
|
cglobs.branch_pointer = cglobs.parent_branches;
|
|
cglobs.or_found = FALSE;
|
|
cglobs.max_args = 0;
|
|
cglobs.nvars = 0;
|
|
cglobs.tmpreg = 0;
|
|
cglobs.needs_env = FALSE;
|
|
/*
|
|
* 2000 added to H in case we need to construct call(G) when G is a
|
|
* variable used as a goal
|
|
*/
|
|
cglobs.vtable = NULL;
|
|
cglobs.common_exps = NULL;
|
|
cglobs.n_common_exps = 0;
|
|
cglobs.labelno = 0L;
|
|
cglobs.is_a_fact = FALSE;
|
|
cglobs.hasdbrefs = FALSE;
|
|
if (IsVarTerm(my_clause)) {
|
|
Yap_Error_TYPE = INSTANTIATION_ERROR;
|
|
Yap_Error_Term = my_clause;
|
|
Yap_ErrorMessage = "in compiling clause";
|
|
return 0;
|
|
}
|
|
if (IsApplTerm(my_clause) && FunctorOfTerm(my_clause) == FunctorAssert) {
|
|
head = ArgOfTerm(1, my_clause);
|
|
body = ArgOfTerm(2, my_clause);
|
|
}
|
|
else {
|
|
head = my_clause, body = MkAtomTerm(AtomTrue);
|
|
}
|
|
if (IsVarTerm(head) || IsPairTerm(head) || IsIntTerm(head) || IsFloatTerm(head) || IsRefTerm(head)) {
|
|
Yap_Error_TYPE = TYPE_ERROR_CALLABLE;
|
|
Yap_Error_Term = my_clause;
|
|
Yap_ErrorMessage = "clause should be atom or term";
|
|
return (0);
|
|
} else {
|
|
|
|
/* find out which predicate we are compiling for */
|
|
if (IsAtomTerm(head)) {
|
|
Atom ap = AtomOfTerm(head);
|
|
cglobs.cint.CurrentPred = RepPredProp(PredPropByAtom(ap, mod));
|
|
} else {
|
|
cglobs.cint.CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),mod));
|
|
}
|
|
/* insert extra instructions to count calls */
|
|
PELOCK(52,cglobs.cint.CurrentPred);
|
|
if ((cglobs.cint.CurrentPred->PredFlags & ProfiledPredFlag) ||
|
|
(PROFILING && (cglobs.cint.CurrentPred->cs.p_code.FirstClause == NIL))) {
|
|
profiling = TRUE;
|
|
call_counting = FALSE;
|
|
} else if ((cglobs.cint.CurrentPred->PredFlags & CountPredFlag) ||
|
|
(CALL_COUNTING && (cglobs.cint.CurrentPred->cs.p_code.FirstClause == NIL))) {
|
|
call_counting = TRUE;
|
|
profiling = FALSE;
|
|
} else {
|
|
profiling = FALSE;
|
|
call_counting = FALSE;
|
|
}
|
|
UNLOCK(cglobs.cint.CurrentPred->PELock);
|
|
}
|
|
cglobs.is_a_fact = (body == MkAtomTerm(AtomTrue));
|
|
/* phase 1 : produce skeleton code and variable information */
|
|
|
|
c_head(head, &cglobs);
|
|
|
|
if (cglobs.is_a_fact && !cglobs.vtable) {
|
|
#ifdef TABLING
|
|
PELOCK(53,cglobs.cint.CurrentPred);
|
|
if (is_tabled(cglobs.cint.CurrentPred))
|
|
Yap_emit(table_new_answer_op, Zero, cglobs.cint.CurrentPred->ArityOfPE, &cglobs.cint);
|
|
else
|
|
#endif /* TABLING */
|
|
Yap_emit(procceed_op, Zero, Zero, &cglobs.cint);
|
|
#ifdef TABLING
|
|
UNLOCK(cglobs.cint.CurrentPred->PELock);
|
|
#endif
|
|
/* ground term, do not need much more work */
|
|
if (cglobs.cint.BlobsStart != NULL) {
|
|
cglobs.cint.cpc->nextInst = cglobs.cint.BlobsStart;
|
|
cglobs.cint.BlobsStart = NULL;
|
|
}
|
|
if (Yap_ErrorMessage)
|
|
return (0);
|
|
#ifdef DEBUG
|
|
if (Yap_Option['g' - 96])
|
|
Yap_ShowCode(&cglobs.cint);
|
|
#endif
|
|
} else {
|
|
#ifdef TABLING_INNER_CUTS
|
|
Yap_emit(nop_op, Zero, Zero, &cglobs.cint);
|
|
cglobs->cut_mark = cpc;
|
|
#endif /* TABLING_INNER_CUTS */
|
|
Yap_emit(allocate_op, Zero, Zero, &cglobs.cint);
|
|
|
|
#ifdef BEAM
|
|
if (EAM) Yap_emit(body_op, Zero, Zero, &cglobs.cint);
|
|
#endif
|
|
|
|
c_body(body, mod, &cglobs);
|
|
/* Insert blobs at the very end */
|
|
|
|
if (cglobs.space_op)
|
|
cglobs.space_op->rnd1 = cglobs.space_used;
|
|
|
|
if (cglobs.cint.BlobsStart != NULL) {
|
|
cglobs.cint.cpc->nextInst = cglobs.cint.BlobsStart;
|
|
cglobs.cint.BlobsStart = NULL;
|
|
}
|
|
|
|
reset_vars(cglobs.vtable);
|
|
H = HB;
|
|
if (B != NULL) {
|
|
HB = B->cp_h;
|
|
}
|
|
if (Yap_ErrorMessage)
|
|
return (0);
|
|
#ifdef DEBUG
|
|
if (Yap_Option['g' - 96])
|
|
Yap_ShowCode(&cglobs.cint);
|
|
#endif
|
|
/* phase 2: classify variables and optimize temporaries */
|
|
c_layout(&cglobs);
|
|
/* Insert blobs at the very end */
|
|
if (cglobs.cint.BlobsStart != NULL) {
|
|
cglobs.cint.cpc->nextInst = cglobs.cint.BlobsStart;
|
|
cglobs.cint.BlobsStart = NULL;
|
|
while (cglobs.cint.cpc->nextInst != NULL)
|
|
cglobs.cint.cpc = cglobs.cint.cpc->nextInst;
|
|
}
|
|
}
|
|
/* eliminate superfluous pop's and unify_var's */
|
|
c_optimize(cglobs.cint.CodeStart);
|
|
#ifdef DEBUG
|
|
if (Yap_Option['f' - 96])
|
|
Yap_ShowCode(&cglobs.cint);
|
|
#endif
|
|
|
|
#ifdef BEAM
|
|
{
|
|
void codigo_eam(compiler_struct *);
|
|
|
|
if (EAM) codigo_eam(&cglobs);
|
|
}
|
|
#endif
|
|
|
|
/* phase 3: assemble code */
|
|
acode = Yap_assemble(ASSEMBLING_CLAUSE, src, cglobs.cint.CurrentPred, (cglobs.is_a_fact && !cglobs.hasdbrefs && !(cglobs.cint.CurrentPred->PredFlags & TabledPredFlag)), &cglobs.cint, cglobs.labelno+1);
|
|
/* check first if there was space for us */
|
|
Yap_ReleaseCMem (&cglobs.cint);
|
|
if (acode == NULL) {
|
|
return NULL;
|
|
} else {
|
|
#ifdef LOW_PROF
|
|
if (ProfilerOn &&
|
|
Yap_OffLineProfiler) {
|
|
Yap_inform_profiler_of_clause(acode, ProfEnd, cglobs.cint.CurrentPred,0);
|
|
}
|
|
#endif /* LOW_PROF */
|
|
return(acode);
|
|
}
|
|
}
|
|
|
|
#ifdef BEAM
|
|
#include "toeam.c"
|
|
#endif
|
|
|