YAP 7.1.0
bignum.c
1/*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: arith1.c *
12 * Last rev: *
13 * mods: *
14 * comments: bignum support through gmp *
15 * *
16 *************************************************************************/
17#ifdef SCCS
18static char SccsId[] = "%W% %G%";
19#endif
20#include "Yap.h"
21#include "Yatom.h"
22
23#if HAVE_STRING_H
24#include <string.h>
25
26#endif
27
28#include "YapHeap.h"
29#include "YapText.h"
30
31#ifdef USE_GMP
32
33#include "YapEval.h"
34#include "alloc.h"
35
36size_t
37SizeOfOpaqueTerm(Term *next, CELL cnext)
38{
39 size_t sz;
40 switch (cnext) {
41 {
42 case (CELL)FunctorLongInt:
43 sz = 3;
44 break;
45 }
46 case (CELL)FunctorDouble:
47 {
48 sz =2+ SIZEOF_DOUBLE / SIZEOF_INT_P;
49 break;
50 }
51 case (CELL)FunctorString:
52 {
53 sz = 3 + next[1];
54 break;
55 }
56 case (CELL)FunctorBigInt:
57 {
58
59 sz = 3+(sizeof(MP_INT)+
60 ((MP_INT *)(next + 2))->_mp_alloc * sizeof(mp_limb_t)) /
61 CellSize;
62 }
63 break;
64 case (CELL)FunctorBlob:
65 {
66
67 sz = 4+next[2];
68 }
69}
70 /* if (!IsAtomTerm(next[sz-1])) */
71 /* return 0; */
72 /* CELL *p = (CELL*)AtomOfTerm(next[sz-1]); */
73 /* if ( p == next ) */
74 /* return sz; */
75 return sz;
76}
77
78
79
80Term Yap_MkBigIntTerm(MP_INT *big) {
81 CACHE_REGS
82 Int nlimbs;
83 MP_INT *dst = (MP_INT *)(HR + 2);
84 CELL *ret = HR;
85 Int bytes;
86
87 if (mpz_fits_slong_p(big)) {
88 long int out = mpz_get_si(big);
89 return MkIntegerTerm((Int)out);
90 }
91 // bytes = big->_mp_alloc * sizeof(mp_limb_t);
92 // nlimbs = ALIGN_YAPTYPE(bytes,CELL)/CellSize;
93 // this works, but it shouldn't need to do this...
94 nlimbs = big->_mp_alloc;
95 bytes = nlimbs * sizeof(mp_limb_t);
96 if (nlimbs > (ASP - ret) - 1024) {
97 return TermNil;
98 }
99 HR[0] = (CELL)FunctorBigInt;
100 HR[1] = BIG_INT;
101
102 dst->_mp_size = big->_mp_size;
103 dst->_mp_alloc = nlimbs * (CellSize / sizeof(mp_limb_t));
104 memmove((void *)(dst + 1), (const void *)(big->_mp_d), bytes);
105 HR = (CELL *)(dst + 1) + bytes/CellSize;
106 HR[0] = CloseExtension(ret);
107 HR++;
108 return AbsAppl(ret);
109}
110
111MP_INT *Yap_BigIntOfTerm(Term t) {
112 MP_INT *new = (MP_INT *)(RepAppl(t) + 2);
113
114 new->_mp_d = (mp_limb_t *)(new + 1);
115 return (new);
116}
117
118Term Yap_MkBigRatTerm(MP_RAT *big) {
119 CACHE_REGS
120 Int nlimbs;
121 MP_INT *dst = (MP_INT *)(HR + 2);
122 MP_INT *num = mpq_numref(big);
123 MP_INT *den = mpq_denref(big);
124 MP_RAT *rat;
125 CELL *ret = HR;
126
127 if (mpz_cmp_si(den, 1) == 0)
128 return Yap_MkBigIntTerm(num);
129 if ((num->_mp_alloc + den->_mp_alloc) * (sizeof(mp_limb_t) / CellSize) >
130 (ASP - ret) - 1024) {
131 return TermNil;
132 }
133 HR[0] = (CELL)FunctorBigInt;
134 HR[1] = BIG_RATIONAL;
135 dst->_mp_size = 0;
136 rat = (MP_RAT *)(dst + 1);
137 rat->_mp_num._mp_size = num->_mp_size;
138 rat->_mp_num._mp_alloc = num->_mp_alloc;
139 nlimbs = (num->_mp_alloc) * (sizeof(mp_limb_t) / CellSize);
140 memmove((void *)(rat + 1), (const void *)(num->_mp_d), nlimbs * CellSize);
141 rat->_mp_den._mp_size = den->_mp_size;
142 rat->_mp_den._mp_alloc = den->_mp_alloc;
143 HR = (CELL *)(rat + 1) + nlimbs;
144 nlimbs = (den->_mp_alloc) * (sizeof(mp_limb_t) / CellSize);
145 memmove((void *)(HR), (const void *)(den->_mp_d), nlimbs * CellSize);
146 HR += nlimbs;
147 dst->_mp_alloc = (HR - (CELL *)(dst + 1));
148 HR[0] = CloseExtension(ret);
149 HR++;
150 return AbsAppl(ret);
151}
152
153MP_RAT *Yap_BigRatOfTerm(Term t) {
154 MP_RAT *new = (MP_RAT *)(RepAppl(t) + 2 + sizeof(MP_INT) / sizeof(CELL));
155 mp_limb_t *nt;
156
157 nt = new->_mp_num._mp_d = (mp_limb_t *)(new + 1);
158 nt += new->_mp_num._mp_alloc;
159 new->_mp_den._mp_d = nt;
160 return new;
161}
162
163Term Yap_RatTermToApplTerm(Term t) {
164 Term ts[2];
165 MP_RAT *rat = Yap_BigRatOfTerm(t);
166
167 ts[0] = Yap_MkBigIntTerm(mpq_numref(rat));
168 ts[1] = Yap_MkBigIntTerm(mpq_denref(rat));
169 return Yap_MkApplTerm(FunctorRDiv, 2, ts);
170}
171
172#endif
173
174Term Yap_AllocExternalDataInStack(CELL tag, size_t bytes, CELL* *pt) {
175 CACHE_REGS
176 Int ncells;
177 CELL *ret = HR, *tmp = HR;
178
179 // fprintf(stderr,"EW %% %p %lx\n",ret,bytes);
180
181 ncells = (bytes+(CellSize-1)) / CellSize;
182 if (ncells > (ASP - ret) - 1024) {
183 return TermNil;
184 }
185
186 ret[0] = (CELL)FunctorBlob;
187 ret[1] = tag;
188 ret[2] = ncells;
189 tmp+=3;
190 *pt = (CELL*)(tmp);
191 HR = tmp+ ncells;
192 HR[0] = CloseExtension((ret));
193 HR++;
194 return AbsAppl(ret);
195}
196
197
198int Yap_CleanOpaqueVariable(CELL d) {
199 CELL *pt = RepAppl(HeadOfTerm(d));
200 CELL blob_tag = pt[1];
201
202 // fprintf(stderr,"FAIL %% %p %lx %lx %lx\n",pt,pt[0],pt[1],pt[2]);
203#ifdef DEBUG
204 /* sanity checking */
205 if (pt[0] != (CELL)FunctorBlob) {
206 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
207 return FALSE;
208 }
209#endif
210 if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
211 Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt),
212 "clean opaque: bad blob with tag " UInt_FORMAT, blob_tag);
213 return FALSE;
214 }
215Int blob_info = blob_tag;
216 if (!GLOBAL_OpaqueHandlers)
217 return false;
218 if (!GLOBAL_OpaqueHandlers[blob_info].fail_handler)
219 return true;
220 return (GLOBAL_OpaqueHandlers[blob_info].fail_handler)(d);
221}
222
223YAP_Opaque_CallOnWrite Yap_blob_write_handler(Term t) {
224 CELL blob_info, blob_tag;
225 CELL *pt = RepAppl(t);
226
227#ifdef DEBUG
228 /* sanity checking */
229 if (pt[0] != (CELL)FunctorBlob) {
230 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
231 return FALSE;
232 }
233#endif
234 blob_tag = pt[1];
235 if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
236 Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt),
237 "clean opaque: bad blob with tag " UInt_FORMAT, blob_tag);
238 return FALSE;
239 }
240 blob_info = blob_tag;
241 if (!GLOBAL_OpaqueHandlers) {
242 return NULL;
243 }
244 return GLOBAL_OpaqueHandlers[blob_info].write_handler;
245}
246
247YAP_Opaque_CallOnGCMark Yap_blob_gc_mark_handler(Term t) {
248 CELL blob_info, blob_tag;
249 CELL *pt = RepAppl(t);
250
251#ifdef DEBUG0
252 /* sanity checking */
253 if (pt[0] != (CELL)FunctorBigInt) {
254 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
255 return FALSE;
256 }
257#endif
258 blob_tag = pt[1];
259 if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
260 return NULL;
261 }
262 blob_info = blob_tag;
263 if (!GLOBAL_OpaqueHandlers)
264 return NULL;
265 return GLOBAL_OpaqueHandlers[blob_info].mark_handler;
266}
267
268YAP_Opaque_CallOnGCRelocate Yap_blob_gc_relocate_handler(Term t) {
269 CELL blob_info, blob_tag;
270 CELL *pt = RepAppl(t);
271
272#ifdef DEBUG
273 /* sanity checking */
274 if (pt[0] != (CELL)FunctorBlob) {
275 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
276 return FALSE;
277 }
278#endif
279 blob_tag = pt[1];
280 if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
281 Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt),
282 "clean opaque: bad blob with tag " UInt_FORMAT, blob_tag);
283 return FALSE;
284 }
285 blob_info = blob_tag;
286 if (!GLOBAL_OpaqueHandlers)
287 return NULL;
288 return GLOBAL_OpaqueHandlers[blob_info].relocate_handler;
289}
290
291extern Int Yap_blob_tag(Term t) {
292 CELL *pt = RepAppl(t);
293
294#ifdef DEBUG
295 /* sanity checking */
296 if (pt[0] != (CELL)FunctorBlob) {
297 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
298 return FALSE;
299 }
300#endif
301 return pt[1];
302}
303
304void *Yap_blob_info(Term t) {
305 MP_INT *blobp;
306 CELL *pt = RepAppl(t);
307
308#ifdef DEBUG
309 /* sanity checking */
310 if (pt[0] != (CELL)FunctorBlob) {
311 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
312 return FALSE;
313 }
314#endif
315 if (!GLOBAL_OpaqueHandlers)
316 return FALSE;
317 blobp = (MP_INT *)(pt + 2);
318 return (void *)(blobp + 1);
319}
320
321Term Yap_MkULLIntTerm(YAP_ULONG_LONG n) {
322#if __GNUC__
323 mpz_t new;
324 char tmp[256];
325 Term t;
326
327#ifdef _WIN32
328 snprintf(tmp, 256, "%I64u", n);
329#elif HAVE_SNPRINTF
330 snprintf(tmp, 256, "%llu", n);
331#else
332 sprintf(tmp, "%llu", n);
333#endif
334 /* try to scan it as a bignum */
335 mpz_init_set_str(new, tmp, 10);
336 if (mpz_fits_slong_p(new)) {
337 CACHE_REGS
338 return MkIntegerTerm(mpz_get_si(new));
339 }
340 t = Yap_MkBigIntTerm(new);
341 mpz_clear(new);
342 return t;
343#else
344 CACHE_REGS
345 return MkIntegerTerm(n);
346#endif
347}
348
349CELL *Yap_HeapStoreOpaqueTerm(Term t) {
350 CELL *ptr = RepAppl(t);
351 size_t sz;
352 void *new;
353
354 sz = SizeOfOpaqueTerm(ptr,ptr[0]);
355 new = Yap_AllocCodeSpace(sz);
356 if (!new) {
357 Yap_Error(RESOURCE_ERROR_HEAP, TermNil,
358 "subgoal_search_loop: no space for %s", StringOfTerm(t));
359 } else {
360 if (ptr[0] == (CELL)FunctorBlob) {
361 CELL *new = ptr + 3;
362 memmove(new, ptr, sz);
363 }
364 }
365 return new;
366}
367
368size_t Yap_OpaqueTermToString(Term t, char *str, size_t max) {
369 size_t str_index = 0;
370 CELL *li = RepAppl(t);
371 unsigned char *ptr = (unsigned char *)StringOfTerm(AbsAppl(li));
372 if (li[0] == (CELL)FunctorString) {
373 str_index += sprintf(&str[str_index], "\"");
374 do {
375 utf8proc_int32_t chr;
376 ptr += get_utf8(ptr, -1, &chr);
377 if (chr == '\0')
378 break;
379 str_index += sprintf(str + str_index, "%C", chr);
380 } while (TRUE);
381 str_index += sprintf(str + str_index, "\"");
382 } else {
383 CELL big_tag = li[1];
384
385 if (big_tag == ARRAY_INT || big_tag == ARRAY_FLOAT) {
386 str_index += sprintf(&str[str_index], "{...}");
387#ifdef USE_GMP
388 } else if (big_tag == BIG_INT) {
389 MP_INT *big = Yap_BigIntOfTerm(AbsAppl(li));
390 char *s = mpz_get_str(&str[str_index], 10, big);
391 str_index += strlen(&s[str_index]);
392 } else if (big_tag == BIG_RATIONAL) {
393 MP_RAT *big = Yap_BigRatOfTerm(AbsAppl(li));
394 char *s = mpq_get_str(&str[str_index], 10, big);
395 str_index += strlen(&s[str_index]);
396#endif
397 }
398 /*
399 else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) {
400 Opaque_CallOnWrite f;
401 CELL blob_info;
402
403 blob_info = big_tag - USER_BLOB_START;
404 if (GLOBAL_OpaqueHandlers &&
405 (f= GLOBAL_OpaqueHandlers[blob_info].write_handler)) {
406 (f)(wglb->stream, big_tag, ExternalBlobFromTerm(t), 0);
407 return;
408 }
409 } */
410 str_index += sprintf(&str[str_index], "0");
411 }
412 return str_index;
413}
414
415static Int p_is_bignum(USES_REGS1) {
416#ifdef USE_GMP
417 Term t = Deref(ARG1);
418 return (IsNonVarTerm(t) && IsApplTerm(t) &&
419 FunctorOfTerm(t) == FunctorBigInt && RepAppl(t)[1] == BIG_INT);
420#else
421 return FALSE;
422#endif
423}
424
425static Int p_is_string(USES_REGS1) {
426 Term t = Deref(ARG1);
427 return (IsNonVarTerm(t) && IsApplTerm(t) &&
428 FunctorOfTerm(t) == FunctorString);
429}
430
431static Int p_nb_set_bit(USES_REGS1) {
432#ifdef USE_GMP
433 Term t = Deref(ARG1);
434 Term ti = Deref(ARG2);
435 Int i;
436
437 if (!(IsNonVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == FunctorBigInt &&
438 RepAppl(t)[1] == BIG_INT))
439 return FALSE;
440 if (!IsIntegerTerm(ti)) {
441 return FALSE;
442 }
443 if (!IsIntegerTerm(ti)) {
444 return FALSE;
445 }
446 i = IntegerOfTerm(ti);
447 if (i < 0) {
448 return FALSE;
449 }
450 Yap_gmp_set_bit(i, t);
451 return TRUE;
452#else
453 return FALSE;
454#endif
455}
456
457static Int p_has_bignums(USES_REGS1) {
458#ifdef USE_GMP
459 return TRUE;
460#else
461 return FALSE;
462#endif
463}
464
465static Int p_is_opaque(USES_REGS1) {
466 Term t = Deref(ARG1);
467 if (IsVarTerm(t))
468 return FALSE;
469 if (IsApplTerm(t)) {
470 Functor f = FunctorOfTerm(t);
471 CELL *pt;
472
473 if (f != FunctorBigInt && f!= FunctorBlob)
474 return FALSE;
475 pt = RepAppl(t);
476 return (pt[1] != BIG_RATIONAL && pt[1] != BIG_INT);
477 }
478 return FALSE;
479}
480
481static Int p_is_rational(USES_REGS1) {
482 Term t = Deref(ARG1);
483 if (IsVarTerm(t))
484 return FALSE;
485 if (IsIntTerm(t))
486 return TRUE;
487 if (IsApplTerm(t)) {
488 Functor f = FunctorOfTerm(t);
489 CELL *pt;
490
491 if (f == FunctorLongInt)
492 return TRUE;
493 if (f != FunctorBigInt)
494 return FALSE;
495 pt = RepAppl(t);
496 return (pt[1] == BIG_RATIONAL || pt[1] == BIG_INT);
497 }
498 return FALSE;
499}
500
501static Int p_rational(USES_REGS1) {
502#ifdef USE_GMP
503 Term t = Deref(ARG1);
504 Functor f;
505 CELL *pt;
506 MP_RAT *rat;
507 Term t1, t2;
508
509 if (IsVarTerm(t))
510 return FALSE;
511 if (!IsApplTerm(t))
512 return FALSE;
513 f = FunctorOfTerm(t);
514 if (f != FunctorBigInt)
515 return FALSE;
516 pt = RepAppl(t);
517 if (pt[1] != BIG_RATIONAL)
518 return FALSE;
519 rat = Yap_BigRatOfTerm(t);
520 while ((t1 = Yap_MkBigIntTerm(mpq_numref(rat))) == TermNil ||
521 (t2 = Yap_MkBigIntTerm(mpq_denref(rat))) == TermNil) {
522 UInt size = (mpq_numref(rat)->_mp_alloc) * (sizeof(mp_limb_t) / CellSize) +
523 (mpq_denref(rat)->_mp_alloc) * (sizeof(mp_limb_t) / CellSize);
524 if (!Yap_dogcl(size PASS_REGS)) {
525 Yap_Error(RESOURCE_ERROR_STACK, t, LOCAL_ErrorMessage);
526 return FALSE;
527 }
528 }
529 return Yap_unify(ARG2, t1) && Yap_unify(ARG3, t2);
530#else
531 return FALSE;
532#endif
533}
534
535void Yap_InitBigNums(void) {
536 Yap_InitCPred("$has_bignums", 0, p_has_bignums, SafePredFlag);
537 Yap_InitCPred("$bignum", 1, p_is_bignum, SafePredFlag);
538 Yap_InitCPred("rational", 3, p_rational, 0);
539 Yap_InitCPred("rational", 1, p_is_rational, SafePredFlag);
547 Yap_InitCPred("string", 1, p_is_string, SafePredFlag);
548 Yap_InitCPred("opaque", 1, p_is_opaque, SafePredFlag);
549 Yap_InitCPred("nb_set_bit", 2, p_nb_set_bit, SafePredFlag);
550}
Yap.h
Main definitions.
MP_INT
Definition: TermExt.h:345
MP_RAT
Definition: TermExt.h:350