test.pl

#!/usr/bin/perl -w
use strict;
use File::Slurper qw(read_text write_text);

my $defs = read_text "runtime/native/event/defs.in";
my $types = "";
my %type = ();

while ($defs =~ /CHI_NEWTYPE\((\w+),\s*(\w+)\)/gs) {
    $types .= "typedef $2 Xy$1;\n\n";
    $type{"Xy$1"} = ['newtype', $1, $2];
}

while ($defs =~ /typedef\s+enum\s+.*?\{(.*?)\}\s*(\w+);/gs) {
    my $lines = $1;
    my $name = $2;
    $lines =~ s/\s//g;
    my @enums = split ',', $lines;
    $type{$name} = ['enum', \@enums];
    $types .= "typedef uint32_t $name;\n\n";
}

while ($defs =~ /typedef\s+struct\s+.*?\{(.*?)\}\s*(\w+);/gs) {
    my $lines = $1;
    my $name = $2;
    $types .= "$&\n\n";
    $lines =~ s/\A\s+|\s+\Z//g;
    my @fields = ();
    foreach my $s (split /\n/, $lines) {
        $s =~ s/\s+/ /g;
        $s =~ s/;//g;
        my @type = split ' ', $s;
        die ("Invalid field type $s\n") if ($#type != 1);
        my ($type, $field) = @type;
        next if ($field =~ /^_/);
        if ($field =~ /^(.*)(\[\d+\])$/) {
            $field = $1;
            if ($type eq "char") {
                $type = "char*";
            } else {
                $type .= $2;
            }
        }
        if ($type =~ /XyStringRef|size_t|u?int\d+_t|char\*|bool/) {
            push @fields, [$field, [$type]];
        } elsif ($type{$type}) {
            push @fields, [$field, $type{$type}];
        } elsif ($type =~ /^(\w+)\*$/ && $type{$1}) {
            push @fields, [$field, ['ptr', $type{$1}]];
        } else {
            die "Invalid type $type\n";
        }
    }
    $type{$name} = ['struct', \@fields];
}

while ($defs =~ /typedef\s+(\w+)\s+(\w+);/gs) {
    $type{$2} = $type{$1};
}

sub writeField {
    my($indent, $type, $ptr) = @_;
    my $t = $$type[0];
    my $ind = ' ' x $indent;
    if ($t eq 'struct') {
        my @fields = @{$$type[1]};
        my $ret = "";
        my $i = 0;
        foreach my $f (@fields) {
            ++$i;
            if ($$f[1][0] eq 'ptr' && $$f[1][1][0] eq 'struct') {
                $ret .= "${ind}XBLOCK_BEGIN(\"$$f[0]\");\n";
                $ret .= writeField($indent + 4, $$f[1], "$ptr$$f[0]");
                $ret .= "${ind}XBLOCK_END(\"$$f[0]\");\n";
            } elsif ($$f[1][0] eq 'struct') {
                my @subfields = @{$$f[1][1]};
                if ($#subfields > 0) {
                    $ret .= "${ind}XBLOCK_BEGIN(\"$$f[0]\");\n";
                    $ret .= writeField($indent + 4, $$f[1], "$ptr$$f[0].");
                    $ret .= "${ind}XBLOCK_END(\"$$f[0]\");\n";
                } else {
                    $ret .= "${ind}XFIELD(\"$$f[0]\", " . writeField(0, $subfields[0][1], "$ptr$$f[0].$subfields[0][0]") . ");\n";
                }
            } else {
                $ret .= "${ind}XFIELD(\"$$f[0]\", " . writeField(0, $$f[1], "$ptr$$f[0]") . ");\n";
            }
        }
        return $ret;
    }
    return "${ind}NUM(CHI_UN($$type[1], $ptr))" if ($t eq "newtype");
    return "${ind}SNUM($ptr)" if ($t =~ /^(int\d+_t)$/);
    return "${ind}NUM($ptr)" if ($t =~ /^(enum|size_t|uint\d+_t|bool)$/);
    return "${ind}XQSTR($ptr)" if ($t eq 'XyStringRef');
    return "${ind}XQSTR(chiStringRef($ptr))" if ($t eq 'char*');
    die "Invalid type $t";
}

sub ctfField {
    my($type, $name, $ptr) = @_;
    my $t = $$type[0];
    return ctfField($$type[1], $name, $ptr) if ($t eq 'ptr');
    if ($t eq 'struct') {
        my @fields = @{$$type[1]};
        if ($#fields == 0 && ${$fields[0][1]}[0] eq 'ptr') {
            return ctfField($fields[0][1], $name, "$ptr$fields[0][0]->");
        }
        if ($#fields == 0 && ${$fields[0][1]}[0] eq 'struct') {
            return ctfField($fields[0][1], $name, "$ptr$fields[0][0].");
        }
        if ($#fields == 0 && $name ne "" && $ptr ne "") {
            return ctfField($fields[0][1], $name, "$ptr$fields[0][0]") . "\n";
        }
        my $ret = "";
        my $i = 0;
        foreach my $f (@fields) {
            ++$i;
            my $n = $name eq "" ? $$f[0] : "${name}_$$f[0]";
            if ($$f[1][0] eq 'ptr' && $$f[1][1][0] eq 'struct') {
                $ret .= ctfField($$f[1], $n, "$ptr$$f[0]->");
            } elsif ($$f[1][0] eq 'struct') {
                $ret .= ctfField($$f[1], $n, "$ptr$$f[0].");
            } else {
                $ret .= ctfField($$f[1], $n, "$ptr$$f[0]") . "\n";
            }
        }
        return $ret;
    }
    return "        ctf_integer($$type[2], $name, CHI_UN($$type[1], $ptr))" if ($t eq "newtype");
    return "        ctf_integer($t, $name, $ptr)" if ($t =~ /^(size_t|u?int\d+_t|bool)$/);
    return "        ctf_integer(uint32_t, $name, $ptr)" if ($t =~ /^(enum)$/);
    return "        ctf_string($name, $ptr)" if ($t eq 'char*');
    return "        ctf_sequence_text(uint8_t, $name, $ptr.bytes, uint32_t, $ptr.size)" if ($t eq 'XyStringRef');
    die "Invalid type $t";
}

my $fns = "";
foreach my $name (sort(keys %type)) {
    if ($name =~ /^XyEvent(\w+)$/) {
        my $field = writeField 4, $type{$name}, "d->";
        $fns .= "static bool CHI_CAT(XFORMAT, Payload$1)(Log* log, const $name* d, XSTATE xstate) {
${field}    return true;
}

";
    }
}

