diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
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.
d7109e6974
yap-6.3/C/compiler.c
vsc 6ca40989fa disallow indexing on floats and friends. 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@234 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2001-12-17 23:31:38 +00:00

2882 lines
68 KiB
C
Raw Blame 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 *
* Last rev: 4/03/88 *
* mods: *
* comments: Clause compiler *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif /* SCCS */
#include "Yap.h"
#include "compile.h"
#include "clause.h"
#include "yapio.h"
#if HAVE_STRING_H
#include <string.h>
#endif
STATIC_PROTO(int active_branch, (int));
STATIC_PROTO(void c_var, (Term, Int, unsigned int));
STATIC_PROTO(void reset_vars, (void));
STATIC_PROTO(Term optimize_ce, (Term, unsigned int));
STATIC_PROTO(void c_arg, (Int, Term, unsigned int));
STATIC_PROTO(void c_args, (Term));
STATIC_PROTO(void c_eq, (Term, Term));
STATIC_PROTO(void c_test, (Int, Term));
STATIC_PROTO(void c_bifun, (Int, Term, Term, Term, int));
STATIC_PROTO(void c_goal, (Term, int));
STATIC_PROTO(void get_type_info, (Term));
STATIC_PROTO(void c_body, (Term, int));
STATIC_PROTO(void get_cl_info, (Term));
STATIC_PROTO(void c_head, (Term));
STATIC_PROTO(int usesvar, (int));
STATIC_PROTO(CELL *init_bvarray, (int));
STATIC_PROTO(void clear_bvarray, (int, CELL *));
STATIC_PROTO(void add_bvarray_op, (PInstr *,CELL *, int));
STATIC_PROTO(void AssignPerm, (PInstr *));
STATIC_PROTO(void CheckUnsafe, (PInstr *));
STATIC_PROTO(void CheckVoids, (void));
STATIC_PROTO(int checktemp, (void));
STATIC_PROTO(void checkreg, (int));
STATIC_PROTO(void c_layout, (void));
STATIC_PROTO(void c_optimize, (PInstr *));
#ifdef SFUNC
STATIC_PROTO(void compile_sf_term, (Term, int));
#endif
PInstr *CodeStart, *cpc, *BodyStart;
PInstr *icpc, *BlobsStart;
int c_mask;
CELL c_store;
PredEntry *pred_p;
PredEntry *CurrentPred;
static Ventry *vtable;
CExpEntry *common_exps;
int n_common_exps, profiling;
static int goalno, level, onlast, onhead, onbranch, cur_branch;
typedef struct branch_descriptor {
int id; /* the branch id */
Term cm; /* if a banch is associated with a commit */
} branch;
static branch parent_branches[256], *branch_pointer;
static Prop current_p0;
static void
push_branch(int id, Term cmvar) {
branch_pointer->id = onbranch;
branch_pointer->cm = cmvar;
branch_pointer++;
}
static int
pop_branch(void) {
branch_pointer--;
return(branch_pointer->id);
}
#ifdef TABLING
#define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
#endif /* TABLING */
#ifdef DEBUG
static int pbvars;
#endif /* DEBUG */
static inline int
active_branch(int i)
{
/* register int *bp;*/
return (i == onbranch);
/* bp = branch_pointer;
while (bp > parent_branches) {
if (*--bp == onbranch)
return (TRUE);
}
return(i==onbranch);*/
}
static Int labelno;
static int or_found;
static Int rn, ic, vreg, vadr;
static Term arg;
static Int Uses[MaxTemps];
static Term Contents[MaxTemps];
static Int tmpreg;
static int nvars, MaxCTemps;
static unsigned int max_args;
jmp_buf CompilerBotch;
#define FAIL(M,T,E) { ErrorMessage=M; Error_TYPE = T; Error_Term = E; return; }
#define IsNewVar(v) (Addr(v)<freep0 || Addr(v)>freep)
static char ErrorSay[80];
inline static void pop_code(void);
inline static void
pop_code(void)
{
if (level == 0)
return;
if (cpc->op == pop_op)
++(cpc->rnd1);
else
emit(pop_op, One, Zero);
}
static void
adjust_current_commits(void) {
branch *bp = branch_pointer;
while (bp > parent_branches) {
bp--;
if (bp->cm != TermNil) {
c_var(bp->cm, patch_b_flag, 1);
}
}
}
static void
c_var(Term t, Int argno, unsigned int arity)
{
int flags, new = FALSE;
Ventry *v = (Ventry *) Deref(t);
if (IsNewVar(v)) { /* new var */
v = (Ventry *) AllocCMem(sizeof(*v));
#if SBA
v->SelfOfVE = 0;
#else
v->SelfOfVE = (CELL) v;
#endif
v->AdrsOfVE = t;
*CellPtr(t) = (CELL) v;
v->KindOfVE = v->NoOfVE = Unassigned;
flags = 0;
/* Be careful with eithers. I may make a variable global in a branch,
and not in another.
a :- (b([X]) ; c), go(X).
This variaiable will not be globalised if we are coming from
the second branch.
I also need to protect the onhead because Luis uses that to
optimise unification in the body of a clause, eg
a :- (X = 2 ; c), go(X).
And, yes, there is code like this...
*/
if (((level > 0 || onhead) && cur_branch == 0)
|| argno == save_pair_flag ||
argno == save_appl_flag)
flags |= SafeVar;
if ((level > 0 && cur_branch == 0) || argno == save_pair_flag ||
argno == save_appl_flag)
flags |= GlobalVal;
v->FlagsOfVE = flags;
v->BranchOfVE = onbranch;
v->NextOfVE = vtable;
v->RCountOfVE = 0;
v->AgeOfVE = v->FirstOfVE = goalno;
new = TRUE;
vtable = v;
} else {
v->FlagsOfVE |= NonVoid;
if (v->BranchOfVE > 0) {
if (!active_branch(v->BranchOfVE)) {
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 (onhead)
v->FlagsOfVE |= OnHeadFlag;
switch (argno) {
case save_b_flag:
emit(save_b_op, (CELL) v, Zero);
break;
case comit_b_flag:
emit(comit_b_op, (CELL) v, Zero);
emit(empty_call_op, Zero, Zero);
emit(restore_tmps_and_skip_op, Zero, Zero);
break;
case patch_b_flag:
emit(patch_b_op, (CELL) v, 0);
break;
case save_pair_flag:
emit(save_pair_op, (CELL) v, 0);
break;
case save_appl_flag:
emit(save_appl_op, (CELL) v, 0);
break;
case f_flag:
if (new) {
++nvars;
emit(f_var_op, (CELL) v, (CELL)arity);
} else
emit(f_val_op, (CELL) v, (CELL)arity);
break;
case bt1_flag:
emit(fetch_args_for_bccall, (CELL)v, 0);
break;
case bt2_flag:
emit(bccall_op, (CELL)v, (CELL)current_p0);
break;
default:
#ifdef SFUNC
if (argno < 0) {
if (new)
emit((onhead ? unify_s_var_op : write_s_var_op), v, -argno);
else
emit((onhead ? unify_s_val_op : write_s_val_op), v, -argno);
} else
#endif
if (onhead) {
if (level == 0)
emit((new ? (++nvars, get_var_op) : get_val_op), (CELL) v, argno);
else
emit((new ? (++nvars, (argno == (Int)arity ?
unify_last_var_op :
unify_var_op)) :
(argno == (Int)arity ? unify_last_val_op :
unify_val_op)),
(CELL) v, Zero);
}
else {
if (level == 0)
emit((new ? (++nvars, put_var_op) : put_val_op), (CELL) v, argno);
else
emit((new ? (++nvars, write_var_op) : write_val_op), (CELL) v, Zero);
}
}
if (new) {
v->FirstOpForV = cpc;
}
++(v->RCountOfVE);
if (onlast)
v->FlagsOfVE |= OnLastGoal;
if (v->AgeOfVE < goalno)
v->AgeOfVE = goalno;
}
static void
reset_vars(void)
{
Ventry *v = vtable;
CELL *t;
while (v != NIL) {
t = (CELL *) v->AdrsOfVE;
RESET_VARIABLE(t);
v = v->NextOfVE;
}
}
static Term
optimize_ce(Term t, unsigned int arity)
{
CExpEntry *p = common_exps, *parent = common_exps;
int cmp = 0;
if (IsApplTerm(t) && IsExtensionFunctor(FunctorOfTerm(t)))
return (t);
while (p != NULL) {
CELL *OldH = H;
H = (CELL *)freep;
cmp = compare_terms(t, (p->TermOfCE));
H = OldH;
if (cmp > 0) {
parent = p;
p = p->RightCE;
}
else if (cmp < 0) {
parent = p;
p = p->LeftCE;
}
else
break;
}
if (p != NULL) { /* already there */
return (p->VarOfCE);
}
/* first occurrence */
if (onbranch)
return (t);
++n_common_exps;
p = (CExpEntry *) AllocCMem(sizeof(CExpEntry));
p->TermOfCE = t;
p->VarOfCE = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
p->RightCE = NULL;
p->LeftCE = NULL;
if (parent == NULL)
common_exps = p;
else if (cmp > 0)
parent->RightCE = p;
else /* if (cmp < 0) */
parent->LeftCE = p;
if (IsApplTerm(t))
c_var(p->VarOfCE, save_appl_flag, arity);
else if (IsPairTerm(t))
c_var(p->VarOfCE, save_pair_flag, arity);
return (t);
}
#ifdef SFUNC
static void
compile_sf_term(Term t, int argno)
{
Functor f = FunctorOfTerm(t);
CELL *p = ArgsOfSFTerm(t) - 1;
SFEntry *pe = RepSFProp(GetAProp(NameOfFunctor(f), SFProperty));
Term nullvalue = pe->NilValue;
if (level == 0)
emit((onhead ? get_s_f_op : put_s_f_op), f, argno);
else
emit((onhead ? unify_s_f_op : write_s_f_op), f, Zero);
++level;
while ((argno = *++p)) {
t = Derefa(++p);
if (t != nullvalue) {
if (IsAtomicTerm(t))
emit((onhead ? unify_s_a_op : write_s_a_op), t, (CELL) argno);
else if (!IsVarTerm(t)) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "illegal argument of soft functor";
save_machine_regs();
longjmp(CompilerBotch, 2);
}
else
c_var(t, -argno, arity);
}
}
--level;
if (level == 0)
emit((onhead ? get_s_end_op : put_s_end_op), Zero, Zero);
else
emit((onhead ? unify_s_end_op : write_s_end_op), Zero, Zero);
}
#endif
inline static void
c_args(Term app)
{
Functor f = FunctorOfTerm(app);
unsigned int Arity = ArityOfFunctor(f);
unsigned int i;
if (level == 0) {
if (Arity >= MaxTemps) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "exceed maximum arity of compiled goal";
save_machine_regs();
longjmp(CompilerBotch, 2);
}
if (Arity > max_args)
max_args = Arity;
}
for (i = 1; i <= Arity; ++i)
c_arg(i, ArgOfTerm(i, app), Arity);
}
static void
c_arg(Int argno, Term t, unsigned int arity)
{
if (IsVarTerm(t))
c_var(t, argno, arity);
else if (IsAtomTerm(t)) {
if (level == 0)
emit((onhead ? get_atom_op : put_atom_op), (CELL) t, argno);
else
emit((onhead ? (argno == (Int)arity ? unify_last_atom_op
: unify_atom_op) :
write_atom_op), (CELL) t, Zero);
}
else if (IsIntegerTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t)) {
if (!IsIntTerm(t)) {
/* 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 = ++labelno;
CELL *src = RepAppl(t);
PInstr *ocpc = cpc, *OCodeStart = CodeStart;
/* use a special list to store the blobs */
cpc = icpc;
emit(label_op, l1, Zero);
if (IsFloatTerm(t)) {
/* let us do floats first */
CELL *dest =
emit_extra_size(blob_op,
(CELL)(SIZEOF_DOUBLE/SIZEOF_LONG_INT+1),
(1+SIZEOF_DOUBLE/SIZEOF_LONG_INT)*CellSize);
/* copy the float bit by bit */
dest[0] = src[0];
dest[1] = src[1];
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
dest[2] = src[2];
#endif
/* note that we don't need to copy size info, unless we wanted
to garbage collect clauses ;-) */
icpc = cpc;
if (BlobsStart == NULL)
BlobsStart = CodeStart;
cpc = ocpc;
CodeStart = OCodeStart;
/* The argument to pass to the structure is now the label for
where we are storing the blob */
if (level == 0)
emit((onhead ? get_float_op : put_float_op), l1, argno);
else
emit((onhead ? (argno == (Int)arity ? unify_last_float_op
: unify_float_op) :
write_float_op), l1, Zero);
#if USE_GMP
} else if (IsBigIntTerm(t)) {
/* next, let us do bigints */
Int sz = sizeof(CELL)+
sizeof(MP_INT)+
((((MP_INT *)(RepAppl(t)+1))->_mp_alloc)*sizeof(mp_limb_t));
CELL *dest =
emit_extra_size(blob_op, sz/CellSize, sz);
/* copy the bignum */
memcpy(dest, src, sz);
/* note that we don't need to copy size info, unless we wanted
to garbage collect clauses ;-) */
icpc = cpc;
if (BlobsStart == NULL)
BlobsStart = CodeStart;
cpc = ocpc;
CodeStart = OCodeStart;
/* The argument to pass to the structure is now the label for
where we are storing the blob */
if (level == 0)
emit((onhead ? get_bigint_op : put_bigint_op), l1, argno);
else
emit((onhead ? (argno == (Int)arity ? unify_last_bigint_op
: unify_bigint_op) :
write_bigint_op), l1, Zero);
#endif
} else {
/* for now, it's just a long int */
CELL *dest =
emit_extra_size(blob_op,
2,
2*CellSize);
/* copy the long int in one fell swoop */
dest[0] = src[0];
dest[1] = src[1];
icpc = cpc;
if (BlobsStart == NULL)
BlobsStart = CodeStart;
cpc = ocpc;
CodeStart = OCodeStart;
if (level == 0)
emit((onhead ? get_longint_op : put_longint_op), l1, argno);
else
emit((onhead ? (argno == (Int)arity ? unify_last_longint_op
: unify_longint_op) :
write_longint_op), l1, Zero);
}
/* That's it folks! */
return;
}
if (level == 0)
emit((onhead ? get_num_op : put_num_op), (CELL) t, argno);
else
emit((onhead ? (argno == (Int)arity ? unify_last_num_op
: unify_num_op) :
write_num_op), (CELL) t, Zero);
}
else if (IsPairTerm(t)) {
if (optimizer_on && (!onhead || argno != 1 || level > 1) && level < 6) {
t = optimize_ce(t, arity);
if (IsVarTerm(t)) {
c_var(t, argno, arity);
return;
}
}
if (level == 0)
emit((onhead ? get_list_op : put_list_op), Zero, argno);
else if (argno == (Int)arity)
emit((onhead ? unify_last_list_op : write_last_list_op), Zero, Zero);
else
emit((onhead ? unify_list_op : write_list_op), Zero, Zero);
++level;
c_arg(1, HeadOfTerm(t), 2);
c_arg(2, TailOfTerm(t), 2);
--level;
if (argno != (Int)arity)
pop_code();
} else if (IsRefTerm(t)) {
READ_LOCK(CurrentPred->PRWLock);
if (!(CurrentPred->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
READ_UNLOCK(CurrentPred->PRWLock);
FAIL("can not compile data base reference",TYPE_ERROR_CALLABLE,t);
return;
} else {
emit((onhead ? get_atom_op : put_atom_op), (CELL) t, argno);
}
} else {
#ifdef SFUNC
if (SFTerm(t)) {
compile_sf_term(t, argno);
return;
}
#endif
if (optimizer_on && (!onhead || argno != 1 || level > 1)) {
t = optimize_ce(t, arity);
if (IsVarTerm(t)) {
c_var(t, argno, arity);
return;
}
}
if (level == 0)
emit((onhead ? get_struct_op : put_struct_op),
(CELL) FunctorOfTerm(t), argno);
else if (argno == (Int)arity)
emit((onhead ? unify_last_struct_op : write_last_struct_op),
(CELL) FunctorOfTerm(t), Zero);
else
emit((onhead ? unify_struct_op : write_struct_op),
(CELL) FunctorOfTerm(t), Zero);
++level;
c_args(t);
--level;
if (argno != (Int)arity)
pop_code();
}
}
static void
c_eq(Term t1, Term t2)
{
Term t;
--tmpreg;
if (IsVarTerm(t2))
t = t2, t2 = t1, t1 = t;
if (IsVarTerm(t1)) {
if (IsVarTerm(t2)) { /* both are variables */
if (IsNewVar(t2))
t = t2, t2 = t1, t1 = t;
c_var(t2, tmpreg, 2);
onhead = 1;
c_var(t1, tmpreg, 2);
onhead = 0;
}
else if (IsNewVar(t1)) {
c_arg(tmpreg, t2, 0);
onhead = 1;
c_var(t1, tmpreg, 2);
onhead = 0;
}
else { /* t2 is non var */
c_var(t1, tmpreg, 2);
onhead = 1;
c_arg(tmpreg, t2, 0);
onhead = 0;
}
}
else {
c_arg(tmpreg, t1, 0);
onhead = 1;
c_arg(tmpreg, t2, 0);
onhead = 0;
}
}
static void
c_test(Int Op, Term t1) {
Term t = Deref(t1);
if (!IsVarTerm(t)) {
char s[32];
Error_TYPE = TYPE_ERROR_VARIABLE;
Error_Term = t;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "when compiling %s/1", s);
save_machine_regs();
longjmp(CompilerBotch, 1);
}
if (IsNewVar(t)) {
/* in this case, var trivially succeeds and the others trivially fail */
if (Op != _var)
emit(fail_op, Zero, Zero);
} else {
c_var(t,f_flag,(unsigned int)Op);
}
}
/* Arithmetic builtins will be compiled in the form:
fetch_args_vv Xi,Xj
put_val Xi,Ri
put_val Xj,Rj
put_var Xk,Ak
bip_body Op,Xk
The put_var should always be disposable, and the put_vals can be disposed of if R is an X.
This, in the best case, Ri and Rj are WAM temp registers and this will reduce to:
bip Op,Ak,Ri,Rj
meaning a single WAM op will call the clause.
If one of the arguments is a constant, the result will be:
fetch_args_vc Xi,C
put_val Xi,Ri
put_var Xk,Ak
bip_body Op,Xk
and this should reduce to :
bip_cons Op,Xk,Ri,C
*/
static void
c_bifun(Int Op, Term t1, Term t2, Term t3, int mod)
{
/* compile Z = X Op Y arithmetic function */
/* first we fetch the arguments */
if (IsVarTerm(t1)) {
if (IsNewVar(t1)) {
char s[32];
Error_TYPE = INSTANTIATION_ERROR;
Error_Term = t1;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "when compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch, 1);
} else if (IsVarTerm(t2)) {
if (IsNewVar(t2)) {
char s[32];
Error_TYPE = INSTANTIATION_ERROR;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "when compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch, 1);
} else {
/* first temp */
Int v1 = --tmpreg;
/* second temp */
Int v2 = --tmpreg;
emit(fetch_args_vv_op, Zero, Zero);
/* these should be the arguments */
c_var(t1, v1, 0);
c_var(t2, v2, 0);
/* now we know where the arguments are */
}
} else {
if (Op == _arg) {
Term tn = MkVarTerm();
Int v1 = --tmpreg;
Int v2 = --tmpreg;
c_arg(t2, v2, 0);
emit(fetch_args_vv_op, Zero, Zero);
/* these should be the arguments */
c_var(t1, v1, 0);
c_var(tn, v2, 0);
/* it has to be either an integer or a floating point */
} else if (IsIntTerm(t2)) {
/* first temp */
Int v1 = --tmpreg;
emit(fetch_args_vc_op, (CELL)IntOfTerm(t2), Zero);
/* these should be the arguments */
c_var(t1, v1, 0);
/* now we know where the arguments are */
} else if (IsLongIntTerm(t2)) {
/* first temp */
Int v1 = --tmpreg;
emit(fetch_args_vc_op, (CELL)LongIntOfTerm(t2), Zero);
/* these should be the arguments */
c_var(t1, v1, 0);
/* now we know where the arguments are */
} else {
char s[32];
Error_TYPE = TYPE_ERROR_NUMBER;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2 with output bound", s);
save_machine_regs();
longjmp(CompilerBotch,1);
}
}
} else { /* t1 is bound */
/* it has to be either an integer or a floating point */
if (IsVarTerm(t2)) {
if (IsNewVar(t2)) {
char s[32];
Error_TYPE = INSTANTIATION_ERROR;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling functor/3");
save_machine_regs();
longjmp(CompilerBotch,1);
}
} else {
if (Op == _functor) {
/* both arguments are bound, we must perform unification */
Int i2;
if (!IsIntegerTerm(t2)) {
char s[32];
Error_TYPE = TYPE_ERROR_INTEGER;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling functor/3");
save_machine_regs();
longjmp(CompilerBotch,1);
}
i2 = IntegerOfTerm(t2);
if (i2 < 0) {
char s[32];
Error_TYPE = DOMAIN_ERROR_NOT_LESS_THAN_ZERO;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling functor/3");
save_machine_regs();
longjmp(CompilerBotch,1);
}
if (IsNumTerm(t1)) {
/* we will always fail */
if (i2)
c_goal(MkAtomTerm(AtomFalse), mod);
} else if (!IsAtomTerm(t1)) {
char s[32];
Error_TYPE = TYPE_ERROR_ATOM;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling functor/3");
save_machine_regs();
longjmp(CompilerBotch,1);
}
if (i2 == 0)
c_eq(t1, t3);
else {
CELL *hi = H;
Int i;
if (t1 == TermDot && i2 == 2) {
if (H+2 >= (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
RESET_VARIABLE(H);
RESET_VARIABLE(H+1);
H += 2;
c_eq(AbsPair(H-2),t3);
} else {
*H++ = (CELL)MkFunctor(AtomOfTerm(t1),i2);
for (i=0; i < i2; i++) {
if (H >= (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
RESET_VARIABLE(H);
H++;
}
c_eq(AbsAppl(hi),t3);
}
}
} else if (Op == _arg) {
Int i1;
if (IsIntegerTerm(t1))
i1 = IntegerOfTerm(t1);
else {
char s[32];
Error_TYPE = TYPE_ERROR_INTEGER;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch,1);
}
if (IsAtomicTerm(t2) ||
(IsApplTerm(t2) && IsExtensionFunctor(FunctorOfTerm(t2)))) {
char s[32];
Error_TYPE = TYPE_ERROR_COMPOUND;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch,1);
} else if (IsApplTerm(t2)) {
Functor f = FunctorOfTerm(t2);
if (i1 < 1 || i1 > ArityOfFunctor(f)) {
c_goal(MkAtomTerm(AtomFalse), mod);
} else {
c_eq(ArgOfTerm(i1, t2), t3);
}
return;
} else if (IsPairTerm(t2)) {
switch (i1) {
case 1:
c_eq(HeadOfTerm(t2), t3);
return;
case 2:
c_eq(TailOfTerm(t2), t3);
return;
default:
c_goal(MkAtomTerm(AtomFalse), mod);
return;
}
}
} else {
char s[32];
Error_TYPE = TYPE_ERROR_INTEGER;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch,1);
}
}
if (Op == _functor) {
if (!IsAtomicTerm(t1)) {
char s[32];
Error_TYPE = TYPE_ERROR_ATOM;
Error_Term = t1;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch,1);
} else {
if (!IsVarTerm(t2)) {
Int arity;
/* We actually have the term ready, so let's just do the unification now */
if (!IsIntegerTerm(t2)) {
char s[32];
Error_TYPE = TYPE_ERROR_INTEGER;
Error_Term = t2;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch,1);
}
arity = IntOfTerm(t2);
if (arity < 0) {
/* fail straight away */
emit(fail_op, Zero, Zero);
}
if (arity) {
Term tnew;
if (!IsAtomTerm(t1)) {
char s[32];
Error_TYPE = TYPE_ERROR_ATOM;
Error_Term = t1;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2", s);
save_machine_regs();
longjmp(CompilerBotch,1);
}
if (H+1+arity >= (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
tnew = AbsAppl(H);
*H++ = (CELL)MkFunctor(AtomOfTerm(t1),arity);
while (arity--) {
RESET_VARIABLE(H);
H++;
}
c_eq(tnew, t3);
} else {
/* just unify the two arguments */
c_eq(t1,t3);
}
return;
} else {
/* first temp */
Int v1 = --tmpreg;
emit(fetch_args_cv_op, t1, Zero);
/* these should be the arguments */
c_var(t2, v1, 0);
/* now we know where the arguments are */
}
}
} else if (IsIntTerm(t1)) {
/* first temp */
Int v1 = --tmpreg;
emit(fetch_args_cv_op, (CELL)IntOfTerm(t1), Zero);
/* these should be the arguments */
c_var(t2, v1, 0);
/* now we know where the arguments are */
} else if (IsLongIntTerm(t1)) {
/* first temp */
Int v1 = --tmpreg;
emit(fetch_args_cv_op, (CELL)LongIntOfTerm(t1), Zero);
/* these should be the arguments */
c_var(t2, v1, 0);
/* now we know where the arguments are */
} else {
char s[32];
Error_TYPE = TYPE_ERROR_VARIABLE;
Error_Term = t1;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2 with output bound", s);
save_machine_regs();
longjmp(CompilerBotch,1);
}
}
/* then we compile the opcode/result */
if (!IsVarTerm(t3)) {
if (Op == _arg) {
Term tmpvar = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
c_var(tmpvar,f_flag,(unsigned int)Op);
c_eq(tmpvar,t3);
} else {
char s[32];
Error_TYPE = TYPE_ERROR_VARIABLE;
Error_Term = t3;
ErrorMessage = ErrorSay;
bip_name(Op, s);
sprintf(ErrorMessage, "compiling %s/2 with input unbound", s);
save_machine_regs();
longjmp(CompilerBotch,1);
}
} else if (IsNewVar(t3) /* && cur_branch == 0 */) {
c_var(t3,f_flag,(unsigned int)Op);
if (Op == _functor) {
emit(empty_call_op, Zero, Zero);
emit(restore_tmps_and_skip_op, Zero, Zero);
}
} else {
/* generate code for a temp and then unify temp with previous variable */
Term tmpvar = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
c_var(tmpvar,f_flag,(unsigned int)Op);
/* I have to dit here, before I do the unification */
if (Op == _functor) {
emit(empty_call_op, Zero, Zero);
emit(restore_tmps_and_skip_op, Zero, Zero);
}
c_eq(tmpvar,t3);
}
}
static void
c_functor(Term Goal, int mod)
{
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, mod);
} else if (IsNonVarTerm(t1)) {
/* just split the structure */
if (IsAtomicTerm(t1)) {
c_eq(t1,t2);
c_eq(t3,MkIntTerm(0));
} else if (IsApplTerm(t1)) {
Functor f = FunctorOfTerm(t1);
c_eq(t2,MkAtomTerm(NameOfFunctor(f)));
c_eq(t3,MkIntegerTerm(ArityOfFunctor(f)));
} else /* list */ {
c_eq(t2,TermDot);
c_eq(t3,MkIntTerm(2));
}
} else if (IsVarTerm(t2) && IsNewVar(t2) &&
IsVarTerm(t3) && IsNewVar(t3)) {
Int v1 = --tmpreg;
emit(fetch_args_vc_op, Zero, Zero);
c_var(t1, v1, 0);
c_var(t2,f_flag,(unsigned int)_functor);
c_var(t3,f_flag,(unsigned int)_functor);
} else {
Functor f = FunctorOfTerm(Goal);
Prop p0 = PredPropByFunc(f, mod);
if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero);
c_args(Goal);
emit(safe_call_op, (CELL)p0 , Zero);
emit(empty_call_op, Zero, Zero);
emit(restore_tmps_and_skip_op, Zero, Zero);
}
}
static int
IsTrueGoal(Term t) {
if (IsVarTerm(t)) return(FALSE);
if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
if (f == FunctorModule) {
return(IsTrueGoal(ArgOfTerm(2,t)));
}
if (f == FunctorComma || f == FunctorOr || f == FunctorArrow) {
return(IsTrueGoal(ArgOfTerm(1,t)) && IsTrueGoal(ArgOfTerm(2,t)));
}
return(FALSE);
}
return(t == MkAtomTerm(AtomTrue));
}
static void
c_goal(Term Goal, int mod)
{
Functor f;
PredEntry *p;
Prop p0;
if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
}
if (IsNumTerm(Goal)) {
FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal);
}
else if (IsRefTerm(Goal)) {
Error_TYPE = TYPE_ERROR_DBREF;
Error_Term = Goal;
FAIL("goal argument in static procedure can not be a data base reference", TYPE_ERROR_CALLABLE, Goal);
} else if (IsPairTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
} else if (IsApplTerm(Goal) && FunctorOfTerm(Goal) == FunctorModule) {
Term M = ArgOfTerm(1, Goal);
if (IsVarTerm(M) || !IsAtomTerm(M)) {
Error_TYPE = TYPE_ERROR_ATOM;
Error_Term = M;
ErrorMessage = "in module name";
save_machine_regs();
longjmp(CompilerBotch, 1);
}
Goal = ArgOfTerm(2, Goal);
mod = LookupModule(M);
}
if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
}
if (IsAtomTerm(Goal)) {
Atom atom = AtomOfTerm(Goal);
if (atom == AtomFail || atom == AtomFalse) {
emit(fail_op, Zero, Zero);
return;
}
else if (atom == AtomTrue || atom == AtomOtherwise) {
if (onlast) {
emit(deallocate_op, Zero, Zero);
#ifdef TABLING
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
}
return;
}
else if (atom == AtomCut) {
if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomCut,0)), Zero);
if (onlast) {
/* never a problem here with a -> b, !, c ; d */
emit(deallocate_op, Zero, Zero);
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred)) {
emit(cut_op, Zero, Zero);
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
} else
#endif /* TABLING */
{
emit(cutexit_op, Zero, Zero);
}
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
else {
emit(cut_op, Zero, Zero);
/* needs to adjust previous commits */
adjust_current_commits();
}
return;
}
#ifndef YAPOR
else if (atom == AtomRepeat) {
CELL l1 = ++labelno;
CELL l2 = ++labelno;
if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomRepeat,0)), Zero);
or_found = 1;
push_branch(onbranch, TermNil);
cur_branch++;
onbranch = cur_branch;
if (onlast)
emit(deallocate_op, Zero, Zero);
emit_3ops(push_or_op, l1, Zero, Zero);
emit_3ops(either_op, l1, Zero, Zero);
emit(restore_tmps_op, Zero, Zero);
emit(jump_op, l2, Zero);
emit(label_op, l1, Zero);
emit(pushpop_or_op, Zero, Zero);
emit_3ops(orelse_op, l1, Zero, Zero);
emit(label_op, l2, Zero);
if (onlast) {
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
} else
++goalno;
onbranch = pop_branch();
emit(pop_or_op, Zero, Zero);
/* --onbranch; */
return;
}
#endif /* YAPOR */
p = RepPredProp(p0 = PredPropByAtom(atom, mod));
/* if we are profiling, make sure we register we entered this predicate */
if (profiling)
emit(enter_profiling_op, (CELL)p, Zero);
}
else {
f = FunctorOfTerm(Goal);
p = RepPredProp(p0 = PredPropByFunc(f, mod));
if (f == FunctorOr) {
CELL l = ++labelno;
CELL m = ++labelno;
Term arg;
int save = onlast;
int savegoalno = goalno;
int frst = TRUE;
int comitflag = 0;
int looking_at_comit = FALSE;
int optimizing_comit = FALSE;
Term comitvar = 0;
PInstr *FirstP = cpc, *savecpc, *savencpc;
push_branch(onbranch, TermNil);
++cur_branch;
onbranch = cur_branch;
or_found = 1;
do {
arg = ArgOfTerm(1, Goal);
looking_at_comit = IsApplTerm(arg) &&
FunctorOfTerm(arg) == FunctorArrow;
if (frst) {
if (optimizing_comit) {
emit(label_op, l, Zero);
l = ++labelno;
}
emit_3ops(push_or_op, l, Zero, Zero);
if (looking_at_comit &&
is_a_test_pred(ArgOfTerm(1, arg), mod)) {
/*
* let them think they are still the
* first
*/
emit(comit_opt_op, l, Zero);
optimizing_comit = TRUE;
}
else {
optimizing_comit = FALSE;
emit_3ops(either_op, l, Zero, Zero);
emit(restore_tmps_op, Zero, Zero);
frst = FALSE;
}
}
else {
optimizing_comit = FALSE;
emit(label_op, l, Zero);
emit(pushpop_or_op, Zero, Zero);
emit_3ops(orelse_op, l = ++labelno, Zero, Zero);
}
/*
* if(IsApplTerm(arg) &&
* FunctorOfTerm(arg)==FunctorArrow) {
*/
if (looking_at_comit) {
if (!optimizing_comit && !comitflag) {
/* 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 = goalno;
goalno = savegoalno;
comitflag = labelno;
comitvar = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
savecpc = cpc;
savencpc = FirstP->nextInst;
cpc = FirstP;
onbranch = pop_branch();
c_var(comitvar, save_b_flag, 1);
push_branch(onbranch, comitvar);
onbranch = cur_branch;
cpc->nextInst = savencpc;
cpc = savecpc;
goalno = my_goalno;
}
save = onlast;
onlast = FALSE;
c_goal(ArgOfTerm(1, arg), mod);
if (!optimizing_comit) {
c_var((Term) comitvar, comit_b_flag,
1);
}
onlast = save;
c_goal(ArgOfTerm(2, arg), mod);
}
else
c_goal(ArgOfTerm(1, Goal), mod);
if (!onlast) {
emit(jump_op, m, Zero);
}
goalno = savegoalno + 1;
Goal = ArgOfTerm(2, Goal);
++cur_branch;
onbranch = cur_branch;
} while (IsNonVarTerm(Goal) && IsApplTerm(Goal)
&& FunctorOfTerm(Goal) == FunctorOr);
emit(pushpop_or_op, Zero, Zero);
emit(label_op, l, Zero);
if (!optimizing_comit)
emit(orlast_op, Zero, Zero);
else {
optimizing_comit = FALSE; /* not really necessary */
}
c_goal(Goal, mod);
/* --onbranch; */
onbranch = pop_branch();
if (!onlast) {
emit(label_op, m, Zero);
if ((onlast = save))
c_goal(MkAtomTerm(AtomTrue), mod);
}
emit(pop_or_op, Zero, Zero);
return;
}
else if (f == FunctorComma) {
int save = onlast;
int t2 = ArgOfTerm(2, Goal);
onlast = FALSE;
c_goal(ArgOfTerm(1, Goal), mod);
onlast = save;
c_goal(t2, mod);
return;
}
else if (f == FunctorNot || f == FunctorAltNot) {
CELL label = (labelno += 2);
CELL end_label = (labelno += 2);
int save = onlast;
Term comitvar;
comitvar = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
push_branch(onbranch, comitvar);
++cur_branch;
onbranch = cur_branch;
or_found = 1;
onlast = FALSE;
c_var(comitvar, save_b_flag, 1);
emit_3ops(push_or_op, label, Zero, Zero);
emit_3ops(either_op, label, Zero, Zero);
emit(restore_tmps_op, Zero, Zero);
c_goal(ArgOfTerm(1, Goal), mod);
c_var(comitvar, comit_b_flag, 1);
onlast = save;
emit(fail_op, end_label, Zero);
emit(pushpop_or_op, Zero, Zero);
emit(label_op, label, Zero);
emit(orlast_op, Zero, Zero);
emit(label_op, end_label, Zero);
onlast = save;
/* --onbranch; */
onbranch = pop_branch();
c_goal(MkAtomTerm(AtomTrue), mod);
++goalno;
emit(pop_or_op, Zero, Zero);
return;
}
else if (f == FunctorArrow) {
Term comitvar;
int save = onlast;
comitvar = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
onlast = FALSE;
c_var(comitvar, save_b_flag, 1);
c_goal(ArgOfTerm(1, Goal), mod);
c_var(comitvar, comit_b_flag, 1);
onlast = save;
c_goal(ArgOfTerm(2, Goal), mod);
return;
} else if (f == FunctorEq) {
if (profiling)
emit(enter_profiling_op, (CELL)p, Zero);
c_eq(ArgOfTerm(1, Goal), ArgOfTerm(2, Goal));
if (onlast) {
emit(deallocate_op, Zero, Zero);
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
return;
} else if (p->PredFlags & BasicPredFlag) {
int op = p->PredFlags & 0x7f;
if (profiling)
emit(enter_profiling_op, (CELL)p, Zero);
if (op >= _atom && op <= _primitive) {
c_test(op, ArgOfTerm(1, Goal));
if (onlast) {
emit(deallocate_op, Zero, Zero);
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
return;
} else if (op >= _plus && op <= _functor) {
if (op == _functor) {
c_functor(Goal, mod);
} else {
c_bifun(op,
ArgOfTerm(1, Goal),
ArgOfTerm(2, Goal),
ArgOfTerm(3, Goal),
mod);
}
if (onlast) {
emit(deallocate_op, Zero, Zero);
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
return;
} else {
c_args(Goal);
}
} else if (p->PredFlags & BinaryTestPredFlag) {
Term a1 = ArgOfTerm(1,Goal);
if (IsVarTerm(a1) && !IsNewVar(a1)) {
Term a2 = ArgOfTerm(2,Goal);
if (IsVarTerm(a2) && !IsNewVar(a2)) {
if (IsNewVar(a2)) {
Error_TYPE = INSTANTIATION_ERROR;
Error_Term = a2;
ErrorMessage = ErrorSay;
sprintf(ErrorMessage, "compiling %s/2 with second arg unbound", RepAtom(NameOfFunctor(p->FunctorOfPred))->StrOfAE);
save_machine_regs();
longjmp(CompilerBotch,1);
}
c_var(a1, bt1_flag, 2);
current_p0 = p0;
c_var(a2, bt2_flag, 2);
} else {
Term t2 = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
c_eq(t2, a2);
c_var(a1, bt1_flag, 2);
current_p0 = p0;
c_var(t2, bt2_flag, 2);
}
} else {
Term a2 = ArgOfTerm(2,Goal);
Term t1 = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
c_eq(t1, a1);
if (IsVarTerm(a2) && !IsNewVar(a2)) {
c_var(t1, bt1_flag, 2);
current_p0 = p0;
c_var(a2, bt2_flag, 2);
} else {
Term t2 = MkVarTerm();
if (H == (CELL *)freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(CompilerBotch,4);
}
c_eq(t2, a2);
c_var(t1, bt1_flag, 2);
current_p0 = p0;
c_var(t2, bt2_flag, 2);
}
}
if (onlast) {
emit(deallocate_op, Zero, Zero);
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
return;
} else {
if (profiling)
emit(enter_profiling_op, (CELL)p, Zero);
c_args(Goal);
}
}
#ifdef YAPOR
/* synchronisation means saving the state, so it is never safe in YAPOR */
if (p->PredFlags & SafePredFlag && !(p->PredFlags & SyncPredFlag)) {
#else
if (p->PredFlags & SafePredFlag) {
#endif /* YAPOR */
if (onlast)
emit(deallocate_op, Zero, Zero);
emit(safe_call_op, (CELL) p0, Zero);
if (onlast) {
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
}
else {
if (p->PredFlags & (CPredFlag | BasicPredFlag)) {
#ifdef YAPOR
if (p->PredFlags & SyncPredFlag)
emit(sync_op, (CELL)p, (CELL)(p->ArityOfPE));
#endif /* YAPOR */
emit_3ops(call_op, (CELL) p0, Zero, Zero);
/* functor is allowed to call the garbage collector */
if (onlast) {
emit(deallocate_op, Zero, Zero);
or_found = 1;
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
else
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
}
else {
if (onlast) {
emit(deallocate_op, Zero, Zero);
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred)) {
emit_3ops(call_op, (CELL) p0, Zero, Zero);
emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
} else
#endif /* TABLING */
emit(execute_op, (CELL) p0, Zero);
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
} else {
emit_3ops(call_op, (CELL) p0, Zero, Zero);
}
}
if (!onlast)
++goalno;
}
}
static void
get_type_info(Term Goal)
{
if (IsNonVarTerm(Goal) && IsApplTerm(Goal)) {
if (c_mask == VarCl &&
ArgOfTerm(1, Goal) == (Term) c_store) {
if (FunctorOfTerm(Goal) == FunctorGVar)
c_mask |= FIsVar;
else if (FunctorOfTerm(Goal) == FunctorGAtom)
c_mask |= AtCl | FIsAtom;
else if (FunctorOfTerm(Goal) == FunctorGInteger)
c_mask |= AtCl | FIsNum;
/*
* vsc: with the new scheme floats are structs, so
* the simple index switch cannot differentiate them
* from structs:
* else if (FunctorOfTerm(Goal) == FunctorGAtomic ||
* FunctorOfTerm(Goal) == FunctorGPrimitive)
* c_mask |= AtCl|FIsNum;
*/
}
}
}
static void
c_body(Term Body, int mod)
{
onhead = FALSE;
BodyStart = cpc;
goalno = 1;
if (IsNonVarTerm(Body) && IsApplTerm(Body)) {
if (FunctorOfTerm(Body) == FunctorComma)
get_type_info(ArgOfTerm(1, Body));
else
get_type_info(Body);
}
while (IsNonVarTerm(Body) && IsApplTerm(Body)
&& FunctorOfTerm(Body) == FunctorComma) {
Term t2 = ArgOfTerm(2, Body);
if (IsTrueGoal(t2)) {
/* optimise the case where some idiot left trues at the end
of the clause.
*/
Body = ArgOfTerm(1, Body);
break;
}
c_goal(ArgOfTerm(1, Body), mod);
Body = t2;
}
onlast = TRUE;
c_goal(Body, mod);
}
static void
get_cl_info(register Term t)
{
if (IsVarTerm(t)) {
c_mask = VarCl;
c_store = (CELL) t;
}
else if (IsPairTerm(t)) {
c_mask = ListCl;
t = HeadOfTerm(t);
if (IsVarTerm(t))
c_mask |= FHeadVar;
else if (IsPairTerm(t))
c_mask |= FHeadList;
else if (IsApplTerm(t)) {
c_store = (CELL) FunctorOfTerm(t);
c_mask |= FHeadAppl;
}
else {
c_store = (CELL) t;
c_mask |= FHeadCons;
}
}
else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
if (!IsExtensionFunctor(fun)) {
c_mask = (CELL)ApplCl;
c_store = (CELL)fun;
}
}
else {
c_store = (CELL) t;
c_mask = AtCl;
}
}
static void
c_head(Term t)
{
Functor f;
goalno = 0;
level = 0;
onhead = TRUE;
onlast = FALSE;
cur_branch = onbranch = 0;
branch_pointer = parent_branches;
if (IsAtomTerm(t)) {
emit(name_op, (CELL) AtomOfTerm(t), Zero);
return;
}
f = FunctorOfTerm(t);
emit(name_op, (CELL) NameOfFunctor(f), ArityOfFunctor(f));
c_args(t);
get_cl_info(ArgOfTerm(1, t));
}
/* number of permanent variables in the clause */
static int nperm;
inline static int
usesvar(int ic)
{
if (ic >= get_var_op && ic <= put_val_op)
return (TRUE);
switch (ic) {
case save_b_op:
case comit_b_op:
case patch_b_op:
case save_appl_op:
case save_pair_op:
case f_val_op:
case f_var_op:
case fetch_args_for_bccall:
case bccall_op:
return (TRUE);
}
#ifdef SFUNC
if (ic >= unify_s_var_op && ic <= write_s_val_op)
return (TRUE);
#endif
return ((ic >= unify_var_op && ic <= write_val_op)
||
(ic >= unify_last_var_op && ic <= unify_last_val_op));
}
/*
* Do as in the traditional WAM and make sure voids are in
* environments
*/
#define LOCALISE_VOIDS 1
#ifdef LOCALISE_VOIDS
typedef struct env_tmp {
Ventry * Var;
struct env_tmp *Next;
} EnvTmp;
#endif
static void
AssignPerm(PInstr *pc)
{
int uses_var;
PInstr *opc = NULL;
#ifdef LOCALISE_VOIDS
EnvTmp *EnvTmps = NULL;
#endif
/* The WAM tries to keep voids on the
* environment. Traditionally, YAP liberally globalises
* voids.
*
* The new version goes to some length to keep void variables
* in environments, but it is dubious that improves
* performance, and may actually slow down the system
*/
while (pc != NULL) {
PInstr *tpc = pc->nextInst;
#ifdef LOCALISE_VOIDS
if (pc->op == put_var_op) {
Ventry *v = (Ventry *) (pc->rnd1);
if (v->AgeOfVE == v->FirstOfVE
&& !(v->FlagsOfVE & (GlobalVal|OnHeadFlag|OnLastGoal|NonVoid)) ) {
EnvTmp *x = (EnvTmp *)AllocCMem(sizeof(*x));
x->Next = EnvTmps;
x->Var = v;
EnvTmps = x;
}
}
#endif
if (pc->op == call_op || pc->op == either_op || pc->op == orelse_op || pc->op == push_or_op) {
#ifdef LOCALISE_VOIDS
pc->ops.opseqt[1] = (CELL)EnvTmps;
if (EnvTmps)
EnvTmps = NULL;
#endif
}
pc->nextInst = opc;
opc = pc;
pc = tpc;
}
pc = opc;
opc = NULL;
do {
PInstr *npc = pc->nextInst;
pc->nextInst = opc;
uses_var = usesvar(pc->op);
if (uses_var) {
Ventry *v = (Ventry *) (pc->rnd1);
if (v->NoOfVE == Unassigned) {
if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE))
|| v->KindOfVE == PermVar /*
* * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE &
* * OnHeadFlag))
*/ ) {
v->NoOfVE = PermVar | (nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= PermFlag;
}
else
v->NoOfVE = v->KindOfVE = TempVar;
}
} else if (pc->op == empty_call_op) {
pc->rnd2 = nperm;
} else if (pc->op == call_op || pc->op == either_op || pc->op == orelse_op || pc->op == push_or_op) {
#ifdef LOCALISE_VOIDS
EnvTmps = (EnvTmp *)(pc->ops.opseqt[1]);
while (EnvTmps) {
Ventry *v = EnvTmps->Var;
v->NoOfVE = PermVar | (nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= (PermFlag|SafeVar);
EnvTmps = EnvTmps->Next;
}
#endif
pc->rnd2 = nperm;
}
opc = pc;
pc = npc;
} while (pc != NULL);
}
static CELL *
init_bvarray(int nperm)
{
CELL *vinfo = NULL;
unsigned int i;
CELL *vptr;
vptr = vinfo = (CELL *)AllocCMem(sizeof(CELL)*(1+nperm/(8*sizeof(CELL))));
for (i = 0; i <= nperm/(8*sizeof(CELL)); i++) {
*vptr++ = (CELL)(0L);
}
return(vinfo);
}
static void
clear_bvarray(int var, CELL *bvarray)
{
int max = 8*sizeof(CELL);
CELL nbit;
/* get to the array position */
while (var >= max) {
bvarray++;
var -= max;
}
/* now put a 0 on it, from now on the variable is initialised */
nbit = (1 << var);
#ifdef DEBUG
if (*bvarray & nbit) {
/* someone had already marked this variable: complain */
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "repeated bit for variable";
save_machine_regs();
longjmp(CompilerBotch, 2);
}
pbvars++;
#endif
*bvarray |= nbit;
}
/* copy the current state of the perm variable state array to code space */
static void
add_bvarray_op(PInstr *cp, CELL *bvarray, int env_size)
{
int i, size = env_size/(8*sizeof(CELL));
CELL *dest;
dest =
emit_extra_size(mark_initialised_pvars_op, (CELL)env_size, (size+1)*sizeof(CELL));
/* copy the cells to dest */
for (i = 0; i <= size; i++)
*dest++ = *bvarray++;
}
/* vsc: this code is not working, as it is too complex */
typedef struct {
int lab;
int last;
PInstr *pc;
} bventry;
#define MAX_DISJUNCTIONS 32
static bventry *bvstack;
static int bvindex = 0;
static void
push_bvmap(int label, PInstr *cpc)
{
if (bvindex == MAX_DISJUNCTIONS) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "Too many embedded disjunctions";
save_machine_regs();
longjmp(CompilerBotch, 2);
}
/* the label instruction */
bvstack[bvindex].lab = label;
bvstack[bvindex].last = -1;
/* where we have the code */
bvstack[bvindex].pc = cpc;
bvindex++;
}
static void
reset_bvmap(CELL *bvarray, int nperm)
{
int size, size1, env_size, i;
CELL *source;
if (bvindex == 0) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "No embedding in disjunctions";
save_machine_regs();
longjmp(CompilerBotch, 2);
}
env_size = (bvstack[bvindex-1].pc)->rnd1;
size = env_size/(8*sizeof(CELL));
size1 = nperm/(8*sizeof(CELL));
source = (bvstack[bvindex-1].pc)->arnds;
for (i = 0; i <= size; i++)
*bvarray++ = *source++;
for (i = size+1; i<= size1; i++)
*bvarray++ = (CELL)(0);
}
static void
pop_bvmap(CELL *bvarray, int nperm)
{
if (bvindex == 0) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "Too few embedded disjunctions";
/* save_machine_regs();
longjmp(CompilerBotch, 2); */
}
reset_bvmap(bvarray, nperm);
bvindex--;
}
typedef struct {
PInstr *p;
Ventry *v;
} UnsafeEntry;
/* extend to also support variable usage bitmaps for garbage collection */
static void
CheckUnsafe(PInstr *pc)
{
int pending = 0;
/* say that all variables are yet to initialise */
CELL *vstat = init_bvarray(nperm);
UnsafeEntry *UnsafeStack =
(UnsafeEntry *) AllocCMem(nperm * sizeof(UnsafeEntry));
/* keep a copy of previous cpc and CodeStart */
PInstr *opc = cpc;
PInstr *OldCodeStart = CodeStart;
CodeStart = BlobsStart;
cpc = icpc;
bvindex = 0;
bvstack = (bventry *)AllocCMem(MAX_DISJUNCTIONS * sizeof(bventry));
while (pc != NIL) {
switch(pc->op) {
case put_val_op:
{
Ventry *v = (Ventry *) (pc->rnd1);
if ((v->FlagsOfVE & PermFlag) && !(v->FlagsOfVE & SafeVar)) {
UnsafeStack[pending].p = pc;
UnsafeStack[pending++].v = v;
v->FlagsOfVE |= SafeVar;
}
break;
}
case put_var_op:
case get_var_op:
case save_b_op:
case unify_var_op:
case unify_last_var_op:
case write_var_op:
case save_appl_op:
case save_pair_op:
case f_var_op:
{
Ventry *v = (Ventry *) (pc->rnd1);
if (v->FlagsOfVE & PermFlag && pc == v->FirstOpForV) {
/* the second condition covers cases such as save_b_op
in a disjunction */
clear_bvarray((v->NoOfVE & MaskVarAdrs), vstat);
}
}
break;
case push_or_op:
emit(label_op, ++labelno, Zero);
pc->ops.opseqt[1] = (CELL)labelno;
add_bvarray_op(pc, vstat, pc->rnd2);
push_bvmap((CELL)labelno, cpc);
break;
case either_op:
/* add a first entry to the array */
emit(label_op, ++labelno, Zero);
pc->ops.opseqt[1] = (CELL)labelno;
add_bvarray_op(pc, vstat, pc->rnd2);
break;
case pushpop_or_op:
reset_bvmap(vstat, nperm);
break;
case orelse_op:
emit(label_op, ++labelno, Zero);
pc->ops.opseqt[1] = (CELL)labelno;
add_bvarray_op(pc, vstat, pc->rnd2);
break;
case pop_or_op:
pop_bvmap(vstat, nperm);
break;
case empty_call_op:
/* just get ourselves a label describing how
many permanent variables are alive */
emit(label_op, ++labelno, Zero);
pc->rnd1 = (CELL)labelno;
add_bvarray_op(pc, vstat, pc->rnd2);
break;
case call_op:
emit(label_op, ++labelno, Zero);
pc->ops.opseqt[1] = (CELL)labelno;
add_bvarray_op(pc, vstat, pc->rnd2);
case deallocate_op:
{
int n = pc->op == call_op ? pc->rnd2 : 0;
int no;
while (pending) {
Ventry *v = UnsafeStack[--pending].v;
v->FlagsOfVE &= ~SafeVar;
no = (v->NoOfVE) & MaskVarAdrs;
if (no >= n)
UnsafeStack[pending].p->op = put_unsafe_op;
}
}
default:
break;
}
pc = pc->nextInst;
}
icpc = cpc;
cpc = opc;
BlobsStart = CodeStart;
CodeStart = OldCodeStart;
}
static void
CheckVoids(void)
{ /* establish voids in the head and initial
* uses */
Ventry *ve;
cpc = CodeStart;
while ((ic = cpc->op) != allocate_op) {
ic = cpc->op;
#ifdef M_WILLIAMS
switch ((int) ic) {
#else
switch (ic) {
#endif
case get_var_op:
case unify_var_op:
case unify_last_var_op:
#ifdef SFUNC
case unify_s_var_op:
#endif
case save_pair_op:
case save_appl_op:
ve = ((Ventry *) cpc->rnd1);
if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1) {
ve->NoOfVE = ve->KindOfVE = VoidVar;
if (ic == get_var_op || ic ==
save_pair_op || ic == save_appl_op
#ifdef SFUNC
|| ic == unify_s_var_op
#endif
) {
cpc->op = nop_op;
break;
}
}
if (ic != get_var_op)
break;
case get_val_op:
case get_atom_op:
case get_num_op:
case get_float_op:
case get_longint_op:
case get_bigint_op:
case get_list_op:
case get_struct_op:
Uses[cpc->rnd2] = 1;
}
cpc = cpc->nextInst;
}
}
static int
checktemp(void)
{
Ventry *v = (Ventry *) arg;
PInstr *q;
Int Needed[MaxTemps];
Int r, target1, target2;
Int n, *np, *rp;
CELL *cp;
vadr = (v->NoOfVE);
vreg = vadr & MaskVarAdrs;
if (v->KindOfVE == PermVar || v->KindOfVE == VoidVar)
return (0);
if (v->RCountOfVE == 1)
return(0);
if (vreg) {
--Uses[vreg];
return (1);
}
/* follow the life of the variable */
q = cpc;
/*
* for(r=0; r<MaxCTemps; ++r) Needed[r] = Uses[r]; might be written
* as:
*/
np = Needed;
rp = Uses;
for (r = 0; r < MaxCTemps; ++r)
*np++ = *rp++;
if (rn > 0 && (ic == get_var_op || ic == put_var_op)) {
if (ic == put_var_op)
Needed[rn] = 1;
target1 = rn; /* try to leave it where it is */
}
else
target1 = MaxCTemps;
target2 = MaxCTemps;
n = v->RCountOfVE - 1;
while ((q = q->nextInst) != NIL) {
if (q->rnd2 < 0);
else if (usesvar(ic = q->op) && arg == q->rnd1) {
--n;
if (ic == put_val_op) {
if (target1 == MaxCTemps && Needed[q->rnd2] == 0)
target1 = q->rnd2;
else if (target1 != (r = q->rnd2)) {
if (target2 == MaxCTemps && Needed[r] == 0)
target2 = r;
else if (target2 > r && Uses[r] == 0 && Needed[r] == 0)
target2 = r;
}
}
}
#ifdef SFUNC
else if ((ic >= get_var_op && ic <= put_unsafe_op)
|| ic == get_s_f_op || ic == put_s_f_op)
Needed[q->rnd2] = 1;
#else
else if (ic >= get_var_op && ic <= put_unsafe_op)
Needed[q->rnd2] = 1;
#endif
if ((ic == call_op || ic == safe_call_op) && n == 0)
break;
}
if (target2 < target1) {
r = target2;
target2 = target1;
target1 = r;
}
if (target1 == MaxCTemps || Uses[target1] || Needed[target1])
if ((target1 = target2) == MaxCTemps || Uses[target1] || Needed[target1]) {
target1 = MaxCTemps;
do
--target1;
while (target1 && Uses[target1] == 0 && Needed[target1] == 0);
++target1;
}
if (target1 == MaxCTemps) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "too many temporaries";
save_machine_regs();
longjmp(CompilerBotch, 1);
}
v->NoOfVE = vadr = TempVar | target1;
v->KindOfVE = TempVar;
Uses[vreg = target1] = v->RCountOfVE - 1;
/*
* for(r=0; r<MaxCTemps; ++r) if(Contents[r]==vadr) Contents[r] =
* NIL;
*/
cp = Contents;
for (r = 0; r < MaxCTemps; ++r)
if (*cp++ == (Term)vadr)
cp[-1] = NIL;
Contents[vreg] = vadr;
ic = cpc->op;
return (1);
}
static void
checkreg(int var_arg)
{
PInstr *p = cpc;
if (rn >= 0)
return;
vreg = 0;
if (var_arg) {
Ventry *v = (Ventry *) arg;
vreg = (v->NoOfVE) & MaskVarAdrs;
if (v->KindOfVE == PermVar)
vreg = 0;
else if (vreg == 0) {
checktemp();
++Uses[vreg];
}
}
if (vreg == 0) {
vreg = MaxCTemps;
do
--vreg;
while (vreg && Uses[vreg] == 0);
++vreg;
++Uses[vreg];
}
while (p) {
if (p->op >= get_var_op && p->op <= put_unsafe_op && p->rnd2 == rn)
p->rnd2 = vreg;
/* only copy variables until you reach a call */
if (p->op == procceed_op || p->op == call_op || p->op == push_or_op || p->op == pushpop_or_op)
break;
p = p->nextInst;
}
rn = vreg;
}
/* Create a bitmap with all live variables */
static CELL
copy_live_temps_bmap(int max)
{
unsigned int size = (max|7)/8+1;
int i;
CELL *dest = emit_extra_size(mark_live_regs_op, max, size);
CELL *ptr=dest;
*ptr = 0L;
for (i=1; i <= max; i++) {
/* move to next cell */
if (i%(8*CellSize) == 0) {
ptr++;
*ptr = 0L;
}
/* set the register live bit */
if (Contents[i]) {
int j = i%(8*CellSize);
*ptr |= (1<<j);
}
}
return((CELL)dest);
}
static void
c_layout(void)
{
PInstr *savepc = BodyStart->nextInst;
register Ventry *v = vtable;
Int *up = Uses, Arity;
CELL *cop = Contents;
cpc = BodyStart;
while (v != NIL) {
if (v->FlagsOfVE & BranchVar) {
v->AgeOfVE = v->FirstOfVE + 1; /* force permanent */
++(v->RCountOfVE);
emit(put_var_op, (CELL) v, Zero);
v->FlagsOfVE &= ~GlobalVal;
v->FirstOpForV = cpc;
}
v = v->NextOfVE;
}
cpc->nextInst = savepc;
nperm = 0;
AssignPerm(CodeStart);
/* vsc: need to do it from the beginning to find which perm vars are active */
/* CheckUnsafe(BodyStart); */
#ifdef DEBUG
pbvars = 0;
#endif
CheckUnsafe(CodeStart);
#ifdef DEBUG
if (pbvars != nperm) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "wrong number of variables found in bitmap";
save_machine_regs();
longjmp(CompilerBotch, 2);
}
#endif
MaxCTemps = nvars + max_args - tmpreg + n_common_exps + 2;
if (MaxCTemps >= MaxTemps)
MaxCTemps = MaxTemps;
for (rn = 0; rn < MaxCTemps; ++rn) {
/* Uses[rn] = 0; Contents[rn] = NIL; */
*up++ = 0;
*cop++ = NIL;
}
CheckVoids();
/* second scan: allocate registers */
cpc = CodeStart;
while (cpc) {
ic = cpc->op;
arg = cpc->rnd1;
rn = cpc->rnd2;
#ifdef M_WILLIAMS
switch ((int) ic) {
#else
switch (ic) {
#endif
case allocate_op:
case deallocate_op:
#ifdef TABLING
READ_LOCK(CurrentPred->PRWLock);
if (is_tabled(CurrentPred))
cpc->op = nop_op;
else
#endif /* TABLING */
if (goalno == 1 && or_found == 0 && nperm == 0)
cpc->op = nop_op;
#ifdef TABLING
READ_UNLOCK(CurrentPred->PRWLock);
#endif
break;
case pop_op:
ic = (cpc->nextInst)->op;
if (ic >= get_var_op && ic <= put_unsafe_op)
cpc->op = nop_op;
break;
case get_var_op:
--Uses[rn];
if (checktemp()) {
if (vreg == rn)
cpc->op = nop_op;
}
Contents[rn] = vadr;
break;
case get_val_op:
--Uses[rn];
checktemp();
Contents[rn] = vadr;
break;
case f_var_op:
case unify_var_op:
case unify_val_op:
case unify_last_var_op:
case unify_last_val_op:
#ifdef SFUNC
case unify_s_var_op:
case unify_s_val_op:
#endif
case fetch_args_for_bccall:
case bccall_op:
checktemp();
break;
case get_atom_op:
case get_num_op:
case get_float_op:
case get_longint_op:
case get_bigint_op:
--Uses[rn];
Contents[rn] = arg;
break;
case get_list_op:
case get_struct_op:
Contents[rn] = NIL;
--Uses[rn];
break;
case put_var_op:
case put_unsafe_op:
checkreg(TRUE);
checktemp();
Contents[rn] = vadr;
++Uses[rn];
break;
case put_val_op:
checkreg(TRUE);
checktemp();
if (Contents[rn] == (Term)vadr)
cpc->op = nop_op;
Contents[rn] = vadr;
++Uses[rn];
break;
#ifdef SFUNC
case write_s_var_op:
{
Ventry *ve = (Ventry *) arg;
if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1)
cpc->op = nop_op;
}
break;
case write_s_val_op:
#endif
case write_var_op:
case write_val_op:
case f_val_op:
checktemp();
break;
#ifdef SFUNC
case put_s_f_op:
Contents[rn] = arg;
++Uses[rn];
break;
#endif
case put_atom_op:
case put_num_op:
case put_float_op:
case put_longint_op:
case put_bigint_op:
checkreg(FALSE);
if (Contents[rn] == arg)
cpc->op = nop_op;
Contents[rn] = arg;
++Uses[rn];
break;
case put_list_op:
case put_struct_op:
checkreg(FALSE);
Contents[rn] = NIL;
++Uses[rn];
break;
case save_b_op:
case comit_b_op:
case patch_b_op:
case save_appl_op:
case save_pair_op:
checktemp();
break;
case safe_call_op:
Arity = RepPredProp((Prop) arg)->ArityOfPE;
for (rn = 1; rn <= Arity; ++rn)
--Uses[rn];
break;
case call_op:
case label_op:
/*
* for(rn=1; rn<MaxCTemps; ++rn) Uses[rn] =
* Contents[rn] = NIL;
*/
up = Uses;
cop = Contents;
for (rn = 1; rn < MaxCTemps; ++rn)
*up++ = *cop++ = NIL;
break;
case restore_tmps_and_skip_op:
case restore_tmps_op:
/*
This instruction is required by the garbage collector to find out
how many temporaries are live right now. It is also useful when
waking up goals before an either or ! instruction.
*/
{
PInstr *mycpc = cpc, *oldCodeStart = CodeStart;
int i, max;
/* instructions must be placed at BlobsStart */
CodeStart = BlobsStart;
cpc = icpc;
max = 0;
for (i = 1; i < MaxCTemps; ++i) {
if (Contents[i]) max = i;
}
emit(label_op, ++labelno, Zero);
mycpc->rnd1 = labelno;
rn = copy_live_temps_bmap(max);
icpc = cpc;
BlobsStart = CodeStart;
cpc = mycpc;
CodeStart = oldCodeStart;
}
break;
}
if (cpc->nextInst)
cpc = cpc->nextInst;
else return;
}
}
static void
c_optimize(PInstr *pc)
{
char onTail;
Ventry *v;
PInstr *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 save_pair_op:
{
Term ve = (Term) pc->rnd1;
PInstr *npc = pc->nextInst;
if (((Ventry *) ve)->RCountOfVE <= 1)
pc->op = nop_op;
else {
*pc = *npc;
pc->nextInst = npc;
npc->op = save_pair_op;
npc->rnd1 = (CELL) ve;
}
}
break;
case save_appl_op:
{
Term ve = (Term) pc->rnd1;
PInstr *npc = pc->nextInst;
if (((Ventry *) ve)->RCountOfVE <= 1)
pc->op = nop_op;
else {
*pc = *npc;
pc->nextInst = npc;
npc->op = save_appl_op;
npc->rnd1 = (CELL) ve;
}
break;
}
case nop_op:
break;
case unify_var_op:
case unify_last_var_op:
#ifdef OLD_SYSTEM
/* In the good old days Yap would remove lots of small void
* instructions for a structure. This is not such a
* good idea nowadays, as we need to know where we
* finish the structure for the last instructions to
* work correctly. Instead, we will use unify_void
* with very little overhead */
v = (Ventry *) (pc->rnd1);
if (v->KindOfVE == VoidVar && onTail) {
pc->op = nop_op;
}
else
#endif /* OLD_SYSTEM */
onTail = 0;
break;
case unify_val_op:
v = (Ventry *) (pc->rnd1);
if (!(v->FlagsOfVE & GlobalVal))
pc->op = unify_local_op;
onTail = 0;
break;
case unify_last_val_op:
v = (Ventry *) (pc->rnd1);
if (!(v->FlagsOfVE & GlobalVal))
pc->op = unify_last_local_op;
onTail = 0;
break;
case write_val_op:
v = (Ventry *) (pc->rnd1);
if (!(v->FlagsOfVE & GlobalVal))
pc->op = write_local_op;
onTail = 0;
break;
case pop_op:
if (FALSE && onTail == 1) {
pc->op = nop_op;
onTail = 1;
break;
}
else {
PInstr *p = pc->nextInst;
while (p != NIL && p->op == nop_op)
p = p->nextInst;
if (p != NIL && p->op == pop_op) {
pc->rnd1 += p->rnd1;
pc->nextInst = p->nextInst;
}
onTail = 2;
break;
}
case write_var_op:
case unify_atom_op:
case unify_last_atom_op:
case write_atom_op:
case unify_num_op:
case unify_last_num_op:
case write_num_op:
case unify_float_op:
case unify_last_float_op:
case write_float_op:
case unify_longint_op:
case unify_bigint_op:
case unify_last_longint_op:
case unify_last_bigint_op:
case write_longint_op:
case write_bigint_op:
case unify_list_op:
case write_list_op:
case unify_struct_op:
case write_struct_op:
case write_unsafe_op:
case unify_last_list_op:
case write_last_list_op:
case unify_last_struct_op:
case write_last_struct_op:
#ifdef SFUNC
case unify_s_f_op:
case write_s_f_op:
#endif
onTail = 0;
break;
default:
onTail = 1;
break;
}
opc = pc;
pc = npc;
} while (pc != NULL);
}
CODEADDR
cclause(Term inp_clause, int NOfArgs, int mod)
{ /* compile a prolog clause, copy of clause myst be in ARG1 */
/* returns address of code for clause */
Term head, body;
CELL *SaveH;
CODEADDR acode;
volatile int maxvnum = 512;
int botch_why;
volatile Term my_clause = inp_clause;
/* may botch while doing a different module */
/* first, initialise CompilerBotch to handle all cases of interruptions */
ErrorMessage = NIL;
if ((botch_why = setjmp(CompilerBotch)) == 3) {
/* out of local stack, just duplicate the stack */
restore_machine_regs();
reset_vars();
{
Int osize = 2*sizeof(CELL)*(ASP-H);
ARG1 = my_clause;
if (!gc(2, ENV, P)) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = my_clause;
ErrorMessage = "not enough stack";
}
if (osize > ASP-H) {
if (!growstack(2*sizeof(CELL)*(ASP-H))) {
Error_TYPE = SYSTEM_ERROR;
Error_Term = my_clause;
ErrorMessage = "not enough stack";
}
}
my_clause = ARG1;
}
} else if (botch_why == 4) {
/* out of temporary cells */
restore_machine_regs();
reset_vars();
if (maxvnum < 16*1024) {
maxvnum *= 2;
} else {
maxvnum += 4096;
}
} else if (botch_why == 2) {
/* not enough heap */
restore_machine_regs();
reset_vars();
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "not enough heap space to compile clause";
return(0);
}
restart_compilation:
if (ErrorMessage != NIL) {
reset_vars();
return (0);
}
SaveH = H;
c_mask = 0;
or_found = 0;
ErrorMessage = NULL;
/* initialize variables for code generation */
CodeStart = cpc = NULL;
BlobsStart = icpc = NULL;
freep = freep0 = (char *) (H + maxvnum);
if (ASP <= CellPtr (freep) + 256) {
vtable = NIL;
save_machine_regs();
longjmp(CompilerBotch,3);
}
common_exps = NULL;
n_common_exps = 0;
cur_branch = onbranch = 0;
branch_pointer = parent_branches;
tmpreg = 0;
nvars = 0;
max_args = 0;
/*
* 2000 added to H in case we need to construct call(G) when G is a
* variable used as a goal
*/
vtable = NIL;
labelno = 0L;
if (IsVarTerm(my_clause)) {
Error_TYPE = INSTANTIATION_ERROR;
Error_Term = my_clause;
ErrorMessage = "in compiling clause";
return (0);
}
if (IsApplTerm(my_clause) && FunctorOfTerm(my_clause) == FunctorAssert) {
head = ArgOfTerm(1, my_clause);
body = ArgOfTerm(2, my_clause);
}
else {
head = my_clause, body = MkAtomTerm(AtomTrue);
}
if (IsVarTerm(head) || IsPairTerm(head) || IsIntTerm(head) || IsFloatTerm(head) || IsRefTerm(head)) {
Error_TYPE = TYPE_ERROR_CALLABLE;
Error_Term = my_clause;
ErrorMessage = "clause should be atom or term";
return (0);
} else {
/* find out which predicate we are compiling for */
if (IsAtomTerm(head)) {
Atom ap = AtomOfTerm(head);
CurrentPred = RepPredProp(PredPropByAtom(ap, mod));
} else {
CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),mod));
}
/* insert extra instructions to count calls */
READ_LOCK(CurrentPred->PRWLock);
if ((CurrentPred->PredFlags & ProfiledPredFlag) ||
(PROFILING && (CurrentPred->FirstClause == NIL)))
profiling = TRUE;
else
profiling = FALSE;
READ_UNLOCK(CurrentPred->PRWLock);
}
/* phase 1 : produce skeleton code and variable information */
c_head(head);
emit(allocate_op, Zero, Zero);
c_body(body, mod);
/* Insert blobs at the very end */
if (BlobsStart != NULL) {
cpc->nextInst = BlobsStart;
BlobsStart = NULL;
}
reset_vars();
H = SaveH;
if (ErrorMessage)
return (0);
#ifdef DEBUG
if (Option['g' - 96])
ShowCode();
#endif
/* phase 2: classify variables and optimize temporaries */
c_layout();
/* Insert blobs at the very end */
if (BlobsStart != NULL) {
cpc->nextInst = BlobsStart;
BlobsStart = NULL;
while (cpc->nextInst != NULL)
cpc = cpc->nextInst;
}
/* eliminate superfluous pop's and unify_var's */
c_optimize(CodeStart);
#ifdef DEBUG
if (Option['f' - 96])
ShowCode();
#endif
/* phase 3: assemble code */
acode = assemble(ASSEMBLING_CLAUSE);
/* check first if there was space for us */
if (acode == NIL) {
/* make sure we have enough space */
reset_vars();
if (!growheap(FALSE)) {
save_machine_regs();
my_clause = Deref(ARG1);
longjmp(CompilerBotch, 2);
return(NULL);
} else {
my_clause = Deref(ARG1);
goto restart_compilation;
}
} else
return(acode);
}
Reference in New Issue View Git Blame Copy Permalink