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: exec.c *
12 * Last rev: 8/2/88 *
13 * mods: *
14 * comments: Execute Prolog code *
15 * *
16 *************************************************************************/
17 #ifdef SCCS
18 static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
19 #endif
20
21 #include "absmi.h"
22 #include "yapio.h"
23 #include "attvar.h"
24 #ifdef CUT_C
25 #include "cut_c.h"
26 #endif
27 #if defined MYDDAS_ODBC || defined MYDDAS_MYSQL
28 #include "myddas.h"
29 #endif
30
31 STATIC_PROTO(Int CallPredicate, (PredEntry *, choiceptr, yamop *));
32 STATIC_PROTO(Int EnterCreepMode, (Term, Term));
33 STATIC_PROTO(Int p_save_cp, (void));
34 STATIC_PROTO(Int p_execute, (void));
35 STATIC_PROTO(Int p_execute0, (void));
36
37 static Term
cp_as_integer(choiceptr cp)38 cp_as_integer(choiceptr cp)
39 {
40 return(MkIntegerTerm(LCL0-(CELL *)cp));
41 }
42
43 static choiceptr
cp_from_integer(Term cpt)44 cp_from_integer(Term cpt)
45 {
46 return (choiceptr)(LCL0-IntegerOfTerm(cpt));
47 }
48
49 Term
Yap_cp_as_integer(choiceptr cp)50 Yap_cp_as_integer(choiceptr cp)
51 {
52 return cp_as_integer(cp);
53 }
54
55 static inline Int
CallPredicate(PredEntry * pen,choiceptr cut_pt,yamop * code)56 CallPredicate(PredEntry *pen, choiceptr cut_pt, yamop *code) {
57 #ifdef LOW_LEVEL_TRACER
58 if (Yap_do_low_level_trace)
59 low_level_trace(enter_pred,pen,XREGS+1);
60 #endif /* LOW_LEVEL_TRACE */
61 #ifdef DEPTH_LIMIT
62 if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is prolog */
63 if (pen->ModuleOfPred) {
64 if (DEPTH == MkIntTerm(0)) {
65 UNLOCK(pen->PELock);
66 return FALSE;
67 }
68 else DEPTH = RESET_DEPTH();
69 }
70 } else if (pen->ModuleOfPred)
71 DEPTH -= MkIntConstant(2);
72 #endif /* DEPTH_LIMIT */
73 if (P->opc != EXECUTE_CPRED_OP_CODE) {
74 CP = P;
75 ENV = YENV;
76 YENV = ASP;
77 }
78 /* make sure we have access to the user given cut */
79 YENV[E_CB] = (CELL) cut_pt;
80 P = code;
81 return TRUE;
82 }
83
84 inline static Int
CallMetaCall(Term mod)85 CallMetaCall(Term mod) {
86 ARG2 = cp_as_integer(B); /* p_save_cp */
87 ARG3 = ARG1;
88 if (mod) {
89 ARG4 = mod;
90 } else {
91 ARG4 = TermProlog;
92 }
93 return (CallPredicate(PredMetaCall, B, PredMetaCall->CodeOfPred));
94 }
95
96 Term
Yap_ExecuteCallMetaCall(Term mod)97 Yap_ExecuteCallMetaCall(Term mod) {
98 Term ts[4];
99 ts[0] = ARG1;
100 ts[1] = cp_as_integer(B); /* p_save_cp */
101 ts[2] = ARG1;
102 ts[3] = mod;
103 return(Yap_MkApplTerm(PredMetaCall->FunctorOfPred,4,ts));
104 }
105
106 static Int
CallError(yap_error_number err,Term mod)107 CallError(yap_error_number err, Term mod)
108 {
109 if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
110 return(CallMetaCall(mod));
111 } else {
112 Yap_Error(err, ARG1, "call/1");
113 return(FALSE);
114 }
115 }
116
117 static Int
p_save_cp(void)118 p_save_cp(void)
119 {
120 Term t = Deref(ARG1);
121 Term td;
122 #if SHADOW_HB
123 register CELL *HBREG = HB;
124 #endif
125 if (!IsVarTerm(t)) return(FALSE);
126 td = cp_as_integer(B);
127 BIND((CELL *)t,td,bind_save_cp);
128 #ifdef COROUTINING
129 DO_TRAIL(VarOfTerm(t), td);
130 if (IsAttVar(VarOfTerm(t))) Yap_WakeUp((CELL *)t);
131 bind_save_cp:
132 #endif
133 return(TRUE);
134 }
135
136 static Int
p_save_env_b(void)137 p_save_env_b(void)
138 {
139 Term t = Deref(ARG1);
140 Term td;
141 #if SHADOW_HB
142 register CELL *HBREG = HB;
143 #endif
144 if (!IsVarTerm(t)) return(FALSE);
145 td = cp_as_integer((choiceptr)YENV[E_CB]);
146 BIND((CELL *)t,td,bind_save_cp);
147 #ifdef COROUTINING
148 DO_TRAIL(VarOfTerm(t), td);
149 if (IsAttVar(VarOfTerm(t))) Yap_WakeUp((CELL *)t);
150 bind_save_cp:
151 #endif
152 return(TRUE);
153 }
154
155 static Int
p_trail_suspension_marker(void)156 p_trail_suspension_marker(void)
157 {
158 Term t = Deref(ARG1);
159
160 TrailTerm(TR) = AbsPair((CELL*)t);
161 TR++;
162 return TRUE;
163 }
164
165 inline static Int
do_execute(Term t,Term mod)166 do_execute(Term t, Term mod)
167 {
168 /* first do predicate expansion, even before you process signals.
169 This way you don't get to spy goal_expansion(). */
170 if (PRED_GOAL_EXPANSION_ALL) {
171 LOCK(SignalLock);
172 /* disable creeping when we do goal expansion */
173 if (ActiveSignals & YAP_CREEP_SIGNAL && !Yap_InterruptsDisabled) {
174 ActiveSignals &= ~YAP_CREEP_SIGNAL;
175 CreepFlag = CalculateStackGap();
176 }
177 UNLOCK(SignalLock);
178 return CallMetaCall(mod);
179 } else if (ActiveSignals && !Yap_InterruptsDisabled) {
180 return EnterCreepMode(t, mod);
181 }
182 restart_exec:
183 if (IsVarTerm(t)) {
184 return CallError(INSTANTIATION_ERROR, mod);
185 } else if (IsApplTerm(t)) {
186 register Functor f = FunctorOfTerm(t);
187 register CELL *pt;
188 PredEntry *pen;
189 unsigned int i, arity;
190
191 f = FunctorOfTerm(t);
192 if (IsExtensionFunctor(f)) {
193 return CallError(TYPE_ERROR_CALLABLE, t);
194 }
195 arity = ArityOfFunctor(f);
196 if (arity > MaxTemps) {
197 return CallError(TYPE_ERROR_CALLABLE, t);
198 }
199 pen = RepPredProp(PredPropByFunc(f, mod));
200 /* You thought we would be over by now */
201 /* but no meta calls require special preprocessing */
202 if (pen->PredFlags & (GoalExPredFlag|MetaPredFlag)) {
203 if (f == FunctorModule) {
204 Term tmod = ArgOfTerm(1,t);
205 if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
206 mod = tmod;
207 t = ArgOfTerm(2,t);
208 goto restart_exec;
209 } else {
210 if (IsVarTerm(tmod)) {
211 return CallError(INSTANTIATION_ERROR,t);
212 } else {
213 return CallError(TYPE_ERROR_ATOM,t);
214 }
215 }
216 } else {
217 return CallMetaCall(mod);
218 }
219 }
220 /* now let us do what we wanted to do from the beginning !! */
221 /* I cannot use the standard macro here because
222 otherwise I would dereference the argument and
223 might skip a svar */
224 pt = RepAppl(t)+1;
225 for (i = 1; i <= arity; i++) {
226 #if SBA
227 Term d0 = *pt++;
228 if (d0 == 0)
229 ` XREGS[i] = (CELL)(pt-1);
230 else
231 XREGS[i] = d0;
232 #else
233
234
235 XREGS[i] = *pt++;
236 #endif
237 }
238 return (CallPredicate(pen, B, pen->CodeOfPred));
239 } else if (IsAtomTerm(t)) {
240 PredEntry *pe;
241 Atom a = AtomOfTerm(t);
242
243 if (a == AtomTrue || a == AtomOtherwise || a == AtomCut)
244 return(TRUE);
245 else if (a == AtomFail || a == AtomFalse)
246 return(FALSE);
247 /* call may not define new system predicates!! */
248 pe = RepPredProp(PredPropByAtom(a, mod));
249 return (CallPredicate(pe, B, pe->CodeOfPred));
250 } else if (IsIntTerm(t)) {
251 return CallError(TYPE_ERROR_CALLABLE, mod);
252 } else {
253 /* Is Pair Term */
254 return(CallMetaCall(mod));
255 }
256 }
257
258 static Term
copy_execn_to_heap(Functor f,CELL * pt,unsigned int n,unsigned int arity,Term mod)259 copy_execn_to_heap(Functor f, CELL *pt, unsigned int n, unsigned int arity, Term mod)
260 {
261 CELL *h0 = H;
262 Term tf;
263 unsigned int i;
264
265 if (arity == 2 &&
266 NameOfFunctor(f) == AtomDot) {
267 for (i = 0; i<arity-n;i++) {
268 *H++ = pt[i];
269 }
270 for (i=0; i< n; i++) {
271 *H++ = h0[(int)(i-n)];
272 }
273 tf = AbsPair(h0);
274 } else {
275 *H++ = (CELL)f;
276 for (i = 0; i<arity-n;i++) {
277 *H++ = pt[i];
278 }
279 for (i=0; i< n; i++) {
280 *H++ = h0[(int)(i-n)];
281 }
282 tf = AbsAppl(h0);
283 }
284 if (mod != CurrentModule) {
285 CELL *h0 = H;
286 *H++ = (CELL)FunctorModule;
287 *H++ = mod;
288 *H++ = tf;
289 tf = AbsAppl(h0);
290 }
291 return tf;
292 }
293
294 inline static Int
do_execute_n(Term t,Term mod,unsigned int n)295 do_execute_n(Term t, Term mod, unsigned int n)
296 {
297 Functor f;
298 Atom Name;
299 register CELL *pt;
300 PredEntry *pen;
301 unsigned int i, arity;
302 int j = -n;
303
304 restart_exec:
305 if (IsVarTerm(t)) {
306 return CallError(INSTANTIATION_ERROR, mod);
307 } else if (IsAtomTerm(t)) {
308 arity = n;
309 Name = AtomOfTerm(t);
310 pt = NULL;
311 } else if (IsIntTerm(t)) {
312 return CallError(TYPE_ERROR_CALLABLE, mod);
313 } else if (IsPairTerm(t)) {
314 arity = n+2;
315 pt = RepPair(t);
316 Name = AtomOfTerm(TermNil);
317 } else /* if (IsApplTerm(t)) */ {
318 f = FunctorOfTerm(t);
319 while (f == FunctorModule) {
320 Term tmod = ArgOfTerm(1,t);
321 if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
322 mod = tmod;
323 t = ArgOfTerm(2,t);
324 goto restart_exec;
325 } else {
326 if (IsVarTerm(tmod)) {
327 return CallError(INSTANTIATION_ERROR,t);
328 } else {
329 return CallError(TYPE_ERROR_ATOM,t);
330 }
331 }
332 }
333 arity = ArityOfFunctor(f)+n;
334 Name = NameOfFunctor(f);
335 pt = RepAppl(t)+1;
336 }
337 f = Yap_MkFunctor(Name,arity);
338 if (IsExtensionFunctor(f)) {
339 return CallError(TYPE_ERROR_CALLABLE, mod);
340 }
341 if (PRED_GOAL_EXPANSION_ALL) {
342 LOCK(SignalLock);
343 /* disable creeping when we do goal expansion */
344 if (ActiveSignals & YAP_CREEP_SIGNAL && !Yap_InterruptsDisabled) {
345 ActiveSignals &= ~YAP_CREEP_SIGNAL;
346 CreepFlag = CalculateStackGap();
347 }
348 UNLOCK(SignalLock);
349 ARG1 = copy_execn_to_heap(f, pt, n, arity, mod);
350 return CallMetaCall(mod);
351 } else if (ActiveSignals && !Yap_InterruptsDisabled) {
352 return EnterCreepMode(copy_execn_to_heap(f, pt, n, arity, CurrentModule), mod);
353 }
354 if (arity > MaxTemps) {
355 return CallError(TYPE_ERROR_CALLABLE, t);
356 }
357 pen = RepPredProp(PredPropByFunc(f, mod));
358 /* You thought we would be over by now */
359 /* but no meta calls require special preprocessing */
360 if (pen->PredFlags & (GoalExPredFlag|MetaPredFlag)) {
361 ARG1 = copy_execn_to_heap(f, pt, n, arity, mod);
362 return(CallMetaCall(mod));
363 }
364 /* now let us do what we wanted to do from the beginning !! */
365 /* I cannot use the standard macro here because
366 otherwise I would dereference the argument and
367 might skip a svar */
368 for (i = 1; i <= arity-n; i++) {
369 #if SBA
370 Term d0 = *pt++;
371 if (d0 == 0)
372 XREGS[i] = (CELL)(pt-1);
373 else
374 XREGS[i] = d0;
375 #else
376 XREGS[i] = *pt++;
377 #endif
378 }
379 for (i = arity-n+1; i <= arity; i++,j++) {
380 XREGS[i] = H[j];
381 }
382 return CallPredicate(pen, B, pen->CodeOfPred);
383 }
384
385 static Int
EnterCreepMode(Term t,Term mod)386 EnterCreepMode(Term t, Term mod) {
387 PredEntry *PredCreep;
388
389 if (ActiveSignals & YAP_CDOVF_SIGNAL) {
390 ARG1 = t;
391 if (!Yap_growheap(FALSE, 0, NULL)) {
392 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP failed to grow heap at meta-call");
393 }
394 if (!ActiveSignals) {
395 return do_execute(ARG1, mod);
396 }
397 }
398 PP = PredMetaCall;
399 PredCreep = RepPredProp(PredPropByFunc(FunctorCreep,1));
400 if (mod) {
401 ARG1 = MkPairTerm(mod,t);
402 } else {
403 ARG1 = MkPairTerm(TermProlog,t);
404 }
405 LOCK(SignalLock);
406 CreepFlag = CalculateStackGap();
407 UNLOCK(SignalLock);
408 P_before_spy = P;
409 return CallPredicate(PredCreep, B, PredCreep->CodeOfPred);
410 }
411
412 static Int
p_execute(void)413 p_execute(void)
414 { /* '$execute'(Goal) */
415 Term t = Deref(ARG1);
416 return do_execute(t, CurrentModule);
417 }
418
419 static void
heap_store(Term t)420 heap_store(Term t)
421 {
422 if (IsVarTerm(t)) {
423 if (VarOfTerm(t) < H) {
424 *H++ = t;
425 } else {
426 RESET_VARIABLE(H);
427 Bind_Local(VarOfTerm(t), (CELL)H);
428 H++;
429 }
430 } else {
431 *H++ = t;
432 }
433 }
434
435 static Int
p_execute2(void)436 p_execute2(void)
437 { /* '$execute'(Goal) */
438 Term t = Deref(ARG1);
439 heap_store(Deref(ARG2));
440 return do_execute_n(t, CurrentModule, 1);
441 }
442
443 static Int
p_execute3(void)444 p_execute3(void)
445 { /* '$execute'(Goal) */
446 Term t = Deref(ARG1);
447 heap_store(Deref(ARG2));
448 heap_store(Deref(ARG3));
449 return do_execute_n(t, CurrentModule, 2);
450 }
451
452 static Int
p_execute4(void)453 p_execute4(void)
454 { /* '$execute'(Goal) */
455 Term t = Deref(ARG1);
456 heap_store(Deref(ARG2));
457 heap_store(Deref(ARG3));
458 heap_store(Deref(ARG4));
459 return do_execute_n(t, CurrentModule, 3);
460 }
461
462 static Int
p_execute5(void)463 p_execute5(void)
464 { /* '$execute'(Goal) */
465 Term t = Deref(ARG1);
466 heap_store(Deref(ARG2));
467 heap_store(Deref(ARG3));
468 heap_store(Deref(ARG4));
469 heap_store(Deref(ARG5));
470 return do_execute_n(t, CurrentModule, 4);
471 }
472
473 static Int
p_execute6(void)474 p_execute6(void)
475 { /* '$execute'(Goal) */
476 Term t = Deref(ARG1);
477 heap_store(Deref(ARG2));
478 heap_store(Deref(ARG3));
479 heap_store(Deref(ARG4));
480 heap_store(Deref(ARG5));
481 heap_store(Deref(ARG6));
482 return do_execute_n(t, CurrentModule, 5);
483 }
484
485 static Int
p_execute7(void)486 p_execute7(void)
487 { /* '$execute'(Goal) */
488 Term t = Deref(ARG1);
489 heap_store(Deref(ARG2));
490 heap_store(Deref(ARG3));
491 heap_store(Deref(ARG4));
492 heap_store(Deref(ARG5));
493 heap_store(Deref(ARG6));
494 heap_store(Deref(ARG7));
495 return do_execute_n(t, CurrentModule, 6);
496 }
497
498 static Int
p_execute8(void)499 p_execute8(void)
500 { /* '$execute'(Goal) */
501 Term t = Deref(ARG1);
502 heap_store(Deref(ARG2));
503 heap_store(Deref(ARG3));
504 heap_store(Deref(ARG4));
505 heap_store(Deref(ARG5));
506 heap_store(Deref(ARG6));
507 heap_store(Deref(ARG7));
508 heap_store(Deref(ARG8));
509 return do_execute_n(t, CurrentModule, 7);
510 }
511
512 static Int
p_execute9(void)513 p_execute9(void)
514 { /* '$execute'(Goal) */
515 Term t = Deref(ARG1);
516 heap_store(Deref(ARG2));
517 heap_store(Deref(ARG3));
518 heap_store(Deref(ARG4));
519 heap_store(Deref(ARG5));
520 heap_store(Deref(ARG6));
521 heap_store(Deref(ARG7));
522 heap_store(Deref(ARG8));
523 heap_store(Deref(ARG9));
524 return do_execute_n(t, CurrentModule, 8);
525 }
526
527 static Int
p_execute10(void)528 p_execute10(void)
529 { /* '$execute'(Goal) */
530 Term t = Deref(ARG1);
531 heap_store(Deref(ARG2));
532 heap_store(Deref(ARG3));
533 heap_store(Deref(ARG4));
534 heap_store(Deref(ARG5));
535 heap_store(Deref(ARG6));
536 heap_store(Deref(ARG7));
537 heap_store(Deref(ARG8));
538 heap_store(Deref(ARG9));
539 heap_store(Deref(ARG10));
540 return(do_execute_n(t, CurrentModule, 9));
541 }
542
543 static Int
p_execute11(void)544 p_execute11(void)
545 { /* '$execute'(Goal) */
546 Term t = Deref(ARG1);
547 heap_store(Deref(ARG2));
548 heap_store(Deref(ARG3));
549 heap_store(Deref(ARG4));
550 heap_store(Deref(ARG5));
551 heap_store(Deref(ARG6));
552 heap_store(Deref(ARG7));
553 heap_store(Deref(ARG8));
554 heap_store(Deref(ARG9));
555 heap_store(Deref(ARG10));
556 heap_store(Deref(ARG11));
557 return(do_execute_n(t, CurrentModule, 10));
558 }
559
560 static Int
p_execute12(void)561 p_execute12(void)
562 { /* '$execute'(Goal) */
563 Term t = Deref(ARG1);
564 heap_store(Deref(ARG2));
565 heap_store(Deref(ARG3));
566 heap_store(Deref(ARG4));
567 heap_store(Deref(ARG5));
568 heap_store(Deref(ARG6));
569 heap_store(Deref(ARG7));
570 heap_store(Deref(ARG8));
571 heap_store(Deref(ARG9));
572 heap_store(Deref(ARG10));
573 heap_store(Deref(ARG11));
574 heap_store(Deref(ARG12));
575 return(do_execute_n(t, CurrentModule, 11));
576 }
577
578 static Int
p_execute_clause(void)579 p_execute_clause(void)
580 { /* '$execute_clause'(Goal) */
581 Term t = Deref(ARG1);
582 Term mod = Deref(ARG2);
583 choiceptr cut_cp = cp_from_integer(Deref(ARG4));
584 unsigned int arity;
585 Prop pe;
586 yamop *code;
587 Term clt = Deref(ARG3);
588
589 restart_exec:
590 if (IsVarTerm(t)) {
591 Yap_Error(INSTANTIATION_ERROR,ARG3,"call/1");
592 return FALSE;
593 } else if (IsAtomTerm(t)) {
594 Atom a = AtomOfTerm(t);
595 pe = PredPropByAtom(a, mod);
596 } else if (IsApplTerm(t)) {
597 register Functor f = FunctorOfTerm(t);
598 register unsigned int i;
599 register CELL *pt;
600
601 if (IsExtensionFunctor(f))
602 return(FALSE);
603 if (f == FunctorModule) {
604 Term tmod = ArgOfTerm(1,t);
605 if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
606 mod = tmod;
607 t = ArgOfTerm(2,t);
608 goto restart_exec;
609 }
610 }
611 pe = PredPropByFunc(f, mod);
612 arity = ArityOfFunctor(f);
613 if (arity > MaxTemps) {
614 return CallError(TYPE_ERROR_CALLABLE, t);
615 }
616 /* I cannot use the standard macro here because
617 otherwise I would dereference the argument and
618 might skip a svar */
619 pt = RepAppl(t)+1;
620 for (i = 1; i <= arity; ++i) {
621 #if SBA
622 Term d0 = *pt++;
623 if (d0 == 0)
624 XREGS[i] = (CELL)(pt-1);
625 else
626 XREGS[i] = d0;
627 #else
628 XREGS[i] = *pt++;
629 #endif
630 }
631 } else {
632 Yap_Error(TYPE_ERROR_CALLABLE,ARG3,"call/1");
633 return FALSE;
634 }
635 /* N = arity; */
636 /* call may not define new system predicates!! */
637 if (RepPredProp(pe)->PredFlags & MegaClausePredFlag) {
638 code = Yap_MegaClauseFromTerm(clt);
639 } else {
640 code = Yap_ClauseFromTerm(clt)->ClCode;
641 }
642 if (ActiveSignals & YAP_CREEP_SIGNAL) {
643 Yap_signal(YAP_CREEP_SIGNAL);
644 }
645 return CallPredicate(RepPredProp(pe), cut_cp, code);
646 }
647
648 static Int
p_execute_in_mod(void)649 p_execute_in_mod(void)
650 { /* '$execute'(Goal) */
651 return(do_execute(Deref(ARG1), Deref(ARG2)));
652 }
653
654 static Int
p_execute0(void)655 p_execute0(void)
656 { /* '$execute0'(Goal,Mod) */
657 Term t = Deref(ARG1);
658 Term mod = Deref(ARG2);
659 unsigned int arity;
660 Prop pe;
661
662 if (ActiveSignals && !Yap_InterruptsDisabled) {
663 return EnterCreepMode(t, mod);
664 }
665 restart_exec:
666 if (IsVarTerm(t)) {
667 Yap_Error(INSTANTIATION_ERROR,ARG3,"call/1");
668 return FALSE;
669 } else if (IsAtomTerm(t)) {
670 Atom a = AtomOfTerm(t);
671 pe = PredPropByAtom(a, mod);
672 } else if (IsApplTerm(t)) {
673 register Functor f = FunctorOfTerm(t);
674 register unsigned int i;
675 register CELL *pt;
676
677 if (IsExtensionFunctor(f))
678 return FALSE;
679 if (f == FunctorModule) {
680 Term tmod = ArgOfTerm(1,t);
681 if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
682 mod = tmod;
683 t = ArgOfTerm(2,t);
684 goto restart_exec;
685 } else {
686 if (IsVarTerm(tmod)) {
687 return CallError(INSTANTIATION_ERROR,t);
688 } else {
689 return CallError(TYPE_ERROR_ATOM,t);
690 }
691 }
692 }
693 pe = PredPropByFunc(f, mod);
694 // Yap_DebugPlWrite(mod);fprintf(stderr,"\n");
695 arity = ArityOfFunctor(f);
696 if (arity > MaxTemps) {
697 return CallError(TYPE_ERROR_CALLABLE, t);
698 }
699 /* I cannot use the standard macro here because
700 otherwise I would dereference the argument and
701 might skip a svar */
702 pt = RepAppl(t)+1;
703 for (i = 1; i <= arity; ++i) {
704 #if SBA
705 Term d0 = *pt++;
706 if (d0 == 0)
707 XREGS[i] = (CELL)(pt-1);
708 else
709 XREGS[i] = d0;
710 #else
711 XREGS[i] = *pt++;
712 #endif
713 }
714 } else {
715 Yap_Error(TYPE_ERROR_CALLABLE,ARG1,"call/1");
716 return FALSE;
717 }
718 /* N = arity; */
719 /* call may not define new system predicates!! */
720 return CallPredicate(RepPredProp(pe), B, RepPredProp(pe)->CodeOfPred);
721 }
722
723 static Int
p_execute_nonstop(void)724 p_execute_nonstop(void)
725 { /* '$execute_nonstop'(Goal,Mod) */
726 Term t = Deref(ARG1);
727 Term mod = Deref(ARG2);
728 unsigned int arity;
729 Prop pe;
730
731 restart_exec:
732 if (IsVarTerm(mod)) {
733 mod = CurrentModule;
734 } else if (!IsAtomTerm(mod)) {
735 Yap_Error(TYPE_ERROR_ATOM, ARG2, "call/1");
736 return FALSE;
737 }
738 if (IsVarTerm(t)) {
739 Yap_Error(INSTANTIATION_ERROR,ARG1,"call/1");
740 return FALSE;
741 } else if (IsAtomTerm(t)) {
742 Atom a = AtomOfTerm(t);
743 pe = PredPropByAtom(a, mod);
744 } else if (IsApplTerm(t)) {
745 register Functor f = FunctorOfTerm(t);
746 register unsigned int i;
747 register CELL *pt;
748
749 if (IsExtensionFunctor(f))
750 return(FALSE);
751 if (f == FunctorModule) {
752 Term tmod = ArgOfTerm(1,t);
753 if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
754 mod = tmod;
755 t = ArgOfTerm(2,t);
756 goto restart_exec;
757 } else {
758 if (IsVarTerm(tmod)) {
759 return CallError(INSTANTIATION_ERROR,t);
760 } else {
761 return CallError(TYPE_ERROR_ATOM,t);
762 }
763 }
764 }
765 pe = PredPropByFunc(f, mod);
766 arity = ArityOfFunctor(f);
767 if (arity > MaxTemps) {
768 return CallError(TYPE_ERROR_CALLABLE, t);
769 }
770 /* I cannot use the standard macro here because
771 otherwise I would dereference the argument and
772 might skip a svar */
773 pt = RepAppl(t)+1;
774 for (i = 1; i <= arity; ++i) {
775 #if SBA
776 Term d0 = *pt++;
777 if (d0 == 0)
778 XREGS[i] = (CELL)(pt-1);
779 else
780 XREGS[i] = d0;
781 #else
782 XREGS[i] = *pt++;
783 #endif
784 }
785 } else {
786 Yap_Error(TYPE_ERROR_CALLABLE,ARG3,"call/1");
787 return FALSE;
788 }
789 /* N = arity; */
790 /* call may not define new system predicates!! */
791 if (RepPredProp(pe)->PredFlags & SpiedPredFlag) {
792 if (ActiveSignals & YAP_CREEP_SIGNAL && !Yap_InterruptsDisabled) {
793 Yap_signal(YAP_CREEP_SIGNAL);
794 }
795 #if defined(YAPOR) || defined(THREADS)
796 if (RepPredProp(pe)->PredFlags & LogUpdatePredFlag) {
797 PP = RepPredProp(pe);
798 PELOCK(80,PP);
799 }
800 #endif
801 return CallPredicate(RepPredProp(pe), B, RepPredProp(pe)->cs.p_code.TrueCodeOfPred);
802 } else { if (ActiveSignals & YAP_CREEP_SIGNAL &&
803 !Yap_InterruptsDisabled &&
804 (!(RepPredProp(pe)->PredFlags & (AsmPredFlag|CPredFlag)) ||
805 RepPredProp(pe)->OpcodeOfPred == Yap_opcode(_call_bfunc_xx))) {
806 Yap_signal(YAP_CREEP_SIGNAL);
807 }
808 return CallPredicate(RepPredProp(pe), B, RepPredProp(pe)->CodeOfPred);
809 }
810 }
811
812 static Term
slice_module_for_call_with_args(Term tin,Term * modp,int arity)813 slice_module_for_call_with_args(Term tin, Term *modp, int arity)
814 {
815 if (IsVarTerm(tin)) {
816 Yap_Error(INSTANTIATION_ERROR,tin,"call_with_args/%d", arity);
817 return 0L;
818 }
819 while (IsApplTerm(tin)) {
820 Functor f = FunctorOfTerm(tin);
821 Term newmod;
822 if (f != FunctorModule) {
823 Yap_Error(TYPE_ERROR_ATOM,tin,"call_with_args/%d", arity);
824 return 0L;
825 }
826 newmod = ArgOfTerm(1,tin);
827 if (IsVarTerm(newmod)) {
828 Yap_Error(INSTANTIATION_ERROR,tin,"call_with_args/%d",arity);
829 return 0L;
830 } else if (!IsAtomTerm(newmod)) {
831 Yap_Error(TYPE_ERROR_ATOM,newmod,"call_with_args/%d",arity);
832 return 0L;
833 }
834 *modp = newmod;
835 tin = ArgOfTerm(2,tin);
836 }
837 if (!IsAtomTerm(tin)) {
838 Yap_Error(TYPE_ERROR_ATOM,tin,"call_with_args/%d",arity);
839 return 0L;
840 }
841 return tin;
842 }
843
844 static Int
p_execute_0(void)845 p_execute_0(void)
846 { /* '$execute_0'(Goal) */
847 Term mod = CurrentModule;
848 Term t = slice_module_for_call_with_args(Deref(ARG1),&mod,0);
849 if (!t)
850 return FALSE;
851 return do_execute(t, mod);
852 }
853
854 static Int
call_with_args(int i)855 call_with_args(int i)
856 {
857 Term mod = CurrentModule, t;
858 int j;
859
860 t = slice_module_for_call_with_args(Deref(ARG1),&mod,i);
861 if (!t)
862 return FALSE;
863 for (j=0;j<i;j++)
864 heap_store(Deref(XREGS[j+2]));
865 return(do_execute_n(t, mod, i));
866 }
867
868
869 static Int
p_execute_1(void)870 p_execute_1(void)
871 { /* '$execute_0'(Goal) */
872 return call_with_args(1);
873 }
874
875 static Int
p_execute_2(void)876 p_execute_2(void)
877 { /* '$execute_2'(Goal) */
878 return call_with_args(2);
879 }
880
881 static Int
p_execute_3(void)882 p_execute_3(void)
883 { /* '$execute_3'(Goal) */
884 return call_with_args(3);
885 }
886
887 static Int
p_execute_4(void)888 p_execute_4(void)
889 { /* '$execute_4'(Goal) */
890 return call_with_args(4);
891 }
892
893 static Int
p_execute_5(void)894 p_execute_5(void)
895 { /* '$execute_5'(Goal) */
896 return call_with_args(5);
897 }
898
899 static Int
p_execute_6(void)900 p_execute_6(void)
901 { /* '$execute_6'(Goal) */
902 return call_with_args(6);
903 }
904
905 static Int
p_execute_7(void)906 p_execute_7(void)
907 { /* '$execute_7'(Goal) */
908 return call_with_args(7);
909 }
910
911 static Int
p_execute_8(void)912 p_execute_8(void)
913 { /* '$execute_8'(Goal) */
914 return call_with_args(8);
915 }
916
917 static Int
p_execute_9(void)918 p_execute_9(void)
919 { /* '$execute_9'(Goal) */
920 return call_with_args(9);
921 }
922
923 static Int
p_execute_10(void)924 p_execute_10(void)
925 { /* '$execute_10'(Goal) */
926 return call_with_args(10);
927 }
928
929 #ifdef DEPTH_LIMIT
930 static Int
p_execute_depth_limit(void)931 p_execute_depth_limit(void) {
932 Term d = Deref(ARG2);
933 if (IsVarTerm(d)) {
934 Yap_Error(INSTANTIATION_ERROR,d,"depth_bound_call/2");
935 } else if (!IsIntTerm(d)) {
936 Yap_Error(TYPE_ERROR_INTEGER, d, "depth_bound_call/2");
937 return(FALSE);
938 }
939 DEPTH = MkIntTerm(IntOfTerm(d)*2);
940 return(p_execute());
941 }
942 #endif
943
944 static Int
p_pred_goal_expansion_on(void)945 p_pred_goal_expansion_on(void) {
946 /* a goal needs expansion if we have goal_expansion defined or
947 if the goal is a meta-call */
948 return PRED_GOAL_EXPANSION_ON;
949 }
950
951
952 static int
exec_absmi(int top)953 exec_absmi(int top)
954 {
955 int lval, out;
956
957 if (top && (lval = sigsetjmp (Yap_RestartEnv, 1)) != 0) {
958 switch(lval) {
959 case 1:
960 { /* restart */
961 /* otherwise, SetDBForThrow will fail entering critical mode */
962 Yap_PrologMode = UserMode;
963 /* find out where to cut to */
964 /* siglongjmp resets the TR hardware register */
965 /* TR and B are crucial, they might have been changed, or not */
966 restore_TR();
967 restore_B();
968 /* H is not so important, because we're gonna backtrack */
969 restore_H();
970 /* set stack */
971 ASP = (CELL *)PROTECT_FROZEN_B(B);
972 Yap_StartSlots();
973 LOCK(SignalLock);
974 /* forget any signals active, we're reborne */
975 ActiveSignals = 0;
976 CreepFlag = CalculateStackGap();
977 Yap_PrologMode = UserMode;
978 UNLOCK(SignalLock);
979 P = (yamop *)FAILCODE;
980 }
981 break;
982 case 2:
983 {
984 /* arithmetic exception */
985 /* must be done here, otherwise siglongjmp will clobber all the registers */
986 Yap_Error(Yap_matherror,TermNil,NULL);
987 /* reset the registers so that we don't have trash in abstract machine */
988 Yap_set_fpu_exceptions(yap_flags[LANGUAGE_MODE_FLAG] == 1);
989 P = (yamop *)FAILCODE;
990 Yap_PrologMode = UserMode;
991 }
992 break;
993 case 3:
994 { /* saved state */
995 return(FALSE);
996 }
997 default:
998 /* do nothing */
999 Yap_PrologMode = UserMode;
1000 }
1001 } else {
1002 Yap_PrologMode = UserMode;
1003 }
1004 Yap_CloseSlots();
1005 YENV = ASP;
1006 YENV[E_CB] = Unsigned (B);
1007 out = Yap_absmi(0);
1008 Yap_StartSlots();
1009 /* make sure we don't leave a FAIL signal hanging around */
1010 ActiveSignals &= ~YAP_FAIL_SIGNAL;
1011 if (!ActiveSignals)
1012 CreepFlag = CalculateStackGap();
1013 return out;
1014 }
1015
1016
1017 static void
init_stack(int arity,CELL * pt,int top,choiceptr saved_b)1018 init_stack(int arity, CELL *pt, int top, choiceptr saved_b)
1019 {
1020 /* create an initial pseudo environment so that when garbage
1021 collection is going up in the environment chain it doesn't get
1022 confused */
1023 EX = NULL;
1024 // sl = Yap_InitSlot(t);
1025 YENV = ASP;
1026 YENV[E_CP] = (CELL)P;
1027 YENV[E_CB] = (CELL)B;
1028 YENV[E_E] = (CELL)ENV;
1029 #ifdef DEPTH_LIMIT
1030 YENV[E_DEPTH] = DEPTH;
1031 #endif
1032 ENV = YENV;
1033 ASP -= EnvSizeInCells;
1034 /* and now create a pseudo choicepoint for much the same reasons */
1035 /* CP = YESCODE; */
1036 /* keep a place where you can inform you had an exception */
1037 {
1038 int i;
1039 for (i = 0; i < arity; i++) {
1040 XREGS[i+1] = *pt++;
1041 }
1042 }
1043 B = (choiceptr)ASP;
1044 B--;
1045 B->cp_h = H;
1046 B->cp_tr = TR;
1047 B->cp_cp = CP;
1048 B->cp_ap = NOCODE;
1049 B->cp_env = ENV;
1050 B->cp_b = saved_b;
1051 #ifdef DEPTH_LIMIT
1052 B->cp_depth = DEPTH;
1053 #endif /* DEPTH_LIMIT */
1054 YENV = ASP = (CELL *)B;
1055 HB = H;
1056 #if defined(YAPOR) || defined(THREADS)
1057 WPP = NULL;
1058 #endif
1059 /* start with some slots so that we can use them */
1060 Yap_StartSlots();
1061 CP = YESCODE;
1062 }
1063
1064 static Term
do_goal(Term t,yamop * CodeAdr,int arity,CELL * pt,int top)1065 do_goal(Term t, yamop *CodeAdr, int arity, CELL *pt, int top)
1066 {
1067 choiceptr saved_b = B;
1068 Term out = 0L;
1069
1070 init_stack(arity, pt, top, saved_b);
1071 P = (yamop *) CodeAdr;
1072 S = CellPtr (RepPredProp (PredPropByFunc (Yap_MkFunctor(AtomCall, 1),0))); /* A1 mishaps */
1073
1074 out = exec_absmi(top);
1075 // if (out) {
1076 // out = Yap_GetFromSlot(sl);
1077 // }
1078 // Yap_RecoverSlots(1);
1079 return out;
1080 }
1081
1082 int
Yap_exec_absmi(int top)1083 Yap_exec_absmi(int top)
1084 {
1085 return exec_absmi(top);
1086 }
1087
1088
1089 Int
Yap_execute_goal(Term t,int nargs,Term mod)1090 Yap_execute_goal(Term t, int nargs, Term mod)
1091 {
1092 Int out;
1093 yamop *CodeAdr;
1094 yamop *saved_p, *saved_cp;
1095 Prop pe;
1096 PredEntry *ppe;
1097 CELL *pt;
1098 /* preserve the current restart environment */
1099 /* visualc*/
1100 /* just keep the difference because of possible garbage collections */
1101
1102
1103 saved_p = P;
1104 saved_cp = CP;
1105
1106 if (IsAtomTerm(t)) {
1107 Atom a = AtomOfTerm(t);
1108 pt = NULL;
1109 pe = PredPropByAtom(a, mod);
1110 } else if (IsApplTerm(t)) {
1111 Functor f = FunctorOfTerm(t);
1112
1113 if (IsBlobFunctor(f)) {
1114 Yap_Error(TYPE_ERROR_CALLABLE,t,"call/1");
1115 return(FALSE);
1116 }
1117 /* I cannot use the standard macro here because
1118 otherwise I would dereference the argument and
1119 might skip a svar */
1120 pt = RepAppl(t)+1;
1121 pe = PredPropByFunc(f, mod);
1122 } else {
1123 Yap_Error(TYPE_ERROR_CALLABLE,t,"call/1");
1124 return(FALSE);
1125 }
1126 ppe = RepPredProp(pe);
1127 if (pe == NIL) {
1128 return(CallMetaCall(mod));
1129 }
1130 PELOCK(81,ppe);
1131 if (IsAtomTerm(t)) {
1132 CodeAdr = RepPredProp (pe)->CodeOfPred;
1133 UNLOCK(ppe->PELock);
1134 out = do_goal(t, CodeAdr, 0, pt, FALSE);
1135 } else {
1136 Functor f = FunctorOfTerm(t);
1137 CodeAdr = RepPredProp (pe)->CodeOfPred;
1138 UNLOCK(ppe->PELock);
1139 out = do_goal(t, CodeAdr, ArityOfFunctor(f), pt, FALSE);
1140 }
1141
1142 if (out == 1) {
1143 choiceptr cut_B, old_B;
1144 /* we succeeded, let's prune */
1145 /* restore the old environment */
1146 /* get to previous environment */
1147 cut_B = (choiceptr)ENV[E_CB];
1148 #ifdef CUT_C
1149 {
1150 /* Note that
1151 cut_B == (choiceptr)ENV[E_CB] */
1152 while (POP_CHOICE_POINT(ENV[E_CB]))
1153 {
1154 POP_EXECUTE();
1155 }
1156 }
1157 #endif /* CUT_C */
1158 #ifdef YAPOR
1159 CUT_prune_to(cut_B);
1160 #endif /* YAPOR */
1161 #ifdef TABLING
1162 if (B != cut_B) {
1163 while (B->cp_b < cut_B) {
1164 B = B->cp_b;
1165 }
1166 abolish_incomplete_subgoals(B);
1167 }
1168 #endif /* TABLING */
1169 B = cut_B;
1170 /* find out where we have the old arguments */
1171 old_B = ((choiceptr)(ENV-(EnvSizeInCells+nargs+1)))-1;
1172 CP = saved_cp;
1173 P = saved_p;
1174 ASP = ENV;
1175 #ifdef DEPTH_LIMIT
1176 DEPTH= ENV[E_DEPTH];
1177 #endif
1178 ENV = (CELL *)(ENV[E_E]);
1179 Yap_StartSlots();
1180 /* we have failed, and usually we would backtrack to this B,
1181 trouble is, we may also have a delayed cut to do */
1182 if (B != NULL)
1183 HB = B->cp_h;
1184 YENV = ENV;
1185 return(TRUE);
1186 } else if (out == 0) {
1187 ASP = B->cp_env;
1188 P = saved_p;
1189 CP = saved_cp;
1190 H = B->cp_h;
1191 #ifdef DEPTH_LIMIT
1192 DEPTH= B->cp_depth;
1193 #endif
1194 /* ASP should be set to the top of the local stack when we
1195 did the call */
1196 ASP = B->cp_env;
1197 /* YENV should be set to the current environment */
1198 YENV = ENV = (CELL *)((B->cp_env)[E_E]);
1199 B = B->cp_b;
1200 SET_BB(B);
1201 HB = PROTECT_FROZEN_H(B);
1202 return(FALSE);
1203 } else {
1204 Yap_Error(SYSTEM_ERROR,TermNil,"emulator crashed");
1205 return(FALSE);
1206 }
1207 }
1208
1209 void
Yap_trust_last(void)1210 Yap_trust_last(void)
1211 {
1212 ASP = B->cp_env;
1213 CP = B->cp_cp;
1214 H = B->cp_h;
1215 #ifdef DEPTH_LIMIT
1216 DEPTH= B->cp_depth;
1217 #endif
1218 YENV= ASP = B->cp_env;
1219 ENV = (CELL *)((B->cp_env)[E_E]);
1220 B = B->cp_b;
1221 P = (yamop *)(ENV[E_CP]);
1222 if (B) {
1223 SET_BB(B);
1224 HB = PROTECT_FROZEN_H(B);
1225 }
1226 }
1227
1228 Term
Yap_RunTopGoal(Term t)1229 Yap_RunTopGoal(Term t)
1230 {
1231 yamop *CodeAdr;
1232 Prop pe;
1233 PredEntry *ppe;
1234 CELL *pt;
1235 UInt arity;
1236 Term mod = CurrentModule;
1237 Term goal_out = 0;
1238
1239 restart_runtopgoal:
1240 if (IsAtomTerm(t)) {
1241 Atom a = AtomOfTerm(t);
1242 pt = NULL;
1243 pe = PredPropByAtom(a, CurrentModule);
1244 arity = 0;
1245 } else if (IsApplTerm(t)) {
1246 Functor f = FunctorOfTerm(t);
1247
1248 if (IsBlobFunctor(f)) {
1249 Yap_Error(TYPE_ERROR_CALLABLE,t,"call/1");
1250 return(FALSE);
1251 }
1252 if (f == FunctorModule) {
1253 Term tmod = ArgOfTerm(1,t);
1254 if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
1255 mod = tmod;
1256 t = ArgOfTerm(2,t);
1257 goto restart_runtopgoal;
1258 } else {
1259 if (IsVarTerm(tmod)) {
1260 Yap_Error(INSTANTIATION_ERROR,t,"call/1");
1261 } else {
1262 Yap_Error(TYPE_ERROR_ATOM,t,"call/1");
1263 }
1264 return FALSE;
1265 }
1266 }
1267 /* I cannot use the standard macro here because
1268 otherwise I would dereference the argument and
1269 might skip a svar */
1270 pe = PredPropByFunc(f, CurrentModule);
1271 pt = RepAppl(t)+1;
1272 arity = ArityOfFunctor(f);
1273 } else {
1274 Yap_Error(TYPE_ERROR_CALLABLE,t,"call/1");
1275 return(FALSE);
1276 }
1277 ppe = RepPredProp(pe);
1278 if (pe == NIL) {
1279 /* we must always start the emulator with Prolog code */
1280 return FALSE;
1281 }
1282 PELOCK(82,ppe);
1283 CodeAdr = ppe->CodeOfPred;
1284 UNLOCK(ppe->PELock);
1285 #if !USE_SYSTEM_MALLOC
1286 if (Yap_TrailTop - HeapTop < 2048) {
1287 Yap_PrologMode = BootMode;
1288 Yap_Error(OUT_OF_TRAIL_ERROR,TermNil,
1289 "unable to boot because of too little Trail space");
1290 }
1291 #endif
1292 goal_out = do_goal(t, CodeAdr, arity, pt, TRUE);
1293 return(goal_out);
1294 }
1295
1296 static void
restore_regs(Term t)1297 restore_regs(Term t)
1298 {
1299 if (IsApplTerm(t)) {
1300 Int i;
1301 Int max = ArityOfFunctor(FunctorOfTerm(t));
1302 CELL *ptr = RepAppl(t)+1;
1303
1304 for (i = 0; i < max; i += 2) {
1305 Int j = IntOfTerm(ptr[0]);
1306 XREGS[j] = ptr[1];
1307 ptr+=2;
1308 }
1309 }
1310 }
1311
1312 /* low level voodoo to restore temporary registers after a call */
1313 static Int
p_restore_regs(void)1314 p_restore_regs(void)
1315 {
1316 Term t = Deref(ARG1);
1317 if (IsVarTerm(t)) {
1318 Yap_Error(INSTANTIATION_ERROR,t,"support for coroutining");
1319 return(FALSE);
1320 }
1321 if (IsAtomTerm(t)) return(TRUE);
1322 restore_regs(t);
1323 return(TRUE);
1324 }
1325
1326 /* low level voodoo to cut and then restore temporary registers after a call */
1327 static Int
p_restore_regs2(void)1328 p_restore_regs2(void)
1329 {
1330
1331 Term t = Deref(ARG1), d0;
1332 choiceptr pt0;
1333 if (IsVarTerm(t)) {
1334 Yap_Error(INSTANTIATION_ERROR,t,"support for coroutining");
1335 return(FALSE);
1336 }
1337 d0 = Deref(ARG2);
1338 if (!IsAtomTerm(t)) {
1339 restore_regs(t);
1340 }
1341 if (IsVarTerm(d0)) {
1342 Yap_Error(INSTANTIATION_ERROR,d0,"support for coroutining");
1343 return(FALSE);
1344 }
1345 if (!IsIntegerTerm(d0)) {
1346 return(FALSE);
1347 }
1348 #if SBA
1349 pt0 = (choiceptr)IntegerOfTerm(d0);
1350 #else
1351 pt0 = (choiceptr)(LCL0-IntOfTerm(d0));
1352 #endif
1353 #ifdef CUT_C
1354 {
1355 while (POP_CHOICE_POINT(pt0))
1356 {
1357 POP_EXECUTE();
1358 }
1359 }
1360 #endif /* CUT_C */
1361 #ifdef YAPOR
1362 CUT_prune_to(pt0);
1363 #endif /* YAPOR */
1364 /* find where to cut to */
1365 if (pt0 > B) {
1366 /* Wow, we're gonna cut!!! */
1367 #ifdef TABLING
1368 while (B->cp_b < pt0) {
1369 B = B->cp_b;
1370 }
1371 abolish_incomplete_subgoals(B);
1372 #endif /* TABLING */
1373 B = pt0;
1374 HB = B->cp_h;
1375 Yap_TrimTrail();
1376 }
1377 return(TRUE);
1378 }
1379
1380 static Int
p_clean_ifcp(void)1381 p_clean_ifcp(void) {
1382 Term t = Deref(ARG1);
1383 choiceptr pt0;
1384
1385 if (IsVarTerm(t)) {
1386 Yap_Error(INSTANTIATION_ERROR, t, "cut_at/1");
1387 return FALSE;
1388 }
1389 if (!IsIntegerTerm(t)) {
1390 Yap_Error(TYPE_ERROR_INTEGER, t, "cut_at/1");
1391 return FALSE;
1392 }
1393 #if SBA
1394 pt0 = (choiceptr)IntegerOfTerm(t);
1395 #else
1396 pt0 = cp_from_integer(t);
1397 #endif
1398 if (pt0 < B) {
1399 /* this should never happen */
1400 return TRUE;
1401 } else if (pt0 == B) {
1402 B = B->cp_b;
1403 HB = B->cp_h;
1404 } else {
1405 pt0->cp_ap = (yamop *)TRUSTFAILCODE;
1406 }
1407 return TRUE;
1408 }
1409
1410
1411
disj_marker(yamop * apc)1412 static int disj_marker(yamop *apc) {
1413 op_numbers opnum = Yap_op_from_opcode(apc->opc);
1414
1415 return opnum == _or_else || opnum == _or_last;
1416 }
1417
1418
1419 static Int
p_cut_up_to_next_disjunction(void)1420 p_cut_up_to_next_disjunction(void) {
1421 choiceptr pt0 = B;
1422 CELL *qenv = (CELL *)ENV[E_E];
1423
1424 while (pt0 &&
1425 !( qenv == pt0->cp_env && disj_marker(pt0->cp_ap))) {
1426 pt0 = pt0->cp_b;
1427 }
1428 if (!pt0)
1429 return TRUE;
1430 #ifdef YAPOR
1431 CUT_prune_to(pt0);
1432 #endif /* YAPOR */
1433 /* find where to cut to */
1434 if (SHOULD_CUT_UP_TO(B,pt0)) {
1435 B = pt0;
1436 #ifdef TABLING
1437 abolish_incomplete_subgoals(B);
1438 #endif /* TABLING */
1439 }
1440 HB = B->cp_h;
1441 Yap_TrimTrail();
1442 return TRUE;
1443 }
1444
is_cleanup_cp(choiceptr cp_b)1445 static int is_cleanup_cp(choiceptr cp_b)
1446 {
1447 PredEntry *pe;
1448
1449 if (cp_b->cp_ap->opc != ORLAST_OPCODE)
1450 return FALSE;
1451 #ifdef YAPOR
1452 pe = cp_b->cp_ap->u.Osblp.p0;
1453 #else
1454 pe = cp_b->cp_ap->u.p.p;
1455 #endif /* YAPOR */
1456 /*
1457 it has to be a cleanup and it has to be a completed goal,
1458 otherwise the throw will be caught anyway.
1459 */
1460 return pe == PredSafeCallCleanup;
1461 }
1462
1463 #ifdef YAPOR
1464 #define TRY_CLAUSE_3OPS Otapl
1465 #else
1466 #define TRY_CLAUSE_3OPS l
1467 #endif
1468
1469 static Int
JumpToEnv(Term t)1470 JumpToEnv(Term t) {
1471 yamop *pos = NEXTOP(PredDollarCatch->cs.p_code.TrueCodeOfPred,TRY_CLAUSE_3OPS),
1472 *catchpos = NEXTOP(PredHandleThrow->cs.p_code.TrueCodeOfPred,TRY_CLAUSE_3OPS);
1473 CELL *env, *env1;
1474 choiceptr handler, previous = NULL;
1475
1476 /* throws cannot interrupt throws */
1477 if (EX)
1478 return FALSE;
1479 /* just keep the throwed object away, we don't need to care about it */
1480 if (!(BallTerm = Yap_StoreTermInDB(t, 0))) {
1481 /* fat chance */
1482 siglongjmp(Yap_RestartEnv,1);
1483 }
1484 /* careful, previous step may have caused a stack shift,
1485 so get pointers here */
1486 handler = B;
1487 env1 = ENV;
1488 do {
1489 /* find the first choicepoint that may be a catch */
1490 while (handler != NULL && handler->cp_ap != pos) {
1491 /* we are already doing a catch */
1492 if (handler->cp_ap == catchpos) {
1493 P = (yamop *)FAILCODE;
1494 return TRUE;
1495 }
1496 /* we have a cleanup handler in the middle */
1497 if (is_cleanup_cp(handler)) {
1498 /* keep it around */
1499 if (previous == NULL)
1500 B = handler;
1501 else
1502 previous->cp_b = handler;
1503 previous = handler;
1504 #ifdef TABLING
1505 } else {
1506 if (handler->cp_ap != NOCODE) {
1507 abolish_incomplete_subgoals(handler);
1508 }
1509 #endif /* TABLING */
1510 }
1511 /* we reached C-Code */
1512 if (handler->cp_ap == NOCODE) {
1513 /* up to the C-code to deal with this! */
1514 UncaughtThrow = TRUE;
1515 if (previous == NULL)
1516 B = handler;
1517 else
1518 previous->cp_b = handler;
1519 EX = BallTerm;
1520 BallTerm = NULL;
1521 P = (yamop *)FAILCODE;
1522 /* make sure failure will be seen at next port */
1523 if (Yap_PrologMode & AsyncIntMode) {
1524 Yap_signal(YAP_FAIL_SIGNAL);
1525 }
1526 HB = B->cp_h;
1527 return TRUE;
1528 }
1529 handler = handler->cp_b;
1530 }
1531 /* uncaught throw */
1532 if (handler == NULL) {
1533 UncaughtThrow = TRUE;
1534 #if PUSH_REGS
1535 restore_absmi_regs(&Yap_standard_regs);
1536 #endif
1537 siglongjmp(Yap_RestartEnv,1);
1538 }
1539 /* is it a continuation? */
1540 env = handler->cp_env;
1541 while (env > env1) {
1542 env1 = ENV_Parent(env1);
1543 }
1544 /* yes, we found it ! */
1545 // while (env < ENV)
1546 // env = ENV_Parent(env);
1547 if (env == env1) {
1548 break;
1549 }
1550 /* oops, try next */
1551 handler = handler->cp_b;
1552 } while (TRUE);
1553 /* step one environment above, otherwise we'll redo the original goal */
1554 if (previous == NULL) {
1555 B = handler;
1556 } else {
1557 // EX = t;
1558 previous->cp_b = handler;
1559 }
1560 handler->cp_cp = (yamop *)env[E_CP];
1561 handler->cp_env = (CELL *)env[E_E];
1562 handler->cp_ap = catchpos;
1563 /* can recover Heap thanks to copy term :-( */
1564 /* B->cp_h = H; */
1565 /* I could backtrack here, but it is easier to leave the unwinding
1566 to the emulator */
1567 if (Yap_PrologMode & AsyncIntMode) {
1568 Yap_signal(YAP_FAIL_SIGNAL);
1569 }
1570 P = (yamop *)FAILCODE;
1571 HB = B->cp_h;
1572 /* try to recover space */
1573 /* can only do that when we recover space */
1574 /* first, simulate backtracking */
1575 /* so that I will execute op_fail */
1576 return TRUE;
1577 }
1578
1579 Int
Yap_JumpToEnv(Term t)1580 Yap_JumpToEnv(Term t) {
1581 if (Yap_PrologMode & BootMode) {
1582 return FALSE;
1583 }
1584 return JumpToEnv(t);
1585 }
1586
1587
1588 /* This does very nasty stuff!!!!! */
1589 static Int
p_jump_env(void)1590 p_jump_env(void) {
1591 return(JumpToEnv(Deref(ARG1)));
1592 }
1593
1594 /* set up a meta-call based on . context info */
1595 static Int
p_generate_pred_info(void)1596 p_generate_pred_info(void) {
1597 ARG1 = ARG3 = ENV[-EnvSizeInCells-1];
1598 ARG4 = ENV[-EnvSizeInCells-3];
1599 ARG2 = cp_as_integer((choiceptr)ENV[E_CB]);
1600 return TRUE;
1601 }
1602
1603 void
Yap_InitYaamRegs(void)1604 Yap_InitYaamRegs(void)
1605 {
1606 Term h0var;
1607
1608 #if PUSH_REGS
1609 /* Guarantee that after a longjmp we go back to the original abstract
1610 machine registers */
1611 #ifdef THREADS
1612 int myworker_id = worker_id;
1613 pthread_setspecific(Yap_yaamregs_key, (const void *)FOREIGN_ThreadHandle(myworker_id).default_yaam_regs);
1614 FOREIGN_ThreadHandle(myworker_id).current_yaam_regs = FOREIGN_ThreadHandle(myworker_id).default_yaam_regs;
1615 worker_id = myworker_id;
1616 #else
1617 Yap_regp = &Yap_standard_regs;
1618 #endif
1619 #endif /* PUSH_REGS */
1620 Yap_ResetExceptionTerm ();
1621 Yap_PutValue (AtomBreak, MkIntTerm (0));
1622 TR = (tr_fr_ptr)Yap_TrailBase;
1623 if (Yap_AttsSize > (Yap_LocalBase-Yap_GlobalBase)/8)
1624 Yap_AttsSize = (Yap_LocalBase-Yap_GlobalBase)/8;
1625 H = H0 = ((CELL *) Yap_GlobalBase)+ Yap_AttsSize/sizeof(CELL);
1626 LCL0 = ASP = (CELL *) Yap_LocalBase;
1627 /* notice that an initial choice-point and environment
1628 *must* be created since for the garbage collector to work */
1629 B = NULL;
1630 ENV = NULL;
1631 P = CP = YESCODE;
1632 #ifdef DEPTH_LIMIT
1633 DEPTH = RESET_DEPTH();
1634 #endif
1635 STATIC_PREDICATES_MARKED = FALSE;
1636 #ifdef FROZEN_STACKS
1637 H_FZ = H;
1638 #ifdef SBA
1639 BSEG =
1640 #endif /* SBA */
1641 BBREG = B_FZ = (choiceptr) Yap_LocalBase;
1642 TR = TR_FZ = (tr_fr_ptr) Yap_TrailBase;
1643 #endif /* FROZEN_STACKS */
1644 LOCK(SignalLock);
1645 CreepFlag = CalculateStackGap();
1646 UNLOCK(SignalLock);
1647 EX = NULL;
1648 init_stack(0, NULL, TRUE, NULL);
1649 /* the first real choice-point will also have AP=FAIL */
1650 /* always have an empty slots for people to use */
1651 CurSlot = 0;
1652 Yap_StartSlots();
1653 GlobalArena = TermNil;
1654 h0var = MkVarTerm();
1655 #if COROUTINING
1656 WokenGoals = Yap_NewTimedVar(TermNil);
1657 AttsMutableList = Yap_NewTimedVar(h0var);
1658 #endif
1659 GcGeneration = Yap_NewTimedVar(h0var);
1660 GcCurrentPhase = 0L;
1661 GcPhase = Yap_NewTimedVar(MkIntTerm(GcCurrentPhase));
1662 #if defined(YAPOR) || defined(THREADS)
1663 PP = NULL;
1664 WPP = NULL;
1665 PREG_ADDR = NULL;
1666 #endif
1667 Yap_AllocateDefaultArena(128*1024, 2);
1668 Yap_InitPreAllocCodeSpace();
1669 #ifdef CUT_C
1670 cut_c_initialize();
1671 #endif
1672 #if defined MYDDAS_MYSQL || defined MYDDAS_ODBC
1673 Yap_REGS.MYDDAS_GLOBAL_POINTER = NULL;
1674 #endif
1675 }
1676
1677 static Int
p_uncaught_throw(void)1678 p_uncaught_throw(void)
1679 {
1680 Int out = UncaughtThrow;
1681 UncaughtThrow = FALSE; /* just caught it */
1682 return out;
1683 }
1684
1685 static Int
p_creep_allowed(void)1686 p_creep_allowed(void)
1687 {
1688 if (PP != NULL) {
1689 LOCK(SignalLock);
1690 if (ActiveSignals & YAP_CREEP_SIGNAL && !Yap_InterruptsDisabled) {
1691 ActiveSignals &= ~YAP_CREEP_SIGNAL;
1692 if (!ActiveSignals)
1693 CreepFlag = CalculateStackGap();
1694 UNLOCK(SignalLock);
1695 } else {
1696 UNLOCK(SignalLock);
1697 }
1698 return TRUE;
1699 }
1700 return FALSE;
1701 }
1702
1703 static Int
p_debug_on(void)1704 p_debug_on(void)
1705 {
1706 Term t = Deref(ARG1);
1707 if (IsVarTerm(t)) {
1708 if (DebugOn)
1709 return Yap_unify(MkAtomTerm(AtomTrue),ARG1);
1710 else
1711 return Yap_unify(MkAtomTerm(AtomFalse),ARG1);
1712 }
1713 if (t == MkAtomTerm(AtomTrue))
1714 DebugOn = TRUE;
1715 else
1716 DebugOn = FALSE;
1717 return TRUE;
1718 }
1719
1720 static Term
GetException(void)1721 GetException(void)
1722 {
1723 Term t = 0L;
1724 if (BallTerm) {
1725 do {
1726 t = Yap_PopTermFromDB(BallTerm);
1727 if (t == 0) {
1728 if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
1729 Yap_Error_TYPE = YAP_NO_ERROR;
1730 if (!Yap_growglobal(NULL)) {
1731 Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
1732 return FALSE;
1733 }
1734 } else {
1735 Yap_Error_TYPE = YAP_NO_ERROR;
1736 if (!Yap_growstack(BallTerm->NOfCells*CellSize)) {
1737 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
1738 return FALSE;
1739 }
1740 }
1741 }
1742 } while (t == 0);
1743 BallTerm = NULL;
1744 }
1745 return t;
1746 }
1747
1748 static Int
p_reset_exception(void)1749 p_reset_exception(void)
1750 {
1751 Term t;
1752 EX = NULL;
1753 t = GetException();
1754 if (!t)
1755 return FALSE;
1756 return Yap_unify(t, ARG1);
1757 }
1758
1759 void
Yap_ResetExceptionTerm(void)1760 Yap_ResetExceptionTerm(void)
1761 {
1762 Yap_ReleaseTermFromDB(BallTerm);
1763 BallTerm = NULL;
1764 }
1765
1766 static Int
p_get_exception(void)1767 p_get_exception(void)
1768 {
1769 Term t = GetException();
1770 if (!t)
1771 return FALSE;
1772 return Yap_unify(t, ARG1);
1773 }
1774
1775 void
Yap_InitExecFs(void)1776 Yap_InitExecFs(void)
1777 {
1778 Term cm = CurrentModule;
1779 Yap_InitComma();
1780 Yap_InitCPred("$execute", 1, p_execute, HiddenPredFlag);
1781 Yap_InitCPred("$execute", 2, p_execute2, HiddenPredFlag);
1782 Yap_InitCPred("$execute", 3, p_execute3, HiddenPredFlag);
1783 Yap_InitCPred("$execute", 4, p_execute4, HiddenPredFlag);
1784 Yap_InitCPred("$execute", 5, p_execute5, HiddenPredFlag);
1785 Yap_InitCPred("$execute", 6, p_execute6, HiddenPredFlag);
1786 Yap_InitCPred("$execute", 7, p_execute7, HiddenPredFlag);
1787 Yap_InitCPred("$execute", 8, p_execute8, HiddenPredFlag);
1788 Yap_InitCPred("$execute", 9, p_execute9, HiddenPredFlag);
1789 Yap_InitCPred("$execute", 10, p_execute10, HiddenPredFlag);
1790 Yap_InitCPred("$execute", 11, p_execute11, HiddenPredFlag);
1791 Yap_InitCPred("$execute", 12, p_execute12, HiddenPredFlag);
1792 Yap_InitCPred("$execute_in_mod", 2, p_execute_in_mod, HiddenPredFlag);
1793 Yap_InitCPred("$execute_wo_mod", 2, p_execute_in_mod, HiddenPredFlag);
1794 Yap_InitCPred("call_with_args", 1, p_execute_0, HiddenPredFlag);
1795 Yap_InitCPred("call_with_args", 2, p_execute_1, HiddenPredFlag);
1796 Yap_InitCPred("call_with_args", 3, p_execute_2, HiddenPredFlag);
1797 Yap_InitCPred("call_with_args", 4, p_execute_3, HiddenPredFlag);
1798 Yap_InitCPred("call_with_args", 5, p_execute_4, HiddenPredFlag);
1799 Yap_InitCPred("call_with_args", 6, p_execute_5, HiddenPredFlag);
1800 Yap_InitCPred("call_with_args", 7, p_execute_6, HiddenPredFlag);
1801 Yap_InitCPred("call_with_args", 8, p_execute_7, HiddenPredFlag);
1802 Yap_InitCPred("call_with_args", 9, p_execute_8, HiddenPredFlag);
1803 Yap_InitCPred("call_with_args", 10, p_execute_9, HiddenPredFlag);
1804 Yap_InitCPred("call_with_args", 11, p_execute_10, HiddenPredFlag);
1805 Yap_InitCPred("$debug_on", 1, p_debug_on, HiddenPredFlag);
1806 #ifdef DEPTH_LIMIT
1807 Yap_InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, HiddenPredFlag);
1808 #endif
1809 Yap_InitCPred("$execute0", 2, p_execute0, HiddenPredFlag);
1810 Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop, HiddenPredFlag);
1811 Yap_InitCPred("$execute_clause", 4, p_execute_clause, HiddenPredFlag);
1812 CurrentModule = HACKS_MODULE;
1813 Yap_InitCPred("current_choice_point", 1, p_save_cp, HiddenPredFlag);
1814 Yap_InitCPred("current_choicepoint", 1, p_save_cp, HiddenPredFlag);
1815 Yap_InitCPred("env_choice_point", 1, p_save_env_b, HiddenPredFlag);
1816 Yap_InitCPred("trail_suspension_marker", 1, p_trail_suspension_marker, HiddenPredFlag);
1817 Yap_InitCPred("cut_at", 1, p_clean_ifcp, SafePredFlag);
1818 CurrentModule = cm;
1819 Yap_InitCPred("$pred_goal_expansion_on", 0, p_pred_goal_expansion_on, SafePredFlag|HiddenPredFlag);
1820 Yap_InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag|HiddenPredFlag);
1821 Yap_InitCPred("$restore_regs", 2, p_restore_regs2, SafePredFlag|HiddenPredFlag);
1822 Yap_InitCPred("$clean_ifcp", 1, p_clean_ifcp, SafePredFlag|HiddenPredFlag);
1823 Yap_InitCPred("qpack_clean_up_to_disjunction", 0, p_cut_up_to_next_disjunction, SafePredFlag);
1824 Yap_InitCPred("$jump_env_and_store_ball", 1, p_jump_env, HiddenPredFlag);
1825 Yap_InitCPred("$creep_allowed", 0, p_creep_allowed, HiddenPredFlag);
1826 Yap_InitCPred("$generate_pred_info", 4, p_generate_pred_info, HiddenPredFlag);
1827 Yap_InitCPred("$uncaught_throw", 0, p_uncaught_throw, HiddenPredFlag);
1828 Yap_InitCPred("$reset_exception", 1, p_reset_exception, HiddenPredFlag);
1829 Yap_InitCPred("$get_exception", 1, p_get_exception, HiddenPredFlag);
1830 }
1831
1832
1833