… | |
… | |
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 | |
25 | my %typemap = ( |
27 | my %typemap = ( |
26 | cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'], |
28 | cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'], |
… | |
… | |
76 | } |
78 | } |
77 | |
79 | |
78 | rename "$file~", $file; |
80 | rename "$file~", $file; |
79 | } |
81 | } |
80 | |
82 | |
81 | for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) { |
83 | for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling gl_texture)) { |
82 | open my $fh, "<getinfo.txt" |
84 | open my $fh, "<getinfo.txt" |
83 | or die "getinfo.txt: $!"; |
85 | or die "getinfo.txt: $!"; |
84 | |
86 | |
85 | my $XS; |
|
|
86 | my $POD; |
87 | my $POD; |
|
|
88 | my @funcs; |
|
|
89 | my %alias; |
87 | |
90 | |
88 | while (<$fh>) { |
91 | while (<$fh>) { |
89 | chomp; |
92 | chomp; |
90 | my ($class, $name, $ctype) = split /,\s*/, $_, 3; |
93 | my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3; |
91 | next unless $class eq "cl_$CLASS\_info"; |
94 | next unless $class eq "cl_$CLASS\_info"; |
92 | next if $name eq "CL_IMAGE_FORMAT"; # struct |
95 | next if $name eq "CL_IMAGE_FORMAT"; # struct |
93 | next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls |
96 | next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls |
94 | |
97 | |
95 | $ctype =~ s/cl:://g; |
98 | $ctype =~ s/cl:://g; |
96 | $ctype =~ s/::size_t/size_t/g; |
99 | $ctype =~ s/::size_t/size_t/g; |
97 | |
100 | |
98 | my $cbase = $class; |
101 | my $cbase = $class; |
99 | $cbase =~ s/_(.)/\U$1/g; |
102 | $cbase =~ s/_(.)/\U$1/g; |
|
|
103 | $cbase =~ s/Gl(?=[A-Z])/GL/g; |
100 | $cbase =~ s/^cl//; |
104 | $cbase =~ s/^cl//; |
101 | $cbase =~ s/Info$//; |
105 | $cbase =~ s/Info$//; |
102 | $cbase = "MemObject" if $cbase eq "Mem"; |
106 | $cbase = "MemObject" if $cbase eq "Mem"; |
103 | $cbase = "EventProfiling" if $cbase eq "Profiling"; |
107 | $cbase = "EventProfiling" if $cbase eq "Profiling"; |
104 | |
108 | |
… | |
… | |
120 | $extra_args = ', device'; |
124 | $extra_args = ', device'; |
121 | $extra_perl_args = ' ($device)'; |
125 | $extra_perl_args = ' ($device)'; |
122 | $extra_xs_args = ', OpenCL::Device device'; |
126 | $extra_xs_args = ', OpenCL::Device device'; |
123 | } |
127 | } |
124 | |
128 | |
|
|
129 | if ($CLASS eq "kernel_arg") { |
|
|
130 | $extra_args = ', idx'; |
|
|
131 | $extra_perl_args = ' ($idx)'; |
|
|
132 | $extra_xs_args = ', cl_uint idx'; |
|
|
133 | } |
|
|
134 | |
125 | my $dynamic; |
135 | my $dynamic; |
126 | my $nelem = "size / sizeof (value [0])"; |
136 | my $nelem = "size / sizeof (*value)"; |
127 | |
137 | |
128 | if ($ctype eq "STRING_CLASS") { |
138 | if ($ctype eq "STRING_CLASS") { |
129 | $ctype = "VECTOR_CLASS<char>"; |
139 | $ctype = "VECTOR_CLASS<char>"; |
130 | $nelem = "1"; |
140 | $nelem = "1"; |
131 | $dynamic = 1; |
141 | $dynamic = 1; |
… | |
… | |
151 | $perltype = "\@${perltype}s"; |
161 | $perltype = "\@${perltype}s"; |
152 | } else { |
162 | } else { |
153 | $perltype = "\$$perltype"; |
163 | $perltype = "\$$perltype"; |
154 | } |
164 | } |
155 | |
165 | |
|
|
166 | (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die; |
|
|
167 | |
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"; |
168 | $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 | |
169 | |
|
|
170 | # XS1 contains the function before ALIAS, XS2 the function afterwards (the body) |
|
|
171 | # after we generate the bdoy we look for an identical body generated earlier |
|
|
172 | # and simply alias us to the earlier xs function, to save text size. |
|
|
173 | my ($XS1, $XS2); |
|
|
174 | |
158 | $XS .= "void\n" |
175 | $XS1 = "void\n" |
159 | . "$perl_name (OpenCL::$classmap{$real_class} this$extra_xs_args)\n" |
176 | . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n"; |
160 | . " PPCODE:\n"; |
177 | $XS2 = " PPCODE:\n"; |
161 | |
178 | |
162 | if ($dynamic) { |
179 | if ($dynamic) { |
163 | $XS .= " size_t size;\n" |
180 | $XS2 .= " size_t size;\n" |
164 | . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, 0, 0, &size));\n" |
181 | . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n" |
165 | . " $type->[0] *value = tmpbuf (size);\n" |
182 | . " $type->[0] *value = tmpbuf (size);\n" |
166 | . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, size, value, 0));\n"; |
183 | . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n"; |
167 | } else { |
184 | } else { |
168 | $XS .= " $type->[0] value [1];\n" |
185 | $XS2 .= " $type->[0] value [1];\n" |
169 | . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, sizeof (value), value, 0));\n"; |
186 | . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n"; |
170 | } |
187 | } |
171 | |
188 | |
172 | if ($array) { |
189 | if ($array && $nelem ne "1") { |
173 | $XS .= " int i, n = $nelem;\n" |
190 | $XS2 .= " int i, n = $nelem;\n" |
174 | . " EXTEND (SP, n);\n" |
191 | . " EXTEND (SP, n);\n" |
175 | . " for (i = 0; i < n; ++i)\n"; |
192 | . " for (i = 0; i < n; ++i)\n"; |
176 | } else { |
193 | } else { |
177 | $XS .= " EXTEND (SP, 1);\n" |
194 | $XS2 .= " EXTEND (SP, 1);\n" |
178 | . " const int i = 0;\n" |
195 | . " const int i = 0;\n" |
179 | } |
196 | } |
180 | |
197 | |
181 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
198 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
182 | my $oclass = $1; |
199 | my $oclass = $1; |
183 | $oclass = "MemObject" if $oclass eq "Memory"; |
200 | $oclass = "MemObject" if $oclass eq "Memory"; |
184 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
201 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
185 | |
202 | |
|
|
203 | my $stash = lc $type->[1]; |
|
|
204 | $stash =~ s/opencl:://; |
|
|
205 | $stash =~ s/::/_/g; |
|
|
206 | |
186 | $XS .= " {\n"; |
207 | $XS2 .= " {\n"; |
187 | $XS .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device"; |
208 | $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"; |
209 | $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n"; |
189 | $XS .= " }\n"; |
210 | $XS2 .= " }\n"; |
190 | } else { |
211 | } else { |
191 | $XS .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
212 | $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
192 | } |
213 | } |
193 | |
214 | |
194 | $XS .= "\n"; |
215 | $XS2 .= "\n"; |
|
|
216 | |
|
|
217 | if (my $alias = $alias{"$XS1$XS2"}) { |
|
|
218 | push @$alias, [$perl_name, $name]; |
|
|
219 | } else { |
|
|
220 | push @funcs, [$XS1, (my $alias = [[$perl_name, $name]]), $XS2]; |
|
|
221 | $alias{"$XS1$XS2"} = $alias; |
|
|
222 | } |
195 | } |
223 | } |
|
|
224 | |
|
|
225 | my $XS; |
|
|
226 | |
|
|
227 | # this very dirty and ugly code is a very dirty and ugly code size optimisation. |
|
|
228 | for (@funcs) { |
|
|
229 | $_->[0] =~s /^XXXNAMEXXX/$_->[1][0][0]/m; |
|
|
230 | |
|
|
231 | if (@{ $_->[1] } == 1) { # undo ALIAS |
|
|
232 | $_->[2] =~ s/\bix\b/$_->[1][0][1]/g; |
|
|
233 | $_->[1] = ""; |
|
|
234 | } else { |
|
|
235 | $_->[1] = " ALIAS:\n" . join "", map " $_->[0] = $_->[1]\n", @{ $_->[1] }; |
|
|
236 | } |
|
|
237 | $XS .= join "", @$_; |
|
|
238 | } |
|
|
239 | |
|
|
240 | warn "patching class $CLASS\n"; |
196 | |
241 | |
197 | patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS; |
242 | patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS; |
198 | patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD; |
243 | patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD; |
199 | } |
244 | } |
200 | |
245 | |