1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 2011-2020, University of Amsterdam
7 CWI, Amsterdam
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions
12 are met:
13
14 1. Redistributions of source code must retain the above copyright
15 notice, this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in
19 the documentation and/or other materials provided with the
20 distribution.
21
22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33 POSSIBILITY OF SUCH DAMAGE.
34 */
35
36 /*#define O_DEBUG 1*/
37 #include "pl-incl.h"
38 #include "pl-copyterm.h"
39 #define AC_TERM_WALK_LRD 1
40 #include "pl-termwalk.c"
41
42
43 /*******************************
44 * COPY TERM *
45 *******************************/
46
47 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
48 Copy-term uses the GC marks to mark the state of variables and terms:
49
50 MARK_MASK FIRST_MASK
51 0 0 Virgin
52 1 0 Visited
53 1 1 Visited twice (share in copy)
54 0 1 Ground (share with origin)
55
56 Places where we put marks:
57
58 - variables (virgin/visited/shared)
59 - value of attvar (virgin/visited/shared)
60 - definition of term (virgin/visited/shared/ground)
61
62 There are two marking algorithms: mark_for_duplicate() for
63 duplicate_term/2 that does not try to share with the original and a more
64 extensive mark_for_copy() that classifies terms as ground. The latter is
65 a bottom-up process and thus requires pushing the processed nodes on the
66 stack for re-visit. The algorithm is carefully designed to use only a
67 single cell on a segmented cell for each node processed. This means that
68 the required stack size is at most 1/2th of the size of the term being
69 copied.
70
71 mark_for_duplicate() could quite easily return the required stack-size,
72 avoiding stack-resizing during the actual copy. This is much harder for
73 mark_for_copy() and I doubt that this makes much difference in actual
74 applications.
75 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
76
77 #define VAR_MARK ((0x1<<LMASK_BITS)|TAG_VAR)
78 #define BOTH_MASK (MARK_MASK|FIRST_MASK)
79
80 #define visited(w) ((w) & BOTH_MASK)
81 #define visited_once(w) (((w) & BOTH_MASK) == MARK_MASK)
82 #define virgin(w) (!visited(w))
83 #define shared(w) (((w) & BOTH_MASK) == BOTH_MASK)
84 #define ground(w) (((w) & BOTH_MASK) == FIRST_MASK)
85 #define set_visited(w) (w |= MARK_MASK)
86 #define set_shared(w) (w |= BOTH_MASK)
87 #define set_ground(w) (w &= ~MARK_MASK, w |= FIRST_MASK)
88
89 #define COPY_SHARE 0x01 /* Share ground terms */
90 #define COPY_ATTRS 0x02 /* do copy attributes */
91 #define COPY_ABSTRACT 0x04 /* Abstract compounds */
92
93 static int
mark_for_duplicate(Word p,int flags ARG_LD)94 mark_for_duplicate(Word p, int flags ARG_LD)
95 { term_agenda agenda;
96
97 initTermAgenda(&agenda, 1, p);
98 while((p=nextTermAgenda(&agenda)))
99 {
100 again:
101 switch(tag(*p))
102 { case TAG_ATTVAR:
103 { if ( flags & COPY_ATTRS )
104 { p = valPAttVar(*p);
105 goto again;
106 }
107 /*FALLTHROUGH*/
108 }
109 case TAG_VAR:
110 { if ( virgin(*p) )
111 set_visited(*p);
112 else if ( visited_once(*p) )
113 set_shared(*p);
114 break;
115 }
116 case TAG_COMPOUND:
117 { Functor t = valueTerm(*p);
118 int arity = arityFunctor(t->definition);
119
120 if ( virgin(t->definition) )
121 { set_visited(t->definition);
122 } else
123 { if ( visited_once(t->definition) )
124 set_shared(t->definition);
125 break;
126 }
127
128 if ( !pushWorkAgenda(&agenda, arity, t->arguments) )
129 return MEMORY_OVERFLOW;
130 continue;
131 }
132 }
133 }
134 clearTermAgenda(&agenda);
135
136 return TRUE;
137 }
138
139
140 /* unshare_attvar() ensures that even ground attvar structures are not
141 shared as ground. We assume that the att/3 structure is not shared
142 with anything else. The shared/unshared distinction is lost during
143 the ground marking.
144 */
145
146 static void
unshare_attvar(Word p ARG_LD)147 unshare_attvar(Word p ARG_LD)
148 { for(;;)
149 { deRef(p);
150
151 if ( isTerm(*p) )
152 { Functor t = valueTerm(*p);
153 word fd = (t->definition & ~BOTH_MASK);
154
155 if ( fd == FUNCTOR_att3 )
156 { t->definition = fd | MARK_MASK;
157 p = &t->arguments[2];
158 }
159 } else
160 { break;
161 }
162 }
163 }
164
165
166 static int
can_share(Word p ARG_LD)167 can_share(Word p ARG_LD)
168 {
169 again:
170 switch(tag(*p))
171 { case TAG_VAR:
172 case TAG_ATTVAR:
173 return FALSE;
174 case TAG_REFERENCE:
175 p = unRef(*p);
176 goto again;
177 case TAG_COMPOUND:
178 { Functor t = valueTerm(*p);
179 return ground(t->definition);
180 }
181 default:
182 return TRUE;
183 }
184 }
185
186
187 static void
update_ground(Word p ARG_LD)188 update_ground(Word p ARG_LD)
189 { Functor t = valueTerm(*p);
190 int arity = arityFunctor(t->definition);
191 Word a = &t->arguments[arity];
192 int ground = TRUE;
193
194 while(--a >= t->arguments)
195 { if ( !can_share(a PASS_LD) )
196 { ground = FALSE;
197 break;
198 }
199 }
200
201 if ( ground )
202 set_ground(t->definition);
203 }
204
205
206 static int
pushForMark(segstack * stack,Word p,int wr)207 pushForMark(segstack *stack, Word p, int wr)
208 { word w = ((word)p)|wr;
209
210 return pushSegStack(stack, w, word);
211 }
212
213 static void
popForMark(segstack * stack,Word * pp,int * wr)214 popForMark(segstack *stack, Word *pp, int *wr)
215 { word w = 0;
216
217 popSegStack(stack, &w, word);
218 *wr = w & (word)0x1;
219 *pp = (Word)(w & ~(word)0x1);
220 }
221
222
223 static int
mark_for_copy(Word p,int flags ARG_LD)224 mark_for_copy(Word p, int flags ARG_LD)
225 { Word start = p;
226 int walk_ref = FALSE;
227 Word buf[1024];
228 segstack stack;
229
230 initSegStack(&stack, sizeof(Word), sizeof(buf), buf);
231
232 for(;;)
233 { switch(tag(*p))
234 { case TAG_ATTVAR:
235 { if ( flags & COPY_ATTRS )
236 { if ( !pushForMark(&stack, p, walk_ref) )
237 { clearSegStack(&stack);
238 return MEMORY_OVERFLOW;
239 }
240 walk_ref = TRUE;
241 p = valPAttVar(*p);
242 continue;
243 }
244 /*FALLTHROUGH*/
245 }
246 case TAG_VAR:
247 { if ( virgin(*p) )
248 set_visited(*p);
249 else if ( visited_once(*p) )
250 set_shared(*p);
251 break;
252 }
253 case TAG_REFERENCE:
254 { if ( !pushForMark(&stack, p, walk_ref) )
255 { clearSegStack(&stack);
256 return MEMORY_OVERFLOW;
257 }
258 walk_ref = TRUE;
259 deRef(p);
260 continue;
261 }
262 case TAG_COMPOUND:
263 { Functor t = valueTerm(*p);
264 int arity = arityFunctor(t->definition);
265
266 if ( virgin(t->definition) )
267 { set_visited(t->definition);
268 } else
269 { if ( visited_once(t->definition) )
270 set_shared(t->definition);
271 break;
272 }
273
274 if ( arity >= 1 )
275 { if ( !pushForMark(&stack, p, walk_ref) )
276 { clearSegStack(&stack);
277 return MEMORY_OVERFLOW;
278 }
279 walk_ref = FALSE;
280 p = &t->arguments[arity-1]; /* last argument */
281 continue;
282 }
283 }
284 }
285
286 if ( p == start )
287 { clearSegStack(&stack);
288 return TRUE;
289 }
290
291 while ( walk_ref )
292 { popForMark(&stack, &p, &walk_ref);
293 if ( isAttVar(*p) )
294 { Word ap = valPAttVar(*p);
295
296 unshare_attvar(ap PASS_LD);
297 }
298 if ( p == start )
299 { clearSegStack(&stack);
300 return TRUE;
301 }
302 }
303
304 p--;
305 if ( tagex(*p) == (TAG_ATOM|STG_GLOBAL) )
306 { popForMark(&stack, &p, &walk_ref);
307 update_ground(p PASS_LD);
308 }
309 }
310 }
311
312
313 /*******************************
314 * UNMARKING *
315 *******************************/
316
317 static void
cp_unmark(Word p,int flags ARG_LD)318 cp_unmark(Word p, int flags ARG_LD)
319 { term_agenda agenda;
320
321 initTermAgenda(&agenda, 1, p);
322 while((p=nextTermAgenda(&agenda)))
323 { again:
324
325 switch(tag(*p))
326 { case TAG_ATTVAR:
327 { if ( flags & COPY_ATTRS )
328 { p = valPAttVar(*p);
329 goto again;
330 }
331 }
332 case TAG_VAR:
333 { *p &= ~BOTH_MASK;
334 continue;
335 }
336 case TAG_COMPOUND:
337 { Functor f = valueTerm(*p);
338
339 if ( visited(f->definition) )
340 { f->definition &= ~BOTH_MASK;
341
342 pushWorkAgenda(&agenda, arityFunctor(f->definition), f->arguments);
343 continue;
344 }
345 }
346 }
347 }
348
349 clearTermAgenda(&agenda);
350 }
351
352
353 static void
initCyclicCopy(ARG1_LD)354 initCyclicCopy(ARG1_LD)
355 { LD->cycle.lstack.unit_size = sizeof(Word);
356 }
357
358 static int
TrailCyclic(Word p ARG_LD)359 TrailCyclic(Word p ARG_LD)
360 { return pushSegStack(&LD->cycle.lstack, p, Word);
361 }
362
363 static inline void
exitCyclicCopy(int flags ARG_LD)364 exitCyclicCopy(int flags ARG_LD)
365 { Word p;
366
367 while(popSegStack(&LD->cycle.lstack, &p, Word))
368 { if ( isRef(*p) )
369 { Word p2 = unRef(*p);
370
371 if ( *p2 == VAR_MARK ) /* sharing variables */
372 { setVar(*p2);
373 setVar(*p);
374 } else
375 { *p = *p2 | MARK_MASK; /* cyclic terms */
376 }
377 } else
378 { Word old = NULL; /* Silence compiler */
379
380 popSegStack(&LD->cycle.lstack, &old, Word);
381
382 if ( !(flags©_ATTRS) )
383 { Word p2 = valPAttVar(*p & ~BOTH_MASK);
384
385 assert(*p2 == VAR_MARK);
386 setVar(*p2);
387 }
388
389 *p = consPtr(old, STG_GLOBAL|TAG_ATTVAR);
390 }
391 }
392 }
393
394
395 static int
copy_term(Word from,Word to,size_t abstract,int flags ARG_LD)396 copy_term(Word from, Word to, size_t abstract, int flags ARG_LD)
397 { term_agendaLRD agenda;
398 int rc = TRUE;
399 size_t aleft = (size_t)-1;
400
401 initTermAgendaLRD(&agenda, 1, from, to);
402 while( nextTermAgendaLRD(&agenda, &from, &to) )
403 { if ( agenda.work.depth == 1 )
404 aleft = abstract;
405
406 again:
407 switch(tag(*from))
408 { case TAG_REFERENCE:
409 { Word p2 = unRef(*from);
410
411 if ( *p2 == VAR_MARK ) /* reference to a copied variable */
412 { *to = makeRef(p2);
413 } else
414 { from = p2; /* normal reference */
415 goto again;
416 }
417
418 continue;
419 }
420 case TAG_VAR:
421 { if ( shared(*from) )
422 { *to = VAR_MARK;
423 *from = makeRef(to);
424 TrailCyclic(from PASS_LD);
425 } else if ( (flags©_ABSTRACT) )
426 { *to = makeRef(from);
427 } else
428 { setVar(*to);
429 }
430
431 continue;
432 }
433 case TAG_ATTVAR:
434 if ( flags©_ATTRS )
435 { Word p = valPAttVar(*from);
436
437 if ( isAttVar(*p) ) /* already copied */
438 { *to = makeRefG(p);
439 } else
440 { Word attr;
441
442 if ( !(attr = alloc_attvar(PASS_LD1)) )
443 { rc = GLOBAL_OVERFLOW;
444 goto out;
445 }
446 TrailCyclic(p PASS_LD);
447 TrailCyclic(from PASS_LD);
448 *from = consPtr(attr, STG_GLOBAL|TAG_ATTVAR);
449 *to = makeRefG(attr);
450
451 from = p;
452 to = &attr[1];
453 goto again;
454 }
455 } else
456 { if ( shared(*from) )
457 { Word p = valPAttVar(*from & ~BOTH_MASK);
458
459 if ( *p == VAR_MARK )
460 { *to = makeRef(p);
461 } else
462 { *to = VAR_MARK;
463 *from = consPtr(to, STG_GLOBAL|TAG_ATTVAR)|BOTH_MASK;
464 TrailCyclic(p PASS_LD);
465 TrailCyclic(from PASS_LD);
466 }
467 } else
468 { setVar(*to);
469 }
470 }
471 continue;
472 case TAG_COMPOUND:
473 { Functor ff = valueTerm(*from);
474
475 if ( aleft == 0 )
476 { setVar(*to);
477 continue;
478 } else
479 { if ( aleft != (size_t)-1 )
480 aleft--;
481 }
482
483 if ( isRef(ff->definition) )
484 { *to = consPtr(unRef(ff->definition), TAG_COMPOUND|STG_GLOBAL);
485 continue;
486 }
487
488 if ( ground(ff->definition) )
489 { *to = *from;
490 continue;
491 }
492
493 if ( shared(ff->definition) )
494 { int arity = arityFunctor(ff->definition);
495 Functor ft;
496
497 if ( !(ft = (Functor)allocGlobalNoShift(arity+1)) )
498 { rc = GLOBAL_OVERFLOW;
499 goto out;
500 }
501 ft->definition = ff->definition & ~BOTH_MASK;
502 ff->definition = makeRefG((Word)ft);
503 TrailCyclic(&ff->definition PASS_LD);
504 *to = consPtr(ft, TAG_COMPOUND|STG_GLOBAL);
505
506 if ( pushWorkAgendaLRD(&agenda, arity, ff->arguments, ft->arguments) )
507 continue;
508 rc = MEMORY_OVERFLOW;
509 goto out;
510 } else /* unshared term */
511 { int arity = arityFunctor(ff->definition);
512 Functor ft;
513
514 if ( !(ft = (Functor)allocGlobalNoShift(arity+1)) )
515 { rc = GLOBAL_OVERFLOW;
516 goto out;
517 }
518 ft->definition = ff->definition & ~BOTH_MASK;
519 *to = consPtr(ft, TAG_COMPOUND|STG_GLOBAL);
520
521 if ( pushWorkAgendaLRD(&agenda, arity, ff->arguments, ft->arguments) )
522 continue;
523 rc = MEMORY_OVERFLOW;
524 goto out;
525 }
526 }
527 case TAG_ATOM:
528 pushVolatileAtom(*from);
529 /*FALLTHROUGH*/
530 default:
531 *to = *from;
532 continue;
533 }
534 }
535
536 out:
537 clearTermAgendaLRD(&agenda);
538 return rc;
539 }
540
541
542 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
543 Both from and to point to locations on the global stack. From is
544 deferenced and to is a variable.
545 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
546
547 static int
do_copy_term(Word from,Word to,int abstract,int flags ARG_LD)548 do_copy_term(Word from, Word to, int abstract, int flags ARG_LD)
549 { int rc;
550
551 again:
552 switch(tag(*from))
553 { case TAG_VAR:
554 return TRUE;
555 case TAG_REFERENCE:
556 from = unRef(*from);
557 goto again;
558 case TAG_ATTVAR:
559 case TAG_COMPOUND:
560 break;
561 case TAG_ATOM:
562 pushVolatileAtom(*from);
563 /*FALLTHROUGH*/
564 default:
565 *to = *from;
566 return TRUE;
567 }
568
569 if ( (flags©_SHARE) )
570 { DEBUG(0, { mark_for_copy(from, flags PASS_LD);
571 cp_unmark(from, flags PASS_LD);
572 checkData(from);
573 });
574 mark_for_copy(from, flags PASS_LD);
575 } else if ( !(flags©_ABSTRACT) )
576 { mark_for_duplicate(from, flags PASS_LD);
577 }
578 initCyclicCopy(PASS_LD1);
579 rc = copy_term(from, to, abstract, flags PASS_LD);
580 exitCyclicCopy(flags PASS_LD);
581 cp_unmark(from, flags PASS_LD);
582 /*DEBUG(0, if ( rc == TRUE ) May lead to "Reference to higher address"
583 { checkData(from);
584 checkData(to);
585 });
586 */
587
588 return rc;
589 }
590
591
592 static int
copy_term_refs(term_t from,term_t to,size_t abstract,int flags ARG_LD)593 copy_term_refs(term_t from, term_t to, size_t abstract, int flags ARG_LD)
594 { for(;;)
595 { fid_t fid;
596 int rc;
597 Word dest, src;
598
599 if ( !(fid = PL_open_foreign_frame()) )
600 return FALSE; /* no space */
601
602 if ( !(dest = allocGlobal(1)) ) /* make a variable on the global */
603 { PL_close_foreign_frame(fid);
604 return FALSE; /* stack */
605 }
606 setVar(*dest);
607 *valTermRef(to) = makeRef(dest);
608 src = valTermRef(from);
609
610 rc = do_copy_term(src, dest, abstract, flags PASS_LD);
611
612 if ( rc < 0 ) /* no space for copy */
613 { PL_discard_foreign_frame(fid);
614 PL_put_variable(to); /* gc consistency */
615 if ( !makeMoreStackSpace(rc, ALLOW_SHIFT|ALLOW_GC) )
616 return FALSE;
617 } else
618 { PL_close_foreign_frame(fid);
619 DEBUG(CHK_SECURE,
620 { checkData(valTermRef(from));
621 checkData(valTermRef(to));
622 checkStacks(NULL);
623 });
624 return TRUE; /* if do_copy_term() == FALSE --> not-ground */
625 }
626 }
627 }
628
629
630 int
duplicate_term(term_t in,term_t copy ARG_LD)631 duplicate_term(term_t in, term_t copy ARG_LD)
632 { return copy_term_refs(in, copy, (size_t)-1, COPY_ATTRS PASS_LD);
633 }
634
635
636 int
size_abstract_term(term_t in,term_t copy,size_t abstract ARG_LD)637 size_abstract_term(term_t in, term_t copy, size_t abstract ARG_LD)
638 { return copy_term_refs(in, copy, abstract, COPY_ATTRS|COPY_ABSTRACT PASS_LD);
639 }
640
641
642 /*******************************
643 * FAST HEAP TERMS *
644 *******************************/
645
646 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
647 The code below copies a term to the heap (program space) just like
648 PL_record(). The representation is particularly suited for copying it
649 back to the stack really quickly: the memory can simply be copied to the
650 global stack, after which a quick series of relocations is performed.
651
652 This representations is particularly suited for re-activating
653 continuations as needed for tabling.
654 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
655
656 #define REL_END (~(unsigned int)0)
657
658 static int
needs_relocation(word w)659 needs_relocation(word w)
660 { return ( isTerm(w) || isRef(w) || isIndirect(w) || isAtom(w) );
661 }
662
663 #if SIZEOF_VOIDP == 8
664 #define PTR_SHIFT (LMASK_BITS+1)
665 #else
666 #define PTR_SHIFT LMASK_BITS
667 #endif
668
669 static word
relocate_down(word w,size_t offset)670 relocate_down(word w, size_t offset)
671 { if ( isAtom(w) )
672 { PL_register_atom(w);
673 return w;
674 } else
675 { return (((w>>PTR_SHIFT)-offset)<<PTR_SHIFT) | tagex(w);
676 }
677 }
678
679 static word
relocate_up(word w,size_t offset ARG_LD)680 relocate_up(word w, size_t offset ARG_LD)
681 { if ( isAtom(w) )
682 { pushVolatileAtom(w);
683 return w;
684 } else
685 { return (((w>>PTR_SHIFT)+offset)<<PTR_SHIFT) | tagex(w);
686 }
687 }
688
689
690 fastheap_term *
term_to_fastheap(term_t t ARG_LD)691 term_to_fastheap(term_t t ARG_LD)
692 { term_t copy = PL_new_term_ref();
693 Word gcopy, gtop, p, o;
694 size_t relocations=0;
695 fastheap_term *fht;
696 unsigned int *r;
697 size_t last_rel = 0;
698 size_t offset;
699 size_t indirect_cells = 0;
700 Word indirects;
701
702 if ( !duplicate_term(t, copy PASS_LD) )
703 return NULL;
704 gcopy = valTermRef(copy);
705 gtop = gTop;
706 deRef(gcopy); /* term at gcopy .. gTop */
707
708 for(p=gcopy; p<gtop; p++)
709 { if ( needs_relocation(*p) )
710 { if ( isIndirect(*p) )
711 { Word ip = addressIndirect(*p);
712 indirect_cells += wsizeofInd(*ip)+2;
713 }
714 relocations++;
715 }
716 }
717
718 if ( !(fht = malloc(sizeof(fastheap_term) +
719 ((char*)gtop-(char *)gcopy) +
720 indirect_cells * sizeof(word) +
721 (relocations+1) * sizeof(unsigned int))) )
722 { PL_resource_error("memory");
723 return NULL;
724 }
725
726 fht->data_len = (gtop-gcopy) + indirect_cells;
727 fht->data = addPointer(fht, sizeof(fastheap_term));
728 fht->relocations = addPointer(fht->data, fht->data_len*sizeof(word));
729 indirects = fht->data + (gtop-gcopy);
730
731 offset = gcopy-gBase;
732 for(p=gcopy, o=fht->data, r=fht->relocations; p<gtop; p++)
733 { if ( needs_relocation(*p) )
734 { size_t this_rel = p-gcopy;
735
736 if ( isIndirect(*p) )
737 { Word ip = addressIndirect(*p);
738 size_t sz = wsizeofInd(*ip)+2;
739 size_t go = gBase - (Word)base_addresses[STG_GLOBAL];
740
741 memcpy(indirects, ip, sz*sizeof(word));
742 *o++ = ((go+indirects-fht->data)<<PTR_SHIFT) | tagex(*p);
743 indirects += sz;
744 } else
745 { *o++ = relocate_down(*p, offset);
746 }
747 *r++ = this_rel-last_rel;
748 last_rel = this_rel;
749 } else
750 { *o++ = *p;
751 }
752 }
753 *r++ = REL_END;
754
755 return fht;
756 }
757
758
759 void
free_fastheap(fastheap_term * fht)760 free_fastheap(fastheap_term *fht)
761 { unsigned int *r;
762 Word p = fht->data;
763
764 for(r = fht->relocations; *r != REL_END; r++)
765 { p += *r;
766 if ( isAtom(*p) )
767 PL_unregister_atom(*p);
768 }
769
770 free(fht);
771 }
772
773
774 int
put_fastheap(fastheap_term * fht,term_t t ARG_LD)775 put_fastheap(fastheap_term *fht, term_t t ARG_LD)
776 { Word p, o;
777 size_t offset;
778 unsigned int *r;
779
780 if ( !hasGlobalSpace(fht->data_len) )
781 { int rc;
782
783 if ( (rc=ensureGlobalSpace(fht->data_len, ALLOW_GC|ALLOW_SHIFT)) != TRUE )
784 return raiseStackOverflow(rc);
785 }
786
787 o = gTop;
788 memcpy(o, fht->data, fht->data_len*sizeof(word));
789
790 offset = o-gBase;
791 for(r = fht->relocations, p=o; *r != REL_END; r++)
792 { p += *r;
793 *p = relocate_up(*p, offset PASS_LD);
794 }
795
796 gTop += fht->data_len;
797 *valTermRef(t) = makeRefG(o);
798
799 return TRUE;
800 }
801
802
803 /*******************************
804 * PROLOG BINDING *
805 *******************************/
806
807 static
808 PRED_IMPL("copy_term", 2, copy_term, 0)
809 { PRED_LD
810
811 if ( PL_is_atomic(A1) )
812 { return PL_unify(A1, A2);
813 } else
814 { term_t copy = PL_new_term_ref();
815
816 if ( copy_term_refs(A1, copy, (size_t)-1, COPY_SHARE|COPY_ATTRS PASS_LD) )
817 return PL_unify(copy, A2);
818
819 fail;
820 }
821 }
822
823
824 static
825 PRED_IMPL("duplicate_term", 2, duplicate_term, 0)
826 { PRED_LD
827
828 if ( PL_is_atomic(A1) )
829 { return PL_unify(A1, A2);
830 } else
831 { term_t copy = PL_new_term_ref();
832
833 if ( duplicate_term(A1, copy PASS_LD) )
834 return PL_unify(copy, A2);
835
836 fail;
837 }
838 }
839
840
841 static
842 PRED_IMPL("copy_term_nat", 2, copy_term_nat, 0)
843 { PRED_LD
844 term_t copy = PL_new_term_ref();
845
846 if ( copy_term_refs(A1, copy, (size_t)-1, COPY_SHARE PASS_LD) )
847 return PL_unify(copy, A2);
848
849 fail;
850 }
851
852
853 static
854 PRED_IMPL("size_abstract_term", 3, size_abstract_term, 0)
855 { PRED_LD
856 size_t abstract;
857
858 if ( PL_get_size_ex(A1, &abstract) )
859 { term_t copy = PL_new_term_ref();
860
861 if ( size_abstract_term(A2, copy, abstract PASS_LD) )
862 return PL_unify(copy, A3);
863 }
864
865 return FALSE;
866 }
867
868 /*******************************
869 * PUBLISH PREDICATES *
870 *******************************/
871
872 BeginPredDefs(copyterm)
873 PRED_DEF("copy_term", 2, copy_term, PL_FA_ISO)
874 PRED_DEF("duplicate_term", 2, duplicate_term, 0)
875 PRED_DEF("copy_term_nat", 2, copy_term_nat, 0)
876 PRED_DEF("size_abstract_term", 3, size_abstract_term, 0)
877 EndPredDefs
878