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

Comparing OpenCL/gengetinfo (file contents):
Revision 1.6 by root, Mon Apr 16 09:42:33 2012 UTC vs.
Revision 1.18 by root, Sat May 5 13:56:00 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);
40 44
41{ 45{
42 my %tmap = ( 46 my %tmap = (
43 T_IV => "newSViv (value [i])", 47 T_IV => "newSViv (value [i])",
… …
76 } 80 }
77 81
78 rename "$file~", $file; 82 rename "$file~", $file;
79} 83}
80 84
81for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) { 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)) {
82 open my $fh, "<getinfo.txt" 86 open my $fh, "<getinfo.txt"
83 or die "getinfo.txt: $!"; 87 or die "getinfo.txt: $!";
84 88
85 my $POD; 89 my $POD;
86 my @funcs; 90 my @funcs;
87 my %alias; 91 my %alias;
88 92
89 while (<$fh>) { 93 while (<$fh>) {
90 chomp; 94 chomp;
91 my ($class, $name, $ctype) = split /,\s*/, $_, 3; 95 my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3;
92 next unless $class eq "cl_$CLASS\_info"; 96 next unless $class eq "cl_$CLASS\_info";
93 next if $name eq "CL_IMAGE_FORMAT"; # struct 97 next if $name eq "CL_IMAGE_FORMAT"; # struct
94 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls 98 next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls
95 99
96 $ctype =~ s/cl:://g; 100 $ctype =~ s/cl:://g;
97 $ctype =~ s/::size_t/size_t/g; 101 $ctype =~ s/::size_t/size_t/g;
98 102
99 my $cbase = $class; 103 my $cbase = $class;
100 $cbase =~ s/_(.)/\U$1/g; 104 $cbase =~ s/_(.)/\U$1/g;
105 $cbase =~ s/Gl(?=[A-Z])/GL/g;
101 $cbase =~ s/^cl//; 106 $cbase =~ s/^cl//;
102 $cbase =~ s/Info$//; 107 $cbase =~ s/Info$//;
103 $cbase = "MemObject" if $cbase eq "Mem"; 108 $cbase = "MemObject" if $cbase eq "Mem";
104 $cbase = "EventProfiling" if $cbase eq "Profiling"; 109 $cbase = "EventProfiling" if $cbase eq "Profiling";
105 110
106 my $real_class = $CLASS; 111 my $real_class = $CLASS;
107 $real_class = "program" if $real_class eq "program_build"; 112 $real_class = "program" if $real_class eq "program_build";
108 $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";
109 $real_class = "event" if $real_class eq "profiling"; 115 $real_class = "event" if $real_class eq "profiling";
110 116
111 my $perl_name = lc $name; 117 my $perl_name = lc $name;
112 $perl_name =~ s/^cl_//; 118 $perl_name =~ s/^cl_//;
113 $perl_name =~ s/^$real_class\_//; 119 $perl_name =~ s/^$real_class\_//;
… …
119 125
120 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { 126 if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") {
121 $extra_args = ', device'; 127 $extra_args = ', device';
122 $extra_perl_args = ' ($device)'; 128 $extra_perl_args = ' ($device)';
123 $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';
124 } 136 }
125 137
126 my $dynamic; 138 my $dynamic;
127 my $nelem = "size / sizeof (*value)"; 139 my $nelem = "size / sizeof (*value)";
128 140
… …
152 $perltype = "\@${perltype}s"; 164 $perltype = "\@${perltype}s";
153 } else { 165 } else {
154 $perltype = "\$$perltype"; 166 $perltype = "\$$perltype";
155 } 167 }
156 168
169 (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die;
170
157 $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";
158 172
159 # 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)
160 # 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
161 # 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.
162 my ($XS1, $XS2); 176 my ($XS1, $XS2);
… …
187 if ($type->[1] =~ /^OpenCL::(\S+)$/) { 201 if ($type->[1] =~ /^OpenCL::(\S+)$/) {
188 my $oclass = $1; 202 my $oclass = $1;
189 $oclass = "MemObject" if $oclass eq "Memory"; 203 $oclass = "MemObject" if $oclass eq "Memory";
190 $oclass = "CommandQueue" if $oclass eq "Queue"; 204 $oclass = "CommandQueue" if $oclass eq "Queue";
191 205
206 my $stash = lc $type->[1];
207 $stash =~ s/opencl:://;
208 $stash =~ s/::/_/g;
209
192 $XS2 .= " {\n"; 210 $XS2 .= " {\n";
193 $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";
194 $XS2 .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n"; 212 $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
195 $XS2 .= " }\n"; 213 $XS2 .= " }\n";
196 } else { 214 } else {
197 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; 215 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
198 } 216 }
199 217
… …
220 $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] }; 238 $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] };
221 } 239 }
222 $XS .= join "", @$_; 240 $XS .= join "", @$_;
223 } 241 }
224 242
243 warn "patching class $CLASS\n";
244
225 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS; 245 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS;
226 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD; 246 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
227} 247}
228 248

Diff Legend

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