1 /* Stuff to parse and compile text.
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_RESOLVE
32 */
33
34 /* regular (and very slow) sanity checks on symbols ... needs DEBUG in
35 * symbol.c as well
36 #define DEBUG_SANITY
37 */
38
39 /* count how many nodes we find with common sub-expression removal.
40 #define DEBUG_COMMON
41 */
42
43 /* show what everything compiled to
44 #define DEBUG_RESULT
45 */
46
47 /* trace list comp compile
48 #define DEBUG_LCOMP
49 */
50
51 /* trace pattern LHS generation
52 #define DEBUG_PATTERN
53 */
54
55 /*
56 #define DEBUG
57 */
58
59 #include "ip.h"
60
61 static iContainerClass *parent_class = NULL;
62
63 Compile *
compile_get_parent(Compile * compile)64 compile_get_parent( Compile *compile )
65 {
66 if( !ICONTAINER( compile->sym )->parent )
67 return( NULL );
68
69 return( COMPILE( ICONTAINER( compile->sym )->parent ) );
70 }
71
72 void *
compile_name_print(Compile * compile)73 compile_name_print( Compile *compile )
74 {
75 printf( "compile(%p) ", compile );
76 symbol_name_print( compile->sym );
77
78 return( NULL );
79 }
80
81 static void *
compile_name_sub(Expr * expr,VipsBuf * buf)82 compile_name_sub( Expr *expr, VipsBuf *buf )
83 {
84 if( expr->row ) {
85 if( !vips_buf_is_empty( buf ) )
86 vips_buf_appends( buf, ", " );
87 row_qualified_name( expr->row, buf );
88 }
89
90 return( NULL );
91 }
92
93 void
compile_name(Compile * compile,VipsBuf * buf)94 compile_name( Compile *compile, VipsBuf *buf )
95 {
96 char txt[256];
97 VipsBuf buf2 = VIPS_BUF_STATIC( txt );
98
99 vips_buf_appends( buf, "\"" );
100 symbol_qualified_name( compile->sym, buf );
101 vips_buf_appends( buf, "\"" );
102
103 slist_map( compile->exprs,
104 (SListMapFn) compile_name_sub, &buf2 );
105 if( !vips_buf_is_empty( &buf2 ) )
106 vips_buf_appendf( buf, " (%s)", vips_buf_all( &buf2 ) );
107 }
108
109 static Compile *
compile_map_all_sub(Symbol * sym,map_compile_fn fn,void * a)110 compile_map_all_sub( Symbol *sym, map_compile_fn fn, void *a )
111 {
112 if( !sym->expr || !sym->expr->compile )
113 return( NULL );
114 else
115 return( compile_map_all( sym->expr->compile, fn, a ) );
116 }
117
118 /* Apply a function to a compile ... and any local compiles. Do top-down.
119 */
120 Compile *
compile_map_all(Compile * compile,map_compile_fn fn,void * a)121 compile_map_all( Compile *compile, map_compile_fn fn, void *a )
122 {
123 Compile *res;
124
125 /* Us first.
126 */
127 if( (res = fn( compile, a )) )
128 return( res );
129
130 /* Then any children.
131 */
132 if( (res = (Compile *) icontainer_map( ICONTAINER( compile ),
133 (icontainer_map_fn) compile_map_all_sub, (void *) fn, a )) )
134 return( res );
135
136 return( NULL );
137 }
138
139 /* Look up by name.
140 */
141 Symbol *
compile_lookup(Compile * compile,const char * name)142 compile_lookup( Compile *compile, const char *name )
143 {
144 return( SYMBOL(
145 icontainer_child_lookup( ICONTAINER( compile ), name ) ) );
146 }
147
148 /* Make a dependency. Text in compile refers to sym.
149 */
150 void
compile_link_make(Compile * compile,Symbol * child)151 compile_link_make( Compile *compile, Symbol *child )
152 {
153 /* Already a dependency? Don't make a second link.
154 */
155 if( !g_slist_find( compile->children, child ) ) {
156 /* New link, each direction.
157 */
158 compile->children = g_slist_prepend( compile->children, child );
159 child->parents = g_slist_prepend( child->parents, compile );
160
161 /* If the child is a forward reference, we may have to patch
162 * this later. Save the pointer-to-child pointer on child.
163 */
164 if( child->type == SYM_ZOMBIE )
165 (void) symbol_patch_add(
166 &compile->children->data, child );
167 }
168
169 #ifdef DEBUG_SANITY
170 /* Sanity check.
171 */
172 symbol_sanity( child );
173 symbol_leaf_set_sanity();
174 #endif /*DEBUG_SANITY*/
175 }
176
177 /* Break a dependency. Text in compile referred to child.
178 */
179 void *
compile_link_break(Compile * compile,Symbol * child)180 compile_link_break( Compile *compile, Symbol *child )
181 {
182 /* Sanity check.
183 */
184 #ifdef DEBUG_SANITY
185 symbol_sanity( child );
186 symbol_leaf_set_sanity();
187 #endif /*DEBUG_SANITY*/
188
189 /* Must be there.
190 */
191 g_assert( g_slist_find( compile->children, child ) &&
192 g_slist_find( child->parents, compile ) );
193
194 compile->children = g_slist_remove( compile->children, child );
195 child->parents = g_slist_remove( child->parents, compile );
196
197 /* Sanity check.
198 */
199 #ifdef DEBUG_SANITY
200 symbol_sanity( child );
201 symbol_leaf_set_sanity();
202 #endif /*DEBUG_SANITY*/
203
204 return( NULL );
205 }
206
207 void *
compile_expr_link_break(Compile * compile,Expr * expr)208 compile_expr_link_break( Compile *compile, Expr *expr )
209 {
210 g_assert( expr->compile == compile );
211 g_assert( g_slist_find( compile->exprs, expr ) );
212
213 expr->compile = NULL;
214 compile->exprs = g_slist_remove( compile->exprs, expr );
215
216 g_object_unref( G_OBJECT( compile ) );
217
218 return( NULL );
219 }
220
221 void *
compile_expr_link_break_rev(Expr * expr,Compile * compile)222 compile_expr_link_break_rev( Expr *expr, Compile *compile )
223 {
224 return( compile_expr_link_break( compile, expr ) );
225 }
226
227 void
compile_expr_link_make(Compile * compile,Expr * expr)228 compile_expr_link_make( Compile *compile, Expr *expr )
229 {
230 g_assert( !expr->compile );
231 g_assert( !g_slist_find( compile->exprs, expr ) );
232 g_assert( compile->sym == expr->sym );
233
234 expr->compile = compile;
235 compile->exprs = g_slist_prepend( compile->exprs, expr );
236
237 g_object_ref( G_OBJECT( compile ) );
238 iobject_sink( IOBJECT( compile ) );
239 }
240
241 static void
compile_finalize(GObject * gobject)242 compile_finalize( GObject *gobject )
243 {
244 Compile *compile;
245
246 g_return_if_fail( gobject != NULL );
247 g_return_if_fail( IS_COMPILE( gobject ) );
248
249 compile = COMPILE( gobject );
250
251 #ifdef DEBUG
252 printf( "compile_finalize: " );
253 compile_name_print( compile );
254 printf( "\n" );
255 #endif /*DEBUG*/
256
257 /* My instance destroy stuff.
258 */
259
260 /* Junk parse tree.
261 */
262 slist_map( compile->treefrag, (SListMapFn) tree_node_destroy, NULL );
263 IM_FREEF( g_slist_free, compile->treefrag );
264 compile->tree = NULL;
265
266 /* Break links to all locals.
267 */
268 IM_FREEF( g_slist_free, compile->param );
269 compile->nparam = 0;
270 IM_FREEF( g_slist_free, compile->secret );
271 compile->nsecret = 0;
272 compile->this = NULL;
273 compile->super = NULL;
274 (void) slist_map( compile->children,
275 (SListMapFn) symbol_link_break, compile );
276 IM_FREEF( g_slist_free, compile->children );
277
278 /* Remove static strings we created.
279 */
280 slist_map( compile->statics,
281 (SListMapFn) managed_destroy_nonheap, NULL );
282 IM_FREEF( g_slist_free, compile->statics );
283
284 /* Junk heap.
285 */
286 if( compile->heap ) {
287 compile->base.type = ELEMENT_NOVAL;
288 compile->base.ele = (void *) 1;
289 heap_unregister_element( compile->heap, &compile->base );
290 UNREF( compile->heap );
291 }
292
293 /* Junk text.
294 */
295 IM_FREE( compile->text );
296 IM_FREE( compile->prhstext );
297 IM_FREE( compile->rhstext );
298
299 compile->sym = NULL;
300
301 /* If we're being finalized, we must have a ref count of zero, so
302 * there shouldn't be any exprs looking at us.
303 */
304 g_assert( !compile->exprs );
305
306 G_OBJECT_CLASS( parent_class )->finalize( gobject );
307 }
308
309 static void
compile_class_init(CompileClass * class)310 compile_class_init( CompileClass *class )
311 {
312 GObjectClass *gobject_class = (GObjectClass *) class;
313
314 parent_class = g_type_class_peek_parent( class );
315
316 gobject_class->finalize = compile_finalize;
317
318 /* Create signals.
319 */
320
321 /* Init default methods.
322 */
323 }
324
325 static void
compile_init(Compile * compile)326 compile_init( Compile *compile )
327 {
328 /* Init our instance fields.
329 */
330 compile->sym = NULL;
331
332 compile->exprs = NULL;
333
334 compile->is_klass = FALSE;
335 compile->has_super = FALSE;
336
337 compile->text = NULL;
338 compile->prhstext = NULL;
339 compile->rhstext = NULL;
340
341 compile->tree = NULL;
342 compile->treefrag = NULL;
343 compile->last_sym = NULL;
344
345 compile->nparam = 0;
346 compile->param = NULL;
347 compile->nsecret = 0;
348 compile->secret = NULL;
349 compile->this = NULL;
350 compile->super = NULL;
351 compile->children = NULL;
352
353 compile->base.type = ELEMENT_NOVAL;
354 compile->heap = NULL;
355 compile->statics = NULL;
356 }
357
358 GType
compile_get_type(void)359 compile_get_type( void )
360 {
361 static GType type = 0;
362
363 if( !type ) {
364 static const GTypeInfo info = {
365 sizeof( CompileClass ),
366 NULL, /* base_init */
367 NULL, /* base_finalize */
368 (GClassInitFunc) compile_class_init,
369 NULL, /* class_finalize */
370 NULL, /* class_data */
371 sizeof( Compile ),
372 32, /* n_preallocs */
373 (GInstanceInitFunc) compile_init,
374 };
375
376 type = g_type_register_static( TYPE_ICONTAINER,
377 "Compile", &info, 0 );
378 }
379
380 return( type );
381 }
382
383 /* Make a compile linked to an expr.
384 */
385 Compile *
compile_new(Expr * expr)386 compile_new( Expr *expr )
387 {
388 Compile *compile = COMPILE( g_object_new( TYPE_COMPILE, NULL ) );
389
390 compile->sym = expr->sym;
391
392 /* Junk any old compile.
393 */
394 if( expr->compile )
395 compile_expr_link_break( expr->compile, expr );
396
397 compile_expr_link_make( compile, expr );
398
399 /* We'll want to be able to do name lookups.
400 */
401 icontainer_set_hash( ICONTAINER( compile ) );
402
403 #ifdef DEBUG
404 printf( "compile_new: " );
405 compile_name_print( compile );
406 printf( "\n" );
407 #endif /*DEBUG*/
408
409 return( compile );
410 }
411
412 /* Max cells function for symbols. Enough to compile something big.
413 */
414 static int
compile_heap_max_fn(Heap * heap)415 compile_heap_max_fn( Heap *heap )
416 {
417 return( 10000 );
418 }
419
420 /* Make a exprinfo suitable for a top-level symbol.
421 */
422 Compile *
compile_new_toplevel(Expr * expr)423 compile_new_toplevel( Expr *expr )
424 {
425 Compile *compile = compile_new( expr );
426
427 compile->heap = heap_new( compile, compile_heap_max_fn, 100, 1000 );
428 g_object_ref( G_OBJECT( compile->heap ) );
429 iobject_sink( IOBJECT( compile->heap ) );
430
431 heap_register_element( compile->heap, &compile->base );
432
433 return( compile );
434 }
435
436 /* Make a exprinfo suitable for a local.
437 */
438 Compile *
compile_new_local(Expr * expr)439 compile_new_local( Expr *expr )
440 {
441 Compile *compile = compile_new( expr );
442
443 compile->heap = heap_new( compile, compile_heap_max_fn, 100, 100 );
444 g_object_ref( G_OBJECT( compile->heap ) );
445 iobject_sink( IOBJECT( compile->heap ) );
446
447 heap_register_element( compile->heap, &compile->base );
448
449 return( compile );
450 }
451
452 /* Code generation.
453 */
454
455 /* Generate a binop. Point arg1 and arg2 at the elements to be filled in:
456 * caller sets them later. First arg is the compile that this operator came
457 * from.
458 */
459 static gboolean
compile_binop(Compile * compile,BinOp bop,PElement * arg1,PElement * arg2,PElement * out)460 compile_binop( Compile *compile,
461 BinOp bop, PElement *arg1, PElement *arg2, PElement *out )
462 {
463 Heap *heap = compile->heap;
464
465 HeapNode *hn1, *hn2, *hn3;
466 PElement e1, e2;
467
468 if( NEWNODE( heap, hn1 ) )
469 return( FALSE );
470 hn1->type = TAG_APPL;
471 PPUT( hn1, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
472 PEPUTP( out, ELEMENT_NODE, hn1 );
473 PEPOINTLEFT( hn1, &e1 );
474 PEPOINTRIGHT( hn1, arg2 );
475
476 if( NEWNODE( heap, hn2 ) )
477 return( FALSE );
478 hn2->type = TAG_APPL;
479 PPUT( hn2, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
480 PEPUTP( &e1, ELEMENT_NODE, hn2 );
481 PEPOINTRIGHT( hn2, arg1 );
482 PEPOINTLEFT( hn2, &e2 );
483
484 if( NEWNODE( heap, hn3 ) )
485 return( FALSE );
486 hn3->type = TAG_APPL;
487 PPUT( hn3, ELEMENT_BINOP, bop, ELEMENT_COMPILEREF, compile );
488 PEPUTP( &e2, ELEMENT_NODE, hn3 );
489
490 return( TRUE );
491 }
492
493 /* Generate "x.sym". Set x to be NULL and point rhs at it .. caller
494 * fills in later.
495 */
496 static gboolean
compile_dotsym(Compile * compile,Symbol * sym,PElement * rhs,PElement * out)497 compile_dotsym( Compile *compile, Symbol *sym, PElement *rhs, PElement *out )
498 {
499 PElement e;
500
501 if( !compile_binop( compile, BI_DOT, rhs, &e, out ) )
502 return( FALSE );
503 PEPUTP( &e, ELEMENT_SYMREF, sym );
504
505 return( TRUE );
506 }
507
508 /* Compile a reference to sym from expr.
509 */
510 static gboolean
compile_reference(Compile * compile,Symbol * sym,PElement * out)511 compile_reference( Compile *compile, Symbol *sym, PElement *out )
512 {
513 Heap *heap = compile->heap;
514 Compile *parent = compile_get_parent( compile );
515
516 #ifdef DEBUG
517 printf( "generate_reference: ref to " );
518 symbol_name_print( sym );
519 printf( "inside " );
520 compile_name_print( compile );
521 printf( "\n" );
522 #endif /*DEBUG*/
523
524 if( g_slist_find( compile->param, sym ) ||
525 g_slist_find( compile->secret, sym ) ) {
526 /* sym is a simple parameter, easy!
527 */
528 PEPUTP( out, ELEMENT_SYMBOL, sym );
529 }
530 else if( is_class( parent ) &&
531 (symbol_get_parent( sym ) == parent->sym ||
532 g_slist_find( parent->secret, sym )) ) {
533 Symbol *ths = parent->this;
534
535 /* sym is a member of the same class as expr, or sym is a
536 * secret to our constructor (in which case it'll be in this
537 * as well) ... generate (.sym this)
538 *
539 * Optimisation: don't generate (.this this)
540 */
541 if( sym == ths ) {
542 PEPUTP( out, ELEMENT_SYMBOL, ths );
543 }
544 else {
545 PElement rhs;
546
547 if( !compile_dotsym( compile, sym, &rhs, out ) )
548 return( FALSE );
549 PEPUTP( &rhs, ELEMENT_SYMBOL, ths );
550 }
551 }
552 else if( is_member_enclosing( compile, sym ) ) {
553 Symbol *sths = symbol_get_parent( sym )->expr->compile->this;
554 PElement rhs;
555
556 /* Sym is a member of an enclosing class ...
557 * generate (.sym ref-to-this-for-that-class)
558 */
559 if( !compile_dotsym( compile, sym, &rhs, out ) ||
560 !compile_reference( compile, sths, &rhs ) )
561 return( FALSE );
562 }
563 else {
564 /* some other reference ... generate (sym secret1 .. secretn)
565 * recurse for secrets, since we may have to fetch them from
566 * "this"
567 */
568 PElement e = *out;
569 PElement f;
570 GSList *l;
571
572 PEPUTP( &e, ELEMENT_SYMBOL, sym );
573
574 /* Build secret args to this sym.
575 */
576 if( sym->expr && sym->expr->compile )
577 for( l = sym->expr->compile->secret; l; l = l->next ) {
578 Symbol *arg = SYMBOL( l->data );
579 HeapNode *hn1;
580
581 if( NEWNODE( heap, hn1 ) )
582 return( FALSE );
583 hn1->type = TAG_APPL;
584 PEPUTLEFT( hn1, &e );
585 PPUTRIGHT( hn1, ELEMENT_ELIST, NULL );
586 PEPUTP( &e, ELEMENT_NODE, hn1 );
587
588 PEPOINTRIGHT( hn1, &f );
589 if( !compile_reference( compile, arg, &f ) )
590 return( FALSE );
591 }
592 }
593
594 return( TRUE );
595 }
596
597 /* Build a graph with vars still in it. Write result to *out.
598 */
599 static gboolean
compile_graph(Compile * compile,ParseNode * pn,PElement * out)600 compile_graph( Compile *compile, ParseNode *pn, PElement *out )
601 {
602 Heap *heap = compile->heap;
603 HeapNode *hn1, *hn2, *hn3;
604 PElement e1, e2, e3;
605 GSList *l;
606
607 switch( pn->type ) {
608 case NODE_APPLY:
609 /* Build apply node.
610 */
611 if( NEWNODE( heap, hn1 ) )
612 return( FALSE );
613 hn1->type = TAG_APPL;
614 PPUT( hn1, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
615 PEPUTP( out, ELEMENT_NODE, hn1 );
616
617 /* Make sides.
618 */
619 PEPOINTLEFT( hn1, &e1 );
620 PEPOINTRIGHT( hn1, &e2 );
621 if( !compile_graph( compile, pn->arg1, &e1 ) ||
622 !compile_graph( compile, pn->arg2, &e2 ) )
623 return( FALSE );
624
625 break;
626
627 case NODE_UOP:
628 /* Build apply node.
629 */
630 if( NEWNODE( heap, hn1 ) )
631 return( FALSE );
632 hn1->type = TAG_APPL;
633 PPUT( hn1, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
634 PEPUTP( out, ELEMENT_NODE, hn1 );
635 PEPOINTLEFT( hn1, &e1 );
636
637 if( NEWNODE( heap, hn2 ) )
638 return( FALSE );
639 hn2->type = TAG_APPL;
640 PPUT( hn2, ELEMENT_UNOP, pn->uop, ELEMENT_COMPILEREF, compile );
641 PEPUTP( &e1, ELEMENT_NODE, hn2 );
642
643 /* Build arg.
644 */
645 PEPOINTRIGHT( hn1, &e2 );
646 if( !compile_graph( compile, pn->arg1, &e2 ) )
647 return( FALSE );
648
649 break;
650
651 case NODE_BINOP:
652 if( !compile_binop( compile, pn->biop, &e1, &e2, out ) ||
653 !compile_graph( compile, pn->arg1, &e1 ) ||
654 !compile_graph( compile, pn->arg2, &e2 ) )
655 return( FALSE );
656
657 break;
658
659 case NODE_COMPOSE:
660 if( NEWNODE( heap, hn1 ) )
661 return( FALSE );
662 hn1->type = TAG_APPL;
663 PPUT( hn1, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
664 PEPUTP( out, ELEMENT_NODE, hn1 );
665 PEPOINTLEFT( hn1, &e1 );
666
667 if( NEWNODE( heap, hn2 ) )
668 return( FALSE );
669 hn2->type = TAG_APPL;
670 PPUT( hn2, ELEMENT_COMB, COMB_SR,
671 ELEMENT_ELIST, NULL );
672 PEPUTP( &e1, ELEMENT_NODE, hn2 );
673
674 /* Build args.
675 */
676 PEPOINTRIGHT( hn1, &e2 );
677 PEPOINTRIGHT( hn2, &e3 );
678 if( !compile_graph( compile, pn->arg1, &e3 ) ||
679 !compile_graph( compile, pn->arg2, &e2 ) )
680 return( FALSE );
681
682 break;
683
684 case NODE_LEAF:
685 /* A reference to a symbol.
686 */
687 if( !compile_reference( compile, pn->leaf, out ) )
688 return( FALSE );
689
690 break;
691
692 case NODE_CLASS:
693 /* Output constructor.
694 */
695 PEPUTP( out, ELEMENT_CONSTRUCTOR, pn->klass );
696 break;
697
698 case NODE_TAG:
699 /* RHS of projection.
700 */
701 PEPUTP( out, ELEMENT_TAG, pn->tag );
702 break;
703
704 case NODE_GENERATOR:
705 /* Build apply nodes.
706 */
707 if( NEWNODE( heap, hn1 ) )
708 return( FALSE );
709 hn1->type = TAG_APPL;
710 PPUT( hn1, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
711 PEPUTP( out, ELEMENT_NODE, hn1 );
712 PEPOINTLEFT( hn1, &e1 );
713
714 if( NEWNODE( heap, hn2 ) )
715 return( FALSE );
716 hn2->type = TAG_APPL;
717 PPUT( hn2, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
718 PEPUTP( &e1, ELEMENT_NODE, hn2 );
719 PEPOINTLEFT( hn2, &e2 );
720
721 if( NEWNODE( heap, hn3 ) )
722 return( FALSE );
723 hn3->type = TAG_APPL;
724 PPUT( hn3, ELEMENT_COMB, COMB_GEN, ELEMENT_ELIST, NULL );
725 PEPUTP( &e2, ELEMENT_NODE, hn3 );
726
727 /* Build args.
728 */
729 PEPOINTRIGHT( hn1, &e3 );
730 PEPOINTRIGHT( hn2, &e2 );
731 PEPOINTRIGHT( hn3, &e1 );
732 if( !compile_graph( compile, pn->arg1, &e1 ) )
733 return( FALSE );
734 if( pn->arg2 )
735 if( !compile_graph( compile, pn->arg2, &e2 ) )
736 return( FALSE );
737 if( pn->arg3 )
738 if( !compile_graph( compile, pn->arg3, &e3 ) )
739 return( FALSE );
740
741 break;
742
743 case NODE_LISTCONST:
744 case NODE_SUPER:
745 /* List of expressions.
746 */
747
748 /* Make first RHS ... the end of the list.
749 */
750 e1 = *out;
751 PEPUTP( &e1, ELEMENT_ELIST, NULL );
752
753 /* Build @':' for each element.
754 */
755 for( l = pn->elist; l; l = l->next ) {
756 ParseNode *arg = (ParseNode *) l->data;
757
758 /* Build apply nodes.
759 */
760 if( NEWNODE( heap, hn1 ) )
761 return( FALSE );
762 hn1->type = TAG_APPL;
763 PPUT( hn1, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
764 PEPUTP( &e1, ELEMENT_NODE, hn1 );
765 PEPOINTLEFT( hn1, &e2 );
766
767 if( NEWNODE( heap, hn2 ) )
768 return( FALSE );
769 hn2->type = TAG_APPL;
770 PPUT( hn2, ELEMENT_ELIST, NULL, ELEMENT_ELIST, NULL );
771 PEPUTP( &e2, ELEMENT_NODE, hn2 );
772 PEPOINTLEFT( hn2, &e2 );
773
774 if( NEWNODE( heap, hn3 ) )
775 return( FALSE );
776 hn3->type = TAG_APPL;
777 PPUT( hn3, ELEMENT_BINOP, BI_CONS,
778 ELEMENT_COMPILEREF, compile );
779 PEPUTP( &e2, ELEMENT_NODE, hn3 );
780
781 /* Build arg.
782 */
783 PEPOINTRIGHT( hn2, &e3 );
784 if( !compile_graph( compile, arg, &e3 ) )
785 return( FALSE );
786
787 /* APPL is now our LHS.
788 */
789 PEPOINTRIGHT( hn1, &e1 );
790 }
791
792 break;
793
794 case NODE_CONST:
795 /* Constant.
796 */
797 switch( pn->con.type ) {
798 case PARSE_CONST_STR:
799 {
800 Managedstring *managedstring;
801
802 if( !(managedstring = managedstring_find(
803 reduce_context->heap,
804 pn->con.val.str )) )
805 return( FALSE );
806 MANAGED_REF( managedstring );
807 compile->statics = g_slist_prepend( compile->statics,
808 managedstring );
809 PEPUTP( out, ELEMENT_MANAGED, managedstring );
810 }
811 break;
812
813 case PARSE_CONST_CHAR:
814 PEPUTP( out, ELEMENT_CHAR, pn->con.val.ch );
815 break;
816
817 case PARSE_CONST_BOOL:
818 PEPUTP( out, ELEMENT_BOOL, pn->con.val.bool );
819 break;
820
821 case PARSE_CONST_ELIST:
822 PEPUTP( out, ELEMENT_ELIST, NULL );
823 break;
824
825 case PARSE_CONST_NUM:
826 if( !heap_real_new( heap, pn->con.val.num, out ) )
827 return( FALSE );
828 break;
829
830 case PARSE_CONST_COMPLEX:
831 if( !heap_complex_new( heap, 0, pn->con.val.num, out ) )
832 return( FALSE );
833 break;
834
835 default:
836 g_assert( FALSE );
837 }
838
839 break;
840
841 case NODE_NONE:
842 default:
843 g_assert( FALSE );
844 }
845
846 return( TRUE );
847 }
848
849 /* Parameter abstraction.
850 */
851
852 /* Abstract a symbol from the body of a piece of graph. Set *used if we found
853 * the symbol in this piece of graph ... ie. if our caller should add an
854 * Sx-combinator for us. Update *root with the new piece of graph.
855 */
856 static int
compile_abstract_body(Compile * compile,PElement * root,Symbol * sym,gboolean * used)857 compile_abstract_body( Compile *compile,
858 PElement *root, Symbol *sym, gboolean *used )
859 {
860 Heap *heap = compile->heap;
861 HeapNode *hn;
862 HeapNode *hn1;
863 PElement e1, e2;
864 gboolean b1, b2;
865 CombinatorType comb;
866
867 switch( PEGETTYPE( root ) ) {
868 case ELEMENT_NODE:
869 hn = PEGETVAL( root );
870 switch( hn->type ) {
871 case TAG_APPL:
872 case TAG_CONS:
873 b1 = FALSE; b2 = FALSE;
874 PEPOINTLEFT( hn, &e1 );
875 PEPOINTRIGHT( hn, &e2 );
876 if( compile_abstract_body( compile, &e1, sym, &b1 ) ||
877 compile_abstract_body( compile,
878 &e2, sym, &b2 ) )
879 return( -1 );
880
881 if( PEISCOMB( &e2 ) &&
882 PEGETCOMB( &e2 ) == COMB_I && !b1 && b2 &&
883 hn->type == TAG_APPL ) {
884 PEPUTPE( root, &e1 );
885 *used = TRUE;
886 }
887 else if( b1 || b2 ) {
888 if( b1 && !b2 )
889 comb = COMB_SL;
890 else if( !b1 && b2 )
891 comb = COMB_SR;
892 else
893 comb = COMB_S;
894
895 /* Generate Sx combinator.
896 */
897 if( NEWNODE( heap, hn1 ) )
898 return( -1 );
899 hn1->type = TAG_APPL;
900 PPUTLEFT( hn1, ELEMENT_COMB, comb );
901 PEPUTRIGHT( hn1, &e1 );
902 PEPUTP( &e1, ELEMENT_NODE, hn1 );
903
904 /* We've used the var too!
905 */
906 *used = TRUE;
907 }
908
909 break;
910
911 case TAG_DOUBLE:
912 case TAG_COMPLEX:
913 case TAG_CLASS:
914 case TAG_GEN:
915 break;
916
917 case TAG_FILE:
918 case TAG_FREE:
919 default:
920 g_assert( FALSE );
921 }
922
923 break;
924
925 case ELEMENT_SYMBOL:
926 if( SYMBOL( PEGETVAL( root ) ) == sym ) {
927 /* Found an instance! Make an I combinator.
928 */
929 *used = TRUE;
930 PEPUTP( root, ELEMENT_COMB, COMB_I );
931 }
932 break;
933
934 case ELEMENT_CONSTRUCTOR:
935 /* set used .. to stop K being generated for this
936 * class parameter.
937 */
938 *used = TRUE;
939 break;
940
941 case ELEMENT_MANAGED:
942 case ELEMENT_CHAR:
943 case ELEMENT_BOOL:
944 case ELEMENT_BINOP:
945 case ELEMENT_UNOP:
946 case ELEMENT_COMB:
947 case ELEMENT_ELIST:
948 case ELEMENT_SYMREF:
949 case ELEMENT_COMPILEREF:
950 case ELEMENT_NOVAL:
951 case ELEMENT_TAG:
952 /* Leave alone.
953 */
954 break;
955
956 default:
957 g_assert( FALSE );
958 }
959
960 return( 0 );
961 }
962
963 /* Abstract a symbol from a graph. As above, but make a K if the symbol is
964 * entirely unused.
965 */
966 static void *
compile_abstract_symbol(Symbol * sym,Compile * compile,PElement * root)967 compile_abstract_symbol( Symbol *sym, Compile *compile, PElement *root )
968 {
969 Heap *heap = compile->heap;
970 gboolean b;
971
972 #ifdef DEBUG
973 printf( "abstracting " );
974 symbol_name_print( sym );
975 printf( "\n" );
976 #endif /*DEBUG*/
977
978 b = FALSE;
979 if( compile_abstract_body( compile, root, sym, &b ) )
980 return( sym );
981
982 if( !b ) {
983 HeapNode *hn1;
984
985 /* Parameter not used! Need a K.
986 */
987 if( NEWNODE( heap, hn1 ) )
988 return( sym );
989 hn1->type = TAG_APPL;
990 PPUTLEFT( hn1, ELEMENT_COMB, COMB_K );
991 PEPUTRIGHT( hn1, root );
992
993 /* Update root.
994 */
995 PEPUTP( root, ELEMENT_NODE, hn1 );
996 }
997
998 return( NULL );
999 }
1000
1001 /* Common sub-expression elimination.
1002 */
1003
1004 #ifdef DEBUG_COMMON
1005 static void *
compile_node_count_sub(HeapNode * hn,int * n)1006 compile_node_count_sub( HeapNode *hn, int *n )
1007 {
1008 *n += 1;
1009
1010 return( NULL );
1011 }
1012
1013 static int
compile_node_count(HeapNode * hn)1014 compile_node_count( HeapNode *hn )
1015 {
1016 int n;
1017
1018 n = 0;
1019 heap_map( hn, (heap_map_fn) compile_node_count_sub, &n, NULL );
1020
1021 return( n );
1022 }
1023
1024 /* Accumulate total saved here during walk of this tree.
1025 */
1026 static int compile_node_sum;
1027 #endif /*DEBUG_COMMON*/
1028
1029 /* A hash code we calculate from a bit of heap.
1030 */
1031 typedef gpointer CompileHash;
1032
1033 /* Combine two hashes.
1034 */
1035 #define COMPILEHASH_ADD( A, B ) \
1036 GUINT_TO_POINTER( GPOINTER_TO_UINT( A ) + GPOINTER_TO_UINT( B ) )
1037
1038 /* An int to a hash.
1039 */
1040 #define INT_TO_HASH GUINT_TO_POINTER
1041
1042 /* Build one of these during sharing analysis. From node pointers to
1043 * hash codes, and from hash codes to a list of matching node pointers.
1044 */
1045 typedef struct _CompileShare {
1046 Compile *compile;
1047
1048 GHashTable *node2hash;
1049 GHashTable *hash2nodel;
1050 } CompileShare;
1051
1052 static gboolean
compile_share_destroy_sub(gpointer key,gpointer value,gpointer user_data)1053 compile_share_destroy_sub( gpointer key, gpointer value, gpointer user_data )
1054 {
1055 if( value )
1056 g_slist_free( (GSList *) value );
1057
1058 return( TRUE );
1059 }
1060
1061 static void
compile_share_destroy(CompileShare * share)1062 compile_share_destroy( CompileShare *share )
1063 {
1064 share->compile = NULL;
1065 if( share->node2hash ) {
1066 g_hash_table_destroy( share->node2hash );
1067 share->node2hash = NULL;
1068 }
1069 if( share->hash2nodel ) {
1070 g_hash_table_foreach_remove( share->hash2nodel,
1071 compile_share_destroy_sub, NULL );
1072 g_hash_table_destroy( share->hash2nodel );
1073 share->hash2nodel = NULL;
1074 }
1075 }
1076
1077 static void
compile_share_init(CompileShare * share,Compile * compile)1078 compile_share_init( CompileShare *share, Compile *compile )
1079 {
1080 share->compile = compile;
1081 share->node2hash = g_hash_table_new( NULL, g_direct_equal );
1082 share->hash2nodel = g_hash_table_new( NULL, g_direct_equal );
1083 }
1084
1085 /* Remove a heapnode from the share.
1086 */
1087 static void *
compile_share_remove(HeapNode * hn,CompileShare * share)1088 compile_share_remove( HeapNode *hn, CompileShare *share )
1089 {
1090 CompileHash hash;
1091
1092 if( (hash = g_hash_table_lookup( share->node2hash, hn )) ) {
1093 GSList *nodel;
1094
1095 if( (nodel = g_hash_table_lookup( share->hash2nodel,
1096 hash )) ) {
1097 nodel = slist_remove_all( nodel, hn );
1098 g_hash_table_replace( share->hash2nodel,
1099 hash, nodel );
1100 }
1101
1102 g_hash_table_remove( share->node2hash, hn );
1103 }
1104
1105 return( NULL );
1106 }
1107
1108 /* Add a new heapnode.
1109 */
1110 static void
compile_share_add(CompileShare * share,HeapNode * hn,CompileHash hash)1111 compile_share_add( CompileShare *share, HeapNode *hn, CompileHash hash )
1112 {
1113 /* Make sure hash is non-zero (very unlikely).
1114 */
1115 if( !hash )
1116 hash = INT_TO_HASH( 1 );
1117
1118 if( !g_hash_table_lookup( share->node2hash, hn ) ) {
1119 GSList *nodel;
1120
1121 g_hash_table_insert( share->node2hash, hn, hash );
1122
1123 if( (nodel = g_hash_table_lookup( share->hash2nodel, hash )) ) {
1124 nodel = g_slist_prepend( nodel, hn );
1125 g_hash_table_replace( share->hash2nodel, hash, nodel );
1126 }
1127 else {
1128 nodel = g_slist_prepend( NULL, hn );
1129 g_hash_table_insert( share->hash2nodel, hash, nodel );
1130 }
1131 }
1132 }
1133
1134 /* From a HeapNode, find a list of the other heapnodes which hashed to the same
1135 * value.
1136 */
1137 static GSList *
compile_share_lookup(CompileShare * share,HeapNode * hn)1138 compile_share_lookup( CompileShare *share, HeapNode *hn )
1139 {
1140 CompileHash hash;
1141
1142 if( (hash = (CompileHash)
1143 g_hash_table_lookup( share->node2hash, hn )) )
1144 return( g_hash_table_lookup( share->hash2nodel,
1145 (gpointer) hash ) );
1146
1147 return( NULL );
1148 }
1149
1150 static CompileHash compile_share_scan_node( CompileShare *share,
1151 HeapNode *hn );
1152
1153 static CompileHash
compile_share_scan_element(CompileShare * share,PElement * e)1154 compile_share_scan_element( CompileShare *share, PElement *e )
1155 {
1156 CompileHash hash;
1157
1158 switch( PEGETTYPE( e ) ) {
1159 case ELEMENT_NODE:
1160 hash = compile_share_scan_node( share, PEGETVAL( e ) );
1161 break;
1162
1163 case ELEMENT_SYMBOL:
1164 case ELEMENT_SYMREF:
1165 case ELEMENT_COMPILEREF:
1166 case ELEMENT_CHAR:
1167 case ELEMENT_BOOL:
1168 case ELEMENT_BINOP:
1169 case ELEMENT_UNOP:
1170 case ELEMENT_COMB:
1171 case ELEMENT_CONSTRUCTOR:
1172 hash = INT_TO_HASH( PEGETTYPE( e ) + PEGETVAL( e ) );
1173 break;
1174
1175 case ELEMENT_ELIST:
1176 hash = INT_TO_HASH( ELEMENT_ELIST );
1177 break;
1178
1179 case ELEMENT_TAG:
1180 hash = INT_TO_HASH( g_str_hash( PEGETTAG( e ) ) );
1181 break;
1182
1183 case ELEMENT_MANAGED:
1184 hash = INT_TO_HASH( PEGETMANAGED( e )->hash );
1185 break;
1186
1187 case ELEMENT_NOVAL:
1188 default:
1189 hash = 0;
1190 g_assert( 0 );
1191 }
1192
1193 return( hash );
1194 }
1195
1196 /* Calculate a hash for every node in a tree. We can just recurse and
1197 * calculate bottom-up, since we'll never get very deep. If we were scanning
1198 * run-time code, we'd need a better scheme.
1199 */
1200 static CompileHash
compile_share_scan_node(CompileShare * share,HeapNode * hn)1201 compile_share_scan_node( CompileShare *share, HeapNode *hn )
1202 {
1203 CompileHash hash;
1204 PElement a;
1205
1206 hash = INT_TO_HASH( 0 );
1207 switch( hn->type ) {
1208 case TAG_CONS:
1209 case TAG_GEN:
1210 case TAG_CLASS:
1211 case TAG_COMPLEX:
1212 case TAG_APPL:
1213 PEPOINTLEFT( hn, &a );
1214 hash = COMPILEHASH_ADD( hash,
1215 compile_share_scan_element( share, &a ) );
1216 PEPOINTRIGHT( hn, &a );
1217 hash = COMPILEHASH_ADD( hash,
1218 compile_share_scan_element( share, &a ) );
1219 hash = COMPILEHASH_ADD( hash,
1220 INT_TO_HASH( (int) hn->type ) );
1221 break;
1222
1223 case TAG_DOUBLE:
1224 hash = COMPILEHASH_ADD( hash,
1225 INT_TO_HASH( (int) hn->body.num ) );
1226 hash = COMPILEHASH_ADD( hash,
1227 INT_TO_HASH( (int) hn->type ) );
1228 break;
1229
1230 case TAG_FILE:
1231 case TAG_REFERENCE:
1232 case TAG_SHARED:
1233 case TAG_FREE:
1234 default:
1235 g_assert( FALSE );
1236 }
1237
1238 /* Add to accumulated table.
1239 */
1240 compile_share_add( share, hn, hash );
1241
1242 return( hash );
1243 }
1244
1245 /* Test two sub-trees for equality.
1246 */
1247 static gboolean
compile_equal_node(HeapNode * hn1,HeapNode * hn2)1248 compile_equal_node( HeapNode *hn1, HeapNode *hn2 )
1249 {
1250 /* Test for pointer equality.
1251 */
1252 if( hn1 == hn2 )
1253 return( TRUE );
1254
1255 /* Test type tags for equality.
1256 */
1257 if( hn1->type != hn2->type )
1258 return( FALSE );
1259
1260 /* If double, test immediately.
1261 */
1262 if( hn1->type == TAG_DOUBLE ) {
1263 if( hn1->body.num == hn2->body.num )
1264 return( TRUE );
1265 else
1266 return( FALSE );
1267 }
1268
1269 /* If complex, test immediately.
1270 */
1271 if( hn1->type == TAG_COMPLEX ) {
1272 if( GETLEFT( hn1 )->body.num == GETLEFT( hn2 )->body.num &&
1273 GETRIGHT( hn1 )->body.num == GETRIGHT( hn2 )->body.num )
1274 return( TRUE );
1275 else
1276 return( FALSE );
1277 }
1278
1279 /* If compound type, something is wrong! Only built by reduce.
1280 */
1281 g_assert( hn1->type != TAG_CLASS );
1282
1283 /* In two parts, test tags.
1284 */
1285 if( GETLT( hn1 ) != GETLT( hn2 ) )
1286 return( FALSE );
1287 if( GETRT( hn1 ) != GETRT( hn2 ) )
1288 return( FALSE );
1289
1290 /* Test non-subtree parts.
1291 */
1292 if( GETLT( hn1 ) != ELEMENT_NODE )
1293 if( GETLEFT( hn1 ) != GETLEFT( hn2 ) )
1294 return( FALSE );
1295 if( GETRT( hn1 ) != ELEMENT_NODE )
1296 if( GETRIGHT( hn1 ) != GETRIGHT( hn2 ) )
1297 return( FALSE );
1298
1299 /* If sub-trees, test them.
1300 */
1301 if( GETLT( hn1 ) == ELEMENT_NODE )
1302 if( !compile_equal_node( GETLEFT( hn1 ), GETLEFT( hn2 ) ) )
1303 return( FALSE );
1304 if( GETRT( hn1 ) == ELEMENT_NODE )
1305 if( !compile_equal_node( GETRIGHT( hn1 ), GETRIGHT( hn2 ) ) )
1306 return( FALSE );
1307
1308 return( TRUE );
1309 }
1310
1311 /* Found two equal sub-expressions. We can change hn1 to just be a reference
1312 * to hn2.
1313 */
1314 static int
compile_transform_reference(Compile * compile,HeapNode * hn1,HeapNode * hn2)1315 compile_transform_reference( Compile *compile, HeapNode *hn1, HeapNode *hn2 )
1316 {
1317 #ifdef DEBUG
1318 {
1319 Heap *heap = compile->heap;
1320 char txt[100];
1321 VipsBuf buf = VIPS_BUF_STATIC( txt );
1322
1323 graph_node( heap, &buf, hn1, TRUE );
1324 printf( "Found common subexpression: %s\n", vips_buf_all( &buf ) );
1325 }
1326 #endif /*DEBUG*/
1327
1328 #ifdef DEBUG_COMMON
1329 compile_node_sum += compile_node_count( hn1 );
1330 #endif /*DEBUG_COMMON*/
1331
1332 /* Zap nodes to indicate sharing.
1333 */
1334 hn1->type = TAG_REFERENCE;
1335 PPUTLEFT( hn1, ELEMENT_NODE, hn2 );
1336 PPUTRIGHT( hn1, ELEMENT_NODE, NULL );
1337
1338 return( 0 );
1339 }
1340
1341 /* Node other hashes to the same value as our node. Test for equality, and if
1342 * they match, turn us into a share point and turn the other node into a ref.
1343 */
1344 static void *
compile_share_test(HeapNode * other,CompileShare * share,HeapNode * hn)1345 compile_share_test( HeapNode *other, CompileShare *share, HeapNode *hn )
1346 {
1347 if( hn != other && compile_equal_node( hn, other ) ) {
1348 heap_map( other,
1349 (heap_map_fn) compile_share_remove, share, NULL );
1350 compile_transform_reference( share->compile, other, hn );
1351 }
1352
1353 return( NULL );
1354 }
1355
1356 /* Scan a chunk of tree top-down, looking for and eliminating common nodes.
1357 */
1358 static void
compile_share_trim(CompileShare * share,HeapNode * hn)1359 compile_share_trim( CompileShare *share, HeapNode *hn )
1360 {
1361 PElement a;
1362 GSList *nodel;
1363
1364 if( (nodel = compile_share_lookup( share, hn )) )
1365 slist_map2( nodel,
1366 (SListMap2Fn) compile_share_test, share, hn );
1367
1368 switch( hn->type ) {
1369 case TAG_CONS:
1370 case TAG_GEN:
1371 case TAG_CLASS:
1372 case TAG_COMPLEX:
1373 case TAG_APPL:
1374 PEPOINTLEFT( hn, &a );
1375 if( PEISNODE( &a ) )
1376 compile_share_trim( share, PEGETVAL( &a ) );
1377 PEPOINTRIGHT( hn, &a );
1378 if( PEISNODE( &a ) )
1379 compile_share_trim( share, PEGETVAL( &a ) );
1380 break;
1381
1382 case TAG_DOUBLE:
1383 case TAG_REFERENCE:
1384 break;
1385
1386 case TAG_SHARED:
1387 case TAG_FREE:
1388 case TAG_FILE:
1389 default:
1390 g_assert( FALSE );
1391 }
1392 }
1393
1394 static void
compile_share_scan(Compile * compile,PElement * a)1395 compile_share_scan( Compile *compile, PElement *a )
1396 {
1397 if( PEISNODE( a ) ) {
1398 HeapNode *hn = PEGETVAL( a );
1399 CompileShare share;
1400
1401 compile_share_init( &share, compile );
1402 compile_share_scan_node( &share, hn );
1403 compile_share_trim( &share, hn );
1404 compile_share_destroy( &share );
1405 }
1406 }
1407
1408 /* Use this to generate an id for each SHARE node.
1409 */
1410 static int compile_share_number = 0;
1411
1412 /* If this is a REF node, make sure dest is a SHARE node.
1413 */
1414 static void *
compile_transform_share(HeapNode * hn,Compile * compile)1415 compile_transform_share( HeapNode *hn, Compile *compile )
1416 {
1417 Heap *heap = compile->heap;
1418
1419 if( hn->type == TAG_REFERENCE ) {
1420 HeapNode *hn1 = GETLEFT( hn );
1421
1422 if( hn1->type != TAG_SHARED ) {
1423 HeapNode *hn2;
1424
1425 #ifdef DEBUG
1426 {
1427 char txt[100];
1428 VipsBuf buf = VIPS_BUF_STATIC( txt );
1429
1430 graph_node( heap, &buf, hn1, TRUE );
1431 printf( "Found shared code: %s\n",
1432 vips_buf_all( &buf ) );
1433 }
1434 #endif /*DEBUG*/
1435
1436 if( NEWNODE( heap, hn2 ) )
1437 return( hn );
1438 *hn2 = *hn1;
1439 hn1->type = TAG_SHARED;
1440 PPUT( hn1,
1441 ELEMENT_NODE, hn2,
1442 ELEMENT_CHAR, GUINT_TO_POINTER(
1443 compile_share_number ) );
1444
1445 compile_share_number++;
1446 if( compile_share_number == MAX_RELOC ) {
1447 error_top( _( "Too many shared nodes in "
1448 "graph." ) );
1449 error_sub( _( "Raise MAX_RELOC" ) );
1450 return( hn );
1451 }
1452 }
1453 }
1454
1455 return( NULL );
1456 }
1457
1458 /* Do common-subexpression elimination.
1459 */
1460 static gboolean
compile_remove_subexpr(Compile * compile,PElement * root)1461 compile_remove_subexpr( Compile *compile, PElement *root )
1462 {
1463 HeapNode *rootn = PEGETVAL( root );
1464 #ifdef DEBUG_COMMON
1465 static int compile_node_total = 0;
1466 #endif /*DEBUG_COMMON*/
1467
1468 if( PEGETTYPE( root ) != ELEMENT_NODE )
1469 /* Nowt to do.
1470 */
1471 return( TRUE );
1472
1473 #ifdef DEBUG_COMMON
1474 compile_node_sum = 0;
1475 #endif /*DEBUG_COMMON*/
1476
1477 /* Scan for common nodes, replace stuff we remove with REFERENCE
1478 * nodes.
1479 */
1480 compile_share_scan( compile, root );
1481
1482 /* Now search for destinations of reference nodes and mark all shared
1483 * sections. Each shared section is given a number ... saves a lookup
1484 * during copy.
1485 */
1486 compile_share_number = 0;
1487 if( heap_map( rootn,
1488 (heap_map_fn) compile_transform_share, compile, NULL ) ) {
1489 /* We can't leave the graph half-done, it'll confuse the copier
1490 * later. Zap the graph.
1491 */
1492 PEPUTP( root, ELEMENT_NOVAL, NULL );
1493 return( FALSE );
1494 }
1495
1496 #ifdef DEBUG_COMMON
1497 if( compile_node_sum ) {
1498 compile_node_total += compile_node_sum;
1499 printf( "compile_remove_subexpr: " );
1500 symbol_name_print( compile->sym );
1501 printf( "saved %d nodes (total %d)\n",
1502 compile_node_sum, compile_node_total );
1503 }
1504 #endif /*DEBUG_COMMON*/
1505
1506 return( TRUE );
1507 }
1508
1509 /* Top-level compiler driver.
1510 */
1511
1512 /* Compile a symbol into a heap.
1513 */
1514 static void *
compile_heap(Compile * compile)1515 compile_heap( Compile *compile )
1516 {
1517 PElement base;
1518
1519 /* Don't generate code for parser temps.
1520 */
1521 if( compile->sym->placeholder )
1522 return( NULL );
1523
1524 PEPOINTE( &base, &compile->base );
1525
1526 /* Is there an existing function base? GC it away.
1527 */
1528 if( PEGETTYPE( &base ) != ELEMENT_NOVAL ) {
1529 PEPUTP( &base, ELEMENT_NOVAL, (void *) 2 );
1530 if( !heap_gc( compile->heap ) )
1531 return( compile->sym );
1532
1533 return( NULL );
1534 }
1535
1536 #ifdef DEBUG
1537 printf( "*** compile_expr: about to compile " );
1538 symbol_name_print( compile->sym );
1539 printf( "\n" );
1540 if( compile->tree )
1541 dump_tree( compile->tree );
1542 #endif /*DEBUG*/
1543
1544 /* Compile function body. Tree can be NULL for classes.
1545 */
1546 if( compile->tree ) {
1547 if( !compile_graph( compile, compile->tree, &base ) )
1548 return( compile->sym );
1549 }
1550 else {
1551 PEPUTP( &base, ELEMENT_NOVAL, (void *) 3 );
1552 }
1553
1554 #ifdef DEBUG
1555 {
1556 char txt[1024];
1557 VipsBuf buf = VIPS_BUF_STATIC( txt );
1558
1559 graph_pelement( compile->heap, &buf, &base, TRUE );
1560 printf( "before var abstraction, compiled \"%s\" to: %s\n",
1561 IOBJECT( compile->sym )->name, vips_buf_all( &buf ) );
1562 }
1563 #endif /*DEBUG*/
1564
1565 /* Abstract real parameters.
1566 */
1567 #ifdef DEBUG
1568 printf( "abstracting real params ...\n" );
1569 #endif /*DEBUG*/
1570 if( slist_map2_rev( compile->param,
1571 (SListMap2Fn) compile_abstract_symbol, compile, &base ) )
1572 return( compile->sym );
1573
1574 /* Abstract secret parameters.
1575 */
1576 #ifdef DEBUG
1577 printf( "abstracting secret params ...\n" );
1578 #endif /*DEBUG*/
1579 if( slist_map2_rev( compile->secret,
1580 (SListMap2Fn) compile_abstract_symbol, compile, &base ) )
1581 return( compile->sym );
1582
1583 /* Remove common sub-expressions.
1584 */
1585 if( !compile_remove_subexpr( compile, &base ) )
1586 return( compile->sym );
1587
1588 #ifdef DEBUG_RESULT
1589 {
1590 char txt[1024];
1591 VipsBuf buf = VIPS_BUF_STATIC( txt );
1592
1593 printf( "compiled " );
1594 symbol_name_print( compile->sym );
1595 printf( "to: " );
1596 graph_pelement( compile->heap, &buf, &base, TRUE );
1597 printf( "%s\n", vips_buf_all( &buf ) );
1598 }
1599 #endif /*DEBUG_RESULT*/
1600
1601 return( NULL );
1602 }
1603
1604 static void *compile_object_sub( Compile *compile );
1605
1606 static void *
compile_symbol_sub(Symbol * sym)1607 compile_symbol_sub( Symbol *sym )
1608 {
1609 Compile *compile;
1610
1611 if( sym->expr && (compile = sym->expr->compile) )
1612 if( compile_object_sub( compile ) )
1613 return( sym );
1614
1615 return( NULL );
1616 }
1617
1618 static void *
compile_object_sub(Compile * compile)1619 compile_object_sub( Compile *compile )
1620 {
1621 if( icontainer_map( ICONTAINER( compile ),
1622 (icontainer_map_fn) compile_symbol_sub, NULL, NULL ) )
1623 return( compile );
1624
1625 if( compile_heap( compile ) )
1626 return( compile );
1627
1628 return( NULL );
1629 }
1630
1631 /* Top-level compile a thing entry point.
1632 */
1633 void *
compile_object(Compile * compile)1634 compile_object( Compile *compile )
1635 {
1636 /* Walk this tree of symbols computing the secret lists.
1637 */
1638 secret_build( compile );
1639
1640 /* Compile all definitions from the inside out.
1641 */
1642 if( compile_object_sub( compile ) )
1643 return( compile );
1644
1645 return( NULL );
1646 }
1647
1648 static void *
compile_toolkit_sub(Tool * tool)1649 compile_toolkit_sub( Tool *tool )
1650 {
1651 Compile *compile;
1652
1653 if( tool->sym && tool->sym->expr &&
1654 (compile = tool->sym->expr->compile ))
1655 /* Only if we have no code.
1656 */
1657 if( compile->base.type == ELEMENT_NOVAL )
1658 if( compile_object( compile ) )
1659 return( tool );
1660
1661 return( NULL );
1662 }
1663
1664 /* Scan a toolkit and make sure all the symbols have been compiled.
1665 */
1666 void *
compile_toolkit(Toolkit * kit)1667 compile_toolkit( Toolkit *kit )
1668 {
1669 return( toolkit_map( kit,
1670 (tool_map_fn) compile_toolkit_sub, NULL, NULL ) );
1671 }
1672
1673 /* Parse support.
1674 */
1675
1676 static ParseNode *
compile_check_i18n(Compile * compile,ParseNode * pn)1677 compile_check_i18n( Compile *compile, ParseNode *pn )
1678 {
1679 switch( pn->type ) {
1680 case NODE_APPLY:
1681 if( pn->arg1->type == NODE_LEAF &&
1682 strcmp( IOBJECT( pn->arg1->leaf )->name, "_" ) == 0 &&
1683 pn->arg2->type == NODE_CONST &&
1684 pn->arg2->con.type == PARSE_CONST_STR ) {
1685 const char *text = pn->arg2->con.val.str;
1686
1687 if( main_option_i18n ) {
1688 /* Remove msgid duplicates with this.
1689 */
1690 static GHashTable *msgid = NULL;
1691
1692 if( !msgid )
1693 msgid = g_hash_table_new(
1694 g_str_hash, g_str_equal );
1695
1696 if( !g_hash_table_lookup( msgid, text ) ) {
1697 char buf[MAX_STRSIZE];
1698
1699 g_hash_table_insert( msgid,
1700 (void *) text, NULL );
1701 my_strecpy( buf, text, TRUE );
1702 printf( "msgid \"%s\"\n", buf );
1703 printf( "msgstr \"\"\n\n" );
1704 }
1705 }
1706
1707 /* We can gettext these at compile time. Replace the
1708 * APPLY node with a fixed-up text string.
1709 */
1710 pn->type = NODE_CONST;
1711 pn->con.type = PARSE_CONST_STR;
1712 pn->con.val.str = im_strdupn( _( text ) );
1713 }
1714 break;
1715
1716 default:
1717 break;
1718 }
1719
1720 return( NULL );
1721 }
1722
1723 static ParseNode *
compile_check_more(Compile * compile,ParseNode * pn)1724 compile_check_more( Compile *compile, ParseNode *pn )
1725 {
1726 switch( pn->type ) {
1727 case NODE_BINOP:
1728 switch( pn->biop ) {
1729 case BI_MORE:
1730 pn->biop = BI_LESS;
1731 SWAPP( pn->arg1, pn->arg2 );
1732 break;
1733
1734 case BI_MOREEQ:
1735 pn->biop = BI_LESSEQ;
1736 SWAPP( pn->arg1, pn->arg2 );
1737 break;
1738
1739 default:
1740 break;
1741 }
1742 break;
1743
1744 default:
1745 break;
1746 }
1747
1748 return( NULL );
1749 }
1750
1751 /* Do end-of-parse checks. Called after every 'A = ...' style definition (not
1752 * just top-level syms). Used to do lots of checks, not much left now.
1753 */
1754 gboolean
compile_check(Compile * compile)1755 compile_check( Compile *compile )
1756 {
1757 Symbol *sym = compile->sym;
1758 Symbol *parent = symbol_get_parent( sym );
1759
1760 /* Check "check" member.
1761 */
1762 if( is_member( sym ) &&
1763 strcmp( IOBJECT( sym )->name, MEMBER_CHECK ) == 0 ) {
1764 if( compile->nparam != 0 ) {
1765 error_top( _( "Too many arguments." ) );
1766 error_sub( _( "Member \"%s\" of class "
1767 "\"%s\" should have no arguments." ),
1768 MEMBER_CHECK, symbol_name( parent ) );
1769
1770 return( FALSE );
1771 }
1772 }
1773
1774 /* Look for (_ "string constant") and pump it through gettext. We can
1775 * do a lot of i18n at compile-time.
1776 */
1777 #ifdef DEBUG
1778 printf( "compile_check_i18n: " );
1779 compile_name_print( compile );
1780 printf( "\n" );
1781 #endif /*DEBUG*/
1782 (void) tree_map( compile,
1783 (tree_map_fn) compile_check_i18n, compile->tree, NULL, NULL );
1784
1785 /* Swap MORE and MOREEQ for LESS and LESSEQ. Reduces the number of
1786 * cases for the compiler.
1787 */
1788 (void) tree_map( compile,
1789 (tree_map_fn) compile_check_more, compile->tree, NULL, NULL );
1790
1791 return( TRUE );
1792 }
1793
1794 /* Mark error on all exprs using this compile.
1795 */
1796 void
compile_error_set(Compile * compile)1797 compile_error_set( Compile *compile )
1798 {
1799 (void) slist_map( compile->exprs, (SListMapFn) expr_error_set, NULL );
1800 }
1801
1802 /* Patch a pointer on a patch list.
1803 */
1804 static void *
compile_patch_pointers_sub(void ** pnt,void * nsym,void * osym)1805 compile_patch_pointers_sub( void **pnt, void *nsym, void *osym )
1806 {
1807 g_assert( *pnt == osym );
1808
1809 *pnt = nsym;
1810
1811 return( NULL );
1812 }
1813
1814 /* Patch pointers to old to point to new instead.
1815 */
1816 static void
compile_patch_pointers(Symbol * nsym,Symbol * osym)1817 compile_patch_pointers( Symbol *nsym, Symbol *osym )
1818 {
1819 (void) slist_map2( osym->patch,
1820 (SListMap2Fn) compile_patch_pointers_sub, nsym, osym );
1821 }
1822
1823 /* Sub fn of below.
1824 */
1825 static void *
compile_resolve_sub(Compile * pnt,Symbol * sym)1826 compile_resolve_sub( Compile *pnt, Symbol *sym )
1827 {
1828 if( !g_slist_find( sym->parents, pnt ) )
1829 sym->parents = g_slist_prepend( sym->parents, pnt );
1830
1831 return( NULL );
1832 }
1833
1834 /* Sub fn 2 of below.
1835 */
1836 static void *
compile_resolve_sub1(Compile * compile)1837 compile_resolve_sub1( Compile *compile )
1838 {
1839 return( symbol_fix_counts( compile->sym ) );
1840 }
1841
1842 /* We've found a symbol which is the true definition of an unresolved symbol.
1843 * We fiddle references to zombie to refer to sym instead.
1844 */
1845 static void
compile_resolve(Symbol * sym,Symbol * zombie)1846 compile_resolve( Symbol *sym, Symbol *zombie )
1847 {
1848 #ifdef DEBUG_RESOLVE
1849 printf( "compile_resolve: resolving zombie " );
1850 symbol_name_print( zombie );
1851 printf( "to symbol " );
1852 symbol_name_print( sym );
1853 printf( "\n" );
1854 #endif /*DEBUG_RESOLVE*/
1855
1856 /* Symbol on outer table. Patch pointers to zombie to point to
1857 * sym instead.
1858 */
1859 compile_patch_pointers( sym, zombie );
1860
1861 /* Also unresolved in outer scope?
1862 */
1863 if( sym->type == SYM_ZOMBIE )
1864 /* We may need to move it again - so add the patch
1865 * pointers we have just used to the patch list on
1866 * sym.
1867 */
1868 (void) slist_map( zombie->patch,
1869 (SListMapFn) symbol_patch_add, sym );
1870
1871 /* Add other information the ZOMBIE has picked up. We only
1872 * need to make the link one way: the patching will make the
1873 * other half for us.
1874 */
1875 (void) slist_map( zombie->parents,
1876 (SListMapFn) compile_resolve_sub, sym );
1877
1878 /* Make sure the dirty counts are set correctly. We have
1879 * changed dep (maybe), so need a fiddle.
1880 */
1881 (void) slist_map( zombie->parents,
1882 (SListMapFn) compile_resolve_sub1, NULL );
1883
1884 /* No one refers to the zombie now.
1885 */
1886 IM_FREEF( g_slist_free, zombie->parents );
1887
1888 IDESTROY( zombie );
1889 }
1890
1891 /* Sub-function of below.
1892 */
1893 static void *
compile_resolve_names_sub(Symbol * sym,Compile * outer)1894 compile_resolve_names_sub( Symbol *sym, Compile *outer )
1895 {
1896 const char *name = IOBJECT( sym )->name;
1897 Symbol *old;
1898
1899 /* Is it the sort of thing we are looking for? ZOMBIEs only, please.
1900 */
1901 if( sym->type != SYM_ZOMBIE )
1902 return( NULL );
1903
1904 if( (old = compile_lookup( outer, name )) )
1905 compile_resolve( old, sym );
1906 else {
1907 /* Nothing on the outer table of that name. Can just move the
1908 * symbol across.
1909 */
1910 g_object_ref( G_OBJECT( sym ) );
1911 icontainer_child_remove( ICONTAINER( sym ) );
1912 icontainer_child_add( ICONTAINER( outer ),
1913 ICONTAINER( sym ), -1 );
1914 g_object_unref( G_OBJECT( sym ) );
1915 }
1916
1917 return( NULL );
1918 }
1919
1920 /* End of definition parse: we search the symbol table we have built for this
1921 * definition, looking for unresolved names (ZOMBIEs). If we find any, we move
1922 * the zombie to the enclosing symbol table, since the name may be
1923 * resolved one level up. If we find a symbol on the enclosing table of the
1924 * same name, we have to patch pointers to our inner ZOMBIE to point to this
1925 * new symbol. Nasty!
1926 */
1927 void
compile_resolve_names(Compile * inner,Compile * outer)1928 compile_resolve_names( Compile *inner, Compile *outer )
1929 {
1930 (void) icontainer_map( ICONTAINER( inner ),
1931 (icontainer_map_fn) compile_resolve_names_sub, outer, NULL );
1932 }
1933
1934 /* Hit a top-level zombie during reduction. Search outwards to root looking on
1935 * enclosing tables for a match.
1936 */
1937 Symbol *
compile_resolve_top(Symbol * sym)1938 compile_resolve_top( Symbol *sym )
1939 {
1940 Compile *enclosing;
1941
1942 for( enclosing = COMPILE( ICONTAINER( sym )->parent ); enclosing;
1943 enclosing = compile_get_parent( enclosing ) ) {
1944 Symbol *outer_sym;
1945
1946 if( (outer_sym = compile_lookup( enclosing,
1947 IOBJECT( sym )->name )) &&
1948 outer_sym->type != SYM_ZOMBIE )
1949 return( outer_sym );
1950 }
1951
1952 return( NULL );
1953 }
1954
1955 /* Search outwards for this sym.
1956 */
1957 static void *
compile_resolve_dynamic_sub(Symbol * sym,Compile * context)1958 compile_resolve_dynamic_sub( Symbol *sym, Compile *context )
1959 {
1960 Compile *tab;
1961
1962 if( sym->type != SYM_ZOMBIE )
1963 return( NULL );
1964
1965 for( tab = context; tab; tab = compile_get_parent( tab ) ) {
1966 Symbol *def = compile_lookup( tab, IOBJECT( sym )->name );
1967
1968 if( def && def->type != SYM_ZOMBIE ) {
1969 /* We've found a non-zombie! Bind and we're done.
1970 */
1971 compile_resolve( def, sym );
1972 break;
1973 }
1974 }
1975
1976 return( NULL );
1977 }
1978
1979 /* Resolve ZOMBIEs in tab by searching outwards from context. We only move
1980 * and patch if we find a match ... otherwise we leave the zombie where is is.
1981 *
1982 * This is used for dynamic exprs in the tally display: we don't care about
1983 * fwd refs, but we want to be able to handle multiple scope contexts.
1984 */
1985 void
compile_resolve_dynamic(Compile * tab,Compile * context)1986 compile_resolve_dynamic( Compile *tab, Compile *context )
1987 {
1988 (void) icontainer_map( ICONTAINER( tab ),
1989 (icontainer_map_fn) compile_resolve_dynamic_sub,
1990 context, NULL );
1991 }
1992
1993 Symbol *
compile_get_member(Compile * compile,const char * name)1994 compile_get_member( Compile *compile, const char *name )
1995 {
1996 iContainer *child;
1997
1998 if( is_class( compile ) &&
1999 (child = icontainer_child_lookup( ICONTAINER( compile ),
2000 name )) )
2001 return( SYMBOL( child ) );
2002
2003 return( NULL );
2004 }
2005
2006 const char *
compile_get_member_string(Compile * compile,const char * name)2007 compile_get_member_string( Compile *compile, const char *name )
2008 {
2009 Symbol *member;
2010 Compile *member_compile;
2011
2012 if( (member = compile_get_member( compile, name )) &&
2013 is_value( member ) &&
2014 (member_compile = member->expr->compile) &&
2015 member_compile->tree &&
2016 member_compile->tree->type == NODE_CONST &&
2017 member_compile->tree->con.type == PARSE_CONST_STR )
2018 return( member_compile->tree->con.val.str );
2019
2020 return( NULL );
2021 }
2022
2023 static void *
compile_find_generated_node(Compile * compile,ParseNode * node,GSList ** list)2024 compile_find_generated_node( Compile *compile, ParseNode *node,
2025 GSList **list )
2026 {
2027 Symbol *sym = node->leaf;
2028
2029 if( node->type == NODE_LEAF &&
2030 sym->generated &&
2031 symbol_get_parent( sym ) &&
2032 symbol_get_parent( sym )->expr->compile == compile )
2033 *list = g_slist_prepend( *list, sym );
2034
2035 return( NULL );
2036 }
2037
2038 /* Search a scrap of tree and build a list of all the lambdas/lcomps/etc. it
2039 * generated.
2040 */
2041 static GSList *
compile_find_generated(Compile * compile,ParseNode * tree)2042 compile_find_generated( Compile *compile, ParseNode *tree )
2043 {
2044 GSList *list;
2045
2046 list = NULL;
2047 tree_map( compile,
2048 (tree_map_fn) compile_find_generated_node, tree, &list, NULL );
2049
2050 return( list );
2051 }
2052
2053 /* Make a copy of sym (and all it's children and trees) in the destination
2054 * scope. This only works for stuff from the parse stage. Symbols which have
2055 * values and stuff attached are too complicated to copy easily.
2056 */
2057 static void *
compile_copy_sym(Symbol * sym,Compile * dest)2058 compile_copy_sym( Symbol *sym, Compile *dest )
2059 {
2060 const char *name = IOBJECT( sym )->name;
2061 Symbol *copy_sym;
2062
2063 #ifdef DEBUG
2064 printf( "compile_copy_sym: copying " );
2065 symbol_name_print( sym );
2066 printf( "to scope of " );
2067 compile_name_print( dest );
2068 printf( "\n" );
2069 #endif /*DEBUG*/
2070
2071 /* Must be a different place.
2072 */
2073 g_assert( symbol_get_parent( sym )->expr->compile != dest );
2074
2075 /* Must not be an existing sym of that name. Or if there is, it has to
2076 * be a zombie.
2077 */
2078 g_assert( !compile_lookup( dest, name ) ||
2079 compile_lookup( dest, name )->type == SYM_ZOMBIE );
2080
2081 switch( sym->type ) {
2082 case SYM_VALUE:
2083 copy_sym = symbol_new_defining( dest, name );
2084 copy_sym->generated = sym->generated;
2085 (void) symbol_user_init( copy_sym );
2086 (void) compile_new_local( copy_sym->expr );
2087
2088 /* Copy any locals over. We have to do this before we copy the
2089 * tree so that the new tree links to the new syms.
2090 */
2091 icontainer_map( ICONTAINER( sym->expr->compile ),
2092 (icontainer_map_fn) compile_copy_sym,
2093 copy_sym->expr->compile, NULL );
2094
2095 copy_sym->expr->compile->tree = tree_copy(
2096 copy_sym->expr->compile, sym->expr->compile->tree );
2097
2098 /* Copying the tree may have made some zombies. Resolve
2099 * outwards.
2100 */
2101 compile_resolve_names( copy_sym->expr->compile, dest );
2102
2103 break;
2104
2105 case SYM_PARAM:
2106 copy_sym = symbol_new_defining( dest, name );
2107 copy_sym->generated = sym->generated;
2108 symbol_parameter_init( copy_sym );
2109 break;
2110
2111 case SYM_ZOMBIE:
2112 break;
2113
2114 case SYM_WORKSPACE:
2115 case SYM_WORKSPACEROOT:
2116 case SYM_ROOT:
2117 case SYM_EXTERNAL:
2118 case SYM_BUILTIN:
2119 default:
2120 g_assert( 0 );
2121 }
2122
2123 return( NULL );
2124 }
2125
2126 /* tree is a scrap of graph in fromscope's context. It may have caused the
2127 * generation of a number of lambdas, lcomps etc. in fromscope. Make a copy
2128 * of the tree in toscope and copy over any generated syms too. fromscope and
2129 * toscope can be the same, in which case we can just copy the tree.
2130 */
2131 ParseNode *
compile_copy_tree(Compile * fromscope,ParseNode * tree,Compile * toscope)2132 compile_copy_tree( Compile *fromscope, ParseNode *tree, Compile *toscope )
2133 {
2134 ParseNode *copy_tree;
2135
2136 #ifdef DEBUG
2137 printf( "compile_copy_tree: copying tree from " );
2138 compile_name_print( fromscope );
2139 printf( " to " );
2140 compile_name_print( toscope );
2141 printf( "\n" );
2142 #endif /*DEBUG*/
2143
2144 /* A new context? Copy generated syms over.
2145 */
2146 if( fromscope != toscope ) {
2147 GSList *generated;
2148
2149 generated = compile_find_generated( fromscope, tree );
2150
2151 #ifdef DEBUG
2152 printf( "with generated children: " );
2153 (void) slist_map( generated, (SListMapFn) dump_tiny, NULL );
2154 printf( "\n" );
2155 #endif /*DEBUG*/
2156
2157 slist_map( generated,
2158 (SListMapFn) compile_copy_sym, toscope );
2159
2160 g_slist_free( generated );
2161 }
2162
2163 copy_tree = tree_copy( toscope, tree );
2164
2165 /* Copying the tree may have made some zombies. Resolve
2166 * outwards.
2167 */
2168 compile_resolve_names( toscope, compile_get_parent( toscope ) );
2169
2170 return( copy_tree );
2171 }
2172
2173 /* Generate the parse tree for this list comprehension.
2174
2175 Example: after parse we have:
2176
2177 [(x, y) :: x <- [1..3]; y <- [x..3]; x + y > 3];
2178
2179 ... $$lcomp1 ...
2180 {
2181 $$lcomp1 = NULL
2182 {
2183 $$result = (x, y);
2184 // elements in left-to-right order
2185 // in compile->children
2186 x = [1..3]
2187 y = [x..3]
2188 $$filter1 = x + y > 3
2189 }
2190 }
2191
2192 and we generate this code:
2193
2194 z = $$lcomp1
2195 {
2196 $$lcomp1 = foldr $f1 [] [1..3]
2197 {
2198 $f1 x $sofar = foldr $f2 $sofar [x..3]
2199 {
2200 $f2 y $sofar = if x + y > 3 then $f3 else $sofar
2201 {
2202 $f3 = (x, y) : $sofar;
2203 }
2204 }
2205 }
2206 }
2207
2208 */
2209
2210 /* Find the placeholders generated by the parser. Filters, generators,
2211 * patterns and $$result.
2212 */
2213 static void *
compile_lcomp_find(Symbol * sym,GSList ** children)2214 compile_lcomp_find( Symbol *sym, GSList **children )
2215 {
2216 if( sym->placeholder )
2217 *children = g_slist_append( *children, sym );
2218
2219 return( NULL );
2220 }
2221
2222 static Symbol *
compile_lcomp_find_pattern(GSList * children,const char * generator)2223 compile_lcomp_find_pattern( GSList *children, const char *generator )
2224 {
2225 int n;
2226 char pattern[256];
2227 GSList *p;
2228
2229 if( sscanf( generator, "$$generator%d", &n ) != 1 )
2230 return( NULL );
2231 im_snprintf( pattern, 256, "$$pattern%d", n );
2232
2233 for( p = children; p; p = p->next ) {
2234 Symbol *sym = (Symbol *) p->data;
2235
2236 if( strcmp( IOBJECT( sym )->name, pattern ) == 0 )
2237 return( sym );
2238 }
2239
2240 return( NULL );
2241 }
2242
2243 void
compile_lcomp(Compile * compile)2244 compile_lcomp( Compile *compile )
2245 {
2246 /* Number nested locals with this. Keep numbering global so debugging
2247 * nested lcomps is easier.
2248 */
2249 static int count = 1;
2250
2251 GSList *children;
2252 gboolean sofar;
2253 Compile *scope;
2254 Symbol *result;
2255 GSList *p;
2256 Symbol *child;
2257 char name[256];
2258 ParseNode *n1, *n2, *n3;
2259
2260 #ifdef DEBUG_LCOMP
2261 printf( "before compile_lcomp:\n" );
2262 dump_compile( compile );
2263 #endif /*DEBUG_LCOMP*/
2264
2265 /* Find all the elements of the lcomp: generators, filters, patterns
2266 * and $$result.
2267 */
2268 children = NULL;
2269 (void) icontainer_map( ICONTAINER( compile ),
2270 (icontainer_map_fn) compile_lcomp_find, &children, NULL );
2271
2272 #ifdef DEBUG_LCOMP
2273 printf( "list comp " );
2274 compile_name_print( compile );
2275 printf( " has children: " );
2276 (void) slist_map( children, (SListMapFn) dump_tiny, NULL );
2277 printf( "\n" );
2278 #endif /*DEBUG_LCOMP*/
2279
2280 /* As yet no list to build on.
2281 */
2282 sofar = FALSE;
2283
2284 /* Start by building a tree in this scope.
2285 */
2286 scope = compile;
2287
2288 /* Not seen the result element yet, but we should.
2289 */
2290 result = NULL;
2291
2292 /* Now generate code for each element, either a filter or a generator.
2293 * If we do a generator, we need to search for the associated pattern
2294 * and expand it.
2295 */
2296 for( p = children; p; p = p->next ) {
2297 Symbol *element = (Symbol *) p->data;
2298
2299 /* Just note the result element ... we use it right at the end.
2300 */
2301 if( strcmp( "$$result", IOBJECT( element )->name ) == 0 ) {
2302 result = element;
2303 continue;
2304 }
2305
2306 /* And only process filter/gen.
2307 */
2308 if( !is_prefix( "$$filter", IOBJECT( element )->name ) &&
2309 !is_prefix( "$$gen", IOBJECT( element )->name ) )
2310 continue;
2311
2312 /* Start the next nest in. child is the local we will make for
2313 * this scope.
2314 */
2315 im_snprintf( name, 256, "$$fn%d", count++ );
2316 child = symbol_new_defining( scope, name );
2317 child->generated = TRUE;
2318 (void) symbol_user_init( child );
2319 (void) compile_new_local( child->expr );
2320
2321 if( is_prefix( "$$filter", IOBJECT( element )->name ) ) {
2322 /* A filter.
2323 */
2324 n1 = compile_copy_tree( compile,
2325 element->expr->compile->tree,
2326 scope );
2327 n2 = tree_leafsym_new( scope, child );
2328 n3 = tree_leaf_new( scope, "$$sofar" );
2329 n1 = tree_ifelse_new( scope, n1, n2, n3 );
2330 scope->tree = n1;
2331 }
2332 else if( is_prefix( "$$gen", IOBJECT( element )->name ) ) {
2333 Symbol *param1;
2334 Symbol *param2;
2335 Symbol *pattern;
2336 GSList *built_syms;
2337
2338 /* A generator.
2339 */
2340 param1 = symbol_new_defining( child->expr->compile,
2341 IOBJECT( element )->name );
2342 param1->generated = TRUE;
2343 symbol_parameter_init( param1 );
2344 param2 = symbol_new_defining( child->expr->compile,
2345 "$$sofar" );
2346 param2->generated = TRUE;
2347 symbol_parameter_init( param2 );
2348
2349 /* Now expand the pattern: it will access parts of the
2350 * $$generator argument.
2351 */
2352 pattern = compile_lcomp_find_pattern( children,
2353 IOBJECT( element )->name );
2354 g_assert( pattern );
2355 built_syms = compile_pattern_lhs( child->expr->compile,
2356 param1, pattern->expr->compile->tree );
2357 g_slist_free( built_syms );
2358
2359 /* Make the "foldr $$fn $sofar expr" tree.
2360 */
2361 n1 = tree_leaf_new( scope, "foldr" );
2362 n2 = tree_leafsym_new( scope, child );
2363 n3 = tree_appl_new( scope, n1, n2 );
2364 if( sofar )
2365 n2 = tree_leaf_new( scope, "$$sofar" );
2366 else {
2367 ParseConst con;
2368
2369 con.type = PARSE_CONST_ELIST;
2370 n2 = tree_const_new( scope, con );
2371 }
2372 n3 = tree_appl_new( scope, n3, n2 );
2373 n2 = compile_copy_tree( compile,
2374 element->expr->compile->tree,
2375 scope );
2376 n3 = tree_appl_new( scope, n3, n2 );
2377 scope->tree = n3;
2378
2379 /* There's now an enclosing sofar we can use.
2380 */
2381 sofar = TRUE;
2382 }
2383
2384 /* Nest in again.
2385 */
2386 scope = child->expr->compile;
2387 }
2388
2389 /* Copy the code for the final result.
2390 */
2391 g_assert( result );
2392
2393 n1 = compile_copy_tree( result->expr->compile,
2394 result->expr->compile->tree, scope );
2395 n2 = tree_leaf_new( scope, "$$sofar" );
2396 n3 = tree_binop_new( compile, BI_CONS, n1, n2 );
2397 scope->tree = n3;
2398
2399 /* Loop outwards again, closing the scopes we made.
2400 */
2401 while( scope != compile ) {
2402 /* We know check can't fail on generated code.
2403
2404 FIXME ... yuk, maybe compile_lcomp should be
2405 failable too
2406
2407 */
2408 (void) compile_check( scope );
2409 compile_resolve_names( scope, compile_get_parent( scope ) );
2410
2411 scope = compile_get_parent( scope );
2412 }
2413
2414 #ifdef DEBUG_LCOMP
2415 printf( "after compile_lcomp:\n" );
2416 dump_compile( compile );
2417 #endif /*DEBUG_LCOMP*/
2418
2419 g_slist_free( children );
2420 }
2421
2422 /* Compile a pattern LHS. Generate a sym for each pattern variable, each of
2423 * which checks and accesses sym. For example:
2424 *
2425 * [a] = x;
2426 *
2427 * compiles to:
2428 *
2429 * sym = x;
2430 * a = if is_list sym && len sym == 1 then sym?0 else error "..";
2431 */
2432
2433 /* Generate code to access element n of a pattern trail. Eg, pattern is
2434 * [[[a]]]
2435 * the trail will be
2436 * 0) LISTCONST 1) LISTCONST 2) LISTCONST 3) LEAF
2437 * then access(0) will be
2438 * leaf
2439 * and access(1) will be
2440 * leaf?0
2441 * and access(3) (to get the value for a) will be
2442 * leaf?0?0?0
2443 */
2444 static ParseNode *
compile_pattern_access(Compile * compile,Symbol * leaf,ParseNode ** trail,int n)2445 compile_pattern_access( Compile *compile,
2446 Symbol *leaf, ParseNode **trail, int n )
2447 {
2448 ParseNode *node;
2449 ParseNode *left;
2450 ParseNode *right;
2451 ParseConst c;
2452 int i;
2453
2454 /* The initial leaf ref we access from.
2455 */
2456 node = tree_leafsym_new( compile, leaf );
2457
2458 for( i = 0; i < n; i++ )
2459 switch( trail[i]->type ) {
2460 case NODE_CONST:
2461 case NODE_PATTERN_CLASS:
2462 case NODE_LEAF:
2463 break;
2464
2465 case NODE_BINOP:
2466 switch( trail[i]->biop ) {
2467 case BI_COMMA:
2468 /* Generate re or im?
2469 */
2470 if( trail[i]->arg1 == trail[i + 1] )
2471 left = tree_leaf_new( compile, "re" );
2472 else
2473 left = tree_leaf_new( compile, "im" );
2474 node = tree_appl_new( compile, left, node );
2475 break;
2476
2477 case BI_CONS:
2478 /* Generate hd or tl?
2479 */
2480 if( trail[i]->arg1 == trail[i + 1] )
2481 left = tree_leaf_new( compile, "hd" );
2482 else
2483 left = tree_leaf_new( compile, "tl" );
2484 node = tree_appl_new( compile, left, node );
2485 break;
2486
2487 default:
2488 g_assert( 0 );
2489 }
2490 break;
2491
2492 case NODE_LISTCONST:
2493 /* Which list element do we need? Look for the next
2494 * item in the trail in the list of elements.
2495 */
2496 c.type = PARSE_CONST_NUM;
2497 c.val.num = g_slist_index( trail[i]->elist,
2498 trail[i + 1] );
2499 right = tree_const_new( compile, c );
2500 node = tree_binop_new( compile,
2501 BI_SELECT, node, right );
2502 break;
2503
2504 default:
2505 g_assert( 0 );
2506 }
2507
2508 return( node );
2509 }
2510
2511 /* Generate a parsetree for the condition test. The array of nodes represents
2512 * the set of conditions we have to test, left to right.
2513 */
2514 static ParseNode *
compile_pattern_condition(Compile * compile,Symbol * leaf,ParseNode ** trail,int depth)2515 compile_pattern_condition( Compile *compile,
2516 Symbol *leaf, ParseNode **trail, int depth )
2517 {
2518 ParseConst n;
2519 ParseNode *node;
2520 ParseNode *node2;
2521 ParseNode *left;
2522 ParseNode *right;
2523 int i;
2524
2525 n.type = PARSE_CONST_BOOL;
2526 n.val.bool = TRUE;
2527 node = tree_const_new( compile, n );
2528
2529 for( i = depth - 1; i >= 0; i-- ) {
2530 switch( trail[i]->type ) {
2531 case NODE_LEAF:
2532 break;
2533
2534 case NODE_BINOP:
2535 switch( trail[i]->biop ) {
2536 case BI_COMMA:
2537 /* Generate is_complex x.
2538 */
2539 left = tree_leaf_new( compile, "is_complex" );
2540 right = compile_pattern_access( compile,
2541 leaf, trail, i );
2542 node2 = tree_appl_new( compile, left, right );
2543
2544 node = tree_binop_new( compile,
2545 BI_LAND, node2, node );
2546 break;
2547
2548 case BI_CONS:
2549 /* Generate is_list x && x != [].
2550 */
2551 left = tree_leaf_new( compile, "is_list" );
2552 right = compile_pattern_access( compile,
2553 leaf, trail, i );
2554 node2 = tree_appl_new( compile, left, right );
2555
2556 node = tree_binop_new( compile,
2557 BI_LAND, node2, node );
2558
2559 left = compile_pattern_access( compile,
2560 leaf, trail, i );
2561 n.type = PARSE_CONST_ELIST;
2562 right = tree_const_new( compile, n );
2563 node2 = tree_binop_new( compile,
2564 BI_NOTEQ, left, right );
2565
2566 node = tree_binop_new( compile,
2567 BI_LAND, node, node2 );
2568 break;
2569
2570 default:
2571 g_assert( 0 );
2572 }
2573 break;
2574
2575 case NODE_LISTCONST:
2576 /* Generate is_list x && is_list_len n x.
2577 */
2578 left = tree_leaf_new( compile, "is_list" );
2579 right = compile_pattern_access( compile,
2580 leaf, trail, i );
2581 node2 = tree_appl_new( compile, left, right );
2582
2583 node = tree_binop_new( compile, BI_LAND, node2, node );
2584
2585 left = tree_leaf_new( compile, "is_list_len" );
2586 n.type = PARSE_CONST_NUM;
2587 n.val.num = g_slist_length( trail[i]->elist );
2588 right = tree_const_new( compile, n );
2589 left = tree_appl_new( compile, left, right );
2590 right = compile_pattern_access( compile,
2591 leaf, trail, i );
2592 node2 = tree_appl_new( compile, left, right );
2593
2594 node = tree_binop_new( compile, BI_LAND, node, node2 );
2595 break;
2596
2597 case NODE_CONST:
2598 /* Generate x == n.
2599 */
2600 left = compile_pattern_access( compile,
2601 leaf, trail, i );
2602 right = tree_const_new( compile, trail[i]->con );
2603 node2 = tree_binop_new( compile, BI_EQ, left, right );
2604
2605 node = tree_binop_new( compile, BI_LAND, node2, node );
2606 break;
2607
2608 case NODE_PATTERN_CLASS:
2609 /* Generate is_instanceof "class-name" x.
2610 */
2611 left = tree_leaf_new( compile, "is_instanceof" );
2612 n.type = PARSE_CONST_STR;
2613 n.val.str = im_strdupn( trail[i]->tag );
2614 right = tree_const_new( compile, n );
2615 node2 = tree_appl_new( compile, left, right );
2616 right = compile_pattern_access( compile,
2617 leaf, trail, i );
2618 node2 = tree_appl_new( compile, node2, right );
2619
2620 node = tree_binop_new( compile, BI_LAND, node2, node );
2621 break;
2622
2623 default:
2624 g_assert( 0 );
2625 }
2626 }
2627
2628 return( node );
2629 }
2630
2631 /* Generate a parsetree for a "pattern match failed" error.
2632 */
2633 static ParseNode *
compile_pattern_error(Compile * compile,Symbol * leaf)2634 compile_pattern_error( Compile *compile, Symbol *leaf )
2635 {
2636 ParseNode *left;
2637 ParseConst n;
2638 ParseNode *right;
2639 ParseNode *node;
2640
2641 left = tree_leaf_new( compile, "error" );
2642 n.type = PARSE_CONST_STR;
2643 n.val.str = im_strdupn( _( "pattern match failed" ) );
2644 right = tree_const_new( compile, n );
2645 node = tree_appl_new( compile, left, right );
2646
2647 return( node );
2648 }
2649
2650 /* Depth of trail we keep as we walk the pattern.
2651 */
2652 #define MAX_TRAIL (10)
2653
2654 typedef struct _PatternLhs {
2655 Compile *compile; /* Scope in which we generate new symbols */
2656 Symbol *sym; /* Thing we access */
2657
2658 /* The trail of nodes representing this slice of the pattern.
2659 */
2660 ParseNode *trail[MAX_TRAIL];
2661 int depth;
2662 GSList *built_syms;
2663 } PatternLhs;
2664
2665 /* Generate one reference. leaf is the new sym we generate.
2666 */
2667 static void
compile_pattern_lhs_leaf(PatternLhs * lhs,Symbol * leaf)2668 compile_pattern_lhs_leaf( PatternLhs *lhs, Symbol *leaf )
2669 {
2670 Symbol *sym;
2671 Compile *compile;
2672
2673 sym = symbol_new_defining( lhs->compile, IOBJECT( leaf )->name );
2674 sym->generated = TRUE;
2675 (void) symbol_user_init( sym );
2676 (void) compile_new_local( sym->expr );
2677 lhs->built_syms = g_slist_prepend( lhs->built_syms, sym );
2678 compile = sym->expr->compile;
2679
2680 compile->tree = tree_ifelse_new( compile,
2681 compile_pattern_condition( compile,
2682 lhs->sym, lhs->trail, lhs->depth ),
2683 compile_pattern_access( compile,
2684 lhs->sym, lhs->trail, lhs->depth ),
2685 compile_pattern_error( compile, leaf ) );
2686
2687 #ifdef DEBUG_PATTERN
2688 printf( "compile_pattern_lhs_leaf: generated\n" );
2689 dump_compile( compile );
2690 #endif /*DEBUG_PATTERN*/
2691 }
2692
2693 /* Recurse over the pattern generating references.
2694 */
2695 static void *
compile_pattern_lhs_sub(ParseNode * node,PatternLhs * lhs)2696 compile_pattern_lhs_sub( ParseNode *node, PatternLhs *lhs )
2697 {
2698 lhs->trail[lhs->depth++] = node;
2699
2700 switch( node->type ) {
2701 case NODE_LEAF:
2702 compile_pattern_lhs_leaf( lhs, node->leaf );
2703 break;
2704
2705 case NODE_PATTERN_CLASS:
2706 compile_pattern_lhs_sub( node->arg1, lhs );
2707 break;
2708
2709 case NODE_BINOP:
2710 compile_pattern_lhs_sub( node->arg1, lhs );
2711 compile_pattern_lhs_sub( node->arg2, lhs );
2712 break;
2713
2714 case NODE_LISTCONST:
2715 slist_map( node->elist,
2716 (SListMapFn) compile_pattern_lhs_sub, lhs );
2717 break;
2718
2719 case NODE_CONST:
2720 break;
2721
2722 default:
2723 g_assert( 0 );
2724 }
2725
2726 lhs->depth--;
2727
2728 return( NULL );
2729 }
2730
2731 /* Something like "[a] = [1];". sym is the $$pattern we are generating access
2732 * syms for, node is the pattern tree, compile is the scope in which we
2733 * generate the new defining symbols. Return a list of the syms we built: they
2734 * will need any final finishing up and then having symbol_made() called on
2735 * them. You need to free the list, too.
2736 */
2737 GSList *
compile_pattern_lhs(Compile * compile,Symbol * sym,ParseNode * node)2738 compile_pattern_lhs( Compile *compile, Symbol *sym, ParseNode *node )
2739 {
2740 PatternLhs lhs;
2741
2742 #ifdef DEBUG_PATTERN
2743 printf( "compile_pattern_lhs: building access fns for %s\n",
2744 symbol_name( sym ) );
2745 #endif /*DEBUG_PATTERN*/
2746
2747 lhs.compile = compile;
2748 lhs.sym = sym;
2749 lhs.depth = 0;
2750 lhs.built_syms = NULL;
2751
2752 compile_pattern_lhs_sub( node, &lhs );
2753
2754 g_assert( lhs.depth == 0 );
2755
2756 return( lhs.built_syms );
2757 }
2758
2759 static ParseNode *
compile_pattern_has_leaf_sub(Compile * compile,ParseNode * node,void * a,void * b)2760 compile_pattern_has_leaf_sub( Compile *compile,
2761 ParseNode *node, void *a, void *b )
2762 {
2763 if( node->type == NODE_LEAF )
2764 return( node );
2765
2766 return( NULL );
2767 }
2768
2769 /* Does a pattern contain a leaf? We don't allow const-only patterns in
2770 * definitions.
2771 */
2772 gboolean
compile_pattern_has_leaf(ParseNode * node)2773 compile_pattern_has_leaf( ParseNode *node )
2774 {
2775 return( tree_map( NULL,
2776 (tree_map_fn) compile_pattern_has_leaf_sub, node,
2777 NULL, NULL ) != NULL );
2778 }
2779