view release on metacpan or  search on metacpan

gengetinfo  view on Meta::CPAN

      $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] };
      }