# Copyright (c) 1997-2006 # Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany) # http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de # # This program is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by the # Free Software Foundation; either version 2, or (at your option) any # later version: http://www.gnu.org/licenses/gpl.txt. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. #---------------------------------------------------------------------------- # $Project: polymake $$Id: Scheduler.pm 7361 2006-05-02 21:37:19Z gawrilow $ use strict; use namespaces; #################################################################################### # # A rule chain under construction # package Poly::RuleChain; use Enum 'Poly::Rule::exec'; use Struct ( [ '$weight' => 'new Poly::Rule::Weight' ], # sum weight of the rules '@rules', # (Rule) rules scheduled for execution, in proper order '%consumer', # Rule => { Rule => 1 } # outgoing arcs in rule precedence graph: rules consuming the output of the given rule '%supplier', # Rule => [ { Rule => 1 } ] # incoming arcs in rule precedence graph: rules producing data needed as input by given rule. # Suppliers are grouped by input properties of the given rule. As soon as the # supplier list become empty, the rule is put in the 'ready' list (below). '%sensitive_consumer', # Rule => { Property => [ Rule ] } '%sensitive_supplier', # Rule => { Property => [ { Rule => 1 } ] } # additional supplier lists triggered by other rules scheduled prior to this '@ready', # (Rule) rules whose inputs are all resolved, that is, created by other rules scheduled earlier. '%preferred', # Rule => [ [ preferred Rule ] ] # Rule can be taken only if at least one list of preferred Rules completely consists # of infeasible or previously failed rules. '$final', # Rule final rule (usually request) '%run', # (precondition or weight) Rule => success code '%dyn_weight', # weight Rule => result $Switches::d>1 || exists $DB::{DB} ? ( # attributes useful for debugging '$id', # unique identifier '$children', # number of variants derived from this chain ) : ( ), ); my $sub_clone=<<'_#_#_#_'; sub { my ($self)=@_; #CLONE_PROLOGUE bless [ $self->weight, (map { deep_copy($_) } $self->rules, $self->consumer, $self->supplier, $self->sensitive_consumer, $self->sensitive_supplier, $self->ready), $self->preferred, $self->final, $self->run, $self->dyn_weight, #CLONE_TRAILER ], "Poly::RuleChain"; } _#_#_#_ if ($Switches::d>1 || exists $DB::{DB}) { $sub_clone =~ s'#CLONE_TRAILER'$self->id.".".(++$self->children), 0,'; require Poly::Scheduler_debug; } *clone=eval $sub_clone; if ($Switches::d || $Switches::v>=2) { # don't expect it installed everywhere eval { require Time::HiRes }; if ($@) { *gettimeofday=sub { times }; *tv_interval=sub { (times)[0]-(shift)->[0] }; } else { import Time::HiRes qw( gettimeofday tv_interval ); } } #################################################################################### package Poly::InitRuleChain; use Enum 'Poly::Rule::exec'; use Struct ( [ new => '$$' ], [ '@ISA' => 'Poly::RuleChain' ], [ '$final' => '#2' ], $Switches::d>1 || exists $DB::{DB} ? ( [ '$id' => '"0"' ], [ '$children' => '0' ], ) : ( ), [ '@Tstart' => '($Switches::v==2 && gettimeofday())' ], '%producer', ); if ($Switches::d>1 || exists $DB::{DB}) { $sub_clone =~ s'#CLONE_PROLOGUE'++$self->id; $self->children=0;'; } *clone=eval $sub_clone; #################################################################################### package Poly::RuleChain; # eliminates given rules, as well as rules becoming infeasible (without supplier) # or useless (without consumer) due to this elimination my $sizeof=sizeof(); sub eliminate_rules { # Rule, ... => my $self=shift; my @elim=@_; my $init= $#$self >= $sizeof; my $verbose= $init && $Switches::v>2; my %marked; @marked{@elim}=(); while (defined (my $rule=shift @elim)) { if (!$init) { # if all consumer of a scheduled rule have gone, this variant has no sense more. foreach my $sched_rule (@{$self->rules}) { my $sched_cons=$self->consumer->{$sched_rule}; if (delete $sched_cons->{$rule} and !keys %{$sched_cons}) { undef $self->final; return; } } } # some rules depending on the one being eliminated may become infeasible if (defined (my $cons=$self->consumer->{$rule})) { foreach my $cons_rule (keys %$cons) { next if exists $marked{$cons_rule}; # each set of suppliers must contain at least one feasible rule my $supp_list=$self->supplier->{$cons_rule}; next unless is_ARRAY($supp_list); foreach my $supp_group (@$supp_list) { if (delete $supp_group->{$rule}) { if (! keys %$supp_group) { dbg_print( " discarding ", $cons_rule->header, ": no more supplier" ) if $verbose; if ($cons_rule == $self->final) { # request become infeasible undef $self->final; return; } push @elim, $cons_rule; $marked{$cons_rule}=1; last; } } } } delete $self->consumer->{$rule}; } # some supplier of the current rule may become useless if (defined (my $supp_list=$self->supplier->{$rule})) { foreach my $supp_group (@$supp_list) { foreach my $supp_rule (keys %$supp_group) { next if exists $marked{$supp_rule}; my $cons=$self->consumer->{$supp_rule}; delete $cons->{$rule}; if (! keys %$cons) { dbg_print( " discarding ", $supp_rule->header, ": no more consumer" ) if $verbose; delete $self->consumer->{$supp_rule}; push @elim, $supp_rule; $marked{$supp_rule}=1; } } } delete $self->supplier->{$rule}; } delete $self->sensitive_supplier->{$rule}; delete $self->preferred->{$rule} if $init; } } #################################################################################### sub add_rule { # Rule => my ($self, $rule)=@_; # check the consumers - some of them might become ready my @to_elim; foreach my $cons_rule (keys %{$self->consumer->{$rule}}) { my $supp_list=$self->supplier->{$cons_rule}; next unless is_ARRAY($supp_list); my %supplier; for (my $i=0; $i<=$#$supp_list; ) { my $supp_group=$supp_list->[$i]; if (delete $supp_group->{$rule}) { foreach my $supp_rule (keys %$supp_group) { $supplier{$supp_rule} |= 1; } splice @$supp_list, $i, 1; } else { foreach my $supp_rule (keys %$supp_group) { $supplier{$supp_rule} |= 2; } ++$i; } } if (!@$supp_list) { push @{$self->ready}, $cons_rule; } while (my ($supp_rule, $code)=each %supplier) { if ($code==1) { my $cons=$self->consumer->{$supp_rule}; delete $cons->{$cons_rule}; # found a superfluous supplier push @to_elim, $supp_rule if !keys %$cons; } } } if (defined (my $sc=$self->sensitive_consumer->{$rule})) { while (my ($generator, $rule_list)=each %$sc) { CONS_RULE: foreach my $cons_rule (@$rule_list) { if (ref($self->supplier->{$cons_rule}) and defined (my $suppliers=delete $self->sensitive_supplier->{$cons_rule}->{$generator})) { # neither scheduled nor eliminated yet nor triggered by another rule producing sensitive props foreach my $supp_rule (keys %$suppliers) { if (defined (my $supp=$self->supplier->{$supp_rule})) { if (!ref($supp)) { # the supplier is already scheduled or run - nothing to be afraid of next CONS_RULE; } } else { # the supplier is eliminated delete $suppliers->{$supp_rule}; } } if (keys %$suppliers) { # some rules not scheduled yet can deliver the data required for the diff - # make them regular supplier of the concerned rule push @{$self->supplier->{$cons_rule}}, $suppliers; $self->consumer->{$_}->{$rule}=1 for keys %$suppliers; } else { # no suppliers avaliable - the rule becomes infeasbile push @to_elim, $cons_rule; } } } } } $self->eliminate_rules(@to_elim); } #################################################################################### sub add_ready_rule { my ($self, $rule)=@_; push @{$self->rules}, $rule; $self->supplier->{$rule}='incl'; $self->weight += $rule->weight; if (defined (my $dwr=$rule->dyn_weight)) { # if the dynamic weight is not computed yet, this variant will not be executed as is. # instead, it might be rebuilt after all postponed preconditions are checked if (defined (my $dw=$self->dyn_weight->{$dwr})) { $self->weight += $dw; } } my $pref=$self->preferred->{$rule}; if (defined($pref) && @$pref) { $self->weight->set_atom($Poly::Rule::Weight::max_major, 1); # preference violation penalty } &add_rule; } #################################################################################### sub constrain { # ( Rules ) => ( Rules with suppliers ) my $self=shift; my %keep; @keep{@_}=(); my $rules=$self->rules; my @result; # visit in reverse order, since the consumer are always executed later than their supplier RULE: for (my $i=$#$rules; $i>=0; --$i) { my $rule=$rules->[$i]; if (exists $keep{$rule}) { unshift @result, $rule; splice @$rules, $i, 1; # it's a precondition rule - remove it next; } foreach my $cons_rule (keys %{$self->consumer->{$rule}}) { if (exists $keep{$cons_rule}) { $keep{$rule}=1; unshift @result, $rule; next RULE; } } } @result; } #################################################################################### sub execute { # => number of the failed rule my ($self, $object, $rules)=@_; $rules ||= $self->rules; my $i=0; my $weight_added; foreach my $rule (@$rules) { my ($rc, $retval)=$rule->execute($object); $self->run->{$rule}=$rc; if ($rc != $exec_OK) { if ($@) { chomp $@; warn_print( "rule ", $rule->header, " failed: $@" ); undef $@; } return $i; } if (wantarray && !ref($rule->output) && $rule->output==$Poly::Rule::is_dyn_weight) { $weight_added=1; $self->dyn_weight->{$rule}=$retval; $self->weight += $retval; } ++$i; } wantarray ? (undef, $weight_added) : undef; } #################################################################################### sub report { my ($self)=@_; return @{$self->rules} ? ( (map { (" ", $_->header, "\n") } @{$self->rules}), " Sum weight=", $self->weight ) : ("nothing to do"); } #################################################################################### package Poly::InitRuleChain; sub good_rule($$$) { my ($self, $object, $rule)=@_; my $rc; !$object->failed_rules->{$rule} && (!defined($rc=$self->run->{$rule}) || $rc != $exec_failed) } #################################################################################### # find all rules supplying one of the properties of the given input list of the given rule # => { Rule => 1 } sub find_suppliers($$$) { my ($self, $object, $input)=@_; my %supp_group; foreach my $prop (@$input) { foreach my $rule (@{ $self->producer->{$prop} ||= do { my $method=$object->can($prop->prod_method); [ grep { good_rule($self, $object, $_) } @{$method->($object)} ] }}) { if (!defined $self->supplier->{$rule}) { $self->supplier->{$rule}=[ ]; push @{$self->rules}, $rule; } $supp_group{$rule}=1; } } return \%supp_group; } #################################################################################### # private: # => undef if applicable, 'text' if infeasible sub rule_status($$$$) { my ($self, $object, $rule, $verbose)=@_; $self->supplier->{$rule} ||= [ ]; foreach my $input_list (@{$rule->input}) { if (! $object->eval_input_list($input_list)) { my $suppliers=find_suppliers($self, $object, $input_list); if (keys %$suppliers) { push @{$self->supplier->{$rule}}, $suppliers; $self->consumer->{$_}->{$rule}=1 for keys %$suppliers; } else { return $verbose && "no available rules to produce " . join(" | ", map { $_->name } @$input_list); } } } while (my ($generator, $input_list)=each %{$rule->triggered_diff}) { if (! $object->eval_input_list($input_list)) { my $positive_suppliers=find_suppliers($self, $object, $input_list); delete $positive_suppliers->{$rule}; my %positive; @positive{@$input_list}=(); my @negative=grep { !exists $positive{$_} } @{$generator->diff_sensitive} or next; if ($object->eval_input_list(\@negative)) { if (keys %$positive_suppliers) { push @{$self->supplier->{$rule}}, $positive_suppliers; $self->consumer->{$_}->{$rule}=1 for keys %$positive_suppliers; } else { return $verbose && (@$input_list ? "no available rules to produce " . join(" | ", map { $_->name } @$input_list) . " needed to synchronize output sensitive to diff(".$generator->name.")" : "produces from scratch output sensitive to diff(".$generator->name. ") but other sensitive properties already exist"); } } else { # preserve up to the end of initial() $self->sensitive_supplier->{$rule}->{$generator}=[ \@negative, $positive_suppliers ]; } } } undef; } #################################################################################### # private: sub resolve_sensitive_suppliers { my ($self)=@_; while (my ($rule, $dict)=each %{$self->sensitive_supplier}) { while (my ($generator, $list)=each %$dict) { my ($negative, $positive_suppliers)=@$list; my $cnt=0; my %seen=%$positive_suppliers; foreach my $prop (@$negative) { if (defined (my $producer=$self->producer->{$prop})) { foreach my $prod_rule (@$producer) { if (exists $self->supplier->{$prod_rule} and !exists $seen{$prod_rule}) { ++$cnt; push @{$self->sensitive_consumer->{$prod_rule}->{$generator}}, $rule; $seen{$prod_rule}=1; # avoid multiple inclusion } } } } if ($cnt) { $dict->{$generator}=$positive_suppliers; } else { # no danger: none of the possible sensitive properties is going to be created in this schedule delete $dict->{$generator}; } } if (!keys %$dict) { # all concerned diff groups are safe delete $self->sensitive_supplier->{$rule}; } } } #################################################################################### # Object, final Rule => sub new { my $self=&_new; my ($object)=@_; my $verbose=$Switches::v>2; dbg_print( "gathering viable rules" ) if $verbose; $self->consumer->{$self->final}={ }; if (defined (my $explain=rule_status($self, $object, $self->final, $verbose))) { dbg_print( " infeasible: ", $self->final->header, ": $explain" ) if $explain; return undef; } $self; } #################################################################################### # protected: sub gather_rules { my ($self, $object)=@_; my $verbose=$Switches::v>2; my (@infeasible, %labels); # breadth-first search in the implicit graph of object states RULE: while (defined (my $rule=shift @{$self->rules})) { foreach my $precond_rule (@{$rule->preconditions}) { if (!good_rule($self, $object, $precond_rule)) { dbg_print( " infeasible: ", $rule->header, ": failed ", $precond_rule->header, " (tested earlier)" ) if $verbose; push @infeasible, $rule; next RULE; } next if $self->run->{$precond_rule} == $exec_OK; # precondition was successfully checked earlier if (defined (my $explain=rule_status($self, $object, $precond_rule, $verbose))) { dbg_print( " infeasible: ", $precond_rule->header, ": $explain\n", " infeasible: ", $rule->header, " due to failed precondition above" ) if $explain; push @infeasible, $rule, $precond_rule; $self->run->{$precond_rule}=$exec_failed; $self->run->{$rule}=$exec_failed; next RULE; } if (! @{$self->supplier->{$precond_rule}}) { dbg_print( " ready to evaluate: ", $precond_rule->header ) if $verbose; if ($Switches::n) { # we don't apply any rules in dry run mode, even if they are ready to use. # we must just show it in the final schedule push @{$self->ready}, $precond_rule; } else { my ($rc, $retval)=$precond_rule->execute($object); if (($self->run->{$precond_rule}=$rc) != $exec_OK) { if ($@) { chomp $@; warn_print( "precondition ", $precond_rule->header, " failed: $@" ); undef $@; } dbg_print( " infeasible: ", $rule->header, " due to failed precondition above" ) if $verbose; push @infeasible, $rule; $self->run->{$rule}=$exec_failed; next RULE; } $self->dyn_weight->{$precond_rule}=$retval if $precond_rule->output == $Poly::Rule::is_dyn_weight; next; } } # the precondition rule must be evaluated later, let it become an exclusive supplier of the current production rule $self->consumer->{$precond_rule}->{$rule}=1; push @{$self->supplier->{$rule}}, { $precond_rule => 1 }; } if (defined (my $explain=rule_status($self, $object, $rule, $verbose))) { dbg_print( " infeasible: ", $rule->header, ": $explain" ) if $explain; push @infeasible, $rule; $self->run->{$rule}=$exec_failed; next RULE; } elsif (! @{$self->supplier->{$rule}}) { # rule can be immediately applied push @{$self->ready}, $rule; dbg_print( " ready to use: ", $rule->header ) if $verbose; } else { dbg_print( " applicable: ", $rule->header ) if $verbose; } foreach my $label (@{$rule->labels}) { my $family=$label->wildcard_name; if (! $labels{$family}++) { my (@pref, @next); foreach my $bag (Poly::Preference::Label::get_items_by_rank($object->$family())) { shift @$bag; # get rid of the rank @next=grep { good_rule($self, $object, $_) } @$bag; push @{$self->preferred->{$_}}, @pref for @next; push @pref, @next; } } } } $self->check_rule_graph if $Switches::d>1; $self->eliminate_rules(@infeasible); $self->resolve_sensitive_suppliers; $self->squeeze_prefs; $self->dump if $Switches::d>=3; } #################################################################################### # # Create the initial rule chain # # Object, final Rule => sub Poly::RuleChain::initial { shift; unshift @_, "Poly::InitRuleChain"; my $self=&Poly::InitRuleChain::new or return undef; gather_rules($self,@_); $self; } #################################################################################### sub squeeze_prefs { my ($self)=@_; my $rc; while (my ($rule, $list)=each %{$self->preferred}) { next if !exists $self->supplier->{$rule}; # not relevant my $r=0; while ($r<=$#$list) { my $pref_rule=$list->[$r]; if (!exists $self->supplier->{$pref_rule} # eliminated || ($rc=$self->run->{$pref_rule}, defined($rc) && $rc==$exec_failed)) { splice @$list, $r, 1; } else { ++$r; } } if ($Switches::v>2) { if (!$r) { dbg_print( " preferred: ", $rule->header ); } else { dbg_print( " not preferred: ", $rule->header, map { "\n after ".$_->header."\n" } @$list ); } } } } #################################################################################### sub constrain_to_preferred { my ($self)=@_; my @elim; foreach my $supp_group (@{$self->supplier->{$self->final}}) { foreach my $supp_rule (keys %$supp_group) { my $pref=$self->preferred->{$supp_rule}; push @elim, $supp_rule if !defined($pref) || @$pref; if ($Switches::v>2 and !defined($pref) || @$pref) { dbg_print( " excluding ", $supp_rule->header ); } } } $self->eliminate_rules(@elim); die "no available preferred rules left over\n" if !defined($self->final); } #################################################################################### sub add_run_rules { my ($self, $rules, $last_rule)=@_; # remember: last_rule (if defined) is the index of the failed rule (in $rules) my $last_failed=defined $last_rule; $last_rule=$#$rules unless $last_failed; my $last_succeeded=$last_rule-$last_failed; # resolve the consumers of the successful rules foreach my $rule (@$rules[0 .. $last_succeeded]) { $self->add_rule($rule); $self->supplier->{$rule}='run'; delete $self->consumer->{$rule}; # force it to be filtered out of @ready during the cloning } if ($last_failed) { $self->eliminate_rules($rules->[$last_rule]); $self->squeeze_prefs; } } #################################################################################### package Poly::Scheduler::Heap; sub new { shift; bless [ @_ ]; } sub push { my ($self, $var)=@_; push @$self, $var; my $i=$#$self; while ($i>0) { my $parent=($i-1)/2; last if $var->weight >= $self->[$parent]->weight; $self->[$i]=$self->[$parent]; $i=$parent; } $self->[$i]=$var; } sub pop { my ($self)=@_; my $top=$self->[0]; if ($#$self>0) { my $var=pop @$self; my $i=0; while ((my $child=$i*2+1)<=$#$self) { $child++ if $child<$#$self and $self->[$child]->weight > $self->[$child+1]->weight; last if $var->weight <= $self->[$child]->weight; $self->[$i]=$self->[$child]; $i=$child; } $self->[$i]=$var; } else { @$self=(); } $top } sub reset { my $self=shift; @$self=@_; } #################################################################################### package Poly::InitRuleChain; # return value: # => 1 if some rule chain successfully executed (or there was nothing to do) # => 0 if no suitable rule chain found # => -n if n different rule chains tried, but no succeeded (if max_tries defined, n<=max_tries) # => RuleChain if max_tries==0 and the rule chain found would do # => undef if max_tries==0 and no suitable rule chain found sub resolve { my ($self, $object, $max_tries)=@_; my $tries=0; if (defined($self->final) and do { if (!@{$self->supplier->{$self->final}}) { return $self if defined($max_tries) && !$max_tries; dbg_print( "nothing to do" ) if $Switches::v>2; return 1; } @{$self->ready} }) { dbg_print( "composing a minimum weight rule chain" ) if $Switches::v>2; my ($maxheap, $popcnt)=(1,0); my $heap=new Poly::Scheduler::Heap($self->clone); while (defined (my $top=$heap->pop)) { ++$popcnt; if ($Switches::d>1) { if (defined $top->final) { $top->announce_pop; } else { $top->dump; die "dead variant in heap!\n"; } } if (@{$top->rules} and @{$top->supplier->{$self->final}} || defined($top->rules->[-1]->dyn_weight) and !$Switches::n and my @postponed= grep { !defined $top->run->{$_} } @{$top->rules->[-1]->preconditions}) { # the rule added last has unchecked preconditions, and the rule chain is not complete: # it's the good moment to check them now dbg_print( "checking postponed preconditions" ) if $Switches::v>2; my @to_run=$top->constrain(@postponed); my ($last_failed, $weight_added)=$top->execute($object, \@to_run); $self->add_run_rules(\@to_run, $last_failed); last if !defined($self->final) or !@{$self->ready}; if (defined($last_failed) || @to_run != @postponed) { $heap->reset($self->clone); next; } elsif ($weight_added) { $heap->push($top); next; } } if (!@{$top->supplier->{$self->final}}) { # ready dbg_print( sprintf "minimum weight rule chain constructed in %.3f sec.", tv_interval($self->Tstart) ) if $Switches::v==2; dbg_print( "|heap|: cur=", $#$heap+2, ", max=$maxheap, #pop=$popcnt\n" ) if $Switches::d; return $top if defined($max_tries) && !$max_tries; dbg_print( "rules to execute:\n", $top->report ) if $Switches::d; my $last_failed=$top->execute($object); return 1 if !defined $last_failed; ++$tries; last if defined($max_tries) && $tries >= $max_tries; if ($Switches::v>=2) { dbg_print( "trying to find an alternative way" ); @{$self->Tstart}=gettimeofday() if $Switches::v==2; } $self->add_run_rules($top->rules, $last_failed); last if !defined($self->final) or !@{$self->ready}; $heap->reset($self->clone); $maxheap=1; $popcnt=0; } else { # not ready my $ready_list=$top->ready; $top->ready=[]; while (1) { my $rule=shift @$ready_list; if (!defined ($top->consumer->{$rule})) { # already run @$ready_list ? next : last; } my $var= @$ready_list ? $top->clone : $top; $var->add_ready_rule($rule); if (defined($var->final)) { # revise remaining ready rules - some of them might become useless push @{$var->ready}, grep { defined($var->consumer->{$_}) } @$ready_list; if (@{$var->ready}) { $heap->push($var); $var->announce_push if $Switches::d>1; } } # eliminate the skipped rule in the stem variant last if !@$ready_list or $top->eliminate_rules($rule), !defined($top->final); } $maxheap=max($maxheap, $#$heap+1) if $Switches::d; } } # end while (heap) } return !defined($max_tries) || $max_tries>0 ? -$tries : undef; } #################################################################################### 1 # Local Variables: # c-basic-offset:3 # End: