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

improve efficiency of call/N, replace '$call_with_default_policy' with

Browse Source 
'$call_with_inference_counting'
This commit is contained in:
Mark Thom
2022-06-12 22:17:44 -06:00
parent a68394b6f2
commit 987bbdecf5
12 changed files with 1116 additions and 621 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/codegen.rs
View File

@@ -196,6 +196,16 @@ impl CodeGenSettings {
Instruction::TrustMe(0)
}
}
pub(crate) fn default_call_policy(&self) -> CallPolicy {
// calls are inference counted by default if and only if
// backtracking is counted too.
if self.non_counted_bt {
CallPolicy::Default
} else {
CallPolicy::Counted
}
}
}
#[derive(Debug)]
@@ -459,10 +469,10 @@ impl<'b> CodeGenerator<'b> {
self.jmp_by_locs.push(code.len());
code.push(instr!("jmp_by_call", vars.len(), 0, pvs));
}
&QueryTerm::Clause(_, ref ct, _, true) => {
&QueryTerm::Clause(_, ref ct, _, CallPolicy::Default) => {
code.push(call_clause_by_default!(ct.clone(), pvs));
}
&QueryTerm::Clause(_, ref ct, _, false) => {
&QueryTerm::Clause(_, ref ct, _, CallPolicy::Counted) => {
code.push(call_clause!(ct.clone(), pvs));
}
_ => {}
@@ -748,7 +758,7 @@ impl<'b> CodeGenerator<'b> {
terms: &Vec<Term>,
code: &mut Code,
term_loc: GenContext,
use_default_call_policy: bool,
call_policy: CallPolicy,
) -> Result<(), CompilationError> {
macro_rules! compile_expr {
($self:expr, $terms:expr, $term_loc:expr, $code:expr) => ({
@@ -790,7 +800,7 @@ impl<'b> CodeGenerator<'b> {
let at = at.unwrap_or(interm!(1));
Ok(if use_default_call_policy {
Ok(if let CallPolicy::Default = call_policy {
code.push(instr!("is", default, temp_v!(1), at, 0));
} else {
code.push(instr!("is", temp_v!(1), at, 0));
@@ -852,8 +862,8 @@ impl<'b> CodeGenerator<'b> {
_,
ClauseType::BuiltIn(BuiltInClauseType::Is(..)),
ref terms,
use_default_call_policy,
) => self.compile_is_call(terms, code, term_loc, use_default_call_policy)?,
call_policy,
) => self.compile_is_call(terms, code, term_loc, call_policy)?,
&QueryTerm::Clause(_, ClauseType::Inlined(ref ct), ref terms, _) => {
self.compile_inlined(ct, terms, term_loc, code)?
}

14
src/forms.rs
View File

@@ -73,10 +73,16 @@ impl Level {
}
}
#[derive(Debug, Clone, Copy)]
pub enum CallPolicy {
Default,
Counted,
}
#[derive(Debug, Clone)]
pub enum QueryTerm {
// register, clause type, subterms, use default call policy.
Clause(Cell<RegType>, ClauseType, Vec<Term>, bool),
// register, clause type, subterms, clause call policy.
Clause(Cell<RegType>, ClauseType, Vec<Term>, CallPolicy),
BlockedCut, // a cut which is 'blocked by letters', like the P term in P -> Q.
UnblockedCut(Cell<VarReg>),
GetLevelAndUnify(Cell<VarReg>, Rc<String>),
@@ -84,9 +90,9 @@ pub enum QueryTerm {
}
impl QueryTerm {
pub(crate) fn set_default_caller(&mut self) {
pub(crate) fn set_call_policy(&mut self, cp: CallPolicy) {
match self {
&mut QueryTerm::Clause(_, _, _, ref mut use_default_cp) => *use_default_cp = true,
&mut QueryTerm::Clause(_, _, _, ref mut clause_cp) => *clause_cp = cp,
_ => {}
}
}

217
src/lib/builtins.pl
View File

@@ -318,61 +318,62 @@ dispatch_prep(Gs, B, [Cont|Conts]) :-
dispatch_call_list([]).
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),
'$call_with_default_policy'(dispatch_call_list(Gs)).
'$call_with_inference_counting'('$call'(G1)),
'$call_with_inference_counting'('$call'(G2)),
'$call_with_inference_counting'('$call'(G3)),
'$call_with_inference_counting'('$call'(G4)),
'$call_with_inference_counting'('$call'(G5)),
'$call_with_inference_counting'('$call'(G6)),
'$call_with_inference_counting'('$call'(G7)),
'$call_with_inference_counting'('$call'(G8)),
dispatch_call_list(Gs).
dispatch_call_list([G1,G2,G3,G4,G5,G6,G7]) :-
!,
'$call'(G1),
'$call'(G2),
'$call'(G3),
'$call'(G4),
'$call'(G5),
'$call'(G6),
'$call'(G7).
'$call_with_inference_counting'('$call'(G1)),
'$call_with_inference_counting'('$call'(G2)),
'$call_with_inference_counting'('$call'(G3)),
'$call_with_inference_counting'('$call'(G4)),
'$call_with_inference_counting'('$call'(G5)),
'$call_with_inference_counting'('$call'(G6)),
'$call_with_inference_counting'('$call'(G7)).
dispatch_call_list([G1,G2,G3,G4,G5,G6]) :-
!,
'$call'(G1),
'$call'(G2),
'$call'(G3),
'$call'(G4),
'$call'(G5),
'$call'(G6).
'$call_with_inference_counting'('$call'(G1)),
'$call_with_inference_counting'('$call'(G2)),
'$call_with_inference_counting'('$call'(G3)),
'$call_with_inference_counting'('$call'(G4)),
'$call_with_inference_counting'('$call'(G5)),
'$call_with_inference_counting'('$call'(G6)).
dispatch_call_list([G1,G2,G3,G4,G5]) :-
!,
'$call'(G1),
'$call'(G2),
'$call'(G3),
'$call'(G4),
'$call'(G5).
'$call_with_inference_counting'('$call'(G1)),
'$call_with_inference_counting'('$call'(G2)),
'$call_with_inference_counting'('$call'(G3)),
'$call_with_inference_counting'('$call'(G4)),
'$call_with_inference_counting'('$call'(G5)).
dispatch_call_list([G1,G2,G3,G4]) :-
!,
'$call'(G1),
'$call'(G2),
'$call'(G3),
'$call'(G4).
'$call_with_inference_counting'('$call'(G1)),
'$call_with_inference_counting'('$call'(G2)),
'$call_with_inference_counting'('$call'(G3)),
'$call_with_inference_counting'('$call'(G4)).
dispatch_call_list([G1,G2,G3]) :-
!,
'$call'(G1),
'$call'(G2),
'$call'(G3).
'$call_with_inference_counting'('$call'(G1)),
'$call_with_inference_counting'('$call'(G2)),
'$call_with_inference_counting'('$call'(G3)).
dispatch_call_list([G1,G2]) :-
!,
'$call'(G1),
'$call'(G2).
'$call_with_inference_counting'('$call'(G1)),
'$call_with_inference_counting'('$call'(G2)).
dispatch_call_list([G1]) :-
'$call'(G1).
'$call_with_inference_counting'('$call'(G1)).
% univ.
:- non_counted_backtracking univ_errors/3.
univ_errors(Term, List, N) :-
'$skip_max_list'(N, _, List, R),
( var(R) ->
@@ -404,9 +405,11 @@ univ_errors(Term, List, N) :-
; true
).
:- non_counted_backtracking (=..)/2.
Term =.. List :-
'$call_with_default_policy'(univ_errors(Term, List, N)),
'$call_with_default_policy'(univ_worker(Term, List, N)).
univ_errors(Term, List, N),
univ_worker(Term, List, N).
:- non_counted_backtracking univ_worker/3.
@@ -414,31 +417,31 @@ Term =.. List :-
univ_worker(Term, List, _) :-
atomic(Term),
!,
'$call_with_default_policy'(List = [Term]).
List = [Term].
univ_worker(Term, [Name|Args], N) :-
var(Term),
!,
'$call_with_default_policy'(Arity is N-1),
'$call_with_default_policy'(functor(Term, Name, Arity)), % Term = {var}, Name = nonvar, Arity = 0.
'$call_with_default_policy'(get_args(Args, Term, 1, Arity)).
Arity is N-1,
functor(Term, Name, Arity), % Term = {var}, Name = nonvar, Arity = 0.
get_args(Args, Term, 1, Arity).
univ_worker(Term, List, _) :-
'$call_with_default_policy'(functor(Term, Name, Arity)),
'$call_with_default_policy'(get_args(Args, Term, 1, Arity)),
'$call_with_default_policy'(List = [Name|Args]).
functor(Term, Name, Arity),
get_args(Args, Term, 1, Arity),
List = [Name|Args].
:- non_counted_backtracking get_args/4.
get_args(Args, _, _, 0) :-
!,
'$call_with_default_policy'(Args = []).
Args = [].
get_args([Arg], Func, N, N) :-
!,
'$call_with_default_policy'(arg(N, Func, Arg)).
arg(N, Func, Arg).
get_args([Arg|Args], Func, I0, N) :-
'$call_with_default_policy'(arg(I0, Func, Arg)),
'$call_with_default_policy'(I1 is I0 + 1),
'$call_with_default_policy'(get_args(Args, Func, I1, N)).
arg(I0, Func, Arg),
I1 is I0 + 1,
get_args(Args, Func, I1, N).
:- meta_predicate parse_options_list(?, 0, ?, ?, ?).
@@ -618,9 +621,11 @@ term_variables(Term, Vars) :-
:- meta_predicate catch(0, ?, 0).
:- non_counted_backtracking catch/3.
catch(G,C,R) :-
'$get_current_block'(Bb),
'$call_with_default_policy'(catch(G,C,R,Bb)).
catch(G,C,R,Bb).
:- meta_predicate catch(0, ?, 0, ?).
@@ -628,12 +633,12 @@ catch(G,C,R) :-
catch(G,C,R,Bb) :-
'$install_new_block'(NBb),
'$call'(G),
'$call_with_default_policy'(end_block(Bb, NBb)).
'$call_with_inference_counting'('$call'(G)),
end_block(Bb, NBb).
catch(G,C,R,Bb) :-
'$reset_block'(Bb),
'$get_ball'(Ball),
'$call_with_default_policy'(handle_ball(Ball, C, R)).
handle_ball(Ball, C, R).
:- non_counted_backtracking end_block/2.
@@ -654,6 +659,8 @@ handle_ball(C, C, R) :-
handle_ball(_, _, _) :-
'$unwind_stack'.
:- non_counted_backtracking throw/1.
throw(Ball) :-
( var(Ball) ->
'$set_ball'(error(instantiation_error,throw/1))
@@ -661,11 +668,10 @@ throw(Ball) :-
),
'$unwind_stack'.
:- non_counted_backtracking '$iterate_find_all'/4.
'$iterate_find_all'(Template, Goal, _, LhOffset) :-
'$call'(Goal),
'$call_with_inference_counting'('$call'(Goal)),
'$copy_to_lh'(LhOffset, Template),
'$fail'.
'$iterate_find_all'(_, _, Solutions, LhOffset) :-
@@ -678,19 +684,20 @@ truncate_lh_to(LhLength) :- '$truncate_lh_to'(LhLength).
:- meta_predicate findall(?, 0, ?).
:- non_counted_backtracking findall/3.
findall(Template, Goal, Solutions) :-
'$call_with_default_policy'(error:can_be(list, Solutions)),
error:can_be(list, Solutions),
'$lh_length'(LhLength),
'$call_with_default_policy'(
catch(builtins:'$iterate_find_all'(Template, Goal, Solutions, LhLength),
Error,
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) ))
).
catch(builtins:'$iterate_find_all'(Template, Goal, Solutions, LhLength),
Error,
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )
).
:- non_counted_backtracking '$iterate_find_all_diff'/5.
'$iterate_find_all_diff'(Template, Goal, _, _, LhOffset) :-
'$call'(Goal),
'$call_with_inference_counting'('$call'(Goal)),
'$copy_to_lh'(LhOffset, Template),
'$fail'.
'$iterate_find_all_diff'(_, _, Solutions0, Solutions1, LhOffset) :-
@@ -700,16 +707,19 @@ findall(Template, Goal, Solutions) :-
:- meta_predicate findall(?, 0, ?, ?).
:- non_counted_backtracking findall/4.
findall(Template, Goal, Solutions0, Solutions1) :-
'$call_with_default_policy'(error:can_be(list, Solutions0)),
'$call_with_default_policy'(error:can_be(list, Solutions1)),
error:can_be(list, Solutions0),
error:can_be(list, Solutions1),
'$lh_length'(LhLength),
'$call_with_default_policy'(
catch(builtins:'$iterate_find_all_diff'(Template, Goal, Solutions0,
Solutions1, LhLength),
Error,
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) ))
).
catch(builtins:'$iterate_find_all_diff'(Template, Goal, Solutions0,
Solutions1, LhLength),
Error,
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )
).
:- non_counted_backtracking set_difference/3.
set_difference([X|Xs], [Y|Ys], Zs) :-
X == Y, !, set_difference(Xs, [Y|Ys], Zs).
@@ -720,6 +730,8 @@ set_difference([X|Xs], [Y|Ys], Zs) :-
set_difference([], _, []) :- !.
set_difference(Xs, [], Xs).
:- non_counted_backtracking group_by_variant/4.
group_by_variant([V2-S2 | Pairs], V1-S1, [S2 | Solutions], Pairs0) :-
V1 = V2, % \+ \+ (V1 = V2), % (2) % iso_ext:variant(V1, V2), % (1)
!,
@@ -727,11 +739,15 @@ group_by_variant([V2-S2 | Pairs], V1-S1, [S2 | Solutions], Pairs0) :-
group_by_variant(Pairs, V2-S2, Solutions, Pairs0).
group_by_variant(Pairs, _, [], Pairs).
:- non_counted_backtracking group_by_variants/2.
group_by_variants([V-S|Pairs], [V-Solution|Solutions]) :-
group_by_variant([V-S|Pairs], V-S, Solution, Pairs0),
group_by_variants(Pairs0, Solutions).
group_by_variants([], []).
:- non_counted_backtracking iterate_variants/3.
iterate_variants([V-Solution|GroupSolutions], V, Solution) :-
( GroupSolutions == [] -> !
; true
@@ -739,6 +755,7 @@ iterate_variants([V-Solution|GroupSolutions], V, Solution) :-
iterate_variants([_|GroupSolutions], Ws, Solution) :-
iterate_variants(GroupSolutions, Ws, Solution).
:- non_counted_backtracking rightmost_power/3.
rightmost_power(Term, FinalTerm, Xs) :-
( Term = X ^ Y
@@ -752,6 +769,7 @@ rightmost_power(Term, FinalTerm, Xs) :-
; Xs = [], FinalTerm = Term
).
:- non_counted_backtracking findall_with_existential/5.
findall_with_existential(Template, Goal, PairedSolutions, Witnesses0, Witnesses) :-
( nonvar(Goal),
@@ -771,6 +789,8 @@ findall_with_existential(Template, Goal, PairedSolutions, Witnesses0, Witnesses)
:- meta_predicate bagof(?, 0, ?).
:- non_counted_backtracking bagof/3.
bagof(Template, Goal, Solution) :-
error:can_be(list, Solution),
term_variables(Template, TemplateVars0),
@@ -783,6 +803,8 @@ bagof(Template, Goal, Solution) :-
group_by_variants(PairedSolutions, GroupedSolutions),
iterate_variants(GroupedSolutions, Witnesses, Solution).
:- non_counted_backtracking iterate_variants_and_sort/3.
iterate_variants_and_sort([V-Solution0|GroupSolutions], V, Solution) :-
sort(Solution0, Solution),
( GroupSolutions == [] -> !
@@ -794,6 +816,8 @@ iterate_variants_and_sort([_|GroupSolutions], Ws, Solution) :-
:- meta_predicate setof(?, 0, ?).
:- non_counted_backtracking setof/3.
setof(Template, Goal, Solution) :-
error:can_be(list, Solution),
term_variables(Template, TemplateVars0),
@@ -808,6 +832,7 @@ setof(Template, Goal, Solution) :-
% Clause retrieval and information.
'$clause_body_is_valid'(B) :-
( var(B) -> true
; functor(B, Name, _) ->
@@ -832,7 +857,6 @@ setof(Template, Goal, Solution) :-
; throw(error(type_error(callable, H), clause/2))
).
clause(H, B) :-
( var(H) ->
throw(error(instantiation_error, clause/2))
@@ -853,11 +877,13 @@ clause(H, B) :-
; throw(error(type_error(callable, H), clause/2))
).
call_asserta(Head, Body, Name, Arity, Module) :-
'$clause_body_is_valid'(Body),
functor(_, Name, Arity),
'$asserta'(Head, Body, Name, Arity, Module).
module_asserta_clause(Head, Body, Module) :-
( var(Head) ->
throw(error(instantiation_error, asserta/1))
@@ -871,6 +897,7 @@ module_asserta_clause(Head, Body, Module) :-
; throw(error(type_error(callable, Head), asserta/1))
).
asserta_clause(Head, Body) :-
( var(Head) ->
throw(error(instantiation_error, asserta/1))
@@ -895,6 +922,7 @@ asserta_clause(Head, Body) :-
; throw(error(type_error(callable, Head), asserta/1))
).
:- meta_predicate asserta(0).
asserta(Clause0) :-
@@ -910,6 +938,7 @@ asserta(Clause0) :-
module_asserta_clause(Head, Body, Module)
).
module_assertz_clause(Head, Body, Module) :-
( var(Head) ->
throw(error(instantiation_error, assertz/1))
@@ -930,6 +959,7 @@ call_assertz(Head, Body, Name, Arity, Module) :-
functor(_, Name, Arity),
'$assertz'(Head, Body, Name, Arity, Module).
assertz_clause(Head, Body) :-
( var(Head) ->
throw(error(instantiation_error, assertz/1))
@@ -954,6 +984,7 @@ assertz_clause(Head, Body) :-
; throw(error(type_error(callable, Head), assertz/1))
).
:- meta_predicate assertz(0).
assertz(Clause0) :-
@@ -981,13 +1012,16 @@ module_retract_clauses([Clause|Clauses0], Head, Body, Name, Arity, Module) :-
; true
).
module_retract_clauses([_|Clauses0], Head, Body, Name, Arity, Module) :-
module_retract_clauses(Clauses0, Head, Body, Name, Arity, Module).
call_module_retract(Head, Body, Name, Arity, Module) :-
findall((Head :- Body), Module:'$clause'(Head, Body), Clauses),
module_retract_clauses(Clauses, Head, Body, Name, Arity, Module).
retract_module_clause(Head, Body, Module) :-
( var(Head) ->
throw(error(instantiation_error, retract/1))
@@ -1012,6 +1046,7 @@ first_match_index([_ | Clauses], Clause, N0, N) :-
N1 is N0 + 1,
first_match_index(Clauses, Clause, N1, N).
retract_clauses([Clause | Clauses0], Head, Body, Name, Arity) :-
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), builtins:'$clause'(VarHead, VarBody), Clauses1),
@@ -1022,14 +1057,15 @@ retract_clauses([Clause | Clauses0], Head, Body, Name, Arity) :-
( Clauses0 == [] -> !
; true
).
retract_clauses([_ | Clauses0], Head, Body, Name, Arity) :-
retract_clauses(Clauses0, Head, Body, Name, Arity).
call_retract(Head, Body, Name, Arity) :-
findall((Head :- Body), builtins:'$clause'(Head, Body), Clauses),
retract_clauses(Clauses, Head, Body, Name, Arity).
retract_clause(Head, Body) :-
( var(Head) ->
throw(error(instantiation_error, retract/1))
@@ -1049,6 +1085,7 @@ retract_clause(Head, Body) :-
; throw(error(type_error(callable, Head), retract/1))
).
:- meta_predicate retract(0).
retract(Clause0) :-
@@ -1137,12 +1174,14 @@ abolish(Pred) :-
; throw(error(type_error(predicate_indicator, Pred), abolish/1))
).
'$iterate_db_refs'(Name, Arity, Name/Arity). % :-
% '$lookup_db_ref'(Ref, Name, Arity).
'$iterate_db_refs'(RName, RArity, Name/Arity) :-
'$get_next_db_ref'(RName, RArity, RRName, RRArity),
'$iterate_db_refs'(RRName, RRArity, Name/Arity).
current_predicate(Pred) :-
( var(Pred) ->
'$get_next_db_ref'(RN, RA, _, _),
@@ -1159,17 +1198,21 @@ current_predicate(Pred) :-
'$iterate_db_refs'(RN, RA, Pred)
).
'$iterate_op_db_refs'(RPriority, RSpec, ROp, _, RPriority, RSpec, ROp).
'$iterate_op_db_refs'(RPriority, RSpec, ROp, OssifiedOpDir, Priority, Spec, Op) :-
'$get_next_op_db_ref'(RPriority, RSpec, ROp, OssifiedOpDir, RRPriority, RRSpec, RROp),
'$iterate_op_db_refs'(RRPriority, RRSpec, RROp, OssifiedOpDir, Priority, Spec, Op).
can_be_op_priority(Priority) :- var(Priority).
can_be_op_priority(Priority) :- op_priority(Priority).
can_be_op_specifier(Spec) :- var(Spec).
can_be_op_specifier(Spec) :- op_specifier(Spec).
current_op(Priority, Spec, Op) :-
( can_be_op_priority(Priority),
can_be_op_specifier(Spec),
@@ -1187,25 +1230,26 @@ list_of_op_atoms([Atom|Atoms]) :-
).
list_of_op_atoms([]).
op_priority(Priority) :-
integer(Priority), !,
( ( Priority < 0 ; Priority > 1200 ) ->
throw(error(domain_error(operator_priority, Priority), op/3)) % 8.14.3.3 h)
; true
).
op_priority(Priority) :-
throw(error(type_error(integer, Priority), op/3)). % 8.14.3.3 d)
op_specifier(OpSpec) :-
atom(OpSpec),
( lists:member(OpSpec, [yfx, xfy, xfx, yf, fy, xf, fx]), !
; throw(error(domain_error(operator_specifier, OpSpec), op/3)) % 8.14.3.3 i)
).
op_specifier(OpSpec) :-
throw(error(type_error(atom, OpSpec), op/3)).
valid_op(Op) :-
atom(Op),
( Op == (',') ->
@@ -1217,9 +1261,11 @@ valid_op(Op) :-
; true
).
op_(Priority, OpSpec, Op) :-
'$op'(Priority, OpSpec, Op).
op(Priority, OpSpec, Op) :-
( var(Priority) ->
throw(error(instantiation_error, op/3)) % 8.14.3.3 a)
@@ -1242,7 +1288,6 @@ op(Priority, OpSpec, Op) :-
; throw(error(type_error(list, Op), op/3)) % 8.14.3.3 f)
).
halt :- halt(0).
halt(N) :-
@@ -1255,6 +1300,7 @@ halt(N) :-
; throw(error(domain_error(exit_code, N), halt/1))
).
atom_length(Atom, Length) :-
( var(Atom) ->
throw(error(instantiation_error, atom_length/2)) % 8.16.1.3 a)
@@ -1271,6 +1317,7 @@ atom_length(Atom, Length) :-
; throw(error(type_error(atom, Atom), atom_length/2)) % 8.16.1.3 b)
).
atom_chars(Atom, List) :-
'$skip_max_list'(_, _, List, Tail),
( ( Tail == [] ; var(Tail) ) ->
@@ -1311,6 +1358,7 @@ atom_codes(Atom, List) :-
; throw(error(type_error(atom, Atom), atom_codes/2))
).
atom_concat(Atom_1, Atom_2, Atom_12) :-
error:can_be(atom, Atom_1),
error:can_be(atom, Atom_2),
@@ -1336,6 +1384,7 @@ atom_concat(Atom_1, Atom_2, Atom_12) :-
atom_chars(Atom_12, Atom_12_Chars)
).
sub_atom(Atom, Before, Length, After, Sub_atom) :-
error:must_be(atom, Atom),
error:can_be(atom, Sub_atom),
@@ -1357,6 +1406,7 @@ sub_atom(Atom, Before, Length, After, Sub_atom) :-
atom_chars(Sub_atom, LengthChars)
).
char_code(Char, Code) :-
( var(Char) ->
( var(Code) ->
@@ -1391,6 +1441,7 @@ can_be_number(N, PI) :-
; must_be_number(N, PI)
).
must_be_number(N, _) :-
( integer(N)
; float(N)
@@ -1402,6 +1453,7 @@ must_be_number(N, PI) :-
; throw(error(instantiation_error, PI))
).
chars_or_vars(Cs, _) :-
( var(Cs) ->
!
@@ -1418,6 +1470,7 @@ chars_or_vars([C|Cs], PI) :-
; chars_or_vars(Cs, PI)
).
codes_or_vars(Cs, _) :-
( var(Cs) ->
!
@@ -1435,6 +1488,7 @@ codes_or_vars([C|Cs], PI) :-
; codes_or_vars(Cs, PI)
).
number_chars(N, Chs) :-
( ground(Chs) ->
can_be_number(N, number_chars/2),
@@ -1451,10 +1505,12 @@ number_chars(N, Chs) :-
'$number_to_chars'(N, Chs)
).
list_of_ints(Ns) :-
error:must_be(list, Ns),
lists:maplist(error:must_be(integer), Ns).
number_codes(N, Chs) :-
( ground(Chs) ->
can_be_number(N, number_codes/2),
@@ -1471,6 +1527,7 @@ number_codes(N, Chs) :-
'$number_to_codes'(N, Chs)
).
subsumes_term(General, Specific) :-
\+ \+ (
term_variables(Specific, SVs1),
@@ -1479,12 +1536,15 @@ subsumes_term(General, Specific) :-
SVs1 == SVs2
).
unify_with_occurs_check(X, Y) :- '$unify_with_occurs_check'(X, Y).
current_input(S) :- '$current_input'(S).
current_output(S) :- '$current_output'(S).
set_input(S) :-
( var(S) ->
throw(error(instantiation_error, set_input/1))
@@ -1536,6 +1596,7 @@ parse_stream_options_(E, _) :-
open(SourceSink, Mode, Stream) :-
open(SourceSink, Mode, Stream, []).
open(SourceSink, Mode, Stream, StreamOptions) :-
( var(SourceSink) ->
throw(error(instantiation_error, open/4)) % 8.11.5.3a)
@@ -1564,6 +1625,7 @@ parse_close_options(Options, OptionValues, Stub) :-
DefaultOptions = [force-false],
parse_options_list(Options, builtins:parse_close_options_, DefaultOptions, OptionValues, Stub).
parse_close_options_(force(Force), force-Force) :-
( nonvar(Force), lists:member(Force, [true, false]), !
;
@@ -1581,6 +1643,7 @@ close(Stream) :-
'$close'(Stream, []).
flush_output(S) :-
'$flush_output'(S).

45
src/lib/iso_ext.pl
View File

@@ -60,28 +60,31 @@ call_cleanup(G, C) :- setup_call_cleanup(true, G, C).
:- meta_predicate(setup_call_cleanup(0, 0, 0)).
:- non_counted_backtracking setup_call_cleanup/3.
setup_call_cleanup(S, G, C) :-
'$get_b_value'(B),
'$call'(S),
'$call_with_inference_counting'('$call'(S)),
'$set_cp_by_default'(B),
'$get_current_block'(Bb),
( C = _:CC,
'$call_with_default_policy'(var(CC)) ->
var(CC) ->
instantiation_error(setup_call_cleanup/3)
; '$call_with_default_policy'(scc_helper(C, G, Bb))
; scc_helper(C, G, Bb)
).
:- meta_predicate(scc_helper(?,0,?)).
:- non_counted_backtracking scc_helper/3.
scc_helper(C, G, Bb) :-
'$get_cp'(Cp),
'$install_scc_cleaner'(C, NBb),
'$call'(G),
'$call_with_inference_counting'('$call'(G)),
( '$check_cp'(Cp) ->
'$reset_block'(Bb),
'$call_with_default_policy'(run_cleaners_without_handling(Cp))
; '$call_with_default_policy'(true)
run_cleaners_without_handling(Cp)
; true
; '$reset_block'(NBb),
'$fail'
).
@@ -89,30 +92,32 @@ scc_helper(_, _, Bb) :-
'$reset_block'(Bb),
'$get_ball'(Ball),
'$erase_ball',
'$call_with_default_policy'(run_cleaners_with_handling),
'$call_with_default_policy'(throw(Ball)).
run_cleaners_with_handling,
throw(Ball).
scc_helper(_, _, _) :-
'$get_cp'(Cp),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)),
run_cleaners_without_handling(Cp),
'$fail'.
:- non_counted_backtracking run_cleaners_with_handling/0.
run_cleaners_with_handling :-
'$get_scc_cleaner'(C),
'$get_level'(B),
'$call_with_default_policy'(catch(C, _, true)),
catch(C, _, true),
'$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_with_handling).
run_cleaners_with_handling.
run_cleaners_with_handling :-
'$restore_cut_policy'.
:- non_counted_backtracking run_cleaners_without_handling/1.
run_cleaners_without_handling(Cp) :-
'$get_scc_cleaner'(C),
'$get_level'(B),
'$call'(C),
'$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)).
run_cleaners_without_handling(Cp).
run_cleaners_without_handling(Cp) :-
'$set_cp_by_default'(Cp),
'$restore_cut_policy'.
@@ -120,6 +125,7 @@ run_cleaners_without_handling(Cp) :-
% call_with_inference_limit
:- non_counted_backtracking end_block/4.
end_block(_, Bb, NBb, _L) :-
'$clean_up_block'(NBb),
'$reset_block'(Bb).
@@ -129,13 +135,16 @@ end_block(B, _Bb, NBb, L) :-
'$fail'.
:- non_counted_backtracking handle_ile/3.
handle_ile(B, inference_limit_exceeded(B), inference_limit_exceeded) :- !.
handle_ile(B, E, _) :-
'$remove_call_policy_check'(B),
'$call_with_default_policy'(throw(E)).
throw(E).
:- meta_predicate(call_with_inference_limit(0, ?, ?)).
:- non_counted_backtracking call_with_inference_limit/3.
call_with_inference_limit(G, L, R) :-
( integer(L) ->
( L < 0 ->
@@ -148,7 +157,7 @@ call_with_inference_limit(G, L, R) :-
),
'$get_current_block'(Bb),
'$get_b_value'(B),
'$call_with_default_policy'(call_with_inference_limit(G, L, R, Bb, B)),
call_with_inference_limit(G, L, R, Bb, B),
'$remove_call_policy_check'(B).
install_inference_counter(B, L, Count0) :-
@@ -161,11 +170,11 @@ install_inference_counter(B, L, Count0) :-
call_with_inference_limit(G, L, R, Bb, B) :-
'$install_new_block'(NBb),
'$install_inference_counter'(B, L, Count0),
'$call'(G),
'$call_with_inference_counting'('$call'(G)),
'$inference_level'(R, B),
'$remove_inference_counter'(B, Count1),
'$call_with_default_policy'(is(Diff, L - (Count1 - Count0))),
'$call_with_default_policy'(end_block(B, Bb, NBb, Diff)).
is(Diff, L - (Count1 - Count0)),
end_block(B, Bb, NBb, Diff).
call_with_inference_limit(_, _, R, Bb, B) :-
'$reset_block'(Bb),
'$remove_inference_counter'(B, _),
@@ -176,7 +185,7 @@ call_with_inference_limit(_, _, R, Bb, B) :-
'$fail'
),
'$erase_ball',
'$call_with_default_policy'(handle_ile(B, Ball, R)).
handle_ile(B, Ball, R).
partial_string(String, L, L0) :-
( String == [] ->

1162
src/loader.pl
View File

File diff suppressed because it is too large Load Diff

4
src/machine/compile.rs
View File

@@ -1339,7 +1339,7 @@ impl<'a, LS: LoadState<'a>> Loader<'a, LS> {
term: Term,
settings: CodeGenSettings,
) -> Result<StandaloneCompileResult, SessionError> {
let mut preprocessor = Preprocessor::new();
let mut preprocessor = Preprocessor::new(settings);
let clause = self.try_term_to_tl(term, &mut preprocessor)?;
let queue = preprocessor.parse_queue(self)?;
@@ -1379,7 +1379,7 @@ impl<'a, LS: LoadState<'a>> Loader<'a, LS> {
let mut code_ptr = code_len;
let mut clauses = vec![];
let mut preprocessor = Preprocessor::new();
let mut preprocessor = Preprocessor::new(settings);
for term in predicates.predicates.drain(0..) {
clauses.push(self.try_term_to_tl(term, &mut preprocessor)?);

60
src/machine/dispatch.rs
View File

@@ -4692,11 +4692,11 @@ impl Machine {
step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
}
&Instruction::CallLoadContextModule(_) => {
self.load_context_module();
self.load_context_module(self.machine_st.registers[1]);
step_or_fail!(self, self.machine_st.p += 1);
}
&Instruction::ExecuteLoadContextModule(_) => {
self.load_context_module();
self.load_context_module(self.machine_st.registers[1]);
step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
}
&Instruction::CallLoadContextStream(_) => {
@@ -4859,6 +4859,62 @@ impl Machine {
self.machine_st.fail = !self.predicate_defined();
self.machine_st.p = self.machine_st.cp;
}
&Instruction::CallStripModule(_) => {
let (module_loc, qualified_goal) = self.machine_st.strip_module(
self.machine_st.registers[1],
self.machine_st.registers[2],
);
let target_module_loc = self.machine_st.registers[2];
unify_fn!(
&mut self.machine_st,
module_loc,
target_module_loc
);
let target_qualified_goal = self.machine_st.registers[3];
unify_fn!(
&mut self.machine_st,
qualified_goal,
target_qualified_goal
);
step_or_fail!(self, self.machine_st.p += 1);
}
&Instruction::ExecuteStripModule(_) => {
let (module_loc, qualified_goal) = self.machine_st.strip_module(
self.machine_st.registers[1],
self.machine_st.registers[2]
);
let target_module_loc = self.machine_st.registers[2];
unify_fn!(
&mut self.machine_st,
module_loc,
target_module_loc
);
let target_qualified_goal = self.machine_st.registers[3];
unify_fn!(
&mut self.machine_st,
qualified_goal,
target_qualified_goal
);
step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
}
&Instruction::CallPrepareCallClause(arity, _) => {
try_or_throw!(self.machine_st, self.prepare_call_clause(arity));
step_or_fail!(self, self.machine_st.p += 1);
}
&Instruction::ExecutePrepareCallClause(arity, _) => {
try_or_throw!(self.machine_st, self.prepare_call_clause(arity));
step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
}
}
}

6
src/machine/loader.rs
View File

@@ -1844,7 +1844,7 @@ impl Machine {
return;
}
_ => {
return self.load_context_module();
return self.load_context_module(self.machine_st.registers[1]);
}
}
}
@@ -1866,9 +1866,9 @@ impl Machine {
self.machine_st.fail = true;
}
pub(crate) fn load_context_module(&mut self) {
pub(crate) fn load_context_module(&mut self, target: HeapCellValue) {
if let Some(load_context) = self.load_contexts.last() {
self.machine_st.unify_atom(load_context.module, self.machine_st.registers[1]);
self.machine_st.unify_atom(load_context.module, target);
} else {
self.machine_st.fail = true;
}

55
src/machine/machine_state_impl.rs
View File

@@ -2039,12 +2039,15 @@ impl MachineState {
)
}
pub(super) fn setup_call_n(&mut self, arity: usize) -> Result<PredicateKey, MachineStub> {
let addr = self.store(self.deref(self.registers[arity]));
let (name, narity) = read_heap_cell!(addr,
pub(crate) fn setup_call_n_init_goal_info(
&mut self,
goal: HeapCellValue,
arity: usize,
) -> Result<(Atom, usize, usize), MachineStub> {
Ok(read_heap_cell!(goal,
(HeapCellValueTag::Str, s) => {
let (name, narity) = cell_as_atom_cell!(self.heap[s]).get_name_and_arity();
let (name, narity) = cell_as_atom_cell!(self.heap[s])
.get_name_and_arity();
if narity + arity > MAX_ARITY {
let stub = functor_stub(atom!("call"), arity + 1);
@@ -2052,34 +2055,48 @@ impl MachineState {
return Err(self.error_form(err, stub));
}
for i in (1..arity).rev() {
self.registers[i + narity] = self.registers[i];
}
for i in 1..narity + 1 {
self.registers[i] = self.heap[s + i];
}
(name, narity)
(name, narity, s)
}
(HeapCellValueTag::Atom, (name, arity)) => {
debug_assert_eq!(arity, 0);
(name, 0)
if name == atom!("[]") {
let stub = functor_stub(atom!("call"), arity + 1);
let err = self.type_error(ValidType::Callable, goal);
return Err(self.error_form(err, stub));
}
(name, 0, 0)
}
(HeapCellValueTag::Char, c) => {
(self.atom_tbl.build_with(&c.to_string()), 0)
(self.atom_tbl.build_with(&c.to_string()), 0, 0)
}
(HeapCellValueTag::Var | HeapCellValueTag::AttrVar | HeapCellValueTag::StackVar, _h) => {
(HeapCellValueTag::Var | HeapCellValueTag::AttrVar | HeapCellValueTag::StackVar) => {
let stub = functor_stub(atom!("call"), arity + 1);
let err = self.instantiation_error();
return Err(self.error_form(err, stub));
}
_ => {
let stub = functor_stub(atom!("call"), arity + 1);
let err = self.type_error(ValidType::Callable, addr);
let err = self.type_error(ValidType::Callable, goal);
return Err(self.error_form(err, stub));
}
);
))
}
pub(crate) fn setup_call_n(&mut self, arity: usize) -> Result<PredicateKey, MachineStub> {
let addr = self.store(self.deref(self.registers[arity]));
let (name, narity, s) = self.setup_call_n_init_goal_info(addr, arity)?;
if narity > 0 {
for i in (1..arity).rev() {
self.registers[i + narity] = self.registers[i];
}
for i in 1..narity + 1 {
self.registers[i] = self.heap[s + i];
}
}
Ok((name, arity + narity - 1))
}

34
src/machine/preprocessor.rs
View File

@@ -1,4 +1,5 @@
use crate::atom_table::*;
use crate::codegen::CodeGenSettings;
use crate::forms::*;
use crate::instructions::*;
use crate::iterators::*;
@@ -474,9 +475,10 @@ fn clause_to_query_term<'a, LS: LoadState<'a>>(
loader: &mut Loader<'a, LS>,
name: Atom,
terms: Vec<Term>,
call_policy: CallPolicy,
) -> QueryTerm {
let ct = loader.get_clause_type(name, terms.len());
QueryTerm::Clause(Cell::default(), ct, terms, false)
QueryTerm::Clause(Cell::default(), ct, terms, call_policy)
}
#[inline]
@@ -485,20 +487,23 @@ fn qualified_clause_to_query_term<'a, LS: LoadState<'a>>(
module_name: Atom,
name: Atom,
terms: Vec<Term>,
call_policy: CallPolicy,
) -> QueryTerm {
let ct = loader.get_qualified_clause_type(module_name, name, terms.len());
QueryTerm::Clause(Cell::default(), ct, terms, false)
QueryTerm::Clause(Cell::default(), ct, terms, call_policy)
}
#[derive(Debug)]
pub(crate) struct Preprocessor {
queue: VecDeque<VecDeque<Term>>,
settings: CodeGenSettings,
}
impl Preprocessor {
pub(super) fn new() -> Self {
pub(super) fn new(settings: CodeGenSettings) -> Self {
Preprocessor {
queue: VecDeque::new(),
settings,
}
}
@@ -599,7 +604,10 @@ impl Preprocessor {
if name == atom!("!") || name == atom!("blocked_!") {
Ok(QueryTerm::BlockedCut)
} else {
Ok(clause_to_query_term(loader, name, vec![]))
Ok(clause_to_query_term(
loader, name, vec![],
self.settings.default_call_policy(),
))
}
}
Term::Literal(_, Literal::Char('!')) => Ok(QueryTerm::BlockedCut),
@@ -663,6 +671,7 @@ impl Preprocessor {
module_name,
predicate_name,
vec![],
self.settings.default_call_policy(),
)),
(
Term::Literal(_, Literal::Atom(module_name)),
@@ -672,22 +681,29 @@ impl Preprocessor {
module_name,
name,
terms,
self.settings.default_call_policy()
)),
(module_name, predicate_name) => {
terms.push(module_name);
terms.push(predicate_name);
Ok(clause_to_query_term(loader, name, terms))
Ok(clause_to_query_term(
loader,
name,
terms,
self.settings.default_call_policy(),
))
}
}
}
_ => Ok(clause_to_query_term(loader, name, terms)),
_ => Ok(clause_to_query_term(loader, name, terms,
self.settings.default_call_policy())),
},
Term::Var(..) => Ok(QueryTerm::Clause(
Cell::default(),
ClauseType::CallN(1),
vec![term],
false,
self.settings.default_call_policy(),
)),
_ => Err(CompilationError::InadmissibleQueryTerm),
}
@@ -700,10 +716,10 @@ impl Preprocessor {
) -> Result<QueryTerm, CompilationError> {
match term {
Term::Clause(r, name, mut subterms) => {
if subterms.len() == 1 && name == atom!("$call_with_default_policy") {
if subterms.len() == 1 && name == atom!("$call_with_inference_counting") {
self.to_query_term(loader, subterms.pop().unwrap())
.map(|mut query_term| {
query_term.set_default_caller();
query_term.set_call_policy(CallPolicy::Counted);
query_term
})
} else {

108
src/machine/system_calls.rs
View File

@@ -887,9 +887,117 @@ impl MachineState {
Ok(string)
}
pub(crate) fn strip_module(
&self,
mut qualified_goal: HeapCellValue,
mut module_loc: HeapCellValue,
) -> (HeapCellValue, HeapCellValue) {
loop {
read_heap_cell!(qualified_goal,
(HeapCellValueTag::Str, s) => {
let (name, arity) = cell_as_atom_cell!(self.heap[s])
.get_name_and_arity();
if name == atom!(":") && arity == 2 {
module_loc = self.heap[s+1];
qualified_goal = self.heap[s+2];
} else {
break;
}
}
(HeapCellValueTag::AttrVar | HeapCellValueTag::Var, h) => {
if qualified_goal != self.heap[h] {
qualified_goal = self.heap[h];
} else {
break;
}
}
_ => {
break;
}
);
}
(module_loc, qualified_goal)
}
}
impl Machine {
#[inline(always)]
pub(crate) fn prepare_call_clause(&mut self, arity: usize) -> CallResult {
let (module_loc, qualified_goal) = self.machine_st.strip_module(
self.machine_st.registers[3],
self.machine_st.registers[2],
);
// the first three arguments don't belong to the containing call/N.
let arity = arity - 3;
let (name, narity, s) = self.machine_st.setup_call_n_init_goal_info(
qualified_goal,
arity,
)?;
let module_loc = self.machine_st.store(self.machine_st.deref(module_loc));
if module_loc.is_var() {
self.load_context_module(module_loc);
if self.machine_st.fail {
self.machine_st.fail = false;
self.machine_st.unify_atom(atom!("user"), module_loc);
if self.machine_st.fail {
return Ok(());
}
}
}
let target_module_loc = self.machine_st.registers[2];
unify_fn!(
&mut self.machine_st,
module_loc,
target_module_loc
);
if self.machine_st.fail {
return Ok(());
}
// assemble goal from pre-loaded (narity) and supplementary
// (arity) arguments.
let h = self.machine_st.heap.len();
self.machine_st.heap.push(atom_as_cell!(name, narity + arity));
let target_goal = if narity + arity > 0 {
for idx in 1 .. narity + 1 {
self.machine_st.heap.push(self.machine_st.heap[s + idx]);
}
for idx in 1 .. arity + 1 {
self.machine_st.heap.push(self.machine_st.registers[3 + idx]);
}
str_loc_as_cell!(h)
} else {
heap_loc_as_cell!(h)
};
let target_qualified_goal = self.machine_st.registers[1];
unify_fn!(
&mut self.machine_st,
target_goal,
target_qualified_goal
);
Ok(())
}
#[inline(always)]
pub(crate) fn is_reset_cont_marker(&self, p: usize) -> bool {
match &self.code[p] {