1 /* Heap management.
2 */
3
4 /*
5
6 Copyright (C) 1991-2003 The National Gallery
7
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
12
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License along
19 with this program; if not, write to the Free Software Foundation, Inc.,
20 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21
22 */
23
24 /*
25
26 These files are distributed with VIPS - http://www.vips.ecs.soton.ac.uk
27
28 */
29
30 /*
31 #define DEBUG
32 */
33
34 /* GC on every alloc too! Extraordinarily slow. Turn on DEBUG_HEAP in ip.h
35 * first. Good for spotting heap pointer errors.
36 #define DEBUG_HEAP_GC
37 */
38
39 /* Count GCs and %full, handy for tuning.
40 #define DEBUG_GETMEM
41 */
42
43 /* Time each GC, handy for benchmarking.
44 #define DEBUG_GC_TIME
45 */
46
47 #include "ip.h"
48
49 static iObjectClass *parent_class = NULL;
50
51 static GSList *heap_all = NULL;
52
53 /* Call a function, passing in a "safe" PElement ... ie. the PElement points
54 * at a fresh element which will be safe from the GC.
55 */
56 void *
heap_safe_pointer(Heap * heap,heap_safe_pointer_fn fn,void * a,void * b,void * c,void * d)57 heap_safe_pointer( Heap *heap, heap_safe_pointer_fn fn,
58 void *a, void *b, void *c, void *d )
59 {
60 Element e;
61 PElement pe;
62 void *result;
63
64 e.type = ELEMENT_NOVAL;
65 e.ele = (void *) 5;
66 PEPOINTE( &pe, &e );
67 heap_register_element( heap, &e );
68
69 result = fn( heap, &pe, a, b, c, d );
70
71 heap_unregister_element( heap, &e );
72
73 return( result );
74 }
75
76 /* Map a function over a piece of graph.
77 */
78 void *
heap_map(HeapNode * hn,heap_map_fn fn,void * a,void * b)79 heap_map( HeapNode *hn, heap_map_fn fn, void *a, void *b )
80 {
81 void *c;
82
83 if( !hn )
84 return( NULL );
85
86 switch( hn->type ) {
87 case TAG_APPL:
88 case TAG_CONS:
89 if( (c = fn( hn, a, b )) )
90 return( c );
91
92 if( GETLT( hn ) == ELEMENT_NODE &&
93 (c = heap_map( GETLEFT( hn ), fn, a, b )) )
94 return( c );
95 if( GETRT( hn ) == ELEMENT_NODE &&
96 (c = heap_map( GETRIGHT( hn ), fn, a, b )) )
97 return( c );
98
99 return( NULL );
100
101 case TAG_REFERENCE:
102 case TAG_COMPLEX:
103 case TAG_GEN:
104 case TAG_FILE:
105 case TAG_CLASS:
106 case TAG_DOUBLE:
107 return( fn( hn, a, b ) );
108
109 case TAG_SHARED:
110 if( (c = fn( hn, a, b )) )
111 return( c );
112
113 return( heap_map( GETLEFT( hn ), fn, a, b ) );
114
115 case TAG_FREE:
116 default:
117 g_assert( FALSE );
118
119 /* Keep gcc happy.
120 */
121 return( NULL );
122 }
123 }
124
125 #ifdef DEBUG_HEAP_GC
126 /* Debugging ... check that all nodes on the free list are TAG_FREE, and that
127 * all other nodes are not TAG_FREE.
128 */
129 static void
heap_check_free(Heap * heap)130 heap_check_free( Heap *heap )
131 {
132 HeapNode *hn;
133 HeapBlock *hb;
134
135 /* Clear all the DEBUG flags.
136 */
137 for( hb = heap->hb; hb; hb = hb->next ) {
138 int i;
139
140 for( i = 0; i < hb->sz; i++ ) {
141 HeapNode *hn = &hb->node[i];
142
143 hn->flgs &= FLAG_DEBUG ^ FLAG_ALL;
144 }
145 }
146
147 /* Check free list.
148 */
149 for( hn = heap->free; hn; hn = GETLEFT( hn ) ) {
150 g_assert( hn->type == TAG_FREE );
151
152 hn->flgs |= FLAG_DEBUG;
153 }
154
155 /* Check for all non-free.
156 */
157 for( hb = heap->hb; hb; hb = hb->next ) {
158 int i;
159
160 for( i = 0; i < hb->sz; i++ ) {
161 HeapNode *hn = &hb->node[i];
162
163 g_assert( hn->type != TAG_FREE ||
164 (hn->flgs & FLAG_DEBUG) );
165 }
166 }
167 }
168 #endif /*DEBUG_HEAP_GC*/
169
170 #ifdef DEBUG_HEAP_GC
171 static void
heap_check_managed(void * key,void * value,Heap * heap)172 heap_check_managed( void *key, void *value, Heap *heap )
173 {
174 /* Validate pointer.
175 */
176 (void) MANAGED( value );
177 }
178 #endif /*DEBUG_HEAP_GC*/
179
180 /* Test for sanity.
181 */
182 int
heap_sanity(Heap * heap)183 heap_sanity( Heap *heap )
184 {
185 #ifdef DEBUG_HEAP_GC
186 heap_check_free( heap );
187
188 heap_gc( heap );
189 heap_check_free( heap );
190 g_hash_table_foreach( heap->mtable, (GHFunc) heap_check_managed, heap );
191 #endif /*DEBUG_HEAP_GC*/
192
193 return( 0 );
194 }
195
196 /* Debugging ... check that all heaps have been closed, dump any which
197 * haven't.
198 */
199 void
heap_check_all_destroyed(void)200 heap_check_all_destroyed( void )
201 {
202 slist_map( heap_all, (SListMapFn) iobject_dump, NULL );
203 }
204
205 /* Free a HeapBlock.
206 */
207 static void
heapblock_free(HeapBlock * hb)208 heapblock_free( HeapBlock *hb )
209 {
210 #ifdef DEBUG
211 printf( "heapblock_free\n" );
212 #endif /*DEBUG*/
213
214 if( hb->next )
215 heapblock_free( hb->next );
216 if( hb->node )
217 IM_FREE( hb->node );
218 IM_FREE( hb );
219 }
220
221 static void
heap_set_flush(Heap * heap,gboolean flush)222 heap_set_flush( Heap *heap, gboolean flush )
223 {
224 heap->flush = flush;
225 }
226
227 static void
heap_dispose_print(void * key,void * value)228 heap_dispose_print( void *key, void *value )
229 {
230 Managed *managed = MANAGED( value );
231
232 iobject_print( IOBJECT( managed ) );
233 }
234
235 static void
heap_dispose(GObject * gobject)236 heap_dispose( GObject *gobject )
237 {
238 Heap *heap = HEAP( gobject );
239
240 /* Repeatedly close managed objects. Each close can trigger other
241 * closes, so we need to loop until done.
242 */
243 managed_clear( heap );
244 heap_set_flush( heap, TRUE );
245 while( managed_free_unused( heap ) )
246 ;
247
248 /* Check all managed objects are dead.
249 */
250 g_hash_table_foreach( heap->mtable,
251 (GHFunc) heap_dispose_print, NULL );
252
253 IM_FREEF( g_source_remove, heap->gc_tid );
254
255 G_OBJECT_CLASS( parent_class )->dispose( gobject );
256 }
257
258 static void
heap_finalize(GObject * gobject)259 heap_finalize( GObject *gobject )
260 {
261 Heap *heap = HEAP( gobject );
262
263 if( heap->hb )
264 heapblock_free( heap->hb );
265
266 IM_FREEF( g_hash_table_destroy, heap->emark );
267
268 IM_FREEF( g_hash_table_destroy, heap->rmark );
269
270 IM_FREEF( g_hash_table_destroy, heap->mtable );
271
272 heap_all = g_slist_remove( heap_all, heap );
273
274 G_OBJECT_CLASS( parent_class )->finalize( gobject );
275 }
276
277 static void
heap_info(iObject * iobject,VipsBuf * buf)278 heap_info( iObject *iobject, VipsBuf *buf )
279 {
280 Heap *heap = HEAP( iobject );
281
282 vips_buf_appendf( buf, "compile = " );
283 if( heap->compile )
284 if( heap->compile->sym ) {
285 symbol_qualified_name( heap->compile->sym, buf );
286 vips_buf_appendf( buf, "(%p) (sym)\n", heap->compile->sym );
287 }
288 else
289 vips_buf_appendf( buf, "(compile, but no sym)\n" );
290 else
291 vips_buf_appendf( buf, "(no compile)\n" );
292 vips_buf_appendf( buf, "mxb (max blocks) = %d\n", heap->mxb );
293 vips_buf_appendf( buf, "rsz (nodes per block) = %d\n", heap->rsz );
294 vips_buf_appendf( buf, "nb (number of blocks) = %d\n", heap->nb );
295 vips_buf_appendf( buf, "emark = %d pointers\n",
296 g_hash_table_size( heap->emark ) );
297 vips_buf_appendf( buf, "rmark = %d pointers\n",
298 g_hash_table_size( heap->rmark ) );
299 vips_buf_appendf( buf, "ncells (cells allocated) = %d\n", heap->ncells );
300 vips_buf_appendf( buf, "nfree (cells free at last GC) = %d\n", heap->nfree );
301 vips_buf_appendf( buf, "mtable (Managed blocks) = %d pointers\n",
302 g_hash_table_size( heap->mtable ) );
303
304 IOBJECT_CLASS( parent_class )->info( iobject, buf );
305 }
306
307 /* Empty a heap block.
308 */
309 static void
heapblock_empty(HeapBlock * hb)310 heapblock_empty( HeapBlock *hb )
311 {
312 int i;
313
314 /* Set as empty free-list.
315 */
316 for( i = 0; i < hb->sz; i++ ) {
317 HeapNode *hn = &hb->node[i];
318
319 hn->type = TAG_FREE;
320 hn->flgs = 0;
321 PPUTLEFT( hn, ELEMENT_NODE, hn + 1 );
322 }
323 PPUTLEFT( &hb->node[hb->sz - 1], ELEMENT_NODE, NULL );
324 }
325
326 /* Add another HeapBlock, if we can.
327 */
328 static gboolean
heapblock_create(Heap * heap,int sz)329 heapblock_create( Heap *heap, int sz )
330 {
331 HeapBlock *hb;
332
333 if( heap->nb > heap->mxb ) {
334 heap->mxb = 1 + (heap->max_fn( heap ) / heap->rsz);
335 if( heap->nb > heap->mxb )
336 /* Hit limit ... caller detects full by ->free becomng
337 * NULL.
338 */
339 return( TRUE );
340 }
341
342 #ifdef DEBUG
343 printf( "heapblock_create: new block, size %d\n", sz );
344 #endif /*DEBUG*/
345
346 if( !(hb = INEW( NULL, HeapBlock )) )
347 return( FALSE );
348 hb->heap = heap;
349 hb->next = NULL;
350 hb->node = NULL;
351 hb->sz = sz;
352
353 if( !(hb->node = IARRAY( NULL, sz, HeapNode )) ) {
354 heapblock_free( hb );
355 return( FALSE );
356 }
357 heapblock_empty( hb );
358
359 /* Link to existing blocks.
360 */
361 hb->next = heap->hb;
362 heap->hb = hb;
363 PPUTLEFT( &hb->node[hb->sz - 1], ELEMENT_NODE, heap->free );
364 heap->free = &hb->node[0];
365 heap->nb++;
366
367 return( TRUE );
368 }
369
370 static void
heap_class_init(HeapClass * class)371 heap_class_init( HeapClass *class )
372 {
373 GObjectClass *gobject_class = G_OBJECT_CLASS( class );
374 iObjectClass *iobject_class = IOBJECT_CLASS( class );
375
376 parent_class = g_type_class_peek_parent( class );
377
378 gobject_class->dispose = heap_dispose;
379 gobject_class->finalize = heap_finalize;
380
381 iobject_class->info = heap_info;
382 }
383
384 static void
heap_init(Heap * heap)385 heap_init( Heap *heap )
386 {
387 heap->compile = NULL;
388
389 heap->max_fn = NULL;
390 heap->mxb = -1;
391 heap->rsz = 0;
392 heap->nb = 0;
393 heap->hb = NULL;
394 heap->free = NULL;
395
396 heap->ncells = 0;
397 heap->nfree = 0;
398 heap->serial = 0;
399 heap->filled = FALSE;
400
401 heap->emark = g_hash_table_new( NULL, g_direct_equal );
402 heap->rmark = g_hash_table_new( NULL, g_direct_equal );
403 heap->mtable = g_hash_table_new( NULL, g_direct_equal );
404
405 heap->gc_tid = 0;
406
407 heap->flush = FALSE;
408
409 heap_all = g_slist_prepend( heap_all, heap );
410 }
411
412 GType
heap_get_type(void)413 heap_get_type( void )
414 {
415 static GType type = 0;
416
417 if( !type ) {
418 static const GTypeInfo info = {
419 sizeof( HeapClass ),
420 NULL, /* base_init */
421 NULL, /* base_finalize */
422 (GClassInitFunc) heap_class_init,
423 NULL, /* class_finalize */
424 NULL, /* class_data */
425 sizeof( Heap ),
426 32, /* n_preallocs */
427 (GInstanceInitFunc) heap_init,
428 };
429
430 type = g_type_register_static( TYPE_IOBJECT,
431 "Heap", &info, 0 );
432 }
433
434 return( type );
435 }
436
437 static void
heap_link(Heap * heap,Compile * compile,heap_max_fn max_fn,int stsz,int rsz)438 heap_link( Heap *heap, Compile *compile, heap_max_fn max_fn, int stsz, int rsz )
439 {
440 heap->compile = compile;
441 heap->max_fn = max_fn;
442 heap->rsz = rsz;
443
444 (void) heapblock_create( heap, stsz );
445
446 if( compile )
447 iobject_set( IOBJECT( heap ),
448 IOBJECT( compile->sym )->name, NULL );
449
450 /* Can now set max blocks.
451 */
452 heap->mxb = 1 + (heap->max_fn( heap ) / rsz);
453 }
454
455 /* Create an empty heap. mxsz is maximum size of heap in units of nodes,
456 * stsz is start size, rsz is heap growth unit.
457 */
458 Heap *
heap_new(Compile * compile,heap_max_fn max_fn,int stsz,int rsz)459 heap_new( Compile *compile, heap_max_fn max_fn, int stsz, int rsz )
460 {
461 Heap *heap;
462
463 heap = HEAP( g_object_new( TYPE_HEAP, NULL ) );
464 heap_link( heap, compile, max_fn, stsz, rsz );
465
466 return( heap );
467 }
468
469 /* Set flags on a heap.
470 */
471 void
heap_set(Heap * heap,NodeFlags setmask)472 heap_set( Heap *heap, NodeFlags setmask )
473 {
474 HeapBlock *hb;
475 int i;
476
477 for( hb = heap->hb; hb; hb = hb->next )
478 for( i = 0; i < hb->sz; i++ )
479 hb->node[i].flgs |= setmask;
480 }
481
482 /* Clear flags on a heap.
483 */
484 void
heap_clear(Heap * heap,NodeFlags clearmask)485 heap_clear( Heap *heap, NodeFlags clearmask )
486 {
487 HeapBlock *hb;
488 int i;
489 int cmask = clearmask ^ FLAG_ALL;
490
491 for( hb = heap->hb; hb; hb = hb->next )
492 for( i = 0; i < hb->sz; i++ )
493 hb->node[i].flgs &= cmask;
494 }
495
496 /* Allocate a new serial number for a heap. On return, we guarantee that
497 * heap->serial is a value not used by any nodes in the heap.
498 */
499 int
heap_serial_new(Heap * heap)500 heap_serial_new( Heap *heap )
501 {
502 heap->serial += 1;
503 if( heap->serial > FLAG_SERIAL ) {
504 heap->serial = 1;
505 heap_clear( heap, FLAG_SERIAL );
506 }
507
508 return( heap->serial );
509 }
510
511 /* Mark a tree. Avoid recursion because of the danger of C stack overflow on
512 * large heaps.
513 */
514 static void
heap_mark_tree(Heap * heap,HeapNode * hn)515 heap_mark_tree( Heap *heap, HeapNode *hn )
516 {
517 GSList *pending = NULL;
518
519 pending = g_slist_prepend( pending, hn );
520
521 while( pending ) {
522 hn = (HeapNode *) pending->data;
523 pending = g_slist_remove( pending, hn );
524
525 /* Chase down the LHS of the nodes, add the RHS nodes we pass
526 * to the pending list.
527 */
528 for(;;) {
529 if( hn->flgs & FLAG_MARK )
530 break;
531
532 hn->flgs |= FLAG_MARK;
533
534 /* Don't modify hn for the do-nothing case: we'll
535 * break on the next loop.
536 */
537 switch( hn->type ) {
538 case TAG_GEN:
539 case TAG_COMPLEX:
540 case TAG_CLASS:
541 case TAG_APPL:
542 case TAG_CONS:
543 if( GETRT( hn ) == ELEMENT_MANAGED )
544 managed_mark( (Managed *)
545 GETRIGHT( hn ) );
546 if( GETLT( hn ) == ELEMENT_MANAGED )
547 managed_mark( (Managed *)
548 GETLEFT( hn ) );
549
550 if( GETRT( hn ) == ELEMENT_NODE ) {
551 if( GETLT( hn ) == ELEMENT_NODE ) {
552 pending = g_slist_prepend(
553 pending,
554 GETRIGHT( hn ) );
555 hn = GETLEFT( hn );
556 }
557 else
558 hn = GETRIGHT( hn );
559 }
560 else if( GETLT( hn ) == ELEMENT_NODE )
561 hn = GETLEFT( hn );
562
563 break;
564
565 case TAG_FILE:
566 g_assert( GETLT( hn ) == ELEMENT_MANAGED );
567 managed_mark( (Managed *) GETLEFT( hn ) );
568 break;
569
570 case TAG_DOUBLE:
571 break;
572
573 case TAG_SHARED:
574 case TAG_REFERENCE:
575 if( GETLT( hn ) == ELEMENT_NODE )
576 hn = GETLEFT( hn );
577 break;
578
579 case TAG_FREE:
580 default:
581 g_assert( FALSE );
582 }
583 }
584 }
585 }
586
587 /* Mark an element.
588 */
589 static void *
mark_pelement(PElement * base,Heap * heap)590 mark_pelement( PElement *base, Heap *heap )
591 {
592 if( PEISMANAGED( base ) )
593 managed_mark( MANAGED( PEGETVAL( base ) ) );
594 else if( PEISNODE( base ) )
595 heap_mark_tree( heap, PEGETVAL( base ) );
596
597 return( NULL );
598 }
599
600 /* Mark an element.
601 */
602 static void
mark_element(void * key,void * value,Heap * heap)603 mark_element( void *key, void *value, Heap *heap )
604 {
605 Element *root = (Element *) value;
606 PElement base;
607
608 PEPOINTE( &base, root );
609 (void) mark_pelement( &base, heap );
610 }
611
612 /* Mark a reduce context ... the heapnodes on the spine stack etc.
613 */
614 static void *
mark_reduce(void * key,void * value,Heap * heap)615 mark_reduce( void *key, void *value, Heap *heap )
616 {
617 Reduce *rc = (Reduce *) value;
618 int i;
619
620 #ifdef DEBUG
621 printf( "mark_reduce: marking %d stack elements\n", rc->sp );
622 #endif /*DEBUG*/
623
624 for( i = 0; i < rc->sp; i++ )
625 heap_mark_tree( heap, rc->nstack[i] );
626
627 return( NULL );
628 }
629
630 /* Do a garbage collect.
631 */
632 gboolean
heap_gc(Heap * heap)633 heap_gc( Heap *heap )
634 {
635 HeapBlock *hb;
636 int nfree;
637 int ncells;
638 int nblocks;
639
640 #ifdef DEBUG_GC_TIME
641 static GTimer *GC_timer = NULL;
642
643 if( !GC_timer )
644 GC_timer = g_timer_new();
645
646 g_timer_reset( GC_timer );
647
648 printf( "heap_gc: starting GC for heap %s\n", IOBJECT( heap )->name );
649 #endif /*DEBUG_GC_TIME*/
650
651 /* Clear marks on managed objects. Nodes should all be clear already.
652 */
653 managed_clear( heap );
654
655 /* All flags should be clear, so just mark.
656 */
657 g_hash_table_foreach( heap->emark, (GHFunc) mark_element, heap );
658 g_hash_table_foreach( heap->rmark, (GHFunc) mark_reduce, heap );
659
660 /* And sweep up unmarked into new free list.
661 */
662 heap->free = NULL;
663 ncells = nfree = nblocks = 0;
664 for( hb = heap->hb; hb; hb = hb->next ) {
665 const int sz = hb->sz;
666 int i;
667
668 for( i = 0; i < sz; i++ ) {
669 HeapNode * const hn = &hb->node[i];
670
671 if( !(hn->flgs & FLAG_MARK) ) {
672 hn->type = TAG_FREE;
673 PPUTLEFT( hn, ELEMENT_NODE, heap->free );
674 #ifdef DEBUG_HEAP_GC
675 /* Not necessary, but may be helpful to zap
676 * any pointer in there.
677 */
678 PPUTRIGHT( hn, ELEMENT_NODE, NULL );
679 #endif /*DEBUG_HEAP_GC*/
680 heap->free = hn;
681 nfree += 1;
682 }
683
684 hn->flgs &= FLAG_MARK ^ FLAG_ALL;
685 }
686
687 ncells += hb->sz;
688 nblocks += 1;
689 }
690 heap->ncells = ncells;
691 heap->nfree = nfree;
692
693 /* Close unused managed objects. It can (potentially) take a couple of
694 * passes through mtable to free everything ... but we'll do more on
695 * the next GC.
696 */
697 managed_free_unused( heap );
698
699 #ifdef DEBUG_GC_TIME
700 printf( "heap_gc: %d cells in %d blocks, %d in use\n",
701 ncells, nblocks, ncells - nfree );
702 printf( "(GC took %gs)\n", g_timer_elapsed( GC_timer, NULL ) );
703 #endif /*DEBUG_GC_TIME*/
704
705 return( TRUE );
706 }
707
708 static gint
heap_gc_request_cb(Heap * heap)709 heap_gc_request_cb( Heap *heap )
710 {
711 heap->gc_tid = 0;
712
713 if( !heap_gc( heap ) )
714 printf( "help! delayed GC failed!\n" );
715
716 iobject_changed( IOBJECT( heap ) );
717
718 return( FALSE );
719 }
720
721 /* Request a delayed garbage collect.
722 */
723 void
heap_gc_request(Heap * heap)724 heap_gc_request( Heap *heap )
725 {
726 IM_FREEF( g_source_remove, heap->gc_tid );
727 heap->gc_tid = g_timeout_add( 1000,
728 (GSourceFunc) heap_gc_request_cb, heap );
729 }
730
731 /* Register a pointer into a heap.
732 */
733 void
heap_register_element(Heap * heap,Element * root)734 heap_register_element( Heap *heap, Element *root )
735 {
736 g_hash_table_insert( heap->emark, root, root );
737 }
738
739 /* Unregister a pointer into a heap.
740 */
741 void
heap_unregister_element(Heap * heap,Element * root)742 heap_unregister_element( Heap *heap, Element *root )
743 {
744 if( g_hash_table_remove( heap->emark, root ) ) {
745 #ifdef DEBUG
746 printf( "heap_unregister_element: %d pointers\n",
747 g_hash_table_size( heap->emark ) );
748 #endif
749 }
750 }
751
752 /* Register a Reduce working on this heap.
753 */
754 void
heap_register_reduce(Heap * heap,Reduce * rc)755 heap_register_reduce( Heap *heap, Reduce *rc )
756 {
757 g_hash_table_insert( heap->rmark, rc, rc );
758 }
759
760 /* Unregister a reduce context.
761 */
762 void
heap_unregister_reduce(Heap * heap,Reduce * rc)763 heap_unregister_reduce( Heap *heap, Reduce *rc )
764 {
765 g_hash_table_remove( heap->rmark, rc );
766 }
767
768 /* Allocate a new HeapNode ... long version. See NEWNODE() macro.
769 */
770 HeapNode *
heap_getmem(Heap * heap)771 heap_getmem( Heap *heap )
772 {
773 HeapNode *hn;
774 int pcused;
775 #ifdef DEBUG_GETMEM
776 static int n_heap_getmem = 0;
777 #endif /*DEBUG_GETMEM*/
778
779 /* Easy case ... this should be handled by the NEWNODE macro, but do
780 * it here as well just in case.
781 */
782 if( heap->free ) {
783 (void) EXTRACTNODE( heap, hn );
784 return( hn );
785 }
786
787 #ifdef DEBUG
788 printf( "heap_getmem: GC on full heap for heap %s\n",
789 IOBJECT( heap )->name );
790 #endif /*DEBUG*/
791
792 /* Try a GC.
793 */
794 if( !heap_gc( heap ) )
795 return( NULL );
796
797 /* Is heap over x% full? Add another heap block if we can.
798 */
799 pcused = 100 * (heap->ncells - heap->nfree) / heap->ncells;
800 #ifdef DEBUG_GETMEM
801 n_heap_getmem += 1;
802 printf( "heap_getmem: %d%% (%d)\n", pcused, n_heap_getmem );
803 #endif /*DEBUG_GETMEM*/
804
805 if( pcused > 50 ) {
806 int nblocks = 1 + (heap->ncells - heap->nfree) / heap->rsz;
807 int i;
808
809 #ifdef DEBUG_GETMEM
810 printf( "heap_getmem: %d more blocks added\n", nblocks );
811 #endif /*DEBUG_GETMEM*/
812 for( i = 0; i < nblocks; i++ )
813 if( !heapblock_create( heap, heap->rsz ) )
814 return( NULL );
815 }
816
817 if( !heap->free ) {
818 error_top( _( "Heap full." ) );
819 if( heap->compile ) {
820 char txt[100];
821 VipsBuf buf = VIPS_BUF_STATIC( txt );
822
823 compile_name( heap->compile, &buf );
824 error_sub( _( "The compile heap for %s has filled. "
825 "Make it smaller and less complicated." ),
826 vips_buf_all( &buf ) );
827 }
828 else
829 error_sub( _( "The main calculation heap has filled. "
830 "Raise the heap size limit in Preferences." ) );
831 heap->filled = TRUE;
832 return( NULL );
833 }
834
835 (void) EXTRACTNODE( heap, hn );
836
837 return( hn );
838 }
839
840 gboolean
heap_bool_new(Heap * heap,gboolean val,PElement * out)841 heap_bool_new( Heap *heap, gboolean val, PElement *out )
842 {
843 PEPUTP( out, ELEMENT_BOOL, val );
844
845 return( TRUE );
846 }
847
848 /* Write a real to an element.
849 */
850 gboolean
heap_real_new(Heap * heap,double in,PElement * out)851 heap_real_new( Heap *heap, double in, PElement *out )
852 {
853 HeapNode *hn;
854
855 if( NEWNODE( heap, hn ) )
856 return( FALSE );
857 hn->type = TAG_DOUBLE;
858 hn->body.num = in;
859
860 PEPUTP( out, ELEMENT_NODE, hn );
861
862 return( TRUE );
863 }
864
865 /* Write an element to an element.
866 */
867 gboolean
heap_element_new(Heap * heap,Element * e,PElement * out)868 heap_element_new( Heap *heap, Element *e, PElement *out )
869 {
870 PEPUTE( out, e );
871
872 return( TRUE );
873 }
874
875 /* Make a complex node from two elements.
876 */
877 gboolean
heap_complex_element_new(Heap * heap,PElement * rp,PElement * ip,PElement * out)878 heap_complex_element_new( Heap *heap,
879 PElement *rp, PElement *ip, PElement *out )
880 {
881 HeapNode *hn;
882
883 if( NEWNODE( heap, hn ) )
884 return( FALSE );
885 hn->type = TAG_COMPLEX;
886 PPUT( hn, PEGETTYPE( rp ), PEGETVAL( rp ),
887 PEGETTYPE( ip ), PEGETVAL( ip ) );
888
889 PEPUTP( out, ELEMENT_NODE, hn );
890
891 return( TRUE );
892 }
893
894 /* Make a complex node.
895 */
896 gboolean
heap_complex_new(Heap * heap,double rp,double ip,PElement * out)897 heap_complex_new( Heap *heap, double rp, double ip, PElement *out )
898 {
899 Element dummy;
900 PElement t;
901
902 /* Form complex node.
903 */
904 dummy.type = ELEMENT_NOVAL;
905 dummy.ele = (void *) 6;
906 PEPOINTE( &t, &dummy );
907 if( !heap_complex_element_new( heap, &t, &t, out ) )
908 return( FALSE );
909
910 /* Install real and imag parts.
911 */
912 PEPOINTLEFT( PEGETVAL( out ), &t );
913 if( !heap_real_new( heap, rp, &t ) )
914 return( FALSE );
915 PEPOINTRIGHT( PEGETVAL( out ), &t );
916 if( !heap_real_new( heap, ip, &t ) )
917 return( FALSE );
918
919 return( TRUE );
920 }
921
922 /* 'get' a list: move the PE to point at the list.
923 */
924 gboolean
heap_get_list(PElement * list)925 heap_get_list( PElement *list )
926 {
927 g_assert( PEISLIST( list ) );
928
929 if( PEISMANAGEDSTRING( list ) ) {
930 if( !managedstring_get( PEGETMANAGEDSTRING( list ), list ) )
931 return( FALSE );
932 }
933
934 return( TRUE );
935 }
936
937 /* Set list to [].
938 */
939 void
heap_list_init(PElement * list)940 heap_list_init( PElement *list )
941 {
942 PEPUTP( list, ELEMENT_ELIST, NULL );
943 }
944
945 /* Add new node to list, point data at new CONS LHS.
946 */
947 gboolean
heap_list_add(Heap * heap,PElement * list,PElement * data)948 heap_list_add( Heap *heap, PElement *list, PElement *data )
949 {
950 HeapNode *hn;
951
952 /* Build CONS node.
953 */
954 if( NEWNODE( heap, hn ) )
955 return( FALSE );
956 hn->type = TAG_CONS;
957 PPUTLEFT( hn, ELEMENT_NOVAL, (void *) 7 );
958 PEPUTRIGHT( hn, list );
959 PEPUTP( list, ELEMENT_NODE, hn );
960
961 /* Point data to new LHS.
962 */
963 PEPOINTLEFT( hn, data );
964
965 return( TRUE );
966 }
967
968 /* Move list on to the next RHS. list points at [], or pointer to next node.
969 * Used with heap_list_init()/heap_list_add() to build lists.
970 */
971 gboolean
heap_list_next(PElement * list)972 heap_list_next( PElement *list )
973 {
974 HeapNode *hn = PEGETVAL( list );
975
976 if( hn ) {
977 PEPOINTRIGHT( hn, list );
978 return( TRUE );
979 }
980 else
981 return( FALSE );
982 }
983
984 gboolean
heap_list_cat(Reduce * rc,PElement * a,PElement * b,PElement * out)985 heap_list_cat( Reduce *rc, PElement *a, PElement *b, PElement *out )
986 {
987 PElement list = *out;
988
989 REDUCE_CATCH_START( FALSE );
990 reduce_clone_list( rc, a, &list );
991 PEPUTPE( &list, b );
992 REDUCE_CATCH_STOP;
993
994 return( TRUE );
995 }
996
997 /* Start off a function application.
998 */
999 void
heap_appl_init(PElement * base,PElement * func)1000 heap_appl_init( PElement *base, PElement *func )
1001 {
1002 PEPUTPE( base, func );
1003 }
1004
1005 /* Add a new parameter to a function application. base points at the
1006 * function built so far ... update base to point to new node (old base
1007 * becomes LHS), return parm pointing to new RHS
1008 */
1009 gboolean
heap_appl_add(Heap * heap,PElement * base,PElement * parm)1010 heap_appl_add( Heap *heap, PElement *base, PElement *parm )
1011 {
1012 HeapNode *hn;
1013
1014 /* Build appl node.
1015 */
1016 if( NEWNODE( heap, hn ) )
1017 return( FALSE );
1018 hn->type = TAG_APPL;
1019 PEPUTLEFT( hn, base );
1020 PPUTRIGHT( hn, ELEMENT_ELIST, NULL );
1021 PEPUTP( base, ELEMENT_NODE, hn );
1022
1023 /* Point parm to new RHS.
1024 */
1025 PEPOINTRIGHT( hn, parm );
1026
1027 return( TRUE );
1028 }
1029
1030 /* Make a lazy file read node.
1031 */
1032 gboolean
heap_file_new(Heap * heap,const char * filename,PElement * out)1033 heap_file_new( Heap *heap, const char *filename, PElement *out )
1034 {
1035 Managedfile *managedfile;
1036 HeapNode *hn;
1037
1038 if( !(managedfile = managedfile_new( heap, filename )) )
1039 return( FALSE );
1040
1041 /* Make sure the managedfile survives a GC.
1042 */
1043 MANAGED_REF( managedfile );
1044
1045 if( NEWNODE( heap, hn ) ) {
1046 MANAGED_UNREF( managedfile );
1047 return( FALSE );
1048 }
1049 hn->type = TAG_FILE;
1050 PPUT( hn,
1051 ELEMENT_MANAGED, managedfile,
1052 ELEMENT_ELIST, NULL );
1053 PEPUTP( out, ELEMENT_NODE, hn );
1054
1055 MANAGED_UNREF( managedfile );
1056
1057 return( TRUE );
1058 }
1059
1060 /* Make a heap string.
1061 */
1062 gboolean
heap_string_new(Heap * heap,const char * str,PElement * out)1063 heap_string_new( Heap *heap, const char *str, PElement *out )
1064 {
1065 PElement list = *out;
1066 const int n = strlen( str );
1067 int i;
1068
1069 heap_list_init( &list );
1070
1071 for( i = 0; i < n; i++ ) {
1072 PElement t;
1073
1074 if( !heap_list_add( heap, &list, &t ) )
1075 return( FALSE );
1076 PEPUTP( &t, ELEMENT_CHAR, (int) str[i] );
1077 (void) heap_list_next( &list );
1078 }
1079
1080 return( TRUE );
1081 }
1082
1083 /* Make a managed string.
1084 */
1085 gboolean
heap_managedstring_new(Heap * heap,const char * str,PElement * out)1086 heap_managedstring_new( Heap *heap, const char *str, PElement *out )
1087 {
1088 Managedstring *managedstring;
1089
1090 if( strcmp( str, "" ) == 0 ) {
1091 PEPUTP( out, ELEMENT_ELIST, NULL );
1092 }
1093 else {
1094 if( !(managedstring = managedstring_find( heap, str )) )
1095 return( FALSE );
1096 PEPUTP( out, ELEMENT_MANAGED, managedstring );
1097 }
1098
1099 return( TRUE );
1100 }
1101
1102 /* Make a [[char]].
1103 */
1104 gboolean
heap_lstring_new(Heap * heap,GSList * labels,PElement * out)1105 heap_lstring_new( Heap *heap, GSList *labels, PElement *out )
1106 {
1107 PElement list = *out;
1108 const int n = g_slist_length( labels );
1109 int i;
1110
1111 /* Make first RHS ... the end of the list.
1112 */
1113 heap_list_init( &list );
1114
1115 /* Build a CONS node for each element.
1116 */
1117 for( i = 0; i < n; i++ ) {
1118 PElement t;
1119
1120 if( !heap_list_add( heap, &list, &t ) ||
1121 !heap_managedstring_new( heap,
1122 g_slist_nth_data( labels, i ), &t ) )
1123 return( FALSE );
1124 (void) heap_list_next( &list );
1125 }
1126
1127 return( TRUE );
1128
1129 }
1130
1131 /* Make a realvec.
1132 */
1133 gboolean
heap_realvec_new(Heap * heap,int n,double * vec,PElement * out)1134 heap_realvec_new( Heap *heap, int n, double *vec, PElement *out )
1135 {
1136 PElement list = *out;
1137 int i;
1138
1139 /* Make first RHS ... the end of the list.
1140 */
1141 heap_list_init( &list );
1142
1143 /* Build a CONS node for each element.
1144 */
1145 for( i = 0; i < n; i++ ) {
1146 PElement t;
1147
1148 if( !heap_list_add( heap, &list, &t ) )
1149 return( FALSE );
1150 if( !heap_real_new( heap, vec[i], &t ) )
1151 return( FALSE );
1152 (void) heap_list_next( &list );
1153 }
1154
1155 return( TRUE );
1156 }
1157
1158 /* Make a realvec, but from an int*.
1159 */
1160 gboolean
heap_intvec_new(Heap * heap,int n,int * vec,PElement * out)1161 heap_intvec_new( Heap *heap, int n, int *vec, PElement *out )
1162 {
1163 PElement list = *out;
1164 int i;
1165
1166 /* Make first RHS ... the end of the list.
1167 */
1168 heap_list_init( &list );
1169
1170 /* Build a CONS node for each element.
1171 */
1172 for( i = 0; i < n; i++ ) {
1173 PElement t;
1174
1175 if( !heap_list_add( heap, &list, &t ) )
1176 return( FALSE );
1177 if( !heap_real_new( heap, (double) vec[i], &t ) )
1178 return( FALSE );
1179 (void) heap_list_next( &list );
1180 }
1181
1182 return( TRUE );
1183 }
1184
1185 /* Make a matrix.
1186 */
1187 gboolean
heap_matrix_new(Heap * heap,int xsize,int ysize,double * vec,PElement * out)1188 heap_matrix_new( Heap *heap,
1189 int xsize, int ysize, double *vec, PElement *out )
1190 {
1191 PElement list = *out;
1192 int y, i;
1193
1194 /* Make first RHS ... the end of the list.
1195 */
1196 heap_list_init( &list );
1197
1198 /* Build a CONS node for each element.
1199 */
1200 for( i = 0, y = 0; y < ysize; y++ ) {
1201 PElement t;
1202
1203 if( !heap_list_add( heap, &list, &t ) )
1204 return( FALSE );
1205 if( !heap_realvec_new( heap, xsize, vec + i, &t ) )
1206 return( FALSE );
1207 i += xsize;
1208 (void) heap_list_next( &list );
1209 }
1210
1211 return( TRUE );
1212 }
1213
1214 /* Make a typecheck error. Always return FALSE ... the gboolean is just there
1215 * for REDUCE_CATCH.
1216 */
1217 gboolean
heap_error_typecheck(PElement * e,const char * name,const char * type)1218 heap_error_typecheck( PElement *e, const char *name, const char *type )
1219 {
1220 Reduce *rc = reduce_context;
1221
1222 REDUCE_CATCH_START( FALSE );
1223 (void) reduce_error_typecheck( reduce_context, e, name, type );
1224 REDUCE_CATCH_STOP;
1225
1226 return( FALSE );
1227 }
1228
1229 /* Map over a heap list. Reduce the list spine as we go, don't reduce the
1230 * heads. Return base on error, or whatever the user function returns (unlike
1231 * reduce_map_list(), which we can't just wrap).
1232 */
1233 void *
heap_map_list(PElement * base,heap_map_list_fn fn,void * a,void * b)1234 heap_map_list( PElement *base, heap_map_list_fn fn, void *a, void *b )
1235 {
1236 Reduce *rc = reduce_context;
1237 PElement e = *base;
1238
1239 if( !reduce_pelement( rc, reduce_spine, &e ) )
1240 return( base );
1241
1242 if( !PEISLIST( &e ) ) {
1243 heap_error_typecheck( &e, "heap_map_list", "[*]" );
1244 return( base );
1245 }
1246
1247 while( PEISFLIST( &e ) ) {
1248 PElement head;
1249 void *res;
1250
1251 if( !heap_get_list( &e ) )
1252 return( base );
1253
1254 /* Apply user function to the head.
1255 */
1256 PEGETHD( &head, &e );
1257 if( (res = fn( &head, a, b )) )
1258 return( res );
1259
1260 /* Reduce the tail.
1261 */
1262 PEGETTL( &e, &e );
1263 if( !reduce_pelement( rc, reduce_spine, &e ) )
1264 return( base );
1265 }
1266
1267 return( NULL );
1268 }
1269
1270 /* Iterate over a list. Move list on to the next tl, point data at the
1271 * head of the current node, FALSE for [].
1272 */
1273 gboolean
heap_get_list_next(PElement * list,PElement * data)1274 heap_get_list_next( PElement *list, PElement *data )
1275 {
1276 Reduce *rc = reduce_context;
1277
1278 if( !reduce_pelement( rc, reduce_spine, list ) )
1279 return( FALSE );
1280
1281 if( PEISFLIST( list ) ) {
1282 HeapNode *hn;
1283
1284 if( !heap_get_list( list ) )
1285 return( FALSE );
1286
1287 hn = PEGETVAL( list );
1288
1289 PEPOINTRIGHT( hn, list );
1290 PEPOINTLEFT( hn, data );
1291
1292 return( TRUE );
1293 }
1294 else
1295 return( FALSE );
1296 }
1297
1298 typedef struct _HeapMapDict {
1299 heap_map_dict_fn fn;
1300 void *a;
1301 void *b;
1302 } HeapMapDict;
1303
1304 static void *
heap_map_dict_entry(PElement * head,HeapMapDict * map_dict)1305 heap_map_dict_entry( PElement *head, HeapMapDict *map_dict )
1306 {
1307 Reduce *rc = reduce_context;
1308 char key[256];
1309 PElement p1, p2;
1310 void *result;
1311
1312 if( !reduce_pelement( rc, reduce_spine, head ) )
1313 return( head );
1314 if( !PEISFLIST( head ) ) {
1315 heap_error_typecheck( head, "heap_map_dict", "[*]" );
1316 return( head );
1317 }
1318 if( !heap_get_list( head ) )
1319 return( head );
1320 PEGETHD( &p1, head );
1321 if( !heap_get_string( &p1, key, 256 ) )
1322 return( head );
1323
1324 PEGETTL( &p2, head );
1325 if( !reduce_pelement( rc, reduce_spine, &p2 ) )
1326 return( head );
1327 if( !PEISFLIST( &p2 ) ) {
1328 heap_error_typecheck( &p2, "heap_map_dict", "[*]" );
1329 return( head );
1330 }
1331 if( !heap_get_list( &p2 ) )
1332 return( head );
1333 PEGETHD( &p1, &p2 );
1334 if( (result = map_dict->fn( key, &p1, map_dict->a, map_dict->b )) )
1335 return( result );
1336
1337 PEGETTL( &p1, &p2 );
1338 if( !reduce_pelement( rc, reduce_spine, &p1 ) )
1339 return( head );
1340 if( !PEISELIST( &p1 ) ) {
1341 heap_error_typecheck( &p1, "heap_map_dict", "[]" );
1342 return( head );
1343 }
1344
1345 return( NULL );
1346 }
1347
1348 /* Map over a list of ["key", value] pairs.
1349 */
1350 void *
heap_map_dict(PElement * base,heap_map_dict_fn fn,void * a,void * b)1351 heap_map_dict( PElement *base, heap_map_dict_fn fn, void *a, void *b )
1352 {
1353 HeapMapDict map_dict;
1354
1355 map_dict.fn = fn;
1356 map_dict.a = a;
1357 map_dict.b = b;
1358
1359 return( heap_map_list( base,
1360 (heap_map_list_fn) heap_map_dict_entry, &map_dict, NULL ) );
1361 }
1362
1363 /* Evaluate a PElement into a string buffer.
1364 */
1365 gboolean
heap_get_string(PElement * base,char * buf,int n)1366 heap_get_string( PElement *base, char *buf, int n )
1367 {
1368 Reduce *rc = reduce_context;
1369
1370 REDUCE_CATCH_START( FALSE );
1371 (void) reduce_get_string( reduce_context, base, buf, n );
1372 REDUCE_CATCH_STOP;
1373
1374 return( TRUE );
1375 }
1376
1377 /* Evaluate a PElement to a [[char]].
1378 */
1379 gboolean
heap_get_lstring(PElement * base,GSList ** labels)1380 heap_get_lstring( PElement *base, GSList **labels )
1381 {
1382 Reduce *rc = reduce_context;
1383
1384 REDUCE_CATCH_START( FALSE );
1385 (void) reduce_get_lstring( reduce_context, base, labels );
1386 REDUCE_CATCH_STOP;
1387
1388 return( TRUE );
1389 }
1390
1391 /* Get an element as a bool.
1392 */
1393 gboolean
heap_get_bool(PElement * base,gboolean * out)1394 heap_get_bool( PElement *base, gboolean *out )
1395 {
1396 Reduce *rc = reduce_context;
1397
1398 REDUCE_CATCH_START( FALSE );
1399 *out = reduce_get_bool( reduce_context, base );
1400 REDUCE_CATCH_STOP;
1401
1402 return( TRUE );
1403 }
1404
1405 /* Get an element as a real.
1406 */
1407 gboolean
heap_get_real(PElement * base,double * out)1408 heap_get_real( PElement *base, double *out )
1409 {
1410 Reduce *rc = reduce_context;
1411
1412 REDUCE_CATCH_START( FALSE );
1413 *out = reduce_get_real( reduce_context, base );
1414 REDUCE_CATCH_STOP;
1415
1416 return( TRUE );
1417 }
1418
1419 /* Get an element as a class ... just reduce and typecheck.
1420 */
1421 gboolean
heap_get_class(PElement * base,PElement * out)1422 heap_get_class( PElement *base, PElement *out )
1423 {
1424 Reduce *rc = reduce_context;
1425
1426 REDUCE_CATCH_START( FALSE );
1427 reduce_get_class( reduce_context, base );
1428 REDUCE_CATCH_STOP;
1429
1430 /* Point out at base ... for consistency with other getters.
1431 */
1432 *out = *base;
1433
1434 return( TRUE );
1435 }
1436
1437 /* Get an element as an image.
1438 */
1439 gboolean
heap_get_image(PElement * base,Imageinfo ** out)1440 heap_get_image( PElement *base, Imageinfo **out )
1441 {
1442 Reduce *rc = reduce_context;
1443
1444 REDUCE_CATCH_START( FALSE );
1445 *out = reduce_get_image( reduce_context, base );
1446 REDUCE_CATCH_STOP;
1447
1448 return( TRUE );
1449 }
1450
1451 /* Get an element as a realvec. Return -1 on error, or length of vector.
1452 */
1453 int
heap_get_realvec(PElement * base,double * buf,int n)1454 heap_get_realvec( PElement *base, double *buf, int n )
1455 {
1456 Reduce *rc = reduce_context;
1457 int l;
1458
1459 REDUCE_CATCH_START( -1 );
1460 l = reduce_get_realvec( reduce_context, base, buf, n );
1461 REDUCE_CATCH_STOP;
1462
1463 return( l );
1464 }
1465
1466 /* Get an element as a imagevec. Return -1 on error, or length of vector.
1467 */
1468 int
heap_get_imagevec(PElement * base,Imageinfo ** buf,int n)1469 heap_get_imagevec( PElement *base, Imageinfo **buf, int n )
1470 {
1471 Reduce *rc = reduce_context;
1472 int l;
1473
1474 REDUCE_CATCH_START( -1 );
1475 l = reduce_get_imagevec( reduce_context, base, buf, n );
1476 REDUCE_CATCH_STOP;
1477
1478 return( l );
1479 }
1480
1481 /* Get an element as a matrix. Return -1 on error, or length of buffer used.
1482 * Write xsize/ysize to args.
1483 */
1484 gboolean
heap_get_matrix_size(PElement * base,int * xsize,int * ysize)1485 heap_get_matrix_size( PElement *base, int *xsize, int *ysize )
1486 {
1487 Reduce *rc = reduce_context;
1488
1489 REDUCE_CATCH_START( FALSE );
1490 (void) reduce_get_matrix_size( reduce_context, base, xsize, ysize );
1491 REDUCE_CATCH_STOP;
1492
1493 return( TRUE );
1494 }
1495
1496 /* Get an element as a matrix. Return -1 on error, or length of buffer used.
1497 * Write xsize/ysize to args.
1498 */
1499 gboolean
heap_get_matrix(PElement * base,double * buf,int n,int * xsize,int * ysize)1500 heap_get_matrix( PElement *base, double *buf, int n, int *xsize, int *ysize )
1501 {
1502 Reduce *rc = reduce_context;
1503
1504 REDUCE_CATCH_START( FALSE );
1505 (void) reduce_get_matrix( reduce_context, base, buf, n, xsize, ysize );
1506 REDUCE_CATCH_STOP;
1507
1508 return( TRUE );
1509 }
1510
1511 gboolean
heap_is_elist(PElement * base,gboolean * out)1512 heap_is_elist( PElement *base, gboolean *out )
1513 {
1514 Reduce *rc = reduce_context;
1515
1516 REDUCE_CATCH_START( FALSE );
1517 *out = reduce_is_elist( rc, base );
1518 REDUCE_CATCH_STOP;
1519
1520 return( TRUE );
1521 }
1522
1523 gboolean
heap_is_list(PElement * base,gboolean * out)1524 heap_is_list( PElement *base, gboolean *out )
1525 {
1526 Reduce *rc = reduce_context;
1527
1528 REDUCE_CATCH_START( FALSE );
1529 *out = reduce_is_list( rc, base );
1530 REDUCE_CATCH_STOP;
1531
1532 return( TRUE );
1533 }
1534
1535 /* Do a get, check it's OK. We don't get very much, in case it's a long
1536 * string and will take a while to eval.
1537 */
1538 gboolean
heap_is_string(PElement * base,gboolean * out)1539 heap_is_string( PElement *base, gboolean *out )
1540 {
1541 Reduce *rc = reduce_context;
1542
1543 REDUCE_CATCH_START( FALSE );
1544 *out = reduce_is_string( rc, base );
1545 REDUCE_CATCH_STOP;
1546
1547 return( TRUE );
1548 }
1549
1550 gboolean
heap_is_realvec(PElement * base,gboolean * out)1551 heap_is_realvec( PElement *base, gboolean *out )
1552 {
1553 Reduce *rc = reduce_context;
1554
1555 REDUCE_CATCH_START( FALSE );
1556 *out = reduce_is_realvec( rc, base );
1557 REDUCE_CATCH_STOP;
1558
1559 return( TRUE );
1560 }
1561
1562 gboolean
heap_is_imagevec(PElement * base,gboolean * out)1563 heap_is_imagevec( PElement *base, gboolean *out )
1564 {
1565 Reduce *rc = reduce_context;
1566
1567 REDUCE_CATCH_START( FALSE );
1568 *out = reduce_is_imagevec( rc, base );
1569 REDUCE_CATCH_STOP;
1570
1571 return( TRUE );
1572 }
1573
1574 gboolean
heap_is_matrix(PElement * base,gboolean * out)1575 heap_is_matrix( PElement *base, gboolean *out )
1576 {
1577 Reduce *rc = reduce_context;
1578
1579 REDUCE_CATCH_START( FALSE );
1580 *out = reduce_is_matrix( rc, base );
1581 REDUCE_CATCH_STOP;
1582
1583 return( TRUE );
1584 }
1585
1586 gboolean
heap_is_class(PElement * base,gboolean * out)1587 heap_is_class( PElement *base, gboolean *out )
1588 {
1589 Reduce *rc = reduce_context;
1590
1591 REDUCE_CATCH_START( FALSE );
1592 *out = reduce_is_class( rc, base );
1593 REDUCE_CATCH_STOP;
1594
1595 return( TRUE );
1596 }
1597
1598 gboolean
heap_is_instanceof_exact(const char * name,PElement * klass,gboolean * out)1599 heap_is_instanceof_exact( const char *name, PElement *klass, gboolean *out )
1600 {
1601 Reduce *rc = reduce_context;
1602
1603 REDUCE_CATCH_START( FALSE );
1604 *out = reduce_is_instanceof_exact( rc, name, klass );
1605 REDUCE_CATCH_STOP;
1606
1607 return( TRUE );
1608 }
1609
1610 gboolean
heap_is_instanceof(const char * name,PElement * klass,gboolean * out)1611 heap_is_instanceof( const char *name, PElement *klass, gboolean *out )
1612 {
1613 Reduce *rc = reduce_context;
1614
1615 REDUCE_CATCH_START( FALSE );
1616 *out = reduce_is_instanceof( rc, name, klass );
1617 REDUCE_CATCH_STOP;
1618
1619 return( TRUE );
1620 }
1621
1622 int
heap_list_length(PElement * base)1623 heap_list_length( PElement *base )
1624 {
1625 Reduce *rc = reduce_context;
1626 int result;
1627
1628 REDUCE_CATCH_START( -1 );
1629 result = reduce_list_length( rc, base );
1630 REDUCE_CATCH_STOP;
1631
1632 return( result );
1633 }
1634
1635 int
heap_list_length_max(PElement * base,int max_length)1636 heap_list_length_max( PElement *base, int max_length )
1637 {
1638 Reduce *rc = reduce_context;
1639 int result;
1640
1641 REDUCE_CATCH_START( -1 );
1642 result = reduce_list_length_max( rc, base, max_length );
1643 REDUCE_CATCH_STOP;
1644
1645 return( result );
1646 }
1647
1648 gboolean
heap_list_index(PElement * base,int n,PElement * out)1649 heap_list_index( PElement *base, int n, PElement *out )
1650 {
1651 Reduce *rc = reduce_context;
1652
1653 REDUCE_CATCH_START( FALSE );
1654 reduce_list_index( rc, base, n, out );
1655 REDUCE_CATCH_STOP;
1656
1657 return( TRUE );
1658 }
1659
1660 gboolean
heap_reduce_strict(PElement * base)1661 heap_reduce_strict( PElement *base )
1662 {
1663 Reduce *rc = reduce_context;
1664
1665 REDUCE_CATCH_START( FALSE );
1666 reduce_spine_strict( rc, base );
1667 REDUCE_CATCH_STOP;
1668
1669 return( TRUE );
1670 }
1671
1672 /* hn is a node in a compiled function, out is part of a node in reduce
1673 * space to which it should be copied.
1674 *
1675 * Have to be careful to copy sym pointers in nodes from compile heap.
1676 */
1677 static gboolean
copy_node(Heap * heap,HeapNode * ri[],HeapNode * hn,PElement * out)1678 copy_node( Heap *heap, HeapNode *ri[], HeapNode *hn, PElement *out )
1679 {
1680 HeapNode *hn1;
1681 PElement pleft, pright;
1682 int i;
1683
1684 /* Look for relocation nodes.
1685 */
1686 if( hn->type == TAG_SHARED ) {
1687 /* RHS of SHARE is the index of this share node.
1688 */
1689 i = GPOINTER_TO_INT( GETRIGHT( hn ) );
1690
1691 /* Skip to shared section.
1692 */
1693 hn = GETLEFT( hn );
1694
1695 /* Copy and link on this node.
1696 */
1697 if( NEWNODE( heap, hn1 ) )
1698 return( FALSE );
1699 *hn1 = *hn;
1700 PEPUTP( out, ELEMENT_NODE, hn1 );
1701
1702 /* Note pointer in relocation table.
1703 */
1704 ri[i] = hn1;
1705 }
1706 else if( hn->type == TAG_REFERENCE ) {
1707 /* Must have already copied this SHARE, just link back.
1708 */
1709 hn1 = GETLEFT( hn );
1710 i = GPOINTER_TO_INT( GETRIGHT( hn1 ) );
1711 PEPUTP( out, ELEMENT_NODE, ri[i] );
1712
1713 /* Done!
1714 */
1715 return( TRUE );
1716 }
1717 else {
1718 /* Copy and link on this node.
1719 */
1720 if( NEWNODE( heap, hn1 ) )
1721 return( FALSE );
1722 *hn1 = *hn;
1723 PEPUTP( out, ELEMENT_NODE, hn1 );
1724 }
1725
1726 /* If it's a DOUBLE, no more to do.
1727 */
1728 if( hn->type == TAG_DOUBLE )
1729 return( TRUE );
1730
1731 if( hn->ltype != ELEMENT_NODE && hn->rtype == ELEMENT_NODE ) {
1732 /* Right pointer only. Zap pointer so we can GC
1733 * safely.
1734 */
1735 hn1->rtype = ELEMENT_CHAR;
1736
1737 /* Recurse for RHS of node.
1738 */
1739 PEPOINTRIGHT( hn1, &pright );
1740 if( !copy_node( heap, ri, GETRIGHT( hn ), &pright ) )
1741 return( FALSE );
1742 }
1743 else if( hn->ltype == ELEMENT_NODE && hn->rtype != ELEMENT_NODE ) {
1744 /* Left pointer only. Zap pointer so we can GC
1745 * safely.
1746 */
1747 hn1->ltype = ELEMENT_CHAR;
1748
1749 /* Recurse for LHS of node.
1750 */
1751 PEPOINTLEFT( hn1, &pleft );
1752 if( !copy_node( heap, ri, GETLEFT( hn ), &pleft ) )
1753 return( FALSE );
1754 }
1755 else if( hn->ltype == ELEMENT_NODE && hn->rtype == ELEMENT_NODE ) {
1756 /* Both pointers. Zap pointers so we can GC safely.
1757 */
1758 hn1->ltype = ELEMENT_CHAR;
1759 hn1->rtype = ELEMENT_CHAR;
1760
1761 /* Recurse for boths sides of node.
1762 */
1763 PEPOINTLEFT( hn1, &pleft );
1764 PEPOINTRIGHT( hn1, &pright );
1765 if( !copy_node( heap, ri, GETLEFT( hn ), &pleft ) ||
1766 !copy_node( heap, ri, GETRIGHT( hn ), &pright ) )
1767 return( FALSE );
1768 }
1769
1770 return( TRUE );
1771 }
1772
1773 /* Copy a compiled graph into the main reduce space. Overwrite the node at
1774 * out.
1775 */
1776 gboolean
heap_copy(Heap * heap,Compile * compile,PElement * out)1777 heap_copy( Heap *heap, Compile *compile, PElement *out )
1778 {
1779 Element *root = &compile->base;
1780 HeapNode *ri[MAX_RELOC];
1781
1782 /* Check for possible C stack overflow ... can't go over 2M on most
1783 * systems if we're using (or any of our libs are using) threads.
1784 */
1785 if( (char *) main_c_stack_base - (char *) &heap > 2000000 ) {
1786 error_top( _( "Overflow error." ) );
1787 error_sub( _( "C stack overflow. Circular definition." ) );
1788 return( FALSE );
1789 }
1790
1791 #ifdef DEBUG
1792 printf( "heap_copy: " );
1793 symbol_name_print( compile->sym );
1794 printf( "\n" );
1795 #endif /*DEBUG*/
1796
1797 /* Check for possible C stack overflow ... can't go over 2M on most
1798 * systems if we're using (or any of our libs are using) threads.
1799 */
1800 if( (char *) main_c_stack_base - (char *) &heap > 2000000 ) {
1801 error_top( _( "Overflow error." ) );
1802 error_sub( _( "C stack overflow. Expression too complex." ) );
1803 return( FALSE );
1804 }
1805
1806 switch( root->type ) {
1807 case ELEMENT_NODE:
1808 /* Need a tree copy.
1809 */
1810 if( !copy_node( heap, &ri[0], (HeapNode *) root->ele, out ) )
1811 return( FALSE );
1812 break;
1813
1814 case ELEMENT_SYMBOL:
1815 case ELEMENT_CHAR:
1816 case ELEMENT_BOOL:
1817 case ELEMENT_BINOP:
1818 case ELEMENT_SYMREF:
1819 case ELEMENT_COMPILEREF:
1820 case ELEMENT_CONSTRUCTOR:
1821 case ELEMENT_UNOP:
1822 case ELEMENT_COMB:
1823 case ELEMENT_TAG:
1824 case ELEMENT_ELIST:
1825 case ELEMENT_MANAGED:
1826 /* Copy value.
1827 */
1828 PEPUTP( out, root->type, root->ele );
1829 break;
1830
1831 case ELEMENT_NOVAL:
1832 /* Not compiled yet: compile now, then copy.
1833 */
1834 if( compile_object( compile ) )
1835 return( FALSE );
1836 if( !heap_copy( heap, compile, out ) )
1837 return( FALSE );
1838 break;
1839
1840 default:
1841 g_assert( FALSE );
1842 }
1843
1844 return( TRUE );
1845 }
1846
1847 /* Try to make a gvalue from a heap object.
1848 */
1849 gboolean
heap_ip_to_gvalue(PElement * in,GValue * out)1850 heap_ip_to_gvalue( PElement *in, GValue *out )
1851 {
1852 Reduce *rc = reduce_context;
1853
1854 if( !reduce_pelement( rc, reduce_spine_strict, in ) )
1855 return( FALSE );
1856
1857 if( PEISREAL( in ) ) {
1858 g_value_init( out, G_TYPE_DOUBLE );
1859 g_value_set_double( out, PEGETREAL( in ) );
1860 }
1861 else if( PEISBOOL( in ) ) {
1862 g_value_init( out, G_TYPE_BOOLEAN );
1863 g_value_set_boolean( out, PEGETBOOL( in ) );
1864 }
1865 else if( PEISCOMPLEX( in ) ) {
1866 printf( "ip_to_gvalue: no complex gtype!\n" );
1867 return( FALSE );
1868 }
1869 else if( PEISIMAGE( in ) ) {
1870 Imageinfo *ii = PEGETII( in );
1871 VipsImage *im = imageinfo_get( FALSE, ii );
1872
1873 g_value_init( out, VIPS_TYPE_IMAGE );
1874 g_value_set_object( out, im );
1875 }
1876 else if( PEISLIST( in ) ) {
1877 gboolean result;
1878
1879 if( heap_is_string( in, &result ) &&
1880 result ) {
1881 char name[256];
1882
1883 if( !heap_get_string( in, name, 256 ) )
1884 return( FALSE );
1885
1886 /* We want a refstring, not a G_TYPE_STRING, since
1887 * this GValue will (probably) be used by vips with
1888 * im_header_string() etc.
1889 */
1890 g_value_init( out, IM_TYPE_REF_STRING );
1891 im_ref_string_set( out, name );
1892 }
1893 #if VIPS_MAJOR_VERSION > 7 || VIPS_MINOR_VERSION > 39
1894 /* vips_value_set_array_*() is a 7.40 feature.
1895 */
1896 else if( heap_is_imagevec( in, &result ) &&
1897 result ) {
1898 Imageinfo *iivec[100];
1899 VipsImage **ivec;
1900 int n;
1901 int i;
1902
1903 if( (n = heap_get_imagevec( in, iivec, 100 )) < 0 )
1904 return( FALSE );
1905 g_value_init( out, VIPS_TYPE_ARRAY_IMAGE );
1906 vips_value_set_array_image( out, n );
1907 ivec = vips_value_get_array_image( out, NULL );
1908 for( i = 0; i < n; i++ ) {
1909 ivec[i] = imageinfo_get( FALSE, iivec[i] );
1910
1911 /* g_value_unset() on out will unref every
1912 * array element, so we need to ref.
1913 */
1914 g_object_ref( ivec[i] );
1915 }
1916 }
1917 else if( heap_is_realvec( in, &result ) &&
1918 result ) {
1919 double realvec[100];
1920 int n;
1921
1922 if( (n = heap_get_realvec( in, realvec, 100 )) < 0 )
1923 return( FALSE );
1924 g_value_init( out, VIPS_TYPE_ARRAY_DOUBLE );
1925 vips_value_set_array_double( out, realvec, n );
1926 }
1927 #endif
1928 else {
1929 error_top( _( "Unimplemented list type." ) );
1930 return( FALSE );
1931 }
1932 }
1933 else if( PEISMANAGED( in ) && IS_MANAGEDGOBJECT( PEGETVAL( in ) ) ) {
1934 g_value_init( out, G_TYPE_OBJECT );
1935 g_value_set_object( out,
1936 MANAGEDGOBJECT( PEGETMANAGED( in ) )->object );
1937 }
1938 else {
1939 char txt[100];
1940 VipsBuf buf = VIPS_BUF_STATIC( txt );
1941
1942 error_top( _( "Unimplemented argument type." ) );
1943 (void) itext_value( rc, &buf, in );
1944 error_sub( _( "Cannot convert %s to GValue." ),
1945 vips_buf_all( &buf ) );
1946 return( FALSE );
1947 }
1948
1949 return( TRUE );
1950 }
1951
1952 /* Try to make a heap object from a gvalue.
1953 */
1954 gboolean
heap_gvalue_to_ip(GValue * in,PElement * out)1955 heap_gvalue_to_ip( GValue *in, PElement *out )
1956 {
1957 Reduce *rc = reduce_context;
1958 Heap *heap = rc->heap;
1959
1960 if( G_VALUE_HOLDS_BOOLEAN( in ) ) {
1961 PEPUTP( out, ELEMENT_BOOL, (int) g_value_get_boolean( in ) );
1962 }
1963 else if( G_VALUE_HOLDS_CHAR( in ) ) {
1964 /* g_value_get_schar() is not in older glibs.
1965 */
1966 PEPUTP( out, ELEMENT_CHAR, (int) g_value_get_uchar( in ) );
1967 }
1968 else if( G_VALUE_HOLDS_UCHAR( in ) ) {
1969 PEPUTP( out, ELEMENT_CHAR, (int) g_value_get_uchar( in ) );
1970 }
1971 else if( G_VALUE_HOLDS_INT( in ) ) {
1972 if( !heap_real_new( heap, g_value_get_int( in ), out ) )
1973 return( FALSE );
1974 }
1975 else if( G_VALUE_HOLDS_UINT( in ) ) {
1976 if( !heap_real_new( heap, g_value_get_uint( in ), out ) )
1977 return( FALSE );
1978 }
1979 else if( G_VALUE_HOLDS_LONG( in ) ) {
1980 if( !heap_real_new( heap, g_value_get_long( in ), out ) )
1981 return( FALSE );
1982 }
1983 else if( G_VALUE_HOLDS_ULONG( in ) ) {
1984 if( !heap_real_new( heap, g_value_get_ulong( in ), out ) )
1985 return( FALSE );
1986 }
1987 else if( G_VALUE_HOLDS_INT64( in ) ) {
1988 if( !heap_real_new( heap, g_value_get_int64( in ), out ) )
1989 return( FALSE );
1990 }
1991 else if( G_VALUE_HOLDS_UINT64( in ) ) {
1992 if( !heap_real_new( heap, g_value_get_uint64( in ), out ) )
1993 return( FALSE );
1994 }
1995 else if( G_VALUE_HOLDS_FLOAT( in ) ) {
1996 if( !heap_real_new( heap, g_value_get_float( in ), out ) )
1997 return( FALSE );
1998 }
1999 else if( G_VALUE_HOLDS_DOUBLE( in ) ) {
2000 if( !heap_real_new( heap, g_value_get_double( in ), out ) )
2001 return( FALSE );
2002 }
2003 else if( G_VALUE_HOLDS_ENUM( in ) ) {
2004 if( !heap_real_new( heap, g_value_get_enum( in ), out ) )
2005 return( FALSE );
2006 }
2007 else if( G_VALUE_HOLDS_STRING( in ) ) {
2008 if( !heap_managedstring_new( heap,
2009 g_value_get_string( in ), out ) )
2010 return( FALSE );
2011 }
2012 else if( G_VALUE_HOLDS_OBJECT( in ) ) {
2013 GObject *object;
2014 Managed *managed;
2015
2016 object = g_value_get_object( in );
2017
2018 if( VIPS_IS_IMAGE( object ) ) {
2019 VipsImage *image = VIPS_IMAGE( object );
2020
2021 g_object_ref( image );
2022 managed = MANAGED( imageinfo_new( main_imageinfogroup,
2023 heap, image, image->filename ) );
2024 }
2025 else
2026 managed = MANAGED( managedgobject_new( heap, object ) );
2027
2028 PEPUTP( out, ELEMENT_MANAGED, managed );
2029 }
2030 else if( g_value_type_transformable( G_VALUE_TYPE( in ),
2031 G_TYPE_STRING ) ) {
2032 GValue temp = { 0 };
2033
2034 g_value_init( &temp, G_TYPE_STRING );
2035 g_value_transform( in, &temp );
2036 if( !heap_managedstring_new( heap,
2037 g_value_get_string( &temp ), out ) ) {
2038 return( FALSE );
2039 g_value_unset( &temp );
2040 }
2041 g_value_unset( &temp );
2042 }
2043 else {
2044 error_top( _( "Unimplemented type." ) );
2045 error_sub( _( "Unable to convert %s to a nip type." ),
2046 G_VALUE_TYPE_NAME( in ) );
2047
2048 return( FALSE );
2049 }
2050
2051 return( TRUE );
2052 }
2053
2054 /* Indent step.
2055 */
2056 #define TAB (2)
2057
2058 /* Fwd ref.
2059 */
2060 static void lisp_pelement( VipsBuf *buf, PElement *base,
2061 GSList **back, gboolean fn, int indent );
2062
2063 /* Print a sym-value list.
2064 */
2065 static void
lisp_symval(VipsBuf * buf,PElement * base,GSList ** back,gboolean fn,int indent,PElement * stop)2066 lisp_symval( VipsBuf *buf, PElement *base,
2067 GSList **back, gboolean fn, int indent, PElement *stop )
2068 {
2069 gboolean error = FALSE;
2070
2071 /* Reached the "stop" element?
2072 */
2073 if( stop && *base->type == *stop->type && *base->ele == *stop->ele )
2074 return;
2075
2076 if( PEISNODE( base ) ) {
2077 HeapNode *hn = PEGETVAL( base );
2078 PElement pe;
2079
2080 if( hn->type != TAG_CONS )
2081 error = TRUE;
2082
2083 PEPOINTLEFT( hn, &pe );
2084 if( !error && PEISNODE( &pe ) ) {
2085 HeapNode *hn2 = PEGETVAL( &pe );
2086
2087 if( hn2->type != TAG_CONS )
2088 error = TRUE;
2089
2090 PEPOINTLEFT( hn2, &pe );
2091 if( !error && PEISSYMREF( &pe ) ) {
2092 vips_buf_appendf( buf, "\n%s", spc( indent ) );
2093 symbol_qualified_name(
2094 PEGETSYMREF( &pe ), buf );
2095 vips_buf_appendf( buf, " = " );
2096
2097 PEPOINTRIGHT( hn2, &pe );
2098 lisp_pelement( buf, &pe,
2099 back, fn, indent + TAB );
2100
2101 PEPOINTRIGHT( hn, &pe );
2102 lisp_symval( buf, &pe, back, fn, indent, stop );
2103 }
2104 else
2105 error = TRUE;
2106 }
2107 else
2108 error = TRUE;
2109 }
2110 else if( !PEISELIST( base ) )
2111 error = TRUE;
2112
2113 if( error )
2114 vips_buf_appendf( buf, "\n%s<*** malformed symval list>",
2115 spc( indent ) );
2116 }
2117
2118 /* Print a [*] ... our caller has printed the enclosing [ ] and the first
2119 * element, so we print a ", " followed by us.
2120 */
2121 static void
lisp_list(VipsBuf * buf,PElement * base,GSList ** back,gboolean fn,int indent)2122 lisp_list( VipsBuf *buf, PElement *base,
2123 GSList **back, gboolean fn, int indent )
2124 {
2125 if( PEISNODE( base ) ) {
2126 HeapNode *hn = PEGETVAL( base );
2127 PElement pe;
2128
2129 vips_buf_appends( buf, ", " );
2130
2131 if( hn->type == TAG_CONS ) {
2132 PEPOINTLEFT( hn, &pe );
2133 lisp_pelement( buf, &pe, back, fn, indent );
2134
2135 PEPOINTRIGHT( hn, &pe );
2136 lisp_list( buf, &pe, back, fn, indent );
2137 }
2138 else
2139 lisp_pelement( buf, base, back, fn, indent );
2140 }
2141 else if( PEISMANAGEDSTRING( base ) ) {
2142 vips_buf_appends( buf, ", Managedstring <" );
2143 vips_buf_appends( buf, PEGETMANAGEDSTRING( base )->string );
2144 vips_buf_appends( buf, ">" );
2145 }
2146 else if( !PEISELIST( base ) )
2147 lisp_pelement( buf, base, back, fn, indent );
2148 }
2149
2150 /* Print a [char] ... fall back to lisp_list() if we hit a non-char
2151 * element. base is the RHS of a cons, so it can be a managedstring too.
2152 */
2153 static gboolean
lisp_string(VipsBuf * buf,PElement * base,GSList ** back,gboolean fn,int indent)2154 lisp_string( VipsBuf *buf, PElement *base,
2155 GSList **back, gboolean fn, int indent )
2156 {
2157 gboolean error = FALSE;
2158
2159 if( PEISNODE( base ) ) {
2160 HeapNode *hn = PEGETVAL( base );
2161 PElement pe;
2162
2163 if( hn->type != TAG_CONS )
2164 error = TRUE;
2165
2166 PEPOINTLEFT( hn, &pe );
2167 if( !error ) {
2168 if( PEISCHAR( &pe ) ) {
2169 vips_buf_appendf( buf, "%c", PEGETCHAR( &pe ) );
2170
2171 PEPOINTRIGHT( hn, &pe );
2172 (void) lisp_string( buf,
2173 &pe, back, fn, indent );
2174 }
2175 else {
2176 vips_buf_appends( buf, "\":[" );
2177 lisp_pelement( buf, &pe, back, fn, indent );
2178
2179 PEPOINTRIGHT( hn, &pe );
2180 lisp_list( buf, &pe, back, fn, indent );
2181 vips_buf_appends( buf, "]" );
2182
2183 error = TRUE;
2184 }
2185 }
2186 else
2187 error = TRUE;
2188 }
2189 else if( PEISMANAGEDSTRING( base ) )
2190 vips_buf_appends( buf, PEGETMANAGEDSTRING( base )->string );
2191 else if( !PEISELIST( base ) )
2192 error = TRUE;
2193
2194 return( error );
2195 }
2196
2197 /* Print a graph LISP-style.
2198 */
2199 static void
lisp_node(VipsBuf * buf,HeapNode * hn,GSList ** back,gboolean fn,int indent)2200 lisp_node( VipsBuf *buf, HeapNode *hn, GSList **back, gboolean fn, int indent )
2201 {
2202 int i;
2203 PElement p1, p2;
2204
2205 /* Have we printed this node before?
2206 */
2207 if( hn->flgs & FLAG_PRINT ) {
2208 if( (i = g_slist_index( *back, hn )) == -1 ) {
2209 *back = g_slist_prepend( *back, hn );
2210 vips_buf_appendf( buf, "<" );
2211 vips_buf_appendf( buf, _( "circular" ) );
2212 vips_buf_appendf( buf, " (%p)>", hn );
2213 }
2214 else {
2215 vips_buf_appendf( buf, "<" );
2216 vips_buf_appendf( buf, _( "circular to label %d" ), i );
2217 vips_buf_appendf( buf, ">" );
2218 }
2219
2220 return;
2221 }
2222 hn->flgs |= FLAG_PRINT;
2223
2224 if( (i = g_slist_index( *back, hn )) != -1 ) {
2225 vips_buf_appendf( buf, "*" );
2226 vips_buf_appendf( buf, _( "label %d" ), i );
2227 vips_buf_appendf( buf, ": " );
2228 }
2229
2230 switch( hn->type ) {
2231 case TAG_APPL:
2232 if( fn ) {
2233 PEPOINTLEFT( hn, &p1 );
2234 PEPOINTRIGHT( hn, &p2 );
2235 vips_buf_appends( buf, "(" );
2236 lisp_pelement( buf, &p1, back, fn, indent );
2237 vips_buf_appends( buf, " " );
2238 lisp_pelement( buf, &p2, back, fn, indent );
2239 vips_buf_appends( buf, ")" );
2240 }
2241 else {
2242 vips_buf_appends( buf, "<" );
2243 vips_buf_appends( buf, _( "unevaluated" ) );
2244 vips_buf_appends( buf, ">" );
2245 }
2246
2247 break;
2248
2249 case TAG_CONS:
2250 PEPOINTLEFT( hn, &p1 );
2251 if( PEISCHAR( &p1 ) ) {
2252 vips_buf_appendf( buf, "\"%c", PEGETCHAR( &p1 ) );
2253 PEPOINTRIGHT( hn, &p2 );
2254 (void) lisp_string( buf, &p2, back, fn, indent );
2255 vips_buf_appends( buf, "\"" );
2256 }
2257 else {
2258 vips_buf_appends( buf, "[" );
2259 lisp_pelement( buf, &p1, back, fn, indent );
2260 PEPOINTRIGHT( hn, &p2 );
2261 lisp_list( buf, &p2, back, fn, indent );
2262 vips_buf_appends( buf, "]" );
2263 }
2264 break;
2265
2266 case TAG_DOUBLE:
2267 vips_buf_appendf( buf, "%g", hn->body.num );
2268 break;
2269
2270 case TAG_COMPLEX:
2271 vips_buf_appendf( buf, "(%g,%g)",
2272 GETLEFT( hn )->body.num, GETRIGHT( hn )->body.num );
2273 break;
2274
2275 case TAG_CLASS:
2276 if( fn ) {
2277 vips_buf_appendf( buf, "\n%s", spc( indent ) );
2278 vips_buf_appendf( buf, _( "class (%p)" ), hn );
2279 vips_buf_appendf( buf, " " );
2280 }
2281
2282 PEPOINTLEFT( hn, &p1 );
2283 lisp_pelement( buf, &p1, back, fn, indent );
2284
2285 if( fn ) {
2286 hn = GETRIGHT( hn );
2287
2288 vips_buf_appendf( buf, "\n%s", spc( indent + TAB ) );
2289 vips_buf_appendf( buf, _( "members" ) );
2290 vips_buf_appendf( buf, " = { " );
2291 PEPOINTRIGHT( hn, &p1 );
2292 lisp_symval( buf, &p1,
2293 back, fn, indent + TAB * 2, NULL );
2294 vips_buf_appendf( buf, "\n%s}", spc( indent + TAB ) );
2295
2296 PEPOINTLEFT( hn, &p2 );
2297 if( *p1.type != *p2.type || *p1.ele != *p2.ele ) {
2298 vips_buf_appendf( buf, "\n%s",
2299 spc( indent + TAB ) );
2300 vips_buf_appendf( buf, _( "secret" ) );
2301 vips_buf_appendf( buf, " = { " );
2302 lisp_symval( buf, &p2,
2303 back, fn, indent + TAB * 2, &p1 );
2304 vips_buf_appendf( buf,
2305 "\n%s} ", spc( indent + TAB ) );
2306 }
2307 }
2308
2309 break;
2310
2311 case TAG_GEN:
2312 vips_buf_appendf( buf, "[%g,%g...",
2313 GETLEFT( hn )->body.num,
2314 GETLEFT( GETRIGHT( hn ) )->body.num );
2315 if( GETRT( GETRIGHT( hn ) ) == ELEMENT_ELIST )
2316 vips_buf_appends( buf, "[ ]]" );
2317 else
2318 vips_buf_appendf( buf, "%g]",
2319 GETRIGHT( GETRIGHT( hn ) )->body.num );
2320 break;
2321
2322 case TAG_SHARED:
2323 PEPOINTLEFT( hn, &p1 );
2324 i = GPOINTER_TO_INT( GETRIGHT( hn ) );
2325 vips_buf_appendf( buf, "SHARE%d[", i );
2326 lisp_pelement( buf, &p1, back, fn, indent );
2327 vips_buf_appends( buf, "]" );
2328 break;
2329
2330 case TAG_REFERENCE:
2331 i = GPOINTER_TO_INT( GETRIGHT( GETLEFT( hn ) ) );
2332 vips_buf_appendf( buf, "REF%d", i );
2333 break;
2334
2335 case TAG_FREE:
2336 default:
2337 g_assert( FALSE );
2338 }
2339 }
2340
2341 /* Print a pelement LISP-style.
2342 */
2343 static void
lisp_pelement(VipsBuf * buf,PElement * base,GSList ** back,gboolean fn,int indent)2344 lisp_pelement( VipsBuf *buf, PElement *base,
2345 GSList **back, gboolean fn, int indent )
2346 {
2347 HeapNode *hn;
2348 EType type = PEGETTYPE( base );
2349
2350 switch( type ) {
2351 case ELEMENT_NOVAL:
2352 vips_buf_appends( buf, "<" );
2353 vips_buf_appendf( buf, _( "no value (type %d)" ),
2354 GPOINTER_TO_INT( PEGETVAL( base ) ) );
2355 vips_buf_appends( buf, ">" );
2356 break;
2357
2358 case ELEMENT_NODE:
2359 if( !(hn = PEGETVAL( base )) ) {
2360 vips_buf_appends( buf, "<" );
2361 vips_buf_appends( buf, _( "NULL pointer" ) );
2362 vips_buf_appends( buf, ">" );
2363 }
2364 else
2365 lisp_node( buf, hn, back, fn, indent );
2366 break;
2367
2368 case ELEMENT_SYMBOL:
2369 vips_buf_appends( buf, "<" );
2370 vips_buf_appends( buf, _( "symbol" ) );
2371 vips_buf_appends( buf, " \"" );
2372 symbol_qualified_name( PEGETSYMBOL( base ), buf );
2373 vips_buf_appends( buf, "\">" );
2374 break;
2375
2376 case ELEMENT_CONSTRUCTOR:
2377 vips_buf_appends( buf, "<" );
2378 vips_buf_appends( buf, _( "constructor" ) );
2379 vips_buf_appends( buf, " \"" );
2380 symbol_qualified_name( PEGETCOMPILE( base )->sym, buf );
2381 vips_buf_appends( buf, "\">" );
2382 break;
2383
2384 case ELEMENT_SYMREF:
2385 vips_buf_appends( buf, "<" );
2386 vips_buf_appends( buf, _( "symref" ) );
2387 vips_buf_appends( buf, " \"" );
2388 symbol_qualified_name( PEGETSYMBOL( base ), buf );
2389 vips_buf_appends( buf, "\">" );
2390 break;
2391
2392 case ELEMENT_COMPILEREF:
2393 vips_buf_appends( buf, "<" );
2394 vips_buf_appends( buf, _( "compileref" ) );
2395 vips_buf_appends( buf, " \"" );
2396 symbol_qualified_name( PEGETCOMPILE( base )->sym, buf );
2397 vips_buf_appends( buf, "\">" );
2398 break;
2399
2400 case ELEMENT_CHAR:
2401 vips_buf_appendf( buf, "'%c'", (int) PEGETCHAR( base ) );
2402 break;
2403
2404 case ELEMENT_BOOL:
2405 vips_buf_appends( buf, bool_to_char( PEGETBOOL( base ) ) );
2406 break;
2407
2408 case ELEMENT_BINOP:
2409 vips_buf_appends( buf, decode_BinOp( PEGETBINOP( base ) ) );
2410 break;
2411
2412 case ELEMENT_UNOP:
2413 vips_buf_appends( buf, decode_UnOp( PEGETUNOP( base ) ) );
2414 break;
2415
2416 case ELEMENT_ELIST:
2417 vips_buf_appends( buf, "[ ]" );
2418 break;
2419
2420 case ELEMENT_TAG:
2421 vips_buf_appendf( buf, "<" );
2422 vips_buf_appendf( buf, _( "tag \"%s\"" ), PEGETTAG( base ) );
2423 vips_buf_appendf( buf, ">" );
2424 break;
2425
2426 case ELEMENT_MANAGED:
2427 vips_buf_appendf( buf, "<Managed* %p>", PEGETVAL( base ) );
2428 break;
2429
2430 case ELEMENT_COMB:
2431 vips_buf_appends( buf,
2432 decode_CombinatorType( PEGETCOMB( base ) ) );
2433 break;
2434
2435 default:
2436 vips_buf_appendf( buf, "<" );
2437 vips_buf_appendf( buf, _( "unknown element tag %d" ), type );
2438 vips_buf_appendf( buf, ">" );
2439 break;
2440 }
2441 }
2442
2443 /* Print a node to a buffer. If fn is true, trace into functions.
2444 */
2445 void
graph_node(Heap * heap,VipsBuf * buf,HeapNode * root,gboolean fn)2446 graph_node( Heap *heap, VipsBuf *buf, HeapNode *root, gboolean fn )
2447 {
2448 GSList *back;
2449 char txt[4];
2450 VipsBuf buf2 = VIPS_BUF_STATIC( txt );
2451
2452 /* May be called before heap is built.
2453 */
2454 if( !heap )
2455 return;
2456
2457 back = NULL;
2458 heap_clear( heap, FLAG_PRINT );
2459 lisp_node( &buf2, root, &back, fn, 0 );
2460 heap_clear( heap, FLAG_PRINT );
2461 lisp_node( buf, root, &back, fn, 0 );
2462 IM_FREEF( g_slist_free, back );
2463 }
2464
2465 /* As above, but start from a pelement.
2466 */
2467 void
graph_pelement(Heap * heap,VipsBuf * buf,PElement * root,gboolean fn)2468 graph_pelement( Heap *heap, VipsBuf *buf, PElement *root, gboolean fn )
2469 {
2470 GSList *back;
2471 char txt[4];
2472 VipsBuf buf2 = VIPS_BUF_STATIC( txt );
2473
2474 /* May be called before heap is built.
2475 */
2476 if( !heap )
2477 return;
2478
2479 /* We print twice ... the first time through we build the list of back
2480 * pointers so we can label the graph correctly.
2481 */
2482 back = NULL;
2483
2484 heap_clear( heap, FLAG_PRINT );
2485 lisp_pelement( &buf2, root, &back, fn, 0 );
2486
2487 heap_clear( heap, FLAG_PRINT );
2488 lisp_pelement( buf, root, &back, fn, 0 );
2489
2490 IM_FREEF( g_slist_free, back );
2491 }
2492
2493 /* As above, but start from an element.
2494 */
2495 void
graph_element(Heap * heap,VipsBuf * buf,Element * root,gboolean fn)2496 graph_element( Heap *heap, VipsBuf *buf, Element *root, gboolean fn )
2497 {
2498 PElement base;
2499
2500 PEPOINTE( &base, root );
2501 graph_pelement( heap, buf, &base, fn );
2502 }
2503
2504 void
graph_pointer(PElement * root)2505 graph_pointer( PElement *root )
2506 {
2507 char txt[1000];
2508 VipsBuf buf = VIPS_BUF_STATIC( txt );
2509
2510 graph_pelement( reduce_context->heap, &buf, root, TRUE );
2511 printf( "%s\n", vips_buf_all( &buf ) );
2512 }
2513
2514 /* Fwd ref.
2515 */
2516 static void shell_pelement( PElement *base );
2517
2518 /* Print a graph shell-style.
2519 */
2520 static void
shell_node(HeapNode * hn)2521 shell_node( HeapNode *hn )
2522 {
2523 PElement p1, p2;
2524
2525 /* Have we printed this node before?
2526 */
2527 if( hn->flgs & FLAG_PRINT ) {
2528 printf( "<*circular*>" );
2529 return;
2530 }
2531 hn->flgs |= FLAG_PRINT;
2532
2533 switch( hn->type ) {
2534 case TAG_CLASS:
2535 case TAG_APPL:
2536 case TAG_REFERENCE:
2537 case TAG_SHARED:
2538 case TAG_GEN:
2539 break;
2540
2541 case TAG_CONS:
2542 {
2543 gboolean string_mode;
2544
2545 PEPOINTLEFT( hn, &p1 );
2546 string_mode = PEISCHAR( &p1 );
2547
2548 for(;;) {
2549 if( string_mode )
2550 printf( "%c", PEGETCHAR( &p1 ) );
2551 else
2552 shell_pelement( &p1 );
2553
2554 PEPOINTRIGHT( hn, &p2 );
2555 if( PEISMANAGEDSTRING( &p2 ) ) {
2556 printf( "%s\n",
2557 PEGETMANAGEDSTRING( &p2 )->string );
2558 break;
2559
2560 }
2561 else if( PEISELIST( &p2 ) )
2562 break;
2563
2564 if( !string_mode )
2565 printf( "\n" );
2566 hn = PEGETVAL( &p2 );
2567 PEPOINTLEFT( hn, &p1 );
2568 if( string_mode && !PEISCHAR( &p1 ) )
2569 string_mode = FALSE;
2570 }
2571 }
2572 break;
2573
2574 case TAG_DOUBLE:
2575 printf( "%g", hn->body.num );
2576 break;
2577
2578 case TAG_COMPLEX:
2579 printf( "%g %g",
2580 GETLEFT( hn )->body.num, GETRIGHT( hn )->body.num );
2581 break;
2582
2583 case TAG_FREE:
2584 default:
2585 g_assert( FALSE );
2586 }
2587 }
2588
2589 /* Print a pelement shell-style.
2590 */
2591 static void
shell_pelement(PElement * base)2592 shell_pelement( PElement *base )
2593 {
2594 switch( PEGETTYPE( base ) ) {
2595 /* Only allow concrete base types.
2596 */
2597 case ELEMENT_SYMREF:
2598 case ELEMENT_COMPILEREF:
2599 case ELEMENT_CONSTRUCTOR:
2600 case ELEMENT_BINOP:
2601 case ELEMENT_UNOP:
2602 case ELEMENT_COMB:
2603 case ELEMENT_TAG:
2604 case ELEMENT_SYMBOL:
2605 case ELEMENT_NOVAL:
2606 printf( "no-value" );
2607 break;
2608
2609 case ELEMENT_NODE:
2610 shell_node( PEGETVAL( base ) );
2611 break;
2612
2613 case ELEMENT_CHAR:
2614 printf( "%c", (int)PEGETCHAR( base ) );
2615 break;
2616
2617 case ELEMENT_BOOL:
2618 printf( "%s", bool_to_char( PEGETBOOL( base ) ) );
2619 break;
2620
2621 case ELEMENT_ELIST:
2622 printf( "[ ]" );
2623 break;
2624
2625 case ELEMENT_MANAGED:
2626 if( PEISIMAGE( base ) )
2627 printf( "%s", PEGETIMAGE( base )->filename );
2628 else if( PEISMANAGEDSTRING( base ) )
2629 printf( "%s", PEGETMANAGEDSTRING( base )->string );
2630 break;
2631
2632 default:
2633 g_assert( FALSE );
2634 }
2635 }
2636
2637 /* Print a pelement shell-style.
2638 */
2639 void
graph_value(PElement * root)2640 graph_value( PElement *root )
2641 {
2642 Reduce *rc = reduce_context;
2643
2644 if( !reduce_pelement( rc, reduce_spine_strict, root ) ) {
2645 iwindow_alert( NULL, GTK_MESSAGE_ERROR );
2646 return;
2647 }
2648
2649 heap_clear( reduce_context->heap, FLAG_PRINT );
2650 shell_pelement( root );
2651 printf( "\n" );
2652 }
2653