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

10
build/instructions_template.rs
View File

@@ -276,6 +276,8 @@ enum SystemClauseType {
DeleteHeadAttribute, DeleteHeadAttribute,
#[strum_discriminants(strum(props(Arity = "arity", Name = "$module_call")))] #[strum_discriminants(strum(props(Arity = "arity", Name = "$module_call")))]
DynamicModuleResolution(usize), DynamicModuleResolution(usize),
#[strum_discriminants(strum(props(Arity = "arity", Name = "$prepare_call_clause")))]
PrepareCallClause(usize),
#[strum_discriminants(strum(props(Arity = "1", Name = "$enqueue_attr_var")))] #[strum_discriminants(strum(props(Arity = "1", Name = "$enqueue_attr_var")))]
EnqueueAttributedVar, EnqueueAttributedVar,
#[strum_discriminants(strum(props(Arity = "2", Name = "$fetch_global_var")))] #[strum_discriminants(strum(props(Arity = "2", Name = "$fetch_global_var")))]
@@ -544,6 +546,8 @@ enum SystemClauseType {
HttpOpen, HttpOpen,
#[strum_discriminants(strum(props(Arity = "3", Name = "$predicate_defined")))] #[strum_discriminants(strum(props(Arity = "3", Name = "$predicate_defined")))]
PredicateDefined, PredicateDefined,
#[strum_discriminants(strum(props(Arity = "3", Name = "$strip_module")))]
StripModule,
REPL(REPLCodePtr), REPL(REPLCodePtr),
} }
@@ -1592,6 +1596,7 @@ fn generate_instruction_preface() -> TokenStream {
&Instruction::CallDeleteAttribute(_) | &Instruction::CallDeleteAttribute(_) |
&Instruction::CallDeleteHeadAttribute(_) | &Instruction::CallDeleteHeadAttribute(_) |
&Instruction::CallDynamicModuleResolution(..) | &Instruction::CallDynamicModuleResolution(..) |
&Instruction::CallPrepareCallClause(..) |
&Instruction::CallEnqueueAttributedVar(_) | &Instruction::CallEnqueueAttributedVar(_) |
&Instruction::CallFetchGlobalVar(_) | &Instruction::CallFetchGlobalVar(_) |
&Instruction::CallFirstStream(_) | &Instruction::CallFirstStream(_) |
@@ -1668,6 +1673,7 @@ fn generate_instruction_preface() -> TokenStream {
&Instruction::CallDeterministicLengthRundown(_) | &Instruction::CallDeterministicLengthRundown(_) |
&Instruction::CallHttpOpen(_) | &Instruction::CallHttpOpen(_) |
&Instruction::CallPredicateDefined(_) | &Instruction::CallPredicateDefined(_) |
&Instruction::CallStripModule(_) |
&Instruction::CallCurrentTime(_) | &Instruction::CallCurrentTime(_) |
&Instruction::CallQuotedToken(_) | &Instruction::CallQuotedToken(_) |
&Instruction::CallReadTermFromChars(_) | &Instruction::CallReadTermFromChars(_) |
@@ -1796,7 +1802,8 @@ fn generate_instruction_preface() -> TokenStream {
&Instruction::ExecuteFileTime(_) | &Instruction::ExecuteFileTime(_) |
&Instruction::ExecuteDeleteAttribute(_) | &Instruction::ExecuteDeleteAttribute(_) |
&Instruction::ExecuteDeleteHeadAttribute(_) | &Instruction::ExecuteDeleteHeadAttribute(_) |
&Instruction::ExecuteDynamicModuleResolution(_, _) | &Instruction::ExecuteDynamicModuleResolution(..) |
&Instruction::ExecutePrepareCallClause(..) |
&Instruction::ExecuteEnqueueAttributedVar(_) | &Instruction::ExecuteEnqueueAttributedVar(_) |
&Instruction::ExecuteFetchGlobalVar(_) | &Instruction::ExecuteFetchGlobalVar(_) |
&Instruction::ExecuteFirstStream(_) | &Instruction::ExecuteFirstStream(_) |
@@ -1873,6 +1880,7 @@ fn generate_instruction_preface() -> TokenStream {
&Instruction::ExecuteDeterministicLengthRundown(_) | &Instruction::ExecuteDeterministicLengthRundown(_) |
&Instruction::ExecuteHttpOpen(_) | &Instruction::ExecuteHttpOpen(_) |
&Instruction::ExecutePredicateDefined(_) | &Instruction::ExecutePredicateDefined(_) |
&Instruction::ExecuteStripModule(_) |
&Instruction::ExecuteCurrentTime(_) | &Instruction::ExecuteCurrentTime(_) |
&Instruction::ExecuteQuotedToken(_) | &Instruction::ExecuteQuotedToken(_) |
&Instruction::ExecuteReadTermFromChars(_) | &Instruction::ExecuteReadTermFromChars(_) |

22
src/codegen.rs
View File

@@ -196,6 +196,16 @@ impl CodeGenSettings {
Instruction::TrustMe(0) 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)] #[derive(Debug)]
@@ -459,10 +469,10 @@ impl<'b> CodeGenerator<'b> {
self.jmp_by_locs.push(code.len()); self.jmp_by_locs.push(code.len());
code.push(instr!("jmp_by_call", vars.len(), 0, pvs)); 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)); 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)); code.push(call_clause!(ct.clone(), pvs));
} }
_ => {} _ => {}
@@ -748,7 +758,7 @@ impl<'b> CodeGenerator<'b> {
terms: &Vec<Term>, terms: &Vec<Term>,
code: &mut Code, code: &mut Code,
term_loc: GenContext, term_loc: GenContext,
use_default_call_policy: bool, call_policy: CallPolicy,
) -> Result<(), CompilationError> { ) -> Result<(), CompilationError> {
macro_rules! compile_expr { macro_rules! compile_expr {
($self:expr, $terms:expr, $term_loc:expr, $code: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)); 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)); code.push(instr!("is", default, temp_v!(1), at, 0));
} else { } else {
code.push(instr!("is", temp_v!(1), at, 0)); code.push(instr!("is", temp_v!(1), at, 0));
@@ -852,8 +862,8 @@ impl<'b> CodeGenerator<'b> {
_, _,
ClauseType::BuiltIn(BuiltInClauseType::Is(..)), ClauseType::BuiltIn(BuiltInClauseType::Is(..)),
ref terms, ref terms,
use_default_call_policy, call_policy,
) => self.compile_is_call(terms, code, term_loc, use_default_call_policy)?, ) => self.compile_is_call(terms, code, term_loc, call_policy)?,
&QueryTerm::Clause(_, ClauseType::Inlined(ref ct), ref terms, _) => { &QueryTerm::Clause(_, ClauseType::Inlined(ref ct), ref terms, _) => {
self.compile_inlined(ct, terms, term_loc, code)? 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)] #[derive(Debug, Clone)]
pub enum QueryTerm { pub enum QueryTerm {
// register, clause type, subterms, use default call policy. // register, clause type, subterms, clause call policy.
Clause(Cell<RegType>, ClauseType, Vec<Term>, bool), Clause(Cell<RegType>, ClauseType, Vec<Term>, CallPolicy),
BlockedCut, // a cut which is 'blocked by letters', like the P term in P -> Q. BlockedCut, // a cut which is 'blocked by letters', like the P term in P -> Q.
UnblockedCut(Cell<VarReg>), UnblockedCut(Cell<VarReg>),
GetLevelAndUnify(Cell<VarReg>, Rc<String>), GetLevelAndUnify(Cell<VarReg>, Rc<String>),
@@ -84,9 +90,9 @@ pub enum QueryTerm {
} }
impl QueryTerm { impl QueryTerm {
pub(crate) fn set_default_caller(&mut self) { pub(crate) fn set_call_policy(&mut self, cp: CallPolicy) {
match self { 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([]).
dispatch_call_list([G1,G2,G3,G4,G5,G6,G7,G8|Gs]) :- dispatch_call_list([G1,G2,G3,G4,G5,G6,G7,G8|Gs]) :-
!, !,
'$call'(G1), '$call_with_inference_counting'('$call'(G1)),
'$call'(G2), '$call_with_inference_counting'('$call'(G2)),
'$call'(G3), '$call_with_inference_counting'('$call'(G3)),
'$call'(G4), '$call_with_inference_counting'('$call'(G4)),
'$call'(G5), '$call_with_inference_counting'('$call'(G5)),
'$call'(G6), '$call_with_inference_counting'('$call'(G6)),
'$call'(G7), '$call_with_inference_counting'('$call'(G7)),
'$call'(G8), '$call_with_inference_counting'('$call'(G8)),
'$call_with_default_policy'(dispatch_call_list(Gs)). dispatch_call_list(Gs).
dispatch_call_list([G1,G2,G3,G4,G5,G6,G7]) :- dispatch_call_list([G1,G2,G3,G4,G5,G6,G7]) :-
!, !,
'$call'(G1), '$call_with_inference_counting'('$call'(G1)),
'$call'(G2), '$call_with_inference_counting'('$call'(G2)),
'$call'(G3), '$call_with_inference_counting'('$call'(G3)),
'$call'(G4), '$call_with_inference_counting'('$call'(G4)),
'$call'(G5), '$call_with_inference_counting'('$call'(G5)),
'$call'(G6), '$call_with_inference_counting'('$call'(G6)),
'$call'(G7). '$call_with_inference_counting'('$call'(G7)).
dispatch_call_list([G1,G2,G3,G4,G5,G6]) :- dispatch_call_list([G1,G2,G3,G4,G5,G6]) :-
!, !,
'$call'(G1), '$call_with_inference_counting'('$call'(G1)),
'$call'(G2), '$call_with_inference_counting'('$call'(G2)),
'$call'(G3), '$call_with_inference_counting'('$call'(G3)),
'$call'(G4), '$call_with_inference_counting'('$call'(G4)),
'$call'(G5), '$call_with_inference_counting'('$call'(G5)),
'$call'(G6). '$call_with_inference_counting'('$call'(G6)).
dispatch_call_list([G1,G2,G3,G4,G5]) :- dispatch_call_list([G1,G2,G3,G4,G5]) :-
!, !,
'$call'(G1), '$call_with_inference_counting'('$call'(G1)),
'$call'(G2), '$call_with_inference_counting'('$call'(G2)),
'$call'(G3), '$call_with_inference_counting'('$call'(G3)),
'$call'(G4), '$call_with_inference_counting'('$call'(G4)),
'$call'(G5). '$call_with_inference_counting'('$call'(G5)).
dispatch_call_list([G1,G2,G3,G4]) :- dispatch_call_list([G1,G2,G3,G4]) :-
!, !,
'$call'(G1), '$call_with_inference_counting'('$call'(G1)),
'$call'(G2), '$call_with_inference_counting'('$call'(G2)),
'$call'(G3), '$call_with_inference_counting'('$call'(G3)),
'$call'(G4). '$call_with_inference_counting'('$call'(G4)).
dispatch_call_list([G1,G2,G3]) :- dispatch_call_list([G1,G2,G3]) :-
!, !,
'$call'(G1), '$call_with_inference_counting'('$call'(G1)),
'$call'(G2), '$call_with_inference_counting'('$call'(G2)),
'$call'(G3). '$call_with_inference_counting'('$call'(G3)).
dispatch_call_list([G1,G2]) :- dispatch_call_list([G1,G2]) :-
!, !,
'$call'(G1), '$call_with_inference_counting'('$call'(G1)),
'$call'(G2). '$call_with_inference_counting'('$call'(G2)).
dispatch_call_list([G1]) :- dispatch_call_list([G1]) :-
'$call'(G1). '$call_with_inference_counting'('$call'(G1)).
% univ. % univ.
:- non_counted_backtracking univ_errors/3. :- non_counted_backtracking univ_errors/3.
univ_errors(Term, List, N) :- univ_errors(Term, List, N) :-
'$skip_max_list'(N, _, List, R), '$skip_max_list'(N, _, List, R),
( var(R) -> ( var(R) ->
@@ -404,9 +405,11 @@ univ_errors(Term, List, N) :-
; true ; true
). ).
:- non_counted_backtracking (=..)/2.
Term =.. List :- Term =.. List :-
'$call_with_default_policy'(univ_errors(Term, List, N)), univ_errors(Term, List, N),
'$call_with_default_policy'(univ_worker(Term, List, N)). univ_worker(Term, List, N).
:- non_counted_backtracking univ_worker/3. :- non_counted_backtracking univ_worker/3.
@@ -414,31 +417,31 @@ Term =.. List :-
univ_worker(Term, List, _) :- univ_worker(Term, List, _) :-
atomic(Term), atomic(Term),
!, !,
'$call_with_default_policy'(List = [Term]). List = [Term].
univ_worker(Term, [Name|Args], N) :- univ_worker(Term, [Name|Args], N) :-
var(Term), var(Term),
!, !,
'$call_with_default_policy'(Arity is N-1), Arity is N-1,
'$call_with_default_policy'(functor(Term, Name, Arity)), % Term = {var}, Name = nonvar, Arity = 0. functor(Term, Name, Arity), % Term = {var}, Name = nonvar, Arity = 0.
'$call_with_default_policy'(get_args(Args, Term, 1, Arity)). get_args(Args, Term, 1, Arity).
univ_worker(Term, List, _) :- univ_worker(Term, List, _) :-
'$call_with_default_policy'(functor(Term, Name, Arity)), functor(Term, Name, Arity),
'$call_with_default_policy'(get_args(Args, Term, 1, Arity)), get_args(Args, Term, 1, Arity),
'$call_with_default_policy'(List = [Name|Args]). List = [Name|Args].
:- non_counted_backtracking get_args/4. :- non_counted_backtracking get_args/4.
get_args(Args, _, _, 0) :- get_args(Args, _, _, 0) :-
!, !,
'$call_with_default_policy'(Args = []). Args = [].
get_args([Arg], Func, N, N) :- 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) :- get_args([Arg|Args], Func, I0, N) :-
'$call_with_default_policy'(arg(I0, Func, Arg)), arg(I0, Func, Arg),
'$call_with_default_policy'(I1 is I0 + 1), I1 is I0 + 1,
'$call_with_default_policy'(get_args(Args, Func, I1, N)). get_args(Args, Func, I1, N).
:- meta_predicate parse_options_list(?, 0, ?, ?, ?). :- meta_predicate parse_options_list(?, 0, ?, ?, ?).
@@ -618,9 +621,11 @@ term_variables(Term, Vars) :-
:- meta_predicate catch(0, ?, 0). :- meta_predicate catch(0, ?, 0).
:- non_counted_backtracking catch/3.
catch(G,C,R) :- catch(G,C,R) :-
'$get_current_block'(Bb), '$get_current_block'(Bb),
'$call_with_default_policy'(catch(G,C,R,Bb)). catch(G,C,R,Bb).
:- meta_predicate catch(0, ?, 0, ?). :- meta_predicate catch(0, ?, 0, ?).
@@ -628,12 +633,12 @@ catch(G,C,R) :-
catch(G,C,R,Bb) :- catch(G,C,R,Bb) :-
'$install_new_block'(NBb), '$install_new_block'(NBb),
'$call'(G), '$call_with_inference_counting'('$call'(G)),
'$call_with_default_policy'(end_block(Bb, NBb)). end_block(Bb, NBb).
catch(G,C,R,Bb) :- catch(G,C,R,Bb) :-
'$reset_block'(Bb), '$reset_block'(Bb),
'$get_ball'(Ball), '$get_ball'(Ball),
'$call_with_default_policy'(handle_ball(Ball, C, R)). handle_ball(Ball, C, R).
:- non_counted_backtracking end_block/2. :- non_counted_backtracking end_block/2.
@@ -654,6 +659,8 @@ handle_ball(C, C, R) :-
handle_ball(_, _, _) :- handle_ball(_, _, _) :-
'$unwind_stack'. '$unwind_stack'.
:- non_counted_backtracking throw/1.
throw(Ball) :- throw(Ball) :-
( var(Ball) -> ( var(Ball) ->
'$set_ball'(error(instantiation_error,throw/1)) '$set_ball'(error(instantiation_error,throw/1))
@@ -661,11 +668,10 @@ throw(Ball) :-
), ),
'$unwind_stack'. '$unwind_stack'.
:- non_counted_backtracking '$iterate_find_all'/4. :- non_counted_backtracking '$iterate_find_all'/4.
'$iterate_find_all'(Template, Goal, _, LhOffset) :- '$iterate_find_all'(Template, Goal, _, LhOffset) :-
'$call'(Goal), '$call_with_inference_counting'('$call'(Goal)),
'$copy_to_lh'(LhOffset, Template), '$copy_to_lh'(LhOffset, Template),
'$fail'. '$fail'.
'$iterate_find_all'(_, _, Solutions, LhOffset) :- '$iterate_find_all'(_, _, Solutions, LhOffset) :-
@@ -678,19 +684,20 @@ truncate_lh_to(LhLength) :- '$truncate_lh_to'(LhLength).
:- meta_predicate findall(?, 0, ?). :- meta_predicate findall(?, 0, ?).
:- non_counted_backtracking findall/3.
findall(Template, Goal, Solutions) :- findall(Template, Goal, Solutions) :-
'$call_with_default_policy'(error:can_be(list, Solutions)), error:can_be(list, Solutions),
'$lh_length'(LhLength), '$lh_length'(LhLength),
'$call_with_default_policy'( catch(builtins:'$iterate_find_all'(Template, Goal, Solutions, LhLength),
catch(builtins:'$iterate_find_all'(Template, Goal, Solutions, LhLength), Error,
Error, ( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )) ).
).
:- non_counted_backtracking '$iterate_find_all_diff'/5. :- non_counted_backtracking '$iterate_find_all_diff'/5.
'$iterate_find_all_diff'(Template, Goal, _, _, LhOffset) :- '$iterate_find_all_diff'(Template, Goal, _, _, LhOffset) :-
'$call'(Goal), '$call_with_inference_counting'('$call'(Goal)),
'$copy_to_lh'(LhOffset, Template), '$copy_to_lh'(LhOffset, Template),
'$fail'. '$fail'.
'$iterate_find_all_diff'(_, _, Solutions0, Solutions1, LhOffset) :- '$iterate_find_all_diff'(_, _, Solutions0, Solutions1, LhOffset) :-
@@ -700,16 +707,19 @@ findall(Template, Goal, Solutions) :-
:- meta_predicate findall(?, 0, ?, ?). :- meta_predicate findall(?, 0, ?, ?).
:- non_counted_backtracking findall/4.
findall(Template, Goal, Solutions0, Solutions1) :- findall(Template, Goal, Solutions0, Solutions1) :-
'$call_with_default_policy'(error:can_be(list, Solutions0)), error:can_be(list, Solutions0),
'$call_with_default_policy'(error:can_be(list, Solutions1)), error:can_be(list, Solutions1),
'$lh_length'(LhLength), '$lh_length'(LhLength),
'$call_with_default_policy'( catch(builtins:'$iterate_find_all_diff'(Template, Goal, Solutions0,
catch(builtins:'$iterate_find_all_diff'(Template, Goal, Solutions0, Solutions1, LhLength),
Solutions1, LhLength), Error,
Error, ( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )) ).
).
:- non_counted_backtracking set_difference/3.
set_difference([X|Xs], [Y|Ys], Zs) :- set_difference([X|Xs], [Y|Ys], Zs) :-
X == Y, !, set_difference(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([], _, []) :- !.
set_difference(Xs, [], Xs). set_difference(Xs, [], Xs).
:- non_counted_backtracking group_by_variant/4.
group_by_variant([V2-S2 | Pairs], V1-S1, [S2 | Solutions], Pairs0) :- group_by_variant([V2-S2 | Pairs], V1-S1, [S2 | Solutions], Pairs0) :-
V1 = V2, % \+ \+ (V1 = V2), % (2) % iso_ext:variant(V1, V2), % (1) 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, V2-S2, Solutions, Pairs0).
group_by_variant(Pairs, _, [], Pairs). group_by_variant(Pairs, _, [], Pairs).
:- non_counted_backtracking group_by_variants/2.
group_by_variants([V-S|Pairs], [V-Solution|Solutions]) :- group_by_variants([V-S|Pairs], [V-Solution|Solutions]) :-
group_by_variant([V-S|Pairs], V-S, Solution, Pairs0), group_by_variant([V-S|Pairs], V-S, Solution, Pairs0),
group_by_variants(Pairs0, Solutions). group_by_variants(Pairs0, Solutions).
group_by_variants([], []). group_by_variants([], []).
:- non_counted_backtracking iterate_variants/3.
iterate_variants([V-Solution|GroupSolutions], V, Solution) :- iterate_variants([V-Solution|GroupSolutions], V, Solution) :-
( GroupSolutions == [] -> ! ( GroupSolutions == [] -> !
; true ; true
@@ -739,6 +755,7 @@ iterate_variants([V-Solution|GroupSolutions], V, Solution) :-
iterate_variants([_|GroupSolutions], Ws, Solution) :- iterate_variants([_|GroupSolutions], Ws, Solution) :-
iterate_variants(GroupSolutions, Ws, Solution). iterate_variants(GroupSolutions, Ws, Solution).
:- non_counted_backtracking rightmost_power/3.
rightmost_power(Term, FinalTerm, Xs) :- rightmost_power(Term, FinalTerm, Xs) :-
( Term = X ^ Y ( Term = X ^ Y
@@ -752,6 +769,7 @@ rightmost_power(Term, FinalTerm, Xs) :-
; Xs = [], FinalTerm = Term ; Xs = [], FinalTerm = Term
). ).
:- non_counted_backtracking findall_with_existential/5.
findall_with_existential(Template, Goal, PairedSolutions, Witnesses0, Witnesses) :- findall_with_existential(Template, Goal, PairedSolutions, Witnesses0, Witnesses) :-
( nonvar(Goal), ( nonvar(Goal),
@@ -771,6 +789,8 @@ findall_with_existential(Template, Goal, PairedSolutions, Witnesses0, Witnesses)
:- meta_predicate bagof(?, 0, ?). :- meta_predicate bagof(?, 0, ?).
:- non_counted_backtracking bagof/3.
bagof(Template, Goal, Solution) :- bagof(Template, Goal, Solution) :-
error:can_be(list, Solution), error:can_be(list, Solution),
term_variables(Template, TemplateVars0), term_variables(Template, TemplateVars0),
@@ -783,6 +803,8 @@ bagof(Template, Goal, Solution) :-
group_by_variants(PairedSolutions, GroupedSolutions), group_by_variants(PairedSolutions, GroupedSolutions),
iterate_variants(GroupedSolutions, Witnesses, Solution). iterate_variants(GroupedSolutions, Witnesses, Solution).
:- non_counted_backtracking iterate_variants_and_sort/3.
iterate_variants_and_sort([V-Solution0|GroupSolutions], V, Solution) :- iterate_variants_and_sort([V-Solution0|GroupSolutions], V, Solution) :-
sort(Solution0, Solution), sort(Solution0, Solution),
( GroupSolutions == [] -> ! ( GroupSolutions == [] -> !
@@ -794,6 +816,8 @@ iterate_variants_and_sort([_|GroupSolutions], Ws, Solution) :-
:- meta_predicate setof(?, 0, ?). :- meta_predicate setof(?, 0, ?).
:- non_counted_backtracking setof/3.
setof(Template, Goal, Solution) :- setof(Template, Goal, Solution) :-
error:can_be(list, Solution), error:can_be(list, Solution),
term_variables(Template, TemplateVars0), term_variables(Template, TemplateVars0),
@@ -808,6 +832,7 @@ setof(Template, Goal, Solution) :-
% Clause retrieval and information. % Clause retrieval and information.
'$clause_body_is_valid'(B) :- '$clause_body_is_valid'(B) :-
( var(B) -> true ( var(B) -> true
; functor(B, Name, _) -> ; functor(B, Name, _) ->
@@ -832,7 +857,6 @@ setof(Template, Goal, Solution) :-
; throw(error(type_error(callable, H), clause/2)) ; throw(error(type_error(callable, H), clause/2))
). ).
clause(H, B) :- clause(H, B) :-
( var(H) -> ( var(H) ->
throw(error(instantiation_error, clause/2)) throw(error(instantiation_error, clause/2))
@@ -853,11 +877,13 @@ clause(H, B) :-
; throw(error(type_error(callable, H), clause/2)) ; throw(error(type_error(callable, H), clause/2))
). ).
call_asserta(Head, Body, Name, Arity, Module) :- call_asserta(Head, Body, Name, Arity, Module) :-
'$clause_body_is_valid'(Body), '$clause_body_is_valid'(Body),
functor(_, Name, Arity), functor(_, Name, Arity),
'$asserta'(Head, Body, Name, Arity, Module). '$asserta'(Head, Body, Name, Arity, Module).
module_asserta_clause(Head, Body, Module) :- module_asserta_clause(Head, Body, Module) :-
( var(Head) -> ( var(Head) ->
throw(error(instantiation_error, asserta/1)) throw(error(instantiation_error, asserta/1))
@@ -871,6 +897,7 @@ module_asserta_clause(Head, Body, Module) :-
; throw(error(type_error(callable, Head), asserta/1)) ; throw(error(type_error(callable, Head), asserta/1))
). ).
asserta_clause(Head, Body) :- asserta_clause(Head, Body) :-
( var(Head) -> ( var(Head) ->
throw(error(instantiation_error, asserta/1)) throw(error(instantiation_error, asserta/1))
@@ -895,6 +922,7 @@ asserta_clause(Head, Body) :-
; throw(error(type_error(callable, Head), asserta/1)) ; throw(error(type_error(callable, Head), asserta/1))
). ).
:- meta_predicate asserta(0). :- meta_predicate asserta(0).
asserta(Clause0) :- asserta(Clause0) :-
@@ -910,6 +938,7 @@ asserta(Clause0) :-
module_asserta_clause(Head, Body, Module) module_asserta_clause(Head, Body, Module)
). ).
module_assertz_clause(Head, Body, Module) :- module_assertz_clause(Head, Body, Module) :-
( var(Head) -> ( var(Head) ->
throw(error(instantiation_error, assertz/1)) throw(error(instantiation_error, assertz/1))
@@ -930,6 +959,7 @@ call_assertz(Head, Body, Name, Arity, Module) :-
functor(_, Name, Arity), functor(_, Name, Arity),
'$assertz'(Head, Body, Name, Arity, Module). '$assertz'(Head, Body, Name, Arity, Module).
assertz_clause(Head, Body) :- assertz_clause(Head, Body) :-
( var(Head) -> ( var(Head) ->
throw(error(instantiation_error, assertz/1)) throw(error(instantiation_error, assertz/1))
@@ -954,6 +984,7 @@ assertz_clause(Head, Body) :-
; throw(error(type_error(callable, Head), assertz/1)) ; throw(error(type_error(callable, Head), assertz/1))
). ).
:- meta_predicate assertz(0). :- meta_predicate assertz(0).
assertz(Clause0) :- assertz(Clause0) :-
@@ -981,13 +1012,16 @@ module_retract_clauses([Clause|Clauses0], Head, Body, Name, Arity, Module) :-
; true ; true
). ).
module_retract_clauses([_|Clauses0], Head, Body, Name, Arity, Module) :- module_retract_clauses([_|Clauses0], Head, Body, Name, Arity, Module) :-
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) :- call_module_retract(Head, Body, Name, Arity, Module) :-
findall((Head :- Body), Module:'$clause'(Head, Body), Clauses), findall((Head :- Body), Module:'$clause'(Head, Body), Clauses),
module_retract_clauses(Clauses, Head, Body, Name, Arity, Module). module_retract_clauses(Clauses, Head, Body, Name, Arity, Module).
retract_module_clause(Head, Body, Module) :- retract_module_clause(Head, Body, Module) :-
( var(Head) -> ( var(Head) ->
throw(error(instantiation_error, retract/1)) throw(error(instantiation_error, retract/1))
@@ -1012,6 +1046,7 @@ first_match_index([_ | Clauses], Clause, N0, N) :-
N1 is N0 + 1, N1 is N0 + 1,
first_match_index(Clauses, Clause, N1, N). first_match_index(Clauses, Clause, N1, N).
retract_clauses([Clause | Clauses0], Head, Body, Name, Arity) :- retract_clauses([Clause | Clauses0], Head, Body, Name, Arity) :-
functor(VarHead, Name, Arity), functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), builtins:'$clause'(VarHead, VarBody), Clauses1), findall((VarHead :- VarBody), builtins:'$clause'(VarHead, VarBody), Clauses1),
@@ -1022,14 +1057,15 @@ retract_clauses([Clause | Clauses0], Head, Body, Name, Arity) :-
( Clauses0 == [] -> ! ( Clauses0 == [] -> !
; true ; true
). ).
retract_clauses([_ | Clauses0], Head, Body, Name, Arity) :- retract_clauses([_ | Clauses0], Head, Body, Name, Arity) :-
retract_clauses(Clauses0, Head, Body, Name, Arity). retract_clauses(Clauses0, Head, Body, Name, Arity).
call_retract(Head, Body, Name, Arity) :- call_retract(Head, Body, Name, Arity) :-
findall((Head :- Body), builtins:'$clause'(Head, Body), Clauses), findall((Head :- Body), builtins:'$clause'(Head, Body), Clauses),
retract_clauses(Clauses, Head, Body, Name, Arity). retract_clauses(Clauses, Head, Body, Name, Arity).
retract_clause(Head, Body) :- retract_clause(Head, Body) :-
( var(Head) -> ( var(Head) ->
throw(error(instantiation_error, retract/1)) throw(error(instantiation_error, retract/1))
@@ -1049,6 +1085,7 @@ retract_clause(Head, Body) :-
; throw(error(type_error(callable, Head), retract/1)) ; throw(error(type_error(callable, Head), retract/1))
). ).
:- meta_predicate retract(0). :- meta_predicate retract(0).
retract(Clause0) :- retract(Clause0) :-
@@ -1137,12 +1174,14 @@ abolish(Pred) :-
; throw(error(type_error(predicate_indicator, Pred), abolish/1)) ; throw(error(type_error(predicate_indicator, Pred), abolish/1))
). ).
'$iterate_db_refs'(Name, Arity, Name/Arity). % :- '$iterate_db_refs'(Name, Arity, Name/Arity). % :-
% '$lookup_db_ref'(Ref, Name, Arity). % '$lookup_db_ref'(Ref, Name, Arity).
'$iterate_db_refs'(RName, RArity, Name/Arity) :- '$iterate_db_refs'(RName, RArity, Name/Arity) :-
'$get_next_db_ref'(RName, RArity, RRName, RRArity), '$get_next_db_ref'(RName, RArity, RRName, RRArity),
'$iterate_db_refs'(RRName, RRArity, Name/Arity). '$iterate_db_refs'(RRName, RRArity, Name/Arity).
current_predicate(Pred) :- current_predicate(Pred) :-
( var(Pred) -> ( var(Pred) ->
'$get_next_db_ref'(RN, RA, _, _), '$get_next_db_ref'(RN, RA, _, _),
@@ -1159,17 +1198,21 @@ current_predicate(Pred) :-
'$iterate_db_refs'(RN, RA, Pred) '$iterate_db_refs'(RN, RA, Pred)
). ).
'$iterate_op_db_refs'(RPriority, RSpec, ROp, _, RPriority, RSpec, ROp). '$iterate_op_db_refs'(RPriority, RSpec, ROp, _, RPriority, RSpec, ROp).
'$iterate_op_db_refs'(RPriority, RSpec, ROp, OssifiedOpDir, Priority, Spec, Op) :- '$iterate_op_db_refs'(RPriority, RSpec, ROp, OssifiedOpDir, Priority, Spec, Op) :-
'$get_next_op_db_ref'(RPriority, RSpec, ROp, OssifiedOpDir, RRPriority, RRSpec, RROp), '$get_next_op_db_ref'(RPriority, RSpec, ROp, OssifiedOpDir, RRPriority, RRSpec, RROp),
'$iterate_op_db_refs'(RRPriority, RRSpec, RROp, OssifiedOpDir, Priority, Spec, Op). '$iterate_op_db_refs'(RRPriority, RRSpec, RROp, OssifiedOpDir, Priority, Spec, Op).
can_be_op_priority(Priority) :- var(Priority). can_be_op_priority(Priority) :- var(Priority).
can_be_op_priority(Priority) :- op_priority(Priority). can_be_op_priority(Priority) :- op_priority(Priority).
can_be_op_specifier(Spec) :- var(Spec). can_be_op_specifier(Spec) :- var(Spec).
can_be_op_specifier(Spec) :- op_specifier(Spec). can_be_op_specifier(Spec) :- op_specifier(Spec).
current_op(Priority, Spec, Op) :- current_op(Priority, Spec, Op) :-
( can_be_op_priority(Priority), ( can_be_op_priority(Priority),
can_be_op_specifier(Spec), can_be_op_specifier(Spec),
@@ -1187,25 +1230,26 @@ list_of_op_atoms([Atom|Atoms]) :-
). ).
list_of_op_atoms([]). list_of_op_atoms([]).
op_priority(Priority) :- op_priority(Priority) :-
integer(Priority), !, integer(Priority), !,
( ( Priority < 0 ; Priority > 1200 ) -> ( ( Priority < 0 ; Priority > 1200 ) ->
throw(error(domain_error(operator_priority, Priority), op/3)) % 8.14.3.3 h) throw(error(domain_error(operator_priority, Priority), op/3)) % 8.14.3.3 h)
; true ; true
). ).
op_priority(Priority) :- op_priority(Priority) :-
throw(error(type_error(integer, Priority), op/3)). % 8.14.3.3 d) throw(error(type_error(integer, Priority), op/3)). % 8.14.3.3 d)
op_specifier(OpSpec) :- op_specifier(OpSpec) :-
atom(OpSpec), atom(OpSpec),
( lists:member(OpSpec, [yfx, xfy, xfx, yf, fy, xf, fx]), ! ( lists:member(OpSpec, [yfx, xfy, xfx, yf, fy, xf, fx]), !
; throw(error(domain_error(operator_specifier, OpSpec), op/3)) % 8.14.3.3 i) ; throw(error(domain_error(operator_specifier, OpSpec), op/3)) % 8.14.3.3 i)
). ).
op_specifier(OpSpec) :- op_specifier(OpSpec) :-
throw(error(type_error(atom, OpSpec), op/3)). throw(error(type_error(atom, OpSpec), op/3)).
valid_op(Op) :- valid_op(Op) :-
atom(Op), atom(Op),
( Op == (',') -> ( Op == (',') ->
@@ -1217,9 +1261,11 @@ valid_op(Op) :-
; true ; true
). ).
op_(Priority, OpSpec, Op) :- op_(Priority, OpSpec, Op) :-
'$op'(Priority, OpSpec, Op). '$op'(Priority, OpSpec, Op).
op(Priority, OpSpec, Op) :- op(Priority, OpSpec, Op) :-
( var(Priority) -> ( var(Priority) ->
throw(error(instantiation_error, op/3)) % 8.14.3.3 a) 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) ; throw(error(type_error(list, Op), op/3)) % 8.14.3.3 f)
). ).
halt :- halt(0). halt :- halt(0).
halt(N) :- halt(N) :-
@@ -1255,6 +1300,7 @@ halt(N) :-
; throw(error(domain_error(exit_code, N), halt/1)) ; throw(error(domain_error(exit_code, N), halt/1))
). ).
atom_length(Atom, Length) :- atom_length(Atom, Length) :-
( var(Atom) -> ( var(Atom) ->
throw(error(instantiation_error, atom_length/2)) % 8.16.1.3 a) 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) ; throw(error(type_error(atom, Atom), atom_length/2)) % 8.16.1.3 b)
). ).
atom_chars(Atom, List) :- atom_chars(Atom, List) :-
'$skip_max_list'(_, _, List, Tail), '$skip_max_list'(_, _, List, Tail),
( ( Tail == [] ; var(Tail) ) -> ( ( Tail == [] ; var(Tail) ) ->
@@ -1311,6 +1358,7 @@ atom_codes(Atom, List) :-
; throw(error(type_error(atom, Atom), atom_codes/2)) ; throw(error(type_error(atom, Atom), atom_codes/2))
). ).
atom_concat(Atom_1, Atom_2, Atom_12) :- atom_concat(Atom_1, Atom_2, Atom_12) :-
error:can_be(atom, Atom_1), error:can_be(atom, Atom_1),
error:can_be(atom, Atom_2), 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) atom_chars(Atom_12, Atom_12_Chars)
). ).
sub_atom(Atom, Before, Length, After, Sub_atom) :- sub_atom(Atom, Before, Length, After, Sub_atom) :-
error:must_be(atom, Atom), error:must_be(atom, Atom),
error:can_be(atom, Sub_atom), error:can_be(atom, Sub_atom),
@@ -1357,6 +1406,7 @@ sub_atom(Atom, Before, Length, After, Sub_atom) :-
atom_chars(Sub_atom, LengthChars) atom_chars(Sub_atom, LengthChars)
). ).
char_code(Char, Code) :- char_code(Char, Code) :-
( var(Char) -> ( var(Char) ->
( var(Code) -> ( var(Code) ->
@@ -1391,6 +1441,7 @@ can_be_number(N, PI) :-
; must_be_number(N, PI) ; must_be_number(N, PI)
). ).
must_be_number(N, _) :- must_be_number(N, _) :-
( integer(N) ( integer(N)
; float(N) ; float(N)
@@ -1402,6 +1453,7 @@ must_be_number(N, PI) :-
; throw(error(instantiation_error, PI)) ; throw(error(instantiation_error, PI))
). ).
chars_or_vars(Cs, _) :- chars_or_vars(Cs, _) :-
( var(Cs) -> ( var(Cs) ->
! !
@@ -1418,6 +1470,7 @@ chars_or_vars([C|Cs], PI) :-
; chars_or_vars(Cs, PI) ; chars_or_vars(Cs, PI)
). ).
codes_or_vars(Cs, _) :- codes_or_vars(Cs, _) :-
( var(Cs) -> ( var(Cs) ->
! !
@@ -1435,6 +1488,7 @@ codes_or_vars([C|Cs], PI) :-
; codes_or_vars(Cs, PI) ; codes_or_vars(Cs, PI)
). ).
number_chars(N, Chs) :- number_chars(N, Chs) :-
( ground(Chs) -> ( ground(Chs) ->
can_be_number(N, number_chars/2), can_be_number(N, number_chars/2),
@@ -1451,10 +1505,12 @@ number_chars(N, Chs) :-
'$number_to_chars'(N, Chs) '$number_to_chars'(N, Chs)
). ).
list_of_ints(Ns) :- list_of_ints(Ns) :-
error:must_be(list, Ns), error:must_be(list, Ns),
lists:maplist(error:must_be(integer), Ns). lists:maplist(error:must_be(integer), Ns).
number_codes(N, Chs) :- number_codes(N, Chs) :-
( ground(Chs) -> ( ground(Chs) ->
can_be_number(N, number_codes/2), can_be_number(N, number_codes/2),
@@ -1471,6 +1527,7 @@ number_codes(N, Chs) :-
'$number_to_codes'(N, Chs) '$number_to_codes'(N, Chs)
). ).
subsumes_term(General, Specific) :- subsumes_term(General, Specific) :-
\+ \+ ( \+ \+ (
term_variables(Specific, SVs1), term_variables(Specific, SVs1),
@@ -1479,12 +1536,15 @@ subsumes_term(General, Specific) :-
SVs1 == SVs2 SVs1 == SVs2
). ).
unify_with_occurs_check(X, Y) :- '$unify_with_occurs_check'(X, Y). unify_with_occurs_check(X, Y) :- '$unify_with_occurs_check'(X, Y).
current_input(S) :- '$current_input'(S). current_input(S) :- '$current_input'(S).
current_output(S) :- '$current_output'(S). current_output(S) :- '$current_output'(S).
set_input(S) :- set_input(S) :-
( var(S) -> ( var(S) ->
throw(error(instantiation_error, set_input/1)) 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, []). open(SourceSink, Mode, Stream, []).
open(SourceSink, Mode, Stream, StreamOptions) :- open(SourceSink, Mode, Stream, StreamOptions) :-
( var(SourceSink) -> ( var(SourceSink) ->
throw(error(instantiation_error, open/4)) % 8.11.5.3a) throw(error(instantiation_error, open/4)) % 8.11.5.3a)
@@ -1564,6 +1625,7 @@ parse_close_options(Options, OptionValues, Stub) :-
DefaultOptions = [force-false], DefaultOptions = [force-false],
parse_options_list(Options, builtins:parse_close_options_, DefaultOptions, OptionValues, Stub). parse_options_list(Options, builtins:parse_close_options_, DefaultOptions, OptionValues, Stub).
parse_close_options_(force(Force), force-Force) :- parse_close_options_(force(Force), force-Force) :-
( nonvar(Force), lists:member(Force, [true, false]), ! ( nonvar(Force), lists:member(Force, [true, false]), !
; ;
@@ -1581,6 +1643,7 @@ close(Stream) :-
'$close'(Stream, []). '$close'(Stream, []).
flush_output(S) :- flush_output(S) :-
'$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)). :- meta_predicate(setup_call_cleanup(0, 0, 0)).
:- non_counted_backtracking setup_call_cleanup/3.
setup_call_cleanup(S, G, C) :- setup_call_cleanup(S, G, C) :-
'$get_b_value'(B), '$get_b_value'(B),
'$call'(S), '$call_with_inference_counting'('$call'(S)),
'$set_cp_by_default'(B), '$set_cp_by_default'(B),
'$get_current_block'(Bb), '$get_current_block'(Bb),
( C = _:CC, ( C = _:CC,
'$call_with_default_policy'(var(CC)) -> var(CC) ->
instantiation_error(setup_call_cleanup/3) 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,?)). :- meta_predicate(scc_helper(?,0,?)).
:- non_counted_backtracking scc_helper/3. :- non_counted_backtracking scc_helper/3.
scc_helper(C, G, Bb) :- scc_helper(C, G, Bb) :-
'$get_cp'(Cp), '$get_cp'(Cp),
'$install_scc_cleaner'(C, NBb), '$install_scc_cleaner'(C, NBb),
'$call'(G), '$call_with_inference_counting'('$call'(G)),
( '$check_cp'(Cp) -> ( '$check_cp'(Cp) ->
'$reset_block'(Bb), '$reset_block'(Bb),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)) run_cleaners_without_handling(Cp)
; '$call_with_default_policy'(true) ; true
; '$reset_block'(NBb), ; '$reset_block'(NBb),
'$fail' '$fail'
). ).
@@ -89,30 +92,32 @@ scc_helper(_, _, Bb) :-
'$reset_block'(Bb), '$reset_block'(Bb),
'$get_ball'(Ball), '$get_ball'(Ball),
'$erase_ball', '$erase_ball',
'$call_with_default_policy'(run_cleaners_with_handling), run_cleaners_with_handling,
'$call_with_default_policy'(throw(Ball)). throw(Ball).
scc_helper(_, _, _) :- scc_helper(_, _, _) :-
'$get_cp'(Cp), '$get_cp'(Cp),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)), run_cleaners_without_handling(Cp),
'$fail'. '$fail'.
:- non_counted_backtracking run_cleaners_with_handling/0. :- non_counted_backtracking run_cleaners_with_handling/0.
run_cleaners_with_handling :- run_cleaners_with_handling :-
'$get_scc_cleaner'(C), '$get_scc_cleaner'(C),
'$get_level'(B), '$get_level'(B),
'$call_with_default_policy'(catch(C, _, true)), catch(C, _, true),
'$set_cp_by_default'(B), '$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_with_handling). run_cleaners_with_handling.
run_cleaners_with_handling :- run_cleaners_with_handling :-
'$restore_cut_policy'. '$restore_cut_policy'.
:- non_counted_backtracking run_cleaners_without_handling/1. :- non_counted_backtracking run_cleaners_without_handling/1.
run_cleaners_without_handling(Cp) :- run_cleaners_without_handling(Cp) :-
'$get_scc_cleaner'(C), '$get_scc_cleaner'(C),
'$get_level'(B), '$get_level'(B),
'$call'(C), '$call'(C),
'$set_cp_by_default'(B), '$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)). run_cleaners_without_handling(Cp).
run_cleaners_without_handling(Cp) :- run_cleaners_without_handling(Cp) :-
'$set_cp_by_default'(Cp), '$set_cp_by_default'(Cp),
'$restore_cut_policy'. '$restore_cut_policy'.
@@ -120,6 +125,7 @@ run_cleaners_without_handling(Cp) :-
% call_with_inference_limit % call_with_inference_limit
:- non_counted_backtracking end_block/4. :- non_counted_backtracking end_block/4.
end_block(_, Bb, NBb, _L) :- end_block(_, Bb, NBb, _L) :-
'$clean_up_block'(NBb), '$clean_up_block'(NBb),
'$reset_block'(Bb). '$reset_block'(Bb).
@@ -129,13 +135,16 @@ end_block(B, _Bb, NBb, L) :-
'$fail'. '$fail'.
:- non_counted_backtracking handle_ile/3. :- non_counted_backtracking handle_ile/3.
handle_ile(B, inference_limit_exceeded(B), inference_limit_exceeded) :- !. handle_ile(B, inference_limit_exceeded(B), inference_limit_exceeded) :- !.
handle_ile(B, E, _) :- handle_ile(B, E, _) :-
'$remove_call_policy_check'(B), '$remove_call_policy_check'(B),
'$call_with_default_policy'(throw(E)). throw(E).
:- meta_predicate(call_with_inference_limit(0, ?, ?)). :- meta_predicate(call_with_inference_limit(0, ?, ?)).
:- non_counted_backtracking call_with_inference_limit/3.
call_with_inference_limit(G, L, R) :- call_with_inference_limit(G, L, R) :-
( integer(L) -> ( integer(L) ->
( L < 0 -> ( L < 0 ->
@@ -148,7 +157,7 @@ call_with_inference_limit(G, L, R) :-
), ),
'$get_current_block'(Bb), '$get_current_block'(Bb),
'$get_b_value'(B), '$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). '$remove_call_policy_check'(B).
install_inference_counter(B, L, Count0) :- 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) :- call_with_inference_limit(G, L, R, Bb, B) :-
'$install_new_block'(NBb), '$install_new_block'(NBb),
'$install_inference_counter'(B, L, Count0), '$install_inference_counter'(B, L, Count0),
'$call'(G), '$call_with_inference_counting'('$call'(G)),
'$inference_level'(R, B), '$inference_level'(R, B),
'$remove_inference_counter'(B, Count1), '$remove_inference_counter'(B, Count1),
'$call_with_default_policy'(is(Diff, L - (Count1 - Count0))), is(Diff, L - (Count1 - Count0)),
'$call_with_default_policy'(end_block(B, Bb, NBb, Diff)). end_block(B, Bb, NBb, Diff).
call_with_inference_limit(_, _, R, Bb, B) :- call_with_inference_limit(_, _, R, Bb, B) :-
'$reset_block'(Bb), '$reset_block'(Bb),
'$remove_inference_counter'(B, _), '$remove_inference_counter'(B, _),
@@ -176,7 +185,7 @@ call_with_inference_limit(_, _, R, Bb, B) :-
'$fail' '$fail'
), ),
'$erase_ball', '$erase_ball',
'$call_with_default_policy'(handle_ile(B, Ball, R)). handle_ile(B, Ball, R).
partial_string(String, L, L0) :- partial_string(String, L, L0) :-
( String == [] -> ( 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, term: Term,
settings: CodeGenSettings, settings: CodeGenSettings,
) -> Result<StandaloneCompileResult, SessionError> { ) -> 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 clause = self.try_term_to_tl(term, &mut preprocessor)?;
let queue = preprocessor.parse_queue(self)?; 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 code_ptr = code_len;
let mut clauses = vec![]; let mut clauses = vec![];
let mut preprocessor = Preprocessor::new(); let mut preprocessor = Preprocessor::new(settings);
for term in predicates.predicates.drain(0..) { for term in predicates.predicates.drain(0..) {
clauses.push(self.try_term_to_tl(term, &mut preprocessor)?); 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); step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
} }
&Instruction::CallLoadContextModule(_) => { &Instruction::CallLoadContextModule(_) => {
self.load_context_module(); self.load_context_module(self.machine_st.registers[1]);
step_or_fail!(self, self.machine_st.p += 1); step_or_fail!(self, self.machine_st.p += 1);
} }
&Instruction::ExecuteLoadContextModule(_) => { &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); step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
} }
&Instruction::CallLoadContextStream(_) => { &Instruction::CallLoadContextStream(_) => {
@@ -4859,6 +4859,62 @@ impl Machine {
self.machine_st.fail = !self.predicate_defined(); self.machine_st.fail = !self.predicate_defined();
self.machine_st.p = self.machine_st.cp; 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;
} }
_ => { _ => {
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; 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() { 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 { } else {
self.machine_st.fail = true; 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> { pub(crate) fn setup_call_n_init_goal_info(
let addr = self.store(self.deref(self.registers[arity])); &mut self,
goal: HeapCellValue,
let (name, narity) = read_heap_cell!(addr, arity: usize,
) -> Result<(Atom, usize, usize), MachineStub> {
Ok(read_heap_cell!(goal,
(HeapCellValueTag::Str, s) => { (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 { if narity + arity > MAX_ARITY {
let stub = functor_stub(atom!("call"), arity + 1); let stub = functor_stub(atom!("call"), arity + 1);
@@ -2052,34 +2055,48 @@ impl MachineState {
return Err(self.error_form(err, stub)); return Err(self.error_form(err, stub));
} }
for i in (1..arity).rev() { (name, narity, s)
self.registers[i + narity] = self.registers[i];
}
for i in 1..narity + 1 {
self.registers[i] = self.heap[s + i];
}
(name, narity)
} }
(HeapCellValueTag::Atom, (name, arity)) => { (HeapCellValueTag::Atom, (name, arity)) => {
debug_assert_eq!(arity, 0); 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) => { (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 stub = functor_stub(atom!("call"), arity + 1);
let err = self.instantiation_error(); let err = self.instantiation_error();
return Err(self.error_form(err, stub)); return Err(self.error_form(err, stub));
} }
_ => { _ => {
let stub = functor_stub(atom!("call"), arity + 1); 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)); 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)) Ok((name, arity + narity - 1))
} }

34
src/machine/preprocessor.rs
View File

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

108
src/machine/system_calls.rs
View File

@@ -887,9 +887,117 @@ impl MachineState {
Ok(string) 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 { 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)] #[inline(always)]
pub(crate) fn is_reset_cont_marker(&self, p: usize) -> bool { pub(crate) fn is_reset_cont_marker(&self, p: usize) -> bool {
match &self.code[p] { match &self.code[p] {