From: Mark Thom Date: Tue, 16 Nov 2021 04:27:42 +0000 (-0700) Subject: greatly reduce the number of goal expansions done in callable if/then/else X-Git-Tag: v0.9.0^2~131 X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=ffd1b7069f0ddcc0c1c14c03560bbddc57abc8ce;p=scryer-prolog.git greatly reduce the number of goal expansions done in callable if/then/else --- diff --git a/src/clause_types.rs b/src/clause_types.rs index e7c2c853..d3ba917c 100644 --- a/src/clause_types.rs +++ b/src/clause_types.rs @@ -284,6 +284,7 @@ pub enum SystemClauseType { GetBall, GetCurrentBlock, GetCutPoint, + GetStaggeredCutPoint, GetDoubleQuotes, InstallNewBlock, Maybe, @@ -525,6 +526,7 @@ impl SystemClauseType { &SystemClauseType::Fail => atom!("$fail"), &SystemClauseType::GetBall => atom!("$get_ball"), &SystemClauseType::GetCutPoint => atom!("$get_cp"), + &SystemClauseType::GetStaggeredCutPoint => atom!("$get_staggered_cp"), &SystemClauseType::GetCurrentBlock => atom!("$get_current_block"), &SystemClauseType::InstallNewBlock => atom!("$install_new_block"), &SystemClauseType::NextEP => atom!("$nextEP"), @@ -705,6 +707,7 @@ impl SystemClauseType { (atom!("$get_cont_chunk"), 3) => Some(SystemClauseType::GetContinuationChunk), (atom!("$get_current_block"), 1) => Some(SystemClauseType::GetCurrentBlock), (atom!("$get_cp"), 1) => Some(SystemClauseType::GetCutPoint), + (atom!("$get_staggered_cp"), 1) => Some(SystemClauseType::GetStaggeredCutPoint), (atom!("$install_new_block"), 1) => Some(SystemClauseType::InstallNewBlock), (atom!("$quoted_token"), 1) => Some(SystemClauseType::QuotedToken), (atom!("$nextEP"), 3) => Some(SystemClauseType::NextEP), diff --git a/src/lib/builtins.pl b/src/lib/builtins.pl index 0c9d33f9..534edb06 100644 --- a/src/lib/builtins.pl +++ b/src/lib/builtins.pl @@ -1,4 +1,4 @@ -:- module(builtins, [(=)/2, (\=)/2, (\+)/1, (',')/2, (->)/2, (;)/2, +:- module(builtins, [(=)/2, (\=)/2, (\+)/1, !/0, (',')/2, (->)/2, (;)/2, (=..)/2, (:)/2, (:)/3, (:)/4, (:)/5, (:)/6, (:)/7, (:)/8, (:)/9, (:)/10, (:)/11, (:)/12, abolish/1, asserta/1, assertz/1, @@ -61,10 +61,8 @@ call(G, A, B, C, D, E, F, G, H) :- '$call'(G, A, B, C, D, E, F, G, H). Module : Predicate :- - ( atom(Module) -> - '$module_call'(Module, Predicate) - ; - throw(error(type_error(atom, Module), (:)/2)) + ( atom(Module) -> '$module_call'(Module, Predicate) + ; throw(error(type_error(atom, Module), (:)/2)) ). @@ -205,142 +203,115 @@ repeat. repeat :- repeat. +:- meta_predicate ','(0,0). -:- meta_predicate ','(0, 0). - -:- meta_predicate ','(0, +, +). - -:- meta_predicate ;(0, 0). - -:- meta_predicate ;(0, 0, +). - -:- meta_predicate ->(0, 0). - -:- meta_predicate ->(0, 0, +). - - -','(G1, G2) :- - '$get_b_value'(B), - ( '$call_with_default_policy'(var(G1)) -> - throw(error(instantiation_error, (',')/2)) - ; '$call_with_default_policy'(','(G1, G2, B)) - ). - - -';'(G1, G2) :- - '$get_b_value'(B), - ( '$call_with_default_policy'(var(G1)) -> - throw(error(instantiation_error, (';')/2)) - ; '$call_with_default_policy'(';'(G1, G2, B)) - ). - - -G1 -> G2 :- - '$get_b_value'(B), - ( '$call_with_default_policy'(var(G1)) -> - throw(error(instantiation_error, (->)/2)) - ; '$call_with_default_policy'(->(G1, G2, B)) - ). - - -:-non_counted_backtracking call_or_cut/3. - -call_or_cut(G, B, ErrorPI) :- - ( '$call_with_default_policy'(var(G)) -> - throw(error(instantiation_error, ErrorPI)) - ; '$call_with_default_policy'(call_or_cut(G, B)) - ). - - -:- non_counted_backtracking control_functor/1. - -control_functor(_:G) :- nonvar(G), control_functor(G). -control_functor(call(_:C)) :- C == !. -control_functor(!). -control_functor((_,_)). -control_functor((_;_)). -control_functor((_->_)). - - -:- non_counted_backtracking call_or_cut/2. +:- meta_predicate ;(0,0). -call_or_cut(G, B) :- - ( nonvar(G), - '$call_with_default_policy'(control_functor(G)) -> - '$call_with_default_policy'(call_or_cut_interp(G, B)) - ; call(G) - ). +:- meta_predicate ->(0,0). +% '!' is for internal use as a callable no-op within if/then/else. +% Where it shouldn't be a no-op, it's interpreted under the expected +% semantics by comma_dispatch/3. -:- non_counted_backtracking call_or_cut_interp/2. +! :- '$get_staggered_cp'(B), '$set_cp'(B). -call_or_cut_interp(_ : G, B) :- - call_or_cut_interp(G, B). -call_or_cut_interp(call(_ : !), B) :- - !. % '$set_cp'(B). -call_or_cut_interp(!, B) :- - '$set_cp'(B). -call_or_cut_interp((G1, G2), B) :- - '$call_with_default_policy'(','(G1, G2, B)). -call_or_cut_interp((G1 ; G2), B) :- - '$call_with_default_policy'(';'(G1, G2, B)). -call_or_cut_interp((G1 -> G2), B) :- - '$call_with_default_policy'(->(G1, G2, B)). +G1 -> G2 :- '$get_staggered_cp'(B), call('$call'(G1)), '$set_cp'(B), call('$call'(G2)). +G ; _ :- call('$call'(G)). +_ ; G :- call('$call'(G)). -:- non_counted_backtracking (',')/3. +','(G1, G2) :- '$get_staggered_cp'(B), comma_dispatch(G1,G2,B). -','(G1, G2, B) :- - ( nonvar(G1), - '$call_with_default_policy'(control_functor(G1)) -> - '$call_with_default_policy'(call_or_cut_interp(G1, B)), - '$call_with_default_policy'(call_or_cut(G2, B, (',')/2)) - ; call(G1), - '$call_with_default_policy'(call_or_cut(G2, B, (',')/2)) - ). +set_cp(B) :- '$set_cp'(B). -:- non_counted_backtracking (;)/3. +:- non_counted_backtracking comma_dispatch_prep/3. -';'(G1, G2, B) :- - ( nonvar(G1), - '$call_with_default_policy'(control_functor(G1)) -> - '$call_with_default_policy'(';-interp'(G1, G2, B)) - ; call(G1) - ; '$call_with_default_policy'(call_or_cut(G2, B, (;)/2)) +comma_dispatch_prep(Gs, B, [Cont|Conts]) :- + ( callable(Gs) -> + ( functor(Gs, ',', 2) -> + arg(1, Gs, G1), + arg(2, Gs, G2), + ( G1 == ! -> + Cont = builtins:set_cp(B) + ; callable(G1) -> + Cont = G1 + ; Cont = throw(error(type_error(callable, G1), call/1)) + ), + comma_dispatch_prep(G2, B, Conts) + ; Cont = Gs, + Conts = [] + ) + ; Gs == ! -> + Cont = builtins:set_cp(B), + Conts = [] + ; Cont = throw(error(type_error(callable, Gs), call/1)), + Conts = [] ). -:- non_counted_backtracking ';-interp'/3. +:- non_counted_backtracking comma_dispatch_call_list/1. -';-interp'((G1 -> G2), G3, B) :- +comma_dispatch_call_list([]). +comma_dispatch_call_list([G1,G2,G3,G4,G5,G6,G7,G8|Gs]) :- !, - ( '$call_with_default_policy'(call_or_cut(G1, B, (->)/2)) -> - '$call_with_default_policy'(call_or_cut(G2, B, (->)/2)) - ; '$call_with_default_policy'(call_or_cut(G3, B, (;)/2)) - ). -';-interp'(_:(G1 -> G2), G3, B) :- + '$call'(G1), + '$call'(G2), + '$call'(G3), + '$call'(G4), + '$call'(G5), + '$call'(G6), + '$call'(G7), + '$call'(G8), + comma_dispatch_call_list(Gs). +comma_dispatch_call_list([G1,G2,G3,G4,G5,G6,G7]) :- !, - ( '$call_with_default_policy'(call_or_cut(G1, B, (->)/2)) -> - '$call_with_default_policy'(call_or_cut(G2, B, (->)/2)) - ; '$call_with_default_policy'(call_or_cut(G3, B, (;)/2)) - ). -';-interp'(G1, G2, B) :- - ( '$call_with_default_policy'(call_or_cut_interp(G1, B)) - ; '$call_with_default_policy'(call_or_cut(G2, B, (;)/2)) - ). + '$call'(G1), + '$call'(G2), + '$call'(G3), + '$call'(G4), + '$call'(G5), + '$call'(G6), + '$call'(G7). +comma_dispatch_call_list([G1,G2,G3,G4,G5,G6]) :- + !, + '$call'(G1), + '$call'(G2), + '$call'(G3), + '$call'(G4), + '$call'(G5), + '$call'(G6). +comma_dispatch_call_list([G1,G2,G3,G4,G5]) :- + !, + '$call'(G1), + '$call'(G2), + '$call'(G3), + '$call'(G4), + '$call'(G5). +comma_dispatch_call_list([G1,G2,G3,G4]) :- + !, + '$call'(G1), + '$call'(G2), + '$call'(G3), + '$call'(G4). +comma_dispatch_call_list([G1,G2,G3]) :- + !, + '$call'(G1), + '$call'(G2), + '$call'(G3). +comma_dispatch_call_list([G1,G2]) :- + !, + '$call'(G1), + '$call'(G2). +comma_dispatch_call_list([G1]) :- + '$call'(G1). -:- non_counted_backtracking (->)/3. +:- non_counted_backtracking comma_dispatch/3. + +comma_dispatch(G1, G2, B) :- + comma_dispatch_prep((G1, G2), B, Conts), + comma_dispatch_call_list(Conts). -->(G1, G2, B) :- - ( nonvar(G1), - '$call_with_default_policy'(control_functor(G1)) -> - ( '$call_with_default_policy'(call_or_cut_interp(G1, B)) -> - '$call_with_default_policy'(call_or_cut(G2, B, (->)/2)) - ) - ; call(G1) -> - '$call_with_default_policy'(call_or_cut(G2, B, (->)/2)) - ). % univ. diff --git a/src/loader.pl b/src/loader.pl index 722d413a..87d758be 100644 --- a/src/loader.pl +++ b/src/loader.pl @@ -629,6 +629,8 @@ expand_module_name(ESG0, M, ESG) :- ESG = M:ESG0 ; ESG0 = _:_ -> ESG = ESG0 + ; predicate_property(ESG0, built_in) -> + ESG = ESG0 ; ESG = M:ESG0 ). @@ -656,7 +658,8 @@ expand_module_names(Goals, MetaSpecs, Module, ExpandedGoals, HeadVars) :- ( GoalFunctor == (:), SubGoals = [M, SubGoal] -> expand_module_names(SubGoal, MetaSpecs, M, ExpandedSubGoal, HeadVars), - ExpandedGoals = M:ExpandedSubGoal + expand_module_name(ExpandedSubGoal, M, ExpandedGoals) + % ExpandedGoals = M:ExpandedSubGoal ; expand_meta_predicate_subgoals(SubGoals, MetaSpecs, Module, ExpandedGoalList, HeadVars), ExpandedGoals =.. [GoalFunctor | ExpandedGoalList] ). diff --git a/src/machine/machine_state_impl.rs b/src/machine/machine_state_impl.rs index 8f4dc44d..89dd4269 100644 --- a/src/machine/machine_state_impl.rs +++ b/src/machine/machine_state_impl.rs @@ -202,9 +202,9 @@ impl MachineState { RefTag::HeapCell => { self.heap[r1.get_value() as usize] = t2; } - RefTag::AttrVar => { - self.bind_attr_var(r1.get_value() as usize, t2); - } + RefTag::AttrVar => { + self.bind_attr_var(r1.get_value() as usize, t2); + } }; self.trail(TrailRef::Ref(r1)); @@ -1457,7 +1457,7 @@ impl MachineState { let order_cat_v2 = v2.order_category(); if order_cat_v1 != order_cat_v2 { - self.pdl.clear(); + self.pdl.clear(); return Some(order_cat_v1.cmp(&order_cat_v2)); } @@ -1467,7 +1467,7 @@ impl MachineState { let v2 = v2.as_var().unwrap(); if v1 != v2 { - self.pdl.clear(); + self.pdl.clear(); return Some(v1.cmp(&v2)); } } @@ -1476,7 +1476,7 @@ impl MachineState { let v2 = cell_as_f64_ptr!(v2); if v1 != v2 { - self.pdl.clear(); + self.pdl.clear(); return Some(v1.cmp(&v2)); } } @@ -1485,7 +1485,7 @@ impl MachineState { let v2 = Number::try_from(v2).unwrap(); if v1 != v2 { - self.pdl.clear(); + self.pdl.clear(); return Some(v1.cmp(&v2)); } } @@ -1495,18 +1495,18 @@ impl MachineState { read_heap_cell!(v2, (HeapCellValueTag::Atom, (n2, _a2)) => { if n1 != n2 { - self.pdl.clear(); + self.pdl.clear(); return Some(n1.cmp(&n2)); } } (HeapCellValueTag::Char, c2) => { if let Some(c1) = n1.as_char() { if c1 != c2 { - self.pdl.clear(); + self.pdl.clear(); return Some(c1.cmp(&c2)); } } else { - self.pdl.clear(); + self.pdl.clear(); return Some(Ordering::Greater); } } @@ -1520,17 +1520,17 @@ impl MachineState { (HeapCellValueTag::Atom, (n2, _a2)) => { if let Some(c2) = n2.as_char() { if c1 != c2 { - self.pdl.clear(); + self.pdl.clear(); return Some(c1.cmp(&c2)); } } else { - self.pdl.clear(); + self.pdl.clear(); return Some(Ordering::Less); } } (HeapCellValueTag::Char, c2) => { if c1 != c2 { - self.pdl.clear(); + self.pdl.clear(); return Some(c1.cmp(&c2)); } } @@ -1634,7 +1634,7 @@ impl MachineState { self.heap.pop(); self.heap.pop(); - self.pdl.clear(); + self.pdl.clear(); return Some(ordering); } @@ -1675,7 +1675,7 @@ impl MachineState { self.pdl.push(self.heap[l1]); } ordering => { - self.pdl.clear(); + self.pdl.clear(); return Some(ordering); } } @@ -1698,7 +1698,7 @@ impl MachineState { self.heap.pop(); self.heap.pop(); - self.pdl.clear(); + self.pdl.clear(); return Some(ordering); } @@ -1730,7 +1730,7 @@ impl MachineState { } } ordering => { - self.pdl.clear(); + self.pdl.clear(); return Some(ordering); } } @@ -1754,7 +1754,7 @@ impl MachineState { self.pdl.push(self.heap[s1+2]); } ordering => { - self.pdl.clear(); + self.pdl.clear(); return Some(ordering); } } @@ -1772,7 +1772,7 @@ impl MachineState { self.heap.pop(); self.heap.pop(); - self.pdl.clear(); + self.pdl.clear(); return Some(ordering); } @@ -1793,7 +1793,7 @@ impl MachineState { } None => { if v1 != v2 { - self.pdl.clear(); + self.pdl.clear(); return None; } } @@ -1873,8 +1873,8 @@ impl MachineState { None => unreachable!(), } } - TrailEntryTag::TrailedAttachedValue => { - } + TrailEntryTag::TrailedAttachedValue => { + } } } } @@ -3307,11 +3307,11 @@ impl MachineState { self.heap.push(atom_as_cell!(name, arity)); for i in 0..arity { - self.heap.push(heap_loc_as_cell!(h + i + 1)); - } + self.heap.push(heap_loc_as_cell!(h + i + 1)); + } str_loc_as_cell!(h) - }; + }; (self.bind_fn)(self, r, f_a); } @@ -3441,10 +3441,10 @@ impl MachineState { Err(self.error_form(err, stub_gen())) } } - (HeapCellValueTag::CStr, cstr_atom) => { - let cstr = cstr_atom.as_str(); - Ok(cstr.chars().map(|c| char_as_cell!(c)).collect()) - } + (HeapCellValueTag::CStr, cstr_atom) => { + let cstr = cstr_atom.as_str(); + Ok(cstr.chars().map(|c| char_as_cell!(c)).collect()) + } _ => { let err = self.type_error(ValidType::List, store_v); Err(self.error_form(err, stub_gen())) diff --git a/src/machine/system_calls.rs b/src/machine/system_calls.rs index 9f3dd089..7b85f2c4 100644 --- a/src/machine/system_calls.rs +++ b/src/machine/system_calls.rs @@ -3580,6 +3580,54 @@ impl MachineState { let n = Fixnum::build_with(i64::try_from(self.b0).unwrap()); self.unify_fixnum(n, self.registers[1]); } + &SystemClauseType::GetStaggeredCutPoint => { + use std::sync::Once; + + let b = self.store(self.deref(self.registers[1])); + + static mut SEMICOLON_SECOND_BRANCH_LOC: usize = 0; + static LOC_INIT: Once = Once::new(); + + let semicolon_second_clause_p = unsafe { + LOC_INIT.call_once(|| { + match indices.code_dir.get(&(atom!(";"), 2)).map(|cell| cell.get()) { + Some(IndexPtr::Index(p)) => { + match code_repo.code[p] { + Line::Choice(ChoiceInstruction::TryMeElse(o)) => { + SEMICOLON_SECOND_BRANCH_LOC = p + o; + } + _ => { + unreachable!(); + } + } + } + _ => { + unreachable!(); + } + } + }); + + LocalCodePtr::DirEntry(SEMICOLON_SECOND_BRANCH_LOC) + }; + + let staggered_b0 = if self.b > 0 { + let or_frame = self.stack.index_or_frame(self.b); + + if or_frame.prelude.bp == semicolon_second_clause_p { + or_frame.prelude.b0 + } else { + self.b0 + } + } else { + self.b0 + }; + + let staggered_b0 = integer_as_cell!( + Number::arena_from(staggered_b0, &mut self.arena) + ); + + self.bind(b.as_var().unwrap(), staggered_b0); + } &SystemClauseType::InstallNewBlock => { self.install_new_block(self.registers[1]); }