mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-16 18:03:36 +00:00
Code Issues Projects Releases Wiki Activity
Files
b357a3dadcdf29c8d8ca184d65f7634a1a94de36
mercury/compiler/inst_test.m
Zoltan Somogyi dde8c1f396 Delete mer_inst's free/1 functor. 
This functor was intended to have the same semantics as free/0, while
containing the type of the value it was applied to. However, commit
87e7e3bafa, the commit in which Fergus
introduced this function symbol, also contained an "XXX temporary hack"
in which the code that was supposed to create a value using this function
symbol when propagating a type into a free/0 inst, just ignored the type,
and left the inst as free/0. THIS TEMPORARY HACK HAS REMAINED IN THE CODE
SINCE 1994.

In a few places, we did hand-create insts using free/1 for code created
by the compiler itself. However, as far as I can tell, no free/1 inst
ever described any code read in from source files. This meant that
any code in switch arms for free/1 in switches on insts was never tested
in any meaningful sense. And predicates such as inst_merge_4, which
processed several kinds of insts without doing a complete switch on insts,
simply lacked code handle free/1 at all.

This diff deletes the free/1 function symbol. It does so NOT because
the type stored as its argument is not useful, but because it is useful
NOT JUST for free insts, but for ALL insts. This means that any mechanism
for providing information about the type of the value that an inst applies to
should work for all insts. This can be done

- either by passing along the type with every inst, and stepping into
  the argument types of each argument of a function symbol as we process
  bound insts, in every operation that operates on insts that needs
  type information.

- or by including a type in ALL the function symbols of the inst type.
  (We could do this either by adding a maybe(mer_type) field to each
  function symbol, which would be "no" before the propagate-types-
  into-modes pass, or by adding just a mer_type field, which would
  be a special dummy value before that pass. I (zs) prefer the latter,
  and so would juliensf.)

The second option would involve reintroducing a free/1 function symbol
into the inst type, but this would replace the existing free/0
function symbol, and it would inherit all the code that currently
handles free/0, NOT the code being deleted by this diff for handling
the *current* free/1.

The first option would be easier to implement if only one or maybe two
operations needed type info, the second would be both easier to implement
and more efficient if more operations needed that info.

compiler/prog_data.m:
    Delete free/1.

compiler/add_mode.m:
compiler/add_mutable_aux_preds.m:
compiler/comp_unit_interface.m:
compiler/dep_par_conj.m:
compiler/direct_arg_in_out.m:
compiler/equiv_type_hlds.m:
compiler/error_msg_inst.m:
compiler/float_regs.m:
compiler/hlds_code_util.m:
compiler/hlds_out_goal.m:
compiler/hlds_out_mode.m:
compiler/hlds_statistics.m:
compiler/inst_abstract_unify.m:
compiler/inst_check.m:
compiler/inst_match.m:
compiler/inst_merge.m:
compiler/inst_mode_type_prop.m:
compiler/inst_test.m:
compiler/inst_user.m:
compiler/inst_util.m:
compiler/mode_constraints.m:
compiler/mode_errors.m:
compiler/mode_top_functor.m:
compiler/modecheck_coerce.m:
compiler/modecheck_util.m:
compiler/modes.m:
compiler/module_qual.qualify_items.m:
compiler/parse_tree_out_inst.m:
compiler/parse_tree_to_term.m:
compiler/pd_util.m:
compiler/prog_mode.m:
compiler/prog_rep.m:
compiler/recompilation.usage.m:
compiler/types_into_modes.m:
compiler/unused_imports.m:
compiler/xml_documentation.m:
    Conform to the change above.
2023-07-22 12:26:55 +02:00

1545 lines
55 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 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 check_hlds.inst_test.
:- interface.
:- import_module hlds.
:- 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_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 is not `mostly_unique' or `unique', i.e.
% if it is shared or free. It fails for abstract insts.
%
:- pred inst_is_not_partly_unique(module_info::in, mer_inst::in) is semidet.
% Succeed if the inst is not `unique', i.e. if it is mostly_unique,
% shared, or free. It fails for abstract insts.
%
:- 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_inst)::out) is semidet.
%-----------------------------------------------------------------------------%
:- pred inst_results_bound_inst_list_is_ground(module_info::in,
inst_test_results::in, list(bound_inst)::in) is semidet.
:- pred inst_results_bound_inst_list_is_ground_mt(module_info::in,
mer_type::in, inst_test_results::in, list(bound_inst)::in) is semidet.
:- pred inst_results_bound_inst_list_is_ground_or_any(module_info::in,
inst_test_results::in, list(bound_inst)::in) is semidet.
:- pred bound_inst_list_is_unique(module_info::in, list(bound_inst)::in)
is semidet.
:- pred bound_inst_list_is_mostly_unique(module_info::in, list(bound_inst)::in)
is semidet.
:- pred bound_inst_list_is_not_partly_unique(module_info::in,
list(bound_inst)::in) is semidet.
:- pred bound_inst_list_is_not_fully_unique(module_info::in,
list(bound_inst)::in) is semidet.
:- pred bound_inst_list_is_free(module_info::in, list(bound_inst)::in)
is semidet.
%-----------------------------------------------------------------------------%
:- pred inst_list_is_ground(module_info::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 livenesses, return
% true 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_inst)::in) is semidet.
% Given a list of insts, and a corresponding list of livenesses, return
% true 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.
:- pred inst_contains_higher_order(module_info::in, mer_inst::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.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module check_hlds.inst_lookup.
:- import_module check_hlds.inst_util.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
:- import_module hlds.passes_aux.
:- import_module parse_tree.prog_type.
:- import_module io.
:- import_module require.
:- import_module set.
:- import_module set_tree234.
%-----------------------------------------------------------------------------%
inst_is_ground(ModuleInfo, Inst) :-
% XXX TYPE_FOR_INST Our caller should pass us the type.
%
% inst_is_ground succeeds iff the inst passed is `ground' or the
% equivalent. Abstract insts are not considered ground.
promise_pure (
semipure lookup_inst_is_ground(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, no_type_available, Inst) then
impure record_inst_is_ground(Inst, yes)
% Succeed.
else
impure record_inst_is_ground(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_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 MayOccur. Otherwise, return Found = no.
%
:- semipure pred lookup_inst_is_ground(mer_inst::in,
bool::out, bool::out) is det.
:- pragma foreign_proc("C",
lookup_inst_is_ground(Inst::in, Found::out, IsGround::out),
[will_not_call_mercury, promise_semipure],
"
MR_Unsigned hash;
hash = (MR_Unsigned) Inst;
hash = hash >> MR_LOW_TAG_BITS;
hash = hash % INST_IS_GROUND_CACHE_SIZE;
if (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_inst::in, bool::in) is det.
:- pragma foreign_proc("C",
record_inst_is_ground(Inst::in, IsGround::in),
[will_not_call_mercury],
"
MR_Unsigned hash;
hash = (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_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 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_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) :-
% XXX This special casing of any/2 was introduced in version 1.65
% of this file. The log message for that version gives a reason why
% this special casing is required, but I (zs) don't believe it,
% at least not without more explanation.
( if Inst = any(_, _) then
( if set_tree234.contains(!.Expansions, Inst) then
true
else
inst_is_ground_mt_2(ModuleInfo, Type, Inst, !Expansions)
)
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,
fail
;
( Inst = not_reached
; Inst = ground(_, _)
)
;
Inst = bound(_, InstResults, BoundInsts),
inst_results_bound_inst_list_is_ground_mt_2(ModuleInfo, Type,
InstResults, BoundInsts, !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 = any(Uniq, HOInstInfo),
maybe_any_to_bound(ModuleInfo, Type, Uniq, HOInstInfo, 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, BoundInsts),
inst_results_bound_inst_list_is_ground_or_any_2(ModuleInfo,
InstResults, BoundInsts, !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, BoundInsts),
(
InstResults = inst_test_results_fgtc,
fail
;
( InstResults = inst_test_no_results
; InstResults = inst_test_results(_, _, _, _, _, _)
),
bound_inst_list_is_unique_2(ModuleInfo, BoundInsts, !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, BoundInsts),
(
InstResults = inst_test_results_fgtc,
fail
;
( InstResults = inst_test_no_results
; InstResults = inst_test_results(_, _, _, _, _, _)
),
bound_inst_list_is_mostly_unique_2(ModuleInfo, BoundInsts,
!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, BoundInsts),
(
InstResult = inst_test_results_fgtc
;
( InstResult = inst_test_no_results
; InstResult = inst_test_results(_, _, _, _, _, _)
),
bound_inst_list_is_not_partly_unique_2(ModuleInfo, BoundInsts,
!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, BoundInsts),
( Uniq = shared
; Uniq = mostly_unique
),
(
InstResult = inst_test_results_fgtc
;
( InstResult = inst_test_no_results
; InstResult = inst_test_results(_, _, _, _, _, _)
),
bound_inst_list_is_not_fully_unique_2(ModuleInfo, BoundInsts,
!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_inst_list_is_ground(ModuleInfo, InstResults, BoundInsts) :-
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_inst_list_is_ground_mt(ModuleInfo, no_type_available,
BoundInsts)
)
;
InstResults = inst_test_no_results,
bound_inst_list_is_ground_mt(ModuleInfo, no_type_available, BoundInsts)
).
inst_results_bound_inst_list_is_ground_mt(ModuleInfo, Type, InstResults,
BoundInsts) :-
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_inst_list_is_ground_mt(ModuleInfo, Type, BoundInsts)
)
;
InstResults = inst_test_no_results,
bound_inst_list_is_ground_mt(ModuleInfo, Type, BoundInsts)
).
:- pred inst_results_bound_inst_list_is_ground_mt_2(module_info::in,
mer_type::in, inst_test_results::in, list(bound_inst)::in,
set_tree234(mer_inst)::in, set_tree234(mer_inst)::out) is semidet.
inst_results_bound_inst_list_is_ground_mt_2(ModuleInfo, Type, InstResults,
BoundInsts, !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_inst_list_is_ground_mt_2(ModuleInfo, Type, BoundInsts,
!Expansions)
)
;
InstResults = inst_test_no_results,
bound_inst_list_is_ground_mt_2(ModuleInfo, Type, BoundInsts,
!Expansions)
).
%-----------------------------------------------------------------------------%
inst_results_bound_inst_list_is_ground_or_any(ModuleInfo, InstResults,
BoundInsts) :-
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_inst_list_is_ground_or_any(ModuleInfo, BoundInsts)
)
;
InstResults = inst_test_no_results,
bound_inst_list_is_ground_or_any(ModuleInfo, BoundInsts)
).
:- pred inst_results_bound_inst_list_is_ground_or_any_2(module_info::in,
inst_test_results::in, list(bound_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
inst_results_bound_inst_list_is_ground_or_any_2(ModuleInfo, InstResults,
BoundInsts, !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_inst_list_is_ground_or_any_2(ModuleInfo, BoundInsts,
!Expansions)
)
;
InstResults = inst_test_no_results,
bound_inst_list_is_ground_or_any_2(ModuleInfo, BoundInsts, !Expansions)
).
%-----------------------------------------------------------------------------%
:- pred bound_inst_list_is_ground_mt(module_info::in, mer_type::in,
list(bound_inst)::in) is semidet.
bound_inst_list_is_ground_mt(_, _, []).
bound_inst_list_is_ground_mt(ModuleInfo, Type,
[BoundInst | BoundInsts]) :-
BoundInst = bound_functor(Name, Args),
get_cons_id_arg_types(ModuleInfo, Type, Name, list.length(Args), Types),
inst_list_is_ground_mt(ModuleInfo, Types, Args),
bound_inst_list_is_ground_mt(ModuleInfo, Type, BoundInsts).
:- pred bound_inst_list_is_ground_mt_2(module_info::in, mer_type::in,
list(bound_inst)::in,
set_tree234(mer_inst)::in, set_tree234(mer_inst)::out) is semidet.
bound_inst_list_is_ground_mt_2(_, _, [], !Expansions).
bound_inst_list_is_ground_mt_2(ModuleInfo, Type, [BoundInst | BoundInsts],
!Expansions) :-
BoundInst = bound_functor(Name, Args),
get_cons_id_arg_types(ModuleInfo, Type, Name, list.length(Args), Types),
inst_list_is_ground_mt_2(ModuleInfo, Types, Args, !Expansions),
bound_inst_list_is_ground_mt_2(ModuleInfo, Type, BoundInsts, !Expansions).
:- pred bound_inst_list_is_ground_or_any(module_info::in,
list(bound_inst)::in) is semidet.
bound_inst_list_is_ground_or_any(_, []).
bound_inst_list_is_ground_or_any(ModuleInfo, [BoundInst | BoundInsts]) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_ground_or_any(ModuleInfo, Args),
bound_inst_list_is_ground_or_any(ModuleInfo, BoundInsts).
:- pred bound_inst_list_is_ground_or_any_2(module_info::in,
list(bound_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_inst_list_is_ground_or_any_2(_, [], !Expansions).
bound_inst_list_is_ground_or_any_2(ModuleInfo, [BoundInst | BoundInsts],
!Expansions) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_ground_or_any_2(ModuleInfo, Args, !Expansions),
bound_inst_list_is_ground_or_any_2(ModuleInfo, BoundInsts, !Expansions).
bound_inst_list_is_unique(_, []).
bound_inst_list_is_unique(ModuleInfo, [BoundInst | BoundInsts]) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_unique(ModuleInfo, Args),
bound_inst_list_is_unique(ModuleInfo, BoundInsts).
:- pred bound_inst_list_is_unique_2(module_info::in, list(bound_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_inst_list_is_unique_2(_, [], !Expansions).
bound_inst_list_is_unique_2(ModuleInfo, [BoundInst | BoundInsts],
!Expansions) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_unique_2(ModuleInfo, Args, !Expansions),
bound_inst_list_is_unique_2(ModuleInfo, BoundInsts, !Expansions).
bound_inst_list_is_mostly_unique(_, []).
bound_inst_list_is_mostly_unique(ModuleInfo, [BoundInst | BoundInsts]) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_mostly_unique(ModuleInfo, Args),
bound_inst_list_is_mostly_unique(ModuleInfo, BoundInsts).
:- pred bound_inst_list_is_mostly_unique_2(module_info::in,
list(bound_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_inst_list_is_mostly_unique_2(_, [], !Expansions).
bound_inst_list_is_mostly_unique_2(ModuleInfo, [BoundInst | BoundInsts],
!Expansions) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_mostly_unique_2(ModuleInfo, Args, !Expansions),
bound_inst_list_is_mostly_unique_2(ModuleInfo, BoundInsts, !Expansions).
bound_inst_list_is_not_partly_unique(_, []).
bound_inst_list_is_not_partly_unique(ModuleInfo, [BoundInst | BoundInsts]) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_not_partly_unique(ModuleInfo, Args),
bound_inst_list_is_not_partly_unique(ModuleInfo, BoundInsts).
:- pred bound_inst_list_is_not_partly_unique_2(module_info::in,
list(bound_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_inst_list_is_not_partly_unique_2(_, [], !Expansions).
bound_inst_list_is_not_partly_unique_2(ModuleInfo, [BoundInst | BoundInsts],
!Expansions) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_not_partly_unique_2(ModuleInfo, Args, !Expansions),
bound_inst_list_is_not_partly_unique_2(ModuleInfo, BoundInsts,
!Expansions).
bound_inst_list_is_not_fully_unique(_, []).
bound_inst_list_is_not_fully_unique(ModuleInfo, [BoundInst | BoundInsts]) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_not_fully_unique(ModuleInfo, Args),
bound_inst_list_is_not_fully_unique(ModuleInfo, BoundInsts).
:- pred bound_inst_list_is_not_fully_unique_2(module_info::in,
list(bound_inst)::in,
set(mer_inst)::in, set(mer_inst)::out) is semidet.
bound_inst_list_is_not_fully_unique_2(_, [], !Expansions).
bound_inst_list_is_not_fully_unique_2(ModuleInfo, [BoundInst | BoundInsts],
!Expansions) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_not_fully_unique_2(ModuleInfo, Args, !Expansions),
bound_inst_list_is_not_fully_unique_2(ModuleInfo, BoundInsts,
!Expansions).
bound_inst_list_is_free(_, []).
bound_inst_list_is_free(ModuleInfo, [BoundInst | BoundInsts]) :-
BoundInst = bound_functor(_Name, Args),
inst_list_is_free(ModuleInfo, Args),
bound_inst_list_is_free(ModuleInfo, BoundInsts).
%-----------------------------------------------------------------------------%
inst_list_is_ground(_, []).
inst_list_is_ground(ModuleInfo, [Inst | Insts]) :-
inst_is_ground(ModuleInfo, Inst),
inst_list_is_ground(ModuleInfo, 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(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, [Live | Lives], [Inst | Insts]) :-
(
Live = is_live,
inst_is_ground(ModuleInfo, Inst)
;
Live = is_dead
),
inst_list_is_ground_or_dead(ModuleInfo, Lives, Insts).
inst_list_is_ground_or_any_or_dead(_, [], []).
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_inst_list_contains_inst_name(ModuleInfo, InstName,
ArgInsts, Contains, !Expansions)
else
Contains = no
)
;
InstNamesResult = inst_result_contains_inst_names_unknown,
bound_inst_list_contains_inst_name(ModuleInfo, InstName,
ArgInsts, Contains, !Expansions)
)
;
InstResults = inst_test_no_results,
bound_inst_list_contains_inst_name(ModuleInfo, InstName,
ArgInsts, Contains, !Expansions)
)
).
:- pred bound_inst_list_contains_inst_name(module_info::in,
inst_name::in, list(bound_inst)::in, bool::out,
inst_names::in, inst_names::out) is det.
bound_inst_list_contains_inst_name(_ModuleInfo, _InstName, [],
no, !Expansions).
bound_inst_list_contains_inst_name(ModuleInfo, InstName,
[BoundInst | BoundInsts], Contains, !Expansions) :-
BoundInst = bound_functor(_Functor, ArgInsts),
inst_list_contains_inst_name(ModuleInfo, InstName, ArgInsts, Contains1,
!Expansions),
(
Contains1 = yes,
Contains = yes
;
Contains1 = no,
bound_inst_list_contains_inst_name(ModuleInfo, InstName, BoundInsts,
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, BoundInsts0),
list.sort_and_remove_dups(BoundInsts0, BoundInsts),
% 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, BoundInsts)
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, BoundInsts),
(
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_inst_list_contains_any(ModuleInfo,
BoundInsts, !.Expansions)
)
;
InstResults = inst_test_no_results,
ContainsAny = bound_inst_list_contains_any(ModuleInfo, BoundInsts,
!.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_inst_list_contains_any(module_info, list(bound_inst),
set(inst_name)) = bool.
bound_inst_list_contains_any(_ModuleInfo, [], _Expansions) = no.
bound_inst_list_contains_any(ModuleInfo, [BoundInst | BoundInsts],
Expansions) = ContainsAny :-
BoundInst = bound_functor(_ConsId, ArgInsts),
HeadContainsAny =
inst_list_contains_any(ModuleInfo, ArgInsts, Expansions),
(
HeadContainsAny = yes,
ContainsAny = yes
;
HeadContainsAny = no,
ContainsAny = bound_inst_list_contains_any(ModuleInfo, BoundInsts,
Expansions)
).
%---------------------------------------------------------------------------%
var_inst_contains_any(ModuleInfo, Instmap, Var) :-
instmap_lookup_var(Instmap, Var, Inst),
inst_contains_any(ModuleInfo, Inst).
%---------------------------------------------------------------------------%
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(_, _, BoundInsts),
ContainsHO = bound_inst_list_contains_higher_order(ModuleInfo,
BoundInsts, !.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_inst_list_contains_higher_order(module_info, list(bound_inst),
set(inst_name)) = bool.
bound_inst_list_contains_higher_order(_ModuleInfo, [], _Expansions) = no.
bound_inst_list_contains_higher_order(ModuleInfo, [BoundInst | BoundInsts],
Expansions) = ContainsHO :-
BoundInst = bound_functor(_ConsId, ArgInsts),
HeadContainsHO =
inst_list_contains_higher_order(ModuleInfo, ArgInsts, Expansions),
(
HeadContainsHO = yes,
ContainsHO = yes
;
HeadContainsHO = no,
ContainsHO = bound_inst_list_contains_higher_order(ModuleInfo,
BoundInsts, 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
).
%---------------------------------------------------------------------------%
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)
).
%-----------------------------------------------------------------------------%
:- end_module check_hlds.inst_test.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink