mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-18 02:43:40 +00:00
2341 lines
72 KiB
Mathematica
2341 lines
72 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 1994-2007, 2012 The University of Melbourne.
|
|
% Copyright (C) 2013-2018, 2020-2022 The Mercury team.
|
|
% This file is distributed under the terms specified in COPYING.LIB.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% File: private_builtin.m.
|
|
% Main authors: fjh, zs.
|
|
% Stability: medium.
|
|
%
|
|
% This file is automatically imported, as if via ":- use_module", into every
|
|
% module. It is intended for builtins that are just implementation details,
|
|
% such as procedures that the compiler generates implicit calls to when
|
|
% implementing polymorphism, unification, compare/3, etc.
|
|
% Note that the builtins that are needed only for the implementation of
|
|
% some specific constructs and/or in some specific grades, such as
|
|
% tabling, deep profiling and parallelism are in other modules named
|
|
% xxx_builtin.m in this directory.
|
|
%
|
|
% This module is a private part of the Mercury implementation; user modules
|
|
% should never explicitly import this module. The interface for this module
|
|
% does not get included in the Mercury library reference manual.
|
|
%
|
|
% Many of the predicates defined in this module are builtin: they do not
|
|
% have definitions, because the compiler generates code for them inline.
|
|
% Some others are implemented in the runtime. A third group are implemented
|
|
% normally in this module.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module private_builtin.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This section of the module contains predicates that are used by the
|
|
% compiler to implement polymorphism. Changes here may also require changes
|
|
% in compiler/polymorphism.m, compiler/unify_proc.m, compiler/higher_order.m
|
|
% and runtime/mercury_type_info.{c,h}.
|
|
%
|
|
% These predicates should not be used by user programs directly.
|
|
%
|
|
|
|
:- interface.
|
|
|
|
:- pred builtin_unify_int(int::in, int::in) is semidet.
|
|
:- pred builtin_compare_int(comparison_result::uo, int::in, int::in) is det.
|
|
|
|
:- pred builtin_unify_uint(uint::in, uint::in) is semidet.
|
|
:- pred builtin_compare_uint(comparison_result::uo, uint::in, uint::in) is det.
|
|
|
|
:- pred builtin_unify_int8(int8::in, int8::in) is semidet.
|
|
:- pred builtin_compare_int8(comparison_result::uo, int8::in, int8::in) is det.
|
|
|
|
:- pred builtin_unify_uint8(uint8::in, uint8::in) is semidet.
|
|
:- pred builtin_compare_uint8(comparison_result::uo, uint8::in, uint8::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_int16(int16::in, int16::in) is semidet.
|
|
:- pred builtin_compare_int16(comparison_result::uo, int16::in, int16::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_uint16(uint16::in, uint16::in) is semidet.
|
|
:- pred builtin_compare_uint16(comparison_result::uo, uint16::in, uint16::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_int32(int32::in, int32::in) is semidet.
|
|
:- pred builtin_compare_int32(comparison_result::uo, int32::in, int32::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_uint32(uint32::in, uint32::in) is semidet.
|
|
:- pred builtin_compare_uint32(comparison_result::uo, uint32::in, uint32::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_int64(int64::in, int64::in) is semidet.
|
|
:- pred builtin_compare_int64(comparison_result::uo, int64::in, int64::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_uint64(uint64::in, uint64::in) is semidet.
|
|
:- pred builtin_compare_uint64(comparison_result::uo, uint64::in, uint64::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_character(character::in, character::in) is semidet.
|
|
:- pred builtin_compare_character(comparison_result::uo, character::in,
|
|
character::in) is det.
|
|
|
|
:- pred builtin_unify_string(string::in, string::in) is semidet.
|
|
:- pred builtin_compare_string(comparison_result::uo, string::in, string::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_float(float::in, float::in) is semidet.
|
|
:- pred builtin_compare_float(comparison_result::uo, float::in, float::in)
|
|
is det.
|
|
|
|
:- pred builtin_unify_pred((pred)::in, (pred)::in) is semidet.
|
|
:- pred builtin_compare_pred(comparison_result::uo, (pred)::in, (pred)::in)
|
|
is det.
|
|
|
|
% These should never be called -- the compiler never specializes
|
|
% comparison on these types because the generic compare is just as good
|
|
% as anything we could put here.
|
|
%
|
|
:- pred builtin_unify_tuple(T::in, T::in) is semidet.
|
|
:- pred builtin_compare_tuple(comparison_result::uo, T::in, T::in) is det.
|
|
|
|
% The following pred is used for compare/3 on non-canonical types
|
|
% (types for which there is a `where equality is ...' declaration).
|
|
%
|
|
:- pred builtin_compare_non_canonical_type(comparison_result::uo,
|
|
T::in, T::in) is det.
|
|
|
|
% The following predicates are used for unify/2 (compare/3) on
|
|
% solver types when the equality (comparison) attribute is omitted
|
|
% from the solver type definition.
|
|
%
|
|
:- pred builtin_unify_solver_type(T::in, T::in) is semidet.
|
|
:- pred builtin_compare_solver_type(comparison_result::uo,
|
|
T::in, T::in) is det.
|
|
|
|
% Compare_error is used in the code generated for compare/3 preds.
|
|
%
|
|
:- pred compare_error is erroneous.
|
|
|
|
% The builtin < and > operators on integers of all sizes and both
|
|
% signednesses, used in the code generated for compare/3 preds.
|
|
%
|
|
:- pred builtin_int_lt(int::in, int::in) is semidet.
|
|
:- pred builtin_int_gt(int::in, int::in) is semidet.
|
|
:- pred builtin_int8_lt(int8::in, int8::in) is semidet.
|
|
:- pred builtin_int8_gt(int8::in, int8::in) is semidet.
|
|
:- pred builtin_int16_lt(int16::in, int16::in) is semidet.
|
|
:- pred builtin_int16_gt(int16::in, int16::in) is semidet.
|
|
:- pred builtin_int32_lt(int32::in, int32::in) is semidet.
|
|
:- pred builtin_int32_gt(int32::in, int32::in) is semidet.
|
|
:- pred builtin_int64_lt(int64::in, int64::in) is semidet.
|
|
:- pred builtin_int64_gt(int64::in, int64::in) is semidet.
|
|
:- pred builtin_uint_lt(int::in, int::in) is semidet.
|
|
:- pred builtin_uint_gt(int::in, int::in) is semidet.
|
|
:- pred builtin_uint8_lt(uint8::in, uint8::in) is semidet.
|
|
:- pred builtin_uint8_gt(uint8::in, uint8::in) is semidet.
|
|
:- pred builtin_uint16_lt(uint16::in, uint16::in) is semidet.
|
|
:- pred builtin_uint16_gt(uint16::in, uint16::in) is semidet.
|
|
:- pred builtin_uint32_lt(uint32::in, uint32::in) is semidet.
|
|
:- pred builtin_uint32_gt(uint32::in, uint32::in) is semidet.
|
|
:- pred builtin_uint64_lt(uint64::in, uint64::in) is semidet.
|
|
:- pred builtin_uint64_gt(uint64::in, uint64::in) is semidet.
|
|
|
|
:- pred unsigned_lt(int::in, int::in) is semidet.
|
|
:- pred unsigned_le(int::in, int::in) is semidet.
|
|
|
|
% These should never be called -- the compiler replaces calls to these
|
|
% predicates with inline code. These predicates are declared not to take
|
|
% type_infos.
|
|
%
|
|
:- pred builtin_compound_eq(T::in, T::in) is semidet.
|
|
:- pred builtin_compound_lt(T::in, T::in) is semidet.
|
|
|
|
% A "typed" version of unify/2 -- i.e. one that can handle arguments
|
|
% of different types. It first unifies their types, and then (if the types
|
|
% are equal) it unifies the values.
|
|
%
|
|
:- pred typed_unify(T1, T2).
|
|
:- mode typed_unify(in, in) is semidet.
|
|
:- mode typed_unify(in, out) is semidet.
|
|
|
|
% A "typed" version of compare/3 -- i.e. one that can handle arguments
|
|
% of different types. It first compares the types, and then (if the
|
|
% types are equal) it compares the values.
|
|
%
|
|
:- pred typed_compare(comparison_result::uo, T1::in, T2::in) is det.
|
|
|
|
% True iff the two terms occupy the same address in memory.
|
|
% This is useful as a cheap but incomplete test of equality
|
|
% when implementing user-defined equality.
|
|
%
|
|
:- pred pointer_equal(T::in, T::in) is semidet.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module char.
|
|
:- import_module float.
|
|
:- import_module int.
|
|
:- import_module int8.
|
|
:- import_module int16.
|
|
:- import_module int32.
|
|
:- import_module int64.
|
|
:- import_module uint.
|
|
:- import_module uint8.
|
|
:- import_module uint16.
|
|
:- import_module uint32.
|
|
:- import_module uint64.
|
|
:- import_module require.
|
|
:- import_module string.
|
|
:- import_module type_desc.
|
|
|
|
:- pragma inline(pred(builtin_compare_int/3)).
|
|
:- pragma inline(pred(builtin_compare_uint/3)).
|
|
:- pragma inline(pred(builtin_compare_int8/3)).
|
|
:- pragma inline(pred(builtin_compare_uint8/3)).
|
|
:- pragma inline(pred(builtin_compare_int16/3)).
|
|
:- pragma inline(pred(builtin_compare_uint16/3)).
|
|
:- pragma inline(pred(builtin_compare_int32/3)).
|
|
:- pragma inline(pred(builtin_compare_uint32/3)).
|
|
:- pragma inline(pred(builtin_compare_int64/3)).
|
|
:- pragma inline(pred(builtin_compare_uint64/3)).
|
|
:- pragma inline(pred(builtin_compare_character/3)).
|
|
:- pragma inline(pred(builtin_compare_string/3)).
|
|
:- pragma inline(pred(builtin_compare_float/3)).
|
|
|
|
builtin_unify_int(X, X).
|
|
|
|
builtin_compare_int(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_uint(X, X).
|
|
|
|
builtin_compare_uint(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_int8(X, X).
|
|
|
|
builtin_compare_int8(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_uint8(X, X).
|
|
|
|
builtin_compare_uint8(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_int16(X, X).
|
|
|
|
builtin_compare_int16(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_uint16(X, X).
|
|
|
|
builtin_compare_uint16(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_int32(X, X).
|
|
|
|
builtin_compare_int32(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_uint32(X, X).
|
|
|
|
builtin_compare_uint32(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_int64(X, X).
|
|
|
|
builtin_compare_int64(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_uint64(X, X).
|
|
|
|
builtin_compare_uint64(R, X, Y) :-
|
|
( if X < Y then
|
|
R = (<)
|
|
else if X = Y then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_character(C, C).
|
|
|
|
builtin_compare_character(R, X, Y) :-
|
|
char.to_int(X, XI),
|
|
char.to_int(Y, YI),
|
|
( if XI < YI then
|
|
R = (<)
|
|
else if XI = YI then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
builtin_unify_string(S, S).
|
|
|
|
builtin_compare_string(R, S1, S2) :-
|
|
builtin_strcmp(Res, S1, S2),
|
|
( if Res < 0 then
|
|
R = (<)
|
|
else if Res = 0 then
|
|
R = (=)
|
|
else
|
|
R = (>)
|
|
).
|
|
|
|
:- pred builtin_strcmp(int::out, string::in, string::in) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
builtin_strcmp(Res::out, S1::in, S2::in),
|
|
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
|
|
does_not_affect_liveness],
|
|
"
|
|
Res = strcmp(S1, S2);
|
|
").
|
|
|
|
:- pragma foreign_proc("C#",
|
|
builtin_strcmp(Res::out, S1::in, S2::in),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
Res = System.String.CompareOrdinal(S1, S2);
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
builtin_strcmp(Res::out, S1::in, S2::in),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
Res = S1.compareTo(S2);
|
|
").
|
|
|
|
builtin_unify_float(F, F).
|
|
|
|
builtin_compare_float(R, F1, F2) :-
|
|
( if F1 < F2 then
|
|
R = (<)
|
|
else if F1 > F2 then
|
|
R = (>)
|
|
else
|
|
R = (=)
|
|
).
|
|
|
|
:- pragma no_inline(pred(builtin_unify_pred/2)).
|
|
builtin_unify_pred(_X, _Y) :-
|
|
( if semidet_succeed then
|
|
error("attempted higher-order unification")
|
|
else
|
|
% The following is never executed.
|
|
semidet_succeed
|
|
).
|
|
|
|
:- pragma no_inline(pred(builtin_compare_pred/3)).
|
|
builtin_compare_pred(Result, _X, _Y) :-
|
|
( if semidet_succeed then
|
|
error("attempted higher-order comparison")
|
|
else
|
|
% The following is never executed.
|
|
Result = (<)
|
|
).
|
|
|
|
builtin_unify_tuple(_, _) :-
|
|
( if semidet_succeed then
|
|
% The generic unification function in the runtime
|
|
% should handle this itself.
|
|
error("builtin_unify_tuple called")
|
|
else
|
|
% The following is never executed.
|
|
semidet_succeed
|
|
).
|
|
|
|
builtin_compare_tuple(Res, _, _) :-
|
|
( if semidet_succeed then
|
|
% The generic comparison function in the runtime
|
|
% should handle this itself.
|
|
error("builtin_compare_tuple called")
|
|
else
|
|
% The following is never executed.
|
|
Res = (<)
|
|
).
|
|
|
|
:- pragma no_inline(pred(builtin_compare_non_canonical_type/3)).
|
|
builtin_compare_non_canonical_type(Res, X, _Y) :-
|
|
% Suppress determinism warning.
|
|
( if semidet_succeed then
|
|
Message = "call to compare/3 for non-canonical type `"
|
|
++ type_name(type_of(X)) ++ "'",
|
|
error(Message)
|
|
else
|
|
% The following is never executed.
|
|
Res = (<)
|
|
).
|
|
|
|
:- pragma no_inline(pred(builtin_unify_solver_type/2)).
|
|
builtin_unify_solver_type(_X, _Y) :-
|
|
% Suppress determinism warning.
|
|
( if semidet_succeed then
|
|
% XXX ideally we should use the commented out code but looking up
|
|
% the name of the solver type in RTTI currently gives us the name of
|
|
% the representation type - reporting the name of the latter is likely
|
|
% to be confusing since representation types will nearly always have
|
|
% equality defined on them.
|
|
%Message = "call to unify/2 for solver type `"
|
|
% ++ type_name(type_of(X)) ++ "'",
|
|
Message = "call to generated unify/2 for solver type",
|
|
error(Message)
|
|
else
|
|
% This is never executed.
|
|
semidet_fail
|
|
).
|
|
|
|
:- pragma no_inline(pred(builtin_compare_solver_type/3)).
|
|
builtin_compare_solver_type(Res, _X, _Y) :-
|
|
% Suppress determinism warning.
|
|
( if semidet_succeed then
|
|
% XXX see the comment above regarding RTTI.
|
|
%Message = "call to compare/3 for solver type `"
|
|
% ++ type_name(type_of(X)) ++ "'",
|
|
Message = "call to generated compare/3 for solver type",
|
|
error(Message)
|
|
else
|
|
% This is never executed.
|
|
Res = (<)
|
|
).
|
|
|
|
:- pragma no_inline(pred(compare_error/0)).
|
|
compare_error :-
|
|
error("internal error in compare/3").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
typed_unify(X, Y) :-
|
|
( if type_of(X) = type_of(Y) then
|
|
unsafe_type_cast(X, Y)
|
|
else
|
|
fail
|
|
).
|
|
|
|
typed_compare(R, X, Y) :-
|
|
compare(R0, type_of(X), type_of(Y)),
|
|
( if R0 = (=) then
|
|
unsafe_type_cast(X, Z),
|
|
compare(R, Z, Y)
|
|
else
|
|
R = R0
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This section of the module handles the runtime representation of
|
|
% type information.
|
|
%
|
|
|
|
:- interface.
|
|
|
|
:- type type_info.
|
|
:- type type_ctor_info.
|
|
|
|
:- type typeclass_info.
|
|
:- type base_typeclass_info.
|
|
|
|
% The following types are used by compiler/ml_code_util.m as the types
|
|
% used for copying type_info/0 and typeclass_info/0 types.
|
|
% XXX Document me better
|
|
%
|
|
:- type sample_type_info
|
|
---> sample_type_info(type_info).
|
|
:- type sample_typeclass_info
|
|
---> sample_typeclass_info(typeclass_info).
|
|
|
|
% type_info_from_typeclass_info(TypeClassInfo, Index, TypeInfo):
|
|
%
|
|
% Extracts TypeInfo from TypeClassInfo, where TypeInfo is the Index'th
|
|
% type_info in the typeclass_info.
|
|
%
|
|
% Note: Index must be equal to the number of the desired type_info
|
|
% plus the number of superclasses for this class.
|
|
%
|
|
:- pred type_info_from_typeclass_info(typeclass_info::in, int::in,
|
|
type_info::out) is det.
|
|
|
|
% unconstrained_type_info_from_typeclass_info(TypeClassInfo,
|
|
% Index, TypeInfo):
|
|
%
|
|
% Extracts the TypeInfo for the Indexth unconstrained type variable
|
|
% from the instance represented by TypeClassInfo.
|
|
%
|
|
:- pred unconstrained_type_info_from_typeclass_info(typeclass_info::in,
|
|
int::in, type_info::out) is det.
|
|
|
|
% superclass_from_typeclass_info(TypeClassInfo, Index, SuperClass):
|
|
%
|
|
% Extracts SuperClass from TypeClassInfo where SuperClass is the
|
|
% Indexth superclass of the class.
|
|
%
|
|
:- pred superclass_from_typeclass_info(typeclass_info::in,
|
|
int::in, typeclass_info::out) is det.
|
|
|
|
% instance_constraint_from_typeclass_info(TypeClassInfo, Index,
|
|
% InstanceConstraintTypeClassInfo):
|
|
%
|
|
% Extracts the typeclass_info for the Indexth typeclass constraint
|
|
% of the instance described by TypeClassInfo.
|
|
%
|
|
% Note: Index must be equal to the number of the desired constraint
|
|
% plus the number of unconstrained type variables for this instance.
|
|
%
|
|
:- pred instance_constraint_from_typeclass_info(typeclass_info::in,
|
|
int::in, typeclass_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
% The definitions for type_ctor_info/0 and type_info/0.
|
|
|
|
:- pragma foreign_code("C#", "
|
|
|
|
public static runtime.TypeInfo_Struct
|
|
MR_typeclass_info_param_type_info(object[] tcinfo, int index)
|
|
{
|
|
object[] tmp;
|
|
int t1;
|
|
|
|
tmp = (object[]) tcinfo[0];
|
|
t1 = System.Convert.ToInt32(tmp[0]) + index;
|
|
return (runtime.TypeInfo_Struct) tcinfo[t1];
|
|
}
|
|
|
|
public static runtime.TypeInfo_Struct
|
|
MR_typeclass_info_instance_tvar_type_info(
|
|
object[] tcinfo, int index)
|
|
{
|
|
return (runtime.TypeInfo_Struct) tcinfo[index];
|
|
}
|
|
|
|
public static object[] MR_typeclass_info_superclass_info(
|
|
object[] tcinfo, int index)
|
|
{
|
|
object[] tmp;
|
|
int t1;
|
|
|
|
tmp = (object[]) tcinfo[0];
|
|
t1 = System.Convert.ToInt32(tmp[0]) + index;
|
|
return (object[]) tcinfo[t1];
|
|
}
|
|
|
|
public static object[] MR_typeclass_info_arg_typeclass_info(
|
|
object[] tcinfo, int index)
|
|
{
|
|
return (object[]) tcinfo[index];
|
|
}
|
|
|
|
").
|
|
|
|
:- pragma foreign_code("Java", "
|
|
|
|
public static jmercury.runtime.TypeInfo_Struct
|
|
MR_typeclass_info_param_type_info(/* typeclass_info */ Object[] tcinfo,
|
|
int index)
|
|
{
|
|
/* typeclass_info */ Object[] base_tcinfo;
|
|
int t1;
|
|
|
|
base_tcinfo = (Object[]) tcinfo[0];
|
|
t1 = ((Integer) base_tcinfo[0]).intValue() + index;
|
|
return (jmercury.runtime.TypeInfo_Struct) tcinfo[t1];
|
|
}
|
|
|
|
public static jmercury.runtime.TypeInfo_Struct
|
|
MR_typeclass_info_instance_tvar_type_info(
|
|
/* typeclass_info */ Object[] tcinfo, int index)
|
|
{
|
|
return (jmercury.runtime.TypeInfo_Struct) tcinfo[index];
|
|
}
|
|
|
|
public static /* typeclass_info */ Object[] MR_typeclass_info_superclass_info(
|
|
/* typeclass_info */ Object[] tcinfo, int index)
|
|
{
|
|
/* typeclass_info */ Object[] base_tcinfo;
|
|
int t1;
|
|
|
|
// The zeroth argument is num_extra_instance_args.
|
|
base_tcinfo = (Object[]) tcinfo[0];
|
|
t1 = ((Integer) base_tcinfo[0]).intValue() + index;
|
|
return (/* typeclass_info */ Object[]) tcinfo[t1];
|
|
}
|
|
|
|
public static /* typeclass_info */ Object[]
|
|
MR_typeclass_info_arg_typeclass_info(
|
|
/* typeclass_info */ Object[] tcinfo, int index)
|
|
{
|
|
return (/* typeclass_info */ Object[]) tcinfo[index];
|
|
}
|
|
|
|
").
|
|
|
|
:- pragma foreign_code("C#", "
|
|
|
|
public class Ref_1
|
|
{
|
|
// XXX stub only
|
|
}
|
|
|
|
public class Heap_pointer_0
|
|
{
|
|
// XXX stub only
|
|
}
|
|
|
|
public static bool
|
|
__Unify____ref_1_0(runtime.TypeInfo_Struct ti,
|
|
private_builtin.Ref_1 x, private_builtin.Ref_1 y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for ref"");
|
|
return false;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____ref_1_0(runtime.TypeInfo_Struct ti,
|
|
private_builtin.Ref_1 x, private_builtin.Ref_1 y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for ref"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____heap_pointer_0_0(
|
|
private_builtin.Heap_pointer_0 x, private_builtin.Heap_pointer_0 y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for heap_pointer"");
|
|
return false;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____heap_pointer_0_0(
|
|
private_builtin.Heap_pointer_0 x, private_builtin.Heap_pointer_0 y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for heap_pointer"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____type_info_0_0(
|
|
runtime.TypeInfo_Struct x,
|
|
runtime.TypeInfo_Struct y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for type_info"");
|
|
return false;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____type_info_1_0(
|
|
object[] type_info,
|
|
runtime.TypeInfo_Struct x,
|
|
runtime.TypeInfo_Struct y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for type_info"");
|
|
return false;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____typeclass_info_0_0(
|
|
object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for typeclass_info"");
|
|
return false;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____typeclass_info_1_0(
|
|
object[] type_info, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for typeclass_info"");
|
|
return false;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____base_typeclass_info_0_0(
|
|
object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for base_typeclass_info"");
|
|
return false;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____base_typeclass_info_1_0(
|
|
object[] type_info, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for base_typeclass_info"");
|
|
return false;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____type_ctor_info_0_0(
|
|
runtime.TypeCtorInfo_Struct x,
|
|
runtime.TypeCtorInfo_Struct y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for type_ctor_info"");
|
|
return false;
|
|
}
|
|
|
|
public static bool
|
|
__Unify____type_ctor_info_1_0(
|
|
object[] type_info, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""unify for type_ctor_info"");
|
|
return false;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_ctor_info_0_0(
|
|
runtime.TypeCtorInfo_Struct x,
|
|
runtime.TypeCtorInfo_Struct y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for type_ctor_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_ctor_info_1_0(
|
|
object[] type_info, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for type_ctor_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_info_0_0(
|
|
runtime.TypeInfo_Struct x,
|
|
runtime.TypeInfo_Struct y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for type_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_info_1_0(
|
|
object[] type_info,
|
|
runtime.TypeInfo_Struct x,
|
|
runtime.TypeInfo_Struct y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for type_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____typeclass_info_0_0(
|
|
object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for typeclass_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____typeclass_info_1_0(
|
|
object[] type_info, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for typeclass_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____base_typeclass_info_0_0(
|
|
object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for base_typeclass_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____base_typeclass_info_1_0(
|
|
object[] type_info, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.SORRY(""compare for base_typeclass_info"");
|
|
return builtin.Comparison_result_0.f_equal;
|
|
}
|
|
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
|
|
TypeInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
|
|
does_not_affect_liveness],
|
|
"
|
|
TypeInfo = MR_typeclass_info_param_type_info(TypeClassInfo, Index);
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
|
|
TypeInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeInfo = private_builtin.MR_typeclass_info_param_type_info(
|
|
TypeClassInfo, Index);
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
|
|
TypeInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeInfo = jmercury.private_builtin.
|
|
MR_typeclass_info_param_type_info(TypeClassInfo, Index);
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
unconstrained_type_info_from_typeclass_info(TypeClassInfo::in,
|
|
Index::in, TypeInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
|
|
does_not_affect_liveness],
|
|
"
|
|
TypeInfo = MR_typeclass_info_instance_tvar_type_info(TypeClassInfo, Index);
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
unconstrained_type_info_from_typeclass_info(TypeClassInfo::in,
|
|
Index::in, TypeInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeInfo = private_builtin.MR_typeclass_info_instance_tvar_type_info(
|
|
TypeClassInfo, Index);
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
unconstrained_type_info_from_typeclass_info(TypeClassInfo::in,
|
|
Index::in, TypeInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeInfo = jmercury.private_builtin.
|
|
MR_typeclass_info_instance_tvar_type_info(TypeClassInfo, Index);
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
superclass_from_typeclass_info(TypeClassInfo0::in, Index::in,
|
|
TypeClassInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
|
|
does_not_affect_liveness],
|
|
"
|
|
TypeClassInfo =
|
|
MR_typeclass_info_superclass_info(TypeClassInfo0, Index);
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
superclass_from_typeclass_info(TypeClassInfo0::in, Index::in,
|
|
TypeClassInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeClassInfo = private_builtin.MR_typeclass_info_superclass_info(
|
|
TypeClassInfo0, Index);
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
superclass_from_typeclass_info(TypeClassInfo0::in, Index::in,
|
|
TypeClassInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeClassInfo = jmercury.private_builtin.
|
|
MR_typeclass_info_superclass_info(TypeClassInfo0, Index);
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
instance_constraint_from_typeclass_info(TypeClassInfo0::in,
|
|
Index::in, TypeClassInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
|
|
does_not_affect_liveness],
|
|
"
|
|
TypeClassInfo =
|
|
MR_typeclass_info_arg_typeclass_info(TypeClassInfo0, Index);
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
instance_constraint_from_typeclass_info(TypeClassInfo0::in,
|
|
Index::in, TypeClassInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeClassInfo = private_builtin.MR_typeclass_info_arg_typeclass_info(
|
|
TypeClassInfo0, Index);
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
instance_constraint_from_typeclass_info(TypeClassInfo0::in,
|
|
Index::in, TypeClassInfo::out),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
TypeClassInfo = jmercury.private_builtin.
|
|
MR_typeclass_info_arg_typeclass_info(TypeClassInfo0, Index);
|
|
").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% In LLDS grades with float registers, we require a type_ctor_info in
|
|
% closure layouts to represent hidden float values which are passed via
|
|
% regular registers. The standard type_ctor_info represents hidden float
|
|
% arguments passed via float registers.
|
|
%
|
|
|
|
:- interface.
|
|
|
|
:- type float_box
|
|
---> float_box(float).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This section of the module contains predicates that are used by the
|
|
% MLDS back-end to implement trailing. (The LLDS back-end does not use these;
|
|
% instead it handles the corresponding tasks directly during code generation.)
|
|
%
|
|
% These predicates should not be used by user programs directly.
|
|
%
|
|
|
|
:- interface.
|
|
|
|
:- type ticket == c_pointer.
|
|
:- type ticket_counter == c_pointer.
|
|
|
|
% For documentation, see the corresponding LLDS instructions
|
|
% in compiler/llds.m. See also compiler/notes/trailing.html.
|
|
|
|
:- impure pred store_ticket(ticket::out) is det.
|
|
:- impure pred reset_ticket_undo(ticket::in) is det.
|
|
:- impure pred reset_ticket_commit(ticket::in) is det.
|
|
:- impure pred reset_ticket_solve(ticket::in) is det.
|
|
:- impure pred discard_ticket is det.
|
|
:- impure pred prune_ticket is det.
|
|
:- impure pred mark_ticket_stack(ticket_counter::out) is det.
|
|
:- impure pred prune_tickets_to(ticket_counter::in) is det.
|
|
|
|
:- implementation.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
store_ticket(Ticket::out),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_store_ticket(Ticket);
|
|
#else
|
|
Ticket = 0;
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
store_ticket(Ticket::out),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_store_ticket(Ticket);
|
|
#else
|
|
Ticket = null;
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
store_ticket(Ticket::out),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
Ticket = null;
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
reset_ticket_undo(Ticket::in),
|
|
[will_not_call_mercury, thread_safe, does_not_affect_liveness],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_reset_ticket(Ticket, MR_undo);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
reset_ticket_undo(Ticket::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_reset_ticket(Ticket, MR_undo);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
reset_ticket_undo(_Ticket::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
reset_ticket_commit(Ticket::in),
|
|
[will_not_call_mercury, thread_safe, does_not_affect_liveness],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_reset_ticket(Ticket, MR_commit);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
reset_ticket_commit(Ticket::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_reset_ticket(Ticket, MR_commit);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
reset_ticket_commit(_Ticket::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
reset_ticket_solve(Ticket::in),
|
|
[will_not_call_mercury, thread_safe, does_not_affect_liveness],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_reset_ticket(Ticket, MR_solve);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
reset_ticket_solve(Ticket::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_reset_ticket(Ticket, MR_solve);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
reset_ticket_solve(_Ticket::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
discard_ticket,
|
|
[will_not_call_mercury, thread_safe, does_not_affect_liveness],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_discard_ticket();
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
discard_ticket,
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_discard_ticket();
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
discard_ticket,
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
prune_ticket,
|
|
[will_not_call_mercury, thread_safe, does_not_affect_liveness],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_prune_ticket();
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
prune_ticket,
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_prune_ticket();
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
prune_ticket,
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
mark_ticket_stack(TicketCounter::out),
|
|
[will_not_call_mercury, thread_safe, does_not_affect_liveness],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_mark_ticket_stack(TicketCounter);
|
|
#else
|
|
TicketCounter = 0;
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
mark_ticket_stack(TicketCounter::out),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_mark_ticket_stack(TicketCounter);
|
|
#else
|
|
TicketCounter = null;
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
mark_ticket_stack(TicketCounter::out),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
TicketCounter = null;
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
prune_tickets_to(TicketCounter::in),
|
|
[will_not_call_mercury, thread_safe, does_not_affect_liveness],
|
|
"
|
|
#ifdef MR_USE_TRAIL
|
|
MR_prune_tickets_to(TicketCounter);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
prune_tickets_to(TicketCounter::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
#if MR_USE_TRAIL
|
|
runtime.Errors.SORRY(""foreign code for this function"");
|
|
// MR_prune_tickets_to(TicketCounter);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
prune_tickets_to(_TicketCounter::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// XXX No trailing for the Java back-end, so take no action.
|
|
").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This section of the module contains predicates and types that are used
|
|
% internally by the compiler for manipulating the heap.
|
|
%
|
|
% These predicates should not be used by user programs directly.
|
|
%
|
|
|
|
:- interface.
|
|
|
|
% free_heap/1 is used internally by the compiler to implement compile-time
|
|
% garbage collection. (Note that currently compile-time garbage collection
|
|
% is not yet fully implemented.)
|
|
%
|
|
% free_heap/1 explicitly deallocates a cell on the heap. It works by
|
|
% calling GC_free(), which will put the cell on the appropriate free list.
|
|
% It can only be used when doing conservative GC, since with `--gc none'
|
|
% or `--gc accurate', allocation does not use a free list. The `di' mode
|
|
% on the argument is overly conservative -- only the top-level cell is
|
|
% clobbered. This is handled correctly by recompute_instmap_delta in
|
|
% mode_util.
|
|
%
|
|
:- impure pred free_heap(T::di) is det.
|
|
|
|
:- type mutvar(T)
|
|
---> mutvar(c_pointer).
|
|
% A no_tag type, i.e. the representation is just a c_pointer.
|
|
|
|
% gc_trace/1 is used for accurate garbage collection in the MLDS->C
|
|
% backend. It takes as parameters a pointer to a variable (normally on
|
|
% the stack) and, implicitly, a type_info which describes the type of
|
|
% that variable. It traverses the heap object(s) pointed to by that
|
|
% variable, copying them to the new heap area, and updating the variable
|
|
% to point to the new copy. This is done by calling MR_agc_deep_copy()
|
|
% (from runtime/mercury_deep_copy*).
|
|
%
|
|
:- impure pred gc_trace(mutvar(T)::in) is det.
|
|
|
|
% mark_hp/1 and restore_hp/1 are used by the MLDS back-end, to implement
|
|
% heap reclamation on failure. (The LLDS back-end does not use these;
|
|
% instead it inserts the corresponding LLDS instructions directly during
|
|
% code generation.) For documentation, see the corresponding LLDS
|
|
% instructions in compiler/llds.m. See also compiler/notes/trailing.html.
|
|
|
|
:- type heap_pointer.
|
|
|
|
:- impure pred mark_hp(heap_pointer::out) is det.
|
|
:- impure pred restore_hp(heap_pointer::in) is det.
|
|
|
|
% The following is a built-in reference type. It is used to define the
|
|
% types store.generic_ref/2, store.generic_mutvar/2, solutions.mutvar/1,
|
|
% benchmarking.int_ref/0, etc.
|
|
:- type ref(T).
|
|
|
|
:- implementation.
|
|
|
|
% These routines are defined in C in ways which may make it not obvious
|
|
% to the Mercury compiler that they are worth inlining.
|
|
%
|
|
% (Note: it is probably not worth inlining gc_trace/1...)
|
|
|
|
:- pragma inline(pred(free_heap/1)).
|
|
:- pragma inline(pred(mark_hp/1)).
|
|
:- pragma inline(pred(restore_hp/1)).
|
|
|
|
:- pragma foreign_decl("C", "
|
|
#include ""mercury_heap.h"" // for MR_free_heap()
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
gc_trace(Pointer::in),
|
|
[will_not_call_mercury, thread_safe, will_not_modify_trail],
|
|
"
|
|
#ifdef MR_NATIVE_GC
|
|
* (MR_Word *) Pointer =
|
|
MR_agc_deep_copy(* (MR_Word *) Pointer, (MR_TypeInfo) TypeInfo_for_T,
|
|
MR_ENGINE(MR_eng_heap_zone2->MR_zone_min),
|
|
MR_ENGINE(MR_eng_heap_zone2->MR_zone_hardmax));
|
|
#else
|
|
MR_fatal_error(""private_builtin.gc_trace/2: ""
|
|
""called when accurate GC not enabled"");
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
gc_trace(_Pointer::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// For the Java back-end, we use the Java garbage collector,
|
|
// so we take no action here.
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
free_heap(Val::di),
|
|
[will_not_call_mercury, thread_safe, will_not_modify_trail],
|
|
"
|
|
MR_free_heap((void *) Val);
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
free_heap(_Val::di),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// For the Java back-end, we don't define our own heaps.
|
|
// So take no action here.
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
mark_hp(SavedHeapPointer::out),
|
|
[will_not_call_mercury, thread_safe, will_not_modify_trail,
|
|
does_not_affect_liveness],
|
|
"
|
|
#ifndef MR_CONSERVATIVE_GC
|
|
MR_mark_hp(SavedHeapPointer);
|
|
#else
|
|
// We can't do heap reclamation with conservative GC.
|
|
SavedHeapPointer = 0;
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
mark_hp(SavedHeapPointer::out),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// We can't do heap reclamation on failure in the .NET back-end.
|
|
SavedHeapPointer = null;
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
mark_hp(SavedHeapPointer::out),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// We can't do heap reclamation on failure in the Java back-end.
|
|
SavedHeapPointer = null;
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
restore_hp(SavedHeapPointer::in),
|
|
[will_not_call_mercury, thread_safe, will_not_modify_trail,
|
|
does_not_affect_liveness],
|
|
"
|
|
#ifndef MR_CONSERVATIVE_GC
|
|
MR_restore_hp(SavedHeapPointer);
|
|
#endif
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
restore_hp(_SavedHeapPointer::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// We can't do heap reclamation on failure in the .NET back-end.
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
restore_hp(_SavedHeapPointer::in),
|
|
[will_not_call_mercury, thread_safe],
|
|
"
|
|
// We can't do heap reclamation on failure in the Java back-end.
|
|
").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Code to define the heap_pointer and ref types for the .NET back-end.
|
|
% (For the C back-ends, they're defined in runtime/mercury_builtin_types.[ch].)
|
|
|
|
:- pragma foreign_code("C#", "
|
|
|
|
public static bool
|
|
__Unify__private_builtin__heap_pointer_0_0(object[] x, object[] y)
|
|
{
|
|
runtime.Errors.fatal_error(
|
|
""called unify for type `private_builtin:heap_pointer'"");
|
|
return false;
|
|
}
|
|
|
|
public static void
|
|
__Compare__private_builtin__heap_pointer_0_0(
|
|
ref object[] result, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.fatal_error(
|
|
""called compare/3 for type `private_builtin:heap_pointer'"");
|
|
}
|
|
|
|
public static bool
|
|
__Unify__private_builtin__ref_1_0(
|
|
object[] type_info, object[] x, object[] y)
|
|
{
|
|
return x == y;
|
|
}
|
|
|
|
public static void
|
|
__Compare__private_builtin__ref_1_0(
|
|
object[] type_info, ref object[] result, object[] x, object[] y)
|
|
{
|
|
runtime.Errors.fatal_error(
|
|
""called compare/3 for type `private_builtin.ref'"");
|
|
}
|
|
|
|
").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This section of the module is for miscellaneous predicates
|
|
% that sometimes have calls to them emitted by the compiler.
|
|
%
|
|
|
|
:- interface.
|
|
|
|
% unsafe_type_cast/2 is used internally by the compiler.
|
|
% Bad things will happen if this is used in programs.
|
|
% With the LLDS back-end, it has no definition,
|
|
% since for efficiency the code generator treats it as a builtin.
|
|
% With the MLDS back-end, it is defined in runtime/mercury.h.
|
|
%
|
|
:- pred unsafe_type_cast(T1::in, T2::out) is det.
|
|
|
|
% store_at_ref_impure/2 is used internally by the compiler.
|
|
% Bad things will happen if this is used in programs.
|
|
%
|
|
:- impure pred store_at_ref_impure(store_at_ref_type(T)::in, T::in) is det.
|
|
|
|
% This type should be used only by the program transformation that
|
|
% introduces calls to store_at_ref_impure. Any other use is will cause
|
|
% bad things to happen.
|
|
:- type store_at_ref_type(T)
|
|
---> store_at_ref_type(int).
|
|
|
|
% unused/0 should never be called.
|
|
% The compiler sometimes generates references to this procedure,
|
|
% but they should never get executed.
|
|
:- pred unused is det.
|
|
|
|
:- pred nyi_foreign_type_unify(T::in, T::in) is semidet.
|
|
:- pred nyi_foreign_type_compare(comparison_result::uo, T::in, T::in) is det.
|
|
|
|
:- semipure pred trace_evaluate_runtime_condition is semidet.
|
|
|
|
% unify_remote_arg_words(TermVarX, TermVarY, Ptag, CellOffsetVar):
|
|
%
|
|
% Succeed iff the argument words at the given offset are the same
|
|
% in TermVarX and TermVarY.
|
|
%
|
|
:- pred unify_remote_arg_words(T::in, T::in, int::in, int::in) is semidet.
|
|
|
|
% compare_remote_uint_words(TermVarX, TermVarY,
|
|
% Ptag, CellOffsetVar, ResultVar):
|
|
%
|
|
% Set ResultVar to the result of the unsigned comparison between
|
|
% two bitfields in the memory cells of TermVarX and TermVarY.
|
|
% The bitfields occupy the entirety of the words at offset
|
|
% CellOffsetVar.
|
|
%
|
|
:- pred compare_remote_uint_words(T::in, T::in, int::in, int::in,
|
|
comparison_result::uo) is det.
|
|
|
|
% compare_remote_uint_bitfields(TermVarX, TermVarY,
|
|
% Ptag, CellOffsetVar, ShiftVar, NumBitsVar, ResultVar):
|
|
%
|
|
% Set ResultVar to the result of the unsigned comparison between
|
|
% two bitfields in the memory cells of TermVarX and TermVarY.
|
|
% The bitfields are in the word at offset CellOffsetVar, with the
|
|
% LSBs of the bitfields being ShiftVar bits from the LSB of the word.
|
|
% Their size is NumBitsVar bits.
|
|
%
|
|
:- pred compare_remote_uint_bitfields(T::in, T::in, int::in, int::in,
|
|
int::in, int::in, comparison_result::uo) is det.
|
|
|
|
% compare_remote_int{8,16,32}_bitfields(TermVarX, TermVarY,
|
|
% Ptag, CellOffsetVar, ShiftVar, ResultVar):
|
|
%
|
|
% Set ResultVar to the result of the signed comparison between two
|
|
% {8,16,32} bit bitfields in the memory cells of TermVarX and TermVarY.
|
|
% The bitfields are in the word at offset CellOffsetVar, with the
|
|
% LSBs of the bitfields being ShiftVar bits from the LSB of the word.
|
|
%
|
|
:- pred compare_remote_int8_bitfields(T::in, T::in, int::in, int::in, int::in,
|
|
comparison_result::uo) is det.
|
|
:- pred compare_remote_int16_bitfields(T::in, T::in, int::in, int::in, int::in,
|
|
comparison_result::uo) is det.
|
|
:- pred compare_remote_int32_bitfields(T::in, T::in, int::in, int::in, int::in,
|
|
comparison_result::uo) is det.
|
|
|
|
% compare_local_uint_words(TermVarX, TermVarY, ResultVar):
|
|
%
|
|
% Set ResultVar to the result of the unsigned comparison between
|
|
% two bitfields in TermVarX and TermVarY.
|
|
% The bitfields occupy the entirety of the words containing
|
|
% the terms themselves.
|
|
%
|
|
:- pred compare_local_uint_words(T::in, T::in,
|
|
comparison_result::uo) is det.
|
|
|
|
% compare_local_uint_bitfields(TermVarX, TermVarY,
|
|
% ShiftVar, NumBitsVar, ResultVar):
|
|
%
|
|
% Set ResultVar to the result of the unsigned comparison between
|
|
% two bitfields in TermVarX and TermVarY.
|
|
% The bitfields are in the term words themselves, with the LSBs
|
|
% of the bitfields being ShiftVar bits from the LSB of the word.
|
|
% Their size is NumBitsVar bits.
|
|
%
|
|
:- pred compare_local_uint_bitfields(T::in, T::in, int::in, int::in,
|
|
comparison_result::uo) is det.
|
|
|
|
% compare_local_int{8,16,32}_bitfields(TermVarX, TermVarY,
|
|
% ShiftVar, ResultVar):
|
|
%
|
|
% Set ResultVar to the result of the signed comparison between two
|
|
% {8,16,32} bit bitfields in TermVarX and TermVarY.
|
|
% The bitfields are in the term words themselves, with the LSBs
|
|
% of the bitfields being ShiftVar bits from the LSB of the word.
|
|
%
|
|
:- pred compare_local_int8_bitfields(T::in, T::in, int::in,
|
|
comparison_result::uo) is det.
|
|
:- pred compare_local_int16_bitfields(T::in, T::in, int::in,
|
|
comparison_result::uo) is det.
|
|
:- pred compare_local_int32_bitfields(T::in, T::in, int::in,
|
|
comparison_result::uo) is det.
|
|
|
|
% This builtin is used by direct_arg_in_out.m.
|
|
%
|
|
% When we fill in the only argument of a partially-instantiated term
|
|
% whose top function symbol has a direct_arg_tag representation,
|
|
% that filling-in updates the non-ptag bits of a local variable.
|
|
% This local variable of course may (and often will) have a different
|
|
% value after the filling-in than it did before. When a predicate
|
|
% is supposed to return the filled-in value, we need to return it
|
|
% in a separate value, since the initial not-yet-filled-in value
|
|
% will have been passed using call-by-value. (This is github issue #72.)
|
|
%
|
|
% We use separate variables in a procedure body to represent the
|
|
% before-fill-in and after-fill-in versions of such variables
|
|
% when the filling-in is done by a call. When the filling-in is done
|
|
% by a unification, that unification's LHS variable will stand for
|
|
% both the pre-fill-in and post-fill-in versions of that value,
|
|
% at the start and end of its execution respectively. This is
|
|
% different from the call case.
|
|
%
|
|
% Arranging for all branches of a branched control structure to have
|
|
% a consistent view of the fill-in state of such an initially partially
|
|
% instantiated term is significantly easier when distinct variables
|
|
% represent distinct stages of filling-in, so we want to adopt that
|
|
% consistently. This is why, immediately after a unification does
|
|
% such a fill-in, we put a call to partial_inst_copy, with the
|
|
% just-filled-in variable as the first argument and a fresh new
|
|
% variable as the second. Operationally, this call assigns its first
|
|
% argument to its second, preserving its instantiation state, but its mode
|
|
% also says that the first argument should never be referenced again.
|
|
% If direct_arg_in_out.m's transformation of the procedure body ever
|
|
% violates this rule, the error will be detected when the instmap deltas
|
|
% are recomputed just after that transformation is completed.
|
|
%
|
|
:- pred partial_inst_copy(T, T).
|
|
:- mode partial_inst_copy(I >> clobbered, free >> I) is det.
|
|
|
|
:- implementation.
|
|
|
|
unused :-
|
|
( if semidet_succeed then
|
|
error("attempted use of dead predicate")
|
|
else
|
|
% the following is never executed
|
|
true
|
|
).
|
|
|
|
nyi_foreign_type_unify(_, _) :-
|
|
( if semidet_succeed then
|
|
sorry("unify for foreign types")
|
|
else
|
|
semidet_succeed
|
|
).
|
|
|
|
nyi_foreign_type_compare(Result, _, _) :-
|
|
( if semidet_succeed then
|
|
sorry("compare for foreign types")
|
|
else
|
|
Result = (=)
|
|
).
|
|
|
|
:- pragma foreign_proc("C",
|
|
trace_evaluate_runtime_condition,
|
|
[will_not_call_mercury, thread_safe, promise_semipure,
|
|
does_not_affect_liveness],
|
|
"
|
|
/* All uses of this predicate should override the body. */
|
|
MR_fatal_error(""trace_evaluate_runtime_condition called"");
|
|
").
|
|
:- pragma foreign_proc("C#",
|
|
trace_evaluate_runtime_condition,
|
|
[will_not_call_mercury, thread_safe, promise_semipure,
|
|
does_not_affect_liveness],
|
|
"
|
|
// All uses of this predicate should override the body.
|
|
throw new System.Exception(
|
|
""trace_evaluate_runtime_condition called"");
|
|
").
|
|
:- pragma foreign_proc("Java",
|
|
trace_evaluate_runtime_condition,
|
|
[will_not_call_mercury, thread_safe, promise_semipure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
if (true) {
|
|
/* All uses of this predicate should override the body. */
|
|
throw new java.lang.RuntimeException(
|
|
""trace_evaluate_runtime_condition called"");
|
|
}
|
|
").
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
unify_remote_arg_words(TermVarX::in, TermVarY::in,
|
|
Ptag::in, CellOffsetVar::in),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned *cell_x;
|
|
MR_Unsigned *cell_y;
|
|
cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag);
|
|
cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag);
|
|
MR_Unsigned word_x = cell_x[CellOffsetVar];
|
|
MR_Unsigned word_y = cell_y[CellOffsetVar];
|
|
SUCCESS_INDICATOR = (word_x == word_y);
|
|
").
|
|
|
|
unify_remote_arg_words(_, _, _, _) :-
|
|
semidet_fail.
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_remote_uint_words(TermVarX::in, TermVarY::in,
|
|
Ptag::in, CellOffsetVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned *cell_x;
|
|
MR_Unsigned *cell_y;
|
|
cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag);
|
|
cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag);
|
|
MR_Unsigned word_x = cell_x[CellOffsetVar];
|
|
MR_Unsigned word_y = cell_y[CellOffsetVar];
|
|
if (word_x < word_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (word_x > word_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_remote_uint_words(_, _, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_remote_int32_words called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_remote_uint_bitfields(TermVarX::in, TermVarY::in,
|
|
Ptag::in, CellOffsetVar::in, ShiftVar::in, NumBitsVar::in,
|
|
ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned *cell_x;
|
|
MR_Unsigned *cell_y;
|
|
cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag);
|
|
cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag);
|
|
MR_Unsigned word_x = cell_x[CellOffsetVar];
|
|
MR_Unsigned word_y = cell_y[CellOffsetVar];
|
|
MR_Unsigned value_x = ((word_x >> ShiftVar) & ((1 << NumBitsVar) - 1));
|
|
MR_Unsigned value_y = ((word_y >> ShiftVar) & ((1 << NumBitsVar) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_remote_uint_bitfields(_, _, _, _, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_remote_int32_bitfields called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_remote_int8_bitfields(TermVarX::in, TermVarY::in,
|
|
Ptag::in, CellOffsetVar::in, ShiftVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned *cell_x;
|
|
MR_Unsigned *cell_y;
|
|
cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag);
|
|
cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag);
|
|
MR_Unsigned word_x = cell_x[CellOffsetVar];
|
|
MR_Unsigned word_y = cell_y[CellOffsetVar];
|
|
int8_t value_x = (int8_t) ((word_x >> ShiftVar) & ((1 << 8) - 1));
|
|
int8_t value_y = (int8_t) ((word_y >> ShiftVar) & ((1 << 8) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_remote_int8_bitfields(_, _, _, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_remote_int8_bitfields called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_remote_int16_bitfields(TermVarX::in, TermVarY::in,
|
|
Ptag::in, CellOffsetVar::in, ShiftVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned *cell_x;
|
|
MR_Unsigned *cell_y;
|
|
cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag);
|
|
cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag);
|
|
MR_Unsigned word_x = cell_x[CellOffsetVar];
|
|
MR_Unsigned word_y = cell_y[CellOffsetVar];
|
|
int16_t value_x = (int16_t) ((word_x >> ShiftVar) & ((1 << 16) - 1));
|
|
int16_t value_y = (int16_t) ((word_y >> ShiftVar) & ((1 << 16) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_remote_int16_bitfields(_, _, _, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_remote_int16_bitfields called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_remote_int32_bitfields(TermVarX::in, TermVarY::in,
|
|
Ptag::in, CellOffsetVar::in, ShiftVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
#ifdef MR_MERCURY_IS_64_BITS
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned *cell_x;
|
|
MR_Unsigned *cell_y;
|
|
cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag);
|
|
cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag);
|
|
MR_Unsigned word_x = cell_x[CellOffsetVar];
|
|
MR_Unsigned word_y = cell_y[CellOffsetVar];
|
|
int32_t value_x =
|
|
(int32_t) ((word_x >> ShiftVar) & ((INT64_C(1) << 32) - 1));
|
|
int32_t value_y =
|
|
(int32_t) ((word_y >> ShiftVar) & ((INT64_C(1) << 32) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
#else
|
|
MR_fatal_error(""compare_remote_int32_bitfields called on ""
|
|
""non-64-bit system"");
|
|
#endif
|
|
").
|
|
|
|
compare_remote_int32_bitfields(_, _, _, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_remote_int32_bitfields called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_local_uint_words(TermVarX::in, TermVarY::in,
|
|
ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned value_x = (MR_Unsigned) TermVarX;
|
|
MR_Unsigned value_y = (MR_Unsigned) TermVarY;
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_local_uint_words(_, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_local_uint_words called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_local_uint_bitfields(TermVarX::in, TermVarY::in,
|
|
ShiftVar::in, NumBitsVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned word_x = (MR_Unsigned) TermVarX;
|
|
MR_Unsigned word_y = (MR_Unsigned) TermVarY;
|
|
MR_Unsigned value_x = ((word_x >> ShiftVar) & ((1 << NumBitsVar) - 1));
|
|
MR_Unsigned value_y = ((word_y >> ShiftVar) & ((1 << NumBitsVar) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_local_uint_bitfields(_, _, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_local_uint_bitfields called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_local_int8_bitfields(TermVarX::in, TermVarY::in,
|
|
ShiftVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned word_x = (MR_Unsigned) TermVarX;
|
|
MR_Unsigned word_y = (MR_Unsigned) TermVarY;
|
|
int8_t value_x = (int8_t) ((word_x >> ShiftVar) & ((1 << 8) - 1));
|
|
int8_t value_y = (int8_t) ((word_y >> ShiftVar) & ((1 << 8) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_local_int8_bitfields(_, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_local_int8_bitfields called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_local_int16_bitfields(TermVarX::in, TermVarY::in,
|
|
ShiftVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned word_x = (MR_Unsigned) TermVarX;
|
|
MR_Unsigned word_y = (MR_Unsigned) TermVarY;
|
|
int16_t value_x = (int16_t) ((word_x >> ShiftVar) & ((1 << 16) - 1));
|
|
int16_t value_y = (int16_t) ((word_y >> ShiftVar) & ((1 << 16) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
").
|
|
|
|
compare_local_int16_bitfields(_, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_local_int16_bitfields called")
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- pragma foreign_proc("C",
|
|
compare_local_int32_bitfields(TermVarX::in, TermVarY::in,
|
|
ShiftVar::in, ResultVar::uo),
|
|
[will_not_call_mercury, thread_safe, promise_pure,
|
|
does_not_affect_liveness, may_not_duplicate],
|
|
"
|
|
#ifdef MR_MERCURY_IS_64_BITS
|
|
// All uses of this predicate should override the body,
|
|
// but just in case they don't ...
|
|
MR_Unsigned word_x = (MR_Unsigned) TermVarX;
|
|
MR_Unsigned word_y = (MR_Unsigned) TermVarY;
|
|
int32_t value_x =
|
|
(int32_t) ((word_x >> ShiftVar) & ((INT64_C(1) << 32) - 1));
|
|
int32_t value_y =
|
|
(int32_t) ((word_y >> ShiftVar) & ((INT64_C(1) << 32) - 1));
|
|
if (value_x < value_y) {
|
|
ResultVar = MR_COMPARE_LESS;
|
|
} else if (value_x > value_y) {
|
|
ResultVar = MR_COMPARE_GREATER;
|
|
} else {
|
|
ResultVar = MR_COMPARE_EQUAL;
|
|
}
|
|
#else
|
|
MR_fatal_error(""compare_local_int32_bitfields called on ""
|
|
""non-64-bit system"");
|
|
#endif
|
|
").
|
|
|
|
compare_local_int32_bitfields(_, _, _, Result) :-
|
|
( if semidet_fail then
|
|
Result = (=)
|
|
else
|
|
error("compare_local_int32_bitfields called")
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This section of the module is for miscellaneous predicates
|
|
% that are useful in other modules of the Mercury standard library.
|
|
%
|
|
|
|
:- interface.
|
|
|
|
% var/1 is intended to make it possible to write code that effectively has
|
|
% different implementations for different modes. It has to be impure
|
|
% to ensure that reordering doesn't cause the wrong mode to be selected.
|
|
%
|
|
:- impure pred var(T).
|
|
:- mode var(ui) is failure.
|
|
:- mode var(in) is failure.
|
|
:- mode var(unused) is det.
|
|
|
|
:- impure pred nonvar(T).
|
|
:- mode nonvar(ui) is det.
|
|
:- mode nonvar(in) is det.
|
|
:- mode nonvar(unused) is failure.
|
|
|
|
% no_clauses/1 is used to report a run-time error when there is a call
|
|
% to a procedure for which there are no clauses, and the procedure was
|
|
% compiled with `--allow-stubs' and is not part of the Mercury standard
|
|
% library. (If the procedure is part of the Mercury standard library,
|
|
% the compiler will generate a call to sorry/1 instead of no_clauses/1.)
|
|
%
|
|
:- pred no_clauses(string::in) is erroneous.
|
|
|
|
% sorry/1 is used to apologize about the fact that we have not implemented
|
|
% some predicate or function in the Mercury standard library for a given
|
|
% back end. The argument should give the name of the predicate or function.
|
|
%
|
|
:- pred sorry(string::in) is erroneous.
|
|
|
|
% imp/0 is used to make pure predicates impure.
|
|
%
|
|
:- impure pred imp is det.
|
|
|
|
% semip/0 is used to make pure predicates semipure.
|
|
%
|
|
:- semipure pred semip is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
var(_::ui) :- fail.
|
|
var(_::in) :- fail.
|
|
var(_::unused) :- true.
|
|
|
|
nonvar(_::ui) :- true.
|
|
nonvar(_::in) :- true.
|
|
nonvar(_::unused) :- fail.
|
|
|
|
no_clauses(PredName) :-
|
|
error("no clauses for " ++ PredName).
|
|
|
|
sorry(PredName) :-
|
|
error("sorry, " ++ PredName ++ " not implemented\n" ++
|
|
"for this target language (or compiler back-end).").
|
|
|
|
:- pragma foreign_proc("C",
|
|
imp,
|
|
[will_not_call_mercury, thread_safe, will_not_modify_trail],
|
|
"").
|
|
:- pragma foreign_proc("C#",
|
|
imp,
|
|
[will_not_call_mercury, thread_safe],
|
|
"").
|
|
:- pragma foreign_proc("Java",
|
|
imp,
|
|
[will_not_call_mercury, thread_safe],
|
|
"").
|
|
|
|
:- pragma foreign_proc("C",
|
|
semip,
|
|
[will_not_call_mercury, thread_safe, promise_semipure,
|
|
will_not_modify_trail],
|
|
"").
|
|
:- pragma foreign_proc("C#",
|
|
semip,
|
|
[will_not_call_mercury, thread_safe, promise_semipure],
|
|
"").
|
|
:- pragma foreign_proc("Java",
|
|
semip,
|
|
[will_not_call_mercury, thread_safe, promise_semipure],
|
|
"").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Foreign language code defining miscellaneous stuff related to types.
|
|
% XXX The foreign_code pragmas below define different things for the
|
|
% different languages. All these should probably be somewhere else.
|
|
%
|
|
|
|
:- pragma foreign_decl("C", "
|
|
|
|
#include ""mercury_builtin_types.h""
|
|
|
|
MR_DECLARE_TYPE_CTOR_INFO_STRUCT(MR_TYPE_CTOR_INFO_NAME(list, list, 1));
|
|
MR_DECLARE_TYPE_CTOR_INFO_STRUCT(MR_TYPE_CTOR_INFO_NAME(univ, univ, 0));
|
|
|
|
").
|
|
|
|
:- pragma foreign_code("C", "
|
|
|
|
const MR_TypeCtorInfo ML_type_ctor_info_for_univ =
|
|
&MR_TYPE_CTOR_INFO_NAME(univ, univ, 0);
|
|
|
|
const MR_TypeCtorInfo ML_type_info_for_type_info =
|
|
&MR_TYPE_CTOR_INFO_NAME(private_builtin, type_info, 0);
|
|
|
|
const MR_TypeCtorInfo ML_type_info_for_pseudo_type_info =
|
|
/*
|
|
** For the time being, we handle pseudo_type_infos the same way
|
|
** as we handle type_infos.
|
|
*/
|
|
&MR_TYPE_CTOR_INFO_NAME(private_builtin, type_info, 0);
|
|
|
|
const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_univ = {
|
|
&MR_TYPE_CTOR_INFO_NAME(list, list, 1),
|
|
{ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(univ, univ, 0) }
|
|
};
|
|
|
|
const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_int = {
|
|
&MR_TYPE_CTOR_INFO_NAME(list, list, 1),
|
|
{ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, int, 0) }
|
|
};
|
|
|
|
const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_char = {
|
|
&MR_TYPE_CTOR_INFO_NAME(list, list, 1),
|
|
{ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, character, 0) }
|
|
};
|
|
|
|
const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_string = {
|
|
&MR_TYPE_CTOR_INFO_NAME(list, list, 1),
|
|
{ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, string, 0) }
|
|
};
|
|
|
|
const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_type_info = {
|
|
&MR_TYPE_CTOR_INFO_NAME(list, list, 1),
|
|
{ (MR_TypeInfo) &ML_type_info_for_type_info }
|
|
};
|
|
|
|
const MR_FA_TypeInfo_Struct1 ML_type_info_for_list_of_pseudo_type_info = {
|
|
&MR_TYPE_CTOR_INFO_NAME(list, list, 1),
|
|
/*
|
|
** For the time being, we handle pseudo_type_infos the same way
|
|
** as we handle type_infos.
|
|
*/
|
|
{ (MR_TypeInfo) &ML_type_info_for_type_info }
|
|
};
|
|
|
|
").
|
|
|
|
:- pragma foreign_code("Java", "
|
|
public static class Ref_1
|
|
{
|
|
// XXX stub only
|
|
}
|
|
|
|
public static class Heap_pointer_0
|
|
{
|
|
// XXX stub only
|
|
}
|
|
|
|
public static final int MR_SECTAG_NONE = 0;
|
|
public static final int MR_SECTAG_NONE_DIRECT_ARG = 1;
|
|
public static final int MR_SECTAG_LOCAL = 2;
|
|
public static final int MR_SECTAG_LOCAL_REST_OF_WORD = 2; // synonym
|
|
public static final int MR_SECTAG_REMOTE = 3;
|
|
public static final int MR_SECTAG_REMOTE_FULL_WORD = 3; // synonym
|
|
public static final int MR_SECTAG_VARIABLE = 4;
|
|
// These are never used in Java grades.
|
|
// public static final int MR_SECTAG_LOCAL_BITS = 5;
|
|
// public static final int MR_SECTAG_REMOTE_BITS = 6;
|
|
|
|
public static final int MR_FUNCTOR_SUBTYPE_NONE = 0;
|
|
public static final int MR_FUNCTOR_SUBTYPE_EXISTS = 1;
|
|
|
|
public static final int MR_PREDICATE = 0;
|
|
public static final int MR_FUNCTION = 1;
|
|
|
|
// The dummy_var is used to represent io.states and values of other types
|
|
// (dummy types) that contain no information. Occasionally a dummy variable
|
|
// will be used by the code generator as an lval, so we use
|
|
// private_builtin.dummy_var as that lval.
|
|
public static java.lang.Object dummy_var;
|
|
").
|
|
|
|
:- pragma foreign_code("C#", "
|
|
// The dummy_var is used to represent io.states and values of other types
|
|
// (dummy types) that contain no information. Occasionally a dummy variable
|
|
// will be used by the code generator as an lval, so we use
|
|
// private_builtin.dummy_var as that lval.
|
|
public static object dummy_var;
|
|
").
|
|
|
|
:- pragma foreign_code("Java", "
|
|
// Type-specific unification and comparison routines.
|
|
|
|
public static boolean
|
|
__Unify____ref_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
private_builtin.Ref_1 x, private_builtin.Ref_1 y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""unify/2 for type private_builtin.ref not implemented"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____heap_pointer_0_0 (private_builtin.Heap_pointer_0 x,
|
|
private_builtin.Heap_pointer_0 y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error(""unify/2 for type heap_pointer/0"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____type_ctor_info_0_0(
|
|
jmercury.runtime.TypeCtorInfo_Struct x,
|
|
jmercury.runtime.TypeCtorInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""unify/2 for type type_ctor_info/1"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____type_ctor_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
jmercury.runtime.TypeCtorInfo_Struct x,
|
|
jmercury.runtime.TypeCtorInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""unify/2 for type type_ctor_info/1"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____type_info_0_0(
|
|
jmercury.runtime.TypeInfo_Struct x,
|
|
jmercury.runtime.TypeInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""unify/2 for type type_info/0"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____type_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
jmercury.runtime.TypeInfo_Struct x,
|
|
jmercury.runtime.TypeInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""unify/2 for type type_info/0"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____base_typeclass_info_0_0(
|
|
java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error(""unify/2 for type typeclass_info/0"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____base_typeclass_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error(""unify/2 for type typeclass_info/0"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____typeclass_info_0_0(java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""unify/2 for type typeclass_info/1"");
|
|
}
|
|
|
|
public static boolean
|
|
__Unify____typeclass_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""unify/2 for type typeclass_info/1"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____ref_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
private_builtin.Ref_1 x, private_builtin.Ref_1 y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""called compare/3 for type private_builtin.ref"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____heap_pointer_0_0 (
|
|
private_builtin.Heap_pointer_0 x,
|
|
private_builtin.Heap_pointer_0 y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error(""compare/2 for type heap_pointer/0"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_ctor_info_0_0(
|
|
jmercury.runtime.TypeCtorInfo_Struct x,
|
|
jmercury.runtime.TypeCtorInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""compare/2 for type type_ctor_info/1"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_ctor_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
jmercury.runtime.TypeCtorInfo_Struct x,
|
|
jmercury.runtime.TypeCtorInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""compare/2 for type type_ctor_info/1"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_info_0_0(
|
|
jmercury.runtime.TypeInfo_Struct x,
|
|
jmercury.runtime.TypeInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""compare/2 for type type_info/0"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____type_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
jmercury.runtime.TypeInfo_Struct x,
|
|
jmercury.runtime.TypeInfo_Struct y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""compare/2 for type type_info/0"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____base_typeclass_info_0_0(
|
|
java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error(""compare/2 for type typeclass_info/1"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____base_typeclass_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error(""compare/2 for type typeclass_info/1"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____typeclass_info_0_0(java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""compare/2 for type typeclass_info/0"");
|
|
}
|
|
|
|
public static builtin.Comparison_result_0
|
|
__Compare____typeclass_info_1_0(jmercury.runtime.TypeInfo_Struct ti,
|
|
java.lang.Object[] x, java.lang.Object[] y)
|
|
{
|
|
// stub only
|
|
throw new java.lang.Error
|
|
(""compare/2 for type typeclass_info/0"");
|
|
}
|
|
|
|
").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module private_builtin.
|
|
%---------------------------------------------------------------------------%
|