[ViewVC] Annotation of: cvs/OpenCL/gengetinfo

#!/opt/bin/perl

# almost every "if" or "?" in this file indicates a place where the OpenCL
# designers fucked it up - each time you have to remember an exception to
# the naming rules.

use common::sense;

my %classmap = qw(
   platform          Platform
   device            Device
   context           Context
   event             Event
   profiling         Event
   mem               Memory
   image             Image
   gl_texture        Image
   sampler           Sampler
   program           Program
   program_build     Program
   kernel            Kernel
   kernel_work_group Kernel
   kernel_arg_info   Kernel
   command_queue     Queue
);

my %typemap = (
   # getinfo.txt        c type, constructor, pod
   cl_bool         => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'],
   #char            => ['char', 'newSVpvn (value, size)', 'string'],
   char            => ['char', 'newSVpv (value, 0)', 'string'], # all these are 0-terminated strings, and the driver often appends a \0
   size_t          => ['size_t', 'newSVuv (value [i])', 'int'],
   "void*"         => ['void *', 'newSVuv ((IV)(intptr_t)value [i])', 'ptr_value'],
   cl_platform_id  => ['cl_platform_id', 'OpenCL::Platform'],
   Context         => ['cl_context', 'OpenCL::Context', 'ctx'],
   Device          => ['cl_device_id', 'OpenCL::Device', 'device'],
   cl_device_id    => ['cl_device_id', 'OpenCL::Device', 'device'],
   Memory          => ['cl_mem', 'OpenCL::Memory', 'mem'],
   Program         => ['cl_program', 'OpenCL::Program', 'program'],
   CommandQueue    => ['cl_command_queue', 'OpenCL::Queue', 'queue'],
   cl_context_properties => ['cl_context_properties', 'newSVuv ((UV)value [i])', 'property_int'],
   cl_program_binary_type => ['cl_program_binary_type', 'newSVuv ((UV)value [i])', 'binary_type'],
);


# try to re-use types with same representation in C - if we
# ever overload bitfields etc. then we need to remove all
# typesimplify code.
my %typesimplify;
{
   open my $h, "<CL/cl.h" or die "CL/cl.h: $!";

   while (<$h>) {
      $typesimplify{$2} = $1
         if /typedef\s+(cl_\S+)\s+(cl_\S+);/;
   }
}

{
   my %tmap = (
      T_IV => "newSViv (value [i])",
      T_UV => "newSVuv (value [i])",
   );

   open my $fh, "<typemap"
      or die "typemap: $!";

   while (<$fh>) {
      next if /^INPUT$/;
      my ($name, $type) = split /\s+/, $_;
      if ($tmap{$type}) {
         $typemap{$name} = [$name, $tmap{$type}, substr $name, 3];
      }
   }
}

sub patch($$$$) {
   my ($file, $beg, $end, $contents) = @_;

   {
      local $/;

      open my $fh, "<$file"
         or die "$file: $!";

      my $data = <$fh>;
      $data =~ s/^(\Q$beg\E\n).*?\n(\Q$end\E\n)/$1\n$contents$2/sm
         or die "$file: couldn't find $beg/$end";

      open my $fh2, ">$file~"
         or die "$file~: $!";

      syswrite $fh2, $data;
   }

   rename "$file~", $file;
}

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)) {
   open my $fh, "<getinfo.txt"
      or die "getinfo.txt: $!";

   my $POD;
   my @funcs;
   my %alias;

   while (<$fh>) {
      chomp;
      my ($class, $name, $ctype) = split /\s*,\s*/, $_, 3;
      next unless $class eq "cl_$CLASS\_info";
      next if $name eq "CL_IMAGE_FORMAT"; # struct
      next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls

      $ctype =~ s/cl:://g;
      $ctype =~ s/::size_t/size_t/g;

      my $cbase = $class;
      $cbase =~ s/_(.)/\U$1/g;
      $cbase =~ s/Gl(?=[A-Z])/GL/g;
      $cbase =~ s/^cl//;
      $cbase =~ s/Info$//;
      $cbase = "MemObject"      if $cbase eq "Mem";
      $cbase = "EventProfiling" if $cbase eq "Profiling";

      my $real_class = $CLASS;
      $real_class = "program" if $real_class eq "program_build";
      $real_class = "kernel"  if $real_class eq "kernel_work_group";
      $real_class = "kernel"  if $real_class eq "kernel_arg";
      $real_class = "event"   if $real_class eq "profiling";

      my $perl_name = lc $name;
      $perl_name =~ s/^cl_//;
      $perl_name =~ s/^$real_class\_//;
      $perl_name =~ s/^queue\_//;

      my $extra_args;
      my $extra_perl_args;
      my $extra_xs_args;

      if ($CLASS eq "program_build" || $CLASS eq "kernel_work_group") {
         $extra_args      = ', device';
         $extra_perl_args = ' ($device)';
         $extra_xs_args   = ', OpenCL::Device device';
      }

      if ($CLASS eq "kernel_arg") {
         $extra_args      = ', idx';
         $extra_perl_args = ' ($idx)';
         $extra_xs_args   = ', cl_uint idx';
      }

      my $dynamic;
      my $nelem = "size / sizeof (*value)";

      if ($ctype eq "STRING_CLASS") {
         $ctype   = "VECTOR_CLASS<char>";
         $nelem   = "1";
         $dynamic = 1;
      }

      my $type = $ctype;
      my $array = 0;

      if ($type =~ s/^VECTOR_CLASS<\s*(.*)>$/$1/) {
         $dynamic = 1;
         $array   = 1;
      } elsif ($type =~ s/<(\d+)>$//) {
         $dynamic = 1;
         $array   = 1;
      }

      $type = $typemap{$type}
         or die "$name: no mapping for $ctype";

      my $perltype = $type->[2];

      if ($array && $nelem ne "1") {
         $perltype = "\@${perltype}s";
      } else {
         $perltype = "\$$perltype";
      }

      (my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die;

      $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";

      # XS1 contains the function before ALIAS, XS2 the function afterwards (the body)
      # after we generate the bdoy we look for an identical body generated earlier
      # and simply alias us to the earlier xs function, to save text size.
      my ($XS1, $XS2);

      $XS1 = "void\n"
           . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
      $XS2 = " PPCODE:\n";

      my $stype = $type->[0]; # simplified type
      $stype = $typesimplify{$stype} while exists $typesimplify{$stype};

      if ($dynamic) {
        $XS2 .= " size_t size;\n"
              . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix,    0,     0, &size));\n"
              . " $stype *value = tmpbuf (size);\n"
             . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value,     0));\n";
      } else {
        $XS2 .= " $stype value [1];\n"
              . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
      }
      
      if ($array && $nelem ne "1") {
         $XS2 .= " int i, n = $nelem;\n"
               . " EXTEND (SP, n);\n"
               . " for (i = 0; i < n; ++i)\n";
      } else {
         $XS2 .= " EXTEND (SP, 1);\n"
               . " const int i = 0;\n"
      }

      if ($type->[1] =~ /^OpenCL::(\S+)$/) {
         my $oclass = $1;
         $oclass = "MemObject"    if $oclass eq "Memory";
         $oclass = "CommandQueue" if $oclass eq "Queue";

         my $stash = lc $type->[1];
         $stash =~ s/opencl:://;
         $stash =~ s/::/_/g;

         $XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" || $oclass eq "Device";
         $XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
      } else {
         $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
      }

      $XS2 .= "\n";

      if (my $alias = $alias{"$XS1$XS2"}) {
         push @$alias, [$perl_name, $name];
      } else {
         push @funcs, [$XS1, (my $alias = [[$perl_name, $name]]), $XS2];
         $alias{"$XS1$XS2"} = $alias;
      }
   }

   my $XS;

   # this very dirty and ugly code is a very dirty and ugly code size optimisation.
   for (@funcs) {
      $_->[0] =~s /^XXXNAMEXXX/$_->[1][0][0]/m;

      if (@{ $_->[1] } == 1) { # undo ALIAS
         $_->[2] =~ s/\bix\b/$_->[1][0][1]/g;
         $_->[1] = "";
      } else {
         $_->[1] = " ALIAS:\n" . join "", sort, map " $_->[0] = $_->[1]\n", @{ $_->[1] };
      }
      $XS .= join "", @$_;
   }

   warn "patching class $CLASS\n";

   patch "OpenCL.xs", "#BEGIN:$CLASS"               , "#END:$CLASS"               , $XS;
   patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
}

