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 /*#define O_DEBUG 1*/
38 #include "pl-incl.h"
39
40 #undef LD
41 #define LD LOCAL_LD
42
43 /*******************************
44 * TEMP MALLOC *
45 *******************************/
46
47 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
48 Allocate memory for findall bags in chunks that can be discarded
49 together and preallocate the first chunk. This approach avoids
50 fragmentation and reduces the number of allocation calls. The latter is
51 notably needed to reduce allocation contention due to intensive use of
52 findall/3.
53 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
54
55 #define FIRST_CHUNK_SIZE (256*sizeof(void*))
56
57 typedef struct mem_chunk
58 { struct mem_chunk *prev;
59 size_t size;
60 size_t used;
61 } mem_chunk;
62
63 typedef struct mem_pool
64 { mem_chunk *chunks;
65 size_t chunk_count;
66 mem_chunk first;
67 char first_data[FIRST_CHUNK_SIZE];
68 } mem_pool;
69
70 static void
init_mem_pool(mem_pool * mp)71 init_mem_pool(mem_pool *mp)
72 { mp->chunks = &mp->first;
73 mp->chunk_count = 1;
74 mp->first.size = FIRST_CHUNK_SIZE;
75 mp->first.used = 0;
76 }
77
78 #define ROUNDUP(n,m) (((n) + (m - 1)) & ~(m-1))
79
80 static void *
alloc_mem_pool(mem_pool * mp,size_t bytes)81 alloc_mem_pool(mem_pool *mp, size_t bytes)
82 { char *ptr;
83
84 if ( mp->chunks->used + bytes <= mp->chunks->size )
85 { ptr = &((char *)(mp->chunks+1))[mp->chunks->used];
86 mp->chunks->used += ROUNDUP(bytes, sizeof(void*));
87 } else
88 { size_t chunksize = tmp_nalloc(4000*((size_t)1<<mp->chunk_count++)+sizeof(mem_chunk));
89 mem_chunk *c;
90
91 if ( bytes > chunksize-sizeof(mem_chunk) )
92 chunksize = tmp_nalloc(bytes+sizeof(mem_chunk));
93
94 if ( (c=tmp_malloc(chunksize)) )
95 { c->size = chunksize-sizeof(mem_chunk);
96 c->used = ROUNDUP(bytes, sizeof(void*));
97 c->prev = mp->chunks;
98 mp->chunks = c;
99 ptr = (char *)(mp->chunks+1);
100 } else
101 return NULL;
102 }
103
104 #ifdef O_DEBUG
105 assert((uintptr_t)ptr%sizeof(void*) == 0);
106 #endif
107
108 return ptr;
109 }
110
111 static void
clear_mem_pool(mem_pool * mp)112 clear_mem_pool(mem_pool *mp)
113 { mem_chunk *c, *p;
114
115 for(c=mp->chunks; c != &mp->first; c=p)
116 { p = c->prev;
117 tmp_free(c);
118 }
119 mp->chunk_count = 1;
120 mp->chunks = &mp->first;
121 mp->first.used = 0;
122 }
123
124
125 /*******************************
126 * FINDALL SUPPORT *
127 *******************************/
128
129 #define FINDALL_MAGIC 0x37ac78fe
130
131 typedef struct findall_bag
132 { struct findall_bag *parent; /* parent bag */
133 int magic; /* FINDALL_MAGIC */
134 int suspended; /* Used for findnsols/4 */
135 size_t suspended_solutions; /* Already handed out solutions */
136 size_t solutions; /* count # solutions */
137 size_t gsize; /* required size on stack */
138 mem_pool records; /* stored records */
139 segstack answers; /* list of answers */
140 Record answer_buf[64]; /* tmp space */
141 } findall_bag;
142
143
144 static
145 PRED_IMPL("$new_findall_bag", 0, new_findall_bag, 0)
146 { PRED_LD
147 findall_bag *bag;
148
149 if ( !LD->bags.bags ) /* outer one */
150 { if ( !LD->bags.default_bag )
151 {
152 #if defined(O_ATOMGC) && defined(O_PLMT)
153 simpleMutexInit(&LD->bags.mutex);
154 #endif
155 LD->bags.default_bag = PL_malloc(sizeof(*bag));
156 }
157 bag = LD->bags.default_bag;
158 } else
159 { bag = PL_malloc(sizeof(*bag));
160 }
161
162 if ( !bag )
163 return PL_no_memory();
164
165 bag->magic = FINDALL_MAGIC;
166 bag->suspended = FALSE;
167 bag->suspended_solutions = 0;
168 bag->solutions = 0;
169 bag->gsize = 0;
170 bag->parent = LD->bags.bags;
171 init_mem_pool(&bag->records);
172 initSegStack(&bag->answers, sizeof(Record),
173 sizeof(bag->answer_buf), bag->answer_buf);
174 MEMORY_BARRIER();
175 LD->bags.bags = bag;
176
177 return TRUE;
178 }
179
180
181 static void *
alloc_record(void * ctx,size_t bytes)182 alloc_record(void *ctx, size_t bytes)
183 { findall_bag *bag = ctx;
184
185 return alloc_mem_pool(&bag->records, bytes);
186 }
187
188
189 static findall_bag *
current_bag(ARG1_LD)190 current_bag(ARG1_LD)
191 { findall_bag *bag = LD->bags.bags;
192
193 while(bag && bag->suspended)
194 { assert(bag->parent);
195 bag = bag->parent;
196 }
197
198 return bag;
199 }
200
201
202 static foreign_t
add_findall_bag(term_t term,term_t count ARG_LD)203 add_findall_bag(term_t term, term_t count ARG_LD)
204 { findall_bag *bag = current_bag(PASS_LD1);
205 Record r;
206
207 DEBUG(MSG_NSOLS, { Sdprintf("Adding to %p: ", bag);
208 PL_write_term(Serror, term, 1200,
209 PL_WRT_ATTVAR_DOTS|
210 PL_WRT_NEWLINE|
211 PL_WRT_QUOTED);
212 });
213
214 if ( !bag )
215 { static atom_t cbag;
216
217 if ( !cbag )
218 cbag = PL_new_atom("findall-bag");
219
220 return PL_error(NULL, 0, "continuation in findall/3 generator?",
221 ERR_PERMISSION, ATOM_append, cbag, term);
222 }
223
224 if ( !(r = compileTermToHeap__LD(term, alloc_record, bag, R_NOLOCK PASS_LD)) )
225 return PL_no_memory();
226 if ( !pushRecordSegStack(&bag->answers, r) )
227 return PL_no_memory();
228 bag->gsize += r->gsize;
229 bag->solutions++;
230
231 if ( bag->gsize + bag->solutions*3 > globalStackLimit()/sizeof(word) )
232 return outOfStack(&LD->stacks.global, STACK_OVERFLOW_RAISE);
233
234 if ( count )
235 return PL_unify_int64(count, bag->solutions + bag->suspended_solutions);
236 else
237 return FALSE;
238 }
239
240 static
241 PRED_IMPL("$add_findall_bag", 1, add_findall_bag, 0)
242 { PRED_LD
243
244 return add_findall_bag(A1, 0 PASS_LD);
245 }
246
247 static
248 PRED_IMPL("$add_findall_bag", 2, add_findall_bag, 0)
249 { PRED_LD
250
251 return add_findall_bag(A1, A2 PASS_LD);
252 }
253
254
255 static
256 PRED_IMPL("$collect_findall_bag", 2, collect_findall_bag, 0)
257 { PRED_LD
258 findall_bag *bag = current_bag(PASS_LD1);
259
260 if ( bag->solutions )
261 { size_t space = bag->gsize + bag->solutions*3;
262 term_t list = PL_copy_term_ref(A2);
263 term_t answer = PL_new_term_ref();
264 Record *rp;
265 int rc;
266
267 if ( !hasGlobalSpace(space) )
268 { if ( (rc=ensureGlobalSpace(space, ALLOW_GC)) != TRUE )
269 return raiseStackOverflow(rc);
270 }
271
272 while ( (rp=topOfSegStack(&bag->answers)) )
273 { Record r = *rp;
274 DEBUG(MSG_NSOLS, Sdprintf("Retrieving answer\n"));
275 copyRecordToGlobal(answer, r, ALLOW_GC PASS_LD);
276 if (GD->atoms.gc_active)
277 markAtomsRecord(r);
278 PL_cons_list(list, answer, list);
279 #ifdef O_ATOMGC
280 /* see comment with scanSegStack() for synchronization details */
281 if ( !quickPopTopOfSegStack(&bag->answers) )
282 { simpleMutexLock(&LD->bags.mutex);
283 popTopOfSegStack(&bag->answers);
284 simpleMutexUnlock(&LD->bags.mutex);
285 }
286 #else
287 popTopOfSegStack(&bag->answers);
288 #endif
289 }
290 DEBUG(CHK_SECURE, assert(emptySegStack(&bag->answers)));
291
292 return PL_unify(A1, list);
293 } else
294 return PL_unify(A1, A2);
295 }
296
297 /** '$suspend_findall_bag'
298
299 Used by findnsols/4,5. It is called after a complete chunk is delivered.
300 On first call it empties the chunk and puts it in `suspended' mode. On
301 redo, the bag is re-enabled and we fail to force backtracking the goal.
302
303 This is a hack. An alternative would be to pass bug-ids explicitly, but
304 earlier experiments showed a significant performance gain for findall/3
305 and friends by keeping the bag implicit because there is no extra
306 argument we need to unify, extract from and verify the result.
307 */
308
309 static
310 PRED_IMPL("$suspend_findall_bag", 0, suspend_findall_bag, PL_FA_NONDETERMINISTIC)
311 { PRED_LD
312 findall_bag *bag;
313
314 switch( CTX_CNTRL )
315 { case FRG_FIRST_CALL:
316 bag = current_bag(PASS_LD1);
317 simpleMutexLock(&LD->bags.mutex);
318 clear_mem_pool(&bag->records);
319 simpleMutexUnlock(&LD->bags.mutex);
320 bag->suspended_solutions += bag->solutions;
321 bag->solutions = 0;
322 bag->gsize = 0;
323 DEBUG(MSG_NSOLS, Sdprintf("Suspend %p\n", bag));
324 bag->suspended = TRUE;
325 ForeignRedoPtr(bag);
326 case FRG_REDO:
327 bag = CTX_PTR;
328 DEBUG(MSG_NSOLS, Sdprintf("Resume %p\n", bag));
329 bag->suspended = FALSE;
330 return FALSE;
331 case FRG_CUTTED:
332 bag = CTX_PTR;
333 DEBUG(MSG_NSOLS, Sdprintf("! Resume %p\n", bag));
334 bag->suspended = FALSE;
335 return TRUE;
336 default:
337 assert(0);
338 return FALSE;
339 }
340 }
341
342
343 static
344 PRED_IMPL("$destroy_findall_bag", 0, destroy_findall_bag, 0)
345 { PRED_LD
346 findall_bag *bag = LD->bags.bags;
347
348 assert(bag);
349 assert(bag->magic == FINDALL_MAGIC);
350 assert(bag->suspended == FALSE);
351
352 #ifdef O_ATOMGC
353 simpleMutexLock(&LD->bags.mutex);
354 #endif
355 LD->bags.bags = bag->parent;
356 #ifdef O_ATOMGC
357 simpleMutexUnlock(&LD->bags.mutex);
358 #endif
359
360 bag->magic = 0;
361 clearSegStack(&bag->answers);
362 clear_mem_pool(&bag->records);
363 if ( bag != LD->bags.default_bag )
364 PL_free(bag);
365
366 return TRUE;
367 }
368
369
370 /*******************************
371 * ATOM-GC SUPPORT *
372 *******************************/
373
374 static void
markAtomsAnswers(void * data)375 markAtomsAnswers(void *data)
376 { Record r = *((Record*)data);
377
378 markAtomsRecord(r);
379 }
380
381
382 void
markAtomsFindall(PL_local_data_t * ld)383 markAtomsFindall(PL_local_data_t *ld)
384 { findall_bag *bag;
385
386 if ( ld->bags.default_bag )
387 { simpleMutexLock(&ld->bags.mutex);
388 bag = ld->bags.bags;
389 for( ; bag; bag = bag->parent )
390 scanSegStack(&bag->answers, markAtomsAnswers);
391 simpleMutexUnlock(&ld->bags.mutex);
392 }
393 }
394
395
396 /*******************************
397 * PUBLISH PREDICATES *
398 *******************************/
399
400 BeginPredDefs(bag)
401 PRED_DEF("$new_findall_bag", 0, new_findall_bag, 0)
402 PRED_DEF("$add_findall_bag", 1, add_findall_bag, 0)
403 PRED_DEF("$add_findall_bag", 2, add_findall_bag, 0)
404 PRED_DEF("$collect_findall_bag", 2, collect_findall_bag, 0)
405 PRED_DEF("$destroy_findall_bag", 0, destroy_findall_bag, 0)
406 PRED_DEF("$suspend_findall_bag", 0, suspend_findall_bag, PL_FA_NONDETERMINISTIC)
407 EndPredDefs
408