[ViewVC] Diff of: cvs/OpenCL/gengetinfo

Comparing OpenCL/gengetinfo (file contents):
Revision 1.3 by root, Sun Nov 20 22:29:36 2011 UTC vs.
Revision 1.17 by root, Sat May 5 13:30:07 2012 UTC

    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_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'],
 );
 {
    my %tmap = (
       T_IV => "newSViv (value [i])",
    }
    rename "$file~", $file;
 }
-for my $CLASS (qw(platform device context command_queue mem image sampler program program_build kernel kernel_work_group event profiling)) {
+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 $XS;
    my $POD;
+   my @funcs;
+   my %alias;
    while (<$fh>) {
       chomp;
-      my ($class, $name, $ctype) = split /,\s*/, $_, 3;
+      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\_//;
       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)";
          $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<$name> and returns the result(s).\n\n";
+      $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);
-      $XS .= "void\n"
+      $XS1 = "void\n"
-           . "$perl_name (OpenCL::$classmap{$real_class} this$extra_xs_args)\n"
+           . "XXXNAMEXXX (OpenCL::$classmap{$real_class} self$extra_xs_args)\n";
-           . " PPCODE:\n";
+      $XS2 = " PPCODE:\n";
       if ($dynamic) {
-        $XS .= " size_t size;\n"
+        $XS2 .= " size_t size;\n"
-             . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name,    0,     0, &size));\n"
+              . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix,    0,     0, &size));\n"
-             . " $type->[0] *value = tmpbuf (size);\n"
+              . " $type->[0] *value = tmpbuf (size);\n"
-             . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, size, value,     0));\n";
+             . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, size, value,     0));\n";
       } else {
-        $XS .= " $type->[0] value [1];\n"
+        $XS2 .= " $type->[0] value [1];\n"
-             . " NEED_SUCCESS (Get${cbase}Info, (this$extra_args, $name, sizeof (value), value, 0));\n";
+              . " NEED_SUCCESS (Get${cbase}Info, (self$extra_args, ix, sizeof (value), value, 0));\n";
       }
-      if ($array) {
+      if ($array && $nelem ne "1") {
-         $XS .= " int i, n = $nelem;\n"
+         $XS2 .= " int i, n = $nelem;\n"
-              . " EXTEND (SP, n);\n"
+               . " EXTEND (SP, n);\n"
-              . " for (i = 0; i < n; ++i)\n";
+               . " for (i = 0; i < n; ++i)\n";
       } else {
-         $XS .= " EXTEND (SP, 1);\n"
+         $XS2 .= " EXTEND (SP, 1);\n"
-              . " const int i = 0;\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;
-         $XS .= " {\n";
+         $XS2 .= " {\n";
-         $XS .= "   NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $1 eq "Platform" || $1 eq "Device";
+         $XS2 .= "   NEED_SUCCESS (Retain$oclass, (value [i]));\n" unless $oclass eq "Platform" || $oclass eq "Device";
-         $XS .= "   PUSHs (NEW_MORTAL_OBJ (\"$type->[1]\", value [i]));\n";
+         $XS2 .= "   PUSH_CLOBJ (stash_$stash, value [i]);\n";
-         $XS .= " }\n";
+         $XS2 .= " }\n";
       } else {
-         $XS .= " PUSHs (sv_2mortal ($type->[1]));\n";
+         $XS2 .= " PUSHs (sv_2mortal ($type->[1]));\n";
       }
-      $XS .= "\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 "", 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;
 }

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing OpenCL/gengetinfo (file contents): Revision 1.3 by root, Sun Nov 20 22:29:36 2011 UTC vs. Revision 1.17 by root, Sat May 5 13:30:07 2012 UTC

Diff Legend

Comparing OpenCL/gengetinfo (file contents):
Revision 1.3 by root, Sun Nov 20 22:29:36 2011 UTC vs.
Revision 1.17 by root, Sat May 5 13:30:07 2012 UTC