PiDP-8/I Software

Artifact [1fb97bc85c]
Log In

Artifact 1fb97bc85c2ab9f8d23848ff8273879e2f301a98:


     1
     2
     3
     4
     5
     6
     7
     8
     9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
   100
   101
   102
   103
   104
   105
   106
   107
   108
   109
   110
   111
   112
   113
   114
   115
   116
   117
   118
   119
   120
   121
   122
   123
   124
   125
   126
   127
   128
   129
   130
   131
   132
   133
   134
   135
   136
   137
   138
   139
   140
   141
   142
   143
   144
   145
   146
   147
   148
   149
   150
   151
   152
   153
   154
   155
   156
   157
   158
   159
   160
   161
   162
   163
   164
   165
   166
   167
   168
   169
   170
   171
   172
   173
   174
   175
   176
   177
   178
   179
   180
   181
   182
   183
   184
   185
   186
   187
   188
   189
   190
   191
   192
   193
   194
   195
   196
   197
   198
   199
   200
   201
   202
   203
   204
   205
   206
   207
   208
   209
   210
   211
   212
   213
   214
   215
   216
   217
   218
   219
   220
   221
   222
   223
   224
   225
   226
   227
   228
   229
   230
   231
   232
   233
   234
   235
   236
   237
   238
   239
   240
   241
   242
   243
   244
   245
   246
   247
   248
   249
   250
   251
   252
   253
   254
   255
   256
   257
   258
   259
   260
   261
   262
   263
   264
   265
   266
   267
   268
   269
   270
   271
   272
   273
   274
   275
   276
   277
   278
   279
   280
   281
   282
   283
   284
   285
   286
   287
   288
   289
   290
   291
   292
   293
   294
   295
   296
   297
   298
   299
   300
   301
   302
   303
   304
   305
   306
   307
   308
   309
   310
   311
   312
   313
   314
   315
   316
   317
   318
   319
   320
   321
   322
   323
   324
   325
   326
   327
   328
   329
   330
   331
   332
   333
   334
   335
   336
   337
   338
   339
   340
   341
   342
   343
   344
   345
   346
   347
   348
   349
   350
   351
   352
   353
   354
   355
   356
   357
   358
   359
   360
   361
   362
   363
   364
   365
   366
   367
   368
   369
   370
   371
   372
   373
   374
   375
   376
   377
   378
   379
   380
   381
   382
   383
   384
   385
   386
   387
   388
   389
   390
   391
   392
   393
   394
   395
   396
   397
   398
   399
#!/usr/bin/env perl
########################################################################
# test-os8-run - Collects the set of all --*-os8-* options from the
#   configure script, generates all unique subsets of that option set,
#   runs configure with each of those subsets, and compares the output
#   OS/8 bin RK05 disk to the previous run's version.  If there is a
#   discrepancy, generate a diff against the build log for that option
#   set and report the problem for the user to diagnose.
#
#   The first time the script is run, or the first time a new unique
#   option subset is generated, we save the build results as the
#   exemplar to use in later tests.
#
# Copyright © 2017-2018 by Warren Young
#
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS LISTED ABOVE BE LIABLE FOR ANY CLAIM,
# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT
# OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
# OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the names of the authors above
# shall not be used in advertising or otherwise to promote the sale,
# use or other dealings in this Software without prior written
# authorization from those authors.
########################################################################

use strict;
use warnings;

# Modules from CPAN
use Math::Subsets::List;
use Parallel::Loops;

# Core modules
use Cwd qw(getcwd abs_path);
use Digest::SHA qw(sha256_hex);
use English;
use File::Basename;
use File::Copy;
use Getopt::Std;
use List::Util qw(shuffle);
use Term::ANSIColor;

# Perl::Critic rules we're willing to bend
## no critic (InputOutput::RequireBriefOpen )


#### GLOBALS ###########################################################

my @tests;
my $tests_mf;
my (%generated, %tested);
my $currlog = 'obj/os8-run.log';
my $cmplz = abs_path (dirname ($0)) . '/cmplz';

# Command line option values
my ($dry_run, $existing_only, $generate_only, $single_core, $shuffle,
        $verbose);


#### sanitize_log ######################################################
# Copy the given input log file to the ouptut file, expurgating bits
# that change from one run to the next without being meaningful.

sub sanitize_log
{
    my ($ifile, $ofile) = @_;

    open my $if, '<', $ifile or die "Cannot read $ifile: $!\n";
    open my $of, '>', $ofile or die "Cannot write $ofile: $!\n";

    while (<$if>) {
        # Strip all the CRs out.  We only need the LFs.
        s{\r}{}gs;
        my $original = $_;      # save it post-strip

        # Strip variable parts of SIMH line following each Ctrl-E:
        #
        # "Simulation stopped, PC: 01210 (JMP 1207)"
        s{
            (Simulation\ stopped)            # bit to preserve
            ,\ PC:\ \d+\ \([A-Z]+(\ \d+)?\)  # variable bit
        }{$1.}x;

        # Rewrite SIMH ATTACH commands to remove pointless differences
        # in absolute paths between machines or Fossil checkouts.
        s{
            (attach\ )           # SIMH command
            (-r\ )?              # optional flag
            ([a-z0-9]+\ )        # SIMH device name
            (.*test/tmp/[0-9]+/) # noise parts of image file name thru PID
        }{$1$3.../}x;
        s{
            (attach\ )
            (-r\ )?
            ([a-z0-9]+\ )
            (.*/(media/os8)/)    # also squish this noise
        }{$1$3.../$5/}x;

        # Add cleaned line to ofile
        print $of $_;
    }

    close $if;
    close $of;

    return;
}


#### construct_test ####################################################
# Assembles a test record for a single permutation

sub construct_test
{
    my @opts = @_;

    # Distill this option set to a hash value after which we will
    # name the output files.  We don't want to name files with a
    # leading hyphen or with long variable-length names, potentially
    # multiple lines long.
    my $optstr = join ' ', @opts;
    my $hash = sha256_hex($optstr);
    my $hdir = "test/$hash";    # test hash dir relative to our CWD
    my $rhdir = "../../$hash";  # $hdir relative to builddir test/tmp/$PID
    my $test = { 
        hash   => $hash,
        hdir   => $rhdir,
        log    => "$rhdir/last.log",
        name   => '{' . substr ($hash, 0, 12) . '}',
        optstr => $optstr,
        rklz   => "$rhdir/last.rklz",
    };

    # Skip this one if it already exists and we're in -g mode.
    if ($generate_only) {
        if (-d $hdir) {
            if (-f "$hdir/last.log") {
                if (-f "$hdir/last.rklz") {
                    print "Skipping $test->{name}: already done.\n";
                    return;
                }
                elsif ($verbose) {
                    print "Must re-gen $hash despite -g: rklz missing!\n";
                }
            }
            elsif ($verbose) {
                print "Must re-gen $hash despite -g: log missing!\n";
            }
        }
        elsif ($verbose) {
            print "Will generate $hash.\n";
        }
    }
    elsif (-d $hdir) {
        print "Will test $optstr against $hash.\n" if $verbose;
    }
    elsif ($verbose) {
        print "Must generate missing test set $hash.\n";
    }

    push @tests, $test;

    return;
}


#### compare_rklz ######################################################
# Compare two lz4-compressed RK05 disk images, returning true if they
# are the same.  If they are different, also outputs a binary difference
# report.
#
# We call a separate shell script instead of use inline shell code here
# because the helper code uses a Bash feature, and /bin/sh might not be
# bash, as on a Raspbian box.

sub compare_rklz
{
    my ($r1, $r2) = @_;
    return system("$cmplz '$r1' '$r2'") == 0;
}


#### do_test ###########################################################
# Test a single permutation

sub do_test
{
    # Set up working directory
    my $test = $_;
    print "Configuring test $test->{name}, PID $PID...\n";
    return if $dry_run;
    chdir "test/tmp" or die "Could not CD to tmp dir: $!\n";
    mkdir $PID;
    chdir $PID;
    die "Could not mkdir $test->{hdir}: $!\n"
            unless -d $test->{hdir} || mkdir($test->{hdir});

    my $currdsk = "bin/v3d.rk05";
    my $currdlz = substr ($currdsk, 0, length ($currdsk) - 2) . 'lz';
    my $target  = 'os8-sys';

    # Configure the test disk image
    system "../../../configure $test->{optstr} > cfg.log 2>&1"
            and die "Failed to configure $test->{name}!\n";
    # We used to link binaries here, but there are more now.
    # So our target, os8-sys now installs binaries and libraries we need.
    open my $itf, '>', 'media/os8/init.tx'             # avoid a pointless diff
            or die "Cannot overwrite init.tx with neutral version: $!\n";
    print $itf "TEST-OS8-RUN BUILT THIS DISK IMAGE.\n\n";
    close $itf;

    # Build the test disk image
    print "Building $currdsk for test $test->{name} (PID $PID)...\n";
    system "make $target > make.log 2>&1"
            and die "Failed to build $currdsk!\n";

    # Quickly compress the test disk: we don't want to store all the
    # "air" in an RK05 in our test corpus.
    system("lz4 -q $currdsk > $currdlz");

    if (not -f $test->{log} or not -f $test->{rklz}) {
        # This test hasn't run here yet, so save it as our exemplar for
        # this optstr, to be compared to future builds.
        sanitize_log ($currlog, $test->{log});
        move ($currdlz, $test->{rklz});

        # Log the mapping between the hash and the options it
        # represents, so the user can reverse it.
        print $tests_mf "$test->{hash}  $test->{optstr}\n";
        $generated{$test->{hash}} = 1;
    }
    elsif (compare_rklz ($currdlz, $test->{rklz})) {
        # We had this test examplar here already and on re-doing it we
        # got the same result.
        print colored(['green'], "mkos8 $test->{name} test passed."), "\n";
        $tested{$test->{hash}} = 1;
    }
    else {
        # This build resulted in a difference, so yell and save the
        # results for manual comparison.
        my $fdiff = "$test->{hdir}/fail.diff";
        my $faillog = "$test->{hdir}/fail.log";
        sanitize_log ($currlog, $faillog);
        move ($currdlz, $test->{hdir} . '/fail.rklz');
        system "diff -wu $test->{log} $faillog > $fdiff";
        print colored(['bold red'], 'RESULT DIFFERS!  See test/',
                substr($fdiff, 6)), "\n";
        $tested{$test->{hash}} = 0;
    }

    system("cd .. ; rm -fr $PID");      # -f because there are read-only files

    return;
}


