lib/Parrot/Op.pm

   1 #! perl
   2 # Copyright (C) 2001-2008, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 Parrot::Op - Parrot Operation
   8
   9 =head1 SYNOPSIS
  10
  11   use Parrot::Op;
  12
  13 =head1 DESCRIPTION
  14
  15 C<Parrot::Op> represents a Parrot operation (op, for short), as read
  16 from an ops file via C<Parrot::OpsFile>, or perhaps even generated by
  17 some other means. It is the Perl equivalent of the C<op_info_t> C
  18 C<struct> defined in F<include/parrot/op.h>.
  19
  20 =head2 Op Type
  21
  22 Ops are either I<auto> or I<manual>. Manual ops are responsible for
  23 having explicit next-op C<RETURN()> statements, while auto ops can count
  24 on an automatically generated next-op to be appended to the op body.
  25
  26 Note that F<tools/build/ops2c.pl> supplies either 'inline' or 'function'
  27 as the op's type, depending on whether the C<inline> keyword is present
  28 in the op definition. This has the effect of causing all ops to be
  29 considered manual.
  30
  31 =head2 Op Arguments
  32
  33 Note that argument 0 is considered to be the op itself, with arguments
  34 1..9 being the arguments passed to the op.
  35
  36 Op argument direction and type are represented by short one or two letter
  37 descriptors.
  38
  39 Op Direction:
  40
  41     i   The argument is incoming
  42     o   The argument is outgoing
  43     io  The argument is both incoming and outgoing
  44
  45 Op Type:
  46
  47     i   The argument is an integer register index.
  48     n   The argument is a number register index.
  49     p   The argument is a PMC register index.
  50     s   The argument is a string register index.
  51     ic  The argument is an integer constant (in-line).
  52     nc  The argument is a number constant index.
  53     pc  The argument is a PMC constant index.
  54     sc  The argument is a string constant index.
  55     kc  The argument is a key constant index.
  56     ki  The argument is a key integer register index.
  57     kic  The argument is a key integer constant (in-line).
  58
  59 =head2 Class Methods
  60
  61 =over 4
  62
  63 =cut
  64
  65 package Parrot::Op;
  66
  67 use strict;
  68 use warnings;
  69
  70 =item C<new($code, $type, $name, $args, $argdirs, $labels, $flags)>
  71
  72 Allocates a new bodyless op. A body must be provided eventually for the
  73 op to be usable.
  74
  75 C<$code> is the integer identifier for the op.
  76
  77 C<$type> is the type of op (see the note on op types above).
  78
  79 C<$name> is the name of the op.
  80
  81 C<$args> is a reference to an array of argument type descriptors.
  82
  83 C<$argdirs> is a reference to an array of argument direction
  84 descriptors. Element I<x> is the direction of argument C<< $args->[I<x>]
  85 >>.
  86
  87 C<$labels> is a reference to an array of boolean values indicating
  88 whether each argument direction was prefixed by 'C<label>'.
  89
  90 C<$flags> is a hash reference containing zero or more I<hints> or
  91 I<directives>.
  92
  93 =cut
  94
  95 sub new {
  96     my $class = shift;
  97     my ( $code, $type, $name, $args, $argdirs, $labels, $flags ) = @_;
  98
  99     my $self = {
 100         CODE    => $code,
 101         TYPE    => $type,
 102         NAME    => $name,
 103         ARGS    => [@$args],
 104         ARGDIRS => [@$argdirs],
 105         LABELS  => [@$labels],
 106         FLAGS   => $flags,
 107         BODY    => '',
 108         JUMP    => 0,
 109     };
 110
 111     return bless $self, $class;
 112 }
 113
 114 =back
 115
 116 =head2 Instance Methods
 117
 118 =over 4
 119
 120 =item C<code()>
 121
 122 Returns the op code.
 123
 124 =cut
 125
 126 sub code {
 127     my $self = shift;
 128
 129     return $self->{CODE};
 130 }
 131
 132 =item C<type()>
 133
 134 The type of the op, either 'inline' or 'function'.
 135
 136 =cut
 137
 138 sub type {
 139     my $self = shift;
 140
 141     return $self->{TYPE};
 142 }
 143
 144 =item C<name()>
 145
 146 The (short or root) name of the op.
 147
 148 =cut
 149
 150 sub name {
 151     my $self = shift;
 152
 153     return $self->{NAME};
 154 }
 155
 156 =item C<full_name()>
 157
 158 For argumentless ops, it's the same as C<name()>. For ops with
 159 arguments, an underscore followed by underscore-separated argument types
 160 are appended to the name.
 161
 162 =cut
 163
 164 sub full_name {
 165     my $self      = shift;
 166     my $name      = $self->name;
 167     my @arg_types = $self->arg_types;
 168
 169     $name .= "_" . join( "_", @arg_types ) if @arg_types;
 170
 171     return $name;
 172 }
 173
 174 =item C<func_name()>
 175
 176 The same as C<full_name()>, but with 'C<Parrot_>' prefixed.
 177
 178 =cut
 179
 180 sub func_name {
 181     my ( $self, $trans ) = @_;
 182
 183     return $trans->prefix . $self->full_name;
 184 }
 185
 186 =item C<arg_types()>
 187
 188 Returns the types of the op's arguments.
 189
 190 =cut
 191
 192 sub arg_types {
 193     my $self = shift;
 194
 195     return @{ $self->{ARGS} };
 196 }
 197
 198 =item C<arg_type($index)>
 199
 200 Returns the type of the op's argument at C<$index>.
 201
 202 =cut
 203
 204 sub arg_type {
 205     my $self = shift;
 206
 207     return $self->{ARGS}[shift];
 208 }
 209
 210 =item C<arg_dirs()>
 211
 212 Returns the directions of the op's arguments.
 213
 214 =cut
 215
 216 sub arg_dirs {
 217     my $self = shift;
 218
 219     return @{ $self->{ARGDIRS} };
 220 }
 221
 222 =item C<labels()>
 223
 224 Returns the labels.
 225
 226 =cut
 227
 228 sub labels {
 229     my $self = shift;
 230
 231     return @{ $self->{LABELS} };
 232 }
 233
 234 =item C<flags(@flags)>
 235
 236 =item C<flags()>
 237
 238 Sets/gets the op's flags.  This returns a hash reference, whose keys are any
 239 flags (passed as ":flag") specified for the op.
 240
 241 =cut
 242
 243 sub flags {
 244     my $self = shift;
 245
 246     if (@_) {
 247         $self->{FLAGS} = shift;
 248     }
 249
 250     return $self->{FLAGS};
 251 }
 252
 253 =item C<arg_dir($index)>
 254
 255 Returns the direction of the op's argument at C<$index>.
 256
 257 =cut
 258
 259 sub arg_dir {
 260     my $self = shift;
 261
 262     return $self->{ARGDIRS}[shift];
 263 }
 264
 265 =item C<body($body)>
 266
 267 =item C<body()>
 268
 269 Sets/gets the op's code body.
 270
 271 =cut
 272
 273 sub body {
 274     my $self = shift;
 275
 276     if (@_) {
 277         $self->{BODY} = shift;
 278     }
 279
 280     return $self->{BODY};
 281 }
 282
 283 =item C<jump($jump)>
 284
 285 =item C<jump()>
 286
 287 Sets/gets a string containing one or more C<op_jump_t> values joined with
 288 C<|> (see F<include/parrot/op.h>). This indicates if and how an op
 289 may jump.
 290
 291 =cut
 292
 293 sub jump {
 294     my $self = shift;
 295
 296     if (@_) {
 297         $self->{JUMP} = shift;
 298     }
 299
 300     return $self->{JUMP};
 301 }
 302
 303 =item C<full_body()>
 304
 305 For manual ops, C<full_body()> is the same as C<body()>. For auto ops
 306 this method adds a final C<goto NEXT()> line to the code to represent
 307 the auto-computed return value. See the note on op types above.
 308
 309 =cut
 310
 311 sub full_body {
 312     my $self = shift;
 313     my $body = $self->body;
 314
 315     $body .= sprintf( "  {{+=%d}};\n", $self->size ) if $self->type eq 'auto';
 316
 317     return $body;
 318 }
 319
 320 # Called from rewrite_body() to perform the actual substitutions.
 321 sub _substitute {
 322     my $self = shift;
 323     local $_ = shift;
 324     my $trans = shift;
 325
 326     s/{{\@([^{]*?)}}/   $trans->access_arg($self->arg_type($1 - 1), $1, $self); /me;
 327
 328     s/{{=0,=([^{]*?)}}/   $trans->restart_address($1) . "; {{=0}}"; /me;
 329     s/{{=0,\+=([^{]*?)}}/ $trans->restart_offset($1)  . "; {{=0}}"; /me;
 330     s/{{=0,-=([^{]*?)}}/  $trans->restart_offset(-$1) . "; {{=0}}"; /me;
 331
 332     s/{{\+=([^{]*?)}}/    $trans->goto_offset($1);  /me;
 333     s/{{-=([^{]*?)}}/     $trans->goto_offset(-$1); /me;
 334     s/{{=([^*][^{]*?)}}/  $trans->goto_address($1); /me;
 335
 336     s/{{\^(-?\d+)}}/      $1                        /me;
 337     s/{{\^\+([^{]*?)}}/   $trans->expr_offset($1);  /me;
 338     s/{{\^-([^{]*?)}}/    $trans->expr_offset(-$1); /me;
 339     s/{{\^([^{]*?)}}/     $trans->expr_address($1); /me;
 340
 341     return $_;
 342 }
 343
 344 =item C<rewrite_body($body, $trans)>
 345
 346 Performs the various macro substitutions using the specified transform,
 347 correctly handling nested substitions, and repeating over the whole string
 348 until no more substitutions can be made.
 349
 350 C<VTABLE_> macros are enforced by converting C<<< I<< x >>->vtable->I<<
 351 method >> >>> to C<VTABLE_I<method>>.
 352
 353 =cut
 354
 355 sub rewrite_body {
 356     my ( $self, $body, $trans ) = @_;
 357
 358     # use vtable macros
 359     $body =~ s!
 360         (?:
 361             {{\@\d+\}}
 362             |
 363             \b\w+(?:->\w+)*
 364         )->vtable->\s*(\w+)\(
 365         !VTABLE_$1(!sgx;
 366
 367     while (1) {
 368         my $new_body = $self->_substitute( $body, $trans );
 369
 370         last if $body eq $new_body;
 371
 372         $body = $new_body;
 373     }
 374
 375     return $body;
 376 }
 377
 378 =item C<source($trans)>
 379
 380 Returns the L<C<full_body()>> of the op with substitutions made by
 381 C<$trans> (a subclass of C<Parrot::OpTrans>).
 382
 383 =cut
 384
 385 sub source {
 386     my ( $self, $trans ) = @_;
 387
 388     my $flags = $self->flags;
 389
 390     if (exists($$flags{pic})
 391         && !( ref($trans) eq 'Parrot::OpTrans::CGP' || ref($trans) eq 'Parrot::OpTrans::CSwitch' ) )
 392     {
 393         return qq{PANIC(interp, "How did you do that");\n};
 394     }
 395
 396     my $prelude = $trans->can( 'add_body_prelude' )
 397                 ? $trans->add_body_prelude()
 398                 : '';
 399
 400     return $self->rewrite_body( $prelude . $self->full_body, $trans );
 401 }
 402
 403 =item C<size()>
 404
 405 Returns the op's number of arguments. Note that this also includes
 406 the op itself as one argument.
 407
 408 =cut
 409
 410 sub size {
 411     my $self = shift;
 412
 413     return scalar( $self->arg_types + 1 );
 414 }
 415
 416 =back
 417
 418 =head1 SEE ALSO
 419
 420 =over 4
 421
 422 =item C<Parrot::OpsFile>
 423
 424 =item C<Parrot::OpTrans>
 425
 426 =item F<tools/build/ops2c.pl>
 427
 428 =item F<tools/build/ops2pm.pl>
 429
 430 =item F<tools/build/pbc2c.pl>
 431
 432 =back
 433
 434 =head1 HISTORY
 435
 436 Author: Gregor N. Purdy E<lt>gregor@focusresearch.comE<gt>
 437
 438 =cut
 439
 440 1;
 441
 442 # Local Variables:
 443 #   mode: cperl
 444 #   cperl-indent-level: 4
 445 #   fill-column: 100
 446 # End:
 447 # vim: expandtab shiftwidth=4: