ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/OpenCL/gengetinfo
(Generate patch)

Comparing OpenCL/gengetinfo (file contents):
Revision 1.4 by root, Sun Nov 20 22:31:48 2011 UTC vs.
Revision 1.5 by root, Tue Nov 22 10:29:18 2011 UTC

… …
80 80
81for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) { 81for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) {
82 open my $fh, "<getinfo.txt" 82 open my $fh, "<getinfo.txt"
83 or die "getinfo.txt: $!"; 83 or die "getinfo.txt: $!";
84 84
85 my $XS;
86 my $POD; 85 my $POD;
86 my @funcs;
87 my %alias;
87 88
88 while (<$fh>) { 89 while (<$fh>) {
89 chomp; 90 chomp;
90 my ($class, $name, $ctype) = split /,\s*/, $_, 3; 91 my ($class, $name, $ctype) = split /,\s*/, $_, 3;
91 next unless $class eq "cl_$CLASS\_info"; 92 next unless $class eq "cl_$CLASS\_info";
… …
153 $perltype = "\$$perltype"; 154 $perltype = "\$$perltype";
154 } 155 }
155 156
156 $POD .= "=item $perltype = \$$real_class->$perl_name$extra_perl_args\n\nCalls C<clGet${cbase}Info> with C<$name> and returns the result.\n\n"; 157 $POD .= "=item $perltype = \$$real_class->$perl_name$extra_perl_args\n\nCalls C<clGet${cbase}Info> with C<$name> and returns the result.\n\n";
157 158
159 # XS1 contains the function before ALIAS, XS2 the function afterwards (the body)
160 # after we generate the bdoy we look for an identical body generated earlier
161 # and simply alias us to the earlier xs function, to save text size.
162 my ($XS1, $XS2);
163
158 $XS .= "void\n" 164 $XS1 = "void\n"
159 . "$perl_name (OpenCL::$classmap{$real_class} this$extra_xs_args)\n" 165 . "XXXNAMEXXX (OpenCL::$classmap{$real_class} this$extra_xs_args)\n";
160 . " PPCODE:\n"; 166 $XS2 = " PPCODE:\n";
161 167
162 if ($dynamic) { 168 if ($dynamic) {
163 $XS .= " size_t size;\n" 169 $XS2 .= " size_t size;\n"
164 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, 0, 0, &size));\n" 170 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, ix, 0, 0, &size));\n"
165 . " $type->[0] *value = tmpbuf (size);\n" 171 . " $type->[0] *value = tmpbuf (size);\n"
166 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, size, value, 0));\n"; 172 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, ix, size, value, 0));\n";
167 } else { 173 } else {
168 $XS .= " $type->[0] value [1];\n" 174 $XS2 .= " $type->[0] value [1];\n"
169 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, sizeof (value), value, 0));\n"; 175 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, ix, sizeof (value), value, 0));\n";
170 } 176 }
171 177
172 if ($array) { 178 if ($array && $nelem ne "1") {
173 $XS .= " int i, n = $nelem;\n" 179 $XS2 .= " int i, n = $nelem;\n"
174 . " EXTEND (SP, n);\n" 180 . " EXTEND (SP, n);\n"
175 . " for (i = 0; i < n; ++i)\n"; 181 . " for (i = 0; i < n; ++i)\n";
176 } else { 182 } else {
177 $XS .= " EXTEND (SP, 1);\n" 183 $XS2 .= " EXTEND (SP, 1);\n"
178 . " const int i = 0;\n" 184 . " const int i = 0;\n"
179 } 185 }
180 186
181 if ($type->[1] =~ /^OpenCL::(\S+)$/) { 187 if ($type->[1] =~ /^OpenCL::(\S+)$/) {
182 my $oclass = $1; 188 my $oclass = $1;
183 $oclass = "MemObject" if $oclass eq "Memory"; 189 $oclass = "MemObject" if $oclass eq "Memory";
184 $oclass = "CommandQueue" if $oclass eq "Queue"; 190 $oclass = "CommandQueue" if $oclass eq "Queue";
185 191
186 $XS .= " {\n"; 192 $XS2 .= " {\n";
187 $XS .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device"; 193 $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device";
188 $XS .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n"; 194 $XS2 .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n";
189 $XS .= " }\n"; 195 $XS2 .= " }\n";
190 } else { 196 } else {
191 $XS .= " PUSHs (sv_2mortal ($type->[1]));\n"; 197 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
192 } 198 }
193 199
194 $XS .= "\n"; 200 $XS2 .= "\n";
201
202 if (my $alias = $alias{"$XS1$XS2"}) {
203 push @$alias, [$perl_name, $name];
204 } else {
205 push @funcs, [$XS1, (my $alias = [[$perl_name, $name]]), $XS2];
206 $alias{"$XS1$XS2"} = $alias;
207 }
208 }
209
210 my $XS;
211
212 # this very dirty and ugly code is a very dirty and ugly code size optimisation.
213 for (@funcs) {
214 $_->[0] =~s /^XXXNAMEXXX/$_->[1][0][0]/m;
215
216 if (@{ $_->[1] } == 1) { # undo ALIAS
217 $_->[2] =~ s/\bix\b/$_->[1][0][1]/g;
218 $_->[1] = "";
219 } else {
220 $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] };
221 }
222 $XS .= join "", @$_;
195 } 223 }
196 224
197 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS; 225 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS;
198 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD; 226 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
199} 227}

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines