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