| … | |
… | |
| 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'], |
| … | |
… | |
| 87 | my @funcs; |
88 | my @funcs; |
| 88 | my %alias; |
89 | my %alias; |
| 89 | |
90 | |
| 90 | while (<$fh>) { |
91 | while (<$fh>) { |
| 91 | chomp; |
92 | chomp; |
| 92 | my ($class, $name, $ctype) = split /,\s*/, $_, 3; |
93 | my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3; |
| 93 | next unless $class eq "cl_$CLASS\_info"; |
94 | next unless $class eq "cl_$CLASS\_info"; |
| 94 | next if $name eq "CL_IMAGE_FORMAT"; # struct |
95 | next if $name eq "CL_IMAGE_FORMAT"; # struct |
| 95 | next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls |
96 | next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls |
| 96 | |
97 | |
| 97 | $ctype =~ s/cl:://g; |
98 | $ctype =~ s/cl:://g; |
| 98 | $ctype =~ s/::size_t/size_t/g; |
99 | $ctype =~ s/::size_t/size_t/g; |
| 99 | |
100 | |
| 100 | my $cbase = $class; |
101 | my $cbase = $class; |
| 101 | $cbase =~ s/_(.)/\U$1/g; |
102 | $cbase =~ s/_(.)/\U$1/g; |
|
|
103 | $cbase =~ s/Gl(?=[A-Z])/GL/g; |
| 102 | $cbase =~ s/^cl//; |
104 | $cbase =~ s/^cl//; |
| 103 | $cbase =~ s/Info$//; |
105 | $cbase =~ s/Info$//; |
| 104 | $cbase = "MemObject" if $cbase eq "Mem"; |
106 | $cbase = "MemObject" if $cbase eq "Mem"; |
| 105 | $cbase = "EventProfiling" if $cbase eq "Profiling"; |
107 | $cbase = "EventProfiling" if $cbase eq "Profiling"; |
| 106 | |
108 | |
| … | |
… | |
| 120 | |
122 | |
| 121 | if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { |
123 | if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") { |
| 122 | $extra_args = ', device'; |
124 | $extra_args = ', device'; |
| 123 | $extra_perl_args = ' ($device)'; |
125 | $extra_perl_args = ' ($device)'; |
| 124 | $extra_xs_args = ', OpenCL::Device device'; |
126 | $extra_xs_args = ', OpenCL::Device device'; |
|
|
127 | } |
|
|
128 | |
|
|
129 | if ($CLASS eq "kernel_arg") { |
|
|
130 | $extra_args = ', idx'; |
|
|
131 | $extra_perl_args = ' ($idx)'; |
|
|
132 | $extra_xs_args = ', cl_uint idx'; |
| 125 | } |
133 | } |
| 126 | |
134 | |
| 127 | my $dynamic; |
135 | my $dynamic; |
| 128 | my $nelem = "size / sizeof (*value)"; |
136 | my $nelem = "size / sizeof (*value)"; |
| 129 | |
137 | |
| … | |
… | |
| 153 | $perltype = "\@${perltype}s"; |
161 | $perltype = "\@${perltype}s"; |
| 154 | } else { |
162 | } else { |
| 155 | $perltype = "\$$perltype"; |
163 | $perltype = "\$$perltype"; |
| 156 | } |
164 | } |
| 157 | |
165 | |
|
|
166 | (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die; |
|
|
167 | |
| 158 | $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"; |
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"; |
| 159 | |
169 | |
| 160 | # XS1 contains the function before ALIAS, XS2 the function afterwards (the body) |
170 | # XS1 contains the function before ALIAS, XS2 the function afterwards (the body) |
| 161 | # after we generate the bdoy we look for an identical body generated earlier |
171 | # after we generate the bdoy we look for an identical body generated earlier |
| 162 | # and simply alias us to the earlier xs function, to save text size. |
172 | # and simply alias us to the earlier xs function, to save text size. |
| 163 | my ($XS1, $XS2); |
173 | my ($XS1, $XS2); |
| … | |
… | |
| 188 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
198 | if ($type->[1] =~ /^OpenCL::(\S+)$/) { |
| 189 | my $oclass = $1; |
199 | my $oclass = $1; |
| 190 | $oclass = "MemObject" if $oclass eq "Memory"; |
200 | $oclass = "MemObject" if $oclass eq "Memory"; |
| 191 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
201 | $oclass = "CommandQueue" if $oclass eq "Queue"; |
| 192 | |
202 | |
|
|
203 | my $stash = lc $type->[1]; |
|
|
204 | $stash =~ s/opencl:://; |
|
|
205 | $stash =~ s/::/_/g; |
|
|
206 | |
| 193 | $XS2 .= " {\n"; |
207 | $XS2 .= " {\n"; |
| 194 | $XS2 .= " 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"; |
| 195 | $XS2 .= " PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n"; |
209 | $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n"; |
| 196 | $XS2 .= " }\n"; |
210 | $XS2 .= " }\n"; |
| 197 | } else { |
211 | } else { |
| 198 | $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
212 | $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n"; |
| 199 | } |
213 | } |
| 200 | |
214 | |
