panama tools and demos
[panamaz] / src / generate
1 #!/usr/bin/perl
2
3 # usage
4 # generate [-d dir] [-t package] [--enclosing-type type ] [-s struct-root-pattern]* [--struct-file file]* [-c class [-llib]* [-f func-pattern]* [--func-file file]* ]*
5 #  -d dir
6 #    root output directory
7 #  -t package
8 #    output package
9 #  --enclosing-type type
10 #    If supplied, all structures and classes are written to an enclosing class
11 #  -s struct-root-pattern
12 #    provide one or more patterns for matching structure roots.
13 #    all dependencies are automatically included.
14 #    if no pattern is provided, all match.
15 #  --struct-file file
16 #    provide a filename with exact structure names in it.  These are
17 #    used as roots(?)
18 #  -c class
19 #    specify class name to generate
20 #  -llib
21 #    specify link library used by class
22 #  -f func-pattern
23 #    function name pattern to include for the last class
24 #  --func-file file
25 #    point to a filename with exact function names in it, one per line ('#' is a comment).
26
27 # TODO: scan all functions and include any types they use as struct roots
28 # TODO: some way to specify external types
29
30 @matchStruct = ();
31 $meta = "";
32 # @classes = ( { name => 'class', match => [ func-pattern, ... ], match_file => [ file, ... ] } )
33 @classes = ();
34 %lastclass = ();
35 $output = ".";
36 # map call signatures to a class name
37 %callMap = ();
38 $package = "";
39
40 while (@ARGV) {
41     my $cmd = shift(@ARGV);
42
43     if ($cmd eq "-f") {
44         my $v = shift(@ARGV);
45         push @{$lastclass{match}}, qr/$v/;
46     } elsif ($cmd eq "--func-file") {
47         my $file = shift(@ARGV);
48         push @{$lastclass{match_file}}, $file;
49         push @{$lastclass{match}}, readMatchFile($file);
50     } elsif ($cmd eq "-s") {
51         my $v = shift(@ARGV);
52         push @matchStruct, qr/$v/;
53     } elsif ($cmd eq "--struct-file") {
54         my $file = shift(@ARGV);
55         push @matchStruct, readMatchFile($file);
56     } elsif ($cmd eq "-t") {
57         $package = shift(@ARGV);
58     } elsif ($cmd eq "-c") {
59         %lastclass = (
60             name => shift(@ARGV),
61             match => [],
62             match_file => [],
63             libs => []);
64         push @classes, \%lastclass;
65     } elsif ($cmd =~ m/^-l(.*)/) {
66         push @{$lastclass{libs}}, $1;
67     } elsif ($cmd eq "-d") {
68         $output = shift(@ARGV);
69     } elsif ($cmd eq "--enclosing-type") {
70         $enclosingType = shift(@ARGV);
71     } else {
72         $meta = $cmd;
73     }
74 }
75
76 use Data::Dumper;
77 print Dumper(@classes);
78 #exit 0;
79
80 require $meta;
81
82 # box types for primitives
83 %map_box = (
84     "long" => "Long",
85     "int" => "Integer",
86     "short" => "Short",
87     "char" => "Character",
88     "float" => "Float",
89     "double" => "Double",
90     "byte" => "Byte",
91     "void" => "Void"
92     );
93
94 sub readMatchFile {
95     my $path = shift @_;
96     my @lines = ();
97
98     open(my $f,"<$path");
99     while (<$f>) {
100         chop;
101         next if m/^#/;
102
103         #push @lines, qr/\^$_\$/;
104         push @lines, $_;
105     }
106     close($f);
107
108     my $all = join ('|', @lines);
109
110     return qr/^($all)$/;
111 }
112
113 sub camelCase {
114     my $name = shift @_;
115
116     $name =~ s/_(.)/uc($1)/eg;
117
118     return $name;
119 }
120
121 sub StudlyCaps {
122     my $name = shift @_;
123
124     $name =~ s/^(.)/uc($1)/e;
125     $name =~ s/_(.)/uc($1)/eg;
126
127     return $name;
128 }
129
130
131 sub structSignature {
132     my %struct = %{shift(@_)};
133     my $union = shift(@_);
134     my $sig = "";
135     my @fields = @{$struct{fields}};
136     my $offset = 0;
137
138     my $inbf = 0;
139     my $bfoffset = 0;
140     my $bfstart = 0;
141     my $bfsig = "";
142
143     for $fi (@fields) {
144         my %field = %{$fi};
145         my $off = $field{offset};
146
147         # bitfields, this only handles 1x u64 bitfield section
148         #  They need to: align to u32/u64
149         #  Group fields into one full u32/u64
150         # TODO: check alignment @ start?
151         # TODO: clean up and complete
152         # TODO: bitfields in unions are probably broken
153         if ($field{ctype} eq 'bitfield') {
154             if ($inbf) {
155                 if ($off - $offset) {
156                     $bfsig .= "x";
157                     $bfsig .= ($off - $offset);
158                 }
159                 $bfsig .= $field{type};
160                 $bfsig .= "($field{name})";
161                 $offset = $off + $field{size};
162             } else {
163                 $inbf = 1;
164                 $bfsig = $field{type};
165                 $bfsig .= "($field{name})";
166                 $offset = $off + $field{size};
167                 $bfstart = $field{offset};
168             }
169
170             if ($union) {
171                 $inbf = 0;
172
173                 if (($offset - $bfstart) == 32) {
174                     $bfsig = "u32=[$bfsig]";
175                 } elsif (($offset - $bfstart) < 32) {
176                     $bfsig .= "x";
177                     $bfsig .= 32 - ($offset - $bfstart);
178                     $offset = $bfstart + 32;
179                     $bfsig = "u32=[$bfsig]";
180                 } elsif (($offset - $bfstart) == 64) {
181                     $bfsig = "u64=[$bfsig]";
182                 } elsif (($offset - $bfstart) < 64) {
183                     $bfsig .= "x";
184                     $bfsig .= 64 - ($offset - $bfstart);
185                     $offset = $bfstart + 64;
186                     $bfsig = "u64=[$bfsig]";
187                 }
188
189                 $sig .= $bfsig;
190                 $sig .= "|" if ($union && $fi != @fields[$#fields]);
191             }
192             next;
193         } elsif ($inbf) {
194             if (($offset - $bfstart) == 32) {
195                 $bfsig = "u32=[$bfsig]";
196             } elsif (($offset - $bfstart) < 32) {
197                 $bfsig .= "x";
198                 $bfsig .= 32 - ($offset - $bfstart);
199                 $offset = $bfstart + 32;
200                 $bfsig = "u32=[$bfsig]";
201             } elsif (($offset - $bfstart) == 64) {
202                 $bfsig = "u64=[$bfsig]";
203             } elsif (($offset - $bfstart) < 64) {
204                 $bfsig .= "x";
205                 $bfsig .= 64 - ($offset - $bfstart);
206                 $offset = $bfstart + 64;
207                 $bfsig = "u64=[$bfsig]";
208             }
209             $sig .= $bfsig;
210             $inbf = 0;
211         }
212
213         # skip to next offset if necessary
214         if ($off > $offset) {
215             $sig .= "x";
216             $sig .= ($off - $offset);
217         }
218         $offset = $off + $field{size};
219
220         # normal field processing
221         if ($field{deref}) {
222             my $deref = $field{deref};
223
224             # HACK: function -> Void
225         #   if ($field{debug} eq 'function') {
226         #       $sig .= "u64($field{name}):v";
227         #    } els
228                 if ($deref =~ m/^(u\d\d)(:.*)/) {
229                 $sig .= "$1($field{name})$2";
230             } else {
231                 $sig .= "$deref($field{name})";
232             }
233         } else {
234             if ($field{type} =~ m/(struct|union):(.*)/) {
235                 $sig .= "\${$2}";
236             } elsif ($field{type} =~ m/([iuf])(\d+)/) {
237                 $sig .= $1;
238                 $sig .= $2;
239             } elsif ($field{type} eq 'void') {
240                 $sig .= "v";
241             } elsif ($field{type} eq 'enum') {
242                 # FIXME: set type in compiler
243                 $sig .= "u32";
244             }
245
246             $sig .= "($field{name})";
247         }
248
249         $sig .= "|" if ($union && $fi != @fields[$#fields]);
250     }
251
252     # finish any trailing bitfield
253     # TODO: cleanup
254     if ($inbf) {
255         if (($offset - $bfstart) == 32) {
256             $bfsig = "u32=[$bfsig]";
257         } elsif (($offset - $bfstart) < 32) {
258             $bfsig .= "x";
259             $bfsig .= 32 - ($offset - $bfstart);
260             $offset = $bfstart + 32;
261             $bfsig = "u32=[$bfsig]";
262         } elsif (($offset - $bfstart) == 64) {
263             $bfsig = "u64=[$bfsig]";
264         } elsif (($offset - $bfstart) < 64) {
265             $bfsig .= "x";
266             $bfsig .= 64 - ($offset - $bfstart);
267             $offset = $bfstart + 64;
268             $bfsig = "u64=[$bfsig]";
269         }
270         #$bfsig .= "]";
271         $sig .= $bfsig;
272     }
273
274     return "[".$sig."]";
275 }
276
277 sub funcSignature {
278     my %func = %{shift(@_)};
279     my $sig = "";
280     my @params = @{$func{arguments}};
281
282     for $pi (@params) {
283         my %param = %{$pi};
284
285         if ($param{deref}) {
286             # HACK: function to void
287             if ($param{debug} eq "function") {
288                 $sig .= "u64:v";
289             } else {
290                 $sig .= $param{deref};
291             }
292         } else {
293             if ($param{type} =~ m/struct:(.*)/) {
294                 $sig .= "\${$1}";
295             } elsif ($param{type} =~ m/([iuf])(\d*)/) {
296                 $sig .= $1;
297                 $sig .= $2;
298             } elsif ($param{type} eq "void") {
299                 $sig .= "v";
300             }
301         }
302     }
303
304     my %result = %{$func{result}};
305     my $ret = "";
306
307     if ($result{deref}) {
308         $ret .= $result{deref};
309     } else {
310         if ($result{type} =~ m/^struct:(.*)/) {
311             $ret .= "\${$1}";
312         } elsif ($result{type} =~ m/^([iuf])(\d+)/) {
313             $ret .= $1;
314             $ret .= $2;
315         } elsif ($result{type} eq "void") {
316             $ret .= "v";
317         }
318     }
319
320     return "($sig)$ret";
321 }
322
323 sub deref {
324     my $type = shift @_;
325     my $ref = shift @_;
326
327     while ($ref) {
328         if ($ref =~ m/\[\d*(.*)\]/) {
329             my $sub = deref($type, $1);
330
331             return "Array<$sub>";
332         } elsif ($ref =~ m/^u64:(.*)/) {
333             $type = "Pointer<$type>";
334             $ref = $1;
335         } else {
336             last;
337         }
338     }
339     return $type;
340 }
341
342 sub typeToJava {
343     my %param = %{shift(@_)};
344     my $type = $param{type};
345     my $ref = $param{deref};
346
347     if ($type =~ m/^struct:(.*)/) {
348         $type = StudlyCaps($1);
349     } elsif ($type =~ m/call:/) {
350         # this re-writes ref to remove one pointer-to as the Callback absorbs it.
351         $type = "Callback<".$callMap{$type}.">";
352         $type || die ("No mapping for type ".Dumper(\%param));
353         $ref =~ s/^u(32|64)://;
354     } elsif ($type =~ m/^enum:(.*)/) {
355         # TODO: other enum options
356         $type = "int";
357     } elsif ($type eq "void") {
358         $type = "void";
359     } elsif ($type =~ m/^([iu])(\d*)/) {
360         my $sign = $1;
361         my $size = $2;
362
363         if ($size <= 8) {
364             $type = "byte";
365         } elsif ($size <= 16) {
366             if ($sign eq "i") {
367                 $type = "short";
368             } else {
369                 $type = "char";
370             }
371         } elsif ($size <= 32) {
372             $type = "int";
373         } else {
374             $type = "long";
375         }
376     } elsif ($type =~ m/^[f](\d*)$/) {
377         my $size = $1;
378
379         if ($size == 32) {
380             $type = "float";
381         } elsif ($size == 64) {
382             $type = "double";
383         }
384     }
385
386     if ($ref) {
387         $type = $map_box{$type} if ($map_box{$type});
388         $type = deref($type, $ref);
389     }
390
391     return $type;
392 }
393
394 sub testMatch {
395     my $name = shift @_;
396
397     if (@_) {
398         for $pat (@_) {
399             if ($name =~ /$pat/) {
400                 return 1;
401             }
402         }
403         return 0;
404     } else {
405         return 1;
406     }
407 }
408
409 # find all matching structures and then all that they require
410 sub findStructs {
411     my %all = %{shift @_};
412     my @match = @_;
413     my @stack = grep {
414         my %e = %{$all{$_}};
415         $e{type} =~ m/(struct|union)/ && testMatch($e{name}, @match);
416     } keys %all;
417     my %visit = ();
418
419     while (@stack) {
420         my $test = shift @stack;
421
422         if (!$visit{$test}) {
423             my %struct = %{$all{$test}};
424
425             $visit{$test} = 1;
426
427             if (%struct) {
428                 print "class: $struct{name}\n";
429                 # find all types this one uses
430                 for $f (@{$struct{fields}}) {
431                     my %field = %{$f};
432
433                     if ($field{type} =~ m/^(struct|union):(.*)/) {
434                         if (!$set{$field{type}}) {
435                             $set{$field{type}} = $all{$field{type}};
436                             push @stack, $field{type};
437                         }
438                     }
439                 }
440             } else {
441                 # this is an anon type, typically used for handles
442                 $test =~ m/^(struct|union):(.*)/;
443                 print " anon: $2\n";
444                 my %rec = (
445                     type => 'struct',
446                     name => $2,
447                     size => 0
448                     );
449                 $data{$test} = \%rec;
450             }
451         }
452     }
453     return keys %visit;
454 }
455
456 sub findFuncs {
457     my %all = %{shift @_};
458     my @match = @_;
459     my @stack = grep {
460         my %e = %{$all{$_}};
461         $e{type} eq "func" && testMatch($e{name}, @match);
462     } keys %all;
463
464     return @stack;
465 }
466
467 # ######################################################################
468
469 # setup section
470
471 # find all classes used by functions, add them to the struct roots
472 my %roots = ();
473 for $c (@classes) {
474     my %class = %{$c};
475     my @libs = @{$class{libs}};
476     my @match = @{$class{match}};
477
478     for $k (findFuncs(\%data, @match)) {
479         my %func = %{$data{$k}};
480         my @params = @{$func{arguments}};
481
482         for $pi (@params) {
483             my %param = %{$pi};
484
485             if ($param{type} =~ m/^(struct|union):(.*)/) {
486                 $roots{$2} = 1;
487             }
488         }
489
490         my %result = %{$func{result}};
491
492         if ($result{type} =~ m/^(struct|union):(.*)/) {
493             $roots{$2} = 1;
494         }
495     }
496 }
497
498 # FIXME: only include ones used elsewhere
499 # add roots for any types used by calls
500 for $k (grep { $_ =~ m/^call:/n } keys %data) {
501     my %func = %{$data{$k}};
502     my @params = @{$func{arguments}};
503
504     for $pi (@params) {
505         my %param = %{$pi};
506
507         if ($param{type} =~ m/^(struct|union):(.*)/) {
508             $roots{$2} = 1;
509         }
510     }
511
512     my %result = %{$func{result}};
513
514     if ($result{type} =~ m/^(struct|union):(.*)/) {
515         $roots{$2} = 1;
516     }
517 }
518
519 $all = join ('|', keys %roots);
520 if ($all) {
521     push @matchStruct, qr/^($all)$/;
522 }
523 print "structures:\n";
524 print Dumper(@matchStruct);
525
526 # make a map for all callbacks (call: type) to generated names
527 for $c (grep { $_ =~ m/^call:/n } keys %data) {
528     my $name = $c;
529
530     print "$c\n";
531     # enum maybe to int?
532
533     $name =~ s/^call:/Call/;
534     $name =~ s/\$\{[^\}]*\}/L/g;
535     $name =~ s/[ui](64|32):/p/g;
536     $name =~ s/[ui]64/J/g;
537     $name =~ s/[ui]32/I/g;
538     $name =~ s/[ui]8/B/g;
539     $name =~ s/f32/F/g;
540     $name =~ s/f64/D/g;
541     $name =~ s/[\[\]\(\)]/_/g;
542
543     $callMap{$c} = "$name";
544 }
545
546 print "call mappings\n";
547 print Dumper(\%callMap);
548
549 # ######################################################################
550 # Start output
551 my $dst;
552
553 use File::Basename;
554 use File::Path qw(make_path);
555
556 if ($package ne "") {
557     $packagePrefix = $package.".";
558 }
559
560 if ($enclosingType) {
561     my $classname = $packagePrefix.$enclosingType;
562
563     $classname =~ s@\.@/@g;
564
565     my $path = $output."/".$classname.".java";
566     my $dir = dirname($path);
567     my $class = basename($path, ".java");
568
569     print "path $path\n";
570     print "dirname $dir\n";
571
572     make_path($dir);
573     open ($dst, ">$path");
574
575     if ($package ne "") {
576         print $dst "package $package;\n";
577     }
578
579     print $dst <<END;
580 import java.foreign.Libraries;
581 import java.foreign.annotations.*;
582 import java.foreign.memory.*;
583 import java.lang.invoke.MethodHandles;
584 END
585     print $dst "public class $class {\n";
586 }
587
588 # Dump structures
589 for $k (findStructs(\%data, @matchStruct)) {
590     my %struct = %{$data{$k}};
591     my @fields = @{$struct{fields}};
592     my $signature = structSignature(\%struct, ($struct{type} eq "union"));
593     my $name = StudlyCaps($struct{name});
594
595     if (!$enclosingType) {
596         my $classname = $packagePrefix.$name;
597
598         open ($dst, ">$path");
599         $classname =~ s@\.@/@g;
600
601         my $path = $output."/".$classname.".java";
602         my $dir = dirname($path);
603         my $class = basename($path, ".java");
604         make_path($dir);
605         open ($dst, ">$path");
606
607         if ($package ne "") {
608             print $dst "package $package;\n";
609         }
610         print $dst <<END;
611 import java.foreign.annotations.*;
612 import java.foreign.memory.*;
613 END
614     }
615
616     # any in-line structures need to be added to the resolutionContext
617     # TODO: only include actual inline, not pointers
618     my %resolve = ();
619     for $fi (@fields) {
620         my %field = %{$fi};
621
622         if ($field{type} =~ m/^(struct|union):(.*)/) {
623             $resolve{StudlyCaps($2).".class"} = 1;
624         }
625     }
626     my $resolve = join (",", keys %resolve);
627
628     print $dst "\@NativeStruct(value=\"$signature($struct{name})\", resolutionContext={$resolve})\n";
629     print $dst "public interface $name extends Struct<$name> {\n";
630
631     for $fi (@fields) {
632         my %field = %{$fi};
633         my $type = typeToJava(\%field);
634         my $cc = StudlyCaps($field{name});
635
636         print $dst "\t\@NativeGetter(value=\"$field{name}\")\n";
637         print $dst "\tpublic $type get$cc();\n";
638
639         print $dst "\t\@NativeSetter(value=\"$field{name}\")\n";
640         print $dst "\tpublic void set$cc($type value);\n";
641     }
642
643     print $dst "}\n";
644
645     if (!$enclosingType) {
646         close($dst);
647     }
648 }
649
650 # Dump classes for library linkage
651 for $c (@classes) {
652     my %class = %{$c};
653     my @libs = @{$class{libs}};
654     my @match = @{$class{match}};
655
656     if (!$enclosingType) {
657         my $classname = $packagePrefix.$class{name};
658
659         open ($dst, ">$path");
660         $classname =~ s@\.@/@g;
661
662         my $path = $output."/".$classname.".java";
663         my $dir = dirname($path);
664         my $class = basename($path, ".java");
665         make_path($dir);
666         open ($dst, ">$path");
667
668         if ($package ne "") {
669             print $dst "package $package;\n";
670         }
671         print $dst <<END;
672 import java.foreign.Libraries;
673 import java.foreign.annotations.*;
674 import java.foreign.memory.*;
675 import java.lang.invoke.MethodHandles;
676 END
677     }
678
679     print $dst "\@NativeHeader(libraries={";
680     print $dst join(",", map { "\"$_\"" } @libs);
681     print $dst "})\n";
682     print $dst "public interface $class{name} {\n";
683
684     for $k (sort(findFuncs(\%data, @match))) {
685         my %func = %{$data{$k}};
686         my @params = @{$func{arguments}};
687         my $signature = funcSignature(\%func);
688         my $name = ($func{name});
689         my $result = typeToJava(\%{$func{result}});
690
691         print $dst "\n\t\@NativeFunction(value=\"$signature\")\n";
692         print $dst "\tpublic $result $name(";
693
694         for $pi (@params) {
695             my %param = %{$pi};
696             my $type = typeToJava($pi);
697
698             print $dst "$type $param{name}";
699             print $dst ", " if ($pi != $params[$#params]);
700         }
701
702         print $dst ");\n";
703     }
704
705     print $dst "\n";
706     print $dst "\tpublic static final $class{name} bind = Libraries.bind(MethodHandles.lookup(), $class{name}.class);\n";
707
708     print $dst "}\n";
709
710     if (!$enclosingType) {
711         close($dst);
712     }
713 }
714
715 # Dump callbacks
716 # TODO: only those used by classes and functions that were exported
717 for $c (keys %callMap) {
718     my %call = %{$data{$c}};
719     my $name = $callMap{$c};
720     my @params = @{$call{arguments}};
721     my $result = typeToJava(\%{$call{result}});
722
723     if (!$enclosingType) {
724         my $classname = $packagePrefix.$name;
725
726         open ($dst, ">$path");
727         $classname =~ s@\.@/@g;
728
729         my $path = $output."/".$classname.".java";
730         my $dir = dirname($path);
731         my $class = basename($path, ".java");
732         make_path($dir);
733         open ($dst, ">$path");
734
735         if ($package ne "") {
736             print $dst "package $package;\n";
737         }
738         print $dst <<END;
739 import java.foreign.Libraries;
740 import java.foreign.annotations.*;
741 import java.foreign.memory.*;
742 END
743     }
744
745     # FIXME: use something other than name to store this
746     print $dst "\@FunctionalInterface\n";
747     print $dst "\@NativeCallback(value=\"$call{name}\")\n";
748     print $dst "public interface $name {\n";
749     print $dst "\tpublic $result fn(";
750
751     for $pi (@params) {
752         my %param = %{$pi};
753         my $type = typeToJava($pi);
754
755         print $dst "$type $param{name}";
756         print $dst ", " if ($pi != $params[$#params]);
757     }
758
759     print $dst ");\n";
760     print $dst "}\n";
761
762     if (!$enclosingType) {
763         close($dst);
764     }
765 }
766
767 # Finish off
768 if ($enclosingType) {
769     print $dst "}\n";
770     close($dst);
771 }