… | |
… | |
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 | |
26 | my %typemap = ( |
27 | my %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. |
|
|
49 | my %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 | |
82 | for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling gl_texture)) { |
99 | for 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; |
88 | my %alias; |
105 | my %alias; |
89 | |
106 | |
90 | while (<$fh>) { |
107 | while (<$fh>) { |
91 | chomp; |
108 | chomp; |
92 | my ($class, $name, $ctype) = split /,\s*/, $_, 3; |
109 | my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3; |
93 | next unless $class eq "cl_$CLASS\_info"; |
110 | next unless $class eq "cl_$CLASS\_info"; |
94 | next if $name eq "CL_IMAGE_FORMAT"; # struct |
111 | next if $name eq "CL_IMAGE_FORMAT"; # struct |
95 | next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls |
112 | next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls |
96 | |
113 | |
97 | $ctype =~ s/cl:://g; |
114 | $ctype =~ s/cl:://g; |
… | |
… | |
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 | |
… | |
… | |
154 | $perltype = "\@${perltype}s"; |
178 | $perltype = "\@${perltype}s"; |
155 | } else { |
179 | } else { |
156 | $perltype = "\$$perltype"; |
180 | $perltype = "\$$perltype"; |
157 | } |
181 | } |
158 | |
182 | |
|
|
183 | (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die; |
|
|
184 | |
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"; |
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"; |
160 | |
186 | |
161 | # XS1 contains the function before ALIAS, XS2 the function afterwards (the body) |
187 | # 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 |
188 | # 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. |
189 | # and simply alias us to the earlier xs function, to save text size. |
164 | my ($XS1, $XS2); |
190 | my ($XS1, $XS2); |
165 | |
191 | |
166 | $XS1 = "void\n" |
192 | $XS1 = "void\n" |
167 | . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n"; |
193 | . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n"; |
168 | $XS2 = " PPCODE:\n"; |
194 | $XS2 = " PPCODE:\n"; |
169 | |
195 | |
|
|
196 | my $stype = $type->[0]; # simplified type |
|
|
197 | $stype = $typesimplify{$stype} while exists $typesimplify{$stype}; |
|
|
198 | |
170 | if ($dynamic) { |
199 | if ($dynamic) { |
171 | $XS2 .= " size_t size;\n" |
200 | $XS2 .= " size_t size;\n" |
172 | . " 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" |
173 | . " $type->[0] *value = tmpbuf (size);\n" |
202 | . " $stype *value = tmpbuf (size);\n" |
174 | . " 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"; |
175 | } else { |
204 | } else { |
176 | $XS2 .= " $type->[0] value [1];\n" |
205 | $XS2 .= " $stype value [1];\n" |
177 | . " 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"; |
178 | } |
207 | } |
179 | |
208 | |
180 | if ($array && $nelem ne "1") { |
209 | if ($array && $nelem ne "1") { |
181 | $XS2 .= " int i, n = $nelem;\n" |
210 | $XS2 .= " int i, n = $nelem;\n" |
… | |
… | |
189 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
218 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
190 | my $oclass = $1; |
219 | my $oclass = $1; |
191 | $oclass = "MemObject" if $oclass eq "Memory"; |
220 | $oclass = "MemObject" if $oclass eq "Memory"; |
192 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
221 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
193 | |
222 | |
194 | $XS2 .= " {\n"; |
223 | my $stash = lc $type->[1]; |
|
|
224 | $stash =~ s/opencl:://; |
|
|
225 | $stash =~ s/::/_/g; |
|
|
226 | |
195 | $XS2 .= " 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"; |
196 | $XS2 .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n"; |
228 | $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n"; |
197 | $XS2 .= " }\n"; |
|
|
198 | } else { |
229 | } else { |
199 | $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
230 | $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
200 | } |
231 | } |
201 | |
232 | |
202 | $XS2 .= "\n"; |
233 | $XS2 .= "\n"; |
… | |
… | |
217 | |
248 | |
218 | if (@{ $_->[1] } == 1) { # undo ALIAS |
249 | if (@{ $_->[1] } == 1) { # undo ALIAS |
219 | $_->[2] =~ s/\bix\b/$_->[1][0][1]/g; |
250 | $_->[2] =~ s/\bix\b/$_->[1][0][1]/g; |
220 | $_->[1] = ""; |
251 | $_->[1] = ""; |
221 | } else { |
252 | } else { |
222 | $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] }; |
253 | $_->[1] = " ALIAS:\n" . join "", sort, map " $_->[0] = $_->[1]\n", @{ $_->[1] }; |
223 | } |
254 | } |
224 | $XS .= join "", @$_; |
255 | $XS .= join "", @$_; |
225 | } |
256 | } |
226 | |
257 | |
227 | warn "patching class $CLASS\n"; |
258 | warn "patching class $CLASS\n"; |