my $mainFn = "";
while ($defs =~ /(DURATION|INSTANT)\s+(\w+)\s+(\w+)\s+(\w+)\s*/g) {
    my $cls = $1;
    my $end    = $cls eq "DURATION" ? "_END" : "";
    my $name = $2;
    my $payload = $4;
    $mainFn .= "    case CHI_EVENT_$name$end: CHI_CAT(XFORMAT, Payload$payload)(log, &e->data->$name$end, xstate); break;\n" if $payload ne "0";
}

write_text "runtime/native/event/writer.h",
        qq(// Generated by generate.pl

${fns}static bool CHI_CAT(XFORMAT, Payload)(Log* log, const Event* e, XSTATE xstate) {
    switch (e->type) {
$mainFn    default: break;
    }
    return true;
}

static bool CHI_CAT(XFORMAT, Event)(Log* log, const Event* e) {
    XINIT(e->type);
    XEVENT_BEGIN(e->type);
    XFIELD("ts", NUM(CHI_UN(Nanos, e->time)));
    if (eventDesc[e->type].cls == CLASS_END)
        XFIELD("dur", NUM(CHI_UN(Nanos, e->dur)));
    if (eventDesc[e->type].ctx != CTX_RUNTIME)
        XFIELD("wid", NUM(CHI_UN(Wid, e->worker->wid)));
    if (eventDesc[e->type].ctx == CTX_THREAD)
        XFIELD("tid", NUM(_chiToUnboxed(chiToThread(e->proc->thread)->tid)));
    if (e->data)
        CHI_CAT(XFORMAT, Payload)(log, e, xstate);
    XEVENT_END(e->type);
    return true;
}

#include "undef.h"
);

