view release on metacpan or  search on metacpan

lib/B/CC.pm  view on Meta::CPAN

Called by every C<CV::save> if ROOT.
B<blocksort> also creates its block closure with cc_queue.

=cut

# coverage: test 18, 28 (fixed with B-C-1.30 r971)
sub cc_queue {
  my ( $name, $root, $start, @pl ) = @_;
  debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
    if $debug{queue};
  if ( $name eq "*ignore*" or $name =~ /^pp_sub_.*(FETCH|MODIFY)_SCALAR_ATTRIBUTES$/) {
    $name = '';
  } else {
    push( @cc_todo, [ $name, $root, $start, ( @pl ? @pl : @padlist ) ] );
  }
  my $fakeop_next = 0;
  if ($name =~ /^pp_sub_.*DESTROY$/) {
    # curse in sv_clean_objs() checks for ->op_next->op_type
    $fakeop_next = $start->next->save;
  }
  my $fakeop = B::FAKEOP->new( "next" => $fakeop_next, ppaddr => $name );
  $start = $fakeop->save;
  debug "cc_queue: name $name returns $start\n" if $debug{queue};
  return $start;
}
BEGIN { B::C::set_callback( \&cc_queue ) }

sub valid_int     { $_[0]->{flags} & VALID_INT }
sub valid_double  { $_[0]->{flags} & VALID_NUM }
sub valid_numeric { $_[0]->{flags} & ( VALID_INT | VALID_NUM ) }
sub valid_str     { $_[0]->{flags} & VALID_STR }
sub valid_sv      { $_[0]->{flags} & VALID_SV }

sub top_int     { @stack ? $stack[-1]->as_int     : "TOPi" }
sub top_double  { @stack ? $stack[-1]->as_double  : "TOPn" }
sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
sub top_sv      { @stack ? $stack[-1]->as_sv      : "TOPs" }
sub top_str     { @stack ? $stack[-1]->as_str     : "TOPs" }
sub top_bool    { @stack ? $stack[-1]->as_bool    : "SvTRUE(TOPs)" }

sub pop_int     { @stack ? ( pop @stack )->as_int     : "POPi" }
sub pop_double  { @stack ? ( pop @stack )->as_double  : "POPn" }
sub pop_numeric { @stack ? ( pop @stack )->as_numeric : "POPn" }
sub pop_str     { @stack ? ( pop @stack )->as_str      : "POPs" }
sub pop_sv      { @stack ? ( pop @stack )->as_sv      : "POPs" }

sub pop_bool {
  if (@stack) {
    return ( ( pop @stack )->as_bool );
  }
  else {
    # Careful: POPs has an auto-decrement and SvTRUE evaluates
    # its argument more than once.
    runtime("sv = POPs;");
    return "SvTRUE(sv)";
  }
}

sub write_back_lexicals {
  my $avoid = shift || 0;
  debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
    if $debug{shadow};
  my $lex;
  foreach $lex (@pad) {
    next unless ref($lex);
    $lex->write_back unless $lex->{flags} & $avoid;
  }
}

=head1 save_or_restore_lexical_state

The compiler tracks state of lexical variables in @pad to generate optimised
code. But multiple execution paths lead to the entry point of a basic block.
The state of the first execution path is saved and all other execution
paths are restored to the state of the first one.

Missing flags are regenerated by loading values.

Added flags must are removed; otherwise the compiler would be too optimistic,
hence generating code which doesn't match state of the other execution paths.

=cut

sub save_or_restore_lexical_state {
  my $bblock = shift;
  unless ( exists $lexstate{$bblock} ) {
    foreach my $lex (@pad) {
      next unless ref($lex);
      ${ $lexstate{$bblock} }{ $lex->{iv} } = $lex->{flags};
    }
  }
  else {
    foreach my $lex (@pad) {
      next unless ref($lex);
      my $old_flags = ${ $lexstate{$bblock} }{ $lex->{iv} };
      next if ( $old_flags eq $lex->{flags} );
      my $changed = $old_flags ^ $lex->{flags};
      if ( $changed & VALID_SV ) {
        ( $old_flags & VALID_SV ) ? $lex->write_back : $lex->invalidate;
      }
      if ( $changed & VALID_NUM ) {
        ( $old_flags & VALID_NUM ) ? $lex->load_double : $lex->invalidate_double;
      }
      if ( $changed & VALID_INT ) {
        ( $old_flags & VALID_INT ) ? $lex->load_int : $lex->invalidate_int;
      }
      if ( $changed & VALID_STR ) {
        ( $old_flags & VALID_STR ) ? $lex->load_str : $lex->invalidate_str;
      }
    }
  }
}

sub write_back_stack {
  debug "write_back_stack() ".scalar(@stack)." called from @{[(caller(1))[3]]}\n"
    if $debug{shadow};
  return unless @stack;
  runtime( sprintf( "EXTEND(sp, %d);", scalar(@stack) ) );
  foreach my $obj (@stack) {
    runtime( sprintf( "PUSHs((SV*)%s);", $obj->as_sv ) );
  }
  @stack = ();
}

sub invalidate_lexicals {
  my $avoid = shift || 0;
  debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
    if $debug{shadow};
  my $lex;
  foreach $lex (@pad) {
    next unless ref($lex);
    $lex->invalidate unless $lex->{flags} & $avoid;
  }
}

sub reload_lexicals {
  my $lex;
  foreach $lex (@pad) {
    next unless ref($lex);
    my $type = $lex->{type};
    if ( $type == T_INT ) {
      $lex->as_int;
    }
    elsif ( $type == T_NUM ) {
      $lex->as_double;
    }
    elsif ( $type == T_STR ) {
      $lex->as_str;
    }
    else {
      $lex->as_sv;
    }
  }
}

{

  package B::Pseudoreg;

  #
  # This class allocates pseudo-registers (OK, so they're C variables).
  #
  my %alloc;   # Keyed by variable name. A value of 1 means the
               # variable has been declared. A value of 2 means
               # it's in use.

  sub new_scope { %alloc = () }

  sub new ($$$) {
    my ( $class, $type, $prefix ) = @_;
    my ( $ptr, $i, $varname, $status, $obj );
    $prefix =~ s/^(\**)//;
    $ptr = $1;
    $i   = 0;
    do {
      $varname = "$prefix$i";
      $status  = exists $alloc{$varname} ? $alloc{$varname} : 0;
    } while $status == 2;

    if ( $status != 1 ) {
      # Not declared yet
      B::CC::declare( $type, "$ptr$varname" );
      $alloc{$varname} = 2;    # declared and in use
    }
    $obj = bless \$varname, $class;
    return $obj;
  }