view src/parallel_execution/lib/Gears/Context.pm @ 823:64a70e5778a7

parsed argument generics
author anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Mon, 18 Jan 2021 13:34:32 +0900
parents 20fdc6938627
children 2deb394a53a9
line wrap: on
line source

package Gears::Context;

use strict;
use warnings;

use Gears::Util;
use Gears::Interface;

use Module::Load qw/load/;

use Carp qw/croak cluck/;


sub new {
  my ($class, %args) = @_;
  my $self = {
    data_gears_with_count => {},
    find_root             => $args{find_root} // ".",
    output                => $args{output},
    template              => $args{template}  // "Gears::Template::Context",
    generics_list         => {}, #generics_list has two keys, defined_type or type_variable
                                 #type_variable is not defined specific type value
  };

  if ($args{compile_sources}) {
    $self->{compile_sources} = $args{compile_sources};
    for my $file (@{$self->{compile_sources}}) {
      Gears::Util->file_checking($file);
    }
  }

  return bless $self, $class;
}


sub extraction_dg_compile_sources {
  my ($self, $compile_sources) = @_;
  my %counter;
  my %include_pool = ();
  for my $cbc_file (@{$compile_sources}) {
    open my $fh , '<', $cbc_file;
    while (my $line = <$fh>) {
        if ($line =~ m|//\s*:skip|) {
          next;
        }

       if ($line =~ /#interface\s*"(.*)\.h"/) {
          push(@{$counter{interfaces}->{$1}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /^\/\/\s*include\s*"(.*)\.(?:h|dg)?"/) {
          push(@{$include_pool{$1}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ m|//\s*Skip:\s*generate_context|) {
          $line = <$fh>;
          next;
       }


       if ($line =~ /^\s*(\w+)(<(.*)>)?\*\s*create(\w+)\(([<>,*\w\s]+)\)/) {
         #AtomicT<T>* createAtomicT(struct Context* context,T init) {
         # this case defined interface or implement
         # T means typed variables, not implement generics
          my $interface      = $1;
          my $generics       = $3;
          my $implementation = $4;
          my $arg            = $5;
          if ($arg eq "") {
            next;
          }

          if ($arg =~ /</) { #generics in arg
            my @tmpArgs = split /,/, $arg;
            my @genericsArgs = grep { /\w+\s*<\w+>/} @tmpArgs;
            for my $tmpArg (@genericsArgs) {
              #[0] " AtomicT<int> right",
              #[1] " AtomicT<int> left"
              if ($tmpArg =~ /(\w+)<(\w+)>\s*(\w+)/){
                my $tmpType     = $1;
                my $tmpGenerics = $2;
                my $tmpVarName  = $3;

                if ($tmpGenerics eq $generics) { #Test<T>* createTest(Impl test, Hoge<T>) case
                    push(
                      @{$self->{generics_list}->{typed_varible}},
                      { name => $tmpType, typed_variable => $tmpGenerics, caller => $cbc_file, line_number => $.}
                    );
                } else {
                    push(
                      @{$self->{generics_list}->{defined_type}},
                      { name => $tmpType, defined_type => $tmpGenerics, caller => $cbc_file, line_number => $.}
                    );
                }
              }
            }
          }

          push(@{$counter{interfaces}->{$interface}->{$cbc_file}},$.);
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          if ($generics) {
            push(@{$self->{generics_list}->{typed_varible}}, { name => $interface, typed_variable => $generics, caller => $cbc_file, line_number => $.});
          }
          next;
       }


       # 'AtomicT<int> fork0 = setAtomicT(int)';
       #  this case define generics variable ex Integer, Single...
       if ($line =~ /^\s*(\w+)<(.+)>\*?\s*(\w+)\s*=\s*(.+)\(?/) {
         my $interface = $1;
         my $generics  = $2;
         my $method    = $3;

          push(@{$counter{interfaces}->{$interface}->{$cbc_file}},$.);
          push(@{$self->{generics_list}->{defined_type}}, { name => $interface, defined_type => $generics, caller => $cbc_file, line_number => $.});
       }


       if ($line =~ /Gearef\(context,\s*(\w+)\)/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

    # ALLOCATE is generated by generate_stub.pl
    # because extraction_dg_compile_sources caller after translated .cbc to .c
    #Element* element = &ALLOCATE(cbc_context, Element)->Element;
       if ($line =~ /ALLOCATE\w*\((?:cbc_)?context,\s*(\w+)\)/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /ALLOCATE_(?:PTR_)?ARRAY\((?:cbc_)?context,\s*(\w+),[\s\w]+\)/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /new\s+(\w+?)\([\w\s]*\);/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /ALLOCATE_DATA_GEAR\((\w+),\s*(\w+)\)/) {
          my $implementation = $2;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       #TaskManagerImpl* taskManager = (TaskManagerImpl*)GearImpl(context, TaskManager, taskManager);
       if ($line =~ /\((\w+)\*\)GearImpl\(context,\s*(\w+),\s*(\w+)\)/) {
          my $implementation = $1;
          my $interface      = $2;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          push(@{$counter{interfaces}->{$interface}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /^__code/) {
         while ($line =~ /struct (\w+)\s*\*/g) {
           next if $1 eq "Context";
           next if (exists $counter{interfaces}->{$1});
           push(@{$counter{impl}->{$1}->{$cbc_file}},$.);
         }
       }
    }
    close $fh;
  }
  use Data::Dumper;

  for my $cg_name (keys %include_pool) {
    my @tmp_cbc_file_names = keys %{$include_pool{$cg_name}};
    my $tmp_cbc_file_name  = shift @tmp_cbc_file_names;
    if (exists $counter{interfaces}->{$cg_name}){
      push(@{$counter{interfaces}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name});
      delete $include_pool{$cg_name};
      next;
    }

    if (exists $counter{impl}->{$cg_name}){
      push(@{$counter{impl}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name});
      delete $include_pool{$cg_name};
      next;
    }
    push(@{$counter{interfaces}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name});
    delete $include_pool{$cg_name};
  }

  $counter{interfaces}->{Meta}++;
  $counter{interfaces}->{TaskManager}++;
  #print "-----------\n";
  #print Dumper \%counter; #this line is debug message
  #print "-----------\n";
  return \%counter;
}



sub _docking_header_name_to_path {
  my ($root_path, $data_gears_name) = @_;
  my %res;

  for my $dg (@{$data_gears_name}) {
    $res{$dg}++;
  }

  my $header_paths = Gears::Util->find_headers_from_path($root_path);

  for my $headerPATH (sort @$header_paths) {
    next if ($headerPATH !~ /(\w+)\.(?:h|dg)$/);

    my $header = $1;

    next unless (exists $res{$header});

    if ($res{$header} =~ /^\d+$/) {
      $res{$header} = $headerPATH;
      next;
    }

    if (($headerPATH =~ /\.dg/) && ($res{$header} =~ /\.h$/)) {
      $res{$header} = $headerPATH;
    }
  }

  return \%res;
}

sub set_data_gear_header_path {
  my $self = shift;
  my @data_gears_name = grep { $_ ne "Context" } @_;
  return _docking_header_name_to_path($self->{find_root},\@data_gears_name);
}

sub update_dg_each_header_path {
  my ($self, $dgs, $dg2path) = @_;
  my $new_dgs;
  for my $kind (keys %$dgs) {
    for my $dg_name (keys %{$dgs->{$kind}}) {
      # If a header is not found, dg2path contains the number of times the header was used
      if ($dg2path->{$dg_name} && $dg2path->{$dg_name} !~ /^\d+$/) {
        $new_dgs->{$kind}->{$dg_name} = $dg2path->{$dg_name};
      } else {
        cluck "[ERROR] failed trans header $dg_name\n";
      }
    }
  }
  return $new_dgs;
}

sub tree2create_context_h {
  my ($self, $dg2path) = @_;


  croak "require ast at tree2create_context_h" unless ($dg2path);

  my $template = $self->{template};
  load $template;

  my ($data_struct_str, $from_header_to_caller) = $self->tree2data_struct_str($dg2path);

  my $output = $self->_select_output();
  $template->emit_top_header($output);
  if (%{$from_header_to_caller}) {
    $template->emit_include_header($output,$from_header_to_caller);
  }
  $template->emit_start_context($output);
  $template->emit_data_gears($output,$data_struct_str);
  $template->emit_last_header($output);
  close $output;
}

sub _select_output {
  my $self = shift;
  #print "$self->{output}\n";
  if ($self->{output} eq  'stdout') {
    return *STDOUT;
  }
  open my $fh, '>', $self->{output};
  return $fh;
}


# Generate a header with include file list from a structure's tree structure
sub tree2data_struct_str {
  my ($self, $dg_str) = @_;
  my %from_header_to_caller;

  my $data_struct_str  = "";
  for my $interface (sort keys %$dg_str) {
    my $elem = $dg_str->{$interface}->{elem};
    $data_struct_str .= $self->h2context_str_w_macro($elem);

    for my $header (_find_include_header_each_cbc($elem)) {
      push(@{$from_header_to_caller{$header}},$elem->{file_name});
    }

    my $root_impl = $dg_str->{$interface}->{impl};

    next unless ($root_impl);
    for my $impl_name (sort keys %{$root_impl}) {
      my $impl = $root_impl->{$impl_name};
      $data_struct_str .= $self->h2context_str_w_macro($impl);
      for my $header (_find_include_header_each_cbc($impl)) {
        push(@{$from_header_to_caller{$header}},$impl->{file_name});
      }
    }
  }
  return $data_struct_str, \%from_header_to_caller;
}

sub _find_include_header_each_cbc {
  my $ir = shift;
  unless (exists $ir->{cbc_context_include_headers}) {
   return ();
  }
   return @{$ir->{cbc_context_include_headers}};
}

sub createImplTree_from_header {
  my ($self, $dg2path) = @_;
  my %dg_str = ();

  my $inters = $dg2path->{interfaces};
  my $impls = $dg2path->{impl};

  use Data::Dumper;
  #print Dumper $dg2path;
  #print Dumper  $self;

  for my $interface (keys %$inters) {
    my $ir = Gears::Interface->parse($inters->{$interface});
    if ($ir) {
      $dg_str{$interface}->{elem} = $ir;
    }
  }

  for my $impl (keys %$impls) {
    my $ir = Gears::Interface->parse($impls->{$impl});
    next unless ($ir);

    if ($ir->{isa}) {
      $dg_str{$ir->{isa}}->{impl}->{$impl} = $ir;
    } else {
      $dg_str{$impl}->{elem} = $ir;
    }
  }

  return \%dg_str;
}

sub h2context_str_w_macro {
  my ($self, $h2context) = @_;
  my $space = '    ';
  my $context = "${space}//$h2context->{file_name}\n";
  $context .= "#ifndef ". uc($h2context->{name}) ."_STRUCT \n";
  $context .= $self->h2context_str($h2context);
  $context .= "#define ". uc($h2context->{name}) ."_STRUCT \n";
  $context .= "#else\n";
  $context .=  "${space}struct $h2context->{name};\n";
  $context .= "#endif\n";
  return $context;
}

sub h2context_str {
  my ($self, $h2context) = @_;
  my $space = '    ';

  my $context =  "${space}struct $h2context->{name} {\n";
  my $content_space;

  my @enumCodes;
  my @var;

  for my $c (@{$h2context->{content}}) {
    if ($c =~ /\A\s*enum Code/) {
      push(@enumCodes,$c);
    } else  {
      push(@var,$c);
    }
  }

  if (@var){
    my @chars = split //, $var[0];
    for my $w (@chars) {
      last if ($w !~ /\s/);
      $content_space .= $w;
    }
  }

  unless (defined $content_space) {
    $content_space = "";
  }

  for my $c (@var) {
    $c =~ s/$content_space//;
    $context .= "${space}${space}$c";
    $context .= "\n";
  }

  for my $c (@enumCodes) {
    $c =~ s/$content_space//;
    $context .= "${space}${space}$c";
    $context .= "\n";
  }

  $context .= "${space}} $h2context->{name};\n";
  return $context;
}

1;