dlls/opencl/make_opencl

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use XML::LibXML;
   4
   5 # Copyright 2021 Zebediah Figura
   6 #
   7 # This library is free software; you can redistribute it and/or
   8 # modify it under the terms of the GNU Lesser General Public
   9 # License as published by the Free Software Foundation; either
  10 # version 2.1 of the License, or (at your option) any later version.
  11 #
  12 # This library is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # Lesser General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU Lesser General Public
  18 # License along with this library; if not, write to the Free Software
  19 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
  20
  21 # Files to generate
  22 my $spec_file = "opencl.spec";
  23 my $pe_file = "pe_thunks.c";
  24 my $types_file = "opencl_types.h";
  25 my $unix_file = "unix_thunks.c";
  26 my $unixheader_file = "unixlib.h";
  27
  28 # If set to 1, generate TRACEs for each OpenGL function
  29 my $gen_traces = 1;
  30
  31 # List of categories to put in the 'opengl_core.c' file
  32 my %cat_1_0 = ( "CL_VERSION_1_0" => 1 );
  33 my %cat_1_1 = ( %cat_1_0, "CL_VERSION_1_1" => 1 );
  34 my %cat_1_2 = ( %cat_1_1, "CL_VERSION_1_2" => 1 );
  35
  36 my %core_categories = ();
  37
  38 my %arg_types =
  39     (
  40         #                      spec      unixlib         format
  41         "cl_bitfield"    => [ "int64",  "ULONGLONG",    "wine_dbgstr_longlong(%s)" ],
  42         "double"         => [ "double", "DOUBLE",       "%.16e" ],
  43         "float"          => [ "float",  "float",        "%.8e" ],
  44         "int"            => [ "long",   "int",          "%d" ],
  45         "int8_t"         => [ "long",   "int8_t",       "%d" ],
  46         "int16_t"        => [ "long",   "int16_t",      "%d" ],
  47         "int32_t"        => [ "long",   "int32_t",      "%d" ],
  48         "int64_t"        => [ "int64",  "LONGLONG",     "wine_dbgstr_longlong(%s)" ],
  49         "intptr_t"       => [ "long",   "INT_PTR",      "%Id" ],
  50         "size_t"         => [ "long",   "SIZE_T",       "%Iu" ],
  51         "uint8_t"        => [ "long",   "uint8_t",      "%u" ],
  52         "uint16_t"       => [ "long",   "uint16_t",     "%u" ],
  53         "uint32_t"       => [ "long",   "uint32_t",     "%u" ],
  54         "uint64_t"       => [ "int64",  "ULONGLONG",    "wine_dbgstr_longlong(%s)" ],
  55         "unsigned int"   => [ "long",   "unsigned int", "%u" ],
  56     );
  57
  58 my %unsupported_extensions =
  59     (
  60         # Needs wined3d integration.
  61         "cl_intel_d3d11_nv12_media_sharing" => 1,
  62         "cl_intel_dx9_media_sharing" => 1,
  63         "cl_khr_d3d10_sharing" => 1,
  64         "cl_khr_d3d11_sharing" => 1,
  65         "cl_khr_dx9_media_sharing" => 1,
  66         "cl_nv_d3d9_sharing" => 1,
  67         "cl_nv_d3d10_sharing" => 1,
  68         "cl_nv_d3d11_sharing" => 1,
  69
  70         # Needs a loader/ICD split.
  71         "cl_khr_icd" => 1,
  72         "cl_loader_layers" => 1,
  73
  74         # Needs callback conversion.
  75         "cl_apple_setmemobjectdestructor" => 1,
  76         "cl_arm_shared_virtual_memory" => 1,
  77     );
  78
  79 sub generate_pe_thunk($$)
  80 {
  81     my ($name, $func_ref) = @_;
  82     my $call_arg = "";
  83     my $trace_call_arg = "";
  84     my $trace_arg = "";
  85
  86     my $ret = get_func_proto( "%s WINAPI %s(%s)", $name, $func_ref );
  87     my $proto = $func_ref->[0]->textContent();
  88     $proto =~ s/ +$//;
  89     foreach my $arg (@{$func_ref->[1]})
  90     {
  91         my $ptype = get_arg_type( $arg );
  92         next unless $arg->findnodes("./name");
  93         my $pname = get_arg_name( $arg );
  94         my $param = $arg->textContent();
  95         $call_arg .= " " . $pname . ",";
  96         if ($param =~ /\*/ || $param =~ /\[/)
  97         {
  98             $trace_arg .= ", %p";
  99             $trace_call_arg .= ", " . $pname;
 100         }
 101         elsif (defined $arg_types{$ptype})
 102         {
 103             my $format = ${$arg_types{$ptype}}[2];
 104             $trace_arg .= ", " . ($format =~ /^%/ ? $format : "%s");
 105             $trace_call_arg .= ", " . sprintf $format =~ /^%/ ? "%s" : $format, $pname;
 106         }
 107         else
 108         {
 109             die "Unknown type %s in %s\n", $param, $name;
 110         }
 111     }
 112     $call_arg =~ s/,$/ /;
 113     $trace_arg =~ s/^, //;
 114     $ret .= "\n{\n";
 115     if (is_void_func( $func_ref ))
 116     {
 117         $ret .= "    struct ${name}_params params = {$call_arg};\n";
 118         $ret .= "    TRACE( \"($trace_arg)\\n\"$trace_call_arg );\n" if $gen_traces;
 119         $ret .= "    OPENCL_CALL( $name, &params );\n"
 120     }
 121     elsif ($proto eq "cl_int")
 122     {
 123         $ret .= "    struct ${name}_params params = {$call_arg};\n";
 124         $ret .= "    TRACE( \"($trace_arg)\\n\"$trace_call_arg );\n" if $gen_traces;
 125         $ret .= "    return OPENCL_CALL( $name, &params );\n";
 126     }
 127     else
 128     {
 129         $ret .= "    $proto __retval;\n";
 130         $ret .= "    struct ${name}_params params = { &__retval,$call_arg};\n";
 131         $ret .= "    TRACE( \"($trace_arg)\\n\"$trace_call_arg );\n" if $gen_traces;
 132         $ret .= "    OPENCL_CALL( $name, &params );\n";
 133         $ret .= "    return __retval;\n";
 134     }
 135     $ret .= "}\n";
 136     return $ret;
 137 }
 138
 139 sub generate_unix_thunk($$)
 140 {
 141     my ($name, $func_ref) = @_;
 142     my $call_arg = "";
 143
 144     my $ret = "static NTSTATUS wrap_$name( void *args )\n";
 145     my $proto = $func_ref->[0]->textContent();
 146     $proto =~ s/ +$//;
 147     foreach my $arg (@{$func_ref->[1]})
 148     {
 149         my $ptype = get_arg_type( $arg );
 150         next unless $arg->findnodes("./name");
 151         my $pname = get_arg_name( $arg );
 152         my $param = $arg->textContent();
 153         $call_arg .= " params->" . $pname . ",";
 154     }
 155     $call_arg =~ s/,$/ /;
 156     $ret .= "{\n";
 157     $ret .= "    struct ${name}_params *params = args;\n\n" if $call_arg;
 158     if (is_void_func( $func_ref ))
 159     {
 160         $ret .= "    $name($call_arg);\n";
 161     }
 162     elsif ($proto eq "cl_int")
 163     {
 164         $ret .= "    return $name($call_arg);\n";
 165     }
 166     else
 167     {
 168         $ret .= "    *params->__retval = $name($call_arg);\n";
 169         $ret .= "    return STATUS_SUCCESS;\n";
 170     }
 171     $ret .= "}\n";
 172     return $ret;
 173 }
 174
 175 sub is_void_func($)
 176 {
 177     my $func = shift;
 178     return 0 if @{$func->[0]->findnodes("./type")};
 179     return $func->[0]->textContent() eq "void";
 180 }
 181
 182 sub get_arg_type($)
 183 {
 184     my $p = shift;
 185     my @type = $p->findnodes("./type");
 186     return @type ? $type[0]->textContent() : "cl_int";
 187 }
 188
 189 sub get_arg_name($)
 190 {
 191     my $p = shift;
 192     my @name = $p->findnodes("./name");
 193     return $name[0]->textContent();
 194 }
 195
 196 sub get_func_proto($$$)
 197 {
 198     my ($format, $name, $func) = @_;
 199     die "unknown func $name" unless defined $func->[0];
 200     my $proto = $func->[0]->textContent();
 201     $proto =~ s/ +$//;
 202     my $args = "";
 203     foreach my $arg (@{$func->[1]})
 204     {
 205         (my $argtext = $arg->textContent()) =~ s/ +/ /g;
 206         $argtext =~ s/CL_CALLBACK/WINAPI/g;
 207         $args .= " " . $argtext . ",";
 208     }
 209     $args =~ s/,$/ /;
 210     $args ||= "void";
 211     return sprintf $format, $proto, $name, $args;
 212 }
 213
 214 sub get_func_params($$)
 215 {
 216     my ($name, $func) = @_;
 217     die "unknown func $name" unless defined $func->[0];
 218     my $proto = $func->[0]->textContent();
 219     $proto =~ s/ +$//;
 220     my $params = "struct ${name}_params\n{\n";
 221     $params .= "    $proto* __retval;\n" unless $proto eq "cl_int";
 222     foreach my $arg (@{$func->[1]})
 223     {
 224         my $ptype = get_arg_type( $arg );
 225         next unless $arg->findnodes("./name");
 226         my $pname = get_arg_name( $arg );
 227         (my $param = $arg->textContent()) =~ s/ +/ /g;
 228         $param =~ s/CL_CALLBACK/WINAPI/g;
 229         if ($param =~ /[[*]/)
 230         {
 231             $params .= "    $param;\n";
 232         }
 233         elsif (defined $arg_types{$ptype})
 234         {
 235             $params .= "    ${$arg_types{$ptype}}[1] $pname;\n";
 236         }
 237         else
 238         {
 239             die "Unknown type %s in %s\n", $param, $name;
 240         }
 241     }
 242     return $params . "};\n";
 243 }
 244
 245 # extract and check the number of arguments
 246 if (@ARGV > 1)
 247 {
 248     my $name0 = $0;
 249     $name0 =~ s%^.*/%%;
 250     die "Usage: $name0 [version]\n";
 251 }
 252 my $version = $ARGV[0] || "1.2";
 253 if ($version eq "1.0")
 254 {
 255     %core_categories = %cat_1_0;
 256 }
 257 elsif ($version eq "1.1")
 258 {
 259     %core_categories = %cat_1_1;
 260 }
 261 elsif ($version eq "1.2")
 262 {
 263     %core_categories = %cat_1_2;
 264 }
 265 else
 266 {
 267     die "Incorrect OpenCL version.\n";
 268 }
 269
 270 my $url = "https://raw.githubusercontent.com/KhronosGroup/OpenCL-Docs";
 271 my $commit = "514965312a65e5d01ae17e23119dc95427b7149e";
 272 -f "cl-$commit.xml" || system "wget", "-O", "cl-$commit.xml", "$url/$commit/xml/cl.xml" || die "cannot download cl.xml";
 273
 274 sub generate_spec_entry($$)
 275 {
 276     my ($name, $func) = @_;
 277     my $args=" ";
 278     foreach my $arg (@{$func->[1]})
 279     {
 280         my $ptype = get_arg_type( $arg );
 281         my $param = $arg->textContent();
 282         if ($param =~ /[[*]/)
 283         {
 284             $args .= "ptr ";
 285         }
 286         elsif (defined($arg_types{$ptype}))
 287         {
 288             $args .= "$@$arg_types{$ptype}[0] ";
 289         }
 290         elsif ($ptype ne "void")
 291         {
 292             die "No conversion for func $name type $param\n";
 293         }
 294     }
 295     $args = substr($args,1,-1);
 296     return "@ stdcall $_($args)";
 297 }
 298
 299 my %core_functions;
 300 my %header_enums;
 301 my (%header_types, @header_types);  # also use an array to preserve declaration order
 302
 303 # some functions need a hand-written wrapper
 304 sub needs_pe_wrapper($)
 305 {
 306     my %funcs =
 307         (
 308             # need extension filtering
 309             "clGetDeviceInfo" => 1,
 310             "clGetPlatformInfo" => 1,
 311
 312             # needs function pointer conversion
 313             "clGetExtensionFunctionAddress" => 1,
 314             "clGetExtensionFunctionAddressForPlatform" => 1,
 315
 316             # deprecated and absent from headers
 317             "clSetCommandQueueProperty" => 1,
 318
 319             # needs GL object unwrapping
 320             "clCreateFromGLBuffer" => 1,
 321             "clCreateFromGLRenderbuffer" => 1,
 322             "clCreateFromGLTexture" => 1,
 323             "clCreateFromGLTexture2D" => 1,
 324             "clCreateFromGLTexture3D" => 1,
 325             "clEnqueueAcquireGLObjects" => 1,
 326             "clEnqueueReleaseGLObjects" => 1,
 327             "clGetGLObjectInfo" => 1,
 328             "clGetGLTextureInfo" => 1,
 329         );
 330     my $name = shift;
 331
 332     return defined $funcs{$name};
 333 }
 334
 335 # some functions need a hand-written wrapper
 336 sub needs_unix_wrapper($)
 337 {
 338     my %funcs =
 339         (
 340             # need callback conversion
 341             "clBuildProgram" => 1,
 342             "clCompileProgram" => 1,
 343             "clCreateContext" => 1,
 344             "clCreateContextFromType" => 1,
 345             "clEnqueueNativeKernel" => 1,
 346             "clLinkProgram" => 1,
 347             "clSetEventCallback" => 1,
 348             "clSetMemObjectDestructorCallback" => 1,
 349         );
 350     my $name = shift;
 351
 352     return defined $funcs{$name};
 353 }
 354
 355 # don't bother putting unused functions in the interface
 356 sub needs_unix_function($)
 357 {
 358     my %funcs =
 359         (
 360             "clGetExtensionFunctionAddress" => 1,
 361             "clGetExtensionFunctionAddressForPlatform" => 1,
 362             "clSetCommandQueueProperty" => 1,
 363
 364             # not yet implemented
 365             "clCreateFromGLBuffer" => 1,
 366             "clCreateFromGLRenderbuffer" => 1,
 367             "clCreateFromGLTexture" => 1,
 368             "clCreateFromGLTexture2D" => 1,
 369             "clCreateFromGLTexture3D" => 1,
 370             "clEnqueueAcquireGLObjects" => 1,
 371             "clEnqueueReleaseGLObjects" => 1,
 372             "clGetGLObjectInfo" => 1,
 373             "clGetGLTextureInfo" => 1,
 374         );
 375     my $name = shift;
 376
 377     return not defined $funcs{$name};
 378 }
 379
 380 sub generate_struct($)
 381 {
 382     my $type = shift;
 383     my $name = $type->{name};
 384     my $ret = "typedef struct _$name\n{\n";
 385     foreach my $member ($type->findnodes("./member"))
 386     {
 387         ($member = $member->textContent()) =~ s/ +/ /g;
 388         $ret .= "    $member;\n";
 389     }
 390     $ret .= "} $name;\n";
 391     return $ret;
 392 }
 393
 394 my %all_functions;
 395 my %all_enums;
 396 my %all_types;
 397
 398 sub parse_feature($$)
 399 {
 400     my ($feature, $is_core) = @_;
 401
 402     my %extra_core_functions =
 403         (
 404             # these are not core, but exported from the loader anyway
 405             "clCreateFromGLBuffer" => 1,
 406             "clCreateFromGLRenderbuffer" => 1,
 407             "clCreateFromGLTexture" => 1,
 408             "clCreateFromGLTexture2D" => 1,
 409             "clCreateFromGLTexture3D" => 1,
 410             "clEnqueueAcquireGLObjects" => 1,
 411             "clEnqueueReleaseGLObjects" => 1,
 412             "clGetGLObjectInfo" => 1,
 413             "clGetGLTextureInfo" => 1,
 414         );
 415
 416     foreach my $cmd ($feature->findnodes("./require/command"))
 417     {
 418         # TODO: store these in a separate list
 419         next unless $is_core or defined $extra_core_functions{$cmd->{name}};
 420
 421         $core_functions{$cmd->{name}} = $all_functions{$cmd->{name}};
 422     }
 423     foreach my $enum ($feature->findnodes("./require/enum"))
 424     {
 425         $header_enums{$enum->{name}} = $all_enums{$enum->{name}};
 426     }
 427     foreach my $type ($feature->findnodes("./require/type"))
 428     {
 429         next unless $all_types{$type->{name}};
 430         push @header_types, $type->{name} unless $header_types{$type->{name}};
 431         $header_types{$type->{name}} = $all_types{$type->{name}};
 432     }
 433 }
 434
 435 sub parse_file($)
 436 {
 437     my $file = shift;
 438     my $xml = XML::LibXML->load_xml( location => $file );
 439
 440     # save all functions
 441     foreach my $command ($xml->findnodes("/registry/commands/command"))
 442     {
 443         my $proto = @{$command->findnodes("./proto")}[0];
 444         my $name = @{$command->findnodes("./proto/name")}[0];
 445         $proto->removeChild( $name );
 446         my @params = $command->findnodes("./param");
 447         $all_functions{$name->textContent()} = [ $proto, \@params ];
 448     }
 449
 450     # save all enums
 451     foreach my $enum ($xml->findnodes("/registry/enums/enum"))
 452     {
 453         if (defined $enum->{value})
 454         {
 455             $all_enums{$enum->{name}} = $enum->{value};
 456         }
 457         else
 458         {
 459             $all_enums{$enum->{name}} = "(1 << " . $enum->{bitpos} . ")";
 460         }
 461     }
 462
 463     # save all types
 464     foreach my $type ($xml->findnodes("/registry/types/type"))
 465     {
 466         if ($type->{category} eq "define")
 467         {
 468             my $name = @{$type->findnodes("./name")}[0];
 469             $name = $name->textContent;
 470             $all_types{$name} = $type;
 471
 472             my $basetype = @{$type->findnodes("./type")}[0];
 473             if ($type->textContent() =~ /[[*]/)
 474             {
 475                 $arg_types{$name} = ["ptr", $name, "%p"];
 476             }
 477             elsif (defined($basetype) and defined($arg_types{$basetype->textContent}))
 478             {
 479                 $arg_types{$name} = $arg_types{$basetype->textContent};
 480             }
 481             elsif ($name ne "cl_icd_dispatch")
 482             {
 483                 die "No conversion for type $name\n"
 484             }
 485         }
 486         elsif ($type->{category} eq "struct")
 487         {
 488             my $name = $type->{name};
 489             $all_types{$name} = $type;
 490         }
 491     }
 492
 493     # generate core functions
 494     foreach my $feature ($xml->findnodes("/registry/feature"))
 495     {
 496         parse_feature($feature, 1) if defined $core_categories{$feature->{name}};
 497     }
 498
 499     # generate extension list and functions
 500     foreach my $ext ($xml->findnodes("/registry/extensions/extension"))
 501     {
 502         # we currently don't support clGetExtensionFunctionAddress, and
 503         # implementing clGetExtensionFunctionAddressForPlatform is nontrivial;
 504         # we need to generate a table of thunks per platform and retrieve the
 505         # platform from the called object
 506         $unsupported_extensions{lc($ext->{name})} = 1 if $ext->findnodes("./require/command");
 507
 508         # FIXME: Parse all supported extensions. Note that we don't actually
 509         # support KHR_gl_sharing yet, but we need to export the functions anyway
 510         # (some applications expect them to be present).
 511         parse_feature($ext, 0) if lc($ext->{name}) eq "cl_khr_gl_sharing";
 512     }
 513 }
 514
 515 parse_file( "cl-$commit.xml" );
 516
 517 # generate the spec file
 518 open(SPEC, ">$spec_file") or die "cannot create $spec_file";
 519
 520 foreach (sort keys %core_functions)
 521 {
 522     printf SPEC "%s\n", generate_spec_entry( $_, $core_functions{$_} );
 523 }
 524
 525 close(SPEC);
 526
 527
 528 # generate the PE thunks
 529 open(PE, ">$pe_file") or die "cannot create $pe_file";
 530
 531 print PE "/* Automatically generated from OpenCL registry files; DO NOT EDIT! */\n\n";
 532
 533 print PE "#include \"opencl_private.h\"\n";
 534 print PE "#include \"opencl_types.h\"\n";
 535 print PE "#include \"unixlib.h\"\n\n";
 536
 537 print PE "WINE_DEFAULT_DEBUG_CHANNEL(opencl);\n" if $gen_traces;
 538
 539 foreach (sort keys %core_functions)
 540 {
 541     next if needs_pe_wrapper( $_ );
 542     print PE "\n", generate_pe_thunk( $_, $core_functions{$_} );
 543 }
 544
 545 print PE <<EOF
 546
 547 BOOL extension_is_supported( const char *name, size_t len )
 548 {
 549     unsigned int i;
 550
 551     static const char *const unsupported[] =
 552     {
 553 EOF
 554 ;
 555
 556 foreach (sort keys %unsupported_extensions)
 557 {
 558     print PE "        \"$_\",\n";
 559 }
 560
 561 print PE <<EOF
 562     };
 563
 564     for (i = 0; i < ARRAY_SIZE(unsupported); ++i)
 565     {
 566         if (!strncasecmp( name, unsupported[i], len ))
 567             return FALSE;
 568     }
 569     return TRUE;
 570 }
 571 EOF
 572 ;
 573
 574 close(PE);
 575
 576 # generate the unix library thunks
 577 open(UNIX, ">$unix_file") or die "cannot create $unix_file";
 578
 579 print UNIX <<EOF
 580 /* Automatically generated from OpenCL registry files; DO NOT EDIT! */
 581
 582 #if 0
 583 #pragma makedep unix
 584 #endif
 585
 586 #include "config.h"
 587 #include "unix_private.h"
 588 EOF
 589 ;
 590
 591 foreach (sort keys %core_functions)
 592 {
 593     next unless needs_unix_function( $_ );
 594     next if needs_unix_wrapper( $_ );
 595     print UNIX "\n", generate_unix_thunk( $_, $core_functions{$_} );
 596 }
 597
 598 print UNIX "\nconst unixlib_entry_t __wine_unix_call_funcs[] =\n{\n";
 599 foreach (sort keys %core_functions)
 600 {
 601     next unless needs_unix_function( $_ );
 602     print UNIX "    wrap_" . $_ . ",\n";
 603 }
 604 print UNIX "};\n";
 605
 606 close(UNIX);
 607
 608 # generate the unix library header
 609 open(UNIXHEADER, ">$unixheader_file") or die "cannot create $unixheader_file";
 610
 611 print UNIXHEADER "/* Automatically generated from OpenCL registry files; DO NOT EDIT! */\n\n";
 612
 613 foreach (sort keys %core_functions)
 614 {
 615     next unless needs_unix_function( $_ );
 616     print UNIXHEADER get_func_params( $_, $core_functions{$_} ), "\n";
 617 }
 618
 619 print UNIXHEADER "enum opencl_funcs\n{\n";
 620 foreach (sort keys %core_functions)
 621 {
 622     next unless needs_unix_function( $_ );
 623     print UNIXHEADER "    unix_$_,\n";
 624 }
 625 print UNIXHEADER "};\n";
 626
 627 close(UNIXHEADER);
 628
 629 # generate the Win32 type definitions
 630 open(TYPES, ">$types_file") or die "cannot create $types_file";
 631
 632 print TYPES <<END
 633 /* Automatically generated from OpenCL registry files; DO NOT EDIT! */
 634
 635 typedef int32_t DECLSPEC_ALIGN(4) cl_int;
 636 typedef uint32_t DECLSPEC_ALIGN(4) cl_uint;
 637 typedef uint64_t DECLSPEC_ALIGN(8) cl_ulong;
 638
 639 END
 640 ;
 641
 642 foreach (@header_types)
 643 {
 644     my $type = $header_types{$_};
 645     if ($type->{category} eq "define")
 646     {
 647         print TYPES $type->textContent() . "\n";
 648     }
 649     elsif ($type->{category} eq "struct")
 650     {
 651         print TYPES generate_struct( $type );
 652     }
 653 }
 654
 655 print TYPES "\n";
 656
 657 foreach (sort keys %header_enums)
 658 {
 659     printf TYPES "#define %s %s\n", $_, $header_enums{$_};
 660 }
 661
 662 close(TYPES);