Mercurial > hg > Gears > Gears

changeset 716:284fa7d7326e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
automatic generation of constructors at stub creation
author anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Tue, 01 Sep 2020 15:56:55 +0900
parents fd9b9fa4ec98
children 1595fc808041
files src/parallel_execution/generate_stub.pl src/parallel_execution/lib/Gears/Interface.pm src/parallel_execution/lib/Gears/Stub.pm src/parallel_execution/lib/Gears/Stub/GenerateConstructor.pm src/parallel_execution/lib/Gears/Stub/GenerateDataGear.pm src/parallel_execution/perlTests/Interface.t src/parallel_execution/tools/trans_impl.pl
diffstat 7 files changed, 149 insertions(+), 115 deletions(-) [+]
line wrap: on
line diff
--- a/src/parallel_execution/generate_stub.pl	Fri Aug 28 16:43:39 2020 +0900
+++ b/src/parallel_execution/generate_stub.pl	Tue Sep 01 15:56:55 2020 +0900
@@ -11,6 +11,7 @@
 
 use Gears::Interface;
 use Gears::Util;
+use Gears::Stub;
 
 # interface.h
 # typedef struct Worker {
@@ -161,22 +162,27 @@
                 $interfaceHeader =~ m|(\w+)\.\w+$|; #remove filename extention
                 my $interfaceName = $1;
                 includeInterface(\%call_interfaces, $filename, $interfaceName, $headerNameToInfo);
-            } elsif(/^#impl "(.*)"/) {
+                # #impl "Stack.h" for "SingleLinkedStack.h"
+            } elsif(/^#impl "(.*?)"(?:\s+for\s+"(.*)")?/) {
                 # use interface
                 my $interfaceHeader = $1;
+                my $implName = $2;
+
                 $interfaceHeader =~ m|(\w+)\.\w+$|; #remove filename extention
                 my $interfaceName = $1;
                 includeInterface(\%call_interfaces, $filename, $interfaceName, $headerNameToInfo);
                 my $interfacePATH = $headerNameToInfo->{$interfaceName}->{path};
 
-                my $implName = basename $filename;
-                $implName =~ s/\.cbc$//;
+                unless ($implName) {
+                  $implName = basename $filename;
+                }
+                $implName =~ s/(\w+)\.\w+$/$1/;
 
                 $implInterfaceInfo->{isImpl} = 1;
                 $implInterfaceInfo->{interface} = $interfaceName;
                 $implInterfaceInfo->{implementation} = $implName;
                 $implInterfaceInfo->{genConstructor} = 1;
-                $implInterfaceInfo->{parsedInterfaceInfo} = Gears::Interface->separate_code_and_data_gear_after_parse($interfacePATH);
+                $implInterfaceInfo->{parsedInterfaceInfo} = Gears::Interface->detailed_parse($interfacePATH);
 
             } elsif (/^\_\_code (\w+)\((.*)\)(.*)/) {
                 my $codeGearName = $1;
@@ -511,7 +517,7 @@
       return undef;
     }
 
