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         "cl_bitfield"    => [ "int64",  "wine_dbgstr_longlong(%s)" ],
  41         "double"         => [ "double", "%.16e" ],
  42         "float"          => [ "float",  "%.8e" ],
  43         "int"            => [ "long",   "%d" ],
  44         "int8_t"         => [ "long",   "%d" ],
  45         "int16_t"        => [ "long",   "%d" ],
  46         "int32_t"        => [ "long",   "%d" ],
  47         "int64_t"        => [ "int64",  "wine_dbgstr_longlong(%s)" ],
  48         "intptr_t"       => [ "long",   "%Id" ],
  49         "size_t"         => [ "long",   "%Iu" ],
  50         "uint8_t"        => [ "long",   "%u" ],
  51         "uint16_t"       => [ "long",   "%u" ],
  52         "uint32_t"       => [ "long",   "%u" ],
  53         "uint64_t"       => [ "int64",  "wine_dbgstr_longlong(%s)" ],
  54         "unsigned int"   => [ "long",   "%u" ],
  55     );
  56
  57 my %unsupported_extensions =
  58     (
  59         # Needs wined3d integration.
  60         "cl_intel_d3d11_nv12_media_sharing" => 1,
  61         "cl_intel_dx9_media_sharing" => 1,
  62         "cl_khr_d3d10_sharing" => 1,
  63         "cl_khr_d3d11_sharing" => 1,
  64         "cl_khr_dx9_media_sharing" => 1,
  65         "cl_nv_d3d9_sharing" => 1,
  66         "cl_nv_d3d10_sharing" => 1,
  67         "cl_nv_d3d11_sharing" => 1,
  68
  69         # Needs a loader/ICD split.
  70         "cl_khr_icd" => 1,
  71         "cl_loader_layers" => 1,
  72
  73         # Needs callback conversion.
  74         "cl_apple_setmemobjectdestructor" => 1,
  75         "cl_arm_shared_virtual_memory" => 1,
  76     );
  77
  78 sub generate_pe_thunk($$)
  79 {
  80     my ($name, $func_ref) = @_;
  81     my $call_arg = "";
  82     my $trace_call_arg = "";
  83     my $trace_arg = "";
  84
  85     my $ret = get_func_proto( "%s WINAPI %s(%s)", $name, $func_ref );
  86     foreach my $arg (@{$func_ref->[1]})
  87     {
  88         my $ptype = get_arg_type( $arg );
  89         next unless $arg->findnodes("./name");
  90         my $pname = get_arg_name( $arg );
  91         my $param = $arg->textContent();
  92         $call_arg .= " " . $pname . ",";
  93         if ($param =~ /\*/ || $param =~ /\[/)
  94         {
  95             $trace_arg .= ", %p";
  96             $trace_call_arg .= ", " . $pname;
  97         }
  98         elsif (defined $arg_types{$ptype})
  99         {
 100             my $format = ${$arg_types{$ptype}}[1];
 101             $trace_arg .= ", " . ($format =~ /^%/ ? $format : "%s");
 102             $trace_call_arg .= ", " . sprintf $format =~ /^%/ ? "%s" : $format, $pname;
 103         }
 104         else
 105         {
 106             die "Unknown type %s in %s\n", $param, $name;
 107         }
 108     }
 109     $call_arg =~ s/,$/ /;
 110     $trace_arg =~ s/^, //;
 111     $ret .= "\n{\n";
 112     $ret .= "    TRACE( \"($trace_arg)\\n\"$trace_call_arg );\n" if $gen_traces;
 113     $ret .= "    ";
 114     $ret .= "return " unless is_void_func( $func_ref );
 115     $ret .= "opencl_funcs->p$name($call_arg);\n";
 116     $ret .= "}\n";
 117     return $ret;
 118 }
 119
 120 sub generate_unix_thunk($$)
 121 {
 122     my ($name, $func_ref) = @_;
 123     my $call_arg = "";
 124
 125     my $ret = get_func_proto( "static %s WINAPI wrap_%s(%s)", $name, $func_ref );
 126     foreach my $arg (@{$func_ref->[1]})
 127     {
 128         my $ptype = get_arg_type( $arg );
 129         next unless $arg->findnodes("./name");
 130         my $pname = get_arg_name( $arg );
 131         my $param = $arg->textContent();
 132         $call_arg .= " " . $pname . ",";
 133     }
 134     $call_arg =~ s/,$/ /;
 135     $ret .= "\n{\n    ";
 136     $ret .= "return " unless is_void_func( $func_ref );
 137     $ret .= "$name($call_arg);\n";
 138     $ret .= "}\n";
 139     return $ret;
 140 }
 141
 142 sub is_void_func($)
 143 {
 144     my $func = shift;
 145     return 0 if @{$func->[0]->findnodes("./type")};
 146     return $func->[0]->textContent() eq "void";
 147 }
 148
 149 sub get_arg_type($)
 150 {
 151     my $p = shift;
 152     my @type = $p->findnodes("./type");
 153     return @type ? $type[0]->textContent() : "cl_int";
 154 }
 155
 156 sub get_arg_name($)
 157 {
 158     my $p = shift;
 159     my @name = $p->findnodes("./name");
 160     return $name[0]->textContent();
 161 }
 162
 163 sub get_func_proto($$$)
 164 {
 165     my ($format, $name, $func) = @_;
 166     die "unknown func $name" unless defined $func->[0];
 167     my $proto = $func->[0]->textContent();
 168     $proto =~ s/ +$//;
 169     my $args = "";
 170     foreach my $arg (@{$func->[1]})
 171     {
 172         (my $argtext = $arg->textContent()) =~ s/ +/ /g;
 173         $argtext =~ s/CL_CALLBACK/WINAPI/g;
 174         $args .= " " . $argtext . ",";
 175     }
 176     $args =~ s/,$/ /;
 177     $args ||= "void";
 178     return sprintf $format, $proto, $name, $args;
 179 }
 180
 181 # extract and check the number of arguments
 182 if (@ARGV > 1)
 183 {
 184     my $name0 = $0;
 185     $name0 =~ s%^.*/%%;
 186     die "Usage: $name0 [version]\n";
 187 }
 188 my $version = $ARGV[0] || "1.2";
 189 if ($version eq "1.0")
 190 {
 191     %core_categories = %cat_1_0;
 192 }
 193 elsif ($version eq "1.1")
 194 {
 195     %core_categories = %cat_1_1;
 196 }
 197 elsif ($version eq "1.2")
 198 {
 199     %core_categories = %cat_1_2;
 200 }
 201 else
 202 {
 203     die "Incorrect OpenCL version.\n";
 204 }
 205
 206 my $url = "https://raw.githubusercontent.com/KhronosGroup/OpenCL-Docs";
 207 my $commit = "514965312a65e5d01ae17e23119dc95427b7149e";
 208 -f "cl-$commit.xml" || system "wget", "-O", "cl-$commit.xml", "$url/$commit/xml/cl.xml" || die "cannot download cl.xml";
 209
 210 sub generate_spec_entry($$)
 211 {
 212     my ($name, $func) = @_;
 213     my $args=" ";
 214     foreach my $arg (@{$func->[1]})
 215     {
 216         my $ptype = get_arg_type( $arg );
 217         my $param = $arg->textContent();
 218         if ($param =~ /[[*]/)
 219         {
 220             $args .= "ptr ";
 221         }
 222         elsif (defined($arg_types{$ptype}))
 223         {
 224             $args .= "$@$arg_types{$ptype}[0] ";
 225         }
 226         elsif ($ptype ne "void")
 227         {
 228             die "No conversion for func $name type $param\n";
 229         }
 230     }
 231     $args = substr($args,1,-1);
 232     return "@ stdcall $_($args)";
 233 }
 234
 235 my %core_functions;
 236 my %cl_enums;
 237 my (%cl_types, @cl_types);  # also use an array to preserve declaration order
 238
 239 # some functions need a hand-written wrapper
 240 sub needs_pe_wrapper($)
 241 {
 242     my %funcs =
 243         (
 244             # need extension filtering
 245             "clGetDeviceInfo" => 1,
 246             "clGetPlatformInfo" => 1,
 247
 248             # needs function pointer conversion
 249             "clGetExtensionFunctionAddress" => 1,
 250             "clGetExtensionFunctionAddressForPlatform" => 1,
 251
 252             # deprecated and absent from headers
 253             "clSetCommandQueueProperty" => 1,
 254         );
 255     my $name = shift;
 256
 257     return defined $funcs{$name};
 258 }
 259
 260 # some functions need a hand-written wrapper
 261 sub needs_unix_wrapper($)
 262 {
 263     my %funcs =
 264         (
 265             # need callback conversion
 266             "clBuildProgram" => 1,
 267             "clCompileProgram" => 1,
 268             "clCreateContext" => 1,
 269             "clCreateContextFromType" => 1,
 270             "clEnqueueNativeKernel" => 1,
 271             "clLinkProgram" => 1,
 272             "clSetEventCallback" => 1,
 273             "clSetMemObjectDestructorCallback" => 1,
 274         );
 275     my $name = shift;
 276
 277     return defined $funcs{$name};
 278 }
 279
 280 # don't bother putting unused functions in the interface
 281 sub needs_unix_function($)
 282 {
 283     my %funcs =
 284         (
 285             "clGetExtensionFunctionAddress" => 1,
 286             "clGetExtensionFunctionAddressForPlatform" => 1,
 287             "clSetCommandQueueProperty" => 1,
 288         );
 289     my $name = shift;
 290
 291     return not defined $funcs{$name};
 292 }
 293
 294 sub generate_struct($)
 295 {
 296     my $type = shift;
 297     my $name = $type->{name};
 298     my $ret = "typedef struct _$name\n{\n";
 299     foreach my $member ($type->findnodes("./member"))
 300     {
 301         ($member = $member->textContent()) =~ s/ +/ /g;
 302         $ret .= "    $member;\n";
 303     }
 304     $ret .= "} $name;\n";
 305     return $ret;
 306 }
 307
 308 sub parse_file($)
 309 {
 310     my $file = shift;
 311     my $xml = XML::LibXML->load_xml( location => $file );
 312     my %functions;
 313     my %enums;
 314     my %types;
 315
 316     # save all functions
 317     foreach my $command ($xml->findnodes("/registry/commands/command"))
 318     {
 319         my $proto = @{$command->findnodes("./proto")}[0];
 320         my $name = @{$command->findnodes("./proto/name")}[0];
 321         $proto->removeChild( $name );
 322         my @params = $command->findnodes("./param");
 323         $functions{$name->textContent()} = [ $proto, \@params ];
 324     }
 325
 326     # save all enums
 327     foreach my $enum ($xml->findnodes("/registry/enums/enum"))
 328     {
 329         if (defined $enum->{value})
 330         {
 331             $enums{$enum->{name}} = $enum->{value};
 332         }
 333         else
 334         {
 335             $enums{$enum->{name}} = "(1 << " . $enum->{bitpos} . ")";
 336         }
 337     }
 338
 339     # save all types
 340     foreach my $type ($xml->findnodes("/registry/types/type"))
 341     {
 342         if ($type->{category} eq "define")
 343         {
 344             my $name = @{$type->findnodes("./name")}[0];
 345             $name = $name->textContent;
 346             $types{$name} = $type;
 347
 348             my $basetype = @{$type->findnodes("./type")}[0];
 349             if ($type->textContent() =~ /[[*]/)
 350             {
 351                 $arg_types{$name} = ["ptr", "%p"];
 352             }
 353             elsif (defined($basetype) and defined($arg_types{$basetype->textContent}))
 354             {
 355                 $arg_types{$name} = $arg_types{$basetype->textContent};
 356             }
 357             elsif ($name ne "cl_icd_dispatch")
 358             {
 359                 die "No conversion for type $name\n"
 360             }
 361         }
 362         elsif ($type->{category} eq "struct")
 363         {
 364             my $name = $type->{name};
 365             $types{$name} = $type;
 366         }
 367     }
 368
 369     # generate core functions
 370     foreach my $feature ($xml->findnodes("/registry/feature"))
 371     {
 372         next unless defined $core_categories{$feature->{name}};
 373         foreach my $cmd ($feature->findnodes("./require/command"))
 374         {
 375             $core_functions{$cmd->{name}} = $functions{$cmd->{name}};
 376         }
 377         foreach my $enum ($feature->findnodes("./require/enum"))
 378         {
 379             $cl_enums{$enum->{name}} = $enums{$enum->{name}};
 380         }
 381         foreach my $type ($feature->findnodes("./require/type"))
 382         {
 383             next unless $types{$type->{name}};
 384             push @cl_types, $type->{name} unless $cl_types{$type->{name}};
 385             $cl_types{$type->{name}} = $types{$type->{name}};
 386         }
 387     }
 388
 389     # generate extension list
 390     foreach my $ext ($xml->findnodes("/registry/extensions/extension"))
 391     {
 392         # we currently don't support clGetExtensionFunctionAddress, and
 393         # implementing clGetExtensionFunctionAddressForPlatform is nontrivial;
 394         # we need to generate a table of thunks per platform and retrieve the
 395         # platform from the called object
 396         $unsupported_extensions{lc($ext->{name})} = 1 if $ext->findnodes("./require/command");
 397     }
 398 }
 399
 400 parse_file( "cl-$commit.xml" );
 401
 402 # generate the spec file
 403 open(SPEC, ">$spec_file") or die "cannot create $spec_file";
 404
 405 foreach (sort keys %core_functions)
 406 {
 407     printf SPEC "%s\n", generate_spec_entry( $_, $core_functions{$_} );
 408 }
 409
 410 close(SPEC);
 411
 412
 413 # generate the PE thunks
 414 open(PE, ">$pe_file") or die "cannot create $pe_file";
 415
 416 print PE "/* Automatically generated from OpenCL registry files; DO NOT EDIT! */\n\n";
 417
 418 print PE "#include \"opencl_private.h\"\n";
 419 print PE "#include \"opencl_types.h\"\n";
 420 print PE "#include \"unixlib.h\"\n\n";
 421
 422 print PE "WINE_DEFAULT_DEBUG_CHANNEL(opencl);\n" if $gen_traces;
 423
 424 foreach (sort keys %core_functions)
 425 {
 426     next if needs_pe_wrapper( $_ );
 427     print PE "\n", generate_pe_thunk( $_, $core_functions{$_} );
 428 }
 429
 430 print PE <<EOF
 431
 432 BOOL extension_is_supported( const char *name, size_t len )
 433 {
 434     unsigned int i;
 435
 436     static const char *const unsupported[] =
 437     {
 438 EOF
 439 ;
 440
 441 foreach (sort keys %unsupported_extensions)
 442 {
 443     print PE "        \"$_\",\n";
 444 }
 445
 446 print PE <<EOF
 447     };
 448
 449     for (i = 0; i < ARRAY_SIZE(unsupported); ++i)
 450     {
 451         if (!strncasecmp( name, unsupported[i], len ))
 452             return FALSE;
 453     }
 454     return TRUE;
 455 }
 456 EOF
 457 ;
 458
 459 close(PE);
 460
 461 # generate the unix library thunks
 462 open(UNIX, ">$unix_file") or die "cannot create $unix_file";
 463
 464 print UNIX <<EOF
 465 /* Automatically generated from OpenCL registry files; DO NOT EDIT! */
 466
 467 #if 0
 468 #pragma makedep unix
 469 #endif
 470
 471 #include "config.h"
 472 #include "unix_private.h"
 473 EOF
 474 ;
 475
 476 foreach (sort keys %core_functions)
 477 {
 478     next unless needs_unix_function( $_ );
 479     next if needs_unix_wrapper( $_ );
 480     print UNIX "\n", generate_unix_thunk( $_, $core_functions{$_} );
 481 }
 482
 483 print UNIX "\nconst struct opencl_funcs funcs =\n{\n";
 484 foreach (sort keys %core_functions)
 485 {
 486     next unless needs_unix_function( $_ );
 487     print UNIX "    wrap_" . $_ . ",\n";
 488 }
 489 print UNIX "};\n";
 490
 491 close(UNIX);
 492
 493 # generate the unix library header
 494 open(UNIXHEADER, ">$unixheader_file") or die "cannot create $unixheader_file";
 495
 496 print UNIXHEADER "/* Automatically generated from OpenCL registry files; DO NOT EDIT! */\n\n";
 497
 498 print UNIXHEADER "struct opencl_funcs\n{\n";
 499 foreach (sort keys %core_functions)
 500 {
 501     next unless needs_unix_function( $_ );
 502     print UNIXHEADER get_func_proto( "    %s (WINAPI *p%s)(%s);\n", $_, $core_functions{$_} );
 503 }
 504 print UNIXHEADER "};\n\n";
 505
 506 print UNIXHEADER "extern const struct opencl_funcs *opencl_funcs;\n";
 507
 508 close(UNIXHEADER);
 509
 510 # generate the Win32 type definitions
 511 open(TYPES, ">$types_file") or die "cannot create $types_file";
 512
 513 print TYPES <<END
 514 /* Automatically generated from OpenCL registry files; DO NOT EDIT! */
 515
 516 typedef int32_t cl_int DECLSPEC_ALIGN(4);
 517 typedef uint32_t cl_uint DECLSPEC_ALIGN(4);
 518 typedef uint64_t cl_ulong DECLSPEC_ALIGN(8);
 519
 520 END
 521 ;
 522
 523 foreach (@cl_types)
 524 {
 525     my $type = $cl_types{$_};
 526     if ($type->{category} eq "define")
 527     {
 528         print TYPES $type->textContent() . "\n";
 529     }
 530     elsif ($type->{category} eq "struct")
 531     {
 532         print TYPES generate_struct( $type );
 533     }
 534 }
 535
 536 print TYPES "\n";
 537
 538 foreach (sort keys %cl_enums)
 539 {
 540     printf TYPES "#define %s %s\n", $_, $cl_enums{$_};
 541 }
 542
 543 close(TYPES);