Commit 92f83e48 authored by Leigh B Stoller's avatar Leigh B Stoller
Browse files

Work on an optimization to the perl code. Maybe you have noticed, but

starting any one of our scripts can take a second or two. That time is
spent including and compiling 10000s of thousands of lines of perl
code, both from our libraries and from the perl libraries.

Mostly this is just a maintenance thing; we just never thought about
it much and we have a lot more code these days.

So I have done two things.

1) I have used SelfLoader() on some of our biggest perl modules.
   SelfLoader delays compilation until code is used. This is not as
   good as AutoLoader() though, and so I did it with just a few 
   modules (the biggest ones).

2) Mostly I reorganized things:

  a) Split libdb into an EmulabConstants module and all the rest of
     the code, which is slowly getting phased out.

  b) Move little things around to avoid including libdb or Experiment
     (the biggest files).

  c) Change "use foo" in many places to a "require foo" in the
     function that actually uses that module. This was really a big
     win cause we have dozens of cases where we would include a
     module, but use it in only one place and typically not all.

Most things are now starting up in 1/3 the time. I am hoping this will
help to reduce the load spiking we see on boss, and also help with the
upcoming Geni tutorial (which kill boss last time).
parent d8230a46
...@@ -14,7 +14,6 @@ use vars qw(@ISA @EXPORT); ...@@ -14,7 +14,6 @@ use vars qw(@ISA @EXPORT);
@EXPORT = qw ( ); @EXPORT = qw ( );
# Must come after package declaration! # Must come after package declaration!
use lib '@prefix@/lib';
use libdb; use libdb;
use libtestbed; use libtestbed;
use Project; use Project;
......
This diff is collapsed.
...@@ -8,19 +8,15 @@ package Experiment; ...@@ -8,19 +8,15 @@ package Experiment;
use strict; use strict;
use Exporter; use Exporter;
use SelfLoader ();
use vars qw(@ISA @EXPORT $AUTOLOAD); use vars qw(@ISA @EXPORT $AUTOLOAD);
@ISA = qw(Exporter SelfLoader);
@ISA = "Exporter";
@EXPORT = qw ( ); @EXPORT = qw ( );
use libdb; use libdb;
use EmulabConstants;
use libtestbed; use libtestbed;
use User;
use Project;
use Group;
use Node; use Node;
use Interface;
use VirtExperiment;
use Logfile; use Logfile;
use English; use English;
use Data::Dumper; use Data::Dumper;
...@@ -33,27 +29,58 @@ use vars qw($EXPT_PRELOAD $EXPT_START $EXPT_SWAPIN $EXPT_SWAPUPDATE ...@@ -33,27 +29,58 @@ use vars qw($EXPT_PRELOAD $EXPT_START $EXPT_SWAPIN $EXPT_SWAPUPDATE
$EXPT_FLAGS_NAMESONLY $EXPT_FLAGS_INCLUDEVIRT $EXPT_FLAGS_NAMESONLY $EXPT_FLAGS_INCLUDEVIRT
$EXPT_FLAGS_LOCALONLY $EXPT_FLAGS_LOCALONLY
$EXPT_GENIFLAGS_EXPT $EXPT_GENIFLAGS_COOKED $EXPT_GENIFLAGS_EXPT $EXPT_GENIFLAGS_COOKED
@EXPORT_OK); @nodetable_fields %experiments
$EXPT_STARTCLOCK $EXPT_RESOURCESHOSED
@EXPORT_OK
$TB $BOSSNODE $CONTROL $TBOPS $PROJROOT $STAMPS $TBBASE
$TEVC $DBCONTROL $RSYNC $MKEXPDIR $TBPRERUN $TBSWAP
$TBREPORT $TBEND $DU $MD5);
# Configure variables # Configure variables
my $TB = "@prefix@"; $TB = "@prefix@";
my $BOSSNODE = "@BOSSNODE@"; $BOSSNODE = "@BOSSNODE@";
my $CONTROL = "@USERNODE@"; $CONTROL = "@USERNODE@";
my $TBOPS = "@TBOPSEMAIL@"; $TBOPS = "@TBOPSEMAIL@";
my $PROJROOT = "@PROJROOT_DIR@"; $PROJROOT = "@PROJROOT_DIR@";
my $EVENTSYS = @EVENTSYS@; $STAMPS = @STAMPS@;
my $STAMPS = @STAMPS@; $TBBASE = "@TBBASE@";
my $TBBASE = "@TBBASE@"; $TEVC = "$TB/bin/tevc";
my $TEVC = "$TB/bin/tevc"; $DBCONTROL = "$TB/sbin/opsdb_control";
my $DBCONTROL = "$TB/sbin/opsdb_control"; $RSYNC = "/usr/local/bin/rsync";
my $RSYNC = "/usr/local/bin/rsync"; $MKEXPDIR = "$TB/libexec/mkexpdir";
my $MKEXPDIR = "$TB/libexec/mkexpdir"; $TBPRERUN = "$TB/bin/tbprerun";
my $TBPRERUN = "$TB/bin/tbprerun"; $TBSWAP = "$TB/bin/tbswap";
my $TBSWAP = "$TB/bin/tbswap"; $TBREPORT = "$TB/bin/tbreport";
my $TBREPORT = "$TB/bin/tbreport"; $TBEND = "$TB/bin/tbend";
my $TBEND = "$TB/bin/tbend"; $DU = "/usr/bin/du";
my $DU = "/usr/bin/du"; $MD5 = "/sbin/md5";
my $MD5 = "/sbin/md5";
# To avoid writting out all the methods.
AUTOLOAD {
#print STDERR "$AUTOLOAD\n";
if (!ref($_[0])) {
$SelfLoader::AUTOLOAD = $AUTOLOAD;
return SelfLoader::AUTOLOAD(@_);
}
my $self = $_[0];
my $name = $AUTOLOAD;
$name =~ s/.*://; # strip fully-qualified portion
# A DB row proxy method call.
if (exists($self->{'EXPT'}->{$name})) {
return $self->{'EXPT'}->{$name};
}
elsif (exists($self->{'STATS'}->{$name})) {
return $self->{'STATS'}->{$name};
}
elsif (exists($self->{'RSRC'}->{$name})) {
return $self->{'RSRC'}->{$name};
}
$SelfLoader::AUTOLOAD = $AUTOLOAD;
my $ref = \&SelfLoader::AUTOLOAD;
goto &$ref;
}
# Swap Actions # Swap Actions
$EXPT_PRELOAD = TBDB_STATS_PRELOAD(); $EXPT_PRELOAD = TBDB_STATS_PRELOAD();
...@@ -72,8 +99,8 @@ $EXPT_GENIFLAGS_EXPT = 0x01; ...@@ -72,8 +99,8 @@ $EXPT_GENIFLAGS_EXPT = 0x01;
$EXPT_GENIFLAGS_COOKED = 0x02; $EXPT_GENIFLAGS_COOKED = 0x02;
# For stats gathering code. # For stats gathering code.
my $EXPT_STARTCLOCK; $EXPT_STARTCLOCK = undef;
my $EXPT_RESOURCESHOSED = 0; $EXPT_RESOURCESHOSED = 0;
# Why, why, why? # Why, why, why?
@EXPORT_OK = qw($EXPT_PRELOAD $EXPT_START $EXPT_SWAPUPDATE @EXPORT_OK = qw($EXPT_PRELOAD $EXPT_START $EXPT_SWAPUPDATE
...@@ -122,7 +149,7 @@ my $EXPT_RESOURCESHOSED = 0; ...@@ -122,7 +149,7 @@ my $EXPT_RESOURCESHOSED = 0;
"bridges" => ["node_id", "bridx", "iface"]); "bridges" => ["node_id", "bridx", "iface"]);
# These are slots in the node table that need to be restored. # These are slots in the node table that need to be restored.
my @nodetable_fields = ("def_boot_osid", @nodetable_fields = ("def_boot_osid",
"def_boot_path", "def_boot_path",
"def_boot_cmd_line", "def_boot_cmd_line",
"temp_boot_osid", "temp_boot_osid",
...@@ -151,15 +178,8 @@ my @nodetable_fields = ("def_boot_osid", ...@@ -151,15 +178,8 @@ my @nodetable_fields = ("def_boot_osid",
"sshdport", "sshdport",
"rtabid"); "rtabid");
# Hmm, this is silly.
if ($EVENTSYS) {
require event;
import event;
}
# Cache of instances to avoid regenerating them. # Cache of instances to avoid regenerating them.
my %experiments = (); %experiments = ();
my $debug = 0;
# Little helper and debug function. # Little helper and debug function.
sub mysystem($) sub mysystem($)
...@@ -170,7 +190,7 @@ sub mysystem($) ...@@ -170,7 +190,7 @@ sub mysystem($)
chomp($cwd = `/bin/pwd`); chomp($cwd = `/bin/pwd`);
print STDERR "Running '$command' in $cwd\n" print STDERR "Running '$command' in $cwd\n"
if ($debug); if (0);
return system($command); return system($command);
} }
...@@ -278,26 +298,48 @@ sub Lookup($$;$) ...@@ -278,26 +298,48 @@ sub Lookup($$;$)
return $self; return $self;
} }
# To avoid writting out all the methods. # Break circular reference someplace to avoid exit errors.
sub AUTOLOAD { sub DESTROY {
my $self = shift; my $self = shift;
my $type = ref($self) or die("$self is not an object\n");
my $name = $AUTOLOAD; $self->{"EXPT"} = undef;
$name =~ s/.*://; # strip fully-qualified portion $self->{"STATS"} = undef;
$self->{"RSRC"} = undef;
$self->{'VIRTEXPT'} = undef;
}
if (exists($self->{'EXPT'}->{$name})) { #
return $self->{'EXPT'}->{$name}; # Flush from our little cache, as for the expire daemon.
} #
elsif (exists($self->{'STATS'}->{$name})) { sub Flush($)
return $self->{'STATS'}->{$name}; {
} my ($self) = @_;
elsif (exists($self->{'RSRC'}->{$name})) {
return $self->{'RSRC'}->{$name}; delete($experiments{$self->idx()});
} }
print STDERR "$self: tried to access unknown slot $name\n"; sub FlushAll($)
return undef; {
my ($class) = @_;
%experiments = ();
}
#
# Stringify for output.
#
sub Stringify($)
{
my ($self) = @_;
my $pid = $self->pid();
my $eid = $self->eid();
return "[Experiment: $pid/$eid]";
} }
1;
__DATA__
sub dbrow($$) { return $_[0]->{'EXPT'}; } sub dbrow($$) { return $_[0]->{'EXPT'}; }
sub locked($) { return $_[0]->expt_locked(); } sub locked($) { return $_[0]->expt_locked(); }
sub elabinelab($) { return $_[0]->elab_in_elab(); } sub elabinelab($) { return $_[0]->elab_in_elab(); }
...@@ -306,16 +348,6 @@ sub creator($) { return $_[0]->expt_head_uid(); } ...@@ -306,16 +348,6 @@ sub creator($) { return $_[0]->expt_head_uid(); }
sub created($) { return $_[0]->expt_created(); } sub created($) { return $_[0]->expt_created(); }
sub swapper($) { return $_[0]->expt_swap_uid(); } sub swapper($) { return $_[0]->expt_swap_uid(); }
# Break circular reference someplace to avoid exit errors.
sub DESTROY {
my $self = shift;
$self->{"EXPT"} = undef;
$self->{"STATS"} = undef;
$self->{"RSRC"} = undef;
$self->{'VIRTEXPT'} = undef;
}
# #
# For canceled, goto to the DB. # For canceled, goto to the DB.
# #
...@@ -800,22 +832,6 @@ sub Delete($;$) ...@@ -800,22 +832,6 @@ sub Delete($;$)
return 0; return 0;
} }
#
# Flush from our little cache, as for the expire daemon.
#
sub Flush($)
{
my ($self) = @_;
delete($experiments{$self->idx()});
}
sub FlushAll($)
{
my ($class) = @_;
%experiments = ();
}
# #
# Add an input file to the template. The point of this is to reduce # Add an input file to the template. The point of this is to reduce
# duplication by taking an md5 of the input file, and sharing that # duplication by taking an md5 of the input file, and sharing that
...@@ -1005,6 +1021,7 @@ sub GetInputFile($$$) ...@@ -1005,6 +1021,7 @@ sub GetInputFile($$$)
sub GetVirtExperiment($) sub GetVirtExperiment($)
{ {
my ($self) = @_; my ($self) = @_;
require VirtExperiment;
return undef return undef
if (! ref($self)); if (! ref($self));
...@@ -1277,19 +1294,6 @@ sub SetBatchMode($$) { ...@@ -1277,19 +1294,6 @@ sub SetBatchMode($$) {
return ($success ? 0 : -1); return ($success ? 0 : -1);
} }
#
# Stringify for output.
#
sub Stringify($)
{
my ($self) = @_;
my $pid = $self->pid();
my $eid = $self->eid();
return "[Experiment: $pid/$eid]";
}
# #
# Generic function to look up some table values given a set of desired # Generic function to look up some table values given a set of desired
# fields and some conditions. Pretty simple, not widely useful, but it # fields and some conditions. Pretty simple, not widely useful, but it
...@@ -1357,8 +1361,8 @@ sub AccessCheck($$$) ...@@ -1357,8 +1361,8 @@ sub AccessCheck($$$)
return 0 return 0
if (! ref($self)); if (! ref($self));
if ($access_type < TB_EXPT_MIN || if ($access_type < TB_EXPT_MIN() ||
$access_type > TB_EXPT_MAX) { $access_type > TB_EXPT_MAX()) {
die("*** Invalid access type: $access_type!"); die("*** Invalid access type: $access_type!");
} }
...@@ -1379,11 +1383,11 @@ sub AccessCheck($$$) ...@@ -1379,11 +1383,11 @@ sub AccessCheck($$$)
# #
my $mintrust; my $mintrust;
if ($access_type == TB_EXPT_READINFO) { if ($access_type == TB_EXPT_READINFO()) {
$mintrust = PROJMEMBERTRUST_USER; $mintrust = PROJMEMBERTRUST_USER();
} }
else { else {
$mintrust = PROJMEMBERTRUST_LOCALROOT; $mintrust = PROJMEMBERTRUST_LOCALROOT();
} }
# #
...@@ -1392,7 +1396,7 @@ sub AccessCheck($$$) ...@@ -1392,7 +1396,7 @@ sub AccessCheck($$$)
# those in groups they do not belong to. # those in groups they do not belong to.
# #
return TBMinTrust($group->Trust($user), $mintrust) || return TBMinTrust($group->Trust($user), $mintrust) ||
TBMinTrust($project->Trust($user), PROJMEMBERTRUST_GROUPROOT); TBMinTrust($project->Trust($user), PROJMEMBERTRUST_GROUPROOT());
} }
# #
...@@ -1424,6 +1428,7 @@ sub CreateDirectory($) ...@@ -1424,6 +1428,7 @@ sub CreateDirectory($)
sub GetProject($) sub GetProject($)
{ {
my ($self) = @_; my ($self) = @_;
require Project;
# Must be a real reference. # Must be a real reference.
return undef return undef
...@@ -1444,6 +1449,7 @@ sub GetProject($) ...@@ -1444,6 +1449,7 @@ sub GetProject($)
sub GetGroup($) sub GetGroup($)
{ {
my ($self) = @_; my ($self) = @_;
require Group;
# Must be a real reference. # Must be a real reference.
return undef return undef
...@@ -1640,15 +1646,15 @@ sub Unlock($;$) ...@@ -1640,15 +1646,15 @@ sub Unlock($;$)
} }
if (defined($newstate)) { if (defined($newstate)) {
require event;
$self->{'EXPT'}->{'state'} = $newstate; $self->{'EXPT'}->{'state'} = $newstate;
if ($EVENTSYS) { event::EventSendWarn(objtype => TBDB_TBEVENT_EXPTSTATE(),
EventSendWarn(objtype => libdb::TBDB_TBEVENT_EXPTSTATE(), objname => "$pid/$eid",
objname => "$pid/$eid", eventtype => $newstate,
eventtype => $newstate, expt => "$pid/$eid",
expt => "$pid/$eid", host => $BOSSNODE);
host => $BOSSNODE);
}
} }
return 0; return 0;
...@@ -1689,15 +1695,15 @@ sub Lock(;$$) ...@@ -1689,15 +1695,15 @@ sub Lock(;$$)
if ($unlocktables); if ($unlocktables);
if (defined($newstate)) { if (defined($newstate)) {
require event;
$self->{'EXPT'}->{'state'} = $newstate; $self->{'EXPT'}->{'state'} = $newstate;
if ($EVENTSYS) { event::EventSendWarn(objtype => TBDB_TBEVENT_EXPTSTATE(),
EventSendWarn(objtype => libdb::TBDB_TBEVENT_EXPTSTATE(), objname => "$pid/$eid",
objname => "$pid/$eid", eventtype => $newstate,
eventtype => $newstate, expt => "$pid/$eid",
expt => "$pid/$eid", host => $BOSSNODE);
host => $BOSSNODE);
}
} }
return 0; return 0;
} }
...@@ -1723,15 +1729,15 @@ sub SetState($$) ...@@ -1723,15 +1729,15 @@ sub SetState($$)
} }
if (defined($newstate)) { if (defined($newstate)) {
require event;
$self->{'EXPT'}->{'state'} = $newstate; $self->{'EXPT'}->{'state'} = $newstate;
if ($EVENTSYS) { event::EventSendWarn(objtype => TBDB_TBEVENT_EXPTSTATE(),
EventSendWarn(objtype => libdb::TBDB_TBEVENT_EXPTSTATE(), objname => "$pid/$eid",
objname => "$pid/$eid", eventtype => $newstate,
eventtype => $newstate, expt => "$pid/$eid",
expt => "$pid/$eid", host => $BOSSNODE);
host => $BOSSNODE);
}
} }
return 0; return 0;
...@@ -1972,6 +1978,8 @@ sub PreRun($;$$) ...@@ -1972,6 +1978,8 @@ sub PreRun($;$$)
sub PreSwap($$$$) sub PreSwap($$$$)
{ {
my ($self, $swapper, $which, $estate) = @_; my ($self, $swapper, $which, $estate) = @_;
# We know we need this later.
require User;
# Must be a real reference. # Must be a real reference.
return -1 return -1
...@@ -1981,7 +1989,7 @@ sub PreSwap($$$$) ...@@ -1981,7 +1989,7 @@ sub PreSwap($$$$)
my $rsrcidx = $self->rsrcidx(); my $rsrcidx = $self->rsrcidx();
my $lastrsrc = $rsrcidx; my $lastrsrc = $rsrcidx;
my $uid_idx = $swapper->uid_idx(); my $uid_idx = $swapper->uid_idx();
my $isactive = ($estate eq EXPTSTATE_ACTIVE); my $isactive = ($estate eq EXPTSTATE_ACTIVE());
# #
# We should never get here with a lastrsrc in the stats record; it # We should never get here with a lastrsrc in the stats record; it
...@@ -2069,7 +2077,7 @@ sub PreSwap($$$$) ...@@ -2069,7 +2077,7 @@ sub PreSwap($$$$)
# Old swap gathering stuff. # Old swap gathering stuff.
$self->GatherSwapStats($swapper, $which, 0, $self->GatherSwapStats($swapper, $which, 0,
libdb::TBDB_STATS_FLAGS_START()) == 0 TBDB_STATS_FLAGS_START()) == 0
or goto failed; or goto failed;
# We do these here since even failed operations implies activity. # We do these here since even failed operations implies activity.
...@@ -2226,7 +2234,7 @@ sub PostSwap($$$$) ...@@ -2226,7 +2234,7 @@ sub PostSwap($$$$)
my $when = "UNIX_TIMESTAMP(now())"; my $when = "UNIX_TIMESTAMP(now())";
# unless its active, in which case pick up swapin time. # unless its active, in which case pick up swapin time.
$when = $self->swapin_time() $when = $self->swapin_time()
if ($self->state() eq libdb::EXPTSTATE_ACTIVE()); if ($self->state() eq EXPTSTATE_ACTIVE());
DBQueryWarn("update experiment_resources set ". DBQueryWarn("update experiment_resources set ".
" swapmod_time=$when ". " swapmod_time=$when ".
...@@ -2236,7 +2244,7 @@ sub PostSwap($$$$) ...@@ -2236,7 +2244,7 @@ sub PostSwap($$$$)
if ($which eq $EXPT_SWAPOUT || if ($which eq $EXPT_SWAPOUT ||
($which eq $EXPT_SWAPMOD && ($which eq $EXPT_SWAPMOD &&
$self->state() eq libdb::EXPTSTATE_ACTIVE())) { $self->state() eq EXPTSTATE_ACTIVE())) {
# #
# If this is a swapout, we use the current resource record. If this # If this is a swapout, we use the current resource record. If this
...@@ -2285,7 +2293,7 @@ sub PostSwap($$$$) ...@@ -2285,7 +2293,7 @@ sub PostSwap($$$$)
# if this fails, so do not worry about it. # if this fails, so do not worry about it.
# #
if ($which eq $EXPT_SWAPOUT && if ($which eq $EXPT_SWAPOUT &&
$flags & libdb::TBDB_STATS_FLAGS_IDLESWAP()) { $flags & TBDB_STATS_FLAGS_IDLESWAP()) {
DBQueryWarn("update experiment_stats ". DBQueryWarn("update experiment_stats ".
"set idle_swaps=idle_swaps+1 ". "set idle_swaps=idle_swaps+1 ".
"where exptidx=$exptidx"); "where exptidx=$exptidx");
...@@ -2301,7 +2309,7 @@ sub PostSwap($$$$) ...@@ -2301,7 +2309,7 @@ sub PostSwap($$$$)
if ($which eq $EXPT_START || if ($which eq $EXPT_START ||
$which eq $EXPT_SWAPIN || $which eq $EXPT_SWAPIN ||
($which eq $EXPT_SWAPMOD && ($which eq $EXPT_SWAPMOD &&
$self->state() eq libdb::EXPTSTATE_ACTIVE())) { $self->state() eq EXPTSTATE_ACTIVE())) {
$query_result = $query_result =
DBQueryWarn("select r.node_id,n.type,r.erole,r.vname, ". DBQueryWarn("select r.node_id,n.type,r.erole,r.vname, ".
" n.phys_nodeid,nt.isremotenode,nt.isvirtnode ". " n.phys_nodeid,nt.isremotenode,nt.isvirtnode ".
...@@ -2423,7 +2431,7 @@ sub GatherSwapStats($$$;$$) ...@@ -2423,7 +2431,7 @@ sub GatherSwapStats($$$;$$)
# variable and return. This is cheezy, but the interface I'm providing # variable and return. This is cheezy, but the interface I'm providing
# allows for fancier stuff later if desired. # allows for fancier stuff later if desired.
# #
if ($flags & libdb::TBDB_STATS_FLAGS_START()) { if ($flags & TBDB_STATS_FLAGS_START()) {
$EXPT_STARTCLOCK = time(); $EXPT_STARTCLOCK = time();
return 0; return 0;
} }
...@@ -2583,8 +2591,8 @@ sub OldReservedNodeList($$) ...@@ -2583,8 +2591,8 @@ sub OldReservedNodeList($$)
@$plist = (); @$plist = ();
my @result = (); my @result = ();
my $exptidx = $self->idx(); my $exptidx = $self->idx();
my $oldreserved_pid = OLDRESERVED_PID; my $oldreserved_pid = OLDRESERVED_PID();
my $oldreserved_eid = OLDRESERVED_EID; my $oldreserved_eid = OLDRESERVED_EID();
my $query_result = my $query_result =
DBQueryWarn("select r.node_id from reserved as r ". DBQueryWarn("select r.node_id from reserved as r ".
...@@ -2826,6 +2834,7 @@ sub SetSwapper($$) ...@@ -2826,6 +2834,7 @@ sub SetSwapper($$)
sub GetSwapper($) sub GetSwapper($)
{ {
my ($self) = @_; my ($self) = @_;