1# Copyright (C) 2004-2012, Parrot Foundation.
2package Parrot::Pmc2c::Method;
3use strict;
4use warnings;
5use Parrot::Pmc2c::UtilFunctions qw( args_from_parameter_list passable_args_from_parameter_list );
6use Parrot::Pmc2c::PCCMETHOD ();
7
8=head1 NAME
9
10Parrot::Pmc2c::Method
11
12=head1 DESCRIPTION
13
14Functions used in transformation of PMCs to C code.
15
16=head1 METHODS
17
18=head2 C<new()>
19
20Parrot::Pmc2c::Method constructor.
21
22=cut
23
24use constant VTABLE_ENTRY => 'VTABLE_ENTRY';
25use constant VTABLE       => 'VTABLE';
26use constant NON_VTABLE   => 'NON_VTABLE';
27use constant MULTI        => 'MULTI';
28
29sub new {
30    my ( $class, $self_hash ) = @_;
31    my $self = {
32        (
33            attrs       => {},
34            body        => "",
35            parameters  => "",
36            parent_name => "",
37            decorators  => [],
38            pmc_unused  => 0,
39            interp_unused => 0,
40            %{ $self_hash || {} }
41        )
42    };
43
44    # this is usually wrong, but *something* calls new on an object somewhere
45    bless $self, ref $class || $class;
46
47    return $self;
48}
49
50sub clone {
51    my ( $self, $self_hash ) = @_;
52    return $self->new( { ( %{$self}, %{ $self_hash || {} } ) } );
53}
54
55
56#getters/setters
57for my $x ( qw( name parent_name type return_type body symbol attrs decorators parameters ) ) {
58    my $code = <<'EOC';
59sub REPLACE {
60    my ( $self, $value ) = @_;
61    $self->{REPLACE} = $value if defined $value;
62    return $self->{REPLACE}
63}
64EOC
65        $code =~ s/REPLACE/$x/g;
66        eval $code;
67    }
68
69sub is_vtable {
70    my $type = shift->type;
71    return $type eq VTABLE || $type eq VTABLE_ENTRY;
72}
73
74sub is_multi {
75    my ($self) = @_;
76    return $self->type eq MULTI;
77}
78
79# if is_ro
80sub pmc_unused {
81    return shift->{pmc_unused};
82}
83
84# detect empty body, like return 1
85sub interp_unused {
86    my ($self) = @_;
87
88    my $body = $self->body;
89    if ($body->{data} and $body->{data} =~ /^\s+return 1;\s+$/) {
90        $self->{interp_unused} = 1;
91        $self->{pmc_unused} = 1;
92    }
93    return $self->{interp_unused};
94}
95
96sub vtable_method_has_manual_wb {
97    my ( $method ) = @_;
98    return $method->{attrs}->{manual_wb};
99}
100
101=head2 C<trans($type)>
102
103Used in C<signature()> to normalize argument types.
104
105=cut
106
107sub trans {
108    my ( $self, $type ) = @_;
109
110    return 'v' unless $type;
111
112    my $char = substr $type, 0, 1;
113
114    return $1  if $char =~ /([ISP])/;
115    return 'N' if $char eq 'F';
116    return 'V' if $type =~ /void\s*\*/;
117    return 'v' if $type =~ /void\s*$/;
118    return 'P' if $type =~ /opcode_t\*/;
119    return 'I' if $type =~ /int(val)?/i;
120    return '?';
121}
122
123=head2 C<signature()>
124
125Returns the method signature for the methods $parameters
126
127=cut
128
129sub signature {
130    my ($self) = @_;
131
132    my $args             = passable_args_from_parameter_list( $self->parameters );
133    my ($types, $vars)   = args_from_parameter_list( $self->parameters );
134    my $return_type      = $self->return_type;
135    my $return_type_char = $self->trans($return_type);
136    my $sig              = $self->trans($return_type) .
137                           join '', map { $self->trans($_) } @{$types};
138    my $return_prefix    = '';
139    my $method_suffix    = '';
140
141    if ( $return_type ne 'void' ) {
142        $return_prefix = "return ($return_type)";
143
144        # PMC* and STRING* don't need a special suffix
145        if ( $return_type !~ /\*/ ) {
146            $method_suffix = "_ret" . lc substr $return_type, 0, 1;
147
148            # change UINTVAl type to reti
149            $method_suffix =~ s/_retu/_reti/;
150        }
151    }
152
153    my $null_return = '';
154    $null_return = "return ($return_type) NULL;" if $return_type_char =~ /P|I|S|V/;
155    $null_return = 'return (FLOATVAL) 0;'        if $return_type_char =~ /N/;
156    $null_return = 'return;'                     if $return_type_char =~ /v/;
157
158    return ( $return_prefix, $method_suffix, $args, $sig, $return_type_char, $null_return );
159}
160
161=head2 C<pcc_signature()>
162
163Returns a PCC-style method signature for the method's parameters, as well as
164some additional information useful in building a call to that method.
165
166=cut
167
168sub pcc_signature {
169    my ($self) = @_;
170
171    my $args             = passable_args_from_parameter_list( $self->parameters );
172    my ($types, $vars)   = args_from_parameter_list( $self->parameters );
173    my $return_type      = $self->return_type;
174    my $return_type_char = $self->trans($return_type);
175    my $sig              = join ('', map { $self->trans($_) } @{$types}) .
176                           '->';
177
178    my $result_decl    = '';
179    my $return_stmt    = '';
180
181    if ( $return_type eq 'void' ) {
182        $return_stmt = "return ($return_type) NULL;" if $return_type_char =~ /P|I|S|V/;
183        $return_stmt = 'return (FLOATVAL) 0;'        if $return_type_char =~ /N/;
184        $return_stmt = 'return;'                     if $return_type_char =~ /v/;
185    }
186    else {
187        $result_decl = "$return_type result;";
188        $result_decl = "$return_type result = PMCNULL;" if $return_type_char eq 'P';
189        $args .= ', &result';
190        $sig .= $return_type_char;
191        $return_stmt = "return ($return_type) result;";
192    }
193
194    return ( $sig, $args, $result_decl, $return_stmt );
195}
196
197=over 4
198
199=item C<generate_body($pmc)>
200
201Generate and emit the C code for the method body.
202
203=cut
204
205sub generate_body {
206    my ( $self, $pmc ) = @_;
207    my $emit = sub { $pmc->{emitter}->emit(@_) };
208
209    Parrot::Pmc2c::PCCMETHOD::rewrite_RETURNs( $self, $pmc );
210    Parrot::Pmc2c::PCCMETHOD::rewrite_pccinvoke( $self, $pmc );
211
212    my $body = $self->body;
213
214    if ( $self->is_vtable ) {
215        $self->rewrite_vtable_method($pmc);
216    }
217    else {
218        $self->rewrite_nci_method($pmc);
219    }
220
221    $emit->( $self->decl( $pmc, 'CFILE' ) );
222    $emit->("{\n");
223    $emit->($body);
224    $emit->("}\n");
225
226    return 1;
227}
228
229sub generate_headers {
230    my ( $self, $pmc ) = @_;
231
232    my $hout = $self->decl( $pmc, 'HEADER' );
233
234    return $hout;
235}
236
237=item C<decl($classname, $method, $for_header)>
238
239Returns the C code for the PMC method declaration. C<$for_header>
240indicates whether the code is for a header or implementation file.
241
242=cut
243
244sub decl {
245    my ( $self, $pmc, $for_header ) = @_;
246
247    my $pmcname = $pmc->name;
248    my $ret     = $self->return_type;
249    my $meth    = $self->name;
250    my $args    = $self->parameters;
251    my $decs    = join( $/, @{$self->decorators}, '' );
252
253    # convert 'type*' to 'type *' per PDD07
254    $ret =~ s/^(.*)\s*(\*)$/$1 $2/;
255
256    # convert args to PDD07
257    $self->{parameters} =~ s/(\w+)\s*(\*)\s*/$1 $2/g;
258    $args = $self->parameters;
259    $args = ", $args" if $args =~ /\S/;
260
261    # SHIM UNUSED(args) in body
262    my $body = $self->body;
263    if ($body =~ /^\s*(return \d;|)$/s) { # empty body
264        $self->{interp_unused} = 1;
265        $self->{pmc_unused}    = 1;
266    }
267    my (%unused, $cnt);
268    if ($body->{data} and $body->{data} !~ /^\s*#if/m) {
269        if (!$self->attrs->{manual_wb} and $body->{data} =~ m|^\s*(/* no )?PARROT_GC_WRITE_BARRIER|m) {
270            $self->attrs->{manual_wb} = 1;
271        }
272        while ($body->{data} =~ /^\s*UNUSED\((\w+)\);?\n/m) {
273            my $key = $1;
274            $cnt++;
275            if ($cnt > 6) {
276                # This happens when the $body->{data} =~ s/// lines below do not remove the line
277                warn "Internal Error: UNUSED($key) detection recursion in $pmcname.$meth($args)\n"
278                  .$body->{data}."\n";
279                last;
280            }
281            if (($key eq 'INTERP' or $key eq 'interp') and !$self->{need_write_barrier}) {
282                $unused{INTERP}++;
283                $self->{interp_unused} = 1;
284                $body->{data} =~ s/^\s*UNUSED\($key\);?\n//m;
285                warn "Replace UNUSED(interp) with UNUSED(INTERP) in $pmcname METHOD $meth\n"
286                  if $key eq 'interp'
287                    and $self->{parent_name} ne 'Null'
288                      and $body->{data} !~ /^\s*$/;
289            } elsif ($body->{data} =~ /^\s*UNUSED\(SELF\)/m and !$self->{need_write_barrier}) {
290                $unused{SELF}++;
291                $self->{pmc_unused} = 1;
292                $body->{data} =~ s/^\s*UNUSED\(SELF\);?\n//m;
293            } elsif ($args =~ s/, (\w+ \*?$key)/, SHIM($1)/) {
294                $unused{$key}++;
295                $body->{data} =~ s/^\s*UNUSED\($key\);?\n//m;
296                $self->{parameters} =~ s/(\w+ \*?$key)/SHIM($1)/;
297            }
298            else {
299                $body->{data} =~ s|^(\s*)UNUSED\($key\);?\n|$1/**/UNUSED\($key\)\n|m;
300                if ($self->{need_write_barrier} and $key =~ /^interp|SELF$/i) {
301                    #warn "Useless use of SHIM UNUSED($key) in $pmcname METHOD $meth: kept for write barrier\n";
302                    ; # XXX ignore this for while until GC WB is stable
303                }
304                else {
305                    $unused{$key}++;
306                    warn "Did not SHIM UNUSED($key) in $pmcname METHOD $meth\n";
307                }
308                last;
309            }
310        }
311    }
312
313    my $params = $self->parameters;
314    for my $key ('INTERP', 'SELF',
315                 map { /.*\b(\w+)$/ } split /,\s*/, $params) {
316        my $inbody = $key eq 'INTERP' ? '(INTERP|interp)'
317                                      : $key eq 'SELF' ? '(_self|SELF)'
318                                                       : $key;
319        if ($body->{data} and !exists($unused{$key}) and $body->{data} !~ /$inbody/) {
320            if ($key eq 'INTERP' and ($self->interp_unused or $body->{data} =~ /(SUPER|STATICSELF|SELF\.)/)) {}
321            elsif ($key eq 'SELF' and ($self->pmc_unused or $body->{data} =~ /(SUPER|STATICSELF)/)) {}
322            elsif ($key =~ /^(INTERP|value)$/ and $pmcname =~ /^(BigInt|BigNum)$/
323                   and $body->{data} =~ /NO_MULTIPLE_DISPATCH/) {}
324            elsif ($self->attrs->{no_wb}) {
325                warn "Possibly forgotten UNUSED($key) in $pmcname METHOD $meth\n"
326                  if $pmcname !~ /^(default|Null|Proxy)$/; # These are valid problems but autogenerated
327            }
328        }
329    }
330
331    my ( $extern, $newl, $semi );
332    if ( $for_header eq 'HEADER' ) {
333        $newl   = ' ';
334        $semi   = ';';
335    }
336    else {
337        $newl   = "\n";
338        $semi   = '';
339    }
340    my $interp = $self->interp_unused ? 'SHIM_INTERP' : 'PARROT_INTERP';
341    my $pmcarg = $self->pmc_unused ? 'SHIM(PMC *_self)' : 'ARGMOD(PMC *_self)';
342    my $static = $pmcname eq 'CallContext' ? "" : "static";
343
344    return <<"EOC";
345$static $decs $ret${newl}Parrot_${pmcname}_$meth($interp, $pmcarg$args)$semi
346EOC
347}
348
349=item C<rewrite_nci_method($self, $pmc )>
350
351Rewrites the method body performing the various macro substitutions for
352nci method bodies (see F<tools/build/pmc2c.pl>).
353
354=cut
355
356sub rewrite_nci_method {
357    my ( $self, $pmc ) = @_;
358    my $pmcname = $pmc->name;
359    my $body    = $self->body;
360
361    # Rewrite SELF.other_method(args...)
362    $body->subst(
363        qr{
364      \bSELF\b       # Macro: SELF
365      \.(\w+)        # other_method
366      \(\s*(.*?)\)   # capture argument list
367      }x,
368        sub { "_self->vtable->$1(" . full_arguments($2) . ')' }
369    );
370
371    # Rewrite STATICSELF.other_method(args...)
372    $body->subst(
373        qr{
374      \bSTATICSELF\b    # Macro STATICSELF
375      \.(\w+)           # other_method
376      \(\s*(.*?)\)      # capture argument list
377      }x,
378        sub {
379            "Parrot_${pmcname}"
380                . ( $pmc->is_vtable_method($1) ? "" : "_nci" ) . "_$1("
381                . full_arguments($2) . ")";
382        }
383    );
384
385    # Rewrite SELF -> _self, INTERP -> interp
386    $body->subst( qr{\bSELF\b},   sub { '_self' } );
387    $body->subst( qr{\bINTERP\b}, sub { 'interp' } );
388
389    # Rewrite GET_ATTR, SET_ATTR with typename
390    $body->subst( qr{\bGET_ATTR}, sub { 'GETATTR_' . $pmcname } );
391    $body->subst( qr{\bSET_ATTR}, sub { 'SETATTR_' . $pmcname } );
392}
393
394=item C<rewrite_vtable_method($self, $pmc, $super, $super_table)>
395
396Rewrites the method body performing the various macro substitutions for
397vtable function bodies (see F<tools/build/pmc2c.pl>).
398
399=cut
400
401sub rewrite_vtable_method {
402    my ( $self, $pmc ) = @_;
403    my $name        = $self->name;
404    my $pmcname     = $pmc->name;
405    my $super       = $pmc->{super}{$name};
406    my $super_table = $pmc->{super};
407    my $body        = $self->body;
408    my $sub;
409
410    # Rewrite method body
411    # Some MMD variants don't have a super mapping.
412    if ($super) {
413        my $supertype = "enum_class_$super";
414        die "$pmcname defines unknown vtable function '$name'\n" unless defined $super_table->{$name};
415        my $supermethod = "Parrot_" . $super_table->{$name} . "_$name";
416
417        # Rewrite OtherClass.SUPER(args...)
418        $body->subst(
419            qr{
420            (\w+)             # capture OtherClass
421            \.SUPER\b         # Macro: SUPER
422            \(\s*(.*?)\)      # capture argument list
423          }x,
424            sub { "interp->vtables[enum_class_${1}]->$name(" . full_arguments($2) . ')' }
425        );
426
427        # Rewrite SUPER(args...)
428        $body->subst(
429            qr{
430            \bSUPER\b         # Macro: SUPER
431            \(\s*(.*?)\)      # capture argument list
432          }x,
433            sub {
434              if ($pmc->is_dynamic($super)) {
435                #*_get_vtable_pointer is a minor hack invented only to handle
436                #the use case when a dynpmc calls a parent dynpmc's vtable
437                #function.  See TT #898 for more info.
438                return "Parrot_" . $super .
439                  "_get_vtable_pointer(interp)->$name(" . full_arguments($1) .
440                  ')';
441              }
442              else {
443                return "interp->vtables[$supertype]->$name(" . full_arguments($1) . ')';
444              }
445            }
446        );
447    }
448
449    # Rewrite SELF.other_method(args...)
450    $body->subst(
451        qr{
452        \bSELF\b       # Macro: SELF
453        \.(\w+)        # other_method
454        \(\s*(.*?)\)   # capture argument list
455      }x,
456        sub { "_self->vtable->$1(" . full_arguments($2) . ')' }
457    );
458
459    # Rewrite SELF(args...). See comments above.
460    $body->subst(
461        qr{
462        \bSELF\b       # Macro: SELF
463        \(\s*(.*?)\)   # capture argument list
464      }x,
465        sub { "_self->vtable->$name(" . full_arguments($1) . ')' }
466    );
467
468    # Rewrite OtherClass.SELF.other_method(args...)
469    $body->subst(
470        qr{
471        (\w+)             # OtherClass
472        \.\bSELF\b        # Macro SELF
473        \.(\w+)           # other_method
474        \(\s*(.*?)\)      # capture argument list
475      }x,
476        sub {
477            "Parrot_${1}"
478                . ( $pmc->is_vtable_method($2) ? "" : "_nci" ) . "_$2("
479                . full_arguments($3) . ')';
480        }
481    );
482
483    # Rewrite OtherClass.STATICSELF.other_method(args...)
484    $body->subst(
485        qr{
486        (\w+)             # OtherClass
487        \.\bSTATICSELF\b  # Macro STATICSELF
488        \.(\w+)           # other_method
489        \(\s*(.*?)\)      # capture argument list
490      }x,
491        sub {
492            "Parrot_${1}"
493                . ( $pmc->is_vtable_method($2) ? "" : "_nci" ) . "_$2("
494                . full_arguments($3) . ')';
495        }
496    );
497
498    # Rewrite OtherClass.object.other_method(args...)
499    $body->subst(
500        qr{
501        (\w+)             # OtherClass
502        \.\b(\w+)\b       # any object
503        \.(\w+)           # other_method
504        \(\s*(.*?)\)      # capture argument list
505      }x,
506        sub {
507            "Parrot_${1}"
508                . ( $pmc->is_vtable_method($3) ? "" : "_nci" ) . "_$3("
509                . full_arguments( $4, $2 ) . ')';
510        }
511    );
512
513    # Rewrite SELF.other_method(args...)
514    $body->subst(
515        qr{
516        \bSELF\b          # Macro SELF
517        \.(\w+)           # other_method
518        \(\s*(.*?)\)      # capture argument list
519      }x,
520        sub {
521            "Parrot_${pmcname}"
522                . ( $pmc->is_vtable_method($1) ? "" : "_nci" ) . "_$1("
523                . full_arguments($2) . ")";
524        }
525    );
526
527    # Rewrite STATICSELF.other_method(args...)
528    $body->subst(
529        qr{
530        \bSTATICSELF\b    # Macro STATICSELF
531        \.(\w+)           # other_method
532        \(\s*(.*?)\)      # capture argument list
533      }x,
534        sub {
535            "Parrot_${pmcname}"
536                . ( $pmc->is_vtable_method($1) ? "" : "_nci" ) . "_$1("
537                . full_arguments($2) . ")";
538        }
539    );
540
541    # Rewrite SELF -> _self, INTERP -> interp
542    $body->subst( qr{\bSELF\b},   sub { '_self' } );
543    $body->subst( qr{\bINTERP\b}, sub { 'interp' } );
544
545    # Rewrite GET_ATTR, SET_ATTR with typename
546    $body->subst( qr{\bGET_ATTR}, sub { 'GETATTR_' . $pmcname } );
547    $body->subst( qr{\bSET_ATTR}, sub { 'SETATTR_' . $pmcname } );
548
549    # now use macros for all rewritten stuff
550    $body->subst( qr{\b(?:\w+)->vtable->(\w+)\(}, sub { "VTABLE_$1(" } );
551
552    # add GC write barrier for writers
553    #if ($pmc->is_vtable_method($name)) {
554    #}
555    return 1;
556}
557
558=item C<full_arguments($args)>
559
560Prepends C<INTERP, SELF> to C<$args>.
561
562=back
563
564=cut
565
566sub full_arguments {
567    my $args = shift;
568    my $obj = shift || 'SELF';
569
570    return "INTERP, $obj, $args" if ( $args =~ m/\S/ );
571    return "INTERP, $obj";
572}
573
574sub full_method_name {
575    my ( $self, $parent_name ) = @_;
576    return "Parrot_${parent_name}_" . $self->name;
577}
578
579=head1 SEE ALSO
580
581    lib/Parrot/Pmc2c/PMC/RO.pm
582    lib/Parrot/Pmc2c/VTable.pm
583    lib/Parrot/Pmc2c/PMC.pm
584    lib/Parrot/Pmc2c/Parser.pm
585
586=cut
587
5881;
589
590# Local Variables:
591#   mode: cperl
592#   cperl-indent-level: 4
593#   fill-column: 100
594# End:
595# vim: expandtab shiftwidth=4:
596
597