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

Comparing OpenCL/gengetinfo (file contents):
Revision 1.13 by root, Fri May 4 14:29:35 2012 UTC vs.
Revision 1.19 by root, Sat May 5 15:43:02 2012 UTC

… …
18 sampler Sampler 18 sampler Sampler
19 program Program 19 program Program
20 program_build Program 20 program_build Program
21 kernel Kernel 21 kernel Kernel
22 kernel_work_group Kernel 22 kernel_work_group Kernel
23 kernel_arg_info Kernel
23 command_queue Queue 24 command_queue Queue
24); 25);
25 26
26my %typemap = ( 27my %typemap = (
28 # getinfo.txt c type, constructor, pod
27 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'],
28 #char => ['char', 'newSVpvn (value, size)', 'string'], 30 #char => ['char', 'newSVpvn (value, size)', 'string'],
29 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
30 size_t => ['size_t', 'newSVuv (value [i])', 'int'], 32 size_t => ['size_t', 'newSVuv (value [i])', 'int'],
31 "void*" => ['void *', 'newSVuv ((IV)(intptr_t)value [i])', 'ptr_value'], 33 "void*" => ['void *', 'newSVuv ((IV)(intptr_t)value [i])', 'ptr_value'],
… …
35 cl_device_id => ['cl_device_id', 'OpenCL::Device', 'device'], 37 cl_device_id => ['cl_device_id', 'OpenCL::Device', 'device'],
36 Memory => ['cl_mem', 'OpenCL::Memory', 'mem'], 38 Memory => ['cl_mem', 'OpenCL::Memory', 'mem'],
37 Program => ['cl_program', 'OpenCL::Program', 'program'], 39 Program => ['cl_program', 'OpenCL::Program', 'program'],
38 CommandQueue => ['cl_command_queue', 'OpenCL::Queue', 'queue'], 40 CommandQueue => ['cl_command_queue', 'OpenCL::Queue', 'queue'],
39 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'],
40); 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}
41 58
42{ 59{
43 my %tmap = ( 60 my %tmap = (
44 T_IV => "newSViv (value [i])", 61 T_IV => "newSViv (value [i])",
45 T_UV => "newSVuv (value [i])", 62 T_UV => "newSVuv (value [i])",
… …
77 } 94 }
78 95
79 rename "$file~", $file; 96 rename "$file~", $file;
80} 97}
81 98
82for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling gl_texture)) { 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)) {
83 open my $fh, "<getinfo.txt" 100 open my $fh, "<getinfo.txt"
84 or die "getinfo.txt: $!"; 101 or die "getinfo.txt: $!";
85 102
86 my $POD; 103 my $POD;
87 my @funcs; 104 my @funcs;
… …
106 $cbase = "EventProfiling" if $cbase eq "Profiling"; 123 $cbase = "EventProfiling" if $cbase eq "Profiling";
107 124
108 my $real_class = $CLASS; 125 my $real_class = $CLASS;
109 $real_class = "program" if $real_class eq "program_build"; 126 $real_class = "program" if $real_class eq "program_build";
110 $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";
111 $real_class = "event" if $real_class eq "profiling"; 129 $real_class = "event" if $real_class eq "profiling";
112 130
113 my $perl_name = lc $name; 131 my $perl_name = lc $name;
114 $perl_name =~ s/^cl_//; 132 $perl_name =~ s/^cl_//;
115 $perl_name =~ s/^$real_class\_//; 133 $perl_name =~ s/^$real_class\_//;
… …
121 139
122 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { 140 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") {
123 $extra_args = ', device'; 141 $extra_args = ', device';
124 $extra_perl_args = ' ($device)'; 142 $extra_perl_args = ' ($device)';
125 $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';
126 } 150 }
127 151
128 my $dynamic; 152 my $dynamic;
129 my $nelem = "size / sizeof (*value)"; 153 my $nelem = "size / sizeof (*value)";
130 154
… …
167 191
168 $XS1 = "void\n" 192 $XS1 = "void\n"
169 . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n"; 193 . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
170 $XS2 = " PPCODE:\n"; 194 $XS2 = " PPCODE:\n";
171 195
196 my $stype = $type->[0]; # simplified type
197 $stype = $typesimplify{$stype} while exists $typesimplify{$stype};
198
172 if ($dynamic) { 199 if ($dynamic) {
173 $XS2 .= " size_t size;\n" 200 $XS2 .= " size_t size;\n"
174 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n" 201 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n"
175 . " $type->[0] *value = tmpbuf (size);\n" 202 . " $stype *value = tmpbuf (size);\n"
176 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n"; 203 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n";
177 } else { 204 } else {
178 $XS2 .= " $type->[0] value [1];\n" 205 $XS2 .= " $stype value [1];\n"
179 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n"; 206 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
180 } 207 }
181 208
182 if ($array && $nelem ne "1") { 209 if ($array && $nelem ne "1") {
183 $XS2 .= " int i, n = $nelem;\n" 210 $XS2 .= " int i, n = $nelem;\n"
… …
195 222
196 my $stash = lc $type->[1]; 223 my $stash = lc $type->[1];
197 $stash =~ s/opencl:://; 224 $stash =~ s/opencl:://;
198 $stash =~ s/::/_/g; 225 $stash =~ s/::/_/g;
199 226
200 $XS2 .= " {\n";
201 $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" || $oclass eq "Device"; 227 $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" || $oclass eq "Device";
202 $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n"; 228 $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
203 $XS2 .= " }\n";
204 } else { 229 } else {
205 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; 230 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
206 } 231 }
207 232
208 $XS2 .= "\n"; 233 $XS2 .= "\n";
… …
223 248
224 if (@{ $_->[1] } == 1) { # undo ALIAS 249 if (@{ $_->[1] } == 1) { # undo ALIAS
225 $_->[2] =~ s/\bix\b/$_->[1][0][1]/g; 250 $_->[2] =~ s/\bix\b/$_->[1][0][1]/g;
226 $_->[1] = ""; 251 $_->[1] = "";
227 } else { 252 } else {
228 $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] }; 253 $_->[1] = " ALIAS:\n" . join "", sort, map " $_->[0] = $_->[1]\n", @{ $_->[1] };
229 } 254 }
230 $XS .= join "", @$_; 255 $XS .= join "", @$_;
231 } 256 }
232 257
233 warn "patching class $CLASS\n"; 258 warn "patching class $CLASS\n";

Diff Legend

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