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

Comparing OpenCL/gengetinfo (file contents):
Revision 1.9 by root, Thu Apr 19 14:36:46 2012 UTC vs.
Revision 1.18 by root, Sat May 5 13:56:00 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);
41 44
42{ 45{
43 my %tmap = ( 46 my %tmap = (
44 T_IV => "newSViv (value [i])", 47 T_IV => "newSViv (value [i])",
… …
77 } 80 }
78 81
79 rename "$file~", $file; 82 rename "$file~", $file;
80} 83}
81 84
82for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling gl_texture)) { 85for 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" 86 open my $fh, "<getinfo.txt"
84 or die "getinfo.txt: $!"; 87 or die "getinfo.txt: $!";
85 88
86 my $POD; 89 my $POD;
87 my @funcs; 90 my @funcs;
88 my %alias; 91 my %alias;
89 92
90 while (<$fh>) { 93 while (<$fh>) {
91 chomp; 94 chomp;
92 my ($class, $name, $ctype) = split /,\s*/, $_, 3; 95 my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3;
93 next unless $class eq "cl_$CLASS\_info"; 96 next unless $class eq "cl_$CLASS\_info";
94 next if $name eq "CL_IMAGE_FORMAT"; # struct 97 next if $name eq "CL_IMAGE_FORMAT"; # struct
95 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls 98 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls
96 99
97 $ctype =~ s/cl:://g; 100 $ctype =~ s/cl:://g;
… …
106 $cbase = "EventProfiling" if $cbase eq "Profiling"; 109 $cbase = "EventProfiling" if $cbase eq "Profiling";
107 110
108 my $real_class = $CLASS; 111 my $real_class = $CLASS;
109 $real_class = "program" if $real_class eq "program_build"; 112 $real_class = "program" if $real_class eq "program_build";
110 $real_class = "kernel" if $real_class eq "kernel_work_group"; 113 $real_class = "kernel" if $real_class eq "kernel_work_group";
114 $real_class = "kernel" if $real_class eq "kernel_arg";
111 $real_class = "event" if $real_class eq "profiling"; 115 $real_class = "event" if $real_class eq "profiling";
112 116
113 my $perl_name = lc $name; 117 my $perl_name = lc $name;
114 $perl_name =~ s/^cl_//; 118 $perl_name =~ s/^cl_//;
115 $perl_name =~ s/^$real_class\_//; 119 $perl_name =~ s/^$real_class\_//;
… …
121 125
122 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { 126 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") {
123 $extra_args = ', device'; 127 $extra_args = ', device';
124 $extra_perl_args = ' ($device)'; 128 $extra_perl_args = ' ($device)';
125 $extra_xs_args = ', OpenCL::Device device'; 129 $extra_xs_args = ', OpenCL::Device device';
130 }
131
132 if ($CLASS eq "kernel_arg") {
133 $extra_args = ', idx';
134 $extra_perl_args = ' ($idx)';
135 $extra_xs_args = ', cl_uint idx';
126 } 136 }
127 137
128 my $dynamic; 138 my $dynamic;
129 my $nelem = "size / sizeof (*value)"; 139 my $nelem = "size / sizeof (*value)";
130 140
… …
154 $perltype = "\@${perltype}s"; 164 $perltype = "\@${perltype}s";
155 } else { 165 } else {
156 $perltype = "\$$perltype"; 166 $perltype = "\$$perltype";
157 } 167 }
158 168
169 (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die;
170
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"; 171 $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";
160 172
161 # XS1 contains the function before ALIAS, XS2 the function afterwards (the body) 173 # 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 174 # 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. 175 # and simply alias us to the earlier xs function, to save text size.
164 my ($XS1, $XS2); 176 my ($XS1, $XS2);
… …
189 if ($type->[1] =~ /^OpenCL::(\S+)$/) { 201 if ($type->[1] =~ /^OpenCL::(\S+)$/) {
190 my $oclass = $1; 202 my $oclass = $1;
191 $oclass = "MemObject" if $oclass eq "Memory"; 203 $oclass = "MemObject" if $oclass eq "Memory";
192 $oclass = "CommandQueue" if $oclass eq "Queue"; 204 $oclass = "CommandQueue" if $oclass eq "Queue";
193 205
206 my $stash = lc $type->[1];
207 $stash =~ s/opencl:://;
208 $stash =~ s/::/_/g;
209
194 $XS2 .= " {\n"; 210 $XS2 .= " {\n";
195 $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device"; 211 $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" || $oclass eq "Device";
196 $XS2 .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n"; 212 $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
197 $XS2 .= " }\n"; 213 $XS2 .= " }\n";
198 } else { 214 } else {
199 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; 215 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
200 } 216 }
201 217

Diff Legend

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