Revision:	1.19
Committed:	Sat May 5 15:43:02 2012 UTC (12 years ago) by root
Branch:	MAIN
CVS Tags:	rel-1_0, rel-1_01, HEAD
Changes since 1.18:	+22 -7 lines
Log Message:	* empty log message *
#	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	root	1.17	# getinfo.txt c type, constructor, pod
29	root	1.1	cl_bool => ['cl_bool', 'value [i] ? &PL_sv_yes : &PL_sv_no', 'boolean'],
30			#char => ['char', 'newSVpvn (value, size)', 'string'],
31			char => ['char', 'newSVpv (value, 0)', 'string'], # all these are 0-terminated strings, and the driver often appends a \0
32			size_t => ['size_t', 'newSVuv (value [i])', 'int'],
33			"void" => ['void ', 'newSVuv ((IV)(intptr_t)value [i])', 'ptr_value'],
34			cl_platform_id => ['cl_platform_id', 'OpenCL::Platform'],
35			Context => ['cl_context', 'OpenCL::Context', 'ctx'],
36			Device => ['cl_device_id', 'OpenCL::Device', 'device'],
37			cl_device_id => ['cl_device_id', 'OpenCL::Device', 'device'],
38			Memory => ['cl_mem', 'OpenCL::Memory', 'mem'],
39			Program => ['cl_program', 'OpenCL::Program', 'program'],
40			CommandQueue => ['cl_command_queue', 'OpenCL::Queue', 'queue'],
41			cl_context_properties => ['cl_context_properties', 'newSVuv ((UV)value [i])', 'property_int'],
42	root	1.18	cl_program_binary_type => ['cl_program_binary_type', 'newSVuv ((UV)value [i])', 'binary_type'],
43	root	1.1	);
44
45	root	1.19
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			}
58
59	root	1.1	{
60			my %tmap = (
61			T_IV => "newSViv (value [i])",
62			T_UV => "newSVuv (value [i])",
63			);
64
65			open my $fh, "<typemap"
66			or die "typemap: $!";
67
68			while (<$fh>) {
69			next if /^INPUT$/;
70			my ($name, $type) = split /\s+/, $_;
71			if ($tmap{$type}) {
72			$typemap{$name} = [$name, $tmap{$type}, substr $name, 3];
73			}
74			}
75			}
76
77			sub patch($$$$) {
78			my ($file, $beg, $end, $contents) = @_;
79
80			{
81			local $/;
82
83			open my $fh, "<$file"
84			or die "$file: $!";
85
86			my $data = <$fh>;
87			$data =~ s/^(\Q$beg\E\n).*?\n(\Q$end\E\n)/$1\n$contents$2/sm
88			or die "$file: couldn't find $beg/$end";
89
90			open my $fh2, ">$file~"
91			or die "$file~: $!";
92
93			syswrite $fh2, $data;
94			}
95
96			rename "$file~", $file;
97			}
98
99	root	1.16	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)) {
100	root	1.1	open my $fh, "<getinfo.txt"
101			or die "getinfo.txt: $!";
102
103			my $POD;
104	root	1.5	my @funcs;
105			my %alias;
106	root	1.1
107			while (<$fh>) {
108			chomp;
109	root	1.10	my ($class, $name, $ctype) = split /\s,\s/, $_, 3;
110	root	1.1	next unless $class eq "cl_$CLASS\_info";
111			next if $name eq "CL_IMAGE_FORMAT"; # struct
112			next if $name eq "CL_PROGRAM_BINARIES"; # needs multiple calls
113
114			$ctype =~ s/cl:://g;
115			$ctype =~ s/::size_t/size_t/g;
116
117			my $cbase = $class;
118			$cbase =~ s/_(.)/\U$1/g;
119	root	1.9	$cbase =~ s/Gl(?=[A-Z])/GL/g;
120	root	1.1	$cbase =~ s/^cl//;
121			$cbase =~ s/Info$//;
122			$cbase = "MemObject" if $cbase eq "Mem";
123			$cbase = "EventProfiling" if $cbase eq "Profiling";
124
125			my $real_class = $CLASS;
126			$real_class = "program" if $real_class eq "program_build";
127			$real_class = "kernel" if $real_class eq "kernel_work_group";
128	root	1.16	$real_class = "kernel" if $real_class eq "kernel_arg";
129	root	1.1	$real_class = "event" if $real_class eq "profiling";
130
131			my $perl_name = lc $name;
132			$perl_name =~ s/^cl_//;
133			$perl_name =~ s/^$real_class\_//;
134			$perl_name =~ s/^queue\_//;
135
136			my $extra_args;
137			my $extra_perl_args;
138			my $extra_xs_args;
139
140			if ($CLASS eq "program_build" \|\| $CLASS eq "kernel_work_group") {
141			$extra_args = ', device';
142			$extra_perl_args = ' ($device)';
143			$extra_xs_args = ', OpenCL::Device device';
144			}
145
146	root	1.14	if ($CLASS eq "kernel_arg") {
147			$extra_args = ', idx';
148			$extra_perl_args = ' ($idx)';
149			$extra_xs_args = ', cl_uint idx';
150			}
151
152	root	1.1	my $dynamic;
153	root	1.3	my $nelem = "size / sizeof (*value)";
154	root	1.1
155			if ($ctype eq "STRING_CLASS") {
156			$ctype = "VECTOR_CLASS<char>";
157			$nelem = "1";
158			$dynamic = 1;
159			}
160
161			my $type = $ctype;
162			my $array = 0;
163
164			if ($type =~ s/^VECTOR_CLASS<\s(.)>$/$1/) {
165			$dynamic = 1;
166			$array = 1;
167			} elsif ($type =~ s/<(\d+)>$//) {
168			$dynamic = 1;
169			$array = 1;
170			}
171
172			$type = $typemap{$type}
173			or die "$name: no mapping for $ctype";
174
175			my $perltype = $type->[2];
176
177			if ($array && $nelem ne "1") {
178			$perltype = "\@${perltype}s";
179			} else {
180			$perltype = "\$$perltype";
181			}
182
183	root	1.13	(my $perlenum = $name) =~ s/^CL_/OpenCL::/ or die;
184
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";
186	root	1.1
187	root	1.5	# XS1 contains the function before ALIAS, XS2 the function afterwards (the body)
188			# after we generate the bdoy we look for an identical body generated earlier
189			# and simply alias us to the earlier xs function, to save text size.
190			my ($XS1, $XS2);
191
192			$XS1 = "void\n"
193	root	1.6	. "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
194	root	1.5	$XS2 = " PPCODE:\n";
195	root	1.1
196	root	1.19	my $stype = $type->[0]; # simplified type
197			$stype = $typesimplify{$stype} while exists $typesimplify{$stype};
198
199	root	1.1	if ($dynamic) {
200	root	1.5	$XS2 .= " size_t size;\n"
201	root	1.6	. " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, 0, 0, &size));\n"
202	root	1.19	. " $stype *value = tmpbuf (size);\n"
203	root	1.6	. " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value, 0));\n";
204	root	1.1	} else {
205	root	1.19	$XS2 .= " $stype value [1];\n"
206	root	1.6	. " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
207	root	1.1	}
208
209	root	1.5	if ($array && $nelem ne "1") {
210			$XS2 .= " int i, n = $nelem;\n"
211			. " EXTEND (SP, n);\n"
212			. " for (i = 0; i < n; ++i)\n";
213	root	1.1	} else {
214	root	1.5	$XS2 .= " EXTEND (SP, 1);\n"
215			. " const int i = 0;\n"
216	root	1.1	}
217
218			if ($type->[1] =~ /^OpenCL::(\S+)$/) {
219			my $oclass = $1;
220			$oclass = "MemObject" if $oclass eq "Memory";
221			$oclass = "CommandQueue" if $oclass eq "Queue";
222
223	root	1.12	my $stash = lc $type->[1];
224			$stash =~ s/opencl:://;
225			$stash =~ s/::/_/g;
226
227	root	1.19	$XS2 .= " NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" \|\| $oclass eq "Device";
228			$XS2 .= " PUSH_CLOBJ (stash_$stash, value [i]);\n";
229	root	1.1	} else {
230	root	1.5	$XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
231	root	1.1	}
232
233	root	1.5	$XS2 .= "\n";
234
235			if (my $alias = $alias{"$XS1$XS2"}) {
236			push @$alias, [$perl_name, $name];
237			} else {
238			push @funcs, [$XS1, (my $alias = [[$perl_name, $name]]), $XS2];
239			$alias{"$XS1$XS2"} = $alias;
240			}
241			}
242
243			my $XS;
244
245			# this very dirty and ugly code is a very dirty and ugly code size optimisation.
246			for (@funcs) {
247			$_->[0] =~s /^XXXNAMEXXX/$_->[1][0][0]/m;
248
249			if (@{ $_->[1] } == 1) { # undo ALIAS
250			$_->[2] =~ s/\bix\b/$_->[1][0][1]/g;
251			$_->[1] = "";
252			} else {
253	root	1.19	$_->[1] = " ALIAS:\n" . join "", sort, map " $_->[0] = $_->[1]\n", @{ $_->[1] };
254	root	1.5	}
255			$XS .= join "", @$_;
256	root	1.1	}
257
258	root	1.7	warn "patching class $CLASS\n";
259
260	root	1.1	patch "OpenCL.xs", "#BEGIN:$CLASS" , "#END:$CLASS" , $XS;
261	root	1.2	patch "OpenCL.pm", "=for gengetinfo begin $CLASS", "=for gengetinfo end $CLASS", $POD;
262	root	1.1	}
263