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