#### remove_missing ####################################################
# Implements -e: given a list of mkos8 options, returns only those for
# which we have a valid test set.

sub remove_missing
{
    my (@tests) = @_;
    my $all = @tests;

    # First read in the set of prebuilt tests, filtering out those that
    # refer to output files that do not exist here.  (This happens when
    # copying over the manifest file but only a subset of the actual
    # test output files.)
    my %existing;
    my $genned = 0;
    my $mff = 'test/tests-manifest.txt';
    open my $mf, '<', $mff or die "Could not read from $mff: $!\n";
    while (<$mf>) {
        chomp;
        my ($hash, @opts) = split ' ';
        my $dir = 'test/' . $hash;
        if (-d $dir and -f "$dir/last.rklz" and -f "$dir/last.log") {
            $existing{join ' ', @opts} = $hash;
        }
        ++$genned;
    }
    close $mf;

    # Now filter the test set to remove those that do not exist
    my @filtered = grep { $existing{$_->{optstr}} } @tests;
    print "Filtered $genned of $all tests down to ", scalar(@filtered),
            " for -e.\n";
    return @filtered;
}


#### report* ###########################################################
# Print on-exit status report.

sub report_part
{
    my ($partref, $kind) = @_;

    return unless keys %$partref;

    my ($successes, $tries) = (0, 0);
    for my $s (values %$partref) {
        ++$tries;
        ++$successes if $s;
    }

    my $extra = $successes == $tries ? '' : " of $tries";
    print colored ([
                $successes == 0 ? 'bold red' :
                    $successes != $tries ?
                        'bold yellow' :
                        'green'
            ],
            "Successfully $kind $successes$extra tests.\n");
}

sub report
{
    print "\n", '=' x 79, "\n";
    report_part (\%generated, 'generated');
    report_part (\%tested,    'built');
    print "\n";

    return;
}


#### main ##############################################################

# Parse command line
my %clopts;
getopts('egnsv1', \%clopts) or die "Failed to parse command line!\n";
$dry_run = $clopts{n};
$existing_only = $clopts{e};
$generate_only = $clopts{g};
$shuffle = $clopts{s};
$verbose = $clopts{v};
$single_core = $clopts{1};

# Init global resources
mkdir 'test';
system("rm -rf test/tmp");
mkdir 'test/tmp';
open $tests_mf, '>>', 'test/tests-manifest.txt'
        or die "Cannot append to test manifest: $!\n";
$SIG{INT} = $SIG{TERM} = sub { report; exit 1 };
$SIG{PIPE} = 'IGNORE';

# Get all current --*-os8-* options, filtering out those we know should
# not be tried for this:
#
# *   No --os8-minimal because that just turns on all --disable-os8-* 
#     options, so it's already covered.
# *   No --disable-os8-src because we don't test the src disk; it's
#     always generated the same way.
# *   No --disable-os8-focal because it disables the other two FOCAL
#     options, which we're already going to test singly and together.
my @cmd = (
    "./configure --help",
    "grep -- -os8-",
    "sed -Ee 's/^ +//'",
    "cut -f1 -d' '",
    "grep -v -e 'os8-minimal' -e 'os8-src' -e 'os8-focal\$'"
);
open my $ocmd, '-|', join('|', @cmd) or die "Failed to get os8 option set: $!\n";
my @cfgOpts = <$ocmd>;
close $ocmd;
chomp @cfgOpts;

# Generate all possible permutations of those options.  Shuffle them if
# requested.
subsets \&construct_test, @cfgOpts;
@tests = remove_missing(@tests) if $existing_only;
@tests = shuffle @tests if $shuffle;

# Run the tests
my $tdir = abs_path(dirname($0));
my $cores = $single_core ? 1 : int(`$tdir/corecount`);
my $pl = Parallel::Loops->new($cores);
$pl->share (\%generated, \%tested);
$pl->foreach ( \@tests, \&do_test);

report;