rishi/scryer-prolog
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

greatly reduce the number of goal expansions done in callable if/then/else

Browse Source
This commit is contained in:
Mark Thom
2021-11-15 21:27:42 -07:00
parent 0404c3bd94
commit ffd1b7069f
5 changed files with 184 additions and 159 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/clause_types.rs
View File

@@ -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),

229
src/lib/builtins.pl
View File

@@ -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,143 +203,116 @@ repeat.
repeat :- repeat.
:- meta_predicate ','(0,0).
:- meta_predicate ','(0, 0).
:- meta_predicate ;(0,0).
:- meta_predicate ','(0, +, +).
:- meta_predicate ->(0,0).
:- 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.
:- meta_predicate ;(0, 0, +).
! :- '$get_staggered_cp'(B), '$set_cp'(B).
:- meta_predicate ->(0, 0).
G1 -> G2 :- '$get_staggered_cp'(B), call('$call'(G1)), '$set_cp'(B), call('$call'(G2)).
:- meta_predicate ->(0, 0, +).
G ; _ :- call('$call'(G)).
_ ; G :- call('$call'(G)).
','(G1, G2) :- '$get_staggered_cp'(B), comma_dispatch(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))
).
set_cp(B) :- '$set_cp'(B).
:- non_counted_backtracking comma_dispatch_prep/3.
';'(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.
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)
).
:- non_counted_backtracking call_or_cut_interp/2.
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)).
:- non_counted_backtracking (',')/3.
','(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))
).
:- non_counted_backtracking (;)/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))
).
:- non_counted_backtracking ';-interp'/3.
';-interp'((G1 -> G2), G3, B) :-
!,
( '$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_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))
).
:- non_counted_backtracking (->)/3.
->(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))
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 = []
)
; call(G1) ->
'$call_with_default_policy'(call_or_cut(G2, B, (->)/2))
; Gs == ! ->
Cont = builtins:set_cp(B),
Conts = []
; Cont = throw(error(type_error(callable, Gs), call/1)),
Conts = []
).
:- non_counted_backtracking comma_dispatch_call_list/1.
comma_dispatch_call_list([]).
comma_dispatch_call_list([G1,G2,G3,G4,G5,G6,G7,G8|Gs]) :-
!,
'$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'(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 comma_dispatch/3.
comma_dispatch(G1, G2, B) :-
comma_dispatch_prep((G1, G2), B, Conts),
comma_dispatch_call_list(Conts).
% univ.
:- non_counted_backtracking univ_errors/3.

5
src/loader.pl
View File

@@ -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]
).

58
src/machine/machine_state_impl.rs
View File

@@ -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()))

48
src/machine/system_calls.rs
View File

@@ -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]);
}