YAP 7.1.0
compiler.c
1/*************************************************************************
2* *
3* YAP Prolog *
4* *
5* Yap Prolog was developed at NCCUP - Universidade do Porto *
6* *
7* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8* *
9**************************************************************************
10* *
11* File: compiler.c *
12* comments: Clause compiler *
13* *
14* Last rev: $Date: 2008-08-06 17:32:18 $,$Author: vsc $
15**
16* $Log: not supported by cvs2svn $
17* Revision 1.88 2008/03/13 14:37:58 vsc
18* update chr
19*
20* Revision 1.87 2007/12/18 17:46:58 vsc
21* purge_clauses does not need to do anything if there are no clauses
22* fix gprof bugs.
23*
24* Revision 1.86 2007/11/26 23:43:08 vsc
25* fixes to support threads and assert correctly, even if inefficiently.
26*
27* Revision 1.85 2007/11/06 17:02:11 vsc
28* compile ground terms away.
29*
30* Revision 1.84 2007/03/27 13:48:51 vsc
31* fix number of overflows (comments by Bart Demoen).
32*
33* Revision 1.83 2007/03/26 15:18:43 vsc
34* debugging and clause/3 over tabled predicates would kill YAP.
35*
36* Revision 1.82 2006/11/06 18:35:03 vsc
37* 1estranha
38*
39* Revision 1.81 2006/10/11 15:08:03 vsc
40* fix bb entries
41* comment development code for timestamp overflow.
42*
43* Revision 1.80 2006/09/20 20:03:51 vsc
44* improve indexing on floats
45* fix sending large lists to DB
46*
47* Revision 1.79 2006/08/01 13:14:17 vsc
48* fix compilation of |
49*
50* Revision 1.78 2006/07/27 19:04:56 vsc
51* fix nasty overflows in and add some very preliminary support for very large
52* clauses with lots
53* of disjuncts (eg, query packs).
54*
55* Revision 1.77 2006/05/19 14:31:31 vsc
56* get rid of IntArrays and FloatArray code.
57* include holes when calculating memory usage.
58*
59* Revision 1.76 2006/05/19 13:48:11 vsc
60* help to make Yap work with dynamic libs
61*
62* Revision 1.75 2006/05/16 18:37:30 vsc
63* WIN32 fixes
64* compiler bug fixes
65* extend interface
66*
67* Revision 1.74 2006/04/13 02:04:24 vsc
68* fix debugging typo
69*
70* Revision 1.73 2006/04/12 20:08:51 vsc
71* make it sure that making vars safe does not propagate across branches of
72*disjunctions.
73*
74* Revision 1.72 2006/04/05 00:16:54 vsc
75* Lots of fixes (check logfile for details
76*
77* Revision 1.71 2006/03/24 17:13:41 rslopes
78* New update to BEAM engine.
79* BEAM now uses YAP Indexing (JITI)
80*
81* Revision 1.70 2005/12/17 03:25:39 vsc
82* major changes to support online event-based profiling
83* improve error discovery and restart on scanner.
84*
85* Revision 1.69 2005/09/08 22:06:44 rslopes
86* BEAM for YAP update...
87*
88* Revision 1.68 2005/07/06 15:10:03 vsc
89* improvements to compiler: merged instructions and fixes for ->
90*
91* Revision 1.67 2005/05/25 21:43:32 vsc
92* fix compiler bug in 1 << X, found by Nuno Fonseca.
93* compiler internal errors get their own message.
94*
95* Revision 1.66 2005/05/12 03:36:32 vsc
96* debugger was making predicates meta instead of testing
97* fix handling of dbrefs in facts and in subarguments.
98*
99* Revision 1.65 2005/04/10 04:01:10 vsc
100* bug fixes, I hope!
101*
102* Revision 1.64 2005/03/13 06:26:10 vsc
103* fix excessive pruning in meta-calls
104* fix Term->int breakage in compiler
105* improve JPL (at least it does something now for amd64).
106*
107* Revision 1.63 2005/03/04 20:30:11 ricroc
108* bug fixes for YapTab support
109*
110* Revision 1.62 2005/02/21 16:49:39 vsc
111* amd64 fixes
112* library fixes
113*
114* Revision 1.61 2005/01/28 23:14:35 vsc
115* move to Yap-4.5.7
116* Fix clause size
117*
118* Revision 1.60 2005/01/14 20:55:16 vsc
119* improve register liveness calculations.
120*
121* Revision 1.59 2005/01/04 02:50:21 vsc
122* - allow MegaClauses with blobs
123* - change Diffs to be thread specific
124* - include Christian's updates
125*
126* Revision 1.58 2005/01/03 17:06:03 vsc
127* fix discontiguous stack overflows in parser
128*
129* Revision 1.57 2004/12/20 21:44:57 vsc
130* more fixes to CLPBN
131* fix some Yap overflows.
132*
133* Revision 1.56 2004/12/16 05:57:32 vsc
134* fix overflows
135*
136* Revision 1.55 2004/12/05 05:01:23 vsc
137* try to reduce overheads when running with goal expansion enabled.
138* CLPBN fixes
139* Handle overflows when allocating big clauses properly.
140*
141* Revision 1.54 2004/11/19 22:08:41 vsc
142* replace SYSTEM_ERROR_INTERNAL by out OUT_OF_WHATEVER_ERROR whenever
143*appropriate.
144*
145* Revision 1.53 2004/09/03 03:11:08 vsc
146* memory management fixes
147*
148* Revision 1.52 2004/07/15 17:20:23 vsc
149* fix error message
150* change makefile and configure for clpbn
151*
152* Revision 1.51 2004/06/29 19:04:41 vsc
153* fix multithreaded version
154* include new version of Ricardo's profiler
155* new predicat atomic_concat
156* allow multithreaded-debugging
157* small fixes
158*
159* Revision 1.50 2004/04/22 20:07:04 vsc
160* more fixes for USE_SYSTEM_MEMORY
161*
162* Revision 1.49 2004/03/10 16:27:39 vsc
163* skip compilation steps for ground facts.
164*
165* Revision 1.48 2004/03/08 19:31:01 vsc
166* move to 4.5.3
167* *
168* *
169*************************************************************************/
170#ifdef SCCS
171static char SccsId[] = "%W% %G%";
172
173#endif /* SCCS */
174#include "Yap.h"
175#include "alloc.h"
176#include "clause.h"
177#include "YapCompile.h"
178#include "yapio.h"
179#if HAVE_STRING_H
180#include <string.h>
181#endif
182
183#ifdef BEAM
184extern int EAM;
185// extern PInstr *CodeStart, *ppc, *ppc1, *BodyStart, *ppc_body;
186#endif
187
188typedef struct branch_descriptor {
189 int id; /* the branch id */
190 Term cm; /* if a banch is associated with a commit */
191} branch;
192
193typedef struct compiler_struct_struct {
194 branch parent_branches[256];
195 branch *branch_pointer;
196 PInstr *BodyStart;
197 Ventry *vtable;
198 CExpEntry *common_exps;
199 int is_a_fact;
200 int hasdbrefs;
201 int n_common_exps;
202 int goalno;
203 int onlast;
204 int onhead;
205 int onbranch;
206 int curbranch;
207 Int space_used;
208 PInstr *space_op;
209 Prop current_p0;
210#ifdef TABLING_INNER_CUTS
211 PInstr *cut_mark;
212#endif /* TABLING_INNER_CUTS */
213#ifdef DEBUG
214 int pbvars;
215#endif /* DEBUG */
216 int nvars;
217 UInt labelno;
218 int or_found;
219 UInt max_args;
220 int MaxCTemps;
221 UInt tmpreg;
222 Int vreg;
223 Int vadr;
224 Int *Uses;
225 Term *Contents;
226 int needs_env;
227 CIntermediates cint;
228} compiler_struct;
229
230static int active_branch(int, int);
231static void c_var(Term, Int, unsigned int, unsigned int, compiler_struct *);
232static void reset_vars(Ventry *);
233static Term optimize_ce(Term, unsigned int, unsigned int, compiler_struct *);
234static void c_arg(Int, Term, unsigned int, unsigned int, compiler_struct *);
235static void c_args(Term, unsigned int, compiler_struct *);
236static void c_eq(Term, Term, compiler_struct *);
237static void c_test(Int, Term, compiler_struct *);
238static void c_bifun(basic_preds, Term, Term, Term, Term, Term,
239 compiler_struct *);
240static void c_goal(Term, Term, compiler_struct *);
241static void c_body(Term, Term, compiler_struct *);
242static void c_head(Term, compiler_struct *);
243static bool usesvar(compiler_vm_op);
244static CELL *init_bvarray(int, compiler_struct *);
245#ifdef DEBUG
246static void clear_bvarray(int, CELL *, compiler_struct *);
247#else
248static void clear_bvarray(int, CELL *);
249#endif
250static void add_bvarray_op(PInstr *, CELL *, int, compiler_struct *);
251static void AssignPerm(PInstr *, compiler_struct *);
252static void CheckUnsafe(PInstr *, compiler_struct *);
253static void CheckVoids(compiler_struct *);
254static int checktemp(Int, Int, compiler_vm_op, compiler_struct *);
255static Int checkreg(Int, Int, compiler_vm_op, int, compiler_struct *);
256static void c_layout(compiler_struct *);
257static void c_optimize(PInstr *);
258#ifdef SFUNC
259static void compile_sf_term(Term, int);
260#endif
261
262static void push_branch(int id, Term cmvar, compiler_struct *cglobs) {
263 cglobs->branch_pointer->id = id;
264 cglobs->branch_pointer->cm = cmvar;
265 cglobs->branch_pointer++;
266}
267
268static int pop_branch(compiler_struct *cglobs) {
269 cglobs->branch_pointer--;
270 return (cglobs->branch_pointer->id);
271}
272
273#ifdef TABLING
274#define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
275#endif /* TABLING */
276
277static inline int active_branch(int i, int onbranch) {
278 /* register int *bp;*/
279
280 return (i == onbranch);
281 /* bp = cglobs->branch_pointer;
282 while (bp > parent_branches) {
283 if (*--bp == onbranch)
284 return (TRUE);
285 }
286 return(i==onbranch);*/
287}
288
289#define FAIL(M, T, E) \
290 { \
291 LOCAL_Error_TYPE = T; \
292 return; \
293 }
294
295#if USE_SYSTEM_MALLOC
296#define IsNewVar(v) ((CELL *)(v) >= H0 && (CELL *)(v) < LCL0)
297#else
298#define IsNewVar(v) \
299 (Addr(v) < cglobs->cint.freep0 || Addr(v) > cglobs->cint.freep)
300#endif
301
302inline static void pop_code(unsigned int, compiler_struct *);
303
304inline static void pop_code(unsigned int level, compiler_struct *cglobs) {
305 if (level == 0)
306 return;
307 if (cglobs->cint.cpc->op == pop_op)
308 ++(cglobs->cint.cpc->rnd1);
309 else {
310 Yap_emit(pop_op, One, Zero, &cglobs->cint);
311 }
312}
313
314static void adjust_current_commits(compiler_struct *cglobs) {
315 branch *bp = cglobs->branch_pointer;
316 while (bp > cglobs->parent_branches) {
317 bp--;
318 if (bp->cm != TermNil) {
319 c_var(bp->cm, patch_b_flag, 1, 0, cglobs);
320 }
321 }
322}
323
324static int check_var(Term t, unsigned int level, Int argno,
325 compiler_struct *cglobs) {
326 CACHE_REGS
327 int flags, new = FALSE;
328 Ventry *v = (Ventry *)t;
329
330 if (IsNewVar(v)) { /* new var */
331 v = (Ventry *)Yap_AllocCMem(sizeof(*v), &cglobs->cint);
332#if YAPOR_SBA
333 v->SelfOfVE = 0;
334#else
335 v->SelfOfVE = (CELL)v;
336#endif
337 v->AdrsOfVE = t;
338 *CellPtr(t) = (CELL)v;
339 v->KindOfVE = v->NoOfVE = Unassigned;
340 flags = 0;
341 /* Be careful with eithers. I may make a variable global in a branch,
342 and not in another.
343 a :- (b([X]) ; c), go(X).
344 This variable will not be globalised if we are coming from
345 the second branch.
346
347 I also need to protect the onhead because Luis uses that to
348 optimise unification in the body of a clause, eg
349 a :- (X = 2 ; c), go(X).
350
351 And, yes, there is code like this...
352 */
353 if (((level > 0 || cglobs->onhead) && cglobs->curbranch == 0) ||
354 argno == save_pair_flag || argno == save_appl_flag)
355 flags |= SafeVar;
356 if ((level > 0 && cglobs->curbranch == 0) || argno == save_pair_flag ||
357 argno == save_appl_flag)
358 flags |= GlobalVal;
359 v->FlagsOfVE = flags;
360 v->BranchOfVE = cglobs->onbranch;
361 v->NextOfVE = cglobs->vtable;
362 v->RCountOfVE = 0;
363 v->AgeOfVE = v->FirstOfVE = cglobs->goalno;
364 new = TRUE;
365 cglobs->vtable = v;
366 } else {
367 v->FlagsOfVE |= NonVoid;
368 if (v->BranchOfVE > 0) {
369 if (!active_branch(v->BranchOfVE, cglobs->onbranch)) {
370 v->AgeOfVE = v->FirstOfVE = 1;
371 new = FALSE;
372 v->FlagsOfVE |= BranchVar;
373 /* set the original instruction correctly */
374 switch (v->FirstOpForV->op) {
375 case get_var_op:
376 v->FirstOpForV->op = get_val_op;
377 break;
378 case unify_var_op:
379 v->FirstOpForV->op = unify_val_op;
380 break;
381 case unify_last_var_op:
382 v->FirstOpForV->op = unify_last_val_op;
383 break;
384 case put_var_op:
385 v->FirstOpForV->op = put_val_op;
386 break;
387 case write_var_op:
388 v->FirstOpForV->op = write_val_op;
389 break;
390 default:
391 break;
392 }
393 }
394 }
395 }
396 if (cglobs->onhead)
397 v->FlagsOfVE |= OnHeadFlag;
398 return new;
399}
400
401static void tag_var(Term t, int new, compiler_struct *cglobs) {
402 Ventry *v = (Ventry *)t;
403
404 if (new) {
405 v->FirstOpForV = cglobs->cint.cpc;
406 }
407 v->LastOpForV = cglobs->cint.cpc;
408 ++(v->RCountOfVE);
409 if (cglobs->onlast)
410 v->FlagsOfVE |= OnLastGoal;
411 if (v->AgeOfVE < cglobs->goalno)
412 v->AgeOfVE = cglobs->goalno;
413}
414
415static void c_var(Term t, Int argno, unsigned int arity, unsigned int level,
416 compiler_struct *cglobs) {
417 int new = check_var(Deref(t), level, argno, cglobs);
418 t = Deref(t);
419
420 switch (argno) {
421 case save_b_flag:
422 Yap_emit(save_b_op, t, Zero, &cglobs->cint);
423 break;
424 case commit_b_flag:
425 Yap_emit(commit_b_op, t, Zero, &cglobs->cint);
426 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
427 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
428 break;
429 case soft_cut_b_flag:
430 Yap_emit(soft_cut_b_op, t, Zero, &cglobs->cint);
431 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
432 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
433 break;
434 case patch_b_flag:
435 Yap_emit(patch_b_op, t, 0, &cglobs->cint);
436 break;
437 case save_pair_flag:
438 Yap_emit(save_pair_op, t, 0, &cglobs->cint);
439 break;
440 case save_appl_flag:
441 Yap_emit(save_appl_op, t, 0, &cglobs->cint);
442 break;
443 case f_flag:
444 if (new) {
445 ++cglobs->nvars;
446 Yap_emit(f_var_op, t, (CELL)arity, &cglobs->cint);
447 } else {
448 Yap_emit(f_val_op, t, (CELL)arity, &cglobs->cint);
449 }
450 break;
451 default:
452#ifdef SFUNC
453 if (argno < 0) {
454 if (new)
455 Yap_emit((cglobs->onhead ? unify_s_var_op : write_s_var_op), v, -argno,
456 &cglobs->cint);
457 else
458 Yap_emit((cglobs->onhead ? unify_s_val_op : write_s_val_op), v, -argno,
459 &cglobs->cint);
460 } else
461#endif
462 if (cglobs->onhead) {
463 cglobs->space_used++;
464 if (level == 0)
465 Yap_emit((new ? (++cglobs->nvars, get_var_op) : get_val_op), t, argno,
466 &cglobs->cint);
467 else
468 Yap_emit(
469 (new ? (++cglobs->nvars,
470 (argno == (Int)arity ? unify_last_var_op : unify_var_op))
471 : (argno == (Int)arity ? unify_last_val_op : unify_val_op)),
472 t, Zero, &cglobs->cint);
473 } else {
474 if (level == 0)
475 Yap_emit((new ? (++cglobs->nvars, put_var_op) : put_val_op), t, argno,
476 &cglobs->cint);
477 else
478 Yap_emit((new ? (++cglobs->nvars, write_var_op) : write_val_op), t,
479 Zero, &cglobs->cint);
480 }
481 }
482 tag_var(t, new, cglobs);
483}
484
485// built-in like X >= Y.
486static void c_2vars(int op, Term t1, Int argno1, Term t2, Int argno2,
487 CELL extra, unsigned int arity, unsigned int level,
488 compiler_struct *cglobs) {
489 int new1 = check_var((t1 = Deref(t1)), level, argno1, cglobs);
490 int new2 = check_var((t2 = Deref(t2)), level, argno2, cglobs);
491
492 switch (op) {
493 case bt_flag:
494 Yap_emit_5ops(bccall_op, t1, argno1, t2, argno2, extra, &cglobs->cint);
495 break;
496 default:
497 return;
498 }
499 tag_var(t1, new1, cglobs);
500 tag_var(t2, new2, cglobs);
501}
502
503static void reset_vars(Ventry *vtable) {
504 Ventry *v = vtable;
505 CELL *t;
506
507 while (v != NIL) {
508 t = (CELL *)v->AdrsOfVE;
509 RESET_VARIABLE(t);
510 v = v->NextOfVE;
511 }
512}
513
514static Term optimize_ce(Term t, unsigned int arity, unsigned int level,
515 compiler_struct *cglobs) {
516 CACHE_REGS
517 CExpEntry *p = cglobs->common_exps;
518 int cmp = 0;
519 return t;
520#ifdef BEAM
521 if (EAM)
522 return t;
523#endif
524 Functor f;
525 if (IsApplTerm(t) &&( IsExtensionFunctor((f =FunctorOfTerm(t))) ||
526 f == FunctorOr
527 || f == FunctorArrow
528 || f == FunctorSoftCut
529 || f == FunctorComma))
530 return (t);
531 while (p != NULL) {
532 CELL *oldH = HR;
533 HR = (CELL *)cglobs->cint.freep;
534 cmp = Yap_compare_terms(t, (p->TermOfCE));
535 HR = oldH;
536
537 if (cmp) {
538 p = p->NextCE;
539 } else {
540 break;
541 }
542 }
543 if (p != NULL) { /* already there */
544 return (p->VarOfCE);
545 }
546 /* first occurrence */
547 if (cglobs->onbranch || level > 1) {
548 return t;
549 }
550 ++(cglobs->n_common_exps);
551 p = (CExpEntry *)Yap_AllocCMem(sizeof(CExpEntry), &cglobs->cint);
552
553 p->TermOfCE = t;
554 p->VarOfCE = MkVarTerm();
555 if (HR >= (CELL *)cglobs->cint.freep0) {
556 /* oops, too many new variables */
557 save_machine_regs();
558 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
559 }
560 p->NextCE = cglobs->common_exps;
561 cglobs->common_exps = p;
562 if (IsApplTerm(t))
563 c_var(p->VarOfCE, save_appl_flag, arity, level, cglobs);
564 else if (IsPairTerm(t))
565 c_var(p->VarOfCE, save_pair_flag, arity, level, cglobs);
566 return (t);
567}
568
569#ifdef SFUNC
570static void compile_sf_term(Term t, int argno, int level) {
571 Functor f = FunctorOfTerm(t);
572 CELL *p = ArgsOfSFTerm(t) - 1;
573 SFEntry *pe = RepSFProp(Yap_GetAProp(NameOfFunctor(f), SFProperty));
574 Term nullvalue = pe->NilValue;
575
576 if (level == 0)
577 Yap_emit((cglobs->onhead ? get_s_f_op : put_s_f_op), f, argno,
578 &cglobs->cint);
579 else
580 Yap_emit((cglobs->onhead ? unify_s_f_op : write_s_f_op), f, Zero,
581 &cglobs->cint);
582 ++level;
583 while ((argno = *++p)) {
584 t = Derefa(++p);
585 if (t != nullvalue) {
586 if (IsAtomicTerm(t))
587 Yap_emit((cglobs->onhead ? unify_s_a_op : write_s_a_op), t, (CELL)argno,
588 &cglobs->cint);
589 else if (!IsVarTerm(t)) {
590 Yap_ThrowError(SYSTEM_ERROR_COMPILER, t, "illegal argument of soft functor");
591 save_machine_regs();
592 siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
593 } else
594 c_var(t, -argno, arity, level, cglobs);
595 }
596 }
597 --level;
598 if (level == 0)
599 Yap_emit((cglobs->onhead ? get_s_end_op : put_s_end_op), Zero, Zero,
600 &cglobs->cint);
601 else
602 Yap_emit((cglobs->onhead ? unify_s_end_op : write_s_end_op), Zero, Zero,
603 &cglobs->cint);
604}
605#endif
606
607inline static void c_args(Term app, unsigned int level,
608 compiler_struct *cglobs) {
609 CACHE_REGS
610 Functor f = FunctorOfTerm(app);
611 unsigned int Arity = ArityOfFunctor(f);
612 unsigned int i;
613
614 if (level == 0) {
615 if (Arity >= MaxTemps) {
616 Yap_ThrowError( SYSTEM_ERROR_COMPILER, app, "exceed maximum arity (%ud) of compiled goal", MaxTemps);
617 save_machine_regs();
618 siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
619 }
620 if (Arity > cglobs->max_args)
621 cglobs->max_args = Arity;
622 }
623 for (i = 1; i <= Arity; ++i)
624 c_arg(i, ArgOfTerm(i, app), Arity, level, cglobs);
625}
626
627static int try_store_as_dbterm(Term t, Int argno, unsigned int arity, int level,
628 compiler_struct *cglobs) {
629 CACHE_REGS
630 DBTerm *dbt;
631 int g;
632 CELL *h0 = HR;
633return false;
634 while ((g = Yap_SizeGroundTerm(t, TRUE)) < 0) {
635 /* oops, too deep a term */
636 Yap_ThrowError( SYSTEM_ERROR_COMPILER, g, "exceeds maximum ground term depth");
637 save_machine_regs();
638 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH);
639 }
640 // if (g < 16)
641 return FALSE;
642 /* store ground term away */
643 HR = CellPtr(cglobs->cint.freep);
644 if ((dbt = Yap_StoreTermInDB(t, -1)) == NULL) {
645 HR = h0;
646 switch (LOCAL_Error_TYPE) {
647 case RESOURCE_ERROR_STACK:
648 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, "while optimising ground term");
649 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_STACK_BOTCH);
650 break;
651 case RESOURCE_ERROR_TRAIL:
652 Yap_ThrowError(RESOURCE_ERROR_TRAIL, TermNil, "while optimising ground term");
653 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TRAIL_BOTCH);
654 break;
655 case RESOURCE_ERROR_HEAP:
656 Yap_ThrowError(RESOURCE_ERROR_HEAP, TermNil, "while optimising ground term");
657 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
658 break;
659 case RESOURCE_ERROR_AUXILIARY_STACK:
660 Yap_ThrowError(RESOURCE_ERROR_AUXILIARY_STACK, TermNil, "while optimising ground term");
661 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH);
662 break;
663 default:
664 Yap_ThrowError(LOCAL_Error_TYPE, TermNil, "while optimising ground term");
665
666 }
667 }
668 HR = h0;
669 if (level == 0)
670 Yap_emit((cglobs->onhead ? get_dbterm_op : put_dbterm_op), dbt->Entry,
671 argno, &cglobs->cint);
672 else
673 Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_dbterm_op
674 : unify_dbterm_op)
675 : write_dbterm_op),
676 dbt->Entry, Zero, &cglobs->cint);
677 return TRUE;
678}
679
680static void c_arg(Int argno, Term t, unsigned int arity, unsigned int level,
681 compiler_struct *cglobs) {
682restart:
683 if (IsVarTerm(t))
684 c_var(t, argno, arity, level, cglobs);
685 else if (IsAtomTerm(t)) {
686 if (level == 0) {
687 Yap_emit((cglobs->onhead ? get_atom_op : put_atom_op), (CELL)t, argno,
688 &cglobs->cint);
689 } else
690 Yap_emit((cglobs->onhead
691 ? (argno == (Int)arity ? unify_last_atom_op : unify_atom_op)
692 : write_atom_op),
693 (CELL)t, Zero, &cglobs->cint);
694 } else if (IsIntegerTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t) ||
695 IsStringTerm(t)) {
696 if (!IsIntTerm(t)) {
697 if (IsFloatTerm(t)) {
698 if (level == 0)
699 Yap_emit((cglobs->onhead ? get_float_op : put_float_op), t, argno,
700 &cglobs->cint);
701 else
702 Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_float_op
703 : unify_float_op)
704 : write_float_op),
705 t, Zero, &cglobs->cint);
706 } else if (IsLongIntTerm(t)) {
707 if (level == 0)
708 Yap_emit((cglobs->onhead ? get_longint_op : put_longint_op), t, argno,
709 &cglobs->cint);
710 else
711 Yap_emit((cglobs->onhead
712 ? (argno == (Int)arity ? unify_last_longint_op
713 : unify_longint_op)
714 : write_longint_op),
715 t, Zero, &cglobs->cint);
716 } else if (IsStringTerm(t)) {
717 /* we are taking a string, that is supposed to be
718 guarded in the clause itself. . */
719 CELL l1 = ++cglobs->labelno;
720 CELL *src = RepAppl(t);
721 PInstr *ocpc = cglobs->cint.cpc, *OCodeStart = cglobs->cint.CodeStart;
722 Int sz = (3 + src[1]) * sizeof(CELL);
723 CELL *dest;
724
725 /* use a special list to store the blobs */
726 cglobs->cint.cpc = cglobs->cint.icpc;
727 /* if (IsFloatTerm(t)) {
728 Yap_emit(align_float_op, Zero, Zero, &cglobs->cint);
729 }*/
730 Yap_emit(label_op, l1, Zero, &cglobs->cint);
731 dest = Yap_emit_extra_size(blob_op, sz / CellSize, sz, &cglobs->cint);
732
733 /* copy the bignum */
734 memcpy(dest, src, sz);
735 /* note that we don't need to copy size info, unless we wanted
736 to garbage collect clauses ;-) */
737 cglobs->cint.icpc = cglobs->cint.cpc;
738 if (cglobs->cint.BlobsStart == NULL)
739 cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
740 cglobs->cint.cpc = ocpc;
741 cglobs->cint.CodeStart = OCodeStart;
742 /* The argument to pass to the structure is now the label for
743 where we are storing the blob */
744 if (level == 0)
745 Yap_emit((cglobs->onhead ? get_string_op : put_string_op), l1, argno,
746 &cglobs->cint);
747 else
748 Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_string_op
749 : unify_string_op)
750 : write_string_op),
751 l1, Zero, &cglobs->cint);
752 } else {
753 /* we are taking a blob, that is a binary that is supposed to be
754 guarded in the clause itself. Possible examples include
755 floats, long ints, bignums, bitmaps.... */
756 CELL l1 = ++cglobs->labelno;
757 CELL *src = RepAppl(t);
758 PInstr *ocpc = cglobs->cint.cpc, *OCodeStart = cglobs->cint.CodeStart;
759 Int sz =
760 2 * sizeof(CELL) + sizeof(Functor) + sizeof(MP_INT) +
761 ((((MP_INT *)(RepAppl(t) + 2))->_mp_alloc) * sizeof(mp_limb_t));
762 CELL *dest;
763
764 /* use a special list to store the blobs */
765 cglobs->cint.cpc = cglobs->cint.icpc;
766 /* if (IsFloatTerm(t)) {
767 Yap_emit(align_float_op, Zero, Zero, &cglobs->cint);
768 }*/
769 Yap_emit(label_op, l1, Zero, &cglobs->cint);
770 dest = Yap_emit_extra_size(blob_op, sz / CellSize, sz, &cglobs->cint);
771
772 /* copy the bignum */
773 memcpy(dest, src, sz);
774 /* note that we don't need to copy size info, unless we wanted
775 to garbage collect clauses ;-) */
776 cglobs->cint.icpc = cglobs->cint.cpc;
777 if (cglobs->cint.BlobsStart == NULL)
778 cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
779 cglobs->cint.cpc = ocpc;
780 cglobs->cint.CodeStart = OCodeStart;
781 /* The argument to pass to the structure is now the label for
782 where we are storing the blob */
783 if (level == 0)
784 Yap_emit((cglobs->onhead ? get_bigint_op : put_bigint_op), l1, argno,
785 &cglobs->cint);
786 else
787 Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_bigint_op
788 : unify_bigint_op)
789 : write_bigint_op),
790 l1, Zero, &cglobs->cint);
791 }
792 /* That's it folks! */
793 return;
794 }
795 if (level == 0)
796 Yap_emit((cglobs->onhead ? get_num_op : put_num_op), (CELL)t, argno,
797 &cglobs->cint);
798 else
799 Yap_emit((cglobs->onhead
800 ? (argno == (Int)arity ? unify_last_num_op : unify_num_op)
801 : write_num_op),
802 (CELL)t, Zero, &cglobs->cint);
803 } else if (IsPairTerm(t)) {
804 cglobs->space_used += 2;
805 if (optimizer_on && level < 6) {
806#if !defined(THREADS) && !defined(YAPOR)
807 /* discard code sharing because we cannot write on shared stuff */
808 if (FALSE &&
809 !(cglobs->cint.CurrentPred->PredFlags &
810 (DynamicPredFlag | LogUpdatePredFlag))) {
811 if (try_store_as_dbterm(t, argno, arity, level, cglobs))
812 return;
813 }
814#endif
815 t = optimize_ce(t, arity, level, cglobs);
816 if (IsVarTerm(t)) {
817 c_var(t, argno, arity, level, cglobs);
818 return;
819 }
820 }
821 if (level == 0)
822 Yap_emit((cglobs->onhead ? get_list_op : put_list_op), Zero, argno,
823 &cglobs->cint);
824 else if (argno == (Int)arity)
825 Yap_emit((cglobs->onhead ? unify_last_list_op : write_last_list_op), Zero,
826 Zero, &cglobs->cint);
827 else
828 Yap_emit((cglobs->onhead ? unify_list_op : write_list_op), Zero, Zero,
829 &cglobs->cint);
830 ++level;
831 c_arg(1, HeadOfTerm(t), 2, level, cglobs);
832 if (argno == (Int)arity) {
833 /* optimise for tail recursion */
834 t = TailOfTerm(t);
835 goto restart;
836 }
837 c_arg(2, TailOfTerm(t), 2, level, cglobs);
838 --level;
839 if (argno != (Int)arity) {
840 pop_code(level, cglobs);
841 }
842 } else if (IsRefTerm(t)) {
843 PELOCK(40, cglobs->cint.CurrentPred);
844 if (!(cglobs->cint.CurrentPred->PredFlags &
845 (DynamicPredFlag | LogUpdatePredFlag))) {
846 CACHE_REGS
847 UNLOCK(cglobs->cint.CurrentPred->PELock);
848 FAIL("can not compile data base reference", TYPE_ERROR_CALLABLE, t);
849 } else {
850 UNLOCK(cglobs->cint.CurrentPred->PELock);
851 cglobs->hasdbrefs = TRUE;
852 if (level == 0)
853 Yap_emit((cglobs->onhead ? get_atom_op : put_atom_op), (CELL)t, argno,
854 &cglobs->cint);
855 else
856 Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_atom_op
857 : unify_atom_op)
858 : write_atom_op),
859 (CELL)t, Zero, &cglobs->cint);
860 }
861 } else {
862
863#ifdef SFUNC
864 if (SFTerm(t)) {
865 compile_sf_term(t, argno);
866 return;
867 }
868#endif
869
870 if (optimizer_on) {
871 if (!(cglobs->cint.CurrentPred->PredFlags &
872 (DynamicPredFlag | LogUpdatePredFlag))) {
873 if (try_store_as_dbterm(t, argno, arity, level, cglobs))
874 return;
875 }
876 t = optimize_ce(t, arity, level, cglobs);
877 if (IsVarTerm(t)) {
878 c_var(t, argno, arity, level, cglobs);
879 return;
880 }
881 }
882 cglobs->space_used += 1 + arity;
883 if (level == 0)
884 Yap_emit((cglobs->onhead ? get_struct_op : put_struct_op),
885 (CELL)FunctorOfTerm(t), argno, &cglobs->cint);
886 else if (argno == (Int)arity)
887 Yap_emit((cglobs->onhead ? unify_last_struct_op : write_last_struct_op),
888 (CELL)FunctorOfTerm(t), Zero, &cglobs->cint);
889 else
890 Yap_emit((cglobs->onhead ? unify_struct_op : write_struct_op),
891 (CELL)FunctorOfTerm(t), Zero, &cglobs->cint);
892 ++level;
893 c_args(t, level, cglobs);
894 --level;
895 if (argno != (Int)arity) {
896 pop_code(level, cglobs);
897 }
898 }
899}
900
901static void c_eq(Term t1, Term t2, compiler_struct *cglobs) {
902 CACHE_REGS
903 if (t1 == t2) {
904 Yap_emit(nop_op, Zero, Zero, &cglobs->cint);
905 return;
906 }
907 if (IsNonVarTerm(t1)) {
908 if (IsVarTerm(t2)) {
909 Term t = t1;
910 t1 = t2;
911 t2 = t;
912 } else {
913 /* compile unification */
914 if (IsAtomicTerm(t1)) {
915 /* just check if they unify */
916 if (!IsAtomicTerm(t2) || !Yap_unify(t1, t2)) {
917 /* they don't */
918 Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
919 return;
920 }
921 /* they do */
922 Yap_emit(nop_op, Zero, Zero, &cglobs->cint);
923 return;
924 } else if (IsPairTerm(t1)) {
925 /* just check if they unify */
926 if (!IsPairTerm(t2)) {
927 /* they don't */
928 Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
929 return;
930 }
931 /* they might */
932 c_eq(HeadOfTerm(t1), HeadOfTerm(t2), cglobs);
933 c_eq(TailOfTerm(t1), TailOfTerm(t2), cglobs);
934 return;
935 } else if (IsRefTerm(t1)) {
936 /* just check if they unify */
937 if (t1 != t2) {
938 /* they don't */
939 Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
940 return;
941 }
942 /* they do */
943 Yap_emit(nop_op, Zero, Zero, &cglobs->cint);
944 return;
945 } else {
946 /* compound terms */
947 Functor f = FunctorOfTerm(t1);
948 UInt i, max;
949 /* just check if they unify */
950 if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
951 /* they don't */
952 Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
953 return;
954 }
955 /* they might */
956 max = ArityOfFunctor(f);
957 for (i = 0; i < max; i++) {
958 c_eq(ArgOfTerm(i + 1, t1), ArgOfTerm(i + 1, t2), cglobs);
959 }
960 return;
961 }
962 }
963 }
964 /* first argument is an unbound var */
965 if (IsNewVar(t1) && !IsVarTerm(t2) &&
966 !(cglobs->cint.CurrentPred->PredFlags & TabledPredFlag)) {
967 Int v;
968
969 v = --cglobs->tmpreg;
970 c_arg(v, t2, 0, 0, cglobs);
971 cglobs->onhead = TRUE;
972 c_var(t1, v, 0, 0, cglobs);
973 cglobs->onhead = FALSE;
974 } else {
975 if (IsVarTerm(t2)) {
976 c_var(t1, 0, 0, 0, cglobs);
977 cglobs->onhead = TRUE;
978 c_var(t2, 0, 0, 0, cglobs);
979 } else {
980 Int v = --cglobs->tmpreg;
981 c_var(t1, v, 0, 0, cglobs);
982 cglobs->onhead = TRUE;
983 c_arg(v, t2, 0, 0, cglobs);
984 }
985 cglobs->onhead = FALSE;
986 }
987}
988
989static void c_test(Int Op, Term t1, compiler_struct *cglobs) {
990 CACHE_REGS
991 Term t = Deref(t1);
992
993 /* be caareful, has to be first occurrence */
994 if (Op == _save_by) {
995 if (!IsNewVar(t)) {
996 Term tn = MkVarTerm();
997 c_var(tn, save_b_flag, 1, 0, cglobs);
998 c_eq(t, tn, cglobs);
999 } else {
1000 c_var(t, save_b_flag, 1, 0, cglobs);
1001 }
1002 return;
1003 }/*
1004
1005 char s[32];
1006
1007 LOCAL_Error_TYPE = UNINSTANTIATION_ERROR;
1008 Yap_bip_name(Op, s);
1009 sprintf(LOCAL_ErrorMessage, "compiling %s/2 on bound variable", s);
1010 save_machine_regs();
1011 siglongjmp(cglobs->cint.CompilerBotch, 1);
1012 }
1013 c_var(t, save_b_flag, 1, 0, cglobs);
1014 return;
1015 }*/
1016if (!IsVarTerm(t) || IsNewVar(t)) {
1017 Term tn = MkVarTerm();
1018 c_eq(t, tn, cglobs);
1019 t = tn;
1020 }
1021 if (Op == _cut_by)
1022 c_var(t, commit_b_flag, 1, 0, cglobs);
1023 else if (Op == _soft_cut_by)
1024 c_var(t, soft_cut_b_flag, 1, 0, cglobs);
1025 else
1026 c_var(t, f_flag, (unsigned int)Op, 0, cglobs);
1027}
1028
1029/* Arithmetic builtins will be compiled in the form:
1030
1031 fetch_args_vv Xi,Xj
1032 put_val Xi,Ri
1033 put_val Xj,Rj
1034 put_var Xk,Ak
1035 bip_body Op,Xk
1036
1037The put_var should always be disposable, and the put_vals can be disposed of if
1038R is an X.
1039This, in the best case, Ri and Rj are WAM temp registers and this will reduce
1040to:
1041
1042 bip Op,Ak,Ri,Rj
1043
1044meaning a single WAM op will call the clause.
1045
1046
1047If one of the arguments is a constant, the result will be:
1048
1049 fetch_args_vc Xi,C
1050 put_val Xi,Ri
1051 put_var Xk,Ak
1052 bip_body Op,Xk
1053
1054and this should reduce to :
1055
1056bip_cons Op,Xk,Ri,C
1057
1058 */
1059static void c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal,
1060 Term mod, compiler_struct *cglobs) {
1061 CACHE_REGS
1062 /* compile Z = X Op Y arithmetic function */
1063 /* first we fetch the arguments */
1064
1065 if (IsVarTerm(t1)) {
1066 if (IsVarTerm(t2)) {
1067 /* first temp */
1068 Int v1 = --cglobs->tmpreg;
1069 /* second temp */
1070 Int v2 = --cglobs->tmpreg;
1071
1072 Yap_emit(fetch_args_vv_op, Zero, Zero, &cglobs->cint);
1073 /* these should be the arguments */
1074 c_var(t1, v1, 0, 0, cglobs);
1075 c_var(t2, v2, 0, 0, cglobs);
1076 /* now we know where the arguments are */
1077 } else {
1078 if (Op == _arg) {
1079 /* we know the second argument is bound */
1080 if (IsPrimitiveTerm(t2) || IsNumTerm(t2)) {
1081 Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
1082 return;
1083 } else {
1084 Term tn = MkVarTerm();
1085 Int v1 = --cglobs->tmpreg;
1086 Int v2 = --cglobs->tmpreg;
1087
1088 c_eq(t2, tn, cglobs);
1089 Yap_emit(fetch_args_vv_op, Zero, Zero, &cglobs->cint);
1090 /* these should be the arguments */
1091 c_var(t1, v1, 0, 0, cglobs);
1092 c_var(tn, v2, 0, 0, cglobs);
1093 }
1094 /* it has to be either an integer or a floating point */
1095 } else if (IsIntegerTerm(t2)) {
1096 /* first temp */
1097 Int v1 = 0;
1098
1099 Yap_emit(fetch_args_vi_op, IntegerOfTerm(t2), 0L, &cglobs->cint);
1100 /* these should be the arguments */
1101 c_var(t1, v1, 0, 0, cglobs);
1102 /* now we know where the arguments are */
1103 } else {
1104 char s[32];
1105
1106 Yap_bip_name(Op, s);
1107 Yap_do_warning(TYPE_ERROR_NUMBER, t2,
1108 "compiling %s/2 with output bound", s);
1109 goto default_code;
1110 }
1111 }
1112 } else { /* t1 is bound */
1113 /* it has to be either an integer or a floating point */
1114 if (IsVarTerm(t2)) {
1115 if (IsNewVar(t2)) {
1116 char s[32];
1117
1118 Yap_bip_name(Op, s);
1119 Yap_do_warning(INSTANTIATION_ERROR, t2,"compiling %s/3", s);
1120 goto default_code;
1121 }
1122 } else {
1123 if (Op == _functor) {
1124 /* both arguments are bound, we must perform unification */
1125 Int i2;
1126
1127 if (!IsIntegerTerm(t2)) {
1128 Yap_do_warning(TYPE_ERROR_INTEGER, t2, "compiling functor/3", NULL);
1129 goto default_code;
1130
1131 }
1132 i2 = IntegerOfTerm(t2);
1133 if (i2 < 0) {
1134
1135 Yap_do_warning(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2,
1136 "compiling functor/3", NULL);
1137 goto default_code;
1138 }
1139 if (IsNumTerm(t1)) {
1140 /* we will always fail */
1141 if (i2)
1142 c_goal(MkAtomTerm(AtomFalse), mod, cglobs);
1143 } else if (!IsAtomTerm(t1)) {
1144 char s[32];
1145
1146 Yap_bip_name(Op, s);
1147 Yap_do_warning(TYPE_ERROR_ATOM, t2, "compiling functor/3", NULL);
1148 goto default_code;
1149 }
1150 if (i2 == 0)
1151 c_eq(t1, t3, cglobs);
1152 else {
1153 CELL *hi = HR;
1154 Int i;
1155
1156 if (t1 == TermDot && i2 == 2) {
1157 if (HR + 2 >= (CELL *)cglobs->cint.freep0) {
1158 /* oops, too many new variables */
1159 save_machine_regs();
1160 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1161 }
1162 RESET_VARIABLE(HR);
1163 RESET_VARIABLE(HR + 1);
1164 HR += 2;
1165 c_eq(AbsPair(HR - 2), t3, cglobs);
1166 } else if (i2 < 256 && IsAtomTerm(t1)) {
1167 *HR++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1), i2);
1168 for (i = 0; i < i2; i++) {
1169 if (HR >= (CELL *)cglobs->cint.freep0) {
1170 /* oops, too many new variables */
1171 save_machine_regs();
1172 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1173 }
1174 RESET_VARIABLE(HR);
1175 HR++;
1176 }
1177 c_eq(AbsAppl(hi), t3, cglobs);
1178 } else {
1179 /* compile as default */
1180 Functor f = FunctorOfTerm(Goal);
1181 Prop p0 = PredPropByFunc(f, mod);
1182 if (EndOfPAEntr(p0)) {
1183 save_machine_regs();
1184 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
1185 }
1186 c_args(Goal, 0, cglobs);
1187 Yap_emit(safe_call_op, (CELL)p0, Zero, &cglobs->cint);
1188 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
1189 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1190 return;
1191 }
1192 }
1193 } else if (Op == _arg) {
1194 Int i1;
1195 if (IsIntegerTerm(t1))
1196 i1 = IntegerOfTerm(t1);
1197 else {
1198 char s[32];
1199
1200 Yap_bip_name(Op, s);
1201 Yap_do_warning(TYPE_ERROR_INTEGER, t1, "compiling %s/2", s);
1202 goto default_code;
1203 }
1204 if (IsAtomicTerm(t2) ||
1205 (IsApplTerm(t2) && IsExtensionFunctor(FunctorOfTerm(t2)))) {
1206 char s[32];
1207
1208 Yap_bip_name(Op, s);
1209 Yap_do_warning(TYPE_ERROR_COMPOUND, t2, "compiling %s/2", s);
1210
1211 goto default_code;
1212 } else if (IsApplTerm(t2)) {
1213 Functor f = FunctorOfTerm(t2);
1214 if (i1 < 1 || i1 > ArityOfFunctor(f)) {
1215 c_goal(MkAtomTerm(AtomFalse), mod, cglobs);
1216 } else {
1217 c_eq(ArgOfTerm(i1, t2), t3, cglobs);
1218 }
1219 return;
1220 } else if (IsPairTerm(t2)) {
1221 switch (i1) {
1222 case 1:
1223 c_eq(HeadOfTerm(t2), t3, cglobs);
1224 return;
1225 case 2:
1226 c_eq(TailOfTerm(t2), t3, cglobs);
1227 return;
1228 default:
1229 c_goal(MkAtomTerm(AtomFalse), mod, cglobs);
1230 return;
1231 }
1232 }
1233 } else {
1234 char s[32];
1235
1236 Yap_bip_name(Op, s);
1237 Yap_do_warning(TYPE_ERROR_INTEGER, t2, "compiling %s", s);
1238 goto default_code;
1239 }
1240 }
1241 if (Op == _functor) {
1242 if (!IsAtomicTerm(t1)) {
1243 char s[32];
1244
1245 Yap_bip_name(Op, s);
1246 Yap_do_warning(TYPE_ERROR_ATOM, t1, "compiling %s", s);
1247 goto default_code;
1248 } else {
1249 if (!IsVarTerm(t2)) {
1250 Int arity;
1251
1252 /* We actually have the term ready, so let's just do the unification
1253 * now */
1254 if (!IsIntegerTerm(t2)) {
1255 char s[32];
1256
1257 Yap_bip_name(Op, s);
1258 Yap_do_warning(TYPE_ERROR_INTEGER, t2, "compiling %s" , s);
1259 goto default_code;
1260 }
1261 arity = IntOfTerm(t2);
1262 if (arity < 0) {
1263 /* fail straight away */
1264 Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
1265 }
1266 if (arity) {
1267 Term tnew;
1268 if (!IsAtomTerm(t1)) {
1269 char s[32];
1270
1271 Yap_bip_name(Op, s);
1272 Yap_do_warning(TYPE_ERROR_INTEGER, t1, "compiling %s", s);
1273 goto default_code;
1274 }
1275 if (HR + 1 + arity >= (CELL *)cglobs->cint.freep0) {
1276 /* oops, too many new variables */
1277 save_machine_regs();
1278 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1279 }
1280 tnew = AbsAppl(HR);
1281 *HR++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1), arity);
1282 while (arity--) {
1283 RESET_VARIABLE(HR);
1284 HR++;
1285 }
1286 c_eq(tnew, t3, cglobs);
1287 } else {
1288 /* just unify the two arguments */
1289 c_eq(t1, t3, cglobs);
1290 }
1291 return;
1292 } else {
1293 /* first temp */
1294 Int v1 = 0;
1295 Yap_emit(fetch_args_cv_op, t1, Zero, &cglobs->cint);
1296 /* these should be the arguments */
1297 c_var(t2, v1, 0, 0, cglobs);
1298 /* now we know where the arguments are */
1299 }
1300 }
1301 } else if (IsIntegerTerm(t1)) {
1302 /* first temp */
1303 Int v1 = 0;
1304 Yap_emit(fetch_args_iv_op, IntegerOfTerm(t1), 0L, &cglobs->cint);
1305 /* these should be the arguments */
1306 c_var(t2, v1, 0, 0, cglobs);
1307 /* now we know where the arguments are */
1308 } else {
1309 char s[32];
1310
1311 Yap_bip_name(Op, s);
1312 Yap_do_warning(UNINSTANTIATION_ERROR, t1, "compiling %s/2 with output bound", s);
1313 goto default_code;
1314 }
1315 }
1316 /* then we compile the opcode/result */
1317 if (!IsVarTerm(t3)) {
1318 if (Op == _arg) {
1319 Term tmpvar = MkVarTerm();
1320 if (HR == (CELL *)cglobs->cint.freep0) {
1321 /* oops, too many new variables */
1322 save_machine_regs();
1323 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1324 }
1325 c_var(tmpvar, f_flag, (unsigned int)Op, 0, cglobs);
1326 c_eq(tmpvar, t3, cglobs);
1327 } else {
1328 char s[32];
1329
1330 Yap_bip_name(Op, s);
1331 Yap_do_warning(UNINSTANTIATION_ERROR, t1, "compiling %s/2 with output bound", s);
1332 goto default_code;
1333
1334 }
1335 } else if (IsNewVar(t3) && cglobs->curbranch == 0 &&
1336 cglobs->cint.CurrentPred->PredFlags & TabledPredFlag) {
1337 Term nv = MkVarTerm();
1338 c_var(nv, f_flag, (unsigned int)Op, 0, cglobs);
1339 if (Op == _functor) {
1340 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
1341 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1342 }
1343 /* make sure that we first get the true t3, and then bind it to nv. That way
1344 * it will be confitional */
1345 c_eq(t3, nv, cglobs);
1346 } else if (
1347 IsNewVar(t3) &&
1348 cglobs->curbranch ==
1349 0 /* otherwise you may have trouble with z(X) :- ( Z is X*2 ; write(Z)) */) {
1350 c_var(t3, f_flag, (unsigned int)Op, 0, cglobs);
1351 if (Op == _functor) {
1352 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
1353 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1354 }
1355 } else {
1356 /* generate code for a temp and then unify temp with previous variable */
1357 Yap_emit(f_0_op, 0, (unsigned int)Op, &cglobs->cint);
1358 /* I have to do it here, before I do the unification */
1359 if (Op == _functor) {
1360 Yap_emit(empty_call_op, Zero, (unsigned int)Op, &cglobs->cint);
1361 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1362 }
1363 cglobs->onhead = TRUE;
1364 c_var(t3, 0, 0, 0, cglobs);
1365 cglobs->onhead = FALSE;
1366 }
1367 return;
1368 default_code:
1369 c_goal(Yap_MkApplTerm(FunctorCall,1,&Goal), mod, cglobs);
1370
1371}
1372
1373static void c_functor(Term Goal, Term mod, compiler_struct *cglobs) {
1374 CACHE_REGS
1375 Term t1 = ArgOfTerm(1, Goal);
1376 Term t2 = ArgOfTerm(2, Goal);
1377 Term t3 = ArgOfTerm(3, Goal);
1378
1379 if (IsVarTerm(t1) && IsNewVar(t1)) {
1380 c_bifun(_functor, t2, t3, t1, Goal, mod, cglobs);
1381 } else if (IsNonVarTerm(t1)) {
1382 /* just split the structure */
1383 if (IsAtomicTerm(t1)) {
1384 c_eq(t1, t2, cglobs);
1385 c_eq(t3, MkIntTerm(0), cglobs);
1386 } else if (IsApplTerm(t1)) {
1387 Functor f = FunctorOfTerm(t1);
1388 c_eq(t2, MkAtomTerm(NameOfFunctor(f)), cglobs);
1389 c_eq(t3, MkIntegerTerm(ArityOfFunctor(f)), cglobs);
1390 } else /* list */ {
1391 c_eq(t2, TermDot, cglobs);
1392 c_eq(t3, MkIntTerm(2), cglobs);
1393 }
1394 } else if (IsVarTerm(t2) && IsNewVar(t2) && IsVarTerm(t3) && IsNewVar(t3)) {
1395 Int v1 = --cglobs->tmpreg;
1396 Yap_emit(fetch_args_vi_op, Zero, Zero, &cglobs->cint);
1397 c_var(t1, v1, 0, 0, cglobs);
1398 c_var(t2, f_flag, (unsigned int)_functor, 0, cglobs);
1399 c_var(t3, f_flag, (unsigned int)_functor, 0, cglobs);
1400 } else {
1401 Functor f = FunctorOfTerm(Goal);
1402 Prop p0 = PredPropByFunc(f, mod);
1403
1404 if (EndOfPAEntr(p0)) {
1405 save_machine_regs();
1406 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
1407 }
1408 if (profiling) {
1409 Yap_emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero, &cglobs->cint);
1410 } else if (call_counting)
1411 Yap_emit(count_call_op, (CELL)RepPredProp(p0), Zero, &cglobs->cint);
1412 c_args(Goal, 0, cglobs);
1413 Yap_emit(safe_call_op, (CELL)p0, Zero, &cglobs->cint);
1414 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
1415 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1416 }
1417}
1418
1419static int IsTrueGoal(Term t) {
1420 if (IsVarTerm(t))
1421 return (FALSE);
1422 if (IsApplTerm(t)) {
1423 Functor f = FunctorOfTerm(t);
1424 if (f == FunctorModule) {
1425 return (IsTrueGoal(ArgOfTerm(2, t)));
1426 }
1427 if (f == FunctorComma || f == FunctorOr || f == FunctorVBar ||
1428 f == FunctorArrow || f==FunctorSoftCut) {
1429 return (IsTrueGoal(ArgOfTerm(1, t)) && IsTrueGoal(ArgOfTerm(2, t)));
1430 }
1431 return (FALSE);
1432 }
1433 return (t == MkAtomTerm(AtomTrue));
1434}
1435
1436static void emit_special_label(Term Goal, compiler_struct *cglobs) {
1437 special_label_op lab_op = IntOfTerm(ArgOfTerm(1, Goal));
1438 special_label_id lab_id = IntOfTerm(ArgOfTerm(2, Goal));
1439 UInt label_name;
1440
1441 switch (lab_op) {
1442 case SPECIAL_LABEL_INIT:
1443 label_name = ++cglobs->labelno;
1444 switch (lab_id) {
1445 case SPECIAL_LABEL_EXCEPTION:
1446 cglobs->cint.exception_handler = label_name;
1447 break;
1448 case SPECIAL_LABEL_SUCCESS:
1449 cglobs->cint.success_handler = label_name;
1450 break;
1451 case SPECIAL_LABEL_FAILURE:
1452 cglobs->cint.failure_handler = label_name;
1453 break;
1454 }
1455 Yap_emit_3ops(label_ctl_op, lab_op, lab_id, label_name, &cglobs->cint);
1456 break;
1457 case SPECIAL_LABEL_SET:
1458 switch (lab_id) {
1459 case SPECIAL_LABEL_EXCEPTION:
1460 Yap_emit(label_op, cglobs->cint.exception_handler, Zero, &cglobs->cint);
1461 break;
1462 case SPECIAL_LABEL_SUCCESS:
1463 Yap_emit(label_op, cglobs->cint.success_handler, Zero, &cglobs->cint);
1464 break;
1465 case SPECIAL_LABEL_FAILURE:
1466 Yap_emit(label_op, cglobs->cint.failure_handler, Zero, &cglobs->cint);
1467 break;
1468 }
1469 case SPECIAL_LABEL_CLEAR:
1470 switch (lab_id) {
1471 case SPECIAL_LABEL_EXCEPTION:
1472 cglobs->cint.exception_handler = 0L;
1473 break;
1474 case SPECIAL_LABEL_SUCCESS:
1475 cglobs->cint.success_handler = 0L;
1476 break;
1477 case SPECIAL_LABEL_FAILURE:
1478 cglobs->cint.failure_handler = 0L;
1479 break;
1480 }
1481 }
1482}
1483
1484static void c_goal(Term Goal, Term mod, compiler_struct *cglobs) {
1485 Functor f;
1486 PredEntry *p;
1487 Prop p0;
1488
1489 Goal = Yap_YapStripModule(Goal, &mod);
1490 if (IsVarTerm(Goal)) {
1491 Goal = Yap_MkApplTerm(FunctorCall, 1, &Goal);
1492 } else if (IsNumTerm(Goal)) {
1493 CACHE_REGS
1494 FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal);
1495 } else if (IsRefTerm(Goal)) {
1496 CACHE_REGS
1497 Yap_ThrowError(TYPE_ERROR_CALLABLE, Goal, "goal argument in static procedure can not be a data base reference");
1498 } else if (IsPairTerm(Goal)) {
1499 Goal = Yap_MkApplTerm(FunctorCall, 1, &Goal);
1500 }
1501 if (IsAtomTerm(Goal)) {
1502 Atom atom = AtomOfTerm(Goal);
1503
1504 if (atom == AtomFail || atom == AtomFalse) {
1505 Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
1506 return;
1507 } else if (atom == AtomTrue || atom == AtomOtherwise) {
1508 if (cglobs->onlast) {
1509 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
1510#ifdef TABLING
1511 PELOCK(41, cglobs->cint.CurrentPred);
1512 if (is_tabled(cglobs->cint.CurrentPred))
1513 Yap_emit(table_new_answer_op, Zero,
1514 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
1515 else
1516#endif /* TABLING */
1517 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
1518#ifdef TABLING
1519 UNLOCK(cglobs->cint.CurrentPred->PELock);
1520#endif
1521 }
1522 return;
1523 } else if (atom == AtomCut) {
1524 if (profiling)
1525 Yap_emit(enter_profiling_op,
1526 (CELL)RepPredProp(PredPropByAtom(AtomCut, 0)), Zero,
1527 &cglobs->cint);
1528 else if (call_counting)
1529 Yap_emit(count_call_op, (CELL)RepPredProp(PredPropByAtom(AtomCut, 0)),
1530 Zero, &cglobs->cint);
1531 if (cglobs->onlast) {
1532 /* never a problem here with a -> b, !, c ; d */
1533 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
1534#ifdef TABLING
1535 PELOCK(42, cglobs->cint.CurrentPred);
1536 if (is_tabled(cglobs->cint.CurrentPred)) {
1537 Yap_emit_3ops(cut_op, Zero, Zero, Zero, &cglobs->cint);
1538 /* needs to adjust previous commits */
1539 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
1540 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1541 Yap_emit(table_new_answer_op, Zero,
1542 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
1543 } else
1544#endif /* TABLING */
1545 {
1546 Yap_emit_3ops(cutexit_op, Zero, Zero, Zero, &cglobs->cint);
1547 /* needs to adjust previous commits */
1548 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
1549 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1550 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
1551 }
1552#ifdef TABLING
1553 UNLOCK(cglobs->cint.CurrentPred->PELock);
1554#endif
1555 } else {
1556 Yap_emit_3ops(cut_op, Zero, Zero, Zero, &cglobs->cint);
1557 /* needs to adjust previous commits */
1558 Yap_emit(empty_call_op, Zero, Zero, &cglobs->cint);
1559 Yap_emit(restore_tmps_and_skip_op, Zero, Zero, &cglobs->cint);
1560 adjust_current_commits(cglobs);
1561 }
1562 return;
1563 }
1564#ifndef YAPOR
1565 else if (atom == AtomRepeat) {
1566 CELL l1 = ++cglobs->labelno;
1567 CELL l2 = ++cglobs->labelno;
1568
1569 /* I need an either_me */
1570 cglobs->needs_env = TRUE;
1571 if (profiling)
1572 Yap_emit(enter_profiling_op,
1573 (CELL)RepPredProp(PredPropByAtom(AtomRepeat, 0)), Zero,
1574 &cglobs->cint);
1575 else if (call_counting)
1576 Yap_emit(count_call_op,
1577 (CELL)RepPredProp(PredPropByAtom(AtomRepeat, 0)), Zero,
1578 &cglobs->cint);
1579 cglobs->or_found = TRUE;
1580 push_branch(cglobs->onbranch, TermNil, cglobs);
1581 cglobs->curbranch++;
1582 cglobs->onbranch = cglobs->curbranch;
1583 Yap_emit_3ops(push_or_op, l1, Zero, Zero, &cglobs->cint);
1584 Yap_emit_3ops(either_op, l1, Zero, Zero, &cglobs->cint);
1585 Yap_emit(restore_tmps_op, Zero, Zero, &cglobs->cint);
1586 Yap_emit(jump_op, l2, Zero, &cglobs->cint);
1587 Yap_emit(label_op, l1, Zero, &cglobs->cint);
1588 Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
1589 Yap_emit_3ops(orelse_op, l1, Zero, Zero, &cglobs->cint);
1590 Yap_emit(label_op, l2, Zero, &cglobs->cint);
1591 if (cglobs->onlast) {
1592#ifdef TABLING
1593 PELOCK(43, cglobs->cint.CurrentPred);
1594 if (is_tabled(cglobs->cint.CurrentPred)) {
1595 Yap_emit(table_new_answer_op, Zero,
1596 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
1597 } else {
1598#endif
1599 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
1600 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
1601#ifdef TABLING
1602 }
1603 UNLOCK(cglobs->cint.CurrentPred->PELock);
1604#endif
1605 } else {
1606 ++cglobs->goalno;
1607 }
1608 cglobs->onbranch = pop_branch(cglobs);
1609 Yap_emit(pop_or_op, Zero, Zero, &cglobs->cint);
1610 /* --cglobs->onbranch; */
1611 return;
1612 }
1613#endif /* YAPOR */
1614 p = RepPredProp(p0 = Yap_PredPropByAtomNonThreadLocal(atom, mod));
1615 if (EndOfPAEntr(p0)) {
1616 save_machine_regs();
1617 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
1618 }
1619 /* if we are profiling, make sure we register we entered this predicate */
1620 if (profiling)
1621 Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
1622 if (call_counting)
1623 Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
1624 } else {
1625 f = FunctorOfTerm(Goal);
1626 p = RepPredProp(p0 = Yap_PredPropByFunctorNonThreadLocal(f, mod));
1627 if (EndOfPAEntr(p0)) {
1628 save_machine_regs();
1629 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
1630 }
1631 if (f == FunctorOr || f == FunctorVBar) {
1632 Term arg;
1633 CELL l = ++cglobs->labelno;
1634 CELL m = ++cglobs->labelno;
1635 int save = cglobs->onlast;
1636 int savegoalno = cglobs->goalno;
1637 int frst = TRUE;
1638 int commitflag = 0;
1639 int looking_at_commit = FALSE;
1640 int optimizing_commit = FALSE;
1641 Term commitvar = 0;
1642 int looking_at_soft_cut = FALSE;
1643 PInstr *FirstP = cglobs->cint.cpc, *savecpc, *savencpc;
1644
1645 push_branch(cglobs->onbranch, TermNil, cglobs);
1646 ++cglobs->curbranch;
1647 cglobs->onbranch = cglobs->curbranch;
1648 cglobs->or_found = TRUE;
1649 do {
1650 arg = ArgOfTerm(1, Goal);
1651 looking_at_commit =
1652 IsApplTerm(arg) && FunctorOfTerm(arg) == FunctorArrow;
1653 looking_at_soft_cut =
1654 IsApplTerm(arg) && FunctorOfTerm(arg) == FunctorSoftCut;
1655 if (frst) {
1656 if (optimizing_commit) {
1657 Yap_emit(label_op, l, Zero, &cglobs->cint);
1658 l = ++cglobs->labelno;
1659 }
1660 Yap_emit_3ops(push_or_op, l, Zero, Zero, &cglobs->cint);
1661 if (looking_at_commit && Yap_is_a_test_pred(ArgOfTerm(1, arg), mod)) {
1662 /*
1663 * let them think they are still the
1664 * first
1665 */
1666 // Yap_emit(commit_opt_op, l, Zero, &cglobs->cint);
1667 optimizing_commit = TRUE;
1668 Yap_emit_3ops(label_ctl_op, SPECIAL_LABEL_INIT,
1669 SPECIAL_LABEL_FAILURE, l, &cglobs->cint);
1670 } else {
1671 optimizing_commit = FALSE;
1672 cglobs->needs_env = TRUE;
1673 Yap_emit_3ops(either_op, l, Zero, Zero, &cglobs->cint);
1674 Yap_emit(restore_tmps_op, Zero, Zero, &cglobs->cint);
1675 frst = FALSE;
1676 }
1677 } else {
1678 optimizing_commit = false;
1679 Yap_emit(label_op, l, Zero, &cglobs->cint);
1680 Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
1681 Yap_emit_3ops(orelse_op, l = ++cglobs->labelno, Zero, Zero,
1682 &cglobs->cint);
1683 cglobs->needs_env = TRUE;
1684 }
1685 /*
1686 * if(IsApplTerm(arg) &&
1687 * FunctorOfTerm(arg)==FunctorArrow) {
1688 */
1689 if (looking_at_commit || looking_at_soft_cut) {
1690 if ((!optimizing_commit && !commitflag)) {
1691 CACHE_REGS
1692 /* This instruction is placed before
1693 * the disjunction. This means that
1694 * the program counter must point
1695 * correctly, and also that the age
1696 * of variable is older than the
1697 * current branch.
1698 */
1699 int my_goalno = cglobs->goalno;
1700
1701 cglobs->goalno = savegoalno;
1702 commitflag = cglobs->labelno;
1703 commitvar = MkVarTerm();
1704 if (HR == (CELL *)cglobs->cint.freep0) {
1705 /* oops, too many new variables */
1706 save_machine_regs();
1707 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1708 }
1709 savecpc = cglobs->cint.cpc;
1710 savencpc = FirstP->nextInst;
1711 cglobs->cint.cpc = FirstP;
1712 cglobs->onbranch = pop_branch(cglobs);
1713 c_var(commitvar, save_b_flag, 1, 0, cglobs);
1714 push_branch(cglobs->onbranch, commitvar, cglobs);
1715 cglobs->onbranch = cglobs->curbranch;
1716 cglobs->cint.cpc->nextInst = savencpc;
1717 cglobs->cint.cpc = savecpc;
1718 cglobs->goalno = my_goalno;
1719 }
1720 save = cglobs->onlast;
1721 cglobs->onlast = FALSE;
1722 c_goal(ArgOfTerm(1, arg), mod, cglobs);
1723 if (!optimizing_commit) {
1724 if (looking_at_soft_cut)
1725 c_var((Term)commitvar, soft_cut_b_flag, 1, 0, cglobs);
1726 else
1727 c_var((Term)commitvar, commit_b_flag, 1, 0, cglobs);
1728 } else {
1729 Yap_emit_3ops(label_ctl_op, SPECIAL_LABEL_CLEAR,
1730 SPECIAL_LABEL_FAILURE, l, &cglobs->cint);
1731 }
1732 cglobs->onlast = save;
1733 c_goal(ArgOfTerm(2, arg), mod, cglobs);
1734 } else {
1735 /* standard disjunction */
1736 c_goal(ArgOfTerm(1, Goal), mod, cglobs);
1737 }
1738 if (!cglobs->onlast) {
1739 Yap_emit(jump_op, m, Zero, &cglobs->cint);
1740 } else {
1741 }
1742 if (!optimizing_commit || !cglobs->onlast) {
1743 cglobs->goalno = savegoalno + 1;
1744 }
1745 Goal = ArgOfTerm(2, Goal);
1746 ++cglobs->curbranch;
1747 cglobs->onbranch = cglobs->curbranch;
1748 } while (IsNonVarTerm(Goal) && IsApplTerm(Goal) &&
1749 (FunctorOfTerm(Goal) == FunctorOr ||
1750 FunctorOfTerm(Goal) == FunctorVBar));
1751 Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
1752 Yap_emit(label_op, l, Zero, &cglobs->cint);
1753 if (!optimizing_commit) {
1754 Yap_emit(orlast_op, Zero, Zero, &cglobs->cint);
1755 } else {
1756 optimizing_commit = FALSE; /* not really necessary */
1757 }
1758 c_goal(Goal, mod, cglobs);
1759 /* --cglobs->onbranch; */
1760 cglobs->onbranch = pop_branch(cglobs);
1761 if (!cglobs->onlast) {
1762 Yap_emit(label_op, m, Zero, &cglobs->cint);
1763 if ((cglobs->onlast = save))
1764 c_goal(MkAtomTerm(AtomTrue), mod, cglobs);
1765 }
1766 Yap_emit(pop_or_op, Zero, Zero, &cglobs->cint);
1767 return;
1768 } else if (f == FunctorComma) {
1769 int save = cglobs->onlast;
1770 Term t2 = ArgOfTerm(2, Goal);
1771
1772 cglobs->onlast = FALSE;
1773 c_goal(ArgOfTerm(1, Goal), mod, cglobs);
1774 cglobs->onlast = save;
1775 c_goal(t2, mod, cglobs);
1776 return;
1777 } else if (f == FunctorNot || f == FunctorAltNot) {
1778 CACHE_REGS
1779 CELL label = (cglobs->labelno += 2);
1780 CELL end_label = (cglobs->labelno += 2);
1781 int save = cglobs->onlast;
1782 Term commitvar;
1783
1784 /* for now */
1785 cglobs->needs_env = TRUE;
1786 commitvar = MkVarTerm();
1787 if (HR == (CELL *)cglobs->cint.freep0) {
1788 /* oops, too many new variables */
1789 save_machine_regs();
1790 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1791 }
1792 push_branch(cglobs->onbranch, commitvar, cglobs);
1793 ++cglobs->curbranch;
1794 cglobs->onbranch = cglobs->curbranch;
1795 cglobs->or_found = TRUE;
1796 cglobs->onlast = FALSE;
1797 c_var(commitvar, save_b_flag, 1, 0, cglobs);
1798 Yap_emit_3ops(push_or_op, label, Zero, Zero, &cglobs->cint);
1799 Yap_emit_3ops(either_op, label, Zero, Zero, &cglobs->cint);
1800 Yap_emit(restore_tmps_op, Zero, Zero, &cglobs->cint);
1801 c_goal(ArgOfTerm(1, Goal), mod, cglobs);
1802 c_var(commitvar, commit_b_flag, 1, 0, cglobs);
1803 cglobs->onlast = save;
1804 Yap_emit(fail_op, end_label, Zero, &cglobs->cint);
1805 Yap_emit(pushpop_or_op, Zero, Zero, &cglobs->cint);
1806 Yap_emit(label_op, label, Zero, &cglobs->cint);
1807 Yap_emit(orlast_op, Zero, Zero, &cglobs->cint);
1808 Yap_emit(label_op, end_label, Zero, &cglobs->cint);
1809 cglobs->onlast = save;
1810 /* --cglobs->onbranch; */
1811 cglobs->onbranch = pop_branch(cglobs);
1812 c_goal(MkAtomTerm(AtomTrue), mod, cglobs);
1813 ++cglobs->goalno;
1814 Yap_emit(pop_or_op, Zero, Zero, &cglobs->cint);
1815 return;
1816 } else if (f == FunctorArrow) {
1817 CACHE_REGS
1818 Term commitvar;
1819 int save = cglobs->onlast;
1820
1821 commitvar = MkVarTerm();
1822 if (HR == (CELL *)cglobs->cint.freep0) {
1823 /* oops, too many new variables */
1824 save_machine_regs();
1825 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1826 }
1827 cglobs->onlast = FALSE;
1828 c_var(commitvar, save_b_flag, 1, 0, cglobs);
1829 c_goal(ArgOfTerm(1, Goal), mod, cglobs);
1830 c_var(commitvar, commit_b_flag, 1, 0, cglobs);
1831 cglobs->onlast = save;
1832 c_goal(ArgOfTerm(2, Goal), mod, cglobs);
1833 return;
1834 }else if (f == FunctorSoftCut) {
1835 CACHE_REGS
1836 int save = cglobs->onlast;
1837 cglobs->onlast = FALSE;
1838 c_goal(ArgOfTerm(1, Goal), mod, cglobs);
1839 cglobs->onlast = save;
1840 c_goal(ArgOfTerm(2, Goal), mod, cglobs);
1841 return;
1842 } else if (f == FunctorEq) {
1843 if (profiling)
1844 Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
1845 else if (call_counting)
1846 Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
1847 c_eq(ArgOfTerm(1, Goal), ArgOfTerm(2, Goal), cglobs);
1848 if (cglobs->onlast) {
1849 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
1850#ifdef TABLING
1851 PELOCK(44, cglobs->cint.CurrentPred);
1852 if (is_tabled(cglobs->cint.CurrentPred))
1853 Yap_emit(table_new_answer_op, Zero,
1854 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
1855 else
1856#endif /* TABLING */
1857 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
1858#ifdef TABLING
1859 UNLOCK(cglobs->cint.CurrentPred->PELock);
1860#endif
1861 }
1862 return;
1863 } else if (f == FunctorSafe) {
1864 Ventry *v = (Ventry *)ArgOfTerm(1, Goal);
1865 /* This variable must be known before */
1866 v->FlagsOfVE |= SafeVar;
1867 return;
1868 } else if (p->PredFlags & (AsmPredFlag)) {
1869 basic_preds op = p->PredFlags & 0x7f;
1870 if (profiling)
1871 Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
1872 else if (call_counting)
1873 Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
1874 if (op >= _atom && op <= _primitive) {
1875 c_test(op, ArgOfTerm(1, Goal), cglobs);
1876 if (cglobs->onlast) {
1877 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
1878#ifdef TABLING
1879 PELOCK(45, cglobs->cint.CurrentPred);
1880 if (is_tabled(cglobs->cint.CurrentPred))
1881 Yap_emit(table_new_answer_op, Zero,
1882 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
1883 else
1884#endif /* TABLING */
1885 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
1886#ifdef TABLING
1887 UNLOCK(cglobs->cint.CurrentPred->PELock);
1888#endif
1889 }
1890 return;
1891 } else if (op >= _plus && op <= _functor) {
1892 if (profiling)
1893 Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
1894 else if (call_counting)
1895 Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
1896 if (op == _functor) {
1897 c_functor(Goal, mod, cglobs);
1898 } else {
1899 c_bifun(op, ArgOfTerm(1, Goal), ArgOfTerm(2, Goal),
1900 ArgOfTerm(3, Goal), Goal, mod, cglobs);
1901 }
1902 if (cglobs->onlast) {
1903 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
1904#ifdef TABLING
1905 PELOCK(46, cglobs->cint.CurrentPred);
1906 if (is_tabled(cglobs->cint.CurrentPred))
1907 Yap_emit(table_new_answer_op, Zero,
1908 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
1909 else
1910#endif /* TABLING */
1911 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
1912#ifdef TABLING
1913 UNLOCK(cglobs->cint.CurrentPred->PELock);
1914#endif
1915 }
1916 return;
1917 } else if (op == _p_label_ctl) {
1918 emit_special_label(Goal, cglobs);
1919 return;
1920 } else {
1921 c_args(Goal, 0, cglobs);
1922 }
1923 }
1924#ifdef BEAM
1925 else if (p->PredFlags & BinaryPredFlag && !EAM) {
1926#else
1927 else if (p->PredFlags & BinaryPredFlag) {
1928#endif
1929 CACHE_REGS
1930 Term a1 = ArgOfTerm(1, Goal);
1931
1932 if (IsVarTerm(a1) && !IsNewVar(a1)) {
1933 Term a2 = ArgOfTerm(2, Goal);
1934 if (IsVarTerm(a2) && !IsNewVar(a2)) {
1935 cglobs->current_p0 = p0;
1936 c_2vars(bt_flag, a1, 0, a2, 0, (CELL)p0, 0, 0, cglobs);
1937 } else {
1938 Term t2 = MkVarTerm();
1939 // c_var(t2, --cglobs->tmpreg, 0, 0, cglobs);
1940 if (HR == (CELL *)cglobs->cint.freep0) {
1941 /* oops, too many new variables */
1942 save_machine_regs();
1943 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1944 }
1945 cglobs->current_p0 = p0;
1946 c_eq(t2, a2, cglobs);
1947 c_2vars(bt_flag, a1, 0, t2, 0, (CELL)p0, 0, 0, cglobs);
1948 }
1949 } else {
1950 Term a2 = ArgOfTerm(2, Goal);
1951 Term t1 = MkVarTerm();
1952 // c_var(t1, --cglobs->tmpreg, 0, 0, cglobs);
1953 if (HR == (CELL *)cglobs->cint.freep0) {
1954 /* oops, too many new variables */
1955 save_machine_regs();
1956 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1957 }
1958 c_eq(t1, a1, cglobs);
1959
1960 if (IsVarTerm(a2) && !IsNewVar(a2)) {
1961 cglobs->current_p0 = p0;
1962 c_2vars(bt_flag, t1, 0, a2, 0, (CELL)p0, 0, 0, cglobs);
1963 } else {
1964 Term t2 = MkVarTerm();
1965 // c_var(t2, --cglobs->tmpreg, 0, 0, cglobs);
1966 if (HR == (CELL *)cglobs->cint.freep0) {
1967 /* oops, too many new variables */
1968 save_machine_regs();
1969 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_TEMPS_BOTCH);
1970 }
1971 c_eq(t2, a2, cglobs);
1972 cglobs->current_p0 = p0;
1973 c_2vars(bt_flag, t1, 0, t2, 0, (CELL)p0, 0, 0, cglobs);
1974 }
1975 }
1976 if (cglobs->onlast) {
1977 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
1978#ifdef TABLING
1979 PELOCK(47, cglobs->cint.CurrentPred);
1980 if (is_tabled(cglobs->cint.CurrentPred))
1981 Yap_emit(table_new_answer_op, Zero,
1982 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
1983 else
1984#endif /* TABLING */
1985 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
1986#ifdef TABLING
1987 UNLOCK(cglobs->cint.CurrentPred->PELock);
1988#endif
1989 }
1990 return;
1991 } else {
1992 if (profiling)
1993 Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
1994 else if (call_counting)
1995 Yap_emit(count_call_op, (CELL)p, Zero, &cglobs->cint);
1996 if (f == FunctorExecuteInMod) {
1997 /* compile the first argument only */
1998 c_arg(1, ArgOfTerm(1, Goal), 1, 0, cglobs);
1999 } else {
2000 c_args(Goal, 0, cglobs);
2001 }
2002 }
2003 }
2004
2005 if (p->PredFlags & SafePredFlag
2006#ifdef YAPOR
2007 /* synchronisation means saving the state, so it is never safe in YAPOR */
2008 && !(p->PredFlags & SyncPredFlag)
2009#endif /* YAPOR */
2010 ) {
2011 Yap_emit(safe_call_op, (CELL)p0, Zero, &cglobs->cint);
2012 if (cglobs->onlast) {
2013 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
2014#ifdef TABLING
2015 PELOCK(48, cglobs->cint.CurrentPred);
2016 if (is_tabled(cglobs->cint.CurrentPred))
2017 Yap_emit(table_new_answer_op, Zero, cglobs->cint.CurrentPred->ArityOfPE,
2018 &cglobs->cint);
2019 else
2020#endif /* TABLING */
2021 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
2022#ifdef TABLING
2023 UNLOCK(cglobs->cint.CurrentPred->PELock);
2024#endif
2025 }
2026 } else {
2027 if ((p->PredFlags &
2028 (AsmPredFlag | ModuleTransparentPredFlag | UserCPredFlag)) ||
2029 p->FunctorOfPred == FunctorExecuteInMod) {
2030#ifdef YAPOR
2031 if (p->PredFlags & SyncPredFlag)
2032 Yap_emit(sync_op, (CELL)p, (CELL)(p->ArityOfPE), &cglobs->cint);
2033#endif /* YAPOR */
2034 if (p->FunctorOfPred == FunctorExecuteInMod) {
2035 cglobs->needs_env = TRUE;
2036 Yap_emit_4ops(call_op, (CELL)p0, Zero, Zero, ArgOfTerm(2, Goal),
2037 &cglobs->cint);
2038 } else {
2039 cglobs->needs_env = TRUE;
2040 Yap_emit_3ops(call_op, (CELL)p0, Zero, Zero, &cglobs->cint);
2041 }
2042 /* functor is allowed to call the garbage collector */
2043 if (cglobs->onlast) {
2044 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
2045 cglobs->or_found = TRUE;
2046#ifdef TABLING
2047 PELOCK(49, cglobs->cint.CurrentPred);
2048 if (is_tabled(cglobs->cint.CurrentPred))
2049 Yap_emit(table_new_answer_op, Zero,
2050 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
2051 else
2052#endif /* TABLING */
2053 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
2054#ifdef TABLING
2055 UNLOCK(cglobs->cint.CurrentPred->PELock);
2056#endif
2057 }
2058 } else {
2059 if (cglobs->onlast) {
2060 Yap_emit(deallocate_op, Zero, Zero, &cglobs->cint);
2061#ifdef TABLING
2062 PELOCK(50, cglobs->cint.CurrentPred);
2063 if (is_tabled(cglobs->cint.CurrentPred)) {
2064 cglobs->needs_env = TRUE;
2065 Yap_emit_3ops(call_op, (CELL)p0, Zero, Zero, &cglobs->cint);
2066 Yap_emit(table_new_answer_op, Zero,
2067 cglobs->cint.CurrentPred->ArityOfPE, &cglobs->cint);
2068 } else
2069#endif /* TABLING */
2070 Yap_emit(execute_op, (CELL)p0, Zero, &cglobs->cint);
2071#ifdef TABLING
2072 UNLOCK(cglobs->cint.CurrentPred->PELock);
2073#endif
2074 } else {
2075 cglobs->needs_env = TRUE;
2076 Yap_emit_3ops(call_op, (CELL)p0, Zero, Zero, &cglobs->cint);
2077 }
2078 }
2079 if (!cglobs->onlast)
2080 ++cglobs->goalno;
2081 }
2082}
2083
2084static void c_body(Term Body, Term mod, compiler_struct *cglobs) {
2085 cglobs->onhead = FALSE;
2086 cglobs->BodyStart = cglobs->cint.cpc;
2087 cglobs->goalno = 1;
2088 while (IsNonVarTerm(Body) && IsApplTerm(Body) &&
2089 FunctorOfTerm(Body) == FunctorComma) {
2090 Term t2 = ArgOfTerm(2, Body);
2091 if (!cglobs->cint.success_handler && IsTrueGoal(t2)) {
2092 /* optimise the case where some idiot left trues at the end
2093 of the clause.
2094 */
2095 Body = ArgOfTerm(1, Body);
2096 break;
2097 }
2098 c_goal(ArgOfTerm(1, Body), mod, cglobs);
2099 Body = t2;
2100#ifdef BEAM
2101 if (EAM)
2102 Yap_emit(endgoal_op, Zero, Zero, &cglobs->cint);
2103#endif
2104 }
2105 cglobs->onlast = TRUE;
2106 c_goal(Body, mod, cglobs);
2107#ifdef BEAM
2108 if (EAM && cglobs->goalno > 1) {
2109 if (cglobs->cint.cpc->op == procceed_op) {
2110 cglobs->cint.cpc->op = endgoal_op;
2111 Yap_emit(procceed_op, Zero, Zero, &cglobs->cint);
2112 } else
2113 Yap_emit(endgoal_op, Zero, Zero, &cglobs->cint);
2114 }
2115#endif
2116}
2117
2118static void c_head(Term t, compiler_struct *cglobs) {
2119 Functor f;
2120
2121 cglobs->goalno = 0;
2122 cglobs->onhead = TRUE;
2123 cglobs->onlast = FALSE;
2124 cglobs->curbranch = cglobs->onbranch = 0;
2125 cglobs->branch_pointer = cglobs->parent_branches;
2126 cglobs->space_used = 0;
2127 cglobs->space_op = NULL;
2128 if (IsAtomTerm(t)) {
2129 Yap_emit(name_op, (CELL)AtomOfTerm(t), Zero, &cglobs->cint);
2130#ifdef BEAM
2131 if (EAM) {
2132 Yap_emit(run_op, Zero, (UInt)cglobs->cint.CurrentPred, &cglobs->cint);
2133 }
2134#endif
2135 Yap_emit(ensure_space_op, Zero, Zero, &cglobs->cint);
2136 cglobs->space_op = cglobs->cint.cpc;
2137 return;
2138 }
2139 f = FunctorOfTerm(t);
2140 Yap_emit(name_op, (CELL)NameOfFunctor(f), ArityOfFunctor(f), &cglobs->cint);
2141#ifdef BEAM
2142 if (EAM) {
2143 Yap_emit(run_op, Zero, (UInt)cglobs->cint.CurrentPred, &cglobs->cint);
2144 }
2145#endif
2146 if (Yap_ExecutionMode == MIXED_MODE_USER)
2147 Yap_emit(native_op, 0, 0, &cglobs->cint);
2148 Yap_emit(ensure_space_op, Zero, Zero, &cglobs->cint);
2149 cglobs->space_op = cglobs->cint.cpc;
2150#ifdef BEAM
2151 if (EAM) {
2152 Yap_emit(run_op, Zero, (UInt)cglobs->cint.CurrentPred, &cglobs->cint);
2153 }
2154#endif
2155 if (Yap_ExecutionMode == MIXED_MODE || Yap_ExecutionMode == COMPILED)
2156#if YAP_JIT
2157 Yap_emit(native_op, 0, 0, &cglobs->cint);
2158#else
2159 {
2160 if (Yap_ExecutionMode == MIXED_MODE)
2161 Yap_NilError(SYSTEM_ERROR_JIT_NOT_AVAILABLE, "mixed");
2162 else /* Yap_ExecutionMode == COMPILED */
2163 Yap_NilError(SYSTEM_ERROR_JIT_NOT_AVAILABLE, "just compiled");
2164 }
2165#endif
2166 c_args(t, 0, cglobs);
2167}
2168
2169inline static bool usesvar(compiler_vm_op ic) {
2170 if (ic >= get_var_op && ic <= put_val_op)
2171 return true;
2172 switch (ic) {
2173 case save_b_op:
2174 case commit_b_op:
2175 case soft_cut_b_op:
2176 case patch_b_op:
2177 case save_appl_op:
2178 case save_pair_op:
2179 case f_val_op:
2180 case f_var_op:
2181 case bccall_op:
2182 return true;
2183 default:
2184 break;
2185 }
2186#ifdef SFUNC
2187 if (ic >= unify_s_var_op && ic <= write_s_val_op)
2188 return true;
2189#endif
2190 return ((ic >= unify_var_op && ic <= write_val_op) ||
2191 (ic >= unify_last_var_op && ic <= unify_last_val_op));
2192}
2193
2194/*
2195inline static bool
2196 uses_this_var(PInstr *pc, Term arg)
2197{
2198 compiler_vm_op ic = pc->op;
2199
2200 if (pc->rnd1 != arg)
2201 return arg == pc->rnd3 && ic == bccall_op;
2202 return usesvar( ic );
2203}
2204*/
2205
2206inline static bool usesvar2(compiler_vm_op ic) { return ic == bccall_op; }
2207
2208/*
2209 * Do as in the traditional WAM and make sure voids are in
2210 * environments
2211 */
2212#define LOCALISE_VOIDS 1
2213
2214#ifdef LOCALISE_VOIDS
2215typedef struct env_tmp {
2216 Ventry *Var;
2217 struct env_tmp *Next;
2218} EnvTmp;
2219#endif
2220
2221static void tag_use(Ventry *v USES_REGS) {
2222#ifdef BEAM
2223 if (EAM) {
2224 if (v->NoOfVE == Unassigned || v->KindOfVE != PermVar) {
2225 v->NoOfVE = PermVar | (LOCAL_nperm++);
2226 v->KindOfVE = PermVar;
2227 v->FlagsOfVE |= PermFlag;
2228 }
2229 }
2230#endif
2231 if (v->NoOfVE == Unassigned) {
2232 if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE)) ||
2233 v->KindOfVE == PermVar /*
2234 * * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE &
2235 * * OnHeadFlag))
2236 */) {
2237 v->NoOfVE = PermVar | (LOCAL_nperm++);
2238 v->KindOfVE = PermVar;
2239 v->FlagsOfVE |= PermFlag;
2240 } else {
2241 v->NoOfVE = v->KindOfVE = TempVar;
2242 }
2243 }
2244}
2245
2246static void AssignPerm(PInstr *pc, compiler_struct *cglobs) {
2247 CACHE_REGS
2248 int uses_var;
2249 PInstr *opc = NULL;
2250#ifdef LOCALISE_VOIDS
2251 EnvTmp *EnvTmps = NULL;
2252#endif
2253
2254 /* The WAM tries to keep voids on the
2255 * environment. Traditionally, YAP liberally globalises
2256 * voids.
2257 *
2258 * The new version goes to some length to keep void variables
2259 * in environments, but it is dubious that improves
2260 * performance, and may actually slow down the system
2261 */
2262 while (pc != NULL) {
2263 PInstr *tpc = pc->nextInst;
2264#ifdef LOCALISE_VOIDS
2265 if (pc->op == put_var_op) {
2266 Ventry *v = (Ventry *)(pc->rnd1);
2267 if (v->AgeOfVE == v->FirstOfVE &&
2268 !(v->FlagsOfVE & (GlobalVal | OnHeadFlag | OnLastGoal | NonVoid))) {
2269 EnvTmp *x = (EnvTmp *)Yap_AllocCMem(sizeof(*x), &cglobs->cint);
2270 x->Next = EnvTmps;
2271 x->Var = v;
2272 EnvTmps = x;
2273 }
2274 } else
2275#endif
2276 if (pc->op == call_op || pc->op == either_op || pc->op == orelse_op ||
2277 pc->op == push_or_op) {
2278#ifdef LOCALISE_VOIDS
2279 pc->ops.opseqt[1] = (CELL)EnvTmps;
2280 if (EnvTmps)
2281 EnvTmps = NULL;
2282#endif
2283 }
2284 pc->nextInst = opc;
2285 opc = pc;
2286 pc = tpc;
2287 }
2288 pc = opc;
2289 opc = NULL;
2290 do {
2291 PInstr *npc = pc->nextInst;
2292
2293 pc->nextInst = opc;
2294 uses_var = usesvar(pc->op);
2295 if (uses_var) {
2296 Ventry *v = (Ventry *)(pc->rnd1);
2297
2298 tag_use(v PASS_REGS);
2299 if (usesvar2(pc->op)) {
2300 Ventry *v2 = (Ventry *)(pc->rnd3);
2301 tag_use(v2 PASS_REGS);
2302 }
2303
2304 } else if (pc->op == empty_call_op) {
2305 pc->rnd2 = LOCAL_nperm;
2306 } else if (pc->op == call_op || pc->op == either_op ||
2307 pc->op == orelse_op || pc->op == push_or_op) {
2308#ifdef LOCALISE_VOIDS
2309 EnvTmps = (EnvTmp *)(pc->ops.opseqt[1]);
2310 while (EnvTmps) {
2311 Ventry *v = EnvTmps->Var;
2312 v->NoOfVE = PermVar | (LOCAL_nperm++);
2313 v->KindOfVE = PermVar;
2314 v->FlagsOfVE |= (PermFlag | SafeVar);
2315 EnvTmps = EnvTmps->Next;
2316 }
2317#endif
2318 pc->rnd2 = LOCAL_nperm;
2319 } else if (pc->op == cut_op || pc->op == cutexit_op ||
2320 pc->op == commit_b_op ||
2321 pc->op == soft_cut_b_op) {
2322 pc->rnd2 = LOCAL_nperm;
2323 }
2324 opc = pc;
2325 pc = npc;
2326 } while (pc != NULL);
2327}
2328
2329static CELL *init_bvarray(int nperm, compiler_struct *cglobs) {
2330 CELL *vinfo = NULL;
2331 size_t sz = sizeof(CELL) * (1 + nperm / (8 * sizeof(CELL)));
2332 vinfo = (CELL *)Yap_AllocCMem(sz, &cglobs->cint);
2333 memset((void *)vinfo, 0, sz);
2334 return vinfo;
2335}
2336
2337static void clear_bvarray(int var, CELL *bvarray
2338#ifdef DEBUG
2339 ,
2340 compiler_struct *cglobs
2341#endif
2342 ) {
2343 int max = 8 * sizeof(CELL);
2344 CELL nbit;
2345
2346 /* get to the array position */
2347 while (var >= max) {
2348 bvarray++;
2349 var -= max;
2350 }
2351 /* now put a 0 on it, from now on the variable is initialized */
2352 nbit = ((CELL)1 << var);
2353#ifdef DEBUG
2354 if (*bvarray & nbit) {
2355 CACHE_REGS
2356 /* someone had already marked this variable: complain */
2357 LOCAL_Error_TYPE = SYSTEM_ERROR_COMPILER;
2358 LOCAL_ErrorMessage = "compiler internal error: variable initialized twice";
2359 save_machine_regs();
2360 siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
2361 }
2362 cglobs->pbvars++;
2363#endif
2364 *bvarray |= nbit;
2365}
2366
2367/* copy the current state of the perm variable state array to code space */
2368static void add_bvarray_op(PInstr *cp, CELL *bvarray, int env_size,
2369 compiler_struct *cglobs) {
2370 int i, size = env_size / (8 * sizeof(CELL));
2371 CELL *dest;
2372
2373 dest = Yap_emit_extra_size(mark_initialized_pvars_op, (CELL)env_size,
2374 (size + 1) * sizeof(CELL), &cglobs->cint);
2375 /* copy the cells to dest */
2376 for (i = 0; i <= size; i++)
2377 *dest++ = *bvarray++;
2378}
2379
2380/* vsc: this code is not working, as it is too complex */
2381
2382typedef struct {
2383 int lab;
2384 int last;
2385 PInstr *pc;
2386} bventry;
2387
2388#define MAX_DISJUNCTIONS (128*128*32)
2389static bventry *bvstack;
2390static int bvindex = 0;
2391
2392static void push_bvmap(int label, PInstr *pcpc, compiler_struct *cglobs) {
2393 if (bvindex == MAX_DISJUNCTIONS) {
2394 CACHE_REGS
2395 Yap_ThrowError(SYSTEM_ERROR_COMPILER, MkIntTerm(0), "too many embedded disjunctions (max = %d)", MAX_DISJUNCTIONS);
2396 save_machine_regs();
2397 siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
2398 }
2399 /* the label instruction */
2400 bvstack[bvindex].lab = label;
2401 bvstack[bvindex].last = -1;
2402 /* where we have the code */
2403 bvstack[bvindex].pc = pcpc;
2404 bvindex++;
2405}
2406
2407static void reset_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs) {
2408 int size, size1, env_size, i;
2409 CELL *source;
2410
2411 if (bvarray == NULL)
2412
2413 if (bvindex == 0) {
2414 CACHE_REGS
2415 Yap_ThrowError(SYSTEM_ERROR_COMPILER, MkIntTerm(0), "No disjunctions found, but reset d1sjunctions was called");
2416 save_machine_regs();
2417 siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
2418 }
2419 env_size = (bvstack[bvindex - 1].pc)->rnd1;
2420 size = env_size / (8 * sizeof(CELL));
2421 size1 = nperm / (8 * sizeof(CELL));
2422 source = (bvstack[bvindex - 1].pc)->arnds;
2423 for (i = 0; i <= size; i++)
2424 *bvarray++ = *source++;
2425 for (i = size + 1; i <= size1; i++)
2426 *bvarray++ = (CELL)(0);
2427}
2428
2429static void pop_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs) {
2430 if (bvindex == 0) {
2431 CACHE_REGS
2432 Yap_ThrowError(SYSTEM_ERROR_COMPILER, MkIntTerm(0), "pop disjunctions called, but no disjunctions available");
2433 /* save_machine_regs();
2434 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); */
2435 }
2436 reset_bvmap(bvarray, nperm, cglobs);
2437 bvindex--;
2438}
2439
2440typedef struct {
2441 PInstr *p;
2442 Ventry *v;
2443} UnsafeEntry;
2444
2445/* extend to also support variable usage bitmaps for garbage collection */
2446static void CheckUnsafe(PInstr *pc, compiler_struct *cglobs) {
2447 CACHE_REGS
2448 int pending = 0;
2449
2450 /* say that all variables are yet to initialize */
2451 CELL *vstat = init_bvarray(LOCAL_nperm, cglobs);
2452 UnsafeEntry *UnsafeStack = (UnsafeEntry *)Yap_AllocCMem(
2453 LOCAL_nperm * sizeof(UnsafeEntry), &cglobs->cint);
2454 /* keep a copy of previous cglobs->cint.cpc and CodeStart */
2455 PInstr *opc = cglobs->cint.cpc;
2456 PInstr *OldCodeStart = cglobs->cint.CodeStart;
2457
2458 cglobs->cint.CodeStart = cglobs->cint.BlobsStart;
2459 cglobs->cint.cpc = cglobs->cint.icpc;
2460 bvindex = 0;
2461 bvstack = (bventry *)Yap_AllocCMem(MAX_DISJUNCTIONS * sizeof(bventry),
2462 &cglobs->cint);
2463 while (pc != NIL) {
2464 switch (pc->op) {
2465 case put_val_op: {
2466 Ventry *v = (Ventry *)(pc->rnd1);
2467 if ((v->FlagsOfVE & PermFlag) && !(v->FlagsOfVE & SafeVar)) {
2468 UnsafeStack[pending].p = pc;
2469 UnsafeStack[pending++].v = v;
2470 v->FlagsOfVE |= SafeVar;
2471 }
2472 break;
2473 }
2474 case bccall_op: {
2475 Ventry *v = (Ventry *)(pc->rnd1), *v3 = (Ventry *)(pc->rnd3);
2476
2477 if ((v->FlagsOfVE & PermFlag && pc == v->FirstOpForV) ||
2478 (v3->FlagsOfVE & PermFlag && pc == v3->FirstOpForV)) {
2479 CACHE_REGS
2480 Yap_ThrowError(SYSTEM_ERROR_COMPILER,TermNil, " comparison between two first instances of two variables.");
2481 save_machine_regs();
2482 siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
2483 }
2484 } break;
2485 case put_var_op:
2486 case get_var_op:
2487 case save_b_op:
2488 case unify_var_op:
2489 case unify_last_var_op:
2490 case write_var_op:
2491 case save_appl_op:
2492 case save_pair_op:
2493 case f_var_op: {
2494 Ventry *v = (Ventry *)(pc->rnd1);
2495
2496 if (v->FlagsOfVE & PermFlag && pc == v->FirstOpForV) {
2497 /* the second condition covers cases such as save_b_op
2498 in a disjunction */
2499 clear_bvarray((v->NoOfVE & MaskVarAdrs), vstat
2500#ifdef DEBUG
2501 ,
2502 cglobs
2503#endif
2504 );
2505 }
2506 } break;
2507 case push_or_op:
2508 Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
2509 pc->ops.opseqt[1] = (CELL)cglobs->labelno;
2510 add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
2511 push_bvmap((CELL)cglobs->labelno, cglobs->cint.cpc, cglobs);
2512 break;
2513 case either_op:
2514 /* add a first entry to the array */
2515 Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
2516 pc->ops.opseqt[1] = (CELL)cglobs->labelno;
2517 add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
2518 break;
2519 case pushpop_or_op:
2520 reset_bvmap(vstat, LOCAL_nperm, cglobs);
2521 goto reset_safe_map;
2522 case orelse_op:
2523 Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
2524 pc->ops.opseqt[1] = (CELL)cglobs->labelno;
2525 add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
2526 break;
2527 case pop_or_op:
2528 pop_bvmap(vstat, LOCAL_nperm, cglobs);
2529 goto reset_safe_map;
2530 break;
2531 case empty_call_op:
2532 /* just get ourselves a label describing how
2533 many permanent variables are alive */
2534 Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
2535 pc->rnd1 = (CELL)cglobs->labelno;
2536 add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
2537 break;
2538 case cut_op:
2539 case cutexit_op:
2540 /* just get ourselves a label describing how
2541 many permanent variables are alive */
2542 Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
2543 pc->rnd1 = (CELL)cglobs->labelno;
2544 add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
2545 break;
2546 case call_op:
2547 Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
2548 pc->ops.opseqt[1] = (CELL)cglobs->labelno;
2549 add_bvarray_op(pc, vstat, pc->rnd2, cglobs);
2550 case deallocate_op:
2551 reset_safe_map : {
2552 int n = pc->op == call_op ? pc->rnd2 : 0;
2553 int no;
2554
2555 while (pending) {
2556 Ventry *v = UnsafeStack[--pending].v;
2557
2558 v->FlagsOfVE &= ~SafeVar;
2559 no = (v->NoOfVE) & MaskVarAdrs;
2560 if (no >= n)
2561 UnsafeStack[pending].p->op = put_unsafe_op;
2562 }
2563 }
2564 default:
2565 break;
2566 }
2567 pc = pc->nextInst;
2568 }
2569 cglobs->cint.icpc = cglobs->cint.cpc;
2570 cglobs->cint.cpc = opc;
2571 cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
2572 cglobs->cint.CodeStart = OldCodeStart;
2573}
2574
2575static void
2576CheckVoids(compiler_struct *cglobs) { /* establish voids in the head and initial
2577 * uses */
2578 Ventry *ve;
2579 compiler_vm_op ic;
2580 struct PSEUDO *cpc;
2581
2582 cpc = cglobs->cint.CodeStart;
2583 while ((ic = cpc->op) != allocate_op) {
2584 switch (ic) {
2585 case get_var_op:
2586 case unify_var_op:
2587 case unify_last_var_op:
2588#ifdef SFUNC
2589 case unify_s_var_op:
2590#endif
2591 case save_pair_op:
2592 case save_appl_op:
2593 ve = ((Ventry *)cpc->rnd1);
2594 if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1) {
2595 ve->NoOfVE = ve->KindOfVE = VoidVar;
2596 if (ic == get_var_op || ic == save_pair_op || ic == save_appl_op
2597#ifdef SFUNC
2598 || ic == unify_s_var_op
2599#endif
2600 ) {
2601 cpc->op = nop_op;
2602 break;
2603 }
2604 }
2605 if (ic != get_var_op)
2606 break;
2607 case get_val_op:
2608 case get_atom_op:
2609 case get_num_op:
2610 case get_float_op:
2611 case get_dbterm_op:
2612 case get_longint_op:
2613 case get_string_op:
2614 case get_bigint_op:
2615 case get_list_op:
2616 case get_struct_op:
2617 cglobs->Uses[cpc->rnd2] = 1;
2618 break;
2619 case bccall_op:
2620 cglobs->Uses[cpc->rnd2] = 1;
2621 cglobs->Uses[cpc->rnd4] = 1;
2622 default:
2623 break;
2624 }
2625 cpc = cpc->nextInst;
2626 }
2627}
2628
2629static int checktemp(Int arg, Int rn, compiler_vm_op ic,
2630 compiler_struct *cglobs) {
2631 Ventry *v = (Ventry *)arg;
2632 PInstr *q;
2633 Int Needed[MaxTemps];
2634 Int r, target1, target2;
2635 Int n, *np, *rp;
2636 CELL *cp;
2637 Int vadr;
2638 Int vreg;
2639
2640 cglobs->vadr = vadr = (v->NoOfVE);
2641 cglobs->vreg = vreg = vadr & MaskVarAdrs;
2642 if (v->KindOfVE == PermVar || v->KindOfVE == VoidVar)
2643 return 0;
2644 if (v->RCountOfVE == 1)
2645 return 0;
2646 if (vreg) {
2647 --cglobs->Uses[vreg];
2648 return 1;
2649 }
2650 /* follow the life of the variable */
2651 q = cglobs->cint.cpc;
2652 /*
2653 * for(r=0; r<cglobs->MaxCTemps; ++r) Needed[r] = cglobs->Uses[r]; might be
2654 * written
2655 * as:
2656 */
2657 np = Needed;
2658 rp = cglobs->Uses;
2659 for (r = 0; r < cglobs->MaxCTemps; ++r)
2660 *np++ = *rp++;
2661 if (rn > 0 && (ic == get_var_op || ic == put_var_op)) {
2662 if (ic == put_var_op)
2663 Needed[rn] = 1;
2664 target1 = rn; /* try to leave it where it is */
2665 } else
2666 target1 = cglobs->MaxCTemps;
2667 target2 = cglobs->MaxCTemps;
2668 n = v->RCountOfVE - 1;
2669 while (q != v->LastOpForV && (q = q->nextInst) != NIL) {
2670 if (q->rnd2 <= 0)
2671 ; /* don't try to reuse REGISTER 0 */
2672 else if ((usesvar(ic = q->op) && arg == q->rnd1) ||
2673 (ic == bccall_op && arg == q->rnd3) /*uses_this_var(q, arg)*/) {
2674 ic = q->op;
2675 --n;
2676 if (ic == put_val_op) {
2677 if (target1 == cglobs->MaxCTemps && Needed[q->rnd2] == 0)
2678 target1 = q->rnd2;
2679 else if (target1 != (r = q->rnd2)) {
2680 if (target2 == cglobs->MaxCTemps && Needed[r] == 0)
2681 target2 = r;
2682 else if (target2 > r && cglobs->Uses[r] == 0 && Needed[r] == 0)
2683 target2 = r;
2684 }
2685 }
2686 }
2687#ifdef SFUNC
2688 else if ((ic >= get_var_op && ic <= put_unsafe_op) || ic == get_s_f_op ||
2689 ic == put_s_f_op)
2690 Needed[q->rnd2] = 1;
2691#else
2692 else if (ic >= get_var_op && ic <= put_unsafe_op)
2693 Needed[q->rnd2] = 1;
2694#endif
2695 if ((ic == call_op || ic == safe_call_op) && n == 0)
2696 break;
2697 }
2698 if (target2 < target1) {
2699 r = target2;
2700 target2 = target1;
2701 target1 = r;
2702 }
2703 if (target1 == cglobs->MaxCTemps || cglobs->Uses[target1] || Needed[target1])
2704 if ((target1 = target2) == cglobs->MaxCTemps || cglobs->Uses[target1] ||
2705 Needed[target1]) {
2706 target1 = cglobs->MaxCTemps;
2707 do
2708 --target1;
2709 while (target1 && cglobs->Uses[target1] == 0 && Needed[target1] == 0);
2710 ++target1;
2711 }
2712 if (target1 == cglobs->MaxCTemps) {
2713 CACHE_REGS
2714 Yap_ThrowError(SYSTEM_ERROR_COMPILER,TermNil, " maximum termporary limit MaxCTmps (%d) exceeded.", cglobs->MaxCTemps);
2715 save_machine_regs();
2716 siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
2717 }
2718 v->NoOfVE = cglobs->vadr = vadr = TempVar | target1;
2719 v->KindOfVE = TempVar;
2720 cglobs->Uses[cglobs->vreg = vreg = target1] = v->RCountOfVE - 1;
2721 /*
2722 * for(r=0; r<cglobs->MaxCTemps; ++r) if(cglobs->Contents[r]==vadr)
2723 * cglobs->Contents[r] =
2724 * NIL;
2725 */
2726 cp = cglobs->Contents;
2727 for (r = 0; r < cglobs->MaxCTemps; ++r)
2728 if (*cp++ == (Term)vadr)
2729 cp[-1] = NIL;
2730 cglobs->Contents[vreg] = vadr;
2731 return 1;
2732}
2733
2734static Int checkreg(Int arg, Int rn, compiler_vm_op ic, int var_arg,
2735 compiler_struct *cglobs) {
2736 PInstr *p = cglobs->cint.cpc;
2737 Int vreg;
2738
2739 if (rn >= 0)
2740 return rn;
2741 if (var_arg) {
2742 Ventry *v = (Ventry *)arg;
2743
2744 vreg = (v->NoOfVE) & MaskVarAdrs;
2745 if (v->KindOfVE == PermVar)
2746 vreg = 0;
2747 else if (vreg == 0) {
2748 checktemp(arg, rn, ic, cglobs);
2749 vreg = (v->NoOfVE) & MaskVarAdrs;
2750 ++cglobs->Uses[vreg];
2751 }
2752 if (!vreg) {
2753 vreg = 1;
2754 while (cglobs->Uses[vreg] != 0) {
2755 ++vreg;
2756 }
2757 cglobs->Uses[vreg] = v->RCountOfVE;
2758 }
2759 } else {
2760 vreg = 1;
2761 while (cglobs->Uses[vreg] != 0) {
2762 ++vreg;
2763 }
2764 }
2765 while (p) {
2766 if (p->op >= get_var_op && p->op <= put_unsafe_op && p->rnd2 == rn)
2767 p->rnd2 = vreg;
2768 /* only copy variables until you reach a call */
2769 if (p->op == procceed_op || p->op == call_op || p->op == push_or_op ||
2770 p->op == pushpop_or_op)
2771 break;
2772 p = p->nextInst;
2773 }
2774 return vreg;
2775}
2776
2777/* Create a bitmap with all live variables */
2778static CELL copy_live_temps_bmap(int max, compiler_struct *cglobs) {
2779 unsigned int size = AdjustSize((max | 7) / 8 + 1);
2780 int i;
2781 CELL *dest = Yap_emit_extra_size(mark_live_regs_op, max, size, &cglobs->cint);
2782 CELL *ptr = dest;
2783 *ptr = 0L;
2784 for (i = 1; i <= max; i++) {
2785 /* move to next cell */
2786 if (i % (8 * CellSize) == 0) {
2787 ptr++;
2788 *ptr = 0L;
2789 }
2790 /* set the register live bit */
2791 if (cglobs->Contents[i]) {
2792 int j = i % (8 * CellSize);
2793 *ptr |= (1 << j);
2794 }
2795 }
2796 return ((CELL)dest);
2797}
2798
2799static void c_layout(compiler_struct *cglobs) {
2800 CACHE_REGS
2801 PInstr *savepc = cglobs->BodyStart->nextInst;
2802 register Ventry *v = cglobs->vtable;
2803 Int *up = cglobs->Uses;
2804 CELL *cop = cglobs->Contents;
2805 /* tell put_values used in bip optimisation */
2806 int rn_kills = 0;
2807 Int rn_to_kill[2];
2808 int needs_either = 0;
2809
2810 rn_to_kill[0] = rn_to_kill[1] = 0;
2811 cglobs->cint.cpc = cglobs->BodyStart;
2812 /*
2813#ifdef BEAM
2814 if (!cglobs->is_a_fact || EAM) {
2815#else
2816 */
2817 if (!cglobs->is_a_fact) {
2818 while (v != NIL) {
2819 if (v->FlagsOfVE & BranchVar) {
2820 v->AgeOfVE = v->FirstOfVE + 1; /* force permanent */
2821 ++(v->RCountOfVE);
2822 Yap_emit(put_var_op, (CELL)v, Zero, &cglobs->cint);
2823 v->FlagsOfVE &= ~GlobalVal;
2824 v->FirstOpForV = cglobs->cint.cpc;
2825 }
2826 v = v->NextOfVE;
2827 }
2828 cglobs->cint.cpc->nextInst = savepc;
2829
2830#ifdef BEAM
2831 if (cglobs->needs_env || EAM) {
2832#else
2833 if (cglobs->needs_env) {
2834#endif
2835 LOCAL_nperm = 0;
2836 AssignPerm(cglobs->cint.CodeStart, cglobs);
2837#ifdef DEBUG
2838 cglobs->pbvars = 0;
2839#endif
2840 CheckUnsafe(cglobs->cint.CodeStart, cglobs);
2841#ifdef DEBUG
2842 if (cglobs->pbvars != LOCAL_nperm) {
2843 CACHE_REGS
2844 Yap_ThrowError(SYSTEM_ERROR_COMPILER,TermNil, " inconsistent calculations for permanent variables %d != %d", cglobs->pbvars, LOCAL_nperm);
2845 save_machine_regs();
2846 siglongjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
2847 }
2848#endif
2849 }
2850 }
2851
2852 cglobs->MaxCTemps = cglobs->nvars + cglobs->max_args - cglobs->tmpreg +
2853 cglobs->n_common_exps + 2;
2854 if (cglobs->MaxCTemps >= MaxTemps)
2855 cglobs->MaxCTemps = MaxTemps;
2856 {
2857 Int rn;
2858 for (rn = 0; rn < cglobs->MaxCTemps; ++rn) {
2859 /* cglobs->Uses[rn] = 0; cglobs->Contents[rn] = NIL; */
2860 *up++ = 0;
2861 *cop++ = NIL;
2862 }
2863 }
2864
2865 CheckVoids(cglobs);
2866
2867 /* second scan: allocate registers */
2868 cglobs->cint.cpc = cglobs->cint.CodeStart;
2869 while (cglobs->cint.cpc) {
2870 compiler_vm_op ic = cglobs->cint.cpc->op;
2871 Int arg = cglobs->cint.cpc->rnd1;
2872 Int rn = cglobs->cint.cpc->rnd2;
2873 switch (ic) {
2874 case pop_or_op:
2875 if (needs_either)
2876 needs_either--;
2877 case either_op:
2878 needs_either++;
2879 break;
2880#ifdef TABLING_INNER_CUTS
2881 case cut_op:
2882 case cutexit_op:
2883 cglobs->cut_mark->op = clause_with_cut_op;
2884 break;
2885#else
2886 case cut_op:
2887 case cutexit_op: {
2888 int i, max;
2889
2890 max = 0;
2891 for (i = 1; i < cglobs->MaxCTemps; ++i) {
2892 if (cglobs->Contents[i])
2893 max = i;
2894 }
2895 cglobs->cint.cpc->ops.opseqt[1] = max;
2896 } break;
2897#endif /* TABLING_INNER_CUTS */
2898 case allocate_op:
2899 case deallocate_op:
2900 if (!cglobs->needs_env) {
2901 cglobs->cint.cpc->op = nop_op;
2902 } else {
2903#ifdef TABLING
2904 PELOCK(51, cglobs->cint.CurrentPred);
2905 if (is_tabled(cglobs->cint.CurrentPred))
2906 cglobs->cint.cpc->op = nop_op;
2907 else
2908#endif /* TABLING */
2909 if (cglobs->goalno == 1 && !cglobs->or_found && LOCAL_nperm == 0)
2910 cglobs->cint.cpc->op = nop_op;
2911#ifdef TABLING
2912 UNLOCK(cglobs->cint.CurrentPred->PELock);
2913#endif
2914 }
2915 break;
2916 case pop_op:
2917 ic = (cglobs->cint.cpc->nextInst)->op;
2918 if (ic >= get_var_op && ic <= put_unsafe_op)
2919 cglobs->cint.cpc->op = nop_op;
2920 break;
2921 case get_var_op:
2922 --cglobs->Uses[rn];
2923 if (checktemp(arg, rn, ic, cglobs)) {
2924#ifdef BEAM
2925 if (cglobs->vreg == rn && !EAM)
2926#else
2927 if (cglobs->vreg == rn)
2928#endif
2929 cglobs->cint.cpc->op = nop_op;
2930 }
2931 if (!cglobs->Uses[rn])
2932 cglobs->Contents[rn] = cglobs->vadr;
2933 break;
2934 case get_val_op:
2935 --cglobs->Uses[rn];
2936 checktemp(arg, rn, ic, cglobs);
2937 if (!cglobs->Uses[rn])
2938 cglobs->Contents[rn] = cglobs->vadr;
2939 break;
2940 case f_0_op:
2941 if (rn_to_kill[0])
2942 --cglobs->Uses[rn_to_kill[0]];
2943 rn_to_kill[1] = rn_to_kill[0] = 0;
2944 break;
2945 case f_var_op:
2946 if (rn_to_kill[0])
2947 --cglobs->Uses[rn_to_kill[0]];
2948 rn_to_kill[1] = rn_to_kill[0] = 0;
2949 case unify_var_op:
2950 case unify_val_op:
2951 case unify_last_var_op:
2952 case unify_last_val_op:
2953#ifdef SFUNC
2954 case unify_s_var_op:
2955 case unify_s_val_op:
2956#endif
2957 checktemp(arg, rn, ic, cglobs);
2958 break;
2959 case bccall_op:
2960 checktemp(arg, rn, ic, cglobs);
2961 checktemp(cglobs->cint.cpc->rnd3, cglobs->cint.cpc->rnd4, ic, cglobs);
2962 break;
2963 case get_atom_op:
2964 case get_num_op:
2965 case get_float_op:
2966 case get_longint_op:
2967 case get_string_op:
2968 case get_dbterm_op:
2969 case get_bigint_op:
2970 --cglobs->Uses[rn];
2971 /* This is not safe if we are in the middle of a disjunction and there
2972 is something ahead.
2973 */
2974 if (!cglobs->Uses[rn])
2975 cglobs->Contents[rn] = arg;
2976 break;
2977 case get_list_op:
2978 case get_struct_op:
2979 --cglobs->Uses[rn];
2980 if (!cglobs->Uses[rn])
2981 cglobs->Contents[rn] = NIL;
2982 break;
2983 case put_var_op:
2984 case put_unsafe_op:
2985 rn = checkreg(arg, rn, ic, TRUE, cglobs);
2986 checktemp(arg, rn, ic, cglobs);
2987 cglobs->Contents[rn] = cglobs->vadr;
2988 ++cglobs->Uses[rn];
2989 break;
2990 case put_val_op:
2991 rn = checkreg(arg, rn, ic, TRUE, cglobs);
2992 checktemp(arg, rn, ic, cglobs);
2993#ifdef BEAM
2994 if (rn && cglobs->Contents[rn] == (Term)cglobs->vadr && !EAM)
2995#else
2996 if (rn && cglobs->Contents[rn] == (Term)cglobs->vadr)
2997#endif
2998 {
2999 cglobs->cint.cpc->op = nop_op;
3000 }
3001 cglobs->Contents[rn] = cglobs->vadr;
3002 ++cglobs->Uses[rn];
3003 if (rn_kills) {
3004 rn_kills--;
3005 rn_to_kill[rn_kills] = rn;
3006 }
3007 break;
3008 case fetch_args_cv_op:
3009 case fetch_args_vc_op:
3010 case fetch_args_iv_op:
3011 case fetch_args_vi_op:
3012 rn_to_kill[1] = rn_to_kill[0] = 0;
3013 if (cglobs->cint.cpc->nextInst &&
3014 cglobs->cint.cpc->nextInst->op == put_val_op &&
3015 cglobs->cint.cpc->nextInst->nextInst &&
3016 (cglobs->cint.cpc->nextInst->nextInst->op == f_var_op ||
3017 cglobs->cint.cpc->nextInst->nextInst->op == f_0_op))
3018 rn_kills = 1;
3019 break;
3020 case f_val_op:
3021#ifdef SFUNC
3022 case write_s_var_op: {
3023 Ventry *ve = (Ventry *)arg;
3024
3025 if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1)
3026 cglobs->cint.cpc->op = nop_op;
3027 } break;
3028 case write_s_val_op:
3029#endif
3030 case write_var_op:
3031 case write_val_op:
3032 checktemp(arg, rn, ic, cglobs);
3033 break;
3034#ifdef SFUNC
3035 case put_s_f_op:
3036 cglobs->Contents[rn] = arg;
3037 ++cglobs->Uses[rn];
3038 break;
3039#endif
3040 case put_atom_op:
3041 case put_num_op:
3042 case put_float_op:
3043 case put_longint_op:
3044 case put_string_op:
3045 case put_dbterm_op:
3046 case put_bigint_op:
3047 rn = checkreg(arg, rn, ic, FALSE, cglobs);
3048 if (cglobs->Contents[rn] == arg)
3049 cglobs->cint.cpc->op = nop_op;
3050 cglobs->Contents[rn] = arg;
3051 ++cglobs->Uses[rn];
3052 break;
3053 case put_list_op:
3054 case put_struct_op:
3055 rn = checkreg(arg, rn, ic, FALSE, cglobs);
3056 cglobs->Contents[rn] = NIL;
3057 ++cglobs->Uses[rn];
3058 break;
3059 case commit_b_op:
3060 case soft_cut_b_op:
3061#ifdef TABLING_INNER_CUTS
3062 cglobs->cut_mark->op = clause_with_cut_op;
3063#endif /* TABLING_INNER_CUTS */
3064 case save_b_op:
3065 case patch_b_op:
3066 case save_appl_op:
3067 case save_pair_op:
3068 checktemp(arg, rn, ic, cglobs);
3069 break;
3070 case safe_call_op:
3071 /*
3072 vsc: The variables will be in use after this!!!!
3073 {
3074 UInt Arity = RepPredProp((Prop) arg)->ArityOfPE;
3075 for (rn = 1; rn <= Arity; ++rn)
3076 --cglobs->Uses[rn];
3077 }
3078 */
3079 break;
3080 case call_op:
3081 case orelse_op:
3082 case orlast_op: {
3083 up = cglobs->Uses;
3084 cop = cglobs->Contents;
3085 for (rn = 1; rn < cglobs->MaxCTemps; ++rn) {
3086 *up++ = *cop++ = NIL;
3087 }
3088 } break;
3089 case label_op: {
3090 up = cglobs->Uses;
3091 cop = cglobs->Contents;
3092 for (rn = 0; rn < cglobs->MaxCTemps; ++rn) {
3093 if (*cop != (TempVar | rn)) {
3094 *up++ = *cop++ = NIL;
3095 } else {
3096 up++;
3097 cop++;
3098 }
3099 }
3100 } break;
3101 case restore_tmps_and_skip_op:
3102 case restore_tmps_op:
3103 /*
3104 This instruction is required by the garbage collector to find out
3105 how many temporaries are live right now. It is also useful when
3106 waking up goals before an either or ! instruction.
3107 */
3108 {
3109 PInstr *mycpc = cglobs->cint.cpc,
3110 *oldCodeStart = cglobs->cint.CodeStart;
3111 int i, max;
3112
3113 /* instructions must be placed at BlobsStart */
3114 cglobs->cint.CodeStart = cglobs->cint.BlobsStart;
3115 cglobs->cint.cpc = cglobs->cint.icpc;
3116 max = 0;
3117 for (i = 1; i < cglobs->MaxCTemps; ++i) {
3118 if (cglobs->Contents[i])
3119 max = i;
3120 }
3121 Yap_emit(label_op, ++cglobs->labelno, Zero, &cglobs->cint);
3122 mycpc->rnd1 = cglobs->labelno;
3123 rn = copy_live_temps_bmap(max, cglobs);
3124 cglobs->cint.icpc = cglobs->cint.cpc;
3125 cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
3126 cglobs->cint.cpc = mycpc;
3127 cglobs->cint.CodeStart = oldCodeStart;
3128 }
3129 default:
3130 break;
3131 }
3132 if (cglobs->cint.cpc->nextInst)
3133 cglobs->cint.cpc = cglobs->cint.cpc->nextInst;
3134 else
3135 return;
3136 }
3137}
3138
3139static void push_allocate(PInstr *pc, PInstr *oldpc) {
3140 /*
3141 The idea is to push an allocate forward as much as we can. This
3142 delays work in the emulated code, and in the best case we may get rid of
3143 allocates altogether.
3144 */
3145 /* we can push the allocate */
3146 int safe = TRUE;
3147 PInstr *initial = oldpc, *dealloc_founds[16];
3148 int d_founds = 0;
3149 int level = 0;
3150
3151 while (pc) {
3152 switch (pc->op) {
3153 case jump_op:
3154 return;
3155 case call_op:
3156 case safe_call_op:
3157 if (!safe)
3158 return;
3159 else {
3160 PInstr *where = initial->nextInst->nextInst;
3161 while (d_founds)
3162 dealloc_founds[--d_founds]->op = nop_op;
3163 if (where == pc || oldpc == initial->nextInst)
3164 return;
3165 oldpc->nextInst = initial->nextInst;
3166 initial->nextInst->nextInst = pc;
3167 initial->nextInst = where;
3168 return;
3169 }
3170 case push_or_op:
3171 /* we cannot just put an allocate here, because it may never be executed
3172 */
3173 level++;
3174 safe = FALSE;
3175 break;
3176 case pushpop_or_op:
3177 /* last branch and we did not need an allocate so far, cool! */
3178 level--;
3179 if (!level)
3180 safe = TRUE;
3181 break;
3182 case cut_op:
3183 case either_op:
3184 case execute_op:
3185 return;
3186 case deallocate_op:
3187 dealloc_founds[d_founds++] = pc;
3188 if (d_founds == 16)
3189 return;
3190 default:
3191 break;
3192 }
3193 oldpc = pc;
3194 pc = pc->nextInst;
3195 }
3196}
3197
3198static void c_optimize(PInstr *pc) {
3199 char onTail;
3200 Ventry *v;
3201 PInstr *opc = NULL;
3202 PInstr *inpc = pc;
3203
3204 pc = inpc;
3205 opc = NULL;
3206 /* first reverse the pointers */
3207 while (pc != NULL) {
3208 PInstr *tpc = pc->nextInst;
3209 pc->nextInst = opc;
3210 opc = pc;
3211 pc = tpc;
3212 }
3213 pc = opc;
3214 opc = NULL;
3215 onTail = 1;
3216 do {
3217 PInstr *npc = pc->nextInst;
3218 pc->nextInst = opc;
3219 switch (pc->op) {
3220 case get_var_op:
3221 /* handle clumsy either branches */
3222 if (npc->op == f_0_op) {
3223 npc->rnd1 = pc->rnd1;
3224 npc->op = f_var_op;
3225 pc->op = nop_op;
3226 break;
3227 }
3228 case put_val_op:
3229 case get_val_op: {
3230 Ventry *ve = (Ventry *)pc->rnd1;
3231
3232 if (ve->KindOfVE == TempVar) {
3233 UInt argno = ve->NoOfVE & MaskVarAdrs;
3234 if (argno && argno == pc->rnd2) {
3235 pc->op = nop_op;
3236 }
3237 }
3238 }
3239 onTail = 1;
3240 break;
3241 case save_pair_op: {
3242 Term ve = (Term)pc->rnd1;
3243 PInstr *npc = pc->nextInst;
3244
3245 if (((Ventry *)ve)->RCountOfVE <= 1)
3246 pc->op = nop_op;
3247 else {
3248 *pc = *npc;
3249 pc->nextInst = npc;
3250 npc->op = save_pair_op;
3251 npc->rnd1 = (CELL)ve;
3252 }
3253 } break;
3254 case save_appl_op: {
3255 Term ve = (Term)pc->rnd1;
3256 PInstr *npc = pc->nextInst;
3257
3258 if (((Ventry *)ve)->RCountOfVE <= 1)
3259 pc->op = nop_op;
3260 else {
3261 *pc = *npc;
3262 pc->nextInst = npc;
3263 npc->op = save_appl_op;
3264 npc->rnd1 = (CELL)ve;
3265 }
3266 break;
3267 }
3268 case nop_op:
3269 break;
3270 case unify_var_op:
3271 case unify_last_var_op:
3272#ifdef OLD_SYSTEM
3273 /* In the good old days Yap would remove lots of small void
3274 * instructions for a structure. This is not such a
3275 * good idea nowadays, as we need to know where we
3276 * finish the structure for the last instructions to
3277 * work correctly. Instead, we will use unify_void
3278 * with very little overhead */
3279 v = (Ventry *)(pc->rnd1);
3280 if (v->KindOfVE == VoidVar && onTail) {
3281 pc->op = nop_op;
3282 } else
3283#endif /* OLD_SYSTEM */
3284 onTail = 0;
3285 break;
3286 case unify_val_op:
3287 v = (Ventry *)(pc->rnd1);
3288 if (!(v->FlagsOfVE & GlobalVal))
3289 pc->op = unify_local_op;
3290 onTail = 0;
3291 break;
3292 case unify_last_val_op:
3293 v = (Ventry *)(pc->rnd1);
3294 if (!(v->FlagsOfVE & GlobalVal))
3295 pc->op = unify_last_local_op;
3296 onTail = 0;
3297 break;
3298 case write_val_op:
3299 v = (Ventry *)(pc->rnd1);
3300 if (!(v->FlagsOfVE & GlobalVal))
3301 pc->op = write_local_op;
3302 onTail = 0;
3303 break;
3304 case pop_op:
3305 if (FALSE && onTail == 1) {
3306 pc->op = nop_op;
3307 onTail = 1;
3308 break;
3309 } else {
3310 PInstr *p = pc->nextInst;
3311
3312 while (p != NIL && p->op == nop_op)
3313 p = p->nextInst;
3314 if (p != NIL && p->op == pop_op) {
3315 pc->rnd1 += p->rnd1;
3316 pc->nextInst = p->nextInst;
3317 }
3318 onTail = 2;
3319 break;
3320 }
3321 case write_var_op:
3322 case unify_atom_op:
3323 case unify_last_atom_op:
3324 case write_atom_op:
3325 case unify_num_op:
3326 case unify_last_num_op:
3327 case write_num_op:
3328 case unify_float_op:
3329 case unify_last_float_op:
3330 case write_float_op:
3331 case unify_longint_op:
3332 case unify_string_op:
3333 case unify_bigint_op:
3334 case unify_last_longint_op:
3335 case unify_last_string_op:
3336 case unify_last_bigint_op:
3337 case write_longint_op:
3338 case write_string_op:
3339 case write_bigint_op:
3340 case unify_list_op:
3341 case write_list_op:
3342 case unify_struct_op:
3343 case write_struct_op:
3344 case write_unsafe_op:
3345 case unify_last_list_op:
3346 case write_last_list_op:
3347 case unify_last_struct_op:
3348 case write_last_struct_op:
3349#ifdef SFUNC
3350 case unify_s_f_op:
3351 case write_s_f_op:
3352#endif
3353 onTail = 0;
3354 break;
3355 default:
3356 onTail = 1;
3357 break;
3358 }
3359 opc = pc;
3360 pc = npc;
3361 } while (pc != NULL);
3362 pc = inpc;
3363 opc = NULL;
3364 while (pc != NULL) {
3365 if (pc->op == allocate_op) {
3366 push_allocate(pc, opc);
3367 break;
3368 }
3369 opc = pc;
3370 pc = pc->nextInst;
3371 }
3372}
3373
3374yamop *Yap_cclause(volatile Term inp_clause, Int NOfArgs, Term mod,
3375 volatile Term src) { /* compile a prolog clause, copy of
3376 clause myst be in ARG1 */
3377 CACHE_REGS
3378 /* returns address of code for clause */
3379 Term head, body;
3380 yamop *acode;
3381 Term my_clause;
3382
3383 volatile int maxvnum = 512;
3384 int botch_why;
3385 /* may botch while doing a different module */
3386 /* first, initialize cglobs->cint.CompilerBotch to handle all cases of
3387 * interruptions */
3388 compiler_struct cglobs;
3389
3390#ifdef TABLING_INNER_CUTS
3391 PInstr cglobs_cut_mark;
3392 cglobs.cut_mark = &cglobs_cut_mark;
3393#endif /* TABLING_INNER_CUTS */
3394
3395 /* make sure we know there was no error yet */
3396 if (LOCAL_ActiveError)
3397 LOCAL_Error_TYPE = YAP_NO_ERROR;
3398 if ((botch_why = sigsetjmp(cglobs.cint.CompilerBotch, 0))) {
3399 restore_machine_regs();
3400 reset_vars(cglobs.vtable);
3401 Yap_ReleaseCMem(&cglobs.cint);
3402 switch (botch_why) {
3403 case OUT_OF_STACK_BOTCH:
3404 /* out of local stack, just duplicate the stack */
3405 {
3406 Int osize = 2 * sizeof(CELL) * (ASP - HR);
3407 ARG1 = inp_clause;
3408 ARG3 = src;
3409
3410 YAPLeaveCriticalSection();
3411 if (!Yap_dogc()) {
3412 LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
3413 }
3414 if (osize > ASP - HR) {
3415 if (!Yap_growstack(2 * sizeof(CELL) * (ASP - HR))) {
3416 LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
3417 }
3418 }
3419 YAPEnterCriticalSection();
3420 src = ARG3;
3421 inp_clause = ARG1;
3422 }
3423 break;
3424 case OUT_OF_AUX_BOTCH:
3425 /* out of local stack, just duplicate the stack */
3426 YAPLeaveCriticalSection();
3427 ARG1 = inp_clause;
3428 ARG3 = src;
3429 if (!Yap_ExpandPreAllocCodeSpace(LOCAL_Error_Size, NULL, TRUE)) {
3430 LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
3431 }
3432 YAPEnterCriticalSection();
3433 src = ARG3;
3434 inp_clause = ARG1;
3435 break;
3436 case OUT_OF_TEMPS_BOTCH:
3437 /* out of temporary cells */
3438 if (maxvnum < 16 * 1024) {
3439 maxvnum *= 2;
3440 } else {
3441 maxvnum += 4096;
3442 }
3443 break;
3444 case OUT_OF_HEAP_BOTCH:
3445 /* not enough heap */
3446 ARG1 = inp_clause;
3447 ARG3 = src;
3448 YAPLeaveCriticalSection();
3449 if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) {
3450 LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
3451 return NULL;
3452 }
3453 YAPEnterCriticalSection();
3454 src = ARG3;
3455 inp_clause = ARG1;
3456 break;
3457 case OUT_OF_TRAIL_BOTCH:
3458 /* not enough trail */
3459 ARG1 = inp_clause;
3460 ARG3 = src;
3461 YAPLeaveCriticalSection();
3462 if (!Yap_growtrail(LOCAL_TrailTop - (ADDR)TR, FALSE)) {
3463 LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
3464 return NULL;
3465 }
3466 YAPEnterCriticalSection();
3467 src = ARG3;
3468 inp_clause = ARG1;
3469 break;
3470 default:
3471 return NULL;
3472 }
3473 }
3474 my_clause = inp_clause;
3475 HB = HR;
3476 LOCAL_Error_TYPE = YAP_NO_ERROR;
3477 /* initialize variables for code generation */
3478
3479 cglobs.cint.CodeStart = cglobs.cint.cpc = NULL;
3480 cglobs.cint.BlobsStart = cglobs.cint.icpc = NULL;
3481 cglobs.cint.dbterml = NULL;
3482 cglobs.cint.blks = NULL;
3483 cglobs.cint.label_offset = NULL;
3484 cglobs.cint.freep = cglobs.cint.freep0 =
3485 (char *)(HR + maxvnum + (sizeof(Int) / sizeof(CELL)) * MaxTemps +
3486 MaxTemps);
3487 cglobs.cint.success_handler = 0L;
3488 if (ASP <= CellPtr(cglobs.cint.freep) + 256) {
3489 cglobs.vtable = NULL;
3490 LOCAL_Error_Size = (256 + maxvnum) * sizeof(CELL);
3491 save_machine_regs();
3492 siglongjmp(cglobs.cint.CompilerBotch, 3);
3493 }
3494 cglobs.Uses = (Int *)(HR + maxvnum);
3495 cglobs.Contents =
3496 (Term *)(HR + maxvnum + (sizeof(Int) / sizeof(CELL)) * MaxTemps);
3497 cglobs.curbranch = cglobs.onbranch = 0;
3498 cglobs.branch_pointer = cglobs.parent_branches;
3499 cglobs.or_found = FALSE;
3500 cglobs.max_args = 0;
3501 cglobs.nvars = 0;
3502 cglobs.tmpreg = 0;
3503 cglobs.needs_env = FALSE;
3504 /*
3505 * 2000 added to H in case we need to construct call(G) when G is a
3506 * variable used as a goal
3507 */
3508 cglobs.vtable = NULL;
3509 cglobs.common_exps = NULL;
3510 cglobs.n_common_exps = 0;
3511 cglobs.labelno = 0L;
3512 cglobs.is_a_fact = FALSE;
3513 cglobs.hasdbrefs = FALSE;
3514 if (IsVarTerm(my_clause)) {
3515 Yap_ThrowError(INSTANTIATION_ERROR, my_clause, " clause is not bound");
3516 return 0;
3517 }
3518 if (IsApplTerm(my_clause) && FunctorOfTerm(my_clause) == FunctorAssert) {
3519 head = ArgOfTerm(1, my_clause);
3520 body = ArgOfTerm(2, my_clause);
3521 } else {
3522 head = my_clause, body = MkAtomTerm(AtomTrue);
3523 }
3524 if (IsVarTerm(head) || IsPairTerm(head) || IsIntTerm(head) ||
3525 IsFloatTerm(head) || IsRefTerm(head)) {
3526 Yap_ThrowError(TYPE_ERROR_CALLABLE, head, "clause head should be atom or compound term");
3527 return (0);
3528 } else {
3529 head = Yap_YapStripModule(head, &mod);
3530 if (IsAtomTerm(head)) {
3531 Atom ap = AtomOfTerm(head);
3532 cglobs.cint.CurrentPred = RepPredProp(PredPropByAtom(ap, mod));
3533 } else {
3534 Functor f = FunctorOfTerm(head);
3535 cglobs.cint.CurrentPred =
3536 RepPredProp(PredPropByFunc(f, mod));
3537 }
3538 /* insert extra instructions to count calls */
3539 PELOCK(52, cglobs.cint.CurrentPred);
3540 if ((cglobs.cint.CurrentPred->PredFlags & ProfiledPredFlag) ||
3541 (PROFILING &&
3542 (cglobs.cint.CurrentPred->cs.p_code.FirstClause == NIL))) {
3543 profiling = TRUE;
3544 call_counting = FALSE;
3545 } else if ((cglobs.cint.CurrentPred->PredFlags & CountPredFlag) ||
3546 (CALL_COUNTING &&
3547 (cglobs.cint.CurrentPred->cs.p_code.FirstClause == NIL))) {
3548 call_counting = TRUE;
3549 profiling = FALSE;
3550 } else {
3551 profiling = FALSE;
3552 call_counting = FALSE;
3553 }
3554 UNLOCK(cglobs.cint.CurrentPred->PELock);
3555 }
3556 cglobs.is_a_fact = (body == MkAtomTerm(AtomTrue));
3557 /* phase 1 : produce skeleton code and variable information */
3558
3559 c_head(head, &cglobs);
3560
3561 if (cglobs.is_a_fact && !cglobs.vtable) {
3562#ifdef TABLING
3563 PELOCK(53, cglobs.cint.CurrentPred);
3564 if (is_tabled(cglobs.cint.CurrentPred))
3565 Yap_emit(table_new_answer_op, Zero, cglobs.cint.CurrentPred->ArityOfPE,
3566 &cglobs.cint);
3567 else
3568#endif /* TABLING */
3569 Yap_emit(procceed_op, Zero, Zero, &cglobs.cint);
3570#ifdef TABLING
3571 UNLOCK(cglobs.cint.CurrentPred->PELock);
3572#endif
3573 /* ground term, do not need much more work */
3574 if (cglobs.cint.BlobsStart != NULL) {
3575 cglobs.cint.cpc->nextInst = cglobs.cint.BlobsStart;
3576 cglobs.cint.BlobsStart = NULL;
3577 }
3578 if (LOCAL_ErrorMessage)
3579 return (0);
3580 /* make sure we give enough space for the fact */
3581 if (cglobs.space_op)
3582 cglobs.space_op->rnd1 = cglobs.space_used;
3583
3584#ifdef DEBUG
3585 if (GLOBAL_Option['g' - 96])
3586 Yap_ShowCode(&cglobs.cint);
3587#endif
3588 } else {
3589#ifdef TABLING_INNER_CUTS
3590 Yap_emit(nop_op, Zero, Zero, &cglobs.cint);
3591 cglobs.cut_mark->op = clause_with_cut_op;
3592#endif /* TABLING_INNER_CUTS */
3593 Yap_emit(allocate_op, Zero, Zero, &cglobs.cint);
3594
3595#ifdef BEAM
3596 if (EAM)
3597 Yap_emit(body_op, Zero, Zero, &cglobs.cint);
3598#endif
3599
3600 c_body(body, mod, &cglobs);
3601 /* Insert blobs at the very end */
3602
3603 if (cglobs.space_op)
3604 cglobs.space_op->rnd1 = cglobs.space_used;
3605
3606 if (cglobs.cint.BlobsStart != NULL) {
3607 cglobs.cint.cpc->nextInst = cglobs.cint.BlobsStart;
3608 cglobs.cint.BlobsStart = NULL;
3609 }
3610
3611 reset_vars(cglobs.vtable);
3612 HR = HB;
3613 if (B != NULL) {
3614 HB = B->cp_h;
3615 }
3616 if (LOCAL_ErrorMessage)
3617 return (0);
3618#ifdef DEBUG
3619 if (GLOBAL_Option['g' - 96])
3620 Yap_ShowCode(&cglobs.cint);
3621#endif
3622 /* phase 2: classify variables and optimize temporaries */
3623 c_layout(&cglobs);
3624 /* Insert blobs at the very end */
3625 if (cglobs.cint.BlobsStart != NULL) {
3626 cglobs.cint.cpc->nextInst = cglobs.cint.BlobsStart;
3627 cglobs.cint.BlobsStart = NULL;
3628 while (cglobs.cint.cpc->nextInst != NULL)
3629 cglobs.cint.cpc = cglobs.cint.cpc->nextInst;
3630 }
3631 }
3632 /* eliminate superfluous pop's and unify_var's */
3633 c_optimize(cglobs.cint.CodeStart);
3634#ifdef DEBUG
3635 if (GLOBAL_Option['f' - 96])
3636 Yap_ShowCode(&cglobs.cint);
3637#endif
3638
3639#ifdef BEAM
3640 {
3641 void codigo_eam(compiler_struct *);
3642
3643 if (EAM)
3644 codigo_eam(&cglobs);
3645 }
3646#endif
3647
3648 /* phase 3: assemble code */
3649 acode = Yap_assemble(ASSEMBLING_CLAUSE, src, cglobs.cint.CurrentPred,
3650 (cglobs.is_a_fact && !cglobs.hasdbrefs &&
3651 !(cglobs.cint.CurrentPred->PredFlags & TabledPredFlag)),
3652 &cglobs.cint, cglobs.labelno + 1);
3653 /* check first if there was space for us */
3654 Yap_ReleaseCMem(&cglobs.cint);
3655 if (acode == NULL) {
3656 Yap_ThrowError(SYSTEM_ERROR_COMPILER,src, "assembler did not generate code");
3657 return NULL;
3658 } else {
3659 return acode;
3660 }
3661}
3662
3663#ifdef BEAM
3664#include "toeam.c"
3665#endif
Yap.h
Main definitions.
source
@ source
If true maintain the source for all clauses.
Definition: YapGFlagInfo.h:601
profiling
@ profiling
profiling
Definition: YapGFlagInfo.h:479
call_counting
@ call_counting
Predicates compiled with this flag set maintain a counter on the numbers of proceduree calls and of r...
Definition: YapLFlagInfo.h:56
DB_TERM
Definition: Yatom.h:689
MP_INT
Definition: TermExt.h:345
branch_descriptor
Definition: compiler.c:188
compiler_struct_struct
Definition: compiler.c:193
env_tmp
Definition: compiler.c:2215
m
A matrix.
Definition: matrix.c:68
pred_entry
Definition: Yatom.h:544
yami
Definition: amidefs.h:264