Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: f79c114de0
Fetching contributors…

Cannot retrieve contributors at this time

441 lines (358 sloc) 12.599 kb
# Copyright (C) 2001-2013, Parrot Foundation.
=head1 NAME
config/auto/pmc.pm - PMC Files
=head1 DESCRIPTION
Prepare PMC files for inclusion.
=cut
package auto::pmc;
use strict;
use warnings;
use base qw(Parrot::Configure::Step);
use File::Basename qw/basename/;
use File::Spec::Functions qw/catfile/;
use Parrot::Configure::Utils ':auto';
sub _init {
my $self = shift;
return {
description => 'Which pmc files should be compiled in',
result => '',
PMC_PARENTS => {},
srcpmc => [ sort map { basename($_) } glob "./src/pmc/*.pmc" ],
};
}
sub runstep {
my ( $self, $conf ) = @_;
# $pmc_list is a string holding a space-delimited list of currently active
# PMCs, sorted (largely) on the basis of src/pmc/pmc.num.
# (By 'current', we take into account the fact that there are PMCs listed
# in src/pmc/pmc.num that no longer exist but whose index numbers are
# never deleted.)
my $pmc_list = get_sorted_pmc_str( @{ $self->{srcpmc} } );
# names of class files for src/pmc/Makefile
( my $TEMP_pmc_o = $pmc_list ) =~ s/\.pmc/\$(O)/g;
( my $TEMP_pmc_str = $pmc_list ) =~ s/\.pmc/\.str/g;
# calls to pmc2c.pl for src/pmc/Makefile
my $TEMP_pmc_build = <<"E_NOTE";
# the following part of the Makefile was built by 'config/auto/pmc.pm'
E_NOTE
$TEMP_pmc_build .= <<END;
PMC2C_FILES = \\
lib/Parrot/Pmc2c/Pmc2cMain.pm \\
lib/Parrot/Pmc2c/Parser.pm \\
lib/Parrot/Pmc2c/Dumper.pm \\
lib/Parrot/Pmc2c/PMC.pm \\
lib/Parrot/Pmc2c/Method.pm \\
lib/Parrot/Pmc2c/PCCMETHOD.pm \\
lib/Parrot/Pmc2c/Library.pm \\
lib/Parrot/Pmc2c/UtilFunctions.pm \\
lib/Parrot/Pmc2c/PMC/default.pm \\
lib/Parrot/Pmc2c/PMC/Null.pm \\
lib/Parrot/Pmc2c/PMC/RO.pm
END
my %universal_deps;
while (<DATA>) {
next if /^#/;
next if /^\s*$/;
chomp;
$universal_deps{$_} = 1;
}
for my $pmc ( split( /\s+/, $pmc_list ) ) {
$pmc =~ s/\.pmc$//;
# make each pmc depend upon its parent.
my $parent_dumps = '';
$parent_dumps .= "src/pmc/$_.dump "
foreach reverse( ( $self->pmc_parents($pmc) ) );
my $parent_headers = '';
$parent_headers .= "include/pmc/pmc_$_.h "
for $self->pmc_parents($pmc);
# add dependencies that result from METHOD usage.
my $pmc_fname = catfile('src', 'pmc', "$pmc.pmc");
my $pccmethod_depend = '';
my %o_deps = %universal_deps;
$o_deps{"src/pmc/$pmc.c"} = 1;
$o_deps{"src/pmc/$pmc.str"} = 1;
$o_deps{"include/pmc/pmc_$pmc.h"} = 1;
if (contains_pccmethod($pmc_fname)) {
$o_deps{"include/pmc/pmc_fixedintegerarray.h"} = 1;
if ($pmc ne 'fixedintegerarray') {
$pccmethod_depend .= ' include/pmc/pmc_fixedintegerarray.h';
}
}
my $include_headers = get_includes($pmc_fname);
my $cc_shared = $conf->data->get('cc_shared');
my $cc_o_out = $conf->data->get('cc_o_out');
my $warnings = $conf->data->get('ccwarn');
my $optimize = $conf->data->get('optimize');
foreach my $header (split ' ', $parent_headers) {
$o_deps{$header} = 1;
}
foreach my $header (split ' ', $include_headers) {
$o_deps{$header} = 1;
}
# includes of includes
# (cheat. The right way to handle this is to do what
# checkdepend.t does.)
if (exists $o_deps{'include/parrot/oplib/core_ops.h'} ) {
$o_deps{'include/parrot/runcore_api.h'} = 1;
}
my $o_deps = " " . join(" \\\n ", keys %o_deps);
$TEMP_pmc_build .= <<END
src/pmc/$pmc.c : src/pmc/$pmc.dump
\t\$(PMC2CC) src/pmc/$pmc.pmc
\t\@\$(ADDGENERATED) "include/pmc/pmc_$pmc.h" "[devel]" include
src/pmc/$pmc.dump : vtable.dump $parent_dumps src/pmc/$pmc.pmc \$(PMC2C_FILES) $pccmethod_depend
\t\$(PMC2CD) src/pmc/$pmc.pmc
include/pmc/pmc_$pmc.h: src/pmc/$pmc.c
## SUFFIX OVERRIDE -Warnings
src/pmc/$pmc\$(O): \\
$o_deps
\t\$(CC) \$(CFLAGS) $optimize $cc_shared $warnings -I\$(\@D)/. $cc_o_out\$@ -c src/pmc/$pmc.c
END
}
# build list of libraries for link line in Makefile
( my $TEMP_pmc_classes_o = $TEMP_pmc_o ) =~ s{^| }{ src/pmc/}g;
( my $TEMP_pmc_classes_str = $TEMP_pmc_str ) =~ s{^| }{ src/pmc/}g;
( my $TEMP_pmc_classes_pmc = $pmc_list ) =~ s{^| }{ src/pmc/}g;
# Gather the actual names (with MixedCase) of all of the non-abstract
# built-in PMCs in rough hierarchical order.
my %parents;
PMC: for my $pmc_file ( split( /\s+/, $pmc_list ) ) {
open my $PMC, "<", "src/pmc/$pmc_file"
or die "open src/pmc/$pmc_file: $!";
my ($const, $name);
while (<$PMC>) {
if (/^pmclass (\w+)(.*)/) {
$name = $1;
my $decl = $2;
$decl .= <$PMC> until $decl =~ s/\{.*//;
$const = 1 if $decl =~ /\bconst_too\b/;
next PMC if $decl =~ /\bextension\b/;
# the default PMC gets handled specially
last if $name eq 'default';
my $parent = 'default';
if ($decl =~ /extends (\w+)/) {
$parent = $1;
}
# set a marker not to initialize an abstract PMC
if ($decl =~ /\babstract\b/) {
unshift @{ $parents{$name} }, '(abstract)';
}
# please note that normal and Const PMCs must be in this order
push @{ $parents{$parent} }, $name;
push @{ $parents{$parent} }, "Const$name" if $const;
last;
}
}
close $PMC;
die "No pmclass declaration found in $pmc_file"
unless defined $name;
}
my @names = ('default', $self->order_pmcs_by_hierarchy( \%parents ));
$conf->data->set(
pmc => $pmc_list,
pmc_names => join( ' ', @names ),
TEMP_pmc_o => $TEMP_pmc_o,
TEMP_pmc_build => $TEMP_pmc_build,
TEMP_pmc_classes_o => $TEMP_pmc_classes_o,
TEMP_pmc_classes_str => $TEMP_pmc_classes_str,
TEMP_pmc_classes_pmc => $TEMP_pmc_classes_pmc,
);
return 1;
}
# Return the (lowercased) name of the immediate parent of the given
# (lowercased) pmc name.
sub pmc_parent {
my ($self, $pmc) = @_;
return $self->{PMC_PARENTS}{$pmc} if defined $self->{PMC_PARENTS}{$pmc};
local $/;
open( my $PMC, '<', "src/pmc/$pmc.pmc" )
or die "open src/pmc/$pmc.pmc failed: $!";
local $_ = <$PMC>;
close $PMC;
# Throw out everything but the pmclass declaration
s/^.*?pmclass//s;
s/\{.*$//s;
return $self->{PMC_PARENTS}{$pmc} = lc($1) if m/extends\s+(\w+)/;
return $self->{PMC_PARENTS}{$pmc} = 'default';
}
# Return an array of all
sub pmc_parents {
my ($self, $pmc) = @_;
my @parents = ($pmc);
push @parents, $self->pmc_parent( $parents[-1] )
until $parents[-1] eq 'default';
shift @parents;
return @parents;
}
# Internal sub get_pmc_order parses src/pmc/pmc.num. The hash it builds
# includes both active and deactivated PMCs.
sub get_pmc_order {
open my $IN, '<', 'src/pmc/pmc.num' or die "Can't read src/pmc/pmc.num";
my %order;
while (<$IN>) {
next unless (/^(\w+\.\w+)\s+(\d+)$/);
$order{$1} = $2;
}
close $IN;
return \%order;
}
sub get_sorted_pmc_str {
my @pmcs = @_;
my $pmc_order = get_pmc_order();
my $n = keys %$pmc_order;
my @sorted_pmcs;
for my $pmc (@pmcs) {
if ( exists $pmc_order->{$pmc} ) {
$sorted_pmcs[ $pmc_order->{$pmc} ] = $pmc;
}
else {
$sorted_pmcs[ $n++ ] = $pmc;
}
}
# With the test for definedness below, we account for PMCs which have been
# deactivated but whose index numbers remain in src/pmc/pmc.num.
my $active_pmcs = [ grep { defined $_ } @sorted_pmcs ];
# At this point we check to see whether any active_pmcs are missing from
# the MANIFEST. We warn about any such missing PMCs but (for the time
# being at least) we proceed to compose $pmc_str.
my $seen_manifest = pmcs_in_manifest();
check_pmcs_against_manifest( $active_pmcs, $seen_manifest );
return join(' ' => @{ $active_pmcs });
}
sub pmcs_in_manifest {
my $manifest = shift || 'MANIFEST';
my %seen_manifest = ();
open my $MAN, '<', $manifest
or die "Unable to open MANIFEST: $!";
while (my $f = <$MAN>) {
chomp $f;
if ($f =~ m{^src/pmc/(.*\.pmc)}) {
my $pmc = $1;
$seen_manifest{$pmc}++;
}
}
close $MAN or die "Unable to close MANIFEST: $!";
return \%seen_manifest;
}
sub check_pmcs_against_manifest {
my ($active_pmcs, $seen_manifest) = @_;
my @missing_from_manifest = grep { ! exists $seen_manifest->{$_} }
@{ $active_pmcs };
if (@missing_from_manifest) {
warn "PMCs found in /src/pmc not found in MANIFEST: @missing_from_manifest";
}
}
sub contains_pccmethod {
my $file = shift;
open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
local $_;
while (<$fh>) {
next unless /\bMETHOD\b/;
return 1;
}
return;
}
# Given a PMC file name, get a list of all the includes it specifies
sub get_includes {
my $file = shift;
open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
my @retval;
local $_;
while (<$fh>) {
next unless /^\s*# *include\s+"(.*)"\s+$/;
my $include = $1;
if ($include =~ m{^parrot}) { # main parrot include dir
next if $include eq "parrot/parrot.h"; # already implicit everywhere.
next if $include eq "parrot/io.h"; # already implicit everywhere.
$include = "include/" . $include;
} elsif ($include =~ m/^pmc_|\.str$/) { # local pmc header
$include = "src/pmc/" . $include;
} elsif ($include =~ m/^pmc\/pmc_/) { # local pmc header
$include = "include/" . $include;
} elsif ($include =~ m/^imcc/) { # IMCC header.
$include = "include/" . $include;
} elsif ($include =~ m{^\.\./}) { # relative to include/ dir...
$include =~ s{^\.\./}{};
}
push @retval, $include;
}
return join(' ', @retval);
}
sub order_pmcs_by_hierarchy {
my ($self, $parents) = @_;
return $self->get_kids_for_parent( $parents, 'default' );
}
sub get_kids_for_parent {
my ($self, $parents, $parent) = @_;
my @kids;
for my $kid (@{ $parents->{$parent} }) {
# skip abstract PMCs
next if $kid eq '(abstract)';
push @kids, $kid unless exists $parents->{$kid}
&& $parents->{$kid}[0] eq '(abstract)';
# and avoid infinite loops
next if $kid eq $parent;
push @kids, $self->get_kids_for_parent($parents, $kid);
}
return @kids;
}
1;
__DATA__
include/parrot/cclass.h
include/parrot/multidispatch.h
include/parrot/call.h
include/parrot/exit.h
include/parrot/pobj.h
include/parrot/extend_vtable.h
include/parrot/memory.h
include/parrot/key.h
include/parrot/oo.h
include/parrot/feature.h
include/parrot/oplib.h
include/parrot/library.h
include/parrot/string.h
include/parrot/settings.h
include/parrot/namespace.h
include/parrot/extend.h
include/parrot/pbcversion.h
include/parrot/core_types.h
include/parrot/interpreter.h
include/parrot/io.h
include/parrot/context.h
include/parrot/parrot.h
include/parrot/dynext.h
include/parrot/hash.h
include/parrot/enums.h
include/parrot/encoding.h
include/parrot/vtable.h
include/parrot/scheduler.h
include/parrot/pmc.h
include/parrot/datatypes.h
include/parrot/core_pmcs.h
include/parrot/misc.h
include/parrot/sub.h
include/parrot/pmc_freeze.h
include/parrot/global_setup.h
include/parrot/gc_api.h
include/parrot/nci.h
include/parrot/vtables.h
include/parrot/has_header.h
include/parrot/warnings.h
include/parrot/op.h
include/parrot/debugger.h
include/parrot/caches.h
include/parrot/config.h
include/parrot/platform_interface.h
include/parrot/hll.h
include/parrot/packfile.h
include/parrot/exceptions.h
include/parrot/string_funcs.h
include/parrot/compiler.h
include/pmc/pmc_callcontext.h
include/pmc/pmc_continuation.h
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
Jump to Line
Something went wrong with that request. Please try again.