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) 1985-2020, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 #include "pl-incl.h"
38 #include "os/pl-cstack.h"
39 #include "pl-dict.h"
40 #include <math.h>
41 #ifdef HAVE_SYS_MMAN_H
42 #define MMAP_STACK 1
43 #include <sys/mman.h>
44 #include <unistd.h>
45 #ifndef MAP_ANONYMOUS
46 #ifdef MAP_ANON
47 #define MAP_ANONYMOUS MAP_ANON
48 #else
49 #define MAP_ANONYMOUS 0
50 #endif
51 #endif
52 #endif
53
54 #undef LD
55 #define LD LOCAL_LD
56
57 #if ALLOC_DEBUG
58 #define ALLOC_FREE_MAGIC 0xFB
59 #define ALLOC_NEW_MAGIC 0xF9
60 #endif
61
62
63 /*******************************
64 * USE BOEHM GC *
65 *******************************/
66
67 #if !defined(PL_ALLOC_DONE) && defined(HAVE_BOEHM_GC)
68 #define PL_ALLOC_DONE 1
69 #undef HAVE_MTRACE
70
71 void *
allocHeap(size_t n)72 allocHeap(size_t n)
73 { void *mem = GC_MALLOC(n);
74
75 #if ALLOC_DEBUG
76 if ( mem )
77 memset(mem, ALLOC_NEW_MAGIC, n);
78 #endif
79
80 return mem;
81 }
82
83
84 void *
allocHeapOrHalt(size_t n)85 allocHeapOrHalt(size_t n)
86 { void *mem = allocHeap(n);
87
88 if ( !mem )
89 outOfCore();
90
91 return mem;
92 }
93
94
95 void
freeHeap(void * mem,size_t n)96 freeHeap(void *mem, size_t n)
97 {
98 #if ALLOC_DEBUG
99 if ( mem )
100 memset(mem, ALLOC_FREE_MAGIC, n);
101 #endif
102
103 GC_FREE(mem);
104 }
105
106
107 #ifdef GC_DEBUG
108 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
109 To debug the interaction between Boehm-GC and Prolog, we run the
110 collector in leak-detection mode. Reported leaks can have three causes:
111
112 - They are real leaks. We would like to fix these, at least for the
113 non-GC version.
114 - They are caused by lacking traceable pointers. This must be fixed
115 to run reliably under Boehm-GC.
116 - The are place that can currently not be safely removed. We call
117 GC_LINGER() on such pointers. These will be left to GC, but in
118 leak-detection mode we give them a reference to silence the leak
119 detector.
120
121 GC_linger() is called to keep track of objects we would like to leave to
122 GC because we are not sure they can be reclaimed safely now. We use this
123 as a debugging aid if GC_DEBUG is enabled.
124 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
125
126 typedef struct linger
127 { struct linger *next;
128 void *object;
129 } linger;
130
131 linger *GC_lingering = NULL;
132
133 void
GC_linger(void * ptr)134 GC_linger(void *ptr)
135 { linger *l = GC_MALLOC_UNCOLLECTABLE(sizeof(*l));
136
137 l->object = ptr;
138 PL_LOCK(L_ALLOC);
139 l->next = GC_lingering;
140 GC_lingering = l->next;
141 PL_UNLOCK(L_ALLOC);
142 }
143
144 #endif /*GC_DEBUG*/
145 #endif /*HAVE_BOEHM_GC*/
146
147
148 /*******************************
149 * USE PLAIN SYSTEM MALLOC *
150 *******************************/
151
152 #ifndef PL_ALLOC_DONE
153 #if defined(HAVE_MTRACE) && defined(O_MAINTENANCE)
154 #include <mcheck.h>
155 #endif
156
157 void *
allocHeap(size_t n)158 allocHeap(size_t n)
159 { void *mem = malloc(n);
160
161 #if ALLOC_DEBUG
162 if ( mem )
163 memset((char *) mem, ALLOC_NEW_MAGIC, n);
164 #endif
165
166 return mem;
167 }
168
169
170 void *
allocHeapOrHalt(size_t n)171 allocHeapOrHalt(size_t n)
172 { if ( n )
173 { void *mem = allocHeap(n);
174
175 if ( !mem )
176 outOfCore();
177
178 return mem;
179 }
180
181 return NULL;
182 }
183
184
185 void
freeHeap(void * mem,size_t n)186 freeHeap(void *mem, size_t n)
187 {
188 #if ALLOC_DEBUG
189 memset((char *) mem, ALLOC_FREE_MAGIC, n);
190 #else
191 (void)n;
192 #endif
193
194 free(mem);
195 }
196
197 #endif /*PL_ALLOC_DONE*/
198
199
200 /*******************************
201 * LINGERING OBJECTS *
202 *******************************/
203
204 void
linger(linger_list ** list,void (* unalloc)(void *),void * object)205 linger(linger_list** list, void (*unalloc)(void *), void *object)
206 { linger_list *c = allocHeapOrHalt(sizeof(*c));
207 linger_list *o;
208
209 c->generation = global_generation();
210 c->object = object;
211 c->unalloc = unalloc;
212
213 do
214 { o = *list;
215 c->next = o;
216 } while( !COMPARE_AND_SWAP_PTR(list, o, c) );
217 }
218
219 void
free_lingering(linger_list ** list,gen_t generation)220 free_lingering(linger_list **list, gen_t generation)
221 { linger_list **p = list;
222 linger_list *c = *list;
223
224 while ( c )
225 { if ( c->generation < generation )
226 { while ( !COMPARE_AND_SWAP_PTR(p, c, c->next) )
227 { p = &(*p)->next;
228 }
229 (*c->unalloc)(c->object);
230 freeHeap(c, sizeof(*c));
231 } else
232 { p = &(*p)->next;
233 }
234 c = *p;
235 }
236 }
237
238 /********************************
239 * STACKS *
240 *********************************/
241
242 int
enableSpareStack(Stack s,int always)243 enableSpareStack(Stack s, int always)
244 { if ( s->spare && (roomStackP(s) < s->def_spare || always) )
245 { DEBUG(MSG_SPARE_STACK,
246 Sdprintf("Enabling spare on %s: %zd bytes\n", s->name, s->spare));
247 s->max = addPointer(s->max, s->spare);
248 s->spare = 0;
249 return TRUE;
250 }
251
252 return FALSE;
253 }
254
255
256 void
enableSpareStacks(void)257 enableSpareStacks(void)
258 { GET_LD
259
260 enableSpareStack((Stack)&LD->stacks.local, FALSE);
261 enableSpareStack((Stack)&LD->stacks.global, FALSE);
262 enableSpareStack((Stack)&LD->stacks.trail, FALSE);
263 }
264
265
266 static intptr_t
env_frames(LocalFrame fr)267 env_frames(LocalFrame fr)
268 { intptr_t count = 0;
269
270 while(fr)
271 { count++;
272 fr = parentFrame(fr);
273 }
274
275 return count;
276 }
277
278
279 static intptr_t
choice_points(Choice chp)280 choice_points(Choice chp)
281 { GET_LD
282
283 intptr_t count = 0;
284 QueryFrame qfr = LD->query;
285
286 while( chp )
287 { count++;
288
289 if ( chp->parent )
290 { chp = chp->parent;
291 } else if ( qfr )
292 { assert(qfr->magic == QID_MAGIC);
293 chp = qfr->saved_bfr;
294 qfr = qfr->parent;
295 }
296 }
297
298 return count;
299 }
300
301
302 #define MAX_CYCLE 20
303 #define CYCLE_CTX 1
304 #define MAX_PRE_LOOP 20
305 #define MIN_REPEAT 100
306
307 typedef struct cycle_entry
308 { LocalFrame frame;
309 } cycle_entry;
310
311 static int
is_variant_frame(LocalFrame fr1,LocalFrame fr2 ARG_LD)312 is_variant_frame(LocalFrame fr1, LocalFrame fr2 ARG_LD)
313 { if ( fr1->predicate == fr2->predicate )
314 { size_t arity = fr1->predicate->functor->arity;
315 size_t i;
316
317 for(i=0; i<arity; i++)
318 { if ( !is_variant_ptr(argFrameP(fr1, i), argFrameP(fr2, i) PASS_LD) )
319 return FALSE;
320 }
321
322 return TRUE;
323 }
324
325 return FALSE;
326 }
327
328
329 static int
non_terminating_recursion(LocalFrame fr0,cycle_entry ce[MAX_CYCLE],int * is_cycle ARG_LD)330 non_terminating_recursion(LocalFrame fr0,
331 cycle_entry ce[MAX_CYCLE],
332 int *is_cycle
333 ARG_LD)
334 { int depth, mindepth = 1, repeat;
335 LocalFrame fr, ctx;
336
337 ce[0].frame = fr0;
338
339 again:
340 for( fr=parentFrame(fr0), depth=1;
341 fr && depth<MAX_CYCLE;
342 depth++, fr = parentFrame(fr) )
343 { if ( fr->predicate == fr0->predicate && depth >= mindepth )
344 break;
345 ce[depth].frame = fr;
346 }
347
348 if ( !fr || depth >= MAX_CYCLE )
349 return 0;
350
351 *is_cycle = is_variant_frame(fr0, fr PASS_LD);
352 ctx = fr;
353
354 for(repeat=MIN_REPEAT; fr && --repeat > 0; )
355 { int i;
356
357 for(i=0; fr && i<depth; i++, fr = parentFrame(fr))
358 { if ( fr->predicate != ce[i].frame->predicate )
359 { mindepth = depth+1;
360 if ( mindepth > MAX_CYCLE )
361 return 0;
362 // Sdprintf("Cycle not repeated at %d\n", i);
363 goto again;
364 }
365 }
366 }
367
368 if ( repeat == 0 )
369 { int nctx = CYCLE_CTX;
370
371 for(fr=ctx; fr && nctx-- > 0; fr = parentFrame(fr))
372 ce[depth++].frame = fr;
373
374 return depth;
375 }
376
377 return 0;
378 }
379
380 static int
find_non_terminating_recursion(LocalFrame fr,cycle_entry ce[MAX_CYCLE],int * is_cycle ARG_LD)381 find_non_terminating_recursion(LocalFrame fr, cycle_entry ce[MAX_CYCLE],
382 int *is_cycle ARG_LD)
383 { int max_pre_loop = MAX_PRE_LOOP;
384
385 for(; fr && max_pre_loop; fr = parentFrame(fr), max_pre_loop--)
386 { int len;
387
388 if ( (len=non_terminating_recursion(fr, ce, is_cycle PASS_LD)) )
389 return len;
390 }
391
392 return 0;
393 }
394
395
396 static int
top_of_stack(LocalFrame fr,cycle_entry ce[MAX_CYCLE],int maxdepth ARG_LD)397 top_of_stack(LocalFrame fr, cycle_entry ce[MAX_CYCLE], int maxdepth ARG_LD)
398 { int depth;
399
400 for(depth = 0; fr && depth < maxdepth; fr = parentFrame(fr), depth++)
401 { ce[depth].frame = fr;
402 }
403
404 return depth;
405 }
406
407
408
409 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
410 Push a goal to the stack. This code uses low-level primitives to avoid
411 stack shifts. The goal is a term `Module:Head`, where each Head argument
412 is a primitive (var, atom, number, string), a term `[Length]` for a list
413 of length Length, a term `[cyclic_term]` if the list is cyclic otherwise
414 a term `Name/Arity` to indicate the principal functor.
415
416 Returns `0` if there is no enough space to store this term.
417 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
418
419 static size_t
size_frame_term(LocalFrame fr)420 size_frame_term(LocalFrame fr)
421 { GET_LD
422 size_t arity = fr->predicate->functor->arity;
423 size_t size = 4 + 3 + arity+1;
424 size_t i;
425
426 for(i=0; i<arity; i++)
427 { Word p = argFrameP(fr, i);
428 deRef(p);
429
430 if ( isTerm(*p) )
431 size += 3; /* one of f/n, [Len] or [c] */
432 }
433
434 return size;
435 }
436
437
438 static word
push_goal(LocalFrame fr)439 push_goal(LocalFrame fr)
440 { GET_LD
441 size_t arity = fr->predicate->functor->arity;
442 size_t i;
443 Word p = gTop;
444 word r = consPtr(p, STG_GLOBAL|TAG_COMPOUND);
445
446 p[0] = FUNCTOR_frame3;
447 p[1] = consInt(fr->level);
448 p[2] = consPtr(&p[4], STG_GLOBAL|TAG_COMPOUND);
449 p[3] = ATOM_nil; /* reserved */
450 p += 4;
451
452 p[0] = FUNCTOR_colon2;
453 p[1] = fr->predicate->module->name;
454 if ( arity > 0 )
455 { Word ad; /* argument descriptions */
456
457 p[2] = consPtr(&p[3], STG_GLOBAL|TAG_COMPOUND);
458 p += 3;
459 p[0] = fr->predicate->functor->functor;
460 p++;
461 ad = p+arity;
462 for(i=0; i<arity; i++)
463 { Word a = argFrameP(fr, i);
464
465 deRef(a);
466 if ( isTerm(*a) )
467 { *p++ = consPtr(ad, STG_GLOBAL|TAG_COMPOUND);
468
469 if ( isList(*a) )
470 { Word tail;
471 intptr_t len = skip_list(a, &tail PASS_LD);
472
473 *ad++ = FUNCTOR_dot2;
474 deRef(tail);
475 if ( isList(*tail) )
476 { *ad++ = ATOM_cyclic_term;
477 *ad++ = ATOM_nil;
478 } else
479 { *ad++ = consInt(len);
480 if ( isTerm(*tail) )
481 *ad++ = ATOM_compound;
482 else
483 *ad++ = *tail;
484 }
485 } else
486 { FunctorDef f = valueFunctor(functorTerm(*a));
487
488 *ad++ = FUNCTOR_divide2;
489 *ad++ = f->name;
490 *ad++ = consInt(f->arity);
491 }
492 } else
493 { *p++ = *a;
494 }
495 }
496 gTop = ad;
497 } else
498 { p[2] = fr->predicate->functor->name;
499 gTop = &p[3];
500 }
501
502 return r;
503 }
504
505
506 static word
push_cycle(cycle_entry ce[MAX_CYCLE],int depth)507 push_cycle(cycle_entry ce[MAX_CYCLE], int depth)
508 { GET_LD
509 size_t size = depth*3;
510 int i;
511
512 for(i=0; i<depth; i++)
513 { size += size_frame_term(ce[i].frame);
514 }
515
516 if ( gTop+size < gMax )
517 { Word p = gTop;
518 word r = consPtr(p, STG_GLOBAL|TAG_COMPOUND);
519
520 gTop = p+depth*3;
521 for(i=0; i<depth; i++, p+=3)
522 { p[0] = FUNCTOR_dot2;
523 p[1] = push_goal(ce[i].frame);
524 if ( i+1 < depth )
525 p[2] = consPtr(&p[3], STG_GLOBAL|TAG_COMPOUND);
526 else
527 p[2] = ATOM_nil;
528 }
529
530 return r;
531 } else
532 return 0;
533 }
534
535
536 static void
push_stack(cycle_entry ce[MAX_CYCLE],int depth,atom_t name,Word * pp ARG_LD)537 push_stack(cycle_entry ce[MAX_CYCLE], int depth, atom_t name, Word *pp ARG_LD)
538 { word w;
539 Word p = *pp;
540
541 gTop = p+2;
542 if ( (w=push_cycle(ce, depth)) )
543 { *p++ = w;
544 *p++ = name;
545 } else
546 { gTop = p;
547 }
548
549 *pp = p;
550 }
551
552
553
554 static word
push_overflow_context(Stack stack,int extra)555 push_overflow_context(Stack stack, int extra)
556 { GET_LD
557 int keys = 7;
558
559 if ( gTop+2*keys+extra < gMax )
560 { Word p = gTop;
561 Word dict = p;
562 cycle_entry ce[MAX_CYCLE+CYCLE_CTX];
563 int depth;
564
565 *p++ = dict_functor(1);
566 *p++ = ATOM_stack_overflow; /* dict tag */
567 *p++ = consInt(LD->stacks.limit/1024);
568 *p++ = ATOM_stack_limit; /* overflow */
569 *p++ = consInt(usedStack(local)/1024); /* K-bytes to avoid small int */
570 *p++ = ATOM_localused;
571 *p++ = consInt(usedStack(global)/1024);
572 *p++ = ATOM_globalused;
573 *p++ = consInt(usedStack(trail)/1024);
574 *p++ = ATOM_trailused;
575 if ( environment_frame )
576 { *p++ = consUInt(environment_frame->level);
577 *p++ = ATOM_depth;
578 }
579 *p++ = consInt(env_frames(environment_frame));
580 *p++ = ATOM_environments;
581 *p++ = consInt(choice_points(BFR));
582 *p++ = ATOM_choicepoints;
583 gTop = p;
584
585 if ( roomStack(local) < LD->stacks.local.def_spare + LOCAL_MARGIN )
586 { int is_cycle;
587
588 if ( (depth=find_non_terminating_recursion(environment_frame, ce,
589 &is_cycle PASS_LD)) )
590 { push_stack(ce, depth, is_cycle ? ATOM_cycle : ATOM_non_terminating,
591 &p PASS_LD);
592 } else if ( (depth=top_of_stack(environment_frame, ce, 5 PASS_LD)) )
593 { push_stack(ce, depth, ATOM_stack, &p PASS_LD);
594 }
595 } else if ( (depth=top_of_stack(environment_frame, ce, 5 PASS_LD)) )
596 { push_stack(ce, depth, ATOM_stack, &p PASS_LD);
597 }
598
599 *dict = dict_functor((p-dict-2)/2); /* final functor */
600
601 dict_order(dict, FALSE PASS_LD);
602
603 return consPtr(dict, STG_GLOBAL|TAG_COMPOUND);
604 } else
605 return PL_new_atom(stack->name); /* The stack names are built-in atoms */
606 }
607
608
609 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
610 (*) outOfStack(stack, how) is called to raise a stack overflow
611 exception. This can happen from two placed: the VM and foreign code.
612 When the error is thrown from the VM, we have to be careful because the
613 state of the VM is unknown. Notably, we might be in `body write' mode,
614 which implies we are writing terms to the local stack above lTop. For
615 this reason, we cannot use PL_open_foreign_frame(). So, we build the
616 error term using low-level primitives that only touch the global stack
617 with a few cells and also avoid the term duplication of
618 PL_raise_exception().
619
620 FIXME: We could consider reserving some space on the global stack for
621 resource exceptions near the bottom. That would also avoid the need to
622 freeze the global stack. One problem is that the user migh keep a
623 reference to this reserved exception term, which makes it impossible to
624 reuse.
625
626 Out of stack exception context:
627 - Stack sizes (Local, Global, Trail)
628 - Goal stack depth
629 - Ratio choice points/stack frames?
630 - Is there unbound recursion?
631 - Ratio global data reachable through environments and
632 choice points (requires running GC)
633 - Global storage only reachable through choice points
634 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
635
636 int
outOfStack(void * stack,stack_overflow_action how)637 outOfStack(void *stack, stack_overflow_action how)
638 { GET_LD
639 Stack s = stack;
640 const char *msg = "out-of-stack";
641
642 if ( LD->outofstack == stack )
643 { Sdprintf("[Thread %d]: failed to recover from %s-overflow\n",
644 PL_thread_self(), s->name);
645 print_backtrace_named(msg);
646 save_backtrace("crash");
647 print_backtrace_named("crash");
648 fatalError("Sorry, cannot continue");
649
650 return FALSE; /* NOTREACHED */
651 }
652
653 save_backtrace(msg);
654
655 if ( s->spare < s->def_spare/4 )
656 { Sdprintf("[Thread %d]: %s-overflow: spare=%ld (def=%ld)\n"
657 "Last resource exception:\n",
658 PL_thread_self(), s->name, (long)s->spare, (long)s->def_spare);
659 print_backtrace_named(msg);
660 }
661
662 enableSpareStacks();
663 LD->trim_stack_requested = TRUE;
664 LD->exception.processing = TRUE;
665 LD->outofstack = stack;
666
667 switch(how)
668 { case STACK_OVERFLOW_THROW:
669 case STACK_OVERFLOW_RAISE:
670 { word ctx = push_overflow_context(s, 6);
671
672 if ( gTop+5 < gMax )
673 { Word p = gTop;
674
675 p[0] = FUNCTOR_error2; /* see (*) above */
676 p[1] = consPtr(&p[3], TAG_COMPOUND|STG_GLOBAL);
677 p[2] = ctx;
678 p[3] = FUNCTOR_resource_error1;
679 p[4] = ATOM_stack;
680 gTop += 5;
681
682 *valTermRef(LD->exception.bin) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
683 freezeGlobal(PASS_LD1);
684 } else
685 { Sdprintf("ERROR: Out of global-stack.\n"
686 "ERROR: No room for exception term. Aborting.\n");
687 *valTermRef(LD->exception.bin) = ATOM_aborted;
688 }
689 exception_term = exception_bin;
690
691 if ( how == STACK_OVERFLOW_THROW &&
692 LD->exception.throw_environment )
693 { /* see PL_throw() */
694 longjmp(LD->exception.throw_environment->exception_jmp_env, 1);
695 }
696
697 return FALSE;
698 }
699 default:
700 assert(0);
701 fail;
702 }
703 }
704
705
706 int
raiseStackOverflow(int overflow)707 raiseStackOverflow(int overflow)
708 { GET_LD
709 Stack s;
710
711 switch(overflow)
712 { case LOCAL_OVERFLOW: s = (Stack)&LD->stacks.local; break;
713 case GLOBAL_OVERFLOW: s = (Stack)&LD->stacks.global; break;
714 case TRAIL_OVERFLOW: s = (Stack)&LD->stacks.trail; break;
715 case STACK_OVERFLOW: s = &GD->combined_stack; break;
716 case ARGUMENT_OVERFLOW: s = (Stack)&LD->stacks.argument; break;
717 case MEMORY_OVERFLOW:
718 return PL_error(NULL, 0, NULL, ERR_NOMEM);
719 case FALSE: /* some other error is pending */
720 return FALSE;
721 default:
722 s = NULL;
723 assert(0);
724 }
725
726 return outOfStack(s, STACK_OVERFLOW_RAISE);
727 }
728
729
730 void
pushArgumentStack__LD(Word p ARG_LD)731 pushArgumentStack__LD(Word p ARG_LD)
732 { Word *newbase;
733 size_t newsize = nextStackSize((Stack)&LD->stacks.argument, 1);
734
735 if ( newsize &&
736 (newsize = stack_nalloc(newsize)) &&
737 (newbase = stack_realloc(aBase, newsize)) )
738 { intptr_t as = newbase - aBase;
739
740 if ( as )
741 { QueryFrame qf;
742
743 aTop += as;
744 aBase = newbase;
745
746 for(qf=LD->query; qf; qf = qf->parent)
747 qf->aSave += as;
748 }
749 aMax = addPointer(newbase, newsize);
750 *aTop++ = p;
751 } else
752 outOfStack((Stack)&LD->stacks.argument, STACK_OVERFLOW_THROW);
753 }
754
755
756 void
outOfCore(void)757 outOfCore(void)
758 { fatalError("Could not allocate memory: %s", OsError());
759 }
760
761
762 /********************************
763 * GLOBAL STACK *
764 *********************************/
765
766 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
767 allocGlobal() allocates on the global stack. Many functions do this
768 inline as it is simple and usualy very time critical.
769 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
770
771 Word
allocGlobal__LD(size_t n ARG_LD)772 allocGlobal__LD(size_t n ARG_LD)
773 { Word result;
774
775 if ( !hasGlobalSpace(n) )
776 { int rc;
777
778 if ( (rc=ensureGlobalSpace(n, ALLOW_GC)) != TRUE )
779 { raiseStackOverflow(rc);
780 return NULL;
781 }
782 }
783
784 result = gTop;
785 gTop += n;
786
787 return result;
788 }
789
790 Word
allocGlobalNoShift__LD(size_t n ARG_LD)791 allocGlobalNoShift__LD(size_t n ARG_LD)
792 { Word result;
793
794 if ( gTop+n > gMax )
795 return NULL;
796
797 result = gTop;
798 gTop += n;
799
800 return result;
801 }
802
803
804 Word
newTerm(void)805 newTerm(void)
806 { GET_LD
807 Word t = allocGlobal(1);
808
809 setVar(*t);
810
811 return t;
812 }
813
814 /*******************************
815 * OPERATIONS ON INTEGERS *
816 *******************************/
817
818 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
819 Translate a 64-bit integer into a Prolog cell. Uses tagged
820 representation if possible or allocates 64-bits on the global stack.
821
822 Return is one of:
823
824 TRUE: Success
825 FALSE: Interrupt
826 GLOBAL_OVERFLOW: Stack overflow
827 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
828
829 int
put_int64(Word at,int64_t l,int flags ARG_LD)830 put_int64(Word at, int64_t l, int flags ARG_LD)
831 { Word p;
832 word r, m;
833 int req;
834
835 r = consInt(l);
836 if ( valInt(r) == l )
837 { *at = r;
838 return TRUE;
839 }
840
841 #if SIZEOF_VOIDP == 8
842 req = 3;
843 #elif SIZEOF_VOIDP == 4
844 req = 4;
845 #else
846 #error "FIXME: Unsupported sizeof word"
847 #endif
848
849 if ( !hasGlobalSpace(req) )
850 { int rc = ensureGlobalSpace(req, flags);
851
852 if ( rc != TRUE )
853 return rc;
854 }
855 p = gTop;
856 gTop += req;
857
858 #if SIZEOF_VOIDP == 8
859 r = consPtr(p, TAG_INTEGER|STG_GLOBAL);
860 m = mkIndHdr(1, TAG_INTEGER);
861
862 *p++ = m;
863 *p++ = l;
864 *p = m;
865 #else
866 #if SIZEOF_VOIDP == 4
867 r = consPtr(p, TAG_INTEGER|STG_GLOBAL);
868 m = mkIndHdr(2, TAG_INTEGER);
869
870 *p++ = m;
871 #ifdef WORDS_BIGENDIAN
872 *p++ = (word)(l>>32);
873 *p++ = (word)l;
874 #else
875 *p++ = (word)l;
876 *p++ = (word)(l>>32);
877 #endif
878 *p = m;
879 #else
880 #error "FIXME: Unsupported sizeof intptr_t."
881 #endif
882 #endif
883
884 *at = r;
885 return TRUE;
886 }
887
888
889 /*******************************
890 * OPERATIONS ON STRINGS *
891 *******************************/
892
893 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
894 To distinguish between byte and wide strings, the system adds a 'B' or
895 'W' in front of the real string. For a 'W', the following 3 bytes are
896 ignored to avoid alignment restriction problems.
897
898 Note that these functions can trigger GC
899 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
900
901 Word
allocString(size_t len ARG_LD)902 allocString(size_t len ARG_LD)
903 { size_t lw = (len+sizeof(word))/sizeof(word);
904 int pad = (int)(lw*sizeof(word) - len);
905 Word p = allocGlobal(2 + lw);
906 word m = mkStrHdr(lw, pad);
907
908 if ( !p )
909 return NULL;
910
911 p[0] = m;
912 p[lw] = 0L; /* zero the pad bytes */
913 p[lw+1] = m;
914
915 return p;
916 }
917
918
919 word
globalString(size_t len,const char * s)920 globalString(size_t len, const char *s)
921 { GET_LD
922 Word p = allocString(len+1 PASS_LD);
923
924 if ( p )
925 { char *q = (char *)&p[1];
926
927 *q++ = 'B';
928 memcpy(q, s, len);
929
930 return consPtr(p, TAG_STRING|STG_GLOBAL);
931 }
932
933 return 0;
934 }
935
936
937 word
globalWString(size_t len,const pl_wchar_t * s)938 globalWString(size_t len, const pl_wchar_t *s)
939 { GET_LD
940 const pl_wchar_t *e = &s[len];
941 const pl_wchar_t *p;
942 Word g;
943
944 for(p=s; p<e; p++)
945 { if ( *p > 0xff )
946 break;
947 }
948
949 if ( p == e ) /* 8-bit string */
950 { unsigned char *t;
951
952 if ( !(g = allocString(len+1 PASS_LD)) )
953 return 0;
954 t = (unsigned char *)&g[1];
955 *t++ = 'B';
956 for(p=s; p<e; )
957 *t++ = (unsigned char)(*p++ & 0xff);
958 } else /* wide string */
959 { char *t;
960 pl_wchar_t *w;
961
962 if ( !(g = allocString((len+1)*sizeof(pl_wchar_t) PASS_LD)) )
963 return 0;
964 t = (char *)&g[1];
965 w = (pl_wchar_t*)t;
966 w[0] = 0;
967 *t = 'W';
968 memcpy(&w[1], s, len*sizeof(pl_wchar_t));
969 }
970
971 return consPtr(g, TAG_STRING|STG_GLOBAL);
972 }
973
974
975 char *
getCharsString__LD(word w,size_t * len ARG_LD)976 getCharsString__LD(word w, size_t *len ARG_LD)
977 { Word p = valPtr(w);
978 word m = *p;
979 size_t wn = wsizeofInd(m);
980 size_t pad = padHdr(m);
981 char *s;
982
983 if ( len )
984 *len = wn*sizeof(word) - pad - 1; /* -1 for the 'B' */
985
986 s = (char *)&p[1];
987
988 if ( *s == 'B' )
989 return s+1;
990
991 assert(*s == 'W');
992 return NULL;
993 }
994
995
996 pl_wchar_t *
getCharsWString__LD(word w,size_t * len ARG_LD)997 getCharsWString__LD(word w, size_t *len ARG_LD)
998 { Word p = valPtr(w);
999 word m = *p;
1000 size_t wn = wsizeofInd(m);
1001 size_t pad = padHdr(m);
1002 char *s;
1003 pl_wchar_t *ws;
1004
1005 s = (char *)&p[1];
1006 if ( *s != 'W' )
1007 return NULL;
1008
1009 if ( len )
1010 *len = ((wn*sizeof(word) - pad)/sizeof(pl_wchar_t)) - 1;
1011
1012 ws = (pl_wchar_t *)&p[1];
1013 return ws+1;
1014 }
1015
1016
1017
1018 /*******************************
1019 * OPERATIONS ON DOUBLES *
1020 *******************************/
1021
1022 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1023 Storage of floats (doubles) on the stacks and heap. Such values are
1024 packed into two `guards words'. We cannot just copy the double as it
1025 might not be properly aligned.
1026 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1027
1028 int
put_double(Word at,double d,int flags ARG_LD)1029 put_double(Word at, double d, int flags ARG_LD)
1030 { Word p;
1031 word m = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
1032
1033 if ( flags != ALLOW_CHECKED && !hasGlobalSpace(2+WORDS_PER_DOUBLE) )
1034 { int rc = ensureGlobalSpace(2+WORDS_PER_DOUBLE, flags);
1035
1036 if ( rc != TRUE )
1037 return rc;
1038 }
1039 p = gTop;
1040 gTop += 2+WORDS_PER_DOUBLE;
1041
1042 *at = consPtr(p, TAG_FLOAT|STG_GLOBAL);
1043
1044 if ( isnan(d) )
1045 d = PL_nan(); /* SWI-Prolog canonical 1.5NaN */
1046
1047 *p++ = m;
1048 memcpy(p, &d, sizeof(d));
1049 p += WORDS_PER_DOUBLE;
1050 *p = m;
1051
1052 return TRUE;
1053 }
1054
1055
1056 /*******************************
1057 * 64-BIT INTEGERS *
1058 *******************************/
1059
1060 #if ALIGNOF_INT64_T != ALIGNOF_VOIDP
1061
1062 int64_t /* take care of alignment! */
valBignum__LD(word w ARG_LD)1063 valBignum__LD(word w ARG_LD)
1064 { Word p = valIndirectP(w);
1065 union
1066 { int64_t i;
1067 word w[WORDS_PER_INT64];
1068 } val;
1069
1070 #if ( SIZEOF_VOIDP == 4 )
1071 val.w[0] = p[0];
1072 val.w[1] = p[1];
1073 #else
1074 #error "Unsupported int64_t alignment conversion"
1075 #endif
1076
1077 return val.i;
1078 }
1079
1080 #endif
1081
1082 /*******************************
1083 * GENERIC INDIRECT OPERATIONS *
1084 *******************************/
1085
1086 int
equalIndirect(word w1,word w2)1087 equalIndirect(word w1, word w2)
1088 { GET_LD
1089 Word p1 = addressIndirect(w1);
1090 Word p2 = addressIndirect(w2);
1091
1092 if ( *p1 == *p2 )
1093 { size_t n = wsizeofInd(*p1);
1094
1095 while( n-- > 0 )
1096 { if ( *++p1 != *++p2 )
1097 fail;
1098 }
1099
1100 succeed;
1101 }
1102
1103 fail;
1104 }
1105
1106
1107 size_t /* size in cells */
gsizeIndirectFromCode(Code pc)1108 gsizeIndirectFromCode(Code pc)
1109 { return wsizeofInd(pc[0]) + 2;
1110 }
1111
1112
1113 word
globalIndirectFromCode(Code * PC)1114 globalIndirectFromCode(Code *PC)
1115 { GET_LD
1116 Code pc = *PC;
1117 word m = *pc++;
1118 size_t n = wsizeofInd(m);
1119 Word p = allocGlobal(n+2);
1120
1121 if ( p )
1122 { word r = consPtr(p, tag(m)|STG_GLOBAL);
1123
1124 *p++ = m;
1125 while(n-- > 0)
1126 *p++ = *pc++;
1127 *p++ = m;
1128
1129 *PC = pc;
1130 return r;
1131 } else
1132 return 0;
1133 }
1134
1135
1136 static int /* used in pl-wam.c */
equalIndirectFromCode(word a,Code * PC)1137 equalIndirectFromCode(word a, Code *PC)
1138 { GET_LD
1139 Word pc = *PC;
1140 Word pa = addressIndirect(a);
1141
1142 if ( *pc == *pa )
1143 { size_t n = wsizeofInd(*pc);
1144
1145 while(n-- > 0)
1146 { if ( *++pc != *++pa )
1147 fail;
1148 }
1149 pc++;
1150 *PC = pc;
1151 succeed;
1152 }
1153
1154 fail;
1155 }
1156
1157
1158 /*******************************
1159 * GNU MALLOC *
1160 *******************************/
1161
1162 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1163 These functions are used by various GNU-libraries and -when not linked
1164 with the GNU C-library lead to undefined symbols. Therefore we define
1165 them in SWI-Prolog so that we can also give consistent warnings. Note
1166 that we must call plain system malloc as the library will call free() on
1167 it.
1168 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1169
1170 #if !defined(xmalloc) && defined(O_XMALLOC)
1171
1172 void *
xmalloc(size_t size)1173 xmalloc(size_t size)
1174 { void *mem;
1175
1176 if ( (mem = malloc(size)) )
1177 return mem;
1178 if ( size )
1179 outOfCore();
1180
1181 return NULL;
1182 }
1183
1184
1185 void *
xrealloc(void * mem,size_t size)1186 xrealloc(void *mem, size_t size)
1187 { void *newmem;
1188
1189 newmem = mem ? realloc(mem, size) : malloc(size);
1190 if ( newmem )
1191 return newmem;
1192 if ( size )
1193 outOfCore();
1194
1195 return NULL;
1196 }
1197
1198 #endif /*xmalloc*/
1199
1200 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1201 Allocation on behalf of foreign code. There is generally no need to use
1202 this, unless malloced data is returned by Prolog and the foreign routine
1203 wants to free it (e.g. using BUF_MALLOC).
1204 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1205
1206 void *
PL_malloc(size_t size)1207 PL_malloc(size_t size)
1208 { void *mem;
1209
1210 if ( (mem = GC_MALLOC(size)) )
1211 return mem;
1212
1213 outOfCore();
1214
1215 return NULL;
1216 }
1217
1218
1219 void *
PL_malloc_atomic(size_t size)1220 PL_malloc_atomic(size_t size)
1221 { void *mem;
1222
1223 if ( (mem = GC_MALLOC_ATOMIC(size)) )
1224 return mem;
1225
1226 outOfCore();
1227
1228 return NULL;
1229 }
1230
1231
1232 void *
PL_malloc_uncollectable(size_t size)1233 PL_malloc_uncollectable(size_t size)
1234 { void *mem;
1235
1236 if ( (mem = GC_MALLOC_UNCOLLECTABLE(size)) )
1237 return mem;
1238
1239 outOfCore();
1240
1241 return NULL;
1242 }
1243
1244
1245 void *
PL_malloc_atomic_uncollectable(size_t size)1246 PL_malloc_atomic_uncollectable(size_t size)
1247 { void *mem;
1248
1249 if ( (mem = GC_MALLOC_ATOMIC_UNCOLLECTABLE(size)) )
1250 return mem;
1251
1252 outOfCore();
1253
1254 return NULL;
1255 }
1256
1257
1258 void *
PL_malloc_unmanaged(size_t size)1259 PL_malloc_unmanaged(size_t size)
1260 { void *mem;
1261
1262 if ( (mem = GC_MALLOC(size)) )
1263 {
1264 #if defined(HAVE_BOEHM_GC) && defined(GC_FLAG_UNCOLLECTABLE)
1265 GC_SET_FLAGS(mem, GC_FLAG_UNCOLLECTABLE);
1266 #endif
1267 return mem;
1268 }
1269
1270 outOfCore();
1271
1272 return NULL;
1273 }
1274
1275
1276 void *
PL_malloc_atomic_unmanaged(size_t size)1277 PL_malloc_atomic_unmanaged(size_t size)
1278 { void *mem;
1279
1280 if ( (mem = GC_MALLOC_ATOMIC(size)) )
1281 {
1282 #if defined(HAVE_BOEHM_GC) && defined(GC_FLAG_UNCOLLECTABLE)
1283 GC_SET_FLAGS(mem, GC_FLAG_UNCOLLECTABLE);
1284 #endif
1285 return mem;
1286 }
1287
1288 outOfCore();
1289
1290 return NULL;
1291 }
1292
1293
1294 void *
PL_realloc(void * mem,size_t size)1295 PL_realloc(void *mem, size_t size)
1296 { void *newmem;
1297
1298 if ( !(newmem = GC_REALLOC(mem, size)) )
1299 outOfCore();
1300
1301 return newmem;
1302 }
1303
1304
1305 void
PL_free(void * mem)1306 PL_free(void *mem)
1307 { GC_FREE(mem);
1308 }
1309
1310
1311 int
PL_linger(void * mem)1312 PL_linger(void *mem)
1313 {
1314 #if defined(HAVE_BOEHM_GC) && defined(GC_FLAG_UNCOLLECTABLE)
1315 if ( mem )
1316 { GC_CLEAR_FLAGS(mem, GC_FLAG_UNCOLLECTABLE);
1317 #ifdef GC_DEBUG
1318 GC_linger(mem);
1319 #endif
1320 }
1321 return TRUE;
1322 #else
1323 return FALSE;
1324 #endif
1325 }
1326
1327
1328 /*******************************
1329 * INIT *
1330 *******************************/
1331
1332 #ifdef HAVE_BOEHM_GC
1333 static void
heap_gc_warn_proc(char * msg,GC_word arg)1334 heap_gc_warn_proc(char *msg, GC_word arg)
1335 {
1336 #if ALLOC_DEBUG
1337 Sdprintf(msg, arg);
1338 save_backtrace("heap-gc-warning");
1339 print_backtrace_named("heap-gc-warning");
1340 #endif
1341 }
1342 #endif
1343
1344 void
initAlloc(void)1345 initAlloc(void)
1346 { static int done = FALSE;
1347
1348 if ( done )
1349 return;
1350 done = TRUE;
1351
1352 #if defined(_DEBUG) && defined(__WINDOWS__) && 0
1353 _CrtSetDbgFlag(_CRTDBG_ALLOC_MEM_DF|
1354 _CRTDBG_CHECK_CRT_DF|
1355 //_CRTDBG_CHECK_ALWAYS_DF| /* very expensive */
1356 //_CRTDBG_DELAY_FREE_MEM_DF| /* does not reuse freed mem */
1357 //_CRTDBG_LEAK_CHECK_DF|
1358 0);
1359 #endif
1360
1361 #ifdef HAVE_BOEHM_GC
1362 GC_INIT();
1363 GC_set_warn_proc(heap_gc_warn_proc);
1364 #endif
1365
1366 #if defined(HAVE_MTRACE) && defined(O_MAINTENANCE)
1367 if ( getenv("MALLOC_TRACE") ) /* glibc malloc tracer */
1368 mtrace();
1369 #endif
1370
1371 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1372 FORCED_MALLOC_BASE is a debugging aid for me to force the system to
1373 allocate memory starting from a specific address. Probably only works
1374 properly on Linux. Don't bother with it.
1375 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1376
1377 #ifdef FORCED_MALLOC_BASE
1378 start_memory((void *)FORCED_MALLOC_BASE);
1379 Sdprintf("FORCED_MALLOC_BASE at 0x%08x\n", FORCED_MALLOC_BASE);
1380 #endif
1381 #if O_MALLOC_DEBUG
1382 malloc_debug(O_MALLOC_DEBUG);
1383 #endif
1384 }
1385
1386 /*******************************
1387 * MMAP STACKS *
1388 *******************************/
1389
1390 #ifdef MMAP_STACK
1391 #define MMAP_THRESHOLD 32768
1392
1393 typedef struct
1394 { size_t size; /* Size (including header) */
1395 int mmapped; /* Is mmapped? */
1396 double data[1]; /* ensure alignment */
1397 } map_region;
1398
1399 #define SA_OFFSET offsetof(map_region, data)
1400
1401 static size_t
pgsize(void)1402 pgsize(void)
1403 { static size_t sz = 0;
1404
1405 if ( !sz )
1406 sz = sysconf(_SC_PAGESIZE);
1407
1408 return sz;
1409 }
1410
1411 static inline size_t
roundpgsize(size_t sz)1412 roundpgsize(size_t sz)
1413 { size_t r = pgsize();
1414
1415 return ((sz+r-1)/r)*r;
1416 }
1417
1418 size_t
tmp_nalloc(size_t req)1419 tmp_nalloc(size_t req)
1420 { if ( req < MMAP_THRESHOLD-SA_OFFSET )
1421 return req;
1422
1423 return roundpgsize(req+SA_OFFSET)-SA_OFFSET;
1424 }
1425
1426 size_t
tmp_nrealloc(void * mem,size_t req)1427 tmp_nrealloc(void *mem, size_t req)
1428 { if ( mem )
1429 { map_region *reg = (map_region *)((char*)mem-SA_OFFSET);
1430
1431 if ( !reg->mmapped && req < MMAP_THRESHOLD-SA_OFFSET )
1432 return req;
1433
1434 return roundpgsize(req+SA_OFFSET)-SA_OFFSET;
1435 }
1436
1437 return tmp_nalloc(req);
1438 }
1439
1440
1441 size_t
tmp_malloc_size(void * mem)1442 tmp_malloc_size(void *mem)
1443 { if ( mem )
1444 { map_region *reg = (map_region *)((char*)mem-SA_OFFSET);
1445 return reg->size-SA_OFFSET;
1446 }
1447
1448 return 0;
1449 }
1450
1451 void *
tmp_malloc(size_t req)1452 tmp_malloc(size_t req)
1453 { map_region *reg;
1454 int mmapped;
1455
1456 req += SA_OFFSET;
1457 if ( req < MMAP_THRESHOLD )
1458 { reg = malloc(req);
1459 mmapped = FALSE;
1460 } else
1461 { req = roundpgsize(req);
1462
1463 reg = mmap(NULL, req,
1464 (PROT_READ|PROT_WRITE),
1465 (MAP_PRIVATE|MAP_ANONYMOUS),
1466 -1, 0);
1467 if ( reg == MAP_FAILED )
1468 reg = NULL;
1469 mmapped = TRUE;
1470 }
1471
1472 if ( reg )
1473 { reg->size = req;
1474 reg->mmapped = mmapped;
1475 #ifdef O_DEBUG
1476 memset(reg->data, 0xFB, req-SA_OFFSET);
1477 #endif
1478
1479 return reg->data;
1480 }
1481
1482 return NULL;
1483 }
1484
1485
1486 void *
tmp_realloc(void * mem,size_t req)1487 tmp_realloc(void *mem, size_t req)
1488 { if ( mem )
1489 { map_region *reg = (map_region *)((char*)mem-SA_OFFSET);
1490
1491 req += SA_OFFSET;
1492 if ( !reg->mmapped )
1493 { if ( req < MMAP_THRESHOLD )
1494 { map_region *nw = realloc(reg, req);
1495 if ( nw )
1496 { nw->size = req;
1497 return nw->data;
1498 }
1499 return NULL;
1500 } else /* malloc --> mmap */
1501 { void *nw = tmp_malloc(req-SA_OFFSET);
1502 if ( nw )
1503 { size_t copy = reg->size;
1504
1505 if ( copy > req )
1506 copy = req;
1507
1508 memcpy(nw, mem, copy-SA_OFFSET);
1509 free(reg);
1510 }
1511 return nw;
1512 }
1513 } else
1514 { req = roundpgsize(req);
1515
1516 if ( reg->size != req )
1517 { if ( reg->size > req )
1518 { size_t trunk = reg->size-req;
1519
1520 munmap((char*)reg+req, trunk);
1521 reg->size = req;
1522
1523 return reg->data;
1524 } else
1525 { void *ra = tmp_malloc(req);
1526
1527 if ( ra )
1528 { memcpy(ra, mem, reg->size-SA_OFFSET);
1529 #ifdef O_DEBUG
1530 memset((char*)ra+reg->size-SA_OFFSET, 0xFB,
1531 req-(reg->size-SA_OFFSET));
1532 #endif
1533 tmp_free(mem);
1534 }
1535
1536 return ra;
1537 }
1538 } else
1539 { return mem;
1540 }
1541 }
1542 } else
1543 { return tmp_malloc(req);
1544 }
1545 }
1546
1547
1548 void
tmp_free(void * mem)1549 tmp_free(void *mem)
1550 { if ( mem )
1551 { map_region *reg = (map_region *)((char*)mem-SA_OFFSET);
1552
1553 if ( reg->mmapped )
1554 munmap(reg, reg->size);
1555 else
1556 free(reg);
1557 }
1558 }
1559
1560 #else /*MMAP_STACK*/
1561
1562 size_t
tmp_nalloc(size_t req)1563 tmp_nalloc(size_t req)
1564 { return req;
1565 }
1566
1567 size_t
tmp_nrealloc(void * mem,size_t req)1568 tmp_nrealloc(void *mem, size_t req)
1569 { (void)mem;
1570
1571 return req;
1572 }
1573
1574 size_t
tmp_malloc_size(void * mem)1575 tmp_malloc_size(void *mem)
1576 { if ( mem )
1577 { size_t *sp = mem;
1578 return sp[-1];
1579 }
1580
1581 return 0;
1582 }
1583
1584 void *
tmp_malloc(size_t size)1585 tmp_malloc(size_t size)
1586 { void *mem = malloc(size+sizeof(size_t));
1587
1588 if ( mem )
1589 { size_t *sp = mem;
1590 *sp++ = size;
1591 #ifdef O_DEBUG
1592 memset(sp, 0xFB, size);
1593 #endif
1594
1595 return sp;
1596 }
1597
1598 return NULL;
1599 }
1600
1601 void *
tmp_realloc(void * old,size_t size)1602 tmp_realloc(void *old, size_t size)
1603 { size_t *sp = old;
1604 size_t osize = *--sp;
1605 void *mem;
1606
1607 #ifdef O_DEBUG
1608 if ( (mem = tmp_malloc(size)) )
1609 { memcpy(mem, old, (size>osize?osize:size));
1610 tmp_free(old);
1611 return mem;
1612 }
1613 #else
1614 (void)osize;
1615 if ( (mem = realloc(sp, size+sizeof(size_t))) )
1616 { sp = mem;
1617 *sp++ = size;
1618 return sp;
1619 }
1620 #endif
1621
1622 return NULL;
1623 }
1624
1625 void
tmp_free(void * mem)1626 tmp_free(void *mem)
1627 { size_t *sp = mem;
1628 size_t osize = *--sp;
1629
1630 #ifdef O_DEBUG
1631 memset(sp, 0xFB, osize+sizeof(size_t));
1632 #else
1633 (void)osize;
1634 #endif
1635 free(sp);
1636 }
1637
1638 #endif /*MMAP_STACK*/
1639
1640 void *
stack_malloc(size_t size)1641 stack_malloc(size_t size)
1642 { void *ptr = tmp_malloc(size);
1643
1644 if ( ptr )
1645 ATOMIC_ADD(&GD->statistics.stack_space, tmp_malloc_size(ptr));
1646
1647 return ptr;
1648 }
1649
1650 void *
stack_realloc(void * mem,size_t size)1651 stack_realloc(void *mem, size_t size)
1652 { size_t osize = tmp_malloc_size(mem);
1653 void *ptr = tmp_realloc(mem, size);
1654
1655 if ( ptr )
1656 { size = tmp_malloc_size(ptr);
1657
1658 if ( osize > size )
1659 ATOMIC_SUB(&GD->statistics.stack_space, osize-size);
1660 else
1661 ATOMIC_ADD(&GD->statistics.stack_space, size-osize);
1662 }
1663
1664 return ptr;
1665 }
1666
1667 void
stack_free(void * mem)1668 stack_free(void *mem)
1669 { size_t size = tmp_malloc_size(mem);
1670
1671 ATOMIC_SUB(&GD->statistics.stack_space, size);
1672 tmp_free(mem);
1673 }
1674
1675 size_t
stack_nalloc(size_t req)1676 stack_nalloc(size_t req)
1677 { return tmp_nalloc(req);
1678 }
1679
1680 size_t
stack_nrealloc(void * mem,size_t req)1681 stack_nrealloc(void *mem, size_t req)
1682 { return tmp_nrealloc(mem, req);
1683 }
1684
1685
1686 /*******************************
1687 * TCMALLOC *
1688 *******************************/
1689
1690 static int (*fMallocExtension_GetNumericProperty)(const char *, size_t *);
1691 static int (*fMallocExtension_SetNumericProperty)(const char *, size_t);
1692 static void (*fMallocExtension_MarkThreadIdle)(void) = NULL;
1693 static void (*fMallocExtension_MarkThreadTemporarilyIdle)(void) = NULL;
1694 static void (*fMallocExtension_MarkThreadBusy)(void) = NULL;
1695
1696 static const char* tcmalloc_properties[] =
1697 { "generic.current_allocated_bytes",
1698 "generic.heap_size",
1699 "tcmalloc.max_total_thread_cache_bytes",
1700 "tcmalloc.current_total_thread_cache_bytes",
1701 "tcmalloc.central_cache_free_bytes",
1702 "tcmalloc.transfer_cache_free_bytes",
1703 "tcmalloc.thread_cache_free_bytes",
1704 "tcmalloc.pageheap_free_bytes",
1705 "tcmalloc.pageheap_unmapped_bytes",
1706 NULL
1707 };
1708
1709 static foreign_t
malloc_property(term_t prop,control_t handle)1710 malloc_property(term_t prop, control_t handle)
1711 { GET_LD
1712 const char **pname;
1713
1714 switch( PL_foreign_control(handle) )
1715 { case PL_FIRST_CALL:
1716 { atom_t name;
1717 size_t arity;
1718
1719 if ( PL_get_name_arity(prop, &name, &arity) && arity == 1 )
1720 { const char *s = PL_atom_nchars(name, NULL);
1721
1722 if ( s )
1723 { pname = tcmalloc_properties;
1724
1725 for(; *pname; pname++)
1726 { if ( streq(s, *pname) )
1727 { size_t val;
1728
1729 if ( fMallocExtension_GetNumericProperty(*pname, &val) )
1730 { term_t a = PL_new_term_ref();
1731 _PL_get_arg(1, prop, a);
1732 return PL_unify_uint64(a, val);
1733 }
1734 }
1735 }
1736 }
1737
1738 return FALSE;
1739 } else if ( PL_is_variable(prop) )
1740 { pname = tcmalloc_properties;
1741 goto enumerate;
1742 }
1743 }
1744 case PL_REDO:
1745 { fid_t fid;
1746
1747 pname = PL_foreign_context_address(handle);
1748 enumerate:
1749
1750 fid = PL_open_foreign_frame();
1751 for(; *pname; pname++)
1752 { size_t val;
1753
1754 if ( fMallocExtension_GetNumericProperty(*pname, &val) )
1755 { if ( PL_unify_term(prop, PL_FUNCTOR_CHARS, *pname, 1,
1756 PL_INT64, val) )
1757 { PL_close_foreign_frame(fid);
1758 pname++;
1759 if ( *pname )
1760 PL_retry_address(pname);
1761 else
1762 return TRUE;
1763 }
1764 }
1765
1766 if ( PL_exception(0) )
1767 return FALSE;
1768 PL_rewind_foreign_frame(fid);
1769 }
1770 PL_close_foreign_frame(fid);
1771
1772 return FALSE;
1773 }
1774 case PL_CUTTED:
1775 { return TRUE;
1776 }
1777 default:
1778 { assert(0);
1779 return FALSE;
1780 }
1781 }
1782 }
1783
1784 static foreign_t
set_malloc(term_t prop)1785 set_malloc(term_t prop)
1786 { GET_LD
1787 atom_t name;
1788 size_t arity;
1789
1790 if ( PL_get_name_arity(prop, &name, &arity) && arity == 1 )
1791 { const char *s = PL_atom_nchars(name, NULL);
1792 term_t a = PL_new_term_ref();
1793 size_t val;
1794
1795 if ( !PL_get_arg(1, prop, a) ||
1796 !PL_get_size_ex(a, &val) )
1797 return FALSE;
1798
1799 if ( s )
1800 { const char **pname = tcmalloc_properties;
1801
1802 for(; *pname; pname++)
1803 { if ( streq(s, *pname) )
1804 { if ( fMallocExtension_SetNumericProperty(*pname, val) )
1805 return TRUE;
1806 else
1807 return PL_permission_error("set", "malloc_property", prop);
1808 }
1809 }
1810
1811 return PL_domain_error("malloc_property", prop);
1812 }
1813 }
1814
1815 return PL_type_error("malloc_property", prop);
1816 }
1817
1818
1819 size_t
heapUsed(void)1820 heapUsed(void)
1821 { size_t val;
1822
1823 if (fMallocExtension_GetNumericProperty &&
1824 fMallocExtension_GetNumericProperty("generic.current_allocated_bytes", &val))
1825 {
1826 #ifdef MMAP_STACK
1827 val += GD->statistics.stack_space;
1828 #endif
1829
1830 return val;
1831 }
1832
1833 return 0;
1834 }
1835
1836
1837 int
initTCMalloc(void)1838 initTCMalloc(void)
1839 { static int done = FALSE;
1840 int set = 0;
1841
1842 if ( done )
1843 return !!fMallocExtension_GetNumericProperty;
1844 done = TRUE;
1845
1846 if ( (fMallocExtension_GetNumericProperty =
1847 PL_dlsym(NULL, "MallocExtension_GetNumericProperty")) )
1848 { PL_register_foreign_in_module("system", "malloc_property", 1, malloc_property,
1849 PL_FA_NONDETERMINISTIC);
1850 set++;
1851 }
1852 if ( (fMallocExtension_SetNumericProperty =
1853 PL_dlsym(NULL, "MallocExtension_SetNumericProperty")) )
1854 { PL_register_foreign_in_module("system", "set_malloc", 1, set_malloc, 0);
1855 set++;
1856 }
1857
1858 fMallocExtension_MarkThreadIdle =
1859 PL_dlsym(NULL, "MallocExtension_MarkThreadIdle");
1860 fMallocExtension_MarkThreadTemporarilyIdle =
1861 PL_dlsym(NULL, "MallocExtension_MarkThreadTemporarilyIdle");
1862 fMallocExtension_MarkThreadBusy =
1863 PL_dlsym(NULL, "MallocExtension_MarkThreadBusy");
1864
1865 return set;
1866 }
1867
1868
1869 /** thread_idle(:Goal, +How)
1870 *
1871 */
1872
1873 static
1874 PRED_IMPL("thread_idle", 2, thread_idle, PL_FA_TRANSPARENT)
1875 { PRED_LD
1876 int rc;
1877 atom_t how;
1878
1879 if ( !PL_get_atom_ex(A2, &how) )
1880 return FALSE;
1881
1882 if ( how == ATOM_short )
1883 { trimStacks(TRUE PASS_LD);
1884 if ( fMallocExtension_MarkThreadTemporarilyIdle &&
1885 fMallocExtension_MarkThreadBusy )
1886 fMallocExtension_MarkThreadTemporarilyIdle();
1887 } else if ( how == ATOM_long )
1888 { LD->trim_stack_requested = TRUE;
1889 garbageCollect(GC_USER);
1890 LD->trim_stack_requested = FALSE;
1891 if ( fMallocExtension_MarkThreadIdle &&
1892 fMallocExtension_MarkThreadBusy )
1893 fMallocExtension_MarkThreadIdle();
1894 }
1895
1896 rc = callProlog(NULL, A1, PL_Q_PASS_EXCEPTION, NULL);
1897
1898 if ( fMallocExtension_MarkThreadBusy )
1899 fMallocExtension_MarkThreadBusy();
1900
1901 return rc;
1902 }
1903
1904
1905
1906 /*******************************
1907 * PREDICATES *
1908 *******************************/
1909
1910 #ifdef HAVE_BOEHM_GC
1911 static
1912 PRED_IMPL("garbage_collect_heap", 0, garbage_collect_heap, 0)
1913 { GC_gcollect();
1914
1915 return TRUE;
1916 }
1917 #endif
1918
1919 BeginPredDefs(alloc)
1920 #ifdef HAVE_BOEHM_GC
1921 PRED_DEF("garbage_collect_heap", 0, garbage_collect_heap, 0)
1922 #endif
1923 PRED_DEF("thread_idle", 2, thread_idle, PL_FA_TRANSPARENT)
1924 EndPredDefs
1925