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: corout.c *
12 * Last rev: *
13 * mods: *
14 * comments: Co-routining from within YAP *
15 * *
16 *************************************************************************/
17 #ifdef SCCS
18 static char SccsId[]="%W% %G%";
19 #endif
20
21 #include "Yap.h"
22 #include "Yatom.h"
23 #include "YapHeap.h"
24 #include "heapgc.h"
25 #include "attvar.h"
26 #ifndef NULL
27 #define NULL (void *)0
28 #endif
29
30 #ifdef COROUTINING
31
32 /* check if variable was there */
AddVarIfNotThere(Term var,Term dest)33 static Term AddVarIfNotThere(Term var , Term dest)
34 {
35 Term test = dest;
36 while (test != TermNil) {
37 if ((RepPair(test))[0] == var) return(dest);
38 else test = (RepPair(test))[1];
39 }
40 return(MkPairTerm(var,dest));
41 }
42
43
44 /* This routine verifies whether two complex structures can unify. */
can_unify_complex(register CELL * pt0,register CELL * pt0_end,register CELL * pt1,Term * Vars)45 static int can_unify_complex(register CELL *pt0,
46 register CELL *pt0_end,
47 register CELL *pt1,
48 Term *Vars)
49 {
50
51 /* This is really just unification, folks */
52 tr_fr_ptr saved_TR;
53 CELL *saved_HB;
54 choiceptr saved_B;
55
56 register CELL **to_visit = (CELL **)Yap_PreAllocCodeSpace();
57 CELL **to_visit_base = to_visit;
58
59 /* make sure to trail all bindings */
60 saved_TR = TR;
61 saved_B = B;
62 saved_HB = HB;
63 HB = H;
64
65 loop:
66 while (pt0 < pt0_end) {
67 register CELL d0, d1;
68 ++ pt0;
69 ++ pt1;
70 d0 = Derefa(pt0);
71 d1 = Derefa(pt1);
72 if (IsVarTerm(d0)) {
73 if (IsVarTerm(d1)) {
74 if (d0 != d1) {
75 /* we need to suspend on both variables ! */
76 *Vars = AddVarIfNotThere(d0, AddVarIfNotThere(d1,*Vars));
77 /* bind the two variables, we would have to do that to unify
78 them */
79 if (d1 > d0) { /* youngest */
80 /* we don't want to wake up goals */
81 Bind_Global((CELL *)d1, d0);
82 } else {
83 Bind_Global((CELL *)d0, d1);
84 }
85 }
86 /* continue the loop */
87 continue;
88 }
89 else {
90 /* oh no, some more variables! */
91 *Vars = AddVarIfNotThere(d0, *Vars);
92 }
93 /* now bind it */
94 Bind_Global((CELL *)d0, d1);
95 /* continue the loop */
96 } else if (IsVarTerm(d1)) {
97 *Vars = AddVarIfNotThere(d1, *Vars);
98 /* and bind it */
99 Bind_Global((CELL *)d1, d0);
100 /* continue the loop */
101 } else {
102 if (d0 == d1) continue;
103 if (IsAtomOrIntTerm(d0) || IsAtomOrIntTerm(d1)) {
104 if (d0 != d1) goto comparison_failed;
105 /* else continue the loop */
106 }
107 else if (IsPairTerm(d0)) {
108 if (!IsPairTerm(d1)) goto comparison_failed;
109 #ifdef RATIONAL_TREES
110 to_visit[0] = pt0;
111 to_visit[1] = pt0_end;
112 to_visit[2] = pt1;
113 to_visit[3] = (CELL *)*pt0;
114 to_visit += 4;
115 *pt0 = d1;
116 #else
117 /* store the terms to visit */
118 if (pt0 < pt0_end) {
119 to_visit[0] = pt0;
120 to_visit[1] = pt0_end;
121 to_visit[2] = pt1;
122 to_visit += 3;
123 }
124 #endif
125 pt0 = RepPair(d0) - 1;
126 pt0_end = RepPair(d0) + 1;
127 pt1 = RepPair(d1) - 1;
128 continue;
129 }
130 else if (IsApplTerm(d0)) {
131 register Functor f;
132 register CELL *ap2, *ap3;
133 if (!IsApplTerm(d1)) {
134 goto comparison_failed;
135 } else {
136 /* store the terms to visit */
137 ap2 = RepAppl(d0);
138 ap3 = RepAppl(d1);
139 f = (Functor)(*ap2);
140 /* compare functors */
141 if (f != (Functor)*ap3) {
142 goto comparison_failed;
143 }
144 if (IsExtensionFunctor(f)) {
145 switch((CELL)f) {
146 case (CELL)FunctorDBRef:
147 if (d0 == d1) continue;
148 goto comparison_failed;
149 case (CELL)FunctorLongInt:
150 if (ap2[1] == ap3[1]) continue;
151 goto comparison_failed;
152 case (CELL)FunctorDouble:
153 if (FloatOfTerm(d0) == FloatOfTerm(d1)) continue;
154 goto comparison_failed;
155 #ifdef USE_GMP
156 case (CELL)FunctorBigInt:
157 if (Yap_gmp_tcmp_big_big(d0,d1) == 0) continue;
158 goto comparison_failed;
159 #endif /* USE_GMP */
160 default:
161 goto comparison_failed;
162 }
163 }
164 #ifdef RATIONAL_TREES
165 to_visit[0] = pt0;
166 to_visit[1] = pt0_end;
167 to_visit[2] = pt1;
168 to_visit[3] = (CELL *)*pt0;
169 to_visit += 4;
170 *pt0 = d1;
171 #else
172 /* store the terms to visit */
173 if (pt0 < pt0_end) {
174 to_visit[0] = pt0;
175 to_visit[1] = pt0_end;
176 to_visit[2] = pt1;
177 to_visit += 3;
178 }
179 #endif
180 d0 = ArityOfFunctor(f);
181 pt0 = ap2;
182 pt0_end = ap2 + d0;
183 pt1 = ap3;
184 continue;
185 }
186 }
187
188 }
189
190 }
191 /* Do we still have compound terms to visit */
192 if (to_visit > (CELL **)to_visit_base) {
193 #ifdef RATIONAL_TREES
194 to_visit -= 4;
195 pt0 = to_visit[0];
196 pt0_end = to_visit[1];
197 pt1 = to_visit[2];
198 *pt0 = (CELL)to_visit[3];
199 #else
200 to_visit -= 3;
201 pt0 = to_visit[0];
202 pt0_end = to_visit[1];
203 pt1 = to_visit[2];
204 #endif
205 goto loop;
206 }
207 /* success */
208 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
209 /* restore B, and later HB */
210 B = saved_B;
211 HB = saved_HB;
212 /* untrail all bindings made by IUnify */
213 while (TR != saved_TR) {
214 pt1 = (CELL *)(TrailTerm(--TR));
215 RESET_VARIABLE(pt1);
216 }
217 return(TRUE);
218
219 comparison_failed:
220 /* failure */
221 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
222 #ifdef RATIONAL_TREES
223 while (to_visit > (CELL **)to_visit_base) {
224 to_visit -= 4;
225 pt0 = to_visit[0];
226 pt0_end = to_visit[1];
227 pt1 = to_visit[2];
228 *pt0 = (CELL)to_visit[3];
229 }
230 #endif
231 /* restore B, and later HB */
232 B = saved_B;
233 HB = saved_HB;
234 /* the system will take care of TR for me, no need to worry here! */
235 return(FALSE);
236 }
237
238 static int
can_unify(Term t1,Term t2,Term * Vars)239 can_unify(Term t1, Term t2, Term *Vars)
240 {
241 t1 = Deref(t1);
242 t2 = Deref(t2);
243 if (t1 == t2) {
244 *Vars = TermNil;
245 return TRUE;
246 }
247 if (IsVarTerm(t1)) {
248 /* we know for sure they can't be different */
249 if (IsVarTerm(t2)) {
250 /* we need to suspend on both variables because otherwise
251 Y = susp(_) would not wakeup susp ! */
252 *Vars = MkPairTerm(t1,MkPairTerm(t2,TermNil));
253 return TRUE;
254 } else {
255 *Vars = MkPairTerm(t1,TermNil);
256 return TRUE;
257 }
258 } else if (IsVarTerm(t2)) {
259 /* wait until t2 is bound */
260 *Vars = MkPairTerm(t2,TermNil);
261 return TRUE;
262 }
263 /* Two standard terms at last! */
264 if (IsAtomOrIntTerm(t1) || IsAtomOrIntTerm(t2)) {
265 /* Two primitive terms can only be equal if they are
266 the same. If they are, $eq succeeds without further ado.
267 */
268 if (t1 != t2)
269 return FALSE;
270 else {
271 *Vars = TermNil;
272 return TRUE;
273 }
274 } else if (IsPairTerm(t1)) {
275 if (IsPairTerm(t2)) {
276 return(can_unify_complex(RepPair(t1)-1, RepPair(t1)+1,
277 RepPair(t2)-1, Vars));
278 } else return FALSE;
279 } else {
280 Functor f = FunctorOfTerm(t1);
281 if (f != FunctorOfTerm(t2))
282 return FALSE;
283 if (IsExtensionFunctor(f)) {
284 switch((CELL)f) {
285 case (CELL)FunctorDBRef:
286 if (t1 == t2) return FALSE;
287 return FALSE;
288 case (CELL)FunctorLongInt:
289 if (RepAppl(t1)[1] == RepAppl(t2)[1]) return(TRUE);
290 return FALSE;
291 case (CELL)FunctorDouble:
292 if (FloatOfTerm(t1) == FloatOfTerm(t2)) return(TRUE);
293 return FALSE;
294 #ifdef USE_GMP
295 case (CELL)FunctorBigInt:
296 if (Yap_gmp_tcmp_big_big(t1,t2) == 0) return(TRUE);
297 return(FALSE);
298 #endif /* USE_GMP */
299 default:
300 return FALSE;
301 }
302 }
303 /* Two complex terms with the same functor */
304 return can_unify_complex(RepAppl(t1),
305 RepAppl(t1)+ArityOfFunctor(f),
306 RepAppl(t2), Vars);
307 }
308 }
309
310 /* This routine verifies whether a complex has variables. */
non_ground_complex(register CELL * pt0,register CELL * pt0_end,Term * Var)311 static int non_ground_complex(register CELL *pt0,
312 register CELL *pt0_end,
313 Term *Var)
314 {
315
316 register CELL **to_visit = (CELL **)Yap_PreAllocCodeSpace();
317 CELL **to_visit_base = to_visit;
318
319 loop:
320 while (pt0 < pt0_end) {
321 register CELL d0;
322 ++ pt0;
323 d0 = Derefa(pt0);
324 if (IsVarTerm(d0)) {
325 *Var = d0;
326 goto var_found;
327 }
328 if (IsPairTerm(d0)) {
329 if (to_visit + 1024 >= (CELL **)AuxSp) {
330 goto aux_overflow;
331 }
332 #ifdef RATIONAL_TREES
333 to_visit[0] = pt0;
334 to_visit[1] = pt0_end;
335 to_visit[2] = (CELL *)*pt0;
336 to_visit += 3;
337 *pt0 = TermNil;
338 #else
339 /* store the terms to visit */
340 if (pt0 < pt0_end) {
341 to_visit[0] = pt0;
342 to_visit[1] = pt0_end;
343 to_visit += 2;
344 }
345 #endif
346 pt0 = RepPair(d0) - 1;
347 pt0_end = RepPair(d0) + 1;
348 }
349 else if (IsApplTerm(d0)) {
350 register Functor f;
351 register CELL *ap2;
352
353 /* store the terms to visit */
354 ap2 = RepAppl(d0);
355 f = (Functor)(*ap2);
356
357 if (IsExtensionFunctor(f)) {
358 continue;
359 }
360 if (to_visit + 1024 >= (CELL **)AuxSp) {
361 goto aux_overflow;
362 }
363 #ifdef RATIONAL_TREES
364 to_visit[0] = pt0;
365 to_visit[1] = pt0_end;
366 to_visit[2] = (CELL *)*pt0;
367 to_visit += 3;
368 *pt0 = TermNil;
369 #else
370 /* store the terms to visit */
371 if (pt0 < pt0_end) {
372 to_visit[0] = pt0;
373 to_visit[1] = pt0_end;
374 to_visit += 2;
375 }
376 #endif
377 d0 = ArityOfFunctor(f);
378 pt0 = ap2;
379 pt0_end = ap2 + d0;
380 }
381 /* just continue the loop */
382 }
383
384 /* Do we still have compound terms to visit */
385 if (to_visit > (CELL **)to_visit_base) {
386 #ifdef RATIONAL_TREES
387 to_visit -= 3;
388 pt0 = to_visit[0];
389 pt0_end = to_visit[1];
390 *pt0 = (CELL)to_visit[2];
391 #else
392 to_visit -= 2;
393 pt0 = to_visit[0];
394 pt0_end = to_visit[1];
395 #endif
396 goto loop;
397 }
398
399 /* the term is ground */
400 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
401 return FALSE;
402
403 var_found:
404 /* the term is non-ground */
405 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
406 #ifdef RATIONAL_TREES
407 while (to_visit > (CELL **)to_visit_base) {
408 to_visit -= 3;
409 pt0 = to_visit[0];
410 pt0_end = to_visit[1];
411 *pt0 = (CELL)to_visit[2];
412 }
413 #endif
414 /* the system will take care of TR for me, no need to worry here! */
415 return TRUE;
416
417 aux_overflow:
418 /* unwind stack */
419 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit);
420 #ifdef RATIONAL_TREES
421 while (to_visit > (CELL **)to_visit_base) {
422 to_visit -= 3;
423 pt0 = to_visit[0];
424 *pt0 = (CELL)to_visit[2];
425 }
426 #endif
427 return -1;
428 }
429
430 static int
non_ground(Term t,Term * Var)431 non_ground(Term t, Term *Var)
432 {
433 int out = -1;
434 while (out < 0) {
435 t = Deref(t);
436 if (IsVarTerm(t)) {
437 /* we found a variable */
438 *Var = t;
439 return TRUE;
440 }
441 if (IsPrimitiveTerm(t)) {
442 return FALSE;
443 } else if (IsPairTerm(t)) {
444 out = non_ground_complex(RepPair(t)-1, RepPair(t)+1, Var);
445 if (out >= 0)
446 return out;
447 } else {
448 Functor f = FunctorOfTerm(t);
449 if (IsExtensionFunctor(f)) {
450 return FALSE;
451 }
452 out = non_ground_complex(RepAppl(t),
453 RepAppl(t)+ArityOfFunctor(FunctorOfTerm(t)),
454 Var);
455 if (out >= 0)
456 return out;
457 }
458 if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
459 Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "overflow in ground");
460 return FALSE;
461 }
462 }
463 return FALSE;
464 }
465
466 #endif
467
468 /* check whether the two terms unify and return what variables should
469 be bound before the terms are exactly equal */
p_can_unify(void)470 static Int p_can_unify(void)
471 {
472 #ifdef COROUTINING
473 Term r = TermNil;
474 if (!can_unify(ARG1, ARG2, &r))
475 return FALSE;
476 return Yap_unify(ARG3, r);
477 #else
478 return FALSE;
479 #endif
480 }
481
482 /* if the term is not ground return a variable in the term */
p_non_ground(void)483 static Int p_non_ground(void)
484 {
485 #ifdef COROUTINING
486 Term r = TermNil;
487 if (!non_ground(ARG1, &r))
488 return(FALSE);
489 return (Yap_unify(ARG2, r));
490 #else
491 return(FALSE);
492 #endif
493 }
494
495 /* if the term is not ground return a variable in the term */
p_coroutining(void)496 static Int p_coroutining(void)
497 {
498 #ifdef COROUTINING
499 return(TRUE);
500 #else
501 return(FALSE);
502 #endif
503 }
504
505 #if COROUTINING
506 static Term
ListOfWokenGoals(void)507 ListOfWokenGoals(void) {
508 return Yap_ReadTimedVar(WokenGoals);
509 }
510
511 Term
Yap_ListOfWokenGoals(void)512 Yap_ListOfWokenGoals(void) {
513 return ListOfWokenGoals();
514 }
515 #endif
516
517 /* return a list of awoken goals */
p_awoken_goals(void)518 static Int p_awoken_goals(void)
519 {
520 #ifdef COROUTINING
521 Term WGs = Yap_ReadTimedVar(WokenGoals);
522 if (WGs == TermNil) {
523 return(FALSE);
524 }
525 WGs = ListOfWokenGoals();
526 Yap_UpdateTimedVar(WokenGoals, TermNil);
527 return(Yap_unify(ARG1,WGs));
528 #else
529 return(FALSE);
530 #endif
531 }
532
533 static Int
p_yap_has_rational_trees(void)534 p_yap_has_rational_trees(void)
535 {
536 #if RATIONAL_TREES
537 return TRUE;
538 #else
539 return FALSE;
540 #endif
541 }
542
543 static Int
p_yap_has_coroutining(void)544 p_yap_has_coroutining(void)
545 {
546 #if COROUTINING
547 return TRUE;
548 #else
549 return FALSE;
550 #endif
551 }
552
553 void
Yap_InitCoroutPreds(void)554 Yap_InitCoroutPreds(void)
555 {
556 #ifdef COROUTINING
557 Atom at;
558 PredEntry *pred;
559
560 at = AtomWakeUpGoal;
561 pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 2),0));
562 WakeUpCode = pred;
563 #endif
564 Yap_InitAttVarPreds();
565 Yap_InitCPred("$yap_has_rational_trees", 0, p_yap_has_rational_trees, SafePredFlag|HiddenPredFlag);
566 Yap_InitCPred("$yap_has_coroutining", 0, p_yap_has_coroutining, SafePredFlag|HiddenPredFlag);
567 Yap_InitCPred("$can_unify", 3, p_can_unify, SafePredFlag|HiddenPredFlag);
568 Yap_InitCPred("$non_ground", 2, p_non_ground, SafePredFlag|HiddenPredFlag);
569 Yap_InitCPred("$coroutining", 0, p_coroutining, SafePredFlag|HiddenPredFlag);
570 Yap_InitCPred("$awoken_goals", 1, p_awoken_goals, SafePredFlag|HiddenPredFlag);
571 }
572
573
574