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