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

Comparing OpenCL/gengetinfo (file contents):
Revision 1.3 by root, Sun Nov 20 22:29:36 2011 UTC vs.
Revision 1.16 by root, Fri May 4 14:56:50 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
23 kernel_arg_info Kernel
22 command_queue Queue 24 command_queue Queue
23); 25);
24 26
25my %typemap = ( 27my %typemap = (
26 cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'], 28 cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'],
… …
76 } 78 }
77 79
78 rename "$file~", $file; 80 rename "$file~", $file;
79} 81}
80 82
81for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) { 83for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group kernel_arg event profiling gl_texture)) {
82 open my $fh, "<getinfo.txt" 84 open my $fh, "<getinfo.txt"
83 or die "getinfo.txt: $!"; 85 or die "getinfo.txt: $!";
84 86
85 my $XS;
86 my $POD; 87 my $POD;
88 my @funcs;
89 my %alias;
87 90
88 while (<$fh>) { 91 while (<$fh>) {
89 chomp; 92 chomp;
90 my ($class, $name, $ctype) = split /,\s*/, $_, 3; 93 my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3;
91 next unless $class eq "cl_$CLASS\_info"; 94 next unless $class eq "cl_$CLASS\_info";
92 next if $name eq "CL_IMAGE_FORMAT"; # struct 95 next if $name eq "CL_IMAGE_FORMAT"; # struct
93 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls 96 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls
94 97
95 $ctype =~ s/cl:://g; 98 $ctype =~ s/cl:://g;
96 $ctype =~ s/::size_t/size_t/g; 99 $ctype =~ s/::size_t/size_t/g;
97 100
98 my $cbase = $class; 101 my $cbase = $class;
99 $cbase =~ s/_(.)/\U$1/g; 102 $cbase =~ s/_(.)/\U$1/g;
103 $cbase =~ s/Gl(?=[A-Z])/GL/g;
100 $cbase =~ s/^cl//; 104 $cbase =~ s/^cl//;
101 $cbase =~ s/Info$//; 105 $cbase =~ s/Info$//;
102 $cbase = "MemObject" if $cbase eq "Mem"; 106 $cbase = "MemObject" if $cbase eq "Mem";
103 $cbase = "EventProfiling" if $cbase eq "Profiling"; 107 $cbase = "EventProfiling" if $cbase eq "Profiling";
104 108
105 my $real_class = $CLASS; 109 my $real_class = $CLASS;
106 $real_class = "program" if $real_class eq "program_build"; 110 $real_class = "program" if $real_class eq "program_build";
107 $real_class = "kernel" if $real_class eq "kernel_work_group"; 111 $real_class = "kernel" if $real_class eq "kernel_work_group";
112 $real_class = "kernel" if $real_class eq "kernel_arg";
108 $real_class = "event" if $real_class eq "profiling"; 113 $real_class = "event" if $real_class eq "profiling";
109 114
110 my $perl_name = lc $name; 115 my $perl_name = lc $name;
111 $perl_name =~ s/^cl_//; 116 $perl_name =~ s/^cl_//;
112 $perl_name =~ s/^$real_class\_//; 117 $perl_name =~ s/^$real_class\_//;
… …
118 123
119 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { 124 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") {
120 $extra_args = ', device'; 125 $extra_args = ', device';
121 $extra_perl_args = ' ($device)'; 126 $extra_perl_args = ' ($device)';
122 $extra_xs_args = ', OpenCL::Device device'; 127 $extra_xs_args = ', OpenCL::Device device';
128 }
129
130 if ($CLASS eq "kernel_arg") {
131 $extra_args = ', idx';
132 $extra_perl_args = ' ($idx)';
133 $extra_xs_args = ', cl_uint idx';
123 } 134 }
124 135
125 my $dynamic; 136 my $dynamic;
126 my $nelem = "size / sizeof (*value)"; 137 my $nelem = "size / sizeof (*value)";
127 138
… …
151 $perltype = "\@${perltype}s"; 162 $perltype = "\@${perltype}s";
152 } else { 163 } else {
153 $perltype = "\$$perltype"; 164 $perltype = "\$$perltype";
154 } 165 }
155 166
167 (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die;
168
156 $POD .= "=item $perltype = \$$real_class->$perl_name$extra_perl_args\n\nCalls C<clGet${cbase}Info> with C<$name> and returns the result(s).\n\n"; 169 $POD .= "=item $perltype = \$$real_class->$perl_name$extra_perl_args\n\nCalls C<clGet${cbase}Info> with C<$perlenum> and returns the result.\n\n";
157 170
171 # XS1 contains the function before ALIAS, XS2 the function afterwards (the body)
172 # after we generate the bdoy we look for an identical body generated earlier
173 # and simply alias us to the earlier xs function, to save text size.
174 my ($XS1, $XS2);
175
158 $XS .= "void\n" 176 $XS1 = "void\n"
159 . "$perl_name (OpenCL::$classmap{$real_class} this$extra_xs_args)\n" 177 . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
160 . " PPCODE:\n"; 178 $XS2 = " PPCODE:\n";
161 179
162 if ($dynamic) { 180 if ($dynamic) {
163 $XS .= " size_t size;\n" 181 $XS2 .= " size_t size;\n"
164 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, 0, 0, &size));\n" 182 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n"
165 . " $type->[0] *value = tmpbuf (size);\n" 183 . " $type->[0] *value = tmpbuf (size);\n"
166 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, size, value, 0));\n"; 184 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n";
167 } else { 185 } else {
168 $XS .= " $type->[0] value [1];\n" 186 $XS2 .= " $type->[0] value [1];\n"
169 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, sizeof (value), value, 0));\n"; 187 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
170 } 188 }
171 189
172 if ($array) { 190 if ($array && $nelem ne "1") {
173 $XS .= " int i, n = $nelem;\n" 191 $XS2 .= " int i, n = $nelem;\n"
174 . " EXTEND (SP, n);\n" 192 . " EXTEND (SP, n);\n"
175 . " for (i = 0; i < n; ++i)\n"; 193 . " for (i = 0; i < n; ++i)\n";
176 } else { 194 } else {
177 $XS .= " EXTEND (SP, 1);\n" 195 $XS2 .= " EXTEND (SP, 1);\n"
178 . " const int i = 0;\n" 196 . " const int i = 0;\n"
179 } 197 }
180 198
181 if ($type->[1] =~ /^OpenCL::(\S+)$/) { 199 if ($type->[1] =~ /^OpenCL::(\S+)$/) {
182 my $oclass = $1; 200 my $oclass = $1;
183 $oclass = "MemObject" if $oclass eq "Memory"; 201 $oclass = "MemObject" if $oclass eq "Memory";
184 $oclass = "CommandQueue" if $oclass eq "Queue"; 202 $oclass = "CommandQueue" if $oclass eq "Queue";
185 203
204 my $stash = lc $type->[1];
205 $stash =~ s/opencl:://;
206 $stash =~ s/::/_/g;
207
186 $XS .= " {\n"; 208 $XS2 .= " {\n";
187 $XS .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device"; 209 $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" || $oclass eq "Device";
188 $XS .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n"; 210 $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
189 $XS .= " }\n"; 211 $XS2 .= " }\n";
190 } else { 212 } else {
191 $XS .= " PUSHs (sv_2mortal ($type->[1]));\n"; 213 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
192 } 214 }
193 215
194 $XS .= "\n"; 216 $XS2 .= "\n";
217
218 if (my $alias = $alias{"$XS1$XS2"}) {
219 push @$alias, [$perl_name, $name];
220 } else {
221 push @funcs, [$XS1, (my $alias = [[$perl_name, $name]]), $XS2];
222 $alias{"$XS1$XS2"} = $alias;
223 }
195 } 224 }
225
226 my $XS;
227
228 # this very dirty and ugly code is a very dirty and ugly code size optimisation.
229 for (@funcs) {
230 $_->[0] =~s /^XXXNAMEXXX/$_->[1][0][0]/m;
231
232 if (@{ $_->[1] } == 1) { # undo ALIAS
233 $_->[2] =~ s/\bix\b/$_->[1][0][1]/g;
234 $_->[1] = "";
235 } else {
236 $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] };
237 }
238 $XS .= join "", @$_;
239 }
240
241 warn "patching class $CLASS\n";
196 242
197 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS; 243 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS;
198 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD; 244 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
199} 245}
200 246

Diff Legend

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