view release on metacpan or  search on metacpan

eg/sha_walk.pl  view on Meta::CPAN

#!/usr/bin/perl
# Hashing a directory tree: File::Find + Digest::SHA, made cooperative.
#
# The reflex when a task is slow is to reach for async, and then spend a day making a synchronous walk yield and a
# synchronous hasher cooperate, and end up with a program that is not measurably faster than the one you started with.
# This file is the worked version of that, and the punchline is in the diagnosis near the end: the hasher was never
# I/O-bound. It is CPU-bound, and no amount of scheduling changes a CPU-bound program that has one thread.
#
# Five things get measured, each against a heartbeat fiber that ticks every 10ms so "did it cooperate" is a number:
#
#   1. File::Find. A synchronous recursive walk. What actually makes it hand the thread back is yield(), and
#      maybe_yield() does not - it is a preemption counter, and at the default threshold of 0 it is a no-op. That is
#      the single most common mistake in this file's genre, so it gets its own section and its own numbers.
#   2. Digest::SHA->addfile. XS. It does its own reading in C, where a Perl-level override cannot reach, so Compat
#      cannot help it at all. Measured, not assumed.
#   3. The same digest driven by a Perl read loop. Now the reads are reachable, so Compat does cooperate - and the
#      chunk size turns out to matter more than anything else in this file.
#   4. One fiber per file, bounded by a semaphore. Buys resource bounding, not throughput, and the numbers say so.
#   5. The diagnosis, and the one tuning knob that is actually worth reaching for.
#
# Run it: perl -Mblib eg/sha_walk.pl [files] [bytes-per-file]
use v5.40;
use blib;
$|++;
use Acme::Parataxis qw[:all];
no warnings 'experimental::try';    # try/catch below; the dist does the same in its .pm files
use Acme::Parataxis::Semaphore;
use Config;
use Digest::SHA ();
use File::Find  ();
use File::Path  ();
use File::Spec;
use File::Temp  ();
use Time::HiRes ();
my $FILE_COUNT = shift // 20;
my $FILE_BYTES = shift // 262_144;

# The install that makes sleep/read/sysread cooperative. It has to sit above the code that reads files, which is
# below, and that is the whole placement rule: an override is resolved when each call site is *compiled*, so it
# covers this file's reads and nothing from a module loaded before it.
BEGIN { Acme::Parataxis->enable_transparent_unblocking() }

# CLEANUP => 0 on purpose, and this is not a style choice - it is the fix for a trap that only bites when the
# threaded branch at the end of this file actually runs.
#
# `threads->create` clones the whole perl stack, so every thread gets its *own* copy of the object graph, with its
# own refcounts. The clone's copy of $ROOT is not kept alive by this interpreter's copy of it, so when a thread
# exits, that refcount goes to zero, DESTROY runs, and File::Temp rmtree's the directory out from under the
# threads still working in it.
#
# The symptom is not an error you would guess at: the first couple of threads succeed, the directory is deleted,
# and everything after that dies with ENOENT. "Open failed: No such file or directory" on files that demonstrably
# existed a second earlier. It looks exactly like a race in the code being benchmarked, and it is not.
my $ROOT = File::Temp->newdir( CLEANUP => 0 );

END {
    return if $main::ROOT_DONE;
    $main::ROOT_DONE = 1;
    my $d = $ROOT->dirname;
    File::Path::remove_tree($d) if defined $d && -d $d;
}

# A tree worth walking: a few directories, a few files each, some nested, one deliberately empty.
sub build_tree {
    my ( $root, $count, $bytes ) = @_;
    my @dirs = map { File::Spec->catdir( $root, "d$_" ) } ( 0 .. 2 );
    push @dirs, File::Spec->catdir( $dirs[0], 'nested' );
    File::Path::make_path(@dirs);
    for my $i ( 0 .. $count - 1 ) {
        my $dir  = $dirs[ $i % @dirs ];
        my $path = File::Spec->catfile( $dir, "file$i.dat" );
        open my $fh, '>:raw', $path or die "open $path: $!";

        # Incompressible-ish content, so the digest has real work and is not measuring a memcpy of zeroes.
        my $chunk = join q{}, map { chr( 32 + ( $_ * 7 + $i ) % 90 ) } 0 .. 4095;
        print {$fh} substr( $chunk x int( $bytes / 4096 ), 0, $bytes );
        close $fh;
    }
    return $root;
}

# The yardstick. A heartbeat fiber ticks every 10ms; anything that blocks the OS thread starves it.
sub measure {
    my ( $label, $note, $work ) = @_;
    my $ticks = 0;
    my $stop  = 0;
    my $beat  = fiber {
        while ( !$stop ) { $ticks++; await_sleep(10) }
        return;
    };
    my $t0 = Time::HiRes::time();
    my @r  = $work->();
    my $ms = ( Time::HiRes::time() - $t0 ) * 1000;
    $stop = 1;
    $beat->await;

    # An empty label means "measured but not printed here" - section 6 prints its own table, and it
    # wants the tick counts without the duplicate millisecond line.
    printf "  %-42s %6.1f ms   ticks: %3d   %s\n", $label, $ms, $ticks, $note if length $label;
    return ( $ms, $ticks, @r );
}

# Hashing, several ways. They all produce the same digests; they differ only in what they do to the other fibers.