my $lttng = "";
while ($defs =~ /(DURATION|INSTANT)\s+(\w+)\s+(\w+)\s+(\w*)\s*/g) {
    my $cls = $1;
    my $name = $2;
    my $ctx = $3;
    my $payload = $4;

    my $end = "";
    if ($cls eq "DURATION") {
        $end = "_END";
        $lttng .= "TRACEPOINT_EVENT(
    xy,
    ${name}_BEGIN,
";
        $lttng .= "    TP_ARGS(";
        if ($ctx eq "THREAD" || $ctx eq "PROCESSOR") {
            $lttng .= "const XyProcessor*, proc";
        } elsif ($ctx eq "WORKER") {
            $lttng .= "const XyWorker*, worker";
        } else {
            $lttng .= "const XyRuntime*, rt";
        }
        $lttng .= "),\n    TP_FIELDS(\n";
        if ($ctx eq "THREAD") {
            $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)proc->rt)\n";
            $lttng .= "        ctf_integer(uint32_t, wid, CHI_UN(Wid, proc->worker->wid))\n";
            $lttng .= "        ctf_integer(uint64_t, tid, _chiToUnboxed(chiToThread(proc->thread)->tid))\n";
        } elsif ($ctx eq "PROCESSOR") {
            $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)proc->rt)\n";
            $lttng .= "        ctf_integer(uint32_t, wid, CHI_UN(Wid, proc->worker->wid))\n";
        } elsif ($ctx eq "WORKER") {
            $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)worker->rt)\n";
            $lttng .= "        ctf_integer(uint32_t, wid, CHI_UN(Wid, worker->wid))\n";
        } else {
            $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)rt)\n";
        }
        $lttng .= "    )\n)\n\n";
    }

    $lttng .= "TRACEPOINT_EVENT(
    xy,
    $name$end,
";

    $lttng .= "    TP_ARGS(";
    if ($ctx eq "THREAD" || $ctx eq "PROCESSOR") {
        $lttng .= "const XyProcessor*, proc";
    } elsif ($ctx eq "WORKER") {
        $lttng .= "const XyWorker*, worker";
    } else {
        $lttng .= "const XyRuntime*, rt";
    }
    if ($payload ne "0") {
        $lttng .= ", ";
        $lttng .= "const XyEvent$payload*, d";
    }

    $lttng .= "),\n    TP_FIELDS(\n";
    if ($ctx eq "THREAD") {
        $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)proc->rt)\n";
        $lttng .= "        ctf_integer(uint32_t, wid, proc->worker->wid)\n";
        $lttng .= "        ctf_integer(uint64_t, tid, _chiToUnboxed(chiToThread(proc->thread)->tid))\n";
    } elsif ($ctx eq "PROCESSOR") {
        $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)proc->rt)\n";
        $lttng .= "        ctf_integer(uint32_t, wid, proc->worker->wid)\n";
    } elsif ($ctx eq "WORKER") {
        $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)worker->rt)\n";
        $lttng .= "        ctf_integer(uint32_t, wid, worker->wid)\n";
    } else {
        $lttng .= "        ctf_integer_hex(uintptr_t, rt, (uintptr_t)rt)\n";
    }
    $lttng .= ctfField($type{"XyEvent$payload"}, "", "d->")if ($payload ne "0");

    $lttng .= "    )\n)\n\n";
}

write_text "runtime/native/event/lttng.h",
        qq(// Generated by generate.pl

#undef TRACEPOINT_PROVIDER
#define TRACEPOINT_PROVIDER xy

#undef TRACEPOINT_INCLUDE
#define TRACEPOINT_INCLUDE "../event/lttng.h"

#if !defined(_CHI_EVENT_LTTNG_H) || defined(TRACEPOINT_HEADER_MULTI_READ)
#define _CHI_EVENT_LTTNG_H

#include "../processor.h"
#include <xy/type/thread.h>
#include <lttng/tracepoint.h>

${lttng}#endif

#include <lttng/tracepoint-event.h>
);

