1 # Copyright (C) 2007-2008, The Perl Foundation.
6 Parrot::Pmc2c::PMCEmitter - PMC to C Code Generation
10 use Parrot::Pmc2c::PMCEmitter;
14 C<Parrot::Pmc2c::PMCEmitter> is used by F<tools/build/pmc2c.pl> to generate C code from PMC files.
22 package Parrot
::Pmc2c
::PMC
;
25 use Parrot
::Pmc2c
::Emitter
;
26 use Parrot
::Pmc2c
::Method
;
27 use Parrot
::Pmc2c
::MethodEmitter
;
28 use Parrot
::Pmc2c
::UtilFunctions
29 qw( gen_ret dont_edit count_newlines dynext_load_code c_code_coda );
30 use Text
::Balanced
'extract_bracketed';
31 use Parrot
::Pmc2c
::PCCMETHOD
;
32 use Parrot
::Pmc2c
::PMC
::RO
;
33 use Parrot
::Pmc2c
::PMC
::ParrotClass
;
36 my ( $this, $pmc, $vtable_dump ) = @_;
38 $pmc->vtable($vtable_dump);
46 my $emitter = $self->{emitter
} =
47 Parrot
::Pmc2c
::Emitter
->new( $self->filename(".c") );
49 $self->generate_c_file;
50 $emitter->write_to_file;
52 $emitter = $self->{emitter
} =
53 Parrot
::Pmc2c
::Emitter
->new( $self->filename(".h") );
55 $self->generate_h_file;
56 $emitter->write_to_file;
59 =item C<generate_c_file()>
61 Generates the C implementation file code for the PMC.
67 my $c = $self->{emitter
};
69 $c->emit( dont_edit
( $self->filename ) );
70 if ($self->is_dynamic) {
71 $c->emit("#define PARROT_IN_EXTENSION\n");
72 $c->emit("#define CONST_STRING(i, s) const_string((i), s)\n");
73 $c->emit("#define CONST_STRING_GEN(i, s) const_string((i), s)\n");
78 $c->emit( $self->preamble );
84 $ro->{emitter
} = $self->{emitter
};
88 $c->emit("#include \"pmc_default.h\"\n");
90 $c->emit( $self->init_func );
91 $c->emit( $self->postamble );
96 =item C<generate_h_file()>
98 Generates the C header file code for the PMC.
102 sub generate_h_file
{
104 my $h = $self->{emitter
};
105 my $name = uc $self->name;
107 $h->emit( dont_edit
( $self->filename ) );
110 #ifndef PARROT_PMC_${name}_H_GUARD
111 #define PARROT_PMC_${name}_H_GUARD
115 $h->emit("#define PARROT_IN_EXTENSION\n") if ( $self->is_dynamic );
116 $h->emit( $self->hdecls );
117 $h->emit( $self->{ro
}->hdecls ) if ( $self->{ro
} );
118 $self->gen_attributes;
121 #endif /* PARROT_PMC_${name}_H_GUARD */
124 $h->emit( c_code_coda
() );
130 Returns the C code function declarations for all the methods for inclusion
131 in the PMC's C header file.
133 TODO include MMD variants.
141 my $name = $self->name;
143 # generate decls for all vtable methods in this PMC
144 foreach my $vt_method_name ( @
{ $self->vtable->names } ) {
145 if ( $self->implements_vtable($vt_method_name) ) {
147 $self->get_method($vt_method_name)->generate_headers($self);
151 # generate decls for all nci methods in this PMC
152 foreach my $method ( @
{ $self->{methods
} } ) {
153 next if $method->is_vtable;
154 $hout .= $method->generate_headers($self);
158 $hout .= 'PARROT_DYNEXT_EXPORT ' if ( $self->is_dynamic );
159 $hout .= "void Parrot_${name}_class_init(PARROT_INTERP, int, int);\n";
160 $self->{hdecls
} .= $hout;
162 return $self->{hdecls
};
167 =head2 Instance Methods
173 Initializes the instance.
180 $self->fixup_singleton if $self->singleton;
182 #!( singleton or abstract ) everything else gets readonly version of
185 $self->ro( Parrot
::Pmc2c
::PMC
::RO
->new($self) )
186 unless $self->abstract or $self->singleton;
189 sub fixup_singleton
{
192 # Because singletons are shared between interpreters, we need to make
193 # special effort to use the right namespace for method lookups.
195 # Note that this trick won't work if the singleton inherits from something
196 # else (because the MRO will still be shared).
198 unless ( $self->implements_vtable('get_namespace')
199 or $self->super_method('get_namespace') ne 'default' )
202 Parrot
::Pmc2c
::Emitter
->text(
203 " return INTERP->vtables[SELF->vtable->base_type]->_namespace;\n");
205 Parrot
::Pmc2c
::Method
->new(
207 name
=> 'get_namespace',
208 parent_name
=> $self->name,
211 type
=> Parrot
::Pmc2c
::Method
::VTABLE
,
213 return_type
=> 'PMC*',
221 =item C<gen_includes()>
223 Returns the C C<#include> for the header file of each of the PMC's superclasses.
229 my $c = $self->{emitter
};
232 #include "parrot/parrot.h"
233 #include "parrot/extend.h"
234 #include "parrot/dynext.h"
237 $c->emit(qq{#include "pmc_fixedintegerarray.h"\n})
238 if $self->flag('need_fia_header');
240 foreach my $parent_name ( $self->name, @
{ $self->parents } ) {
241 $c->emit( '#include "pmc_' . lc $parent_name . ".h\"\n" );
244 foreach my $mixin_name ( @
{ $self->mixins } ) {
245 $c->emit( '#include "pmc_' . lc $mixin_name . ".h\"\n" );
248 $c->emit( '#include "' . lc $self->name . ".str\"\n" )
249 unless $self->is_dynamic;
252 =item C<proto($type,$parameters)>
254 Determines the prototype (argument signature) for a method body
255 (see F<src/call_list>).
279 #"BIGNUM*" => "???" # RT#43731
283 my ( $type, $parameters ) = @_;
285 # reduce to a comma separated set of types
286 $parameters =~ s/\w+(,|$)/,/g;
287 $parameters =~ s/ //g;
289 # flatten whitespace before "*" in return value
290 $type =~ s/\s+\*$/\*/ if defined $type;
292 # type method(interp, self, parameters...)
293 my $ret = $calltype{ $type or "void" }
295 . join( '', map { $calltype{$_} or "?" } split( /,/, $parameters ) );
298 # scan src/call_list.txt if the generated signature is available
300 # RT #43735 report errors for "?"
309 =item C<gen_methods()>
311 Returns the C code for the pmc methods.
319 foreach my $method ( @
{ $self->vtable->methods } ) {
320 my $vt_method_name = $method->name;
321 next if $vt_method_name eq 'class_init';
323 if ( $self->implements_vtable($vt_method_name) ) {
324 $self->get_method($vt_method_name)->generate_body($self);
329 foreach my $method ( @
{ $self->methods } ) {
330 next if $method->is_vtable;
331 $method->generate_body($self);
335 =item C<gen_attributes()>
337 Returns the C code for the attribute struct definition.
343 my $attributes = $self->attributes;
345 if ( @
$attributes ) {
347 Parrot
::Pmc2c
::Attribute
::generate_start
( $attributes->[0], $self );
349 foreach my $attribute ( @
$attributes ) {
350 $attribute->generate_declaration($self);
353 Parrot
::Pmc2c
::Attribute
::generate_end
( $attributes->[0], $self );
355 foreach my $attribute ( @
$attributes ) {
356 $attribute->generate_accessor($self);
362 # RT #43737 quick hack - to get MMD variants
364 my ( $self, $vt_method_name, $right, $mmd_prefix ) = @_;
367 my $super_mmd_rights = $self->{super_mmd_rights
}{$vt_method_name};
368 if ($super_mmd_rights) {
369 while ( my ( $super_pmc_name, $mmd_rights ) = each %$super_mmd_rights )
371 for my $x ( @
{$mmd_rights} ) {
372 next if $x eq "DEFAULT";
373 my $right = "enum_class_$x";
375 "Parrot_${super_pmc_name}_${vt_method_name}_$x";
376 push @mmds, [ $mmd_prefix, 0, $right, $super_name ];
384 =item C<find_mmd_methods()>
386 Returns three values:
388 The first is an arrayref of <[ mmd_number, left, right, implementation_func]>
389 suitable for initializing the MMD list.
391 The second is a arrayref listing dynamic PMCs which will need to be looked up.
393 The third is a list of C<[index, dynamic PMC]> pairs of right entries
394 in the MMD table that will need to be resolved at runtime.
398 sub find_mmd_methods
{
400 my $pmcname = $self->name;
402 my ( @mmds, @init_mmds, %init_mmds );
404 foreach my $vt_method ( @
{ $self->vtable->methods } ) {
405 my $vt_method_name = $vt_method->name;
406 next unless $vt_method->is_mmd;
409 if ( $self->implements_vtable($vt_method_name) ) {
410 $implementor = $pmcname;
413 my $class = $self->{super
}{$vt_method_name};
415 if $class =~ /^[A-Z]/
416 or $class eq 'default'
417 or $class eq 'delegate';
418 $implementor = $class;
421 my ( $mmd_method_name, $func, $left, $right );
422 $mmd_method_name = "Parrot_${implementor}_$vt_method_name";
423 $func = $vt_method->mmd_prefix;
425 # dynamic PMCs need the runtime type which is passed in entry to
428 # set to 'entry' below in initialization loop.
430 $right = $vt_method->right;
432 if ( exists $self->{super
}{$vt_method_name} ) {
433 push @mmds, $self->get_super_mmds( $vt_method_name, $right, $func );
436 push @mmds, [ $func, $left, $right, $mmd_method_name ];
438 my $pmc_method = $self->get_method($vt_method_name);
440 foreach my $mmd ( @
{ $pmc_method->mmds } ) {
441 my $right = $mmd->right;
442 if ( $self->is_dynamic($right) ) {
444 push @init_mmds, [ scalar @mmds, $mmd->right ];
445 $init_mmds{ $mmd->right } = 1;
448 $right = "enum_class_$right";
450 $mmd_method_name = "Parrot_" . $self->name . "_" . $mmd->name;
451 push @mmds, [ $func, $left, $right, $mmd_method_name ];
454 #$self->{mmds} = @mmds; # RT#43739
457 return ( \
@mmds, \
@init_mmds, [ keys %init_mmds ] );
460 sub build_full_c_vt_method_name
{
461 my ( $self, $vt_method_name ) = @_;
464 if ( $self->implements_vtable($vt_method_name) ) {
465 return $self->get_method($vt_method_name)
466 ->full_method_name( $self->name . $self->{variant
} );
468 elsif ( $self->{super
}{$vt_method_name} ) {
469 $implementor = $self->{super
}{$vt_method_name};
472 $implementor = "default";
475 return "Parrot_${implementor}_$vt_method_name";
478 =item C<vtable_decl($name)>
480 Returns the C code for the declaration of a vtable temporary named
481 C<$name> with the functions for this class.
486 my ( $self, $temp_struct_name, $enum_name ) = @_;
490 $vtbl_flag .= '|VTABLE_PMC_NEEDS_EXT' if $self->flag('need_ext');
491 $vtbl_flag .= '|VTABLE_PMC_IS_SINGLETON' if $self->flag('singleton');
492 $vtbl_flag .= '|VTABLE_IS_SHARED_FLAG' if $self->flag('is_shared');
493 $vtbl_flag .= '|VTABLE_IS_READONLY_FLAG' if $self->flag('is_ro');
494 $vtbl_flag .= '|VTABLE_HAS_READONLY_FLAG' if $self->flag('has_ro');
497 foreach my $vt_method ( @
{ $self->vtable->methods } ) {
498 next if $vt_method->is_mmd;
500 $self->build_full_c_vt_method_name( $vt_method->name );
503 my $methlist = join( ",\n ", @vt_methods );
505 my $cout = <<ENDOFCODE;
506 const VTABLE $temp_struct_name = {
507 NULL, /* namespace */
508 $enum_name, /* base_type */
510 $vtbl_flag, /* flags */
511 NULL, /* provides_str */
515 NULL, /* ro_variant_vtable */
524 Returns the C code for the PMC's initialization method, or an empty
525 string if the PMC has a C<no_init> flag.
531 return "" if $self->no_init;
534 my $classname = $self->name;
536 my ( $mmds, $init_mmds, $dyn_mmds ) = $self->find_mmd_methods();
538 my $enum_name = $self->is_dynamic ?
-1 : "enum_class_$classname";
539 my $vtable_decl = $self->vtable_decl( 'temp_base_vtable', $enum_name );
541 my $mmd_list = join( ",\n ",
542 map { "{ $_->[0], $_->[1], $_->[2], (funcptr_t) $_->[3] }" } @
$mmds );
544 my @isa = grep { $_ ne 'default' } @
{ $self->parents };
546 my $provides = join( " ", keys( %{ $self->{flags
}{provides
} } ) );
547 my $class_init_code = "";
549 if ($self->has_method('class_init')) {
550 $class_init_code = $self->get_method('class_init')->body;
552 $class_init_code =~ s/INTERP/interp/g;
555 $class_init_code =~ s/^/ /mg;
559 $extra_vt{ro
} = $self->{ro
} if $self->{ro
};
563 Parrot_${classname}_class_init(PARROT_INTERP, int entry, int pass)
568 for my $k ( keys %extra_vt ) {
569 $cout .= $extra_vt{$k}->vtable_decl( "temp_${k}_vtable", $enum_name );
572 my $const = ( $self->{flags
}{dynpmc
} ) ?
" " : " const ";
576 $const MMD_init _temp_mmd_init[] = {
579 /* Dynamic PMCs need the runtime type which is passed in entry to class_init. */
588 /* create vtable - clone it - we have to set a few items */
589 VTABLE * const vt_clone = Parrot_clone_vtable(interp,
592 for my $k ( keys %extra_vt ) {
594 VTABLE * const vt_${k}_clone = Parrot_clone_vtable(interp,
600 if ( $self->is_dynamic ) {
602 vt_clone->base_type = entry;
603 vt_clone->whoami = string_make(interp, "$classname", @{[length($classname)]}, "ascii",
604 PObj_constant_FLAG|PObj_external_FLAG);
605 vt_clone->provides_str = string_append(interp, vt_clone->provides_str,
606 string_make(interp, " $provides", @{[length($provides) + 1]}, "ascii",
607 PObj_constant_FLAG|PObj_external_FLAG));
609 /* set up isa hash */
610 parrot_new_hash(interp, &isa_hash);
611 vt_clone->isa_hash = isa_hash;
616 vt_clone->whoami = CONST_STRING_GEN(interp, "$classname");
617 vt_clone->provides_str = CONST_STRING_GEN(interp, "$provides");
619 /* set up isa hash */
620 parrot_new_hash(interp, &isa_hash);
621 vt_clone->isa_hash = isa_hash;
625 for my $k ( keys %extra_vt ) {
627 vt_${k}_clone->base_type = entry;
628 vt_${k}_clone->whoami = vt_clone->whoami;
629 vt_${k}_clone->provides_str = vt_clone->provides_str;
633 if ( $extra_vt{ro
} ) {
635 vt_clone->ro_variant_vtable = vt_ro_clone;
636 vt_ro_clone->ro_variant_vtable = vt_clone;
637 vt_ro_clone->isa_hash = isa_hash;
642 interp->vtables[entry] = vt_clone;
645 for my $isa ($classname, @isa) {
647 parrot_hash_put(interp, isa_hash, (void *)(CONST_STRING_GEN(interp, "$isa")), PMCNULL);
656 # To make use of the .HLL directive, register any mapping...
657 if ( $self->{flags
}{hll
} && $self->{flags
}{maps
} ) {
659 my $hll = $self->{flags
}{hll
};
663 /* Register this PMC as a HLL mapping */
664 const INTVAL pmc_id = Parrot_get_HLL_id( interp, CONST_STRING_GEN(interp, "$hll")
668 foreach my $maps ( sort keys %{ $self->{flags
}{maps
} } ) {
670 Parrot_register_HLL_type( interp, pmc_id, enum_class_$maps, entry);
681 PMC *mro = pmc_new(interp, enum_class_ResizableStringArray);
682 VTABLE * const vt_clone = interp->vtables[entry];
686 if (vt_clone->ro_variant_vtable)
687 vt_clone->ro_variant_vtable->mro = mro;
691 for my $isa ($classname, @isa) {
693 VTABLE_push_string(interp, mro, CONST_STRING_GEN(interp, "$isa"));
700 /* setup MRO and _namespace */
701 Parrot_create_mro(interp, entry);
704 # declare each nci method for this class
705 foreach my $method ( @
{ $self->{methods
} } ) {
706 next unless $method->type eq Parrot
::Pmc2c
::Method
::NON_VTABLE
;
708 my $proto = proto
( $method->return_type, $method->parameters );
709 my $method_name = $method->name;
711 defined $method->symbol ?
$method->symbol : $method->name;
713 if ( exists $method->{PCCMETHOD
} ) {
715 register_raw_nci_method_in_ns(interp, entry,
716 F2DPTR(Parrot_${classname}_${method_name}), "$symbol_name");
721 register_nci_method(interp, entry,
722 F2DPTR(Parrot_${classname}_${method_name}), "$symbol_name", "$proto");
725 if ( $method->{attrs
}{write} ) {
727 Parrot_mark_method_writes(interp, entry, "$symbol_name");
732 # include any class specific init code from the .pmc file
733 $cout .= <<"EOC" if $class_init_code;
744 # declare auxiliary variables for dyncpmc IDs
745 foreach my $dynpmc (@
$dyn_mmds) {
746 next if $dynpmc eq $classname;
748 const int my_enum_class_$dynpmc = pmc_type(interp, string_from_literal(interp, "$dynpmc"));
752 # init MMD "right" slots with the dynpmc types
753 foreach my $entry (@
$init_mmds) {
754 if ( $entry->[1] eq $classname ) {
756 _temp_mmd_init[$entry->[0]].right = entry;
761 _temp_mmd_init[$entry->[0]].right = my_enum_class_$entry->[1];
767 foreach my $dynpmc (@
$dyn_mmds) {
768 next if $dynpmc eq $classname;
770 PARROT_ASSERT(my_enum_class_$dynpmc != enum_class_default);
776 #define N_MMD_INIT (sizeof(_temp_mmd_init)/sizeof(_temp_mmd_init[0]))
777 Parrot_mmd_register_table(interp, entry,
778 _temp_mmd_init, N_MMD_INIT);
785 } /* Parrot_${classname}_class_init */
787 if ( $self->is_dynamic ) {
788 $cout .= dynext_load_code
( $classname, $classname => {} );
794 sub is_vtable_method
{
795 my ( $self, $vt_method_name ) = @_;
796 return 1 if $self->vtable->has_method($vt_method_name);
801 my ( $self, $value ) = @_;
802 $self->{vtable
} = $value if $value;
803 return $self->{vtable
};
810 # cperl-indent-level: 4
813 # vim: expandtab shiftwidth=4: