--- deliantra/server/lib/cf.pm 2007/04/18 17:32:07 1.253 +++ deliantra/server/lib/cf.pm 2007/05/22 21:35:26 1.269 @@ -92,6 +92,10 @@ # used to convert map paths into valid unix filenames by replacing / by ∕ our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons +our $LOAD; # a number between 0 (idle) and 1 (too many objects) +our $LOADAVG; # same thing, but with alpha-smoothing +our $tick_start; # for load detecting purposes + binmode STDOUT; binmode STDERR; @@ -141,6 +145,16 @@ The interval between server ticks, in seconds. +=item $cf::LOADAVG + +The current CPU load on the server (alpha-smoothed), as a value between 0 +(none) and 1 (overloaded), indicating how much time is spent on processing +objects per tick. Healthy values are < 0.5. + +=item $cf::LOAD + +The raw value load value from the last tick. + =item %cf::CFG Configuration for the server, loaded from C, or @@ -163,7 +177,7 @@ $msg .= "\n" unless $msg =~ /\n$/; - $msg =~ s/([\x00-\x09\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; + $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; utf8::encode $msg; LOG llevError, $msg; @@ -320,6 +334,8 @@ my ($job) = @_; if ($Coro::current == $Coro::main) { + my $time = Event::time; + # this is the main coro, too bad, we have to block # till the operation succeeds, freezing the server :/ @@ -340,6 +356,13 @@ Coro::cede or Event::one_event; } + $time = Event::time - $time; + + LOG llevError | logBacktrace, Carp::longmess "long sync job" + if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; + + $tick_start += $time; # do not account sync jobs to server load + wantarray ? @res : $res[0] } else { # we are in another coroutine, how wonderful, everything just works @@ -369,10 +392,17 @@ } sub write_runtime { - my $guard = cf::lock_acquire "write_runtime"; - my $runtime = "$LOCALDIR/runtime"; + # first touch the runtime file to show we are still running: + # the fsync below can take a very very long time. + + if (my $fh = aio_open $runtime, O_WRONLY, 0) { + utime undef, undef, $fh; + } + + my $guard = cf::lock_acquire "write_runtime"; + my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 or return; @@ -387,12 +417,17 @@ aio_fsync $fh and return; + # touch it again to show we are up-to-date + utime undef, undef, $fh; + close $fh or return; aio_rename "$runtime~", $runtime and return; + warn "runtime file written.\n";#d# + 1 } @@ -594,7 +629,7 @@ } elsif ($type eq "subtype") { defined $object_type or Carp::croak "subtype specified without type"; my $object_subtype = shift @arg; - $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; + $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= []; } elsif ($type eq "package") { my $pkg = shift @arg; @@ -645,6 +680,7 @@ } else { _attach shift->_attach_registry, @_; } + _recalc_want; }; # all those should be optimised @@ -657,6 +693,7 @@ } else { Carp::croak "cannot, currently, detach class attachments"; } + _recalc_want; }; sub cf::attachable::attached { @@ -1354,7 +1391,7 @@ sub load_path { my ($self) = @_; - "$MAPDIR($self->{path}" + "$MAPDIR/$self->{path}.map" } # the temporary/swap location @@ -1362,7 +1399,7 @@ my ($self) = @_; (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; - "$TMPDIR/$path" + "$TMPDIR/$path.map" } # the unique path, undef == no special unique path @@ -1492,53 +1529,54 @@ local $self->{deny_reset} = 1; # loading can take a long time my $path = $self->{path}; - my $guard = cf::lock_acquire "map_load:$path"; - return if $self->in_memory != cf::MAP_SWAPPED; + { + my $guard = cf::lock_acquire "map_load:$path"; - $self->in_memory (cf::MAP_LOADING); + return if $self->in_memory != cf::MAP_SWAPPED; - $self->alloc; + $self->in_memory (cf::MAP_LOADING); - $self->pre_load; - Coro::cede; + $self->alloc; - $self->_load_objects ($self->{load_path}, 1) - or return; + $self->pre_load; + Coro::cede; - $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) - if delete $self->{load_original}; + $self->_load_objects ($self->{load_path}, 1) + or return; - if (my $uniq = $self->uniq_path) { - utf8::encode $uniq; - if (aio_open $uniq, O_RDONLY, 0) { - $self->clear_unique_items; - $self->_load_objects ($uniq, 0); - } - } + $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) + if delete $self->{load_original}; - Coro::cede; - # now do the right thing for maps - $self->link_multipart_objects; - Coro::cede; + if (my $uniq = $self->uniq_path) { + utf8::encode $uniq; + if (aio_open $uniq, O_RDONLY, 0) { + $self->clear_unique_items; + $self->_load_objects ($uniq, 0); + } + } - unless ($self->{deny_activate}) { - $self->decay_objects; - $self->fix_auto_apply; - $self->update_buttons; Coro::cede; - $self->set_darkness_map; + # now do the right thing for maps + $self->link_multipart_objects; $self->difficulty ($self->estimate_difficulty) unless $self->difficulty; Coro::cede; - $self->activate; - Coro::cede; + + unless ($self->{deny_activate}) { + $self->decay_objects; + $self->fix_auto_apply; + $self->update_buttons; + Coro::cede; + $self->set_darkness_map; + Coro::cede; + $self->activate; + } + + $self->in_memory (cf::MAP_IN_MEMORY); } $self->post_load; - Coro::cede; - - $self->in_memory (cf::MAP_IN_MEMORY); } sub customise_for { @@ -1939,22 +1977,38 @@ }, ); -=item $player_object->goto ($path, $x, $y) +=item $player_object->goto ($path, $x, $y[, $check->($map)]) + +Moves the player to the given map-path and coordinates by first freezing +her, loading and preparing them map, calling the provided $check callback +that has to return the map if sucecssful, and then unfreezes the player on +the new (success) or old (failed) map position. =cut sub cf::object::player::goto { - my ($self, $path, $x, $y) = @_; + my ($self, $path, $x, $y, $check) = @_; $self->enter_link; (async { my $map = eval { my $map = cf::map::find $path; - $map = $map->customise_for ($self) if $map; + + if ($map) { + $map = $map->customise_for ($self); + $map = $check->($map) if $check && $map; + } else { + $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); + } + $map - } or - $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); + }; + + if ($@) { + $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED); + LOG llevError | logBacktrace, Carp::longmess $@; + } $self->leave_link ($map, $x, $y); })->prio (1); @@ -2436,9 +2490,10 @@ return wantarray ? @$res : $res->[-1]; } else { + reset_signals; local $SIG{__WARN__}; + local $SIG{__DIE__}; eval { - local $SIG{__DIE__}; close $fh1; my @res = eval { $cb->(@args) }; @@ -2811,6 +2866,8 @@ $signal->wait; } + my $min = 1e6;#d# + my $avg = 10; $TICK_WATCHER = Event->timer ( reentrant => 0, parked => 1, @@ -2824,10 +2881,33 @@ return; } - $NOW = Event::time; + $NOW = $tick_start = Event::time; cf::server_tick; # one server iteration + 0 && sync_job {#d# + for(1..10) { + my $t = Event::time; + my $map = my $map = new_from_path cf::map "/tmp/x.map" + or die; + + $map->width (50); + $map->height (50); + $map->alloc; + $map->_load_objects ("/tmp/x.map", 1); + my $t = Event::time - $t; + + #next unless $t < 0.0013;#d# + if ($t < $min) { + $min = $t; + } + $avg = $avg * 0.99 + $t * 0.01; + } + warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d# + exit 0; + # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477 + }; + $RUNTIME += $TICK; $NEXT_TICK += $TICK; @@ -2842,12 +2922,6 @@ # my $AFTER = Event::time; # warn $AFTER - $NOW;#d# - # if we are delayed by four ticks or more, skip them all - $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; - - $TICK_WATCHER->at ($NEXT_TICK); - $TICK_WATCHER->start; - if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { $sig->send; } @@ -2855,7 +2929,20 @@ $sig->send; } + $NOW = Event::time; + + # if we are delayed by four ticks or more, skip them all + $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; + + $TICK_WATCHER->at ($NEXT_TICK); + $TICK_WATCHER->start; + + $LOAD = ($NOW - $tick_start) / $TICK; + $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; + _post_tick; + + }, ); @@ -2924,6 +3011,44 @@ ); } +my $_log_backtrace; + +sub _log_backtrace { + my ($msg, @addr) = @_; + + $msg =~ s/\n//; + + # limit the # of concurrent backtraces + if ($_log_backtrace < 2) { + ++$_log_backtrace; + async { + my @bt = fork_call { + @addr = map { sprintf "%x", $_ } @addr; + my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; + open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" + or die "addr2line: $!"; + + my @funcs; + my @res = <$fh>; + chomp for @res; + while (@res) { + my ($func, $line) = splice @res, 0, 2, (); + push @funcs, "[$func] $line"; + } + + @funcs + }; + + LOG llevInfo, "[ABT] $msg\n"; + LOG llevInfo, "[ABT] $_\n" for @bt; + --$_log_backtrace; + }; + } else { + LOG llevInfo, "[ABT] $msg\n"; + LOG llevInfo, "[ABT] [suppressed]\n"; + } +} + # load additional modules use cf::pod;