mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-15 09:23:44 +00:00
Code Issues Projects Releases Wiki Activity
Files
d067ea1255ec9a5adda35908f080a99f68dc8867
mercury/compiler/inst_test.m
Zoltan Somogyi 593212d807 Minor improvements to comments and code. 
compiler/inst_lookup.m:
    Fix minor bugs in comments.

    Do not use state variables where they do not help.

compiler/inst_merge.m:
    Special-case merges between two bound insts.

    Expand a comment.

compiler/inst_test.m:
    Delete a test that cannot ever succeed, and simplify the resulting code.

    Fix comment rot.
2025-12-11 10:21:37 +11:00

1588 lines
56 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1995-1998, 2000-2012 The University of Melbourne.
% Copyright (C) 2015, 2018-2025 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: inst_test.m.
% Author: fjh.
%
% Predicates to test various properties of insts.
%
% NOTE: `not_reached' insts are considered to satisfy all of these predicates
% except inst_is_clobbered.
%
%-----------------------------------------------------------------------------%
:- module hlds.inst_test.
:- interface.
:- import_module hlds.hlds_module.
:- import_module hlds.instmap.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module list.
%-----------------------------------------------------------------------------%
% Succeed if the inst is fully ground (i.e. contains only `ground',
% `bound', and `not_reached' insts, with no `free' or `any' insts).
% This predicate succeeds for non-default function insts so some care
% needs to be taken since these insts may not be replaced by a less
% precise inst that uses the higher-order mode information.
%
:- pred inst_is_ground(module_info::in, mer_type::in, mer_inst::in) is semidet.
% Succeed if the inst is not partly free (i.e. contains only `any',
% `ground', `bound', and `not_reached' insts, with no `free' insts).
% This predicate succeeds for non-default function insts so some care
% needs to be taken since these insts may not be replaced by a less
% precise inst that uses the higher-order mode information.
%
:- pred inst_is_ground_or_any(module_info::in, mer_inst::in) is semidet.
% Succeed if the inst is `unique'.
%
% XXX The documentation on the code used to say: "inst_is_unique succeeds
% iff the inst passed is unique or free. Abstract insts are not considered
% unique.". The part about free is dubious.
%
:- pred inst_is_unique(module_info::in, mer_inst::in) is semidet.
% Succeed if the inst is `mostly_unique' or `unique'.
%
% XXX The documentation on the code used to say: " inst_is_mostly_unique
% succeeds iff the inst passed is unique, mostly_unique, or free.
% Abstract insts are not considered unique.". The part about free is
% dubious.
%
:- pred inst_is_mostly_unique(module_info::in, mer_inst::in) is semidet.
% Succeed if the inst contains no `mostly_unique' or `unique' components,
% i.e. if all of it is one of shared or free.
%
:- pred inst_is_not_partly_unique(module_info::in, mer_inst::in) is semidet.
% Succeed if the inst contains no `unique' components,
% i.e. if all of it is one of mostly_unique, shared or free.
%
:- pred inst_is_not_fully_unique(module_info::in, mer_inst::in) is semidet.
% inst_is_clobbered succeeds iff the inst passed is `clobbered'
% or `mostly_clobbered' or if it is a user-defined inst which
% is defined as one of those.
%
:- pred inst_is_clobbered(module_info::in, mer_inst::in) is semidet.
% inst_is_free succeeds iff the inst passed is `free'
% or is a user-defined inst which is defined as `free'.
% Abstract insts must not be free.
%
:- pred inst_is_free(module_info::in, mer_inst::in) is semidet.
:- pred inst_is_any(module_info::in, mer_inst::in) is semidet.
% inst_is_bound succeeds iff the inst passed is not `free'
% or is a user-defined inst which is not defined as `free'.
% Abstract insts must be bound.
%
:- pred inst_is_bound(module_info::in, mer_inst::in) is semidet.
:- pred inst_is_bound_to_functors(module_info::in, mer_inst::in,
list(bound_functor)::out) is semidet.
%-----------------------------------------------------------------------------%
:- pred inst_results_bound_functor_list_is_ground(module_info::in,
mer_type::in, inst_test_results::in, list(bound_functor)::in) is semidet.
:- pred inst_results_bound_functor_list_is_ground_mt(module_info::in,
mer_type::in, inst_test_results::in, list(bound_functor)::in) is semidet.
:- pred inst_results_bound_functor_list_is_ground_or_any(module_info::in,
inst_test_results::in, list(bound_functor)::in) is semidet.
:- pred bound_functor_list_is_unique(module_info::in, list(bound_functor)::in)
is semidet.
:- pred bound_functor_list_is_mostly_unique(module_info::in,
list(bound_functor)::in) is semidet.
:- pred bound_functor_list_is_not_partly_unique(module_info::in,
list(bound_functor)::in) is semidet.
:- pred bound_functor_list_is_not_fully_unique(module_info::in,
list(bound_functor)::in) is semidet.
:- pred bound_functor_list_is_free(module_info::in, list(bound_functor)::in)
is semidet.
%-----------------------------------------------------------------------------%
:- pred inst_list_is_ground(module_info::in,
list(mer_type)::in, list(mer_inst)::in) is semidet.
:- pred inst_list_is_ground_or_any(module_info::in, list(mer_inst)::in)
is semidet.
:- pred inst_list_is_unique(module_info::in, list(mer_inst)::in) is semidet.
:- pred inst_list_is_mostly_unique(module_info::in, list(mer_inst)::in)
is semidet.
:- pred inst_list_is_not_partly_unique(module_info::in, list(mer_inst)::in)
is semidet.
:- pred inst_list_is_not_fully_unique(module_info::in, list(mer_inst)::in)
is semidet.
:- pred inst_list_is_free(module_info::in, list(mer_inst)::in) is semidet.
% Given a list of insts, and a corresponding list of types and livenesses,
% succeed iff for every element in the list of insts, either the element
% is ground or the corresponding element in the liveness list is dead.
%
:- pred inst_list_is_ground_or_dead(module_info::in,
list(is_live)::in, list(mer_type)::in, list(mer_inst)::in) is semidet.
% Given a list of insts, and a corresponding list of livenesses, succeed
% iff for every element in the list of insts, either the element
% is ground or any, or the corresponding element in the liveness list is
% dead.
%
:- pred inst_list_is_ground_or_any_or_dead(module_info::in,
list(is_live)::in, list(mer_inst)::in) is semidet.
%-----------------------------------------------------------------------------%
% Succeed iff the specified inst contains (directly or indirectly) the
% specified inst_name.
%
:- pred inst_contains_inst_name(module_info::in, inst_name::in, mer_inst::in)
is semidet.
%-----------------------------------------------------------------------------%
% For a non-solver type t (i.e. any type declared without using the
% `solver' keyword), the inst `any' should be considered to be equivalent
% to a bound inst i where i contains all the functors of the type t and
% each argument has inst `any'.
%
% Note that pred and func types are considered solver types, since
% higher-order terms that contain non-local solver variables are
% themselves not ground -- they only become ground when all non-locals do.
% However, functions with the default inst can still be treated as ground,
% since they are det and therefore cannot bind any non-local solver
% variables that may be present.
%
:- pred maybe_any_to_bound(module_info::in, mer_type::in,
uniqueness::in, ho_inst_info::in, mer_inst::out) is semidet.
%---------------------------------------------------------------------------%
% Succeed iff the inst is any or contains any.
%
:- pred inst_contains_any(module_info::in, mer_inst::in) is semidet.
% Succeed iff the given var's inst is any or contains any.
%
:- pred var_inst_contains_any(module_info::in, instmap::in, prog_var::in)
is semidet.
%---------------------------------------------------------------------------%
% Return true if the given inst may restrict the set of function symbols
% that may be successfully unified with the variable that has this inst.
%
:- func inst_may_restrict_cons_ids(module_info, mer_inst) = bool.
%---------------------------------------------------------------------------%
:- pred inst_contains_higher_order(module_info::in, mer_inst::in) is semidet.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module hlds.inst_lookup.
:- import_module hlds.inst_util.
:- import_module hlds.mode_util.
:- import_module hlds.passes_aux.
:- import_module hlds.type_util.
:- import_module parse_tree.prog_type.
:- import_module io.
:- import_module require.
:- import_module set.
:- import_module set_tree234.
%-----------------------------------------------------------------------------%
inst_is_ground(ModuleInfo, Type, Inst) :-
promise_pure (
semipure lookup_inst_is_ground(Type, Inst, Found, OldIsGround),
(
Found = yes,
trace [compiletime(flag("inst-is-ground-perf")), io(!IO)] (
get_debug_output_stream(ModuleInfo, DebugStream, !IO),
io.write_string(DebugStream, "inst_is_ground hit\n", !IO)
),
% Succeed if OldIsGround = yes, fail if OldIsGround = no.
OldIsGround = yes
;
Found = no,
trace [compiletime(flag("inst-is-ground-perf")), io(!IO)] (
get_debug_output_stream(ModuleInfo, DebugStream, !IO),
io.write_string(DebugStream, "inst_is_ground miss\n", !IO)
),
( if inst_is_ground_mt(ModuleInfo, Type, Inst) then
impure record_inst_is_ground(Type, Inst, yes)
% Succeed.
else
impure record_inst_is_ground(Type, Inst, no),
fail
)
)
).
%-----------------------------------------------------------------------------%
%
% The expansion of terms by the superhomogeneous transformation generates code
% that looks like this:
%
% V1 = [],
% V2 = e1,
% V3 = [V2 | V1],
% V4 = e2,
% V5 = [V3 | V4]
%
% The insts on those unifications will contain insts from earlier unifications.
% For example, the inst on the unification building V5 will give V5 an inst
% that contains the insts of V3 and V4.
%
% If there are N elements in a list, testing the insts of the N variables
% representing the N cons cells in the list would ordinarily take O(N^2) steps.
% Since N could be very large, this is disastrous.
%
% We avoid quadratic performance by caching the results of recent calls
% to inst_is_ground for insts that are susceptible to this problem.
% This way, the test on the inst of e.g. V5 will find the results of the tests
% on the insts of V3 and V4 already available. This reduces the overall
% complexity of testing the insts of those N variables to O(n).
%
% The downsides of this cache include the costs of the lookups, and
% the fact that it keeps the cached insts alive.
%
% Note that we do not need to record the ModuleInfo argument of inst_is_ground,
% since it is needed only to interpret insts that need access to the mode
% tables. If we get a result for an inst with one ModuleInfo, we should get
% the exact same result with any later ModuleInfo. The conservative nature
% of the Boehm collector means that an inst address recorded in the cache
% will always point to the original inst; the address cannot be reused until
% the cache entry is itself reused.
:- pragma foreign_decl("C",
"
typedef struct {
MR_Word iig_type_addr;
MR_Word iig_inst_addr;
MR_Word iig_is_ground;
} InstIsGroundCacheEntry;
#define INST_IS_GROUND_CACHE_SIZE 1307
// Every entry should be implicitly initialized to zeros. Since zero is
// not a valid address for an inst, uninitialized entries cannot be mistaken
// for filled-in entries.
static InstIsGroundCacheEntry inst_is_ground_cache[INST_IS_GROUND_CACHE_SIZE];
").
% Look up Inst in the cache. If it is there, return Found = yes
% and set IsGround. Otherwise, return Found = no.
%
:- semipure pred lookup_inst_is_ground(mer_type::in, mer_inst::in,
bool::out, bool::out) is det.
:- pragma foreign_proc("C",
lookup_inst_is_ground(Type::in, Inst::in, Found::out, IsGround::out),
[will_not_call_mercury, promise_semipure],
"
MR_Unsigned hash;
hash = (MR_Unsigned) Type << 5u | (MR_Unsigned) Inst;
hash = hash >> MR_LOW_TAG_BITS;
hash = hash % INST_IS_GROUND_CACHE_SIZE;
if (
inst_is_ground_cache[hash].iig_type_addr == Type &&
inst_is_ground_cache[hash].iig_inst_addr == Inst)
{
Found = MR_BOOL_YES;
IsGround = inst_is_ground_cache[hash].iig_is_ground;
} else {
Found = MR_BOOL_NO;
IsGround = MR_NO;
}
").
lookup_inst_is_ground(_, _, no, no) :-
semipure semipure_true.
% Record the result for Inst in the cache.
%
:- impure pred record_inst_is_ground(mer_type::in, mer_inst::in, bool::in)
is det.
:- pragma foreign_proc("C",
record_inst_is_ground(Type::in, Inst::in, IsGround::in),
[will_not_call_mercury],
"
MR_Unsigned hash;
hash = (MR_Unsigned) Type << 5u | (MR_Unsigned) Inst;
hash = hash >> MR_LOW_TAG_BITS;
hash = hash % INST_IS_GROUND_CACHE_SIZE;
// We overwrite any existing entry in the slot.
inst_is_ground_cache[hash].iig_type_addr = Type;
inst_is_ground_cache[hash].iig_inst_addr = Inst;
inst_is_ground_cache[hash].iig_is_ground = IsGround;
").
record_inst_is_ground(_, _, _) :-
impure impure_true.
%-----------------------------------------------------------------------------%
:- pred inst_is_ground_mt(module_info::in, mer_type::in, mer_inst::in)
is semidet.
inst_is_ground_mt(ModuleInfo, Type, Inst) :-
Expansions0 = set_tree234.init,
inst_is_ground_mt_1(ModuleInfo, Type, Inst, Expansions0, _Expansions).
% The fourth arg is the set of insts which have already been expanded;
% we use this to avoid going into an infinite loop.
%
:- pred inst_is_ground_mt_1(module_info::in, mer_type::in, mer_inst::in,
set_tree234(mer_inst)::in, set_tree234(mer_inst)::out) is semidet.
inst_is_ground_mt_1(ModuleInfo, Type, Inst, !Expansions) :-
( if Inst = any(_, _) then
% This special casing of any/2 was introduced in commit
% 1412a135cb57af6f9ecab2bc5c8128bad8d30d2e, whose log message says:
%
% "Fix a bug where under certain situations inst_is_ground_1/5
% would erroneously add any(_) to the set of insts it would treat
% as ground."
fail
else
% XXX Make this work on Inst's *address*.
( if set_tree234.insert_new(Inst, !Expansions) then
% Inst was not yet in Expansions, but we have now inserted it.
inst_is_ground_mt_2(ModuleInfo, Type, Inst, !Expansions)
else
% Inst was already in !.Expansions.
true
)
).
:- pred inst_is_ground_mt_2(module_info::in, mer_type::in, mer_inst::in,
set_tree234(mer_inst)::in, set_tree234(mer_inst)::out) is semidet.
inst_is_ground_mt_2(ModuleInfo, Type, Inst, !Expansions) :-
require_complete_switch [Inst]
(
( Inst = free
; Inst = any(_, _)
),
fail
;
( Inst = not_reached
; Inst = ground(_, _)
)
;
Inst = bound(_, InstResults, BoundFunctors),
inst_results_bound_functor_list_is_ground_mt_2(ModuleInfo, Type,
InstResults, BoundFunctors, !Expansions)
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_ground_mt_1(ModuleInfo, Type, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_ground_mt_1(ModuleInfo, Type, NextInst, !Expansions)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
).
%-----------------------------------------------------------------------------%
inst_is_ground_or_any(ModuleInfo, Inst) :-
set.init(Expansions0),
inst_is_ground_or_any_2(ModuleInfo, Inst, Expansions0, _Expansions).
% The third arg is the set of insts which have already been expanded;
% we use this to avoid going into an infinite loop.
%
:- pred inst_is_ground_or_any_2(module_info::in, mer_inst::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_is_ground_or_any_2(ModuleInfo, Inst, !Expansions) :-
require_complete_switch [Inst]
(
( Inst = ground(_, _)
; Inst = any(_, _)
; Inst = not_reached
)
;
Inst = bound(_, InstResults, BoundFunctors),
inst_results_bound_functor_list_is_ground_or_any_2(ModuleInfo,
InstResults, BoundFunctors, !Expansions)
;
Inst = free,
fail
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_ground_or_any_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
( if set.insert_new(Inst, !Expansions) then
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_ground_or_any_2(ModuleInfo, NextInst, !Expansions)
else
true
)
).
%-----------------------------------------------------------------------------%
inst_is_unique(ModuleInfo, Inst) :-
set.init(Expansions0),
inst_is_unique_2(ModuleInfo, Inst, Expansions0, _Expansions).
% The third arg is the set of insts which have already been expanded;
% we use this to avoid going into an infinite loop.
%
:- pred inst_is_unique_2(module_info::in, mer_inst::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_is_unique_2(ModuleInfo, Inst, !Expansions) :-
(
( Inst = ground(unique, _)
; Inst = any(unique, _)
; Inst = not_reached
; Inst = free % XXX I don't think this is right [zs].
)
;
( Inst = ground(shared, _)
; Inst = bound(shared, _, _)
; Inst = any(shared, _)
),
fail
;
Inst = bound(unique, InstResults, BoundFunctors),
(
InstResults = inst_test_results_fgtc,
fail
;
( InstResults = inst_test_no_results
; InstResults = inst_test_results(_, _, _, _, _, _)
),
bound_functor_list_is_unique_2(ModuleInfo, BoundFunctors,
!Expansions)
)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
( if set.insert_new(Inst, !Expansions) then
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_unique_2(ModuleInfo, NextInst, !Expansions)
else
true
)
).
%-----------------------------------------------------------------------------%
inst_is_mostly_unique(ModuleInfo, Inst) :-
set.init(Expansions0),
inst_is_mostly_unique_2(ModuleInfo, Inst, Expansions0, _Expansions).
% The third arg is the set of insts which have already been expanded;
% we use this to avoid going into an infinite loop.
%
:- pred inst_is_mostly_unique_2(module_info::in, mer_inst::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_is_mostly_unique_2(ModuleInfo, Inst, !Expansions) :-
require_complete_switch [Inst]
(
( Inst = not_reached
; Inst = free
; Inst = ground(unique, _)
; Inst = ground(mostly_unique, _)
; Inst = any(unique, _)
; Inst = any(mostly_unique, _)
)
;
Inst = bound(unique, InstResults, BoundFunctors),
(
InstResults = inst_test_results_fgtc,
fail
;
( InstResults = inst_test_no_results
; InstResults = inst_test_results(_, _, _, _, _, _)
),
bound_functor_list_is_mostly_unique_2(ModuleInfo, BoundFunctors,
!Expansions)
)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_mostly_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
( if set.insert_new(Inst, !Expansions) then
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_mostly_unique_2(ModuleInfo, NextInst, !Expansions)
else
true
)
).
%-----------------------------------------------------------------------------%
inst_is_not_partly_unique(ModuleInfo, Inst) :-
set.init(Expansions0),
inst_is_not_partly_unique_2(ModuleInfo, Inst, Expansions0, _Expansions).
% The third arg is the set of insts which have already been expanded;
% we use this to avoid going into an infinite loop.
%
:- pred inst_is_not_partly_unique_2(module_info::in, mer_inst::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_is_not_partly_unique_2(ModuleInfo, Inst, !Expansions) :-
require_complete_switch [Inst]
(
( Inst = not_reached
; Inst = free
; Inst = any(shared, _)
; Inst = ground(shared, _)
)
;
Inst = bound(shared, InstResult, BoundFunctors),
(
InstResult = inst_test_results_fgtc
;
( InstResult = inst_test_no_results
; InstResult = inst_test_results(_, _, _, _, _, _)
),
bound_functor_list_is_not_partly_unique_2(ModuleInfo,
BoundFunctors, !Expansions)
)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_not_partly_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
( if set.insert_new(Inst, !Expansions) then
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_not_partly_unique_2(ModuleInfo, NextInst, !Expansions)
else
true
)
).
%-----------------------------------------------------------------------------%
inst_is_not_fully_unique(ModuleInfo, Inst) :-
set.init(Expansions0),
inst_is_not_fully_unique_2(ModuleInfo, Inst, Expansions0, _Expansions).
% The third arg is the set of insts which have already been expanded - we
% use this to avoid going into an infinite loop.
%
:- pred inst_is_not_fully_unique_2(module_info::in, mer_inst::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_is_not_fully_unique_2(ModuleInfo, Inst, !Expansions) :-
require_complete_switch [Inst]
(
( Inst = not_reached
; Inst = free
; Inst = ground(shared, _)
; Inst = ground(mostly_unique, _)
; Inst = any(shared, _)
; Inst = any(mostly_unique, _)
)
;
Inst = bound(Uniq, InstResult, BoundFunctors),
( Uniq = shared
; Uniq = mostly_unique
),
(
InstResult = inst_test_results_fgtc
;
( InstResult = inst_test_no_results
; InstResult = inst_test_results(_, _, _, _, _, _)
),
bound_functor_list_is_not_fully_unique_2(ModuleInfo, BoundFunctors,
!Expansions)
)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_not_fully_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
( if set.insert_new(Inst, !Expansions) then
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_not_fully_unique_2(ModuleInfo, NextInst, !Expansions)
else
true
)
).
%-----------------------------------------------------------------------------%
inst_is_clobbered(ModuleInfo, Inst) :-
require_complete_switch [Inst]
(
( Inst = free
; Inst = not_reached
),
fail
;
( Inst = any(mostly_clobbered, _)
; Inst = any(clobbered, _)
; Inst = ground(clobbered, _)
; Inst = ground(mostly_clobbered, _)
; Inst = bound(clobbered, _, _)
; Inst = bound(mostly_clobbered, _, _)
)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_clobbered(ModuleInfo, SubInst)
;
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_clobbered(ModuleInfo, NextInst)
).
inst_is_free(ModuleInfo, Inst) :-
require_complete_switch [Inst]
(
Inst = free
;
( Inst = ground(_, _)
; Inst = bound(_, _, _)
; Inst = any(_, _)
; Inst = not_reached
),
fail
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_free(ModuleInfo, SubInst)
;
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_free(ModuleInfo, NextInst)
).
inst_is_any(ModuleInfo, Inst) :-
require_complete_switch [Inst]
(
Inst = any(_, _)
;
( Inst = free
; Inst = ground(_, _)
; Inst = bound(_, _, _)
; Inst = not_reached
),
fail
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_any(ModuleInfo, SubInst)
;
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_any(ModuleInfo, NextInst)
).
inst_is_bound(ModuleInfo, Inst) :-
require_complete_switch [Inst]
(
( Inst = ground(_, _)
; Inst = bound(_, _, _)
; Inst = any(_, _)
; Inst = not_reached
)
;
Inst = free,
fail
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_bound(ModuleInfo, SubInst)
;
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_bound(ModuleInfo, NextInst)
).
inst_is_bound_to_functors(ModuleInfo, Inst, Functors) :-
% inst_is_bound_to_functors succeeds iff the inst passed is
% `bound(_Uniq, Functors)' or is a user-defined inst which expands to
% `bound(_Uniq, Functors)'.
%
require_complete_switch [Inst]
(
Inst = bound(_Uniq, _InstResult, Functors)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = constrained_inst_vars(_, SubInst),
inst_is_bound_to_functors(ModuleInfo, SubInst, Functors)
;
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_bound_to_functors(ModuleInfo, NextInst, Functors)
;
( Inst = free
; Inst = any(_, _)
; Inst = ground(_, _)
; Inst = not_reached
),
fail
).
%-----------------------------------------------------------------------------%
inst_results_bound_functor_list_is_ground(ModuleInfo, Type, InstResults,
BoundFunctors) :-
require_complete_switch [InstResults]
(
InstResults = inst_test_results_fgtc
;
InstResults = inst_test_results(GroundnessResult, _, _, _, _, _),
require_complete_switch [GroundnessResult]
(
GroundnessResult = inst_result_is_ground
;
GroundnessResult = inst_result_is_not_ground,
fail
;
GroundnessResult = inst_result_groundness_unknown,
bound_functor_list_is_ground_mt(ModuleInfo, Type, BoundFunctors)
)
;
InstResults = inst_test_no_results,
bound_functor_list_is_ground_mt(ModuleInfo, Type, BoundFunctors)
).
inst_results_bound_functor_list_is_ground_mt(ModuleInfo, Type, InstResults,
BoundFunctors) :-
require_complete_switch [InstResults]
(
InstResults = inst_test_results_fgtc
;
InstResults = inst_test_results(GroundnessResult, _, _, _, _, _),
require_complete_switch [GroundnessResult]
(
GroundnessResult = inst_result_is_ground
;
GroundnessResult = inst_result_is_not_ground,
fail
;
GroundnessResult = inst_result_groundness_unknown,
bound_functor_list_is_ground_mt(ModuleInfo, Type, BoundFunctors)
)
;
InstResults = inst_test_no_results,
bound_functor_list_is_ground_mt(ModuleInfo, Type, BoundFunctors)
).
:- pred inst_results_bound_functor_list_is_ground_mt_2(module_info::in,
mer_type::in, inst_test_results::in, list(bound_functor)::in,
set_tree234(mer_inst)::in, set_tree234(mer_inst)::out) is semidet.
inst_results_bound_functor_list_is_ground_mt_2(ModuleInfo, Type, InstResults,
BoundFunctors, !Expansions) :-
require_complete_switch [InstResults]
(
InstResults = inst_test_results_fgtc
;
InstResults = inst_test_results(GroundnessResult, _, _, _, _, _),
require_complete_switch [GroundnessResult]
(
GroundnessResult = inst_result_is_ground
;
GroundnessResult = inst_result_is_not_ground,
fail
;
GroundnessResult = inst_result_groundness_unknown,
bound_functor_list_is_ground_mt_2(ModuleInfo, Type, BoundFunctors,
!Expansions)
)
;
InstResults = inst_test_no_results,
bound_functor_list_is_ground_mt_2(ModuleInfo, Type, BoundFunctors,
!Expansions)
).
%-----------------------------------------------------------------------------%
inst_results_bound_functor_list_is_ground_or_any(ModuleInfo, InstResults,
BoundFunctors) :-
require_complete_switch [InstResults]
(
InstResults = inst_test_results_fgtc
;
InstResults = inst_test_results(GroundnessResult, _, _, _, _, _),
require_complete_switch [GroundnessResult]
(
GroundnessResult = inst_result_is_ground
;
( GroundnessResult = inst_result_is_not_ground
; GroundnessResult = inst_result_groundness_unknown
),
bound_functor_list_is_ground_or_any(ModuleInfo, BoundFunctors)
)
;
InstResults = inst_test_no_results,
bound_functor_list_is_ground_or_any(ModuleInfo, BoundFunctors)
).
:- pred inst_results_bound_functor_list_is_ground_or_any_2(module_info::in,
inst_test_results::in, list(bound_functor)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_results_bound_functor_list_is_ground_or_any_2(ModuleInfo, InstResults,
BoundFunctors, !Expansions) :-
require_complete_switch [InstResults]
(
InstResults = inst_test_results_fgtc
;
InstResults = inst_test_results(GroundnessResult, _, _, _, _, _),
require_complete_switch [GroundnessResult]
(
GroundnessResult = inst_result_is_ground
;
GroundnessResult = inst_result_is_not_ground,
fail
;
GroundnessResult = inst_result_groundness_unknown,
bound_functor_list_is_ground_or_any_2(ModuleInfo, BoundFunctors,
!Expansions)
)
;
InstResults = inst_test_no_results,
bound_functor_list_is_ground_or_any_2(ModuleInfo, BoundFunctors,
!Expansions)
).
%-----------------------------------------------------------------------------%
:- pred bound_functor_list_is_ground_mt(module_info::in, mer_type::in,
list(bound_functor)::in) is semidet.
bound_functor_list_is_ground_mt(_, _, []).
bound_functor_list_is_ground_mt(ModuleInfo, Type,
[BoundFunctor | BoundFunctors]) :-
get_cons_id_arg_types_for_bound_functor(ModuleInfo, Type, BoundFunctor,
ArgTypes),
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_ground_mt(ModuleInfo, ArgTypes, ArgInsts),
bound_functor_list_is_ground_mt(ModuleInfo, Type, BoundFunctors).
:- pred bound_functor_list_is_ground_mt_2(module_info::in, mer_type::in,
list(bound_functor)::in,
set_tree234(mer_inst)::in, set_tree234(mer_inst)::out) is semidet.
bound_functor_list_is_ground_mt_2(_, _, [], !Expansions).
bound_functor_list_is_ground_mt_2(ModuleInfo, Type,
[BoundFunctor | BoundFunctors], !Expansions) :-
get_cons_id_arg_types_for_bound_functor(ModuleInfo, Type, BoundFunctor,
ArgTypes),
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_ground_mt_2(ModuleInfo, ArgTypes, ArgInsts, !Expansions),
bound_functor_list_is_ground_mt_2(ModuleInfo, Type, BoundFunctors,
!Expansions).
:- pred bound_functor_list_is_ground_or_any(module_info::in,
list(bound_functor)::in) is semidet.
bound_functor_list_is_ground_or_any(_, []).
bound_functor_list_is_ground_or_any(ModuleInfo,
[BoundFunctor | BoundFunctors]) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_ground_or_any(ModuleInfo, ArgInsts),
bound_functor_list_is_ground_or_any(ModuleInfo, BoundFunctors).
:- pred bound_functor_list_is_ground_or_any_2(module_info::in,
list(bound_functor)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_functor_list_is_ground_or_any_2(_, [], !Expansions).
bound_functor_list_is_ground_or_any_2(ModuleInfo,
[BoundFunctor | BoundFunctors], !Expansions) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_ground_or_any_2(ModuleInfo, ArgInsts, !Expansions),
bound_functor_list_is_ground_or_any_2(ModuleInfo, BoundFunctors,
!Expansions).
bound_functor_list_is_unique(_, []).
bound_functor_list_is_unique(ModuleInfo, [BoundFunctor | BoundFunctors]) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_unique(ModuleInfo, ArgInsts),
bound_functor_list_is_unique(ModuleInfo, BoundFunctors).
:- pred bound_functor_list_is_unique_2(module_info::in,
list(bound_functor)::in, set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_functor_list_is_unique_2(_, [], !Expansions).
bound_functor_list_is_unique_2(ModuleInfo, [BoundFunctor | BoundFunctors],
!Expansions) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_unique_2(ModuleInfo, ArgInsts, !Expansions),
bound_functor_list_is_unique_2(ModuleInfo, BoundFunctors, !Expansions).
bound_functor_list_is_mostly_unique(_, []).
bound_functor_list_is_mostly_unique(ModuleInfo,
[BoundFunctor | BoundFunctors]) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_mostly_unique(ModuleInfo, ArgInsts),
bound_functor_list_is_mostly_unique(ModuleInfo, BoundFunctors).
:- pred bound_functor_list_is_mostly_unique_2(module_info::in,
list(bound_functor)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_functor_list_is_mostly_unique_2(_, [], !Expansions).
bound_functor_list_is_mostly_unique_2(ModuleInfo,
[BoundFunctor | BoundFunctors], !Expansions) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_mostly_unique_2(ModuleInfo, ArgInsts, !Expansions),
bound_functor_list_is_mostly_unique_2(ModuleInfo,
BoundFunctors, !Expansions).
bound_functor_list_is_not_partly_unique(_, []).
bound_functor_list_is_not_partly_unique(ModuleInfo,
[BoundFunctor | BoundFunctors]) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_not_partly_unique(ModuleInfo, ArgInsts),
bound_functor_list_is_not_partly_unique(ModuleInfo, BoundFunctors).
:- pred bound_functor_list_is_not_partly_unique_2(module_info::in,
list(bound_functor)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_functor_list_is_not_partly_unique_2(_, [], !Expansions).
bound_functor_list_is_not_partly_unique_2(ModuleInfo,
[BoundFunctor | BoundFunctors], !Expansions) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_not_partly_unique_2(ModuleInfo, ArgInsts, !Expansions),
bound_functor_list_is_not_partly_unique_2(ModuleInfo, BoundFunctors,
!Expansions).
bound_functor_list_is_not_fully_unique(_, []).
bound_functor_list_is_not_fully_unique(ModuleInfo,
[BoundFunctor | BoundFunctors]) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_not_fully_unique(ModuleInfo, ArgInsts),
bound_functor_list_is_not_fully_unique(ModuleInfo, BoundFunctors).
:- pred bound_functor_list_is_not_fully_unique_2(module_info::in,
list(bound_functor)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_functor_list_is_not_fully_unique_2(_, [], !Expansions).
bound_functor_list_is_not_fully_unique_2(ModuleInfo,
[BoundFunctor | BoundFunctors], !Expansions) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_not_fully_unique_2(ModuleInfo, ArgInsts, !Expansions),
bound_functor_list_is_not_fully_unique_2(ModuleInfo, BoundFunctors,
!Expansions).
bound_functor_list_is_free(_, []).
bound_functor_list_is_free(ModuleInfo, [BoundFunctor | BoundFunctors]) :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
inst_list_is_free(ModuleInfo, ArgInsts),
bound_functor_list_is_free(ModuleInfo, BoundFunctors).
%-----------------------------------------------------------------------------%
inst_list_is_ground(_, [], []).
inst_list_is_ground(_, [], [_ | _]) :-
unexpected($pred, "length mismatch").
inst_list_is_ground(_, [_ | _], []) :-
unexpected($pred, "length mismatch").
inst_list_is_ground(ModuleInfo, [Type | Types], [Inst | Insts]) :-
inst_is_ground(ModuleInfo, Type, Inst),
inst_list_is_ground(ModuleInfo, Types, Insts).
:- pred inst_list_is_ground_mt(module_info::in, list(mer_type)::in,
list(mer_inst)::in) is semidet.
inst_list_is_ground_mt(_, [], []).
inst_list_is_ground_mt(_, [], [_ | _]) :-
unexpected($pred, "length mismatch").
inst_list_is_ground_mt(_, [_ | _], []) :-
unexpected($pred, "length mismatch").
inst_list_is_ground_mt(ModuleInfo, [Type | Types], [Inst | Insts]) :-
inst_is_ground_mt(ModuleInfo, Type, Inst),
inst_list_is_ground_mt(ModuleInfo, Types, Insts).
:- pred inst_list_is_ground_mt_2(module_info::in,
list(mer_type)::in, list(mer_inst)::in,
set_tree234(mer_inst)::in, set_tree234(mer_inst)::out) is semidet.
inst_list_is_ground_mt_2(_, [], [], !Expansions).
inst_list_is_ground_mt_2(_, [], [_ | _], !Expansions) :-
unexpected($pred, "length mismatch").
inst_list_is_ground_mt_2(_, [_ | _], [], !Expansions) :-
unexpected($pred, "length mismatch").
inst_list_is_ground_mt_2(ModuleInfo, [Type | Types], [Inst | Insts],
!Expansions) :-
inst_is_ground_mt_1(ModuleInfo, Type, Inst, !Expansions),
inst_list_is_ground_mt_2(ModuleInfo, Types, Insts, !Expansions).
inst_list_is_ground_or_any(_, []).
inst_list_is_ground_or_any(ModuleInfo, [Inst | Insts]) :-
inst_is_ground_or_any(ModuleInfo, Inst),
inst_list_is_ground_or_any(ModuleInfo, Insts).
:- pred inst_list_is_ground_or_any_2(module_info::in, list(mer_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_list_is_ground_or_any_2(_, [], !Expansions).
inst_list_is_ground_or_any_2(ModuleInfo, [Inst | Insts], !Expansions) :-
inst_is_ground_or_any_2(ModuleInfo, Inst, !Expansions),
inst_list_is_ground_or_any_2(ModuleInfo, Insts, !Expansions).
inst_list_is_unique(_, []).
inst_list_is_unique(ModuleInfo, [Inst | Insts]) :-
inst_is_unique(ModuleInfo, Inst),
inst_list_is_unique(ModuleInfo, Insts).
:- pred inst_list_is_unique_2(module_info::in, list(mer_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_list_is_unique_2(_, [], !Expansions).
inst_list_is_unique_2(ModuleInfo, [Inst | Insts], !Expansions) :-
inst_is_unique_2(ModuleInfo, Inst, !Expansions),
inst_list_is_unique_2(ModuleInfo, Insts, !Expansions).
inst_list_is_mostly_unique(_, []).
inst_list_is_mostly_unique(ModuleInfo, [Inst | Insts]) :-
inst_is_mostly_unique(ModuleInfo, Inst),
inst_list_is_mostly_unique(ModuleInfo, Insts).
:- pred inst_list_is_mostly_unique_2(module_info::in, list(mer_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_list_is_mostly_unique_2(_, [], !Expansions).
inst_list_is_mostly_unique_2(ModuleInfo, [Inst | Insts], !Expansions) :-
inst_is_mostly_unique_2(ModuleInfo, Inst, !Expansions),
inst_list_is_mostly_unique_2(ModuleInfo, Insts, !Expansions).
inst_list_is_not_partly_unique(_, []).
inst_list_is_not_partly_unique(ModuleInfo, [Inst | Insts]) :-
inst_is_not_partly_unique(ModuleInfo, Inst),
inst_list_is_not_partly_unique(ModuleInfo, Insts).
:- pred inst_list_is_not_partly_unique_2(module_info::in, list(mer_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_list_is_not_partly_unique_2(_, [], !Expansions).
inst_list_is_not_partly_unique_2(ModuleInfo, [Inst | Insts], !Expansions) :-
inst_is_not_partly_unique_2(ModuleInfo, Inst, !Expansions),
inst_list_is_not_partly_unique_2(ModuleInfo, Insts, !Expansions).
inst_list_is_not_fully_unique(_, []).
inst_list_is_not_fully_unique(ModuleInfo, [Inst | Insts]) :-
inst_is_not_fully_unique(ModuleInfo, Inst),
inst_list_is_not_fully_unique(ModuleInfo, Insts).
:- pred inst_list_is_not_fully_unique_2(module_info::in, list(mer_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_list_is_not_fully_unique_2(_, [], !Expansions).
inst_list_is_not_fully_unique_2(ModuleInfo, [Inst | Insts], !Expansions) :-
inst_is_not_fully_unique_2(ModuleInfo, Inst, !Expansions),
inst_list_is_not_fully_unique_2(ModuleInfo, Insts, !Expansions).
inst_list_is_free(_, []).
inst_list_is_free(ModuleInfo, [Inst | Insts]) :-
inst_is_free(ModuleInfo, Inst),
inst_list_is_free(ModuleInfo, Insts).
inst_list_is_ground_or_dead(_, [], [], []).
inst_list_is_ground_or_dead(ModuleInfo, Lives, Types, Insts) :-
( if
Lives = [HeadLive | TailLives],
Types = [HeadType | TailTypes],
Insts = [HeadInst | TailInsts]
then
(
HeadLive = is_live,
inst_is_ground(ModuleInfo, HeadType, HeadInst)
;
HeadLive = is_dead
),
inst_list_is_ground_or_dead(ModuleInfo,
TailLives, TailTypes, TailInsts)
else if
Lives = [],
Types = [],
Insts = []
then
true
else
unexpected($pred, "length mismatch")
).
inst_list_is_ground_or_any_or_dead(_, [], []).
inst_list_is_ground_or_any_or_dead(_, [], [_ | _]) :-
unexpected($pred, "length mismatch").
inst_list_is_ground_or_any_or_dead(_, [_ | _], []) :-
unexpected($pred, "length mismatch").
inst_list_is_ground_or_any_or_dead(ModuleInfo,
[Live | Lives], [Inst | Insts]) :-
(
Live = is_live,
inst_is_ground_or_any(ModuleInfo, Inst)
;
Live = is_dead
),
inst_list_is_ground_or_any_or_dead(ModuleInfo, Lives, Insts).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
inst_contains_inst_name(ModuleInfo, InstName, Inst) :-
set.init(Expansions0),
inst_contains_inst_name_2(ModuleInfo, InstName, Inst, yes,
Expansions0, _Expansions).
:- type inst_names == set(inst_name).
:- pred inst_contains_inst_name_2(module_info::in, inst_name::in, mer_inst::in,
bool::out, inst_names::in, inst_names::out) is det.
inst_contains_inst_name_2(ModuleInfo, InstName, Inst, Contains, !Expansions) :-
(
( Inst = any(_, _)
; Inst = free
; Inst = ground(_, _)
; Inst = inst_var(_)
; Inst = not_reached
),
Contains = no
;
Inst = constrained_inst_vars(_, SubInst),
inst_contains_inst_name_2(ModuleInfo, InstName, SubInst, Contains,
!Expansions)
;
Inst = defined_inst(ThisInstName),
( if InstName = ThisInstName then
Contains = yes
else
( if set.insert_new(ThisInstName, !Expansions) then
inst_lookup(ModuleInfo, ThisInstName, ThisInst),
set.insert(ThisInstName, !Expansions),
inst_contains_inst_name_2(ModuleInfo, InstName, ThisInst,
Contains, !Expansions)
else
Contains = no
)
)
;
Inst = bound(_Uniq, InstResults, ArgInsts),
% XXX This code has a performance problem.
%
% The problem is that e.g. in a list of length N, you will have N
% variables for the skeletons whose insts contain an average of N/2
% occurences of `bound' each, so the complexity of running
% inst_contains_inst_name_2 on all their insts is quadratic in N.
%
% The inst_test result argument of bound/3 is an attempt at solving
% this problem.
%
% We could also try to solve this performance problem with a cache
% of the results of recent invocations of inst_contains_inst_name.
(
InstResults = inst_test_results_fgtc,
Contains = no
;
InstResults = inst_test_results(_, _, InstNamesResult, _, _, _),
(
InstNamesResult =
inst_result_contains_inst_names_known(InstNameSet),
( if set.contains(InstNameSet, InstName) then
% The Inst may contain InstName, and probably does,
% but verify it.
bound_functor_list_contains_inst_name(ModuleInfo, InstName,
ArgInsts, Contains, !Expansions)
else
Contains = no
)
;
InstNamesResult = inst_result_contains_inst_names_unknown,
bound_functor_list_contains_inst_name(ModuleInfo, InstName,
ArgInsts, Contains, !Expansions)
)
;
InstResults = inst_test_no_results,
bound_functor_list_contains_inst_name(ModuleInfo, InstName,
ArgInsts, Contains, !Expansions)
)
).
:- pred bound_functor_list_contains_inst_name(module_info::in,
inst_name::in, list(bound_functor)::in, bool::out,
inst_names::in, inst_names::out) is det.
bound_functor_list_contains_inst_name(_ModuleInfo, _InstName, [],
no, !Expansions).
bound_functor_list_contains_inst_name(ModuleInfo, InstName,
[BoundFunctor | BoundFunctors], Contains, !Expansions) :-
BoundFunctor = bound_functor(_Functor, ArgInsts),
inst_list_contains_inst_name(ModuleInfo, InstName, ArgInsts, Contains1,
!Expansions),
(
Contains1 = yes,
Contains = yes
;
Contains1 = no,
bound_functor_list_contains_inst_name(ModuleInfo, InstName,
BoundFunctors,
Contains, !Expansions)
).
:- pred inst_list_contains_inst_name(module_info::in, inst_name::in,
list(mer_inst)::in, bool::out, inst_names::in, inst_names::out) is det.
inst_list_contains_inst_name(_ModuleInfo, _InstName, [], no, !Expansions).
inst_list_contains_inst_name(ModuleInfo, InstName, [Inst | Insts], Contains,
!Expansions) :-
inst_contains_inst_name_2(ModuleInfo, InstName, Inst, Contains1,
!Expansions),
(
Contains1 = yes,
Contains = yes
;
Contains1 = no,
inst_list_contains_inst_name(ModuleInfo, InstName, Insts, Contains,
!Expansions)
).
%-----------------------------------------------------------------------------%
maybe_any_to_bound(ModuleInfo, Type, Uniq, none_or_default_func, Inst) :-
not type_is_solver_type(ModuleInfo, Type),
( if type_constructors(ModuleInfo, Type, Constructors) then
type_to_ctor_det(Type, TypeCtor),
constructors_to_bound_any_insts(ModuleInfo, Uniq, TypeCtor,
Constructors, BoundFunctors0),
list.sort_and_remove_dups(BoundFunctors0, BoundFunctors),
% If all the constructors are constant, then Inst will be ground
% and will not contain any.
InstResult = inst_test_results(
inst_result_groundness_unknown,
inst_result_contains_any_unknown,
inst_result_contains_inst_names_known(set.init),
inst_result_contains_inst_vars_known(set.init),
inst_result_contains_types_known(set.init),
inst_result_type_ctor_propagated(TypeCtor)
),
Inst = bound(Uniq, InstResult, BoundFunctors)
else if type_may_contain_solver_type(ModuleInfo, Type) then
% For a type for which constructors are not available (e.g. an
% abstract type) and which may contain solver types, we fail, meaning
% that we will use `any' for this type.
fail
else
Inst = ground(Uniq, none_or_default_func)
).
:- pred type_may_contain_solver_type(module_info::in, mer_type::in) is semidet.
type_may_contain_solver_type(ModuleInfo, Type) :-
TypeCtorCat = classify_type(ModuleInfo, Type),
type_may_contain_solver_type_2(TypeCtorCat) = yes.
:- func type_may_contain_solver_type_2(type_ctor_category) = bool.
type_may_contain_solver_type_2(CtorCat) = MayContainSolverType :-
(
( CtorCat = ctor_cat_builtin(_)
; CtorCat = ctor_cat_enum(_)
; CtorCat = ctor_cat_higher_order
; CtorCat = ctor_cat_builtin_dummy
; CtorCat = ctor_cat_void
; CtorCat = ctor_cat_system(_)
; CtorCat = ctor_cat_user(cat_user_direct_dummy)
; CtorCat = ctor_cat_user(cat_user_abstract_dummy)
),
MayContainSolverType = no
;
( CtorCat = ctor_cat_variable
; CtorCat = ctor_cat_tuple
; CtorCat = ctor_cat_user(cat_user_notag)
; CtorCat = ctor_cat_user(cat_user_abstract_notag)
; CtorCat = ctor_cat_user(cat_user_general)
),
MayContainSolverType = yes
).
%-----------------------------------------------------------------------------%
inst_contains_any(ModuleInfo, Inst) :-
set.init(Expansions),
inst_contains_any_2(ModuleInfo, Inst, Expansions) = yes.
:- func inst_contains_any_2(module_info, mer_inst, set(inst_name)) = bool.
inst_contains_any_2(ModuleInfo, Inst, !.Expansions) = ContainsAny :-
(
Inst = any(_, _),
ContainsAny = yes
;
Inst = bound(_, InstResults, BoundFunctors),
(
InstResults = inst_test_results_fgtc,
ContainsAny = no
;
InstResults = inst_test_results(_, AnyResults, _, _, _, _),
(
AnyResults = inst_result_does_not_contain_any,
ContainsAny = no
;
AnyResults = inst_result_does_contain_any,
ContainsAny = yes
;
AnyResults = inst_result_contains_any_unknown,
ContainsAny = bound_functor_list_contains_any(ModuleInfo,
BoundFunctors, !.Expansions)
)
;
InstResults = inst_test_no_results,
ContainsAny = bound_functor_list_contains_any(ModuleInfo,
BoundFunctors,
!.Expansions)
)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = defined_inst(InstName),
( if set.member(InstName, !.Expansions) then
ContainsAny = no
else
set.insert(InstName, !Expansions),
inst_lookup(ModuleInfo, InstName, SubInst),
ContainsAny =
inst_contains_any_2(ModuleInfo, SubInst, !.Expansions)
)
;
Inst = constrained_inst_vars(_, SubInst),
ContainsAny = inst_contains_any_2(ModuleInfo, SubInst, !.Expansions)
;
( Inst = free
; Inst = not_reached
; Inst = ground(_, _)
),
ContainsAny = no
).
:- func inst_list_contains_any(module_info, list(mer_inst), set(inst_name))
= bool.
inst_list_contains_any(_ModuleInfo, [], _Expansions) = no.
inst_list_contains_any(ModuleInfo, [Inst | Insts], Expansions) = ContainsAny :-
HeadContainsAny = inst_contains_any_2(ModuleInfo, Inst, Expansions),
(
HeadContainsAny = yes,
ContainsAny = yes
;
HeadContainsAny = no,
ContainsAny = inst_list_contains_any(ModuleInfo, Insts, Expansions)
).
:- func bound_functor_list_contains_any(module_info, list(bound_functor),
set(inst_name)) = bool.
bound_functor_list_contains_any(_ModuleInfo, [], _Expansions) = no.
bound_functor_list_contains_any(ModuleInfo, [BoundFunctor | BoundFunctors],
Expansions) = ContainsAny :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
HeadContainsAny =
inst_list_contains_any(ModuleInfo, ArgInsts, Expansions),
(
HeadContainsAny = yes,
ContainsAny = yes
;
HeadContainsAny = no,
ContainsAny = bound_functor_list_contains_any(ModuleInfo,
BoundFunctors, Expansions)
).
%---------------------------------------------------------------------------%
var_inst_contains_any(ModuleInfo, Instmap, Var) :-
instmap_lookup_var(Instmap, Var, Inst),
inst_contains_any(ModuleInfo, Inst).
%---------------------------------------------------------------------------%
inst_may_restrict_cons_ids(ModuleInfo, Inst) = MayRestrict :-
(
( Inst = any(_, _)
; Inst = bound(_, _, _)
; Inst = inst_var(_)
; Inst = constrained_inst_vars(_, _) % XXX is this right?
),
MayRestrict = yes
;
( Inst = free
; Inst = not_reached
; Inst = ground(_, _)
),
MayRestrict = no
;
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, NewInst),
MayRestrict = inst_may_restrict_cons_ids(ModuleInfo, NewInst)
).
%---------------------------------------------------------------------------%
inst_contains_higher_order(ModuleInfo, Inst) :-
set.init(Expansions),
inst_contains_higher_order_2(ModuleInfo, Inst, Expansions) = yes.
:- func inst_contains_higher_order_2(module_info, mer_inst, set(inst_name))
= bool.
inst_contains_higher_order_2(ModuleInfo, Inst, !.Expansions) = ContainsHO :-
(
( Inst = ground(_, HOInstInfo)
; Inst = any(_, HOInstInfo)
),
ContainsHO = ho_inst_info_contains_higher_order(HOInstInfo)
;
Inst = bound(_, _, BoundFunctors),
ContainsHO = bound_functor_list_contains_higher_order(ModuleInfo,
BoundFunctors, !.Expansions)
;
Inst = inst_var(_),
unexpected($pred, "uninstantiated inst parameter")
;
Inst = defined_inst(InstName),
( if set.member(InstName, !.Expansions) then
ContainsHO = no
else
set.insert(InstName, !Expansions),
inst_lookup(ModuleInfo, InstName, SubInst),
ContainsHO =
inst_contains_higher_order_2(ModuleInfo, SubInst, !.Expansions)
)
;
Inst = constrained_inst_vars(_, SubInst),
ContainsHO =
inst_contains_higher_order_2(ModuleInfo, SubInst, !.Expansions)
;
( Inst = free
; Inst = not_reached
),
ContainsHO = no
).
:- func inst_list_contains_higher_order(module_info, list(mer_inst),
set(inst_name)) = bool.
inst_list_contains_higher_order(_ModuleInfo, [], _Expansions) = no.
inst_list_contains_higher_order(ModuleInfo, [Inst | Insts], Expansions) =
ContainsHO :-
HeadContainsHO =
inst_contains_higher_order_2(ModuleInfo, Inst, Expansions),
(
HeadContainsHO = yes,
ContainsHO = yes
;
HeadContainsHO = no,
ContainsHO =
inst_list_contains_higher_order(ModuleInfo, Insts, Expansions)
).
:- func bound_functor_list_contains_higher_order(module_info,
list(bound_functor),
set(inst_name)) = bool.
bound_functor_list_contains_higher_order(_ModuleInfo, [], _Expansions) = no.
bound_functor_list_contains_higher_order(ModuleInfo,
[BoundFunctor | BoundFunctors], Expansions) = ContainsHO :-
BoundFunctor = bound_functor(_ConsId, ArgInsts),
HeadContainsHO =
inst_list_contains_higher_order(ModuleInfo, ArgInsts, Expansions),
(
HeadContainsHO = yes,
ContainsHO = yes
;
HeadContainsHO = no,
ContainsHO = bound_functor_list_contains_higher_order(ModuleInfo,
BoundFunctors, Expansions)
).
:- func ho_inst_info_contains_higher_order(ho_inst_info) = bool.
ho_inst_info_contains_higher_order(HOInstInfo) = ContainsHO :-
(
HOInstInfo = higher_order(_),
ContainsHO = yes
;
HOInstInfo = none_or_default_func,
ContainsHO = no
).
%-----------------------------------------------------------------------------%
:- end_module hlds.inst_test.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink