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.8 by root, Thu Apr 19 14:34:56 2012 UTC

… …
12 context Context 12 context Context
13 event Event 13 event Event
14 profiling Event 14 profiling Event
15 mem Memory 15 mem Memory
16 image Image 16 image Image
17 gl_texture Image
17 sampler Sampler 18 sampler Sampler
18 program Program 19 program Program
19 program_build Program 20 program_build Program
20 kernel Kernel 21 kernel Kernel
21 kernel_work_group Kernel 22 kernel_work_group Kernel
… …
76 } 77 }
77 78
78 rename "$file~", $file; 79 rename "$file~", $file;
79} 80}
80 81
81for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) { 82for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling gl_texture)) {
82 open my $fh, "<getinfo.txt" 83 open my $fh, "<getinfo.txt"
83 or die "getinfo.txt: $!"; 84 or die "getinfo.txt: $!";
84 85
85 my $XS;
86 my $POD; 86 my $POD;
87 my @funcs;
88 my %alias;
87 89
88 while (<$fh>) { 90 while (<$fh>) {
89 chomp; 91 chomp;
90 my ($class, $name, $ctype) = split /,\s*/, $_, 3; 92 my ($class, $name, $ctype) = split /,\s*/, $_, 3;
91 next unless $class eq "cl_$CLASS\_info"; 93 next unless $class eq "cl_$CLASS\_info";
… …
95 $ctype =~ s/cl:://g; 97 $ctype =~ s/cl:://g;
96 $ctype =~ s/::size_t/size_t/g; 98 $ctype =~ s/::size_t/size_t/g;
97 99
98 my $cbase = $class; 100 my $cbase = $class;
99 $cbase =~ s/_(.)/\U$1/g; 101 $cbase =~ s/_(.)/\U$1/g;
102 $cbase =~ s/_Gl_/_GL/g;
100 $cbase =~ s/^cl//; 103 $cbase =~ s/^cl//;
101 $cbase =~ s/Info$//; 104 $cbase =~ s/Info$//;
102 $cbase = "MemObject" if $cbase eq "Mem"; 105 $cbase = "MemObject" if $cbase eq "Mem";
103 $cbase = "EventProfiling" if $cbase eq "Profiling"; 106 $cbase = "EventProfiling" if $cbase eq "Profiling";
104 107
… …
153 $perltype = "\$$perltype"; 156 $perltype = "\$$perltype";
154 } 157 }
155 158
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"; 159 $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 160
161 # XS1 contains the function before ALIAS, XS2 the function afterwards (the body)
162 # after we generate the bdoy we look for an identical body generated earlier
163 # and simply alias us to the earlier xs function, to save text size.
164 my ($XS1, $XS2);
165
158 $XS .= "void\n" 166 $XS1 = "void\n"
159 . "$perl_name (OpenCL::$classmap{$real_class} this$extra_xs_args)\n" 167 . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
160 . " PPCODE:\n"; 168 $XS2 = " PPCODE:\n";
161 169
162 if ($dynamic) { 170 if ($dynamic) {
163 $XS .= " size_t size;\n" 171 $XS2 .= " size_t size;\n"
164 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, 0, 0, &size));\n" 172 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n"
165 . " $type->[0] *value = tmpbuf (size);\n" 173 . " $type->[0] *value = tmpbuf (size);\n"
166 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, size, value, 0));\n"; 174 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n";
167 } else { 175 } else {
168 $XS .= " $type->[0] value [1];\n" 176 $XS2 .= " $type->[0] value [1];\n"
169 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, sizeof (value), value, 0));\n"; 177 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
170 } 178 }
171 179
172 if ($array) { 180 if ($array && $nelem ne "1") {
173 $XS .= " int i, n = $nelem;\n" 181 $XS2 .= " int i, n = $nelem;\n"
174 . " EXTEND (SP, n);\n" 182 . " EXTEND (SP, n);\n"
175 . " for (i = 0; i < n; ++i)\n"; 183 . " for (i = 0; i < n; ++i)\n";
176 } else { 184 } else {
177 $XS .= " EXTEND (SP, 1);\n" 185 $XS2 .= " EXTEND (SP, 1);\n"
178 . " const int i = 0;\n" 186 . " const int i = 0;\n"
179 } 187 }
180 188
181 if ($type->[1] =~ /^OpenCL::(\S+)$/) { 189 if ($type->[1] =~ /^OpenCL::(\S+)$/) {
182 my $oclass = $1; 190 my $oclass = $1;
183 $oclass = "MemObject" if $oclass eq "Memory"; 191 $oclass = "MemObject" if $oclass eq "Memory";
184 $oclass = "CommandQueue" if $oclass eq "Queue"; 192 $oclass = "CommandQueue" if $oclass eq "Queue";
185 193
186 $XS .= " {\n"; 194 $XS2 .= " {\n";
187 $XS .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device"; 195 $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"; 196 $XS2 .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n";
189 $XS .= " }\n"; 197 $XS2 .= " }\n";
190 } else { 198 } else {
191 $XS .= " PUSHs (sv_2mortal ($type->[1]));\n"; 199 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
192 } 200 }
193 201
194 $XS .= "\n"; 202 $XS2 .= "\n";
203
204 if (my $alias = $alias{"$XS1$XS2"}) {
205 push @$alias, [$perl_name, $name];
206 } else {
207 push @funcs, [$XS1, (my $alias = [[$perl_name, $name]]), $XS2];
208 $alias{"$XS1$XS2"} = $alias;
209 }
195 } 210 }
211
212 my $XS;
213
214 # this very dirty and ugly code is a very dirty and ugly code size optimisation.
215 for (@funcs) {
216 $_->[0] =~s /^XXXNAMEXXX/$_->[1][0][0]/m;
217
218 if (@{ $_->[1] } == 1) { # undo ALIAS
219 $_->[2] =~ s/\bix\b/$_->[1][0][1]/g;
220 $_->[1] = "";
221 } else {
222 $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] };
223 }
224 $XS .= join "", @$_;
225 }
226
227 warn "patching class $CLASS\n";
196 228
197 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS; 229 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS;
198 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD; 230 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
199} 231}
200 232

Diff Legend

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