1# Copyright (C) 2001-2014, Parrot Foundation.
2
3=head1 NAME
4
5config/auto/pmc.pm - PMC Files
6
7=head1 DESCRIPTION
8
9Prepare PMC files for inclusion.
10
11=cut
12
13package auto::pmc;
14
15use strict;
16use warnings;
17
18use base qw(Parrot::Configure::Step);
19
20use File::Basename qw/basename/;
21use File::Spec::Functions qw/catfile/;
22
23use Parrot::Configure::Utils ':auto';
24
25sub _init {
26    my $self = shift;
27    return {
28        description => 'Which pmc files should be compiled in',
29        result      => '',
30        PMC_PARENTS => {},
31        srcpmc      => [ sort map { basename($_) } glob "./src/pmc/*.pmc" ],
32    };
33}
34
35sub runstep {
36    my ( $self, $conf ) = @_;
37
38    # $pmc_list is a string holding a space-delimited list of currently active
39    # PMCs, sorted (largely) on the basis of src/pmc/pmc.num.
40    # (By 'current', we take into account the fact that there are PMCs listed
41    # in src/pmc/pmc.num that no longer exist but whose index numbers are
42    # never deleted.)
43    my $pmc_list = get_sorted_pmc_str( @{ $self->{srcpmc} } );
44
45    # names of class files for src/pmc/Makefile
46    ( my $TEMP_pmc_o   = $pmc_list ) =~ s/\.pmc/\$(O)/g;
47    ( my $TEMP_pmc_str = $pmc_list ) =~ s/\.pmc/\.str/g;
48
49    # calls to pmc2c.pl for src/pmc/Makefile
50    my $TEMP_pmc_build = <<"E_NOTE";
51
52# the following part of the Makefile was built by 'config/auto/pmc.pm'
53
54E_NOTE
55
56    $TEMP_pmc_build .= <<END;
57PMC2C_FILES = \\
58    lib/Parrot/Pmc2c/Pmc2cMain.pm \\
59    lib/Parrot/Pmc2c/Parser.pm \\
60    lib/Parrot/Pmc2c/Dumper.pm \\
61    lib/Parrot/Pmc2c/PMC.pm \\
62    lib/Parrot/Pmc2c/Method.pm \\
63    lib/Parrot/Pmc2c/PCCMETHOD.pm \\
64    lib/Parrot/Pmc2c/Library.pm \\
65    lib/Parrot/Pmc2c/UtilFunctions.pm \\
66    lib/Parrot/Pmc2c/PMC/RO.pm
67
68END
69
70    my %universal_deps;
71    while (<DATA>) {
72        next if /^#/;
73        next if /^\s*$/;
74        chomp;
75        $universal_deps{$_} = 1;
76    }
77
78    for my $pmc ( split( /\s+/, $pmc_list ) ) {
79        $pmc =~ s/\.pmc$//;
80
81        # make each pmc depend upon its parent.
82        my $parent_dumps = '';
83        $parent_dumps .= "src/pmc/$_.dump "
84            foreach reverse( ( $self->pmc_parents($pmc) ) );
85        my $parent_headers = '';
86        $parent_headers .= "include/pmc/pmc_$_.h "
87            for $self->pmc_parents($pmc);
88
89        # add dependencies that result from METHOD usage.
90        my $pmc_fname = catfile('src', 'pmc', "$pmc.pmc");
91        my $pccmethod_depend = '';
92        my %o_deps    = %universal_deps;
93        $o_deps{"src/pmc/$pmc.c"}         = 1;
94        $o_deps{"src/pmc/$pmc.str"}       = 1;
95        $o_deps{"include/pmc/pmc_$pmc.h"} = 1;
96
97        if (contains_pccmethod($pmc_fname)) {
98            $o_deps{"include/pmc/pmc_fixedintegerarray.h"} = 1;
99            if ($pmc ne 'fixedintegerarray') {
100                $pccmethod_depend .= ' include/pmc/pmc_fixedintegerarray.h';
101            }
102        }
103
104        my $include_headers = get_includes($pmc_fname);
105        my $cc_shared = $conf->data->get('cc_shared');
106        my $cc_o_out  = $conf->data->get('cc_o_out');
107        my $warnings  = $conf->data->get('ccwarn');
108        my $optimize  = $conf->data->get('optimize');
109
110        foreach my $header (split ' ', $parent_headers) {
111            $o_deps{$header} = 1;
112        }
113        foreach my $header (split ' ', $include_headers) {
114            $o_deps{$header} = 1;
115        }
116
117        # includes of includes
118        # (cheat. The right way to handle this is to do what
119        # checkdepend.t does.)
120        if (exists $o_deps{'include/parrot/oplib/core_ops.h'} ) {
121            $o_deps{'include/parrot/runcore_api.h'} = 1;
122        }
123
124        # optional pmc2c classfiles
125        my $class = uc(substr($pmc,0,1)).substr($pmc,1);
126        $class = "default" if $pmc eq "default";
127        if (-e "lib/Parrot/Pmc2c/PMC/$class.pm" ) {
128            $o_deps{"lib/Parrot/Pmc2c/PMC/$class.pm"} = 1;
129        }
130
131        my $o_deps = "    " . join(" \\\n    ", sort keys %o_deps);
132        $TEMP_pmc_build .= <<END
133include/pmc/pmc_$pmc.h src/pmc/$pmc.c : src/pmc/$pmc.dump
134\t\$(PMC2CC) src/pmc/$pmc.pmc
135\t\@\$(ADDGENERATED) "include/pmc/pmc_$pmc.h" "[devel]" include
136
137src/pmc/$pmc.dump : vtable.dump $parent_dumps src/pmc/$pmc.pmc \$(PMC2C_FILES) $pccmethod_depend
138\t\$(PMC2CD) src/pmc/$pmc.pmc
139\t\@\$(ADDGENERATED) "src/pmc/$pmc.dump" "[devel]" src
140
141## SUFFIX OVERRIDE -Warnings
142src/pmc/$pmc\$(O): \\
143$o_deps
144\t\$(CC) \$(CFLAGS) $optimize $cc_shared $warnings -I\$(\@D)/. $cc_o_out\$@ -c src/pmc/$pmc.c
145
146END
147    }
148
149
150    # build list of libraries for link line in Makefile
151    ( my $TEMP_pmc_classes_o   = $TEMP_pmc_o )   =~ s{^| }{ src/pmc/}g;
152    ( my $TEMP_pmc_classes_str = $TEMP_pmc_str ) =~ s{^| }{ src/pmc/}g;
153    ( my $TEMP_pmc_classes_pmc = $pmc_list )     =~ s{^| }{ src/pmc/}g;
154
155    # Gather the actual names (with MixedCase) of all of the non-abstract
156    # built-in PMCs in rough hierarchical order.
157    my %parents;
158
159PMC: for my $pmc_file ( split( /\s+/, $pmc_list ) ) {
160
161        open my $PMC, "<", "src/pmc/$pmc_file"
162            or die "open src/pmc/$pmc_file: $!";
163
164        my ($const, $name);
165
166        while (<$PMC>) {
167            if (/^pmclass (\w+)(.*)/) {
168                $name    = $1;
169                my $decl = $2;
170                $decl .= <$PMC> until $decl =~ s/\{.*//;
171
172                $const = 1 if $decl =~ /\bconst_too\b/;
173                next PMC   if $decl =~ /\bextension\b/;
174
175                # the default PMC gets handled specially
176                last       if $name eq 'default';
177
178                my $parent = 'default';
179
180                if ($decl =~ /extends (\w+)/) {
181                    $parent = $1;
182                }
183
184                # set a marker not to initialize an abstract PMC
185                if ($decl =~ /\babstract\b/) {
186                    unshift @{ $parents{$name} }, '(abstract)';
187                }
188
189                # please note that normal and Const PMCs must be in this order
190                push @{ $parents{$parent} }, $name;
191                push @{ $parents{$parent} }, "Const$name" if $const;
192
193                last;
194            }
195        }
196
197        close $PMC;
198
199        die "No pmclass declaration found in $pmc_file"
200            unless defined $name;
201    }
202
203    my @names = ('default', $self->order_pmcs_by_hierarchy( \%parents ));
204
205    $conf->data->set(
206        pmc                  => $pmc_list,
207        pmc_names            => join( ' ', @names ),
208        TEMP_pmc_o           => $TEMP_pmc_o,
209        TEMP_pmc_build       => $TEMP_pmc_build,
210        TEMP_pmc_classes_o   => $TEMP_pmc_classes_o,
211        TEMP_pmc_classes_str => $TEMP_pmc_classes_str,
212        TEMP_pmc_classes_pmc => $TEMP_pmc_classes_pmc,
213    );
214
215    return 1;
216}
217
218# Return the (lowercased) name of the immediate parent of the given
219# (lowercased) pmc name.
220sub pmc_parent {
221    my ($self, $pmc) = @_;
222
223    return $self->{PMC_PARENTS}{$pmc} if defined $self->{PMC_PARENTS}{$pmc};
224
225    local $/;
226    open( my $PMC, '<', "src/pmc/$pmc.pmc" )
227        or die "open src/pmc/$pmc.pmc failed: $!";
228    local $_ = <$PMC>;
229    close $PMC;
230
231    # Throw out everything but the pmclass declaration
232    s/^.*?pmclass//s;
233    s/\{.*$//s;
234
235    return $self->{PMC_PARENTS}{$pmc} = lc($1) if m/extends\s+(\w+)/;
236    return $self->{PMC_PARENTS}{$pmc} = 'default';
237}
238
239# Return an array of all
240sub pmc_parents {
241    my ($self, $pmc) = @_;
242
243    my @parents = ($pmc);
244    push @parents, $self->pmc_parent( $parents[-1] )
245        until $parents[-1] eq 'default';
246
247    shift @parents;
248    return @parents;
249}
250
251# Internal sub get_pmc_order parses src/pmc/pmc.num.  The hash it builds
252# includes both active and deactivated PMCs.
253sub get_pmc_order {
254    open my $IN, '<', 'src/pmc/pmc.num' or die "Can't read src/pmc/pmc.num";
255    my %order;
256    while (<$IN>) {
257        next unless (/^(\w+\.\w+)\s+(\d+)$/);
258        $order{$1} = $2;
259    }
260    close $IN;
261    return \%order;
262}
263
264sub get_sorted_pmc_str {
265    my @pmcs      = @_;
266    my $pmc_order = get_pmc_order();
267    my $n         = keys %$pmc_order;
268    my @sorted_pmcs;
269
270    for my $pmc (@pmcs) {
271        if ( exists $pmc_order->{$pmc} ) {
272            $sorted_pmcs[ $pmc_order->{$pmc} ] = $pmc;
273        }
274        else {
275            $sorted_pmcs[ $n++ ] = $pmc;
276        }
277    }
278
279    # With the test for definedness below, we account for PMCs which have been
280    # deactivated but whose index numbers remain in src/pmc/pmc.num.
281    my $active_pmcs = [ grep { defined $_ } @sorted_pmcs ];
282
283    # At this point we check to see whether any active_pmcs are missing from
284    # the MANIFEST.  We warn about any such missing PMCs but (for the time
285    # being at least) we proceed to compose $pmc_str.
286    my $seen_manifest = pmcs_in_manifest();
287    check_pmcs_against_manifest( $active_pmcs, $seen_manifest );
288    return join(' ' => @{ $active_pmcs });
289}
290
291sub pmcs_in_manifest {
292    my $manifest = shift || 'MANIFEST';
293    my %seen_manifest = ();
294    open my $MAN, '<', $manifest
295        or die "Unable to open MANIFEST: $!";
296    while (my $f = <$MAN>) {
297        chomp $f;
298        if ($f =~ m{^src/pmc/(.*\.pmc)}) {
299            my $pmc = $1;
300            $seen_manifest{$pmc}++;
301        }
302    }
303    close $MAN or die "Unable to close MANIFEST: $!";
304    return \%seen_manifest;
305}
306
307sub check_pmcs_against_manifest {
308    my ($active_pmcs, $seen_manifest) = @_;
309    my @missing_from_manifest = grep { ! exists $seen_manifest->{$_} }
310        @{ $active_pmcs };
311    if (@missing_from_manifest) {
312        warn "PMCs found in /src/pmc not found in MANIFEST: @missing_from_manifest";
313    }
314}
315
316sub contains_pccmethod {
317    my $file = shift;
318    open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
319
320    local $_;
321    while (<$fh>) {
322        next unless /\bMETHOD\b/;
323        return 1;
324    }
325
326    return;
327}
328
329# Given a PMC file name, get a list of all the includes it specifies
330sub get_includes {
331    my $file = shift;
332    open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
333
334    my @retval;
335    local $_;
336    while (<$fh>) {
337        next unless /^\s*# *include\s+"(.*)"\s+$/;
338        my $include = $1;
339        if ($include =~ m{^parrot}) { # main parrot include dir
340          next if $include eq "parrot/parrot.h"; # already implicit everywhere.
341          next if $include eq "parrot/io.h";     # already implicit everywhere.
342          $include = "include/" . $include;
343        } elsif ($include =~ m/^pmc_|\.str$/) { # local pmc header
344          $include = "src/pmc/" . $include;
345        } elsif ($include =~ m/^pmc\/pmc_/) { # local pmc header
346          $include = "include/" . $include;
347        } elsif ($include =~ m/^imcc/) { # IMCC header.
348            $include = "include/" . $include;
349        } elsif ($include =~ m{^\.\./}) { # relative to include/ dir...
350          $include =~ s{^\.\./}{};
351        }
352        push @retval, $include;
353    }
354
355    return join(' ', @retval);
356}
357
358sub order_pmcs_by_hierarchy {
359    my ($self, $parents) = @_;
360
361    return $self->get_kids_for_parent( $parents, 'default' );
362}
363
364sub get_kids_for_parent {
365    my ($self, $parents, $parent) = @_;
366
367    my @kids;
368
369    for my $kid (@{ $parents->{$parent} }) {
370        # skip abstract PMCs
371        next if $kid eq '(abstract)';
372        push @kids, $kid unless exists $parents->{$kid}
373                                &&     $parents->{$kid}[0] eq '(abstract)';
374
375        # and avoid infinite loops
376        next if $kid eq $parent;
377        push @kids, $self->get_kids_for_parent($parents, $kid);
378    }
379
380    return @kids;
381}
382
3831;
384
385__DATA__
386include/parrot/cclass.h
387include/parrot/multidispatch.h
388include/parrot/call.h
389include/parrot/exit.h
390include/parrot/pobj.h
391include/parrot/extend_vtable.h
392include/parrot/memory.h
393include/parrot/key.h
394include/parrot/oo.h
395include/parrot/feature.h
396include/parrot/oplib.h
397include/parrot/library.h
398include/parrot/string.h
399include/parrot/settings.h
400include/parrot/namespace.h
401include/parrot/extend.h
402include/parrot/pbcversion.h
403include/parrot/core_types.h
404include/parrot/interpreter.h
405include/parrot/io.h
406include/parrot/context.h
407include/parrot/parrot.h
408include/parrot/dynext.h
409include/parrot/hash.h
410include/parrot/enums.h
411include/parrot/encoding.h
412include/parrot/vtable.h
413include/parrot/scheduler.h
414include/parrot/pmc.h
415include/parrot/datatypes.h
416include/parrot/core_pmcs.h
417include/parrot/misc.h
418include/parrot/sub.h
419include/parrot/pmc_freeze.h
420include/parrot/global_setup.h
421include/parrot/gc_api.h
422include/parrot/nci.h
423include/parrot/vtables.h
424include/parrot/has_header.h
425include/parrot/warnings.h
426include/parrot/op.h
427include/parrot/debugger.h
428include/parrot/caches.h
429include/parrot/config.h
430include/parrot/platform_interface.h
431include/parrot/hll.h
432include/parrot/packfile.h
433include/parrot/exceptions.h
434include/parrot/string_funcs.h
435include/parrot/compiler.h
436include/pmc/pmc_callcontext.h
437include/pmc/pmc_continuation.h
438
439# Local Variables:
440#   mode: cperl
441#   cperl-indent-level: 4
442#   fill-column: 100
443# End:
444# vim: expandtab shiftwidth=4:
445