lib/Parrot/Pmc2c/MethodEmitter.pm

   1 # Copyright (C) 2004-2007, The Perl Foundation.
   2
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 Parrot::Pmc2c - PMC to C Code Generation
   8
   9 =head1 SYNOPSIS
  10
  11     use Parrot::Pmc2c;
  12
  13 =head1 DESCRIPTION
  14
  15 C<Parrot::Pmc2c> is used by F<tools/build/pmc2c.pl> to generate C code from PMC files.
  16
  17 =head2 Functions
  18
  19 =over
  20
  21 =cut
  22
  23 package Parrot::Pmc2c::Method;
  24 use strict;
  25 use warnings;
  26 use Parrot::Pmc2c::Emitter;
  27 use Parrot::Pmc2c::UtilFunctions
  28     qw( gen_ret dont_edit count_newlines dynext_load_code c_code_coda );
  29 use Parrot::Pmc2c::PCCMETHOD;
  30
  31 =item C<generate_body($pmc)>
  32
  33 Generate and emit the C code for the method body.
  34
  35 =cut
  36
  37 sub generate_body {
  38     my ( $self, $pmc ) = @_;
  39     my $emit = sub { $pmc->{emitter}->emit(@_) };
  40
  41     Parrot::Pmc2c::PCCMETHOD::rewrite_pccinvoke( $self, $pmc );
  42
  43     my $body = $self->body;
  44
  45     if ( $self->is_vtable ) {
  46         $self->rewrite_vtable_method($pmc);
  47     }
  48     else {
  49         $self->rewrite_nci_method($pmc);
  50     }
  51
  52     $emit->( ( $pmc->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_API ') . $self->decl( $pmc, 'CFILE' ) );
  53     $emit->("{\n");
  54     $emit->($body);
  55     $emit->("}\n");
  56
  57     if ( $self->mmds ) {
  58         for my $mmd ( @{ $self->mmds } ) {
  59             $mmd->generate_body($pmc);
  60         }
  61     }
  62
  63     return 1;
  64 }
  65
  66 sub generate_headers {
  67     my ( $self, $pmc ) = @_;
  68     my $hout = "";
  69
  70     $hout .= $self->decl( $pmc, 'HEADER' );
  71
  72     if ( $self->mmds ) {
  73         for my $mmd ( @{ $self->mmds } ) {
  74             $hout .= $mmd->decl( $pmc, 'HEADER' );
  75         }
  76     }
  77
  78     return $hout;
  79 }
  80
  81 =item C<decl($classname, $method, $for_header)>
  82
  83 Returns the C code for the PMC method declaration. C<$for_header>
  84 indicates whether the code is for a header or implementation file.
  85
  86 =cut
  87
  88 sub decl {
  89     my ( $self, $pmc, $for_header ) = @_;
  90
  91     my $pmcname = $pmc->name;
  92     my $ret     = $self->return_type;
  93     my $meth    = $self->name;
  94     my $args    = $self->parameters;
  95     my $ro      = $pmc->flag('is_ro') ? '' : '';
  96     my $decs    = $self->decorators;
  97
  98     # convert 'type*' to 'type *' per PDD07
  99     $ret =~ s/^(.*)\s*(\*)$/$1 $2/;
 100
 101     # convert args to PDD07
 102     $args = ", $args" if $args =~ /\S/;
 103     $args =~ s/(\w+)\s*(\*)\s*/$1 $2/g;
 104
 105     my ( $decorators, $export, $extern, $newl, $semi, $interp, $pmcvar );
 106     $decorators = join($/, @$decs, '');
 107     if ( $for_header eq 'HEADER' ) {
 108         $export = $pmc->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_API ';
 109         $extern = "";
 110         $newl   = " ";
 111         $semi   = ";";
 112         $interp = $pmcvar = "";
 113     }
 114     else {
 115         $export = "";
 116         $extern = "";
 117         $newl   = "\n";
 118         $semi   = "";
 119         $interp = 'interp';
 120         $pmcvar = 'pmc';
 121     }
 122
 123     return <<"EOC";
 124 $decorators$export$extern$ret${newl}Parrot_${pmcname}${ro}_$meth(PARROT_INTERP, PMC *$pmcvar$args)$semi
 125 EOC
 126 }
 127
 128 =item C<proto($type,$parameters)>
 129
 130 Determines the prototype (argument signature) for a method body
 131 (see F<src/call_list>).
 132
 133 =cut
 134
 135 my %calltype = (
 136     "char"     => "c",
 137     "short"    => "s",
 138     "char"     => "c",
 139     "short"    => "s",
 140     "int"      => "i",
 141     "INTVAL"   => "I",
 142     "float"    => "f",
 143     "FLOATVAL" => "N",
 144     "double"   => "d",
 145     "STRING*"  => "S",
 146     "STRING *" => "S",
 147     "char*"    => "t",
 148     "char *"   => "t",
 149     "PMC*"     => "P",
 150     "PMC *"    => "P",
 151     "short*"   => "2",
 152     "short *"  => "2",
 153     "int*"     => "3",
 154     "int *"    => "3",
 155     "long*"    => "4",
 156     "long *"   => "4",
 157     "void"     => "v",
 158     "void*"    => "b",
 159     "void *"   => "b",
 160     "void**"   => "B",
 161     "void **"  => "B",
 162
 163     #"BIGNUM*" => "???" # RT#43731
 164     #"BIGNUM *"=> "???" # RT#43731
 165 );
 166
 167 sub proto {
 168     my ( $type, $parameters ) = @_;
 169
 170     # reduce to a comma separated set of types
 171     $parameters =~ s/\w+(,|$)/,/g;
 172     $parameters =~ s/ //g;
 173
 174     # type method(interp, self, parameters...)
 175     my $ret = $calltype{ $type or "void" };
 176     $ret .= "JO" . join( '', map { $calltype{$_} or "?" } split( /,/, $parameters ) );
 177
 178     # RT#43733
 179     # scan src/call_list.txt if the generated signature is available
 180
 181     # RT#43735 report errors for "?"
 182     # --leo
 183
 184     return $ret;
 185 }
 186
 187 =item C<rewrite_nci_method($self, $pmc )>
 188
 189 Rewrites the method body performing the various macro substitutions for
 190 nci method bodies (see F<tools/build/pmc2c.pl>).
 191
 192 =cut
 193
 194 sub rewrite_nci_method {
 195     my ( $self, $pmc ) = @_;
 196     my $pmcname = $pmc->name;
 197     my $body    = $self->body;
 198
 199     # Rewrite SELF.other_method(args...)
 200     $body->subst(
 201         qr{
 202     \bSELF\b         # Macro: SELF
 203       \.(\w+)        # other_method
 204       \(\s*(.*?)\)   # capture argument list
 205       }x,
 206         sub { "pmc->real_self->vtable->$1(" . full_arguments( $2, 'pmc->real_self' ) . ')' }
 207     );
 208
 209     # Rewrite SELF.other_method(args...)
 210     $body->subst(
 211         qr{
 212     \bSELF\b         # Macro: SELF
 213       \.(\w+)        # other_method
 214       \(\s*(.*?)\)   # capture argument list
 215       }x,
 216         sub { "pmc->vtable->$1(" . full_arguments($2) . ')' }
 217     );
 218
 219     # Rewrite STATICSELF.other_method(args...)
 220     $body->subst(
 221         qr{
 222       \bSTATICSELF\b          # Macro STATICSELF
 223       \.(\w+)           # other_method
 224       \(\s*(.*?)\)      # capture argument list
 225       }x,
 226         sub {
 227             "Parrot_${pmcname}"
 228                 . ( $pmc->is_vtable_method($1) ? "" : "_nci" ) . "_$1("
 229                 . full_arguments($2) . ")";
 230         }
 231     );
 232
 233     # Rewrite SELF -> pmc, INTERP -> interp
 234     $body->subst( qr{\bSELF\b},   sub { 'pmc' } );
 235     $body->subst( qr{\bINTERP\b}, sub { 'interp' } );
 236
 237     # Rewrite GET_ATTR, SET_ATTR with typename
 238     $body->subst( qr{\bGET_ATTR}, sub { 'GETATTR_' . $pmcname } );
 239     $body->subst( qr{\bSET_ATTR}, sub { 'SETATTR_' . $pmcname } );
 240 }
 241
 242 =item C<rewrite_vtable_method($self, $pmc, $super, $super_table)>
 243
 244 Rewrites the method body performing the various macro substitutions for
 245 vtable method bodies (see F<tools/build/pmc2c.pl>).
 246
 247 =cut
 248
 249 sub rewrite_vtable_method {
 250     my ( $self, $pmc ) = @_;
 251     my $name        = $self->name;
 252     my $pmcname     = $pmc->name;
 253     my $super       = $pmc->{super}{$name};
 254     my $super_table = $pmc->{super};
 255     my $body        = $self->body;
 256     my $sub;
 257
 258     # Rewrite method body
 259     # Some MMD variants don't have a super mapping.
 260     if ($super) {
 261         my $supertype = "enum_class_$super";
 262         die "$pmcname defines unknown vtable method '$name'\n" unless defined $super_table->{$name};
 263         my $supermethod = "Parrot_" . $super_table->{$name} . "_$name";
 264
 265         # Rewrite DYNSUPER(args)
 266         $body->subst(
 267             qr{
 268             \bDYNSUPER\b      # Macro: DYNSUPER
 269             \(\s*(.*?)\)      # capture argument list
 270           }x,
 271             sub { "interp->vtables[$supertype].$name(" . full_arguments($1) . ')' }
 272         );
 273
 274         # Rewrite OtherClass.SUPER(args...)
 275         $body->subst(
 276             qr{
 277             (\w+)             # capture OtherClass
 278             \.SUPER\b         # Macro: SUPER
 279             \(\s*(.*?)\)      # capture argument list
 280           }x,
 281             sub { "Parrot_${1}_$name(" . full_arguments($2) . ')' }
 282         );
 283
 284         # Rewrite SUPER(args...)
 285         $body->subst(
 286             qr{
 287             \bSUPER\b         # Macro: SUPER
 288             \(\s*(.*?)\)      # capture argument list
 289           }x,
 290             sub { "$supermethod(" . full_arguments($1) . ')' }
 291         );
 292     }
 293
 294     # Rewrite SELF.other_method(args...)
 295     $body->subst(
 296         qr{
 297         \bSELF\b       # Macro: SELF
 298         \.(\w+)        # other_method
 299         \(\s*(.*?)\)   # capture argument list
 300       }x,
 301         sub { "pmc->vtable->$1(" . full_arguments($2) . ')' }
 302     );
 303
 304     # Rewrite SELF(args...). See comments above.
 305     $body->subst(
 306         qr{
 307         \bSELF\b       # Macro: SELF
 308         \(\s*(.*?)\)   # capture argument list
 309       }x,
 310         sub { "pmc->vtable->$name(" . full_arguments($1) . ')' }
 311     );
 312
 313     # Rewrite OtherClass.SELF.other_method(args...)
 314     $body->subst(
 315         qr{
 316         (\w+)             # OtherClass
 317         \.\bSELF\b        # Macro SELF
 318         \.(\w+)           # other_method
 319         \(\s*(.*?)\)      # capture argument list
 320       }x,
 321         sub {
 322             "Parrot_${1}"
 323                 . ( $pmc->is_vtable_method($2) ? "" : "_nci" ) . "_$2("
 324                 . full_arguments($3) . ')';
 325         }
 326     );
 327
 328     # Rewrite OtherClass.STATICSELF.other_method(args...)
 329     $body->subst(
 330         qr{
 331         (\w+)             # OtherClass
 332         \.\bSTATICSELF\b  # Macro STATICSELF
 333         \.(\w+)           # other_method
 334         \(\s*(.*?)\)      # capture argument list
 335       }x,
 336         sub {
 337             "Parrot_${1}"
 338                 . ( $pmc->is_vtable_method($2) ? "" : "_nci" ) . "_$2("
 339                 . full_arguments($3) . ')';
 340         }
 341     );
 342
 343     # Rewrite OtherClass.object.other_method(args...)
 344     $body->subst(
 345         qr{
 346         (\w+)             # OtherClass
 347         \.\b(\w+)\b       # any object
 348         \.(\w+)           # other_method
 349         \(\s*(.*?)\)      # capture argument list
 350       }x,
 351         sub {
 352             "Parrot_${1}"
 353                 . ( $pmc->is_vtable_method($3) ? "" : "_nci" ) . "_$3("
 354                 . full_arguments( $4, $2 ) . ')';
 355         }
 356     );
 357
 358     # Rewrite SELF.other_method(args...)
 359     $body->subst(
 360         qr{
 361         \bSELF\b          # Macro SELF
 362         \.(\w+)           # other_method
 363         \(\s*(.*?)\)      # capture argument list
 364       }x,
 365         sub {
 366             "Parrot_${pmcname}"
 367                 . ( $pmc->is_vtable_method($1) ? "" : "_nci" ) . "_$1("
 368                 . full_arguments($2) . ")";
 369         }
 370     );
 371
 372     # Rewrite STATICSELF.other_method(args...)
 373     $body->subst(
 374         qr{
 375         \bSTATICSELF\b    # Macro STATICSELF
 376         \.(\w+)           # other_method
 377         \(\s*(.*?)\)      # capture argument list
 378       }x,
 379         sub {
 380             "Parrot_${pmcname}"
 381                 . ( $pmc->is_vtable_method($1) ? "" : "_nci" ) . "_$1("
 382                 . full_arguments($2) . ")";
 383         }
 384     );
 385
 386     # Rewrite SELF -> pmc, INTERP -> interp
 387     $body->subst( qr{\bSELF\b},   sub { 'pmc' } );
 388     $body->subst( qr{\bINTERP\b}, sub { 'interp' } );
 389
 390     # Rewrite GET_ATTR, SET_ATTR with typename
 391     $body->subst( qr{\bGET_ATTR}, sub { 'GETATTR_' . $pmcname } );
 392     $body->subst( qr{\bSET_ATTR}, sub { 'SETATTR_' . $pmcname } );
 393
 394     # now use macros for all rewritten stuff
 395     $body->subst( qr{\b(?:\w+)->vtable->(\w+)\(}, sub { "VTABLE_$1(" } );
 396
 397     return 1;
 398 }
 399
 400 =item C<full_arguments($args)>
 401
 402 Prepends C<INTERP, SELF> to C<$args>.
 403
 404 =cut
 405
 406 sub full_arguments {
 407     my $args = shift;
 408     my $obj = shift || 'SELF';
 409
 410     return "INTERP, $obj, $args" if ( $args =~ m/\S/ );
 411     return "INTERP, $obj";
 412 }
 413
 414 sub full_method_name {
 415     my ( $self, $parent_name ) = @_;
 416     return "Parrot_${parent_name}_" . $self->name;
 417 }
 418
 419 1;
 420
 421 # Local Variables:
 422 #   mode: cperl
 423 #   cperl-indent-level: 4
 424 #   fill-column: 100
 425 # End:
 426 # vim: expandtab shiftwidth=4: