Skip if_/3 inlining if Then_0 is unsafe or invalid

As a part of optimization goal expansion in library(reif) inlines Then_0
argument verbatim into predicate body – this avoids unnecessary call/N
invocations and dramatically increases performance, but not all goals are safe
to be inlined in such a way. Here we are skipping this optimization if !s or
invalid goal were detected to prevent undesired side-effects from leaking into
outer goals.

Author: hurufu

src/lib/reif.pl

@@ -24,6 +24,7 @@
 */
 
 :- use_module(library(dif)).
+:- use_module(library(loader), [goal_sanitized/2]).
 
 :- meta_predicate(if_(1, 0, 0)).
 :- meta_predicate(cond_t(1, 0, ?)).
@@ -91,19 +92,16 @@
 sameargs(0, _, _).
 
 
-/*
-  no !s that cut outside.
-  no variables in place of goals
-  no malformed goals like integers
-*/
 
 
 /* 2do: unqualified If_1: error
 */
 
 %
 user:goal_expansion(if_(If_1, Then_0, Else_0), G_0) :-
-   ugoal_expansion(if_(If_1, Then_0, Else_0), G_0).
+   goal_sanitized(Then_0, SanitizedThen_0),
+   goal_sanitized(Else_0, SanitizedElse_0),
+   ugoal_expansion(if_(If_1, SanitizedThen_0, SanitizedElse_0), G_0).
 
 %
 %

src/loader.pl

@@ -8,7 +8,8 @@
                    strip_module/3,
                    use_module/1,
                    use_module/2,
-                   current_module/1
+                   current_module/1,
+                   goal_sanitized/2
                   ]).
 
 :- use_module(library(error)).
@@ -42,6 +43,67 @@
     nl,
     '$fail'.
 
+
+never(_) :- fail.
+
+
+%% goal_sanitized(?G_0, ?S_0).
+%
+% Both `G_0` and `S_0` are valid callable terms having the same meaning, but
+% additionally `S_0` is safe to be called in combination with surrounding
+% goals, without worrying that cut side-effect will escape and contaminate
+% outer goals. `S_0 = call(G_0)` when it contains callable !s that cut outside,
+% and `S_0 = G_0` otherwise.
+%
+% For example: given `G_0 = (a,!)` then compound goal `b,a,!` will remove
+% choice points generated by `b`, but since `S_0 = call((a,!))` then
+% `b, call((a,!))` is safe.
+%
+% TODO: Should it be marked with meta_predicate(goal_sanitized(:,-))?
+%
+goal_sanitized(G, S) :-
+    catch(goal_sanitized_aux(G, S), stop(_), false).
+
+goal_sanitized_aux(G, call(G)) :-    cuts_outside(G).
+goal_sanitized_aux(G,      G ) :- \+ cuts_outside(G).
+
+
+%% cuts_outside(?G_0).
+%
+% `G_0` is a goal for which side-effects of a cut may spill out to the
+% surrounding goals. Throws `stop(_)` when it doesn't represent a valid goal.
+%
+% For example it succeeds for terms `a, (!, b)` and `a, b -> !` where cut
+% removes choice points generated by `a`, but fails for `a, (! -> b)` and
+% `a, \+ \+ !`.
+%
+cuts_outside(G_0) :- cuts_outside(G_0, =(!)).
+
+%% cuts_outside(?G_0, +StopCondition_1).
+%
+cuts_outside(G, C_1) :- callable_term(G), cuts_outside_aux(G, C_1).
+
+cuts_outside_aux(G, C_1) :- call(C_1, G).
+cuts_outside_aux(M:A, C_1) :- module_name(M), cuts_outside(A, C_1).
+cuts_outside_aux((A,B), C_1)  :- cuts_outside(B, C_1); cuts_outside(A, C_1).
+cuts_outside_aux((A;B), C_1)  :- cuts_outside(B, C_1); cuts_outside(A, C_1).
+% FIXME: There is an issue with `C, (! -> B)` construct, see #2739
+cuts_outside_aux((A->B), C_1) :- cuts_outside(A, loader:never); cuts_outside(B, C_1).
+
+
+module_name(M) :-
+    atom(M) -> true; throw(stop(type_error(atom,M))).
+
+
+callable_term(T) :-
+    callable(T) ->
+    (   acyclic_term(T) ->
+            true
+        ;   throw(stop(type_error(acyclic_term,T)))
+    )
+    ;   throw(stop(type_error(callable,T))).
+
+
 expand_term(Term, ExpandedTerm) :-
     (  '$predicate_defined'(user, term_expansion, 2),
        catch(user:term_expansion(Term, ExpandedTerm0),

src/tests/reif.pl

@@ -110,6 +110,39 @@
     Solutions == [if_(1=1,a=a,2), error(type_error(callable,2),call/1)]
 )).
 
+test(W, loader:call(T)) :-
+    member(T, [
+        cuts_outside(!),
+        cuts_outside(foo:!),
+        cuts_outside((a,!)),
+        cuts_outside((!;b(_))),
+        cuts_outside(((a;b(_,_);c),!,d)),
+        \+ cuts_outside(call((a,!))),
+        \+ cuts_outside(((a;b;c),\+ !,d)),
+        \+ cuts_outside((! -> a; b)),
+        \+ cuts_outside(((x,!;y) -> a; b)),
+        catch((cuts_outside(_),false),   E0, E0  = stop(type_error(callable,_))),
+        catch((cuts_outside(2),false),   E1, E1 == stop(type_error(callable,2))),
+        catch((cuts_outside(1:!),false), E2, E2 == stop(type_error(atom,1))),
+        catch((cuts_outside(_:!),false), E3, E3  = stop(type_error(atom,_))),
+        (G0 = a(G0), catch((cuts_outside(G0),false), E4, E4 = stop(type_error(acyclic_term,_)))),
+        (G1 = m:G1,  catch((cuts_outside(G1),false), E5, E5 = stop(type_error(acyclic_term,_)))),
+        catch((cuts_outside((6->a)),false),   E6, E6 == stop(type_error(callable,6))),
+        (goal_sanitized(a, X0), X0 == a),
+        (goal_sanitized(!, X1), X1 == call(!)),
+        (goal_sanitized((a,b;c,d), X2), X2 == (a,b;c,d)),
+        (goal_sanitized((\+ \+ a), X3), X3 == (\+ \+ a)),
+        % Questionable test case, see #2739
+        (goal_sanitized((!,a->c;d), X4), X4 == (!,a->c;d)),
+        (goal_sanitized((x,a->!;d), X5), X5 == call((x,a->!;d))),
+        (goal_sanitized((a,b,c,!), X6), X6 == call((a,b,c,!))),
+        \+ goal_sanitized(0, _),
+        \+ goal_sanitized(_, _),
+        \+ goal_sanitized((a,_), _),
+        \+ goal_sanitized((a,b;1), _)
+    ]),
+    phrase(format_("callable cut: ~q", [T]), W).
+
 result_or_exception(Goal, Result) :-
     catch((Goal,Result=Goal), Result, true).