-    my $parsedInterface = Gears::Interface->separate_code_and_data_gear_after_parse($interfacePATH);
+    my $parsedInterface = Gears::Interface->detailed_parse($interfacePATH);
 
     unless ($parsedInterface) {
       return undef;
@@ -568,6 +574,22 @@
             } elsif (/^int main\((.*)\) \{/) {
                 $inMain = 1;
             } elsif(/^#impl "(.*)"/) {
+              next unless ($implInterfaceInfo->{genConstructor});
+
+              my $constructInterface = {
+                                         name => $implInterfaceInfo->{interface},
+                                         path => $headerNameToInfo->{$implInterfaceInfo->{interface}}->{path}
+                                       };
+
+              my $constructImpl      = {
+                                        name => $implInterfaceInfo->{implementation},
+                                         path => $headerNameToInfo->{$implInterfaceInfo->{implementation}}->{path}
+                                       };
+
+              unless ($constructImpl->{path}) {
+                warn "[WARN] Not found $constructImpl->{name}.h";
+              }
+              print $fd Gears::Stub->generate_constructor($constructInterface, $constructImpl);
               next;
             } elsif(/^#interface "(.*)"/) {
                 my $interfaceHeader = $1;
--- a/src/parallel_execution/lib/Gears/Interface.pm	Fri Aug 28 16:43:39 2020 +0900
+++ b/src/parallel_execution/lib/Gears/Interface.pm	Tue Sep 01 15:56:55 2020 +0900
@@ -103,7 +103,8 @@
   return $ir;
 }
 
-sub separate_code_and_data_gear_after_parse {
+# separate_code_and_data_gear_after_parse
+sub detailed_parse {
   my ($class, $file)  = @_;
   my $ir = Gears::Interface->parse($file);
 
--- a/src/parallel_execution/lib/Gears/Stub.pm	Fri Aug 28 16:43:39 2020 +0900
+++ b/src/parallel_execution/lib/Gears/Stub.pm	Tue Sep 01 15:56:55 2020 +0900
@@ -1,39 +1,107 @@
 package Gears::Stub;
 use strict;
 use warnings;
+
 use Carp qw/croak/;
-use File::Find;
-use Gears::Util;
+
+use Gears::Interface;
+
+sub generate_constructor {
+  my ($class, $interface_info, $impl_info) = @_;
 
-use DDP {deparse => 1};
+  my $interface_name = $interface_info->{name};
+  my $impl_name      = $impl_info->{name};
+
+  my $interface_ir = Gears::Interface->detailed_parse($interface_info->{path});
+  my $impl_ir  = Gears::Interface->detailed_parse($impl_info->{path});
+
+  my $interface_var_name = shift @{$interface_ir->{data}};
 
-sub new {
-  my ($class, %args) = @_;
+  if ($interface_var_name =~ /union\s*Data\*\s*(\w+)/) {
+    $interface_var_name = $1;
+  }
+
+  my $impl_var_name  = _decamelize($impl_ir->{name});
+
+
+  my @interface_data = @{$interface_ir->{data}};
+  my @impl_data      = @{$impl_ir->{data}};
 
-  my $self = {};
-  $self->{file_name} = $args{file_name} || croak 'invalid file_name!'; 
+  my $constructor;
 
-  return bless $self, $class;
-}
+  $constructor .=  <<"EOF";
+$impl_ir->{isa}* create$impl_ir->{name}(struct Context* context) {
+    struct $impl_ir->{isa}* $interface_name  = new $impl_ir->{isa}();
+    struct $impl_ir->{name}* $impl_name = new $impl_ir->{name}();
+    $interface_name->$interface_name = (union Data*)$impl_name;
+EOF
+
+  $constructor .= _generate_variable_initialization($interface_ir->{data}, $interface_var_name);
+  $constructor .= _generate_variable_initialization($impl_ir->{data},      $impl_var_name);
 
 
 
-sub findInterfacewImpl {
-  my $self     = shift;
-  my $cbc_file = shift // $self->{file_name};
-  my $findInterfaces = Gears::Util->extraction_dg_compile_sources([$cbc_file]);
-  my $edgcs = Gears::Util->extraction_dg_compile_sources([$cbc_file]);
-  my $findInterfaces = {};
+  for my $code (@{$impl_ir->{codes}}) {
+      my $code_gear = $code->{name};
+      next if $code_gear eq 'next';
+      $constructor .= "    ${impl_name}->$code_gear = C_$code_gear;\n"
+  }
 
-  my %ifs = ();
-  map { $ifs{$_}++ } keys %{$edgcs->{interfaces}};
-  delete $ifs{Meta};
-  delete $ifs{TaskManager};
+  for my $code (@{$interface_ir->{codes}}) {
+      my $code_gear = $code->{name};
+      next if $code_gear eq 'next';
+      $constructor .= "    ${interface_name}->$code_gear = C_${code_gear}$impl_ir->{name};\n"
+  }
 
-  push(@{$findInterfaces->{interfaces}}, keys %ifs);
-  push(@{$findInterfaces->{impls}}, keys %{$edgcs->{impl}});
+  $constructor .= "    return $interface_name;\n";
+  $constructor .= "}\n";
 
-  return $findInterfaces;
+  return $constructor;
 }
 
+sub _generate_variable_initialization {
+  my ($data, $varTypeName) = @_;
+  my @generate_lines;
+  for my $datum (@$data) {
+        $datum =~ s|//[\s\w]+||;
+        if ($datum =~ /^\s+#/) {
+          next;
+        }
+
+        if ($datum =~ /\w+\s\w+\*\s(\w+)/) {
+           push(@generate_lines, "    ${varTypeName}->$1 = NULL;\n");
+            next;
+        }
+        if ($datum =~ /\w+\s\w+\s(\w+)/) {
+            push(@generate_lines, "    ${varTypeName}->$1 = 0;\n");
+        }
+
+        if ($datum =~ /\w+(\*)?\s(\w+)/) {
+            my $is_pointer = $1;
+            my $name = $2;
+            if ($is_pointer) {
+                push(@generate_lines, "    ${varTypeName}->$name = NULL;\n");
+            } else {
+                push(@generate_lines, "    ${varTypeName}->$name  = 0;\n");
+            }
+        }
+  }
+
+  return join '', @generate_lines;
+}
+
+#https://metacpan.org/pod/String::CamelCase
+sub _decamelize {
+  my $s = shift;
+  $s =~ s{([^a-zA-Z]?)([A-Z]*)([A-Z])([a-z]?)}{
+          my $fc = pos($s)==0;
+          my ($p0,$p1,$p2,$p3) = ($1,lc$2,lc$3,$4);
+          my $t = $p0 || $fc ? $p0 : '_';
+          $t .= $p3 ? $p1 ? "${p1}_$p2$p3" : "$p2$p3" : "$p1$p2";
+          $t;
+  }ge;
+  $s;
+}
+
+
 1;
--- a/src/parallel_execution/lib/Gears/Stub/GenerateConstructor.pm	Fri Aug 28 16:43:39 2020 +0900
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,68 +0,0 @@
-package Gears::Stub::GenerateConstructor;
-
-use strict;
-use warnings;
-
-use Gears::Util;
-
-sub generate {
-  my ($out, $impl, $interface) = @_;
-
-  my $impl_ir = $impl->{ir};
-  my $inter_ir = $interface->{ir};
-  my $impl_var_name = $impl->{var_name};
-  my $interface_var_name = $interface->{var_name};
-
-  my @inter_data     = @{$inter_ir->{data}};
-  my @impl_data      = @{$impl_ir->{data}};
-
-  print $out <<"EOF";
-$impl_ir->{isa}* create$impl_ir->{name}(struct Context* context) {
-    struct $impl_ir->{isa}* $interface_var_name  = new $impl_ir->{isa}();
-    struct $impl_ir->{name}* $impl_var_name = new $impl_ir->{name}();
-    $interface_var_name->$interface_var_name = (union Data*)$impl_var_name;
-EOF
-
-  for my $datum (@impl_data) {
-        $datum =~ s|//[\s\w]+||;
-        if ($datum =~ /^\s+#/) {
-          next;
-        }
-
-        if ($datum =~ /\w+\s\w+\*\s(\w+)/) {
-            print $out "    ${impl_var_name}->$1 = NULL;\n";
-            next;
-        }
-        if ($datum =~ /\w+\s\w+\s(\w+)/) {
-            print $out "    ${impl_var_name}->$1 = 0;\n";
-        }
-
-        if ($datum =~ /\w+(\*)?\s(\w+)/) {
-            my $is_pointer = $1;
-            my $var_name = $2;
-            if ($1) {
-                print $out "    ${impl_var_name}->$var_name = NULL;\n";
-            } else {
-                print $out "    ${impl_var_name}->$var_name  = 0;\n";
-            }
-        }
-  }
-
-
-  for my $code (@{$impl_ir->{codes}}) {
-      my $code_gear = $code->{name};
-      next if $code_gear eq 'next';
-      print $out "    ${impl_var_name}->$code_gear = C_$code_gear;\n"
-  }
-
-  for my $code (@{$inter_ir->{codes}}) {
-      my $code_gear = $code->{name};
-      next if $code_gear eq 'next';
-      print $out "    ${interface_var_name}->$code_gear = C_${code_gear}_$impl_ir->{name};\n"
-  }
-
-print $out "    return $interface_var_name;\n";
-print $out "}\n";
-}
-
-1;
--- a/src/parallel_execution/lib/Gears/Stub/GenerateDataGear.pm	Fri Aug 28 16:43:39 2020 +0900
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-package Gears::Stub::GenerateDataGear;
-use strict;
-use warnings;
-
-
-sub new {
-  my ($class, %args) = @_;
-  my $self = {};
-
-  return bless $self, $class;
-}
-
-
-1;
--- a/src/parallel_execution/perlTests/Interface.t	Fri Aug 28 16:43:39 2020 +0900
+++ b/src/parallel_execution/perlTests/Interface.t	Tue Sep 01 15:56:55 2020 +0900
@@ -46,7 +46,7 @@
 };
 
 
-subtest 'separate_code_and_data_gear_after_parse' => sub {
+subtest 'detailed_parse' => sub {
   subtest 'Queue' => sub {
     plan tests => 1;
 
@@ -102,7 +102,7 @@
                                }
           };
 
-          my $have = Gears::Interface->separate_code_and_data_gear_after_parse($queue_header);
+          my $have = Gears::Interface->detailed_parse($queue_header);
 
           is_deeply ($have, $want, "parsing Queue.h")  || diag explain $have;
       };
@@ -189,7 +189,7 @@
                     ],
           'name' => 'Stack'
         };
-            my $have = Gears::Interface->separate_code_and_data_gear_after_parse($stack_header);
+            my $have = Gears::Interface->detailed_parse($stack_header);
 
             is_deeply ($have, $want, "parsing Stack.h")  || diag explain $have;
     };
--- a/src/parallel_execution/tools/trans_impl.pl	Fri Aug 28 16:43:39 2020 +0900
+++ b/src/parallel_execution/tools/trans_impl.pl	Tue Sep 01 15:56:55 2020 +0900
@@ -19,10 +19,10 @@
     die "require header file";
 }
 
-my $impl_ir         = Gears::Interface->separate_code_and_data_gear_after_parse(File::Spec->rel2abs($impl_file));
+my $impl_ir         = Gears::Interface->detailed_parse(File::Spec->rel2abs($impl_file));
 my $interface_file  = find_using_interface_header($impl_ir->{isa},"$FindBin::Bin/..");
 
-my $inter_ir        = Gears::Interface->separate_code_and_data_gear_after_parse($interface_file);
+my $inter_ir        = Gears::Interface->detailed_parse($interface_file);
 
 my $interface_var_name = shift @{$inter_ir->{data}};
 
@@ -127,6 +127,31 @@
   }
 
 
+  for my $datum (@inter_data) {
+        $datum =~ s|//[\s\w]+||;
+        if ($datum =~ /^\s+#/) {
+          next;
+        }
+
+        if ($datum =~ /\w+\s\w+\*\s(\w+)/) {
+            print $out "    ${interface_var_name}->$1 = NULL;\n";
+            next;
+        }
+        if ($datum =~ /\w+\s\w+\s(\w+)/) {
+            print $out "    ${interface_var_name}->$1 = 0;\n";
+        }
+
+        if ($datum =~ /\w+(\*)?\s(\w+)/) {
+            my $is_pointer = $1;
+            my $var_name = $2;
+            if ($1) {
+                print $out "    ${interface_var_name}->$var_name = NULL;\n";
+            } else {
+                print $out "    ${interface_var_name}->$var_name  = 0;\n";
+            }
+        }
+  }
+
   for my $code (@{$impl_ir->{codes}}) {
       my $code_gear = $code->{name};
       next if $code_gear eq 'next';