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.19 by root, Sat May 5 15:43:02 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 = (
28 # getinfo.txt c type, constructor, pod
26 cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'], 29 cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'],
27 #char => ['char', 'newSVpvn (value, size)', 'string'], 30 #char => ['char', 'newSVpvn (value, size)', 'string'],
28 char => ['char', 'newSVpv (value, 0)', 'string'], # all these are 0-terminated strings, and the driver often appends a \0 31 char => ['char', 'newSVpv (value, 0)', 'string'], # all these are 0-terminated strings, and the driver often appends a \0
29 size_t => ['size_t', 'newSVuv (value [i])', 'int'], 32 size_t => ['size_t', 'newSVuv (value [i])', 'int'],
30 "void*" => ['void *', 'newSVuv ((IV)(intptr_t)value [i])', 'ptr_value'], 33 "void*" => ['void *', 'newSVuv ((IV)(intptr_t)value [i])', 'ptr_value'],
… …
34 cl_device_id => ['cl_device_id', 'OpenCL::Device', 'device'], 37 cl_device_id => ['cl_device_id', 'OpenCL::Device', 'device'],
35 Memory => ['cl_mem', 'OpenCL::Memory', 'mem'], 38 Memory => ['cl_mem', 'OpenCL::Memory', 'mem'],
36 Program => ['cl_program', 'OpenCL::Program', 'program'], 39 Program => ['cl_program', 'OpenCL::Program', 'program'],
37 CommandQueue => ['cl_command_queue', 'OpenCL::Queue', 'queue'], 40 CommandQueue => ['cl_command_queue', 'OpenCL::Queue', 'queue'],
38 cl_context_properties => ['cl_context_properties', 'newSVuv ((UV)value [i])', 'property_int'], 41 cl_context_properties => ['cl_context_properties', 'newSVuv ((UV)value [i])', 'property_int'],
42 cl_program_binary_type => ['cl_program_binary_type', 'newSVuv ((UV)value [i])', 'binary_type'],
39); 43);
44
45
46# try to re-use types with same representation in C - if we
47# ever overload bitfields etc. then we need to remove all
48# typesimplify code.
49my %typesimplify;
50{
51 open my $h, "<CL/cl.h" or die "CL/cl.h: $!";
52
53 while (<$h>) {
54 $typesimplify{$2} = $1
55 if /typedef\s+(cl_\S+)\s+(cl_\S+);/;
56 }
57}
40 58
41{ 59{
42 my %tmap = ( 60 my %tmap = (
43 T_IV => "newSViv (value [i])", 61 T_IV => "newSViv (value [i])",
44 T_UV => "newSVuv (value [i])", 62 T_UV => "newSVuv (value [i])",
… …
76 } 94 }
77 95
78 rename "$file~", $file; 96 rename "$file~", $file;
79} 97}
80 98
81for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) { 99for 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" 100 open my $fh, "<getinfo.txt"
83 or die "getinfo.txt: $!"; 101 or die "getinfo.txt: $!";
84 102
85 my $XS;
86 my $POD; 103 my $POD;
104 my @funcs;
105 my %alias;
87 106
88 while (<$fh>) { 107 while (<$fh>) {
89 chomp; 108 chomp;
90 my ($class, $name, $ctype) = split /,\s*/, $_, 3; 109 my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3;
91 next unless $class eq "cl_$CLASS\_info"; 110 next unless $class eq "cl_$CLASS\_info";
92 next if $name eq "CL_IMAGE_FORMAT"; # struct 111 next if $name eq "CL_IMAGE_FORMAT"; # struct
93 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls 112 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls
94 113
95 $ctype =~ s/cl:://g; 114 $ctype =~ s/cl:://g;
96 $ctype =~ s/::size_t/size_t/g; 115 $ctype =~ s/::size_t/size_t/g;
97 116
98 my $cbase = $class; 117 my $cbase = $class;
99 $cbase =~ s/_(.)/\U$1/g; 118 $cbase =~ s/_(.)/\U$1/g;
119 $cbase =~ s/Gl(?=[A-Z])/GL/g;
100 $cbase =~ s/^cl//; 120 $cbase =~ s/^cl//;
101 $cbase =~ s/Info$//; 121 $cbase =~ s/Info$//;
102 $cbase = "MemObject" if $cbase eq "Mem"; 122 $cbase = "MemObject" if $cbase eq "Mem";
103 $cbase = "EventProfiling" if $cbase eq "Profiling"; 123 $cbase = "EventProfiling" if $cbase eq "Profiling";
104 124
105 my $real_class = $CLASS; 125 my $real_class = $CLASS;
106 $real_class = "program" if $real_class eq "program_build"; 126 $real_class = "program" if $real_class eq "program_build";
107 $real_class = "kernel" if $real_class eq "kernel_work_group"; 127 $real_class = "kernel" if $real_class eq "kernel_work_group";
128 $real_class = "kernel" if $real_class eq "kernel_arg";
108 $real_class = "event" if $real_class eq "profiling"; 129 $real_class = "event" if $real_class eq "profiling";
109 130
110 my $perl_name = lc $name; 131 my $perl_name = lc $name;
111 $perl_name =~ s/^cl_//; 132 $perl_name =~ s/^cl_//;
112 $perl_name =~ s/^$real_class\_//; 133 $perl_name =~ s/^$real_class\_//;
… …
118 139
119 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { 140 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") {
120 $extra_args = ', device'; 141 $extra_args = ', device';
121 $extra_perl_args = ' ($device)'; 142 $extra_perl_args = ' ($device)';
122 $extra_xs_args = ', OpenCL::Device device'; 143 $extra_xs_args = ', OpenCL::Device device';
144 }
145
146 if ($CLASS eq "kernel_arg") {
147 $extra_args = ', idx';
148 $extra_perl_args = ' ($idx)';
149 $extra_xs_args = ', cl_uint idx';
123 } 150 }
124 151
125 my $dynamic; 152 my $dynamic;
126 my $nelem = "size / sizeof (*value)"; 153 my $nelem = "size / sizeof (*value)";
127 154
… …
151 $perltype = "\@${perltype}s"; 178 $perltype = "\@${perltype}s";
152 } else { 179 } else {
153 $perltype = "\$$perltype"; 180 $perltype = "\$$perltype";
154 } 181 }
155 182
183 (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die;
184
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"; 185 $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 186
187 # XS1 contains the function before ALIAS, XS2 the function afterwards (the body)
188 # after we generate the bdoy we look for an identical body generated earlier
189 # and simply alias us to the earlier xs function, to save text size.
190 my ($XS1, $XS2);
191
158 $XS .= "void\n" 192 $XS1 = "void\n"
159 . "$perl_name (OpenCL::$classmap{$real_class} this$extra_xs_args)\n" 193 . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
160 . " PPCODE:\n"; 194 $XS2 = " PPCODE:\n";
195
196 my $stype = $type->[0]; # simplified type
197 $stype = $typesimplify{$stype} while exists $typesimplify{$stype};
161 198
162 if ($dynamic) { 199 if ($dynamic) {
163 $XS .= " size_t size;\n" 200 $XS2 .= " size_t size;\n"
164 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, 0, 0, &size));\n" 201 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n"
165 . " $type->[0] *value = tmpbuf (size);\n" 202 . " $stype *value = tmpbuf (size);\n"
166 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, size, value, 0));\n"; 203 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n";
167 } else { 204 } else {
168 $XS .= " $type->[0] value [1];\n" 205 $XS2 .= " $stype value [1];\n"
169 . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, sizeof (value), value, 0));\n"; 206 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
170 } 207 }
171 208
172 if ($array) { 209 if ($array && $nelem ne "1") {
173 $XS .= " int i, n = $nelem;\n" 210 $XS2 .= " int i, n = $nelem;\n"
174 . " EXTEND (SP, n);\n" 211 . " EXTEND (SP, n);\n"
175 . " for (i = 0; i < n; ++i)\n"; 212 . " for (i = 0; i < n; ++i)\n";
176 } else { 213 } else {
177 $XS .= " EXTEND (SP, 1);\n" 214 $XS2 .= " EXTEND (SP, 1);\n"
178 . " const int i = 0;\n" 215 . " const int i = 0;\n"
179 } 216 }
180 217
181 if ($type->[1] =~ /^OpenCL::(\S+)$/) { 218 if ($type->[1] =~ /^OpenCL::(\S+)$/) {
182 my $oclass = $1; 219 my $oclass = $1;
183 $oclass = "MemObject" if $oclass eq "Memory"; 220 $oclass = "MemObject" if $oclass eq "Memory";
184 $oclass = "CommandQueue" if $oclass eq "Queue"; 221 $oclass = "CommandQueue" if $oclass eq "Queue";
185 222
186 $XS .= " {\n"; 223 my $stash = lc $type->[1];
224 $stash =~ s/opencl:://;
225 $stash =~ s/::/_/g;
226
187 $XS .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device"; 227 $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"; 228 $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
189 $XS .= " }\n";
190 } else { 229 } else {
191 $XS .= " PUSHs (sv_2mortal ($type->[1]));\n"; 230 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
192 } 231 }
193 232
194 $XS .= "\n"; 233 $XS2 .= "\n";
234
235 if (my $alias = $alias{"$XS1$XS2"}) {
236 push @$alias, [$perl_name, $name];
237 } else {
238 push @funcs, [$XS1, (my $alias = [[$perl_name, $name]]), $XS2];
239 $alias{"$XS1$XS2"} = $alias;
240 }
195 } 241 }
242
243 my $XS;
244
245 # this very dirty and ugly code is a very dirty and ugly code size optimisation.
246 for (@funcs) {
247 $_->[0] =~s /^XXXNAMEXXX/$_->[1][0][0]/m;
248
249 if (@{ $_->[1] } == 1) { # undo ALIAS
250 $_->[2] =~ s/\bix\b/$_->[1][0][1]/g;
251 $_->[1] = "";
252 } else {
253 $_->[1] = " ALIAS:\n" . join "", sort, map " $_->[0] = $_->[1]\n", @{ $_->[1] };
254 }
255 $XS .= join "", @$_;
256 }
257
258 warn "patching class $CLASS\n";
196 259
197 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS; 260 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS;
198 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD; 261 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
199} 262}
200 263

Diff Legend

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