… | |
… | |
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 = ( |
27 | 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'], |
… | |
… | |
77 | } |
78 | } |
78 | |
79 | |
79 | rename "$file~", $file; |
80 | rename "$file~", $file; |
80 | } |
81 | } |
81 | |
82 | |
82 | for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling gl_texture)) { |
83 | 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" |
84 | open my $fh, "<getinfo.txt" |
84 | or die "getinfo.txt: $!"; |
85 | or die "getinfo.txt: $!"; |
85 | |
86 | |
86 | my $POD; |
87 | my $POD; |
87 | my @funcs; |
88 | my @funcs; |
… | |
… | |
106 | $cbase = "EventProfiling" if $cbase eq "Profiling"; |
107 | $cbase = "EventProfiling" if $cbase eq "Profiling"; |
107 | |
108 | |
108 | my $real_class = $CLASS; |
109 | my $real_class = $CLASS; |
109 | $real_class = "program" if $real_class eq "program_build"; |
110 | $real_class = "program" if $real_class eq "program_build"; |
110 | $real_class = "kernel" if $real_class eq "kernel_work_group"; |
111 | $real_class = "kernel" if $real_class eq "kernel_work_group"; |
|
|
112 | $real_class = "kernel" if $real_class eq "kernel_arg"; |
111 | $real_class = "event" if $real_class eq "profiling"; |
113 | $real_class = "event" if $real_class eq "profiling"; |
112 | |
114 | |
113 | my $perl_name = lc $name; |
115 | my $perl_name = lc $name; |
114 | $perl_name =~ s/^cl_//; |
116 | $perl_name =~ s/^cl_//; |
115 | $perl_name =~ s/^$real_class\_//; |
117 | $perl_name =~ s/^$real_class\_//; |
… | |
… | |
121 | |
123 | |
122 | if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { |
124 | if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { |
123 | $extra_args = ', device'; |
125 | $extra_args = ', device'; |
124 | $extra_perl_args = ' ($device)'; |
126 | $extra_perl_args = ' ($device)'; |
125 | $extra_xs_args = ', OpenCL::Device device'; |
127 | $extra_xs_args = ', OpenCL::Device device'; |
|
|
128 | } |
|
|
129 | |
|
|
130 | if ($CLASS eq "kernel_arg") { |
|
|
131 | $extra_args = ', idx'; |
|
|
132 | $extra_perl_args = ' ($idx)'; |
|
|
133 | $extra_xs_args = ', cl_uint idx'; |
126 | } |
134 | } |
127 | |
135 | |
128 | my $dynamic; |
136 | my $dynamic; |
129 | my $nelem = "size / sizeof (*value)"; |
137 | my $nelem = "size / sizeof (*value)"; |
130 | |
138 | |
… | |
… | |
154 | $perltype = "\@${perltype}s"; |
162 | $perltype = "\@${perltype}s"; |
155 | } else { |
163 | } else { |
156 | $perltype = "\$$perltype"; |
164 | $perltype = "\$$perltype"; |
157 | } |
165 | } |
158 | |
166 | |
|
|
167 | (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die; |
|
|
168 | |
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"; |
169 | $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 | |
170 | |
161 | # XS1 contains the function before ALIAS, XS2 the function afterwards (the body) |
171 | # 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 |
172 | # 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. |
173 | # and simply alias us to the earlier xs function, to save text size. |
164 | my ($XS1, $XS2); |
174 | my ($XS1, $XS2); |
… | |
… | |
189 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
199 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
190 | my $oclass = $1; |
200 | my $oclass = $1; |
191 | $oclass = "MemObject" if $oclass eq "Memory"; |
201 | $oclass = "MemObject" if $oclass eq "Memory"; |
192 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
202 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
193 | |
203 | |
|
|
204 | my $stash = lc $type->[1]; |
|
|
205 | $stash =~ s/opencl:://; |
|
|
206 | $stash =~ s/::/_/g; |
|
|
207 | |
194 | $XS2 .= " {\n"; |
208 | $XS2 .= " {\n"; |
195 | $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device"; |
209 | $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"; |
210 | $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n"; |
197 | $XS2 .= " }\n"; |
211 | $XS2 .= " }\n"; |
198 | } else { |
212 | } else { |
199 | $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
213 | $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
200 | } |
214 | } |
201 | |
215 | |