my $dtrace = "";
while ($defs =~ /(DURATION|INSTANT)\s+(\w+)\s+(\w+)\s+(\w*)\s*/g) {
    my $cls = $1;
    my $name = lc $2;
    my $ctx = $3;
    my $payload = $4;
    $name =~ s/_/__/g;
    if ($ctx eq "THREAD" || $ctx eq "PROCESSOR") {
        $ctx = "XyProcessor*";
    } elsif ($ctx eq "WORKER") {
        $ctx = "XyWorker*";
    } else {
        $ctx = "XyRuntime*";
    }
    $payload = $payload eq "0" ? "" : ", XyEvent$payload*";
    if ($cls eq "DURATION") {
        $dtrace .= "  probe ${name}__begin($ctx);\n  probe ${name}__end($ctx$payload);\n";
    } else {
        $dtrace .= "  probe $name($ctx$payload);\n";
    }
}

write_text "runtime/native/event/dtrace.d",
        "/* Generated by generate.pl */

typedef struct {
    uint32_t size;
    uint8_t* bytes;
} XyStringRef;

typedef struct XyRuntime_   XyRuntime;
typedef struct XyWorker_    XyWorker;
typedef struct XyProcessor_ XyProcessor;

${types}provider xy {
$dtrace};
";

my $hash = "";
my $const = "";
my $exp = "";
my $exp2 = "  \$col_ts\n  \$col_dur\n  \$col_wid\n  \$col_tid\n";
my $cols = "our \$col_ts = 1;\nour \$col_dur = 2;\nour \$col_wid = 3;\nour \$col_tid = 4;\n";
for (my $i = 0; $defs =~ /(DURATION|INSTANT)\s+(\w+)\s+(\w+)\s+(\w*)\s*/g; ++$i) {
    my $class = $1;
    my $ev = $2;
    my $ctx = $3;
    my $payload = $4;
    $hash .= qq(@{[$i > 0 ? ",\n  " : '']}$2 => $i);
    $exp .= "  E_$2\n";
    $const .= qq(@{[$i > 0 ? ",\n  " : '']}E_$2 => $i);
    if ($payload ne "0") {
        my $tmp = ctfField($type{"XyEvent$payload"}, $ev, "");
        my $j = 2;
        ++$j if ($class eq "DURATION");
        ++$j if ($ctx ne "RUNTIME");
        ++$j if ($ctx eq "THREAD");
        while ($tmp =~ /(${ev}_\w+)/g) {
            $exp2 .= "  \$col_$1\n";
            $cols .= "our \$col_$1 = $j;\n";
            ++$j;
        }
    }
}

write_text "runtime/native/event/names.pm",
        "# Generated by generate.pl
package event::names;
use strict;
our \@ISA = qw(Exporter);
our \@EXPORT = qw(
  \%E
$exp$exp2);
our \%E = (
  $hash
);
use constant {
  $const
};
${cols}1;
";

my $table = "";
for (my $i = 0; $defs =~ /(DURATION|INSTANT)\s+(\w+)\s+(\w+)\s+(\w*)\s*/g; ++$i) {
    my $class = $1;
    my $ev = $2;
    my $ctx = $3;
    my $payload = $4;
    if ($class eq "DURATION") {
        $class = "Duration";
    } else {
        $class = "Instant";
    }
    if ($payload ne "0") {
        $payload = "XyEvent$payload";
    }
    $ctx = ucfirst (lc $ctx);
    $payload = "" if ($payload eq "0");
    $table .= "|$class|$ev|$ctx|$payload\n";
}

write_text "runtime/native/event/table.adoc",
        qq(// Generated by generate.pl

|===
|Class|Event|Context|Payload

$table|===
);

my $enum = "";
my $contexttypes = "";
my $union = "";
my $names = "";
my $desc = "";
my $statsenum = "";

