in reply to Re^2: Why won't this Deadlock?
in thread Why won't this Deadlock?

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

Replies are listed 'Best First'.
Re^4: Why won't this Deadlock?
by Jambo Hamon (Novice) on Jul 12, 2017 at 01:28 UTC
    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]
[reply]
[d/l]
[select]

      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

[reply]
[d/l]
[select]
        Hi Mario,

        The pipeline_eval sub is awesome. Exactly what I was thinking about.

        There is a document that shows that ' can be used in place of :: for package separators. 

        perldoc perlmod 
http://perltricks.com/article/obscure-perl-trick--single-quote-separat
+ors/

        [download]
        Here's a test for correctness of the MCE'*:

        Can MCE'* clone itself into MCE'MCE'* ?
        Or in a similar way MCE'MCE'MCE'*

        Sorry if I was rude last night. I was blitz'ed

        Packages are just GLOBS right, so it should be possible to share everything, from the __PACKAGE__ quite easily.

        This is the English version and has the famous last words:

        Coming up with the some code in a few hours to show MCE'* is Genius.

        Cheers,
        James PS. Here is a small diff that moves use strict; use warnings; to the start of the file. 

        2,4d1
< use strict;
< use warnings;
< use v5.20;    # oh yeah
7d3
< 
22c18,20
< 
---
> use strict;
> use warnings;
> use v5.20;    # oh yeah

        [download]
[reply]
[d/l]
[select]

        It's a display model, it doesn't work the way it's intended to (yet!). 

        #!/usr/bin/perl
use strict;
use warnings;
use v5.20;    # oh yeah

package Stash;

# Stash = Symbol Table Hash

sub steal {

    # hosed logic here
    #my ($from, $to) = @_ || ( shift || 'main', (caller)[0] );
    my ( $from, $to ) = @_;

    no strict 'refs';

    return map {
        s/\\/\\\\/;
        qq!\$_->{$$}{'$_'} = qq|*{'${to}::$_'} = *{'${from}::$_'}| !
    } keys %{"${from}::"};
}

1;

package My::Hash;

use MCE::Shared::Hash;
use base 'MCE::Shared::Hash';

sub pipeline_eval {
    my $self = shift;
    local $_ = $self;
    while (@_) {

        #say " eval ", shift->[0];
        eval shift->[0];
    }
    return;
}
1;

package main;

use Data::Dumper;
use MCE::Shared;

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

tied(%t)->pipeline_eval(
    map { [$_] } Stash::steal( "main", "My::Hash" )    # steal from, t
+o
);

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

        [download]
[reply]
[d/l]
      Like acting, it takes time. 
      rg => 1

      [download]
      that means rg was the first to run!

      Like a Pony,
      Jambo

[reply]
[d/l]
        And what does this mean class?
        (UPDATE: In the nicest possible tone, it means Bob Marley is still alive)

        That's all from ME,
        Jambo 

           'null' => {
                                   'rgy' => '1',
                                   'rg' => '1'
                                 },

        [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom