ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/OpenCL/gengetinfo
Revision: 1.15
Committed: Fri May 4 14:49:42 2012 UTC (12 years ago) by root
Branch: MAIN
Changes since 1.14: +1 -0 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 #!/opt/bin/perl
2    
3     # almost every "if" or "?" in this file indicates a place where the OpenCL
4     # designers fucked it up - each time you have to remember an exception to
5     # the naming rules.
6    
7     use common::sense;
8    
9     my %classmap = qw(
10     platform Platform
11     device Device
12     context Context
13     event Event
14     profiling Event
15     mem Memory
16     image Image
17 root 1.7 gl_texture Image
18 root 1.1 sampler Sampler
19     program Program
20     program_build Program
21     kernel Kernel
22     kernel_work_group Kernel
23 root 1.15 kernel_arg_info Kernel
24 root 1.1 command_queue Queue
25     );
26    
27     my %typemap = (
28     cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'],
29     #char => ['char', 'newSVpvn (value, size)', 'string'],
30     char => ['char', 'newSVpv (value, 0)', 'string'], # all these are 0-terminated strings, and the driver often appends a \0
31     size_t => ['size_t', 'newSVuv (value [i])', 'int'],
32     "void*" => ['void *', 'newSVuv ((IV)(intptr_t)value [i])', 'ptr_value'],
33     cl_platform_id => ['cl_platform_id', 'OpenCL::Platform'],
34     Context => ['cl_context', 'OpenCL::Context', 'ctx'],
35     Device => ['cl_device_id', 'OpenCL::Device', 'device'],
36     cl_device_id => ['cl_device_id', 'OpenCL::Device', 'device'],
37     Memory => ['cl_mem', 'OpenCL::Memory', 'mem'],
38     Program => ['cl_program', 'OpenCL::Program', 'program'],
39     CommandQueue => ['cl_command_queue', 'OpenCL::Queue', 'queue'],
40     cl_context_properties => ['cl_context_properties', 'newSVuv ((UV)value [i])', 'property_int'],
41     );
42    
43     {
44     my %tmap = (
45     T_IV => "newSViv (value [i])",
46     T_UV => "newSVuv (value [i])",
47     );
48    
49     open my $fh, "<typemap"
50     or die "typemap: $!";
51    
52     while (<$fh>) {
53     next if /^INPUT$/;
54     my ($name, $type) = split /\s+/, $_;
55     if ($tmap{$type}) {
56     $typemap{$name} = [$name, $tmap{$type}, substr $name, 3];
57     }
58     }
59     }
60    
61     sub patch($$$$) {
62     my ($file, $beg, $end, $contents) = @_;
63    
64     {
65     local $/;
66    
67     open my $fh, "<$file"
68     or die "$file: $!";
69    
70     my $data = <$fh>;
71     $data =~ s/^(\Q$beg\E\n).*?\n(\Q$end\E\n)/$1\n$contents$2/sm
72     or die "$file: couldn't find $beg/$end";
73    
74     open my $fh2, ">$file~"
75     or die "$file~: $!";
76    
77     syswrite $fh2, $data;
78     }
79    
80     rename "$file~", $file;
81     }
82    
83 root 1.7 for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling gl_texture)) {
84 root 1.1 open my $fh, "<getinfo.txt"
85     or die "getinfo.txt: $!";
86    
87     my $POD;
88 root 1.5 my @funcs;
89     my %alias;
90 root 1.1
91     while (<$fh>) {
92     chomp;
93 root 1.10 my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3;
94 root 1.1 next unless $class eq "cl_$CLASS\_info";
95     next if $name eq "CL_IMAGE_FORMAT"; # struct
96     next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls
97    
98     $ctype =~ s/cl:://g;
99     $ctype =~ s/::size_t/size_t/g;
100    
101     my $cbase = $class;
102     $cbase =~ s/_(.)/\U$1/g;
103 root 1.9 $cbase =~ s/Gl(?=[A-Z])/GL/g;
104 root 1.1 $cbase =~ s/^cl//;
105     $cbase =~ s/Info$//;
106     $cbase = "MemObject" if $cbase eq "Mem";
107     $cbase = "EventProfiling" if $cbase eq "Profiling";
108    
109     my $real_class = $CLASS;
110     $real_class = "program" if $real_class eq "program_build";
111     $real_class = "kernel" if $real_class eq "kernel_work_group";
112     $real_class = "event" if $real_class eq "profiling";
113    
114     my $perl_name = lc $name;
115     $perl_name =~ s/^cl_//;
116     $perl_name =~ s/^$real_class\_//;
117     $perl_name =~ s/^queue\_//;
118    
119     my $extra_args;
120     my $extra_perl_args;
121     my $extra_xs_args;
122    
123     if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") {
124     $extra_args = ', device';
125     $extra_perl_args = ' ($device)';
126     $extra_xs_args = ', OpenCL::Device device';
127     }
128    
129 root 1.14 if ($CLASS eq "kernel_arg") {
130     $extra_args = ', idx';
131     $extra_perl_args = ' ($idx)';
132     $extra_xs_args = ', cl_uint idx';
133     }
134    
135 root 1.1 my $dynamic;
136 root 1.3 my $nelem = "size / sizeof (*value)";
137 root 1.1
138     if ($ctype eq "STRING_CLASS") {
139     $ctype = "VECTOR_CLASS<char>";
140     $nelem = "1";
141     $dynamic = 1;
142     }
143    
144     my $type = $ctype;
145     my $array = 0;
146    
147     if ($type =~ s/^VECTOR_CLASS<\s*(.*)>$/$1/) {
148     $dynamic = 1;
149     $array = 1;
150     } elsif ($type =~ s/<(\d+)>$//) {
151     $dynamic = 1;
152     $array = 1;
153     }
154    
155     $type = $typemap{$type}
156     or die "$name: no mapping for $ctype";
157    
158     my $perltype = $type->[2];
159    
160     if ($array && $nelem ne "1") {
161     $perltype = "\@${perltype}s";
162     } else {
163     $perltype = "\$$perltype";
164     }
165    
166 root 1.13 (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die;
167    
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";
169 root 1.1
170 root 1.5 # 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    
175     $XS1 = "void\n"
176 root 1.6 . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
177 root 1.5 $XS2 = " PPCODE:\n";
178 root 1.1
179     if ($dynamic) {
180 root 1.5 $XS2 .= " size_t size;\n"
181 root 1.6 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n"
182 root 1.5 . " $type->[0] *value = tmpbuf (size);\n"
183 root 1.6 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n";
184 root 1.1 } else {
185 root 1.5 $XS2 .= " $type->[0] value [1];\n"
186 root 1.6 . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
187 root 1.1 }
188    
189 root 1.5 if ($array && $nelem ne "1") {
190     $XS2 .= " int i, n = $nelem;\n"
191     . " EXTEND (SP, n);\n"
192     . " for (i = 0; i < n; ++i)\n";
193 root 1.1 } else {
194 root 1.5 $XS2 .= " EXTEND (SP, 1);\n"
195     . " const int i = 0;\n"
196 root 1.1 }
197    
198     if ($type->[1] =~ /^OpenCL::(\S+)$/) {
199     my $oclass = $1;
200     $oclass = "MemObject" if $oclass eq "Memory";
201     $oclass = "CommandQueue" if $oclass eq "Queue";
202    
203 root 1.12 my $stash = lc $type->[1];
204     $stash =~ s/opencl:://;
205     $stash =~ s/::/_/g;
206    
207 root 1.5 $XS2 .= " {\n";
208 root 1.12 $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" || $oclass eq "Device";
209     $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
210 root 1.5 $XS2 .= " }\n";
211 root 1.1 } else {
212 root 1.5 $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
213 root 1.1 }
214    
215 root 1.5 $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     }
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 root 1.1 }
239    
240 root 1.7 warn "patching class $CLASS\n";
241    
242 root 1.1 patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS;
243 root 1.2 patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
244 root 1.1 }
245