view src/parallel_execution/lib/Gears/Interface.pm @ 1070:fba66b75a7dc default tip

rollback
author matac42 <matac@cr.ie.u-ryukyu.ac.jp>
date Mon, 05 Feb 2024 01:48:23 +0900
parents 15db95806d4e
children
line wrap: on
line source

package Gears::Interface;
use strict;
use warnings;
use Carp qw/croak cluck confess/;
use File::Basename qw/dirname/;
use File::Spec;

use Gears::Util;
#use DDP {deparse => 1};

sub parse {
    # create this data structure
  my ($class, $file) = @_;
  my $ir  = {};
  $ir->{file_name} = $file // confess "require file";

  return undef unless (Gears::Util->file_checking($file));

  open my $fh, '<', $file;
  my $line = <$fh>;
  my $static_data_gear_write_mode = 0;

  my $dir_name = dirname(File::Spec->rel2abs($file));

  while ($line =~ /#include\s+"([\w\/\.]+)"/) {
    my $header_file = $1;
    if ($header_file =~ m|\./context\.h|) {
      $line = <$fh>;
      next;
    }
    push(@{$ir->{cbc_context_include_headers}}, "$dir_name/$header_file");
    $line = <$fh>;
  }

  # skip space

  while ($line =~ /^\s*$/) {
    $line = <$fh>;
  }

  my $typed_variable = {};

  if ($line =~ /typedef struct (\w+)\s?<(.*)>([\s\w{]+)/) {
    my $vname            = $1;
    my $v_typed_variable = $2;
    my $annotation       = $3;

    unless ($vname) {
      cluck "[WARN] invalied struct name from $file";
      return undef;
    }
    $ir->{name}    = $vname;

    if ($v_typed_variable) {
      $typed_variable = parse_header_typed_variable($v_typed_variable);
      $ir->{typed_variable_order} = $typed_variable->{__order};
    }

    if ($annotation =~ m|\s*impl\s*([\w+]+)\s*{|) {
      $ir->{isa} = $1;
    }
  }

  return undef unless ($ir->{name});

  my @data_gears;
  my %inner_code_gears;

  while ($line = <$fh>) {
    chomp $line;
    if ($line =~ m|\s*/\*|) {
      while ( $line !~ m|\*/|) {
        $line = <$fh>;
        next;
      }
      next;
    }
    next if ($line =~ /^\s+$/);
    next if ($line =~ m[^\s*//]);
    next if ($line =~ m[^\}\s*$ir->{name};]);

    if ($line =~ m|__code (\w+)|) {

      push(@data_gears,"enum Code $1;"); #this case insert __code name (__code hoge -> enum Code hoge;)

      #In the case of writing field variables one line at a time, cancel the following
      next if $static_data_gear_write_mode;


      my $args = $';
      #$args eq  (Impl* vm, pde_t* pgdir, char* init, uint sz, __code next(...));
      while ($args =~ /\s*(struct|union|const|enum)?\s*([<>\w\[\]_]+)(\*)?\s*(\w+)?,?/g) {
        my $const_type = $1;
        my $type       = $2;
        my $pointer    = $3 // "";
        my $vname      = $4;

        if ($type eq '__code') {
          $inner_code_gears{$vname} = 1; #collect inner code gears (ex. next, whenEmpty)
          next;
        }
        next unless $vname; # __code hoge(int ret, __code next(ret, ...); this is second "ret" case
        $type =~ s/^(?:Impl|Type|Isa)\s*(\*)?/union Data/;

        my $val = "$type$pointer $vname;";

        parse_generics($val);

        my $generics_info;
        if ($typed_variable) {
          ($val, $generics_info)  = check_use_typed_variable($ir->{name},$typed_variable, $val); #define typed variable
          if (defined $generics_info->{type}){
             unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{typed_variable}}) {
              push(@{$ir->{typed_variable}},$generics_info);
              push(@{$ir->{typed_variable_types}->{$generics_info->{type}}}, $generics_info->{vname});
            }
          }
        }

        $generics_info = {};
        ($val, $generics_info)  = check_use_instance_generics_type($val); #define instance generics variable
        if (defined $generics_info->{type}){
           unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{generics}}) {
              push(@{$ir->{generics}},$generics_info);
            }
        }

        push(@data_gears, $const_type ?  "$const_type $val" : $val);
      }
      next;
    }

    #this is a case of writing field variables one line at a time
    $line =~ s/^\s+//;
    parse_generics($line);

    my $generics_info;
    if ($typed_variable && keys(%$typed_variable)) {
      ($line, $generics_info)  = check_use_typed_variable($ir->{name},$typed_variable, $line); #define typed variable
      if (defined $generics_info->{type}){
        unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{typed_variable}}) {
          push(@{$ir->{typed_variable}},$generics_info);
          push(@{$ir->{typed_variable_types}->{$generics_info->{type}}}, $generics_info->{vname});
        }
      }
    }
    $generics_info = {};
    ($line, $generics_info)  = check_use_instance_generics_type($line); #define typed variable
    if (defined $generics_info->{type}){
      unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{generics}}) {
        push(@{$ir->{generics}},$generics_info);
      }
    }
    push(@data_gears,$line);
    $static_data_gear_write_mode = 1;
  }

  $ir->{inner_code_gears} = \%inner_code_gears;
  push(@{$ir->{content}}, Gears::Util->uniq(@data_gears));
  return $ir;
}

# separate_code_and_data_gear_after_parse
sub detailed_parse {
  my ($class, $file)  = @_;
  my $ir = Gears::Interface->parse($file);

  return undef unless ($ir);

  $ir->{hasOutputArgs} = {};

  my @data_gears;
  my @code_gears;

  for my $dg (@{$ir->{content}}) {
    if ($dg =~ /enum Code (\w+);/) {
      push(@code_gears, $1);
    } else {
      push(@data_gears, $dg);
    }
  }

  open my $fh , '<', $file;
  my $i = 0;
  my @have_output_data;
  my @inner_code_gears;

  my @output_code_gears;

  while (($i < scalar @code_gears) && (my $line = <$fh>)) {
      my $codeGearName = $code_gears[$i];

      if (exists $ir->{inner_code_gears}->{$codeGearName}) {
        $i++;
        next;
      }

      if ($line =~ m|__code $codeGearName\(([()\.\*\s\w,_]+)\)|) {
        my $arg = $1;

        # check individual argument
        # eg. (Impl* self, Int a, char* b, struct hoge* h, __code next(out* o, out* o2, ...))
        # indivisual argument is  self, a, b, h, next  ( $argc == 5)
        my @comma_split_arg = split /,/, $arg;
        my $inParen         = undef;
        my $argc            = 0;
        for my $tmpArg (@comma_split_arg) {
          #ignore inner code gear (eg next)
          if ($tmpArg =~ /\(/ ) {
            $inParen = 1;
          }

          # want to __code next(...) <- right paren
          if ($tmpArg =~ /\)/) {
            $inParen = undef;
          }

          next if ($inParen);
          $argc++;
        }
        #ignore self
        # ex upper case, before $argc == 5, after $argc == 4
        if (@comma_split_arg) {
          $argc-- if ($comma_split_arg[0] =~ /Impl/);
        }
        my $element = { name => $codeGearName, args => $arg, argc => $argc };
        push(@output_code_gears, $element);

        #code gear name to hash
        $ir->{codeName}->{$codeGearName} = $element;

        # args  eq "Impl* stack, __code next(Type* data, Type* data1, ...)",
        if ($arg =~ /__code \w+\((.+),\s*\.\.\.\s*\)/) {
          my $outputArgs = $1;
          while ($outputArgs =~ /(struct|union|const|enum)?\s*([\w*]+)\s(\w+),?/g) {
            my $structType = $1;
            my $ttype      = $2;
            my $tname      = $3;
            $ir->{hasOutputArgs}->{$codeGearName}->{$tname} = $ttype;
          }
        }
        $i++;
      }
  }


  $ir->{codes} = \@output_code_gears;
  $ir->{data}  = \@data_gears;
  return $ir;
}


sub isThisFileInterface {
  my ($class, $filename) = @_;

  open my $fh, '<', $filename;
  my $line = <$fh>; #read top line  ex Typedef struct Stack<Type, Impl> {

  return 0 unless ($line =~ /typedef struct \w+\s?<.*>([\s\w{]+)/);

  my $annotation = $1;
  return 0 if ($annotation =~ /impl/);

  return 1;
}

sub parse_header_typed_variable {
  #parsed typedef struct Hoge <S, T> {
  my $str = shift;
  my @pair_generics = split /,/, $str;
  my %typed_variable;
  for my $pear (@pair_generics) {
    $pear =~ s/\s*(\w+)/$1/;
    my ($type, $border) = split /:/, $pear;
    confess "failed parsed type at $pear\n" unless $type;
    unless ($border) {
      $border = "_any"; #_any is union Data*
    }
    $typed_variable{$type} = $border;
    push(@{$typed_variable{__order}},$type);
  }
  return \%typed_variable;
}

sub parse_generics {
  my $line = shift;
  return unless ($line =~ /([\w\*]+)\s*<([\w\*]+)>/);
  print "[INFO] use generics $1 $2 at $line\n";
}

sub collect_interfaces_from_all_headers {
  my ($class, $find_path) = @_;
  my $header_files = Gears::Util->find_headers_from_path($find_path);
  my @result       = sort grep { Gears::Interface->isThisFileInterface($_) } @$header_files;
  return \@result;
}

sub check_use_typed_variable {
  my ($caller, $typed_variable, $line) = @_;
  if ($line =~ /(\w+)(\*?)\s+(\w+);?$/) {
    my $type    = $1;
    my $pointer = $2 // '';
    my $vname   = $3;

    my $typed_info = { type => $type, vname => $vname};

    if (exists $typed_variable->{$type}) {
      if ($typed_variable->{$type} eq "_any") {
        #$line = "TYPED_GENERICS_${caller}_$type $pointer $vname;"; #no extend case
      } else {
        #extend case
        #$line = "EXTEND_TYPED_GENERICS_${type}_$typed_variable->{$type}$pointer $vname;"; # <T:Say> -> T_say
         $typed_info->{extends} = $typed_variable->{$type};
      }

      return ($line, $typed_info);
    }
  }
  return ($line, {});
}

sub check_use_instance_generics_type {
 #define typed variable
    my $line = shift;
    my $not_use = {};
    my $use     = {};
    unless ($line =~ /(\w+)<(\w+)>(\*)?\s+(\w+);/) {
      return ($line, $not_use);
    }
    my $type     = $1;
    my $generics = $2;
    my $pointer  = $3;
    my $vname    = $4;

    unless ($pointer) {
      $pointer = "";
    }

    my $upGenerics = ucfirst($generics);
    $use->{type}     = $type;
    $use->{generics} = $generics;
    $use->{vname}    = $vname;
    #return ("INTERFACE_GENERICS_${type}_$upGenerics$pointer $vname;", $use);
    return ("$type$pointer $vname;", $use);
}

1;