Update: Changed max_age from 3 seconds to 1 hour. Was missed before posting.

Hi Jambo Hamon,

The following is a FCGI::ProcManager + MCE::Shared demonstration. One can make use of MCE::Shared and have a fast cache. Perhaps a nosql-like object is handy as well for session data during multi-page HTTP requests.

The MCE::Shared::Cache module is a hybrid LRU-plain implementation.

The MCE::Shared::Minidb nosql-like module is Redis-like for the API.

#!/usr/bin/perl

# http://127.0.0.1/cgi-bin/test_shared.fcgi
# http://127.0.0.1/cgi-bin/test_shared.fcgi?param1=foo&param2=baz

use strict;
use warnings;

use MCE::Shared;

use CGI::Fast;
use FCGI::ProcManager;

# construct any shared objects and mutexes (optional)

my $cache = MCE::Shared->cache( max_keys => 500, max_age => 3600 );
my $count = MCE::Shared->scalar( 0 );
my $nosql = MCE::Shared->minidb();

# launch FCGI manager next

my $proc_manager = FCGI::ProcManager->new({ n_processes => 4 });
   $proc_manager->pm_manage();

# calling init enables parallel IPC for data flow
# worker is assigned 1 of 12 channels

MCE::Shared->init();

# at last, the loop

while ( my $query = CGI::Fast->new() ) {
   $proc_manager->pm_pre_dispatch();

   print "Content-type: text/html\r\n\r\n";

   print "<hr>\n";
   print "$_ = $ENV{$_}<br>\n" foreach sort keys %ENV;
   print "<hr>\n";

   my %params;

   foreach ( sort $query->param() ) {
      $params{$_} = $query->param($_);
      print $_, " = ", $params{$_}, "<br>\n";
   }

   print "<hr>\n";

   print "$$: ", $count->incr(), "<br>\n";

   my $val = $cache->get('foo') // do {
       $cache->set( foo => 'bar'.$count->get() )
   };

   print "$$: ", $val, "<br>\n";

   $proc_manager->pm_post_dispatch();
}
[download]

For maximum performance, ensure Perl has Sereal::Encoder/Decoder 3.015+ installed. IO::FDPass 1.2+ is beneficial if wanting to construct a shared queue.

All was done in MCE::Shared::Cache and MCE::Shared::Minidb to run with low memory consumption and maximum performance. For example, MCE::Shared::Cache makes use of dualvar to hold the time expiration along with the key internally. Only enable what you want. Basically, do not enable max_age if not needed for maximum performance.

The OO interface for shared objects saves you from having to handle mutex at the application level, unless of course wanting to wrap a mutex (enter) around multiple shared actions.

Regards, Mario

I like you, Mario.

sort { "You cut to the chase." cmp "I'm frying something here for a se
+cond." } @beers
[download]

Do you think the following is proof of the promises mechanism?

I cannot wait to have a few "@beers" on the dock.

Man, I slay me.

Now I could show you. Is it possible that the index $t{index}->{prev}{cur}{rgy} is being mis-counted or not?

That's the one I am hunting.

All the Best,
Jambo

$VAR1 = {
          'index' => {
                       'rg' => {
                                 'ry' => '4995',
                                 'rgy' => '2243',
                                 'rg' => '2904'
                               },
                       'ry' => {
                                 'rg' => '5010',
                                 'ry' => '2877',
                                 'rgy' => '2212'
                               },
                       'rgy' => {
                                  'rg' => '2051',
                                  'ry' => '1959'
                                },
                       'null' => {
                                   'rg' => '1'
                                 }
                     },
          'mothersbaugh' => {
                              'rg' => '5000',
                              'rgy' => '5000',
                              'r' => '5000',
                              'g' => '10000',
                              'gy' => '5000'
                            },
          'fork2' => {
                       'r' => '10000',
                       'g' => '5000',
                       'y' => '5000',
                       'rg' => '5000',
                       'ry' => '5000'
                     },
          'fork1' => {
                       'ry' => '5000',
                       'rg' => '5000',
                       'y' => '5000',
                       'g' => '5000',
                       'r' => '10000'
                     },
          'starttime' => '1499821117',
          'prev' => 'ry',
          'cur' => 'ry'
        };
$ 
$ ~
$ perl  def4.pl --iterations 5000 -stats 1
[download]

#!/usr/bin/perl

use strict;
use warnings;
use v5.20;    # oh yeah

use Time::HiRes qw(usleep);
use Data::Dumper;

my $ITER       = 200;
my $IS_SLEEP   = 0;
my $RAND_SLEEP = 200;
my $DEBUG      = 0;
my $STATS      = 0;

# IS_SLEEP CONSTANTS
use constant PROMISES_INNER   => 1;
use constant PROMISES_INSIDE  => 2;
use constant PROMISES_BETWEEN => 4;

use Getopt::Long;
GetOptions(
    "iterations=i"  => \$ITER,          # numeric
    "sleep=i"       => \$IS_SLEEP,      #numeric
    "randomsleep=i" => \$RAND_SLEEP,    #numeric
    "debug=i"       => \$DEBUG,         #numeric
    "stats=i"       => \$STATS,         #numeric
  )
  or die(
"Usage $0:\t--iterations NUMBER --sleep NUMBER  --randomsleep INTERVAL
+ --debug NUMBER --stats NUMBER --ofile STRING\n"
  );

use Mutex;
use MCE::Shared;

my $red    = Mutex->new;
my $yellow = Mutex->new;
my $green  = Mutex->new;

$red->lock;
$yellow->lock;
$green->lock;

$|++;

sub spin {

    #   print Dumper(\@_);
    # Mutex, subroutine reference, ...Jazz
    return shift->enter( shift, @_ );
}

sub make_promise {
    my $mutex = shift;
    my $sub   = shift;

    my $promise;
    if (@_) {
        $promise = spin( $mutex, $sub, make_promise(@_) );
    }
    else {
        $promise = spin( $mutex, $sub );
    }
    return $promise;
}

tie my %t, 'MCE::Shared';
$t{starttime} = time;
$t{prev}      = "null";

my $sleep_inside = sub {
    usleep int( rand($RAND_SLEEP) ) if ( $IS_SLEEP & PROMISES_INSIDE )
+;
};

my $sleep_between = sub {
    usleep int( rand($RAND_SLEEP) ) if ( $IS_SLEEP & PROMISES_BETWEEN 
+);
};

my $sleep_inner = sub {
    usleep int( rand($RAND_SLEEP) ) if ( $IS_SLEEP & PROMISES_INNER );
};

my $rg = sub {
    my $name = shift || die;
    print "(rg)" if ( $name eq "fork1" );
    print "[rg]" if ( $name eq "fork2" );

    $t{$name}->{r}++;
    $t{$name}->{rg}++;
    $t{$name}->{g}++;

    $t{cur} = "rg";
    $t{index}->{ $t{prev} }{ $t{cur} }++;
    $t{prev} = "rg";

    $sleep_inside->();
};

my $ry = sub {
    my $name = shift || die;
    print "(ry)" if ( $name eq "fork1" );
    print "[ry]" if ( $name eq "fork2" );

    $t{$name}->{r}++;
    $t{$name}->{ry}++;
    $t{$name}->{y}++;

    $t{cur} = "ry";
    $t{index}->{ $t{prev} }{ $t{cur} }++;
    $t{prev} = "ry";

    $sleep_inside->();
};

my $rgy = sub {
    my $name = shift || die;
    say "{rgy}" if ( $name eq "mothersbaugh" );

    # yeah a few beers
    $t{$name}->{r}++;
    $t{$name}->{rg}++;
    $t{$name}->{g}++;
    $t{$name}->{gy}++;
    $t{$name}->{g}++;
    $t{$name}->{rgy}++;

    $t{cur} = "rgy";
    $t{index}->{ $t{prev} }{ $t{cur} }++;
    $t{prev} = "rgy";

    $sleep_inside->();
};

my $promise_rgy =
  sub { make_promise( $red, shift, $green, shift, $yellow, shift ); };
+ # or die
my $promise_ry = sub { make_promise( $red, shift, $yellow, shift ); };
my $promise_rg = sub { make_promise( $red, shift, $green,  shift ); };



my $pid = fork;

die "$!: who knows me?" if not defined $pid;

if ( $pid == 0 ) {
    #say "fork1 here: $$";
    #child: fork1
    #child: fork1
    #child: fork1
    #child: fork1
    #child: fork1



    my $pid = fork;

    die "$!: who knows me?" if not defined $pid;
    my $cnt;  

    if ( $pid == 0 ) {
        #say "fork2 here: $$";
        #child: fork2
        #child: fork2
        #child: fork2
        #child: fork2
        #child: fork2



        while ( $cnt++ < $ITER ) {


            $promise_rg->( $sleep_inside, $rg->("fork2") );
            $sleep_between->();
            $promise_ry->( $sleep_inside, $ry->("fork2") );
            $sleep_between->();
        }

    }
    else {
        # fork1
        # fork1
        # fork1
        # fork1
        # fork1

        while ( $cnt++ < $ITER ) {

            $promise_rg->( $sleep_inside, $rg->("fork1") );
            $sleep_between->();
            $promise_ry->( $sleep_inside, $ry->("fork1") );
            $sleep_between->();
        }
        wait;    # for fork2
    }

}
else {
    #mothersbaugh ship
    #mothersbaugh ship
    #mothersbaugh ship
    #mothersbaugh ship
    #mothersbaugh ship

    my $cnt;

    # sleep works wonders # sleep 2;
    while ( $cnt++ < $ITER ) {    # adjust to taste

      # no one can get red, cos it's locked until i unlock it. PID bas
+ed switch.
      # only true on the first iteration.
        $sleep_between->();

        $promise_rgy->( $sleep_inner, $sleep_inner, $rgy->("mothersbau
+gh") );
    }

    wait;    # fork1

    print "\n";
    print Dumper( tied(%t)->export( { unbless => 1 } ) ) if ($STATS);
}
[download]

Now the evidence is tampered with.
I just found a bug.

Counting g twice in $rgy.

124d123
<     $t{$name}->{g}++;
[download]

Hi Jambo,

Incrementing a shared value (++) involves FETCH and STORE meaning two IPC trips behind the scene. It becomes more expensive for deeply-shared structures. I see the reason for wanting 3 mutexes to control which one goes first. However, having many mutexes may likely behave similarly to running without any mutex when involving multiple IPC trips.

# 3 IPC trips:  FETCH, FETCH, STORE
$t{$name}->{r}++;

# 6 IPC trips: FETCH, FETCH, FETCH, FETCH, FETCH, STORE
$t{index}->{ $t{prev} }{ $t{cur} }++;
[download]

Another possibility is 1-level shared-hash with compounded key names.

# 2 IPC trips: FETCH, STORE
$t{ "$name-rg" }++;

# 4 IPC trips: FETCH, FETCH, FETCH, STORE
my $prev = $t{prev};
my $cur  = $t{cur};
$t{ "index-$prev-$cur" }++;
[download]

To resolve the mis-counting issue, I constructed another mutex named $mutex and wrapped the operations inside it.

my $mutex  = Mutex->new;
...

my $rg = sub {
    my $name = shift || die;
    print "(rg)" if ( $name eq "fork1" );
    print "[rg]" if ( $name eq "fork2" );

    $mutex->enter( sub {
        $t{$name}->{r}++;
        $t{$name}->{rg}++;
        $t{$name}->{g}++;

        $t{cur} = "rg";
        $t{index}->{ $t{prev} }{ $t{cur} }++;
        $t{prev} = "rg";
    });

    $sleep_inside->();
};

my $ry = sub {
    my $name = shift || die;
    print "(ry)" if ( $name eq "fork1" );
    print "[ry]" if ( $name eq "fork2" );

    $mutex->enter( sub {
        $t{$name}->{r}++;
        $t{$name}->{ry}++;
        $t{$name}->{y}++;

        $t{cur} = "ry";
        $t{index}->{ $t{prev} }{ $t{cur} }++;
        $t{prev} = "ry";
    });

    $sleep_inside->();
};

my $rgy = sub {
    my $name = shift || die;
    say "{rgy}" if ( $name eq "mothersbaugh" );

    $mutex->enter( sub {
        $t{$name}->{r}++;
        $t{$name}->{rg}++;
        $t{$name}->{g}++;
        $t{$name}->{gy}++;
        $t{$name}->{rgy}++;

        $t{cur} = "rgy";
        $t{index}->{ $t{prev} }{ $t{cur} }++;
        $t{prev} = "rgy";
    });

    $sleep_inside->();
};
[download]

Here's an optimized version to rid of the extra mutex. It runs about 6 times faster over the original code. I've made a custom hash package based on MCE::Shared::Hash. Calling the OO method pipeline_eval sends a list of actions to the shared-manager to perform, where the data resides.

In essense, what this does is removes the deeply-sharing aspect from the picture. Only the outer-most hash is shared. The commands for updating the hash are combined and sent via 1 IPC call.

$ diff orig.pl script.pl
2a3,19
> package My::Hash;
>
> use MCE::Shared::Hash;
> use base 'MCE::Shared::Hash';
>
> sub pipeline_eval {
>    my $self = shift;
>    local $_ = $self;
>    while ( @_ ) {
>       eval shift->[0];
>    }
>    return;
> }
>
> 1;
>
> package main;
>

70c87
< tie my %t, 'MCE::Shared';
---
> tie my %t, 'MCE::Shared', { module => 'My::Hash' };

91,97c108,115
<     $t{$name}->{r}++;
<     $t{$name}->{rg}++;
<     $t{$name}->{g}++;
<
<     $t{cur} = "rg";
<     $t{index}->{ $t{prev} }{ $t{cur} }++;
<     $t{prev} = "rg";
---
>     tied( %t )->pipeline_eval(
>        [ "\$_->{ $name }->{r }++" ],
>        [ "\$_->{ $name }->{rg}++" ],
>        [ "\$_->{ $name }->{g }++" ],
>        [ "\$_->{ cur   } = 'rg'"  ],
>        [ "\$_->{ index }->{ \$_->{ prev } }{ \$_->{ cur } }++" ],
>        [ "\$_->{ prev  } = 'rg'"  ]
>     );

107,113c125,132
<     $t{$name}->{r}++;
<     $t{$name}->{ry}++;
<     $t{$name}->{y}++;
<
<     $t{cur} = "ry";
<     $t{index}->{ $t{prev} }{ $t{cur} }++;
<     $t{prev} = "ry";
---
>     tied( %t )->pipeline_eval(
>        [ "\$_->{ $name }->{r }++" ],
>        [ "\$_->{ $name }->{ry}++" ],
>        [ "\$_->{ $name }->{y }++" ],
>        [ "\$_->{ cur   } = 'ry'"  ],
>        [ "\$_->{ index }->{ \$_->{ prev } }{ \$_->{ cur } }++" ],
>        [ "\$_->{ prev  } = 'ry'"  ]
>     );

123,131c142,151
<     $t{$name}->{r}++;
<     $t{$name}->{rg}++;
<     $t{$name}->{g}++;
<     $t{$name}->{gy}++;
<     $t{$name}->{rgy}++;
<
<     $t{cur} = "rgy";
<     $t{index}->{ $t{prev} }{ $t{cur} }++;
<     $t{prev} = "rgy";
---
>     tied( %t )->pipeline_eval(
>        [ "\$_->{ $name }->{r  }++" ],
>        [ "\$_->{ $name }->{rg }++" ],
>        [ "\$_->{ $name }->{g  }++" ],
>        [ "\$_->{ $name }->{gy }++" ],
>        [ "\$_->{ $name }->{rgy}++" ],
>        [ "\$_->{ cur   } = 'rgy'"  ],
>        [ "\$_->{ index }->{ \$_->{ prev } }{ \$_->{ cur } }++" ],
>        [ "\$_->{ prev  } = 'rgy'"  ]
>     );
[download]

Below is the dump output from perl script.pl --iterations=5000 --stats=1

$VAR1 = {
          'cur' => 'ry',
          'index' => {
                       'ry' => {
                                 'rg' => 4035,
                                 'rgy' => 2471,
                                 'ry' => 3493
                               },
                       'rgy' => {
                                  'rg' => 2480,
                                  'ry' => 2496,
                                  'rgy' => 24
                                },
                       'rg' => {
                                 'rg' => 3485,
                                 'rgy' => 2504,
                                 'ry' => 4011
                               },
                       'null' => {
                                   'rgy' => 1
                                 }
                     },
          'starttime' => 1499832324,
          'fork2' => {
                       'rg' => 5000,
                       'ry' => 5000,
                       'r' => 10000,
                       'g' => 5000,
                       'y' => 5000
                     },
          'prev' => 'ry',
          'mothersbaugh' => {
                              'rgy' => 5000,
                              'gy' => 5000,
                              'rg' => 5000,
                              'r' => 5000,
                              'g' => 5000
                            },
          'fork1' => {
                       'r' => 10000,
                       'g' => 5000,
                       'y' => 5000,
                       'rg' => 5000,
                       'ry' => 5000
                     }
        };
[download]

Update:

After running, the overhead of the shared-variable isn't needed. Therefore, export the shared hash into a normal hash. Optionally, untie the shared hash.

  # print Dumper( tied(%t)->export( { unbless => 1 } ) ) if ($STATS);

    my %h = %{ tied(%t)->export({ unbless => 1 }) };  untie %t;
    print Dumper(\%h) if $STATS;
[download]

Regards, Mario

Like acting, it takes time.

rg => 1
[download]

that means rg was the first to run!

Like a Pony,
Jambo