Mercurial > hg > GearsTemplate

annotate src/parallel_execution/trans_impl.pl @ 560:2276952ed717

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
impl trans_impl.pl
author anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Tue, 19 Nov 2019 13:24:21 +0900
parents 2dc06f944a85
children aa4bef31cbfd
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
555
bcc137ca91da add trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
1 #!/usr/bin/env perl
bcc137ca91da add trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
2 use strict;
bcc137ca91da add trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
3 use warnings;
bcc137ca91da add trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
4
557
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 556
diff changeset
5 use FindBin;
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 556
diff changeset
6 use lib "$FindBin::Bin/lib";
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 556
diff changeset
7 use Gears::Util;
555
bcc137ca91da add trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
8
557
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 556
diff changeset
9 use DDP { deparse => 1};
555
bcc137ca91da add trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
10
557
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 556
diff changeset
11 my $impl_file = shift or die 'require impl file';
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
12 my $impl_ir = Gears::Util->parse_code_verbose($impl_file);
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
13 my $interface_file = Gears::Util->find_header($impl_ir->{isa},"$FindBin::Bin");
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
14
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
15 my $inter_ir = Gears::Util->parse_code_verbose($interface_file);
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
16 my $stdout = *STDOUT;
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
17 emit_include_part($stdout, $inter_ir->{name});
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
18 emit_constracutor($stdout,$impl_ir,$inter_ir);
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
19 emit_code_gears($stdout,$impl_ir,$inter_ir);
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
20 #emit_impl_header_in_comment($stdout, $impl_file);
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
21
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
22 sub emit_include_part {
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
23 my ($out, $interface) = @_;
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
24 print $out <<"EOF"
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
25 #include "../context.h";
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
26 #interface "$interface.h";
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
27
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
28 EOF
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
29 }
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
30
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
31 sub emit_impl_header_in_comment {
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
32 my ($out, $impl_file) = @_;
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
33 my $line = Gears::Util->slup($impl_file);
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
34 print $out "// ----\n";
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
35 map { print $out "// $_\n" } split /\n/, $line;
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
36 print $out "// ----\n";
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
37 }
558
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 557
diff changeset
38
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
39 sub emit_constracutor {
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
40 my ($out, $impl_ir, $inter_ir) = @_;
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
41
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
42 my @inter_data = @{$inter_ir->{data}};
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
43 my $instance_inter = shift @inter_data;
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
44 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) {
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
45 $instance_inter = $1;
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
46 }
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
47 my $instance_impl = lcfirst $impl_ir->{name};
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
48
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
49 print $out <<"EOF";
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
50 $impl_ir->{isa}* create$impl_ir->{name}(struct Context* context) {
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
51 struct $impl_ir->{isa}* $instance_inter = new $impl_ir->{isa}();
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
52 struct $impl_ir->{name}* $instance_impl = new $impl_ir->{name}();
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
53 $instance_inter->$instance_inter = (union Data*)$instance_impl;
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
54 EOF
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
55
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
56 for my $datum (@inter_data) {
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
57 if ($datum =~ /\w+ \w+\* (\w+)/) {
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
58 print $out " ${instance_impl}->$1 = NULL;\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
59 next;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
60 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
61 if ($datum =~ /\w+ \w+ (\w+)/) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
62 print $out " ${instance_impl}->$1 = 0;\n";
559
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
63 }
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
64 }
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
65
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
66 for my $code (@{$inter_ir->{codes}}) {
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
67 my $code_gear = $code->[0];
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
68 print $out " ${instance_inter}->$code_gear = C_$code_gear$impl_ir->{name};\n"
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
69 }
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
70
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
71 print $out " return $instance_inter;\n";
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
72 print $out "}\n";
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
73 }
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 558
diff changeset
74
560
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
75
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
76 sub emit_code_gears {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
77 my ($out, $impl_ir, $inter_ir) = @_;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
78 my $impl = $impl_ir->{name};
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
79
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
80 my @inter_data = @{$inter_ir->{data}};
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
81 my $instance_inter = shift @inter_data;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
82 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
83 $instance_inter = $1;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
84 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
85 my $instance_impl = lcfirst $impl_ir->{name};
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
86 my $data_gear_types = {};
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
87
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
88 for my $code_ir (@{$inter_ir->{codes}}) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
89 my $data_gears = $code_ir->[1];
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
90 $data_gears =~ s/Impl/$impl/g;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
91 while ($data_gears =~ /Type\*\s*(\w+),/) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
92 my $target = $1;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
93 if (exists $data_gear_types->{$target}){
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
94 $data_gears =~ s/Type\*/$data_gear_types->{$target}/;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
95 } else {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
96 my $td = "";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
97 map { $td = $_ if ($_ =~ /$target/) } @inter_data;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
98 if ($td =~ /(\w+)\s*([\w\*]+)\s*(\w+)/) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
99 my $tmp = "$1 $2";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
100 $data_gears =~ s/Type\*/$tmp/;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
101 $data_gear_types->{$target} = $tmp;
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
102 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
103 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
104 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
105
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
106 print $out "__code $code_ir->[0]$impl(";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
107 print $out "$data_gears) {\n\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
108
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
109 #__code next(...), __code whenEmpty(...)
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
110 my @cg = ();
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
111 while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
112 push(@cg, $1);
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
113 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
114
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
115 if (@cg) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
116 if (@cg == 2) {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
117 print $out " if (:TODO:) {\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
118 print $out " goto ",shift(@cg),";\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
119 print $out " }\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
120 print $out " goto ",shift(@cg),";\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
121 } else {
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
122 print $out " goto ",shift(@cg),";\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
123 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
124 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
125 print $out "}\n\n";
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
126 }
2276952ed717 impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents: 559
diff changeset
127 }