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