while ($defs =~ /(DURATION|INSTANT)\s+(\w+)\s+(\w+)\s+(\w+)\s+([^\s]+)/g) {
    my $cls = $1;
    my $name = $2;
    my $ctx = $3;
    my $payload = $4;
    my $stats = $5;

    if ($stats ne "0") {
        $statsenum .= ", \\\n  " if ($statsenum);
        $statsenum .= "STATS_$name";
        if ($stats ne "1") {
            $statsenum .= ", _END_STATS_$name = STATS_$name + $stats - 1";
        }
    }

    $desc .= ", \\\n  " if ($desc);
    $names .= ", \\\n  " if ($names);
    if ($cls eq "DURATION") {
        $desc .= "{ .payload = @{[$payload ne \"0\" ? 1 : 0]}, .stats = @{[$stats ne \"0\" ? \"STATS_$name\" : 'STATS_NONE']}, .ctx = CTX_$ctx, .cls = CLASS_BEGIN }, \\\n  ";
        $desc .= "{ .payload = @{[$payload ne \"0\" ? 1 : 0]}, .stats = @{[$stats ne \"0\" ? \"STATS_$name\" : 'STATS_NONE']}, .ctx = CTX_$ctx, .cls = CLASS_END }";
        $names .= "\"${name}\", \\\n  \"${name}\"";
        $enum .= "  CHI_EVENT_${name}_BEGIN,\n  CHI_EVENT_${name}_END,\n";
    } else {
        $desc .= "{ .payload = @{[$payload ne \"0\" ? 1 : 0]}, .stats = @{[$stats ne \"0\" ? \"STATS_$name\" : 'STATS_NONE']}, .ctx = CTX_$ctx, .cls = CLASS_INSTANT }";
        $names .= "\"$name\"";
        $enum .= "  CHI_EVENT_$name,\n";
    }

    if ($payload ne "0") {
        $union .= $cls eq "DURATION"
            ? "  XyEvent$payload ${name}_END;\n"
            : "  XyEvent$payload ${name};\n";
    }

    if ($ctx eq "RUNTIME") {
        if ($cls eq "DURATION") {
            $contexttypes .= "typedef XyRuntime _CHI_EVENT_CTX_${name}_BEGIN;\n";
            $contexttypes .= "typedef XyRuntime _CHI_EVENT_CTX_${name}_END;\n";
        } else {
            $contexttypes .= "typedef XyRuntime _CHI_EVENT_CTX_${name};\n";
        }
    } elsif ($ctx eq "WORKER") {
        if ($cls eq "DURATION") {
            $contexttypes .= "typedef XyWorker _CHI_EVENT_CTX_${name}_BEGIN;\n";
            $contexttypes .= "typedef XyWorker _CHI_EVENT_CTX_${name}_END;\n";
        } else {
            $contexttypes .= "typedef XyWorker _CHI_EVENT_CTX_${name};\n";
        }
    } else {
        if ($cls eq "DURATION") {
            $contexttypes .= "typedef XyProcessor _CHI_EVENT_CTX_${name}_BEGIN;\n";
            $contexttypes .= "typedef XyProcessor _CHI_EVENT_CTX_${name}_END;\n";
        } else {
            $contexttypes .= "typedef XyProcessor _CHI_EVENT_CTX_${name};\n";
        }
    }
}

$defs =~ s/\s*#.*//sg;
write_text "runtime/native/event/defs.h",
    qq(// Generated by generate.pl
#pragma once

#include <xy/type/string.h>

typedef struct XyRuntime_   XyRuntime;
typedef struct XyWorker_    XyWorker;
typedef struct XyProcessor_ XyProcessor;

$defs

#define _CHI_EVENT_NAME \\
  $names

#define _CHI_EVENT_DESC \\
  $desc

#define _CHI_EVENT_STATS \\
  $statsenum

typedef enum {
$enum  _CHI_EVENT_COUNT
} XyEventType;

typedef union {
$union} XEvent;

$contexttypes);