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

3658 lines
110 KiB
C
Raw Normal View History

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: compiler.c *
* comments: Clause compiler *
* *
2016-10-20 04:44:59 +01:00
* 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
2016-10-20 04:44:59 +01:00
* 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
2016-10-20 04:44:59 +01:00
* replace SYSTEM_ERROR_INTERNAL 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%";
2016-10-20 04:44:59 +01:00
#endif /* SCCS */
#include "Yap.h"
2010-04-08 00:53:38 +01:00
#include "alloc.h"
2016-10-20 04:44:59 +01:00
#include "clause.h"
2017-02-20 14:21:46 +00:00
#include "YapCompile.h"
#include "yapio.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#ifdef BEAM
extern int EAM;
2016-10-20 04:44:59 +01:00
// extern PInstr *CodeStart, *ppc, *ppc1, *BodyStart, *ppc_body;
#endif
typedef struct branch_descriptor {
2016-10-20 04:44:59 +01:00
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;
2013-04-25 23:15:04 +01:00
static int active_branch(int, int);
static void c_var(Term, Int, unsigned int, unsigned int, compiler_struct *);
static void reset_vars(Ventry *);
static Term optimize_ce(Term, unsigned int, unsigned int, compiler_struct *);
static void c_arg(Int, Term, unsigned int, unsigned int, compiler_struct *);
static void c_args(Term, unsigned int, compiler_struct *);
static void c_eq(Term, Term, compiler_struct *);
static void c_test(Int, Term, compiler_struct *);
2016-10-20 04:44:59 +01:00
static void c_bifun(basic_preds, Term, Term, Term, Term, Term,
compiler_struct *);
2013-04-25 23:15:04 +01:00
static void c_goal(Term, Term, compiler_struct *);
static void c_body(Term, Term, compiler_struct *);
static void c_head(Term, compiler_struct *);
static bool usesvar(compiler_vm_op);
2013-04-25 23:15:04 +01:00
static CELL *init_bvarray(int, compiler_struct *);
#ifdef DEBUG
2013-04-25 23:15:04 +01:00
static void clear_bvarray(int, CELL *, compiler_struct *);
#else
2013-04-25 23:15:04 +01:00
static void clear_bvarray(int, CELL *);
#endif
2016-10-20 04:44:59 +01:00
static void add_bvarray_op(PInstr *, CELL *, int, compiler_struct *);
2013-04-25 23:15:04 +01:00
static void AssignPerm(PInstr *, compiler_struct *);
static void CheckUnsafe(PInstr *, compiler_struct *);
static void CheckVoids(compiler_struct *);
2016-10-20 04:44:59 +01:00
static int checktemp(Int, Int, compiler_vm_op, compiler_struct *);
static Int checkreg(Int, Int, compiler_vm_op, int, compiler_struct *);
2013-04-25 23:15:04 +01:00
static void c_layout(compiler_struct *);
static void c_optimize(PInstr *);
#ifdef SFUNC
2013-04-25 23:15:04 +01:00
static void compile_sf_term(Term, int);
#endif
2016-10-20 04:44:59 +01:00
static void push_branch(int id, Term cmvar, compiler_struct *cglobs) {
cglobs->branch_pointer->id = id;
cglobs->branch_pointer->cm = cmvar;
cglobs->branch_pointer++;
}
2016-10-20 04:44:59 +01:00
static int pop_branch(compiler_struct *cglobs) {
cglobs->branch_pointer--;
2016-10-20 04:44:59 +01:00
return (cglobs->branch_pointer->id);
}
#ifdef TABLING
2016-10-20 04:44:59 +01:00
#define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
#endif /* TABLING */
2016-10-20 04:44:59 +01:00
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);*/
}
2016-10-20 04:44:59 +01:00
#define FAIL(M, T, E) \
{ \
LOCAL_Error_TYPE = T; \
return; \
}
#if USE_SYSTEM_MALLOC
2016-10-20 04:44:59 +01:00
#define IsNewVar(v) ((CELL *)(v) >= H0 && (CELL *)(v) < LCL0)
#else
2016-10-20 04:44:59 +01:00
#define IsNewVar(v) \
(Addr(v) < cglobs->cint.freep0 || Addr(v) > cglobs->cint.freep)
#endif
inline static void pop_code(unsigned int, compiler_struct *);
2016-10-20 04:44:59 +01:00
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);
}
}
2016-10-20 04:44:59 +01:00
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);
}
}
}
2016-10-20 04:44:59 +01:00
static int check_var(Term t, unsigned int level, Int argno,
compiler_struct *cglobs) {
CACHE_REGS
int flags, new = FALSE;
Ventry *v = (Ventry *)t;
2016-10-20 04:44:59 +01:00
if (IsNewVar(v)) { /* new var */
v = (Ventry *)Yap_AllocCMem(sizeof(*v), &cglobs->cint);
2011-03-30 15:32:59 +01:00
#if YAPOR_SBA
v->SelfOfVE = 0;
#else
2016-10-20 04:44:59 +01:00
v->SelfOfVE = (CELL)v;
#endif
v->AdrsOfVE = t;
2016-10-20 04:44:59 +01:00
*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...
*/
2016-10-20 04:44:59 +01:00
if (((level > 0 || cglobs->onhead) && cglobs->curbranch == 0) ||
argno == save_pair_flag || argno == save_appl_flag)
flags |= SafeVar;
2016-10-20 04:44:59 +01:00
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)) {
2016-10-20 04:44:59 +01:00
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;
}
2016-10-20 04:44:59 +01:00
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;
}
2016-10-20 04:44:59 +01:00
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;
default:
#ifdef SFUNC
if (argno < 0) {
if (new)
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? unify_s_var_op : write_s_var_op), v, -argno,
&cglobs->cint);
else
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? unify_s_val_op : write_s_val_op), v, -argno,
&cglobs->cint);
} else
#endif
2016-10-20 04:44:59 +01:00
if (cglobs->onhead) {
cglobs->space_used++;
if (level == 0)
2016-10-20 04:44:59 +01:00
Yap_emit((new ? (++cglobs->nvars, get_var_op) : get_val_op), t, argno,
&cglobs->cint);
else
2016-10-20 04:44:59 +01:00
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)
2016-10-20 04:44:59 +01:00
Yap_emit((new ? (++cglobs->nvars, put_var_op) : put_val_op), t, argno,
&cglobs->cint);
else
2016-10-20 04:44:59 +01:00
Yap_emit((new ? (++cglobs->nvars, write_var_op) : write_val_op), t,
Zero, &cglobs->cint);
}
}
tag_var(t, new, cglobs);
}
// built-in like X >= Y.
2016-10-20 04:44:59 +01:00
static void c_2vars(int op, Term t1, Int argno1, Term t2, Int argno2,
CELL extra, unsigned int arity, unsigned int level,
compiler_struct *cglobs) {
int new1 = check_var((t1 = Deref(t1)), level, argno1, cglobs);
int new2 = check_var((t2 = Deref(t2)), level, argno2, cglobs);
switch (op) {
case bt_flag:
Yap_emit_5ops(bccall_op, t1, argno1, t2, argno2, extra, &cglobs->cint);
break;
default:
return;
}
tag_var(t1, new1, cglobs);
tag_var(t2, new2, cglobs);
}
2016-10-20 04:44:59 +01:00
static void reset_vars(Ventry *vtable) {
Ventry *v = vtable;
CELL *t;
while (v != NIL) {
2016-10-20 04:44:59 +01:00
t = (CELL *)v->AdrsOfVE;
RESET_VARIABLE(t);
v = v->NextOfVE;
}
}
2016-10-20 04:44:59 +01:00
static Term optimize_ce(Term t, unsigned int arity, unsigned int level,
compiler_struct *cglobs) {
CACHE_REGS
CExpEntry *p = cglobs->common_exps;
int cmp = 0;
#ifdef BEAM
2016-10-20 04:44:59 +01:00
if (EAM)
return t;
#endif
if (IsApplTerm(t) && IsExtensionFunctor(FunctorOfTerm(t)))
return (t);
while (p != NULL) {
2014-01-19 21:15:05 +00:00
CELL *oldH = HR;
HR = (CELL *)cglobs->cint.freep;
cmp = Yap_compare_terms(t, (p->TermOfCE));
2014-01-19 21:15:05 +00:00
HR = oldH;
if (cmp) {
p = p->NextCE;
} else {
break;
}
}
2016-10-20 04:44:59 +01:00
if (p != NULL) { /* already there */
return (p->VarOfCE);
}
/* first occurrence */
if (cglobs->onbranch || level > 1) {
return t;
}
++(cglobs->n_common_exps);
2016-10-20 04:44:59 +01:00
p = (CExpEntry *)Yap_AllocCMem(sizeof(CExpEntry), &cglobs->cint);
p->TermOfCE = t;
p->VarOfCE = MkVarTerm();
2014-01-19 21:15:05 +00:00
if (HR >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
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)
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? get_s_f_op : put_s_f_op), f, argno,
&cglobs->cint);
else
2016-10-20 04:44:59 +01:00
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))
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? unify_s_a_op : write_s_a_op), t, (CELL)argno,
&cglobs->cint);
else if (!IsVarTerm(t)) {
2016-10-20 04:44:59 +01:00
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
LOCAL_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)
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? get_s_end_op : put_s_end_op), Zero, Zero,
&cglobs->cint);
else
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? unify_s_end_op : write_s_end_op), Zero, Zero,
&cglobs->cint);
}
#endif
2016-10-20 04:44:59 +01:00
inline static void c_args(Term app, unsigned int level,
compiler_struct *cglobs) {
CACHE_REGS
Functor f = FunctorOfTerm(app);
unsigned int Arity = ArityOfFunctor(f);
unsigned int i;
if (level == 0) {
if (Arity >= MaxTemps) {
2015-09-25 10:57:26 +01:00
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
LOCAL_ErrorMessage = "exceed maximum arity of compiled goal";
save_machine_regs();
2010-12-16 01:22:10 +00:00
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);
}
2016-10-20 04:44:59 +01:00
static int try_store_as_dbterm(Term t, Int argno, unsigned int arity, int level,
compiler_struct *cglobs) {
CACHE_REGS
DBTerm *dbt;
int g;
2014-01-19 21:15:05 +00:00
CELL *h0 = HR;
2016-10-20 04:44:59 +01:00
while ((g = Yap_SizeGroundTerm(t, TRUE)) < 0) {
/* oops, too deep a term */
save_machine_regs();
LOCAL_Error_Size = 0;
2010-12-16 01:22:10 +00:00
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH);
}
// if (g < 16)
2016-10-20 04:44:59 +01:00
return FALSE;
/* store ground term away */
2014-01-19 21:15:05 +00:00
HR = CellPtr(cglobs->cint.freep);
if ((dbt = Yap_StoreTermInDB(t, -1)) == NULL) {
2014-01-19 21:15:05 +00:00
HR = h0;
2016-10-20 04:44:59 +01:00
switch (LOCAL_Error_TYPE) {
2015-09-25 10:57:26 +01:00
case RESOURCE_ERROR_STACK:
LOCAL_Error_TYPE = YAP_NO_ERROR;
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_STACK_BOTCH);
2015-09-25 10:57:26 +01:00
case RESOURCE_ERROR_TRAIL:
LOCAL_Error_TYPE = YAP_NO_ERROR;
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TRAIL_BOTCH);
2015-09-25 10:57:26 +01:00
case RESOURCE_ERROR_HEAP:
LOCAL_Error_TYPE = YAP_NO_ERROR;
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
2015-09-25 10:57:26 +01:00
case RESOURCE_ERROR_AUXILIARY_STACK:
LOCAL_Error_TYPE = YAP_NO_ERROR;
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH);
default:
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
}
}
2014-01-19 21:15:05 +00:00
HR = h0;
if (level == 0)
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
: unify_dbterm_op)
: write_dbterm_op),
dbt->Entry, Zero, &cglobs->cint);
return TRUE;
}
2016-10-20 04:44:59 +01:00
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)) {
2016-10-20 04:44:59 +01:00
if (level == 0) {
Yap_emit((cglobs->onhead ? get_atom_op : put_atom_op), (CELL)t, argno,
&cglobs->cint);
} else
2016-10-20 04:44:59 +01:00
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) ||
IsStringTerm(t)) {
if (!IsIntTerm(t)) {
if (IsFloatTerm(t)) {
2016-10-20 04:44:59 +01:00
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)) {
2016-10-20 04:44:59 +01:00
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 if (IsStringTerm(t)) {
2016-10-20 04:44:59 +01:00
/* we are taking a string, that is supposed to be
guarded in the clause itself. . */
CELL l1 = ++cglobs->labelno;
CELL *src = RepAppl(t);
PInstr *ocpc = cglobs->cint.cpc, *OCodeStart = cglobs->cint.CodeStart;
Int sz = (3 + src[1]) * sizeof(CELL);
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_string_op : put_string_op), l1, argno,
&cglobs->cint);
else
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_string_op
: unify_string_op)
: write_string_op),
l1, Zero, &cglobs->cint);
} else {
2016-10-20 04:44:59 +01:00
/* 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(Functor) + 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)
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? get_num_op : put_num_op), (CELL)t, argno,
&cglobs->cint);
else
2016-10-20 04:44:59 +01:00
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) && !defined(YAPOR)
/* discard code sharing because we cannot write on shared stuff */
2016-10-20 04:44:59 +01:00
if (FALSE &&
!(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)) {
2016-10-20 04:44:59 +01:00
c_var(t, argno, arity, level, cglobs);
return;
}
}
if (level == 0)
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? get_list_op : put_list_op), Zero, argno,
&cglobs->cint);
else if (argno == (Int)arity)
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? unify_last_list_op : write_last_list_op), Zero,
Zero, &cglobs->cint);
else
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
/* 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)) {
2016-10-20 04:44:59 +01:00
PELOCK(40, cglobs->cint.CurrentPred);
if (!(cglobs->cint.CurrentPred->PredFlags &
(DynamicPredFlag | LogUpdatePredFlag))) {
CACHE_REGS
UNLOCK(cglobs->cint.CurrentPred->PELock);
2016-10-20 04:44:59 +01:00
FAIL("can not compile data base reference", TYPE_ERROR_CALLABLE, t);
} else {
UNLOCK(cglobs->cint.CurrentPred->PELock);
cglobs->hasdbrefs = TRUE;
if (level == 0)
2016-10-20 04:44:59 +01:00
Yap_emit((cglobs->onhead ? get_atom_op : put_atom_op), (CELL)t, argno,
&cglobs->cint);
else
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
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)) {
2016-10-20 04:44:59 +01:00
c_var(t, argno, arity, level, cglobs);
return;
}
}
2016-10-20 04:44:59 +01:00
cglobs->space_used += 1 + arity;
if (level == 0)
Yap_emit((cglobs->onhead ? get_struct_op : put_struct_op),
2016-10-20 04:44:59 +01:00
(CELL)FunctorOfTerm(t), argno, &cglobs->cint);
else if (argno == (Int)arity)
Yap_emit((cglobs->onhead ? unify_last_struct_op : write_last_struct_op),
2016-10-20 04:44:59 +01:00
(CELL)FunctorOfTerm(t), Zero, &cglobs->cint);
else
Yap_emit((cglobs->onhead ? unify_struct_op : write_struct_op),
2016-10-20 04:44:59 +01:00
(CELL)FunctorOfTerm(t), Zero, &cglobs->cint);
++level;
c_args(t, level, cglobs);
--level;
if (argno != (Int)arity) {
pop_code(level, cglobs);
}
}
}
2016-10-20 04:44:59 +01:00
static void c_eq(Term t1, Term t2, compiler_struct *cglobs) {
CACHE_REGS
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)) {
2016-10-20 04:44:59 +01:00
/* 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)) {
2016-10-20 04:44:59 +01:00
/* 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)) {
2016-10-20 04:44:59 +01:00
/* 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 {
2016-10-20 04:44:59 +01:00
/* 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 */
2016-10-20 04:44:59 +01:00
if (IsNewVar(t1) && !IsVarTerm(t2) &&
!(cglobs->cint.CurrentPred->PredFlags & TabledPredFlag)) {
Int v;
2016-10-20 04:44:59 +01:00
v = --cglobs->tmpreg;
c_arg(v, t2, 0, 0, cglobs);
cglobs->onhead = TRUE;
c_var(t1, v, 0, 0, cglobs);
2016-10-20 04:44:59 +01:00
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;
}
}
2016-10-20 04:44:59 +01:00
static void c_test(Int Op, Term t1, compiler_struct *cglobs) {
CACHE_REGS
Term t = Deref(t1);
2013-02-15 16:30:53 +00:00
/* be caareful, has to be first occurrence */
if (Op == _save_by) {
if (!IsNewVar(t)) {
2016-10-20 04:44:59 +01:00
char s[32];
2013-02-15 16:30:53 +00:00
2016-10-20 04:44:59 +01:00
LOCAL_Error_TYPE = UNINSTANTIATION_ERROR;
Yap_bip_name(Op, s);
sprintf(LOCAL_ErrorMessage, "compiling %s/2 on bound variable", s);
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
2013-02-15 16:30:53 +00:00
}
c_var(t, save_b_flag, 1, 0, cglobs);
return;
}
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
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
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
*/
2016-10-20 04:44:59 +01:00
static void c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal,
Term mod, compiler_struct *cglobs) {
CACHE_REGS
2016-10-20 04:44:59 +01:00
/* compile Z = X Op Y arithmetic function */
/* first we fetch the arguments */
if (IsVarTerm(t1)) {
if (IsVarTerm(t2)) {
2016-10-20 04:44:59 +01:00
/* 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) {
2016-10-20 04:44:59 +01:00
/* 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)) {
2016-10-20 04:44:59 +01:00
/* first temp */
Int v1 = 0;
2016-10-20 04:44:59 +01:00
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 {
2016-10-20 04:44:59 +01:00
char s[32];
Yap_bip_name(Op, s);
2016-11-16 23:09:06 +00:00
Yap_ThrowError(TYPE_ERROR_NUMBER, t2, 1,
"compiling %s/2 with output bound", s);
2016-10-20 04:44:59 +01:00
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)) {
2016-10-20 04:44:59 +01:00
char s[32];
Yap_bip_name(Op, s);
2016-11-16 23:09:06 +00:00
Yap_ThrowError(INSTANTIATION_ERROR, t2, 1, "compiling %s/3", s);
2016-10-20 04:44:59 +01:00
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
} else {
if (Op == _functor) {
2016-10-20 04:44:59 +01:00
/* both arguments are bound, we must perform unification */
Int i2;
if (!IsIntegerTerm(t2)) {
2016-11-16 23:09:06 +00:00
Yap_ThrowError(TYPE_ERROR_INTEGER, t2, 1, "compiling functor/3");
2016-10-20 04:44:59 +01:00
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
i2 = IntegerOfTerm(t2);
if (i2 < 0) {
Yap_ThrowError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2,
2016-11-16 23:09:06 +00:00
"compiling functor/3");
2016-10-20 04:44:59 +01:00
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_bip_name(Op, s);
2016-11-16 23:09:06 +00:00
Yap_ThrowError(TYPE_ERROR_ATOM, t2, 4, "compiling functor/3");
2016-10-20 04:44:59 +01:00
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
if (i2 == 0)
c_eq(t1, t3, cglobs);
else {
CELL *hi = HR;
Int i;
if (t1 == TermDot && i2 == 2) {
if (HR + 2 >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
}
RESET_VARIABLE(HR);
RESET_VARIABLE(HR + 1);
HR += 2;
c_eq(AbsPair(HR - 2), t3, cglobs);
} else if (i2 < 256 && IsAtomTerm(t1)) {
*HR++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1), i2);
for (i = 0; i < i2; i++) {
if (HR >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
}
RESET_VARIABLE(HR);
HR++;
}
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) {
2016-10-20 04:44:59 +01:00
Int i1;
if (IsIntegerTerm(t1))
i1 = IntegerOfTerm(t1);
else {
char s[32];
Yap_bip_name(Op, s);
2016-11-16 23:09:06 +00:00
Yap_ThrowError(TYPE_ERROR_INTEGER, t1, 1, "compiling %s/2", s);
2016-10-20 04:44:59 +01:00
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
if (IsAtomicTerm(t2) ||
(IsApplTerm(t2) && IsExtensionFunctor(FunctorOfTerm(t2)))) {
char s[32];
LOCAL_Error_TYPE = TYPE_ERROR_COMPOUND;
Yap_bip_name(Op, s);
2016-11-16 23:09:06 +00:00
Yap_ThrowError(TYPE_ERROR_COMPOUND, t2, 1, "compiling %s/2", 1, s);
2016-10-20 04:44:59 +01:00
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 {
2016-10-20 04:44:59 +01:00
char s[32];
LOCAL_Error_TYPE = TYPE_ERROR_INTEGER;
Yap_bip_name(Op, s);
sprintf(LOCAL_ErrorMessage, "compiling %s/2", s);
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
}
if (Op == _functor) {
if (!IsAtomicTerm(t1)) {
2016-10-20 04:44:59 +01:00
char s[32];
LOCAL_Error_TYPE = TYPE_ERROR_ATOM;
Yap_bip_name(Op, s);
sprintf(LOCAL_ErrorMessage, "compiling %s/2", s);
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
} else {
2016-10-20 04:44:59 +01:00
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];
LOCAL_Error_TYPE = TYPE_ERROR_INTEGER;
Yap_bip_name(Op, s);
sprintf(LOCAL_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];
LOCAL_Error_TYPE = TYPE_ERROR_ATOM;
Yap_bip_name(Op, s);
sprintf(LOCAL_ErrorMessage, "compiling %s/2", s);
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
if (HR + 1 + arity >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
}
tnew = AbsAppl(HR);
*HR++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1), arity);
while (arity--) {
RESET_VARIABLE(HR);
HR++;
}
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];
2015-09-25 10:57:26 +01:00
LOCAL_Error_TYPE = UNINSTANTIATION_ERROR;
Yap_bip_name(Op, s);
2016-10-20 04:44:59 +01:00
sprintf(LOCAL_ErrorMessage, "compiling %s/2 with output bound", s);
save_machine_regs();
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
2016-10-20 04:44:59 +01:00
}
/* then we compile the opcode/result */
if (!IsVarTerm(t3)) {
if (Op == _arg) {
Term tmpvar = MkVarTerm();
2014-01-19 21:15:05 +00:00
if (HR == (CELL *)cglobs->cint.freep0) {
2016-10-20 04:44:59 +01:00
/* oops, too many new variables */
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
}
2016-10-20 04:44:59 +01:00
c_var(tmpvar, f_flag, (unsigned int)Op, 0, cglobs);
c_eq(tmpvar, t3, cglobs);
} else {
char s[32];
2015-09-25 10:57:26 +01:00
LOCAL_Error_TYPE = UNINSTANTIATION_ERROR;
Yap_bip_name(Op, s);
2016-10-20 04:44:59 +01:00
sprintf(LOCAL_ErrorMessage, "compiling %s/2 with input unbound", s);
save_machine_regs();
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs->cint.CompilerBotch, 1);
}
2016-10-20 04:44:59 +01:00
} else if (IsNewVar(t3) && cglobs->curbranch == 0 &&
cglobs->cint.CurrentPred->PredFlags & TabledPredFlag) {
Term nv = MkVarTerm();
2016-10-20 04:44:59 +01:00
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);
}
2016-10-20 04:44:59 +01:00
/* 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);
2016-10-20 04:44:59 +01:00
} 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 {
2016-10-20 04:44:59 +01:00
/* 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;
}
}
2016-10-20 04:44:59 +01:00
static void c_functor(Term Goal, Term mod, compiler_struct *cglobs) {
CACHE_REGS
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)) {
2016-10-20 04:44:59 +01:00
c_eq(t1, t2, cglobs);
c_eq(t3, MkIntTerm(0), cglobs);
} else if (IsApplTerm(t1)) {
Functor f = FunctorOfTerm(t1);
2016-10-20 04:44:59 +01:00
c_eq(t2, MkAtomTerm(NameOfFunctor(f)), cglobs);
c_eq(t3, MkIntegerTerm(ArityOfFunctor(f)), cglobs);
} else /* list */ {
2016-10-20 04:44:59 +01:00
c_eq(t2, TermDot, cglobs);
c_eq(t3, MkIntTerm(2), cglobs);
}
2016-10-20 04:44:59 +01:00
} 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);
2016-10-20 04:44:59 +01:00
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();
2010-12-16 01:22:10 +00:00
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
2016-05-13 11:41:19 +01:00
if (profiling) {
Yap_emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero, &cglobs->cint);
2016-05-13 11:41:19 +01:00
} else if (call_counting)
Yap_emit(count_call_op, (CELL)RepPredProp(p0), Zero, &cglobs->cint);
c_args(Goal, 0, cglobs);
2016-10-20 04:44:59 +01:00
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);
}
}
2016-10-20 04:44:59 +01:00
static int IsTrueGoal(Term t) {
if (IsVarTerm(t))
return (FALSE);
if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
if (f == FunctorModule) {
2016-10-20 04:44:59 +01:00
return (IsTrueGoal(ArgOfTerm(2, t)));
}
2016-10-20 04:44:59 +01:00
if (f == FunctorComma || f == FunctorOr || f == FunctorVBar ||
f == FunctorArrow) {
return (IsTrueGoal(ArgOfTerm(1, t)) && IsTrueGoal(ArgOfTerm(2, t)));
}
2016-10-20 04:44:59 +01:00
return (FALSE);
}
2016-10-20 04:44:59 +01:00
return (t == MkAtomTerm(AtomTrue));
}
2016-10-20 04:44:59 +01:00
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;
}
}
}
2016-10-20 04:44:59 +01:00
static void c_goal(Term Goal, Term mod, compiler_struct *cglobs) {
Functor f;
PredEntry *p;
Prop p0;
2016-11-16 23:09:06 +00:00
Goal = Yap_YapStripModule(Goal, &mod);
if (IsVarTerm(Goal)) {
Goal = Yap_MkApplTerm(FunctorCall, 1, &Goal);
} else if (IsNumTerm(Goal)) {
CACHE_REGS
FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal);
} else if (IsRefTerm(Goal)) {
CACHE_REGS
LOCAL_Error_TYPE = TYPE_ERROR_DBREF;
2016-10-20 04:44:59 +01:00
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;
2016-10-20 04:44:59 +01:00
} else if (atom == AtomTrue || atom == AtomOtherwise) {
if (cglobs->onlast) {
2016-10-20 04:44:59 +01:00
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
}
return;
2016-10-20 04:44:59 +01:00
} else if (atom == AtomCut) {
if (profiling)
2016-10-20 04:44:59 +01:00
Yap_emit(enter_profiling_op,
(CELL)RepPredProp(PredPropByAtom(AtomCut, 0)), Zero,
&cglobs->cint);
else if (call_counting)
2016-10-20 04:44:59 +01:00
Yap_emit(count_call_op, (CELL)RepPredProp(PredPropByAtom(AtomCut, 0)),
Zero, &cglobs->cint);
if (cglobs->onlast) {
2016-10-20 04:44:59 +01:00
/* never a problem here with a -> b, !, c ; d */
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
{
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
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
2016-10-20 04:44:59 +01:00
} 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)
2016-10-20 04:44:59 +01:00
Yap_emit(enter_profiling_op,
(CELL)RepPredProp(PredPropByAtom(AtomRepeat, 0)), Zero,
&cglobs->cint);
else if (call_counting)
2016-10-20 04:44:59 +01:00
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;
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
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
}
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
2016-10-20 04:44:59 +01:00
} 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();
2010-12-16 01:22:10 +00:00
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);
2016-10-20 04:44:59 +01:00
} else {
f = FunctorOfTerm(Goal);
p = RepPredProp(p0 = Yap_PredPropByFunctorNonThreadLocal(f, mod));
if (EndOfPAEntr(p0)) {
save_machine_regs();
2010-12-16 01:22:10 +00:00
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 {
2016-10-20 04:44:59 +01:00
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) {
CACHE_REGS
/* 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 (HR == (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) {
2016-10-20 04:44:59 +01:00
Yap_emit(orlast_op, Zero, Zero, &cglobs->cint);
} else {
2016-10-20 04:44:59 +01:00
optimizing_commit = FALSE; /* not really necessary */
}
c_goal(Goal, mod, cglobs);
/* --cglobs->onbranch; */
cglobs->onbranch = pop_branch(cglobs);
if (!cglobs->onlast) {
2016-10-20 04:44:59 +01:00
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;
2016-10-20 04:44:59 +01:00
} 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;
2016-10-20 04:44:59 +01:00
} else if (f == FunctorNot || f == FunctorAltNot) {
CACHE_REGS
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();
2014-01-19 21:15:05 +00:00
if (HR == (CELL *)cglobs->cint.freep0) {
2016-10-20 04:44:59 +01:00
/* 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);
2016-10-20 04:44:59 +01:00
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;
2016-10-20 04:44:59 +01:00
} else if (f == FunctorArrow) {
CACHE_REGS
Term commitvar;
int save = cglobs->onlast;
commitvar = MkVarTerm();
2014-01-19 21:15:05 +00:00
if (HR == (CELL *)cglobs->cint.freep0) {
2016-10-20 04:44:59 +01:00
/* 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;
2016-10-20 04:44:59 +01:00
} else if (f == FunctorEq) {
if (profiling)
2016-10-20 04:44:59 +01:00
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
else if (call_counting)
2016-10-20 04:44:59 +01:00
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
c_eq(ArgOfTerm(1, Goal), ArgOfTerm(2, Goal), cglobs);
if (cglobs->onlast) {
2016-10-20 04:44:59 +01:00
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
}
return;
2016-10-20 04:44:59 +01:00
} else if (f == FunctorSafe) {
Ventry *v = (Ventry *)ArgOfTerm(1, Goal);
/* This variable must be known before */
v->FlagsOfVE |= SafeVar;
return;
2016-10-20 04:44:59 +01:00
} else if (p->PredFlags & (AsmPredFlag)) {
2010-02-22 23:08:40 +00:00
basic_preds op = p->PredFlags & 0x7f;
if (profiling)
2016-10-20 04:44:59 +01:00
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
else if (call_counting)
2016-10-20 04:44:59 +01:00
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
if (op >= _atom && op <= _primitive) {
2016-10-20 04:44:59 +01:00
c_test(op, ArgOfTerm(1, Goal), cglobs);
if (cglobs->onlast) {
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
2016-10-20 04:44:59 +01:00
}
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
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
2016-10-20 04:44:59 +01:00
}
return;
} else if (op == _p_label_ctl) {
2016-10-20 04:44:59 +01:00
emit_special_label(Goal, cglobs);
return;
} else {
2016-10-20 04:44:59 +01:00
c_args(Goal, 0, cglobs);
}
}
#ifdef BEAM
else if (p->PredFlags & BinaryPredFlag && !EAM) {
#else
2016-10-20 04:44:59 +01:00
else if (p->PredFlags & BinaryPredFlag) {
#endif
CACHE_REGS
2016-10-20 04:44:59 +01:00
Term a1 = ArgOfTerm(1, Goal);
if (IsVarTerm(a1) && !IsNewVar(a1)) {
2016-10-20 04:44:59 +01:00
Term a2 = ArgOfTerm(2, Goal);
if (IsVarTerm(a2) && !IsNewVar(a2)) {
cglobs->current_p0 = p0;
c_2vars(bt_flag, a1, 0, a2, 0, (CELL)p0, 0, 0, cglobs);
} else {
Term t2 = MkVarTerm();
// c_var(t2, --cglobs->tmpreg, 0, 0, cglobs);
if (HR == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
}
cglobs->current_p0 = p0;
c_eq(t2, a2, cglobs);
c_2vars(bt_flag, a1, 0, t2, 0, (CELL)p0, 0, 0, cglobs);
}
} else {
2016-10-20 04:44:59 +01:00
Term a2 = ArgOfTerm(2, Goal);
Term t1 = MkVarTerm();
// c_var(t1, --cglobs->tmpreg, 0, 0, cglobs);
if (HR == (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)) {
cglobs->current_p0 = p0;
c_2vars(bt_flag, t1, 0, a2, 0, (CELL)p0, 0, 0, cglobs);
} else {
Term t2 = MkVarTerm();
// c_var(t2, --cglobs->tmpreg, 0, 0, cglobs);
if (HR == (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);
cglobs->current_p0 = p0;
c_2vars(bt_flag, t1, 0, t2, 0, (CELL)p0, 0, 0, cglobs);
}
}
if (cglobs->onlast) {
2016-10-20 04:44:59 +01:00
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
}
return;
} else {
if (profiling)
2016-10-20 04:44:59 +01:00
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
else if (call_counting)
2016-10-20 04:44:59 +01:00
Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
if (f == FunctorExecuteInMod) {
2016-10-20 04:44:59 +01:00
/* compile the first argument only */
c_arg(1, ArgOfTerm(1, Goal), 1, 0, cglobs);
} else {
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
) {
Yap_emit(safe_call_op, (CELL)p0, Zero, &cglobs->cint);
if (cglobs->onlast) {
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
PELOCK(48, cglobs->cint.CurrentPred);
if (is_tabled(cglobs->cint.CurrentPred))
2016-10-20 04:44:59 +01:00
Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE,
&cglobs->cint);
else
#endif /* TABLING */
2016-10-20 04:44:59 +01:00
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
}
2016-10-20 04:44:59 +01:00
} else {
if ((p->PredFlags &
(AsmPredFlag | ModuleTransparentPredFlag | UserCPredFlag)) ||
p->FunctorOfPred == FunctorExecuteInMod) {
#ifdef YAPOR
if (p->PredFlags & SyncPredFlag)
2016-10-20 04:44:59 +01:00
Yap_emit(sync_op, (CELL)p, (CELL)(p->ArityOfPE), &cglobs->cint);
#endif /* YAPOR */
if (p->FunctorOfPred == FunctorExecuteInMod) {
2016-10-20 04:44:59 +01:00
cglobs->needs_env = TRUE;
Yap_emit_4ops(call_op, (CELL)p0, Zero, Zero, ArgOfTerm(2, Goal),
&cglobs->cint);
} else {
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
cglobs->or_found = TRUE;
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
}
2016-10-20 04:44:59 +01:00
} else {
if (cglobs->onlast) {
2016-10-20 04:44:59 +01:00
Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_emit(execute_op, (CELL)p0, Zero, &cglobs->cint);
#ifdef TABLING
2016-10-20 04:44:59 +01:00
UNLOCK(cglobs->cint.CurrentPred->PELock);
#endif
2016-10-20 04:44:59 +01:00
} else {
cglobs->needs_env = TRUE;
Yap_emit_3ops(call_op, (CELL)p0, Zero, Zero, &cglobs->cint);
}
}
if (!cglobs->onlast)
++cglobs->goalno;
}
}
2016-10-20 04:44:59 +01:00
static void c_body(Term Body, Term mod, compiler_struct *cglobs) {
cglobs->onhead = FALSE;
cglobs->BodyStart = cglobs->cint.cpc;
cglobs->goalno = 1;
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
of the clause.
*/
Body = ArgOfTerm(1, Body);
break;
}
c_goal(ArgOfTerm(1, Body), mod, cglobs);
Body = t2;
#ifdef BEAM
2016-10-20 04:44:59 +01:00
if (EAM)
Yap_emit(endgoal_op, Zero, Zero, &cglobs->cint);
#endif
}
cglobs->onlast = TRUE;
c_goal(Body, mod, cglobs);
#ifdef BEAM
2016-10-20 04:44:59 +01:00
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
}
2016-10-20 04:44:59 +01:00
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)) {
2016-10-20 04:44:59 +01:00
Yap_emit(name_op, (CELL)AtomOfTerm(t), Zero, &cglobs->cint);
#ifdef BEAM
2013-01-15 22:58:34 +00:00
if (EAM) {
2016-10-20 04:44:59 +01:00
Yap_emit(run_op, Zero, (UInt)cglobs->cint.CurrentPred, &cglobs->cint);
2013-01-15 22:58:34 +00:00
}
#endif
2016-10-20 04:44:59 +01:00
Yap_emit(ensure_space_op, Zero, Zero, &cglobs->cint);
2013-01-15 22:58:34 +00:00
cglobs->space_op = cglobs->cint.cpc;
return;
}
f = FunctorOfTerm(t);
2016-10-20 04:44:59 +01:00
Yap_emit(name_op, (CELL)NameOfFunctor(f), ArityOfFunctor(f), &cglobs->cint);
#ifdef BEAM
2016-10-20 04:44:59 +01:00
if (EAM) {
Yap_emit(run_op, Zero, (UInt)cglobs->cint.CurrentPred, &cglobs->cint);
}
#endif
2013-01-15 22:58:34 +00:00
if (Yap_ExecutionMode == MIXED_MODE_USER)
2016-10-20 04:44:59 +01:00
Yap_emit(native_op, 0, 0, &cglobs->cint);
Yap_emit(ensure_space_op, Zero, Zero, &cglobs->cint);
2013-01-15 22:58:34 +00:00
cglobs->space_op = cglobs->cint.cpc;
2015-01-26 04:02:46 +00:00
#ifdef BEAM
if (EAM) {
2016-10-20 04:44:59 +01:00
Yap_emit(run_op, Zero, (UInt)cglobs->cint.CurrentPred, &cglobs->cint);
2015-01-26 04:02:46 +00:00
}
#endif
if (Yap_ExecutionMode == MIXED_MODE || Yap_ExecutionMode == COMPILED)
#if YAP_JIT
Yap_emit(native_op, 0, 0, &cglobs->cint);
#else
{
if (Yap_ExecutionMode == MIXED_MODE)
2015-09-25 10:57:26 +01:00
Yap_NilError(SYSTEM_ERROR_JIT_NOT_AVAILABLE, "mixed");
2015-01-26 04:02:46 +00:00
else /* Yap_ExecutionMode == COMPILED */
2015-09-25 10:57:26 +01:00
Yap_NilError(SYSTEM_ERROR_JIT_NOT_AVAILABLE, "just compiled");
2015-01-26 04:02:46 +00:00
}
#endif
c_args(t, 0, cglobs);
}
2016-10-20 04:44:59 +01:00
inline static bool 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 bccall_op:
return true;
default:
break;
}
#ifdef SFUNC
if (ic >= unify_s_var_op && ic <= write_s_val_op)
return true;
#endif
2016-10-20 04:44:59 +01:00
return ((ic >= unify_var_op && ic <= write_val_op) ||
(ic >= unify_last_var_op && ic <= unify_last_val_op));
}
2014-10-13 12:33:24 +01:00
/*
inline static bool
uses_this_var(PInstr *pc, Term arg)
{
compiler_vm_op ic = pc->op;
if (pc->rnd1 != arg)
return arg == pc->rnd3 && ic == bccall_op;
return usesvar( ic );
}
2014-10-13 12:33:24 +01:00
*/
2016-10-20 04:44:59 +01:00
inline static bool usesvar2(compiler_vm_op ic) { return ic == bccall_op; }
/*
* Do as in the traditional WAM and make sure voids are in
* environments
*/
#define LOCALISE_VOIDS 1
#ifdef LOCALISE_VOIDS
2016-10-20 04:44:59 +01:00
typedef struct env_tmp {
Ventry *Var;
struct env_tmp *Next;
2016-10-20 04:44:59 +01:00
} EnvTmp;
#endif
2016-10-20 04:44:59 +01:00
static void tag_use(Ventry *v USES_REGS) {
#ifdef BEAM
2016-10-20 04:44:59 +01:00
if (EAM) {
if (v->NoOfVE == Unassigned || v->KindOfVE != PermVar) {
v->NoOfVE = PermVar | (LOCAL_nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= PermFlag;
}
}
#endif
2016-10-20 04:44:59 +01:00
if (v->NoOfVE == Unassigned) {
if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE)) ||
v->KindOfVE == PermVar /*
* * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE &
2016-10-20 04:44:59 +01:00
* * OnHeadFlag))
*/) {
v->NoOfVE = PermVar | (LOCAL_nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= PermFlag;
} else {
v->NoOfVE = v->KindOfVE = TempVar;
}
}
}
2016-10-20 04:44:59 +01:00
static void AssignPerm(PInstr *pc, compiler_struct *cglobs) {
2012-02-07 15:18:43 +00:00
CACHE_REGS
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.
2016-10-20 04:44:59 +01:00
*
* 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) {
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
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)
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
Ventry *v = (Ventry *)(pc->rnd1);
2016-10-20 04:44:59 +01:00
tag_use(v PASS_REGS);
if (usesvar2(pc->op)) {
Ventry *v2 = (Ventry *)(pc->rnd3);
tag_use(v2 PASS_REGS);
}
} else if (pc->op == empty_call_op) {
pc->rnd2 = LOCAL_nperm;
2016-10-20 04:44:59 +01:00
} 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) {
2016-10-20 04:44:59 +01:00
Ventry *v = EnvTmps->Var;
v->NoOfVE = PermVar | (LOCAL_nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= (PermFlag | SafeVar);
EnvTmps = EnvTmps->Next;
}
#endif
pc->rnd2 = LOCAL_nperm;
2016-10-20 04:44:59 +01:00
} else if (pc->op == cut_op || pc->op == cutexit_op ||
pc->op == commit_b_op) {
pc->rnd2 = LOCAL_nperm;
}
opc = pc;
pc = npc;
} while (pc != NULL);
}
2016-10-20 04:44:59 +01:00
static CELL *init_bvarray(int nperm, compiler_struct *cglobs) {
CELL *vinfo = NULL;
2016-10-20 04:44:59 +01:00
size_t sz = sizeof(CELL) * (1 + nperm / (8 * sizeof(CELL)));
2010-05-11 00:18:12 +01:00
vinfo = (CELL *)Yap_AllocCMem(sz, &cglobs->cint);
memset((void *)vinfo, 0, sz);
return vinfo;
}
2016-10-20 04:44:59 +01:00
static void clear_bvarray(int var, CELL *bvarray
#ifdef DEBUG
2016-10-20 04:44:59 +01:00
,
compiler_struct *cglobs
#endif
2016-10-20 04:44:59 +01:00
) {
int max = 8 * sizeof(CELL);
CELL nbit;
/* get to the array position */
while (var >= max) {
bvarray++;
var -= max;
}
2015-11-05 15:12:29 +00:00
/* now put a 0 on it, from now on the variable is initialized */
2010-05-11 00:18:12 +01:00
nbit = ((CELL)1 << var);
#ifdef DEBUG
if (*bvarray & nbit) {
CACHE_REGS
/* someone had already marked this variable: complain */
2015-09-25 10:57:26 +01:00
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
2015-11-05 15:12:29 +00:00
LOCAL_ErrorMessage = "compiler internal error: variable initialized twice";
save_machine_regs();
2010-12-16 01:22:10 +00:00
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 */
2016-10-20 04:44:59 +01:00
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;
2016-10-20 04:44:59 +01:00
dest = Yap_emit_extra_size(mark_initialized_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;
2016-10-20 04:44:59 +01:00
} bventry;
#define MAX_DISJUNCTIONS 128
static bventry *bvstack;
static int bvindex = 0;
2016-10-20 04:44:59 +01:00
static void push_bvmap(int label, PInstr *pcpc, compiler_struct *cglobs) {
if (bvindex == MAX_DISJUNCTIONS) {
CACHE_REGS
2015-09-25 10:57:26 +01:00
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
LOCAL_ErrorMessage = "Too many embedded disjunctions";
save_machine_regs();
2010-12-16 01:22:10 +00:00
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++;
}
2016-10-20 04:44:59 +01:00
static void reset_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs) {
int size, size1, env_size, i;
CELL *source;
if (bvarray == NULL)
2016-10-20 04:44:59 +01:00
if (bvindex == 0) {
CACHE_REGS
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
LOCAL_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++;
2016-10-20 04:44:59 +01:00
for (i = size + 1; i <= size1; i++)
*bvarray++ = (CELL)(0);
}
2016-10-20 04:44:59 +01:00
static void pop_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs) {
if (bvindex == 0) {
CACHE_REGS
2015-09-25 10:57:26 +01:00
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
LOCAL_ErrorMessage = "Too few embedded disjunctions";
/* save_machine_regs();
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
static void CheckUnsafe(PInstr *pc, compiler_struct *cglobs) {
2012-02-07 15:18:43 +00:00
CACHE_REGS
int pending = 0;
2015-11-05 15:12:29 +00:00
/* say that all variables are yet to initialize */
CELL *vstat = init_bvarray(LOCAL_nperm, cglobs);
2016-10-20 04:44:59 +01:00
UnsafeEntry *UnsafeStack = (UnsafeEntry *)Yap_AllocCMem(
LOCAL_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;
2016-10-20 04:44:59 +01:00
cglobs->cint.CodeStart = cglobs->cint.BlobsStart;
cglobs->cint.cpc = cglobs->cint.icpc;
bvindex = 0;
2016-10-20 04:44:59 +01:00
bvstack = (bventry *)Yap_AllocCMem(MAX_DISJUNCTIONS * sizeof(bventry),
&cglobs->cint);
while (pc != NIL) {
2016-10-20 04:44:59 +01:00
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;
2016-10-20 04:44:59 +01:00
}
case bccall_op: {
Ventry *v = (Ventry *)(pc->rnd1), *v3 = (Ventry *)(pc->rnd3);
if ((v->FlagsOfVE & PermFlag && pc == v->FirstOpForV) ||
(v3->FlagsOfVE & PermFlag && pc == v3->FirstOpForV)) {
CACHE_REGS
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
LOCAL_ErrorMessage =
"comparison should not have first instance of variables";
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
}
} 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:
2016-10-20 04:44:59 +01:00
case f_var_op: {
Ventry *v = (Ventry *)(pc->rnd1);
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
,
cglobs
#endif
2016-10-20 04:44:59 +01:00
);
}
2016-10-20 04:44:59 +01:00
} 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, LOCAL_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, LOCAL_nperm, cglobs);
goto reset_safe_map;
break;
case empty_call_op:
/* just get ourselves a label describing how
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
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:
2016-10-20 04:44:59 +01:00
reset_safe_map : {
int n = pc->op == call_op ? pc->rnd2 : 0;
int no;
2016-10-20 04:44:59 +01:00
while (pending) {
Ventry *v = UnsafeStack[--pending].v;
2016-10-20 04:44:59 +01:00
v->FlagsOfVE &= ~SafeVar;
no = (v->NoOfVE) & MaskVarAdrs;
if (no >= n)
UnsafeStack[pending].p->op = put_unsafe_op;
}
2016-10-20 04:44:59 +01:00
}
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
2016-10-20 04:44:59 +01:00
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:
2016-10-20 04:44:59 +01:00
ve = ((Ventry *)cpc->rnd1);
if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1) {
2016-10-20 04:44:59 +01:00
ve->NoOfVE = ve->KindOfVE = VoidVar;
if (ic == get_var_op || ic == save_pair_op || ic == save_appl_op
#ifdef SFUNC
2016-10-20 04:44:59 +01:00
|| ic == unify_s_var_op
#endif
2016-10-20 04:44:59 +01:00
) {
cpc->op = nop_op;
break;
}
}
if (ic != get_var_op)
2016-10-20 04:44:59 +01:00
break;
case get_val_op:
case get_atom_op:
case get_num_op:
case get_float_op:
2010-02-03 18:52:10 +00:00
case get_dbterm_op:
case get_longint_op:
case get_string_op:
case get_bigint_op:
case get_list_op:
case get_struct_op:
cglobs->Uses[cpc->rnd2] = 1;
break;
case bccall_op:
cglobs->Uses[cpc->rnd2] = 1;
cglobs->Uses[cpc->rnd4] = 1;
default:
break;
}
cpc = cpc->nextInst;
}
}
2016-10-20 04:44:59 +01:00
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)
2016-10-20 04:44:59 +01:00
return 0;
if (vreg) {
--cglobs->Uses[vreg];
return 1;
}
/* follow the life of the variable */
q = cglobs->cint.cpc;
/*
2016-10-20 04:44:59 +01:00
* 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;
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
if (q->rnd2 <= 0)
; /* don't try to reuse REGISTER 0 */
else if ((usesvar(ic = q->op) && arg == q->rnd1) ||
2016-10-20 04:44:59 +01:00
(ic == bccall_op && arg == q->rnd3) /*uses_this_var(q, arg)*/) {
ic = q->op;
--n;
if (ic == put_val_op) {
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
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])
2016-10-20 04:44:59 +01:00
if ((target1 = target2) == cglobs->MaxCTemps || cglobs->Uses[target1] ||
Needed[target1]) {
target1 = cglobs->MaxCTemps;
do
2016-10-20 04:44:59 +01:00
--target1;
while (target1 && cglobs->Uses[target1] == 0 && Needed[target1] == 0);
++target1;
}
if (target1 == cglobs->MaxCTemps) {
CACHE_REGS
2015-09-25 10:57:26 +01:00
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
2016-10-20 04:44:59 +01:00
LOCAL_ErrorMessage = "too many temporaries";
save_machine_regs();
2010-12-16 01:22:10 +00:00
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;
/*
2016-10-20 04:44:59 +01:00
* 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;
}
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
++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 */
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
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);
2016-10-20 04:44:59 +01:00
CELL *ptr = dest;
*ptr = 0L;
2016-10-20 04:44:59 +01:00
for (i = 1; i <= max; i++) {
/* move to next cell */
2016-10-20 04:44:59 +01:00
if (i % (8 * CellSize) == 0) {
ptr++;
*ptr = 0L;
}
/* set the register live bit */
if (cglobs->Contents[i]) {
2016-10-20 04:44:59 +01:00
int j = i % (8 * CellSize);
*ptr |= (1 << j);
}
}
2016-10-20 04:44:59 +01:00
return ((CELL)dest);
}
2016-10-20 04:44:59 +01:00
static void c_layout(compiler_struct *cglobs) {
2012-02-07 15:18:43 +00:00
CACHE_REGS
PInstr *savepc = cglobs->BodyStart->nextInst;
register Ventry *v = cglobs->vtable;
Int *up = cglobs->Uses;
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) {
2016-10-20 04:44:59 +01:00
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
LOCAL_nperm = 0;
AssignPerm(cglobs->cint.CodeStart, cglobs);
#ifdef DEBUG
cglobs->pbvars = 0;
#endif
CheckUnsafe(cglobs->cint.CodeStart, cglobs);
#ifdef DEBUG
if (cglobs->pbvars != LOCAL_nperm) {
2016-10-20 04:44:59 +01:00
CACHE_REGS
LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
LOCAL_ErrorMessage = "wrong number of variables found in bitmap";
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
#endif
}
}
2016-10-20 04:44:59 +01:00
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)
2016-10-20 04:44:59 +01:00
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;
2011-04-29 14:59:17 +01:00
#else
case cut_op:
2016-10-20 04:44:59 +01:00
case cutexit_op: {
int i, max;
2011-04-29 14:59:17 +01:00
2016-10-20 04:44:59 +01:00
max = 0;
for (i = 1; i < cglobs->MaxCTemps; ++i) {
if (cglobs->Contents[i])
max = i;
2011-04-29 14:59:17 +01:00
}
2016-10-20 04:44:59 +01:00
cglobs->cint.cpc->ops.opseqt[1] = max;
} break;
#endif /* TABLING_INNER_CUTS */
case allocate_op:
case deallocate_op:
if (!cglobs->needs_env) {
2016-10-20 04:44:59 +01:00
cglobs->cint.cpc->op = nop_op;
} else {
#ifdef TABLING
2016-10-20 04:44:59 +01:00
PELOCK(51, cglobs->cint.CurrentPred);
if (is_tabled(cglobs->cint.CurrentPred))
cglobs->cint.cpc->op = nop_op;
else
#endif /* TABLING */
2016-10-20 04:44:59 +01:00
if (cglobs->goalno == 1 && !cglobs->or_found && LOCAL_nperm == 0)
cglobs->cint.cpc->op = nop_op;
#ifdef TABLING
2016-10-20 04:44:59 +01:00
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)
2016-10-20 04:44:59 +01:00
cglobs->cint.cpc->op = nop_op;
break;
case get_var_op:
--cglobs->Uses[rn];
if (checktemp(arg, rn, ic, cglobs)) {
#ifdef BEAM
2016-10-20 04:44:59 +01:00
if (cglobs->vreg == rn && !EAM)
#else
2016-10-20 04:44:59 +01:00
if (cglobs->vreg == rn)
#endif
2016-10-20 04:44:59 +01:00
cglobs->cint.cpc->op = nop_op;
}
if (!cglobs->Uses[rn])
2016-10-20 04:44:59 +01:00
cglobs->Contents[rn] = cglobs->vadr;
break;
case get_val_op:
--cglobs->Uses[rn];
checktemp(arg, rn, ic, cglobs);
if (!cglobs->Uses[rn])
2016-10-20 04:44:59 +01:00
cglobs->Contents[rn] = cglobs->vadr;
break;
case f_0_op:
2016-10-20 04:44:59 +01:00
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:
2016-10-20 04:44:59 +01:00
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
checktemp(arg, rn, ic, cglobs);
break;
case bccall_op:
checktemp(arg, rn, ic, cglobs);
checktemp(cglobs->cint.cpc->rnd3, cglobs->cint.cpc->rnd4, ic, cglobs);
break;
case get_atom_op:
case get_num_op:
case get_float_op:
case get_longint_op:
case get_string_op:
2010-02-03 18:52:10 +00:00
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
2016-10-20 04:44:59 +01:00
is something ahead.
*/
if (!cglobs->Uses[rn])
2016-10-20 04:44:59 +01:00
cglobs->Contents[rn] = arg;
break;
case get_list_op:
case get_struct_op:
--cglobs->Uses[rn];
if (!cglobs->Uses[rn])
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
{
cglobs->cint.cpc->op = nop_op;
}
cglobs->Contents[rn] = cglobs->vadr;
++cglobs->Uses[rn];
if (rn_kills) {
2016-10-20 04:44:59 +01:00
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:
2016-10-20 04:44:59 +01:00
rn_to_kill[1] = rn_to_kill[0] = 0;
if (cglobs->cint.cpc->nextInst &&
2016-10-20 04:44:59 +01:00
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
2016-10-20 04:44:59 +01:00
case write_s_var_op: {
Ventry *ve = (Ventry *)arg;
2016-10-20 04:44:59 +01:00
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_string_op:
2010-02-03 18:52:10 +00:00
case put_dbterm_op:
case put_bigint_op:
rn = checkreg(arg, rn, ic, FALSE, cglobs);
if (cglobs->Contents[rn] == arg)
2016-10-20 04:44:59 +01:00
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:
2016-10-20 04:44:59 +01:00
case patch_b_op:
case save_appl_op:
case save_pair_op:
checktemp(arg, rn, ic, cglobs);
break;
case safe_call_op:
/*
2016-10-20 04:44:59 +01:00
vsc: The variables will be in use after this!!!!
{
UInt Arity = RepPredProp((Prop) arg)->ArityOfPE;
for (rn = 1; rn <= Arity; ++rn)
--cglobs->Uses[rn];
}
*/
break;
case call_op:
case orelse_op:
2016-10-20 04:44:59 +01:00
case orlast_op: {
up = cglobs->Uses;
cop = cglobs->Contents;
for (rn = 1; rn < cglobs->MaxCTemps; ++rn) {
*up++ = *cop++ = NIL;
}
2016-10-20 04:44:59 +01:00
} 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++;
}
}
2016-10-20 04:44:59 +01:00
} break;
case restore_tmps_and_skip_op:
case restore_tmps_op:
/*
2016-10-20 04:44:59 +01:00
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.
*/
{
2016-10-20 04:44:59 +01:00
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;
2016-10-20 04:44:59 +01:00
else
return;
}
}
2016-10-20 04:44:59 +01:00
static void push_allocate(PInstr *pc, PInstr *oldpc) {
/*
The idea is to push an allocate forward as much as we can. This
2016-10-20 04:44:59 +01:00
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;
2016-10-20 04:44:59 +01:00
while (pc) {
switch (pc->op) {
case jump_op:
return;
case call_op:
case safe_call_op:
if (!safe)
2016-10-20 04:44:59 +01:00
return;
else {
2016-10-20 04:44:59 +01:00
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:
2016-10-20 04:44:59 +01:00
/* 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)
2016-10-20 04:44:59 +01:00
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)
2016-10-20 04:44:59 +01:00
return;
default:
break;
}
oldpc = pc;
pc = pc->nextInst;
}
}
2016-10-20 04:44:59 +01:00
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) {
2016-10-20 04:44:59 +01:00
npc->rnd1 = pc->rnd1;
npc->op = f_var_op;
pc->op = nop_op;
break;
}
case put_val_op:
2016-10-20 04:44:59 +01:00
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;
}
}
2016-10-20 04:44:59 +01:00
}
onTail = 1;
break;
2016-10-20 04:44:59 +01:00
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;
}
2016-10-20 04:44:59 +01:00
} 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 */
2016-10-20 04:44:59 +01:00
v = (Ventry *)(pc->rnd1);
if (v->KindOfVE == VoidVar && onTail) {
2015-11-05 15:12:29 +00:00
pc->op = nop_op;
2016-10-20 04:44:59 +01:00
} else
#endif /* OLD_SYSTEM */
onTail = 0;
break;
case unify_val_op:
2016-10-20 04:44:59 +01:00
v = (Ventry *)(pc->rnd1);
if (!(v->FlagsOfVE & GlobalVal))
2016-10-20 04:44:59 +01:00
pc->op = unify_local_op;
onTail = 0;
break;
case unify_last_val_op:
2016-10-20 04:44:59 +01:00
v = (Ventry *)(pc->rnd1);
if (!(v->FlagsOfVE & GlobalVal))
2016-10-20 04:44:59 +01:00
pc->op = unify_last_local_op;
onTail = 0;
break;
case write_val_op:
2016-10-20 04:44:59 +01:00
v = (Ventry *)(pc->rnd1);
if (!(v->FlagsOfVE & GlobalVal))
2016-10-20 04:44:59 +01:00
pc->op = write_local_op;
onTail = 0;
break;
case pop_op:
if (FALSE && onTail == 1) {
2016-10-20 04:44:59 +01:00
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_string_op:
case unify_bigint_op:
case unify_last_longint_op:
case unify_last_string_op:
case unify_last_bigint_op:
case write_longint_op:
case write_string_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;
2016-10-20 04:44:59 +01:00
}
opc = pc;
pc = pc->nextInst;
}
}
2016-10-20 04:44:59 +01:00
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 */
CACHE_REGS
/* 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 */
2016-10-20 04:44:59 +01:00
/* first, initialize cglobs->cint.CompilerBotch to handle all cases of
* interruptions */
compiler_struct cglobs;
2016-10-20 04:44:59 +01:00
#ifdef TABLING_INNER_CUTS
PInstr cglobs_cut_mark;
cglobs.cut_mark = &cglobs_cut_mark;
2016-10-20 04:44:59 +01:00
#endif /* TABLING_INNER_CUTS */
/* make sure we know there was no error yet */
LOCAL_ErrorMessage = NULL;
2010-12-16 01:22:10 +00:00
if ((botch_why = sigsetjmp(cglobs.cint.CompilerBotch, 0))) {
restore_machine_regs();
reset_vars(cglobs.vtable);
Yap_ReleaseCMem(&cglobs.cint);
2016-10-20 04:44:59 +01:00
switch (botch_why) {
case OUT_OF_STACK_BOTCH:
/* out of local stack, just duplicate the stack */
{
2016-10-20 04:44:59 +01:00
Int osize = 2 * sizeof(CELL) * (ASP - HR);
ARG1 = inp_clause;
ARG3 = src;
YAPLeaveCriticalSection();
if (!Yap_gcl(LOCAL_Error_Size, NOfArgs, ENV, gc_P(P, CP))) {
LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
}
if (osize > ASP - HR) {
if (!Yap_growstack(2 * sizeof(CELL) * (ASP - HR))) {
LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
}
}
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(LOCAL_Error_Size, NULL, TRUE)) {
2016-10-20 04:44:59 +01:00
LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
}
YAPEnterCriticalSection();
src = ARG3;
inp_clause = ARG1;
break;
case OUT_OF_TEMPS_BOTCH:
/* out of temporary cells */
2016-10-20 04:44:59 +01:00
if (maxvnum < 16 * 1024) {
maxvnum *= 2;
} else {
2016-10-20 04:44:59 +01:00
maxvnum += 4096;
}
break;
case OUT_OF_HEAP_BOTCH:
/* not enough heap */
ARG1 = inp_clause;
ARG3 = src;
YAPLeaveCriticalSection();
if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) {
2016-10-20 04:44:59 +01:00
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
return NULL;
}
YAPEnterCriticalSection();
src = ARG3;
inp_clause = ARG1;
break;
case OUT_OF_TRAIL_BOTCH:
/* not enough trail */
ARG1 = inp_clause;
ARG3 = src;
YAPLeaveCriticalSection();
2016-10-20 04:44:59 +01:00
if (!Yap_growtrail(LOCAL_TrailTop - (ADDR)TR, FALSE)) {
LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
return NULL;
}
YAPEnterCriticalSection();
src = ARG3;
inp_clause = ARG1;
break;
default:
return NULL;
}
}
my_clause = inp_clause;
2014-01-19 21:15:05 +00:00
HB = HR;
LOCAL_ErrorMessage = NULL;
LOCAL_Error_Size = 0;
LOCAL_Error_TYPE = YAP_NO_ERROR;
/* initialize variables for code generation */
2016-10-20 04:44:59 +01:00
cglobs.cint.CodeStart = cglobs.cint.cpc = NULL;
cglobs.cint.BlobsStart = cglobs.cint.icpc = NULL;
cglobs.cint.dbterml = NULL;
cglobs.cint.blks = NULL;
2010-04-15 22:49:25 +01:00
cglobs.cint.label_offset = NULL;
2016-10-20 04:44:59 +01:00
cglobs.cint.freep = cglobs.cint.freep0 =
(char *)(HR + maxvnum + (sizeof(Int) / sizeof(CELL)) * MaxTemps +
MaxTemps);
2009-07-15 20:27:56 +01:00
cglobs.cint.success_handler = 0L;
2016-10-20 04:44:59 +01:00
if (ASP <= CellPtr(cglobs.cint.freep) + 256) {
cglobs.vtable = NULL;
2016-10-20 04:44:59 +01:00
LOCAL_Error_Size = (256 + maxvnum) * sizeof(CELL);
save_machine_regs();
2016-10-20 04:44:59 +01:00
siglongjmp(cglobs.cint.CompilerBotch, 3);
}
2016-10-20 04:44:59 +01:00
cglobs.Uses = (Int *)(HR + maxvnum);
cglobs.Contents =
(Term *)(HR + 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
2016-10-20 04:44:59 +01:00
* 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)) {
LOCAL_Error_TYPE = INSTANTIATION_ERROR;
LOCAL_ErrorMessage = "in compiling clause";
return 0;
}
if (IsApplTerm(my_clause) && FunctorOfTerm(my_clause) == FunctorAssert) {
head = ArgOfTerm(1, my_clause);
body = ArgOfTerm(2, my_clause);
2016-10-20 04:44:59 +01:00
} else {
head = my_clause, body = MkAtomTerm(AtomTrue);
}
2016-10-20 04:44:59 +01:00
if (IsVarTerm(head) || IsPairTerm(head) || IsIntTerm(head) ||
IsFloatTerm(head) || IsRefTerm(head)) {
LOCAL_Error_TYPE = TYPE_ERROR_CALLABLE;
2014-10-20 09:20:56 +01:00
LOCAL_ErrorMessage = "clause head should be atom or compound term";
return (0);
} else {
2018-01-22 13:53:17 +00:00
loop:
/* find out which predicate we are compiling for */
if (IsAtomTerm(head)) {
Atom ap = AtomOfTerm(head);
cglobs.cint.CurrentPred = RepPredProp(PredPropByAtom(ap, mod));
} else {
2018-01-22 13:53:17 +00:00
Functor f = FunctorOfTerm(head);
if (f == FunctorModule) {
mod = ArgOfTerm(1,head);
head = ArgOfTerm(2,head);
goto loop;
}
2016-10-20 04:44:59 +01:00
cglobs.cint.CurrentPred =
2018-01-22 13:53:17 +00:00
RepPredProp(PredPropByFunc(f, mod));
}
/* insert extra instructions to count calls */
2016-10-20 04:44:59 +01:00
PELOCK(52, cglobs.cint.CurrentPred);
if ((cglobs.cint.CurrentPred->PredFlags & ProfiledPredFlag) ||
2016-10-20 04:44:59 +01:00
(PROFILING &&
(cglobs.cint.CurrentPred->cs.p_code.FirstClause == NIL))) {
profiling = TRUE;
call_counting = FALSE;
} else if ((cglobs.cint.CurrentPred->PredFlags & CountPredFlag) ||
2016-10-20 04:44:59 +01:00
(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
2016-10-20 04:44:59 +01:00
PELOCK(53, cglobs.cint.CurrentPred);
if (is_tabled(cglobs.cint.CurrentPred))
2016-10-20 04:44:59 +01:00
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 (LOCAL_ErrorMessage)
return (0);
2013-01-15 22:58:34 +00:00
/* make sure we give enough space for the fact */
if (cglobs.space_op)
cglobs.space_op->rnd1 = cglobs.space_used;
#ifdef DEBUG
if (GLOBAL_Option['g' - 96])
Yap_ShowCode(&cglobs.cint);
#endif
} else {
#ifdef TABLING_INNER_CUTS
Yap_emit(nop_op, Zero, Zero, &cglobs.cint);
2011-04-29 14:59:17 +01:00
cglobs.cut_mark->op = clause_with_cut_op;
#endif /* TABLING_INNER_CUTS */
Yap_emit(allocate_op, Zero, Zero, &cglobs.cint);
#ifdef BEAM
2016-10-20 04:44:59 +01:00
if (EAM)
Yap_emit(body_op, Zero, Zero, &cglobs.cint);
#endif
c_body(body, mod, &cglobs);
2016-10-20 04:44:59 +01:00
/* 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);
2014-01-19 21:15:05 +00:00
HR = HB;
if (B != NULL) {
HB = B->cp_h;
}
if (LOCAL_ErrorMessage)
return (0);
#ifdef DEBUG
if (GLOBAL_Option['g' - 96])
Yap_ShowCode(&cglobs.cint);
#endif
/* phase 2: classify variables and optimize temporaries */
c_layout(&cglobs);
2016-10-20 04:44:59 +01:00
/* 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)
2016-10-20 04:44:59 +01:00
cglobs.cint.cpc = cglobs.cint.cpc->nextInst;
}
}
/* eliminate superfluous pop's and unify_var's */
c_optimize(cglobs.cint.CodeStart);
#ifdef DEBUG
if (GLOBAL_Option['f' - 96])
Yap_ShowCode(&cglobs.cint);
#endif
#ifdef BEAM
2016-10-20 04:44:59 +01:00
{
void codigo_eam(compiler_struct *);
if (EAM)
codigo_eam(&cglobs);
}
#endif
/* phase 3: assemble code */
2016-10-20 04:44:59 +01:00
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 */
2016-10-20 04:44:59 +01:00
Yap_ReleaseCMem(&cglobs.cint);
if (acode == NULL) {
return NULL;
} else {
2012-03-09 11:46:34 +00:00
return acode;
}
}
#ifdef BEAM
2016-10-20 04:44:59 +01:00
#include "toeam.c"
#endif