summaryrefslogtreecommitdiff
path: root/lib/Kratos
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Kratos')
-rw-r--r--lib/Kratos/DFADriver.pm1423
-rw-r--r--lib/Kratos/DFADriver/DFA.pm277
-rw-r--r--lib/Kratos/DFADriver/Model.pm495
3 files changed, 0 insertions, 2195 deletions
diff --git a/lib/Kratos/DFADriver.pm b/lib/Kratos/DFADriver.pm
deleted file mode 100644
index deb758c..0000000
--- a/lib/Kratos/DFADriver.pm
+++ /dev/null
@@ -1,1423 +0,0 @@
-package Kratos::DFADriver;
-
-use strict;
-use warnings;
-use 5.020;
-
-use parent 'Class::Accessor';
-
-use Archive::Tar;
-use AspectC::Repo;
-use Carp;
-use Carp::Assert::More;
-use Cwd;
-use Data::Dumper;
-use DateTime;
-use Device::SerialPort;
-use File::Slurp qw(read_dir read_file write_file);
-use IPC::Run qw(harness);
-use JSON;
-use Kratos::DFADriver::DFA;
-use Kratos::DFADriver::Model;
-use List::Util qw(first);
-use List::MoreUtils qw(pairwise);
-use MIMOSA;
-use MIMOSA::Log;
-
-Kratos::DFADriver->mk_ro_accessors(qw(class_name dfa mimosa model repo));
-
-our $VERSION = '0.00';
-
-sub new {
- my ( $class, %opt ) = @_;
-
- my $self = \%opt;
-
- $self->{dfa} = Kratos::DFADriver::DFA->new(%opt);
- $self->{mimosa} = MIMOSA->new(%opt);
- $self->{repo} = AspectC::Repo->new;
- $self->{lp}{iteration} = 1;
-
- if ( -r $opt{model_file} ) {
- $self->{model} = Kratos::DFADriver::Model->new(%opt);
- $self->{class_name} = $self->{model}->class_name;
- }
- elsif ( $opt{class_name} ) {
- $self->{model} = Kratos::DFADriver::Model->new_from_repo(
- repo => $self->{repo},
- class_name => $opt{class_name},
- model_file => $opt{model_file},
- );
- }
- else {
- die('Neither driver.json nor class name specified, cannot continue');
- }
-
- bless( $self, $class );
-
- $self->set_paths;
- $self->dfa->set_model( $self->model );
-
- return $self;
-}
-
-sub set_paths {
- my ($self) = @_;
-
- my $model_path = $self->{model_file};
- $model_path =~ s{ /?+dfa-driver/[^/]+[.] ( xml | json ) $ }{}x;
-
- my $prefix = $self->{prefix} = cwd() . "/${model_path}/src";
- my $class_prefix
- = $self->repo->get_class_path_prefix( $self->{class_name} );
- $self->{ah_file} = "${prefix}/${class_prefix}_dfa.ah";
- $self->{cc_file} = "${prefix}/${class_prefix}_dfa.cc.inc";
- $self->{h_file} = "${prefix}/${class_prefix}_dfa.h.inc";
-}
-
-sub set_output {
- my ( $self, $mode ) = @_;
-
- if ( $mode eq 'tex' ) {
- $self->{tex} = 1;
- }
-
- return $self;
-}
-
-sub preprocess {
- my ( $self, @files ) = @_;
- my @logs;
- my @json_files;
-
- for my $i ( 0 .. $#files ) {
- push(
- @logs,
- MIMOSA::Log->new(
- data_file => $files[$i],
- fast_analysis => $self->{fast_analysis},
- model => $self->model,
- merge_args => $self->{merge_args},
- tmpsuffix => $i,
- )
- );
- }
-
- for my $log (@logs) {
- if ( not $self->{cache} or not $log->load_cache ) {
- $log->load_archive;
- $log->preprocess;
- $log->save_cache;
- }
- push( @json_files, $log->json_name );
- }
-
- $self->{log} = $logs[0];
- return ( \@logs, \@json_files );
-}
-
-sub analyze {
- my ( $self, @files ) = @_;
- my ( $logs, $json_files ) = $self->preprocess(@files);
- $self->log->analyze( @{$json_files} );
-}
-
-sub crossvalidate_model {
- my ( $self, @files ) = @_;
- my ( $logs, $json_files ) = $self->preprocess(@files);
- $self->log->crossvalidate( @{$json_files} );
-}
-
-sub log {
- my ( $self, $file ) = @_;
-
- if ($file) {
- $self->{log} = undef;
- }
-
- $self->{log} //= MIMOSA::Log->new(
- data_file => $file // $self->{data_file},
- fast_analysis => $self->{fast_analysis},
- model => $self->model,
- merge_args => $self->{merge_args}
- );
-
- return $self->{log};
-}
-
-sub assess_fits {
- my ( $self, $hash, $param, $funtype ) = @_;
-
- $funtype //= 'fit_guess';
-
- my $errmap = $hash->{$funtype}{$param};
- my @errors = map { [ $_, $errmap->{$_} ] } keys %{$errmap};
- @errors = sort { $a->[1]{rmsd} <=> $b->[1]{rmsd} } @errors;
-
- my $min_err = $errors[0][1]{rmsd};
- @errors = grep { $_->[1]{rmsd} <= 2 * $min_err } @errors;
- my @function_types = map {
- sprintf( '%s (%.f / %.2f%%)', $_->[0], $_->[1]{rmsd}, $_->[1]{smape} )
- } @errors;
-
- return @function_types;
-}
-
-sub printf_aggr {
- my ( $self, $hash, $key, $unit ) = @_;
-
- $hash = $hash->{$key};
-
- if ( exists $hash->{median_goodness}{smape} ) {
- printf(
- " %s: static error: %.2f%% / %.f %s (σ = %.f)\n",
- $key,
- $hash->{median_goodness}{smape},
- $hash->{median_goodness}{mae},
- $unit, $hash->{std_inner}
- );
-
-#printf(" %s: median %.f (%.2f / %.2f%%), mean %.f (%.2f / %.2f%%), σ %.f %s\n",
-# $key,
-# $hash->{median},
-# $hash->{median_goodness}{mae} // -1,
-# $hash->{median_goodness}{smape} // -1,
-# $hash->{mean},
-# $hash->{mean_goodness}{mae} // -1,
-# $hash->{mean_goodness}{smape} // -1,
-# $hash->{std_inner},
-# $unit
-#);
- }
- else {
- printf(
- " %s: static error: %.f %s (σ = %.f)\n",
- $key, $hash->{median_goodness}{mae},
- $unit, $hash->{std_inner}
- );
-
- #printf(
- # " %s: median %.f (%.2f), mean %.f (%.2f), σ %.f %s\n",
- # $key, $hash->{median}, $hash->{median_goodness}{mae},
- # $hash->{mean}, $hash->{mean_goodness}{mae},
- # $hash->{std_inner}, $unit
- #);
- }
-}
-
-sub printf_counter_status {
- my ( $self, $hash, $key ) = @_;
-
- $hash = $hash->{$key};
-
- if ( 2**32 / $hash->{median} < 10e6 ) {
- printf( " %s: 32bit energy counter will overflow after %.f ms\n",
- 'power', ( 2**32 / $hash->{median} ) / 1000 );
- }
-}
-
-sub printf_aggr_tex {
- my ( $self, $hash, $key, $unit, $divisor ) = @_;
-
- $hash = $hash->{$key};
-
- if ( $unit eq 'ms' and $hash->{median} < 1e3 ) {
- $unit = '\us';
- $divisor = 1;
- }
- elsif ( $unit eq '\uJ' and $hash->{median} < 1e6 ) {
- $unit = 'nJ';
- $divisor = 1e3;
- }
- elsif ( $unit eq '\uW' and $hash->{median} >= 1e3 ) {
- $unit = 'mW';
- $divisor = 1e3;
- }
-
- use locale;
-
- printf( ' & & \unit[%.3g]{%s}', $hash->{median} / $divisor, $unit );
-}
-
-sub printf_count_tex {
- my ( $self, $hash, $key ) = @_;
-
- if ($hash) {
- $hash = $hash->{$key};
-
- printf( ' & %d', $hash->{count} );
- }
- else {
- printf(' & ');
- }
-}
-
-sub printf_eval_tex {
- my ( $self, $hash, $key, $unit, $divisor ) = @_;
-
- $hash = $hash->{$key};
-
- if ( $unit eq 'ms' and $hash->{median_goodness}{mae} < 1e3 ) {
- $unit = '\us';
- $divisor = 1;
- }
- if ( $unit eq '\uJ' and $hash->{median_goodness}{mae} < 1e6 ) {
- $unit = 'nJ';
- $divisor = 1e3;
- }
-
- use locale;
-
- printf(
- "\n%20s & \\unit[%.3g]{%s} & \\unit[%.2g]{\\%%}",
- q{}, $hash->{median_goodness}{mae} / $divisor,
- $unit, $hash->{median_goodness}{smape} // -1
- );
-}
-
-sub printf_goodness {
- my ( $self, $modval, $hash, $key, $unit ) = @_;
-
- $hash = $hash->{$key};
-
- if ( exists $hash->{goodness}->{smape} ) {
- printf(
-" %s: model %.f %s, log ~=%.f / µ=%.f %s, mean absolute error %.2f %s (%.2f%%)\n",
- $key, $modval,
- $unit, $hash->{median},
- $hash->{mean}, $unit,
- $hash->{goodness}->{mae}, $unit,
- $hash->{goodness}{smape}
- );
- }
- else {
- printf(
-" %s: model %.f %s, log ~=%.f / µ=%.f %s, mean absolute error %.2f %s\n",
- $key, $modval, $unit, $hash->{median}, $hash->{mean}, $unit,
- $hash->{goodness}->{mae}, $unit );
- }
-}
-
-sub printf_online_goodness {
- my ( $self, $hash, $key, $unit ) = @_;
-
- $hash = $hash->{$key};
-
- if ( exists $hash->{goodness}->{smape} ) {
- printf(
- " %s: ~=%.f / µ=%.f %s, mean absolute error %.2f %s (%.2f%%)\n",
- $key, $hash->{median}, $hash->{mean}, $unit,
- $hash->{goodness}->{mae},
- $unit, $hash->{goodness}{smape}
- );
- }
- else {
- printf( " %s: ~=%.f / µ=%.f %s, mean absolute error %.2f %s\n",
- $key, $hash->{median}, $hash->{mean}, $unit,
- $hash->{goodness}->{mae}, $unit );
- }
-}
-
-sub printf_clip {
- my ( $self, $hash ) = @_;
-
- if ( $hash->{clip}{max} > 0.01 ) {
- printf(
- " WARNING: Up to %.f%% clipping in power measurements (avg %.f%%)"
- . ", results are unreliable\n",
- $hash->{clip}{max} * 100,
- $hash->{clip}{mean} * 100
- );
- }
-}
-
-sub printf_parameterized {
- my ( $self, $hash, $key ) = @_;
- $hash = $hash->{$key};
-
- my $std_global = $hash->{std_inner};
- my $std_ind_arg = $hash->{std_arg};
- my $std_ind_param = $hash->{std_param};
- my $std_ind_trace = $hash->{std_trace};
- my $std_by_arg = $hash->{std_by_arg} // {};
- my $std_by_param = $hash->{std_by_param};
- my $std_by_trace = $hash->{std_by_trace} // {};
- my $r_by_param = $hash->{spearmanr_by_param} // {};
- my $arg_ratio;
- my $param_ratio;
- my $trace_ratio;
-
- if ( $std_global > 0 ) {
- $param_ratio = $std_ind_param / $std_global;
- if ( defined $std_ind_arg ) {
- $arg_ratio = $std_ind_arg / $std_global;
- }
- }
- if ( $std_ind_param > 0 ) {
- $trace_ratio = $std_ind_trace / $std_ind_param;
- }
-
- if ( $std_global > 10
- and $param_ratio < 0.5
- and not exists $hash->{function}{user} )
- {
- printf( " %s: should be parameterized (%.2f / %.2f = %.3f)\n",
- $key, $std_ind_param, $std_global, $param_ratio );
- }
- if (
- (
- $std_global < 10
- or $param_ratio > 0.5
- )
- and exists $hash->{function}{user}
- )
- {
- printf( " %s: should not be parameterized (%.2f / %.2f = %.3f)\n",
- $key, $std_ind_param, $std_global,
- $param_ratio ? $param_ratio : 0 );
- }
-
- if ( defined $std_ind_arg
- and $std_global > 10
- and $arg_ratio < 0.5
- and not exists $hash->{function}{user_arg} )
- {
- printf( " %s: depends on arguments (%.2f / %.2f = %.3f)\n",
- $key, $std_ind_arg, $std_global, $arg_ratio );
- }
- if (
- defined $std_ind_arg
- and ( $std_global < 10
- or $arg_ratio > 0.5 )
- and exists $hash->{function}{user_arg}
- )
- {
- printf( " %s: should not depend on arguments (%.2f / %.2f = %.3f)\n",
- $key, $std_ind_arg, $std_global, $arg_ratio ? $arg_ratio : 0 );
- }
-
- if ( $std_global > 10 and $trace_ratio < 0.5 ) {
- printf(
- " %s: model insufficient, depends on trace (%.2f / %.2f = %.3f)\n",
- $key, $std_ind_trace, $std_ind_param, $trace_ratio );
- }
-
- if ( $std_global < 10 ) {
- return;
- }
-
- for my $param ( sort keys %{$std_by_param} ) {
- my $std_this = $std_by_param->{$param};
- my $ratio = $std_ind_param / $std_this;
- my $status = 'does not depend';
- my $fline = q{};
- if ( $ratio < 0.6 ) {
- $status = 'might depend';
- $fline = q{, probably };
- $fline .= join( ' or ', $self->assess_fits( $hash, $param ) );
- }
- if ( $ratio < 0.3 ) {
- $status = 'depends';
- }
- if ($fline) {
- printf( " %s: %s on global %s (%.2f / %.2f = %.3f%s)\n",
- $key, $status, $param, $std_ind_param, $std_this, $ratio,
- $fline );
- }
- if ( exists $r_by_param->{$param} ) {
- printf( " %s: spearman_r for global %s is %.3f (p = %.3f)\n",
- $key, $param, $r_by_param->{$param}, -1 );
- }
- }
-
- for my $arg ( sort keys %{$std_by_arg} ) {
- my $std_this = $std_by_arg->{$arg};
- my $ratio = $std_ind_arg / $std_this;
- my $status = 'does not depend';
- my $fline = q{};
- if ( $ratio < 0.6 ) {
- $status = 'might depend';
- $fline = q{, probably };
- $fline .= join( ' or ',
- $self->assess_fits( $hash, $arg, 'arg_fit_guess' ) );
- }
- if ( $ratio < 0.3 ) {
- $status = 'depends';
- }
- if ($fline) {
- printf( " %s: %s on local %s (%.2f / %.2f = %.3f%s)\n",
- $key, $status, $arg, $std_ind_arg, $std_this, $ratio, $fline );
- }
- }
-
- for my $transition ( sort keys %{$std_by_trace} ) {
- my $std_this = $std_by_trace->{$transition};
- my $ratio = $std_ind_trace / $std_this;
- if ( $ratio < 0.4 ) {
- printf(
-" %s: depends on presence of %s in trace (%.2f / %.2f = %.3f)\n",
- $key, $transition, $std_ind_trace, $std_this, $ratio );
- }
- }
-}
-
-sub printf_fit {
- my ( $self, $hash, $key, $unit ) = @_;
- $hash = $hash->{$key};
-
- for my $funtype ( sort keys %{ $hash->{function} } ) {
- if ( exists $hash->{function}{$funtype}{error} ) {
- printf( " %s: %s function could not be fitted: %s\n",
- $key, $funtype, $hash->{function}{$funtype}{error} );
- }
- else {
- printf(
- " %s: %s function fit error: %.2f%% / %.f %s\n",
- $key, $funtype,
- $hash->{function}{$funtype}{fit}{smape} // -1,
- $hash->{function}{$funtype}{fit}{mae}, $unit
- );
- }
- }
-
- for my $pair (
- [ 'param_mean_goodness', 'param mean/ssr-fit' ],
- [ 'param_median_goodness', 'param median/static' ],
- [ 'arg_mean_goodness', 'arg mean/ssr-fit' ],
- [ 'arg_median_goodness', 'arg median/static' ]
- )
- {
- my ( $goodness, $desc ) = @{$pair};
- if ( exists $hash->{$goodness} ) {
- printf(
- " %s: %s LUT error: %.2f%% / %.f %s / %.f\n",
- $key, $desc,
- $hash->{$goodness}{smape} // -1,
- $hash->{$goodness}{mae},
- $unit, $hash->{$goodness}{rmsd}
- );
- }
- }
-}
-
-sub assess_model {
- my ($self) = @_;
-
- for my $name ( sort keys %{ $self->{log}{aggregate}{state} } ) {
- my $state = $self->{log}{aggregate}{state}{$name};
-
- printf( "Assessing %s:\n", $name );
-
- $self->printf_clip($state);
- $self->printf_aggr( $state, 'power', 'µW' );
- $self->printf_counter_status( $state, 'power' );
- $self->printf_parameterized( $state, 'power' );
- $self->printf_fit( $state, 'power', 'µW' );
- }
- for my $name ( sort keys %{ $self->{log}{aggregate}{transition} } ) {
- my $transition = $self->{log}{aggregate}{transition}{$name};
-
- printf( "Assessing %s:\n", $name );
-
- $self->printf_clip($transition);
- $self->printf_aggr( $transition, 'duration', 'µs' );
- $self->printf_parameterized( $transition, 'duration' );
- $self->printf_fit( $transition, 'duration', 'µs' );
- $self->printf_aggr( $transition, 'energy', 'pJ' );
- $self->printf_parameterized( $transition, 'energy' );
- $self->printf_fit( $transition, 'energy', 'pJ' );
- $self->printf_aggr( $transition, 'rel_energy_prev', 'pJ' );
- $self->printf_parameterized( $transition, 'rel_energy_prev' );
- $self->printf_fit( $transition, 'rel_energy_prev', 'pJ' );
-
- if ( exists $transition->{rel_energy_next}{median} ) {
- $self->printf_aggr( $transition, 'rel_energy_next', 'pJ' );
- $self->printf_parameterized( $transition, 'rel_energy_next' );
- $self->printf_fit( $transition, 'rel_energy_next', 'pJ' );
- }
-
- if ( exists $transition->{timeout}{median} ) {
- $self->printf_aggr( $transition, 'timeout', 'µs' );
- $self->printf_parameterized( $transition, 'timeout' );
- $self->printf_fit( $transition, 'timeout', 'µs' );
- }
- }
-
-}
-
-sub assess_model_tex {
- my ($self) = @_;
- say '\begin{tabular}{|c|rrr|r|}\\hline';
- say 'Zustand & $\MmedP$ & & & $n$ \\\\\\hline';
- for my $name ( sort keys %{ $self->{log}{aggregate}{state} } ) {
- my $state = $self->{log}{aggregate}{state}{$name};
-
- printf( "\n%20s", $name );
-
- $self->printf_aggr_tex( $state, 'power', '\uW', 1 );
- $self->printf_eval_tex( $state, 'power', '\uW', 1 );
- $self->printf_count_tex( $state, 'power' );
- print " \\\\";
- }
- say '\end{tabular}\\\\';
- say '\vspace{0.5cm}';
- say '\begin{tabular}{|c|rr|rr|rr|r|}\\hline';
- say 'Transition & & $\MmedE$ & & $\MmedF$ & & $\Mmeddur$ & $n$ \\\\\\hline';
- for my $name ( sort keys %{ $self->{log}{aggregate}{transition} } ) {
- my $transition = $self->{log}{aggregate}{transition}{$name};
-
- printf( "\n%20s", $name );
-
- $self->printf_aggr_tex( $transition, 'energy', '\uJ', 1e6 );
- $self->printf_aggr_tex( $transition, 'rel_energy_prev', '\uJ', 1e6 );
- $self->printf_aggr_tex( $transition, 'rel_energy_next', '\uJ', 1e6 );
- $self->printf_aggr_tex( $transition, 'duration', 'ms', 1e3 );
- $self->printf_count_tex( $transition, 'energy' );
- print " \\\\";
- $self->printf_eval_tex( $transition, 'energy', '\uJ', 1e6 );
- $self->printf_eval_tex( $transition, 'rel_energy_prev', '\uJ', 1e6 );
- $self->printf_eval_tex( $transition, 'rel_energy_next', '\uJ', 1e6 );
- $self->printf_eval_tex( $transition, 'duration', 'ms', 1e3 );
- $self->printf_count_tex;
- print " \\\\";
- }
- print "\\hline\n";
- say '\end{tabular}';
-}
-
-sub assess_workload {
- my ( $self, $workload ) = @_;
-
- $workload =~ s{ \s* \) \s* ; \s* }{:}gx;
- $workload =~ s{ \s* \) \s* $ }{}gx;
- $workload =~ s{ \s* ; \s* }{!:}gx;
- $workload =~ s{ \s* \( \s* }{!}gx;
- $workload =~ s{ \s* , \s* }{!}gx;
- $workload =~ s{ [^!] \K $ }{!}gx;
-
- say $workload;
-
- my $traces = $self->dfa->run_str_to_trace($workload);
-}
-
-sub update_model {
- my ($self) = @_;
-
- for my $name ( sort keys %{ $self->{log}{aggregate}{state} } ) {
- my $state = $self->{log}{aggregate}{state}{$name};
- $self->model->set_state_power( $name, $state->{power}{median} );
- for my $fname ( keys %{ $state->{power}{function} } ) {
- $self->model->set_state_params(
- $name, $fname,
- $state->{power}{function}{$fname}{raw},
- @{ $state->{power}{function}{$fname}{params} }
- );
- }
- if ( $self->{with_lut} ) {
- $self->model->set_state_lut( $name, 'power',
- $state->{power}{median_by_param} );
- }
- }
- for my $name ( sort keys %{ $self->{log}{aggregate}{transition} } ) {
- my $transition = $self->{log}{aggregate}{transition}{$name};
- my @keys = (qw(duration energy rel_energy_prev rel_energy_next));
-
- if (
- $self->model->get_transition_by_name($name)->{level} eq 'epilogue' )
- {
- push( @keys, 'timeout' );
- }
-
- for my $key (@keys) {
- $self->model->set_transition_property( $name, $key,
- $transition->{$key}{median} );
- for my $fname ( keys %{ $transition->{$key}{function} } ) {
- $self->model->set_transition_params(
- $name,
- $key,
- $fname,
- $transition->{$key}{function}{$fname}{raw},
- @{ $transition->{$key}{function}{$fname}{params} }
- );
- }
- if ( $self->{with_lut} ) {
- $self->model->set_transition_lut( $name, $key,
- $transition->{$key}{median_by_param} );
- }
- }
- }
-
- $self->model->set_voltage(
- $self->{log}{aggregate}{min_voltage},
- $self->{log}{aggregate}{max_voltage}
- );
-
- $self->model->save;
-}
-
-sub reset_model {
- my ($self) = @_;
-
- $self->model->reset;
- $self->model->save;
-}
-
-sub to_ah {
- my ($self) = @_;
- my $class_name = $self->{class_name};
- my $repo = $self->repo;
- my $class_header = $repo->{class}{$class_name}{sources}[0]{file};
-
- my @transition_names
- = grep { $_ ne q{?} } map { $_->{name} } $self->model->transitions;
-
- my $trigger_port = $self->{trigger_port};
- my $trigger_pin = $self->{trigger_pin};
-
- my $ignore_nested = q{};
- my $adv_type = 'execution';
- my $pass_function = $self->{logging} ? 'logTransition' : 'passTransition';
-
- if ( $self->{ignore_nested} ) {
- $adv_type = 'call';
- $ignore_nested = "&& !within(\"${class_name}\")";
- }
-
- my $ah_buf = <<"EOF";
-
-#ifndef ${class_name}_DFA_AH
-#define ${class_name}_DFA_AH
-
-#include "drivers/dfa_driver.h"
-#include "drivers/gpio.h"
-#include "drivers/eUSCI_A/uart/prototype_uart.h"
-#include "${class_header}"
-
-EOF
-
- if ( defined $trigger_port and defined $trigger_pin ) {
-
- $ah_buf .= "aspect ${class_name}_Trigger {\n\n";
-
- $ah_buf .= 'pointcut Transition() = "'
- . join( q{" || "},
- map { "% ${class_name}::$_(...)" } @transition_names )
- . "\";\n\n";
- $ah_buf .= <<"EOF";
-
- advice execution("void initialize_devices()") : after() {
- setOutput(${trigger_port}, ${trigger_pin});
- }
-
- advice ${adv_type}(Transition()) ${ignore_nested} : before() {
- pinHigh(${trigger_port}, ${trigger_pin});
- }
- advice ${adv_type}(Transition()) ${ignore_nested} : after() {
- /* 22 = 10.2us delay @ 16MHz */
- /* 32 = 14.6us delay @ 16MHz */
- /* 64 = 28.6us delay @ 16MHz */
- /* 160 = 50.6us delay @ 16MHz */
- for (unsigned int i = 0; i < 64; i++)
- asm volatile("nop");
- pinLow(${trigger_port}, ${trigger_pin});
- }
-
- advice execution(Transition()) : order("${class_name}_DFA", "${class_name}_Trigger");
-
-EOF
-
- if ( $self->{ignore_nested} ) {
- for my $transition ( $self->model->transitions ) {
- if ( $transition->{level} eq 'epilogue' ) {
- $ah_buf .= <<"EOF";
-
- advice execution("% ${class_name}::$transition->{name}(...)") : before() {
- pinHigh(${trigger_port}, ${trigger_pin});
- }
- advice execution("% ${class_name}::$transition->{name}(...)") : after() {
- for (unsigned int i = 0; i < 64; i++)
- asm volatile("nop");
- pinLow(${trigger_port}, ${trigger_pin});
- }
-
-EOF
- }
- }
- }
- $ah_buf .= "};\n\n";
- }
-
- $ah_buf .= "aspect ${class_name}_DFA {\n\n";
-
- for my $transition ( $self->model->transitions ) {
- if ( $transition->{name} ne q{?} ) {
- my $dest_state_id
- = $self->model->get_state_id( $transition->{destination} );
- if ( $transition->{level} eq 'user' ) {
- $ah_buf .= <<"EOF";
-
- advice ${adv_type}("% ${class_name}::$transition->{name}(...)") ${ignore_nested} : after() {
- tjp->target()->${pass_function}(${class_name}::statepower[tjp->target()->state],
- $transition->{rel_energy_prev}{static}, $transition->{id},
- ${dest_state_id});
- };
-
-EOF
- }
- else {
- $ah_buf .= <<"EOF";
-
- advice execution("% ${class_name}::$transition->{name}(...)") : after() {
- tjp->target()->${pass_function}(${class_name}::statepower[tjp->target()->state],
- $transition->{rel_energy_prev}{static}, $transition->{id},
- ${dest_state_id});
- };
-
-EOF
- }
- }
- }
-
- $ah_buf .= <<"EOF";
-
-};
-#endif
-
-EOF
-
- return $ah_buf;
-}
-
-sub to_cc {
- my ($self) = @_;
- my $class_name = $self->{class_name};
-
- my @state_enum = $self->model->get_state_enum;
- my %param_default;
-
- for my $default_setting ( @{ $self->{param_default} } ) {
- my ( $param, $value ) = split( qr{ = }x, $default_setting );
- $param_default{$param} = $value;
- }
-
- my $buf = "DFA_Driver::power_uW_t ${class_name}::statepower[] = {" . join(
- ', ',
- map {
- sprintf(
- '%.f',
- $self->model->get_state_power_with_params(
- $_, \%param_default
- )
- )
- } @state_enum
- ) . "};\n";
-
- return $buf;
-}
-
-sub to_h {
- my ($self) = @_;
-
- my @state_enum = $self->model->get_state_enum;
-
- my $buf
- = "public:\n"
- . "static power_uW_t statepower[];\n"
- . "enum State : uint8_t {"
- . join( ', ', @state_enum ) . "};\n";
-
- return $buf;
-}
-
-sub to_tikz {
- my ($self) = @_;
-
- my $buf = <<'EOF';
-
- \begin{tikzpicture}[node distance=3cm,>=stealth',bend angle=45,auto,->]
- \tikzstyle{state}=[ellipse,thick,draw=black!75,minimum size=1cm,inner sep=2pt]
-
-EOF
-
- my @state_enum = $self->model->get_state_enum;
- my $initial = shift(@state_enum);
- my $prev = $initial;
- my $ini_name = $initial;
-
- if ( $ini_name eq 'UNINITIALIZED' ) {
- $ini_name = '?';
- }
-
- $buf
- .= "\t\t\\node [state,initial,initial text={},initial where=left] ($initial) {\\small $ini_name};\n";
- for my $state (@state_enum) {
- $buf
- .= "\t\t\\node [state,right of=${prev}] ($state) {\\small $state};\n";
- $prev = $state;
- }
-
- $buf .= "\n\t\t\\path\n";
-
- for my $transition ( $self->model->transitions ) {
- for my $transition_elem ( @{ $transition->{transitions} } ) {
- my ( $origin, $destination ) = @{$transition_elem};
- my @edgestyles;
- if ( $transition->{level} eq 'epilogue' ) {
- push( @edgestyles, 'dashed' );
- }
- if ( $origin eq $destination ) {
- push( @edgestyles, 'loop above' );
- }
- my $edgestyle
- = @edgestyles ? '[' . join( q{,}, @edgestyles ) . ']' : q{};
- $buf
- .= "\t\t ($origin) edge ${edgestyle} node {$transition->{name}} ($destination)\n";
- }
- }
- $buf .= "\t\t;\n";
- $buf .= "\t\\end{tikzpicture}\n";
-
- return $buf;
-}
-
-sub to_test_ah {
- my ($self) = @_;
-
- my $buf = <<"EOF";
-
-/*
- * Autogenerated code -- Manual changes are not preserved
- * vim:readonly
- */
-
-#ifndef DRIVEREVAL_AH
-#define DRIVEREVAL_AH
-
-#include "DriverEval.h"
-#include "syscall/guarded_scheduler.h"
-
-aspect StartDFADriverEvalThread {
- advice execution("void ready_threads()") : after() {
- organizer.Scheduler::ready(driverEvalThread);
- }
-};
-
-#endif
-
-EOF
-
- return $buf;
-}
-
-sub to_test_cc {
- my ($self) = @_;
-
- my $class_name = $self->{class_name};
- my @runs = $self->dfa->traces;
- my @state_enum = $self->model->get_state_enum;
- my $dfa = $self->dfa->dfa;
- my $num_runs = @runs;
- my $instance = $self->repo->get_class_instance( $self->{class_name} );
-
- my $state_duration = $self->{state_duration} // 1000;
-
- my $buf = <<"EOF";
-
-/*
- * Autogenerated code - Manual changes are not preserved.
- * vim:readonly
- */
-
-#include "DriverEval.h"
-#include "syscall/guarded_buzzer.h"
-
-DeclareThread(DriverEvalThread_${class_name}, driverEvalThread, 256);
-
-EOF
-
- $buf .= <<"EOF";
-void DriverEvalThread_${class_name}::action()
-{
- Guarded_Buzzer buzzer;
-
- while (1) {
-
- /* wait for MIMOSA calibration */
- buzzer.sleep(12000);
- buzzer.set(${state_duration});
-
-
-EOF
-
- $buf .= "${instance}.startIteration(${num_runs});\n";
-
- for my $run (@runs) {
- $buf .= "\t\t/* test run $run->{id} start */\n";
- $buf .= "\t\t${instance}.resetLogging();\n";
-
- # $buf .= "\t\t${instance}.resetAccounting();\n"; # TODO sinnvoll?
- my $state = 0;
- for my $transition ( grep { $_->{isa} eq 'transition' }
- @{ $run->{trace} } )
- {
- my ( $cmd, @args ) = @{ $transition->{code} };
- my ($new_state)
- = $dfa->successors( $state, ":${cmd}!" . join( '!', @args ) );
- my $state_name = $self->dfa->reduced_id_to_state($state);
- my $new_state_name = $self->dfa->reduced_id_to_state($new_state);
- $buf .= "\t\t/* Transition $state_name -> $new_state_name */\n";
-
- if ( $self->model->get_transition_by_name($cmd)->{level} eq
- 'epilogue' )
- {
- $buf .= "\t\t/* wait for $cmd interrupt */\n";
- $buf .= "\t\tbuzzer.sleep();\n";
- }
- else {
- $buf .= sprintf( "\t\t%s.%s(%s);\n",
- $instance, $cmd, join( ', ', @args ) );
- $buf .= "\t\tbuzzer.sleep();\n";
- }
- $buf .= $self->model->after_transition_code;
- $state = $new_state;
- }
- $buf .= "\t\t${instance}.dumpLog();\n\n";
- }
-
- $buf .= "${instance}.stopIteration(); }}\n";
-
- return $buf;
-}
-
-sub to_test_h {
- my ($self) = @_;
- my $class_name = $self->{class_name};
-
- my $class_prefix = $self->repo->get_class_path_prefix($class_name);
-
- my $buf = <<"EOF";
-
-/*
- * Autogenerated code -- Manual changes are not preserved
- * vim:readonly
- */
-
-#ifndef DRIVEREVAL_H
-#define DRIVEREVAL_H
-
-#include "${class_prefix}.h"
-#include "syscall/thread.h"
-
-class DriverEvalThread_${class_name} : public Thread {
- public:
- DriverEvalThread_${class_name}(void* tos) : Thread(tos) { }
- void action();
-};
-
-extern DriverEvalThread_${class_name} driverEvalThread;
-
-#endif
-
-EOF
-
- return $buf;
-}
-
-sub to_test_json {
- my ($self) = @_;
-
- return JSON->new->encode( [ $self->dfa->traces ] );
-}
-
-sub rm_acc_files {
- my ($self) = @_;
-
- for my $file ( $self->{ah_file}, $self->{cc_file}, $self->{h_file} ) {
- if ( -e $file ) {
- unlink($file);
- }
- }
-
- return $self;
-}
-
-sub write_test_files {
- my ($self) = @_;
-
- my $prefix = $self->{prefix} . '/apps/DriverEval';
-
- if ( not -d $prefix ) {
- mkdir($prefix);
- }
-
- write_file( "${prefix}/DriverEval.ah", $self->to_test_ah );
- write_file( "${prefix}/DriverEval.cc", $self->to_test_cc );
- write_file( "${prefix}/DriverEval.h", $self->to_test_h );
- write_file( "${prefix}/DriverEval.json", $self->to_test_json );
-
- # Old log may no longer apply to new test files
- unlink("${prefix}/DriverLog.txt");
-
- return $self;
-}
-
-sub rm_test_files {
- my ($self) = @_;
-
- my $prefix = $self->{prefix} . '/apps/DriverEval/DriverEval';
-
- for my $file ( "${prefix}.ah", "${prefix}.cc", "${prefix}.h" ) {
- if ( -e $file ) {
- unlink($file);
- }
- }
-
- return $self;
-}
-
-sub archive_files {
- my ($self) = @_;
-
- $self->{lp}{timestamp} //= DateTime->now( time_zone => 'Europe/Berlin' )
- ->strftime('%Y%m%d_%H%M%S');
-
- my $tar = Archive::Tar->new;
-
- my @eval_files = (
- ( map { "src/apps/DriverEval/DriverEval.$_" } (qw(ah cc h json)) ),
- ( map { "src/apps/DriverEval/DriverLog.$_" } (qw(json txt)) ),
- );
-
- my @mim_files = grep { m{ \. mim }x } read_dir('.');
-
- $tar->add_files( $self->{model_file}, @eval_files, @mim_files );
-
- $tar->add_data(
- 'setup.json',
- JSON->new->encode(
- {
- excluded_states => $self->{excluded_states},
- ignore_nested => $self->{ignore_nested},
- mimosa_offset => $self->{mimosa_offset},
- mimosa_shunt => $self->{mimosa_shunt},
- mimosa_voltage => $self->{mimosa_voltage},
- state_duration => $self->{state_duration},
- trace_filter => $self->{trace_filter},
- trace_revisit => $self->{trace_revisit},
- trigger_pin => $self->{trigger_pin},
- trigger_port => $self->{trigger_port},
- }
- )
- );
-
- my $filename = "../data/$self->{lp}{timestamp}_$self->{class_name}";
- if ( $self->{filename_suffix} ) {
- $filename .= '_' . $self->{filename_suffix};
- }
- $filename .= '.tar';
-
- $tar->write($filename);
-
- return $self;
-}
-
-sub write_acc_files {
- my ($self) = @_;
-
- write_file( $self->{ah_file}, $self->to_ah );
- write_file( $self->{cc_file}, $self->to_cc );
- write_file( $self->{h_file}, $self->to_h );
-
- return $self;
-}
-
-sub launchpad_connect {
- my ($self) = @_;
-
- $self->{port_file} //= '/dev/ttyACM1';
- $self->{port} = Device::SerialPort->new( $self->{port_file} )
- or croak("Error openig serial port $self->{port_file}");
-
- $self->{port}->baudrate( $self->{baud_rate} // 115200 );
- $self->{port}->databits(8);
- $self->{port}->parity('none');
- $self->{port}->read_const_time(500);
-
- return $self;
-}
-
-sub launchpad_flash {
- my ($self) = @_;
-
- my ( $make_buf, $prog_buf );
-
- my $remake = harness(
- [ 'make', '-B' ],
- '<' => \undef,
- '>&' => \$make_buf,
- );
-
- my $make_program = harness(
- [ 'make', 'program' ],
- '<' => \undef,
- '>&' => \$prog_buf,
- );
-
- $remake->run
- or croak( 'make -B returned ' . $remake->full_result );
- $make_program->run
- or croak( 'make program returned ' . $remake->full_result );
-
- return $self;
-}
-
-sub launchpad_reset {
- my ($self) = @_;
-
- my $output_buffer;
- my $make_reset = harness(
- [ 'make', 'reset' ],
- '<' => \undef,
- '>&' => \$output_buffer,
- );
-
- $make_reset->run
- or croak( 'make reset returned ' . $make_reset->full_result );
-
- return $self;
-}
-
-sub launchpad_log_clean {
- my ($self) = @_;
-
- for my $file ( read_dir('.') ) {
- if ( $file =~ m{ \. mim $ }x ) {
- unlink($file);
- }
- }
-}
-
-sub launchpad_log_init {
- my ($self) = @_;
-
- $self->{lp}{run_id} = 0;
- $self->{lp}{sync} = 0;
- $self->{lp}{calibrating} = 0;
- $self->{lp}{run_done} = 0;
- $self->{lp}{run} = [];
- $self->{lp}{log} = [];
- $self->{lp}{errors} = [];
- $self->{lp}{log_buf} = q{};
-
- $self->{lp}{re}{iter_start} = qr{
- ^ \[ EP \] \s iteration \s start, \s (?<runs> \d+ ) \s runs $
- }x;
- $self->{lp}{re}{iter_stop} = qr{
- ^ \[ EP \] \s iteration \s stop $
- }x;
- $self->{lp}{re}{run_start} = qr{
- ^ \[ EP \] \s run \s start $
- }x;
- $self->{lp}{re}{run_stop} = qr{
- ^ \[ EP \] \s run \s stop, \s energyUsed = (?<total_e> \S+) $
- }x;
- $self->{lp}{re}{transition} = qr{
- ^ \[ EP \] \s dt = (?<delta_t> \S+) \s de = (?<delta_e> \S+) \s
- oldst = (?<old_state> \S+ ) \s trid = (?<transition_id> \S+ ) $
- }x;
-
- $self->launchpad_connect;
-
- return $self;
-}
-
-sub launchpad_run_done {
- my ($self) = @_;
-
- if ( $self->{lp}{run_done} ) {
- $self->{lp}{run_done} = 0;
- return 1;
- }
- return 0;
-}
-
-sub launchpad_get_errors {
- my ($self) = @_;
-
- my @errors = @{ $self->{lp}{errors} };
- $self->{lp}{errors} = [];
- return @errors;
-}
-
-sub launchpad_log_is_synced {
- my ($self) = @_;
-
- return $self->{lp}{sync};
-}
-
-sub launchpad_log_status {
- my ($self) = @_;
-
- return ( $self->{lp}{iteration}, $self->{lp}{run_id},
- $self->{lp}{num_runs} );
-}
-
-sub launchpad_log_read {
- my ($self) = @_;
-
- my $port = $self->{port};
-
- my ( $count, $chars ) = $port->read(1024);
-
- $self->{lp}{log_buf} .= $chars;
-
- if ( not defined $count ) {
- $port->close;
- croak("Serial port was disconnected");
- }
- if ( $count > 0 ) {
- my @lines = split( /\n\r|\r\n/, $chars );
- for my $line (@lines) {
- $self->launchpad_parse_line($line);
- }
- }
-}
-
-sub merged_json {
- my ($self) = @_;
-
- my @traces = $self->dfa->traces;
-
- for my $run ( @{ $self->{lp}{log} } ) {
- my $trace_idx = $run->{id} - 1;
- my $idx = 0;
-
- assert_is( $traces[$trace_idx]{id}, $run->{id} );
- push( @{ $traces[$trace_idx]{total_energy} }, $run->{total_energy} );
- for my $online_obj ( @{ $run->{trace} } ) {
- my $plan_obj = $traces[$trace_idx]{trace}[$idx];
-
- #printf("%-15s %-15s\n", $plan_obj->{name}, $online_obj->{name});
-
- if ( not defined $plan_obj->{name} ) {
-
- # The planned test run is done, but the hardware reported an
- # epilogue-level transition before the next run was started.
-
- $traces[$trace_idx]{trace}[$idx] = {
- isa => $online_obj->{isa},
- name => $online_obj->{name},
- parameter =>
- $traces[$trace_idx]{trace}[ $idx - 1 ]{parameter},
- };
- if (
- exists $traces[$trace_idx]{trace}[ $idx - 1 ]
- {final_parameter} )
- {
- $traces[$trace_idx]{trace}[$idx]{parameter}
- = $traces[$trace_idx]{trace}[ $idx - 1 ]{final_parameter};
- }
- }
- else {
- if ( $online_obj->{isa} ne $plan_obj->{isa} ) {
- printf(
-"Log merge: ISA mismatch (should be %s, is %s) at index %d#%d\n",
- $plan_obj->{isa}, $online_obj->{isa}, $trace_idx,
- $idx );
- $self->mimosa->kill;
- exit(1);
- }
- if ( $plan_obj->{name} ne 'UNINITIALIZED' ) {
- if ( $online_obj->{name} ne $plan_obj->{name} ) {
- printf(
-"Log merge: name mismatch (should be %s, is %s) at index %d#%d\n",
- $plan_obj->{name}, $online_obj->{name}, $trace_idx,
- $idx );
- $self->mimosa->kill;
- exit(1);
- }
- }
- }
-
- push(
- @{ $traces[$trace_idx]{trace}[$idx]{online} },
- $online_obj->{online}
- );
-
- $idx++;
- }
- }
-
- $self->{lp}{log} = [];
-
- return @traces;
-}
-
-sub launchpad_parse_line {
- my ( $self, $line ) = @_;
-
- if ( $line =~ $self->{lp}{re}{iter_start} ) {
- $self->{lp}{sync} = 1;
- $self->{lp}{run_id} = 0;
- $self->{lp}{num_runs} = $+{runs};
- $self->{lp}{calibrating} = 0;
- }
- elsif ( not $self->{lp}{sync} ) {
- return;
- }
- elsif ( $line =~ $self->{lp}{re}{iter_stop} ) {
- $self->{lp}{iteration}++;
- $self->{lp}{calibrating} = 1;
- write_file( '../kratos/src/apps/DriverEval/DriverLog.txt',
- $self->{lp}{log_buf} );
- write_file(
- '../kratos/src/apps/DriverEval/DriverLog.json',
- JSON->new->encode( [ $self->merged_json ] )
- );
- }
- elsif ( $line =~ $self->{lp}{re}{run_start} ) {
- $self->{lp}{run_id}++;
- $self->{lp}{run} = [];
- }
- elsif ( $line =~ $self->{lp}{re}{run_stop} ) {
- $self->{lp}{run_done} = 1;
- push(
- @{ $self->{lp}{log} },
- {
- id => $self->{lp}{run_id},
- trace => [ @{ $self->{lp}{run} } ],
- total_energy => 0 + $+{total_e},
- }
- );
- }
- elsif ( $line =~ $self->{lp}{re}{transition} ) {
- push(
- @{ $self->{lp}{run} },
- {
- isa => 'state',
- name => ( $self->model->get_state_enum )[ $+{old_state} ],
- online => {
- time => 0 + $+{delta_t},
- energy => 0 + $+{delta_e},
- power => 0 + $+{delta_e} / $+{delta_t},
- },
- },
- {
- isa => 'transition',
- name =>
- $self->model->get_transition_by_id( $+{transition_id} )
- ->{name},
- online => {
- timeout => 0 + $+{delta_t},
- },
- },
- );
- }
- else {
- $self->{lp}{sync} = 0;
- push( @{ $self->{lp}{errors} }, "Cannot parse $line" );
- }
-
-}
-
-1;
diff --git a/lib/Kratos/DFADriver/DFA.pm b/lib/Kratos/DFADriver/DFA.pm
deleted file mode 100644
index 9b581d8..0000000
--- a/lib/Kratos/DFADriver/DFA.pm
+++ /dev/null
@@ -1,277 +0,0 @@
-package Kratos::DFADriver::DFA;
-
-use strict;
-use warnings;
-use 5.020;
-
-use parent 'Class::Accessor';
-
-use Data::Dumper;
-use FLAT::DFA;
-use Math::Cartesian::Product;
-
-Kratos::DFADriver::DFA->mk_ro_accessors(qw(model));
-
-our $VERSION = '0.00';
-
-sub new {
- my ( $class, %opt ) = @_;
-
- my $self = \%opt;
-
- bless( $self, $class );
-
- return $self;
-}
-
-sub set_model {
- my ( $self, $model ) = @_;
-
- $self->{model} = $model;
-
- return $self;
-}
-
-sub reduced_id_to_state {
- my ( $self, $id ) = @_;
-
- if ( not( $self->{excluded_states} and @{ $self->{excluded_states} } ) ) {
- return $self->model->get_state_name($id);
- }
-
- my @excluded
- = map { $self->model->get_state_id($_) } @{ $self->{excluded_states} };
- @excluded = reverse sort { $a <=> $b } @excluded;
- my @state_enum = $self->model->get_state_enum;
-
- for my $state (@excluded) {
- splice( @state_enum, $state, 1 );
- }
-
- return $state_enum[$id];
-}
-
-sub dfa {
- my ($self) = @_;
-
- if ( exists $self->{dfa} ) {
- return $self->{dfa};
- }
-
- my $dfa = FLAT::DFA->new();
- my @state_enum = $self->model->get_state_enum;
-
- $dfa->add_states( scalar @state_enum );
- $dfa->set_starting(0);
- $dfa->set_accepting( $dfa->get_states );
-
- for my $transition ( $self->model->transitions ) {
- print Dumper( $transition->{parameters} );
-
- for my $param ( @{ $transition->{parameters} } ) {
- if ( not defined $param->{values} ) {
- die(
-"argument values for transition $transition->{name} are undefined\n"
- );
- }
- if ( @{ $param->{values} } == 0 ) {
- die(
-"argument-value list for transition $transition->{name} is empty \n"
- );
- }
- }
-
- my @argtuples
- = cartesian { 1 } map { $_->{values} } @{ $transition->{parameters} };
-
- # cartesian will return a one-element list containing a reference to
- # an empty array if @{$transition->{parameters}} is empty
-
- for my $argtuple (@argtuples) {
- for my $transition_pair ( @{ $transition->{transitions} } ) {
- my ( $origin, $destination ) = @{$transition_pair};
- $dfa->add_transition(
- $self->model->get_state_id($origin),
- $self->model->get_state_id($destination),
- ':' . $transition->{name} . '!' . join( '!', @{$argtuple} )
- );
- }
- }
- }
-
- if ( $self->{excluded_states} and @{ $self->{excluded_states} } ) {
- my @to_delete = map { $self->model->get_state_id($_) }
- @{ $self->{excluded_states} };
- $dfa->delete_states(@to_delete);
- }
-
- $self->{dfa} = $dfa;
-
- say $dfa->as_summary;
-
- return $dfa;
-}
-
-sub run_str_to_trace {
- my ( $self, $run_str ) = @_;
- my @trace;
- my $dfa = $self->dfa;
- my %param = $self->model->parameter_hash;
- my $state = 0;
- my $state_duration = $self->{state_duration} // 1000;
- my @state_enum = $self->model->get_state_enum;
- my $prev_transition = {};
- for my $transition_str ( split( qr{ : }x, $run_str ) ) {
- my ( $cmd, @args ) = split( qr{ ! }x, $transition_str );
- my $state_name = $self->reduced_id_to_state($state);
- my $transition = $self->model->get_transition_by_name($cmd);
-
- push(
- @trace,
- {
- isa => 'state',
- name => $state_name,
- plan => {
- time => $prev_transition->{timeout}{static}
- // $state_duration,
- power => $self->model->get_state_power($state_name),
- energy => $self->model->get_state_power($state_name)
- * $state_duration,
- },
- parameter => { map { $_ => $param{$_}{value} } keys %param, },
- },
- {
- isa => 'transition',
- name => $cmd,
- args => [@args],
- code => [ $cmd, @args ],
- plan => {
- level => $transition->{level},
- energy => $transition->{energy}{static},
- timeout => $transition->{timeout}{static},
- },
- parameter => { map { $_ => $param{$_}{value} } keys %param, },
- },
- );
-
- $self->model->update_parameter_hash( \%param, $cmd, @args );
-
- ($state) = $dfa->successors( $state, ":${transition_str}" );
-
- if ( not defined $state ) {
- die("Transition $transition_str is invalid or has no successors\n");
- }
-
- $prev_transition = $transition;
- for my $extra_cmd (
- $self->model->get_state_extra_transitions( $state_enum[$state] ) )
- {
- $state_name = $self->reduced_id_to_state($state);
- $transition = $self->model->get_transition_by_name($extra_cmd);
- push(
- @trace,
- {
- isa => 'state',
- name => $state_name,
- plan => {
- time => $prev_transition->{timeout}{static}
- // $state_duration,
- power => $self->model->get_state_power($state_name),
- energy => $self->model->get_state_power($state_name)
- * $state_duration,
- },
- parameter =>
- { map { $_ => $param{$_}{value} } keys %param, },
- },
- {
- isa => 'transition',
- name => $extra_cmd,
- args => [],
- code => [$extra_cmd],
- plan => {
- level => $transition->{level},
- energy => $transition->{energy}{static},
- timeout => $transition->{timeout}{static},
- },
- parameter =>
- { map { $_ => $param{$_}{value} } keys %param, },
- }
- );
- $prev_transition = $transition;
- }
- }
-
- # required for unscheduled extra states and transitions caused by interrupts
- $trace[-1]{final_parameter}
- = { map { $_ => $param{$_}{value} } keys %param, };
- return @trace;
-}
-
-sub traces {
- my ($self) = @_;
-
- # Warning: This function is not deterministic!
- # Therefore, results are cached. When in doubt, reload traces / execution
- # plan from DriverEval.json
-
- if ( exists $self->{traces} ) {
- return @{ $self->{traces} };
- }
-
- my $max_iter = $self->{trace_revisit} // 2;
- my $next = $self->dfa->new_deepdft_string_generator($max_iter);
- my $trace_id = 1;
-
- my ( @raw_runs, @traces );
- my $filter_re;
-
- if ( $self->{trace_filter} and @{ $self->{trace_filter} } ) {
- my @res;
- for my $filter ( @{ $self->{trace_filter} } ) {
- my $re = $filter;
- $re =~ s{,}{![^:]*:}g;
- $re =~ s{$}{![^:]*)};
- $re =~ s{^}{(^};
- if ( $re =~ m{ \$ }x ) {
- $re =~ s{\$}{};
- $re =~ s{\)$}{\$)};
- }
- push( @res, $re );
- }
- $filter_re = join( q{|}, @res );
- }
-
- while ( my $run = $next->() ) {
- $run = substr( $run, 1 );
- if ( $filter_re and not $run =~ m{$filter_re} ) {
- next;
- }
- @raw_runs = grep { $_ ne substr( $run, 0, length($_) ) } @raw_runs;
- push( @raw_runs, $run );
- }
-
- if ( @raw_runs == 0 ) {
- say STDERR "--trace-filter did not match any run. Aborting.";
- exit 1;
- }
-
- @raw_runs = sort @raw_runs;
-
- for my $run_str (@raw_runs) {
- my @trace = $self->run_str_to_trace($run_str);
- push(
- @traces,
- {
- id => $trace_id,
- trace => [@trace],
- }
- );
- $trace_id++;
- }
-
- $self->{traces} = [@traces];
-
- return @traces;
-}
-
-1;
diff --git a/lib/Kratos/DFADriver/Model.pm b/lib/Kratos/DFADriver/Model.pm
deleted file mode 100644
index 4a38155..0000000
--- a/lib/Kratos/DFADriver/Model.pm
+++ /dev/null
@@ -1,495 +0,0 @@
-package Kratos::DFADriver::Model;
-
-use strict;
-use warnings;
-use 5.020;
-
-use parent 'Class::Accessor';
-
-use Carp;
-use Carp::Assert::More;
-use List::Util qw(first uniq);
-use File::Slurp qw(read_file write_file);
-use JSON;
-
-Kratos::DFADriver::Model->mk_ro_accessors(
- qw(class_name parameter state transition));
-
-our $VERSION = '0.00';
-
-sub new {
- my ( $class, %opt ) = @_;
-
- my $self = \%opt;
-
- $self->{custom_code} = {};
- $self->{parameter} = {};
- $self->{state} = {};
- $self->{transition} = {};
- $self->{voltage} = {};
-
- bless( $self, $class );
-
- my $json = JSON->new->decode( scalar read_file( $self->{model_file} ) );
- for my $key (qw(custom_code parameter state transition)) {
- $self->{$key} = $json->{$key};
- }
- $self->{class_name} = $json->{class};
-
- return $self;
-}
-
-sub new_from_repo {
- my ( $class, %opt ) = @_;
- my $repo = $opt{repo};
-
- my $self = {
- class_name => $opt{class_name},
- model_file => $opt{model_file},
- voltage => {},
- };
-
- bless( $self, $class );
-
- my $class_name = $self->{class_name};
-
- my @states;
- my %transition;
-
- if ( not exists $repo->{class}{$class_name} ) {
- die("Unknown class: $class_name\n");
- }
- my $class_base = $repo->{class}{$class_name};
-
- for my $function ( values %{ $class_base->{function} } ) {
- my %param_values;
- for my $attrib ( @{ $function->{attributes} // [] } ) {
- if ( $attrib->{namespace} eq 'Model' ) {
- if ( $attrib->{name} =~ m{ ^ transition }x
- and @{ $attrib->{args} } == 2 )
- {
- push( @states, $attrib->{args}[0]{expression} );
- push( @states, $attrib->{args}[1]{expression} );
- push(
- @{ $transition{ $function->{name} }{src} },
- $attrib->{args}[0]{expression}
- );
- push(
- @{ $transition{ $function->{name} }{dst} },
- $attrib->{args}[1]{expression}
- );
- push(
- @{ $transition{ $function->{name} }{transitions} },
- [
- $attrib->{args}[0]{expression},
- $attrib->{args}[1]{expression}
- ]
- );
- }
- elsif ( $attrib->{name} =~ m{ ^ testval }x
- and @{ $attrib->{args} } == 2 )
- {
- push(
- @{ $param_values{ $attrib->{args}[0]{value} } },
- $attrib->{args}[1]{value}
- );
- }
- elsif (
- $attrib->{name} =~ m{ ^ required_in_ (?<state> .* ) $ }x )
- {
- push(
- @{
- $self->{custom_code}{after_transition_by_state}
- { $+{state} }
- },
- $function->{name}
- );
- }
- else {
- printf( "wat %s::%s\n",
- $attrib->{namespace}, $attrib->{name} );
- }
- }
- elsif ( $attrib =~ m{ ^ epilogue $ }x ) {
- $transition{ $function->{name} }{level} = 'epilogue';
- }
- else {
- printf( "wat %s::%s\n", $attrib->{namespace}, $attrib->{name} );
- }
- }
- if ( exists $transition{ $function->{name} } ) {
- for my $i ( 0 .. $#{ $function->{argtypes} } ) {
- my $argtype = $function->{argtypes}[$i];
- my $param_name = sprintf( '%s.arg%d', $function->{name}, $i );
- push(
- @{ $transition{ $function->{name} }{parameters} },
- {
- name => $param_name,
- values => $param_values{$i},
- }
- );
- $self->{parameter}{$param_name} = {
- arg_name => $param_name,
- function => $function->{name},
- default => undef,
- };
- }
- }
- }
-
- if ( exists $repo->{class}{"DriverEvalThread_${class_name}"} ) {
- for my $var (
- keys %{ $repo->{class}{"DriverEvalThread_${class_name}"}{variable} }
- )
- {
- if ( $var
- =~ m{ ^ testVal __ (?<fun> [^_]+ ) __ arg (?<index> \d+ ) __ (?<descr> [^_]+ ) $ }x
- )
- {
- push(
- @{
- $transition{ $+{fun} }{parameters}[ $+{index} ]{values}
- },
- $var
- );
- }
- }
- }
-
- @states = uniq @states;
- @states = sort @states;
-
- # by convention, UNINITIALIZED always has ID 0
- @states = grep { $_ ne 'UNINITIALIZED' } @states;
- unshift( @states, 'UNINITIALIZED' );
-
- for my $i ( 0 .. $#states ) {
- $self->{state}{ $states[$i] } = {
- id => $i,
- power => {
- static => 0,
- }
- };
- }
-
- my @transition_names = sort keys %transition;
-
- for my $i ( 0 .. $#transition_names ) {
-
- my $name = $transition_names[$i];
- my @origins = uniq @{ $transition{$name}{src} };
- my @destinations = uniq @{ $transition{$name}{dst} };
- my $guess_level = ( $name eq 'epilogue' ? 'epilogue' : 'user' );
-
- $self->{transition}{$name} = {
- name => $name,
- id => $i,
- destination => \@destinations,
- origins => \@origins,
- transitions => $transition{$name}{transitions},
- level => $transition{$name}{level} // $guess_level,
- parameters => $transition{$name}{parameters} // [],
- duration => { static => 0 },
- energy => { static => 0 },
- rel_energy_prev => { static => 0 },
- rel_energy_next => { static => 0 },
- timeout => { static => 0 },
- };
- if ( @destinations > 1 ) {
- my $dst_str = join( q{, }, @destinations );
- warn(
-"Transition ${name} has several destination states ($dst_str). This is only partially supported.\n"
- );
- }
- }
-
- write_file( $self->{model_file},
- JSON->new->pretty->encode( $self->TO_JSON ) );
-
- return $self;
-}
-
-sub reset_property {
- my ( $self, $hash, $name ) = @_;
-
- delete $hash->{$name}{static};
- if ( exists $hash->{$name}{function} ) {
- delete $hash->{$name}{function}{estimate};
- }
- if ( exists $hash->{$name}{function}{user} ) {
- $hash->{$name}{function}{user}{params}
- = [ map { 1 } @{ $hash->{$name}{function}{user}{params} } ];
- }
-}
-
-sub reset {
- my ($self) = @_;
-
- for my $state ( values %{ $self->{state} } ) {
- for my $property (qw(power)) {
- $self->reset_property( $state, $property );
- }
- }
-
- for my $transition ( $self->transitions ) {
- for my $property (
- qw(duration energy rel_energy_prev rel_energy_next timeout))
- {
- $self->reset_property( $transition, $property );
- }
- }
-}
-
-sub set_state_power {
- my ( $self, $state, $power ) = @_;
-
- $power = sprintf( '%.f', $power );
-
- printf( "state %-16s: adjust power %d -> %d µW\n",
- $state, $self->{state}{$state}{power}{static}, $power );
-
- $self->{state}{$state}{power}{static} = $power;
-}
-
-sub set_transition_property {
- my ( $self, $transition_name, $property, $value ) = @_;
-
- if ( not defined $value ) {
- return;
- }
-
- my $transition = $self->get_transition_by_name($transition_name);
-
- $value = sprintf( '%.f', $value );
-
- printf( "transition %-16s: adjust %s %d -> %d\n",
- $transition->{name}, $property, $transition->{$property}{static},
- $value );
-
- $transition->{$property}{static} = $value;
-}
-
-sub set_state_lut {
- my ( $self, $state, $property, $lut ) = @_;
-
- if ( not defined $lut ) {
- return;
- }
-
- ...;
-}
-
-sub set_transition_lut {
- my ( $self, $transition_name, $property, $lut ) = @_;
-
- if ( not defined $lut ) {
- return;
- }
-
- ...;
-}
-
-sub set_state_params {
- my ( $self, $state, $fun_name, $function, @params ) = @_;
- my $old_params = 'None';
-
- if ( exists $self->{state}{$state}{power}{function}{$fun_name} ) {
- $old_params = join( q{ },
- @{ $self->{state}{$state}{power}{function}{$fun_name}{params} } );
- }
-
- printf( "state %-16s: adjust %s power function parameters [%s] -> [%s]\n",
- $state, $fun_name, $old_params, join( q{ }, @params ) );
-
- $self->{state}{$state}{power}{function}{$fun_name}{raw} = $function;
- for my $i ( 0 .. $#params ) {
- $self->{state}{$state}{power}{function}{$fun_name}{params}[$i]
- = $params[$i];
- }
-}
-
-sub set_transition_params {
- my ( $self, $transition_name, $fun_type, $fun_name, $function, @params )
- = @_;
- my $transition = $self->get_transition_by_name($transition_name);
- my $old_params = 'None';
-
- if ( exists $transition->{$fun_type}{function}{$fun_name} ) {
- $old_params = join( q{ },
- @{ $transition->{$fun_type}{function}{$fun_name}{params} } );
- }
-
- printf( "transition %-16s: adjust %s %s function parameters [%s] -> [%s]\n",
- $transition_name, $fun_name, $fun_type, $old_params,
- join( q{ }, @params ) );
-
- $transition->{$fun_type}{function}{$fun_name}{raw} = $function;
- for my $i ( 0 .. $#params ) {
- $transition->{$fun_type}{function}{$fun_name}{params}[$i] = $params[$i];
- }
-}
-
-sub set_voltage {
- my ( $self, $min_voltage, $max_voltage ) = @_;
-
- $self->{voltage} = {
- min => $min_voltage,
- max => $max_voltage,
- };
-}
-
-sub save {
- my ($self) = @_;
-
- write_file( $self->{model_file},
- JSON->new->pretty->encode( $self->TO_JSON ) );
-}
-
-sub parameter_hash {
- my ($self) = @_;
-
- for my $param_name ( keys %{ $self->{parameter} } ) {
- $self->{parameter}{$param_name}{value}
- = $self->{parameter}{$param_name}{default};
- }
-
- return %{ $self->{parameter} };
-}
-
-sub update_parameter_hash {
- my ( $self, $param_hash, $function, @args ) = @_;
-
- my $transition = $self->get_transition_by_name($function);
-
- for my $param ( keys %{ $transition->{affects} } ) {
- $param_hash->{$param}{value} = $transition->{affects}{$param};
- }
-
- for my $i ( 0 .. $#args ) {
- my $arg_name = $transition->{parameters}[$i]{name};
- my $arg_value = $args[$i];
-
- for my $param_name ( keys %{ $self->{parameter} } ) {
- if ( $self->{parameter}{$param_name}{arg_name} eq $arg_name ) {
- $param_hash->{$param_name}{value} = $arg_value;
- }
- }
- }
-}
-
-sub startup_code {
- my ($self) = @_;
-
- return $self->{custom_code}{startup} // q{};
-}
-
-sub heap_code {
- my ($self) = @_;
-
- return $self->{custom_code}{heap} // q{};
-}
-
-sub after_transition_code {
- my ($self) = @_;
-
- return $self->{custom_code}{after_transition} // q{};
-}
-
-sub get_state_extra_transitions {
- my ( $self, $state ) = @_;
-
- return @{ $self->{custom_code}{after_transition_by_state}{$state} // [] };
-}
-
-sub shutdown_code {
- my ($self) = @_;
-
- return $self->{custom_code}{shutdown} // q{};
-}
-
-sub get_transition_by_name {
- my ( $self, $name ) = @_;
-
- return $self->{transition}{$name};
-}
-
-sub get_transition_by_id {
- my ( $self, $id ) = @_;
-
- my $transition = first { $_->{id} == $id } $self->transitions;
-
- return $transition;
-}
-
-sub get_state_id {
- my ( $self, $name ) = @_;
-
- return $self->{state}{$name}{id};
-}
-
-sub get_state_name {
- my ( $self, $id ) = @_;
-
- return ( $self->get_state_enum )[$id];
-}
-
-sub get_state_power {
- my ( $self, $name ) = @_;
-
- return $self->{state}{$name}{power}{static};
-}
-
-sub get_state_power_with_params {
- my ( $self, $name, $param_values ) = @_;
-
- my $hash_str = join( ';',
- map { $param_values->{$_} }
- sort { $a cmp $b } keys %{$param_values} );
-
- if ( $hash_str eq q{} ) {
- return $self->get_state_power($name);
- }
-
- if ( exists $self->{state}{$name}{power}{lut}{$hash_str} ) {
- return $self->{state}{$name}{power}{lut}{$hash_str};
- }
-
- say "Note: No matching LUT for state ${name}, using median";
-
- return $self->get_state_power($name);
-}
-
-sub get_state_enum {
- my ($self) = @_;
-
- if ( not exists $self->{state_enum} ) {
- @{ $self->{state_enum} }
- = sort { $self->{state}{$a}{id} <=> $self->{state}{$b}{id} }
- keys %{ $self->{state} };
- }
-
- return @{ $self->{state_enum} };
-}
-
-sub transitions {
- my ($self) = @_;
-
- my @ret = values %{ $self->{transition} };
- @ret = sort { $a->{id} <=> $b->{id} } @ret;
- return @ret;
-}
-
-sub TO_JSON {
- my ($self) = @_;
-
- return {
- class => $self->{class_name},
- parameter => $self->{parameter},
- state => $self->{state},
- transition => $self->{transition},
- custom_code => $self->{custom_code},
- voltage => $self->{voltage},
- };
-}
-
-1;
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-26 00:18:01 +0000