[m-rev.] diff: break up some large modules
Zoltan Somogyi
zs at csse.unimelb.edu.au
Fri Sep 25 15:12:19 AEST 2009
Divide the old 4100, 2900 and 4600 line modules ml_code_gen.m, ml_code_util.m
and modes.m into smaller, more cohesive modules. In the process, put
related predicates next to each other. There are no algorithmic changes.
compiler/ml_proc_gen.m:
New module that looks after code generation tasks that affect a
procedure as a whole. Its code is taken from the old ml_code_gen.m.
Analogous to proc_gen.m, which does the same job for the LLDS backend.
compiler/ml_foreign_proc_gen.m:
New module that generates code for foreign_proc goals.
Its code is taken from the old ml_code_gen.m.
Analogous to pragma_c_gen.m in the LLDS backend.
compiler/ml_commit_gen.m:
New module that generates code for commit goals.
Its code is taken from the old ml_code_gen.m.
Analogous to commit_gen.m in the LLDS backend.
compiler/ml_gen_info.m:
New module that encapsulates the ml_gen_info structure.
Its code is taken from the old ml_code_util.m.
Analogous to code_info.m in the LLDS backend.
compiler/ml_accurate_gc.m:
New module that generates the data and goals needed for accurate gc.
Its code is taken from the old ml_code_util.m.
compiler/ml_call_gen.m:
compiler/ml_closure_gen.m:
Move some predicates that are used by other modules of the MLDS backend
to ml_code_util, in order to avoid otherwise unneeded dependencies.
compiler/mode_util.m:
Move a predicate here from ml_code_util.m, since it is needed by
several MLDS backend modules but is not MLDS specific.
compiler/ml_code_gen.m:
Remove the code moved to other modules.
Delete an old note about a problem fixed long ago.
compiler/ml_code_util.m:
Remove the code moved to other modules.
Add the code moved here from other modules.
compiler/modecheck_conj.m:
New module that handles mode analysis of conjunctions.
Its code is taken from the old modes.m.
compiler/modecheck_goal.m:
New module that handles mode analysis of most types of goals,
except conjunctions, unifications and calls.
Its code is taken from the old modes.m.
compiler/modecheck_util.m:
New module containing utility predicates used more one of the modules
do mode analysis. Its code is taken from the old modes.m.
compiler/mode_util.m:
Move a predicate here from modes.m, since this is where a related
predicate already is.
Give a predicate a more meaningful name.
compiler/goal_util.m:
Move a predicate here from modes.m, since this is where a related
predicate already is.
compiler/modes.m:
Remove the code moved to other modules.
compiler/ml_backend.m:
compiler/check_hlds.m:
Add the new modules.
compiler/notes/compiler_design.html:
Document the new modules.
compiler/prog_data.m:
Give some function symbols disambiguating prefixes.
compiler/add_solver.m:
compiler/deforest.m:
compiler/make_hlds_passes.m:
compiler/mercury_compile.m:
compiler/ml_lookup_switch.m:
compiler/ml_simplify_switch.m:
compiler/ml_string.m:
compiler/ml_switch_gen.m:
compiler/ml_tag_switch.m:
compiler/ml_unify_gen.m:
compiler/modecheck_call.m:
compiler/modecheck_unify.m:
compiler/prog_io_type_defn.m:
compiler/rtti_to_mlds.m:
compiler/type_ctor_info.m:
compiler/unify_proc.m:
Conform to the changes above.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/add_solver.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_solver.m,v
retrieving revision 1.22
diff -u -b -r1.22 add_solver.m
--- compiler/add_solver.m 28 Jul 2008 08:34:16 -0000 1.22
+++ compiler/add_solver.m 24 Sep 2009 04:22:30 -0000
@@ -79,9 +79,9 @@
SolverType = defined_type(TypeSymName, Args, kind_star),
Arity = length(TypeParams),
- RepnType = SolverTypeDetails ^ representation_type,
- AnyInst = SolverTypeDetails ^ any_inst,
- GroundInst = SolverTypeDetails ^ ground_inst,
+ RepnType = SolverTypeDetails ^ std_representation_type,
+ AnyInst = SolverTypeDetails ^ std_any_inst,
+ GroundInst = SolverTypeDetails ^ std_ground_inst,
InAnyMode = in_mode(AnyInst),
InGroundMode = in_mode(GroundInst),
@@ -184,8 +184,8 @@
Context, !Status, !ModuleInfo, !QualInfo, !Specs) :-
Arity = length(TypeParams),
- AnyInst = SolverTypeDetails ^ any_inst,
- GroundInst = SolverTypeDetails ^ ground_inst,
+ AnyInst = SolverTypeDetails ^ std_any_inst,
+ GroundInst = SolverTypeDetails ^ std_ground_inst,
InAnyMode = in_mode(AnyInst),
InGroundMode = in_mode(GroundInst),
Index: compiler/check_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/check_hlds.m,v
retrieving revision 1.22
diff -u -b -r1.22 check_hlds.m
--- compiler/check_hlds.m 10 Mar 2009 05:00:28 -0000 1.22
+++ compiler/check_hlds.m 24 Sep 2009 03:22:29 -0000
@@ -46,8 +46,11 @@
:- include_module mode_info.
:- include_module mode_ordering.
:- include_module mode_util.
+ :- include_module modecheck_goal.
+ :- include_module modecheck_conj.
:- include_module modecheck_call.
:- include_module modecheck_unify.
+ :- include_module modecheck_util.
:- include_module modes.
:- include_module unify_proc.
:- include_module unique_modes.
Index: compiler/deforest.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deforest.m,v
retrieving revision 1.91
diff -u -b -r1.91 deforest.m
--- compiler/deforest.m 8 Sep 2009 02:43:31 -0000 1.91
+++ compiler/deforest.m 24 Sep 2009 03:01:31 -0000
@@ -52,7 +52,7 @@
:- import_module check_hlds.det_report.
:- import_module check_hlds.inst_match.
:- import_module check_hlds.mode_util.
-:- import_module check_hlds.modes.
+:- import_module check_hlds.modecheck_util.
:- import_module check_hlds.simplify.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_goal.
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.170
diff -u -b -r1.170 goal_util.m
--- compiler/goal_util.m 3 Sep 2009 23:57:24 -0000 1.170
+++ compiler/goal_util.m 24 Sep 2009 01:34:26 -0000
@@ -262,6 +262,8 @@
%
:- pred flatten_conj(list(hlds_goal)::in, list(hlds_goal)::out) is det.
+:- func flatten_disjs(list(hlds_goal)) = list(hlds_goal).
+
% Create a conjunction of the specified type using the specified goals,
% This fills in the hlds_goal_info.
%
@@ -1478,6 +1480,17 @@
Goals = [Goal | Goals1]
).
+flatten_disjs(Disjs) = list.foldr(flatten_disj, Disjs, []).
+
+:- func flatten_disj(hlds_goal, list(hlds_goal)) = list(hlds_goal).
+
+flatten_disj(Disj, Disjs0) = Disjs :-
+ ( Disj = hlds_goal(disj(Disjs1), _GoalInfo) ->
+ Disjs = list.foldr(flatten_disj, Disjs1, Disjs0)
+ ;
+ Disjs = [Disj | Disjs0]
+ ).
+
%-----------------------------------------------------------------------------%
create_conj(GoalA, GoalB, Type, ConjGoal) :-
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.92
diff -u -b -r1.92 make_hlds_passes.m
--- compiler/make_hlds_passes.m 4 Sep 2009 02:27:52 -0000 1.92
+++ compiler/make_hlds_passes.m 24 Sep 2009 04:23:18 -0000
@@ -375,8 +375,9 @@
( TypeDefn = parse_tree_solver_type(SolverTypeDetails, _MaybeUserEqComp) ->
add_solver_type_decl_items(TVarSet, SymName, TypeParams,
SolverTypeDetails, Context, !Status, !ModuleInfo, !Specs),
- add_solver_type_mutable_items_pass_1(SolverTypeDetails ^ mutable_items,
- !Status, !ModuleInfo, !Specs)
+ MutableItems = SolverTypeDetails ^ std_mutable_items,
+ add_solver_type_mutable_items_pass_1(MutableItems, !Status,
+ !ModuleInfo, !Specs)
;
true
).
@@ -717,8 +718,9 @@
module_add_type_defn(VarSet, Name, Args, TypeDefn, Cond, Context,
Status, !ModuleInfo, !Specs),
( TypeDefn = parse_tree_solver_type(SolverTypeDetails, _MaybeUserEqComp) ->
- add_solver_type_mutable_items_pass_2(SolverTypeDetails ^ mutable_items,
- Status, _, !ModuleInfo, !Specs)
+ MutableItems = SolverTypeDetails ^ std_mutable_items,
+ add_solver_type_mutable_items_pass_2(MutableItems, Status, _,
+ !ModuleInfo, !Specs)
;
true
).
@@ -1107,7 +1109,7 @@
->
add_solver_type_clause_items(SymName, TypeParams, SolverTypeDetails,
Context, Status, _, !ModuleInfo, !QualInfo, !Specs),
- MutableItems = SolverTypeDetails ^ mutable_items,
+ MutableItems = SolverTypeDetails ^ std_mutable_items,
add_solver_type_mutable_items_clauses(MutableItems, Status, _,
!ModuleInfo, !QualInfo, !Specs)
;
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.504
diff -u -b -r1.504 mercury_compile.m
--- compiler/mercury_compile.m 21 Sep 2009 04:08:54 -0000 1.504
+++ compiler/mercury_compile.m 23 Sep 2009 13:43:34 -0000
@@ -145,7 +145,7 @@
:- import_module ml_backend.add_heap_ops. % HLDS -> HLDS
:- import_module ml_backend.mark_static_terms. % HLDS -> HLDS
:- import_module ml_backend.mlds. % MLDS data structure
-:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_proc_gen.
:- import_module ml_backend.rtti_to_mlds. % HLDS/RTTI -> MLDS
:- import_module ml_backend.ml_elim_nested. % MLDS -> MLDS
:- import_module ml_backend.ml_tailcall. % MLDS -> MLDS
Index: compiler/ml_accurate_gc.m
===================================================================
RCS file: compiler/ml_accurate_gc.m
diff -N compiler/ml_accurate_gc.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/ml_accurate_gc.m 23 Sep 2009 16:20:41 -0000
@@ -0,0 +1,617 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ml_accurate_gc.m.
+% Main author: fjh.
+%
+% This module is part of the MLDS code generator.
+% It generates the data and code required for accurate gc.
+%
+%-----------------------------------------------------------------------------%
+
+:- module ml_backend.ml_accurate_gc.
+:- interface.
+
+:- import_module ml_backend.mlds.
+:- import_module ml_backend.ml_gen_info.
+:- import_module parse_tree.prog_data.
+
+%-----------------------------------------------------------------------------%
+%
+% Code to handle accurate GC.
+%
+
+ % ml_gen_gc_statement(Var, Type, Context, Code):
+ %
+ % If accurate GC is enabled, and the specified variable might contain
+ % pointers, generate code to call `private_builtin.gc_trace' to trace
+ % the variable.
+ %
+:- pred ml_gen_gc_statement(mlds_var_name::in, mer_type::in,
+ prog_context::in, mlds_gc_statement::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % ml_gen_gc_statement_poly(Var, DeclType, ActualType, Context, Code):
+ %
+ % This is the same as ml_gen_gc_statement, except that it takes two
+ % type arguments, rather than one. The first (DeclType) is the type that
+ % the variable was declared with, while the second (ActualType) is that
+ % type that the variable is known to have. This is used to generate GC
+ % tracing code for the temporaries variables used when calling procedures
+ % with polymorphically-typed output arguments. In that case, DeclType
+ % may be a type variable from the callee's type declaration, but ActualType
+ % will be the type from the caller.
+ %
+ % We can't just use DeclType to generate the GC trace code, because there's
+ % no way to compute the type_info for type variables that come from the
+ % callee rather than the current procedure. And we can't just use
+ % ActualType, since DeclType may contain pointers even when ActualType
+ % doesn't (e.g. because DeclType may be a boxed float). So we need to pass
+ % both.
+ %
+:- pred ml_gen_gc_statement_poly(mlds_var_name::in,
+ mer_type::in, mer_type::in, prog_context::in,
+ mlds_gc_statement::out, ml_gen_info::in, ml_gen_info::out) is det.
+
+ % ml_gen_gc_statement_with_typeinfo(Var, DeclType, TypeInfoRval,
+ % Context, Code):
+ %
+ % This is the same as ml_gen_gc_statement_poly, except that rather
+ % than passing ActualType, the caller constructs the typeinfo itself,
+ % and just passes the rval for it to this routine.
+ %
+ % This is used by ml_closure_gen.m to generate GC tracing code
+ % for the the local variables in closure wrapper functions.
+ %
+:- pred ml_gen_gc_statement_with_typeinfo(mlds_var_name::in,
+ mer_type::in, mlds_rval::in, prog_context::in,
+ mlds_gc_statement::out, ml_gen_info::in, ml_gen_info::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module backend_libs.foreign.
+:- import_module check_hlds.polymorphism.
+:- import_module hlds.code_model.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.instmap.
+:- import_module libs.globals.
+:- import_module mdbcomp.prim_data.
+:- import_module mdbcomp.program_representation.
+:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_code_util.
+:- import_module parse_tree.builtin_lib_types.
+:- import_module parse_tree.prog_type.
+
+:- import_module bool.
+:- import_module counter.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module set.
+
+%-----------------------------------------------------------------------------%
+%
+% Code to handle accurate GC.
+%
+
+ml_gen_gc_statement(VarName, Type, Context, GCStatement, !Info) :-
+ ml_gen_gc_statement_poly(VarName, Type, Type, Context, GCStatement, !Info).
+
+ml_gen_gc_statement_poly(VarName, DeclType, ActualType, Context,
+ GCStatement, !Info) :-
+ HowToGetTypeInfo = construct_from_type(ActualType),
+ ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
+ GCStatement, !Info).
+
+ml_gen_gc_statement_with_typeinfo(VarName, DeclType, TypeInfoRval, Context,
+ GCStatement, !Info) :-
+ HowToGetTypeInfo = already_provided(TypeInfoRval),
+ ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
+ GCStatement, !Info).
+
+:- type how_to_get_type_info
+ ---> construct_from_type(mer_type)
+ ; already_provided(mlds_rval).
+
+:- pred ml_gen_gc_statement_2(mlds_var_name::in, mer_type::in,
+ how_to_get_type_info::in, prog_context::in,
+ mlds_gc_statement::out, ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
+ GCStatement, !Info) :-
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_gc_method(Globals, GC),
+ (
+ GC = gc_accurate,
+ MLDS_DeclType = mercury_type_to_mlds_type(ModuleInfo, DeclType),
+ ml_type_might_contain_pointers_for_gc(MLDS_DeclType) = yes,
+ % don't generate GC tracing code in no_type_info_builtins
+ ml_gen_info_get_pred_id(!.Info, PredId),
+ predicate_id(ModuleInfo, PredId, PredModule, PredName, PredArity),
+ \+ no_type_info_builtin(PredModule, PredName, PredArity)
+ ->
+ (
+ HowToGetTypeInfo = construct_from_type(ActualType0),
+ % We need to handle type_info/1 and typeclass_info/1
+ % types specially, to avoid infinite recursion here...
+ ( trace_type_info_type(ActualType0, ActualType1) ->
+ ActualType = ActualType1
+ ;
+ ActualType = ActualType0
+ ),
+ ml_gen_gc_trace_code(VarName, DeclType, ActualType,
+ Context, GC_TraceCode, !Info)
+ ;
+ HowToGetTypeInfo = already_provided(TypeInfoRval),
+ ml_gen_trace_var(!.Info, VarName, DeclType, TypeInfoRval,
+ Context, GC_TraceCode)
+ ),
+ GCStatement = gc_trace_code(GC_TraceCode)
+ ;
+ GCStatement = gc_no_stmt
+ ).
+
+ % Return `yes' if the type needs to be traced by the accurate garbage
+ % collector, i.e. if it might contain pointers.
+ %
+ % Any type for which we return `yes' here must be word-sized, because
+ % we will call private_builtin.gc_trace with its address, and that
+ % procedure assumes that its argument is an `MR_Word *'.
+ %
+ % For floats, we can (and must) return `no' even though they might
+ % get boxed in some circumstances, because if they are boxed then they will
+ % be represented as mlds_generic_type.
+ %
+ % Note that with --gcc-nested-functions, cont_type will be a function
+ % pointer that may point to a trampoline function, which might in fact
+ % contain pointers. But the pointers will only be pointers to code and
+ % pointers to the stack, not pointers to the heap, so we don't need to
+ % trace them for accurate GC. Hence we can return `no' here for
+ % mlds_cont_type.
+ %
+ % Similarly, the only pointers in type_ctor_infos and base_typeclass_infos
+ % are to static code and/or static data, which do not need to be traced.
+ %
+:- func ml_type_might_contain_pointers_for_gc(mlds_type) = bool.
+
+ml_type_might_contain_pointers_for_gc(Type) = MightContainPointers :-
+ (
+ Type = mercury_type(_Type, TypeCategory, _),
+ MightContainPointers =
+ ml_type_category_might_contain_pointers(TypeCategory)
+ ;
+ Type = mlds_class_type(_, _, Category),
+ ( Category = mlds_enum ->
+ MightContainPointers = no
+ ;
+ MightContainPointers = yes
+ )
+ ;
+ ( Type = mlds_mercury_array_type(_)
+ ; Type = mlds_ptr_type(_)
+ ; Type = mlds_array_type(_)
+ ; Type = mlds_generic_type
+ ; Type = mlds_generic_env_ptr_type
+ ; Type = mlds_type_info_type
+ ; Type = mlds_pseudo_type_info_type
+ ; Type = mlds_rtti_type(_)
+ ; Type = mlds_unknown_type
+ ),
+ MightContainPointers = yes
+ ;
+ ( Type = mlds_native_int_type
+ ; Type = mlds_native_float_type
+ ; Type = mlds_native_bool_type
+ ; Type = mlds_native_char_type
+ ; Type = mlds_foreign_type(_)
+ % We assume that foreign types are not allowed to contain pointers
+ % to the Mercury heap. XXX is this requirement too strict?
+ ; Type = mlds_func_type(_)
+ ; Type = mlds_cont_type(_)
+ ; Type = mlds_commit_type
+ ; Type = mlds_tabling_type(_)
+ % Values of mlds_tabling_type types may contain pointers, but
+ % they won't exist if we are using accurate GC.
+ ),
+ MightContainPointers = no
+ ).
+
+:- func ml_type_category_might_contain_pointers(type_ctor_category) = bool.
+
+ml_type_category_might_contain_pointers(CtorCat) = MayContainPointers :-
+ (
+ ( CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_float)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_system(cat_system_type_ctor_info)
+ ; CtorCat = ctor_cat_system(cat_system_base_typeclass_info)
+ ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
+ ),
+ MayContainPointers = no
+ ;
+ ( CtorCat = ctor_cat_builtin(cat_builtin_string)
+ ; CtorCat = ctor_cat_system(cat_system_type_info)
+ ; CtorCat = ctor_cat_system(cat_system_typeclass_info)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_user(cat_user_notag)
+ ; CtorCat = ctor_cat_user(cat_user_general)
+ ),
+ MayContainPointers = yes
+ ).
+
+ % trace_type_info_type(Type, RealType):
+ %
+ % Succeed iff Type is a type_info-related type which needs to be copied
+ % as if it were some other type, binding RealType to that other type.
+ %
+:- pred trace_type_info_type(mer_type::in, mer_type::out) is semidet.
+
+trace_type_info_type(Type, RealType) :-
+ Type = defined_type(TypeName, _, _),
+ TypeName = qualified(PrivateBuiltin, Name),
+ PrivateBuiltin = mercury_private_builtin_module,
+ ( Name = "type_info", RealType = sample_type_info_type
+ ; Name = "type_ctor_info", RealType = c_pointer_type
+ ; Name = "typeclass_info", RealType = sample_typeclass_info_type
+ ; Name = "base_typeclass_info", RealType = c_pointer_type
+ ; Name = "zero_type_info", RealType = sample_type_info_type
+ ; Name = "zero_type_ctor_info", RealType = c_pointer_type
+ ; Name = "zero_typeclass_info", RealType = sample_typeclass_info_type
+ ; Name = "zero_base_typeclass_info", RealType = c_pointer_type
+ ).
+
+ % Generate code to call to `private_builtin.gc_trace'
+ % to trace the specified variable.
+ %
+:- pred ml_gen_gc_trace_code(mlds_var_name::in, mer_type::in, mer_type::in,
+ prog_context::in, statement::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_gc_trace_code(VarName, DeclType, ActualType, Context, GC_TraceCode,
+ !Info) :-
+ % Build HLDS code to construct the type_info for this type.
+ ml_gen_make_type_info_var(ActualType, Context,
+ TypeInfoVar, HLDS_TypeInfoGoals, !Info),
+ NonLocalsList = list.map(
+ (func(hlds_goal(_GX, GI)) = goal_info_get_nonlocals(GI)),
+ HLDS_TypeInfoGoals),
+ NonLocals = set.union_list(NonLocalsList),
+ InstMapDelta = instmap_delta_bind_var(TypeInfoVar),
+ goal_info_init(NonLocals, InstMapDelta, detism_det, purity_impure,
+ GoalInfo),
+ conj_list_to_goal(HLDS_TypeInfoGoals, GoalInfo, Conj),
+
+ % Convert this HLDS code to MLDS.
+ ml_gen_goal_as_block(model_det, Conj, MLDS_TypeInfoStatement0, !Info),
+
+ % Replace all heap allocation (new_object instructions) with stack
+ % allocation (local variable declarations) in the code to construct
+ % type_infos. This is safe because those type_infos will only be used
+ % in the immediately following call to gc_trace/1.
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ module_info_get_name(ModuleInfo, ModuleName),
+ fixup_newobj(MLDS_TypeInfoStatement0,
+ mercury_module_name_to_mlds(ModuleName),
+ MLDS_TypeInfoStatement, MLDS_NewobjLocals),
+
+ % Build MLDS code to trace the variable.
+ ml_gen_var(!.Info, TypeInfoVar, TypeInfoLval),
+ ml_gen_trace_var(!.Info, VarName, DeclType, ml_lval(TypeInfoLval), Context,
+ MLDS_TraceStatement),
+
+ % Generate declarations for any type_info variables used.
+ %
+ % Note: this will generate local declarations even for type_info variables
+ % which are not local to this goal. However, fortunately ml_elim_nested.m
+ % will transform the GC code to use the original definitions, which will
+ % get put in the GC frame, rather than these declarations, which will get
+ % ignored.
+ % XXX This is not a very robust way of doing things...
+ ml_gen_info_get_varset(!.Info, VarSet),
+ ml_gen_info_get_var_types(!.Info, VarTypes),
+ MLDS_Context = mlds_make_context(Context),
+ GenLocalVarDecl =
+ (func(Var) = VarDefn :-
+ LocalVarName = ml_gen_var_name(VarSet, Var),
+ map.lookup(VarTypes, Var, LocalVarType),
+ VarDefn = ml_gen_mlds_var_decl(mlds_data_var(LocalVarName),
+ mercury_type_to_mlds_type(ModuleInfo, LocalVarType),
+ gc_no_stmt, MLDS_Context)
+ ),
+ set.to_sorted_list(NonLocals, NonLocalVarList),
+ MLDS_NonLocalVarDecls = list.map(GenLocalVarDecl, NonLocalVarList),
+
+ % Combine the MLDS code fragments together.
+ GC_TraceCode = ml_gen_block(MLDS_NewobjLocals ++ MLDS_NonLocalVarDecls,
+ [MLDS_TypeInfoStatement, MLDS_TraceStatement], Context).
+
+ % ml_gen_trace_var(VarName, DeclType, TypeInfo, Context, Code):
+ % Generate a call to `private_builtin.gc_trace' for the specified variable,
+ % given the variable's name, type, and the already-constructed type_info
+ % for that type.
+ %
+:- pred ml_gen_trace_var(ml_gen_info::in, mlds_var_name::in, mer_type::in,
+ mlds_rval::in, prog_context::in, statement::out) is det.
+
+ml_gen_trace_var(Info, VarName, Type, TypeInfoRval, Context, TraceStatement) :-
+ % Generate the lval for Var.
+ ml_gen_info_get_module_info(Info, ModuleInfo),
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
+ ml_gen_var_lval(Info, VarName, MLDS_Type, VarLval),
+
+ % Generate the address of `private_builtin.gc_trace/1#0'.
+ PredName = "gc_trace",
+ PredOrigArity = 1,
+ PredLabel = mlds_user_pred_label(pf_predicate, no, PredName, PredOrigArity,
+ model_det, no),
+ ProcId = hlds_pred.initial_proc_id,
+ PredModule = mercury_private_builtin_module,
+ MLDS_Module = mercury_module_name_to_mlds(PredModule),
+ ProcLabel = mlds_proc_label(PredLabel, ProcId),
+ QualProcLabel = qual(MLDS_Module, module_qual, ProcLabel),
+ CPointerType = mercury_type(c_pointer_type,
+ ctor_cat_user(cat_user_general), non_foreign_type(c_pointer_type)),
+ ArgTypes = [mlds_pseudo_type_info_type, CPointerType],
+ Signature = mlds_func_signature(ArgTypes, []),
+ FuncAddr = ml_const(mlconst_code_addr(
+ code_addr_proc(QualProcLabel, Signature))),
+
+ % Generate the call
+ % `private_builtin.gc_trace(TypeInfo, (MR_C_Pointer) &Var);'.
+ CastVarAddr = ml_unop(cast(CPointerType), ml_mem_addr(VarLval)),
+ TraceStmt = ml_stmt_call(Signature, FuncAddr, no,
+ [TypeInfoRval, CastVarAddr], [], ordinary_call),
+ TraceStatement = statement(TraceStmt, mlds_make_context(Context)).
+
+ % Generate HLDS code to construct the type_info for this type.
+ %
+:- pred ml_gen_make_type_info_var(mer_type::in, prog_context::in,
+ prog_var::out, list(hlds_goal)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_make_type_info_var(Type, Context, TypeInfoVar, TypeInfoGoals, !Info) :-
+ ml_gen_info_get_module_info(!.Info, ModuleInfo0),
+ ml_gen_info_get_pred_id(!.Info, PredId),
+ ml_gen_info_get_proc_id(!.Info, ProcId),
+ module_info_pred_proc_info(ModuleInfo0, PredId, ProcId,
+ PredInfo0, ProcInfo0),
+
+ % Call polymorphism.m to generate the HLDS code to create the type_infos.
+ create_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0),
+ polymorphism_make_type_info_var(Type, Context,
+ TypeInfoVar, TypeInfoGoals, PolyInfo0, PolyInfo),
+ poly_info_extract(PolyInfo, PredInfo0, PredInfo,
+ ProcInfo0, ProcInfo, ModuleInfo1),
+
+ % Save the new information back in the ml_gen_info.
+ module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
+ ModuleInfo1, ModuleInfo),
+ proc_info_get_varset(ProcInfo, VarSet),
+ proc_info_get_vartypes(ProcInfo, VarTypes),
+ ml_gen_info_set_module_info(ModuleInfo, !Info),
+ ml_gen_info_set_varset(VarSet, !Info),
+ ml_gen_info_set_var_types(VarTypes, !Info).
+
+%-----------------------------------------------------------------------------%
+
+:- type fixup_newobj_info
+ ---> fixup_newobj_info(
+ % The current module.
+ fnoi_module_name :: mlds_module_name,
+
+ % The current context.
+ fnoi_context :: mlds_context,
+
+ % The local variable declarations accumulated so far.
+ fnoi_locals :: list(mlds_defn),
+
+ % A counter used to allocate variable names.
+ fnoi_next_id :: counter
+ ).
+
+ % Replace all heap allocation (new_object instructions) with stack
+ % allocation (local variable declarations) in the specified statement,
+ % returning the local variable declarations needed for the stack
+ % allocation.
+ %
+:- pred fixup_newobj(statement::in, mlds_module_name::in,
+ statement::out, list(mlds_defn)::out) is det.
+
+fixup_newobj(Statement0, ModuleName, Statement, Defns) :-
+ Statement0 = statement(Stmt0, Context),
+ Info0 = fixup_newobj_info(ModuleName, Context, [], counter.init(0)),
+ fixup_newobj_in_stmt(Stmt0, Stmt, Info0, Info),
+ Statement = statement(Stmt, Context),
+ Defns = Info ^ fnoi_locals.
+
+:- pred fixup_newobj_in_statement(statement::in, statement::out,
+ fixup_newobj_info::in, fixup_newobj_info::out) is det.
+
+fixup_newobj_in_statement(Statement0, Statement, !Info) :-
+ Statement0 = statement(Stmt0, Context),
+ !:Info = !.Info ^ fnoi_context := Context,
+ fixup_newobj_in_stmt(Stmt0, Stmt, !Info),
+ Statement = statement(Stmt, Context).
+
+:- pred fixup_newobj_in_stmt(mlds_stmt::in, mlds_stmt::out,
+ fixup_newobj_info::in, fixup_newobj_info::out) is det.
+
+fixup_newobj_in_stmt(Stmt0, Stmt, !Fixup) :-
+ (
+ Stmt0 = ml_stmt_block(Defns, Statements0),
+ list.map_foldl(fixup_newobj_in_statement,
+ Statements0, Statements, !Fixup),
+ Stmt = ml_stmt_block(Defns, Statements)
+ ;
+ Stmt0 = ml_stmt_while(Rval, Statement0, Once),
+ fixup_newobj_in_statement(Statement0, Statement, !Fixup),
+ Stmt = ml_stmt_while(Rval, Statement, Once)
+ ;
+ Stmt0 = ml_stmt_if_then_else(Cond, Then0, MaybeElse0),
+ fixup_newobj_in_statement(Then0, Then, !Fixup),
+ fixup_newobj_in_maybe_statement(MaybeElse0, MaybeElse, !Fixup),
+ Stmt = ml_stmt_if_then_else(Cond, Then, MaybeElse)
+ ;
+ Stmt0 = ml_stmt_switch(Type, Val, Range, Cases0, Default0),
+ list.map_foldl(fixup_newobj_in_case, Cases0, Cases, !Fixup),
+ fixup_newobj_in_default(Default0, Default, !Fixup),
+ Stmt = ml_stmt_switch(Type, Val, Range, Cases, Default)
+ ;
+ Stmt0 = ml_stmt_label(_),
+ Stmt = Stmt0
+ ;
+ Stmt0 = ml_stmt_goto(_),
+ Stmt = Stmt0
+ ;
+ Stmt0 = ml_stmt_computed_goto(Rval, Labels),
+ Stmt = ml_stmt_computed_goto(Rval, Labels)
+ ;
+ Stmt0 = ml_stmt_call(_Sig, _Func, _Obj, _Args, _RetLvals, _TailCall),
+ Stmt = Stmt0
+ ;
+ Stmt0 = ml_stmt_return(_Rvals),
+ Stmt = Stmt0
+ ;
+ Stmt0 = ml_stmt_do_commit(_Ref),
+ Stmt = Stmt0
+ ;
+ Stmt0 = ml_stmt_try_commit(Ref, Statement0, Handler0),
+ fixup_newobj_in_statement(Statement0, Statement, !Fixup),
+ fixup_newobj_in_statement(Handler0, Handler, !Fixup),
+ Stmt = ml_stmt_try_commit(Ref, Statement, Handler)
+ ;
+ Stmt0 = ml_stmt_atomic(AtomicStmt0),
+ fixup_newobj_in_atomic_statement(AtomicStmt0, Stmt, !Fixup)
+ ).
+
+:- pred fixup_newobj_in_case(mlds_switch_case::in, mlds_switch_case::out,
+ fixup_newobj_info::in, fixup_newobj_info::out) is det.
+
+fixup_newobj_in_case(Case0, Case, !Fixup) :-
+ Case0 = mlds_switch_case(FirstCond, LaterConds, Statement0),
+ fixup_newobj_in_statement(Statement0, Statement, !Fixup),
+ Case = mlds_switch_case(FirstCond, LaterConds, Statement).
+
+:- pred fixup_newobj_in_maybe_statement(maybe(statement)::in,
+ maybe(statement)::out,
+ fixup_newobj_info::in, fixup_newobj_info::out) is det.
+
+fixup_newobj_in_maybe_statement(no, no, !Fixup).
+fixup_newobj_in_maybe_statement(yes(Statement0), yes(Statement), !Fixup) :-
+ fixup_newobj_in_statement(Statement0, Statement, !Fixup).
+
+:- pred fixup_newobj_in_default(mlds_switch_default::in,
+ mlds_switch_default::out,
+ fixup_newobj_info::in, fixup_newobj_info::out) is det.
+
+fixup_newobj_in_default(default_is_unreachable, default_is_unreachable,
+ !Fixup).
+fixup_newobj_in_default(default_do_nothing, default_do_nothing, !Fixup).
+fixup_newobj_in_default(default_case(Statement0), default_case(Statement),
+ !Fixup) :-
+ fixup_newobj_in_statement(Statement0, Statement, !Fixup).
+
+:- pred fixup_newobj_in_atomic_statement(mlds_atomic_statement::in,
+ mlds_stmt::out, fixup_newobj_info::in, fixup_newobj_info::out) is det.
+
+fixup_newobj_in_atomic_statement(AtomicStatement0, Stmt, !Fixup) :-
+ (
+ AtomicStatement0 = new_object(Lval, MaybeTag, _HasSecTag, PointerType,
+ _MaybeSizeInWordsRval, _MaybeCtorName, ArgRvals, _ArgTypes,
+ _MayUseAtomic)
+ ->
+ % Generate the declaration of the new local variable.
+ %
+ % XXX Using array(generic_type) is wrong for --high-level-data.
+ %
+ % We need to specify an initializer to tell the C back-end what the
+ % length of the array is. We initialize it with null pointers and then
+ % later generate assignment statements to fill in the values properly
+ % (see below).
+ counter.allocate(Id, !.Fixup ^ fnoi_next_id, NextId),
+ VarName = mlds_var_name("new_obj", yes(Id)),
+ VarType = mlds_array_type(mlds_generic_type),
+ NullPointers = list.duplicate(list.length(ArgRvals),
+ init_obj(ml_const(mlconst_null(mlds_generic_type)))),
+ Initializer = init_array(NullPointers),
+ % This is used for the type_infos allocated during tracing,
+ % and we don't need to trace them.
+ GCStatement = gc_no_stmt,
+ Context = !.Fixup ^ fnoi_context,
+ VarDecl = ml_gen_mlds_var_decl_init(mlds_data_var(VarName), VarType,
+ Initializer, GCStatement, Context),
+ !Fixup ^ fnoi_next_id := NextId,
+ % XXX We should keep a more structured representation of the local
+ % variables, such as a map from variable names.
+ !Fixup ^ fnoi_locals := !.Fixup ^ fnoi_locals ++ [VarDecl],
+
+ % Generate code to initialize the variable.
+ %
+ % Note that we need to use assignment statements, rather than an
+ % initializer, to initialize the local variable, because the
+ % initialization code needs to occur at exactly the point where the
+ % atomic_statement occurs, rather than at the local variable
+ % declaration.
+
+ VarLval = ml_var(
+ qual(!.Fixup ^ fnoi_module_name, module_qual, VarName),
+ VarType),
+ PtrRval = ml_unop(cast(PointerType), ml_mem_addr(VarLval)),
+ list.map_foldl(init_field_n(PointerType, PtrRval, Context),
+ ArgRvals, ArgInitStatements, 0, _NumFields),
+
+ % Generate code to assign the address of the new local variable
+ % to the Lval.
+ TaggedPtrRval = maybe_tag_rval(MaybeTag, PointerType, PtrRval),
+ AssignStmt = ml_stmt_atomic(assign(Lval, TaggedPtrRval)),
+ AssignStatement = statement(AssignStmt, Context),
+ Stmt = ml_stmt_block([], ArgInitStatements ++ [AssignStatement])
+ ;
+ Stmt = ml_stmt_atomic(AtomicStatement0)
+ ).
+
+:- pred init_field_n(mlds_type::in, mlds_rval::in, mlds_context::in,
+ mlds_rval::in, statement::out, int::in, int::out) is det.
+
+init_field_n(PointerType, PointerRval, Context, ArgRval, Statement,
+ FieldNum, FieldNum + 1) :-
+ FieldId = ml_field_offset(ml_const(mlconst_int(FieldNum))),
+ % XXX FieldType is wrong for --high-level-data
+ FieldType = mlds_generic_type,
+ MaybeTag = yes(0),
+ Field = ml_field(MaybeTag, PointerRval, FieldId, FieldType, PointerType),
+ AssignStmt = ml_stmt_atomic(assign(Field, ArgRval)),
+ Statement = statement(AssignStmt, Context).
+
+:- func maybe_tag_rval(maybe(mlds_tag), mlds_type, mlds_rval) = mlds_rval.
+
+maybe_tag_rval(no, _Type, Rval) = Rval.
+maybe_tag_rval(yes(Tag), Type, Rval) = TaggedRval :-
+ TaggedRval = ml_unop(cast(Type), ml_mkword(Tag, Rval)).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "ml_accurate_gc.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module ml_accurate_gc.
+%-----------------------------------------------------------------------------%
Index: compiler/ml_backend.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_backend.m,v
retrieving revision 1.14
diff -u -b -r1.14 ml_backend.m
--- compiler/ml_backend.m 21 Sep 2009 04:08:55 -0000 1.14
+++ compiler/ml_backend.m 23 Sep 2009 16:04:40 -0000
@@ -38,9 +38,12 @@
:- include_module mark_static_terms. % annotation
% Phase 5-ml: compile HLDS to MLDS
+:- include_module ml_proc_gen.
:- include_module ml_code_gen.
:- include_module ml_call_gen.
+ :- include_module ml_foreign_proc_gen.
:- include_module ml_closure_gen.
+ :- include_module ml_commit_gen.
:- include_module ml_switch_gen.
:- include_module ml_simplify_switch.
:- include_module ml_string_switch.
@@ -48,7 +51,9 @@
:- include_module ml_lookup_switch.
:- include_module ml_type_gen.
:- include_module ml_unify_gen.
+:- include_module ml_gen_info.
:- include_module ml_code_util.
+:- include_module ml_accurate_gc.
:- include_module ml_global_data.
:- include_module rtti_to_mlds.
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.85
diff -u -b -r1.85 ml_call_gen.m
--- compiler/ml_call_gen.m 2 Sep 2009 00:30:17 -0000 1.85
+++ compiler/ml_call_gen.m 23 Sep 2009 16:55:15 -0000
@@ -19,9 +19,8 @@
:- import_module hlds.code_model.
:- import_module hlds.hlds_goal.
-:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -74,38 +73,6 @@
:- pred ml_gen_proc_addr_rval(pred_id::in, proc_id::in, mlds_rval::out,
ml_gen_info::in, ml_gen_info::out) is det.
- % Given a source type and a destination type, and given an source rval
- % holding a value of the source type, produce an rval that converts
- % the source rval to the destination type.
- %
-:- pred ml_gen_box_or_unbox_rval(module_info::in, mer_type::in, mer_type::in,
- box_policy::in, mlds_rval::in, mlds_rval::out) is det.
-
- % ml_gen_box_or_unbox_lval(CallerType, CalleeType, VarLval, VarName,
- % Context, ForClosureWrapper, ArgNum,
- % ArgLval, ConvDecls, ConvInputStatements, ConvOutputStatements):
- %
- % This is like `ml_gen_box_or_unbox_rval', except that it works on lvals
- % rather than rvals. Given a source type and a destination type,
- % a source lval holding a value of the source type, and a name to base
- % the name of the local temporary variable on, this procedure produces
- % an lval of the destination type, the declaration for the local temporary
- % used (if any), code to assign from the source lval (suitable converted)
- % to the destination lval, and code to assign from the destination lval
- % (suitable converted) to the source lval.
- %
- % If ForClosureWrapper = yes, then the type_info for type variables
- % in CallerType may not be available in the current procedure, so the GC
- % tracing code for the ConvDecls (if any) should obtain the type_info
- % from the ArgNum-th entry in the `type_params' local.
- % (If ForClosureWrapper = no, then ArgNum is unused.)
- %
-:- pred ml_gen_box_or_unbox_lval(mer_type::in, mer_type::in, box_policy::in,
- mlds_lval::in, mlds_var_name::in, prog_context::in, bool::in, int::in,
- mlds_lval::out, list(mlds_defn)::out,
- list(statement)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
% Generate the appropriate MLDS type for a continuation function
% for a nondet procedure whose output arguments have the specified types.
%
@@ -124,11 +91,14 @@
:- import_module backend_libs.builtin_ops.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_module.
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
+:- import_module ml_backend.ml_accurate_gc.
:- import_module ml_backend.ml_closure_gen.
+:- import_module ml_backend.ml_code_util.
:- import_module parse_tree.prog_type.
:- import_module bool.
@@ -740,173 +710,6 @@
ml_gen_mem_addr(Lval) =
(if Lval = ml_mem_ref(Rval, _) then Rval else ml_mem_addr(Lval)).
-ml_gen_box_or_unbox_rval(ModuleInfo, SourceType, DestType, BoxPolicy, VarRval,
- ArgRval) :-
- % Convert VarRval, of type SourceType, to ArgRval, of type DestType.
- (
- BoxPolicy = always_boxed,
- ArgRval = VarRval
- ;
- BoxPolicy = native_if_possible,
- (
- % If converting from polymorphic type to concrete type, then unbox.
- SourceType = type_variable(_, _),
- DestType \= type_variable(_, _)
- ->
- MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
- ArgRval = ml_unop(unbox(MLDS_DestType), VarRval)
- ;
- % If converting from concrete type to polymorphic type, then box.
- SourceType \= type_variable(_, _),
- DestType = type_variable(_, _)
- ->
- MLDS_SourceType =
- mercury_type_to_mlds_type(ModuleInfo, SourceType),
- ArgRval = ml_unop(box(MLDS_SourceType), VarRval)
- ;
- % If converting to float, cast to mlds_generic_type and then unbox.
- DestType = builtin_type(builtin_type_float),
- SourceType \= builtin_type(builtin_type_float)
- ->
- MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
- ArgRval = ml_unop(unbox(MLDS_DestType),
- ml_unop(cast(mlds_generic_type), VarRval))
- ;
- % If converting from float, box and then cast the result.
- SourceType = builtin_type(builtin_type_float),
- DestType \= builtin_type(builtin_type_float)
- ->
- MLDS_SourceType =
- mercury_type_to_mlds_type(ModuleInfo, SourceType),
- MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
- ArgRval = ml_unop(cast(MLDS_DestType),
- ml_unop(box(MLDS_SourceType), VarRval))
- ;
- % If converting from an array(T) to array(X) where X is a concrete
- % instance, we should insert a cast to the concrete instance.
- % Also when converting to array(T) from array(X) we should cast
- % to array(T).
- type_to_ctor_and_args(SourceType, SourceTypeCtor, SourceTypeArgs),
- type_to_ctor_and_args(DestType, DestTypeCtor, DestTypeArgs),
- (
- type_ctor_is_array(SourceTypeCtor),
- SourceTypeArgs = [type_variable(_, _)]
- ;
- type_ctor_is_array(DestTypeCtor),
- DestTypeArgs = [type_variable(_, _)]
- ),
- % Don't insert redundant casts if the types are the same, since
- % the extra assignments introduced can inhibit tail call
- % optimisation.
- SourceType \= DestType
- ->
- MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
- ArgRval = ml_unop(cast(MLDS_DestType), VarRval)
- ;
- % If converting from one concrete type to a different one, then
- % cast. This is needed to handle construction/deconstruction
- % unifications for no_tag types.
- %
- \+ type_unify(SourceType, DestType, [], map.init, _)
- ->
- MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
- ArgRval = ml_unop(cast(MLDS_DestType), VarRval)
- ;
- % Otherwise leave unchanged.
- ArgRval = VarRval
- )
- ).
-
-ml_gen_box_or_unbox_lval(CallerType, CalleeType, BoxPolicy, VarLval, VarName,
- Context, ForClosureWrapper, ArgNum, ArgLval, ConvDecls,
- ConvInputStatements, ConvOutputStatements, !Info) :-
- % First see if we can just convert the lval as an rval;
- % if no boxing/unboxing is required, then ml_box_or_unbox_rval
- % will return its argument unchanged, and so we're done.
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ml_gen_box_or_unbox_rval(ModuleInfo, CalleeType, CallerType, BoxPolicy,
- ml_lval(VarLval), BoxedRval),
- ( BoxedRval = ml_lval(VarLval) ->
- ArgLval = VarLval,
- ConvDecls = [],
- ConvInputStatements = [],
- ConvOutputStatements = []
- ;
- % If that didn't work, then we need to declare a fresh variable
- % to use as the arg, and to generate statements to box/unbox
- % that fresh arg variable and assign it to/from the output
- % argument whose address we were passed.
-
- % Generate a declaration for the fresh variable.
- %
- % Note that generating accurate GC tracing code for this
- % variable requires some care, because CalleeType might be a
- % type variable from the callee, not from the caller,
- % and we can't generate type_infos for type variables
- % from the callee. Hence we need to call the version of
- % ml_gen_gc_statement which takes two types:
- % the CalleeType is used to determine the type for the
- % temporary variable declaration, but the CallerType is
- % used to construct the type_info.
-
- ml_gen_info_new_conv_var(ConvVarSeq, !Info),
- VarName = mlds_var_name(VarNameStr, MaybeNum),
- ConvVarSeq = conv_seq(ConvVarNum),
- string.format("conv%d_%s", [i(ConvVarNum), s(VarNameStr)],
- ConvVarName),
- ArgVarName = mlds_var_name(ConvVarName, MaybeNum),
- ml_gen_type(!.Info, CalleeType, MLDS_CalleeType),
- (
- ForClosureWrapper = yes,
- % For closure wrappers, the argument type_infos are
- % stored in the `type_params' local, so we need to
- % handle the GC tracing code specially
- ( CallerType = type_variable(_, _) ->
- ml_gen_local_for_output_arg(ArgVarName, CalleeType, ArgNum,
- Context, ArgVarDecl, !Info)
- ;
- unexpected(this_file, "invalid CalleeType for closure wrapper")
- )
- ;
- ForClosureWrapper = no,
- ml_gen_gc_statement_poly(ArgVarName, CalleeType, CallerType,
- Context, GC_Statements, !Info),
- ArgVarDecl = ml_gen_mlds_var_decl(mlds_data_var(ArgVarName),
- MLDS_CalleeType, GC_Statements, mlds_make_context(Context))
- ),
- ConvDecls = [ArgVarDecl],
-
- % Create the lval for the variable and use it for the argument lval.
- ml_gen_var_lval(!.Info, ArgVarName, MLDS_CalleeType, ArgLval),
-
- CallerIsDummy = check_dummy_type(ModuleInfo, CallerType),
- (
- CallerIsDummy = is_dummy_type,
- % If it is a dummy argument type (e.g. io.state),
- % then we don't need to bother assigning it.
- ConvInputStatements = [],
- ConvOutputStatements = []
- ;
- CallerIsDummy = is_not_dummy_type,
- % Generate statements to box/unbox the fresh variable and assign it
- % to/from the output argument whose address we were passed.
-
- % Assign to the freshly generated arg variable.
- ml_gen_box_or_unbox_rval(ModuleInfo, CallerType, CalleeType,
- BoxPolicy, ml_lval(VarLval), ConvertedVarRval),
- AssignInputStatement = ml_gen_assign(ArgLval, ConvertedVarRval,
- Context),
- ConvInputStatements = [AssignInputStatement],
-
- % Assign from the freshly generated arg variable.
- ml_gen_box_or_unbox_rval(ModuleInfo, CalleeType, CallerType,
- BoxPolicy, ml_lval(ArgLval), ConvertedArgRval),
- AssignOutputStatement = ml_gen_assign(VarLval, ConvertedArgRval,
- Context),
- ConvOutputStatements = [AssignOutputStatement]
- )
- ).
-
%-----------------------------------------------------------------------------%
%
% Code for builtins.
Index: compiler/ml_closure_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_closure_gen.m,v
retrieving revision 1.63
diff -u -b -r1.63 ml_closure_gen.m
--- compiler/ml_closure_gen.m 21 Sep 2009 04:08:55 -0000 1.63
+++ compiler/ml_closure_gen.m 23 Sep 2009 16:53:42 -0000
@@ -19,7 +19,7 @@
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -65,23 +65,12 @@
; typeclass_info_closure
; special_pred_closure.
- % ml_gen_local_for_output_arg(VarName, Type, ArgNum, Context,
- % LocalVarDefn):
- %
- % Generate a declaration for a local variable with the specified
- % VarName and Type. However, don't use the normal GC tracing code;
- % instead, generate GC tracing code that gets the typeinfo from
- % the ArgNum-th entry in `type_params'.
- %
-:- pred ml_gen_local_for_output_arg(mlds_var_name::in, mer_type::in, int::in,
- prog_context::in, mlds_defn::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
+% XXX The modules from the LLDS backend should not be used here.
:- import_module backend_libs.pseudo_type_info.
:- import_module backend_libs.rtti.
:- import_module check_hlds.mode_util.
@@ -91,15 +80,14 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
-
-% XXX The following modules depend on the LLDS,
-% so ideally they should not be used here.
:- import_module ll_backend.
:- import_module ll_backend.continuation_info. % for `generate_closure_layout'
:- import_module ll_backend.llds. % for `layout_locn'
:- import_module ll_backend.stack_layout. % for `represent_locn_as_int'
:- import_module mdbcomp.prim_data.
+:- import_module ml_backend.ml_accurate_gc.
:- import_module ml_backend.ml_call_gen.
+:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_unify_gen.
:- import_module ml_backend.rtti_to_mlds.
@@ -1182,90 +1170,6 @@
ml_target_c, TypeParamsGCInitFragments)), MLDS_Context),
GC_Decls = [ClosureLayoutPtrDecl, TypeParamsDecl].
-ml_gen_local_for_output_arg(VarName, Type, ArgNum, Context, LocalVarDefn,
- !Info) :-
- % Generate a declaration for a corresponding local variable.
- % However, don't use the normal GC tracing code; instead,
- % we need to get the typeinfo from `type_params', using the following code:
- %
- % MR_TypeInfo type_info;
- % MR_MemoryList allocated_memory_cells = NULL;
- % type_info = MR_make_type_info_maybe_existq(type_params,
- % closure_layout->MR_closure_arg_pseudo_type_info[<ArgNum> - 1],
- % NULL, NULL, &allocated_memory_cells);
- %
- % private_builtin__gc_trace_1_0(type_info, &<VarName>);
- %
- % MR_deallocate(allocated_memory_cells);
- %
- MLDS_Context = mlds_make_context(Context),
-
- ClosureLayoutPtrName = mlds_var_name("closure_layout_ptr", no),
- % This type is really `const MR_Closure_Layout *', but there's no easy
- % way to represent that in the MLDS; using MR_Box instead works fine.
- ClosureLayoutPtrType = mlds_generic_type,
- ml_gen_var_lval(!.Info, ClosureLayoutPtrName, ClosureLayoutPtrType,
- ClosureLayoutPtrLval),
-
- TypeParamsName = mlds_var_name("type_params", no),
- % This type is really MR_TypeInfoParams, but there's no easy way to
- % represent that in the MLDS; using MR_Box instead works fine.
- TypeParamsType = mlds_generic_type,
- ml_gen_var_lval(!.Info, TypeParamsName, TypeParamsType,
- TypeParamsLval),
-
- TypeInfoName = mlds_var_name("type_info", no),
- % The type for this should match the type of the first argument
- % of private_builtin.gc_trace/1, i.e. `mutvar(T)', which is a no_tag type
- % whose representation is c_pointer.
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- TypeInfoMercuryType = c_pointer_type,
- TypeInfoType = mercury_type_to_mlds_type(ModuleInfo, TypeInfoMercuryType),
- ml_gen_var_lval(!.Info, TypeInfoName, TypeInfoType, TypeInfoLval),
- TypeInfoDecl = ml_gen_mlds_var_decl(mlds_data_var(TypeInfoName),
- TypeInfoType, gc_no_stmt, MLDS_Context),
-
- ml_gen_gc_statement_with_typeinfo(VarName, Type,
- ml_lval(TypeInfoLval), Context, GCStatement0, !Info),
-
- (
- (
- GCStatement0 = gc_trace_code(CallTraceFuncCode)
- ;
- GCStatement0 = gc_initialiser(CallTraceFuncCode)
- ),
- MakeTypeInfoCode = ml_stmt_atomic(inline_target_code(ml_target_c, [
- raw_target_code("{\n", []),
- raw_target_code("MR_MemoryList allocated_mem = NULL;\n", []),
- target_code_output(TypeInfoLval),
- raw_target_code(" = (MR_C_Pointer) " ++
- "MR_make_type_info_maybe_existq(\n\t", []),
- target_code_input(ml_lval(TypeParamsLval)),
- raw_target_code(", ((MR_Closure_Layout *)\n\t", []),
- target_code_input(ml_lval(ClosureLayoutPtrLval)),
- raw_target_code(string.format(")->" ++
- "MR_closure_arg_pseudo_type_info[%d - 1],\n\t" ++
- "NULL, NULL, &allocated_mem);\n",
- [i(ArgNum)]), [])
- ])),
- DeallocateCode = ml_stmt_atomic(inline_target_code(ml_target_c, [
- raw_target_code("MR_deallocate(allocated_mem);\n", []),
- raw_target_code("}\n", [])
- ])),
- GCTraceCode = ml_stmt_block([TypeInfoDecl], [
- statement(MakeTypeInfoCode, MLDS_Context),
- CallTraceFuncCode,
- statement(DeallocateCode, MLDS_Context)
- ]),
- GCStatement = gc_trace_code(statement(GCTraceCode, MLDS_Context))
- ;
- GCStatement0 = gc_no_stmt,
- GCStatement = GCStatement0
- ),
- LocalVarDefn = ml_gen_mlds_var_decl(mlds_data_var(VarName),
- mercury_type_to_mlds_type(ModuleInfo, Type),
- GCStatement, MLDS_Context).
-
:- pred ml_gen_closure_field_lvals(mlds_lval::in, int::in, int::in, int::in,
list(mlds_lval)::out, ml_gen_info::in, ml_gen_info::out) is det.
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.225
diff -u -b -r1.225 ml_code_gen.m
--- compiler/ml_code_gen.m 22 Sep 2009 04:40:58 -0000 1.225
+++ compiler/ml_code_gen.m 23 Sep 2009 16:30:09 -0000
@@ -146,154 +146,6 @@
%
%-----------------------------------------------------------------------------%
%
-% Code for commits
-%
-%
-% There's several different ways of handling commits:
-% - using catch/throw
-% - using setjmp/longjmp
-% - using GCC's __builtin_setjmp/__builtin_longjmp
-% - exiting nested functions via gotos to
-% their containing functions
-%
-% The MLDS data structure abstracts away these differences using the
-% `try_commit' and `do_commit' instructions. The comments below show
-% the MLDS try_commit/do_commit version first, but for clarity I've also
-% included sample code using each of the three different techniques.
-% This shows how the MLDS->target back-end can map mlds_commit_type,
-% do_commit and try_commit into target language constructs.
-%
-% Note that if we're using GCC's __builtin_longjmp(), then it is important
-% that the call to __builtin_longjmp() be put in its own function, to ensure
-% that it is not in the same function as the __builtin_setjmp(). The code
-% generation schema below does that automatically. We will need to be careful
-% with MLDS optimizations to ensure that we preserve that invariant, though.
-% (Alternatively, we could just call a function that calls __builtin_longjmp()
-% rather than calling it directly. But that would be a little less efficient.)
-%
-% If those methods turn out to be too inefficient, another alternative would be
-% to change the generated code so that after every function call, it would
-% check a flag, and if that flag was set, it would return. Then MR_DO_COMMIT
-% would just set the flag and return. The flag could be in a global
-% (or thread-local) variable, or it could be an additional value returned
-% from each function.
-%
-% model_non in semi context: (using try_commit/do_commit)
-% <succeeded = Goal>
-% ===>
-% MR_COMMIT_TYPE ref;
-% void success() {
-% MR_DO_COMMIT(ref);
-% }
-% MR_TRY_COMMIT(ref, {
-% <Goal && success()>
-% succeeded = MR_FALSE;
-% }, {
-% succeeded = MR_TRUE;
-% })
-%
-% model_non in semi context: (using catch/throw)
-% <succeeded = Goal>
-% ===>
-% void success() {
-% throw COMMIT();
-% }
-% try {
-% <Goal && success()>
-% succeeded = MR_FALSE;
-% } catch (COMMIT) {
-% succeeded = MR_TRUE;
-% }
-%
-% The above is using C++ syntax. Here COMMIT is an exception type, which
-% can be defined trivially (e.g. "class COMMIT {};"). Note that when using
-% catch/throw, we don't need the "ref" argument at all; the target language's
-% exception handling implementation keeps track of all the information needed
-% to unwind the stack.
-%
-% model_non in semi context: (using setjmp/longjmp)
-% <succeeded = Goal>
-% ===>
-% jmp_buf ref;
-% void success() {
-% longjmp(ref, 1);
-% }
-% if (setjmp(ref)) {
-% succeeded = MR_TRUE;
-% } else {
-% <Goal && success()>
-% succeeded = MR_FALSE;
-% }
-%
-% model_non in semi context: (using GNU C nested functions,
-% GNU C local labels, and exiting
-% the nested function by a goto
-% to a label in the containing function)
-% <succeeded = Goal>
-% ===>
-% __label__ commit;
-% void success() {
-% goto commit;
-% }
-% <Goal && success()>
-% succeeded = MR_FALSE;
-% goto commit_done;
-% commit:
-% succeeded = MR_TRUE;
-% commit_done:
-% ;
-%
-% model_non in det context: (using try_commit/do_commit)
-% <do Goal>
-% ===>
-% MR_COMMIT_TYPE ref;
-% void success() {
-% MR_DO_COMMIT(ref);
-% }
-% MR_TRY_COMMIT(ref, {
-% <Goal && success()>
-% }, {})
-%
-% model_non in det context (using GNU C nested functions,
-% GNU C local labels, and exiting
-% the nested function by a goto
-% to a label in the containing function)
-% <do Goal>
-% ===>
-% __label__ done;
-% void success() {
-% goto done;
-% }
-% <Goal && success()>
-% done: ;
-%
-% model_non in det context (using catch/throw):
-% <do Goal>
-% ===>
-% void success() {
-% throw COMMIT();
-% }
-% try {
-% <Goal && success()>
-% } catch (COMMIT) {}
-%
-% model_non in det context (using setjmp/longjmp):
-% <do Goal>
-% ===>
-% jmp_buf ref;
-% void success() {
-% longjmp(ref, 1);
-% }
-% if (setjmp(ref) == 0) {
-% <Goal && success()>
-% }
-%
-% Note that for all of these versions, we must hoist any static declarations
-% generated for <Goal> out to the top level; this is needed so that such
-% declarations remain in scope for any following goals.
-%
-%-----------------------------------------------------------------------------%
-%
% Code for empty conjunctions (`true')
%
%
@@ -622,28 +474,6 @@
%
%-----------------------------------------------------------------------------%
%
-% Code for deconstruction unifications
-%
-%
-% det (cannot_fail) deconstruction:
-% <succeeded = (X => f(A1, A2, ...))>
-% ===>
-% A1 = arg(X, f, 1); % extract arguments
-% A2 = arg(X, f, 2);
-% ...
-%
-% semidet (can_fail) deconstruction:
-% <X => f(A1, A2, ...)>
-% ===>
-% <succeeded = (X => f(_, _, _, _))> % tag test
-% if (succeeded) {
-% A1 = arg(X, f, 1); % extract arguments
-% A2 = arg(X, f, 2);
-% ...
-% }
-%
-%-----------------------------------------------------------------------------%
-%
% This back-end is still not yet 100% complete.
%
% Done:
@@ -668,10 +498,6 @@
% (i.e. generate MLDS type declarations for user-defined types)
% - support trailing
%
-% BUGS:
-% - XXX parameter passing problem for abstract equivalence types
-% that are defined as float (or anything which doesn't map to `Word')
-%
% TODO:
% - XXX define compare & unify preds for RTTI types
% - XXX need to generate correct layout information for closures
@@ -708,9 +534,8 @@
:- import_module hlds.code_model.
:- import_module hlds.hlds_goal.
-:- import_module hlds.hlds_module.
-:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.mlds.
+:- import_module ml_backend.ml_gen_info.
:- import_module parse_tree.prog_data.
:- import_module list.
@@ -718,10 +543,6 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
- % Generate MLDS code for an entire module.
- %
-:- pred ml_code_gen(module_info::in, module_info::out, mlds::out) is det.
-
% Generate MLDS code for the specified goal in the specified code model.
% Return the result as a single statement (which may be a block statement
% containing nested declarations).
@@ -777,28 +598,24 @@
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.c_util.
:- import_module backend_libs.foreign. % XXX needed for pragma foreign code
-:- import_module backend_libs.rtti.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
-:- import_module hlds.goal_util.
-:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
-:- import_module hlds.passes_aux.
-:- import_module hlds.pred_table.
-:- import_module hlds.quantification.
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
-:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ml_call_gen.
:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_commit_gen.
+:- import_module ml_backend.ml_foreign_proc_gen.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_switch_gen.
:- import_module ml_backend.ml_type_gen.
:- import_module ml_backend.ml_unify_gen.
:- import_module ml_backend.ml_util.
:- import_module parse_tree.builtin_lib_types.
-:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_type.
:- import_module bool.
@@ -806,916 +623,12 @@
:- import_module maybe.
:- import_module pair.
:- import_module set.
-:- import_module set_tree234.
-:- import_module solutions.
:- import_module string.
-:- import_module std_util.
-:- import_module term.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-ml_code_gen(!ModuleInfo, MLDS) :-
- module_info_get_name(!.ModuleInfo, ModuleName),
- ml_gen_foreign_code(!.ModuleInfo, ForeignCode),
- ml_gen_imports(!.ModuleInfo, Imports),
- ml_gen_defns(!ModuleInfo, Defns, GlobalData),
- ml_gen_exported_enums(!.ModuleInfo, ExportedEnums),
- module_info_user_init_pred_c_names(!.ModuleInfo, InitPreds),
- module_info_user_final_pred_c_names(!.ModuleInfo, FinalPreds),
- MLDS = mlds(ModuleName, ForeignCode, Imports, GlobalData, Defns,
- InitPreds, FinalPreds, ExportedEnums).
-
-:- pred ml_gen_foreign_code(module_info::in,
- map(foreign_language, mlds_foreign_code)::out) is det.
-
-ml_gen_foreign_code(ModuleInfo, AllForeignCode) :-
- module_info_get_foreign_decl(ModuleInfo, ForeignDecls),
- module_info_get_foreign_import_module(ModuleInfo, ForeignImports),
- module_info_get_foreign_body_code(ModuleInfo, ForeignBodys),
- module_info_get_pragma_exported_procs(ModuleInfo, ForeignExports),
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_backend_foreign_languages(Globals, BackendForeignLanguages),
-
- WantedForeignImports = list.condense(
- list.map((func(L) = Imports :-
- foreign.filter_imports(L, ForeignImports, Imports, _)
- ), BackendForeignLanguages)),
-
- list.foldl(ml_gen_foreign_code_lang(ModuleInfo, ForeignDecls,
- ForeignBodys, WantedForeignImports, ForeignExports),
- BackendForeignLanguages, map.init, AllForeignCode).
-
-:- pred ml_gen_foreign_code_lang(module_info::in, foreign_decl_info::in,
- foreign_body_info::in, foreign_import_module_info_list::in,
- list(pragma_exported_proc)::in, foreign_language::in,
- map(foreign_language, mlds_foreign_code)::in,
- map(foreign_language, mlds_foreign_code)::out) is det.
-
-ml_gen_foreign_code_lang(ModuleInfo, ForeignDecls, ForeignBodys,
- WantedForeignImports, ForeignExports, Lang, Map0, Map) :-
- foreign.filter_decls(Lang, ForeignDecls, WantedForeignDecls,
- _OtherForeignDecls),
- foreign.filter_bodys(Lang, ForeignBodys, WantedForeignBodys,
- _OtherForeignBodys),
- foreign.filter_exports(Lang, ForeignExports, WantedForeignExports,
- _OtherForeignExports),
- ConvBody = (func(foreign_body_code(L, S, C)) =
- user_foreign_code(L, S, C)),
- MLDSWantedForeignBodys = list.map(ConvBody, WantedForeignBodys),
- list.map(ml_gen_pragma_export_proc(ModuleInfo),
- WantedForeignExports, MLDSWantedForeignExports),
- MLDS_ForeignCode = mlds_foreign_code(WantedForeignDecls,
- WantedForeignImports, MLDSWantedForeignBodys,
- MLDSWantedForeignExports),
- map.det_insert(Map0, Lang, MLDS_ForeignCode, Map).
-
-:- pred ml_gen_imports(module_info::in, mlds_imports::out) is det.
-
-ml_gen_imports(ModuleInfo, MLDS_ImportList) :-
- % Determine all the mercury imports.
- % XXX This is overly conservative, i.e. we import more than we really need.
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_target(Globals, Target),
- module_info_get_all_deps(ModuleInfo, AllImports0),
- % No module needs to import itself.
- module_info_get_name(ModuleInfo, ThisModule),
- AllImports = set.delete(AllImports0, ThisModule),
- P = (func(Name) = mercury_import(compiler_visible_interface,
- mercury_module_name_to_mlds(Name))),
-
- % For every foreign type determine the import needed to find
- % the declaration for that type.
- module_info_get_type_table(ModuleInfo, TypeTable),
- get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
- ForeignTypeImports = list.condense(
- list.map(foreign_type_required_imports(Target), TypeCtorsDefns)),
-
- MLDS_ImportList = ForeignTypeImports ++
- list.map(P, set.to_sorted_list(AllImports)).
-
-:- func foreign_type_required_imports(compilation_target,
- pair(type_ctor, hlds_type_defn)) = list(mlds_import).
-
-foreign_type_required_imports(Target, _TypeCtor - TypeDefn) = Imports :-
- (
- ( Target = target_c
- ; Target = target_java
- ; Target = target_asm
- ),
- Imports = []
- ;
- Target = target_il,
- hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- (
- TypeBody = hlds_foreign_type(ForeignTypeBody),
- ForeignTypeBody = foreign_type_body(MaybeIL,
- _MaybeC, _MaybeJava, _MaybeErlang),
- (
- MaybeIL = yes(Data),
- Data = foreign_type_lang_data(il_type(_, Location, _), _, _)
- ->
- Name = il_assembly_name(mercury_module_name_to_mlds(
- unqualified(Location))),
- Imports = [foreign_import(Name)]
- ;
- unexpected(this_file, "no IL type")
- )
- ;
- ( TypeBody = hlds_du_type(_, _, _,_, _, _, _, _)
- ; TypeBody = hlds_eqv_type(_)
- ; TypeBody = hlds_solver_type(_, _)
- ; TypeBody = hlds_abstract_type(_)
- ),
- Imports = []
- )
- ;
- Target = target_x86_64,
- unexpected(this_file, "target x86_64 and --high-level-code")
- ;
- Target = target_erlang,
- unexpected(this_file, "foreign_type_required_imports: target erlang")
- ).
-
-:- pred ml_gen_defns(module_info::in, module_info::out,
- list(mlds_defn)::out, ml_global_data::out) is det.
-
-ml_gen_defns(!ModuleInfo, Defns, GlobalData) :-
- ml_gen_types(!.ModuleInfo, TypeDefns),
- ml_gen_table_structs(!.ModuleInfo, TableStructDefns),
- ml_gen_preds(!ModuleInfo, PredDefns, GlobalData),
- Defns = TypeDefns ++ TableStructDefns ++ PredDefns.
-
-%-----------------------------------------------------------------------------%
-%
-% For each pragma foreign_export declaration we associate with it the
-% information used to generate the function prototype for the MLDS entity.
-
-:- pred ml_gen_pragma_export_proc(module_info::in, pragma_exported_proc::in,
- mlds_pragma_export::out) is det.
-
-ml_gen_pragma_export_proc(ModuleInfo, PragmaExportedProc, Defn) :-
- PragmaExportedProc = pragma_exported_proc(Lang, PredId, ProcId,
- ExportName, ProgContext),
- ml_gen_proc_label(ModuleInfo, PredId, ProcId, Name, ModuleName),
- FuncParams = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
- MLDS_Context = mlds_make_context(ProgContext),
- Defn = ml_pragma_export(Lang, ExportName,
- qual(ModuleName, module_qual, Name), FuncParams, MLDS_Context).
-
-%-----------------------------------------------------------------------------%
-%
-% Stuff to generate MLDS code for HLDS predicates & functions.
-%
-
- % Generate MLDS definitions for all the non-imported predicates
- % (and functions) in the HLDS.
- %
-:- pred ml_gen_preds(module_info::in, module_info::out,
- list(mlds_defn)::out, ml_global_data::out) is det.
-
-ml_gen_preds(!ModuleInfo, PredDefns, GlobalData) :-
- module_info_preds(!.ModuleInfo, PredTable),
- map.keys(PredTable, PredIds),
- module_info_get_globals(!.ModuleInfo, Globals),
- globals.get_target(Globals, Target),
- (
- Target = target_c,
- UseCommonCells = use_common_cells
- ;
- ( Target = target_asm
- ; Target = target_java
- ; Target = target_il
- ; Target = target_erlang
- ; Target = target_x86_64
- ),
- UseCommonCells = do_not_use_common_cells
- ),
- GlobalData0 = ml_global_data_init(UseCommonCells),
- ml_gen_preds_2(!ModuleInfo, PredIds, [], PredDefns,
- GlobalData0, GlobalData).
-
-:- pred ml_gen_preds_2(module_info::in, module_info::out, list(pred_id)::in,
- list(mlds_defn)::in, list(mlds_defn)::out,
- ml_global_data::in, ml_global_data::out) is det.
-
-ml_gen_preds_2(!ModuleInfo, PredIds0, !Defns, !GlobalDefns) :-
- (
- PredIds0 = [PredId | PredIds],
- module_info_preds(!.ModuleInfo, PredTable),
- map.lookup(PredTable, PredId, PredInfo),
- pred_info_get_import_status(PredInfo, ImportStatus),
- (
- (
- ImportStatus = status_imported(_)
- ;
- % We generate incorrect and unnecessary code for the external
- % special preds which are pseudo_imported, so just ignore them.
- is_unify_or_compare_pred(PredInfo),
- ImportStatus = status_external(status_pseudo_imported)
- )
- ->
- true
- ;
- ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
- !GlobalDefns)
- ),
- ml_gen_preds_2(!ModuleInfo, PredIds, !Defns, !GlobalDefns)
- ;
- PredIds0 = []
- ).
-
- % Generate MLDS definitions for all the non-imported procedures
- % of a given predicate (or function).
- %
-:- pred ml_gen_pred(module_info::in, module_info::out, pred_id::in,
- pred_info::in, import_status::in,
- list(mlds_defn)::in, list(mlds_defn)::out,
- ml_global_data::in, ml_global_data::out) is det.
-
-ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
- !GlobalData) :-
- ( ImportStatus = status_external(_) ->
- ProcIds = pred_info_procids(PredInfo)
- ;
- ProcIds = pred_info_non_imported_procids(PredInfo)
- ),
- (
- ProcIds = []
- ;
- ProcIds = [_ | _],
- trace [io(!IO)] (
- write_pred_progress_message("% Generating MLDS code for ",
- PredId, !.ModuleInfo, !IO)
- ),
- ml_gen_procs(!ModuleInfo, PredId, ProcIds, !Defns, !GlobalData)
- ).
-
-:- pred ml_gen_procs(module_info::in, module_info::out,
- pred_id::in, list(proc_id)::in,
- list(mlds_defn)::in, list(mlds_defn)::out,
- ml_global_data::in, ml_global_data::out) is det.
-
-ml_gen_procs(!ModuleInfo, _, [], !Defns, !GlobalData).
-ml_gen_procs(!ModuleInfo, PredId, [ProcId | ProcIds], !Defns, !GlobalData) :-
- ml_gen_proc(!ModuleInfo, PredId, ProcId, !Defns, !GlobalData),
- ml_gen_procs(!ModuleInfo, PredId, ProcIds, !Defns, !GlobalData).
%-----------------------------------------------------------------------------%
-%
-% Code for handling tabling structures.
-%
-
-:- pred ml_gen_table_structs(module_info::in, list(mlds_defn)::out) is det.
-
-ml_gen_table_structs(ModuleInfo, Defns) :-
- module_info_get_table_struct_map(ModuleInfo, TableStructMap),
- map.to_assoc_list(TableStructMap, TableStructs),
- (
- TableStructs = [],
- Defns = []
- ;
- TableStructs = [_ | _],
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_gc_method(Globals, GC_Method),
- % XXX To handle accurate GC properly, the GC would need to trace
- % through the global variables that we generate for the tables.
- % Support for this is not yet implemented. Also, we would need to add
- % GC support (stack frame registration, and calls to MR_GC_check()) to
- % MR_make_long_lived() and MR_deep_copy() so that we do garbage
- % collection of the "global heap" which is used to store the tables.
- expect(isnt(unify(gc_accurate), GC_Method), this_file,
- "tabling and `--gc accurate'"),
-
- list.foldl(ml_gen_add_table_var(ModuleInfo), TableStructs, [], Defns)
- ).
-
-:- pred ml_gen_add_table_var(module_info::in,
- pair(pred_proc_id, table_struct_info)::in,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
-
-ml_gen_add_table_var(ModuleInfo, PredProcId - TableStructInfo, !Defns) :-
- module_info_get_name(ModuleInfo, ModuleName),
- MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- PredProcId = proc(_PredId, ProcId),
-
- TableStructInfo = table_struct_info(ProcTableStructInfo, _Attributes),
- ProcTableStructInfo = proc_table_struct_info(RttiProcLabel, _TVarSet,
- Context, NumInputs, NumOutputs, InputSteps, MaybeOutputSteps,
- _ArgInfos, EvalMethod),
-
- ml_gen_pred_label_from_rtti(ModuleInfo, RttiProcLabel, PredLabel,
- _PredModule),
- MLDS_ProcLabel = mlds_proc_label(PredLabel, ProcId),
- MLDS_Context = mlds_make_context(Context),
- TableTypeStr = eval_method_to_table_type(EvalMethod),
- (
- InputSteps = [],
- % We don't want to generate arrays with zero elements.
- InputStepsRefInit = gen_init_null_pointer(
- mlds_tabling_type(tabling_steps_desc(call_table))),
- InputStepsDefns = []
- ;
- InputSteps = [_ | _],
- InputStepsRefInit = gen_init_tabling_name(MLDS_ModuleName,
- MLDS_ProcLabel, tabling_steps_desc(call_table)),
- InputStepsInit = init_array(
- list.map(init_step_desc(tabling_steps_desc(call_table)),
- InputSteps)),
- InputStepsDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
- MLDS_Context, const, tabling_steps_desc(call_table),
- InputStepsInit),
- InputStepsDefns = [InputStepsDefn]
- ),
- init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
- call_table, curr_table, InputSteps,
- CallStatsInit, CallStatsDefns),
- init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
- call_table, prev_table, InputSteps,
- PrevCallStatsInit, PrevCallStatsDefns),
- CallDefns = InputStepsDefns ++ CallStatsDefns ++ PrevCallStatsDefns,
- (
- MaybeOutputSteps = no,
- HasAnswerTable = 0,
- OutputStepsRefInit = gen_init_null_pointer(
- mlds_tabling_type(tabling_steps_desc(answer_table))),
- OutputStepsDefns = []
- ;
- MaybeOutputSteps = yes(OutputSteps),
- HasAnswerTable = 1,
- OutputStepsRefInit = gen_init_tabling_name(MLDS_ModuleName,
- MLDS_ProcLabel, tabling_steps_desc(answer_table)),
- OutputStepsInit = init_array(
- list.map(init_step_desc(tabling_steps_desc(answer_table)),
- OutputSteps)),
- OutputStepsDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
- MLDS_Context, const, tabling_steps_desc(answer_table),
- OutputStepsInit),
- OutputStepsDefns = [OutputStepsDefn]
- ),
- init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
- answer_table, curr_table, InputSteps,
- AnswerStatsInit, AnswerStatsDefns),
- init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
- answer_table, prev_table, InputSteps,
- PrevAnswerStatsInit, PrevAnswerStatsDefns),
- AnswerDefns = OutputStepsDefns ++ AnswerStatsDefns ++ PrevAnswerStatsDefns,
-
- PTIsRefInit = gen_init_null_pointer(mlds_tabling_type(tabling_ptis)),
- TypeParamLocnsRefInit = gen_init_null_pointer(
- mlds_tabling_type(tabling_type_param_locns)),
- RootNodeInit = init_struct(mlds_tabling_type(tabling_root_node),
- [gen_init_int(0)]),
- TipsRefInit = gen_init_null_pointer(mlds_tabling_type(tabling_tips)),
-
- ProcTableInfoInit = init_struct(mlds_tabling_type(tabling_info), [
- gen_init_builtin_const(TableTypeStr),
- gen_init_int(NumInputs),
- gen_init_int(NumOutputs),
- gen_init_int(HasAnswerTable),
- PTIsRefInit,
- TypeParamLocnsRefInit,
- RootNodeInit,
- init_array([InputStepsRefInit, OutputStepsRefInit]),
- init_array([
- init_array([CallStatsInit, PrevCallStatsInit]),
- init_array([AnswerStatsInit, PrevAnswerStatsInit])
- ]),
- gen_init_int(0),
- TipsRefInit,
- gen_init_int(0),
- gen_init_int(0)
- ]),
- ProcTableInfoDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
- MLDS_Context, modifiable, tabling_info, ProcTableInfoInit),
-
- !:Defns = CallDefns ++ AnswerDefns ++ [ProcTableInfoDefn | !.Defns].
-
-:- func init_step_desc(proc_tabling_struct_id, table_step_desc)
- = mlds_initializer.
-
-init_step_desc(StructId, StepDesc) = init_struct(StructType, FieldInits) :-
- StepDesc = table_step_desc(VarName, Step),
- table_trie_step_to_c(Step, StepStr, MaybeEnumRange),
- VarNameInit = gen_init_string(VarName),
- StepInit = encode_enum_init(StepStr),
- (
- MaybeEnumRange = no,
- MaybeEnumRangeInit = gen_init_int(-1)
- ;
- MaybeEnumRange = yes(EnumRange),
- MaybeEnumRangeInit = gen_init_int(EnumRange)
- ),
- StructType = mlds_tabling_type(StructId),
- FieldInits = [VarNameInit, StepInit, MaybeEnumRangeInit].
-
-:- pred init_stats(mlds_module_name::in, mlds_proc_label::in, mlds_context::in,
- call_or_answer_table::in, curr_or_prev_table::in,
- list(table_step_desc)::in, mlds_initializer::out, list(mlds_defn)::out)
- is det.
-
-init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
- CallOrAnswer, CurrOrPrev, StepDescs, StatsInit, StatsStepDefns) :-
- StatsId = tabling_stats(CallOrAnswer, CurrOrPrev),
- StatsStepsId = tabling_stat_steps(CallOrAnswer, CurrOrPrev),
- StatsType = mlds_tabling_type(StatsId),
- StatsStepsType = mlds_tabling_type(StatsStepsId),
- (
- StepDescs = [],
- StatsStepDefns = [],
- StatsStepsArrayRefInit = gen_init_null_pointer(StatsStepsType)
- ;
- StepDescs = [_ | _],
- list.map(init_stats_step(StatsStepsId), StepDescs, StatsStepsInits),
- StatsStepsArrayInit = init_array(StatsStepsInits),
- StatsStepDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
- MLDS_Context, modifiable, StatsStepsId, StatsStepsArrayInit),
- StatsStepDefns = [StatsStepDefn],
- StatsStepsArrayRefInit = gen_init_tabling_name(MLDS_ModuleName,
- MLDS_ProcLabel, tabling_stat_steps(CallOrAnswer, CurrOrPrev))
- ),
- StatsInit = init_struct(StatsType, [
- gen_init_int(0),
- gen_init_int(0),
- StatsStepsArrayRefInit
- ]).
-
-:- pred init_stats_step(proc_tabling_struct_id::in, table_step_desc::in,
- mlds_initializer::out) is det.
-
-init_stats_step(StepId, StepDesc, Init) :-
- StepDesc = table_step_desc(_VarName, Step),
- KindStr = table_step_stats_kind(Step),
- Init = init_struct(mlds_tabling_type(StepId), [
- gen_init_int(0),
- gen_init_int(0),
- encode_enum_init(KindStr),
-
- % The fields about hash tables.
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
-
- % The fields about enums.
- gen_init_int(0),
- gen_init_int(0),
-
- % The fields about du types.
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
- gen_init_int(0),
-
- % The fields about start tables.
- gen_init_int(0),
- gen_init_int(0)
- ]).
-
-:- func encode_enum_init(string) = mlds_initializer.
-
-encode_enum_init(EnumConstName) =
- init_obj(ml_const(mlconst_named_const(EnumConstName))).
-
-:- func gen_init_tabling_name(mlds_module_name, mlds_proc_label,
- proc_tabling_struct_id) = mlds_initializer.
-
-gen_init_tabling_name(ModuleName, ProcLabel, TablingId) = Rval :-
- DataAddr = data_addr(ModuleName, mlds_tabling_ref(ProcLabel, TablingId)),
- Rval = init_obj(ml_const(mlconst_data_addr(DataAddr))).
-
-:- func tabling_name_and_init_to_defn(mlds_proc_label, mlds_context, constness,
- proc_tabling_struct_id, mlds_initializer) = mlds_defn.
-
-tabling_name_and_init_to_defn(ProcLabel, MLDS_Context, Constness, Id,
- Initializer) = Defn :-
- GCStatement = gc_no_stmt,
- MLDS_Type = mlds_tabling_type(Id),
- Flags = tabling_data_decl_flags(Constness),
- DefnBody = mlds_data(MLDS_Type, Initializer, GCStatement),
- Name = entity_data(mlds_tabling_ref(ProcLabel, Id)),
- Defn = mlds_defn(Name, MLDS_Context, Flags, DefnBody).
-
- % Return the declaration flags appropriate for a tabling data structure.
- %
-:- func tabling_data_decl_flags(constness) = mlds_decl_flags.
-
-tabling_data_decl_flags(Constness) = MLDS_DeclFlags :-
- Access = acc_private,
- PerInstance = one_copy,
- Virtuality = non_virtual,
- Finality = final,
- Abstractness = concrete,
- MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
- Virtuality, Finality, Constness, Abstractness).
-
-%-----------------------------------------------------------------------------%
-%
-% Code for handling individual procedures.
-% ZZZ reorder
-%
-
-:- pred ml_gen_proc(module_info::in, module_info::out,
- pred_id::in, proc_id::in, list(mlds_defn)::in, list(mlds_defn)::out,
- ml_global_data::in, ml_global_data::out) is det.
-
-ml_gen_proc(!ModuleInfo, PredId, ProcId, !Defns, !GlobalData) :-
- % The specification of the HLDS allows goal_infos to overestimate
- % the set of non-locals. Such overestimates are bad for us for two reasons:
- %
- % - If the non-locals of the top-level goal contained any variables other
- % than head vars, those variables would not be declared.
- %
- % - The code of goal_expr_find_subgoal_nonlocals depends on the nonlocals
- % sets of goals being exactly correct, since this is the only way it can
- % avoid traversing the entirety of the goals themselves. Such traversals
- % can be very expensive on large goals, since it would have to be done
- % repeatedly, once for each containing goal. Quantification does just one
- % traversal.
-
- module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
- PredInfo, ProcInfo0),
- requantify_proc_general(ordinary_nonlocals_no_lambda, ProcInfo0, ProcInfo),
- module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
- !ModuleInfo),
-
- pred_info_get_import_status(PredInfo, ImportStatus),
- pred_info_get_arg_types(PredInfo, ArgTypes),
- CodeModel = proc_info_interface_code_model(ProcInfo),
- proc_info_get_headvars(ProcInfo, HeadVars),
- proc_info_get_argmodes(ProcInfo, Modes),
- proc_info_get_goal(ProcInfo, Goal),
-
- Goal = hlds_goal(_GoalExpr, GoalInfo),
- Context = goal_info_get_context(GoalInfo),
-
- some [!Info] (
- !:Info = ml_gen_info_init(!.ModuleInfo, PredId, ProcId, ProcInfo,
- !.GlobalData),
-
- ( ImportStatus = status_external(_) ->
- % For Mercury procedures declared `:- external', we generate an
- % MLDS definition for them with no function body. The MLDS ->
- % target code pass can treat this accordingly, e.g. for C
- % it outputs a function declaration with no corresponding
- % definition, making sure that the function is declared as `extern'
- % rather than `static'.
- %
- FunctionBody = body_external,
- ExtraDefns = [],
- ml_gen_proc_params(PredId, ProcId, MLDS_Params, !.Info, _Info)
- ;
- % Set up the initial success continuation, if any.
- % Also figure out which output variables are returned by value
- % (rather than being passed by reference) and remove them from
- % the byref_output_vars field in the ml_gen_info.
- (
- ( CodeModel = model_det
- ; CodeModel = model_semi
- ),
- ml_det_copy_out_vars(!.ModuleInfo, CopiedOutputVars, !Info)
- ;
- CodeModel = model_non,
- ml_set_up_initial_succ_cont(!.ModuleInfo, CopiedOutputVars,
- !Info)
- ),
-
- % This would generate all the local variables at the top of
- % the function:
- % ml_gen_all_local_var_decls(Goal,
- % VarSet, VarTypes, HeadVars, MLDS_LocalVars, Info1, Info2)
- % But instead we now generate them locally for each goal.
- % We just declare the `succeeded' var here, plus locals
- % for any output arguments that are returned by value
- % (e.g. if --nondet-copy-out is enabled, or for det function
- % return values).
- (
- CopiedOutputVars = [],
- % Optimize common case.
- OutputVarLocals = []
- ;
- CopiedOutputVars = [_ | _],
- proc_info_get_varset(ProcInfo, VarSet),
- proc_info_get_vartypes(ProcInfo, VarTypes),
- % Note that for headvars we must use the types from
- % the procedure interface, not from the procedure body.
- HeadVarTypes = map.from_corresponding_lists(HeadVars,
- ArgTypes),
- ml_gen_local_var_decls(VarSet,
- map.overlay(VarTypes, HeadVarTypes),
- Context, CopiedOutputVars, OutputVarLocals, !Info)
- ),
- MLDS_Context = mlds_make_context(Context),
- MLDS_LocalVars = [ml_gen_succeeded_var_decl(MLDS_Context) |
- OutputVarLocals],
- modes_to_arg_modes(!.ModuleInfo, Modes, ArgTypes, ArgModes),
- ml_gen_proc_body(CodeModel, HeadVars, ArgTypes, ArgModes,
- CopiedOutputVars, Goal, Defns0, Statements, !Info),
- ml_gen_proc_params(PredId, ProcId, MLDS_Params, !Info),
- ml_gen_info_get_closure_wrapper_defns(!.Info, ExtraDefns),
- ml_gen_info_get_global_data(!.Info, !:GlobalData),
- Defns = MLDS_LocalVars ++ Defns0,
- Statement = ml_gen_block(Defns, Statements, Context),
- FunctionBody = body_defined_here(Statement)
-
- ),
- % XXX Can env_var_names be affected by body_external?
- % If, as I (zs) suspect, it cannot, this should be inside the previous
- % scope.
- ml_gen_info_get_env_var_names(!.Info, EnvVarNames)
- ),
-
- proc_info_get_context(ProcInfo0, ProcContext),
- ml_gen_proc_label(!.ModuleInfo, PredId, ProcId, EntityName, _ModuleName),
- MLDS_ProcContext = mlds_make_context(ProcContext),
- DeclFlags = ml_gen_proc_decl_flags(!.ModuleInfo, PredId, ProcId),
- MaybePredProcId = yes(proc(PredId, ProcId)),
- pred_info_get_attributes(PredInfo, Attributes),
- attributes_to_attribute_list(Attributes, AttributeList),
- MLDS_Attributes =
- attributes_to_mlds_attributes(!.ModuleInfo, AttributeList),
- EntityBody = mlds_function(MaybePredProcId, MLDS_Params,
- FunctionBody, MLDS_Attributes, EnvVarNames),
- ProcDefn = mlds_defn(EntityName, MLDS_ProcContext, DeclFlags, EntityBody),
- !:Defns = ExtraDefns ++ [ProcDefn | !.Defns].
-
- % Return the declaration flags appropriate for a procedure definition.
- %
-:- func ml_gen_proc_decl_flags(module_info, pred_id, proc_id)
- = mlds_decl_flags.
-
-ml_gen_proc_decl_flags(ModuleInfo, PredId, ProcId) = DeclFlags :-
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- ( procedure_is_exported(ModuleInfo, PredInfo, ProcId) ->
- Access = acc_public
- ;
- Access = acc_private
- ),
- PerInstance = one_copy,
- Virtuality = non_virtual,
- Finality = overridable,
- Constness = modifiable,
- Abstractness = concrete,
- DeclFlags = init_decl_flags(Access, PerInstance,
- Virtuality, Finality, Constness, Abstractness).
-
- % For model_det and model_semi procedures, figure out which output
- % variables are returned by value (rather than being passed by reference)
- % and remove them from the byref_output_vars field in the ml_gen_info.
- %
-:- pred ml_det_copy_out_vars(module_info::in, list(prog_var)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_det_copy_out_vars(ModuleInfo, CopiedOutputVars, !Info) :-
- ml_gen_info_get_byref_output_vars(!.Info, OutputVars),
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, det_copy_out, DetCopyOut),
- (
- % If --det-copy-out is enabled, all non-dummy output variables are
- % returned by value, rather than passing them by reference.
- DetCopyOut = yes,
- ByRefOutputVars = [],
- ml_gen_info_get_var_types(!.Info, VarTypes),
- list.filter(var_is_of_dummy_type(ModuleInfo, VarTypes), OutputVars,
- _, CopiedOutputVars)
- ;
- DetCopyOut = no,
- (
- % For det functions, the function result variable is returned by
- % value, and any remaining output variables are passed by
- % reference.
- ml_gen_info_get_pred_id(!.Info, PredId),
- ml_gen_info_get_proc_id(!.Info, ProcId),
- ml_is_output_det_function(ModuleInfo, PredId, ProcId, ResultVar)
- ->
- CopiedOutputVars = [ResultVar],
- list.delete_all(OutputVars, ResultVar, ByRefOutputVars)
- ;
- % Otherwise, all output vars are passed by reference.
- CopiedOutputVars = [],
- ByRefOutputVars = OutputVars
- )
- ),
- ml_gen_info_set_byref_output_vars(ByRefOutputVars, !Info),
- ml_gen_info_set_value_output_vars(CopiedOutputVars, !Info).
-
- % For model_non procedures, figure out which output variables are returned
- % by value (rather than being passed by reference) and remove them from
- % the byref_output_vars field in the ml_gen_info, and construct the
- % initial success continuation.
- %
-:- pred ml_set_up_initial_succ_cont(module_info::in, list(prog_var)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_set_up_initial_succ_cont(ModuleInfo, NondetCopiedOutputVars, !Info) :-
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, nondet_copy_out, NondetCopyOut),
- (
- NondetCopyOut = yes,
- % For --nondet-copy-out, we generate local variables for the output
- % variables and then pass them to the continuation, rather than
- % passing them by reference.
- ml_gen_info_get_byref_output_vars(!.Info, NondetCopiedOutputVars),
- ml_gen_info_set_byref_output_vars([], !Info)
- ;
- NondetCopyOut = no,
- NondetCopiedOutputVars = []
- ),
- ml_gen_info_set_value_output_vars(NondetCopiedOutputVars, !Info),
- ml_gen_var_list(!.Info, NondetCopiedOutputVars, OutputVarLvals),
- ml_variable_types(!.Info, NondetCopiedOutputVars, OutputVarTypes),
- ml_initial_cont(!.Info, OutputVarLvals, OutputVarTypes, InitialCont),
- ml_gen_info_push_success_cont(InitialCont, !Info).
-
- % Generate MLDS definitions for all the local variables in a function.
- %
- % Note that this function generates all the local variables at the
- % top of the function. It might be a better idea to instead generate
- % local declarations for all the variables used in each sub-goal.
- %
-:- pred ml_gen_all_local_var_decls(hlds_goal::in, prog_varset::in,
- vartypes::in, list(prog_var)::in, list(mlds_defn)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_all_local_var_decls(Goal, VarSet, VarTypes, HeadVars, MLDS_LocalVars,
- !Info) :-
- Goal = hlds_goal(_, GoalInfo),
- Context = goal_info_get_context(GoalInfo),
- goal_util.goal_vars(Goal, AllVarsSet),
- set.delete_list(AllVarsSet, HeadVars, LocalVarsSet),
- set.to_sorted_list(LocalVarsSet, LocalVars),
- ml_gen_local_var_decls(VarSet, VarTypes, Context, LocalVars,
- MLDS_LocalVars0, !Info),
- MLDS_Context = mlds_make_context(Context),
- MLDS_SucceededVar = ml_gen_succeeded_var_decl(MLDS_Context),
- MLDS_LocalVars = [MLDS_SucceededVar | MLDS_LocalVars0].
-
- % Generate declarations for a list of local variables.
- %
-ml_gen_local_var_decls(_VarSet, _VarTypes, _Context, [], [], !Info).
-ml_gen_local_var_decls(VarSet, VarTypes, Context, [Var | Vars], Defns,
- !Info) :-
- map.lookup(VarTypes, Var, Type),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- IsDummy = check_dummy_type(ModuleInfo, Type),
- (
- IsDummy = is_dummy_type,
- % No declaration needed for this variable.
- ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars, Defns, !Info)
- ;
- IsDummy = is_not_dummy_type,
- VarName = ml_gen_var_name(VarSet, Var),
- ml_gen_var_decl(VarName, Type, Context, Defn, !Info),
- ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars, Defns0, !Info),
- Defns = [Defn | Defns0]
- ).
-
- % Generate the code for a procedure body.
- %
-:- pred ml_gen_proc_body(code_model::in, list(prog_var)::in,
- list(mer_type)::in, list(arg_mode)::in, list(prog_var)::in,
- hlds_goal::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_proc_body(CodeModel, HeadVars, ArgTypes, ArgModes, CopiedOutputVars,
- Goal, Decls, Statements, !Info) :-
- Goal = hlds_goal(_, GoalInfo),
- Context = goal_info_get_context(GoalInfo),
-
- % First just generate the code for the procedure's goal.
-
- % In certain cases -- for example existentially typed procedures,
- % or unification/compare procedures for equivalence types --
- % the parameters types may not match the types of the head variables.
- % In such cases, we need to box/unbox/cast them to the right type.
- % We also grab the original (uncast) lvals for the copied output
- % variables (if any) here, since for the return statement that
- % we append below, we want the original vars, not their cast versions.
-
- ml_gen_var_list(!.Info, CopiedOutputVars, CopiedOutputVarOriginalLvals),
- ml_gen_convert_headvars(HeadVars, ArgTypes, ArgModes, CopiedOutputVars,
- Context, ConvDecls, ConvInputStatements, ConvOutputStatements, !Info),
- (
- ConvDecls = [],
- ConvInputStatements = [],
- ConvOutputStatements = []
- ->
- % No boxing/unboxing/casting required.
- ml_gen_goal(CodeModel, Goal, Decls, Statements1, !Info)
- ;
- DoGenGoal = ml_gen_goal(CodeModel, Goal),
-
- % Boxing/unboxing/casting required. We need to convert the input
- % arguments, generate the goal, convert the output arguments,
- % and then succeeed.
- DoConvOutputs = (pred(NewDecls::out, NewStatements::out,
- Info0::in, Info::out) is det :-
- ml_gen_success(CodeModel, Context, SuccStatements, Info0, Info),
- NewDecls = [],
- NewStatements = ConvOutputStatements ++ SuccStatements
- ),
- ml_combine_conj(CodeModel, Context, DoGenGoal, DoConvOutputs,
- Decls0, Statements0, !Info),
- Statements1 = ConvInputStatements ++ Statements0,
- Decls = ConvDecls ++ Decls0
- ),
-
- % Finally append an appropriate `return' statement, if needed.
- ml_append_return_statement(!.Info, CodeModel, CopiedOutputVarOriginalLvals,
- Context, Statements1, Statements).
-
- % In certain cases -- for example existentially typed procedures,
- % or unification/compare procedures for equivalence types --
- % the parameter types may not match the types of the head variables.
- % In such cases, we need to box/unbox/cast them to the right type.
- % This procedure handles that.
- %
-:- pred ml_gen_convert_headvars(list(prog_var)::in, list(mer_type)::in,
- list(arg_mode)::in, list(prog_var)::in, prog_context::in,
- list(mlds_defn)::out, list(statement)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_convert_headvars(Vars, HeadTypes, ArgModes, CopiedOutputVars, Context,
- Decls, InputStatements, OutputStatements, !Info) :-
- (
- Vars = [],
- HeadTypes = [],
- ArgModes = []
- ->
- Decls = [],
- InputStatements = [],
- OutputStatements = []
- ;
- Vars = [Var | VarsTail],
- HeadTypes = [HeadType | HeadTypesTail],
- ArgModes = [ArgMode | ArgModesTail]
- ->
- ml_variable_type(!.Info, Var, BodyType),
- (
- % Arguments with mode `top_unused' do not need to be converted.
- ArgMode = top_unused
- ->
- ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
- CopiedOutputVars, Context, Decls,
- InputStatements, OutputStatements, !Info)
- ;
- % Check whether HeadType is the same as BodyType
- % (modulo the term.contexts). If so, no conversion is needed.
- map.init(Subst0),
- type_unify(HeadType, BodyType, [], Subst0, Subst),
- map.is_empty(Subst)
- ->
- ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
- CopiedOutputVars, Context, Decls,
- InputStatements, OutputStatements, !Info)
- ;
- % Generate the lval for the head variable.
- ml_gen_var_with_type(!.Info, Var, HeadType, HeadVarLval),
-
- % Generate code to box or unbox that head variable,
- % to convert its type from HeadType to BodyType.
- ml_gen_info_get_varset(!.Info, VarSet),
- VarName = ml_gen_var_name(VarSet, Var),
- ml_gen_box_or_unbox_lval(HeadType, BodyType, native_if_possible,
- HeadVarLval, VarName, Context, no, 0, BodyLval, ConvDecls,
- ConvInputStatements, ConvOutputStatements, !Info),
-
- % Ensure that for any uses of this variable in the procedure body,
- % we use the BodyLval (which has type BodyType) rather than the
- % HeadVarLval (which has type HeadType).
- ml_gen_info_set_var_lval(Var, BodyLval, !Info),
-
- ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
- CopiedOutputVars, Context, DeclsTail,
- InputStatementsTail, OutputStatementsTail, !Info),
-
- % Add the code to convert this input or output.
- ml_gen_info_get_byref_output_vars(!.Info, ByRefOutputVars),
- (
- ( list.member(Var, ByRefOutputVars)
- ; list.member(Var, CopiedOutputVars)
- )
- ->
- InputStatements = InputStatementsTail,
- OutputStatements = OutputStatementsTail ++ ConvOutputStatements
- ;
- InputStatements = ConvInputStatements ++ InputStatementsTail,
- OutputStatements = OutputStatementsTail
- ),
- Decls = ConvDecls ++ DeclsTail
- )
- ;
- unexpected(this_file, "ml_gen_convert_headvars: length mismatch")
- ).
-
%-----------------------------------------------------------------------------%
%
-% Stuff to generate code for goals.
+% Generate code for goals.
%
ml_gen_goal_as_branch(CodeModel, Goal, Decls, Statements, !Info) :-
@@ -1767,585 +680,13 @@
Decls = VarDecls ++ GoalDecls,
Statements = GoalStatements.
- % For any given goal, we need to declare any variables which are local
- % to this goal (including its subgoals), but which are not local to
- % a subgoal. If they're local to a subgoal, they will be declared when
- % we generate code for that subgoal.
- %
- % We need to make sure that we declare any type_info or type_classinfo
- % variables *before* any other variables, since the GC tracing code
- % for the other variables may refer to the type_info variables, so they
- % need to be in scope.
- %
- % However, in the common case that the number of variables to declare is
- % zero or one, such reordering is guaranteed to be a no-op, so avoid the
- % expense.
+%-----------------------------------------------------------------------------%
+
+ % Generate MLDS code for the different kinds of HLDS goals.
%
-:- pred find_vars_to_declare(vartypes::in,
- hlds_goal_expr::in, hlds_goal_info::in, list(prog_var)::out) is det.
-
-find_vars_to_declare(VarTypes, GoalExpr, GoalInfo, VarsToDeclare) :-
- goal_expr_find_subgoal_nonlocals(GoalExpr, SubGoalNonLocals),
- NonLocals = goal_info_get_nonlocals(GoalInfo),
- set.difference(SubGoalNonLocals, NonLocals, VarsToDeclareSet),
- set.to_sorted_list(VarsToDeclareSet, VarsToDeclare0),
- (
- ( VarsToDeclare0 = []
- ; VarsToDeclare0 = [_]
- ),
- VarsToDeclare = VarsToDeclare0
- ;
- VarsToDeclare0 = [_, _ | _],
- VarsToDeclare = put_typeinfo_vars_first(VarsToDeclare0, VarTypes)
- ).
-
- % The task of this predicate is to help compute the set of MLDS variables
- % that should be declared at the scope of GoalExpr. This should be the
- % set of variables that
- %
- % - do not occur outside GoalExpr, since if they did, they would have to be
- % declared in a larger scope containing GoalExpr; and
- %
- % - need to be declared at the scope of GoalExpr, since they cannot be
- % declared in a scope inside GoalExpr.
- %
- % Our caller will take care of the first point by deleting the nonlocals
- % set of GoalExpr from the SubGoalNonLocals we return, which means that
- % we can include any variable from GoalExpr's nonlocals set in
- % SubGoalNonLocals without affecting the final outcome.
- %
- % If GoalExpr is a compound goal, a variable that occurs in GoalExpr
- % can be declared in a smaller scope that GoalExpr if it occurs inside
- % a single one of GoalExpr's subgoals. In this case, we therefore return
- % the union of the nonlocals sets of GoalExpr's direct subgoals.
- %
- % If GoalExpr is an atomic goal, there is no smaller scope, but we do have
- % to declare at GoalExpr's scope any MLDS variables that GoalExpr refers to
- % but are not visible GoalExpr. This can happen e.g. with ignored output
- % arguments from calls and unifications.
- %
-:- pred goal_expr_find_subgoal_nonlocals(hlds_goal_expr::in,
- set(prog_var)::out) is det.
-
-goal_expr_find_subgoal_nonlocals(GoalExpr, SubGoalNonLocals) :-
- (
- GoalExpr = unify(_LHS, _RHS, _Mode, Unification, _UnifyContext),
- (
- Unification = construct(LHSVar, _ConsId, ArgVars, _ArgModes,
- _HowToConstruct, _Unique, _SubInfo),
- % _HowToConstruct can contain a var specifying to a cell to reuse
- % or a region to construct the term in, but both of those require
- % that variable to be nonlocal to GoalExpr, which means that they
- % would be subtracted from SubGoalNonLocals by our caller anyway.
- SubGoalNonLocals = set.list_to_set([LHSVar | ArgVars])
- ;
- Unification = deconstruct(LHSVar, _ConsId, ArgVars, _ArgModes,
- _CanFail, _CanCGC),
- SubGoalNonLocals = set.list_to_set([LHSVar | ArgVars])
- ;
- Unification = assign(LHSVar, RHSVar),
- SubGoalNonLocals = set.list_to_set([LHSVar, RHSVar])
- ;
- Unification = simple_test(LHSVar, RHSVar),
- SubGoalNonLocals = set.list_to_set([LHSVar, RHSVar])
- ;
- Unification = complicated_unify(_, _, _),
- unexpected(this_file, "goal_expr_find_subgoal_nonlocals")
- )
- ;
- GoalExpr = plain_call(_PredId, _ProcId, ArgVars, _Builtin,
- _Unify_context, _SymName),
- SubGoalNonLocals = set.list_to_set(ArgVars)
- ;
- GoalExpr = generic_call(GenericCall, ArgVars, _Modes, _Detism),
- (
- GenericCall = higher_order(HOVar, _Purity, _Kind, _Arity),
- SubGoalNonLocals = set.list_to_set([HOVar | ArgVars])
- ;
- GenericCall = class_method(MethodVar, _MethodNum, _MethodClassId,
- _Name),
- SubGoalNonLocals = set.list_to_set([MethodVar | ArgVars])
- ;
- GenericCall = event_call(_Eventname),
- SubGoalNonLocals = set.list_to_set(ArgVars)
- ;
- GenericCall = cast(_CastKind),
- SubGoalNonLocals = set.list_to_set(ArgVars)
- )
- ;
- GoalExpr = call_foreign_proc(_Attr, _PredId, _ProcId, Args, ExtraArgs,
- _TraceCond, _Impl),
- ArgVars = list.map(foreign_arg_var, Args),
- ExtraVars = list.map(foreign_arg_var, ExtraArgs),
- SubGoalNonLocals = set.list_to_set(ExtraVars ++ ArgVars)
- ;
- ( GoalExpr = negation(SubGoal)
- ; GoalExpr = scope(_Reason, SubGoal)
- ),
- % If _Reason = from_ground_term, the TermVar in it is guaranteed by
- % construction to be nonlocal, so there is no need to add it
- % separately.
- % If _Reason = exist_quant(Vars), the variables in Vars are ignored by
- % the code generator.
- SubGoalNonLocals = goal_get_nonlocals(SubGoal)
- ;
- ( GoalExpr = conj(_, SubGoals)
- ; GoalExpr = disj(SubGoals)
- ),
- goals_find_subgoal_nonlocals(SubGoals, set.init, SubGoalNonLocals)
- ;
- GoalExpr = if_then_else(_Vars, Cond, Then, Else),
- % The value of _Vars is not guaranteed to contain the set of variables
- % shared between only Cond and Then.
- goals_find_subgoal_nonlocals([Cond, Then, Else],
- set.init, SubGoalNonLocals)
- ;
- GoalExpr = switch(_Var, _CanFail, Cases),
- % _Var must be nonlocal; if it weren't, there would have been a mode
- % error (no producer for _Var before a consumer, namely this switch).
- cases_find_subgoal_nonlocals(Cases, set.init, SubGoalNonLocals)
- ;
- GoalExpr = shorthand(_),
- unexpected(this_file, "goal_expr_find_subgoal_nonlocals: shorthand")
- ).
-
-:- pred goals_find_subgoal_nonlocals(list(hlds_goal)::in,
- set(prog_var)::in, set(prog_var)::out) is det.
-
-goals_find_subgoal_nonlocals([], !SubGoalNonLocals).
-goals_find_subgoal_nonlocals([SubGoal | SubGoals], !SubGoalNonLocals) :-
- NonLocals = goal_get_nonlocals(SubGoal),
- set.union(!.SubGoalNonLocals, NonLocals, !:SubGoalNonLocals),
- goals_find_subgoal_nonlocals(SubGoals, !SubGoalNonLocals).
-
-:- pred cases_find_subgoal_nonlocals(list(case)::in,
- set(prog_var)::in, set(prog_var)::out) is det.
-
-cases_find_subgoal_nonlocals([], !SubGoalNonLocals).
-cases_find_subgoal_nonlocals([Case | Cases], !SubGoalNonLocals) :-
- Case = case(_, _, SubGoal),
- NonLocals = goal_get_nonlocals(SubGoal),
- set.union(!.SubGoalNonLocals, NonLocals, !:SubGoalNonLocals),
- cases_find_subgoal_nonlocals(Cases, !SubGoalNonLocals).
-
- % If the inner and outer code models are equal, we don't need to do
- % anything.
- %
- % If the inner code model is less precise than the outer code model,
- % then that is either a determinism error, or a situation in which
- % simplify.m is supposed to wrap the goal inside a `some' to indicate that
- % a commit is needed.
- %
- % If the inner code model is more precise than the outer code model,
- % then we need to append some statements to convert the calling convention
- % for the inner code model to that of the outer code model.
-
-ml_gen_maybe_convert_goal_code_model(model_det, model_det, _,
- !Statements, !Info).
-ml_gen_maybe_convert_goal_code_model(model_semi, model_semi, _,
- !Statements, !Info).
-ml_gen_maybe_convert_goal_code_model(model_non, model_non, _,
- !Statements, !Info).
-
-ml_gen_maybe_convert_goal_code_model(model_det, model_semi, _, _, _, !Info) :-
- unexpected(this_file,
- "ml_gen_maybe_convert_goal_code_model: semi in det").
-ml_gen_maybe_convert_goal_code_model(model_det, model_non, _, _, _, !Info) :-
- unexpected(this_file,
- "ml_gen_maybe_convert_goal_code_model: nondet in det").
-ml_gen_maybe_convert_goal_code_model(model_semi, model_non, _, _, _, !Info) :-
- unexpected(this_file,
- "ml_gen_maybe_convert_goal_code_model: nondet in semi").
-
-ml_gen_maybe_convert_goal_code_model(model_semi, model_det, Context,
- !Statements, !Info) :-
- % det goal in semidet context:
- % <succeeded = Goal>
- % ===>
- % <do Goal>
- % succeeded = MR_TRUE
-
- ml_gen_set_success(!.Info, ml_const(mlconst_true), Context,
- SetSuccessTrue),
- !:Statements = !.Statements ++ [SetSuccessTrue].
-
-ml_gen_maybe_convert_goal_code_model(model_non, model_det, Context,
- !Statements, !Info) :-
- % det goal in nondet context:
- % <Goal && SUCCEED()>
- % ===>
- % <do Goal>
- % SUCCEED()
-
- ml_gen_call_current_success_cont(Context, CallCont, !Info),
- !:Statements = !.Statements ++ [CallCont].
-
-ml_gen_maybe_convert_goal_code_model(model_non, model_semi, Context,
- !Statements, !Info) :-
- % semi goal in nondet context:
- % <Goal && SUCCEED()>
- % ===>
- % MR_bool succeeded;
- %
- % <succeeded = Goal>
- % if (succeeded) SUCCEED()
-
- ml_gen_test_success(!.Info, Succeeded),
- ml_gen_call_current_success_cont(Context, CallCont, !Info),
- IfStmt = ml_stmt_if_then_else(Succeeded, CallCont, no),
- IfStatement = statement(IfStmt, mlds_make_context(Context)),
- !:Statements = !.Statements ++ [IfStatement].
-
- % Generate code for a commit.
- %
-:- pred ml_gen_commit(hlds_goal::in, code_model::in, prog_context::in,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_commit(Goal, CodeModel, Context, Decls, Statements, !Info) :-
- Goal = hlds_goal(_, GoalInfo),
- GoalCodeModel = goal_info_get_code_model(GoalInfo),
- GoalContext = goal_info_get_context(GoalInfo),
-
- (
- GoalCodeModel = model_non,
- CodeModel = model_semi
- ->
-
- % model_non in semi context: (using try_commit/do_commit)
- % <succeeded = Goal>
- % ===>
- % MR_bool succeeded;
- % #ifdef NONDET_COPY_OUT
- % <local var decls>
- % #endif
- % #ifdef PUT_COMMIT_IN_OWN_FUNC
- % /*
- % ** to avoid problems with setjmp() and non-volatile
- % ** local variables, we need to put the call to
- % ** setjmp() in its own nested function
- % */
- % void commit_func()
- % {
- % #endif
- % MR_COMMIT_TYPE ref;
- %
- % void success() {
- % MR_DO_COMMIT(ref);
- % }
- %
- % MR_TRY_COMMIT(ref, {
- % <Goal && success()>
- % succeeded = MR_FALSE;
- % }, {
- % #ifdef NONDET_COPY_OUT
- % <copy local vars to output args>
- % #endif
- % succeeded = MR_TRUE;
- % })
- % #ifdef PUT_COMMIT_IN_OWN_FUNC
- %
- % commit_func();
- % #endif
-
- ml_gen_maybe_make_locals_for_output_args(GoalInfo, LocalVarDecls,
- CopyLocalsToOutputArgs, OrigVarLvalMap, !Info),
-
- % Generate the `success()' function.
- ml_gen_new_func_label(no, SuccessFuncLabel, SuccessFuncLabelRval,
- !Info),
- % push nesting level
- MLDS_Context = mlds_make_context(Context),
- ml_gen_info_new_aux_var_name("commit", CommitRef, !Info),
- ml_gen_var_lval(!.Info, CommitRef, mlds_commit_type, CommitRefLval),
- CommitRefDecl = ml_gen_commit_var_decl(MLDS_Context, CommitRef),
- DoCommitStmt = ml_stmt_do_commit(ml_lval(CommitRefLval)),
- DoCommitStatement = statement(DoCommitStmt, MLDS_Context),
- % Pop nesting level.
- ml_gen_nondet_label_func(!.Info, SuccessFuncLabel, Context,
- DoCommitStatement, SuccessFunc),
-
- ml_get_env_ptr(!.Info, EnvPtrRval),
- SuccessCont = success_cont(SuccessFuncLabelRval, EnvPtrRval, [], []),
- ml_gen_info_push_success_cont(SuccessCont, !Info),
- ml_gen_goal(model_non, Goal, GoalDecls, GoalStatements, !Info),
- % Hoist any static constant declarations for Goal out to the top level.
- list.filter(ml_decl_is_static_const, GoalDecls,
- GoalStaticDecls, GoalOtherDecls),
- GoalStatement = ml_gen_block(GoalOtherDecls, GoalStatements,
- GoalContext),
- ml_gen_info_pop_success_cont(!Info),
- ml_gen_set_success(!.Info, ml_const(mlconst_false), Context,
- SetSuccessFalse),
- ml_gen_set_success(!.Info, ml_const(mlconst_true), Context,
- SetSuccessTrue),
- TryCommitStmt = ml_stmt_try_commit(CommitRefLval,
- ml_gen_block([], [GoalStatement, SetSuccessFalse], Context),
- ml_gen_block([], CopyLocalsToOutputArgs ++ [SetSuccessTrue],
- Context)
- ),
- TryCommitStatement = statement(TryCommitStmt, MLDS_Context),
- CommitFuncLocalDecls = [CommitRefDecl, SuccessFunc | GoalStaticDecls],
- maybe_put_commit_in_own_func(CommitFuncLocalDecls,
- [TryCommitStatement], Context, CommitFuncDecls, Statements, !Info),
- Decls = LocalVarDecls ++ CommitFuncDecls,
-
- ml_gen_info_set_var_lvals(OrigVarLvalMap, !Info)
- ;
- GoalCodeModel = model_non,
- CodeModel = model_det
- ->
- % model_non in det context: (using try_commit/do_commit)
- % <do Goal>
- % ===>
- % #ifdef NONDET_COPY_OUT
- % <local var decls>
- % #endif
- % #ifdef PUT_COMMIT_IN_NESTED_FUNC
- % /*
- % ** to avoid problems with setjmp() and non-volatile
- % ** local variables, we need to put the call to
- % ** setjmp() in its own nested functions
- % */
- % void commit_func()
- % {
- % #endif
- % MR_COMMIT_TYPE ref;
- % void success() {
- % MR_DO_COMMIT(ref);
- % }
- % MR_TRY_COMMIT(ref, {
- % <Goal && success()>
- % }, {
- % #ifdef NONDET_COPY_OUT
- % <copy local vars to output args>
- % #endif
- % })
- % #ifdef PUT_COMMIT_IN_NESTED_FUNC
- %
- % commit_func();
- % #endif
-
- ml_gen_maybe_make_locals_for_output_args(GoalInfo, LocalVarDecls,
- CopyLocalsToOutputArgs, OrigVarLvalMap, !Info),
-
- % Generate the `success()' function.
- ml_gen_new_func_label(no, SuccessFuncLabel, SuccessFuncLabelRval,
- !Info),
- % push nesting level
- MLDS_Context = mlds_make_context(Context),
- ml_gen_info_new_aux_var_name("commit", CommitRef, !Info),
- ml_gen_var_lval(!.Info, CommitRef, mlds_commit_type, CommitRefLval),
- CommitRefDecl = ml_gen_commit_var_decl(MLDS_Context, CommitRef),
- DoCommitStmt = ml_stmt_do_commit(ml_lval(CommitRefLval)),
- DoCommitStatement = statement(DoCommitStmt, MLDS_Context),
- % pop nesting level
- ml_gen_nondet_label_func(!.Info, SuccessFuncLabel, Context,
- DoCommitStatement, SuccessFunc),
-
- ml_get_env_ptr(!.Info, EnvPtrRval),
- SuccessCont = success_cont(SuccessFuncLabelRval, EnvPtrRval, [], []),
- ml_gen_info_push_success_cont(SuccessCont, !Info),
- ml_gen_goal(model_non, Goal, GoalDecls, GoalStatements, !Info),
- % Hoist any static constant declarations for Goal out to the top level.
- list.filter(ml_decl_is_static_const, GoalDecls,
- GoalStaticDecls, GoalOtherDecls),
- GoalStatement = ml_gen_block(GoalOtherDecls, GoalStatements,
- GoalContext),
- ml_gen_info_pop_success_cont(!Info),
-
- TryCommitStmt = ml_stmt_try_commit(CommitRefLval, GoalStatement,
- ml_gen_block([], CopyLocalsToOutputArgs, Context)),
- TryCommitStatement = statement(TryCommitStmt, MLDS_Context),
- CommitFuncLocalDecls = [CommitRefDecl, SuccessFunc | GoalStaticDecls],
- maybe_put_commit_in_own_func(CommitFuncLocalDecls,
- [TryCommitStatement], Context, CommitFuncDecls, Statements, !Info),
- Decls = LocalVarDecls ++ CommitFuncDecls,
- ml_gen_info_set_var_lvals(OrigVarLvalMap, !Info)
- ;
- % No commit required.
- ml_gen_goal(CodeModel, Goal, Decls, Statements, !Info)
- ).
-
- % maybe_put_commit_in_own_func(Defns0, Stmts0, Defns, Stmts):
- %
- % If the --put-commit-in-own-func option is set, put the commit in its
- % own function. This is needed for the high-level C back-end, to handle
- % problems with setjmp()/longjmp() clobbering non-volatile local variables.
- %
- % Detailed explanation:
- %
- % For the high-level C back-end, we implement commits using
- % setjmp()/longjmp(). Unfortunately for us, ANSI/ISO C says that longjmp()
- % is allowed to clobber the values of any non-volatile local variables
- % in the function that called setjmp() which have been modified between
- % the setjmp() and the longjmp().
- %
- % To avoid this, whenever we generate a commit, we put it in its own
- % nested function, with the local variables (e.g. `succeeded', plus any
- % outputs from the goal that we're committing over) remaining in the
- % containing function. This ensures that none of the variables which
- % get modified between the setjmp() and the longjmp() and which get
- % referenced after the longjmp() are local variables in the function
- % containing the setjmp().
- %
- % [The obvious alternative of declaring the local variables in the function
- % containing setjmp() as `volatile' doesn't work, since the assignments
- % to those output variables may be deep in some function called indirectly
- % from the goal that we're committing across, and assigning to a
- % volatile-qualified variable via a non-volatile pointer is undefined
- % behaviour. The only way to make it work would be to be to declare
- % *every* output argument that we pass by reference as `volatile T *'.
- % But that would impose distributed fat and would make interoperability
- % difficult.]
- %
-:- pred maybe_put_commit_in_own_func(list(mlds_defn)::in, list(statement)::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-maybe_put_commit_in_own_func(CommitFuncLocalDecls, TryCommitStatements,
- Context, Decls, Statements, !Info) :-
- ml_gen_info_put_commit_in_own_func(!.Info, PutCommitInOwnFunc),
- (
- PutCommitInOwnFunc = yes,
-
- % Generate the `void commit_func() { ... }' wrapper
- % around the main body that we generated above
- ml_gen_new_func_label(no, CommitFuncLabel, CommitFuncLabelRval, !Info),
- % push nesting level
- CommitFuncBody = ml_gen_block(CommitFuncLocalDecls,
- TryCommitStatements, Context),
- % pop nesting level
- ml_gen_nondet_label_func(!.Info, CommitFuncLabel, Context,
- CommitFuncBody, CommitFunc),
-
- % Generate the call to `commit_func();'
- ml_gen_info_use_gcc_nested_functions(!.Info, UseNestedFuncs),
- (
- UseNestedFuncs = yes,
- ArgRvals = [],
- ArgTypes = []
- ;
- UseNestedFuncs = no,
- ml_get_env_ptr(!.Info, EnvPtrRval),
- ArgRvals = [EnvPtrRval],
- ArgTypes = [mlds_generic_env_ptr_type]
- ),
- RetTypes = [],
- Signature = mlds_func_signature(ArgTypes, RetTypes),
- CallKind = ordinary_call,
- CallStmt = ml_stmt_call(Signature, CommitFuncLabelRval, no, ArgRvals,
- [], CallKind),
- CallStatement = statement(CallStmt, mlds_make_context(Context)),
- % Package it all up.
- Statements = [CallStatement],
- Decls = [CommitFunc]
- ;
- PutCommitInOwnFunc = no,
- Statements = TryCommitStatements,
- Decls = CommitFuncLocalDecls
- ).
-
- % In commits, you have model_non code called from a model_det or model_semi
- % context. With --nondet-copy-out, when generating code for commits,
- % if the context is a model_det or model_semi procedure with output
- % arguments passed by reference, then we need to introduce local variables
- % corresponding to those output arguments, and at the end of the commit
- % we'll copy the local variables into the output arguments.
- %
-:- pred ml_gen_maybe_make_locals_for_output_args(hlds_goal_info::in,
- list(mlds_defn)::out, list(statement)::out,
- map(prog_var, mlds_lval)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_maybe_make_locals_for_output_args(GoalInfo, LocalVarDecls,
- CopyLocalsToOutputArgs, OrigVarLvalMap, !Info) :-
- ml_gen_info_get_var_lvals(!.Info, OrigVarLvalMap),
- ml_gen_info_get_globals(!.Info, Globals),
- globals.lookup_bool_option(Globals, nondet_copy_out, NondetCopyOut),
- (
- NondetCopyOut = yes,
- Context = goal_info_get_context(GoalInfo),
- NonLocals = goal_info_get_nonlocals(GoalInfo),
- ml_gen_info_get_byref_output_vars(!.Info, ByRefOutputVars),
- VarsToCopy = set.intersect(set.list_to_set(ByRefOutputVars),
- NonLocals),
- ml_gen_make_locals_for_output_args(set.to_sorted_list(VarsToCopy),
- Context, LocalVarDecls, CopyLocalsToOutputArgs, !Info)
- ;
- NondetCopyOut = no,
- LocalVarDecls = [],
- CopyLocalsToOutputArgs = []
- ).
-
-:- pred ml_gen_make_locals_for_output_args(list(prog_var)::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_make_locals_for_output_args([], _, [], [], !Info).
-ml_gen_make_locals_for_output_args([Var | Vars], Context,
- LocalDefns, Assigns, !Info) :-
- ml_gen_make_locals_for_output_args(Vars, Context, LocalDefns0, Assigns0,
- !Info),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ml_variable_type(!.Info, Var, Type),
- IsDummy = check_dummy_type(ModuleInfo, Type),
- (
- IsDummy = is_dummy_type,
- LocalDefns = LocalDefns0,
- Assigns = Assigns0
- ;
- IsDummy = is_not_dummy_type,
- ml_gen_make_local_for_output_arg(Var, Type, Context,
- LocalDefn, Assign, !Info),
- LocalDefns = [LocalDefn | LocalDefns0],
- Assigns = [Assign | Assigns0]
- ).
-
-:- pred ml_gen_make_local_for_output_arg(prog_var::in, mer_type::in,
- prog_context::in, mlds_defn::out, statement::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_make_local_for_output_arg(OutputVar, Type, Context,
- LocalVarDefn, Assign, !Info) :-
- % Look up the name of the output variable.
- ml_gen_info_get_varset(!.Info, VarSet),
- OutputVarName = ml_gen_var_name(VarSet, OutputVar),
-
- % Generate a declaration for a corresponding local variable.
- OutputVarName = mlds_var_name(OutputVarNameStr, MaybeNum),
- LocalVarName = mlds_var_name(
- string.append("local_", OutputVarNameStr), MaybeNum),
- ml_gen_type(!.Info, Type, MLDS_Type),
- ml_gen_gc_statement(LocalVarName, Type, Context, GCStatement,
- !Info),
- LocalVarDefn = ml_gen_mlds_var_decl(mlds_data_var(LocalVarName), MLDS_Type,
- GCStatement, mlds_make_context(Context)),
-
- % Generate code to assign from the local var to the output var.
- ml_gen_var(!.Info, OutputVar, OutputVarLval),
- ml_gen_var_lval(!.Info, LocalVarName, MLDS_Type, LocalVarLval),
- Assign = ml_gen_assign(OutputVarLval, ml_lval(LocalVarLval), Context),
-
- % Update the lval for this variable so that any references to it inside
- % the commit refer to the local variable rather than to the output
- % argument. (Note that we reset all the var lvals at the end of the
- % commit.)
- ml_gen_info_set_var_lval(OutputVar, LocalVarLval, !Info).
-
- % Generate the declaration for the `commit' variable.
- %
-:- func ml_gen_commit_var_decl(mlds_context, mlds_var_name) = mlds_defn.
-
-ml_gen_commit_var_decl(Context, VarName) =
- ml_gen_mlds_var_decl(mlds_data_var(VarName), mlds_commit_type, gc_no_stmt,
- Context).
-
- % Generate MLDS code for the different kinds of HLDS goals.
- %
-:- pred ml_gen_goal_expr(hlds_goal_expr::in, code_model::in, prog_context::in,
- hlds_goal_info::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_goal_expr(hlds_goal_expr::in, code_model::in, prog_context::in,
+ hlds_goal_info::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_goal_expr(GoalExpr, CodeModel, Context, GoalInfo, Decls, Statements,
!Info) :-
@@ -2457,1299 +798,257 @@
unexpected(this_file, "ml_gen_goal_expr: unexpected shorthand")
).
- % ml_foreign creates MLDS code to execute foreign language code.
- %
-:- pred ml_gen_nondet_pragma_foreign_proc(code_model::in,
- pragma_foreign_proc_attributes::in,
- pred_id::in, proc_id::in, list(foreign_arg)::in,
- prog_context::in, string::in, maybe(prog_context)::in, string::in,
- maybe(prog_context)::in, string::in, maybe(prog_context)::in,
- string::in, maybe(prog_context)::in,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+%-----------------------------------------------------------------------------%
- % For model_non pragma c_code,
- % we generate code of the following form:
- %
- % #define MR_PROC_LABEL <procedure name>
- % <declaration of locals needed for boxing/unboxing>
- % {
- % <declaration of one local variable for each arg>
- % struct {
- % <user's local_vars decls>
- % } MR_locals;
- % MR_bool MR_done = MR_FALSE;
- % MR_bool MR_succeeded = MR_FALSE;
- %
- % #define FAIL (MR_done = MR_TRUE)
- % #define SUCCEED (MR_succeeded = MR_TRUE)
- % #define SUCCEED_LAST (MR_succeeded = MR_TRUE, \
- % MR_done = MR_TRUE)
- % #define LOCALS (&MR_locals)
- %
- % <assign input args>
- % <obtain global lock>
- % <user's first_code C code>
- % while (true) {
- % <user's shared_code C code>
- % <release global lock>
- % if (MR_succeeded) {
- % <assign output args>
- % <boxing/unboxing of outputs>
- % CONT();
- % }
- % if (MR_done) break;
- % MR_succeeded = MR_FALSE;
- % <obtain global lock>
- % <user's later_code C code>
- % }
+ % For any given goal, we need to declare any variables which are local
+ % to this goal (including its subgoals), but which are not local to
+ % a subgoal. If they're local to a subgoal, they will be declared when
+ % we generate code for that subgoal.
%
- % #undef FAIL
- % #undef SUCCEED
- % #undef SUCCEED_LAST
- % #undef LOCALS
- % }
- % #undef MR_PROC_LABEL
+ % We need to make sure that we declare any type_info or type_classinfo
+ % variables *before* any other variables, since the GC tracing code
+ % for the other variables may refer to the type_info variables, so they
+ % need to be in scope.
%
- % We insert a #define for MR_PROC_LABEL, so that the C code in the Mercury
- % standard library that allocates memory manually can use MR_PROC_LABEL
- % as the procname argument to incr_hp_msg(), for memory profiling.
- % Hard-coding the procname argument in the C code would be wrong,
- % since it wouldn't handle the case where the original pragma foreign_proc
- % procedure gets inlined and optimized away. Of course we also need to
- % #undef it afterwards.
+ % However, in the common case that the number of variables to declare is
+ % zero or one, such reordering is guaranteed to be a no-op, so avoid the
+ % expense.
%
-ml_gen_nondet_pragma_foreign_proc(CodeModel, Attributes, PredId, _ProcId,
- Args, Context, LocalVarsDecls, LocalVarsContext,
- FirstCode, FirstContext, LaterCode, LaterContext,
- SharedCode, SharedContext, Decls, Statements, !Info) :-
- Lang = get_foreign_language(Attributes),
- ( Lang = lang_csharp ->
- sorry(this_file, "nondet pragma foreign_proc for C#")
- ;
- true
- ),
-
- % Generate <declaration of one local variable for each arg>
- ml_gen_pragma_c_decls(!.Info, Lang, Args, ArgDeclsList),
-
- % Generate definitions of the FAIL, SUCCEED, SUCCEED_LAST,
- % and LOCALS macros.
-
- string.append_list([
-" #define FAIL (MR_done = MR_TRUE)\n",
-" #define SUCCEED (MR_succeeded = MR_TRUE)\n",
-" #define SUCCEED_LAST (MR_succeeded = MR_TRUE, MR_done = MR_TRUE)\n",
-" #define LOCALS (&MR_locals)\n"
- ], HashDefines),
- string.append_list([
- " #undef FAIL\n",
- " #undef SUCCEED\n",
- " #undef SUCCEED_LAST\n",
- " #undef LOCALS\n"
- ], HashUndefs),
-
- % Generate code to set the values of the input variables.
- ml_gen_pragma_c_java_input_arg_list(Lang, Args, AssignInputsList, !Info),
-
- % Generate code to assign the values of the output variables.
- ml_gen_pragma_c_output_arg_list(Args, Context,
- AssignOutputsList, ConvDecls, ConvStatements, !Info),
-
- % Generate code fragments to obtain and release the global lock.
- ThreadSafe = get_thread_safe(Attributes),
- ml_gen_obtain_release_global_lock(!.Info, ThreadSafe, PredId,
- ObtainLock, ReleaseLock),
-
- % Generate the MR_PROC_LABEL #define.
- ml_gen_hash_define_mr_proc_label(!.Info, HashDefine),
-
- % Put it all together.
- Starting_C_Code = list.condense([
- [raw_target_code("{\n", [])],
- HashDefine,
- ArgDeclsList,
- [raw_target_code("\tstruct {\n", []),
- user_target_code(LocalVarsDecls, LocalVarsContext, []),
- raw_target_code("\n", []),
- raw_target_code("\t} MR_locals;\n", []),
- raw_target_code("\tMR_bool MR_succeeded = MR_FALSE;\n", []),
- raw_target_code("\tMR_bool MR_done = MR_FALSE;\n", []),
- raw_target_code("\n", []),
- raw_target_code(HashDefines, []),
- raw_target_code("\n", [])],
- AssignInputsList,
- [raw_target_code(ObtainLock, []),
- raw_target_code("\t{\n", []),
- user_target_code(FirstCode, FirstContext, []),
- raw_target_code("\n\t;}\n", []),
- raw_target_code("\twhile (1) {\n", []),
- raw_target_code("\t\t{\n", []),
- user_target_code(SharedCode, SharedContext, []),
- raw_target_code("\n\t\t;}\n", []),
- raw_target_code("#undef MR_PROC_LABEL\n", []),
- raw_target_code(ReleaseLock, []),
- raw_target_code("\t\tif (MR_succeeded) {\n", [])],
- AssignOutputsList
- ]),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_target(Globals, Target),
- (
- CodeModel = model_non,
-
- (
- Target = target_il,
- % For IL code, we can't call continutations because there is no
- % syntax for calling managed function pointers in C#. Instead,
- % we have to call back into IL and make the continuation call
- % in IL. This is called an "indirect" success continuation call.
- ml_gen_call_current_success_cont_indirectly(Context, CallCont,
- !Info)
- ;
- ( Target = target_c
- ; Target = target_java
- ; Target = target_asm
- ),
- ml_gen_call_current_success_cont(Context, CallCont, !Info)
- ;
- Target = target_x86_64,
- unexpected(this_file,
- "target x86_64 with --high-level-code")
- ;
- Target = target_erlang,
- unexpected(this_file,
- "ml_gen_nondet_pragma_foreign_proc: target erlang")
- )
- ;
- ( CodeModel = model_det
- ; CodeModel = model_semi
- ),
- unexpected(this_file,
- "ml_gen_nondet_pragma_foreign_proc: unexpected code model")
- ),
- Ending_C_Code = [
- raw_target_code("\t\t}\n", []),
- raw_target_code("\t\tif (MR_done) break;\n", []),
- raw_target_code("\tMR_succeeded = MR_FALSE;\n", []),
- raw_target_code(ObtainLock, []),
- raw_target_code("\t\t{\n", []),
- user_target_code(LaterCode, LaterContext, []),
- raw_target_code("\n\t\t;}\n", []),
- raw_target_code("\t}\n", []),
- raw_target_code("\n", []),
- raw_target_code(HashUndefs, []),
- raw_target_code("}\n", [])
- ],
- Starting_C_Code_Stmt = inline_target_code(ml_target_c, Starting_C_Code),
- Starting_C_Code_Statement = statement(
- ml_stmt_atomic(Starting_C_Code_Stmt), mlds_make_context(Context)),
- Ending_C_Code_Stmt = inline_target_code(ml_target_c, Ending_C_Code),
- Ending_C_Code_Statement = statement(
- ml_stmt_atomic(Ending_C_Code_Stmt), mlds_make_context(Context)),
- Statements =
- [Starting_C_Code_Statement | ConvStatements] ++
- [CallCont, Ending_C_Code_Statement],
- Decls = ConvDecls.
-
-:- pred ml_gen_trace_runtime_cond(trace_expr(trace_runtime)::in,
- term.context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_trace_runtime_cond(TraceRuntimeCond, Context, Decls, Statements,
- !Info) :-
- Decls = [],
- MLDSContext = mlds_make_context(Context),
- ml_success_lval(!.Info, SuccessLval),
- ml_generate_runtime_cond_code(TraceRuntimeCond, CondRval, !Info),
- Statement = statement(ml_stmt_atomic(assign(SuccessLval, CondRval)),
- MLDSContext),
- Statements = [Statement].
-
-:- pred ml_generate_runtime_cond_code(trace_expr(trace_runtime)::in,
- mlds_rval::out, ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_generate_runtime_cond_code(Expr, CondRval, !Info) :-
- (
- Expr = trace_base(trace_envvar(EnvVar)),
- ml_gen_info_add_env_var_name(EnvVar, !Info),
- EnvVarRval = ml_lval(ml_global_var_ref(env_var_ref(EnvVar))),
- ZeroRval = ml_const(mlconst_int(0)),
- CondRval = ml_binop(ne, EnvVarRval, ZeroRval)
- ;
- Expr = trace_not(ExprA),
- ml_generate_runtime_cond_code(ExprA, RvalA, !Info),
- CondRval = ml_unop(std_unop(logical_not), RvalA)
- ;
- Expr = trace_op(TraceOp, ExprA, ExprB),
- ml_generate_runtime_cond_code(ExprA, RvalA, !Info),
- ml_generate_runtime_cond_code(ExprB, RvalB, !Info),
- (
- TraceOp = trace_or,
- Op = logical_or
- ;
- TraceOp = trace_and,
- Op = logical_and
- ),
- CondRval = ml_binop(Op, RvalA, RvalB)
- ).
-
-:- pred ml_gen_ordinary_pragma_foreign_proc(code_model::in,
- pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
- list(foreign_arg)::in, list(foreign_arg)::in, string::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_ordinary_pragma_foreign_proc(CodeModel, Attributes, PredId, ProcId,
- Args, ExtraArgs, Foreign_Code, Context, Decls, Statements, !Info) :-
- Lang = get_foreign_language(Attributes),
- (
- CodeModel = model_det,
- OrdinaryKind = kind_det
- ;
- CodeModel = model_semi,
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
- _PredInfo, ProcInfo),
- proc_info_interface_determinism(ProcInfo, Detism),
- determinism_components(Detism, _, MaxSoln),
- (
- MaxSoln = at_most_zero,
- OrdinaryKind = kind_failure
- ;
- ( MaxSoln = at_most_one
- ; MaxSoln = at_most_many
- ; MaxSoln = at_most_many_cc
- ),
- OrdinaryKind = kind_semi
- )
- ;
- CodeModel = model_non,
- OrdinaryDespiteDetism = get_ordinary_despite_detism(Attributes),
- (
- OrdinaryDespiteDetism = no,
- unexpected(this_file,
- "ml_gen_ordinary_pragma_foreign_proc: unexpected code model")
- ;
- OrdinaryDespiteDetism = yes,
- OrdinaryKind = kind_semi
- )
- ),
- (
- Lang = lang_c,
- ml_gen_ordinary_pragma_c_proc(OrdinaryKind, Attributes,
- PredId, ProcId, Args, ExtraArgs,
- Foreign_Code, Context, Decls, Statements, !Info)
- ;
- Lang = lang_csharp,
- ml_gen_ordinary_pragma_managed_proc(OrdinaryKind, Attributes,
- PredId, ProcId, Args, ExtraArgs,
- Foreign_Code, Context, Decls, Statements, !Info)
- ;
- Lang = lang_il,
- % XXX should pass OrdinaryKind
- ml_gen_ordinary_pragma_il_proc(CodeModel, Attributes,
- PredId, ProcId, Args, ExtraArgs,
- Foreign_Code, Context, Decls, Statements, !Info)
- ;
- Lang = lang_java,
- % XXX should pass OrdinaryKind
- ml_gen_ordinary_pragma_java_proc(CodeModel, Attributes,
- PredId, ProcId, Args, ExtraArgs,
- Foreign_Code, Context, Decls, Statements, !Info)
- ;
- Lang = lang_erlang,
- unexpected(this_file,
- "ml_gen_ordinary_pragma_foreign_proc: unexpected language Erlang")
- ).
-
-:- pred ml_gen_ordinary_pragma_java_proc(code_model::in,
- pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
- list(foreign_arg)::in, list(foreign_arg)::in, string::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_ordinary_pragma_java_proc(_CodeModel, Attributes, PredId, _ProcId,
- Args, ExtraArgs, JavaCode, Context, Decls, Statements, !Info) :-
- Lang = get_foreign_language(Attributes),
-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- pred_info_get_markers(PredInfo, Markers),
- ( check_marker(Markers, marker_mutable_access_pred) ->
- MutableSpecial = mutable_special_case
- ;
- MutableSpecial = not_mutable_special_case
- ),
-
- % Generate <declaration of one local variable for each arg>
- ml_gen_pragma_java_decls(!.Info, MutableSpecial, Args, ArgDeclsList),
- expect(unify(ExtraArgs, []), this_file,
- "ml_gen_ordinary_pragma_java_proc: extra args"),
-
- % Generate code to set the values of the input variables.
- ml_gen_pragma_c_java_input_arg_list(Lang, Args, AssignInputsList, !Info),
-
- % Generate MLDS statements to assign the values of the output variables.
- ml_gen_pragma_java_output_arg_list(MutableSpecial, Args, Context,
- AssignOutputsList, ConvDecls, ConvStatements, !Info),
-
- % Put it all together
- % XXX FIXME need to handle model_semi code here,
- % i.e. provide some equivalent to SUCCESS_INDICATOR.
- Java_Code = list.condense([
- ArgDeclsList,
- AssignInputsList,
- [user_target_code(JavaCode, yes(Context), [])]
- ]),
- Java_Code_Stmt = inline_target_code(ml_target_java, Java_Code),
- Java_Code_Statement = statement(
- ml_stmt_atomic(Java_Code_Stmt),
- mlds_make_context(Context)),
- Statements = [Java_Code_Statement | AssignOutputsList] ++ ConvStatements,
- Decls = ConvDecls.
-
-:- type ordinary_pragma_kind
- ---> kind_det
- ; kind_semi
- ; kind_failure.
-
- % For ordinary (not model_non) pragma foreign_code in C#,
- % we generate a call to an out-of-line procedure that contains
- % the user's code.
- %
-:- pred ml_gen_ordinary_pragma_managed_proc(ordinary_pragma_kind::in,
- pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
- list(foreign_arg)::in, list(foreign_arg)::in, string::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_ordinary_pragma_managed_proc(OrdinaryKind, Attributes, _PredId, _ProcId,
- Args, ExtraArgs, ForeignCode, Context, Decls, Statements, !Info) :-
- ml_gen_outline_args(Args, OutlineArgs, !Info),
- expect(unify(ExtraArgs, []), this_file,
- "ml_gen_ordinary_pragma_managed_proc: extra args"),
-
- ForeignLang = get_foreign_language(Attributes),
- MLDSContext = mlds_make_context(Context),
- ml_gen_info_get_value_output_vars(!.Info, OutputVars),
- ml_gen_var_list(!.Info, OutputVars, OutputVarLvals),
- OutlineStmt = outline_foreign_proc(ForeignLang, OutlineArgs,
- OutputVarLvals, ForeignCode),
-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_name(ModuleInfo, ModuleName),
- MLDSModuleName = mercury_module_name_to_mlds(ModuleName),
-
- ml_success_lval(!.Info, SucceededLval),
- (
- OrdinaryKind = kind_det,
- SuccessVarLocals = [],
- SuccessIndicatorStatements = []
- ;
- OrdinaryKind = kind_semi,
- % If the code is semidet, we should copy SUCCESS_INDICATOR
- % out into "success".
- SuccessIndicatorVarName = mlds_var_name("SUCCESS_INDICATOR", no),
- SuccessIndicatorDecl = ml_gen_mlds_var_decl(
- mlds_data_var(SuccessIndicatorVarName),
- mlds_native_bool_type,
- gc_no_stmt, MLDSContext),
- SuccessIndicatorLval = ml_var(qual(MLDSModuleName, module_qual,
- SuccessIndicatorVarName), mlds_native_bool_type),
- SuccessIndicatorStatement = ml_gen_assign(SucceededLval,
- ml_lval(SuccessIndicatorLval), Context),
- SuccessVarLocals = [SuccessIndicatorDecl],
- SuccessIndicatorStatements = [SuccessIndicatorStatement]
- ;
- OrdinaryKind = kind_failure,
- unexpected(this_file,
- "ml_gen_ordinary_pragma_managed_proc: " ++
- "kind_failure not yet implemented")
- ),
-
- OutlineStatement = statement(ml_stmt_atomic(OutlineStmt), MLDSContext),
- Statements = [OutlineStatement | SuccessIndicatorStatements],
- Decls = SuccessVarLocals.
-
-:- pred ml_gen_outline_args(list(foreign_arg)::in, list(outline_arg)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+:- pred find_vars_to_declare(vartypes::in,
+ hlds_goal_expr::in, hlds_goal_info::in, list(prog_var)::out) is det.
-ml_gen_outline_args([], [], !Info).
-ml_gen_outline_args([Arg | Args], [OutlineArg | OutlineArgs], !Info) :-
- Arg = foreign_arg(Var, MaybeVarMode, OrigType, BoxPolicy),
- ml_gen_outline_args(Args, OutlineArgs, !Info),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ml_gen_var(!.Info, Var, VarLval),
+find_vars_to_declare(VarTypes, GoalExpr, GoalInfo, VarsToDeclare) :-
+ goal_expr_find_subgoal_nonlocals(GoalExpr, SubGoalNonLocals),
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ set.difference(SubGoalNonLocals, NonLocals, VarsToDeclareSet),
+ set.to_sorted_list(VarsToDeclareSet, VarsToDeclare0),
(
- BoxPolicy = native_if_possible,
- ml_gen_type(!.Info, OrigType, MldsType)
- ;
- BoxPolicy = always_boxed,
- MldsType = mlds_generic_type
+ ( VarsToDeclare0 = []
+ ; VarsToDeclare0 = [_]
),
- (
- MaybeVarMode = yes(ArgName - Mode),
- check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
- not var_is_singleton(ArgName)
- ->
- mode_to_arg_mode(ModuleInfo, Mode, OrigType, ArgMode),
- (
- ArgMode = top_in,
- OutlineArg = ola_in(MldsType, ArgName, ml_lval(VarLval))
- ;
- ArgMode = top_out,
- OutlineArg = ola_out(MldsType, ArgName, VarLval)
- ;
- ArgMode = top_unused,
- OutlineArg = ola_unused
- )
+ VarsToDeclare = VarsToDeclare0
;
- OutlineArg = ola_unused
+ VarsToDeclare0 = [_, _ | _],
+ VarsToDeclare = put_typeinfo_vars_first(VarsToDeclare0, VarTypes)
).
-:- pred ml_gen_ordinary_pragma_il_proc(code_model::in,
- pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
- list(foreign_arg)::in, list(foreign_arg)::in, string::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_ordinary_pragma_il_proc(_CodeModel, Attributes, PredId, ProcId,
- Args, ExtraArgs, ForeignCode, Context, Decls, Statements, !Info) :-
- expect(unify(ExtraArgs, []), this_file,
- "ml_gen_ordinary_pragma_managed_proc: extra args"),
-
- % XXX FIXME need to handle model_semi code here,
- % i.e. provide some equivalent to SUCCESS_INDICATOR.
-
- % XXX FIXME do we handle top_unused mode correctly?
-
- MLDSContext = mlds_make_context(Context),
-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
- _PredInfo, ProcInfo),
- proc_info_get_varset(ProcInfo, VarSet),
-% proc_info_get_vartypes(ProcInfo, VarTypes),
- % note that for headvars we must use the types from
- % the procedure interface, not from the procedure body
- ml_gen_info_get_byref_output_vars(!.Info, ByRefOutputVars),
- ml_gen_info_get_value_output_vars(!.Info, CopiedOutputVars),
- module_info_get_name(ModuleInfo, ModuleName),
- MLDSModuleName = mercury_module_name_to_mlds(ModuleName),
-
- % XXX in the code to marshall parameters, fjh says:
- % We need to handle the case where the types in the procedure interface
- % are polymorphic, but the types of the vars in the `foreign_proc' HLDS
- % goal are concrete instances of those types, which can happen when the
- % procedure is inlined or specialized. The assignment that you
- % generate here with ml_gen_assign won't be type-correct. In general
- % you may need to box/unbox the arguments.
-
- build_arg_map(Args, map.init, ArgMap),
-
- % Generate statements to assign by-ref output arguments.
- list.filter_map(ml_gen_pragma_il_proc_assign_output(ModuleInfo,
- MLDSModuleName, ArgMap, VarSet, Context, yes),
- ByRefOutputVars, ByRefAssignStatements),
-
- % Generate statements to assign copied output arguments.
- list.filter_map(ml_gen_pragma_il_proc_assign_output(ModuleInfo,
- MLDSModuleName, ArgMap, VarSet, Context, no),
- CopiedOutputVars, CopiedOutputStatements),
-
- ArgVars = list.map(foreign_arg_var, Args),
- % Generate declarations for all the variables, and initializers for
- % input variables.
- list.map(
- ml_gen_pragma_il_proc_var_decl_defn(ModuleInfo, MLDSModuleName,
- ArgMap, VarSet, MLDSContext, ByRefOutputVars, CopiedOutputVars),
- ArgVars, VarLocals),
-
- OutlineStmt = inline_target_code(ml_target_il, [
- user_target_code(ForeignCode, yes(Context),
- get_target_code_attributes(lang_il,
- get_extra_attributes(Attributes)))
- ]),
-
- ILCodeFragment = statement(ml_stmt_atomic(OutlineStmt), MLDSContext),
- BlockStatements = [ILCodeFragment | ByRefAssignStatements] ++
- CopiedOutputStatements,
- BlockStatement = statement(ml_stmt_block(VarLocals, BlockStatements),
- mlds_make_context(Context)),
- Statements = [BlockStatement],
- Decls = [].
-
-:- pred build_arg_map(list(foreign_arg)::in, map(prog_var, foreign_arg)::in,
- map(prog_var, foreign_arg)::out) is det.
-
-build_arg_map([], !ArgMap).
-build_arg_map([ForeignArg | ForeignArgs], !ArgMap) :-
- ForeignArg = foreign_arg(Var, _, _, _),
- map.det_insert(!.ArgMap, Var, ForeignArg, !:ArgMap),
- build_arg_map(ForeignArgs, !ArgMap).
-
-:- pred ml_gen_pragma_il_proc_assign_output(module_info::in,
- mlds_module_name::in, map(prog_var, foreign_arg)::in, prog_varset::in,
- prog_context::in, bool::in, prog_var::in, statement::out)
- is semidet.
-
-ml_gen_pragma_il_proc_assign_output(ModuleInfo, MLDSModuleName, ArgMap,
- VarSet, Context, IsByRef, Var, Statement) :-
- map.lookup(ArgMap, Var, ForeignArg),
- ForeignArg = foreign_arg(_, MaybeNameMode, Type, BoxPolicy),
- check_dummy_type(ModuleInfo, Type) = is_not_dummy_type,
- (
- BoxPolicy = always_boxed,
- MLDSType = mlds_generic_type
- ;
- BoxPolicy = native_if_possible,
- MLDSType = mercury_type_to_mlds_type(ModuleInfo, Type)
- ),
-
- VarName = ml_gen_var_name(VarSet, Var),
- QualVarName = qual(MLDSModuleName, module_qual, VarName),
- (
- IsByRef = yes,
- OutputVarLval = ml_mem_ref(ml_lval(ml_var(QualVarName, MLDSType)),
- MLDSType)
- ;
- IsByRef = no,
- OutputVarLval = ml_var(QualVarName, MLDSType)
- ),
-
- MaybeNameMode = yes(UserVarNameString - _),
- NonMangledVarName = mlds_var_name(UserVarNameString, no),
- QualLocalVarName= qual(MLDSModuleName, module_qual, NonMangledVarName),
- LocalVarLval = ml_var(QualLocalVarName, MLDSType),
-
- Statement = ml_gen_assign(OutputVarLval, ml_lval(LocalVarLval), Context).
-
-:- pred ml_gen_pragma_il_proc_var_decl_defn(module_info::in,
- mlds_module_name::in, map(prog_var, foreign_arg)::in, prog_varset::in,
- mlds_context::in, list(prog_var)::in, list(prog_var)::in,
- prog_var::in, mlds_defn::out) is det.
-
-ml_gen_pragma_il_proc_var_decl_defn(ModuleInfo, MLDSModuleName, ArgMap, VarSet,
- MLDSContext, ByRefOutputVars, CopiedOutputVars, Var, Defn) :-
- map.lookup(ArgMap, Var, ForeignArg),
- ForeignArg = foreign_arg(_, MaybeNameMode, Type, BoxPolicy),
- VarName = ml_gen_var_name(VarSet, Var),
- (
- MaybeNameMode = yes(UserVarNameString - _),
- NonMangledVarName = mlds_var_name(UserVarNameString, no)
- ;
- MaybeNameMode = no,
- sorry(this_file, "no variable name for var")
- ),
- (
- BoxPolicy = always_boxed,
- MLDSType0 = mlds_generic_type
- ;
- BoxPolicy = native_if_possible,
- MLDSType0 = mercury_type_to_mlds_type(ModuleInfo, Type)
- ),
-
- % Dummy arguments are just mapped to integers, since they shouldn't be
- % used in any way that requires them to have a real value.
- ( check_dummy_type(ModuleInfo, Type) = is_dummy_type ->
- Initializer = no_initializer,
- MLDSType = mlds_native_int_type
- ; list.member(Var, ByRefOutputVars) ->
- Initializer = no_initializer,
- MLDSType = MLDSType0
- ; list.member(Var, CopiedOutputVars) ->
- Initializer = no_initializer,
- MLDSType = MLDSType0
- ;
- MLDSType = MLDSType0,
- QualVarName = qual(MLDSModuleName, module_qual, VarName),
- Initializer = init_obj(ml_lval(ml_var(QualVarName, MLDSType)))
- ),
- % XXX Accurate GC is not supported for IL foreign code;
- % this would only be useful if interfacing to
- % IL when compiling to C, which is not yet supported.
- GCStatement = gc_no_stmt,
- Defn = ml_gen_mlds_var_decl_init(mlds_data_var(NonMangledVarName),
- MLDSType, Initializer, GCStatement, MLDSContext).
-
- % For ordinary (not model_non) pragma c_proc,
- % we generate code of the following form:
- %
- % model_det pragma_c_proc:
- %
- % #define MR_PROC_LABEL <procedure name>
- % <declaration of locals needed for boxing/unboxing>
- % {
- % <declaration of one local variable for each arg>
- %
- % <assign input args>
- % <obtain global lock>
- % <c code>
- % <boxing/unboxing of outputs>
- % <release global lock>
- % <assign output args>
- % }
- % #undef MR_PROC_LABEL
+ % The task of this predicate is to help compute the set of MLDS variables
+ % that should be declared at the scope of GoalExpr. This should be the
+ % set of variables that
%
- % model_semi pragma_c_proc:
+ % - do not occur outside GoalExpr, since if they did, they would have to be
+ % declared in a larger scope containing GoalExpr; and
%
- % #define MR_PROC_LABEL <procedure name>
- % <declaration of locals needed for boxing/unboxing>
- % {
- % <declaration of one local variable for each arg>
- % MR_bool SUCCESS_INDICATOR;
+ % - need to be declared at the scope of GoalExpr, since they cannot be
+ % declared in a scope inside GoalExpr.
%
- % <assign input args>
- % <obtain global lock>
- % <c code>
- % <release global lock>
- % if (SUCCESS_INDICATOR) {
- % <assign output args>
- % <boxing/unboxing of outputs>
- % }
+ % Our caller will take care of the first point by deleting the nonlocals
+ % set of GoalExpr from the SubGoalNonLocals we return, which means that
+ % we can include any variable from GoalExpr's nonlocals set in
+ % SubGoalNonLocals without affecting the final outcome.
%
- % <succeeded> = SUCCESS_INDICATOR;
- % }
- % #undef MR_PROC_LABEL
+ % If GoalExpr is a compound goal, a variable that occurs in GoalExpr
+ % can be declared in a smaller scope that GoalExpr if it occurs inside
+ % a single one of GoalExpr's subgoals. In this case, we therefore return
+ % the union of the nonlocals sets of GoalExpr's direct subgoals.
%
- % We insert a #define for MR_PROC_LABEL, so that the C code in
- % the Mercury standard library that allocates memory manually
- % can use MR_PROC_LABEL as the procname argument to
- % incr_hp_msg(), for memory profiling. Hard-coding the procname
- % argument in the C code would be wrong, since it wouldn't
- % handle the case where the original pragma c_code procedure
- % gets inlined and optimized away. Of course we also need to
- % #undef it afterwards.
- %
- % Note that we generate this code directly as
- % `target_code(lang_C, <string>)' instructions in the MLDS.
- % It would probably be nicer to encode more of the structure
- % in the MLDS, so that (a) we could do better MLDS optimization
- % and (b) so that the generation of C code strings could be
- % isolated in mlds_to_c.m. Also we will need to do something
- % different for targets other than C, e.g. when compiling to
- % Java.
- %
-:- pred ml_gen_ordinary_pragma_c_proc(ordinary_pragma_kind::in,
- pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
- list(foreign_arg)::in, list(foreign_arg)::in, string::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_ordinary_pragma_c_proc(OrdinaryKind, Attributes, PredId, _ProcId,
- OrigArgs, ExtraArgs, C_Code, Context, Decls, Statements, !Info) :-
- Lang = get_foreign_language(Attributes),
-
- % Generate <declaration of one local variable for each arg>
- list.append(OrigArgs, ExtraArgs, Args),
- ml_gen_pragma_c_decls(!.Info, Lang, Args, ArgDeclsList),
-
- % Generate code to set the values of the input variables.
- ml_gen_pragma_c_java_input_arg_list(Lang, Args, AssignInputsList, !Info),
-
- % Generate code to assign the values of the output variables.
- ml_gen_pragma_c_output_arg_list(Args, Context,
- AssignOutputsList, ConvDecls, ConvStatements, !Info),
-
- % Generate code fragments to obtain and release the global lock.
- ThreadSafe = get_thread_safe(Attributes),
- ml_gen_obtain_release_global_lock(!.Info, ThreadSafe, PredId,
- ObtainLock, ReleaseLock),
-
- % Generate the MR_PROC_LABEL #define.
- ml_gen_hash_define_mr_proc_label(!.Info, HashDefine),
-
- % Put it all together.
- (
- OrdinaryKind = kind_det,
- Starting_C_Code = list.condense([
- [raw_target_code("{\n", [])],
- HashDefine,
- ArgDeclsList,
- [raw_target_code("\n", [])],
- AssignInputsList,
- [raw_target_code(ObtainLock, []),
- raw_target_code("\t\t{\n", []),
- user_target_code(C_Code, yes(Context), []),
- raw_target_code("\n\t\t;}\n", []),
- raw_target_code("#undef MR_PROC_LABEL\n", []),
- raw_target_code(ReleaseLock, [])],
- AssignOutputsList
- ]),
- Ending_C_Code = [raw_target_code("}\n", [])]
- ;
- OrdinaryKind = kind_failure,
- % We need to treat this case separately, because for these
- % foreign_procs the C code fragment won't assign anything
- % SUCCESS_INDICATOR; the code we generate for CanSucceed = yes
- % would test an undefined value.
- ml_success_lval(!.Info, SucceededLval),
- Starting_C_Code = list.condense([
- [raw_target_code("{\n", [])],
- HashDefine,
- ArgDeclsList,
- [raw_target_code("\n", [])],
- AssignInputsList,
- [raw_target_code(ObtainLock, []),
- raw_target_code("\t\t{\n", []),
- user_target_code(C_Code, yes(Context), []),
- raw_target_code("\n\t\t;}\n", []),
- raw_target_code("#undef MR_PROC_LABEL\n", []),
- raw_target_code(ReleaseLock, [])]
- ]),
- Ending_C_Code = [
- target_code_output(SucceededLval),
- raw_target_code(" = MR_FALSE;\n", []),
- raw_target_code("}\n", [])
- ]
- ;
- OrdinaryKind = kind_semi,
- ml_success_lval(!.Info, SucceededLval),
- Starting_C_Code = list.condense([
- [raw_target_code("{\n", [])],
- HashDefine,
- ArgDeclsList,
- [raw_target_code("\tMR_bool SUCCESS_INDICATOR;\n", []),
- raw_target_code("\n", [])],
- AssignInputsList,
- [raw_target_code(ObtainLock, []),
- raw_target_code("\t\t{\n", []),
- user_target_code(C_Code, yes(Context), []),
- raw_target_code("\n\t\t;}\n", []),
- raw_target_code("#undef MR_PROC_LABEL\n", []),
- raw_target_code(ReleaseLock, []),
- raw_target_code("\tif (SUCCESS_INDICATOR) {\n", [])],
- AssignOutputsList
- ]),
- Ending_C_Code = [
- raw_target_code("\t}\n", []),
- target_code_output(SucceededLval),
- raw_target_code(" = SUCCESS_INDICATOR;\n", []),
- raw_target_code("}\n", [])
- ]
- ),
- Starting_C_Code_Stmt = inline_target_code(ml_target_c, Starting_C_Code),
- Ending_C_Code_Stmt = inline_target_code(ml_target_c, Ending_C_Code),
- Starting_C_Code_Statement = statement(
- ml_stmt_atomic(Starting_C_Code_Stmt), mlds_make_context(Context)),
- Ending_C_Code_Statement = statement(ml_stmt_atomic(Ending_C_Code_Stmt),
- mlds_make_context(Context)),
- Statements = [Starting_C_Code_Statement | ConvStatements] ++
- [Ending_C_Code_Statement],
- Decls = ConvDecls.
-
- % Generate code fragments to obtain and release the global lock
- % (this is used for ensuring thread safety in a concurrent implementation).
- %
-:- pred ml_gen_obtain_release_global_lock(ml_gen_info::in,
- proc_thread_safe::in, pred_id::in, string::out, string::out) is det.
-
-ml_gen_obtain_release_global_lock(Info, ThreadSafe, PredId,
- ObtainLock, ReleaseLock) :-
- ml_gen_info_get_module_info(Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, parallel, Parallel),
- (
- Parallel = yes,
- ThreadSafe = proc_not_thread_safe
- ->
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- Name = pred_info_name(PredInfo),
- MangledName = c_util.quote_string(Name),
- string.append_list(["\tMR_OBTAIN_GLOBAL_LOCK(""",
- MangledName, """);\n"], ObtainLock),
- string.append_list(["\tMR_RELEASE_GLOBAL_LOCK(""",
- MangledName, """);\n"], ReleaseLock)
- ;
- ObtainLock = "",
- ReleaseLock = ""
- ).
-
-:- pred ml_gen_hash_define_mr_proc_label(ml_gen_info::in,
- list(target_code_component)::out) is det.
+ % If GoalExpr is an atomic goal, there is no smaller scope, but we do have
+ % to declare at GoalExpr's scope any MLDS variables that GoalExpr refers to
+ % but are not visible GoalExpr. This can happen e.g. with ignored output
+ % arguments from calls and unifications.
+ %
+:- pred goal_expr_find_subgoal_nonlocals(hlds_goal_expr::in,
+ set(prog_var)::out) is det.
-ml_gen_hash_define_mr_proc_label(Info, HashDefine) :-
- ml_gen_info_get_module_info(Info, ModuleInfo),
- % Note that we use the pred_id and proc_id of the current procedure,
- % not the one that the pragma foreign_code originally came from.
- % There may not be any function address for the latter, e.g. if it
- % has been inlined and the original definition optimized away.
- ml_gen_info_get_pred_id(Info, PredId),
- ml_gen_info_get_proc_id(Info, ProcId),
- ml_gen_proc_label(ModuleInfo, PredId, ProcId, Name, Module),
- HashDefine = [raw_target_code("#define MR_PROC_LABEL ", []),
- target_code_name(qual(Module, module_qual, Name)),
- raw_target_code("\n", [])].
-
-:- func get_target_code_attributes(foreign_language,
- pragma_foreign_proc_extra_attributes) = target_code_attributes.
-
-get_target_code_attributes(_Lang, []) = [].
-get_target_code_attributes(Lang, [ProcAttr | ProcAttrs]) = TargetAttrs :-
- TargetAttrs1 = get_target_code_attributes(Lang, ProcAttrs),
+goal_expr_find_subgoal_nonlocals(GoalExpr, SubGoalNonLocals) :-
(
- ProcAttr = max_stack_size(N),
+ GoalExpr = unify(_LHS, _RHS, _Mode, Unification, _UnifyContext),
(
- Lang = lang_il,
- TargetAttrs = [max_stack_size(N) | TargetAttrs1]
+ Unification = construct(LHSVar, _ConsId, ArgVars, _ArgModes,
+ _HowToConstruct, _Unique, _SubInfo),
+ % _HowToConstruct can contain a var specifying to a cell to reuse
+ % or a region to construct the term in, but both of those require
+ % that variable to be nonlocal to GoalExpr, which means that they
+ % would be subtracted from SubGoalNonLocals by our caller anyway.
+ SubGoalNonLocals = set.list_to_set([LHSVar | ArgVars])
;
- ( Lang = lang_c
- ; Lang = lang_csharp
- ; Lang = lang_java
- ; Lang = lang_erlang
- ),
- TargetAttrs = TargetAttrs1
+ Unification = deconstruct(LHSVar, _ConsId, ArgVars, _ArgModes,
+ _CanFail, _CanCGC),
+ SubGoalNonLocals = set.list_to_set([LHSVar | ArgVars])
+ ;
+ Unification = assign(LHSVar, RHSVar),
+ SubGoalNonLocals = set.list_to_set([LHSVar, RHSVar])
+ ;
+ Unification = simple_test(LHSVar, RHSVar),
+ SubGoalNonLocals = set.list_to_set([LHSVar, RHSVar])
+ ;
+ Unification = complicated_unify(_, _, _),
+ unexpected(this_file, "goal_expr_find_subgoal_nonlocals")
)
;
- ( ProcAttr = refers_to_llds_stack
- ; ProcAttr = backend(_)
- ; ProcAttr = needs_call_standard_output_registers
- ),
- TargetAttrs = TargetAttrs1
- ).
-
-%---------------------------------------------------------------------------%
-
- % ml_gen_pragma_c_decls generates C code to declare the arguments
- % for a `pragma foreign_proc' declaration.
- %
-:- pred ml_gen_pragma_c_decls(ml_gen_info::in, foreign_language::in,
- list(foreign_arg)::in, list(target_code_component)::out) is det.
-
-ml_gen_pragma_c_decls(_, _, [], []).
-ml_gen_pragma_c_decls(Info, Lang, [Arg | Args], [Decl | Decls]) :-
- ml_gen_pragma_c_decl(Info, Lang, Arg, Decl),
- ml_gen_pragma_c_decls(Info, Lang, Args, Decls).
-
- % ml_gen_pragma_c_decl generates C code to declare an argument
- % of a `pragma foreign_proc' declaration.
- %
-:- pred ml_gen_pragma_c_decl(ml_gen_info::in, foreign_language::in,
- foreign_arg::in, target_code_component::out) is det.
-
-ml_gen_pragma_c_decl(Info, Lang, Arg, Decl) :-
- Arg = foreign_arg(_Var, MaybeNameAndMode, Type, BoxPolicy),
- ml_gen_info_get_module_info(Info, ModuleInfo),
- (
- MaybeNameAndMode = yes(ArgName - _Mode),
- not var_is_singleton(ArgName)
- ->
+ GoalExpr = plain_call(_PredId, _ProcId, ArgVars, _Builtin,
+ _Unify_context, _SymName),
+ SubGoalNonLocals = set.list_to_set(ArgVars)
+ ;
+ GoalExpr = generic_call(GenericCall, ArgVars, _Modes, _Detism),
(
- BoxPolicy = always_boxed,
- TypeString = "MR_Word"
+ GenericCall = higher_order(HOVar, _Purity, _Kind, _Arity),
+ SubGoalNonLocals = set.list_to_set([HOVar | ArgVars])
;
- BoxPolicy = native_if_possible,
- TypeString = mercury_exported_type_to_string(ModuleInfo, Lang,
- Type)
- ),
- string.format("\t%s %s;\n", [s(TypeString), s(ArgName)], DeclString)
+ GenericCall = class_method(MethodVar, _MethodNum, _MethodClassId,
+ _Name),
+ SubGoalNonLocals = set.list_to_set([MethodVar | ArgVars])
+ ;
+ GenericCall = event_call(_Eventname),
+ SubGoalNonLocals = set.list_to_set(ArgVars)
+ ;
+ GenericCall = cast(_CastKind),
+ SubGoalNonLocals = set.list_to_set(ArgVars)
+ )
+ ;
+ GoalExpr = call_foreign_proc(_Attr, _PredId, _ProcId, Args, ExtraArgs,
+ _TraceCond, _Impl),
+ ArgVars = list.map(foreign_arg_var, Args),
+ ExtraVars = list.map(foreign_arg_var, ExtraArgs),
+ SubGoalNonLocals = set.list_to_set(ExtraVars ++ ArgVars)
;
- % If the variable doesn't occur in the ArgNames list,
- % it can't be used, so we just ignore it.
- DeclString = ""
+ ( GoalExpr = negation(SubGoal)
+ ; GoalExpr = scope(_Reason, SubGoal)
),
- Decl = raw_target_code(DeclString, []).
-
-%-----------------------------------------------------------------------------%
-
- % The foreign code generated to implement mutable variables requires
- % special case treatment, enabled by passing `mutable_special_case'.
- %
-:- type mutable_special_case
- ---> mutable_special_case
- ; not_mutable_special_case.
-
- % ml_gen_pragma_java_decls generates Java code to declare the arguments
- % for a `pragma foreign_proc' declaration.
- %
-:- pred ml_gen_pragma_java_decls(ml_gen_info::in, mutable_special_case::in,
- list(foreign_arg)::in, list(target_code_component)::out) is det.
-
-ml_gen_pragma_java_decls(_, _, [], []).
-ml_gen_pragma_java_decls(Info, MutableSpecial, [Arg | Args], Decl ++ Decls) :-
- ml_gen_pragma_java_decl(Info, MutableSpecial, Arg, Decl),
- ml_gen_pragma_java_decls(Info, MutableSpecial, Args, Decls).
-
- % ml_gen_pragma_java_decl generates Java code to declare an argument
- % of a `pragma foreign_proc' declaration.
- %
-:- pred ml_gen_pragma_java_decl(ml_gen_info::in, mutable_special_case::in,
- foreign_arg::in, list(target_code_component)::out) is det.
-
-ml_gen_pragma_java_decl(Info, MutableSpecial, Arg, Decl) :-
- Arg = foreign_arg(_Var, MaybeNameAndMode, Type, _BoxPolicy),
- ml_gen_info_get_module_info(Info, ModuleInfo),
- (
- MaybeNameAndMode = yes(ArgName - _Mode),
- not var_is_singleton(ArgName)
- ->
- (
- MutableSpecial = not_mutable_special_case,
- MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type)
+ % If _Reason = from_ground_term, the TermVar in it is guaranteed by
+ % construction to be nonlocal, so there is no need to add it
+ % separately.
+ % If _Reason = exist_quant(Vars), the variables in Vars are ignored by
+ % the code generator.
+ SubGoalNonLocals = goal_get_nonlocals(SubGoal)
;
- MutableSpecial = mutable_special_case,
- % The code for mutables is generated in the frontend.
- % All mutable variables have the type `java.lang.Object'.
- MLDS_Type = mlds_generic_type
+ ( GoalExpr = conj(_, SubGoals)
+ ; GoalExpr = disj(SubGoals)
),
- TypeDecl = target_code_type(MLDS_Type),
- string.format(" %s;\n", [s(ArgName)], VarDeclString),
- VarDecl = raw_target_code(VarDeclString, []),
- Decl = [TypeDecl, VarDecl]
- ;
- % If the variable doesn't occur in the ArgNames list,
- % it can't be used, so we just ignore it.
- Decl = []
+ goals_find_subgoal_nonlocals(SubGoals, set.init, SubGoalNonLocals)
+ ;
+ GoalExpr = if_then_else(_Vars, Cond, Then, Else),
+ % The value of _Vars is not guaranteed to contain the set of variables
+ % shared between only Cond and Then.
+ goals_find_subgoal_nonlocals([Cond, Then, Else],
+ set.init, SubGoalNonLocals)
+ ;
+ GoalExpr = switch(_Var, _CanFail, Cases),
+ % _Var must be nonlocal; if it weren't, there would have been a mode
+ % error (no producer for _Var before a consumer, namely this switch).
+ cases_find_subgoal_nonlocals(Cases, set.init, SubGoalNonLocals)
+ ;
+ GoalExpr = shorthand(_),
+ unexpected(this_file, "goal_expr_find_subgoal_nonlocals: shorthand")
).
-%-----------------------------------------------------------------------------%
+:- pred goals_find_subgoal_nonlocals(list(hlds_goal)::in,
+ set(prog_var)::in, set(prog_var)::out) is det.
- % var_is_singleton determines whether or not a given foreign_proc variable
- % is singleton (i.e. starts with an underscore)
- %
- % Singleton vars should be ignored when generating the declarations for
- % foreign_proc arguments because:
- %
- % - they should not appear in the C code
- % - they could clash with the system name space
- %
-:- pred var_is_singleton(string::in) is semidet.
+goals_find_subgoal_nonlocals([], !SubGoalNonLocals).
+goals_find_subgoal_nonlocals([SubGoal | SubGoals], !SubGoalNonLocals) :-
+ NonLocals = goal_get_nonlocals(SubGoal),
+ set.union(!.SubGoalNonLocals, NonLocals, !:SubGoalNonLocals),
+ goals_find_subgoal_nonlocals(SubGoals, !SubGoalNonLocals).
+
+:- pred cases_find_subgoal_nonlocals(list(case)::in,
+ set(prog_var)::in, set(prog_var)::out) is det.
-var_is_singleton(Name) :-
- string.first_char(Name, '_', _).
+cases_find_subgoal_nonlocals([], !SubGoalNonLocals).
+cases_find_subgoal_nonlocals([Case | Cases], !SubGoalNonLocals) :-
+ Case = case(_, _, SubGoal),
+ NonLocals = goal_get_nonlocals(SubGoal),
+ set.union(!.SubGoalNonLocals, NonLocals, !:SubGoalNonLocals),
+ cases_find_subgoal_nonlocals(Cases, !SubGoalNonLocals).
%-----------------------------------------------------------------------------%
- % For both C and Java.
+ % If the inner and outer code models are equal, we don't need to do
+ % anything.
%
-:- pred ml_gen_pragma_c_java_input_arg_list(foreign_language::in,
- list(foreign_arg)::in, list(target_code_component)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_pragma_c_java_input_arg_list(Lang, ArgList, AssignInputs, !Info) :-
- list.map_foldl(ml_gen_pragma_c_java_input_arg(Lang), ArgList,
- AssignInputsList, !Info),
- list.condense(AssignInputsList, AssignInputs).
-
- % ml_gen_pragma_c_input_arg generates C or Java code to assign the value of
- % an input arg for a `pragma foreign_proc' declaration.
+ % If the inner code model is less precise than the outer code model,
+ % then that is either a determinism error, or a situation in which
+ % simplify.m is supposed to wrap the goal inside a `some' to indicate that
+ % a commit is needed.
%
-:- pred ml_gen_pragma_c_java_input_arg(foreign_language::in, foreign_arg::in,
- list(target_code_component)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_pragma_c_java_input_arg(Lang, ForeignArg, AssignInput, !Info) :-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- (
- ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
- MaybeNameAndMode = yes(ArgName - Mode),
- not var_is_singleton(ArgName),
- mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_in)
- ->
- ml_gen_pragma_c_java_gen_input_arg(Lang, Var, ArgName, OrigType,
- BoxPolicy, AssignInput, !Info)
- ;
- % If the variable doesn't occur in the ArgNames list,
- % it can't be used, so we just ignore it.
- AssignInput = []
- ).
-
-:- pred ml_gen_pragma_c_java_gen_input_arg(foreign_language::in, prog_var::in,
- string::in, mer_type::in, box_policy::in, list(target_code_component)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_pragma_c_java_gen_input_arg(Lang, Var, ArgName, OrigType, BoxPolicy,
- AssignInput, !Info) :-
- ml_variable_type(!.Info, Var, VarType),
- ml_gen_var(!.Info, Var, VarLval),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- IsDummy = check_dummy_type(ModuleInfo, VarType),
- (
- IsDummy = is_dummy_type,
- % The variable may not have been declared, so we need to generate
- % a dummy value for it. Using a constant here is more efficient than
- % using private_builtin.dummy_var, which is what ml_gen_var will have
- % generated for this variable.
- ArgRval = dummy_arg_rval(Lang, ModuleInfo, VarType)
- ;
- IsDummy = is_not_dummy_type,
- ml_gen_box_or_unbox_rval(ModuleInfo, VarType, OrigType, BoxPolicy,
- ml_lval(VarLval), ArgRval)
- ),
- % At this point we have an rval with the right type for *internal* use
- % in the code generated by the Mercury compiler's MLDS back-end. We need
- % to convert this to the appropriate type to use for the C interface.
- ExportedType = foreign.to_exported_type(ModuleInfo, OrigType),
- TypeString = exported_type_to_string(Lang, ExportedType),
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
- (
- input_arg_assignable_with_cast(Lang, HighLevelData, OrigType,
- ExportedType, TypeString, Cast)
- ->
- % In the usual case, we can just use an assignment and perhaps a cast.
- string.format("\t%s = %s ", [s(ArgName), s(Cast)], AssignToArgName),
- AssignInput = [
- raw_target_code(AssignToArgName, []),
- target_code_input(ArgRval),
- raw_target_code(";\n", [])
- ]
- ;
- % For foreign types (without the `can_pass_as_mercury_type' assertion)
- % we need to call MR_MAYBE_UNBOX_FOREIGN_TYPE.
- AssignInput = [
- raw_target_code("\tMR_MAYBE_UNBOX_FOREIGN_TYPE("
- ++ TypeString ++ ", ", []),
- target_code_input(ArgRval),
- raw_target_code(", " ++ ArgName ++ ");\n", [])
- ]
- ).
-
-:- func dummy_arg_rval(foreign_language, module_info, mer_type) = mlds_rval.
-
-dummy_arg_rval(Lang, ModuleInfo, Type) = Rval :-
- MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
- ( Lang = lang_java ->
- Rval = ml_const(mlconst_null(MLDS_Type))
- ;
- Rval = ml_const(mlconst_int(0))
- ).
+ % If the inner code model is more precise than the outer code model,
+ % then we need to append some statements to convert the calling convention
+ % for the inner code model to that of the outer code model.
-:- pred input_arg_assignable_with_cast(foreign_language::in, bool::in,
- mer_type::in, exported_type::in, string::in, string::out) is semidet.
+ml_gen_maybe_convert_goal_code_model(model_det, model_det, _,
+ !Statements, !Info).
+ml_gen_maybe_convert_goal_code_model(model_semi, model_semi, _,
+ !Statements, !Info).
+ml_gen_maybe_convert_goal_code_model(model_non, model_non, _,
+ !Statements, !Info).
-input_arg_assignable_with_cast(Lang, HighLevelData, OrigType, ExportedType,
- TypeString, Cast) :-
- (
- Lang = lang_c,
- HighLevelData = yes,
- % In general, the types used for the C interface are not the same
- % as the types used by --high-level-data, so we always use a cast
- % here. (Strictly speaking the cast is not needed for a few cases
- % like `int', but it doesn't do any harm.)
- Cast = "(" ++ TypeString ++ ")"
- ;
- Lang = lang_c,
- HighLevelData = no,
- ( OrigType = type_variable(_, _) ->
- % For --no-high-level-data, we only need to use a cast for
- % polymorphic types, which are `MR_Word' in the C interface but
- % `MR_Box' in the MLDS back-end.
- Cast = "(MR_Word)"
- ;
- IsForeign = foreign.is_foreign_type(ExportedType),
- (
- IsForeign = yes(Assertions),
- list.member(foreign_type_can_pass_as_mercury_type, Assertions),
- Cast = "(" ++ TypeString ++ ")"
- ;
- IsForeign = no,
- Cast = ""
- )
- )
- ;
- Lang = lang_java,
- % There is no difference between types used by the foreign interface
- % and the generated code.
- Cast = ""
- ;
- ( Lang = lang_csharp
- ; Lang = lang_il
- ; Lang = lang_erlang
- ),
+ml_gen_maybe_convert_goal_code_model(model_det, model_semi, _, _, _, !Info) :-
unexpected(this_file,
- "input_arg_assignable_with_cast: unexpected language")
- ).
-
-:- pred ml_gen_pragma_java_output_arg_list(mutable_special_case::in,
- list(foreign_arg)::in, prog_context::in, list(statement)::out,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_pragma_java_output_arg_list(_, [], _, [], [], [], !Info).
-ml_gen_pragma_java_output_arg_list(MutableSpecial, [JavaArg | JavaArgs],
- Context, Statements, ConvDecls, ConvStatements, !Info) :-
- ml_gen_pragma_java_output_arg(MutableSpecial, JavaArg, Context,
- Statements1, ConvDecls1, ConvStatements1, !Info),
- ml_gen_pragma_java_output_arg_list(MutableSpecial, JavaArgs, Context,
- Statements2, ConvDecls2, ConvStatements2, !Info),
- Statements = Statements1 ++ Statements2,
- ConvDecls = ConvDecls1 ++ ConvDecls2,
- ConvStatements = ConvStatements1 ++ ConvStatements2.
+ "ml_gen_maybe_convert_goal_code_model: semi in det").
+ml_gen_maybe_convert_goal_code_model(model_det, model_non, _, _, _, !Info) :-
+ unexpected(this_file,
+ "ml_gen_maybe_convert_goal_code_model: nondet in det").
+ml_gen_maybe_convert_goal_code_model(model_semi, model_non, _, _, _, !Info) :-
+ unexpected(this_file,
+ "ml_gen_maybe_convert_goal_code_model: nondet in semi").
- % ml_gen_pragma_java_output_arg generates MLDS statements to assign the
- % value of an output arg for a `pragma foreign_proc' declaration.
- %
-:- pred ml_gen_pragma_java_output_arg(mutable_special_case::in,
- foreign_arg::in, prog_context::in, list(statement)::out,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ml_gen_maybe_convert_goal_code_model(model_semi, model_det, Context,
+ !Statements, !Info) :-
+ % det goal in semidet context:
+ % <succeeded = Goal>
+ % ===>
+ % <do Goal>
+ % succeeded = MR_TRUE
-ml_gen_pragma_java_output_arg(MutableSpecial, ForeignArg, Context,
- AssignOutput, ConvDecls, ConvOutputStatements, !Info) :-
- ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- (
- MaybeNameAndMode = yes(ArgName - Mode),
- not var_is_singleton(ArgName),
- check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
- mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out)
- ->
- % Create a target lval with the right type for *internal* use in the
- % code generated by the Mercury compiler's MLDS back-end.
- ml_variable_type(!.Info, Var, VarType),
- ml_gen_var(!.Info, Var, VarLval),
- ml_gen_box_or_unbox_lval(VarType, OrigType, BoxPolicy,
- VarLval, mlds_var_name(ArgName, no), Context, no, 0,
- ArgLval, ConvDecls, _ConvInputStatements,
- ConvOutputStatements, !Info),
- MLDSType = mercury_type_to_mlds_type(ModuleInfo, OrigType),
- module_info_get_name(ModuleInfo, ModuleName),
- MLDSModuleName = mercury_module_name_to_mlds(ModuleName),
- NonMangledVarName = mlds_var_name(ArgName, no),
- QualLocalVarName = qual(MLDSModuleName, module_qual,
- NonMangledVarName),
- LocalVarLval = ml_var(QualLocalVarName, MLDSType),
- (
- MutableSpecial = not_mutable_special_case,
- Rval = ml_lval(LocalVarLval)
- ;
- MutableSpecial = mutable_special_case,
- % The code for mutables is generated in the frontend.
- % All mutable variables have the type `java.lang.Object'
- % so we need to cast the variable or extract the primitive
- % value from the box.
- Rval = ml_unop(unbox(MLDSType), ml_lval(LocalVarLval))
- ),
- AssignOutput = [ml_gen_assign(ArgLval, Rval, Context)]
- ;
- % If the variable doesn't occur in the ArgNames list,
- % it can't be used, so we just ignore it.
- AssignOutput = [],
- ConvDecls = [],
- ConvOutputStatements = []
- ).
+ ml_gen_set_success(!.Info, ml_const(mlconst_true), Context,
+ SetSuccessTrue),
+ !:Statements = !.Statements ++ [SetSuccessTrue].
-:- pred ml_gen_pragma_c_output_arg_list(list(foreign_arg)::in,
- prog_context::in, list(target_code_component)::out,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ml_gen_maybe_convert_goal_code_model(model_non, model_det, Context,
+ !Statements, !Info) :-
+ % det goal in nondet context:
+ % <Goal && SUCCEED()>
+ % ===>
+ % <do Goal>
+ % SUCCEED()
-ml_gen_pragma_c_output_arg_list([], _, [], [], [], !Info).
-ml_gen_pragma_c_output_arg_list([ForeignArg | ForeignArgs], Context,
- Components, ConvDecls, ConvStatements, !Info) :-
- ml_gen_pragma_c_output_arg(ForeignArg, Context, Components1,
- ConvDecls1, ConvStatements1, !Info),
- ml_gen_pragma_c_output_arg_list(ForeignArgs, Context,
- Components2, ConvDecls2, ConvStatements2, !Info),
- Components = Components1 ++ Components2,
- ConvDecls = ConvDecls1 ++ ConvDecls2,
- ConvStatements = ConvStatements1 ++ ConvStatements2.
+ ml_gen_call_current_success_cont(Context, CallCont, !Info),
+ !:Statements = !.Statements ++ [CallCont].
- % ml_gen_pragma_c_output_arg generates C code to assign the value of
- % an output arg for a `pragma foreign_proc' declaration.
+ml_gen_maybe_convert_goal_code_model(model_non, model_semi, Context,
+ !Statements, !Info) :-
+ % semi goal in nondet context:
+ % <Goal && SUCCEED()>
+ % ===>
+ % MR_bool succeeded;
%
-:- pred ml_gen_pragma_c_output_arg(foreign_arg::in,
- prog_context::in, list(target_code_component)::out,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ % <succeeded = Goal>
+ % if (succeeded) SUCCEED()
-ml_gen_pragma_c_output_arg(Arg, Context, AssignOutput, ConvDecls,
- ConvOutputStatements, !Info) :-
- Arg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- (
- MaybeNameAndMode = yes(ArgName - Mode),
- not var_is_singleton(ArgName),
- check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
- mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out)
- ->
- ml_gen_pragma_c_gen_output_arg(Var, ArgName, OrigType, BoxPolicy,
- Context, AssignOutput, ConvDecls, ConvOutputStatements, !Info)
- ;
- % If the variable doesn't occur in the ArgNames list,
- % it can't be used, so we just ignore it.
- AssignOutput = [],
- ConvDecls = [],
- ConvOutputStatements = []
- ).
+ ml_gen_test_success(!.Info, Succeeded),
+ ml_gen_call_current_success_cont(Context, CallCont, !Info),
+ IfStmt = ml_stmt_if_then_else(Succeeded, CallCont, no),
+ IfStatement = statement(IfStmt, mlds_make_context(Context)),
+ !:Statements = !.Statements ++ [IfStatement].
-:- pred ml_gen_pragma_c_gen_output_arg(prog_var::in,
- string::in, mer_type::in, box_policy::in, prog_context::in,
- list(target_code_component)::out,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+%-----------------------------------------------------------------------------%
-ml_gen_pragma_c_gen_output_arg(Var, ArgName, OrigType, BoxPolicy,
- Context, AssignOutput, ConvDecls, ConvOutputStatements, !Info) :-
- ml_variable_type(!.Info, Var, VarType),
- ml_gen_var(!.Info, Var, VarLval),
- ml_gen_box_or_unbox_lval(VarType, OrigType, BoxPolicy, VarLval,
- mlds_var_name(ArgName, no), Context, no, 0, ArgLval,
- ConvDecls, _ConvInputStatements, ConvOutputStatements, !Info),
- % At this point we have an lval with the right type for *internal* use
- % in the code generated by the Mercury compiler's MLDS back-end. We need
- % to convert this to the appropriate type to use for the C interface.
+ml_gen_local_var_decls(_VarSet, _VarTypes, _Context, [], [], !Info).
+ml_gen_local_var_decls(VarSet, VarTypes, Context, [Var | Vars], Defns,
+ !Info) :-
+ map.lookup(VarTypes, Var, Type),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ExportedType = foreign.to_exported_type(ModuleInfo, OrigType),
- TypeString = exported_type_to_string(lang_c, ExportedType),
- IsForeign = foreign.is_foreign_type(ExportedType),
- (
- (
- IsForeign = no,
- Cast = no
- ;
- IsForeign = yes(Assertions),
- list.member(foreign_type_can_pass_as_mercury_type, Assertions),
- Cast = yes
- )
- ->
- % In the usual case, we can just use an assignment,
- % perhaps with a cast.
- ml_gen_info_get_high_level_data(!.Info, HighLevelData),
- (
- HighLevelData = yes,
- % In general, the types used for the C interface are not the same
- % as the types used by --high-level-data, so we always use a cast
- % here. (Strictly speaking the cast is not needed for a few cases
- % like `int', but it doesn't do any harm.) Note that we can't
- % easily obtain the type string for the RHS of the assignment,
- % so instead we cast the LHS.
- LHS_Cast = "* (" ++ TypeString ++ " *) &",
- RHS_Cast = ""
- ;
- HighLevelData = no,
- % For --no-high-level-data, we only need to use a cast is for
- % polymorphic types, which are `MR_Word' in the C interface but
- % `MR_Box' in the MLDS back-end.
+ IsDummy = check_dummy_type(ModuleInfo, Type),
(
- ( OrigType = type_variable(_, _)
- ; Cast = yes
- )
- ->
- RHS_Cast = "(MR_Box) "
+ IsDummy = is_dummy_type,
+ % No declaration needed for this variable.
+ ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars, Defns, !Info)
;
- RHS_Cast = ""
- ),
- LHS_Cast = ""
- ),
- string.format(" = %s%s;\n", [s(RHS_Cast), s(ArgName)],
- AssignFromArgName),
- string.format("\t%s ", [s(LHS_Cast)], AssignTo),
- AssignOutput = [
- raw_target_code(AssignTo, []),
- target_code_output(ArgLval),
- raw_target_code(AssignFromArgName, [])
- ]
- ;
- % For foreign types, we need to call MR_MAYBE_BOX_FOREIGN_TYPE.
- AssignOutput = [
- raw_target_code("\tMR_MAYBE_BOX_FOREIGN_TYPE("
- ++ TypeString ++ ", " ++ ArgName ++ ", ", []),
- target_code_output(ArgLval),
- raw_target_code(");\n", [])
- ]
+ IsDummy = is_not_dummy_type,
+ VarName = ml_gen_var_name(VarSet, Var),
+ ml_gen_var_decl(VarName, Type, Context, Defn, !Info),
+ ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars, Defns0, !Info),
+ Defns = [Defn | Defns0]
).
%-----------------------------------------------------------------------------%
@@ -4077,23 +1376,6 @@
).
%-----------------------------------------------------------------------------%
-%
-% Code for handling attributes.
-%
-
-:- func attributes_to_mlds_attributes(module_info, list(hlds_pred.attribute))
- = list(mlds_attribute).
-
-attributes_to_mlds_attributes(ModuleInfo, Attrs) =
- list.map(attribute_to_mlds_attribute(ModuleInfo), Attrs).
-
-:- func attribute_to_mlds_attribute(module_info, hlds_pred.attribute)
- = mlds_attribute.
-
-attribute_to_mlds_attribute(ModuleInfo, custom(Type)) =
- custom(mercury_type_to_mlds_type(ModuleInfo, Type)).
-
-%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.145
diff -u -b -r1.145 ml_code_util.m
--- compiler/ml_code_util.m 24 Sep 2009 03:29:26 -0000 1.145
+++ compiler/ml_code_util.m 25 Sep 2009 04:00:47 -0000
@@ -9,8 +9,8 @@
% File: ml_code_util.m.
% Main author: fjh.
%
-% This module is part of the MLDS code generator.
-% It defines the ml_gen_info type and its access routines.
+% This module is part of the MLDS code generator; it contains utility
+% predicates.
%
%-----------------------------------------------------------------------------%
@@ -25,14 +25,13 @@
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.mlds.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.ml_global_data.
:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module list.
-:- import_module map.
:- import_module maybe.
-:- import_module set.
%-----------------------------------------------------------------------------%
%
@@ -168,12 +167,6 @@
list(mer_mode)::in, pred_or_func::in, code_model::in,
mlds_func_params::out, ml_gen_info::in, ml_gen_info::out) is det.
- % Given a list of variables and their corresponding modes,
- % return a list containing only those variables which have an output mode.
- %
-:- func select_output_vars(module_info, list(Var), list(mer_mode),
- map(Var, mer_type)) = list(Var).
-
%-----------------------------------------------------------------------------%
%
% Routines for generating labels and entity names.
@@ -322,6 +315,54 @@
%
:- pred ml_must_box_field_type(module_info::in, mer_type::in) is semidet.
+:- pred ml_gen_box_const_rval(module_info::in, prog_context::in,
+ mlds_type::in, mlds_rval::in, mlds_rval::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ % Given a source type and a destination type, and given an source rval
+ % holding a value of the source type, produce an rval that converts
+ % the source rval to the destination type.
+ %
+:- pred ml_gen_box_or_unbox_rval(module_info::in, mer_type::in, mer_type::in,
+ box_policy::in, mlds_rval::in, mlds_rval::out) is det.
+
+ % ml_gen_box_or_unbox_lval(CallerType, CalleeType, VarLval, VarName,
+ % Context, ForClosureWrapper, ArgNum,
+ % ArgLval, ConvDecls, ConvInputStatements, ConvOutputStatements):
+ %
+ % This is like `ml_gen_box_or_unbox_rval', except that it works on lvals
+ % rather than rvals. Given a source type and a destination type,
+ % a source lval holding a value of the source type, and a name to base
+ % the name of the local temporary variable on, this procedure produces
+ % an lval of the destination type, the declaration for the local temporary
+ % used (if any), code to assign from the source lval (suitable converted)
+ % to the destination lval, and code to assign from the destination lval
+ % (suitable converted) to the source lval.
+ %
+ % If ForClosureWrapper = yes, then the type_info for type variables
+ % in CallerType may not be available in the current procedure, so the GC
+ % tracing code for the ConvDecls (if any) should obtain the type_info
+ % from the ArgNum-th entry in the `type_params' local.
+ % (If ForClosureWrapper = no, then ArgNum is unused.)
+ %
+:- pred ml_gen_box_or_unbox_lval(mer_type::in, mer_type::in, box_policy::in,
+ mlds_lval::in, mlds_var_name::in, prog_context::in, bool::in, int::in,
+ mlds_lval::out, list(mlds_defn)::out,
+ list(statement)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % ml_gen_local_for_output_arg(VarName, Type, ArgNum, Context,
+ % LocalVarDefn):
+ %
+ % Generate a declaration for a local variable with the specified
+ % VarName and Type. However, don't use the normal GC tracing code;
+ % instead, generate GC tracing code that gets the typeinfo from
+ % the ArgNum-th entry in `type_params'.
+ %
+:- pred ml_gen_local_for_output_arg(mlds_var_name::in, mer_type::in, int::in,
+ prog_context::in, mlds_defn::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
%-----------------------------------------------------------------------------%
%
% Routines for handling success and failure.
@@ -432,57 +473,6 @@
%-----------------------------------------------------------------------------%
%
-% Code to handle accurate GC.
-%
-
- % ml_gen_gc_statement(Var, Type, Context, Code):
- %
- % If accurate GC is enabled, and the specified variable might contain
- % pointers, generate code to call `private_builtin.gc_trace' to trace
- % the variable.
- %
-:- pred ml_gen_gc_statement(mlds_var_name::in, mer_type::in,
- prog_context::in, mlds_gc_statement::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % ml_gen_gc_statement_poly(Var, DeclType, ActualType, Context, Code):
- %
- % This is the same as ml_gen_gc_statement, except that it takes two
- % type arguments, rather than one. The first (DeclType) is the type that
- % the variable was declared with, while the second (ActualType) is that
- % type that the variable is known to have. This is used to generate GC
- % tracing code for the temporaries variables used when calling procedures
- % with polymorphically-typed output arguments. In that case, DeclType
- % may be a type variable from the callee's type declaration, but ActualType
- % will be the type from the caller.
- %
- % We can't just use DeclType to generate the GC trace code, because there's
- % no way to compute the type_info for type variables that come from the
- % callee rather than the current procedure. And we can't just use
- % ActualType, since DeclType may contain pointers even when ActualType
- % doesn't (e.g. because DeclType may be a boxed float). So we need to pass
- % both.
- %
-:- pred ml_gen_gc_statement_poly(mlds_var_name::in,
- mer_type::in, mer_type::in, prog_context::in,
- mlds_gc_statement::out, ml_gen_info::in, ml_gen_info::out) is det.
-
- % ml_gen_gc_statement_with_typeinfo(Var, DeclType, TypeInfoRval,
- % Context, Code):
- %
- % This is the same as ml_gen_gc_statement_poly, except that rather
- % than passing ActualType, the caller constructs the typeinfo itself,
- % and just passes the rval for it to this routine.
- %
- % This is used by ml_closure_gen.m to generate GC tracing code
- % for the the local variables in closure wrapper functions.
- %
-:- pred ml_gen_gc_statement_with_typeinfo(mlds_var_name::in,
- mer_type::in, mlds_rval::in, prog_context::in,
- mlds_gc_statement::out, ml_gen_info::in, ml_gen_info::out) is det.
-
-%-----------------------------------------------------------------------------%
-%
% Magic numbers relating to the representation of
% typeclass_infos, base_typeclass_infos, and closures.
%
@@ -524,241 +514,6 @@
list(mlds_type)::in, list(mlds_rval)::in, list(mlds_rval)::out,
ml_global_data::in, ml_global_data::out) is det.
-:- pred ml_gen_box_const_rval(module_info::in, prog_context::in,
- mlds_type::in, mlds_rval::in, mlds_rval::out,
- ml_global_data::in, ml_global_data::out) is det.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-%
-% The `ml_gen_info' ADT.
-%
-
- % The `ml_gen_info' type holds information used during
- % MLDS code generation for a given procedure.
- %
-:- type ml_gen_info.
-
- % Initialize the ml_gen_info, so that it is ready for generating code
- % for the given procedure. The last argument records the persistent
- % information accumulated by the code generator so far during the
- % processing of previous procedures.
- %
-:- func ml_gen_info_init(module_info, pred_id, proc_id, proc_info,
- ml_global_data) = ml_gen_info.
-
-:- pred ml_gen_info_get_module_info(ml_gen_info::in, module_info::out) is det.
-:- pred ml_gen_info_get_high_level_data(ml_gen_info::in, bool::out) is det.
-:- pred ml_gen_info_get_target(ml_gen_info::in, compilation_target::out)
- is det.
-:- pred ml_gen_info_get_pred_id(ml_gen_info::in, pred_id::out) is det.
-:- pred ml_gen_info_get_proc_id(ml_gen_info::in, proc_id::out) is det.
-:- pred ml_gen_info_get_varset(ml_gen_info::in, prog_varset::out) is det.
-:- pred ml_gen_info_get_var_types(ml_gen_info::in, vartypes::out) is det.
-:- pred ml_gen_info_get_byref_output_vars(ml_gen_info::in, list(prog_var)::out)
- is det.
-:- pred ml_gen_info_get_value_output_vars(ml_gen_info::in, list(prog_var)::out)
- is det.
-:- pred ml_gen_info_get_global_data(ml_gen_info::in, ml_global_data::out)
- is det.
-
-:- pred ml_gen_info_set_byref_output_vars(list(prog_var)::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_value_output_vars(list(prog_var)::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_global_data(ml_global_data::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-:- pred ml_gen_info_get_globals(ml_gen_info::in, globals::out) is det.
-:- pred ml_gen_info_get_module_name(ml_gen_info::in, mercury_module_name::out)
- is det.
-
- % Lookup the --gcc-nested-functions option.
- %
-:- pred ml_gen_info_use_gcc_nested_functions(ml_gen_info::in, bool::out)
- is det.
-
- % Lookup the --put-commit-in-nested-func option.
- %
-:- pred ml_gen_info_put_commit_in_own_func(ml_gen_info::in, bool::out) is det.
-
- % Generate a new label number for use in label statements.
- % This is used to give unique names to the case labels generated
- % for dense switch statements.
- %
-:- type label_num == int.
-:- pred ml_gen_info_new_label(label_num::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % A number corresponding to an MLDS nested function which serves as a
- % label (i.e. a continuation function).
- %
-:- type ml_label_func == mlds_func_sequence_num.
-
- % Generate a new function label number. This is used to give unique names
- % to the nested functions used when generating code for nondet procedures.
- %
-:- pred ml_gen_info_new_func_label(ml_label_func::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % Increase the function label and const sequence number counters by some
- % amount which is presumed to be sufficient to ensure that if we start
- % again with a fresh ml_gen_info and then call this function, we won't
- % encounter any already-used function labels or constants. (This is used
- % when generating wrapper functions for type class methods.)
- %
-:- pred ml_gen_info_bump_counters(ml_gen_info::in, ml_gen_info::out) is det.
-
- % Generate a new auxiliary variable name. The name of the variable
- % will start with the given prefix and end with a sequence number
- % that differentiates this aux var from all others.
- %
- % Auxiliary variables are used for purposes such as commit label numbers
- % and holding table indexes in switches.
- %
-:- pred ml_gen_info_new_aux_var_name(string::in, mlds_var_name::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % Generate a new `cond' variable number.
- %
-:- type cond_seq ---> cond_seq(int).
-:- pred ml_gen_info_new_cond_var(cond_seq::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % Generate a new `conv' variable number. This is used to give unique names
- % to the local variables generated by ml_gen_box_or_unbox_lval, which are
- % used to handle boxing/unboxing argument conversions.
- %
-:- type conv_seq ---> conv_seq(int).
-:- pred ml_gen_info_new_conv_var(conv_seq::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-:- type ml_ground_term
- ---> ml_ground_term(
- % The value of the ground term.
- mlds_rval,
-
- % The type of the ground term (actually, the type of the
- % variable the ground term was constructed for).
- mer_type,
-
- % The corresponding MLDS type. It could be computed from the
- % Mercury type, but there is no point in doing so when using
- % the ground term as well when constructing it.
- mlds_type
- ).
-
-:- type ml_ground_term_map == map(prog_var, ml_ground_term).
-
- % Set the `const' variable name corresponding to the given HLDS variable.
- %
-:- pred ml_gen_info_set_const_var(prog_var::in, ml_ground_term::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % Lookup the `const' sequence number corresponding to a given HLDS
- % variable.
- %
-:- pred ml_gen_info_lookup_const_var(ml_gen_info::in, prog_var::in,
- ml_ground_term::out) is det.
-:- pred ml_gen_info_search_const_var(ml_gen_info::in, prog_var::in,
- ml_ground_term::out) is semidet.
-
- % A success continuation specifies the (rval for the variable holding
- % the address of the) function that a nondet procedure should call
- % if it succeeds, and possibly also the (rval for the variable holding)
- % the environment pointer for that function, and possibly also the
- % (list of rvals for the) arguments to the continuation.
-
-:- type success_cont
- ---> success_cont(
- mlds_rval, % function pointer
- mlds_rval, % environment pointer
- % note that if we're using nested
- % functions then the environment
- % pointer will not be used
- list(mlds_type), % argument types, if any
- list(mlds_lval) % arguments, if any
- % The arguments will only be non-empty
- % if the --nondet-copy-out option is
- % enabled. They do not include the
- % environment pointer.
- ).
-
- % The ml_gen_info contains a stack of success continuations.
- % The following routines provide access to that stack.
-
-:- pred ml_gen_info_push_success_cont(success_cont::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-:- pred ml_gen_info_pop_success_cont(ml_gen_info::in, ml_gen_info::out) is det.
-
-:- pred ml_gen_info_current_success_cont(ml_gen_info::in, success_cont::out)
- is det.
-
- % We keep a partial mapping from vars to lvals. This is used in special
- % cases to override the normal lval for a variable. ml_gen_var will check
- % this map first, and if the variable is not in this map, then it will go
- % ahead and generate an lval for it as usual.
-
- % Set the lval for a variable.
- %
-:- pred ml_gen_info_set_var_lval(prog_var::in, mlds_lval::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % Get the partial mapping from variables to lvals.
- %
-:- pred ml_gen_info_get_var_lvals(ml_gen_info::in,
- map(prog_var, mlds_lval)::out) is det.
-
- % Set the partial mapping from variables to lvals.
- %
-:- pred ml_gen_info_set_var_lvals(map(prog_var, mlds_lval)::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % A variable can be bound to a constant in one branch of a control
- % structure and to a non-constant term in another branch. We remember
- % information about variables bound to constants in the map these two
- % predicates are the getter and setter of. Branched control structures
- % should reset the map to its original value at the start of every branch
- % after the first (to prevent a later branch from using information that is
- % applicable only in a previous branch), and at the end of the branched
- % control structure (to prevent the code after it using information whose
- % correctness depends on the exact route execution took to there).
- %
-:- pred ml_gen_info_get_const_var_map(ml_gen_info::in,
- map(prog_var, ml_ground_term)::out) is det.
-:- pred ml_gen_info_set_const_var_map(map(prog_var, ml_ground_term)::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % The ml_gen_info contains a list of extra definitions of functions or
- % global constants which should be inserted before the definition of the
- % function for the current procedure. This is used for the definitions
- % of the wrapper functions needed for closures. When generating code
- % for a procedure that creates a closure, we insert the definition of
- % the wrapper function used for that closure into this list.
-
- % Insert an extra definition at the start of the list of extra
- % definitions.
- %
-:- pred ml_gen_info_add_closure_wrapper_defn(mlds_defn::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % Get the list of extra definitions.
- %
-:- pred ml_gen_info_get_closure_wrapper_defns(ml_gen_info::in,
- list(mlds_defn)::out) is det.
-
- % Add the given string as the name of an environment variable used by
- % the function being generated.
- %
-:- pred ml_gen_info_add_env_var_name(string::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
- % Get the names of the used environment variables.
- %
-:- pred ml_gen_info_get_env_var_names(ml_gen_info::in, set(string)::out)
- is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -774,6 +529,7 @@
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.program_representation.
+:- import_module ml_backend.ml_accurate_gc.
:- import_module ml_backend.ml_call_gen.
:- import_module ml_backend.ml_code_gen.
:- import_module parse_tree.builtin_lib_types.
@@ -783,7 +539,9 @@
:- import_module counter.
:- import_module int.
+:- import_module map.
:- import_module pair.
+:- import_module set.
:- import_module stack.
:- import_module string.
:- import_module term.
@@ -845,8 +603,7 @@
->
Block = SingleStatement
;
- Block = statement(ml_stmt_block(VarDecls, Statements),
- Context)
+ Block = statement(ml_stmt_block(VarDecls, Statements), Context)
).
ml_combine_conj(FirstCodeModel, Context, DoGenFirst, DoGenRest,
@@ -1631,6 +1388,305 @@
MustBox = yes
).
+ml_gen_box_const_rvals(_, _, [], [], [], !GlobalData).
+ml_gen_box_const_rvals(_, _, [], [_ | _], _, !GlobalData) :-
+ unexpected(this_file, "ml_gen_box_const_rvals: list length mismatch").
+ml_gen_box_const_rvals(_, _, [_ | _], [], _, !GlobalData) :-
+ unexpected(this_file, "ml_gen_box_const_rvals: list length mismatch").
+ml_gen_box_const_rvals(ModuleInfo, Context, [Type | Types], [Rval | Rvals],
+ [BoxedRval | BoxedRvals], !GlobalData) :-
+ ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
+ !GlobalData),
+ ml_gen_box_const_rvals(ModuleInfo, Context, Types, Rvals, BoxedRvals,
+ !GlobalData).
+
+ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
+ !GlobalData) :-
+ (
+ ( Type = mercury_type(type_variable(_, _), _, _)
+ ; Type = mlds_generic_type
+ )
+ ->
+ BoxedRval = Rval
+ ;
+ % For the MLDS->C and MLDS->asm back-ends, we need to handle floats
+ % specially, since boxed floats normally get heap allocated, whereas
+ % for other types boxing is just a cast (casts are OK in static
+ % initializers, but calls to malloc() are not).
+ ( Type = mercury_type(builtin_type(builtin_type_float), _, _)
+ ; Type = mlds_native_float_type
+ ),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ ( Target = target_c
+ ; Target = target_asm
+ ; Target = target_x86_64
+ )
+ ->
+ % Generate a local static constant for this float.
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ Initializer = init_obj(Rval),
+ ml_gen_static_scalar_const_addr(MLDS_ModuleName, "float", Type,
+ Initializer, Context, ConstAddrRval, !GlobalData),
+
+ % Return as the boxed rval the address of that constant,
+ % cast to mlds_generic_type.
+ BoxedRval = ml_unop(cast(mlds_generic_type), ConstAddrRval)
+ ;
+ BoxedRval = ml_unop(box(Type), Rval)
+ ).
+
+ml_gen_box_or_unbox_rval(ModuleInfo, SourceType, DestType, BoxPolicy, VarRval,
+ ArgRval) :-
+ % Convert VarRval, of type SourceType, to ArgRval, of type DestType.
+ (
+ BoxPolicy = always_boxed,
+ ArgRval = VarRval
+ ;
+ BoxPolicy = native_if_possible,
+ (
+ % If converting from polymorphic type to concrete type, then unbox.
+ SourceType = type_variable(_, _),
+ DestType \= type_variable(_, _)
+ ->
+ MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
+ ArgRval = ml_unop(unbox(MLDS_DestType), VarRval)
+ ;
+ % If converting from concrete type to polymorphic type, then box.
+ SourceType \= type_variable(_, _),
+ DestType = type_variable(_, _)
+ ->
+ MLDS_SourceType =
+ mercury_type_to_mlds_type(ModuleInfo, SourceType),
+ ArgRval = ml_unop(box(MLDS_SourceType), VarRval)
+ ;
+ % If converting to float, cast to mlds_generic_type and then unbox.
+ DestType = builtin_type(builtin_type_float),
+ SourceType \= builtin_type(builtin_type_float)
+ ->
+ MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
+ ArgRval = ml_unop(unbox(MLDS_DestType),
+ ml_unop(cast(mlds_generic_type), VarRval))
+ ;
+ % If converting from float, box and then cast the result.
+ SourceType = builtin_type(builtin_type_float),
+ DestType \= builtin_type(builtin_type_float)
+ ->
+ MLDS_SourceType =
+ mercury_type_to_mlds_type(ModuleInfo, SourceType),
+ MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
+ ArgRval = ml_unop(cast(MLDS_DestType),
+ ml_unop(box(MLDS_SourceType), VarRval))
+ ;
+ % If converting from an array(T) to array(X) where X is a concrete
+ % instance, we should insert a cast to the concrete instance.
+ % Also when converting to array(T) from array(X) we should cast
+ % to array(T).
+ type_to_ctor_and_args(SourceType, SourceTypeCtor, SourceTypeArgs),
+ type_to_ctor_and_args(DestType, DestTypeCtor, DestTypeArgs),
+ (
+ type_ctor_is_array(SourceTypeCtor),
+ SourceTypeArgs = [type_variable(_, _)]
+ ;
+ type_ctor_is_array(DestTypeCtor),
+ DestTypeArgs = [type_variable(_, _)]
+ ),
+ % Don't insert redundant casts if the types are the same, since
+ % the extra assignments introduced can inhibit tail call
+ % optimisation.
+ SourceType \= DestType
+ ->
+ MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
+ ArgRval = ml_unop(cast(MLDS_DestType), VarRval)
+ ;
+ % If converting from one concrete type to a different one, then
+ % cast. This is needed to handle construction/deconstruction
+ % unifications for no_tag types.
+ %
+ \+ type_unify(SourceType, DestType, [], map.init, _)
+ ->
+ MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
+ ArgRval = ml_unop(cast(MLDS_DestType), VarRval)
+ ;
+ % Otherwise leave unchanged.
+ ArgRval = VarRval
+ )
+ ).
+
+ml_gen_box_or_unbox_lval(CallerType, CalleeType, BoxPolicy, VarLval, VarName,
+ Context, ForClosureWrapper, ArgNum, ArgLval, ConvDecls,
+ ConvInputStatements, ConvOutputStatements, !Info) :-
+ % First see if we can just convert the lval as an rval;
+ % if no boxing/unboxing is required, then ml_box_or_unbox_rval
+ % will return its argument unchanged, and so we're done.
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ml_gen_box_or_unbox_rval(ModuleInfo, CalleeType, CallerType, BoxPolicy,
+ ml_lval(VarLval), BoxedRval),
+ ( BoxedRval = ml_lval(VarLval) ->
+ ArgLval = VarLval,
+ ConvDecls = [],
+ ConvInputStatements = [],
+ ConvOutputStatements = []
+ ;
+ % If that didn't work, then we need to declare a fresh variable
+ % to use as the arg, and to generate statements to box/unbox
+ % that fresh arg variable and assign it to/from the output
+ % argument whose address we were passed.
+
+ % Generate a declaration for the fresh variable.
+ %
+ % Note that generating accurate GC tracing code for this
+ % variable requires some care, because CalleeType might be a
+ % type variable from the callee, not from the caller,
+ % and we can't generate type_infos for type variables
+ % from the callee. Hence we need to call the version of
+ % ml_gen_gc_statement which takes two types:
+ % the CalleeType is used to determine the type for the
+ % temporary variable declaration, but the CallerType is
+ % used to construct the type_info.
+
+ ml_gen_info_new_conv_var(ConvVarSeq, !Info),
+ VarName = mlds_var_name(VarNameStr, MaybeNum),
+ ConvVarSeq = conv_seq(ConvVarNum),
+ string.format("conv%d_%s", [i(ConvVarNum), s(VarNameStr)],
+ ConvVarName),
+ ArgVarName = mlds_var_name(ConvVarName, MaybeNum),
+ ml_gen_type(!.Info, CalleeType, MLDS_CalleeType),
+ (
+ ForClosureWrapper = yes,
+ % For closure wrappers, the argument type_infos are
+ % stored in the `type_params' local, so we need to
+ % handle the GC tracing code specially
+ ( CallerType = type_variable(_, _) ->
+ ml_gen_local_for_output_arg(ArgVarName, CalleeType, ArgNum,
+ Context, ArgVarDecl, !Info)
+ ;
+ unexpected(this_file, "invalid CalleeType for closure wrapper")
+ )
+ ;
+ ForClosureWrapper = no,
+ ml_gen_gc_statement_poly(ArgVarName, CalleeType, CallerType,
+ Context, GC_Statements, !Info),
+ ArgVarDecl = ml_gen_mlds_var_decl(mlds_data_var(ArgVarName),
+ MLDS_CalleeType, GC_Statements, mlds_make_context(Context))
+ ),
+ ConvDecls = [ArgVarDecl],
+
+ % Create the lval for the variable and use it for the argument lval.
+ ml_gen_var_lval(!.Info, ArgVarName, MLDS_CalleeType, ArgLval),
+
+ CallerIsDummy = check_dummy_type(ModuleInfo, CallerType),
+ (
+ CallerIsDummy = is_dummy_type,
+ % If it is a dummy argument type (e.g. io.state),
+ % then we don't need to bother assigning it.
+ ConvInputStatements = [],
+ ConvOutputStatements = []
+ ;
+ CallerIsDummy = is_not_dummy_type,
+ % Generate statements to box/unbox the fresh variable and assign it
+ % to/from the output argument whose address we were passed.
+
+ % Assign to the freshly generated arg variable.
+ ml_gen_box_or_unbox_rval(ModuleInfo, CallerType, CalleeType,
+ BoxPolicy, ml_lval(VarLval), ConvertedVarRval),
+ AssignInputStatement = ml_gen_assign(ArgLval, ConvertedVarRval,
+ Context),
+ ConvInputStatements = [AssignInputStatement],
+
+ % Assign from the freshly generated arg variable.
+ ml_gen_box_or_unbox_rval(ModuleInfo, CalleeType, CallerType,
+ BoxPolicy, ml_lval(ArgLval), ConvertedArgRval),
+ AssignOutputStatement = ml_gen_assign(VarLval, ConvertedArgRval,
+ Context),
+ ConvOutputStatements = [AssignOutputStatement]
+ )
+ ).
+
+ml_gen_local_for_output_arg(VarName, Type, ArgNum, Context, LocalVarDefn,
+ !Info) :-
+ % Generate a declaration for a corresponding local variable.
+ % However, don't use the normal GC tracing code; instead,
+ % we need to get the typeinfo from `type_params', using the following code:
+ %
+ % MR_TypeInfo type_info;
+ % MR_MemoryList allocated_memory_cells = NULL;
+ % type_info = MR_make_type_info_maybe_existq(type_params,
+ % closure_layout->MR_closure_arg_pseudo_type_info[<ArgNum> - 1],
+ % NULL, NULL, &allocated_memory_cells);
+ %
+ % private_builtin__gc_trace_1_0(type_info, &<VarName>);
+ %
+ % MR_deallocate(allocated_memory_cells);
+ %
+ MLDS_Context = mlds_make_context(Context),
+
+ ClosureLayoutPtrName = mlds_var_name("closure_layout_ptr", no),
+ % This type is really `const MR_Closure_Layout *', but there's no easy
+ % way to represent that in the MLDS; using MR_Box instead works fine.
+ ClosureLayoutPtrType = mlds_generic_type,
+ ml_gen_var_lval(!.Info, ClosureLayoutPtrName, ClosureLayoutPtrType,
+ ClosureLayoutPtrLval),
+
+ TypeParamsName = mlds_var_name("type_params", no),
+ % This type is really MR_TypeInfoParams, but there's no easy way to
+ % represent that in the MLDS; using MR_Box instead works fine.
+ TypeParamsType = mlds_generic_type,
+ ml_gen_var_lval(!.Info, TypeParamsName, TypeParamsType, TypeParamsLval),
+
+ TypeInfoName = mlds_var_name("type_info", no),
+ % The type for this should match the type of the first argument
+ % of private_builtin.gc_trace/1, i.e. `mutvar(T)', which is a no_tag type
+ % whose representation is c_pointer.
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ TypeInfoMercuryType = c_pointer_type,
+ TypeInfoType = mercury_type_to_mlds_type(ModuleInfo, TypeInfoMercuryType),
+ ml_gen_var_lval(!.Info, TypeInfoName, TypeInfoType, TypeInfoLval),
+ TypeInfoDecl = ml_gen_mlds_var_decl(mlds_data_var(TypeInfoName),
+ TypeInfoType, gc_no_stmt, MLDS_Context),
+
+ ml_gen_gc_statement_with_typeinfo(VarName, Type, ml_lval(TypeInfoLval),
+ Context, GCStatement0, !Info),
+
+ (
+ (
+ GCStatement0 = gc_trace_code(CallTraceFuncCode)
+ ;
+ GCStatement0 = gc_initialiser(CallTraceFuncCode)
+ ),
+ MakeTypeInfoCode = ml_stmt_atomic(inline_target_code(ml_target_c, [
+ raw_target_code("{\n", []),
+ raw_target_code("MR_MemoryList allocated_mem = NULL;\n", []),
+ target_code_output(TypeInfoLval),
+ raw_target_code(" = (MR_C_Pointer) " ++
+ "MR_make_type_info_maybe_existq(\n\t", []),
+ target_code_input(ml_lval(TypeParamsLval)),
+ raw_target_code(", ((MR_Closure_Layout *)\n\t", []),
+ target_code_input(ml_lval(ClosureLayoutPtrLval)),
+ raw_target_code(string.format(")->" ++
+ "MR_closure_arg_pseudo_type_info[%d - 1],\n\t" ++
+ "NULL, NULL, &allocated_mem);\n",
+ [i(ArgNum)]), [])
+ ])),
+ DeallocateCode = ml_stmt_atomic(inline_target_code(ml_target_c, [
+ raw_target_code("MR_deallocate(allocated_mem);\n", []),
+ raw_target_code("}\n", [])
+ ])),
+ GCTraceCode = ml_stmt_block([TypeInfoDecl], [
+ statement(MakeTypeInfoCode, MLDS_Context),
+ CallTraceFuncCode,
+ statement(DeallocateCode, MLDS_Context)
+ ]),
+ GCStatement = gc_trace_code(statement(GCTraceCode, MLDS_Context))
+ ;
+ GCStatement0 = gc_no_stmt,
+ GCStatement = GCStatement0
+ ),
+ LocalVarDefn = ml_gen_mlds_var_decl(mlds_data_var(VarName),
+ mercury_type_to_mlds_type(ModuleInfo, Type),
+ GCStatement, MLDS_Context).
+
%-----------------------------------------------------------------------------%
%
% Code for handling success and failure.
@@ -1906,875 +1962,6 @@
GCStatement = gc_no_stmt.
%-----------------------------------------------------------------------------%
-%
-% Code to handle accurate GC.
-%
-
-ml_gen_gc_statement(VarName, Type, Context, GCStatement, !Info) :-
- ml_gen_gc_statement_poly(VarName, Type, Type, Context, GCStatement, !Info).
-
-ml_gen_gc_statement_poly(VarName, DeclType, ActualType, Context,
- GCStatement, !Info) :-
- HowToGetTypeInfo = construct_from_type(ActualType),
- ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
- GCStatement, !Info).
-
-ml_gen_gc_statement_with_typeinfo(VarName, DeclType, TypeInfoRval, Context,
- GCStatement, !Info) :-
- HowToGetTypeInfo = already_provided(TypeInfoRval),
- ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
- GCStatement, !Info).
-
-:- type how_to_get_type_info
- ---> construct_from_type(mer_type)
- ; already_provided(mlds_rval).
-
-:- pred ml_gen_gc_statement_2(mlds_var_name::in, mer_type::in,
- how_to_get_type_info::in, prog_context::in,
- mlds_gc_statement::out, ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
- GCStatement, !Info) :-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_gc_method(Globals, GC),
- (
- GC = gc_accurate,
- MLDS_DeclType = mercury_type_to_mlds_type(ModuleInfo, DeclType),
- ml_type_might_contain_pointers_for_gc(MLDS_DeclType) = yes,
- % don't generate GC tracing code in no_type_info_builtins
- ml_gen_info_get_pred_id(!.Info, PredId),
- predicate_id(ModuleInfo, PredId, PredModule, PredName, PredArity),
- \+ no_type_info_builtin(PredModule, PredName, PredArity)
- ->
- (
- HowToGetTypeInfo = construct_from_type(ActualType0),
- % We need to handle type_info/1 and typeclass_info/1
- % types specially, to avoid infinite recursion here...
- ( trace_type_info_type(ActualType0, ActualType1) ->
- ActualType = ActualType1
- ;
- ActualType = ActualType0
- ),
- ml_gen_gc_trace_code(VarName, DeclType, ActualType,
- Context, GC_TraceCode, !Info)
- ;
- HowToGetTypeInfo = already_provided(TypeInfoRval),
- ml_gen_trace_var(!.Info, VarName, DeclType, TypeInfoRval,
- Context, GC_TraceCode)
- ),
- GCStatement = gc_trace_code(GC_TraceCode)
- ;
- GCStatement = gc_no_stmt
- ).
-
- % Return `yes' if the type needs to be traced by the accurate garbage
- % collector, i.e. if it might contain pointers.
- %
- % Any type for which we return `yes' here must be word-sized, because
- % we will call private_builtin.gc_trace with its address, and that
- % procedure assumes that its argument is an `MR_Word *'.
- %
- % For floats, we can (and must) return `no' even though they might
- % get boxed in some circumstances, because if they are boxed then they will
- % be represented as mlds_generic_type.
- %
- % Note that with --gcc-nested-functions, cont_type will be a function
- % pointer that may point to a trampoline function, which might in fact
- % contain pointers. But the pointers will only be pointers to code and
- % pointers to the stack, not pointers to the heap, so we don't need to
- % trace them for accurate GC. Hence we can return `no' here for
- % mlds_cont_type.
- %
- % Similarly, the only pointers in type_ctor_infos and base_typeclass_infos
- % are to static code and/or static data, which do not need to be traced.
- %
-:- func ml_type_might_contain_pointers_for_gc(mlds_type) = bool.
-
-ml_type_might_contain_pointers_for_gc(Type) = MightContainPointers :-
- (
- Type = mercury_type(_Type, TypeCategory, _),
- MightContainPointers =
- ml_type_category_might_contain_pointers(TypeCategory)
- ;
- Type = mlds_class_type(_, _, Category),
- ( Category = mlds_enum ->
- MightContainPointers = no
- ;
- MightContainPointers = yes
- )
- ;
- ( Type = mlds_mercury_array_type(_)
- ; Type = mlds_ptr_type(_)
- ; Type = mlds_array_type(_)
- ; Type = mlds_generic_type
- ; Type = mlds_generic_env_ptr_type
- ; Type = mlds_type_info_type
- ; Type = mlds_pseudo_type_info_type
- ; Type = mlds_rtti_type(_)
- ; Type = mlds_unknown_type
- ),
- MightContainPointers = yes
- ;
- ( Type = mlds_native_int_type
- ; Type = mlds_native_float_type
- ; Type = mlds_native_bool_type
- ; Type = mlds_native_char_type
- ; Type = mlds_foreign_type(_)
- % We assume that foreign types are not allowed to contain pointers
- % to the Mercury heap. XXX is this requirement too strict?
- ; Type = mlds_func_type(_)
- ; Type = mlds_cont_type(_)
- ; Type = mlds_commit_type
- ; Type = mlds_tabling_type(_)
- % Values of mlds_tabling_type types may contain pointers, but
- % they won't exist if we are using accurate GC.
- ),
- MightContainPointers = no
- ).
-
-:- func ml_type_category_might_contain_pointers(type_ctor_category) = bool.
-
-ml_type_category_might_contain_pointers(CtorCat) = MayContainPointers :-
- (
- ( CtorCat = ctor_cat_builtin(cat_builtin_int)
- ; CtorCat = ctor_cat_builtin(cat_builtin_char)
- ; CtorCat = ctor_cat_builtin(cat_builtin_float)
- ; CtorCat = ctor_cat_builtin_dummy
- ; CtorCat = ctor_cat_void
- ; CtorCat = ctor_cat_enum(_)
- ; CtorCat = ctor_cat_system(cat_system_type_ctor_info)
- ; CtorCat = ctor_cat_system(cat_system_base_typeclass_info)
- ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
- ),
- MayContainPointers = no
- ;
- ( CtorCat = ctor_cat_builtin(cat_builtin_string)
- ; CtorCat = ctor_cat_system(cat_system_type_info)
- ; CtorCat = ctor_cat_system(cat_system_typeclass_info)
- ; CtorCat = ctor_cat_higher_order
- ; CtorCat = ctor_cat_tuple
- ; CtorCat = ctor_cat_variable
- ; CtorCat = ctor_cat_user(cat_user_notag)
- ; CtorCat = ctor_cat_user(cat_user_general)
- ),
- MayContainPointers = yes
- ).
-
- % trace_type_info_type(Type, RealType):
- %
- % Succeed iff Type is a type_info-related type which needs to be copied
- % as if it were some other type, binding RealType to that other type.
- %
-:- pred trace_type_info_type(mer_type::in, mer_type::out) is semidet.
-
-trace_type_info_type(Type, RealType) :-
- Type = defined_type(TypeName, _, _),
- TypeName = qualified(PrivateBuiltin, Name),
- PrivateBuiltin = mercury_private_builtin_module,
- ( Name = "type_info", RealType = sample_type_info_type
- ; Name = "type_ctor_info", RealType = c_pointer_type
- ; Name = "typeclass_info", RealType = sample_typeclass_info_type
- ; Name = "base_typeclass_info", RealType = c_pointer_type
- ; Name = "zero_type_info", RealType = sample_type_info_type
- ; Name = "zero_type_ctor_info", RealType = c_pointer_type
- ; Name = "zero_typeclass_info", RealType = sample_typeclass_info_type
- ; Name = "zero_base_typeclass_info", RealType = c_pointer_type
- ).
-
- % Generate code to call to `private_builtin.gc_trace'
- % to trace the specified variable.
- %
-:- pred ml_gen_gc_trace_code(mlds_var_name::in, mer_type::in, mer_type::in,
- prog_context::in, statement::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_gc_trace_code(VarName, DeclType, ActualType, Context, GC_TraceCode,
- !Info) :-
- % Build HLDS code to construct the type_info for this type.
- ml_gen_make_type_info_var(ActualType, Context,
- TypeInfoVar, HLDS_TypeInfoGoals, !Info),
- NonLocalsList = list.map(
- (func(hlds_goal(_GX, GI)) = goal_info_get_nonlocals(GI)),
- HLDS_TypeInfoGoals),
- NonLocals = set.union_list(NonLocalsList),
- InstMapDelta = instmap_delta_bind_var(TypeInfoVar),
- goal_info_init(NonLocals, InstMapDelta, detism_det, purity_impure,
- GoalInfo),
- conj_list_to_goal(HLDS_TypeInfoGoals, GoalInfo, Conj),
-
- % Convert this HLDS code to MLDS.
- ml_gen_goal_as_block(model_det, Conj, MLDS_TypeInfoStatement0, !Info),
-
- % Replace all heap allocation (new_object instructions) with stack
- % allocation (local variable declarations) in the code to construct
- % type_infos. This is safe because those type_infos will only be used
- % in the immediately following call to gc_trace/1.
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_name(ModuleInfo, ModuleName),
- fixup_newobj(MLDS_TypeInfoStatement0,
- mercury_module_name_to_mlds(ModuleName),
- MLDS_TypeInfoStatement, MLDS_NewobjLocals),
-
- % Build MLDS code to trace the variable.
- ml_gen_var(!.Info, TypeInfoVar, TypeInfoLval),
- ml_gen_trace_var(!.Info, VarName, DeclType, ml_lval(TypeInfoLval), Context,
- MLDS_TraceStatement),
-
- % Generate declarations for any type_info variables used.
- %
- % Note: this will generate local declarations even for type_info variables
- % which are not local to this goal. However, fortunately ml_elim_nested.m
- % will transform the GC code to use the original definitions, which will
- % get put in the GC frame, rather than these declarations, which will get
- % ignored.
- % XXX This is not a very robust way of doing things...
- ml_gen_info_get_varset(!.Info, VarSet),
- ml_gen_info_get_var_types(!.Info, VarTypes),
- MLDS_Context = mlds_make_context(Context),
- GenLocalVarDecl =
- (func(Var) = VarDefn :-
- LocalVarName = ml_gen_var_name(VarSet, Var),
- map.lookup(VarTypes, Var, LocalVarType),
- VarDefn = ml_gen_mlds_var_decl(mlds_data_var(LocalVarName),
- mercury_type_to_mlds_type(ModuleInfo, LocalVarType),
- gc_no_stmt, MLDS_Context)
- ),
- set.to_sorted_list(NonLocals, NonLocalVarList),
- MLDS_NonLocalVarDecls = list.map(GenLocalVarDecl, NonLocalVarList),
-
- % Combine the MLDS code fragments together.
- GC_TraceCode = ml_gen_block(MLDS_NewobjLocals ++ MLDS_NonLocalVarDecls,
- [MLDS_TypeInfoStatement, MLDS_TraceStatement], Context).
-
- % ml_gen_trace_var(VarName, DeclType, TypeInfo, Context, Code):
- % Generate a call to `private_builtin.gc_trace' for the specified variable,
- % given the variable's name, type, and the already-constructed type_info
- % for that type.
- %
-:- pred ml_gen_trace_var(ml_gen_info::in, mlds_var_name::in, mer_type::in,
- mlds_rval::in, prog_context::in, statement::out) is det.
-
-ml_gen_trace_var(Info, VarName, Type, TypeInfoRval, Context, TraceStatement) :-
- % Generate the lval for Var.
- ml_gen_info_get_module_info(Info, ModuleInfo),
- MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
- ml_gen_var_lval(Info, VarName, MLDS_Type, VarLval),
-
- % Generate the address of `private_builtin.gc_trace/1#0'.
- PredName = "gc_trace",
- PredOrigArity = 1,
- PredLabel = mlds_user_pred_label(pf_predicate, no, PredName, PredOrigArity,
- model_det, no),
- ProcId = hlds_pred.initial_proc_id,
- PredModule = mercury_private_builtin_module,
- MLDS_Module = mercury_module_name_to_mlds(PredModule),
- ProcLabel = mlds_proc_label(PredLabel, ProcId),
- QualProcLabel = qual(MLDS_Module, module_qual, ProcLabel),
- CPointerType = mercury_type(c_pointer_type,
- ctor_cat_user(cat_user_general), non_foreign_type(c_pointer_type)),
- ArgTypes = [mlds_pseudo_type_info_type, CPointerType],
- Signature = mlds_func_signature(ArgTypes, []),
- FuncAddr = ml_const(mlconst_code_addr(
- code_addr_proc(QualProcLabel, Signature))),
-
- % Generate the call
- % `private_builtin.gc_trace(TypeInfo, (MR_C_Pointer) &Var);'.
- CastVarAddr = ml_unop(cast(CPointerType), ml_mem_addr(VarLval)),
- TraceStmt = ml_stmt_call(Signature, FuncAddr, no,
- [TypeInfoRval, CastVarAddr], [], ordinary_call),
- TraceStatement = statement(TraceStmt, mlds_make_context(Context)).
-
- % Generate HLDS code to construct the type_info for this type.
- %
-:- pred ml_gen_make_type_info_var(mer_type::in, prog_context::in,
- prog_var::out, hlds_goals::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_make_type_info_var(Type, Context, TypeInfoVar, TypeInfoGoals, !Info) :-
- ml_gen_info_get_module_info(!.Info, ModuleInfo0),
- ml_gen_info_get_pred_id(!.Info, PredId),
- ml_gen_info_get_proc_id(!.Info, ProcId),
- module_info_pred_proc_info(ModuleInfo0, PredId, ProcId,
- PredInfo0, ProcInfo0),
-
- % Call polymorphism.m to generate the HLDS code to create the type_infos.
- create_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0),
- polymorphism_make_type_info_var(Type, Context,
- TypeInfoVar, TypeInfoGoals, PolyInfo0, PolyInfo),
- poly_info_extract(PolyInfo, PredInfo0, PredInfo,
- ProcInfo0, ProcInfo, ModuleInfo1),
-
- % Save the new information back in the ml_gen_info.
- module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
- ModuleInfo1, ModuleInfo),
- proc_info_get_varset(ProcInfo, VarSet),
- proc_info_get_vartypes(ProcInfo, VarTypes),
- ml_gen_info_set_module_info(ModuleInfo, !Info),
- ml_gen_info_set_varset(VarSet, !Info),
- ml_gen_info_set_var_types(VarTypes, !Info).
-
-%-----------------------------------------------------------------------------%
-
-:- type fixup_newobj_info
- ---> fixup_newobj_info(
- % The current module.
- fnoi_module_name :: mlds_module_name,
-
- % The current context.
- fnoi_context :: mlds_context,
-
- % The local variable declarations accumulated so far.
- fnoi_locals :: list(mlds_defn),
-
- % A counter used to allocate variable names.
- fnoi_next_id :: counter
- ).
-
- % Replace all heap allocation (new_object instructions) with stack
- % allocation (local variable declarations) in the specified statement,
- % returning the local variable declarations needed for the stack
- % allocation.
- %
-:- pred fixup_newobj(statement::in, mlds_module_name::in,
- statement::out, list(mlds_defn)::out) is det.
-
-fixup_newobj(Statement0, ModuleName, Statement, Defns) :-
- Statement0 = statement(Stmt0, Context),
- Info0 = fixup_newobj_info(ModuleName, Context, [], counter.init(0)),
- fixup_newobj_in_stmt(Stmt0, Stmt, Info0, Info),
- Statement = statement(Stmt, Context),
- Defns = Info ^ fnoi_locals.
-
-:- pred fixup_newobj_in_statement(statement::in, statement::out,
- fixup_newobj_info::in, fixup_newobj_info::out) is det.
-
-fixup_newobj_in_statement(Statement0, Statement, !Info) :-
- Statement0 = statement(Stmt0, Context),
- !:Info = !.Info ^ fnoi_context := Context,
- fixup_newobj_in_stmt(Stmt0, Stmt, !Info),
- Statement = statement(Stmt, Context).
-
-:- pred fixup_newobj_in_stmt(mlds_stmt::in, mlds_stmt::out,
- fixup_newobj_info::in, fixup_newobj_info::out) is det.
-
-fixup_newobj_in_stmt(Stmt0, Stmt, !Fixup) :-
- (
- Stmt0 = ml_stmt_block(Defns, Statements0),
- list.map_foldl(fixup_newobj_in_statement,
- Statements0, Statements, !Fixup),
- Stmt = ml_stmt_block(Defns, Statements)
- ;
- Stmt0 = ml_stmt_while(Rval, Statement0, Once),
- fixup_newobj_in_statement(Statement0, Statement, !Fixup),
- Stmt = ml_stmt_while(Rval, Statement, Once)
- ;
- Stmt0 = ml_stmt_if_then_else(Cond, Then0, MaybeElse0),
- fixup_newobj_in_statement(Then0, Then, !Fixup),
- fixup_newobj_in_maybe_statement(MaybeElse0, MaybeElse, !Fixup),
- Stmt = ml_stmt_if_then_else(Cond, Then, MaybeElse)
- ;
- Stmt0 = ml_stmt_switch(Type, Val, Range, Cases0, Default0),
- list.map_foldl(fixup_newobj_in_case, Cases0, Cases, !Fixup),
- fixup_newobj_in_default(Default0, Default, !Fixup),
- Stmt = ml_stmt_switch(Type, Val, Range, Cases, Default)
- ;
- Stmt0 = ml_stmt_label(_),
- Stmt = Stmt0
- ;
- Stmt0 = ml_stmt_goto(_),
- Stmt = Stmt0
- ;
- Stmt0 = ml_stmt_computed_goto(Rval, Labels),
- Stmt = ml_stmt_computed_goto(Rval, Labels)
- ;
- Stmt0 = ml_stmt_call(_Sig, _Func, _Obj, _Args, _RetLvals, _TailCall),
- Stmt = Stmt0
- ;
- Stmt0 = ml_stmt_return(_Rvals),
- Stmt = Stmt0
- ;
- Stmt0 = ml_stmt_do_commit(_Ref),
- Stmt = Stmt0
- ;
- Stmt0 = ml_stmt_try_commit(Ref, Statement0, Handler0),
- fixup_newobj_in_statement(Statement0, Statement, !Fixup),
- fixup_newobj_in_statement(Handler0, Handler, !Fixup),
- Stmt = ml_stmt_try_commit(Ref, Statement, Handler)
- ;
- Stmt0 = ml_stmt_atomic(AtomicStmt0),
- fixup_newobj_in_atomic_statement(AtomicStmt0, Stmt, !Fixup)
- ).
-
-:- pred fixup_newobj_in_case(mlds_switch_case::in, mlds_switch_case::out,
- fixup_newobj_info::in, fixup_newobj_info::out) is det.
-
-fixup_newobj_in_case(Case0, Case, !Fixup) :-
- Case0 = mlds_switch_case(FirstCond, LaterConds, Statement0),
- fixup_newobj_in_statement(Statement0, Statement, !Fixup),
- Case = mlds_switch_case(FirstCond, LaterConds, Statement).
-
-:- pred fixup_newobj_in_maybe_statement(maybe(statement)::in,
- maybe(statement)::out,
- fixup_newobj_info::in, fixup_newobj_info::out) is det.
-
-fixup_newobj_in_maybe_statement(no, no, !Fixup).
-fixup_newobj_in_maybe_statement(yes(Statement0), yes(Statement), !Fixup) :-
- fixup_newobj_in_statement(Statement0, Statement, !Fixup).
-
-:- pred fixup_newobj_in_default(mlds_switch_default::in,
- mlds_switch_default::out,
- fixup_newobj_info::in, fixup_newobj_info::out) is det.
-
-fixup_newobj_in_default(default_is_unreachable, default_is_unreachable,
- !Fixup).
-fixup_newobj_in_default(default_do_nothing, default_do_nothing, !Fixup).
-fixup_newobj_in_default(default_case(Statement0), default_case(Statement),
- !Fixup) :-
- fixup_newobj_in_statement(Statement0, Statement, !Fixup).
-
-:- pred fixup_newobj_in_atomic_statement(mlds_atomic_statement::in,
- mlds_stmt::out, fixup_newobj_info::in, fixup_newobj_info::out) is det.
-
-fixup_newobj_in_atomic_statement(AtomicStatement0, Stmt, !Fixup) :-
- (
- AtomicStatement0 = new_object(Lval, MaybeTag, _HasSecTag, PointerType,
- _MaybeSizeInWordsRval, _MaybeCtorName, ArgRvals, _ArgTypes,
- _MayUseAtomic)
- ->
- % Generate the declaration of the new local variable.
- %
- % XXX Using array(generic_type) is wrong for --high-level-data.
- %
- % We need to specify an initializer to tell the C back-end what the
- % length of the array is. We initialize it with null pointers and then
- % later generate assignment statements to fill in the values properly
- % (see below).
- counter.allocate(Id, !.Fixup ^ fnoi_next_id, NextId),
- VarName = mlds_var_name("new_obj", yes(Id)),
- VarType = mlds_array_type(mlds_generic_type),
- NullPointers = list.duplicate(list.length(ArgRvals),
- init_obj(ml_const(mlconst_null(mlds_generic_type)))),
- Initializer = init_array(NullPointers),
- % This is used for the type_infos allocated during tracing,
- % and we don't need to trace them.
- GCStatement = gc_no_stmt,
- Context = !.Fixup ^ fnoi_context,
- VarDecl = ml_gen_mlds_var_decl_init(mlds_data_var(VarName), VarType,
- Initializer, GCStatement, Context),
- !Fixup ^ fnoi_next_id := NextId,
- % XXX We should keep a more structured representation of the local
- % variables, such as a map from variable names.
- !Fixup ^ fnoi_locals := !.Fixup ^ fnoi_locals ++ [VarDecl],
-
- % Generate code to initialize the variable.
- %
- % Note that we need to use assignment statements, rather than an
- % initializer, to initialize the local variable, because the
- % initialization code needs to occur at exactly the point where the
- % atomic_statement occurs, rather than at the local variable
- % declaration.
-
- VarLval = ml_var(
- qual(!.Fixup ^ fnoi_module_name, module_qual, VarName),
- VarType),
- PtrRval = ml_unop(cast(PointerType), ml_mem_addr(VarLval)),
- list.map_foldl(init_field_n(PointerType, PtrRval, Context),
- ArgRvals, ArgInitStatements, 0, _NumFields),
-
- % Generate code to assign the address of the new local variable
- % to the Lval.
- TaggedPtrRval = maybe_tag_rval(MaybeTag, PointerType, PtrRval),
- AssignStmt = ml_stmt_atomic(assign(Lval, TaggedPtrRval)),
- AssignStatement = statement(AssignStmt, Context),
- Stmt = ml_stmt_block([], ArgInitStatements ++ [AssignStatement])
- ;
- Stmt = ml_stmt_atomic(AtomicStatement0)
- ).
-
-:- pred init_field_n(mlds_type::in, mlds_rval::in, mlds_context::in,
- mlds_rval::in, statement::out, int::in, int::out) is det.
-
-init_field_n(PointerType, PointerRval, Context, ArgRval, Statement,
- FieldNum, FieldNum + 1) :-
- FieldId = ml_field_offset(ml_const(mlconst_int(FieldNum))),
- % XXX FieldType is wrong for --high-level-data
- FieldType = mlds_generic_type,
- MaybeTag = yes(0),
- Field = ml_field(MaybeTag, PointerRval, FieldId, FieldType, PointerType),
- AssignStmt = ml_stmt_atomic(assign(Field, ArgRval)),
- Statement = statement(AssignStmt, Context).
-
-:- func maybe_tag_rval(maybe(mlds_tag), mlds_type, mlds_rval) = mlds_rval.
-
-maybe_tag_rval(no, _Type, Rval) = Rval.
-maybe_tag_rval(yes(Tag), Type, Rval) = TaggedRval :-
- TaggedRval = ml_unop(cast(Type), ml_mkword(Tag, Rval)).
-
-%-----------------------------------------------------------------------------%
-%
-% The definition of the `ml_gen_info' ADT.
-%
-
- % The `ml_gen_info' type holds information used during MLDS code generation
- % for a given procedure.
- %
-:- type ml_gen_info
- ---> ml_gen_info(
-/* 1 */ mgi_module_info :: module_info,
-
- % These fields remain constant for each procedure unless
- % accurate GC is enabled, in which case they may get updated
- % if we create fresh variables for the type_info variables
- % needed for calls to private_builtin.gc_trace.
-/* 2 */ mgi_varset :: prog_varset,
-/* 3 */ mgi_var_types :: vartypes,
-
- % Output arguments that are passed by reference.
-/* 4 */ mgi_byref_output_vars :: list(prog_var),
-
- % Output arguments that are returned as values.
-/* 5 */ mgi_value_output_vars :: list(prog_var),
-
- % Definitions of functions or global constants which should be
- % inserted before the definition of the function for the
- % current procedure.
-/* 6 */ mgi_var_lvals :: map(prog_var, mlds_lval),
-
-/* 7 */ mgi_global_data :: ml_global_data,
-
- % All of the other pieces of information that are not among
- % the most frequently read and/or written fields. Limiting
- % ml_gen_info to eight fields make updating the structure
- % quicker and less wasteful of memory.
-/* 8 */ mgi_sub_info :: ml_gen_sub_info
- ).
-
-:- type ml_gen_sub_info
- ---> ml_gen_sub_info(
- % Quick-access read-only copies of parts of the globals
- % structure taken from the module_info.
-/* 1 */ mgsi_high_level_data :: bool,
-/* 2 */ mgsi_target :: compilation_target,
-
- % The identity of the procedure we are generating code for.
-/* 3 */ mgsi_pred_id :: pred_id,
-/* 4 */ mgsi_proc_id :: proc_id,
-
-/* 5 */ mgsi_func_counter :: counter,
-/* 6 */ mgsi_label_counter :: counter,
-/* 7 */ mgsi_aux_var_counter :: counter,
-/* 8 */ mgsi_cond_var_counter :: counter,
-/* 9 */ mgsi_conv_var_counter :: counter,
-
-/* 10 */ mgsi_const_var_map :: map(prog_var, ml_ground_term),
-
-/* 11 */ mgsi_closure_wrapper_defns :: list(mlds_defn),
-
- % A partial mapping from vars to lvals, used to override
- % the normal lval that we use for a variable.
-/* 12 */ mgsi_success_cont_stack :: stack(success_cont),
-
-/* 13 */ mgsi_env_var_names :: set(string)
- ).
-
-ml_gen_info_init(ModuleInfo, PredId, ProcId, ProcInfo, GlobalData) = Info :-
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
- globals.get_target(Globals, CompilationTarget),
-
- proc_info_get_headvars(ProcInfo, HeadVars),
- proc_info_get_varset(ProcInfo, VarSet),
- proc_info_get_vartypes(ProcInfo, VarTypes),
- proc_info_get_argmodes(ProcInfo, HeadModes),
- ByRefOutputVars = select_output_vars(ModuleInfo, HeadVars, HeadModes,
- VarTypes),
- ValueOutputVars = [],
-
- % XXX This needs to start at 1 rather than 0 otherwise the transformation
- % for adding the shadow stack for accurate garbage collection does not work
- % properly and we will end up generating two C functions with the same
- % name (see ml_elim_nested.gen_gc_trace_func/8 for details).
- %
- counter.init(1, FuncLabelCounter),
- counter.init(0, LabelCounter),
- counter.init(0, AuxVarCounter),
- counter.init(0, CondVarCounter),
- counter.init(0, ConvVarCounter),
- map.init(ConstVarMap),
- stack.init(SuccContStack),
- map.init(VarLvals),
- ClosureWrapperDefns = [],
- EnvVarNames = set.init,
-
- SubInfo = ml_gen_sub_info(
- HighLevelData,
- CompilationTarget,
- PredId,
- ProcId,
- FuncLabelCounter,
- LabelCounter,
- AuxVarCounter,
- CondVarCounter,
- ConvVarCounter,
- ConstVarMap,
- ClosureWrapperDefns,
- SuccContStack,
- EnvVarNames
- ),
- Info = ml_gen_info(
- ModuleInfo,
- VarSet,
- VarTypes,
- ByRefOutputVars,
- ValueOutputVars,
- VarLvals,
- GlobalData,
- SubInfo
- ).
-
-:- pred ml_gen_info_get_func_counter(ml_gen_info::in, counter::out) is det.
-:- pred ml_gen_info_get_label_counter(ml_gen_info::in, counter::out) is det.
-:- pred ml_gen_info_get_aux_var_counter(ml_gen_info::in, counter::out) is det.
-:- pred ml_gen_info_get_cond_var_counter(ml_gen_info::in, counter::out) is det.
-:- pred ml_gen_info_get_conv_var_counter(ml_gen_info::in, counter::out) is det.
-:- pred ml_gen_info_get_success_cont_stack(ml_gen_info::in,
- stack(success_cont)::out) is det.
-
-ml_gen_info_get_module_info(Info, Info ^ mgi_module_info).
-ml_gen_info_get_high_level_data(Info,
- Info ^ mgi_sub_info ^ mgsi_high_level_data).
-ml_gen_info_get_target(Info, Info ^ mgi_sub_info ^ mgsi_target).
-ml_gen_info_get_pred_id(Info, Info ^ mgi_sub_info ^ mgsi_pred_id).
-ml_gen_info_get_proc_id(Info, Info ^ mgi_sub_info ^ mgsi_proc_id).
-ml_gen_info_get_varset(Info, Info ^ mgi_varset).
-ml_gen_info_get_var_types(Info, Info ^ mgi_var_types).
-ml_gen_info_get_byref_output_vars(Info, Info ^ mgi_byref_output_vars).
-ml_gen_info_get_value_output_vars(Info, Info ^ mgi_value_output_vars).
-ml_gen_info_get_var_lvals(Info, Info ^ mgi_var_lvals).
-ml_gen_info_get_global_data(Info, Info ^ mgi_global_data).
-
-ml_gen_info_get_func_counter(Info, Info ^ mgi_sub_info ^ mgsi_func_counter).
-ml_gen_info_get_label_counter(Info, Info ^ mgi_sub_info ^ mgsi_label_counter).
-ml_gen_info_get_aux_var_counter(Info,
- Info ^ mgi_sub_info ^ mgsi_aux_var_counter).
-ml_gen_info_get_cond_var_counter(Info,
- Info ^ mgi_sub_info ^ mgsi_cond_var_counter).
-ml_gen_info_get_conv_var_counter(Info,
- Info ^ mgi_sub_info ^ mgsi_conv_var_counter).
-ml_gen_info_get_const_var_map(Info,
- Info ^ mgi_sub_info ^ mgsi_const_var_map).
-ml_gen_info_get_success_cont_stack(Info,
- Info ^ mgi_sub_info ^ mgsi_success_cont_stack).
-ml_gen_info_get_closure_wrapper_defns(Info,
- Info ^ mgi_sub_info ^ mgsi_closure_wrapper_defns).
-ml_gen_info_get_env_var_names(Info, Info ^ mgi_sub_info ^ mgsi_env_var_names).
-
-:- pred ml_gen_info_set_module_info(module_info::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_varset(prog_varset::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_var_types(vartypes::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_func_counter(counter::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_label_counter(counter::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_aux_var_counter(counter::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_cond_var_counter(counter::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_conv_var_counter(counter::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_success_cont_stack(stack(success_cont)::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_closure_wrapper_defns(list(mlds_defn)::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-:- pred ml_gen_info_set_env_var_names(set(string)::in,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_info_set_module_info(ModuleInfo, !Info) :-
- !Info ^ mgi_module_info := ModuleInfo.
-ml_gen_info_set_varset(VarSet, !Info) :-
- !Info ^ mgi_varset := VarSet.
-ml_gen_info_set_var_types(VarTypes, !Info) :-
- !Info ^ mgi_var_types := VarTypes.
-ml_gen_info_set_byref_output_vars(OutputVars, !Info) :-
- !Info ^ mgi_byref_output_vars := OutputVars.
-ml_gen_info_set_value_output_vars(OutputVars, !Info) :-
- !Info ^ mgi_value_output_vars := OutputVars.
-ml_gen_info_set_var_lvals(VarLvals, !Info) :-
- !Info ^ mgi_var_lvals := VarLvals.
-ml_gen_info_set_global_data(GlobalData, !Info) :-
- !Info ^ mgi_global_data := GlobalData.
-
-ml_gen_info_set_func_counter(FuncCounter, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_func_counter := FuncCounter,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_label_counter(LabelCounter, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_label_counter := LabelCounter,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_aux_var_counter(AuxVarCounter, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_aux_var_counter := AuxVarCounter,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_cond_var_counter(CondVarCounter, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_cond_var_counter := CondVarCounter,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_conv_var_counter(ConvVarCounter, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_conv_var_counter := ConvVarCounter,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_const_var_map(ConstVarMap, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_const_var_map := ConstVarMap,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_success_cont_stack(SuccessContStack, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_success_cont_stack := SuccessContStack,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_closure_wrapper_defns(ClosureWrapperDefns, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_closure_wrapper_defns := ClosureWrapperDefns,
- !Info ^ mgi_sub_info := SubInfo.
-ml_gen_info_set_env_var_names(EnvVarNames, !Info) :-
- SubInfo0 = !.Info ^ mgi_sub_info,
- SubInfo = SubInfo0 ^ mgsi_env_var_names := EnvVarNames,
- !Info ^ mgi_sub_info := SubInfo.
-
-ml_gen_info_get_module_name(Info, ModuleName) :-
- ml_gen_info_get_module_info(Info, ModuleInfo),
- module_info_get_name(ModuleInfo, ModuleName).
-
-ml_gen_info_use_gcc_nested_functions(Info, UseNestedFuncs) :-
- ml_gen_info_get_globals(Info, Globals),
- globals.lookup_bool_option(Globals, gcc_nested_functions,
- UseNestedFuncs).
-
-ml_gen_info_put_commit_in_own_func(Info, PutCommitInNestedFunc) :-
- ml_gen_info_get_globals(Info, Globals),
- globals.lookup_bool_option(Globals, put_commit_in_own_func,
- PutCommitInNestedFunc).
-
-ml_gen_info_get_globals(Info, Globals) :-
- ml_gen_info_get_module_info(Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals).
-
-ml_gen_info_new_func_label(Label, !Info) :-
- ml_gen_info_get_func_counter(!.Info, Counter0),
- counter.allocate(Label, Counter0, Counter),
- ml_gen_info_set_func_counter(Counter, !Info).
-
-ml_gen_info_new_label(Label, !Info) :-
- ml_gen_info_get_label_counter(!.Info, Counter0),
- counter.allocate(Label, Counter0, Counter),
- ml_gen_info_set_label_counter(Counter, !Info).
-
-ml_gen_info_bump_counters(!Info) :-
- ml_gen_info_get_func_counter(!.Info, FuncLabelCounter0),
- counter.allocate(FuncLabel, FuncLabelCounter0, _),
- FuncLabelCounter = counter.init(FuncLabel + 10000),
- ml_gen_info_set_func_counter(FuncLabelCounter, !Info).
-
-ml_gen_info_new_aux_var_name(Prefix, VarName, !Info) :-
- ml_gen_info_get_aux_var_counter(!.Info, AuxVarCounter0),
- counter.allocate(AuxVarNum, AuxVarCounter0, AuxVarCounter),
- ml_gen_info_set_aux_var_counter(AuxVarCounter, !Info),
-
- Name = Prefix ++ "_" ++ string.int_to_string(AuxVarNum),
- VarName = mlds_var_name(Name, no).
-
-ml_gen_info_new_cond_var(cond_seq(CondNum), !Info) :-
- ml_gen_info_get_cond_var_counter(!.Info, CondCounter0),
- counter.allocate(CondNum, CondCounter0, CondCounter),
- ml_gen_info_set_cond_var_counter(CondCounter, !Info).
-
-ml_gen_info_new_conv_var(conv_seq(ConvNum), !Info) :-
- ml_gen_info_get_conv_var_counter(!.Info, ConvCounter0),
- counter.allocate(ConvNum, ConvCounter0, ConvCounter),
- ml_gen_info_set_conv_var_counter(ConvCounter, !Info).
-
-ml_gen_info_set_const_var(Var, GroundTerm, !Info) :-
- ml_gen_info_get_const_var_map(!.Info, ConstVarMap0),
- % We cannot call map.det_insert, because we do not (yet) clean up the
- % const_var_map at the start of later branches of a branched goal,
- % and thus when generating code for a later branch, we may come across
- % an entry left by an earlier branch. Using map.set instead throws away
- % such obsolete entries.
- map.set(ConstVarMap0, Var, GroundTerm, ConstVarMap),
- ml_gen_info_set_const_var_map(ConstVarMap, !Info).
-
-ml_gen_info_lookup_const_var(Info, Var, GroundTerm) :-
- ml_gen_info_get_const_var_map(Info, ConstVarMap),
- map.lookup(ConstVarMap, Var, GroundTerm).
-
-ml_gen_info_search_const_var(Info, Var, GroundTerm) :-
- ml_gen_info_get_const_var_map(Info, ConstVarMap),
- map.search(ConstVarMap, Var, GroundTerm).
-
-ml_gen_info_push_success_cont(SuccCont, !Info) :-
- ml_gen_info_get_success_cont_stack(!.Info, Stack0),
- stack.push(Stack0, SuccCont, Stack),
- ml_gen_info_set_success_cont_stack(Stack, !Info).
-
-ml_gen_info_pop_success_cont(!Info) :-
- ml_gen_info_get_success_cont_stack(!.Info, Stack0),
- stack.pop_det(Stack0, _SuccCont, Stack),
- ml_gen_info_set_success_cont_stack(Stack, !Info).
-
-ml_gen_info_current_success_cont(Info, SuccCont) :-
- ml_gen_info_get_success_cont_stack(Info, Stack),
- stack.top_det(Stack, SuccCont).
-
-ml_gen_info_set_var_lval(Var, Lval, !Info) :-
- ml_gen_info_get_var_lvals(!.Info, VarLvals0),
- map.set(VarLvals0, Var, Lval, VarLvals),
- ml_gen_info_set_var_lvals(VarLvals, !Info).
-
-ml_gen_info_add_closure_wrapper_defn(ClosureWrapperDefn, !Info) :-
- ml_gen_info_get_closure_wrapper_defns(!.Info, ClosureWrapperDefns0),
- ClosureWrapperDefns = [ClosureWrapperDefn | ClosureWrapperDefns0],
- ml_gen_info_set_closure_wrapper_defns(ClosureWrapperDefns, !Info).
-
-ml_gen_info_add_env_var_name(Name, !Info) :-
- ml_gen_info_get_env_var_names(!.Info, EnvVarNames0),
- set.insert(EnvVarNames0, Name, EnvVarNames),
- ml_gen_info_set_env_var_names(EnvVarNames, !Info).
-
-%-----------------------------------------------------------------------------%
-
-select_output_vars(ModuleInfo, HeadVars, HeadModes, VarTypes) = OutputVars :-
- (
- HeadVars = [],
- HeadModes = [],
- OutputVars = []
- ;
- HeadVars = [Var | Vars],
- HeadModes = [Mode | Modes],
- map.lookup(VarTypes, Var, VarType),
- (
- mode_to_arg_mode(ModuleInfo, Mode, VarType, top_out)
- ->
- OutputVars1 = select_output_vars(ModuleInfo, Vars, Modes,
- VarTypes),
- OutputVars = [Var | OutputVars1]
- ;
- OutputVars = select_output_vars(ModuleInfo, Vars, Modes, VarTypes)
- )
- ;
- HeadVars = [],
- HeadModes = [_ | _],
- unexpected(this_file, "select_output_vars: length mismatch")
- ;
- HeadVars = [_ | _],
- HeadModes = [],
- unexpected(this_file, "select_output_vars: length mismatch")
- ).
-
-%-----------------------------------------------------------------------------%
% This function returns the offset to add to the argument
% number of a closure arg to get its field number.
@@ -2837,55 +2024,6 @@
ModuleName = ModuleName0
).
-ml_gen_box_const_rvals(_, _, [], [], [], !GlobalData).
-ml_gen_box_const_rvals(_, _, [], [_ | _], _, !GlobalData) :-
- unexpected(this_file, "ml_gen_box_const_rvals: list length mismatch").
-ml_gen_box_const_rvals(_, _, [_ | _], [], _, !GlobalData) :-
- unexpected(this_file, "ml_gen_box_const_rvals: list length mismatch").
-ml_gen_box_const_rvals(ModuleInfo, Context, [Type | Types], [Rval | Rvals],
- [BoxedRval | BoxedRvals], !GlobalData) :-
- ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
- !GlobalData),
- ml_gen_box_const_rvals(ModuleInfo, Context, Types, Rvals, BoxedRvals,
- !GlobalData).
-
-ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
- !GlobalData) :-
- (
- ( Type = mercury_type(type_variable(_, _), _, _)
- ; Type = mlds_generic_type
- )
- ->
- BoxedRval = Rval
- ;
- % For the MLDS->C and MLDS->asm back-ends, we need to handle floats
- % specially, since boxed floats normally get heap allocated, whereas
- % for other types boxing is just a cast (casts are OK in static
- % initializers, but calls to malloc() are not).
- ( Type = mercury_type(builtin_type(builtin_type_float), _, _)
- ; Type = mlds_native_float_type
- ),
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_target(Globals, Target),
- ( Target = target_c
- ; Target = target_asm
- ; Target = target_x86_64
- )
- ->
- % Generate a local static constant for this float.
- module_info_get_name(ModuleInfo, ModuleName),
- MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- Initializer = init_obj(Rval),
- ml_gen_static_scalar_const_addr(MLDS_ModuleName, "float", Type,
- Initializer, Context, ConstAddrRval, !GlobalData),
-
- % Return as the boxed rval the address of that constant,
- % cast to mlds_generic_type.
- BoxedRval = ml_unop(cast(mlds_generic_type), ConstAddrRval)
- ;
- BoxedRval = ml_unop(box(Type), Rval)
- ).
-
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/ml_commit_gen.m
===================================================================
RCS file: compiler/ml_commit_gen.m
diff -N compiler/ml_commit_gen.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/ml_commit_gen.m 23 Sep 2009 16:32:35 -0000
@@ -0,0 +1,542 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ml_commit_gen.m.
+% Main author: fjh.
+%
+% This module handles code generation for commits.
+%
+% There's several different ways of handling commits:
+% - using catch/throw
+% - using setjmp/longjmp
+% - using GCC's __builtin_setjmp/__builtin_longjmp
+% - exiting nested functions via gotos to
+% their containing functions
+%
+% The MLDS data structure abstracts away these differences using the
+% `try_commit' and `do_commit' instructions. The comments below show
+% the MLDS try_commit/do_commit version first, but for clarity I've also
+% included sample code using each of the three different techniques.
+% This shows how the MLDS->target back-end can map mlds_commit_type,
+% do_commit and try_commit into target language constructs.
+%
+% Note that if we're using GCC's __builtin_longjmp(), then it is important
+% that the call to __builtin_longjmp() be put in its own function, to ensure
+% that it is not in the same function as the __builtin_setjmp(). The code
+% generation schema below does that automatically. We will need to be careful
+% with MLDS optimizations to ensure that we preserve that invariant, though.
+% (Alternatively, we could just call a function that calls __builtin_longjmp()
+% rather than calling it directly. But that would be a little less efficient.)
+%
+% If those methods turn out to be too inefficient, another alternative would be
+% to change the generated code so that after every function call, it would
+% check a flag, and if that flag was set, it would return. Then MR_DO_COMMIT
+% would just set the flag and return. The flag could be in a global
+% (or thread-local) variable, or it could be an additional value returned
+% from each function.
+%
+% model_non in semi context: (using try_commit/do_commit)
+% <succeeded = Goal>
+% ===>
+% MR_COMMIT_TYPE ref;
+% void success() {
+% MR_DO_COMMIT(ref);
+% }
+% MR_TRY_COMMIT(ref, {
+% <Goal && success()>
+% succeeded = MR_FALSE;
+% }, {
+% succeeded = MR_TRUE;
+% })
+%
+% model_non in semi context: (using catch/throw)
+% <succeeded = Goal>
+% ===>
+% void success() {
+% throw COMMIT();
+% }
+% try {
+% <Goal && success()>
+% succeeded = MR_FALSE;
+% } catch (COMMIT) {
+% succeeded = MR_TRUE;
+% }
+%
+% The above is using C++ syntax. Here COMMIT is an exception type, which
+% can be defined trivially (e.g. "class COMMIT {};"). Note that when using
+% catch/throw, we don't need the "ref" argument at all; the target language's
+% exception handling implementation keeps track of all the information needed
+% to unwind the stack.
+%
+% model_non in semi context: (using setjmp/longjmp)
+% <succeeded = Goal>
+% ===>
+% jmp_buf ref;
+% void success() {
+% longjmp(ref, 1);
+% }
+% if (setjmp(ref)) {
+% succeeded = MR_TRUE;
+% } else {
+% <Goal && success()>
+% succeeded = MR_FALSE;
+% }
+%
+% model_non in semi context: (using GNU C nested functions,
+% GNU C local labels, and exiting
+% the nested function by a goto
+% to a label in the containing function)
+% <succeeded = Goal>
+% ===>
+% __label__ commit;
+% void success() {
+% goto commit;
+% }
+% <Goal && success()>
+% succeeded = MR_FALSE;
+% goto commit_done;
+% commit:
+% succeeded = MR_TRUE;
+% commit_done:
+% ;
+%
+% model_non in det context: (using try_commit/do_commit)
+% <do Goal>
+% ===>
+% MR_COMMIT_TYPE ref;
+% void success() {
+% MR_DO_COMMIT(ref);
+% }
+% MR_TRY_COMMIT(ref, {
+% <Goal && success()>
+% }, {})
+%
+% model_non in det context (using GNU C nested functions,
+% GNU C local labels, and exiting
+% the nested function by a goto
+% to a label in the containing function)
+% <do Goal>
+% ===>
+% __label__ done;
+% void success() {
+% goto done;
+% }
+% <Goal && success()>
+% done: ;
+%
+% model_non in det context (using catch/throw):
+% <do Goal>
+% ===>
+% void success() {
+% throw COMMIT();
+% }
+% try {
+% <Goal && success()>
+% } catch (COMMIT) {}
+%
+% model_non in det context (using setjmp/longjmp):
+% <do Goal>
+% ===>
+% jmp_buf ref;
+% void success() {
+% longjmp(ref, 1);
+% }
+% if (setjmp(ref) == 0) {
+% <Goal && success()>
+% }
+%
+% Note that for all of these versions, we must hoist any static declarations
+% generated for <Goal> out to the top level; this is needed so that such
+% declarations remain in scope for any following goals.
+
+:- module ml_backend.ml_commit_gen.
+:- interface.
+
+:- import_module hlds.code_model.
+:- import_module hlds.hlds_goal.
+:- import_module ml_backend.ml_gen_info.
+:- import_module ml_backend.mlds.
+:- import_module parse_tree.prog_data.
+
+:- import_module list.
+
+ % Generate code for a commit.
+ %
+:- pred ml_gen_commit(hlds_goal::in, code_model::in, prog_context::in,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds.type_util.
+:- import_module libs.globals.
+:- import_module libs.options.
+:- import_module ml_backend.ml_accurate_gc.
+:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_code_util.
+
+:- import_module bool.
+:- import_module map.
+:- import_module maybe.
+:- import_module set.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ml_gen_commit(Goal, CodeModel, Context, Decls, Statements, !Info) :-
+ Goal = hlds_goal(_, GoalInfo),
+ GoalCodeModel = goal_info_get_code_model(GoalInfo),
+ GoalContext = goal_info_get_context(GoalInfo),
+
+ (
+ GoalCodeModel = model_non,
+ CodeModel = model_semi
+ ->
+
+ % model_non in semi context: (using try_commit/do_commit)
+ % <succeeded = Goal>
+ % ===>
+ % MR_bool succeeded;
+ % #ifdef NONDET_COPY_OUT
+ % <local var decls>
+ % #endif
+ % #ifdef PUT_COMMIT_IN_OWN_FUNC
+ % /*
+ % ** to avoid problems with setjmp() and non-volatile
+ % ** local variables, we need to put the call to
+ % ** setjmp() in its own nested function
+ % */
+ % void commit_func()
+ % {
+ % #endif
+ % MR_COMMIT_TYPE ref;
+ %
+ % void success() {
+ % MR_DO_COMMIT(ref);
+ % }
+ %
+ % MR_TRY_COMMIT(ref, {
+ % <Goal && success()>
+ % succeeded = MR_FALSE;
+ % }, {
+ % #ifdef NONDET_COPY_OUT
+ % <copy local vars to output args>
+ % #endif
+ % succeeded = MR_TRUE;
+ % })
+ % #ifdef PUT_COMMIT_IN_OWN_FUNC
+ %
+ % commit_func();
+ % #endif
+
+ ml_gen_maybe_make_locals_for_output_args(GoalInfo, LocalVarDecls,
+ CopyLocalsToOutputArgs, OrigVarLvalMap, !Info),
+
+ % Generate the `success()' function.
+ ml_gen_new_func_label(no, SuccessFuncLabel, SuccessFuncLabelRval,
+ !Info),
+ % push nesting level
+ MLDS_Context = mlds_make_context(Context),
+ ml_gen_info_new_aux_var_name("commit", CommitRef, !Info),
+ ml_gen_var_lval(!.Info, CommitRef, mlds_commit_type, CommitRefLval),
+ CommitRefDecl = ml_gen_commit_var_decl(MLDS_Context, CommitRef),
+ DoCommitStmt = ml_stmt_do_commit(ml_lval(CommitRefLval)),
+ DoCommitStatement = statement(DoCommitStmt, MLDS_Context),
+ % Pop nesting level.
+ ml_gen_nondet_label_func(!.Info, SuccessFuncLabel, Context,
+ DoCommitStatement, SuccessFunc),
+
+ ml_get_env_ptr(!.Info, EnvPtrRval),
+ SuccessCont = success_cont(SuccessFuncLabelRval, EnvPtrRval, [], []),
+ ml_gen_info_push_success_cont(SuccessCont, !Info),
+ ml_gen_goal(model_non, Goal, GoalDecls, GoalStatements, !Info),
+ % Hoist any static constant declarations for Goal out to the top level.
+ list.filter(ml_decl_is_static_const, GoalDecls,
+ GoalStaticDecls, GoalOtherDecls),
+ GoalStatement = ml_gen_block(GoalOtherDecls, GoalStatements,
+ GoalContext),
+ ml_gen_info_pop_success_cont(!Info),
+ ml_gen_set_success(!.Info, ml_const(mlconst_false), Context,
+ SetSuccessFalse),
+ ml_gen_set_success(!.Info, ml_const(mlconst_true), Context,
+ SetSuccessTrue),
+ TryCommitStmt = ml_stmt_try_commit(CommitRefLval,
+ ml_gen_block([], [GoalStatement, SetSuccessFalse], Context),
+ ml_gen_block([], CopyLocalsToOutputArgs ++ [SetSuccessTrue],
+ Context)
+ ),
+ TryCommitStatement = statement(TryCommitStmt, MLDS_Context),
+ CommitFuncLocalDecls = [CommitRefDecl, SuccessFunc | GoalStaticDecls],
+ maybe_put_commit_in_own_func(CommitFuncLocalDecls,
+ [TryCommitStatement], Context, CommitFuncDecls, Statements, !Info),
+ Decls = LocalVarDecls ++ CommitFuncDecls,
+
+ ml_gen_info_set_var_lvals(OrigVarLvalMap, !Info)
+ ;
+ GoalCodeModel = model_non,
+ CodeModel = model_det
+ ->
+ % model_non in det context: (using try_commit/do_commit)
+ % <do Goal>
+ % ===>
+ % #ifdef NONDET_COPY_OUT
+ % <local var decls>
+ % #endif
+ % #ifdef PUT_COMMIT_IN_NESTED_FUNC
+ % /*
+ % ** to avoid problems with setjmp() and non-volatile
+ % ** local variables, we need to put the call to
+ % ** setjmp() in its own nested functions
+ % */
+ % void commit_func()
+ % {
+ % #endif
+ % MR_COMMIT_TYPE ref;
+ % void success() {
+ % MR_DO_COMMIT(ref);
+ % }
+ % MR_TRY_COMMIT(ref, {
+ % <Goal && success()>
+ % }, {
+ % #ifdef NONDET_COPY_OUT
+ % <copy local vars to output args>
+ % #endif
+ % })
+ % #ifdef PUT_COMMIT_IN_NESTED_FUNC
+ %
+ % commit_func();
+ % #endif
+
+ ml_gen_maybe_make_locals_for_output_args(GoalInfo, LocalVarDecls,
+ CopyLocalsToOutputArgs, OrigVarLvalMap, !Info),
+
+ % Generate the `success()' function.
+ ml_gen_new_func_label(no, SuccessFuncLabel, SuccessFuncLabelRval,
+ !Info),
+ % push nesting level
+ MLDS_Context = mlds_make_context(Context),
+ ml_gen_info_new_aux_var_name("commit", CommitRef, !Info),
+ ml_gen_var_lval(!.Info, CommitRef, mlds_commit_type, CommitRefLval),
+ CommitRefDecl = ml_gen_commit_var_decl(MLDS_Context, CommitRef),
+ DoCommitStmt = ml_stmt_do_commit(ml_lval(CommitRefLval)),
+ DoCommitStatement = statement(DoCommitStmt, MLDS_Context),
+ % pop nesting level
+ ml_gen_nondet_label_func(!.Info, SuccessFuncLabel, Context,
+ DoCommitStatement, SuccessFunc),
+
+ ml_get_env_ptr(!.Info, EnvPtrRval),
+ SuccessCont = success_cont(SuccessFuncLabelRval, EnvPtrRval, [], []),
+ ml_gen_info_push_success_cont(SuccessCont, !Info),
+ ml_gen_goal(model_non, Goal, GoalDecls, GoalStatements, !Info),
+ % Hoist any static constant declarations for Goal out to the top level.
+ list.filter(ml_decl_is_static_const, GoalDecls,
+ GoalStaticDecls, GoalOtherDecls),
+ GoalStatement = ml_gen_block(GoalOtherDecls, GoalStatements,
+ GoalContext),
+ ml_gen_info_pop_success_cont(!Info),
+
+ TryCommitStmt = ml_stmt_try_commit(CommitRefLval, GoalStatement,
+ ml_gen_block([], CopyLocalsToOutputArgs, Context)),
+ TryCommitStatement = statement(TryCommitStmt, MLDS_Context),
+ CommitFuncLocalDecls = [CommitRefDecl, SuccessFunc | GoalStaticDecls],
+ maybe_put_commit_in_own_func(CommitFuncLocalDecls,
+ [TryCommitStatement], Context, CommitFuncDecls, Statements, !Info),
+ Decls = LocalVarDecls ++ CommitFuncDecls,
+ ml_gen_info_set_var_lvals(OrigVarLvalMap, !Info)
+ ;
+ % No commit required.
+ ml_gen_goal(CodeModel, Goal, Decls, Statements, !Info)
+ ).
+
+ % maybe_put_commit_in_own_func(Defns0, Stmts0, Defns, Stmts):
+ %
+ % If the --put-commit-in-own-func option is set, put the commit in its
+ % own function. This is needed for the high-level C back-end, to handle
+ % problems with setjmp()/longjmp() clobbering non-volatile local variables.
+ %
+ % Detailed explanation:
+ %
+ % For the high-level C back-end, we implement commits using
+ % setjmp()/longjmp(). Unfortunately for us, ANSI/ISO C says that longjmp()
+ % is allowed to clobber the values of any non-volatile local variables
+ % in the function that called setjmp() which have been modified between
+ % the setjmp() and the longjmp().
+ %
+ % To avoid this, whenever we generate a commit, we put it in its own
+ % nested function, with the local variables (e.g. `succeeded', plus any
+ % outputs from the goal that we're committing over) remaining in the
+ % containing function. This ensures that none of the variables which
+ % get modified between the setjmp() and the longjmp() and which get
+ % referenced after the longjmp() are local variables in the function
+ % containing the setjmp().
+ %
+ % [The obvious alternative of declaring the local variables in the function
+ % containing setjmp() as `volatile' doesn't work, since the assignments
+ % to those output variables may be deep in some function called indirectly
+ % from the goal that we're committing across, and assigning to a
+ % volatile-qualified variable via a non-volatile pointer is undefined
+ % behaviour. The only way to make it work would be to be to declare
+ % *every* output argument that we pass by reference as `volatile T *'.
+ % But that would impose distributed fat and would make interoperability
+ % difficult.]
+ %
+:- pred maybe_put_commit_in_own_func(list(mlds_defn)::in, list(statement)::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+maybe_put_commit_in_own_func(CommitFuncLocalDecls, TryCommitStatements,
+ Context, Decls, Statements, !Info) :-
+ ml_gen_info_put_commit_in_own_func(!.Info, PutCommitInOwnFunc),
+ (
+ PutCommitInOwnFunc = yes,
+
+ % Generate the `void commit_func() { ... }' wrapper
+ % around the main body that we generated above
+ ml_gen_new_func_label(no, CommitFuncLabel, CommitFuncLabelRval, !Info),
+ % push nesting level
+ CommitFuncBody = ml_gen_block(CommitFuncLocalDecls,
+ TryCommitStatements, Context),
+ % pop nesting level
+ ml_gen_nondet_label_func(!.Info, CommitFuncLabel, Context,
+ CommitFuncBody, CommitFunc),
+
+ % Generate the call to `commit_func();'
+ ml_gen_info_use_gcc_nested_functions(!.Info, UseNestedFuncs),
+ (
+ UseNestedFuncs = yes,
+ ArgRvals = [],
+ ArgTypes = []
+ ;
+ UseNestedFuncs = no,
+ ml_get_env_ptr(!.Info, EnvPtrRval),
+ ArgRvals = [EnvPtrRval],
+ ArgTypes = [mlds_generic_env_ptr_type]
+ ),
+ RetTypes = [],
+ Signature = mlds_func_signature(ArgTypes, RetTypes),
+ CallKind = ordinary_call,
+ CallStmt = ml_stmt_call(Signature, CommitFuncLabelRval, no, ArgRvals,
+ [], CallKind),
+ CallStatement = statement(CallStmt, mlds_make_context(Context)),
+ % Package it all up.
+ Statements = [CallStatement],
+ Decls = [CommitFunc]
+ ;
+ PutCommitInOwnFunc = no,
+ Statements = TryCommitStatements,
+ Decls = CommitFuncLocalDecls
+ ).
+
+ % In commits, you have model_non code called from a model_det or model_semi
+ % context. With --nondet-copy-out, when generating code for commits,
+ % if the context is a model_det or model_semi procedure with output
+ % arguments passed by reference, then we need to introduce local variables
+ % corresponding to those output arguments, and at the end of the commit
+ % we'll copy the local variables into the output arguments.
+ %
+:- pred ml_gen_maybe_make_locals_for_output_args(hlds_goal_info::in,
+ list(mlds_defn)::out, list(statement)::out,
+ map(prog_var, mlds_lval)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_maybe_make_locals_for_output_args(GoalInfo, LocalVarDecls,
+ CopyLocalsToOutputArgs, OrigVarLvalMap, !Info) :-
+ ml_gen_info_get_var_lvals(!.Info, OrigVarLvalMap),
+ ml_gen_info_get_globals(!.Info, Globals),
+ globals.lookup_bool_option(Globals, nondet_copy_out, NondetCopyOut),
+ (
+ NondetCopyOut = yes,
+ Context = goal_info_get_context(GoalInfo),
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ ml_gen_info_get_byref_output_vars(!.Info, ByRefOutputVars),
+ VarsToCopy = set.intersect(set.list_to_set(ByRefOutputVars),
+ NonLocals),
+ ml_gen_make_locals_for_output_args(set.to_sorted_list(VarsToCopy),
+ Context, LocalVarDecls, CopyLocalsToOutputArgs, !Info)
+ ;
+ NondetCopyOut = no,
+ LocalVarDecls = [],
+ CopyLocalsToOutputArgs = []
+ ).
+
+:- pred ml_gen_make_locals_for_output_args(list(prog_var)::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_make_locals_for_output_args([], _, [], [], !Info).
+ml_gen_make_locals_for_output_args([Var | Vars], Context,
+ LocalDefns, Assigns, !Info) :-
+ ml_gen_make_locals_for_output_args(Vars, Context, LocalDefns0, Assigns0,
+ !Info),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ml_variable_type(!.Info, Var, Type),
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
+ LocalDefns = LocalDefns0,
+ Assigns = Assigns0
+ ;
+ IsDummy = is_not_dummy_type,
+ ml_gen_make_local_for_output_arg(Var, Type, Context,
+ LocalDefn, Assign, !Info),
+ LocalDefns = [LocalDefn | LocalDefns0],
+ Assigns = [Assign | Assigns0]
+ ).
+
+:- pred ml_gen_make_local_for_output_arg(prog_var::in, mer_type::in,
+ prog_context::in, mlds_defn::out, statement::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_make_local_for_output_arg(OutputVar, Type, Context,
+ LocalVarDefn, Assign, !Info) :-
+ % Look up the name of the output variable.
+ ml_gen_info_get_varset(!.Info, VarSet),
+ OutputVarName = ml_gen_var_name(VarSet, OutputVar),
+
+ % Generate a declaration for a corresponding local variable.
+ OutputVarName = mlds_var_name(OutputVarNameStr, MaybeNum),
+ LocalVarName = mlds_var_name(
+ string.append("local_", OutputVarNameStr), MaybeNum),
+ ml_gen_type(!.Info, Type, MLDS_Type),
+ ml_gen_gc_statement(LocalVarName, Type, Context, GCStatement,
+ !Info),
+ LocalVarDefn = ml_gen_mlds_var_decl(mlds_data_var(LocalVarName), MLDS_Type,
+ GCStatement, mlds_make_context(Context)),
+
+ % Generate code to assign from the local var to the output var.
+ ml_gen_var(!.Info, OutputVar, OutputVarLval),
+ ml_gen_var_lval(!.Info, LocalVarName, MLDS_Type, LocalVarLval),
+ Assign = ml_gen_assign(OutputVarLval, ml_lval(LocalVarLval), Context),
+
+ % Update the lval for this variable so that any references to it inside
+ % the commit refer to the local variable rather than to the output
+ % argument. (Note that we reset all the var lvals at the end of the
+ % commit.)
+ ml_gen_info_set_var_lval(OutputVar, LocalVarLval, !Info).
+
+ % Generate the declaration for the `commit' variable.
+ %
+:- func ml_gen_commit_var_decl(mlds_context, mlds_var_name) = mlds_defn.
+
+ml_gen_commit_var_decl(Context, VarName) =
+ ml_gen_mlds_var_decl(mlds_data_var(VarName), mlds_commit_type, gc_no_stmt,
+ Context).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "ml_commit_gen.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module ml_commit_gen.
+%-----------------------------------------------------------------------------%
Index: compiler/ml_foreign_proc_gen.m
===================================================================
RCS file: compiler/ml_foreign_proc_gen.m
diff -N compiler/ml_foreign_proc_gen.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/ml_foreign_proc_gen.m 23 Sep 2009 16:34:06 -0000
@@ -0,0 +1,1351 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ml_foreign_proc.m.
+% Main author: fjh.
+%
+
+:- module ml_backend.ml_foreign_proc_gen.
+:- interface.
+
+:- import_module hlds.code_model.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_pred.
+:- import_module ml_backend.ml_gen_info.
+:- import_module ml_backend.mlds.
+:- import_module parse_tree.prog_data.
+
+:- import_module list.
+:- import_module maybe.
+
+:- pred ml_gen_trace_runtime_cond(trace_expr(trace_runtime)::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+:- pred ml_gen_nondet_pragma_foreign_proc(code_model::in,
+ pragma_foreign_proc_attributes::in,
+ pred_id::in, proc_id::in, list(foreign_arg)::in,
+ prog_context::in, string::in, maybe(prog_context)::in, string::in,
+ maybe(prog_context)::in, string::in, maybe(prog_context)::in,
+ string::in, maybe(prog_context)::in,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+:- pred ml_gen_ordinary_pragma_foreign_proc(code_model::in,
+ pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
+ list(foreign_arg)::in, list(foreign_arg)::in, string::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module backend_libs.builtin_ops.
+:- import_module backend_libs.c_util.
+:- import_module backend_libs.foreign. % XXX needed for pragma foreign code
+:- import_module check_hlds.mode_util.
+:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_module.
+:- import_module libs.compiler_util.
+:- import_module libs.globals.
+:- import_module libs.options.
+:- import_module ml_backend.ml_code_util.
+
+:- import_module bool.
+:- import_module map.
+:- import_module pair.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ml_gen_trace_runtime_cond(TraceRuntimeCond, Context, Decls, Statements,
+ !Info) :-
+ Decls = [],
+ MLDSContext = mlds_make_context(Context),
+ ml_success_lval(!.Info, SuccessLval),
+ ml_generate_runtime_cond_code(TraceRuntimeCond, CondRval, !Info),
+ Statement = statement(ml_stmt_atomic(assign(SuccessLval, CondRval)),
+ MLDSContext),
+ Statements = [Statement].
+
+:- pred ml_generate_runtime_cond_code(trace_expr(trace_runtime)::in,
+ mlds_rval::out, ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_generate_runtime_cond_code(Expr, CondRval, !Info) :-
+ (
+ Expr = trace_base(trace_envvar(EnvVar)),
+ ml_gen_info_add_env_var_name(EnvVar, !Info),
+ EnvVarRval = ml_lval(ml_global_var_ref(env_var_ref(EnvVar))),
+ ZeroRval = ml_const(mlconst_int(0)),
+ CondRval = ml_binop(ne, EnvVarRval, ZeroRval)
+ ;
+ Expr = trace_not(ExprA),
+ ml_generate_runtime_cond_code(ExprA, RvalA, !Info),
+ CondRval = ml_unop(std_unop(logical_not), RvalA)
+ ;
+ Expr = trace_op(TraceOp, ExprA, ExprB),
+ ml_generate_runtime_cond_code(ExprA, RvalA, !Info),
+ ml_generate_runtime_cond_code(ExprB, RvalB, !Info),
+ (
+ TraceOp = trace_or,
+ Op = logical_or
+ ;
+ TraceOp = trace_and,
+ Op = logical_and
+ ),
+ CondRval = ml_binop(Op, RvalA, RvalB)
+ ).
+
+ % For model_non pragma c_code,
+ % we generate code of the following form:
+ %
+ % #define MR_PROC_LABEL <procedure name>
+ % <declaration of locals needed for boxing/unboxing>
+ % {
+ % <declaration of one local variable for each arg>
+ % struct {
+ % <user's local_vars decls>
+ % } MR_locals;
+ % MR_bool MR_done = MR_FALSE;
+ % MR_bool MR_succeeded = MR_FALSE;
+ %
+ % #define FAIL (MR_done = MR_TRUE)
+ % #define SUCCEED (MR_succeeded = MR_TRUE)
+ % #define SUCCEED_LAST (MR_succeeded = MR_TRUE, \
+ % MR_done = MR_TRUE)
+ % #define LOCALS (&MR_locals)
+ %
+ % <assign input args>
+ % <obtain global lock>
+ % <user's first_code C code>
+ % while (true) {
+ % <user's shared_code C code>
+ % <release global lock>
+ % if (MR_succeeded) {
+ % <assign output args>
+ % <boxing/unboxing of outputs>
+ % CONT();
+ % }
+ % if (MR_done) break;
+ % MR_succeeded = MR_FALSE;
+ % <obtain global lock>
+ % <user's later_code C code>
+ % }
+ %
+ % #undef FAIL
+ % #undef SUCCEED
+ % #undef SUCCEED_LAST
+ % #undef LOCALS
+ % }
+ % #undef MR_PROC_LABEL
+ %
+ % We insert a #define for MR_PROC_LABEL, so that the C code in the Mercury
+ % standard library that allocates memory manually can use MR_PROC_LABEL
+ % as the procname argument to incr_hp_msg(), for memory profiling.
+ % Hard-coding the procname argument in the C code would be wrong,
+ % since it wouldn't handle the case where the original pragma foreign_proc
+ % procedure gets inlined and optimized away. Of course we also need to
+ % #undef it afterwards.
+ %
+ml_gen_nondet_pragma_foreign_proc(CodeModel, Attributes, PredId, _ProcId,
+ Args, Context, LocalVarsDecls, LocalVarsContext,
+ FirstCode, FirstContext, LaterCode, LaterContext,
+ SharedCode, SharedContext, Decls, Statements, !Info) :-
+ Lang = get_foreign_language(Attributes),
+ ( Lang = lang_csharp ->
+ sorry(this_file, "nondet pragma foreign_proc for C#")
+ ;
+ true
+ ),
+
+ % Generate <declaration of one local variable for each arg>
+ ml_gen_pragma_c_decls(!.Info, Lang, Args, ArgDeclsList),
+
+ % Generate definitions of the FAIL, SUCCEED, SUCCEED_LAST,
+ % and LOCALS macros.
+
+ string.append_list([
+" #define FAIL (MR_done = MR_TRUE)\n",
+" #define SUCCEED (MR_succeeded = MR_TRUE)\n",
+" #define SUCCEED_LAST (MR_succeeded = MR_TRUE, MR_done = MR_TRUE)\n",
+" #define LOCALS (&MR_locals)\n"
+ ], HashDefines),
+ string.append_list([
+ " #undef FAIL\n",
+ " #undef SUCCEED\n",
+ " #undef SUCCEED_LAST\n",
+ " #undef LOCALS\n"
+ ], HashUndefs),
+
+ % Generate code to set the values of the input variables.
+ ml_gen_pragma_c_java_input_arg_list(Lang, Args, AssignInputsList, !Info),
+
+ % Generate code to assign the values of the output variables.
+ ml_gen_pragma_c_output_arg_list(Args, Context,
+ AssignOutputsList, ConvDecls, ConvStatements, !Info),
+
+ % Generate code fragments to obtain and release the global lock.
+ ThreadSafe = get_thread_safe(Attributes),
+ ml_gen_obtain_release_global_lock(!.Info, ThreadSafe, PredId,
+ ObtainLock, ReleaseLock),
+
+ % Generate the MR_PROC_LABEL #define.
+ ml_gen_hash_define_mr_proc_label(!.Info, HashDefine),
+
+ % Put it all together.
+ Starting_C_Code = list.condense([
+ [raw_target_code("{\n", [])],
+ HashDefine,
+ ArgDeclsList,
+ [raw_target_code("\tstruct {\n", []),
+ user_target_code(LocalVarsDecls, LocalVarsContext, []),
+ raw_target_code("\n", []),
+ raw_target_code("\t} MR_locals;\n", []),
+ raw_target_code("\tMR_bool MR_succeeded = MR_FALSE;\n", []),
+ raw_target_code("\tMR_bool MR_done = MR_FALSE;\n", []),
+ raw_target_code("\n", []),
+ raw_target_code(HashDefines, []),
+ raw_target_code("\n", [])],
+ AssignInputsList,
+ [raw_target_code(ObtainLock, []),
+ raw_target_code("\t{\n", []),
+ user_target_code(FirstCode, FirstContext, []),
+ raw_target_code("\n\t;}\n", []),
+ raw_target_code("\twhile (1) {\n", []),
+ raw_target_code("\t\t{\n", []),
+ user_target_code(SharedCode, SharedContext, []),
+ raw_target_code("\n\t\t;}\n", []),
+ raw_target_code("#undef MR_PROC_LABEL\n", []),
+ raw_target_code(ReleaseLock, []),
+ raw_target_code("\t\tif (MR_succeeded) {\n", [])],
+ AssignOutputsList
+ ]),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ (
+ CodeModel = model_non,
+
+ (
+ Target = target_il,
+ % For IL code, we can't call continutations because there is no
+ % syntax for calling managed function pointers in C#. Instead,
+ % we have to call back into IL and make the continuation call
+ % in IL. This is called an "indirect" success continuation call.
+ ml_gen_call_current_success_cont_indirectly(Context, CallCont,
+ !Info)
+ ;
+ ( Target = target_c
+ ; Target = target_java
+ ; Target = target_asm
+ ),
+ ml_gen_call_current_success_cont(Context, CallCont, !Info)
+ ;
+ Target = target_x86_64,
+ unexpected(this_file,
+ "target x86_64 with --high-level-code")
+ ;
+ Target = target_erlang,
+ unexpected(this_file,
+ "ml_gen_nondet_pragma_foreign_proc: target erlang")
+ )
+ ;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
+ unexpected(this_file,
+ "ml_gen_nondet_pragma_foreign_proc: unexpected code model")
+ ),
+ Ending_C_Code = [
+ raw_target_code("\t\t}\n", []),
+ raw_target_code("\t\tif (MR_done) break;\n", []),
+ raw_target_code("\tMR_succeeded = MR_FALSE;\n", []),
+ raw_target_code(ObtainLock, []),
+ raw_target_code("\t\t{\n", []),
+ user_target_code(LaterCode, LaterContext, []),
+ raw_target_code("\n\t\t;}\n", []),
+ raw_target_code("\t}\n", []),
+ raw_target_code("\n", []),
+ raw_target_code(HashUndefs, []),
+ raw_target_code("}\n", [])
+ ],
+ Starting_C_Code_Stmt = inline_target_code(ml_target_c, Starting_C_Code),
+ Starting_C_Code_Statement = statement(
+ ml_stmt_atomic(Starting_C_Code_Stmt), mlds_make_context(Context)),
+ Ending_C_Code_Stmt = inline_target_code(ml_target_c, Ending_C_Code),
+ Ending_C_Code_Statement = statement(
+ ml_stmt_atomic(Ending_C_Code_Stmt), mlds_make_context(Context)),
+ Statements =
+ [Starting_C_Code_Statement | ConvStatements] ++
+ [CallCont, Ending_C_Code_Statement],
+ Decls = ConvDecls.
+
+ml_gen_ordinary_pragma_foreign_proc(CodeModel, Attributes, PredId, ProcId,
+ Args, ExtraArgs, Foreign_Code, Context, Decls, Statements, !Info) :-
+ Lang = get_foreign_language(Attributes),
+ (
+ CodeModel = model_det,
+ OrdinaryKind = kind_det
+ ;
+ CodeModel = model_semi,
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
+ _PredInfo, ProcInfo),
+ proc_info_interface_determinism(ProcInfo, Detism),
+ determinism_components(Detism, _, MaxSoln),
+ (
+ MaxSoln = at_most_zero,
+ OrdinaryKind = kind_failure
+ ;
+ ( MaxSoln = at_most_one
+ ; MaxSoln = at_most_many
+ ; MaxSoln = at_most_many_cc
+ ),
+ OrdinaryKind = kind_semi
+ )
+ ;
+ CodeModel = model_non,
+ OrdinaryDespiteDetism = get_ordinary_despite_detism(Attributes),
+ (
+ OrdinaryDespiteDetism = no,
+ unexpected(this_file,
+ "ml_gen_ordinary_pragma_foreign_proc: unexpected code model")
+ ;
+ OrdinaryDespiteDetism = yes,
+ OrdinaryKind = kind_semi
+ )
+ ),
+ (
+ Lang = lang_c,
+ ml_gen_ordinary_pragma_c_proc(OrdinaryKind, Attributes,
+ PredId, ProcId, Args, ExtraArgs,
+ Foreign_Code, Context, Decls, Statements, !Info)
+ ;
+ Lang = lang_csharp,
+ ml_gen_ordinary_pragma_managed_proc(OrdinaryKind, Attributes,
+ PredId, ProcId, Args, ExtraArgs,
+ Foreign_Code, Context, Decls, Statements, !Info)
+ ;
+ Lang = lang_il,
+ % XXX should pass OrdinaryKind
+ ml_gen_ordinary_pragma_il_proc(CodeModel, Attributes,
+ PredId, ProcId, Args, ExtraArgs,
+ Foreign_Code, Context, Decls, Statements, !Info)
+ ;
+ Lang = lang_java,
+ % XXX should pass OrdinaryKind
+ ml_gen_ordinary_pragma_java_proc(CodeModel, Attributes,
+ PredId, ProcId, Args, ExtraArgs,
+ Foreign_Code, Context, Decls, Statements, !Info)
+ ;
+ Lang = lang_erlang,
+ unexpected(this_file,
+ "ml_gen_ordinary_pragma_foreign_proc: unexpected language Erlang")
+ ).
+
+:- pred ml_gen_ordinary_pragma_java_proc(code_model::in,
+ pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
+ list(foreign_arg)::in, list(foreign_arg)::in, string::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_ordinary_pragma_java_proc(_CodeModel, Attributes, PredId, _ProcId,
+ Args, ExtraArgs, JavaCode, Context, Decls, Statements, !Info) :-
+ Lang = get_foreign_language(Attributes),
+
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_markers(PredInfo, Markers),
+ ( check_marker(Markers, marker_mutable_access_pred) ->
+ MutableSpecial = mutable_special_case
+ ;
+ MutableSpecial = not_mutable_special_case
+ ),
+
+ % Generate <declaration of one local variable for each arg>
+ ml_gen_pragma_java_decls(!.Info, MutableSpecial, Args, ArgDeclsList),
+ expect(unify(ExtraArgs, []), this_file,
+ "ml_gen_ordinary_pragma_java_proc: extra args"),
+
+ % Generate code to set the values of the input variables.
+ ml_gen_pragma_c_java_input_arg_list(Lang, Args, AssignInputsList, !Info),
+
+ % Generate MLDS statements to assign the values of the output variables.
+ ml_gen_pragma_java_output_arg_list(MutableSpecial, Args, Context,
+ AssignOutputsList, ConvDecls, ConvStatements, !Info),
+
+ % Put it all together
+ % XXX FIXME need to handle model_semi code here,
+ % i.e. provide some equivalent to SUCCESS_INDICATOR.
+ Java_Code = list.condense([
+ ArgDeclsList,
+ AssignInputsList,
+ [user_target_code(JavaCode, yes(Context), [])]
+ ]),
+ Java_Code_Stmt = inline_target_code(ml_target_java, Java_Code),
+ Java_Code_Statement = statement(
+ ml_stmt_atomic(Java_Code_Stmt),
+ mlds_make_context(Context)),
+ Statements = [Java_Code_Statement | AssignOutputsList] ++ ConvStatements,
+ Decls = ConvDecls.
+
+:- type ordinary_pragma_kind
+ ---> kind_det
+ ; kind_semi
+ ; kind_failure.
+
+ % For ordinary (not model_non) pragma foreign_code in C#,
+ % we generate a call to an out-of-line procedure that contains
+ % the user's code.
+ %
+:- pred ml_gen_ordinary_pragma_managed_proc(ordinary_pragma_kind::in,
+ pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
+ list(foreign_arg)::in, list(foreign_arg)::in, string::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_ordinary_pragma_managed_proc(OrdinaryKind, Attributes, _PredId, _ProcId,
+ Args, ExtraArgs, ForeignCode, Context, Decls, Statements, !Info) :-
+ ml_gen_outline_args(Args, OutlineArgs, !Info),
+ expect(unify(ExtraArgs, []), this_file,
+ "ml_gen_ordinary_pragma_managed_proc: extra args"),
+
+ ForeignLang = get_foreign_language(Attributes),
+ MLDSContext = mlds_make_context(Context),
+ ml_gen_info_get_value_output_vars(!.Info, OutputVars),
+ ml_gen_var_list(!.Info, OutputVars, OutputVarLvals),
+ OutlineStmt = outline_foreign_proc(ForeignLang, OutlineArgs,
+ OutputVarLvals, ForeignCode),
+
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDSModuleName = mercury_module_name_to_mlds(ModuleName),
+
+ ml_success_lval(!.Info, SucceededLval),
+ (
+ OrdinaryKind = kind_det,
+ SuccessVarLocals = [],
+ SuccessIndicatorStatements = []
+ ;
+ OrdinaryKind = kind_semi,
+ % If the code is semidet, we should copy SUCCESS_INDICATOR
+ % out into "success".
+ SuccessIndicatorVarName = mlds_var_name("SUCCESS_INDICATOR", no),
+ SuccessIndicatorDecl = ml_gen_mlds_var_decl(
+ mlds_data_var(SuccessIndicatorVarName),
+ mlds_native_bool_type,
+ gc_no_stmt, MLDSContext),
+ SuccessIndicatorLval = ml_var(qual(MLDSModuleName, module_qual,
+ SuccessIndicatorVarName), mlds_native_bool_type),
+ SuccessIndicatorStatement = ml_gen_assign(SucceededLval,
+ ml_lval(SuccessIndicatorLval), Context),
+ SuccessVarLocals = [SuccessIndicatorDecl],
+ SuccessIndicatorStatements = [SuccessIndicatorStatement]
+ ;
+ OrdinaryKind = kind_failure,
+ unexpected(this_file,
+ "ml_gen_ordinary_pragma_managed_proc: " ++
+ "kind_failure not yet implemented")
+ ),
+
+ OutlineStatement = statement(ml_stmt_atomic(OutlineStmt), MLDSContext),
+ Statements = [OutlineStatement | SuccessIndicatorStatements],
+ Decls = SuccessVarLocals.
+
+:- pred ml_gen_outline_args(list(foreign_arg)::in, list(outline_arg)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_outline_args([], [], !Info).
+ml_gen_outline_args([Arg | Args], [OutlineArg | OutlineArgs], !Info) :-
+ Arg = foreign_arg(Var, MaybeVarMode, OrigType, BoxPolicy),
+ ml_gen_outline_args(Args, OutlineArgs, !Info),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ml_gen_var(!.Info, Var, VarLval),
+ (
+ BoxPolicy = native_if_possible,
+ ml_gen_type(!.Info, OrigType, MldsType)
+ ;
+ BoxPolicy = always_boxed,
+ MldsType = mlds_generic_type
+ ),
+ (
+ MaybeVarMode = yes(ArgName - Mode),
+ check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
+ not var_is_singleton(ArgName)
+ ->
+ mode_to_arg_mode(ModuleInfo, Mode, OrigType, ArgMode),
+ (
+ ArgMode = top_in,
+ OutlineArg = ola_in(MldsType, ArgName, ml_lval(VarLval))
+ ;
+ ArgMode = top_out,
+ OutlineArg = ola_out(MldsType, ArgName, VarLval)
+ ;
+ ArgMode = top_unused,
+ OutlineArg = ola_unused
+ )
+ ;
+ OutlineArg = ola_unused
+ ).
+
+:- pred ml_gen_ordinary_pragma_il_proc(code_model::in,
+ pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
+ list(foreign_arg)::in, list(foreign_arg)::in, string::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_ordinary_pragma_il_proc(_CodeModel, Attributes, PredId, ProcId,
+ Args, ExtraArgs, ForeignCode, Context, Decls, Statements, !Info) :-
+ expect(unify(ExtraArgs, []), this_file,
+ "ml_gen_ordinary_pragma_managed_proc: extra args"),
+
+ % XXX FIXME need to handle model_semi code here,
+ % i.e. provide some equivalent to SUCCESS_INDICATOR.
+
+ % XXX FIXME do we handle top_unused mode correctly?
+
+ MLDSContext = mlds_make_context(Context),
+
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
+ _PredInfo, ProcInfo),
+ proc_info_get_varset(ProcInfo, VarSet),
+% proc_info_get_vartypes(ProcInfo, VarTypes),
+ % note that for headvars we must use the types from
+ % the procedure interface, not from the procedure body
+ ml_gen_info_get_byref_output_vars(!.Info, ByRefOutputVars),
+ ml_gen_info_get_value_output_vars(!.Info, CopiedOutputVars),
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDSModuleName = mercury_module_name_to_mlds(ModuleName),
+
+ % XXX in the code to marshall parameters, fjh says:
+ % We need to handle the case where the types in the procedure interface
+ % are polymorphic, but the types of the vars in the `foreign_proc' HLDS
+ % goal are concrete instances of those types, which can happen when the
+ % procedure is inlined or specialized. The assignment that you
+ % generate here with ml_gen_assign won't be type-correct. In general
+ % you may need to box/unbox the arguments.
+
+ build_arg_map(Args, map.init, ArgMap),
+
+ % Generate statements to assign by-ref output arguments.
+ list.filter_map(ml_gen_pragma_il_proc_assign_output(ModuleInfo,
+ MLDSModuleName, ArgMap, VarSet, Context, yes),
+ ByRefOutputVars, ByRefAssignStatements),
+
+ % Generate statements to assign copied output arguments.
+ list.filter_map(ml_gen_pragma_il_proc_assign_output(ModuleInfo,
+ MLDSModuleName, ArgMap, VarSet, Context, no),
+ CopiedOutputVars, CopiedOutputStatements),
+
+ ArgVars = list.map(foreign_arg_var, Args),
+ % Generate declarations for all the variables, and initializers for
+ % input variables.
+ list.map(
+ ml_gen_pragma_il_proc_var_decl_defn(ModuleInfo, MLDSModuleName,
+ ArgMap, VarSet, MLDSContext, ByRefOutputVars, CopiedOutputVars),
+ ArgVars, VarLocals),
+
+ OutlineStmt = inline_target_code(ml_target_il, [
+ user_target_code(ForeignCode, yes(Context),
+ get_target_code_attributes(lang_il,
+ get_extra_attributes(Attributes)))
+ ]),
+
+ ILCodeFragment = statement(ml_stmt_atomic(OutlineStmt), MLDSContext),
+ BlockStatements = [ILCodeFragment | ByRefAssignStatements] ++
+ CopiedOutputStatements,
+ BlockStatement = statement(ml_stmt_block(VarLocals, BlockStatements),
+ mlds_make_context(Context)),
+ Statements = [BlockStatement],
+ Decls = [].
+
+:- pred build_arg_map(list(foreign_arg)::in, map(prog_var, foreign_arg)::in,
+ map(prog_var, foreign_arg)::out) is det.
+
+build_arg_map([], !ArgMap).
+build_arg_map([ForeignArg | ForeignArgs], !ArgMap) :-
+ ForeignArg = foreign_arg(Var, _, _, _),
+ map.det_insert(!.ArgMap, Var, ForeignArg, !:ArgMap),
+ build_arg_map(ForeignArgs, !ArgMap).
+
+:- pred ml_gen_pragma_il_proc_assign_output(module_info::in,
+ mlds_module_name::in, map(prog_var, foreign_arg)::in, prog_varset::in,
+ prog_context::in, bool::in, prog_var::in, statement::out)
+ is semidet.
+
+ml_gen_pragma_il_proc_assign_output(ModuleInfo, MLDSModuleName, ArgMap,
+ VarSet, Context, IsByRef, Var, Statement) :-
+ map.lookup(ArgMap, Var, ForeignArg),
+ ForeignArg = foreign_arg(_, MaybeNameMode, Type, BoxPolicy),
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type,
+ (
+ BoxPolicy = always_boxed,
+ MLDSType = mlds_generic_type
+ ;
+ BoxPolicy = native_if_possible,
+ MLDSType = mercury_type_to_mlds_type(ModuleInfo, Type)
+ ),
+
+ VarName = ml_gen_var_name(VarSet, Var),
+ QualVarName = qual(MLDSModuleName, module_qual, VarName),
+ (
+ IsByRef = yes,
+ OutputVarLval = ml_mem_ref(ml_lval(ml_var(QualVarName, MLDSType)),
+ MLDSType)
+ ;
+ IsByRef = no,
+ OutputVarLval = ml_var(QualVarName, MLDSType)
+ ),
+
+ MaybeNameMode = yes(UserVarNameString - _),
+ NonMangledVarName = mlds_var_name(UserVarNameString, no),
+ QualLocalVarName= qual(MLDSModuleName, module_qual, NonMangledVarName),
+ LocalVarLval = ml_var(QualLocalVarName, MLDSType),
+
+ Statement = ml_gen_assign(OutputVarLval, ml_lval(LocalVarLval), Context).
+
+:- pred ml_gen_pragma_il_proc_var_decl_defn(module_info::in,
+ mlds_module_name::in, map(prog_var, foreign_arg)::in, prog_varset::in,
+ mlds_context::in, list(prog_var)::in, list(prog_var)::in,
+ prog_var::in, mlds_defn::out) is det.
+
+ml_gen_pragma_il_proc_var_decl_defn(ModuleInfo, MLDSModuleName, ArgMap, VarSet,
+ MLDSContext, ByRefOutputVars, CopiedOutputVars, Var, Defn) :-
+ map.lookup(ArgMap, Var, ForeignArg),
+ ForeignArg = foreign_arg(_, MaybeNameMode, Type, BoxPolicy),
+ VarName = ml_gen_var_name(VarSet, Var),
+ (
+ MaybeNameMode = yes(UserVarNameString - _),
+ NonMangledVarName = mlds_var_name(UserVarNameString, no)
+ ;
+ MaybeNameMode = no,
+ sorry(this_file, "no variable name for var")
+ ),
+ (
+ BoxPolicy = always_boxed,
+ MLDSType0 = mlds_generic_type
+ ;
+ BoxPolicy = native_if_possible,
+ MLDSType0 = mercury_type_to_mlds_type(ModuleInfo, Type)
+ ),
+
+ % Dummy arguments are just mapped to integers, since they shouldn't be
+ % used in any way that requires them to have a real value.
+ ( check_dummy_type(ModuleInfo, Type) = is_dummy_type ->
+ Initializer = no_initializer,
+ MLDSType = mlds_native_int_type
+ ; list.member(Var, ByRefOutputVars) ->
+ Initializer = no_initializer,
+ MLDSType = MLDSType0
+ ; list.member(Var, CopiedOutputVars) ->
+ Initializer = no_initializer,
+ MLDSType = MLDSType0
+ ;
+ MLDSType = MLDSType0,
+ QualVarName = qual(MLDSModuleName, module_qual, VarName),
+ Initializer = init_obj(ml_lval(ml_var(QualVarName, MLDSType)))
+ ),
+ % XXX Accurate GC is not supported for IL foreign code;
+ % this would only be useful if interfacing to
+ % IL when compiling to C, which is not yet supported.
+ GCStatement = gc_no_stmt,
+ Defn = ml_gen_mlds_var_decl_init(mlds_data_var(NonMangledVarName),
+ MLDSType, Initializer, GCStatement, MLDSContext).
+
+ % For ordinary (not model_non) pragma c_proc,
+ % we generate code of the following form:
+ %
+ % model_det pragma_c_proc:
+ %
+ % #define MR_PROC_LABEL <procedure name>
+ % <declaration of locals needed for boxing/unboxing>
+ % {
+ % <declaration of one local variable for each arg>
+ %
+ % <assign input args>
+ % <obtain global lock>
+ % <c code>
+ % <boxing/unboxing of outputs>
+ % <release global lock>
+ % <assign output args>
+ % }
+ % #undef MR_PROC_LABEL
+ %
+ % model_semi pragma_c_proc:
+ %
+ % #define MR_PROC_LABEL <procedure name>
+ % <declaration of locals needed for boxing/unboxing>
+ % {
+ % <declaration of one local variable for each arg>
+ % MR_bool SUCCESS_INDICATOR;
+ %
+ % <assign input args>
+ % <obtain global lock>
+ % <c code>
+ % <release global lock>
+ % if (SUCCESS_INDICATOR) {
+ % <assign output args>
+ % <boxing/unboxing of outputs>
+ % }
+ %
+ % <succeeded> = SUCCESS_INDICATOR;
+ % }
+ % #undef MR_PROC_LABEL
+ %
+ % We insert a #define for MR_PROC_LABEL, so that the C code in
+ % the Mercury standard library that allocates memory manually
+ % can use MR_PROC_LABEL as the procname argument to
+ % incr_hp_msg(), for memory profiling. Hard-coding the procname
+ % argument in the C code would be wrong, since it wouldn't
+ % handle the case where the original pragma c_code procedure
+ % gets inlined and optimized away. Of course we also need to
+ % #undef it afterwards.
+ %
+ % Note that we generate this code directly as
+ % `target_code(lang_C, <string>)' instructions in the MLDS.
+ % It would probably be nicer to encode more of the structure
+ % in the MLDS, so that (a) we could do better MLDS optimization
+ % and (b) so that the generation of C code strings could be
+ % isolated in mlds_to_c.m. Also we will need to do something
+ % different for targets other than C, e.g. when compiling to
+ % Java.
+ %
+:- pred ml_gen_ordinary_pragma_c_proc(ordinary_pragma_kind::in,
+ pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
+ list(foreign_arg)::in, list(foreign_arg)::in, string::in,
+ prog_context::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_ordinary_pragma_c_proc(OrdinaryKind, Attributes, PredId, _ProcId,
+ OrigArgs, ExtraArgs, C_Code, Context, Decls, Statements, !Info) :-
+ Lang = get_foreign_language(Attributes),
+
+ % Generate <declaration of one local variable for each arg>
+ list.append(OrigArgs, ExtraArgs, Args),
+ ml_gen_pragma_c_decls(!.Info, Lang, Args, ArgDeclsList),
+
+ % Generate code to set the values of the input variables.
+ ml_gen_pragma_c_java_input_arg_list(Lang, Args, AssignInputsList, !Info),
+
+ % Generate code to assign the values of the output variables.
+ ml_gen_pragma_c_output_arg_list(Args, Context,
+ AssignOutputsList, ConvDecls, ConvStatements, !Info),
+
+ % Generate code fragments to obtain and release the global lock.
+ ThreadSafe = get_thread_safe(Attributes),
+ ml_gen_obtain_release_global_lock(!.Info, ThreadSafe, PredId,
+ ObtainLock, ReleaseLock),
+
+ % Generate the MR_PROC_LABEL #define.
+ ml_gen_hash_define_mr_proc_label(!.Info, HashDefine),
+
+ % Put it all together.
+ (
+ OrdinaryKind = kind_det,
+ Starting_C_Code = list.condense([
+ [raw_target_code("{\n", [])],
+ HashDefine,
+ ArgDeclsList,
+ [raw_target_code("\n", [])],
+ AssignInputsList,
+ [raw_target_code(ObtainLock, []),
+ raw_target_code("\t\t{\n", []),
+ user_target_code(C_Code, yes(Context), []),
+ raw_target_code("\n\t\t;}\n", []),
+ raw_target_code("#undef MR_PROC_LABEL\n", []),
+ raw_target_code(ReleaseLock, [])],
+ AssignOutputsList
+ ]),
+ Ending_C_Code = [raw_target_code("}\n", [])]
+ ;
+ OrdinaryKind = kind_failure,
+ % We need to treat this case separately, because for these
+ % foreign_procs the C code fragment won't assign anything
+ % SUCCESS_INDICATOR; the code we generate for CanSucceed = yes
+ % would test an undefined value.
+ ml_success_lval(!.Info, SucceededLval),
+ Starting_C_Code = list.condense([
+ [raw_target_code("{\n", [])],
+ HashDefine,
+ ArgDeclsList,
+ [raw_target_code("\n", [])],
+ AssignInputsList,
+ [raw_target_code(ObtainLock, []),
+ raw_target_code("\t\t{\n", []),
+ user_target_code(C_Code, yes(Context), []),
+ raw_target_code("\n\t\t;}\n", []),
+ raw_target_code("#undef MR_PROC_LABEL\n", []),
+ raw_target_code(ReleaseLock, [])]
+ ]),
+ Ending_C_Code = [
+ target_code_output(SucceededLval),
+ raw_target_code(" = MR_FALSE;\n", []),
+ raw_target_code("}\n", [])
+ ]
+ ;
+ OrdinaryKind = kind_semi,
+ ml_success_lval(!.Info, SucceededLval),
+ Starting_C_Code = list.condense([
+ [raw_target_code("{\n", [])],
+ HashDefine,
+ ArgDeclsList,
+ [raw_target_code("\tMR_bool SUCCESS_INDICATOR;\n", []),
+ raw_target_code("\n", [])],
+ AssignInputsList,
+ [raw_target_code(ObtainLock, []),
+ raw_target_code("\t\t{\n", []),
+ user_target_code(C_Code, yes(Context), []),
+ raw_target_code("\n\t\t;}\n", []),
+ raw_target_code("#undef MR_PROC_LABEL\n", []),
+ raw_target_code(ReleaseLock, []),
+ raw_target_code("\tif (SUCCESS_INDICATOR) {\n", [])],
+ AssignOutputsList
+ ]),
+ Ending_C_Code = [
+ raw_target_code("\t}\n", []),
+ target_code_output(SucceededLval),
+ raw_target_code(" = SUCCESS_INDICATOR;\n", []),
+ raw_target_code("}\n", [])
+ ]
+ ),
+ Starting_C_Code_Stmt = inline_target_code(ml_target_c, Starting_C_Code),
+ Ending_C_Code_Stmt = inline_target_code(ml_target_c, Ending_C_Code),
+ Starting_C_Code_Statement = statement(
+ ml_stmt_atomic(Starting_C_Code_Stmt), mlds_make_context(Context)),
+ Ending_C_Code_Statement = statement(ml_stmt_atomic(Ending_C_Code_Stmt),
+ mlds_make_context(Context)),
+ Statements = [Starting_C_Code_Statement | ConvStatements] ++
+ [Ending_C_Code_Statement],
+ Decls = ConvDecls.
+
+ % Generate code fragments to obtain and release the global lock
+ % (this is used for ensuring thread safety in a concurrent implementation).
+ %
+:- pred ml_gen_obtain_release_global_lock(ml_gen_info::in,
+ proc_thread_safe::in, pred_id::in, string::out, string::out) is det.
+
+ml_gen_obtain_release_global_lock(Info, ThreadSafe, PredId,
+ ObtainLock, ReleaseLock) :-
+ ml_gen_info_get_module_info(Info, ModuleInfo),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, parallel, Parallel),
+ (
+ Parallel = yes,
+ ThreadSafe = proc_not_thread_safe
+ ->
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ Name = pred_info_name(PredInfo),
+ MangledName = c_util.quote_string(Name),
+ string.append_list(["\tMR_OBTAIN_GLOBAL_LOCK(""",
+ MangledName, """);\n"], ObtainLock),
+ string.append_list(["\tMR_RELEASE_GLOBAL_LOCK(""",
+ MangledName, """);\n"], ReleaseLock)
+ ;
+ ObtainLock = "",
+ ReleaseLock = ""
+ ).
+
+:- pred ml_gen_hash_define_mr_proc_label(ml_gen_info::in,
+ list(target_code_component)::out) is det.
+
+ml_gen_hash_define_mr_proc_label(Info, HashDefine) :-
+ ml_gen_info_get_module_info(Info, ModuleInfo),
+ % Note that we use the pred_id and proc_id of the current procedure,
+ % not the one that the pragma foreign_code originally came from.
+ % There may not be any function address for the latter, e.g. if it
+ % has been inlined and the original definition optimized away.
+ ml_gen_info_get_pred_id(Info, PredId),
+ ml_gen_info_get_proc_id(Info, ProcId),
+ ml_gen_proc_label(ModuleInfo, PredId, ProcId, Name, Module),
+ HashDefine = [raw_target_code("#define MR_PROC_LABEL ", []),
+ target_code_name(qual(Module, module_qual, Name)),
+ raw_target_code("\n", [])].
+
+:- func get_target_code_attributes(foreign_language,
+ pragma_foreign_proc_extra_attributes) = target_code_attributes.
+
+get_target_code_attributes(_Lang, []) = [].
+get_target_code_attributes(Lang, [ProcAttr | ProcAttrs]) = TargetAttrs :-
+ TargetAttrs1 = get_target_code_attributes(Lang, ProcAttrs),
+ (
+ ProcAttr = max_stack_size(N),
+ (
+ Lang = lang_il,
+ TargetAttrs = [max_stack_size(N) | TargetAttrs1]
+ ;
+ ( Lang = lang_c
+ ; Lang = lang_csharp
+ ; Lang = lang_java
+ ; Lang = lang_erlang
+ ),
+ TargetAttrs = TargetAttrs1
+ )
+ ;
+ ( ProcAttr = refers_to_llds_stack
+ ; ProcAttr = backend(_)
+ ; ProcAttr = needs_call_standard_output_registers
+ ),
+ TargetAttrs = TargetAttrs1
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % ml_gen_pragma_c_decls generates C code to declare the arguments
+ % for a `pragma foreign_proc' declaration.
+ %
+:- pred ml_gen_pragma_c_decls(ml_gen_info::in, foreign_language::in,
+ list(foreign_arg)::in, list(target_code_component)::out) is det.
+
+ml_gen_pragma_c_decls(_, _, [], []).
+ml_gen_pragma_c_decls(Info, Lang, [Arg | Args], [Decl | Decls]) :-
+ ml_gen_pragma_c_decl(Info, Lang, Arg, Decl),
+ ml_gen_pragma_c_decls(Info, Lang, Args, Decls).
+
+ % ml_gen_pragma_c_decl generates C code to declare an argument
+ % of a `pragma foreign_proc' declaration.
+ %
+:- pred ml_gen_pragma_c_decl(ml_gen_info::in, foreign_language::in,
+ foreign_arg::in, target_code_component::out) is det.
+
+ml_gen_pragma_c_decl(Info, Lang, Arg, Decl) :-
+ Arg = foreign_arg(_Var, MaybeNameAndMode, Type, BoxPolicy),
+ ml_gen_info_get_module_info(Info, ModuleInfo),
+ (
+ MaybeNameAndMode = yes(ArgName - _Mode),
+ not var_is_singleton(ArgName)
+ ->
+ (
+ BoxPolicy = always_boxed,
+ TypeString = "MR_Word"
+ ;
+ BoxPolicy = native_if_possible,
+ TypeString = mercury_exported_type_to_string(ModuleInfo, Lang,
+ Type)
+ ),
+ string.format("\t%s %s;\n", [s(TypeString), s(ArgName)], DeclString)
+ ;
+ % If the variable doesn't occur in the ArgNames list,
+ % it can't be used, so we just ignore it.
+ DeclString = ""
+ ),
+ Decl = raw_target_code(DeclString, []).
+
+%-----------------------------------------------------------------------------%
+
+ % The foreign code generated to implement mutable variables requires
+ % special case treatment, enabled by passing `mutable_special_case'.
+ %
+:- type mutable_special_case
+ ---> mutable_special_case
+ ; not_mutable_special_case.
+
+ % ml_gen_pragma_java_decls generates Java code to declare the arguments
+ % for a `pragma foreign_proc' declaration.
+ %
+:- pred ml_gen_pragma_java_decls(ml_gen_info::in, mutable_special_case::in,
+ list(foreign_arg)::in, list(target_code_component)::out) is det.
+
+ml_gen_pragma_java_decls(_, _, [], []).
+ml_gen_pragma_java_decls(Info, MutableSpecial, [Arg | Args], Decl ++ Decls) :-
+ ml_gen_pragma_java_decl(Info, MutableSpecial, Arg, Decl),
+ ml_gen_pragma_java_decls(Info, MutableSpecial, Args, Decls).
+
+ % ml_gen_pragma_java_decl generates Java code to declare an argument
+ % of a `pragma foreign_proc' declaration.
+ %
+:- pred ml_gen_pragma_java_decl(ml_gen_info::in, mutable_special_case::in,
+ foreign_arg::in, list(target_code_component)::out) is det.
+
+ml_gen_pragma_java_decl(Info, MutableSpecial, Arg, Decl) :-
+ Arg = foreign_arg(_Var, MaybeNameAndMode, Type, _BoxPolicy),
+ ml_gen_info_get_module_info(Info, ModuleInfo),
+ (
+ MaybeNameAndMode = yes(ArgName - _Mode),
+ not var_is_singleton(ArgName)
+ ->
+ (
+ MutableSpecial = not_mutable_special_case,
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type)
+ ;
+ MutableSpecial = mutable_special_case,
+ % The code for mutables is generated in the frontend.
+ % All mutable variables have the type `java.lang.Object'.
+ MLDS_Type = mlds_generic_type
+ ),
+ TypeDecl = target_code_type(MLDS_Type),
+ string.format(" %s;\n", [s(ArgName)], VarDeclString),
+ VarDecl = raw_target_code(VarDeclString, []),
+ Decl = [TypeDecl, VarDecl]
+ ;
+ % If the variable doesn't occur in the ArgNames list,
+ % it can't be used, so we just ignore it.
+ Decl = []
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % var_is_singleton determines whether or not a given foreign_proc variable
+ % is singleton (i.e. starts with an underscore)
+ %
+ % Singleton vars should be ignored when generating the declarations for
+ % foreign_proc arguments because:
+ %
+ % - they should not appear in the C code
+ % - they could clash with the system name space
+ %
+:- pred var_is_singleton(string::in) is semidet.
+
+var_is_singleton(Name) :-
+ string.first_char(Name, '_', _).
+
+%-----------------------------------------------------------------------------%
+
+ % For both C and Java.
+ %
+:- pred ml_gen_pragma_c_java_input_arg_list(foreign_language::in,
+ list(foreign_arg)::in, list(target_code_component)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_java_input_arg_list(Lang, ArgList, AssignInputs, !Info) :-
+ list.map_foldl(ml_gen_pragma_c_java_input_arg(Lang), ArgList,
+ AssignInputsList, !Info),
+ list.condense(AssignInputsList, AssignInputs).
+
+ % ml_gen_pragma_c_input_arg generates C or Java code to assign the value of
+ % an input arg for a `pragma foreign_proc' declaration.
+ %
+:- pred ml_gen_pragma_c_java_input_arg(foreign_language::in, foreign_arg::in,
+ list(target_code_component)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_java_input_arg(Lang, ForeignArg, AssignInput, !Info) :-
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ (
+ ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
+ MaybeNameAndMode = yes(ArgName - Mode),
+ not var_is_singleton(ArgName),
+ mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_in)
+ ->
+ ml_gen_pragma_c_java_gen_input_arg(Lang, Var, ArgName, OrigType,
+ BoxPolicy, AssignInput, !Info)
+ ;
+ % If the variable doesn't occur in the ArgNames list,
+ % it can't be used, so we just ignore it.
+ AssignInput = []
+ ).
+
+:- pred ml_gen_pragma_c_java_gen_input_arg(foreign_language::in, prog_var::in,
+ string::in, mer_type::in, box_policy::in, list(target_code_component)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_java_gen_input_arg(Lang, Var, ArgName, OrigType, BoxPolicy,
+ AssignInput, !Info) :-
+ ml_variable_type(!.Info, Var, VarType),
+ ml_gen_var(!.Info, Var, VarLval),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
+ (
+ IsDummy = is_dummy_type,
+ % The variable may not have been declared, so we need to generate
+ % a dummy value for it. Using a constant here is more efficient than
+ % using private_builtin.dummy_var, which is what ml_gen_var will have
+ % generated for this variable.
+ ArgRval = dummy_arg_rval(Lang, ModuleInfo, VarType)
+ ;
+ IsDummy = is_not_dummy_type,
+ ml_gen_box_or_unbox_rval(ModuleInfo, VarType, OrigType, BoxPolicy,
+ ml_lval(VarLval), ArgRval)
+ ),
+ % At this point we have an rval with the right type for *internal* use
+ % in the code generated by the Mercury compiler's MLDS back-end. We need
+ % to convert this to the appropriate type to use for the C interface.
+ ExportedType = foreign.to_exported_type(ModuleInfo, OrigType),
+ TypeString = exported_type_to_string(Lang, ExportedType),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ (
+ input_arg_assignable_with_cast(Lang, HighLevelData, OrigType,
+ ExportedType, TypeString, Cast)
+ ->
+ % In the usual case, we can just use an assignment and perhaps a cast.
+ string.format("\t%s = %s ", [s(ArgName), s(Cast)], AssignToArgName),
+ AssignInput = [
+ raw_target_code(AssignToArgName, []),
+ target_code_input(ArgRval),
+ raw_target_code(";\n", [])
+ ]
+ ;
+ % For foreign types (without the `can_pass_as_mercury_type' assertion)
+ % we need to call MR_MAYBE_UNBOX_FOREIGN_TYPE.
+ AssignInput = [
+ raw_target_code("\tMR_MAYBE_UNBOX_FOREIGN_TYPE("
+ ++ TypeString ++ ", ", []),
+ target_code_input(ArgRval),
+ raw_target_code(", " ++ ArgName ++ ");\n", [])
+ ]
+ ).
+
+:- func dummy_arg_rval(foreign_language, module_info, mer_type) = mlds_rval.
+
+dummy_arg_rval(Lang, ModuleInfo, Type) = Rval :-
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
+ ( Lang = lang_java ->
+ Rval = ml_const(mlconst_null(MLDS_Type))
+ ;
+ Rval = ml_const(mlconst_int(0))
+ ).
+
+:- pred input_arg_assignable_with_cast(foreign_language::in, bool::in,
+ mer_type::in, exported_type::in, string::in, string::out) is semidet.
+
+input_arg_assignable_with_cast(Lang, HighLevelData, OrigType, ExportedType,
+ TypeString, Cast) :-
+ (
+ Lang = lang_c,
+ HighLevelData = yes,
+ % In general, the types used for the C interface are not the same
+ % as the types used by --high-level-data, so we always use a cast
+ % here. (Strictly speaking the cast is not needed for a few cases
+ % like `int', but it doesn't do any harm.)
+ Cast = "(" ++ TypeString ++ ")"
+ ;
+ Lang = lang_c,
+ HighLevelData = no,
+ ( OrigType = type_variable(_, _) ->
+ % For --no-high-level-data, we only need to use a cast for
+ % polymorphic types, which are `MR_Word' in the C interface but
+ % `MR_Box' in the MLDS back-end.
+ Cast = "(MR_Word)"
+ ;
+ IsForeign = foreign.is_foreign_type(ExportedType),
+ (
+ IsForeign = yes(Assertions),
+ list.member(foreign_type_can_pass_as_mercury_type, Assertions),
+ Cast = "(" ++ TypeString ++ ")"
+ ;
+ IsForeign = no,
+ Cast = ""
+ )
+ )
+ ;
+ Lang = lang_java,
+ % There is no difference between types used by the foreign interface
+ % and the generated code.
+ Cast = ""
+ ;
+ ( Lang = lang_csharp
+ ; Lang = lang_il
+ ; Lang = lang_erlang
+ ),
+ unexpected(this_file,
+ "input_arg_assignable_with_cast: unexpected language")
+ ).
+
+:- pred ml_gen_pragma_java_output_arg_list(mutable_special_case::in,
+ list(foreign_arg)::in, prog_context::in, list(statement)::out,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_java_output_arg_list(_, [], _, [], [], [], !Info).
+ml_gen_pragma_java_output_arg_list(MutableSpecial, [JavaArg | JavaArgs],
+ Context, Statements, ConvDecls, ConvStatements, !Info) :-
+ ml_gen_pragma_java_output_arg(MutableSpecial, JavaArg, Context,
+ Statements1, ConvDecls1, ConvStatements1, !Info),
+ ml_gen_pragma_java_output_arg_list(MutableSpecial, JavaArgs, Context,
+ Statements2, ConvDecls2, ConvStatements2, !Info),
+ Statements = Statements1 ++ Statements2,
+ ConvDecls = ConvDecls1 ++ ConvDecls2,
+ ConvStatements = ConvStatements1 ++ ConvStatements2.
+
+ % ml_gen_pragma_java_output_arg generates MLDS statements to assign the
+ % value of an output arg for a `pragma foreign_proc' declaration.
+ %
+:- pred ml_gen_pragma_java_output_arg(mutable_special_case::in,
+ foreign_arg::in, prog_context::in, list(statement)::out,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_java_output_arg(MutableSpecial, ForeignArg, Context,
+ AssignOutput, ConvDecls, ConvOutputStatements, !Info) :-
+ ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ (
+ MaybeNameAndMode = yes(ArgName - Mode),
+ not var_is_singleton(ArgName),
+ check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
+ mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out)
+ ->
+ % Create a target lval with the right type for *internal* use in the
+ % code generated by the Mercury compiler's MLDS back-end.
+ ml_variable_type(!.Info, Var, VarType),
+ ml_gen_var(!.Info, Var, VarLval),
+ ml_gen_box_or_unbox_lval(VarType, OrigType, BoxPolicy,
+ VarLval, mlds_var_name(ArgName, no), Context, no, 0,
+ ArgLval, ConvDecls, _ConvInputStatements,
+ ConvOutputStatements, !Info),
+ MLDSType = mercury_type_to_mlds_type(ModuleInfo, OrigType),
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDSModuleName = mercury_module_name_to_mlds(ModuleName),
+ NonMangledVarName = mlds_var_name(ArgName, no),
+ QualLocalVarName = qual(MLDSModuleName, module_qual,
+ NonMangledVarName),
+ LocalVarLval = ml_var(QualLocalVarName, MLDSType),
+ (
+ MutableSpecial = not_mutable_special_case,
+ Rval = ml_lval(LocalVarLval)
+ ;
+ MutableSpecial = mutable_special_case,
+ % The code for mutables is generated in the frontend.
+ % All mutable variables have the type `java.lang.Object'
+ % so we need to cast the variable or extract the primitive
+ % value from the box.
+ Rval = ml_unop(unbox(MLDSType), ml_lval(LocalVarLval))
+ ),
+ AssignOutput = [ml_gen_assign(ArgLval, Rval, Context)]
+ ;
+ % If the variable doesn't occur in the ArgNames list,
+ % it can't be used, so we just ignore it.
+ AssignOutput = [],
+ ConvDecls = [],
+ ConvOutputStatements = []
+ ).
+
+:- pred ml_gen_pragma_c_output_arg_list(list(foreign_arg)::in,
+ prog_context::in, list(target_code_component)::out,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_output_arg_list([], _, [], [], [], !Info).
+ml_gen_pragma_c_output_arg_list([ForeignArg | ForeignArgs], Context,
+ Components, ConvDecls, ConvStatements, !Info) :-
+ ml_gen_pragma_c_output_arg(ForeignArg, Context, Components1,
+ ConvDecls1, ConvStatements1, !Info),
+ ml_gen_pragma_c_output_arg_list(ForeignArgs, Context,
+ Components2, ConvDecls2, ConvStatements2, !Info),
+ Components = Components1 ++ Components2,
+ ConvDecls = ConvDecls1 ++ ConvDecls2,
+ ConvStatements = ConvStatements1 ++ ConvStatements2.
+
+ % ml_gen_pragma_c_output_arg generates C code to assign the value of
+ % an output arg for a `pragma foreign_proc' declaration.
+ %
+:- pred ml_gen_pragma_c_output_arg(foreign_arg::in,
+ prog_context::in, list(target_code_component)::out,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_output_arg(Arg, Context, AssignOutput, ConvDecls,
+ ConvOutputStatements, !Info) :-
+ Arg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ (
+ MaybeNameAndMode = yes(ArgName - Mode),
+ not var_is_singleton(ArgName),
+ check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
+ mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out)
+ ->
+ ml_gen_pragma_c_gen_output_arg(Var, ArgName, OrigType, BoxPolicy,
+ Context, AssignOutput, ConvDecls, ConvOutputStatements, !Info)
+ ;
+ % If the variable doesn't occur in the ArgNames list,
+ % it can't be used, so we just ignore it.
+ AssignOutput = [],
+ ConvDecls = [],
+ ConvOutputStatements = []
+ ).
+
+:- pred ml_gen_pragma_c_gen_output_arg(prog_var::in,
+ string::in, mer_type::in, box_policy::in, prog_context::in,
+ list(target_code_component)::out,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_gen_output_arg(Var, ArgName, OrigType, BoxPolicy,
+ Context, AssignOutput, ConvDecls, ConvOutputStatements, !Info) :-
+ ml_variable_type(!.Info, Var, VarType),
+ ml_gen_var(!.Info, Var, VarLval),
+ ml_gen_box_or_unbox_lval(VarType, OrigType, BoxPolicy, VarLval,
+ mlds_var_name(ArgName, no), Context, no, 0, ArgLval,
+ ConvDecls, _ConvInputStatements, ConvOutputStatements, !Info),
+ % At this point we have an lval with the right type for *internal* use
+ % in the code generated by the Mercury compiler's MLDS back-end. We need
+ % to convert this to the appropriate type to use for the C interface.
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ExportedType = foreign.to_exported_type(ModuleInfo, OrigType),
+ TypeString = exported_type_to_string(lang_c, ExportedType),
+ IsForeign = foreign.is_foreign_type(ExportedType),
+ (
+ (
+ IsForeign = no,
+ Cast = no
+ ;
+ IsForeign = yes(Assertions),
+ list.member(foreign_type_can_pass_as_mercury_type, Assertions),
+ Cast = yes
+ )
+ ->
+ % In the usual case, we can just use an assignment,
+ % perhaps with a cast.
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
+ (
+ HighLevelData = yes,
+ % In general, the types used for the C interface are not the same
+ % as the types used by --high-level-data, so we always use a cast
+ % here. (Strictly speaking the cast is not needed for a few cases
+ % like `int', but it doesn't do any harm.) Note that we can't
+ % easily obtain the type string for the RHS of the assignment,
+ % so instead we cast the LHS.
+ LHS_Cast = "* (" ++ TypeString ++ " *) &",
+ RHS_Cast = ""
+ ;
+ HighLevelData = no,
+ % For --no-high-level-data, we only need to use a cast is for
+ % polymorphic types, which are `MR_Word' in the C interface but
+ % `MR_Box' in the MLDS back-end.
+ (
+ ( OrigType = type_variable(_, _)
+ ; Cast = yes
+ )
+ ->
+ RHS_Cast = "(MR_Box) "
+ ;
+ RHS_Cast = ""
+ ),
+ LHS_Cast = ""
+ ),
+ string.format(" = %s%s;\n", [s(RHS_Cast), s(ArgName)],
+ AssignFromArgName),
+ string.format("\t%s ", [s(LHS_Cast)], AssignTo),
+ AssignOutput = [
+ raw_target_code(AssignTo, []),
+ target_code_output(ArgLval),
+ raw_target_code(AssignFromArgName, [])
+ ]
+ ;
+ % For foreign types, we need to call MR_MAYBE_BOX_FOREIGN_TYPE.
+ AssignOutput = [
+ raw_target_code("\tMR_MAYBE_BOX_FOREIGN_TYPE("
+ ++ TypeString ++ ", " ++ ArgName ++ ", ", []),
+ target_code_output(ArgLval),
+ raw_target_code(");\n", [])
+ ]
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "ml_foreign_proc_gen.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module ml_foreign_proc_gen.
+%-----------------------------------------------------------------------------%
Index: compiler/ml_gen_info.m
===================================================================
RCS file: compiler/ml_gen_info.m
diff -N compiler/ml_gen_info.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/ml_gen_info.m 23 Sep 2009 15:58:41 -0000
@@ -0,0 +1,605 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ml_code_util.m.
+% Main author: fjh.
+%
+% This module is part of the MLDS code generator.
+% It defines the ml_gen_info type and its access routines.
+%
+%-----------------------------------------------------------------------------%
+
+:- module ml_backend.ml_gen_info.
+:- interface.
+
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+:- import_module libs.globals.
+:- import_module ml_backend.mlds.
+:- import_module ml_backend.ml_global_data.
+:- import_module parse_tree.prog_data.
+
+:- import_module bool.
+:- import_module list.
+:- import_module map.
+:- import_module set.
+
+%-----------------------------------------------------------------------------%
+%
+% The `ml_gen_info' ADT.
+%
+
+ % The `ml_gen_info' type holds information used during
+ % MLDS code generation for a given procedure.
+ %
+:- type ml_gen_info.
+
+ % Initialize the ml_gen_info, so that it is ready for generating code
+ % for the given procedure. The last argument records the persistent
+ % information accumulated by the code generator so far during the
+ % processing of previous procedures.
+ %
+:- func ml_gen_info_init(module_info, pred_id, proc_id, proc_info,
+ ml_global_data) = ml_gen_info.
+
+:- pred ml_gen_info_get_module_info(ml_gen_info::in, module_info::out) is det.
+:- pred ml_gen_info_get_high_level_data(ml_gen_info::in, bool::out) is det.
+:- pred ml_gen_info_get_target(ml_gen_info::in, compilation_target::out)
+ is det.
+:- pred ml_gen_info_get_pred_id(ml_gen_info::in, pred_id::out) is det.
+:- pred ml_gen_info_get_proc_id(ml_gen_info::in, proc_id::out) is det.
+:- pred ml_gen_info_get_varset(ml_gen_info::in, prog_varset::out) is det.
+:- pred ml_gen_info_get_var_types(ml_gen_info::in, vartypes::out) is det.
+:- pred ml_gen_info_get_byref_output_vars(ml_gen_info::in, list(prog_var)::out)
+ is det.
+:- pred ml_gen_info_get_value_output_vars(ml_gen_info::in, list(prog_var)::out)
+ is det.
+:- pred ml_gen_info_get_global_data(ml_gen_info::in, ml_global_data::out)
+ is det.
+
+:- pred ml_gen_info_set_module_info(module_info::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_varset(prog_varset::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_var_types(vartypes::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_byref_output_vars(list(prog_var)::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_value_output_vars(list(prog_var)::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_global_data(ml_global_data::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+:- pred ml_gen_info_get_globals(ml_gen_info::in, globals::out) is det.
+:- pred ml_gen_info_get_module_name(ml_gen_info::in, mercury_module_name::out)
+ is det.
+
+ % Lookup the --gcc-nested-functions option.
+ %
+:- pred ml_gen_info_use_gcc_nested_functions(ml_gen_info::in, bool::out)
+ is det.
+
+ % Lookup the --put-commit-in-nested-func option.
+ %
+:- pred ml_gen_info_put_commit_in_own_func(ml_gen_info::in, bool::out) is det.
+
+ % Generate a new label number for use in label statements.
+ % This is used to give unique names to the case labels generated
+ % for dense switch statements.
+ %
+:- type label_num == int.
+:- pred ml_gen_info_new_label(label_num::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % A number corresponding to an MLDS nested function which serves as a
+ % label (i.e. a continuation function).
+ %
+:- type ml_label_func == mlds_func_sequence_num.
+
+ % Generate a new function label number. This is used to give unique names
+ % to the nested functions used when generating code for nondet procedures.
+ %
+:- pred ml_gen_info_new_func_label(ml_label_func::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Increase the function label and const sequence number counters by some
+ % amount which is presumed to be sufficient to ensure that if we start
+ % again with a fresh ml_gen_info and then call this function, we won't
+ % encounter any already-used function labels or constants. (This is used
+ % when generating wrapper functions for type class methods.)
+ %
+:- pred ml_gen_info_bump_counters(ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Generate a new auxiliary variable name. The name of the variable
+ % will start with the given prefix and end with a sequence number
+ % that differentiates this aux var from all others.
+ %
+ % Auxiliary variables are used for purposes such as commit label numbers
+ % and holding table indexes in switches.
+ %
+:- pred ml_gen_info_new_aux_var_name(string::in, mlds_var_name::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Generate a new `cond' variable number.
+ %
+:- type cond_seq ---> cond_seq(int).
+:- pred ml_gen_info_new_cond_var(cond_seq::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Generate a new `conv' variable number. This is used to give unique names
+ % to the local variables generated by ml_gen_box_or_unbox_lval, which are
+ % used to handle boxing/unboxing argument conversions.
+ %
+:- type conv_seq ---> conv_seq(int).
+:- pred ml_gen_info_new_conv_var(conv_seq::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+:- type ml_ground_term
+ ---> ml_ground_term(
+ % The value of the ground term.
+ mlds_rval,
+
+ % The type of the ground term (actually, the type of the
+ % variable the ground term was constructed for).
+ mer_type,
+
+ % The corresponding MLDS type. It could be computed from the
+ % Mercury type, but there is no point in doing so when using
+ % the ground term as well when constructing it.
+ mlds_type
+ ).
+
+:- type ml_ground_term_map == map(prog_var, ml_ground_term).
+
+ % Set the `const' variable name corresponding to the given HLDS variable.
+ %
+:- pred ml_gen_info_set_const_var(prog_var::in, ml_ground_term::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Lookup the `const' sequence number corresponding to a given HLDS
+ % variable.
+ %
+:- pred ml_gen_info_lookup_const_var(ml_gen_info::in, prog_var::in,
+ ml_ground_term::out) is det.
+:- pred ml_gen_info_search_const_var(ml_gen_info::in, prog_var::in,
+ ml_ground_term::out) is semidet.
+
+ % A success continuation specifies the (rval for the variable holding
+ % the address of the) function that a nondet procedure should call
+ % if it succeeds, and possibly also the (rval for the variable holding)
+ % the environment pointer for that function, and possibly also the
+ % (list of rvals for the) arguments to the continuation.
+
+:- type success_cont
+ ---> success_cont(
+ mlds_rval, % function pointer
+ mlds_rval, % environment pointer
+ % note that if we're using nested
+ % functions then the environment
+ % pointer will not be used
+ list(mlds_type), % argument types, if any
+ list(mlds_lval) % arguments, if any
+ % The arguments will only be non-empty
+ % if the --nondet-copy-out option is
+ % enabled. They do not include the
+ % environment pointer.
+ ).
+
+ % The ml_gen_info contains a stack of success continuations.
+ % The following routines provide access to that stack.
+
+:- pred ml_gen_info_push_success_cont(success_cont::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+:- pred ml_gen_info_pop_success_cont(ml_gen_info::in, ml_gen_info::out) is det.
+
+:- pred ml_gen_info_current_success_cont(ml_gen_info::in, success_cont::out)
+ is det.
+
+ % We keep a partial mapping from vars to lvals. This is used in special
+ % cases to override the normal lval for a variable. ml_gen_var will check
+ % this map first, and if the variable is not in this map, then it will go
+ % ahead and generate an lval for it as usual.
+
+ % Set the lval for a variable.
+ %
+:- pred ml_gen_info_set_var_lval(prog_var::in, mlds_lval::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Get the partial mapping from variables to lvals.
+ %
+:- pred ml_gen_info_get_var_lvals(ml_gen_info::in,
+ map(prog_var, mlds_lval)::out) is det.
+
+ % Set the partial mapping from variables to lvals.
+ %
+:- pred ml_gen_info_set_var_lvals(map(prog_var, mlds_lval)::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % A variable can be bound to a constant in one branch of a control
+ % structure and to a non-constant term in another branch. We remember
+ % information about variables bound to constants in the map these two
+ % predicates are the getter and setter of. Branched control structures
+ % should reset the map to its original value at the start of every branch
+ % after the first (to prevent a later branch from using information that is
+ % applicable only in a previous branch), and at the end of the branched
+ % control structure (to prevent the code after it using information whose
+ % correctness depends on the exact route execution took to there).
+ %
+:- pred ml_gen_info_get_const_var_map(ml_gen_info::in,
+ map(prog_var, ml_ground_term)::out) is det.
+:- pred ml_gen_info_set_const_var_map(map(prog_var, ml_ground_term)::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % The ml_gen_info contains a list of extra definitions of functions or
+ % global constants which should be inserted before the definition of the
+ % function for the current procedure. This is used for the definitions
+ % of the wrapper functions needed for closures. When generating code
+ % for a procedure that creates a closure, we insert the definition of
+ % the wrapper function used for that closure into this list.
+
+ % Insert an extra definition at the start of the list of extra
+ % definitions.
+ %
+:- pred ml_gen_info_add_closure_wrapper_defn(mlds_defn::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Get the list of extra definitions.
+ %
+:- pred ml_gen_info_get_closure_wrapper_defns(ml_gen_info::in,
+ list(mlds_defn)::out) is det.
+
+ % Add the given string as the name of an environment variable used by
+ % the function being generated.
+ %
+:- pred ml_gen_info_add_env_var_name(string::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Get the names of the used environment variables.
+ %
+:- pred ml_gen_info_get_env_var_names(ml_gen_info::in, set(string)::out)
+ is det.
+
+:- implementation.
+
+:- import_module check_hlds.mode_util.
+:- import_module libs.options.
+
+:- import_module counter.
+:- import_module int.
+:- import_module maybe.
+:- import_module stack.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
+%
+% The definition of the `ml_gen_info' ADT.
+%
+
+:- type ml_gen_info
+ ---> ml_gen_info(
+/* 1 */ mgi_module_info :: module_info,
+
+ % These fields remain constant for each procedure unless
+ % accurate GC is enabled, in which case they may get updated
+ % if we create fresh variables for the type_info variables
+ % needed for calls to private_builtin.gc_trace.
+/* 2 */ mgi_varset :: prog_varset,
+/* 3 */ mgi_var_types :: vartypes,
+
+ % Output arguments that are passed by reference.
+/* 4 */ mgi_byref_output_vars :: list(prog_var),
+
+ % Output arguments that are returned as values.
+/* 5 */ mgi_value_output_vars :: list(prog_var),
+
+ % Definitions of functions or global constants which should be
+ % inserted before the definition of the function for the
+ % current procedure.
+/* 6 */ mgi_var_lvals :: map(prog_var, mlds_lval),
+
+/* 7 */ mgi_global_data :: ml_global_data,
+
+ % All of the other pieces of information that are not among
+ % the most frequently read and/or written fields. Limiting
+ % ml_gen_info to eight fields make updating the structure
+ % quicker and less wasteful of memory.
+/* 8 */ mgi_sub_info :: ml_gen_sub_info
+ ).
+
+:- type ml_gen_sub_info
+ ---> ml_gen_sub_info(
+ % Quick-access read-only copies of parts of the globals
+ % structure taken from the module_info.
+/* 1 */ mgsi_high_level_data :: bool,
+/* 2 */ mgsi_target :: compilation_target,
+
+ % The identity of the procedure we are generating code for.
+/* 3 */ mgsi_pred_id :: pred_id,
+/* 4 */ mgsi_proc_id :: proc_id,
+
+/* 5 */ mgsi_func_counter :: counter,
+/* 6 */ mgsi_label_counter :: counter,
+/* 7 */ mgsi_aux_var_counter :: counter,
+/* 8 */ mgsi_cond_var_counter :: counter,
+/* 9 */ mgsi_conv_var_counter :: counter,
+
+/* 10 */ mgsi_const_var_map :: map(prog_var, ml_ground_term),
+
+/* 11 */ mgsi_closure_wrapper_defns :: list(mlds_defn),
+
+ % A partial mapping from vars to lvals, used to override
+ % the normal lval that we use for a variable.
+/* 12 */ mgsi_success_cont_stack :: stack(success_cont),
+
+/* 13 */ mgsi_env_var_names :: set(string)
+ ).
+
+ml_gen_info_init(ModuleInfo, PredId, ProcId, ProcInfo, GlobalData) = Info :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ globals.get_target(Globals, CompilationTarget),
+
+ proc_info_get_headvars(ProcInfo, HeadVars),
+ proc_info_get_varset(ProcInfo, VarSet),
+ proc_info_get_vartypes(ProcInfo, VarTypes),
+ proc_info_get_argmodes(ProcInfo, HeadModes),
+ ByRefOutputVars = select_output_vars(ModuleInfo, HeadVars, HeadModes,
+ VarTypes),
+ ValueOutputVars = [],
+
+ % XXX This needs to start at 1 rather than 0 otherwise the transformation
+ % for adding the shadow stack for accurate garbage collection does not work
+ % properly and we will end up generating two C functions with the same
+ % name (see ml_elim_nested.gen_gc_trace_func/8 for details).
+ %
+ counter.init(1, FuncLabelCounter),
+ counter.init(0, LabelCounter),
+ counter.init(0, AuxVarCounter),
+ counter.init(0, CondVarCounter),
+ counter.init(0, ConvVarCounter),
+ map.init(ConstVarMap),
+ stack.init(SuccContStack),
+ map.init(VarLvals),
+ ClosureWrapperDefns = [],
+ EnvVarNames = set.init,
+
+ SubInfo = ml_gen_sub_info(
+ HighLevelData,
+ CompilationTarget,
+ PredId,
+ ProcId,
+ FuncLabelCounter,
+ LabelCounter,
+ AuxVarCounter,
+ CondVarCounter,
+ ConvVarCounter,
+ ConstVarMap,
+ ClosureWrapperDefns,
+ SuccContStack,
+ EnvVarNames
+ ),
+ Info = ml_gen_info(
+ ModuleInfo,
+ VarSet,
+ VarTypes,
+ ByRefOutputVars,
+ ValueOutputVars,
+ VarLvals,
+ GlobalData,
+ SubInfo
+ ).
+
+:- pred ml_gen_info_get_func_counter(ml_gen_info::in, counter::out) is det.
+:- pred ml_gen_info_get_label_counter(ml_gen_info::in, counter::out) is det.
+:- pred ml_gen_info_get_aux_var_counter(ml_gen_info::in, counter::out) is det.
+:- pred ml_gen_info_get_cond_var_counter(ml_gen_info::in, counter::out) is det.
+:- pred ml_gen_info_get_conv_var_counter(ml_gen_info::in, counter::out) is det.
+:- pred ml_gen_info_get_success_cont_stack(ml_gen_info::in,
+ stack(success_cont)::out) is det.
+
+ml_gen_info_get_module_info(Info, Info ^ mgi_module_info).
+ml_gen_info_get_high_level_data(Info,
+ Info ^ mgi_sub_info ^ mgsi_high_level_data).
+ml_gen_info_get_target(Info, Info ^ mgi_sub_info ^ mgsi_target).
+ml_gen_info_get_pred_id(Info, Info ^ mgi_sub_info ^ mgsi_pred_id).
+ml_gen_info_get_proc_id(Info, Info ^ mgi_sub_info ^ mgsi_proc_id).
+ml_gen_info_get_varset(Info, Info ^ mgi_varset).
+ml_gen_info_get_var_types(Info, Info ^ mgi_var_types).
+ml_gen_info_get_byref_output_vars(Info, Info ^ mgi_byref_output_vars).
+ml_gen_info_get_value_output_vars(Info, Info ^ mgi_value_output_vars).
+ml_gen_info_get_var_lvals(Info, Info ^ mgi_var_lvals).
+ml_gen_info_get_global_data(Info, Info ^ mgi_global_data).
+
+ml_gen_info_get_func_counter(Info, Info ^ mgi_sub_info ^ mgsi_func_counter).
+ml_gen_info_get_label_counter(Info, Info ^ mgi_sub_info ^ mgsi_label_counter).
+ml_gen_info_get_aux_var_counter(Info,
+ Info ^ mgi_sub_info ^ mgsi_aux_var_counter).
+ml_gen_info_get_cond_var_counter(Info,
+ Info ^ mgi_sub_info ^ mgsi_cond_var_counter).
+ml_gen_info_get_conv_var_counter(Info,
+ Info ^ mgi_sub_info ^ mgsi_conv_var_counter).
+ml_gen_info_get_const_var_map(Info,
+ Info ^ mgi_sub_info ^ mgsi_const_var_map).
+ml_gen_info_get_success_cont_stack(Info,
+ Info ^ mgi_sub_info ^ mgsi_success_cont_stack).
+ml_gen_info_get_closure_wrapper_defns(Info,
+ Info ^ mgi_sub_info ^ mgsi_closure_wrapper_defns).
+ml_gen_info_get_env_var_names(Info, Info ^ mgi_sub_info ^ mgsi_env_var_names).
+
+:- pred ml_gen_info_set_func_counter(counter::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_label_counter(counter::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_aux_var_counter(counter::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_cond_var_counter(counter::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_conv_var_counter(counter::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_success_cont_stack(stack(success_cont)::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_closure_wrapper_defns(list(mlds_defn)::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_info_set_env_var_names(set(string)::in,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_info_set_module_info(ModuleInfo, !Info) :-
+ !Info ^ mgi_module_info := ModuleInfo.
+ml_gen_info_set_varset(VarSet, !Info) :-
+ !Info ^ mgi_varset := VarSet.
+ml_gen_info_set_var_types(VarTypes, !Info) :-
+ !Info ^ mgi_var_types := VarTypes.
+ml_gen_info_set_byref_output_vars(OutputVars, !Info) :-
+ !Info ^ mgi_byref_output_vars := OutputVars.
+ml_gen_info_set_value_output_vars(OutputVars, !Info) :-
+ !Info ^ mgi_value_output_vars := OutputVars.
+ml_gen_info_set_var_lvals(VarLvals, !Info) :-
+ !Info ^ mgi_var_lvals := VarLvals.
+ml_gen_info_set_global_data(GlobalData, !Info) :-
+ !Info ^ mgi_global_data := GlobalData.
+
+ml_gen_info_set_func_counter(FuncCounter, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_func_counter := FuncCounter,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_label_counter(LabelCounter, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_label_counter := LabelCounter,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_aux_var_counter(AuxVarCounter, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_aux_var_counter := AuxVarCounter,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_cond_var_counter(CondVarCounter, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_cond_var_counter := CondVarCounter,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_conv_var_counter(ConvVarCounter, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_conv_var_counter := ConvVarCounter,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_const_var_map(ConstVarMap, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_const_var_map := ConstVarMap,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_success_cont_stack(SuccessContStack, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_success_cont_stack := SuccessContStack,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_closure_wrapper_defns(ClosureWrapperDefns, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_closure_wrapper_defns := ClosureWrapperDefns,
+ !Info ^ mgi_sub_info := SubInfo.
+ml_gen_info_set_env_var_names(EnvVarNames, !Info) :-
+ SubInfo0 = !.Info ^ mgi_sub_info,
+ SubInfo = SubInfo0 ^ mgsi_env_var_names := EnvVarNames,
+ !Info ^ mgi_sub_info := SubInfo.
+
+ml_gen_info_get_module_name(Info, ModuleName) :-
+ ml_gen_info_get_module_info(Info, ModuleInfo),
+ module_info_get_name(ModuleInfo, ModuleName).
+
+ml_gen_info_use_gcc_nested_functions(Info, UseNestedFuncs) :-
+ ml_gen_info_get_globals(Info, Globals),
+ globals.lookup_bool_option(Globals, gcc_nested_functions,
+ UseNestedFuncs).
+
+ml_gen_info_put_commit_in_own_func(Info, PutCommitInNestedFunc) :-
+ ml_gen_info_get_globals(Info, Globals),
+ globals.lookup_bool_option(Globals, put_commit_in_own_func,
+ PutCommitInNestedFunc).
+
+ml_gen_info_get_globals(Info, Globals) :-
+ ml_gen_info_get_module_info(Info, ModuleInfo),
+ module_info_get_globals(ModuleInfo, Globals).
+
+ml_gen_info_new_func_label(Label, !Info) :-
+ ml_gen_info_get_func_counter(!.Info, Counter0),
+ counter.allocate(Label, Counter0, Counter),
+ ml_gen_info_set_func_counter(Counter, !Info).
+
+ml_gen_info_new_label(Label, !Info) :-
+ ml_gen_info_get_label_counter(!.Info, Counter0),
+ counter.allocate(Label, Counter0, Counter),
+ ml_gen_info_set_label_counter(Counter, !Info).
+
+ml_gen_info_bump_counters(!Info) :-
+ ml_gen_info_get_func_counter(!.Info, FuncLabelCounter0),
+ counter.allocate(FuncLabel, FuncLabelCounter0, _),
+ FuncLabelCounter = counter.init(FuncLabel + 10000),
+ ml_gen_info_set_func_counter(FuncLabelCounter, !Info).
+
+ml_gen_info_new_aux_var_name(Prefix, VarName, !Info) :-
+ ml_gen_info_get_aux_var_counter(!.Info, AuxVarCounter0),
+ counter.allocate(AuxVarNum, AuxVarCounter0, AuxVarCounter),
+ ml_gen_info_set_aux_var_counter(AuxVarCounter, !Info),
+
+ Name = Prefix ++ "_" ++ string.int_to_string(AuxVarNum),
+ VarName = mlds_var_name(Name, no).
+
+ml_gen_info_new_cond_var(cond_seq(CondNum), !Info) :-
+ ml_gen_info_get_cond_var_counter(!.Info, CondCounter0),
+ counter.allocate(CondNum, CondCounter0, CondCounter),
+ ml_gen_info_set_cond_var_counter(CondCounter, !Info).
+
+ml_gen_info_new_conv_var(conv_seq(ConvNum), !Info) :-
+ ml_gen_info_get_conv_var_counter(!.Info, ConvCounter0),
+ counter.allocate(ConvNum, ConvCounter0, ConvCounter),
+ ml_gen_info_set_conv_var_counter(ConvCounter, !Info).
+
+ml_gen_info_set_const_var(Var, GroundTerm, !Info) :-
+ ml_gen_info_get_const_var_map(!.Info, ConstVarMap0),
+ % We cannot call map.det_insert, because we do not (yet) clean up the
+ % const_var_map at the start of later branches of a branched goal,
+ % and thus when generating code for a later branch, we may come across
+ % an entry left by an earlier branch. Using map.set instead throws away
+ % such obsolete entries.
+ map.set(ConstVarMap0, Var, GroundTerm, ConstVarMap),
+ ml_gen_info_set_const_var_map(ConstVarMap, !Info).
+
+ml_gen_info_lookup_const_var(Info, Var, GroundTerm) :-
+ ml_gen_info_get_const_var_map(Info, ConstVarMap),
+ map.lookup(ConstVarMap, Var, GroundTerm).
+
+ml_gen_info_search_const_var(Info, Var, GroundTerm) :-
+ ml_gen_info_get_const_var_map(Info, ConstVarMap),
+ map.search(ConstVarMap, Var, GroundTerm).
+
+ml_gen_info_push_success_cont(SuccCont, !Info) :-
+ ml_gen_info_get_success_cont_stack(!.Info, Stack0),
+ stack.push(Stack0, SuccCont, Stack),
+ ml_gen_info_set_success_cont_stack(Stack, !Info).
+
+ml_gen_info_pop_success_cont(!Info) :-
+ ml_gen_info_get_success_cont_stack(!.Info, Stack0),
+ stack.pop_det(Stack0, _SuccCont, Stack),
+ ml_gen_info_set_success_cont_stack(Stack, !Info).
+
+ml_gen_info_current_success_cont(Info, SuccCont) :-
+ ml_gen_info_get_success_cont_stack(Info, Stack),
+ stack.top_det(Stack, SuccCont).
+
+ml_gen_info_set_var_lval(Var, Lval, !Info) :-
+ ml_gen_info_get_var_lvals(!.Info, VarLvals0),
+ map.set(VarLvals0, Var, Lval, VarLvals),
+ ml_gen_info_set_var_lvals(VarLvals, !Info).
+
+ml_gen_info_add_closure_wrapper_defn(ClosureWrapperDefn, !Info) :-
+ ml_gen_info_get_closure_wrapper_defns(!.Info, ClosureWrapperDefns0),
+ ClosureWrapperDefns = [ClosureWrapperDefn | ClosureWrapperDefns0],
+ ml_gen_info_set_closure_wrapper_defns(ClosureWrapperDefns, !Info).
+
+ml_gen_info_add_env_var_name(Name, !Info) :-
+ ml_gen_info_get_env_var_names(!.Info, EnvVarNames0),
+ set.insert(EnvVarNames0, Name, EnvVarNames),
+ ml_gen_info_set_env_var_names(EnvVarNames, !Info).
+
+%-----------------------------------------------------------------------------%
+:- end_module ml_gen_info.
+%-----------------------------------------------------------------------------%
Index: compiler/ml_lookup_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_lookup_switch.m,v
retrieving revision 1.1
diff -u -b -r1.1 ml_lookup_switch.m
--- compiler/ml_lookup_switch.m 21 Sep 2009 04:08:56 -0000 1.1
+++ compiler/ml_lookup_switch.m 23 Sep 2009 16:34:59 -0000
@@ -17,7 +17,7 @@
:- import_module backend_libs.switch_util.
:- import_module hlds.code_model.
:- import_module hlds.hlds_goal.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -45,6 +45,7 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_global_data.
:- import_module assoc_list.
Index: compiler/ml_proc_gen.m
===================================================================
RCS file: compiler/ml_proc_gen.m
diff -N compiler/ml_proc_gen.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/ml_proc_gen.m 23 Sep 2009 16:36:23 -0000
@@ -0,0 +1,970 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ml_proc_gen.m.
+% Main author: fjh.
+%
+
+:- module ml_backend.ml_proc_gen.
+:- interface.
+
+:- import_module hlds.hlds_module.
+:- import_module ml_backend.mlds.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ % Generate MLDS code for an entire module.
+ %
+:- pred ml_code_gen(module_info::in, module_info::out, mlds::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module backend_libs.foreign. % XXX needed for foreign_proc
+:- import_module backend_libs.rtti.
+:- import_module check_hlds.mode_util.
+:- import_module hlds.code_model.
+:- import_module hlds.goal_util.
+:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.passes_aux.
+:- import_module hlds.pred_table.
+:- import_module hlds.quantification.
+:- import_module libs.compiler_util.
+:- import_module libs.globals.
+:- import_module libs.options.
+:- import_module mdbcomp.prim_data.
+:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
+:- import_module ml_backend.ml_global_data.
+:- import_module ml_backend.ml_type_gen.
+:- import_module ml_backend.ml_util.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_foreign.
+:- import_module parse_tree.prog_type.
+
+:- import_module bool.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module pair.
+:- import_module set.
+:- import_module std_util.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ml_code_gen(!ModuleInfo, MLDS) :-
+ module_info_get_name(!.ModuleInfo, ModuleName),
+ ml_gen_foreign_code(!.ModuleInfo, ForeignCode),
+ ml_gen_imports(!.ModuleInfo, Imports),
+ ml_gen_defns(!ModuleInfo, Defns, GlobalData),
+ ml_gen_exported_enums(!.ModuleInfo, ExportedEnums),
+ module_info_user_init_pred_c_names(!.ModuleInfo, InitPreds),
+ module_info_user_final_pred_c_names(!.ModuleInfo, FinalPreds),
+ MLDS = mlds(ModuleName, ForeignCode, Imports, GlobalData, Defns,
+ InitPreds, FinalPreds, ExportedEnums).
+
+:- pred ml_gen_foreign_code(module_info::in,
+ map(foreign_language, mlds_foreign_code)::out) is det.
+
+ml_gen_foreign_code(ModuleInfo, AllForeignCode) :-
+ module_info_get_foreign_decl(ModuleInfo, ForeignDecls),
+ module_info_get_foreign_import_module(ModuleInfo, ForeignImports),
+ module_info_get_foreign_body_code(ModuleInfo, ForeignBodys),
+ module_info_get_pragma_exported_procs(ModuleInfo, ForeignExports),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_backend_foreign_languages(Globals, BackendForeignLanguages),
+
+ WantedForeignImports = list.condense(
+ list.map((func(L) = Imports :-
+ foreign.filter_imports(L, ForeignImports, Imports, _)
+ ), BackendForeignLanguages)),
+
+ list.foldl(ml_gen_foreign_code_lang(ModuleInfo, ForeignDecls,
+ ForeignBodys, WantedForeignImports, ForeignExports),
+ BackendForeignLanguages, map.init, AllForeignCode).
+
+:- pred ml_gen_foreign_code_lang(module_info::in, foreign_decl_info::in,
+ foreign_body_info::in, foreign_import_module_info_list::in,
+ list(pragma_exported_proc)::in, foreign_language::in,
+ map(foreign_language, mlds_foreign_code)::in,
+ map(foreign_language, mlds_foreign_code)::out) is det.
+
+ml_gen_foreign_code_lang(ModuleInfo, ForeignDecls, ForeignBodys,
+ WantedForeignImports, ForeignExports, Lang, Map0, Map) :-
+ foreign.filter_decls(Lang, ForeignDecls, WantedForeignDecls,
+ _OtherForeignDecls),
+ foreign.filter_bodys(Lang, ForeignBodys, WantedForeignBodys,
+ _OtherForeignBodys),
+ foreign.filter_exports(Lang, ForeignExports, WantedForeignExports,
+ _OtherForeignExports),
+ ConvBody = (func(foreign_body_code(L, S, C)) =
+ user_foreign_code(L, S, C)),
+ MLDSWantedForeignBodys = list.map(ConvBody, WantedForeignBodys),
+ list.map(ml_gen_pragma_export_proc(ModuleInfo),
+ WantedForeignExports, MLDSWantedForeignExports),
+ MLDS_ForeignCode = mlds_foreign_code(WantedForeignDecls,
+ WantedForeignImports, MLDSWantedForeignBodys,
+ MLDSWantedForeignExports),
+ map.det_insert(Map0, Lang, MLDS_ForeignCode, Map).
+
+:- pred ml_gen_imports(module_info::in, mlds_imports::out) is det.
+
+ml_gen_imports(ModuleInfo, MLDS_ImportList) :-
+ % Determine all the mercury imports.
+ % XXX This is overly conservative, i.e. we import more than we really need.
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ module_info_get_all_deps(ModuleInfo, AllImports0),
+ % No module needs to import itself.
+ module_info_get_name(ModuleInfo, ThisModule),
+ AllImports = set.delete(AllImports0, ThisModule),
+ P = (func(Name) = mercury_import(compiler_visible_interface,
+ mercury_module_name_to_mlds(Name))),
+
+ % For every foreign type determine the import needed to find
+ % the declaration for that type.
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
+ ForeignTypeImports = list.condense(
+ list.map(foreign_type_required_imports(Target), TypeCtorsDefns)),
+
+ MLDS_ImportList = ForeignTypeImports ++
+ list.map(P, set.to_sorted_list(AllImports)).
+
+:- func foreign_type_required_imports(compilation_target,
+ pair(type_ctor, hlds_type_defn)) = list(mlds_import).
+
+foreign_type_required_imports(Target, _TypeCtor - TypeDefn) = Imports :-
+ (
+ ( Target = target_c
+ ; Target = target_java
+ ; Target = target_asm
+ ),
+ Imports = []
+ ;
+ Target = target_il,
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
+ (
+ TypeBody = hlds_foreign_type(ForeignTypeBody),
+ ForeignTypeBody = foreign_type_body(MaybeIL,
+ _MaybeC, _MaybeJava, _MaybeErlang),
+ (
+ MaybeIL = yes(Data),
+ Data = foreign_type_lang_data(il_type(_, Location, _), _, _)
+ ->
+ Name = il_assembly_name(mercury_module_name_to_mlds(
+ unqualified(Location))),
+ Imports = [foreign_import(Name)]
+ ;
+ unexpected(this_file, "no IL type")
+ )
+ ;
+ ( TypeBody = hlds_du_type(_, _, _,_, _, _, _, _)
+ ; TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
+ Imports = []
+ )
+ ;
+ Target = target_x86_64,
+ unexpected(this_file, "target x86_64 and --high-level-code")
+ ;
+ Target = target_erlang,
+ unexpected(this_file, "foreign_type_required_imports: target erlang")
+ ).
+
+:- pred ml_gen_defns(module_info::in, module_info::out,
+ list(mlds_defn)::out, ml_global_data::out) is det.
+
+ml_gen_defns(!ModuleInfo, Defns, GlobalData) :-
+ ml_gen_types(!.ModuleInfo, TypeDefns),
+ ml_gen_table_structs(!.ModuleInfo, TableStructDefns),
+ ml_gen_preds(!ModuleInfo, PredDefns, GlobalData),
+ Defns = TypeDefns ++ TableStructDefns ++ PredDefns.
+
+%-----------------------------------------------------------------------------%
+%
+% For each pragma foreign_export declaration we associate with it the
+% information used to generate the function prototype for the MLDS entity.
+%
+
+:- pred ml_gen_pragma_export_proc(module_info::in, pragma_exported_proc::in,
+ mlds_pragma_export::out) is det.
+
+ml_gen_pragma_export_proc(ModuleInfo, PragmaExportedProc, Defn) :-
+ PragmaExportedProc = pragma_exported_proc(Lang, PredId, ProcId,
+ ExportName, ProgContext),
+ ml_gen_proc_label(ModuleInfo, PredId, ProcId, Name, ModuleName),
+ FuncParams = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+ MLDS_Context = mlds_make_context(ProgContext),
+ Defn = ml_pragma_export(Lang, ExportName,
+ qual(ModuleName, module_qual, Name), FuncParams, MLDS_Context).
+
+%-----------------------------------------------------------------------------%
+%
+% Stuff to generate MLDS code for HLDS predicates & functions.
+%
+
+ % Generate MLDS definitions for all the non-imported predicates
+ % (and functions) in the HLDS.
+ %
+:- pred ml_gen_preds(module_info::in, module_info::out,
+ list(mlds_defn)::out, ml_global_data::out) is det.
+
+ml_gen_preds(!ModuleInfo, PredDefns, GlobalData) :-
+ module_info_preds(!.ModuleInfo, PredTable),
+ map.keys(PredTable, PredIds),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ (
+ Target = target_c,
+ UseCommonCells = use_common_cells
+ ;
+ ( Target = target_asm
+ ; Target = target_java
+ ; Target = target_il
+ ; Target = target_erlang
+ ; Target = target_x86_64
+ ),
+ UseCommonCells = do_not_use_common_cells
+ ),
+ GlobalData0 = ml_global_data_init(UseCommonCells),
+ ml_gen_preds_2(!ModuleInfo, PredIds, [], PredDefns,
+ GlobalData0, GlobalData).
+
+:- pred ml_gen_preds_2(module_info::in, module_info::out, list(pred_id)::in,
+ list(mlds_defn)::in, list(mlds_defn)::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_preds_2(!ModuleInfo, PredIds0, !Defns, !GlobalDefns) :-
+ (
+ PredIds0 = [PredId | PredIds],
+ module_info_preds(!.ModuleInfo, PredTable),
+ map.lookup(PredTable, PredId, PredInfo),
+ pred_info_get_import_status(PredInfo, ImportStatus),
+ (
+ (
+ ImportStatus = status_imported(_)
+ ;
+ % We generate incorrect and unnecessary code for the external
+ % special preds which are pseudo_imported, so just ignore them.
+ is_unify_or_compare_pred(PredInfo),
+ ImportStatus = status_external(status_pseudo_imported)
+ )
+ ->
+ true
+ ;
+ ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
+ !GlobalDefns)
+ ),
+ ml_gen_preds_2(!ModuleInfo, PredIds, !Defns, !GlobalDefns)
+ ;
+ PredIds0 = []
+ ).
+
+ % Generate MLDS definitions for all the non-imported procedures
+ % of a given predicate (or function).
+ %
+:- pred ml_gen_pred(module_info::in, module_info::out, pred_id::in,
+ pred_info::in, import_status::in,
+ list(mlds_defn)::in, list(mlds_defn)::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
+ !GlobalData) :-
+ ( ImportStatus = status_external(_) ->
+ ProcIds = pred_info_procids(PredInfo)
+ ;
+ ProcIds = pred_info_non_imported_procids(PredInfo)
+ ),
+ (
+ ProcIds = []
+ ;
+ ProcIds = [_ | _],
+ trace [io(!IO)] (
+ write_pred_progress_message("% Generating MLDS code for ",
+ PredId, !.ModuleInfo, !IO)
+ ),
+ ml_gen_procs(!ModuleInfo, PredId, ProcIds, !Defns, !GlobalData)
+ ).
+
+:- pred ml_gen_procs(module_info::in, module_info::out,
+ pred_id::in, list(proc_id)::in,
+ list(mlds_defn)::in, list(mlds_defn)::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_procs(!ModuleInfo, _, [], !Defns, !GlobalData).
+ml_gen_procs(!ModuleInfo, PredId, [ProcId | ProcIds], !Defns, !GlobalData) :-
+ ml_gen_proc(!ModuleInfo, PredId, ProcId, !Defns, !GlobalData),
+ ml_gen_procs(!ModuleInfo, PredId, ProcIds, !Defns, !GlobalData).
+
+%-----------------------------------------------------------------------------%
+%
+% Code for handling individual procedures.
+%
+
+:- pred ml_gen_proc(module_info::in, module_info::out,
+ pred_id::in, proc_id::in, list(mlds_defn)::in, list(mlds_defn)::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_proc(!ModuleInfo, PredId, ProcId, !Defns, !GlobalData) :-
+ % The specification of the HLDS allows goal_infos to overestimate
+ % the set of non-locals. Such overestimates are bad for us for two reasons:
+ %
+ % - If the non-locals of the top-level goal contained any variables other
+ % than head vars, those variables would not be declared.
+ %
+ % - The code of goal_expr_find_subgoal_nonlocals depends on the nonlocals
+ % sets of goals being exactly correct, since this is the only way it can
+ % avoid traversing the entirety of the goals themselves. Such traversals
+ % can be very expensive on large goals, since it would have to be done
+ % repeatedly, once for each containing goal. Quantification does just one
+ % traversal.
+
+ module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
+ PredInfo, ProcInfo0),
+ requantify_proc_general(ordinary_nonlocals_no_lambda, ProcInfo0, ProcInfo),
+ module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
+ !ModuleInfo),
+
+ pred_info_get_import_status(PredInfo, ImportStatus),
+ pred_info_get_arg_types(PredInfo, ArgTypes),
+ CodeModel = proc_info_interface_code_model(ProcInfo),
+ proc_info_get_headvars(ProcInfo, HeadVars),
+ proc_info_get_argmodes(ProcInfo, Modes),
+ proc_info_get_goal(ProcInfo, Goal),
+
+ Goal = hlds_goal(_GoalExpr, GoalInfo),
+ Context = goal_info_get_context(GoalInfo),
+
+ some [!Info] (
+ !:Info = ml_gen_info_init(!.ModuleInfo, PredId, ProcId, ProcInfo,
+ !.GlobalData),
+
+ ( ImportStatus = status_external(_) ->
+ % For Mercury procedures declared `:- external', we generate an
+ % MLDS definition for them with no function body. The MLDS ->
+ % target code pass can treat this accordingly, e.g. for C
+ % it outputs a function declaration with no corresponding
+ % definition, making sure that the function is declared as `extern'
+ % rather than `static'.
+ %
+ FunctionBody = body_external,
+ ExtraDefns = [],
+ ml_gen_proc_params(PredId, ProcId, MLDS_Params, !.Info, _Info)
+ ;
+ % Set up the initial success continuation, if any.
+ % Also figure out which output variables are returned by value
+ % (rather than being passed by reference) and remove them from
+ % the byref_output_vars field in the ml_gen_info.
+ (
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
+ ml_det_copy_out_vars(!.ModuleInfo, CopiedOutputVars, !Info)
+ ;
+ CodeModel = model_non,
+ ml_set_up_initial_succ_cont(!.ModuleInfo, CopiedOutputVars,
+ !Info)
+ ),
+
+ % This would generate all the local variables at the top of
+ % the function:
+ % ml_gen_all_local_var_decls(Goal,
+ % VarSet, VarTypes, HeadVars, MLDS_LocalVars, Info1, Info2)
+ % But instead we now generate them locally for each goal.
+ % We just declare the `succeeded' var here, plus locals
+ % for any output arguments that are returned by value
+ % (e.g. if --nondet-copy-out is enabled, or for det function
+ % return values).
+ (
+ CopiedOutputVars = [],
+ % Optimize common case.
+ OutputVarLocals = []
+ ;
+ CopiedOutputVars = [_ | _],
+ proc_info_get_varset(ProcInfo, VarSet),
+ proc_info_get_vartypes(ProcInfo, VarTypes),
+ % Note that for headvars we must use the types from
+ % the procedure interface, not from the procedure body.
+ HeadVarTypes = map.from_corresponding_lists(HeadVars,
+ ArgTypes),
+ ml_gen_local_var_decls(VarSet,
+ map.overlay(VarTypes, HeadVarTypes),
+ Context, CopiedOutputVars, OutputVarLocals, !Info)
+ ),
+ MLDS_Context = mlds_make_context(Context),
+ MLDS_LocalVars = [ml_gen_succeeded_var_decl(MLDS_Context) |
+ OutputVarLocals],
+ modes_to_arg_modes(!.ModuleInfo, Modes, ArgTypes, ArgModes),
+ ml_gen_proc_body(CodeModel, HeadVars, ArgTypes, ArgModes,
+ CopiedOutputVars, Goal, Defns0, Statements, !Info),
+ ml_gen_proc_params(PredId, ProcId, MLDS_Params, !Info),
+ ml_gen_info_get_closure_wrapper_defns(!.Info, ExtraDefns),
+ ml_gen_info_get_global_data(!.Info, !:GlobalData),
+ Defns = MLDS_LocalVars ++ Defns0,
+ Statement = ml_gen_block(Defns, Statements, Context),
+ FunctionBody = body_defined_here(Statement)
+
+ ),
+ % XXX Can env_var_names be affected by body_external?
+ % If, as I (zs) suspect, it cannot, this should be inside the previous
+ % scope.
+ ml_gen_info_get_env_var_names(!.Info, EnvVarNames)
+ ),
+
+ proc_info_get_context(ProcInfo0, ProcContext),
+ ml_gen_proc_label(!.ModuleInfo, PredId, ProcId, EntityName, _ModuleName),
+ MLDS_ProcContext = mlds_make_context(ProcContext),
+ DeclFlags = ml_gen_proc_decl_flags(!.ModuleInfo, PredId, ProcId),
+ MaybePredProcId = yes(proc(PredId, ProcId)),
+ pred_info_get_attributes(PredInfo, Attributes),
+ attributes_to_attribute_list(Attributes, AttributeList),
+ MLDS_Attributes =
+ attributes_to_mlds_attributes(!.ModuleInfo, AttributeList),
+ EntityBody = mlds_function(MaybePredProcId, MLDS_Params,
+ FunctionBody, MLDS_Attributes, EnvVarNames),
+ ProcDefn = mlds_defn(EntityName, MLDS_ProcContext, DeclFlags, EntityBody),
+ !:Defns = ExtraDefns ++ [ProcDefn | !.Defns].
+
+ % Return the declaration flags appropriate for a procedure definition.
+ %
+:- func ml_gen_proc_decl_flags(module_info, pred_id, proc_id)
+ = mlds_decl_flags.
+
+ml_gen_proc_decl_flags(ModuleInfo, PredId, ProcId) = DeclFlags :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ ( procedure_is_exported(ModuleInfo, PredInfo, ProcId) ->
+ Access = acc_public
+ ;
+ Access = acc_private
+ ),
+ PerInstance = one_copy,
+ Virtuality = non_virtual,
+ Finality = overridable,
+ Constness = modifiable,
+ Abstractness = concrete,
+ DeclFlags = init_decl_flags(Access, PerInstance,
+ Virtuality, Finality, Constness, Abstractness).
+
+ % For model_det and model_semi procedures, figure out which output
+ % variables are returned by value (rather than being passed by reference)
+ % and remove them from the byref_output_vars field in the ml_gen_info.
+ %
+:- pred ml_det_copy_out_vars(module_info::in, list(prog_var)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_det_copy_out_vars(ModuleInfo, CopiedOutputVars, !Info) :-
+ ml_gen_info_get_byref_output_vars(!.Info, OutputVars),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, det_copy_out, DetCopyOut),
+ (
+ % If --det-copy-out is enabled, all non-dummy output variables are
+ % returned by value, rather than passing them by reference.
+ DetCopyOut = yes,
+ ByRefOutputVars = [],
+ ml_gen_info_get_var_types(!.Info, VarTypes),
+ list.filter(var_is_of_dummy_type(ModuleInfo, VarTypes), OutputVars,
+ _, CopiedOutputVars)
+ ;
+ DetCopyOut = no,
+ (
+ % For det functions, the function result variable is returned by
+ % value, and any remaining output variables are passed by
+ % reference.
+ ml_gen_info_get_pred_id(!.Info, PredId),
+ ml_gen_info_get_proc_id(!.Info, ProcId),
+ ml_is_output_det_function(ModuleInfo, PredId, ProcId, ResultVar)
+ ->
+ CopiedOutputVars = [ResultVar],
+ list.delete_all(OutputVars, ResultVar, ByRefOutputVars)
+ ;
+ % Otherwise, all output vars are passed by reference.
+ CopiedOutputVars = [],
+ ByRefOutputVars = OutputVars
+ )
+ ),
+ ml_gen_info_set_byref_output_vars(ByRefOutputVars, !Info),
+ ml_gen_info_set_value_output_vars(CopiedOutputVars, !Info).
+
+ % For model_non procedures, figure out which output variables are returned
+ % by value (rather than being passed by reference) and remove them from
+ % the byref_output_vars field in the ml_gen_info, and construct the
+ % initial success continuation.
+ %
+:- pred ml_set_up_initial_succ_cont(module_info::in, list(prog_var)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_set_up_initial_succ_cont(ModuleInfo, NondetCopiedOutputVars, !Info) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, nondet_copy_out, NondetCopyOut),
+ (
+ NondetCopyOut = yes,
+ % For --nondet-copy-out, we generate local variables for the output
+ % variables and then pass them to the continuation, rather than
+ % passing them by reference.
+ ml_gen_info_get_byref_output_vars(!.Info, NondetCopiedOutputVars),
+ ml_gen_info_set_byref_output_vars([], !Info)
+ ;
+ NondetCopyOut = no,
+ NondetCopiedOutputVars = []
+ ),
+ ml_gen_info_set_value_output_vars(NondetCopiedOutputVars, !Info),
+ ml_gen_var_list(!.Info, NondetCopiedOutputVars, OutputVarLvals),
+ ml_variable_types(!.Info, NondetCopiedOutputVars, OutputVarTypes),
+ ml_initial_cont(!.Info, OutputVarLvals, OutputVarTypes, InitialCont),
+ ml_gen_info_push_success_cont(InitialCont, !Info).
+
+ % Generate MLDS definitions for all the local variables in a function.
+ %
+ % Note that this function generates all the local variables at the
+ % top of the function. It might be a better idea to instead generate
+ % local declarations for all the variables used in each sub-goal.
+ %
+:- pred ml_gen_all_local_var_decls(hlds_goal::in, prog_varset::in,
+ vartypes::in, list(prog_var)::in, list(mlds_defn)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_all_local_var_decls(Goal, VarSet, VarTypes, HeadVars, MLDS_LocalVars,
+ !Info) :-
+ Goal = hlds_goal(_, GoalInfo),
+ Context = goal_info_get_context(GoalInfo),
+ goal_util.goal_vars(Goal, AllVarsSet),
+ set.delete_list(AllVarsSet, HeadVars, LocalVarsSet),
+ set.to_sorted_list(LocalVarsSet, LocalVars),
+ ml_gen_local_var_decls(VarSet, VarTypes, Context, LocalVars,
+ MLDS_LocalVars0, !Info),
+ MLDS_Context = mlds_make_context(Context),
+ MLDS_SucceededVar = ml_gen_succeeded_var_decl(MLDS_Context),
+ MLDS_LocalVars = [MLDS_SucceededVar | MLDS_LocalVars0].
+
+ % Generate the code for a procedure body.
+ %
+:- pred ml_gen_proc_body(code_model::in, list(prog_var)::in,
+ list(mer_type)::in, list(arg_mode)::in, list(prog_var)::in,
+ hlds_goal::in, list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_proc_body(CodeModel, HeadVars, ArgTypes, ArgModes, CopiedOutputVars,
+ Goal, Decls, Statements, !Info) :-
+ Goal = hlds_goal(_, GoalInfo),
+ Context = goal_info_get_context(GoalInfo),
+
+ % First just generate the code for the procedure's goal.
+
+ % In certain cases -- for example existentially typed procedures,
+ % or unification/compare procedures for equivalence types --
+ % the parameters types may not match the types of the head variables.
+ % In such cases, we need to box/unbox/cast them to the right type.
+ % We also grab the original (uncast) lvals for the copied output
+ % variables (if any) here, since for the return statement that
+ % we append below, we want the original vars, not their cast versions.
+
+ ml_gen_var_list(!.Info, CopiedOutputVars, CopiedOutputVarOriginalLvals),
+ ml_gen_convert_headvars(HeadVars, ArgTypes, ArgModes, CopiedOutputVars,
+ Context, ConvDecls, ConvInputStatements, ConvOutputStatements, !Info),
+ (
+ ConvDecls = [],
+ ConvInputStatements = [],
+ ConvOutputStatements = []
+ ->
+ % No boxing/unboxing/casting required.
+ ml_gen_goal(CodeModel, Goal, Decls, Statements1, !Info)
+ ;
+ DoGenGoal = ml_gen_goal(CodeModel, Goal),
+
+ % Boxing/unboxing/casting required. We need to convert the input
+ % arguments, generate the goal, convert the output arguments,
+ % and then succeeed.
+ DoConvOutputs = (pred(NewDecls::out, NewStatements::out,
+ Info0::in, Info::out) is det :-
+ ml_gen_success(CodeModel, Context, SuccStatements, Info0, Info),
+ NewDecls = [],
+ NewStatements = ConvOutputStatements ++ SuccStatements
+ ),
+ ml_combine_conj(CodeModel, Context, DoGenGoal, DoConvOutputs,
+ Decls0, Statements0, !Info),
+ Statements1 = ConvInputStatements ++ Statements0,
+ Decls = ConvDecls ++ Decls0
+ ),
+
+ % Finally append an appropriate `return' statement, if needed.
+ ml_append_return_statement(!.Info, CodeModel, CopiedOutputVarOriginalLvals,
+ Context, Statements1, Statements).
+
+ % In certain cases -- for example existentially typed procedures,
+ % or unification/compare procedures for equivalence types --
+ % the parameter types may not match the types of the head variables.
+ % In such cases, we need to box/unbox/cast them to the right type.
+ % This procedure handles that.
+ %
+:- pred ml_gen_convert_headvars(list(prog_var)::in, list(mer_type)::in,
+ list(arg_mode)::in, list(prog_var)::in, prog_context::in,
+ list(mlds_defn)::out, list(statement)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_convert_headvars(Vars, HeadTypes, ArgModes, CopiedOutputVars, Context,
+ Decls, InputStatements, OutputStatements, !Info) :-
+ (
+ Vars = [],
+ HeadTypes = [],
+ ArgModes = []
+ ->
+ Decls = [],
+ InputStatements = [],
+ OutputStatements = []
+ ;
+ Vars = [Var | VarsTail],
+ HeadTypes = [HeadType | HeadTypesTail],
+ ArgModes = [ArgMode | ArgModesTail]
+ ->
+ ml_variable_type(!.Info, Var, BodyType),
+ (
+ % Arguments with mode `top_unused' do not need to be converted.
+ ArgMode = top_unused
+ ->
+ ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
+ CopiedOutputVars, Context, Decls,
+ InputStatements, OutputStatements, !Info)
+ ;
+ % Check whether HeadType is the same as BodyType
+ % (modulo the term.contexts). If so, no conversion is needed.
+ map.init(Subst0),
+ type_unify(HeadType, BodyType, [], Subst0, Subst),
+ map.is_empty(Subst)
+ ->
+ ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
+ CopiedOutputVars, Context, Decls,
+ InputStatements, OutputStatements, !Info)
+ ;
+ % Generate the lval for the head variable.
+ ml_gen_var_with_type(!.Info, Var, HeadType, HeadVarLval),
+
+ % Generate code to box or unbox that head variable,
+ % to convert its type from HeadType to BodyType.
+ ml_gen_info_get_varset(!.Info, VarSet),
+ VarName = ml_gen_var_name(VarSet, Var),
+ ml_gen_box_or_unbox_lval(HeadType, BodyType, native_if_possible,
+ HeadVarLval, VarName, Context, no, 0, BodyLval, ConvDecls,
+ ConvInputStatements, ConvOutputStatements, !Info),
+
+ % Ensure that for any uses of this variable in the procedure body,
+ % we use the BodyLval (which has type BodyType) rather than the
+ % HeadVarLval (which has type HeadType).
+ ml_gen_info_set_var_lval(Var, BodyLval, !Info),
+
+ ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
+ CopiedOutputVars, Context, DeclsTail,
+ InputStatementsTail, OutputStatementsTail, !Info),
+
+ % Add the code to convert this input or output.
+ ml_gen_info_get_byref_output_vars(!.Info, ByRefOutputVars),
+ (
+ ( list.member(Var, ByRefOutputVars)
+ ; list.member(Var, CopiedOutputVars)
+ )
+ ->
+ InputStatements = InputStatementsTail,
+ OutputStatements = OutputStatementsTail ++ ConvOutputStatements
+ ;
+ InputStatements = ConvInputStatements ++ InputStatementsTail,
+ OutputStatements = OutputStatementsTail
+ ),
+ Decls = ConvDecls ++ DeclsTail
+ )
+ ;
+ unexpected(this_file, "ml_gen_convert_headvars: length mismatch")
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Code for handling tabling structures.
+%
+
+:- pred ml_gen_table_structs(module_info::in, list(mlds_defn)::out) is det.
+
+ml_gen_table_structs(ModuleInfo, Defns) :-
+ module_info_get_table_struct_map(ModuleInfo, TableStructMap),
+ map.to_assoc_list(TableStructMap, TableStructs),
+ (
+ TableStructs = [],
+ Defns = []
+ ;
+ TableStructs = [_ | _],
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_gc_method(Globals, GC_Method),
+ % XXX To handle accurate GC properly, the GC would need to trace
+ % through the global variables that we generate for the tables.
+ % Support for this is not yet implemented. Also, we would need to add
+ % GC support (stack frame registration, and calls to MR_GC_check()) to
+ % MR_make_long_lived() and MR_deep_copy() so that we do garbage
+ % collection of the "global heap" which is used to store the tables.
+ expect(isnt(unify(gc_accurate), GC_Method), this_file,
+ "tabling and `--gc accurate'"),
+
+ list.foldl(ml_gen_add_table_var(ModuleInfo), TableStructs, [], Defns)
+ ).
+
+:- pred ml_gen_add_table_var(module_info::in,
+ pair(pred_proc_id, table_struct_info)::in,
+ list(mlds_defn)::in, list(mlds_defn)::out) is det.
+
+ml_gen_add_table_var(ModuleInfo, PredProcId - TableStructInfo, !Defns) :-
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ PredProcId = proc(_PredId, ProcId),
+
+ TableStructInfo = table_struct_info(ProcTableStructInfo, _Attributes),
+ ProcTableStructInfo = proc_table_struct_info(RttiProcLabel, _TVarSet,
+ Context, NumInputs, NumOutputs, InputSteps, MaybeOutputSteps,
+ _ArgInfos, EvalMethod),
+
+ ml_gen_pred_label_from_rtti(ModuleInfo, RttiProcLabel, PredLabel,
+ _PredModule),
+ MLDS_ProcLabel = mlds_proc_label(PredLabel, ProcId),
+ MLDS_Context = mlds_make_context(Context),
+ TableTypeStr = eval_method_to_table_type(EvalMethod),
+ (
+ InputSteps = [],
+ % We don't want to generate arrays with zero elements.
+ InputStepsRefInit = gen_init_null_pointer(
+ mlds_tabling_type(tabling_steps_desc(call_table))),
+ InputStepsDefns = []
+ ;
+ InputSteps = [_ | _],
+ InputStepsRefInit = gen_init_tabling_name(MLDS_ModuleName,
+ MLDS_ProcLabel, tabling_steps_desc(call_table)),
+ InputStepsInit = init_array(
+ list.map(init_step_desc(tabling_steps_desc(call_table)),
+ InputSteps)),
+ InputStepsDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
+ MLDS_Context, const, tabling_steps_desc(call_table),
+ InputStepsInit),
+ InputStepsDefns = [InputStepsDefn]
+ ),
+ init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
+ call_table, curr_table, InputSteps,
+ CallStatsInit, CallStatsDefns),
+ init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
+ call_table, prev_table, InputSteps,
+ PrevCallStatsInit, PrevCallStatsDefns),
+ CallDefns = InputStepsDefns ++ CallStatsDefns ++ PrevCallStatsDefns,
+ (
+ MaybeOutputSteps = no,
+ HasAnswerTable = 0,
+ OutputStepsRefInit = gen_init_null_pointer(
+ mlds_tabling_type(tabling_steps_desc(answer_table))),
+ OutputStepsDefns = []
+ ;
+ MaybeOutputSteps = yes(OutputSteps),
+ HasAnswerTable = 1,
+ OutputStepsRefInit = gen_init_tabling_name(MLDS_ModuleName,
+ MLDS_ProcLabel, tabling_steps_desc(answer_table)),
+ OutputStepsInit = init_array(
+ list.map(init_step_desc(tabling_steps_desc(answer_table)),
+ OutputSteps)),
+ OutputStepsDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
+ MLDS_Context, const, tabling_steps_desc(answer_table),
+ OutputStepsInit),
+ OutputStepsDefns = [OutputStepsDefn]
+ ),
+ init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
+ answer_table, curr_table, InputSteps,
+ AnswerStatsInit, AnswerStatsDefns),
+ init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
+ answer_table, prev_table, InputSteps,
+ PrevAnswerStatsInit, PrevAnswerStatsDefns),
+ AnswerDefns = OutputStepsDefns ++ AnswerStatsDefns ++ PrevAnswerStatsDefns,
+
+ PTIsRefInit = gen_init_null_pointer(mlds_tabling_type(tabling_ptis)),
+ TypeParamLocnsRefInit = gen_init_null_pointer(
+ mlds_tabling_type(tabling_type_param_locns)),
+ RootNodeInit = init_struct(mlds_tabling_type(tabling_root_node),
+ [gen_init_int(0)]),
+ TipsRefInit = gen_init_null_pointer(mlds_tabling_type(tabling_tips)),
+
+ ProcTableInfoInit = init_struct(mlds_tabling_type(tabling_info), [
+ gen_init_builtin_const(TableTypeStr),
+ gen_init_int(NumInputs),
+ gen_init_int(NumOutputs),
+ gen_init_int(HasAnswerTable),
+ PTIsRefInit,
+ TypeParamLocnsRefInit,
+ RootNodeInit,
+ init_array([InputStepsRefInit, OutputStepsRefInit]),
+ init_array([
+ init_array([CallStatsInit, PrevCallStatsInit]),
+ init_array([AnswerStatsInit, PrevAnswerStatsInit])
+ ]),
+ gen_init_int(0),
+ TipsRefInit,
+ gen_init_int(0),
+ gen_init_int(0)
+ ]),
+ ProcTableInfoDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
+ MLDS_Context, modifiable, tabling_info, ProcTableInfoInit),
+
+ !:Defns = CallDefns ++ AnswerDefns ++ [ProcTableInfoDefn | !.Defns].
+
+:- func init_step_desc(proc_tabling_struct_id, table_step_desc)
+ = mlds_initializer.
+
+init_step_desc(StructId, StepDesc) = init_struct(StructType, FieldInits) :-
+ StepDesc = table_step_desc(VarName, Step),
+ table_trie_step_to_c(Step, StepStr, MaybeEnumRange),
+ VarNameInit = gen_init_string(VarName),
+ StepInit = encode_enum_init(StepStr),
+ (
+ MaybeEnumRange = no,
+ MaybeEnumRangeInit = gen_init_int(-1)
+ ;
+ MaybeEnumRange = yes(EnumRange),
+ MaybeEnumRangeInit = gen_init_int(EnumRange)
+ ),
+ StructType = mlds_tabling_type(StructId),
+ FieldInits = [VarNameInit, StepInit, MaybeEnumRangeInit].
+
+:- pred init_stats(mlds_module_name::in, mlds_proc_label::in, mlds_context::in,
+ call_or_answer_table::in, curr_or_prev_table::in,
+ list(table_step_desc)::in, mlds_initializer::out, list(mlds_defn)::out)
+ is det.
+
+init_stats(MLDS_ModuleName, MLDS_ProcLabel, MLDS_Context,
+ CallOrAnswer, CurrOrPrev, StepDescs, StatsInit, StatsStepDefns) :-
+ StatsId = tabling_stats(CallOrAnswer, CurrOrPrev),
+ StatsStepsId = tabling_stat_steps(CallOrAnswer, CurrOrPrev),
+ StatsType = mlds_tabling_type(StatsId),
+ StatsStepsType = mlds_tabling_type(StatsStepsId),
+ (
+ StepDescs = [],
+ StatsStepDefns = [],
+ StatsStepsArrayRefInit = gen_init_null_pointer(StatsStepsType)
+ ;
+ StepDescs = [_ | _],
+ list.map(init_stats_step(StatsStepsId), StepDescs, StatsStepsInits),
+ StatsStepsArrayInit = init_array(StatsStepsInits),
+ StatsStepDefn = tabling_name_and_init_to_defn(MLDS_ProcLabel,
+ MLDS_Context, modifiable, StatsStepsId, StatsStepsArrayInit),
+ StatsStepDefns = [StatsStepDefn],
+ StatsStepsArrayRefInit = gen_init_tabling_name(MLDS_ModuleName,
+ MLDS_ProcLabel, tabling_stat_steps(CallOrAnswer, CurrOrPrev))
+ ),
+ StatsInit = init_struct(StatsType, [
+ gen_init_int(0),
+ gen_init_int(0),
+ StatsStepsArrayRefInit
+ ]).
+
+:- pred init_stats_step(proc_tabling_struct_id::in, table_step_desc::in,
+ mlds_initializer::out) is det.
+
+init_stats_step(StepId, StepDesc, Init) :-
+ StepDesc = table_step_desc(_VarName, Step),
+ KindStr = table_step_stats_kind(Step),
+ Init = init_struct(mlds_tabling_type(StepId), [
+ gen_init_int(0),
+ gen_init_int(0),
+ encode_enum_init(KindStr),
+
+ % The fields about hash tables.
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+
+ % The fields about enums.
+ gen_init_int(0),
+ gen_init_int(0),
+
+ % The fields about du types.
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+ gen_init_int(0),
+
+ % The fields about start tables.
+ gen_init_int(0),
+ gen_init_int(0)
+ ]).
+
+:- func encode_enum_init(string) = mlds_initializer.
+
+encode_enum_init(EnumConstName) =
+ init_obj(ml_const(mlconst_named_const(EnumConstName))).
+
+:- func gen_init_tabling_name(mlds_module_name, mlds_proc_label,
+ proc_tabling_struct_id) = mlds_initializer.
+
+gen_init_tabling_name(ModuleName, ProcLabel, TablingId) = Rval :-
+ DataAddr = data_addr(ModuleName, mlds_tabling_ref(ProcLabel, TablingId)),
+ Rval = init_obj(ml_const(mlconst_data_addr(DataAddr))).
+
+:- func tabling_name_and_init_to_defn(mlds_proc_label, mlds_context, constness,
+ proc_tabling_struct_id, mlds_initializer) = mlds_defn.
+
+tabling_name_and_init_to_defn(ProcLabel, MLDS_Context, Constness, Id,
+ Initializer) = Defn :-
+ GCStatement = gc_no_stmt,
+ MLDS_Type = mlds_tabling_type(Id),
+ Flags = tabling_data_decl_flags(Constness),
+ DefnBody = mlds_data(MLDS_Type, Initializer, GCStatement),
+ Name = entity_data(mlds_tabling_ref(ProcLabel, Id)),
+ Defn = mlds_defn(Name, MLDS_Context, Flags, DefnBody).
+
+ % Return the declaration flags appropriate for a tabling data structure.
+ %
+:- func tabling_data_decl_flags(constness) = mlds_decl_flags.
+
+tabling_data_decl_flags(Constness) = MLDS_DeclFlags :-
+ Access = acc_private,
+ PerInstance = one_copy,
+ Virtuality = non_virtual,
+ Finality = final,
+ Abstractness = concrete,
+ MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
+ Virtuality, Finality, Constness, Abstractness).
+
+%-----------------------------------------------------------------------------%
+%
+% Code for handling attributes.
+%
+
+:- func attributes_to_mlds_attributes(module_info, list(hlds_pred.attribute))
+ = list(mlds_attribute).
+
+attributes_to_mlds_attributes(ModuleInfo, Attrs) =
+ list.map(attribute_to_mlds_attribute(ModuleInfo), Attrs).
+
+:- func attribute_to_mlds_attribute(module_info, hlds_pred.attribute)
+ = mlds_attribute.
+
+attribute_to_mlds_attribute(ModuleInfo, custom(Type)) =
+ custom(mercury_type_to_mlds_type(ModuleInfo, Type)).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "ml_proc_gen.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module ml_proc_gen.
+%-----------------------------------------------------------------------------%
Index: compiler/ml_simplify_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_simplify_switch.m,v
retrieving revision 1.29
diff -u -b -r1.29 ml_simplify_switch.m
--- compiler/ml_simplify_switch.m 25 Aug 2009 23:46:48 -0000 1.29
+++ compiler/ml_simplify_switch.m 23 Sep 2009 16:37:18 -0000
@@ -26,7 +26,7 @@
:- interface.
:- import_module ml_backend.mlds.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- pred ml_simplify_switch(mlds_stmt::in, mlds_context::in,
statement::out, ml_gen_info::in, ml_gen_info::out) is det.
@@ -41,6 +41,7 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_switch_gen.
:- import_module parse_tree.prog_type.
Index: compiler/ml_string_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_string_switch.m,v
retrieving revision 1.42
diff -u -b -r1.42 ml_string_switch.m
--- compiler/ml_string_switch.m 21 Sep 2009 04:08:56 -0000 1.42
+++ compiler/ml_string_switch.m 23 Sep 2009 16:37:30 -0000
@@ -22,7 +22,7 @@
:- import_module hlds.code_model.
:- import_module hlds.hlds_goal.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -44,6 +44,7 @@
:- import_module hlds.hlds_module.
:- import_module libs.compiler_util.
:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_simplify_switch.
:- import_module parse_tree.builtin_lib_types.
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.44
diff -u -b -r1.44 ml_switch_gen.m
--- compiler/ml_switch_gen.m 21 Sep 2009 04:08:56 -0000 1.44
+++ compiler/ml_switch_gen.m 23 Sep 2009 15:40:00 -0000
@@ -66,7 +66,7 @@
:- import_module hlds.code_model.
:- import_module hlds.hlds_goal.
:- import_module libs.globals.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
Index: compiler/ml_tag_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_tag_switch.m,v
retrieving revision 1.32
diff -u -b -r1.32 ml_tag_switch.m
--- compiler/ml_tag_switch.m 21 Sep 2009 04:08:56 -0000 1.32
+++ compiler/ml_tag_switch.m 23 Sep 2009 16:37:42 -0000
@@ -19,7 +19,7 @@
:- import_module hlds.code_model.
:- import_module hlds.hlds_goal.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -44,6 +44,7 @@
:- import_module hlds.hlds_data.
:- import_module libs.compiler_util.
:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_simplify_switch.
:- import_module ml_backend.ml_switch_gen.
:- import_module ml_backend.ml_unify_gen.
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.142
diff -u -b -r1.142 ml_unify_gen.m
--- compiler/ml_unify_gen.m 25 Sep 2009 02:09:35 -0000 1.142
+++ compiler/ml_unify_gen.m 25 Sep 2009 03:45:34 -0000
@@ -12,6 +12,26 @@
% This module is part of the MLDS code generator.
% It handles MLDS code generation for unifications.
%
+% Code for deconstruction unifications
+%
+%
+% det (cannot_fail) deconstruction:
+% <succeeded = (X => f(A1, A2, ...))>
+% ===>
+% A1 = arg(X, f, 1); % extract arguments
+% A2 = arg(X, f, 2);
+% ...
+%
+% semidet (can_fail) deconstruction:
+% <X => f(A1, A2, ...)>
+% ===>
+% <succeeded = (X => f(_, _, _, _))> % tag test
+% if (succeeded) {
+% A1 = arg(X, f, 1); % extract arguments
+% A2 = arg(X, f, 2);
+% ...
+% }
+%
%-----------------------------------------------------------------------------%
:- module ml_backend.ml_unify_gen.
@@ -21,7 +41,7 @@
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
-:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -111,9 +131,9 @@
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
-:- import_module ml_backend.ml_call_gen.
:- import_module ml_backend.ml_closure_gen.
:- import_module ml_backend.ml_code_gen.
+:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_type_gen.
:- import_module ml_backend.ml_util.
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.212
diff -u -b -r1.212 mode_util.m
--- compiler/mode_util.m 4 Sep 2009 02:27:53 -0000 1.212
+++ compiler/mode_util.m 24 Sep 2009 03:59:36 -0000
@@ -25,6 +25,7 @@
:- import_module parse_tree.prog_data.
:- import_module list.
+:- import_module map.
%-----------------------------------------------------------------------------%
@@ -86,6 +87,12 @@
:- pred modes_to_arg_modes(module_info::in, list(mer_mode)::in,
list(mer_type)::in, list(arg_mode)::out) is det.
+ % Given a list of variables and their corresponding modes,
+ % return a list containing only those variables which have an output mode.
+ %
+:- func select_output_vars(module_info, list(Var), list(mer_mode),
+ map(Var, mer_type)) = list(Var).
+
:- func mode_get_initial_inst(module_info, mer_mode) = mer_inst.
:- func mode_get_final_inst(module_info, mer_mode) = mer_inst.
@@ -166,7 +173,7 @@
% and after a branch make sure that any information added by the
% functor test gets added to the instmap for the case.
%
-:- pred fixup_switch_var(prog_var::in, instmap::in, instmap::in,
+:- pred fixup_instmap_switch_var(prog_var::in, instmap::in, instmap::in,
hlds_goal::in, hlds_goal::out) is det.
%-----------------------------------------------------------------------------%
@@ -203,7 +210,6 @@
:- import_module parse_tree.prog_type_subst.
:- import_module int.
-:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module set.
@@ -326,6 +332,37 @@
ArgMode = top_unused
).
+select_output_vars(ModuleInfo, HeadVars, HeadModes, VarTypes) = OutputVars :-
+ (
+ HeadVars = [],
+ HeadModes = [],
+ OutputVars = []
+ ;
+ HeadVars = [Var | Vars],
+ HeadModes = [Mode | Modes],
+ map.lookup(VarTypes, Var, VarType),
+ mode_to_arg_mode(ModuleInfo, Mode, VarType, Top),
+ (
+ Top = top_out,
+ OutputVars1 = select_output_vars(ModuleInfo, Vars, Modes,
+ VarTypes),
+ OutputVars = [Var | OutputVars1]
+ ;
+ ( Top = top_in
+ ; Top = top_unused
+ ),
+ OutputVars = select_output_vars(ModuleInfo, Vars, Modes, VarTypes)
+ )
+ ;
+ HeadVars = [],
+ HeadModes = [_ | _],
+ unexpected(this_file, "select_output_vars: length mismatch")
+ ;
+ HeadVars = [_ | _],
+ HeadModes = [],
+ unexpected(this_file, "select_output_vars: length mismatch")
+ ).
+
%-----------------------------------------------------------------------------%
% get_single_arg_inst(ModuleInfo, Inst, ConsId, ArgInsts):
@@ -1659,7 +1696,7 @@
%-----------------------------------------------------------------------------%
-fixup_switch_var(Var, InstMap0, InstMap, Goal0, Goal) :-
+fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal0, Goal) :-
Goal0 = hlds_goal(GoalExpr, GoalInfo0),
InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
instmap_lookup_var(InstMap0, Var, Inst0),
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.84
diff -u -b -r1.84 modecheck_call.m
--- compiler/modecheck_call.m 23 Dec 2008 01:37:37 -0000 1.84
+++ compiler/modecheck_call.m 24 Sep 2009 03:11:47 -0000
@@ -23,7 +23,7 @@
:- interface.
:- import_module check_hlds.mode_info.
-:- import_module check_hlds.modes.
+:- import_module check_hlds.modecheck_util.
:- import_module hlds.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
@@ -84,6 +84,7 @@
:- import_module check_hlds.mode_errors.
:- import_module check_hlds.mode_info.
:- import_module check_hlds.mode_util.
+:- import_module check_hlds.modecheck_util.
:- import_module check_hlds.modes.
:- import_module check_hlds.unify_proc.
:- import_module hlds.instmap.
Index: compiler/modecheck_conj.m
===================================================================
RCS file: compiler/modecheck_conj.m
diff -N compiler/modecheck_conj.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/modecheck_conj.m 24 Sep 2009 03:45:03 -0000
@@ -0,0 +1,764 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: modecheck_conj.m.
+% Main author: fjh.
+%
+%-----------------------------------------------------------------------------%
+
+:- module check_hlds.modecheck_conj.
+:- interface.
+
+:- import_module check_hlds.mode_info.
+:- import_module hlds.
+:- import_module hlds.hlds_goal.
+
+:- import_module list.
+
+:- pred modecheck_conj_list(conj_type::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ mode_info::in, mode_info::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds.delay_info.
+:- import_module check_hlds.delay_partial_inst.
+:- import_module check_hlds.mode_debug.
+:- import_module check_hlds.mode_errors.
+:- import_module check_hlds.mode_util.
+:- import_module check_hlds.modecheck_goal.
+:- import_module check_hlds.modecheck_util.
+:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_clauses.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.instmap.
+:- import_module libs.
+:- import_module libs.compiler_util.
+:- import_module parse_tree.
+:- import_module parse_tree.prog_data.
+
+:- import_module assoc_list.
+:- import_module bool.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module pair.
+:- import_module set.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+modecheck_conj_list(ConjType, Goals0, Goals, !ModeInfo) :-
+ mode_info_get_errors(!.ModeInfo, OldErrors),
+ mode_info_set_errors([], !ModeInfo),
+
+ mode_info_get_may_init_solver_vars(!.ModeInfo, OldMayInit),
+
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
+ delay_info_enter_conj(DelayInfo0, DelayInfo1),
+ mode_info_set_delay_info(DelayInfo1, !ModeInfo),
+
+ mode_info_get_live_vars(!.ModeInfo, LiveVars1),
+ mode_info_add_goals_live_vars(ConjType, Goals0, !ModeInfo),
+
+ % Try to schedule goals without inserting any solver initialisation calls
+ % by setting the mode_info flag may_initialise_solver_vars to no.
+ mode_info_set_may_init_solver_vars(may_not_init_solver_vars, !ModeInfo),
+
+ modecheck_conj_list_2(ConjType, Goals0, Goals1,
+ [], RevImpurityErrors0, !ModeInfo),
+
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
+ delay_info_leave_conj(DelayInfo2, DelayedGoals0, DelayInfo3),
+ mode_info_set_delay_info(DelayInfo3, !ModeInfo),
+
+ % Otherwise try scheduling by inserting solver initialisation calls
+ % where necessary (although only if `--solver-type-auto-init' is enabled).
+ %
+ modecheck_delayed_solver_goals(ConjType, Goals2,
+ DelayedGoals0, DelayedGoals, RevImpurityErrors0, RevImpurityErrors,
+ !ModeInfo),
+ Goals = Goals1 ++ Goals2,
+
+ mode_info_get_errors(!.ModeInfo, NewErrors),
+ Errors = OldErrors ++ NewErrors,
+ mode_info_set_errors(Errors, !ModeInfo),
+
+ % We only report impurity errors if there were no other errors.
+ (
+ DelayedGoals = [],
+
+ % Report all the impurity errors
+ % (making sure we report the errors in the correct order).
+ list.reverse(RevImpurityErrors, ImpurityErrors),
+ mode_info_get_errors(!.ModeInfo, Errors5),
+ Errors6 = Errors5 ++ ImpurityErrors,
+ mode_info_set_errors(Errors6, !ModeInfo)
+ ;
+ DelayedGoals = [FirstDelayedGoal | MoreDelayedGoals],
+ % The variables in the delayed goals should no longer be considered
+ % live (the conjunction itself will delay, and its nonlocals will be
+ % made live).
+ mode_info_set_live_vars(LiveVars1, !ModeInfo),
+ (
+ MoreDelayedGoals = [],
+ FirstDelayedGoal = delayed_goal(_DVars, Error, _DGoal),
+ mode_info_add_error(Error, !ModeInfo)
+ ;
+ MoreDelayedGoals = [_ | _],
+ get_all_waiting_vars(DelayedGoals, Vars),
+ ModeError = mode_error_conj(DelayedGoals, conj_floundered),
+ mode_info_error(Vars, ModeError, !ModeInfo)
+ )
+ ),
+ % Restore the value of the may_initialise_solver_vars flag.
+ mode_info_set_may_init_solver_vars(OldMayInit, !ModeInfo).
+
+:- type impurity_errors == list(mode_error_info).
+
+ % Flatten conjunctions as we go, as long as they are of the same type.
+ % Call modecheck_conj_list_3 to do the actual scheduling.
+ %
+:- pred modecheck_conj_list_2(conj_type::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ impurity_errors::in, impurity_errors::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_conj_list_2(_ConjType, [], [], !ImpurityErrors, !ModeInfo).
+modecheck_conj_list_2(ConjType, [Goal0 | Goals0], Goals, !ImpurityErrors,
+ !ModeInfo) :-
+ (
+ Goal0 = hlds_goal(conj(plain_conj, ConjGoals), _),
+ ConjType = plain_conj
+ ->
+ Goals1 = ConjGoals ++ Goals0,
+ modecheck_conj_list_2(ConjType, Goals1, Goals, !ImpurityErrors,
+ !ModeInfo)
+ ;
+ modecheck_conj_list_3(ConjType, Goal0, Goals0, Goals, !ImpurityErrors,
+ !ModeInfo)
+ ).
+
+ % Schedule a conjunction. If it is empty, then there is nothing to do.
+ % For non-empty conjunctions, we attempt to schedule the first goal
+ % in the conjunction. If successful, we wakeup a newly pending goal
+ % (if any), and if not, we delay the goal. Then we continue attempting
+ % to schedule all the rest of the goals.
+ %
+:- pred modecheck_conj_list_3(conj_type::in, hlds_goal::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ impurity_errors::in, impurity_errors::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_conj_list_3(ConjType, Goal0, Goals0, Goals, !ImpurityErrors,
+ !ModeInfo) :-
+ Purity = goal_get_purity(Goal0),
+ (
+ Purity = purity_impure,
+ Impure = yes,
+ check_for_impurity_error(Goal0, ScheduledSolverGoals,
+ !ImpurityErrors, !ModeInfo)
+ ;
+ ( Purity = purity_pure
+ ; Purity = purity_semipure
+ ),
+ Impure = no,
+ ScheduledSolverGoals = []
+ ),
+
+ % Hang onto the original instmap, delay_info, and live_vars.
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
+
+ % Modecheck the goal, noting first that the non-locals
+ % which occur in the goal might not be live anymore.
+ NonLocalVars = goal_get_nonlocals(Goal0),
+ mode_info_remove_live_vars(NonLocalVars, !ModeInfo),
+ modecheck_goal(Goal0, Goal, !ModeInfo),
+
+ % Now see whether the goal was successfully scheduled. If we didn't manage
+ % to schedule the goal, then we restore the original instmap, delay_info
+ % and livevars here, and delay the goal.
+ mode_info_get_errors(!.ModeInfo, Errors),
+ (
+ Errors = [FirstErrorInfo | _],
+ mode_info_set_errors([], !ModeInfo),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ mode_info_add_live_vars(NonLocalVars, !ModeInfo),
+ delay_info_delay_goal(FirstErrorInfo, Goal0, DelayInfo0, DelayInfo1),
+ % Delaying an impure goal is an impurity error.
+ (
+ Impure = yes,
+ FirstErrorInfo = mode_error_info(Vars, _, _, _),
+ ImpureError = mode_error_conj(
+ [delayed_goal(Vars, FirstErrorInfo, Goal0)],
+ goal_itself_was_impure),
+ mode_info_get_context(!.ModeInfo, Context),
+ mode_info_get_mode_context(!.ModeInfo, ModeContext),
+ ImpureErrorInfo = mode_error_info(Vars, ImpureError,
+ Context, ModeContext),
+ !:ImpurityErrors = [ImpureErrorInfo | !.ImpurityErrors]
+ ;
+ Impure = no
+ )
+ ;
+ Errors = [],
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo1)
+ ),
+
+ % Next, we attempt to wake up any pending goals, and then continue
+ % scheduling the rest of the goal.
+ delay_info_wakeup_goals(WokenGoals, DelayInfo1, DelayInfo),
+ Goals1 = WokenGoals ++ Goals0,
+ (
+ WokenGoals = []
+ ;
+ WokenGoals = [_],
+ mode_checkpoint(wakeup, "goal", !ModeInfo)
+ ;
+ WokenGoals = [_, _ | _],
+ mode_checkpoint(wakeup, "goals", !ModeInfo)
+ ),
+ mode_info_set_delay_info(DelayInfo, !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ ( instmap_is_unreachable(InstMap) ->
+ % We should not mode-analyse the remaining goals, since they are
+ % unreachable. Instead we optimize them away, so that later passes
+ % won't complain about them not having mode information.
+ mode_info_remove_goals_live_vars(Goals1, !ModeInfo),
+ Goals2 = []
+ ;
+ % The remaining goals may still need to be flattened.
+ modecheck_conj_list_2(ConjType, Goals1, Goals2, !ImpurityErrors,
+ !ModeInfo)
+ ),
+ (
+ Errors = [_ | _],
+ % We delayed this goal -- it will be stored in the delay_info.
+ Goals = ScheduledSolverGoals ++ Goals2
+ ;
+ Errors = [],
+ % We successfully scheduled this goal, so insert it
+ % in the list of successfully scheduled goals.
+ % We flatten out conjunctions if we can. They can arise
+ % when Goal0 was a scope(from_ground_term, _) goal.
+ ( Goal = hlds_goal(conj(ConjType, SubGoals), _) ->
+ Goals = ScheduledSolverGoals ++ SubGoals ++ Goals2
+ ;
+ Goals = ScheduledSolverGoals ++ [Goal | Goals2]
+ )
+ ).
+
+ % We may still have some unscheduled goals. This may be because some
+ % initialisation calls are needed to turn some solver type vars
+ % from inst free to inst any. This predicate attempts to schedule
+ % such goals.
+ %
+ % XXX Despite its name this predicate will in fact try to reschedule all
+ % delayed goals, not just delayed solver goals.
+ %
+:- pred modecheck_delayed_solver_goals(conj_type::in, list(hlds_goal)::out,
+ list(delayed_goal)::in, list(delayed_goal)::out,
+ impurity_errors::in, impurity_errors::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_delayed_solver_goals(ConjType, Goals, !DelayedGoals,
+ !ImpurityErrors, !ModeInfo) :-
+ % Try to handle any unscheduled goals by inserting solver
+ % initialisation calls, aiming for a deterministic schedule.
+ modecheck_delayed_goals_try_det(ConjType, !DelayedGoals,
+ Goals0, !ImpurityErrors, !ModeInfo),
+
+ % Try to handle any unscheduled goals by inserting solver
+ % initialisation calls, aiming for *any* workable schedule.
+ modecheck_delayed_goals_eager(ConjType, !DelayedGoals,
+ Goals1, !ImpurityErrors, !ModeInfo),
+ Goals = Goals0 ++ Goals1.
+
+ % We may still have some unscheduled goals. This may be because some
+ % initialisation calls are needed to turn some solver type vars
+ % from inst free to inst any. This pass attempts to identify a
+ % minimal subset of such vars to initialise that will allow the
+ % remaining goals to be scheduled in a deterministic fashion.
+ %
+ % This works as follows. If a deterministic schedule exists for
+ % the remaining goals, then each subgoal must also be deterministic.
+ % Moreover, no call may employ an implied mode since these mean
+ % introducing a semidet unification. Therefore we only need to
+ % consider det procs for calls, constructions for var/functor
+ % unifications, and assignments for var/var unifications.
+ %
+ % If a consistent deterministic schedule exists then every
+ % variable involved in the goals either
+ % - has already been instantiated;
+ % - will be instantiated by a single remaining subgoal;
+ % - will not be instantiated by any remaining subgoal.
+ % Variables in this last category that are solver type variables
+ % should be initialised. If all the variables that will remain
+ % uninstantiated are in this last category then, after inserting
+ % initialisation call, we should expect another attempt at
+ % scheduling the remaining goals to succeed and produce a
+ % deterministic result.
+ %
+ % XXX At some point we should extend this analysis to handle
+ % disjunction, if-then-else goals, and negation.
+ %
+:- pred modecheck_delayed_goals_try_det(conj_type::in, list(delayed_goal)::in,
+ list(delayed_goal)::out, list(hlds_goal)::out,
+ impurity_errors::in, impurity_errors::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_delayed_goals_try_det(ConjType, DelayedGoals0, DelayedGoals, Goals,
+ !ImpurityErrors, !ModeInfo) :-
+ (
+ % There are no unscheduled goals, so we don't need to do anything.
+
+ DelayedGoals0 = [],
+ DelayedGoals = [],
+ Goals = []
+ ;
+ % There are some unscheduled goals. See if allowing extra
+ % initialisation calls (for a single goal) makes a difference.
+
+ DelayedGoals0 = [_ | _],
+ (
+ % Extract the HLDS goals from the delayed goals.
+ Goals0 = list.map(hlds_goal_from_delayed_goal, DelayedGoals0),
+
+ % Work out which vars are already instantiated
+ % (i.e. have non-free insts).
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ instmap_to_assoc_list(InstMap, VarInsts),
+ NonFreeVars0 = set.list_to_set(
+ non_free_vars_in_assoc_list(VarInsts)),
+
+ % Find the set of vars whose instantiation should lead to
+ % a deterministic schedule.
+ promise_equivalent_solutions [CandidateInitVars] (
+ candidate_init_vars(!.ModeInfo, Goals0, NonFreeVars0,
+ CandidateInitVars)
+ ),
+
+ % And verify that all of these vars are solver type vars
+ % (and can therefore be initialised.)
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ all [Var] (
+ set.member(Var, CandidateInitVars)
+ =>
+ (
+ map.lookup(VarTypes, Var, VarType),
+ type_is_solver_type_with_auto_init(ModuleInfo, VarType)
+ )
+ ),
+ mode_info_solver_init_is_supported(!.ModeInfo)
+ ->
+ % Construct the inferred initialisation goals
+ % and try scheduling again.
+ CandidateInitVarList = set.to_sorted_list(CandidateInitVars),
+ construct_initialisation_calls(CandidateInitVarList,
+ InitGoals, !ModeInfo),
+ Goals1 = InitGoals ++ Goals0,
+
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
+ delay_info_enter_conj(DelayInfo0, DelayInfo1),
+ mode_info_set_delay_info(DelayInfo1, !ModeInfo),
+
+ mode_info_add_goals_live_vars(ConjType, InitGoals, !ModeInfo),
+
+ modecheck_conj_list_2(ConjType, Goals1, Goals, !ImpurityErrors,
+ !ModeInfo),
+
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
+ delay_info_leave_conj(DelayInfo2, DelayedGoals, DelayInfo3),
+ mode_info_set_delay_info(DelayInfo3, !ModeInfo)
+ ;
+ % We couldn't identify a deterministic solution.
+ DelayedGoals = DelayedGoals0,
+ Goals = []
+ )
+ ).
+
+ % XXX will this catch synonyms for `free'?
+ % N.B. This is perhaps the only time when `for' and `free'
+ % can be juxtaposed grammatically :-)
+ %
+:- func non_free_vars_in_assoc_list(assoc_list(prog_var, mer_inst)) =
+ list(prog_var).
+
+non_free_vars_in_assoc_list([]) = [].
+non_free_vars_in_assoc_list([Var - Inst | AssocList]) =
+ (
+ ( Inst = free
+ ; Inst = free(_)
+ )
+ ->
+ non_free_vars_in_assoc_list(AssocList)
+ ;
+ [Var | non_free_vars_in_assoc_list(AssocList)]
+ ).
+
+ % Find a set of vars that, if they were instantiated, might
+ % lead to a deterministic scheduling of the given goals.
+ %
+ % This approximation is fairly crude: it only considers variables as
+ % being free or non-free, rather than having detailed insts.
+ %
+ % XXX Does not completely handle negation, disjunction, if_then_else
+ % goals, foreign_code, or var/lambda unifications.
+ %
+:- pred candidate_init_vars(mode_info::in, list(hlds_goal)::in,
+ set(prog_var)::in, set(prog_var)::out) is cc_nondet.
+
+candidate_init_vars(ModeInfo, Goals, NonFreeVars0, CandidateVars) :-
+ CandidateVars0 = set.init,
+ candidate_init_vars_2(ModeInfo, Goals, NonFreeVars0, NonFreeVars1,
+ CandidateVars0, CandidateVars1),
+ CandidateVars = set.difference(CandidateVars1, NonFreeVars1).
+
+:- pred candidate_init_vars_2(mode_info::in, list(hlds_goal)::in,
+ set(prog_var)::in, set(prog_var)::out,
+ set(prog_var)::in, set(prog_var)::out) is nondet.
+
+candidate_init_vars_2(ModeInfo, Goals, !NonFree, !CandidateVars) :-
+ list.foldl2(candidate_init_vars_3(ModeInfo), Goals,
+ !NonFree, !CandidateVars).
+
+:- pred candidate_init_vars_3(mode_info::in, hlds_goal::in,
+ set(prog_var)::in, set(prog_var)::out,
+ set(prog_var)::in, set(prog_var)::out) is nondet.
+
+candidate_init_vars_3(ModeInfo, Goal, !NonFree, !CandidateVars) :-
+ Goal = hlds_goal(GoalExpr, _GoalInfo),
+ (
+ % A var/var unification.
+ GoalExpr = unify(X, RHS, _, _, _),
+ RHS = rhs_var(Y),
+ ( set.member(X, !.NonFree) ->
+ not set.member(Y, !.NonFree),
+ % It is an assignment from X to Y.
+ !:NonFree = set.insert(!.NonFree, Y)
+ ; set.member(Y, !.NonFree) ->
+ % It is an assignment from Y to X.
+ !:NonFree = set.insert(!.NonFree, X)
+ ;
+ % It is an assignment one way or the other.
+ (
+ !:NonFree = set.insert(!.NonFree, X),
+ !:CandidateVars = set.insert(!.CandidateVars, Y)
+ ;
+ !:NonFree = set.insert(!.NonFree, Y),
+ !:CandidateVars = set.insert(!.CandidateVars, X)
+ )
+ )
+ ;
+ % A var/functor unification, which can only be deterministic
+ % if it is a construction.
+ GoalExpr = unify(X, RHS, _, _, _),
+ RHS = rhs_functor(_, _, Args),
+
+ % If this is a construction then X must be free.
+ not set.member(X, !.NonFree),
+
+ % But X becomes instantiated.
+ !:NonFree = set.insert(!.NonFree, X),
+
+ % And the Args are potential candidates for initialisation.
+ !:CandidateVars = set.insert_list(!.CandidateVars, Args)
+ ;
+ % A var/lambda unification, which can only be deterministic if it is
+ % a construction.
+ GoalExpr = unify(X, RHS, _, _, _),
+ RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
+
+ % If this is a construction then X must be free.
+ not set.member(X, !.NonFree),
+
+ % But X becomes instantiated.
+ !:NonFree = set.insert(!.NonFree, X)
+ ;
+ % Disjunctions are tricky, because we don't perform switch analysis
+ % until after mode analysis. So here we assume that the disjunction
+ % is a det switch and that we can ignore it for the purposes of
+ % identifying candidate vars for initialisation.
+ GoalExpr = disj(_Goals)
+ ;
+ % We ignore the condition of an if-then-else goal, other than to assume
+ % that it binds its non-solver-type non-locals, but proceed on the
+ % assumption that the then and else arms are det. This isn't very
+ % accurate and may need refinement.
+
+ GoalExpr = if_then_else(_LocalVars, CondGoal, ThenGoal, ElseGoal),
+
+ CondGoal = hlds_goal(_CondGoalExpr, CondGoalInfo),
+ NonLocals = goal_info_get_nonlocals(CondGoalInfo),
+ mode_info_get_module_info(ModeInfo, ModuleInfo),
+ mode_info_get_var_types(ModeInfo, VarTypes),
+ NonSolverNonLocals =
+ set.filter(non_solver_var(ModuleInfo, VarTypes), NonLocals),
+ !:NonFree = set.union(NonSolverNonLocals, !.NonFree),
+
+ candidate_init_vars_3(ModeInfo, ThenGoal, !.NonFree, NonFreeThen,
+ !CandidateVars),
+ candidate_init_vars_3(ModeInfo, ElseGoal, !.NonFree, NonFreeElse,
+ !CandidateVars),
+ !:NonFree = set.union(NonFreeThen, NonFreeElse)
+ ;
+ % XXX We should special-case the handling of from_ground_term_construct
+ % scopes.
+ GoalExpr = scope(_, SubGoal),
+ candidate_init_vars_3(ModeInfo, SubGoal, !NonFree, !CandidateVars)
+ ;
+ GoalExpr = conj(_ConjType, Goals),
+ candidate_init_vars_2(ModeInfo, Goals, !NonFree, !CandidateVars)
+ ;
+ % XXX Is the determinism field of a generic_call valid at this point?
+ % Determinism analysis is run after mode analysis.
+ %
+ % We assume that generic calls are deterministic. The modes field of
+ % higher_order calls is junk until *after* mode analysis, hence we
+ % can't handle them here.
+ GoalExpr = generic_call(Details, Args, ArgModes, _JunkDetism),
+ Details \= higher_order(_, _, _, _),
+ candidate_init_vars_call(ModeInfo, Args, ArgModes,
+ !NonFree, !CandidateVars)
+ ;
+ % A call (at this point the ProcId is just a dummy value since it isn't
+ % meaningful until the call is scheduled.)
+
+ GoalExpr = plain_call(PredId, _, Args, _, _, _),
+
+ % Find a deterministic proc for this call.
+ mode_info_get_preds(ModeInfo, Preds),
+ map.lookup(Preds, PredId, PredInfo),
+ pred_info_get_procedures(PredInfo, ProcTable),
+ map.values(ProcTable, ProcInfos),
+ list.member(ProcInfo, ProcInfos),
+ proc_info_get_declared_determinism(ProcInfo, yes(DeclaredDetism)),
+ ( DeclaredDetism = detism_det ; DeclaredDetism = detism_cc_multi ),
+
+ % Find the argument modes.
+ proc_info_get_argmodes(ProcInfo, ArgModes),
+
+ % Process the call args.
+ candidate_init_vars_call(ModeInfo, Args, ArgModes,
+ !NonFree, !CandidateVars)
+ ).
+
+ % This filter pred succeeds if the given variable does not have
+ % a solver type.
+ %
+:- pred non_solver_var(module_info::in, vartypes::in, prog_var::in) is semidet.
+
+non_solver_var(ModuleInfo, VarTypes, Var) :-
+ VarType = VarTypes ^ det_elem(Var),
+ not type_is_solver_type(ModuleInfo, VarType).
+
+ % Update !NonFree and !CandidateVars given the args and modes for a call.
+ %
+:- pred candidate_init_vars_call(mode_info::in,
+ list(prog_var)::in, list(mer_mode)::in,
+ set(prog_var)::in, set(prog_var)::out,
+ set(prog_var)::in, set(prog_var)::out) is semidet.
+
+candidate_init_vars_call(_ModeInfo, [], [], !NonFree, !CandidateVars).
+candidate_init_vars_call(ModeInfo, [Arg | Args], [Mode | Modes],
+ !NonFree, !CandidateVars) :-
+ mode_info_get_module_info(ModeInfo, ModuleInfo),
+ mode_get_insts_semidet(ModuleInfo, Mode, InitialInst, FinalInst),
+ (
+ InitialInst \= free,
+ InitialInst \= free(_)
+ ->
+ % This arg is an input that needs instantiation.
+ !:CandidateVars = set.insert(!.CandidateVars, Arg)
+ ;
+ % Otherwise this arg could be an output...
+ FinalInst \= free,
+ FinalInst \= free(_)
+ ->
+ % And it is.
+ ( set.contains(!.NonFree, Arg) ->
+ % This arg appears in an implied mode.
+ fail
+ ;
+ % This arg is instantiated on output.
+ !:NonFree = set.insert(!.NonFree, Arg)
+ )
+ ;
+ % This arg is unused.
+ true
+ ),
+ candidate_init_vars_call(ModeInfo, Args, Modes, !NonFree, !CandidateVars).
+
+ % We may still have some unscheduled goals. This may be because some
+ % initialisation calls are needed to turn some solver type vars
+ % from inst free to inst any. This pass tries to unblock the
+ % remaining goals by conservatively inserting initialisation calls.
+ % It is "eager" in the sense that as soon as it encounters a sub-goal
+ % that may be unblocked this way it tries to do so.
+ %
+:- pred modecheck_delayed_goals_eager(conj_type::in, list(delayed_goal)::in,
+ list(delayed_goal)::out, list(hlds_goal)::out,
+ impurity_errors::in, impurity_errors::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_delayed_goals_eager(ConjType, DelayedGoals0, DelayedGoals, Goals,
+ !ImpurityErrors, !ModeInfo) :-
+ (
+ % There are no unscheduled goals, so we don't need to do anything.
+ DelayedGoals0 = [],
+ DelayedGoals = [],
+ Goals = []
+ ;
+ % There are some unscheduled goals. See if allowing extra
+ % initialisation calls (for a single goal) makes a difference.
+ DelayedGoals0 = [_ | _],
+
+ Goals0 = list.map(hlds_goal_from_delayed_goal, DelayedGoals0),
+
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
+ delay_info_enter_conj(DelayInfo0, DelayInfo1),
+ mode_info_set_delay_info(DelayInfo1, !ModeInfo),
+
+ mode_info_get_may_init_solver_vars(!.ModeInfo, OldMayInit),
+ expect(unify(OldMayInit, may_not_init_solver_vars), this_file,
+ "modecheck_delayed_goals_eager: may init solver vars"),
+ mode_info_set_may_init_solver_vars(may_init_solver_vars, !ModeInfo),
+ modecheck_conj_list_2(ConjType, Goals0, Goals1, !ImpurityErrors,
+ !ModeInfo),
+ mode_info_set_may_init_solver_vars(may_not_init_solver_vars,
+ !ModeInfo),
+
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
+ delay_info_leave_conj(DelayInfo2, DelayedGoals1, DelayInfo3),
+ mode_info_set_delay_info(DelayInfo3, !ModeInfo),
+
+ % See if we scheduled any goals.
+ ( length(DelayedGoals1) < length(DelayedGoals0) ->
+ % We scheduled some goals. Keep going until we either
+ % flounder or succeed.
+ modecheck_delayed_goals_eager(ConjType,
+ DelayedGoals1, DelayedGoals, Goals2,
+ !ImpurityErrors, !ModeInfo),
+ Goals = Goals1 ++ Goals2
+ ;
+ DelayedGoals = DelayedGoals1,
+ Goals = Goals1
+ )
+ ).
+
+:- func hlds_goal_from_delayed_goal(delayed_goal) = hlds_goal.
+
+hlds_goal_from_delayed_goal(delayed_goal(_WaitingVars, _ModeError, Goal)) =
+ Goal.
+
+ % Check whether there are any delayed goals (other than unifications)
+ % at the point where we are about to schedule an impure goal. If so,
+ % that is an error. Headvar unifications are allowed to be delayed
+ % because in the case of output arguments, they cannot be scheduled until
+ % the variable value is known. If headvar unifications couldn't be delayed
+ % past impure goals, impure predicates wouldn't be able to have outputs!
+ % (Note that we first try to schedule any delayed solver goals waiting
+ % for initialisation.)
+ %
+:- pred check_for_impurity_error(hlds_goal::in, list(hlds_goal)::out,
+ impurity_errors::in, impurity_errors::out,
+ mode_info::in, mode_info::out) is det.
+
+check_for_impurity_error(Goal, Goals, !ImpurityErrors, !ModeInfo) :-
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
+ delay_info_leave_conj(DelayInfo0, DelayedGoals0, DelayInfo1),
+ mode_info_set_delay_info(DelayInfo1, !ModeInfo),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ mode_info_get_pred_id(!.ModeInfo, PredId),
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_clauses_info(PredInfo, ClausesInfo),
+ clauses_info_get_headvar_list(ClausesInfo, HeadVars),
+ filter_headvar_unification_goals(HeadVars, DelayedGoals0,
+ HeadVarUnificationGoals, NonHeadVarUnificationGoals0),
+ modecheck_delayed_solver_goals(plain_conj, Goals,
+ NonHeadVarUnificationGoals0, NonHeadVarUnificationGoals,
+ !ImpurityErrors, !ModeInfo),
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
+ delay_info_enter_conj(DelayInfo2, DelayInfo3),
+ redelay_goals(HeadVarUnificationGoals, DelayInfo3, DelayInfo),
+ mode_info_set_delay_info(DelayInfo, !ModeInfo),
+ (
+ NonHeadVarUnificationGoals = []
+ ;
+ NonHeadVarUnificationGoals = [_ | _],
+ get_all_waiting_vars(NonHeadVarUnificationGoals, Vars),
+ ModeError = mode_error_conj(NonHeadVarUnificationGoals,
+ goals_followed_by_impure_goal(Goal)),
+ mode_info_get_context(!.ModeInfo, Context),
+ mode_info_get_mode_context(!.ModeInfo, ModeContext),
+ ImpurityError = mode_error_info(Vars, ModeError, Context, ModeContext),
+ !:ImpurityErrors = [ImpurityError | !.ImpurityErrors]
+ ).
+
+:- pred filter_headvar_unification_goals(list(prog_var)::in,
+ list(delayed_goal)::in, list(delayed_goal)::out, list(delayed_goal)::out)
+ is det.
+
+filter_headvar_unification_goals(HeadVars, DelayedGoals,
+ HeadVarUnificationGoals, NonHeadVarUnificationGoals) :-
+ list.filter(is_headvar_unification_goal(HeadVars), DelayedGoals,
+ HeadVarUnificationGoals, NonHeadVarUnificationGoals).
+
+:- pred is_headvar_unification_goal(list(prog_var)::in, delayed_goal::in)
+ is semidet.
+
+is_headvar_unification_goal(HeadVars, delayed_goal(_, _, Goal)) :-
+ Goal ^ hlds_goal_expr = unify(Var, RHS, _, _, _),
+ (
+ list.member(Var, HeadVars)
+ ;
+ RHS = rhs_var(OtherVar),
+ list.member(OtherVar, HeadVars)
+ ).
+
+ % Given an association list of Vars - Goals,
+ % combine all the Vars together into a single set.
+ %
+:- pred get_all_waiting_vars(list(delayed_goal)::in, set(prog_var)::out)
+ is det.
+
+get_all_waiting_vars(DelayedGoals, Vars) :-
+ get_all_waiting_vars_2(DelayedGoals, set.init, Vars).
+
+:- pred get_all_waiting_vars_2(list(delayed_goal)::in,
+ set(prog_var)::in, set(prog_var)::out) is det.
+
+get_all_waiting_vars_2([], Vars, Vars).
+get_all_waiting_vars_2([delayed_goal(Vars1, _, _) | Rest], Vars0, Vars) :-
+ set.union(Vars0, Vars1, Vars2),
+ get_all_waiting_vars_2(Rest, Vars2, Vars).
+
+:- pred redelay_goals(list(delayed_goal)::in, delay_info::in, delay_info::out)
+ is det.
+
+redelay_goals([], !DelayInfo).
+redelay_goals([DelayedGoal | DelayedGoals], !DelayInfo) :-
+ DelayedGoal = delayed_goal(_WaitingVars, ModeErrorInfo, Goal),
+ delay_info_delay_goal(ModeErrorInfo, Goal, !DelayInfo),
+ redelay_goals(DelayedGoals, !DelayInfo).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "modecheck_conj.m".
+
+%-----------------------------------------------------------------------------%
Index: compiler/modecheck_goal.m
===================================================================
RCS file: compiler/modecheck_goal.m
diff -N compiler/modecheck_goal.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/modecheck_goal.m 24 Sep 2009 04:00:15 -0000
@@ -0,0 +1,1586 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: modecheck_goal.m.
+% Main author: fjh.
+%
+% To mode-analyse a goal:
+% If goal is
+% (a) a disjunction
+% Mode-analyse the sub-goals;
+% check that the final insts of all the non-local
+% variables are the same for all the sub-goals.
+% (b) a conjunction
+% Attempt to schedule each sub-goal. If a sub-goal can
+% be scheduled, then schedule it, otherwise delay it.
+% Continue with the remaining sub-goals until there are
+% no goals left. Every time a variable gets bound,
+% see whether we should wake up a delayed goal,
+% and if so, wake it up next time we get back to
+% the conjunction. If there are still delayed goals
+% hanging around at the end of the conjunction,
+% report a mode error.
+% (c) a negation
+% Mode-check the sub-goal.
+% Check that the sub-goal does not further instantiate
+% any non-local variables. (Actually, rather than
+% doing this check after we mode-analyse the subgoal,
+% we instead "lock" the non-local variables, and
+% disallow binding of locked variables.)
+% (d) a unification
+% Check that the unification doesn't attempt to unify
+% two free variables (or in general two free sub-terms)
+% unless one of them is dead. Split unifications
+% up if necessary to avoid complicated sub-unifications.
+% We also figure out at this point whether or not each
+% unification can fail.
+% (e) a predicate call
+% Check that there is a mode declaration for the
+% predicate which matches the current instantiation of
+% the arguments. (Also handle calls to implied modes.)
+% If the called predicate is one for which we must infer
+% the modes, then create a new mode for the called predicate
+% whose initial insts are the result of normalising
+% the current inst of the arguments.
+% (f) an if-then-else
+% Attempt to schedule the condition. If successful,
+% then check that it doesn't further instantiate any
+% non-local variables, mode-check the `then' part
+% and the `else' part, and then check that the final
+% insts match. (Perhaps also think about expanding
+% if-then-elses so that they can be run backwards,
+% if the condition can't be scheduled?)
+%
+% To attempt to schedule a goal, first mode-check the goal. If mode-checking
+% succeeds, then scheduling succeeds. If mode-checking would report
+% an error due to the binding of a local variable, then scheduling
+% fails. (If mode-checking would report an error due to the binding of
+% a *local* variable, we could report the error right away --
+% but this idea has not yet been implemented.)
+%
+% Note that the notion of liveness used here is different to that
+% used in liveness.m and the code generator. Here, we consider
+% a variable live if its value will be used later on in the computation.
+%
+% XXX We ought to allow unification of free with free even when both
+% *variables* are live, if one of the particular *sub-nodes* is dead
+% (causes problems handling e.g. `list.same_length').
+%
+% XXX We ought to break unifications into "micro-unifications", because
+% some code can't be scheduled without splitting up unifications.
+% For example, `p(X) :- X = f(A, B), B is A + 1.', where p is declared as
+% `:- mode p(bound(f(ground,free))->ground).'.
+%
+% XXX At the moment we don't check for circular modes or insts.
+% If they aren't used, the compiler will probably not detect the error;
+% if they are, it will probably go into an infinite loop.
+%
+%-----------------------------------------------------------------------------%
+
+:- module check_hlds.modecheck_goal.
+:- interface.
+
+:- import_module check_hlds.mode_info.
+:- import_module hlds.
+:- import_module hlds.hlds_goal.
+
+ % Modecheck a goal by abstractly interpreting it, as explained
+ % at the top of this file.
+ %
+ % Input-output:
+ % InstMap Stored in ModeInfo
+ % DelayInfo Stored in ModeInfo
+ % Goal Passed as an argument pair
+ % Input only:
+ % ModuleInfo Stored in ModeInfo (constant)
+ % Context Stored in ModeInfo (changing as we go along the clause)
+ % Output only:
+ % Error Messages Output directly to stdout.
+ %
+:- pred modecheck_goal(hlds_goal::in, hlds_goal::out,
+ mode_info::in, mode_info::out) is det.
+
+ % Mode-check a single goal-expression.
+ %
+:- pred modecheck_goal_expr(hlds_goal_expr::in, hlds_goal_info::in,
+ hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds.inst_match.
+:- import_module check_hlds.inst_util.
+:- import_module check_hlds.mode_debug.
+:- import_module check_hlds.mode_errors.
+:- import_module check_hlds.mode_util.
+:- import_module check_hlds.modecheck_call.
+:- import_module check_hlds.modecheck_conj.
+:- import_module check_hlds.modecheck_unify.
+:- import_module check_hlds.modecheck_util.
+:- import_module check_hlds.polymorphism.
+:- import_module check_hlds.type_util.
+:- import_module hlds.goal_util.
+:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.instmap.
+:- import_module hlds.pred_table.
+:- import_module libs.
+:- import_module libs.compiler_util.
+:- import_module mdbcomp.
+:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.
+:- import_module parse_tree.builtin_lib_types.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_event.
+:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_type.
+
+:- import_module bag.
+:- import_module bool.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module pair.
+:- import_module set.
+:- import_module string.
+:- import_module svmap.
+:- import_module term.
+:- import_module varset.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+modecheck_goal(Goal0, Goal, !ModeInfo) :-
+ Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
+ % Note: any changes here may need to be duplicated in unique_modes.m.
+
+ % Store the current context in the mode_info.
+ Context = goal_info_get_context(GoalInfo0),
+ term.context_init(EmptyContext),
+ ( Context = EmptyContext ->
+ true
+ ;
+ mode_info_set_context(Context, !ModeInfo)
+ ),
+ ( goal_info_has_feature(GoalInfo0, feature_duplicated_for_switch) ->
+ mode_info_get_in_dupl_for_switch(!.ModeInfo, InDuplForSwitch),
+ mode_info_set_in_dupl_for_switch(in_dupl_for_switch, !ModeInfo),
+ modecheck_goal_2(GoalExpr0, GoalInfo0, Goal, !ModeInfo),
+ mode_info_set_in_dupl_for_switch(InDuplForSwitch, !ModeInfo)
+ ;
+ modecheck_goal_2(GoalExpr0, GoalInfo0, Goal, !ModeInfo)
+ ).
+
+:- pred modecheck_goal_2(hlds_goal_expr::in, hlds_goal_info::in,
+ hlds_goal::out, mode_info::in, mode_info::out) is det.
+
+:- pragma inline(modecheck_goal_2/5).
+
+modecheck_goal_2(GoalExpr0, GoalInfo0, Goal, !ModeInfo) :-
+ % Modecheck the goal, and then store the changes in instantiation
+ % of the vars in the delta_instmap in the goal's goal_info.
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ modecheck_goal_expr(GoalExpr0, GoalInfo0, GoalExpr, !ModeInfo),
+ compute_goal_instmap_delta(InstMap0, GoalExpr, GoalInfo0, GoalInfo,
+ !ModeInfo),
+ Goal = hlds_goal(GoalExpr, GoalInfo).
+
+modecheck_goal_expr(GoalExpr0, GoalInfo0, GoalExpr, !ModeInfo) :-
+ % XXX The predicates we call here should have their definitions
+ % in the same order as this switch.
+ (
+ GoalExpr0 = unify(LHS0, RHS0, _UniMode, Unification0, UnifyContext),
+ modecheck_goal_unify(LHS0, RHS0, Unification0, UnifyContext, GoalInfo0,
+ GoalExpr, !ModeInfo)
+ ;
+ GoalExpr0 = plain_call(PredId, ProcId0, Args0, _Builtin,
+ MaybeCallUnifyContext, PredName),
+ modecheck_goal_plain_call(PredId, ProcId0, Args0,
+ MaybeCallUnifyContext, PredName, GoalInfo0, GoalExpr,
+ !ModeInfo)
+ ;
+ GoalExpr0 = generic_call(GenericCall, Args0, Modes0, _Detism),
+ modecheck_goal_generic_call(GenericCall, Args0, Modes0, GoalInfo0,
+ GoalExpr, !ModeInfo)
+ ;
+ GoalExpr0 = call_foreign_proc(Attributes, PredId, ProcId0,
+ Args0, ExtraArgs, MaybeTraceRuntimeCond, PragmaCode),
+ modecheck_goal_call_foreign_proc(Attributes, PredId, ProcId0,
+ Args0, ExtraArgs, MaybeTraceRuntimeCond, PragmaCode,
+ GoalInfo0, GoalExpr, !ModeInfo)
+ ;
+ GoalExpr0 = conj(ConjType, Goals),
+ modecheck_goal_conj(ConjType, Goals, GoalInfo0, GoalExpr,
+ !ModeInfo)
+ ;
+ GoalExpr0 = disj(Goals),
+ modecheck_goal_disj(Goals, GoalInfo0, GoalExpr, !ModeInfo)
+ ;
+ GoalExpr0 = switch(Var, CanFail, Cases0),
+ modecheck_goal_switch(Var, CanFail, Cases0, GoalInfo0, GoalExpr,
+ !ModeInfo)
+ ;
+ GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
+ modecheck_goal_if_then_else(Vars, Cond0, Then0, Else0, GoalInfo0,
+ GoalExpr, !ModeInfo)
+ ;
+ GoalExpr0 = negation(SubGoal0),
+ modecheck_goal_negation(SubGoal0, GoalInfo0, GoalExpr, !ModeInfo)
+ ;
+ GoalExpr0 = scope(Reason, SubGoal0),
+ modecheck_goal_scope(Reason, SubGoal0, GoalInfo0, GoalExpr, !ModeInfo)
+ ;
+ GoalExpr0 = shorthand(ShortHand0),
+ modecheck_goal_shorthand(ShortHand0, GoalInfo0, GoalExpr, !ModeInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck conjunctions. Most of the work is done by modecheck_conj.m.
+%
+
+:- pred modecheck_goal_conj(conj_type::in, list(hlds_goal)::in,
+ hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_conj(ConjType, Goals0, GoalInfo0, GoalExpr, !ModeInfo) :-
+ (
+ ConjType = plain_conj,
+ mode_checkpoint(enter, "conj", !ModeInfo),
+ (
+ Goals0 = [],
+ % Optimize the common case for efficiency.
+ GoalExpr = conj(plain_conj, [])
+ ;
+ Goals0 = [_ | _],
+ modecheck_conj_list(ConjType, Goals0, Goals, !ModeInfo),
+ conj_list_to_goal(Goals, GoalInfo0, hlds_goal(GoalExpr, _GoalInfo))
+ ),
+ mode_checkpoint(exit, "conj", !ModeInfo)
+ ;
+ ConjType = parallel_conj,
+ mode_checkpoint(enter, "par_conj", !ModeInfo),
+ % Empty parallel conjunction should not be a common case.
+ modecheck_conj_list(ConjType, Goals0, Goals, !ModeInfo),
+ par_conj_list_to_goal(Goals, GoalInfo0, Goal),
+ Goal = hlds_goal(GoalExpr, _GoalInfo),
+ mode_checkpoint(exit, "par_conj", !ModeInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck disjunctions.
+%
+
+:- pred modecheck_goal_disj(list(hlds_goal)::in, hlds_goal_info::in,
+ hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
+
+modecheck_goal_disj(Disjuncts0, GoalInfo0, GoalExpr, !ModeInfo) :-
+ mode_checkpoint(enter, "disj", !ModeInfo),
+ (
+ Disjuncts0 = [], % for efficiency, optimize common case
+ GoalExpr = disj(Disjuncts0),
+ instmap.init_unreachable(InstMap),
+ mode_info_set_instmap(InstMap, !ModeInfo)
+ ;
+ % If you modify this code, you may also need to modify
+ % modecheck_clause_disj or the code that calls it.
+ Disjuncts0 = [_ | _],
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+ modecheck_disj_list(Disjuncts0, Disjuncts1, InstMaps0,
+ NonLocals, LargeFlatConstructs, !ModeInfo),
+ ( mode_info_solver_init_is_supported(!.ModeInfo) ->
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ handle_solver_vars_in_disjs(set.to_sorted_list(NonLocals),
+ VarTypes, Disjuncts1, Disjuncts2, InstMaps0, InstMaps,
+ !ModeInfo)
+ ;
+ InstMaps = InstMaps0,
+ Disjuncts2 = Disjuncts1
+ ),
+ Disjuncts3 = flatten_disjs(Disjuncts2),
+ merge_disj_branches(NonLocals, LargeFlatConstructs,
+ Disjuncts3, Disjuncts, InstMaps, !ModeInfo),
+ disj_list_to_goal(Disjuncts, GoalInfo0, hlds_goal(GoalExpr, _GoalInfo))
+ ),
+ mode_checkpoint(exit, "disj", !ModeInfo).
+
+:- pred modecheck_disj_list(list(hlds_goal)::in, list(hlds_goal)::out,
+ list(instmap)::out, set(prog_var)::in, set(prog_var)::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_disj_list([], [], [], !LargeFlatConstructs, !ModeInfo).
+modecheck_disj_list([Goal0 | Goals0], [Goal | Goals], [InstMap | InstMaps],
+ !LargeFlatConstructs, !ModeInfo) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ modecheck_goal(Goal0, Goal, !ModeInfo),
+ accumulate_large_flat_constructs(Goal, !LargeFlatConstructs),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ modecheck_disj_list(Goals0, Goals, InstMaps, !LargeFlatConstructs,
+ !ModeInfo).
+
+:- pred merge_disj_branches(set(prog_var)::in, set(prog_var)::in,
+ list(hlds_goal)::in, list(hlds_goal)::out, list(instmap)::in,
+ mode_info::in, mode_info::out) is det.
+
+merge_disj_branches(NonLocals, LargeFlatConstructs, Disjuncts0, Disjuncts,
+ InstMaps0, !ModeInfo) :-
+ ( set.empty(LargeFlatConstructs) ->
+ Disjuncts = Disjuncts0,
+ InstMaps = InstMaps0
+ ;
+ % The instmaps will each map every var in LargeFlatConstructs
+ % to a very big inst. This means that instmap_merge will take a long
+ % time on those variables and add lots of big insts to the merge_inst
+ % table. That in turn will cause the later equiv_type_hlds pass
+ % to take a long time processing the merge_inst table. All this
+ % expense is for nothing, since the chances that the following code
+ % wants to know the precise set of possible bindings of variables
+ % constructed in what are effectively fact tables is astronomically
+ % small.
+ %
+ % For the variables in LargeFlatConstructs, we know that their
+ % final insts do not cause unreachability, do not have uniqueness,
+ % do not have higher order inst info, and any information they contain
+ % about specific bindings is something we are better off without.
+ % We therefore just map all these variables to ground in the instmaps
+ % of all the arms before merging them.
+
+ list.map(
+ set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs),
+ Disjuncts0, Disjuncts),
+ LargeFlatConstructList = set.to_sorted_list(LargeFlatConstructs),
+ list.map(
+ instmap_set_vars_same(ground(shared, none),
+ LargeFlatConstructList),
+ InstMaps0, InstMaps)
+ ),
+ instmap_merge(NonLocals, InstMaps, merge_disj, !ModeInfo).
+
+ % Ensure that any non-local solver var that is initialised in
+ % one disjunct is initialised in all disjuncts.
+ %
+:- pred handle_solver_vars_in_disjs(list(prog_var)::in,
+ vartypes::in, list(hlds_goal)::in, list(hlds_goal)::out,
+ list(instmap)::in, list(instmap)::out, mode_info::in, mode_info::out)
+ is det.
+
+handle_solver_vars_in_disjs(NonLocals, VarTypes, Disjs0, Disjs,
+ InstMaps0, InstMaps, !ModeInfo) :-
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ EnsureInitialised = solver_vars_that_must_be_initialised(NonLocals,
+ VarTypes, ModuleInfo, InstMaps0),
+ add_necessary_disj_init_calls(Disjs0, Disjs, InstMaps0, InstMaps,
+ EnsureInitialised, !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck switches.
+%
+
+:- pred modecheck_goal_switch(prog_var::in, can_fail::in, list(case)::in,
+ hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_switch(Var, CanFail, Cases0, GoalInfo0, GoalExpr, !ModeInfo) :-
+ mode_checkpoint(enter, "switch", !ModeInfo),
+ (
+ Cases0 = [],
+ Cases = [],
+ instmap.init_unreachable(InstMap),
+ mode_info_set_instmap(InstMap, !ModeInfo)
+ ;
+ % If you modify this code, you may also need to modify
+ % modecheck_clause_switch or the code that calls it.
+ Cases0 = [_ | _],
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+ modecheck_case_list(Cases0, Var, Cases1, InstMaps,
+ NonLocals, LargeFlatConstructs, !ModeInfo),
+ merge_switch_branches(NonLocals, LargeFlatConstructs,
+ Cases1, Cases, InstMaps, !ModeInfo)
+ ),
+ GoalExpr = switch(Var, CanFail, Cases),
+ mode_checkpoint(exit, "switch", !ModeInfo).
+
+:- pred modecheck_case_list(list(case)::in, prog_var::in, list(case)::out,
+ list(instmap)::out, set(prog_var)::in, set(prog_var)::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_case_list([], _Var, [], [], !LargeFlatConstructs, !ModeInfo).
+modecheck_case_list([Case0 | Cases0], Var, [Case | Cases],
+ [InstMap | InstMaps], !LargeFlatConstructs, !ModeInfo) :-
+ Case0 = case(MainConsId, OtherConsIds, Goal0),
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+
+ % Record the fact that Var was bound to ConsId in the instmap
+ % before processing this case.
+ modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo),
+
+ % Modecheck this case (if it is reachable).
+ mode_info_get_instmap(!.ModeInfo, InstMap1),
+ ( instmap_is_reachable(InstMap1) ->
+ modecheck_goal(Goal0, Goal1, !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMap)
+ ;
+ % We should not mode-analyse the goal, since it is unreachable.
+ % Instead we optimize the goal away, so that later passes
+ % won't complain about it not having mode information.
+ Goal1 = true_goal,
+ InstMap = InstMap1
+ ),
+
+ % Don't lose the information added by the functor test above.
+ fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal1, Goal),
+
+ Case = case(MainConsId, OtherConsIds, Goal),
+ accumulate_large_flat_constructs(Goal, !LargeFlatConstructs),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ modecheck_case_list(Cases0, Var, Cases, InstMaps, !LargeFlatConstructs,
+ !ModeInfo).
+
+:- pred merge_switch_branches(set(prog_var)::in, set(prog_var)::in,
+ list(case)::in, list(case)::out, list(instmap)::in,
+ mode_info::in, mode_info::out) is det.
+
+merge_switch_branches(NonLocals, LargeFlatConstructs, Cases0, Cases,
+ InstMaps0, !ModeInfo) :-
+ ( set.empty(LargeFlatConstructs) ->
+ Cases = Cases0,
+ InstMaps = InstMaps0
+ ;
+ % The same considerations apply here as in merge_disj_branches.
+ list.map(
+ set_large_flat_constructs_to_ground_in_case(LargeFlatConstructs),
+ Cases0, Cases),
+ LargeFlatConstructList = set.to_sorted_list(LargeFlatConstructs),
+ list.map(
+ instmap_set_vars_same(ground(shared, none),
+ LargeFlatConstructList),
+ InstMaps0, InstMaps)
+ ),
+ instmap_merge(NonLocals, InstMaps, merge_disj, !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Utility predicates used to help optimize the modechecking of disjunctions and
+% switches.
+%
+
+:- pred accumulate_large_flat_constructs(hlds_goal::in,
+ set(prog_var)::in, set(prog_var)::out) is det.
+
+accumulate_large_flat_constructs(Goal, !LargeFlatConstructs) :-
+ ( set.empty(!.LargeFlatConstructs) ->
+ % Calling goal_large_flat_constructs and then set.intersect
+ % would be waste of time; !:LargeFlatConstructs will still be empty.
+ true
+ ;
+ GoalLargeFlatConstructs = goal_large_flat_constructs(Goal),
+ set.intersect(GoalLargeFlatConstructs, !LargeFlatConstructs)
+ ).
+
+:- func goal_large_flat_constructs(hlds_goal) = set(prog_var).
+
+goal_large_flat_constructs(Goal) = LargeFlatConstructs :-
+ Goal = hlds_goal(GoalExpr, _),
+ (
+ GoalExpr = unify(_, _, _, _, _),
+ % Unifications not wrapped in from_ground_term_construct scopes
+ % are never marked by the modechecker as being constructed statically.
+ LargeFlatConstructs = set.init
+ ;
+ ( GoalExpr = plain_call(_, _, _, _, _, _)
+ ; GoalExpr = generic_call(_, _, _, _)
+ ; GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
+ ),
+ LargeFlatConstructs = set.init
+ ;
+ ( GoalExpr = disj(_)
+ ; GoalExpr = switch(_, _, _)
+ ; GoalExpr = if_then_else(_, _, _, _)
+ ; GoalExpr = negation(_)
+ ; GoalExpr = shorthand(_)
+ ; GoalExpr = conj(parallel_conj, _)
+ ),
+ LargeFlatConstructs = set.init
+ ;
+ GoalExpr = scope(Reason, _),
+ (
+ Reason = from_ground_term(TermVar, from_ground_term_construct),
+ LargeFlatConstructs = set.make_singleton_set(TermVar)
+ ;
+ ( Reason = from_ground_term(_, from_ground_term_deconstruct)
+ ; Reason = from_ground_term(_, from_ground_term_other)
+ ; Reason = exist_quant(_)
+ ; Reason = promise_solutions(_, _)
+ ; Reason = promise_purity(_)
+ ; Reason = commit(_)
+ ; Reason = barrier(_)
+ ; Reason = trace_goal(_, _, _, _, _)
+ ),
+ LargeFlatConstructs = set.init
+ )
+ ;
+ GoalExpr = conj(plain_conj, Conjuncts),
+ goals_large_flat_constructs(Conjuncts, set.init, LargeFlatConstructs)
+ ).
+
+:- pred goals_large_flat_constructs(list(hlds_goal)::in,
+ set(prog_var)::in, set(prog_var)::out) is det.
+
+goals_large_flat_constructs([], !LargeFlatConstructs).
+goals_large_flat_constructs([Goal | Goals], !LargeFlatConstructs) :-
+ GoalLargeFlatConstructs = goal_large_flat_constructs(Goal),
+ set.union(GoalLargeFlatConstructs, !LargeFlatConstructs),
+ goals_large_flat_constructs(Goals, !LargeFlatConstructs).
+
+:- pred set_large_flat_constructs_to_ground_in_goal(set(prog_var)::in,
+ hlds_goal::in, hlds_goal::out) is det.
+
+set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs,
+ Goal0, Goal) :-
+ Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
+ (
+ GoalExpr0 = unify(_, _, _, _, _),
+ Goal = Goal0
+ ;
+ ( GoalExpr0 = plain_call(_, _, _, _, _, _)
+ ; GoalExpr0 = generic_call(_, _, _, _)
+ ; GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _)
+ ),
+ Goal = Goal0
+ ;
+ ( GoalExpr0 = disj(_)
+ ; GoalExpr0 = switch(_, _, _)
+ ; GoalExpr0 = if_then_else(_, _, _, _)
+ ; GoalExpr0 = negation(_)
+ ; GoalExpr0 = shorthand(_)
+ ; GoalExpr0 = conj(parallel_conj, _)
+ ),
+ Goal = Goal0
+ ;
+ GoalExpr0 = scope(Reason, SubGoal0),
+ (
+ Reason = from_ground_term(TermVar, from_ground_term_construct),
+ ( set.member(TermVar, LargeFlatConstructs) ->
+ InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
+ instmap_delta_set_var(TermVar, ground(shared, none),
+ InstMapDelta0, InstMapDelta),
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo),
+
+ SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo0),
+ goal_info_set_instmap_delta(InstMapDelta,
+ SubGoalInfo0, SubGoalInfo),
+ % We could also replace the instmap deltas of the conjuncts
+ % inside SubGoalExpr0. Doing so would take time but reduce
+ % the compiler's memory requirements.
+ SubGoal = hlds_goal(SubGoalExpr0, SubGoalInfo),
+ GoalExpr = scope(Reason, SubGoal),
+ Goal = hlds_goal(GoalExpr, GoalInfo)
+ ;
+ Goal = Goal0
+ )
+ ;
+ ( Reason = from_ground_term(_, from_ground_term_deconstruct)
+ ; Reason = from_ground_term(_, from_ground_term_other)
+ ; Reason = exist_quant(_)
+ ; Reason = promise_solutions(_, _)
+ ; Reason = promise_purity(_)
+ ; Reason = commit(_)
+ ; Reason = barrier(_)
+ ; Reason = trace_goal(_, _, _, _, _)
+ ),
+ Goal = Goal0
+ )
+ ;
+ GoalExpr0 = conj(plain_conj, Conjuncts0),
+ set_large_flat_constructs_to_ground_in_goals(LargeFlatConstructs,
+ Conjuncts0, Conjuncts),
+ GoalExpr = conj(plain_conj, Conjuncts),
+
+ InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
+ instmap_delta_changed_vars(InstMapDelta0, ChangedVars),
+ set.intersect(ChangedVars, LargeFlatConstructs, GroundVars),
+ instmap_delta_set_vars_same(ground(shared, none),
+ set.to_sorted_list(GroundVars), InstMapDelta0, InstMapDelta),
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo),
+ Goal = hlds_goal(GoalExpr, GoalInfo)
+ ).
+
+:- pred set_large_flat_constructs_to_ground_in_goals(set(prog_var)::in,
+ list(hlds_goal)::in, list(hlds_goal)::out) is det.
+
+set_large_flat_constructs_to_ground_in_goals(_, [], []).
+set_large_flat_constructs_to_ground_in_goals(LargeFlatConstructs,
+ [Goal0 | Goals0], [Goal | Goals]) :-
+ set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs,
+ Goal0, Goal),
+ set_large_flat_constructs_to_ground_in_goals(LargeFlatConstructs,
+ Goals0, Goals).
+
+:- pred set_large_flat_constructs_to_ground_in_case(set(prog_var)::in,
+ case::in, case::out) is det.
+
+set_large_flat_constructs_to_ground_in_case(LargeFlatConstructs,
+ Case0, Case) :-
+ Case0 = case(MainConsId, OtherConsIds, Goal0),
+ set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs,
+ Goal0, Goal),
+ Case = case(MainConsId, OtherConsIds, Goal).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck if-then-elses.
+%
+
+:- pred modecheck_goal_if_then_else(list(prog_var)::in,
+ hlds_goal::in, hlds_goal::in, hlds_goal::in,
+ hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_if_then_else(Vars, Cond0, Then0, Else0, GoalInfo0, GoalExpr,
+ !ModeInfo) :-
+ mode_checkpoint(enter, "if-then-else", !ModeInfo),
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+ ThenVars = goal_get_nonlocals(Then0),
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+
+ % We need to lock the non-local variables, to ensure that the condition
+ % of the if-then-else does not bind them.
+
+ mode_info_lock_vars(var_lock_if_then_else, NonLocals, !ModeInfo),
+ mode_info_add_live_vars(ThenVars, !ModeInfo),
+ modecheck_goal(Cond0, Cond, !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMapCond),
+ mode_info_remove_live_vars(ThenVars, !ModeInfo),
+ mode_info_unlock_vars(var_lock_if_then_else, NonLocals, !ModeInfo),
+ ( instmap_is_reachable(InstMapCond) ->
+ modecheck_goal(Then0, Then1, !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMapThen1)
+ ;
+ % We should not mode-analyse the goal, since it is unreachable.
+ % Instead we optimize the goal away, so that later passes
+ % won't complain about it not having mode information.
+ Then1 = true_goal,
+ InstMapThen1 = InstMapCond
+ ),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ modecheck_goal(Else0, Else1, !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMapElse1),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ handle_solver_vars_in_ite(set.to_sorted_list(NonLocals), VarTypes,
+ Then1, Then, Else1, Else,
+ InstMapThen1, InstMapThen, InstMapElse1, InstMapElse, !ModeInfo),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ instmap_merge(NonLocals, [InstMapThen, InstMapElse], merge_if_then_else,
+ !ModeInfo),
+ GoalExpr = if_then_else(Vars, Cond, Then, Else),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ mode_info_get_in_promise_purity_scope(!.ModeInfo, InPromisePurityScope),
+ (
+ InPromisePurityScope = not_in_promise_purity_scope,
+ CondNonLocals0 = goal_get_nonlocals(Cond),
+ CondNonLocals =
+ set.to_sorted_list(CondNonLocals0 `intersect` NonLocals),
+ check_no_inst_any_vars(if_then_else, CondNonLocals,
+ InstMap0, InstMap, !ModeInfo)
+ ;
+ InPromisePurityScope = in_promise_purity_scope
+ ),
+ mode_checkpoint(exit, "if-then-else", !ModeInfo).
+
+:- pred handle_solver_vars_in_ite(list(prog_var)::in, vartypes::in,
+ hlds_goal::in, hlds_goal::out, hlds_goal::in, hlds_goal::out,
+ instmap::in, instmap::out, instmap::in, instmap::out, mode_info::in,
+ mode_info::out) is det.
+
+handle_solver_vars_in_ite(NonLocals, VarTypes, Then0, Then, Else0, Else,
+ ThenInstMap0, ThenInstMap, ElseInstMap0, ElseInstMap, !ModeInfo) :-
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ EnsureInitialised = solver_vars_that_must_be_initialised(NonLocals,
+ VarTypes, ModuleInfo, [ThenInstMap0, ElseInstMap0]),
+
+ ThenVarsToInit = solver_vars_to_init(EnsureInitialised, ModuleInfo,
+ ThenInstMap0),
+ construct_initialisation_calls(ThenVarsToInit, ThenInitCalls, !ModeInfo),
+ InitedThenVars = list_to_set(ThenVarsToInit),
+ Then = append_init_calls_to_goal(InitedThenVars, ThenInitCalls, Then0),
+ instmap_set_vars_same(any_inst, ThenVarsToInit, ThenInstMap0, ThenInstMap),
+
+ ElseVarsToInit = solver_vars_to_init(EnsureInitialised, ModuleInfo,
+ ElseInstMap0),
+ construct_initialisation_calls(ElseVarsToInit, ElseInitCalls, !ModeInfo),
+ InitedElseVars = list_to_set(ElseVarsToInit),
+ Else = append_init_calls_to_goal(InitedElseVars, ElseInitCalls, Else0),
+ instmap_set_vars_same(any_inst, ElseVarsToInit, ElseInstMap0, ElseInstMap).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck negations.
+%
+
+:- pred modecheck_goal_negation(hlds_goal::in, hlds_goal_info::in,
+ hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
+
+modecheck_goal_negation(SubGoal0, GoalInfo0, GoalExpr, !ModeInfo) :-
+ mode_checkpoint(enter, "not", !ModeInfo),
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+
+ % When analyzing a negated goal, nothing is forward-live (live on forward
+ % execution after that goal), because if the goal succeeds then execution
+ % will immediately backtrack. So we need to set the live variables set
+ % to empty here. This allows those variables to be backtrackably
+ % destructively updated. (If you try to do non-backtrackable destructive
+ % update on such a variable, it will be caught later on by unique_modes.m.)
+ mode_info_get_live_vars(!.ModeInfo, LiveVars0),
+ mode_info_set_live_vars(bag.init, !ModeInfo),
+
+ % We need to lock the non-local variables, to ensure that
+ % the negation does not bind them.
+ mode_info_lock_vars(var_lock_negation, NonLocals, !ModeInfo),
+ modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
+ mode_info_set_live_vars(LiveVars0, !ModeInfo),
+ mode_info_unlock_vars(var_lock_negation, NonLocals, !ModeInfo),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ mode_info_get_in_promise_purity_scope(!.ModeInfo, InPromisePurityScope),
+ (
+ InPromisePurityScope = not_in_promise_purity_scope,
+ NegNonLocals = goal_info_get_nonlocals(GoalInfo0),
+ instmap.init_unreachable(Unreachable),
+ check_no_inst_any_vars(negation, set.to_sorted_list(NegNonLocals),
+ InstMap0, Unreachable, !ModeInfo)
+ ;
+ InPromisePurityScope = in_promise_purity_scope
+ ),
+ GoalExpr = negation(SubGoal),
+ mode_checkpoint(exit, "not", !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck scope goals.
+%
+
+:- pred modecheck_goal_scope(scope_reason::in, hlds_goal::in,
+ hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_scope(Reason, SubGoal0, GoalInfo0, GoalExpr, !ModeInfo) :-
+ (
+ Reason = trace_goal(_, _, _, _, _),
+ mode_checkpoint(enter, "scope", !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+ % We need to lock the non-local variables, to ensure that
+ % the trace goal does not bind them. If it did, then the code
+ % would not be valid with the trace goal disabled.
+ mode_info_lock_vars(var_lock_trace_goal, NonLocals, !ModeInfo),
+ modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
+ mode_info_unlock_vars(var_lock_trace_goal, NonLocals, !ModeInfo),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ GoalExpr = scope(Reason, SubGoal),
+ mode_checkpoint(exit, "scope", !ModeInfo)
+ ;
+ ( Reason = exist_quant(_)
+ ; Reason = promise_solutions(_, _)
+ ; Reason = commit(_)
+ ; Reason = barrier(_)
+ ),
+ mode_checkpoint(enter, "scope", !ModeInfo),
+ modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
+ GoalExpr = scope(Reason, SubGoal),
+ mode_checkpoint(exit, "scope", !ModeInfo)
+ ;
+ Reason = from_ground_term(TermVar, _),
+ mode_checkpoint(enter, "scope", !ModeInfo),
+ modecheck_goal_from_ground_term_scope(TermVar, SubGoal0, GoalInfo0,
+ Kind1, SubGoal1, !ModeInfo),
+ mode_checkpoint(exit, "scope", !ModeInfo),
+ mode_info_set_had_from_ground_term(had_from_ground_term_scope,
+ !ModeInfo),
+
+ mode_info_get_make_ground_terms_unique(!.ModeInfo,
+ MakeGroundTermsUnique),
+ (
+ MakeGroundTermsUnique = do_not_make_ground_terms_unique,
+ UpdatedReason1 = from_ground_term(TermVar, Kind1),
+ GoalExpr = scope(UpdatedReason1, SubGoal1)
+ ;
+ MakeGroundTermsUnique = make_ground_terms_unique,
+ (
+ Kind1 = from_ground_term_construct,
+ modecheck_goal_make_ground_term_unique(TermVar,
+ SubGoal1, GoalInfo0, GoalExpr, !ModeInfo)
+ ;
+ ( Kind1 = from_ground_term_deconstruct
+ ; Kind1 = from_ground_term_other
+ ),
+ % Do not wrap the subgoal up in a scope, since these scopes
+ % do not get useful any special treatment.
+ SubGoal1 = hlds_goal(GoalExpr, _)
+ )
+ )
+ ;
+ Reason = promise_purity(_Purity),
+ mode_info_get_in_promise_purity_scope(!.ModeInfo, InPPScope),
+ mode_info_set_in_promise_purity_scope(in_promise_purity_scope,
+ !ModeInfo),
+ mode_checkpoint(enter, "scope", !ModeInfo),
+ modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
+ GoalExpr = scope(Reason, SubGoal),
+ mode_checkpoint(exit, "scope", !ModeInfo),
+ mode_info_set_in_promise_purity_scope(InPPScope, !ModeInfo)
+ ).
+
+ % This predicate transforms
+ %
+ % scope(TermVar,
+ % conj(plain_conj,
+ % X1 = ...
+ % X2 = ...
+ % ...
+ % TermVar = ...
+ % )
+ % )
+ %
+ % into
+ %
+ % conj(plain_conj,
+ % scope(TermVar,
+ % conj(plain_conj,
+ % X1 = ...
+ % X2 = ...
+ % ...
+ % CloneVar = ...
+ % )
+ % ),
+ % builtin.copy(CloneVar, TermVar)
+ % )
+ %
+ % We could transform it instead into a plain conjunction that directly
+ % builds a unique term, but that could have a significant detrimental
+ % effect on compile time.
+ %
+ % The performance of the generated code is unlikely to be of too much
+ % importance, since we expect programs will rarely need a unique copy
+ % of a ground term.
+ %
+:- pred modecheck_goal_make_ground_term_unique(prog_var::in,
+ hlds_goal::in, hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_make_ground_term_unique(TermVar, SubGoal0, GoalInfo0, GoalExpr,
+ !ModeInfo) :-
+ mode_info_get_var_types(!.ModeInfo, VarTypes0),
+ mode_info_get_varset(!.ModeInfo, VarSet0),
+ varset.new_var(VarSet0, CloneVar, VarSet),
+ map.lookup(VarTypes0, TermVar, TermVarType),
+ map.det_insert(VarTypes0, CloneVar, TermVarType, VarTypes),
+ mode_info_set_varset(VarSet, !ModeInfo),
+ mode_info_set_var_types(VarTypes, !ModeInfo),
+ map.det_insert(map.init, TermVar, CloneVar, Rename),
+ % By construction, TermVar can appear only in (a) SubGoal0's goal_info,
+ % and (b) in the last conjunct in SubGoal0's goal_expr; it cannot appear
+ % in any of the other conjuncts. We could make this code more efficient
+ % by exploiting this fact, but there is not yet any evidence of any need
+ % for this.
+ rename_some_vars_in_goal(Rename, SubGoal0, SubGoal),
+ rename_vars_in_goal_info(need_not_rename, Rename, GoalInfo0,
+ ScopeGoalInfo1),
+
+ % We must put the instmaps into the goal_infos of all the subgoals of the
+ % final GoalExpr we return, since modecheck_goal will not get a chance to
+ % do so.
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ instmap_lookup_var(InstMap0, TermVar, TermVarOldInst),
+ ScopeInstMapDelta =
+ instmap_delta_from_assoc_list([CloneVar - TermVarOldInst]),
+ goal_info_set_instmap_delta(ScopeInstMapDelta,
+ ScopeGoalInfo1, ScopeGoalInfo),
+
+ Reason = from_ground_term(CloneVar, from_ground_term_construct),
+ ScopeGoalExpr = scope(Reason, SubGoal),
+ ScopeGoal = hlds_goal(ScopeGoalExpr, ScopeGoalInfo),
+
+ % We could get a more accurate new inst for TermVar by replacing
+ % all the "shared" functors in TermVarOldInst with "unique".
+ % However, this should be good enough. XXX wangp, is this right?
+ TermVarUniqueInst = ground(unique, none),
+
+ instmap_set_var(CloneVar, TermVarOldInst, InstMap0, InstMap1),
+ mode_info_set_instmap(InstMap1, !ModeInfo),
+
+ Context = goal_info_get_context(GoalInfo0),
+ modecheck_make_type_info_var_for_type(TermVarType, Context, TypeInfoVar,
+ TypeInfoGoals, !ModeInfo),
+
+ InstMapDelta =
+ instmap_delta_from_assoc_list([TermVar - TermVarUniqueInst]),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ generate_simple_call(mercury_public_builtin_module, "copy", pf_predicate,
+ mode_no(1), detism_det, purity_pure, [TypeInfoVar, CloneVar, TermVar],
+ [], InstMapDelta, ModuleInfo, Context, CopyGoal),
+ mode_info_get_instmap(!.ModeInfo, InstMap2),
+ instmap_set_var(TermVar, TermVarUniqueInst, InstMap2, InstMap),
+ mode_info_set_instmap(InstMap, !ModeInfo),
+
+ GoalExpr = conj(plain_conj, [ScopeGoal | TypeInfoGoals] ++ [CopyGoal]).
+
+:- pred modecheck_make_type_info_var_for_type(mer_type::in, prog_context::in,
+ prog_var::out, list(hlds_goal)::out, mode_info::in, mode_info::out) is det.
+
+modecheck_make_type_info_var_for_type(Type, Context, TypeInfoVar,
+ TypeInfoGoals, !ModeInfo) :-
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+
+ % Get the relevant information for the current procedure.
+ mode_info_get_pred_id(!.ModeInfo, PredId),
+ mode_info_get_proc_id(!.ModeInfo, ProcId),
+ module_info_pred_proc_info(ModuleInfo0, PredId, ProcId, PredInfo0,
+ ProcInfo0),
+
+ % Create a poly_info for the current procedure. We have to set the varset
+ % and vartypes from the mode_info, not the proc_info, because new vars may
+ % have been introduced during mode analysis, e.g. when adding
+ % unifications to handle implied modes.
+ mode_info_get_var_types(!.ModeInfo, VarTypes0),
+ mode_info_get_varset(!.ModeInfo, VarSet0),
+ proc_info_set_varset(VarSet0, ProcInfo0, ProcInfo1),
+ proc_info_set_vartypes(VarTypes0, ProcInfo1, ProcInfo2),
+ polymorphism.create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2,
+ PolyInfo0),
+
+ polymorphism_make_type_info_var(Type, Context, TypeInfoVar, TypeInfoGoals,
+ PolyInfo0, PolyInfo),
+
+ % Update the information in the predicate table.
+ polymorphism.poly_info_extract(PolyInfo, PredInfo0, PredInfo,
+ ProcInfo2, ProcInfo, ModuleInfo1),
+ module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
+ ModuleInfo1, ModuleInfo),
+
+ % Update the information in the mode_info.
+ proc_info_get_varset(ProcInfo, VarSet),
+ proc_info_get_vartypes(ProcInfo, VarTypes),
+ mode_info_set_varset(VarSet, !ModeInfo),
+ mode_info_set_var_types(VarTypes, !ModeInfo),
+ mode_info_set_module_info(ModuleInfo, !ModeInfo).
+
+:- pred modecheck_goal_from_ground_term_scope(prog_var::in,
+ hlds_goal::in, hlds_goal_info::in, from_ground_term_kind::out,
+ hlds_goal::out, mode_info::in, mode_info::out) is det.
+
+modecheck_goal_from_ground_term_scope(TermVar, SubGoal0, GoalInfo0,
+ Kind, SubGoal, !ModeInfo) :-
+ % The original goal does no quantification, so deleting the `scope'
+ % would be OK. However, deleting it during mode analysis would mean
+ % we don't have it during unique mode analysis and other later compiler
+ % passes.
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ instmap_lookup_var(InstMap0, TermVar, TermVarInst),
+ mode_info_get_varset(!.ModeInfo, VarSet),
+ modecheck_specializable_ground_term(SubGoal0, TermVar, TermVarInst,
+ MaybeGroundTermMode),
+ (
+ MaybeGroundTermMode = yes(construct_ground_term(RevConj0)),
+ SubGoal0 = hlds_goal(_, SubGoalInfo0),
+ modecheck_ground_term_construct(TermVar, RevConj0,
+ SubGoalInfo0, VarSet, SubGoal, !ModeInfo),
+ Kind = from_ground_term_construct
+ ;
+ (
+ MaybeGroundTermMode = yes(deconstruct_ground_term(_)),
+ % We should specialize the handling of these scopes as well as
+ % scopes that construct ground terms, but we don't yet have
+ % a compelling motivating example.
+ SubGoal1 = SubGoal0,
+ Kind = from_ground_term_deconstruct
+ ;
+ MaybeGroundTermMode = no,
+ (
+ TermVarInst = free,
+ SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo0),
+ SubGoalExpr0 = conj(plain_conj, SubGoalConjuncts0)
+ ->
+ % We reverse the list here for the same reason
+ % modecheck_specializable_ground_term does in the
+ % corresponding case.
+ list.reverse(SubGoalConjuncts0, SubGoalConjuncts1),
+ SubGoalExpr1 = conj(plain_conj, SubGoalConjuncts1),
+ SubGoal1 = hlds_goal(SubGoalExpr1, SubGoalInfo0)
+ ;
+ SubGoal1 = SubGoal0
+ ),
+ Kind = from_ground_term_other
+ ),
+ ( goal_info_has_feature(GoalInfo0, feature_from_head) ->
+ attach_features_to_all_goals([feature_from_head],
+ attach_in_from_ground_term, SubGoal1, SubGoal2)
+ ;
+ SubGoal2 = SubGoal1
+ ),
+ mode_checkpoint(enter, "scope", !ModeInfo),
+ modecheck_goal(SubGoal2, SubGoal, !ModeInfo),
+ mode_checkpoint(exit, "scope", !ModeInfo)
+ ).
+
+:- type ground_term_mode
+ ---> construct_ground_term(list(hlds_goal))
+ ; deconstruct_ground_term(list(hlds_goal)).
+
+:- pred modecheck_specializable_ground_term(hlds_goal::in, prog_var::in,
+ mer_inst::in, maybe(ground_term_mode)::out) is det.
+
+modecheck_specializable_ground_term(SubGoal, TermVar, TermVarInst,
+ MaybeGroundTermMode) :-
+ SubGoal = hlds_goal(SubGoalExpr, SubGoalInfo),
+ (
+ NonLocals = goal_info_get_nonlocals(SubGoalInfo),
+ set.singleton_set(NonLocals, TermVar),
+ goal_info_get_purity(SubGoalInfo) = purity_pure,
+ SubGoalExpr = conj(plain_conj, [UnifyTermGoal | UnifyArgGoals]),
+ % If TermVar is created by an impure unification, which is
+ % possible for solver types, it is possible for UnifyTermGoal
+ % to contain a unification other than one involving TermVar.
+ UnifyTermGoal ^ hlds_goal_expr = unify(TermVar, _, _, _, _),
+ all_plain_construct_unifies([UnifyTermGoal | UnifyArgGoals])
+ ->
+ ( TermVarInst = free ->
+ % UnifyTerm unifies TermVar with the arguments created
+ % by UnifyArgs. Since TermVar is now free and the
+ % argument variables haven't been encountered yet,
+ % UnifyTerm cannot succeed until *after* the argument
+ % variables become ground.
+ %
+ % Putting UnifyTerm after UnifyArgs here is much more efficient
+ % than letting the usual more ordering algorithm delay it
+ % repeatedly: it is linear instead of quadratic.
+
+ list.reverse([UnifyTermGoal | UnifyArgGoals], RevConj),
+ MaybeGroundTermMode = yes(construct_ground_term(RevConj))
+ ; TermVarInst = ground(shared, none) ->
+ Conj = [UnifyTermGoal | UnifyArgGoals],
+ MaybeGroundTermMode = yes(deconstruct_ground_term(Conj))
+ ;
+ MaybeGroundTermMode = no
+ )
+ ;
+ MaybeGroundTermMode = no
+ ).
+
+:- pred all_plain_construct_unifies(list(hlds_goal)::in) is semidet.
+
+all_plain_construct_unifies([]).
+all_plain_construct_unifies([Goal | Goals]) :-
+ Goal = hlds_goal(GoalExpr, _),
+ GoalExpr = unify(_LHSVar, RHS, _, _, _),
+ RHS = rhs_functor(_ConsId, no, _RHSVars),
+ all_plain_construct_unifies(Goals).
+
+:- pred modecheck_ground_term_construct(prog_var::in, list(hlds_goal)::in,
+ hlds_goal_info::in, prog_varset::in, hlds_goal::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_ground_term_construct(TermVar, ConjGoals0, !.SubGoalInfo, VarSet,
+ SubGoal, !ModeInfo) :-
+ map.init(LocalVarMap0),
+ modecheck_ground_term_construct_goal_loop(VarSet, ConjGoals0, ConjGoals,
+ LocalVarMap0, LocalVarMap),
+ map.lookup(LocalVarMap, TermVar, TermVarInfo),
+ TermVarInfo = construct_var_info(TermVarInst),
+ InstMapDelta = instmap_delta_from_assoc_list([TermVar - TermVarInst]),
+ goal_info_set_instmap_delta(InstMapDelta, !SubGoalInfo),
+ % We present the determinism, so that the determinism analysis pass
+ % does not have to traverse the goals inside the scope.
+ goal_info_set_determinism(detism_det, !SubGoalInfo),
+ SubGoalExpr = conj(plain_conj, ConjGoals),
+ SubGoal = hlds_goal(SubGoalExpr, !.SubGoalInfo),
+
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ instmap_set_var(TermVar, TermVarInst, InstMap0, InstMap),
+ mode_info_set_instmap(InstMap, !ModeInfo).
+
+:- type construct_var_info
+ ---> construct_var_info(mer_inst).
+
+:- type construct_var_info_map == map(prog_var, construct_var_info).
+
+:- pred modecheck_ground_term_construct_goal_loop(prog_varset::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ construct_var_info_map::in, construct_var_info_map::out) is det.
+
+modecheck_ground_term_construct_goal_loop(_, [], [], !LocalVarMap).
+modecheck_ground_term_construct_goal_loop(VarSet,
+ [Goal0 | Goals0], [Goal | Goals], !LocalVarMap) :-
+ Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
+ (
+ GoalExpr0 = unify(LHSVar, RHS, _, _, UnifyContext),
+ RHS = rhs_functor(ConsId, no, RHSVars)
+ ->
+ % We could set TermInst to simply to ground, as opposed to the inst
+ % we now use which gives information about LHSVar's shape. This would
+ % remove the need for the inst information in !LocalVarMap, and
+ % would make HLDS dumps linear in the size of the term instead of
+ % quadratic. However, due to structure sharing, the actual memory
+ % requirements of these bound insts are only linear in the size of the
+ % term.
+ modecheck_ground_term_construct_arg_loop(RHSVars, ArgInsts, UniModes,
+ !LocalVarMap),
+ BoundInst = bound_functor(ConsId, ArgInsts),
+ TermInst = bound(shared, [BoundInst]),
+ LHSMode = (free -> TermInst),
+ RHSMode = (TermInst -> TermInst),
+ UnifyMode = LHSMode - RHSMode,
+ ConstructHow = construct_statically,
+ Uniqueness = cell_is_shared,
+ Unification = construct(LHSVar, ConsId, RHSVars, UniModes,
+ ConstructHow, Uniqueness, no_construct_sub_info),
+ GoalExpr = unify(LHSVar, RHS, UnifyMode, Unification, UnifyContext),
+ InstMapDelta = instmap_delta_from_assoc_list([LHSVar - TermInst]),
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo1),
+ % We preset the determinism, so that the determinism analysis pass
+ % does not have to traverse the goals inside the scope.
+ goal_info_set_determinism(detism_det, GoalInfo1, GoalInfo),
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+
+ LHSVarInfo = construct_var_info(TermInst),
+ svmap.det_insert(LHSVar, LHSVarInfo, !LocalVarMap)
+ ;
+ unexpected(this_file,
+ "modecheck_ground_term_construct_goal_loop: not rhs_functor unify")
+ ),
+ modecheck_ground_term_construct_goal_loop(VarSet, Goals0, Goals,
+ !LocalVarMap).
+
+:- pred modecheck_ground_term_construct_arg_loop(list(prog_var)::in,
+ list(mer_inst)::out, list(uni_mode)::out,
+ construct_var_info_map::in, construct_var_info_map::out) is det.
+
+modecheck_ground_term_construct_arg_loop([], [], [], !LocalVarMap).
+modecheck_ground_term_construct_arg_loop([Var | Vars], [VarInst | VarInsts],
+ [UniMode | UniModes], !LocalVarMap) :-
+ % Each variable introduced by the superhomogeneous transformation
+ % for a ground term appears in the from_ground_term scope exactly twice.
+ % Once when it is produced (which is handled in the goal loop predicate),
+ % and once when it is consumed, which is handled here.
+ %
+ % Since there will be no more appearances of this variable, we remove it
+ % from LocalVarMap. This greatly reduces the size of LocalVarMap.
+ svmap.det_remove(Var, VarInfo, !LocalVarMap),
+ VarInfo = construct_var_info(VarInst),
+ LHSOldInst = free,
+ RHSOldInst = VarInst,
+ LHSNewInst = VarInst,
+ RHSNewInst = VarInst,
+ UniMode = ((LHSOldInst - RHSOldInst) -> (LHSNewInst - RHSNewInst)),
+ modecheck_ground_term_construct_arg_loop(Vars, VarInsts, UniModes,
+ !LocalVarMap).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck plain calls. Most of the work is in modecheck_call.m.
+%
+
+:- pred modecheck_goal_plain_call(pred_id::in, proc_id::in,
+ list(prog_var)::in, maybe(call_unify_context)::in, sym_name::in,
+ hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_plain_call(PredId, ProcId0, Args0, MaybeCallUnifyContext,
+ PredName, GoalInfo0, GoalExpr, !ModeInfo) :-
+ PredNameString = sym_name_to_string(PredName),
+ CallString = "call " ++ PredNameString,
+ mode_checkpoint(enter, CallString, !ModeInfo),
+
+ mode_info_get_call_id(!.ModeInfo, PredId, CallId),
+ mode_info_set_call_context(call_context_call(plain_call_id(CallId)),
+ !ModeInfo),
+
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ DeterminismKnown = no,
+ modecheck_call_pred(PredId, DeterminismKnown, ProcId0, ProcId,
+ Args0, Args, GoalInfo0, ExtraGoals, !ModeInfo),
+
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ mode_info_get_pred_id(!.ModeInfo, CallerPredId),
+ Builtin = builtin_state(ModuleInfo, CallerPredId, PredId, ProcId),
+ Call = plain_call(PredId, ProcId, Args, Builtin, MaybeCallUnifyContext,
+ PredName),
+ handle_extra_goals(Call, ExtraGoals, GoalInfo0, Args0, Args,
+ InstMap0, GoalExpr, !ModeInfo),
+
+ mode_info_unset_call_context(!ModeInfo),
+ mode_checkpoint(exit, CallString, !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck generic calls.
+%
+
+:- pred modecheck_goal_generic_call(generic_call::in, list(prog_var)::in,
+ list(mer_mode)::in, hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_generic_call(GenericCall, Args0, Modes0, GoalInfo0, GoalExpr,
+ !ModeInfo) :-
+ mode_checkpoint(enter, "generic_call", !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+
+ hlds_goal.generic_call_id(GenericCall, CallId),
+ mode_info_set_call_context(call_context_call(CallId), !ModeInfo),
+ (
+ GenericCall = higher_order(PredVar, _, PredOrFunc, _),
+ modecheck_higher_order_call(PredOrFunc, PredVar,
+ Args0, Args, Modes, Det, ExtraGoals, !ModeInfo),
+ GoalExpr1 = generic_call(GenericCall, Args, Modes, Det),
+ AllArgs0 = [PredVar | Args0],
+ AllArgs = [PredVar | Args],
+ handle_extra_goals(GoalExpr1, ExtraGoals, GoalInfo0, AllArgs0, AllArgs,
+ InstMap0, GoalExpr, !ModeInfo)
+ ;
+ % Class method calls are added by polymorphism.m.
+ % XXX We should probably fill this in so that
+ % rerunning mode analysis works on code with typeclasses.
+ GenericCall = class_method(_, _, _, _),
+ unexpected(this_file, "modecheck_goal_expr: class_method_call")
+ ;
+ GenericCall = event_call(EventName),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ module_info_get_event_set(ModuleInfo, EventSet),
+ EventSpecMap = EventSet ^ event_set_spec_map,
+ ( event_arg_modes(EventSpecMap, EventName, ModesPrime) ->
+ Modes = ModesPrime
+ ;
+ % The typechecker should have caught the unknown event,
+ % and not let compilation of this predicate proceed any further.
+ unexpected(this_file, "modecheck_goal_expr: unknown event")
+ ),
+ modecheck_event_call(Modes, Args0, Args, !ModeInfo),
+ GoalExpr = generic_call(GenericCall, Args, Modes, detism_det)
+ ;
+ GenericCall = cast(_CastType),
+ (
+ goal_info_has_feature(GoalInfo0, feature_keep_constant_binding),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ (
+ Args0 = [Arg1Prime, _Arg2Prime],
+ Modes0 = [Mode1Prime, Mode2Prime]
+ ->
+ Arg1 = Arg1Prime,
+ Mode1 = Mode1Prime,
+ Mode2 = Mode2Prime
+ ;
+ unexpected(this_file, "modecheck_goal_expr: bad cast")
+ ),
+ Mode1 = in_mode,
+ Mode2 = out_mode,
+ instmap_lookup_var(InstMap, Arg1, Inst1),
+ Inst1 = bound(Unique, [bound_functor(ConsId, [])]),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, Arg1, ArgType1),
+ type_to_ctor(ArgType1, ArgTypeCtor1),
+ lookup_type_ctor_defn(TypeTable, ArgTypeCtor1, CtorDefn),
+ get_type_defn_body(CtorDefn, Body),
+ ConsTagValues = Body ^ du_type_cons_tag_values,
+ map.lookup(ConsTagValues, ConsId, ConsTag),
+ ConsTag = shared_local_tag(_, LocalTag)
+ ->
+ BoundInst = bound_functor(int_const(LocalTag), []),
+ NewMode2 = (free -> bound(Unique, [BoundInst])),
+ Modes = [Mode1, NewMode2]
+ ;
+ Modes = Modes0
+ ),
+ modecheck_builtin_cast(Modes, Args0, Args, Det, ExtraGoals, !ModeInfo),
+ GoalExpr1 = generic_call(GenericCall, Args, Modes, Det),
+ handle_extra_goals(GoalExpr1, ExtraGoals, GoalInfo0, Args0, Args,
+ InstMap0, GoalExpr, !ModeInfo)
+ ),
+
+ mode_info_unset_call_context(!ModeInfo),
+ mode_checkpoint(exit, "generic_call", !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck unifications. Most of the work is in modecheck_unify.m.
+%
+
+:- pred modecheck_goal_unify(prog_var::in, unify_rhs::in,
+ unification::in, unify_context::in, hlds_goal_info::in,
+ hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
+
+modecheck_goal_unify(LHS0, RHS0, Unification0, UnifyContext, GoalInfo0,
+ GoalExpr, !ModeInfo) :-
+ mode_checkpoint(enter, "unify", !ModeInfo),
+ mode_info_set_call_context(call_context_unify(UnifyContext), !ModeInfo),
+ modecheck_unification(LHS0, RHS0, Unification0, UnifyContext, GoalInfo0,
+ GoalExpr, !ModeInfo),
+ mode_info_unset_call_context(!ModeInfo),
+ mode_checkpoint(exit, "unify", !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck foreign_proc goals.
+%
+
+:- pred modecheck_goal_call_foreign_proc(pragma_foreign_proc_attributes::in,
+ pred_id::in, proc_id::in, list(foreign_arg)::in, list(foreign_arg)::in,
+ maybe(trace_expr(trace_runtime))::in, pragma_foreign_code_impl::in,
+ hlds_goal_info::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_goal_call_foreign_proc(Attributes, PredId, ProcId0, Args0, ExtraArgs,
+ MaybeTraceRuntimeCond, PragmaCode, GoalInfo0, GoalExpr, !ModeInfo) :-
+ % To modecheck a foreign_proc, we just modecheck the proc for
+ % which it is the goal.
+
+ mode_checkpoint(enter, "pragma_foreign_code", !ModeInfo),
+ mode_info_get_call_id(!.ModeInfo, PredId, CallId),
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ DeterminismKnown = no,
+ mode_info_set_call_context(call_context_call(plain_call_id(CallId)),
+ !ModeInfo),
+ ArgVars0 = list.map(foreign_arg_var, Args0),
+ modecheck_call_pred(PredId, DeterminismKnown, ProcId0, ProcId,
+ ArgVars0, ArgVars, GoalInfo0, ExtraGoals, !ModeInfo),
+
+ % zs: The assignment to Pragma looks wrong: instead of Args0,
+ % I think we should use Args after the following call:
+ % replace_foreign_arg_vars(Args0, ArgVars, Args)
+ % or is there some reason why Args0 and Args would be the same?
+ Pragma = call_foreign_proc(Attributes, PredId, ProcId, Args0, ExtraArgs,
+ MaybeTraceRuntimeCond, PragmaCode),
+ handle_extra_goals(Pragma, ExtraGoals, GoalInfo0, ArgVars0, ArgVars,
+ InstMap0, GoalExpr, !ModeInfo),
+
+ mode_info_unset_call_context(!ModeInfo),
+ mode_checkpoint(exit, "pragma_foreign_code", !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Modecheck shorthand goals.
+%
+
+:- pred modecheck_goal_shorthand(shorthand_goal_expr::in, hlds_goal_info::in,
+ hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
+
+modecheck_goal_shorthand(ShortHand0, GoalInfo0, GoalExpr, !ModeInfo) :-
+ (
+ ShortHand0 = atomic_goal(_, Outer, Inner, MaybeOutputVars,
+ MainGoal0, OrElseGoals0, OrElseInners),
+
+ % The uniqueness of the Outer and Inner variables are handled by the
+ % addition of calls to the fake predicates "stm_inner_to_outer_io" and
+ % "stm_outer_to_inner_io" during the construction of the HLDS.
+ % These calls are removed when atomic goals are expanded.
+
+ mode_checkpoint(enter, "atomic", !ModeInfo),
+ AtomicGoalList0 = [MainGoal0 | OrElseGoals0],
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+
+ % XXX STM: Locking the outer variables would generate an error message
+ % during mode analysis of the sub goal because of the calls to
+ % "stm_outer_to_inner_io" and "stm_inner_to_outer_io". I (lmika) don't
+ % think this is a problem as the uniqueness states of the outer and
+ % inner variables are enforced by these calls anyway.
+
+ % mode_info_lock_vars(var_lock_atomic_goal, OuterVars, !ModeInfo),
+ modecheck_orelse_list(AtomicGoalList0, AtomicGoalList1, InstMapList0,
+ !ModeInfo),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ % mode_info_unlock_vars(var_lock_atomic_goal, OuterVars, !ModeInfo),
+
+ % XXX STM: Handling of solver vars
+ handle_solver_vars_in_disjs(set.to_sorted_list(NonLocals),
+ VarTypes, AtomicGoalList1, AtomicGoalList, InstMapList0,
+ InstMapList, !ModeInfo),
+ MainGoal = list.det_head(AtomicGoalList),
+ OrElseGoals = list.det_tail(AtomicGoalList),
+
+ instmap_merge(NonLocals, InstMapList, merge_stm_atomic, !ModeInfo),
+
+ % Here we determine the type of atomic goal this is. It could be argued
+ % that this should have been done in the typechecker, but the type of
+ % the outer variables could be unknown when the typechecker looks
+ % at the atomic goal.
+ %
+ % To prevent the need to traverse the code again, we will put this
+ % check here (also: types of variables must be known at this point).
+
+ Outer = atomic_interface_vars(OuterDI, OuterUO),
+ map.lookup(VarTypes, OuterDI, OuterDIType),
+ map.lookup(VarTypes, OuterUO, OuterUOType),
+ (
+ ( OuterDIType = io_state_type
+ ; OuterDIType = io_io_type
+ )
+ ->
+ GoalType = top_level_atomic_goal
+ ;
+ OuterDIType = stm_atomic_type
+ ->
+ GoalType = nested_atomic_goal
+ ;
+ unexpected(this_file,
+ "modecheck_goal_shorthand atomic_goal: Invalid outer var type")
+ ),
+
+ % The following are sanity checks.
+ expect(unify(OuterDIType, OuterUOType), this_file,
+ "modecheck_goal_shorthand atomic_goal: mismatched outer var type"),
+ Inner = atomic_interface_vars(InnerDI, InnerUO),
+ map.lookup(VarTypes, InnerDI, InnerDIType),
+ map.lookup(VarTypes, InnerUO, InnerUOType),
+ expect(unify(InnerDIType, stm_atomic_type), this_file,
+ "modecheck_goal_shorthand atomic_goal: Invalid inner var type"),
+ expect(unify(InnerUOType, stm_atomic_type), this_file,
+ "modecheck_goal_shorthand atomic_goal: Invalid inner var type"),
+
+ ShortHand = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars,
+ MainGoal, OrElseGoals, OrElseInners),
+ GoalExpr = shorthand(ShortHand),
+ mode_checkpoint(exit, "atomic", !ModeInfo)
+ ;
+ ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0),
+ mode_checkpoint(enter, "try", !ModeInfo),
+ modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
+ ShortHand = try_goal(MaybeIO, ResultVar, SubGoal),
+ GoalExpr = shorthand(ShortHand),
+ mode_checkpoint(exit, "try", !ModeInfo)
+ ;
+ ShortHand0 = bi_implication(_, _),
+ % These should have been expanded out by now.
+ unexpected(this_file, "modecheck_goal_shorthand: bi_implication")
+ ).
+
+:- pred modecheck_orelse_list(list(hlds_goal)::in, list(hlds_goal)::out,
+ list(instmap)::out, mode_info::in, mode_info::out) is det.
+
+modecheck_orelse_list([], [], [], !ModeInfo).
+modecheck_orelse_list([Goal0 | Goals0], [Goal | Goals], [InstMap | InstMaps],
+ !ModeInfo) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ modecheck_goal(Goal0, Goal, !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ modecheck_orelse_list(Goals0, Goals, InstMaps, !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Service predicates dealing with solver variables.
+%
+
+ % If the condition of a negation or if-then-else contains any inst any
+ % non-locals (a potential referential transparency violation), then
+ % we need to check that the programmer has recognised the possibility
+ % and placed the if-then-else in a promise_<purity> scope.
+ %
+:- pred check_no_inst_any_vars(negated_context_desc::in, prog_vars::in,
+ instmap::in, instmap::in, mode_info::in, mode_info::out) is det.
+
+check_no_inst_any_vars(_, [], _, _, !ModeInfo).
+check_no_inst_any_vars(NegCtxtDesc, [NonLocal | NonLocals], InstMap0, InstMap,
+ !ModeInfo) :-
+ (
+ ( instmap_lookup_var(InstMap0, NonLocal, Inst)
+ ; instmap_lookup_var(InstMap, NonLocal, Inst)
+ ),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ inst_contains_any(ModuleInfo, Inst)
+ ->
+ ModeError = purity_error_should_be_in_promise_purity_scope(NegCtxtDesc,
+ NonLocal),
+ mode_info_error(make_singleton_set(NonLocal), ModeError, !ModeInfo)
+ ;
+ check_no_inst_any_vars(NegCtxtDesc, NonLocals, InstMap0, InstMap,
+ !ModeInfo)
+ ).
+
+:- func solver_vars_that_must_be_initialised(list(prog_var),
+ vartypes, module_info, list(instmap)) = list(prog_var).
+
+solver_vars_that_must_be_initialised(Vars, VarTypes, ModuleInfo, InstMaps) =
+ list.filter(
+ solver_var_must_be_initialised(VarTypes, ModuleInfo, InstMaps),
+ Vars).
+
+:- pred solver_var_must_be_initialised(vartypes::in, module_info::in,
+ list(instmap)::in, prog_var::in) is semidet.
+
+solver_var_must_be_initialised(VarTypes, ModuleInfo, InstMaps, Var) :-
+ map.lookup(VarTypes, Var, VarType),
+ type_is_solver_type_with_auto_init(ModuleInfo, VarType),
+ list.member(InstMap, InstMaps),
+ instmap_lookup_var(InstMap, Var, Inst),
+ not inst_match.inst_is_free(ModuleInfo, Inst).
+
+:- pred add_necessary_disj_init_calls(list(hlds_goal)::in,
+ list(hlds_goal)::out, list(instmap)::in, list(instmap)::out,
+ list(prog_var)::in, mode_info::in, mode_info::out) is det.
+
+add_necessary_disj_init_calls([], [], [], [], _EnsureInitialised, !ModeInfo).
+add_necessary_disj_init_calls([], _, [_ | _], _, _, _, _) :-
+ unexpected(this_file, "add_necessary_init_calls: mismatched lists").
+add_necessary_disj_init_calls([_ | _], _, [], _, _, _, _) :-
+ unexpected(this_file, "add_necessary_init_calls: mismatched lists").
+add_necessary_disj_init_calls([Goal0 | Goals0], [Goal | Goals],
+ [InstMap0 | InstMaps0], [InstMap | InstMaps],
+ EnsureInitialised, !ModeInfo) :-
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ VarsToInit = solver_vars_to_init(EnsureInitialised, ModuleInfo, InstMap0),
+ construct_initialisation_calls(VarsToInit, InitCalls, !ModeInfo),
+ InitedVars = list_to_set(VarsToInit),
+ Goal = append_init_calls_to_goal(InitedVars, InitCalls, Goal0),
+ instmap_set_vars_same(any_inst, VarsToInit, InstMap0, InstMap),
+ add_necessary_disj_init_calls(Goals0, Goals, InstMaps0, InstMaps,
+ EnsureInitialised, !ModeInfo).
+
+:- func append_init_calls_to_goal(set(prog_var), list(hlds_goal), hlds_goal) =
+ hlds_goal.
+
+append_init_calls_to_goal(InitedVars, InitCalls, Goal0) = Goal :-
+ Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
+ NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
+ NonLocals = set.union(InitedVars, NonLocals0),
+ goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
+ ( GoalExpr0 = disj(Disjs0) ->
+ Disjs = list.map(append_init_calls_to_goal(InitedVars, InitCalls),
+ Disjs0),
+ Goal = hlds_goal(disj(Disjs), GoalInfo)
+ ;
+ goal_to_conj_list(Goal0, Conjs),
+ conj_list_to_goal(Conjs ++ InitCalls, GoalInfo, Goal)
+ ).
+
+:- func solver_vars_to_init(list(prog_var), module_info, instmap) =
+ list(prog_var).
+
+solver_vars_to_init(Vars, ModuleInfo, InstMap) =
+ list.filter(solver_var_to_init(ModuleInfo, InstMap), Vars).
+
+:- pred solver_var_to_init(module_info::in, instmap::in, prog_var::in)
+ is semidet.
+
+solver_var_to_init(ModuleInfo, InstMap, Var) :-
+ instmap_lookup_var(InstMap, Var, Inst),
+ inst_match.inst_is_free(ModuleInfo, Inst).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "modecheck_goal.m".
+
+%-----------------------------------------------------------------------------%
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.133
diff -u -b -r1.133 modecheck_unify.m
--- compiler/modecheck_unify.m 24 Sep 2009 07:53:09 -0000 1.133
+++ compiler/modecheck_unify.m 25 Sep 2009 03:45:35 -0000
@@ -48,8 +48,10 @@
:- import_module check_hlds.mode_debug.
:- import_module check_hlds.mode_errors.
:- import_module check_hlds.mode_info.
-:- import_module check_hlds.modes.
:- import_module check_hlds.mode_util.
+:- import_module check_hlds.modecheck_goal.
+:- import_module check_hlds.modecheck_util.
+:- import_module check_hlds.modes.
:- import_module check_hlds.polymorphism.
:- import_module check_hlds.type_util.
:- import_module check_hlds.unify_proc.
Index: compiler/modecheck_util.m
===================================================================
RCS file: compiler/modecheck_util.m
diff -N compiler/modecheck_util.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/modecheck_util.m 24 Sep 2009 03:14:49 -0000
@@ -0,0 +1,1056 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: modecheck_util.m.
+%
+
+:- module check_hlds.modecheck_util.
+:- interface.
+
+:- import_module check_hlds.mode_info.
+:- import_module hlds.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.instmap.
+:- import_module parse_tree.
+:- import_module parse_tree.prog_data.
+
+:- import_module list.
+:- import_module maybe.
+
+%-----------------------------------------------------------------------------%
+
+:- type extra_goals
+ ---> no_extra_goals
+ ; extra_goals(
+ extra_before_main :: list(hlds_goal),
+ % goals to insert before the main goal
+ extra_after_main :: list(hlds_goal)
+ % goals to append after the main goal
+ ).
+
+:- type after_goals
+ ---> no_after_goals
+ ; after_goals(
+ after_instmap :: instmap,
+ % instmap at end of main goal
+ after_goals :: list(hlds_goal)
+ % goals to append after the main goal
+ ).
+
+ % Append_extra_goals inserts adds some goals to the
+ % list of goals to insert before/after the main goal.
+ %
+:- pred append_extra_goals(extra_goals::in, extra_goals::in,
+ extra_goals::out) is det.
+
+ % Handle_extra_goals combines MainGoal and ExtraGoals into a single
+ % hlds_goal_expr, rerunning mode analysis on the entire conjunction
+ % if ExtraGoals is not empty.
+ %
+:- pred handle_extra_goals(hlds_goal_expr::in, extra_goals::in,
+ hlds_goal_info::in, list(prog_var)::in, list(prog_var)::in,
+ instmap::in, hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % Calculate the argument number offset that needs to be passed to
+ % modecheck_var_list_is_live, modecheck_var_has_inst_list, and
+ % modecheck_set_var_inst_list. This offset number is calculated so that
+ % real arguments get positive argument numbers and type_info arguments
+ % get argument numbers less than or equal to 0.
+ %
+:- pred compute_arg_offset(pred_info::in, int::out) is det.
+
+ % Given a list of variables and a list of expected liveness, ensure
+ % that the inst of each variable satisfies the corresponding expected
+ % liveness. See below for the difference between the two variants.
+ %
+:- pred modecheck_var_list_is_live_exact_match(list(prog_var)::in,
+ list(is_live)::in, int::in, mode_info::in, mode_info::out) is det.
+:- pred modecheck_var_list_is_live_no_exact_match(list(prog_var)::in,
+ list(is_live)::in, int::in, mode_info::in, mode_info::out) is det.
+
+ % Given a list of variables and a list of initial insts, ensure that
+ % the inst of each variable matches the corresponding initial inst.
+ % The first variant requires an exact match (using inst_matches_final),
+ % while the second we allow the var to be more instantiated than the inst
+ % (using inst_matches_initial).
+ %
+:- pred modecheck_var_has_inst_list_exact_match(list(prog_var)::in,
+ list(mer_inst)::in, int::in, inst_var_sub::out,
+ mode_info::in, mode_info::out) is det.
+:- pred modecheck_var_has_inst_list_no_exact_match(list(prog_var)::in,
+ list(mer_inst)::in, int::in, inst_var_sub::out,
+ mode_info::in, mode_info::out) is det.
+
+ % This is a special-cased, cut-down version of
+ % modecheck_var_has_inst_list_no_exact_match for use specifically
+ % on introduced type_info_type variables.
+ %
+:- pred modecheck_introduced_type_info_var_has_inst_no_exact_match(
+ prog_var::in, mer_type::in, mer_inst::in,
+ mode_info::in, mode_info::out) is det.
+
+ % modecheck_set_var_inst(Var, Inst, MaybeUInst, !ModeInfo):
+ %
+ % Assign the given Inst to the given Var, after checking that it is
+ % okay to do so. If the inst to be assigned is the result of an
+ % abstract unification then the MaybeUInst argument should be the
+ % initial inst of the _other_ side of the unification. This allows
+ % more precise (i.e. less conservative) checking in the case that
+ % Inst contains `any' components and Var is locked (i.e. is a
+ % nonlocal variable in a negated context). Where the inst is not
+ % the result of an abstract unification then MaybeUInst should be `no'.
+ %
+:- pred modecheck_set_var_inst(prog_var::in, mer_inst::in, maybe(mer_inst)::in,
+ mode_info::in, mode_info::out) is det.
+
+:- pred modecheck_set_var_inst_list(list(prog_var)::in, list(mer_inst)::in,
+ list(mer_inst)::in, int::in, list(prog_var)::out, extra_goals::out,
+ mode_info::in, mode_info::out) is det.
+
+:- pred mode_info_add_goals_live_vars(conj_type::in, list(hlds_goal)::in,
+ mode_info::in, mode_info::out) is det.
+
+:- pred mode_info_remove_goals_live_vars(list(hlds_goal)::in,
+ mode_info::in, mode_info::out) is det.
+
+ % modecheck_functor_test(Var, ConsId, !ModeInfo):
+ %
+ % Update the instmap to reflect the fact that Var was bound to ConsId.
+ % This is used for the functor tests in `switch' statements.
+ %
+:- pred modecheck_functor_test(prog_var::in, cons_id::in,
+ mode_info::in, mode_info::out) is det.
+
+ % modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo):
+ %
+ % Update the instmap to reflect the fact that Var was bound to either
+ % MainConsId or one of the OtherConsIds.
+ % This is used for the functor tests in `switch' statements.
+ %
+:- pred modecheck_functors_test(prog_var::in, cons_id::in, list(cons_id)::in,
+ mode_info::in, mode_info::out) is det.
+
+ % compute_goal_instmap_delta(InstMap0, GoalExpr, !GoalInfo, !ModeInfo):
+ %
+ % Work out the instmap_delta for a goal from the instmaps before and after
+ % the goal. The instmap before the goal is given by InstMap0; the instmap
+ % after the goal is given by !.ModeInfo.
+ %
+:- pred compute_goal_instmap_delta(instmap::in, hlds_goal_expr::in,
+ hlds_goal_info::in, hlds_goal_info::out, mode_info::in, mode_info::out)
+ is det.
+
+%-----------------------------------------------------------------------------%
+
+ % Construct a call to initialise a free solver type variable.
+ %
+:- pred construct_initialisation_call(prog_var::in, mer_type::in, mer_inst::in,
+ prog_context::in, maybe(call_unify_context)::in,
+ hlds_goal::out, mode_info::in, mode_info::out) is det.
+
+ % Construct a list of initialisation calls.
+ %
+:- pred construct_initialisation_calls(list(prog_var)::in,
+ list(hlds_goal)::out, mode_info::in, mode_info::out) is det.
+
+:- pred prepend_initialisation_call(prog_var::in, mer_type::in, mer_inst::in,
+ hlds_goal::in, hlds_goal::out, mode_info::in, mode_info::out) is det.
+
+:- pred mode_context_to_unify_context(mode_info::in, mode_context::in,
+ unify_context::out) is det.
+
+ % Given a list of variables, and a list of livenesses,
+ % select the live variables.
+ %
+:- pred get_live_vars(list(prog_var)::in, list(is_live)::in,
+ list(prog_var)::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds.clause_to_proc.
+:- import_module check_hlds.cse_detection.
+:- import_module check_hlds.delay_info.
+:- import_module check_hlds.delay_partial_inst.
+:- import_module check_hlds.det_analysis.
+:- import_module check_hlds.inst_match.
+:- import_module check_hlds.inst_util.
+:- import_module check_hlds.mode_debug.
+:- import_module check_hlds.mode_errors.
+:- import_module check_hlds.mode_util.
+:- import_module check_hlds.modecheck_call.
+:- import_module check_hlds.modecheck_goal.
+:- import_module check_hlds.modecheck_unify.
+:- import_module check_hlds.polymorphism.
+:- import_module check_hlds.switch_detection.
+:- import_module check_hlds.type_util.
+:- import_module check_hlds.unify_proc.
+:- import_module check_hlds.unique_modes.
+:- import_module hlds.goal_util.
+:- import_module hlds.hlds_clauses.
+:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_out.
+:- import_module hlds.passes_aux.
+:- import_module hlds.pred_table.
+:- import_module hlds.quantification.
+:- import_module hlds.special_pred.
+:- import_module libs.
+:- import_module libs.compiler_util.
+:- import_module libs.file_util.
+:- import_module libs.globals.
+:- import_module libs.options.
+:- import_module mdbcomp.
+:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
+:- import_module parse_tree.error_util.
+:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.prog_event.
+:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
+
+:- import_module assoc_list.
+:- import_module bag.
+:- import_module bool.
+:- import_module int.
+:- import_module io.
+:- import_module list.
+:- import_module map.
+:- import_module pair.
+:- import_module queue.
+:- import_module set.
+:- import_module string.
+:- import_module svmap.
+:- import_module term.
+:- import_module varset.
+
+%-----------------------------------------------------------------------------%
+
+append_extra_goals(no_extra_goals, ExtraGoals, ExtraGoals).
+append_extra_goals(extra_goals(BeforeGoals, AfterGoals),
+ no_extra_goals, extra_goals(BeforeGoals, AfterGoals)).
+append_extra_goals(extra_goals(BeforeGoals0, AfterGoals0),
+ extra_goals(BeforeGoals1, AfterGoals1),
+ extra_goals(BeforeGoals, AfterGoals)) :-
+ BeforeGoals = BeforeGoals0 ++ BeforeGoals1,
+ AfterGoals = AfterGoals0 ++ AfterGoals1.
+
+handle_extra_goals(MainGoal, no_extra_goals, _GoalInfo0, _Args0, _Args,
+ _InstMap0, MainGoal, !ModeInfo).
+handle_extra_goals(MainGoal, extra_goals(BeforeGoals0, AfterGoals0),
+ GoalInfo0, Args0, Args, InstMap0, Goal, !ModeInfo) :-
+ mode_info_get_errors(!.ModeInfo, Errors),
+ (
+ % There's no point adding extra goals if the code is
+ % unreachable anyway.
+ instmap_is_reachable(InstMap0),
+
+ % If we recorded errors processing the goal, it will have to be
+ % reprocessed anyway, so don't add the extra goals now.
+ Errors = []
+ ->
+ % We need to be careful to update the delta-instmaps
+ % correctly, using the appropriate instmaps:
+ %
+ % % InstMapAtStart is here
+ % BeforeGoals,
+ % % we don't know the instmap here,
+ % % but as it happens we don't need it
+ % main goal,
+ % % InstMapAfterMain is here
+ % AfterGoals
+ % % InstMapAtEnd (from the ModeInfo) is here
+
+ % Recompute the new set of non-local variables for the main goal.
+ NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
+ set.list_to_set(Args0, OldArgVars),
+ set.list_to_set(Args, NewArgVars),
+ set.difference(NewArgVars, OldArgVars, IntroducedVars),
+ set.union(NonLocals0, IntroducedVars, OutsideVars),
+ set.intersect(OutsideVars, NewArgVars, NonLocals),
+ goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
+
+ % Combine the main goal and the extra goals into a conjunction.
+ Goal0 = hlds_goal(MainGoal, GoalInfo),
+ Context = goal_info_get_context(GoalInfo0),
+ handle_extra_goals_contexts(BeforeGoals0, Context, BeforeGoals),
+ handle_extra_goals_contexts(AfterGoals0, Context, AfterGoals),
+ GoalList0 = BeforeGoals ++ [Goal0 | AfterGoals],
+
+ mode_info_get_may_change_called_proc(!.ModeInfo, MayChangeCalledProc0),
+
+ % Make sure we don't go into an infinite loop if
+ % there is a bug in the code to add extra goals.
+ mode_info_set_checking_extra_goals(yes, !ModeInfo),
+
+ % We've already worked out which procedure should be called,
+ % we don't need to do it again.
+ mode_info_set_may_change_called_proc(may_not_change_called_proc,
+ !ModeInfo),
+
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+
+ % Recheck the goals to compute the instmap_deltas.
+ %
+ % This can fail even if the original check on the goal
+ % succeeded in the case of a unification procedure which
+ % binds a partially instantiated variable, because adding
+ % the extra goals can make the partially instantiated
+ % variables `live' after the main goal.
+ % The other thing to beware of in this case is that delaying
+ % must be disabled while processing the extra goals. If it
+ % is not, the main unification will be delayed until after the
+ % argument unifications, which turns them into assignments,
+ % and we end up repeating the process forever.
+ mode_info_add_goals_live_vars(plain_conj, GoalList0, !ModeInfo),
+ modecheck_conj_list_no_delay(GoalList0, GoalList, !ModeInfo),
+ Goal = conj(plain_conj, GoalList),
+ mode_info_set_checking_extra_goals(no, !ModeInfo),
+ mode_info_set_may_change_called_proc(MayChangeCalledProc0, !ModeInfo)
+ ;
+ Goal = MainGoal
+ ).
+
+ % Modecheck a conjunction without doing any reordering.
+ % This is used by handle_extra_goals above.
+ %
+:- pred modecheck_conj_list_no_delay(list(hlds_goal)::in, list(hlds_goal)::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_conj_list_no_delay([], [], !ModeInfo).
+modecheck_conj_list_no_delay([Goal0 | Goals0], [Goal | Goals], !ModeInfo) :-
+ NonLocals = goal_get_nonlocals(Goal0),
+ mode_info_remove_live_vars(NonLocals, !ModeInfo),
+ modecheck_goal(Goal0, Goal, !ModeInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ ( instmap_is_unreachable(InstMap) ->
+ % We should not mode-analyse the remaining goals, since they
+ % are unreachable. Instead we optimize them away, so that
+ % later passes won't complain about them not having mode information.
+ mode_info_remove_goals_live_vars(Goals0, !ModeInfo),
+ Goals = []
+ ;
+ modecheck_conj_list_no_delay(Goals0, Goals, !ModeInfo)
+ ).
+
+:- pred handle_extra_goals_contexts(list(hlds_goal)::in, prog_context::in,
+ list(hlds_goal)::out) is det.
+
+handle_extra_goals_contexts([], _Context, []).
+handle_extra_goals_contexts([Goal0 | Goals0], Context, [Goal | Goals]) :-
+ Goal0 = hlds_goal(GoalExpr, GoalInfo0),
+ goal_info_set_context(Context, GoalInfo0, GoalInfo),
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ handle_extra_goals_contexts(Goals0, Context, Goals).
+
+%-----------------------------------------------------------------------------%
+
+modecheck_functor_test(Var, ConsId, !ModeInfo) :-
+ % Figure out the arity of this constructor, _including_ any type-infos
+ % or typeclass-infos inserted for existential data types.
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, Var, Type),
+ BoundInst = cons_id_to_bound_inst(ModuleInfo, Type, ConsId),
+
+ % Record the fact that Var was bound to ConsId.
+ modecheck_set_var_inst(Var, bound(unique, [BoundInst]), no, !ModeInfo).
+
+modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo) :-
+ % Figure out the arity of this constructor, _including_ any type-infos
+ % or typeclass-infos inserted for existential data types.
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, Var, Type),
+ BoundInsts = list.map(cons_id_to_bound_inst(ModuleInfo, Type),
+ [MainConsId | OtherConsIds]),
+
+ % Record the fact that Var was bound to MainConsId or one of the
+ % OtherConsIds.
+ modecheck_set_var_inst(Var, bound(unique, BoundInsts), no, !ModeInfo).
+
+:- func cons_id_to_bound_inst(module_info, mer_type, cons_id) = bound_inst.
+
+cons_id_to_bound_inst(ModuleInfo, Type, ConsId) = BoundInst :-
+ ConsIdAdjustedArity = cons_id_adjusted_arity(ModuleInfo, Type, ConsId),
+ list.duplicate(ConsIdAdjustedArity, free, ArgInsts),
+ BoundInst = bound_functor(ConsId, ArgInsts).
+
+compute_goal_instmap_delta(InstMap0, GoalExpr, !GoalInfo, !ModeInfo) :-
+ ( GoalExpr = conj(_, []) ->
+ % When modecheck_unify.m replaces a unification with a dead variable
+ % with `true', make sure the instmap_delta of the goal is empty.
+ % The code generator and mode_util.recompute_instmap_delta can be
+ % confused by references to the dead variable in the instmap_delta,
+ % resulting in calls to error/1.
+
+ instmap_delta_init_reachable(DeltaInstMap),
+ mode_info_set_instmap(InstMap0, !ModeInfo)
+ ;
+ NonLocals = goal_info_get_nonlocals(!.GoalInfo),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ compute_instmap_delta(InstMap0, InstMap, NonLocals, DeltaInstMap)
+ ),
+ goal_info_set_instmap_delta(DeltaInstMap, !GoalInfo).
+
+%-----------------------------------------------------------------------------%
+
+ % Calculate the argument number offset that needs to be passed to
+ % modecheck_var_list_is_live, modecheck_var_has_inst_list, and
+ % modecheck_set_var_inst_list. This offset number is calculated
+ % so that real arguments get positive argument numbers and
+ % type_info arguments get argument numbers less than or equal to 0.
+ %
+compute_arg_offset(PredInfo, ArgOffset) :-
+ OrigArity = pred_info_orig_arity(PredInfo),
+ pred_info_get_arg_types(PredInfo, ArgTypes),
+ list.length(ArgTypes, CurrentArity),
+ ArgOffset = OrigArity - CurrentArity.
+
+%-----------------------------------------------------------------------------%
+
+modecheck_var_list_is_live_exact_match([_ | _], [], _, !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_list_is_live_exact_match: length mismatch").
+modecheck_var_list_is_live_exact_match([], [_ | _], _, !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_list_is_live_exact_match: length mismatch").
+modecheck_var_list_is_live_exact_match([], [], _ArgNum, !ModeInfo).
+modecheck_var_list_is_live_exact_match([Var | Vars], [IsLive | IsLives],
+ ArgNum0, !ModeInfo) :-
+ ArgNum = ArgNum0 + 1,
+ mode_info_set_call_arg_context(ArgNum, !ModeInfo),
+ modecheck_var_is_live_exact_match(Var, IsLive, !ModeInfo),
+ modecheck_var_list_is_live_exact_match(Vars, IsLives, ArgNum, !ModeInfo).
+
+modecheck_var_list_is_live_no_exact_match([_ | _], [], _, !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_list_is_live_no_exact_match: length mismatch").
+modecheck_var_list_is_live_no_exact_match([], [_ | _], _, !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_list_is_live_no_exact_match: length mismatch").
+modecheck_var_list_is_live_no_exact_match([], [], _ArgNum, !ModeInfo).
+modecheck_var_list_is_live_no_exact_match([Var | Vars], [IsLive | IsLives],
+ ArgNum0, !ModeInfo) :-
+ ArgNum = ArgNum0 + 1,
+ mode_info_set_call_arg_context(ArgNum, !ModeInfo),
+ modecheck_var_is_live_no_exact_match(Var, IsLive, !ModeInfo),
+ modecheck_var_list_is_live_no_exact_match(Vars, IsLives, ArgNum,
+ !ModeInfo).
+
+ % `live' means possibly used later on, and `dead' means definitely not used
+ % later on. If you don't need an exact match, then the only time you get
+ % an error is if you pass a variable which is live to a predicate
+ % that expects the variable to be dead; the predicate may use destructive
+ % update to clobber the variable, so we must be sure that it is dead
+ % after the call.
+ %
+
+ % A version of modecheck_var_is_live specialized for NeedExactMatch = no.
+ %
+:- pred modecheck_var_is_live_no_exact_match(prog_var::in, is_live::in,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_var_is_live_no_exact_match(VarId, ExpectedIsLive, !ModeInfo) :-
+ mode_info_var_is_live(!.ModeInfo, VarId, VarIsLive),
+ (
+ ExpectedIsLive = is_dead,
+ VarIsLive = is_live
+ ->
+ set.singleton_set(WaitingVars, VarId),
+ ModeError = mode_error_var_is_live(VarId),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ ;
+ true
+ ).
+
+ % A version of modecheck_var_is_live specialized for NeedExactMatch = yes.
+ %
+:- pred modecheck_var_is_live_exact_match(prog_var::in, is_live::in,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_var_is_live_exact_match(VarId, ExpectedIsLive, !ModeInfo) :-
+ mode_info_var_is_live(!.ModeInfo, VarId, VarIsLive),
+ ( VarIsLive = ExpectedIsLive ->
+ true
+ ;
+ set.singleton_set(WaitingVars, VarId),
+ ModeError = mode_error_var_is_live(VarId),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % Given a list of variables and a list of initial insts, ensure that
+ % the inst of each variable matches the corresponding initial inst.
+ %
+modecheck_var_has_inst_list_exact_match(Vars, Insts, ArgNum, Subst,
+ !ModeInfo) :-
+ modecheck_var_has_inst_list_exact_match_2(Vars, Insts, ArgNum,
+ map.init, Subst, !ModeInfo).
+
+modecheck_var_has_inst_list_no_exact_match(Vars, Insts, ArgNum, Subst,
+ !ModeInfo) :-
+ modecheck_var_has_inst_list_no_exact_match_2(Vars, Insts, ArgNum,
+ map.init, Subst, !ModeInfo).
+
+:- pred modecheck_var_has_inst_list_exact_match_2(list(prog_var)::in,
+ list(mer_inst)::in, int::in, inst_var_sub::in, inst_var_sub::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_var_has_inst_list_exact_match_2([_ | _], [], _, !Subst, !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_has_inst_list_exact_match_2: length mismatch").
+modecheck_var_has_inst_list_exact_match_2([], [_ | _], _, !Subst, !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_has_inst_list_exact_match_2: length mismatch").
+modecheck_var_has_inst_list_exact_match_2([], [], _ArgNum, !Subst, !ModeInfo).
+modecheck_var_has_inst_list_exact_match_2([Var | Vars], [Inst | Insts],
+ ArgNum0, !Subst, !ModeInfo) :-
+ ArgNum = ArgNum0 + 1,
+ mode_info_set_call_arg_context(ArgNum, !ModeInfo),
+ modecheck_var_has_inst_exact_match(Var, Inst, !Subst, !ModeInfo),
+ modecheck_var_has_inst_list_exact_match_2(Vars, Insts, ArgNum,
+ !Subst, !ModeInfo).
+
+:- pred modecheck_var_has_inst_list_no_exact_match_2(list(prog_var)::in,
+ list(mer_inst)::in, int::in, inst_var_sub::in, inst_var_sub::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_var_has_inst_list_no_exact_match_2([_ | _], [], _, !Subst,
+ !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_has_inst_list_no_exact_match_2: length mismatch").
+modecheck_var_has_inst_list_no_exact_match_2([], [_ | _], _,
+ !Subst, !ModeInfo) :-
+ unexpected(this_file,
+ "modecheck_var_has_inst_list_no_exact_match_2: length mismatch").
+modecheck_var_has_inst_list_no_exact_match_2([], [], _ArgNum,
+ !Subst, !ModeInfo).
+modecheck_var_has_inst_list_no_exact_match_2([Var | Vars], [Inst | Insts],
+ ArgNum0, !Subst, !ModeInfo) :-
+ ArgNum = ArgNum0 + 1,
+ mode_info_set_call_arg_context(ArgNum, !ModeInfo),
+ modecheck_var_has_inst_no_exact_match(Var, Inst, !Subst, !ModeInfo),
+ modecheck_var_has_inst_list_no_exact_match_2(Vars, Insts, ArgNum,
+ !Subst, !ModeInfo).
+
+:- pred modecheck_var_has_inst_exact_match(prog_var::in, mer_inst::in,
+ inst_var_sub::in, inst_var_sub::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_var_has_inst_exact_match(Var, Inst, !Subst, !ModeInfo) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ instmap_lookup_var(InstMap, Var, VarInst),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, Var, Type),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ (
+ inst_matches_initial_no_implied_modes_sub(VarInst, Inst, Type,
+ ModuleInfo0, ModuleInfo, !Subst)
+ ->
+ mode_info_set_module_info(ModuleInfo, !ModeInfo)
+ ;
+ set.singleton_set(WaitingVars, Var),
+ ModeError = mode_error_var_has_inst(Var, VarInst, Inst),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ ).
+
+:- pred modecheck_var_has_inst_no_exact_match(prog_var::in, mer_inst::in,
+ inst_var_sub::in, inst_var_sub::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_var_has_inst_no_exact_match(Var, Inst, !Subst, !ModeInfo) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ instmap_lookup_var(InstMap, Var, VarInst),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, Var, Type),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ (
+ inst_matches_initial_sub(VarInst, Inst, Type, ModuleInfo0, ModuleInfo,
+ !Subst)
+ ->
+ mode_info_set_module_info(ModuleInfo, !ModeInfo)
+ ;
+ set.singleton_set(WaitingVars, Var),
+ ModeError = mode_error_var_has_inst(Var, VarInst, Inst),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ ).
+
+modecheck_introduced_type_info_var_has_inst_no_exact_match(Var, Type, Inst,
+ !ModeInfo) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ instmap_lookup_var(InstMap, Var, VarInst),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ (
+ inst_matches_initial_sub(VarInst, Inst, Type, ModuleInfo0, ModuleInfo,
+ map.init, _Subst)
+ ->
+ mode_info_set_module_info(ModuleInfo, !ModeInfo)
+ ;
+ set.singleton_set(WaitingVars, Var),
+ ModeError = mode_error_var_has_inst(Var, VarInst, Inst),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+modecheck_set_var_inst_list(Vars0, InitialInsts, FinalInsts, ArgOffset,
+ Vars, Goals, !ModeInfo) :-
+ (
+ modecheck_set_var_inst_list_2(Vars0, InitialInsts, FinalInsts,
+ ArgOffset, Vars1, no_extra_goals, Goals1, !ModeInfo)
+ ->
+ Vars = Vars1,
+ Goals = Goals1
+ ;
+ unexpected(this_file, "modecheck_set_var_inst_list: length mismatch")
+ ).
+
+:- pred modecheck_set_var_inst_list_2(list(prog_var)::in, list(mer_inst)::in,
+ list(mer_inst)::in, int::in, list(prog_var)::out,
+ extra_goals::in, extra_goals::out, mode_info::in, mode_info::out)
+ is semidet.
+
+modecheck_set_var_inst_list_2([], [], [], _, [], !ExtraGoals, !ModeInfo).
+modecheck_set_var_inst_list_2([Var0 | Vars0], [InitialInst | InitialInsts],
+ [FinalInst | FinalInsts], ArgNum0, [Var | Vars],
+ !ExtraGoals, !ModeInfo) :-
+ ArgNum = ArgNum0 + 1,
+ mode_info_set_call_arg_context(ArgNum, !ModeInfo),
+ modecheck_set_var_inst_call(Var0, InitialInst, FinalInst,
+ Var, !ExtraGoals, !ModeInfo),
+ modecheck_set_var_inst_list_2(Vars0, InitialInsts, FinalInsts, ArgNum,
+ Vars, !ExtraGoals, !ModeInfo).
+
+:- pred modecheck_set_var_inst_call(prog_var::in, mer_inst::in, mer_inst::in,
+ prog_var::out, extra_goals::in, extra_goals::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_set_var_inst_call(Var0, InitialInst, FinalInst, Var, !ExtraGoals,
+ !ModeInfo) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ ( instmap_is_reachable(InstMap0) ->
+ % The new inst must be computed by unifying the
+ % old inst and the proc's final inst.
+ instmap_lookup_var(InstMap0, Var0, VarInst0),
+ handle_implied_mode(Var0, VarInst0, InitialInst, Var, !ExtraGoals,
+ !ModeInfo),
+ modecheck_set_var_inst(Var0, FinalInst, no, !ModeInfo),
+ ( Var = Var0 ->
+ true
+ ;
+ modecheck_set_var_inst(Var, FinalInst, no, !ModeInfo)
+ )
+ ;
+ Var = Var0
+ ).
+
+ % Note that there are two versions of modecheck_set_var_inst,
+ % one with arity 8 (suffixed with _call) and one with arity 5.
+ % The former is used for predicate calls, where we may need
+ % to introduce unifications to handle calls to implied modes.
+ %
+modecheck_set_var_inst(Var0, FinalInst, MaybeUInst, !ModeInfo) :-
+ mode_info_get_parallel_vars(!.ModeInfo, PVars0),
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ ( instmap_is_reachable(InstMap0) ->
+ % The new inst must be computed by unifying the
+ % old inst and the proc's final inst.
+ instmap_lookup_var(InstMap0, Var0, Inst0),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ (
+ abstractly_unify_inst(is_dead, Inst0, FinalInst,
+ fake_unify, UnifyInst, _Det, ModuleInfo0, ModuleInfo1)
+ ->
+ ModuleInfo = ModuleInfo1,
+ Inst = UnifyInst
+ ;
+ unexpected(this_file, "modecheck_set_var_inst: unify_inst failed")
+ ),
+ mode_info_set_module_info(ModuleInfo, !ModeInfo),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, Var0, Type),
+ (
+ % If the top-level inst of the variable is not_reached,
+ % then the instmap as a whole must be unreachable.
+ inst_expand(ModuleInfo, Inst, not_reached)
+ ->
+ instmap.init_unreachable(InstMap),
+ mode_info_set_instmap(InstMap, !ModeInfo)
+ ;
+ % If we haven't added any information and
+ % we haven't bound any part of the var, then
+ % the only thing we can have done is lose uniqueness.
+ inst_matches_initial(Inst0, Inst, Type, ModuleInfo)
+ ->
+ instmap_set_var(Var0, Inst, InstMap0, InstMap),
+ mode_info_set_instmap(InstMap, !ModeInfo)
+ ;
+ % We must have either added some information,
+ % lost some uniqueness, or bound part of the var.
+ % The call to inst_matches_binding will succeed
+ % only if we haven't bound any part of the var.
+ \+ inst_matches_binding(Inst, Inst0, Type, ModuleInfo),
+
+ % We've bound part of the var. If the var was locked,
+ % then we need to report an error...
+ mode_info_var_is_locked(!.ModeInfo, Var0, Reason0),
+ \+ (
+ % ...unless the goal is a unification and the var was unified
+ % with something no more instantiated than itself. This allows
+ % for the case of `any = free', for example. The call to
+ % inst_matches_binding, above will fail for the var with
+ % mode `any >> any' however, it should be allowed because
+ % it has only been unified with a free variable.
+ MaybeUInst = yes(UInst),
+ inst_is_at_least_as_instantiated(Inst, UInst, Type,
+ ModuleInfo),
+ inst_matches_binding_allow_any_any(Inst, Inst0, Type,
+ ModuleInfo)
+ )
+ ->
+ set.singleton_set(WaitingVars, Var0),
+ ModeError = mode_error_bind_var(Reason0, Var0, Inst0, Inst),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ ;
+ instmap_set_var(Var0, Inst, InstMap0, InstMap),
+ mode_info_set_instmap(InstMap, !ModeInfo),
+ mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
+ delay_info_bind_var(Var0, DelayInfo0, DelayInfo),
+ mode_info_set_delay_info(DelayInfo, !ModeInfo)
+ )
+ ;
+ true
+ ),
+ (
+ PVars0 = []
+ ;
+ PVars0 = [par_conj_mode_check(NonLocals, Bound0) | PVars1],
+ ( set.member(Var0, NonLocals) ->
+ set.insert(Bound0, Var0, Bound),
+ PVars = [par_conj_mode_check(NonLocals, Bound) | PVars1]
+ ;
+ PVars = PVars0
+ ),
+ mode_info_set_parallel_vars(PVars, !ModeInfo)
+ ).
+
+ % If this was a call to an implied mode for that variable, then we need to
+ % introduce a fresh variable.
+ %
+:- pred handle_implied_mode(prog_var::in, mer_inst::in, mer_inst::in,
+ prog_var::out, extra_goals::in, extra_goals::out,
+ mode_info::in, mode_info::out) is det.
+
+handle_implied_mode(Var0, VarInst0, InitialInst0, Var, !ExtraGoals,
+ !ModeInfo) :-
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ inst_expand(ModuleInfo0, InitialInst0, InitialInst),
+ inst_expand(ModuleInfo0, VarInst0, VarInst1),
+
+ mode_info_get_var_types(!.ModeInfo, VarTypes0),
+ map.lookup(VarTypes0, Var0, VarType),
+ (
+ % If the initial inst of the variable matches_final the initial inst
+ % specified in the pred's mode declaration, then it's not a call
+ % to an implied mode, it's an exact match with a genuine mode.
+ inst_matches_initial_no_implied_modes(VarInst1, InitialInst,
+ VarType, ModuleInfo0)
+ ->
+ Var = Var0
+ ;
+ % This is the implied mode case. We do not yet handle implied modes
+ % for partially instantiated vars, since that would require doing
+ % a partially instantiated deep copy, and we don't know how to do
+ % that yet.
+
+ InitialInst = any(_, _),
+ inst_is_free(ModuleInfo0, VarInst1)
+ ->
+ % This is the simple case of implied `any' modes, where the declared
+ % mode was `any -> ...' and the argument passed was `free'.
+
+ Var = Var0,
+
+ % If the variable's type is not a solver type (in which case inst `any'
+ % means the same as inst `ground') then this is an implied mode that we
+ % don't yet know how to handle.
+ %
+ % If the variable's type is a solver type then we need to insert a call
+ % to the solver type's initialisation predicate. (To avoid unnecessary
+ % complications, we avoid doing this if there are any mode errors
+ % recorded at this point.)
+
+ mode_info_get_context(!.ModeInfo, Context),
+ mode_info_get_mode_context(!.ModeInfo, ModeContext),
+ mode_context_to_unify_context(!.ModeInfo, ModeContext, UnifyContext),
+ CallUnifyContext = yes(call_unify_context(Var, rhs_var(Var),
+ UnifyContext)),
+ (
+ mode_info_get_errors(!.ModeInfo, ModeErrors),
+ ModeErrors = [],
+ mode_info_may_init_solver_vars(!.ModeInfo),
+ mode_info_solver_init_is_supported(!.ModeInfo),
+ type_is_solver_type_with_auto_init(ModuleInfo0, VarType)
+ ->
+ % Create code to initialize the variable to inst `any',
+ % by calling the solver type's initialisation predicate.
+ insert_extra_initialisation_call(Var, VarType, InitialInst,
+ Context, CallUnifyContext, !ExtraGoals, !ModeInfo)
+ ;
+ % If the type is a type variable, or isn't a solver type,
+ % then give up.
+ set.singleton_set(WaitingVars, Var0),
+ ModeError = mode_error_implied_mode(Var0, VarInst0, InitialInst),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ )
+ ;
+ inst_is_bound(ModuleInfo0, InitialInst)
+ ->
+ % This is the case we can't handle.
+ Var = Var0,
+ set.singleton_set(WaitingVars, Var0),
+ ModeError = mode_error_implied_mode(Var0, VarInst0, InitialInst),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo)
+ ;
+ % This is the simple case of implied modes,
+ % where the declared mode was free -> ...
+
+ % Introduce a new variable.
+ mode_info_get_varset(!.ModeInfo, VarSet0),
+ varset.new_var(VarSet0, Var, VarSet),
+ map.set(VarTypes0, Var, VarType, VarTypes),
+ mode_info_set_varset(VarSet, !ModeInfo),
+ mode_info_set_var_types(VarTypes, !ModeInfo),
+
+ % Construct the code to do the unification.
+ create_var_var_unification(Var0, Var, VarType, !.ModeInfo, ExtraGoal),
+
+ % Append the goals together in the appropriate order:
+ % ExtraGoals0, then NewUnify.
+ NewUnifyExtraGoal = extra_goals([], [ExtraGoal]),
+ append_extra_goals(!.ExtraGoals, NewUnifyExtraGoal, !:ExtraGoals)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+mode_info_add_goals_live_vars(_ConjType, [], !ModeInfo).
+mode_info_add_goals_live_vars(ConjType, [Goal | Goals], !ModeInfo) :-
+ % We add the live vars for the goals in the goal list in reverse order,
+ % because this ensures that in the common case (where there is no
+ % delaying), when we come to remove the live vars for the first goal
+ % they will have been added last and will thus be at the start of the list
+ % of live vars sets, which makes them cheaper to remove.
+ mode_info_add_goals_live_vars(ConjType, Goals, !ModeInfo),
+ (
+ % Recurse into conjunctions, in case there are any conjunctions
+ % that have not been flattened.
+ Goal = hlds_goal(conj(ConjType, ConjGoals), _)
+ ->
+ mode_info_add_goals_live_vars(ConjType, ConjGoals, !ModeInfo)
+ ;
+ NonLocals = goal_get_nonlocals(Goal),
+ mode_info_add_live_vars(NonLocals, !ModeInfo)
+ ).
+
+mode_info_remove_goals_live_vars([], !ModeInfo).
+mode_info_remove_goals_live_vars([Goal | Goals], !ModeInfo) :-
+ (
+ % Recurse into conjunctions, in case there are any conjunctions
+ % that have not been flattened.
+ Goal = hlds_goal(conj(plain_conj, ConjGoals), _)
+ ->
+ mode_info_remove_goals_live_vars(ConjGoals, !ModeInfo)
+ ;
+ NonLocals = goal_get_nonlocals(Goal),
+ mode_info_remove_live_vars(NonLocals, !ModeInfo)
+ ),
+ mode_info_remove_goals_live_vars(Goals, !ModeInfo).
+
+%-----------------------------------------------------------------------------%
+
+:- pred insert_extra_initialisation_call(prog_var::in, mer_type::in,
+ mer_inst::in, prog_context::in, maybe(call_unify_context)::in,
+ extra_goals::in, extra_goals::out, mode_info::in, mode_info::out) is det.
+
+insert_extra_initialisation_call(Var, VarType, Inst, Context, CallUnifyContext,
+ !ExtraGoals, !ModeInfo) :-
+ construct_initialisation_call(Var, VarType, Inst, Context,
+ CallUnifyContext, InitVarGoal, !ModeInfo),
+ NewExtraGoal = extra_goals([InitVarGoal], []),
+ append_extra_goals(!.ExtraGoals, NewExtraGoal, !:ExtraGoals).
+
+construct_initialisation_calls([], [], !ModeInfo).
+construct_initialisation_calls([Var | Vars], [Goal | Goals], !ModeInfo) :-
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, Var, VarType),
+ InitialInst = free,
+ Context = term.context_init,
+ MaybeCallUnifyContext = no,
+ construct_initialisation_call(Var, VarType, InitialInst, Context,
+ MaybeCallUnifyContext, Goal, !ModeInfo),
+ construct_initialisation_calls(Vars, Goals, !ModeInfo).
+
+construct_initialisation_call(Var, VarType, Inst, Context,
+ MaybeCallUnifyContext, InitVarGoal, !ModeInfo) :-
+ (
+ type_to_ctor_and_args(VarType, TypeCtor, _TypeArgs),
+ PredName = special_pred_name(spec_pred_init, TypeCtor),
+ (
+ TypeCtor = type_ctor(qualified(ModuleName, _TypeName), _Arity)
+ ;
+ TypeCtor = type_ctor(unqualified(_TypeName), _Arity),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ module_info_get_name(ModuleInfo, ModuleName)
+ ),
+ NonLocals = set.make_singleton_set(Var),
+ InstMapDeltaAL = [Var - Inst],
+ InstMapDelta = instmap_delta_from_assoc_list(InstMapDeltaAL),
+ build_call(ModuleName, PredName, [Var], [VarType], NonLocals,
+ InstMapDelta, Context, MaybeCallUnifyContext,
+ hlds_goal(GoalExpr, GoalInfo), !ModeInfo)
+ ->
+ InitVarGoal = hlds_goal(GoalExpr, GoalInfo),
+ % If Var was ignored, i.e. it occurred in only one atomic goal
+ % and was not in that atomic goal's nonlocals set, then creating
+ % the call to the initialisation predicate and adding it to the
+ % procedure body requires the addition of Var to the original goal's
+ % nonlocals set. This *should* be done by looking at all the places
+ % in the compiler that decide to call construct_initialisation_call
+ % directly or indirectly, and modifying that code to add Var to
+ % the relevant nonlocals set, or possibly by avoiding the call
+ % to construct_initialisation_call altogether (after all, if
+ % a variable is ignored, it should not need initialization).
+ %
+ % However, getting a requantify pass to do it for us is less work.
+ %
+ % An example of code that needs this fix for the correctness of the
+ % HLDS is tests/hard_coded/solver_construction_init_test.m.
+ mode_info_set_need_to_requantify(need_to_requantify, !ModeInfo)
+ ;
+ unexpected(this_file, "construct_initialisation_call")
+ ).
+
+:- pred build_call(module_name::in, string::in, list(prog_var)::in,
+ list(mer_type)::in, set(prog_var)::in, instmap_delta::in,
+ prog_context::in, maybe(call_unify_context)::in, hlds_goal::out,
+ mode_info::in, mode_info::out) is semidet.
+
+build_call(CalleeModuleName, CalleePredName, ArgVars, ArgTypes, NonLocals,
+ InstMapDelta, Context, MaybeCallUnifyContext, Goal, !ModeInfo) :-
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+
+ % Get the relevant information for the procedure we are transforming
+ % (i.e., the caller).
+ mode_info_get_pred_id(!.ModeInfo, PredId),
+ mode_info_get_proc_id(!.ModeInfo, ProcId),
+ module_info_pred_proc_info(ModuleInfo0, PredId, ProcId, PredInfo0,
+ ProcInfo0),
+ pred_info_get_typevarset(PredInfo0, TVarSet),
+ pred_info_get_exist_quant_tvars(PredInfo0, ExistQTVars),
+ pred_info_get_head_type_params(PredInfo0, HeadTypeParams),
+
+ % Get the pred_info and proc_info for the procedure we are calling.
+ SymName = qualified(CalleeModuleName, CalleePredName),
+ get_pred_id_and_proc_id_by_types(is_fully_qualified, SymName, pf_predicate,
+ TVarSet, ExistQTVars, ArgTypes, HeadTypeParams, ModuleInfo0,
+ Context, CalleePredId, CalleeProcId),
+ module_info_pred_proc_info(ModuleInfo0, CalleePredId, CalleeProcId,
+ CalleePredInfo, CalleeProcInfo),
+
+ % Create a poly_info for the caller. We have to set the varset and
+ % vartypes from the mode_info, not the proc_info, because new vars may
+ % have been introduced during mode analysis (e.g., when adding
+ % unifications to handle implied modes).
+ mode_info_get_varset(!.ModeInfo, VarSet0),
+ mode_info_get_var_types(!.ModeInfo, VarTypes0),
+ proc_info_set_varset(VarSet0, ProcInfo0, ProcInfo1),
+ proc_info_set_vartypes(VarTypes0, ProcInfo1, ProcInfo2),
+ polymorphism.create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2,
+ PolyInfo0),
+
+ % Create a goal_info for the call.
+ goal_info_init(GoalInfo0),
+ goal_info_set_context(Context, GoalInfo0, GoalInfo1),
+ goal_info_set_nonlocals(NonLocals, GoalInfo1, GoalInfo2),
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo2, GoalInfo),
+
+ % Do the transformation for this call goal.
+ SymName = qualified(CalleeModuleName, CalleePredName),
+ polymorphism_process_new_call(CalleePredInfo, CalleeProcInfo,
+ CalleePredId, CalleeProcId, ArgVars, not_builtin,
+ MaybeCallUnifyContext, SymName, GoalInfo, Goal, PolyInfo0, PolyInfo),
+
+ % Update the information in the predicate table.
+ polymorphism.poly_info_extract(PolyInfo, PredInfo0, PredInfo,
+ ProcInfo2, ProcInfo, ModuleInfo1),
+ module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
+ ModuleInfo1, ModuleInfo),
+
+ % Update the information in the mode_info.
+ proc_info_get_varset(ProcInfo, VarSet),
+ proc_info_get_vartypes(ProcInfo, VarTypes),
+ mode_info_set_varset(VarSet, !ModeInfo),
+ mode_info_set_var_types(VarTypes, !ModeInfo),
+ mode_info_set_module_info(ModuleInfo, !ModeInfo).
+
+prepend_initialisation_call(Var, VarType, InitialInst, Goal0, Goal,
+ !ModeInfo) :-
+ Goal0 = hlds_goal(_GoalExpr0, GoalInfo0),
+ Context = goal_info_get_context(GoalInfo0),
+ CallUnifyContext = no,
+ construct_initialisation_call(Var, VarType, InitialInst, Context,
+ CallUnifyContext, InitVarGoal, !ModeInfo),
+ goal_to_conj_list(Goal0, ConjList0),
+ conj_list_to_goal([InitVarGoal | ConjList0], GoalInfo0, Goal).
+
+%-----------------------------------------------------------------------------%
+
+mode_context_to_unify_context(_ModeInfo, ModeContext, UnifyContext) :-
+ (
+ ModeContext = mode_context_unify(UnifyContext, _)
+ ;
+ ModeContext = mode_context_call(CallId, Arg),
+ UnifyContext = unify_context(umc_call(CallId, Arg), [])
+ ;
+ ModeContext = mode_context_uninitialized,
+ unexpected(this_file,
+ "mode_context_to_unify_context: uninitialized context")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+get_live_vars([], [], []).
+get_live_vars([_ | _], [], _) :-
+ unexpected(this_file, "get_live_vars: length mismatch").
+get_live_vars([], [_ | _], _) :-
+ unexpected(this_file, "get_live_vars: length mismatch").
+get_live_vars([Var | Vars], [IsLive | IsLives], LiveVars) :-
+ (
+ IsLive = is_live,
+ LiveVars = [Var | LiveVars0]
+ ;
+ IsLive = is_dead,
+ LiveVars = LiveVars0
+ ),
+ get_live_vars(Vars, IsLives, LiveVars0).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "modecheck_util.m".
+
+%-----------------------------------------------------------------------------%
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.387
diff -u -b -r1.387 modes.m
--- compiler/modes.m 22 Sep 2009 07:34:15 -0000 1.387
+++ compiler/modes.m 24 Sep 2009 04:21:28 -0000
@@ -10,8 +10,7 @@
% Main author: fjh.
%
% This module contains the top level of the code for mode checking and mode
-% inference. It uses code in the subsidiary modules mode_info, delay_info,
-% inst_match, mode_errors, and mode_util.
+% inference.
%
% Basically what this module does is to traverse the HLDS, performing
% mode-checking or mode inference on each predicate. For each procedure, it
@@ -56,76 +55,7 @@
% in the proc_info, and check whether they changed
% (so that we know when we've reached the fixpoint).
%
-% To mode-analyse a goal:
-% If goal is
-% (a) a disjunction
-% Mode-analyse the sub-goals;
-% check that the final insts of all the non-local
-% variables are the same for all the sub-goals.
-% (b) a conjunction
-% Attempt to schedule each sub-goal. If a sub-goal can
-% be scheduled, then schedule it, otherwise delay it.
-% Continue with the remaining sub-goals until there are
-% no goals left. Every time a variable gets bound,
-% see whether we should wake up a delayed goal,
-% and if so, wake it up next time we get back to
-% the conjunction. If there are still delayed goals
-% hanging around at the end of the conjunction,
-% report a mode error.
-% (c) a negation
-% Mode-check the sub-goal.
-% Check that the sub-goal does not further instantiate
-% any non-local variables. (Actually, rather than
-% doing this check after we mode-analyse the subgoal,
-% we instead "lock" the non-local variables, and
-% disallow binding of locked variables.)
-% (d) a unification
-% Check that the unification doesn't attempt to unify
-% two free variables (or in general two free sub-terms)
-% unless one of them is dead. Split unifications
-% up if necessary to avoid complicated sub-unifications.
-% We also figure out at this point whether or not each
-% unification can fail.
-% (e) a predicate call
-% Check that there is a mode declaration for the
-% predicate which matches the current instantiation of
-% the arguments. (Also handle calls to implied modes.)
-% If the called predicate is one for which we must infer
-% the modes, then create a new mode for the called predicate
-% whose initial insts are the result of normalising
-% the current inst of the arguments.
-% (f) an if-then-else
-% Attempt to schedule the condition. If successful,
-% then check that it doesn't further instantiate any
-% non-local variables, mode-check the `then' part
-% and the `else' part, and then check that the final
-% insts match. (Perhaps also think about expanding
-% if-then-elses so that they can be run backwards,
-% if the condition can't be scheduled?)
-%
-% To attempt to schedule a goal, first mode-check the goal. If mode-checking
-% succeeds, then scheduling succeeds. If mode-checking would report
-% an error due to the binding of a local variable, then scheduling
-% fails. (If mode-checking would report an error due to the binding of
-% a *local* variable, we could report the error right away --
-% but this idea has not yet been implemented.)
-%
-% Note that the notion of liveness used here is different to that
-% used in liveness.m and the code generator. Here, we consider
-% a variable live if its value will be used later on in the computation.
-%
-% XXX We ought to allow unification of free with free even when both
-% *variables* are live, if one of the particular *sub-nodes* is dead
-% (causes problems handling e.g. `list.same_length').
-%
-% XXX We ought to break unifications into "micro-unifications", because
-% some code can't be scheduled without splitting up unifications.
-% For example, `p(X) :- X = f(A, B), B is A + 1.', where p is declared as
-% `:- mode p(bound(f(ground,free))->ground).'.
-%
-% XXX At the moment we don't check for circular modes or insts.
-% If they aren't used, the compiler will probably not detect the error;
-% if they are, it will probably go into an infinite loop.
+% How to mode-analyse a goal is documented at the top of modecheck_goal.
%
%-----------------------------------------------------------------------------%
@@ -137,14 +67,12 @@
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
-:- import_module hlds.instmap.
:- import_module parse_tree.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module list.
-:- import_module maybe.
%-----------------------------------------------------------------------------%
@@ -191,184 +119,12 @@
may_change_called_proc::in, module_info::in, module_info::out,
list(error_spec)::out, bool::out) is det.
-%-----------------------------------------------------------------------------%
-
-% The following predicates are used by unique_modes.m.
-
- % Modecheck a unification.
-
- % Given a list of variables, and a list of livenesses,
- % select the live variables.
- %
-:- pred get_live_vars(list(prog_var)::in, list(is_live)::in,
- list(prog_var)::out) is det.
-
- % Calculate the argument number offset that needs to be passed to
- % modecheck_var_list_is_live, modecheck_var_has_inst_list, and
- % modecheck_set_var_inst_list. This offset number is calculated so that
- % real arguments get positive argument numbers and type_info arguments
- % get argument numbers less than or equal to 0.
- %
-:- pred compute_arg_offset(pred_info::in, int::out) is det.
-
- % Given a list of variables and a list of expected liveness, ensure
- % that the inst of each variable satisfies the corresponding expected
- % liveness. See below for the difference between the two variants.
- %
-:- pred modecheck_var_list_is_live_exact_match(list(prog_var)::in,
- list(is_live)::in, int::in, mode_info::in, mode_info::out) is det.
-:- pred modecheck_var_list_is_live_no_exact_match(list(prog_var)::in,
- list(is_live)::in, int::in, mode_info::in, mode_info::out) is det.
-
- % Given a list of variables and a list of initial insts, ensure that
- % the inst of each variable matches the corresponding initial inst.
- % The first variant requires an exact match (using inst_matches_final),
- % while the second we allow the var to be more instantiated than the inst
- % (using inst_matches_initial).
- %
-:- pred modecheck_var_has_inst_list_exact_match(list(prog_var)::in,
- list(mer_inst)::in, int::in, inst_var_sub::out,
- mode_info::in, mode_info::out) is det.
-:- pred modecheck_var_has_inst_list_no_exact_match(list(prog_var)::in,
- list(mer_inst)::in, int::in, inst_var_sub::out,
- mode_info::in, mode_info::out) is det.
-
- % This is a special-cased, cut-down version of
- % modecheck_var_has_inst_list_no_exact_match for use specifically
- % on introduced type_info_type variables.
- %
-:- pred modecheck_introduced_type_info_var_has_inst_no_exact_match(
- prog_var::in, mer_type::in, mer_inst::in,
- mode_info::in, mode_info::out) is det.
-
- % modecheck_set_var_inst(Var, Inst, MaybeUInst, !ModeInfo):
- %
- % Assign the given Inst to the given Var, after checking that it is
- % okay to do so. If the inst to be assigned is the result of an
- % abstract unification then the MaybeUInst argument should be the
- % initial inst of the _other_ side of the unification. This allows
- % more precise (i.e. less conservative) checking in the case that
- % Inst contains `any' components and Var is locked (i.e. is a
- % nonlocal variable in a negated context). Where the inst is not
- % the result of an abstract unification then MaybeUInst should be `no'.
- %
-:- pred modecheck_set_var_inst(prog_var::in, mer_inst::in, maybe(mer_inst)::in,
- mode_info::in, mode_info::out) is det.
-
-:- pred modecheck_set_var_inst_list(list(prog_var)::in, list(mer_inst)::in,
- list(mer_inst)::in, int::in, list(prog_var)::out, extra_goals::out,
- mode_info::in, mode_info::out) is det.
-
% Check that the final insts of the head vars of a lambda goal
% matches their expected insts.
%
:- pred modecheck_lambda_final_insts(list(prog_var)::in, list(mer_inst)::in,
hlds_goal::in, hlds_goal::out, mode_info::in, mode_info::out) is det.
-:- pred mode_info_add_goals_live_vars(conj_type::in, list(hlds_goal)::in,
- mode_info::in, mode_info::out) is det.
-
-:- pred mode_info_remove_goals_live_vars(list(hlds_goal)::in,
- mode_info::in, mode_info::out) is det.
-
- % modecheck_functor_test(Var, ConsId, !ModeInfo):
- %
- % Update the instmap to reflect the fact that Var was bound to ConsId.
- % This is used for the functor tests in `switch' statements.
- %
-:- pred modecheck_functor_test(prog_var::in, cons_id::in,
- mode_info::in, mode_info::out) is det.
-
- % modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo):
- %
- % Update the instmap to reflect the fact that Var was bound to either
- % MainConsId or one of the OtherConsIds.
- % This is used for the functor tests in `switch' statements.
- %
-:- pred modecheck_functors_test(prog_var::in, cons_id::in, list(cons_id)::in,
- mode_info::in, mode_info::out) is det.
-
- % compute_goal_instmap_delta(InstMap0, GoalExpr, !GoalInfo, !ModeInfo):
- %
- % Work out the instmap_delta for a goal from the instmaps before and after
- % the goal. The instmap before the goal is given by InstMap0; the instmap
- % after the goal is given by !.ModeInfo.
- %
-:- pred compute_goal_instmap_delta(instmap::in, hlds_goal_expr::in,
- hlds_goal_info::in, hlds_goal_info::out, mode_info::in, mode_info::out)
- is det.
-
-%-----------------------------------------------------------------------------%
-
-% The following predicates are used by modecheck_unify.m.
-
- % Modecheck a goal by abstractly interpreting it, as explained
- % at the top of this file.
- %
- % Input-output:
- % InstMap Stored in ModeInfo
- % DelayInfo Stored in ModeInfo
- % Goal Passed as an argument pair
- % Input only:
- % ModuleInfo Stored in ModeInfo (constant)
- % Context Stored in ModeInfo (changing as we go along the clause)
- % Output only:
- % Error Messages Output directly to stdout.
- %
-:- pred modecheck_goal(hlds_goal::in, hlds_goal::out,
- mode_info::in, mode_info::out) is det.
-
- % Mode-check a single goal-expression.
- %
-:- pred modecheck_goal_expr(hlds_goal_expr::in, hlds_goal_info::in,
- hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
-
-:- type extra_goals
- ---> no_extra_goals
- ; extra_goals(
- extra_before_main :: list(hlds_goal),
- % goals to insert before the main goal
- extra_after_main :: list(hlds_goal)
- % goals to append after the main goal
- ).
-
-:- type after_goals
- ---> no_after_goals
- ; after_goals(
- after_instmap :: instmap,
- % instmap at end of main goal
- after_goals :: list(hlds_goal)
- % goals to append after the main goal
- ).
-
- % Append_extra_goals inserts adds some goals to the
- % list of goals to insert before/after the main goal.
- %
-:- pred append_extra_goals(extra_goals::in, extra_goals::in,
- extra_goals::out) is det.
-
- % Handle_extra_goals combines MainGoal and ExtraGoals into a single
- % hlds_goal_expr, rerunning mode analysis on the entire conjunction
- % if ExtraGoals is not empty.
- %
-:- pred handle_extra_goals(hlds_goal_expr::in, extra_goals::in,
- hlds_goal_info::in, list(prog_var)::in, list(prog_var)::in,
- instmap::in, hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
-
-:- pred mode_context_to_unify_context(mode_info::in, mode_context::in,
- unify_context::out) is det.
-
- % Construct a call to initialise a free solver type variable.
- %
-:- pred construct_initialisation_call(prog_var::in, mer_type::in, mer_inst::in,
- prog_context::in, maybe(call_unify_context)::in,
- hlds_goal::out, mode_info::in, mode_info::out) is det.
-
- % Construct a list of initialisation calls.
- %
-:- pred construct_initialisation_calls(list(prog_var)::in,
- list(hlds_goal)::out, mode_info::in, mode_info::out) is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -376,43 +132,31 @@
:- import_module check_hlds.clause_to_proc.
:- import_module check_hlds.cse_detection.
-:- import_module check_hlds.delay_info.
:- import_module check_hlds.delay_partial_inst.
:- import_module check_hlds.det_analysis.
:- import_module check_hlds.inst_match.
-:- import_module check_hlds.inst_util.
-:- import_module check_hlds.mode_debug.
:- import_module check_hlds.mode_errors.
:- import_module check_hlds.mode_util.
-:- import_module check_hlds.modecheck_call.
-:- import_module check_hlds.modecheck_unify.
-:- import_module check_hlds.polymorphism.
+:- import_module check_hlds.modecheck_goal.
+:- import_module check_hlds.modecheck_util.
:- import_module check_hlds.switch_detection.
:- import_module check_hlds.type_util.
:- import_module check_hlds.unify_proc.
:- import_module check_hlds.unique_modes.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_clauses.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_out.
+:- import_module hlds.instmap.
:- import_module hlds.passes_aux.
:- import_module hlds.pred_table.
:- import_module hlds.quantification.
-:- import_module hlds.special_pred.
:- import_module libs.
:- import_module libs.compiler_util.
:- import_module libs.file_util.
:- import_module libs.globals.
:- import_module libs.options.
-:- import_module mdbcomp.
-:- import_module mdbcomp.prim_data.
-:- import_module parse_tree.builtin_lib_types.
-:- import_module parse_tree.error_util.
-:- import_module parse_tree.mercury_to_mercury.
-:- import_module parse_tree.prog_event.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
-:- import_module parse_tree.prog_type.
:- import_module assoc_list.
:- import_module bag.
@@ -420,13 +164,12 @@
:- import_module io.
:- import_module list.
:- import_module map.
-:- import_module pair.
+:- import_module maybe.
:- import_module queue.
:- import_module set.
:- import_module string.
:- import_module svmap.
:- import_module term.
-:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -1293,7 +1036,7 @@
),
% Don't lose the information added by the functor test above.
- fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal2),
+ fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal1, Goal2),
% Check that final insts match those specified in the mode declaration.
modecheck_final_insts(HeadVars, no, ArgFinalInsts0,
@@ -1339,7 +1082,7 @@
% Don't lose the information added by the functor test above.
mode_info_get_instmap(!.ModeInfo, InstMap),
- fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal2),
+ fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal1, Goal2),
% Check that final insts match those specified in the mode declaration.
modecheck_final_insts(HeadVars, no, ArgFinalInsts0, _ArgFinalInsts,
@@ -1507,3001 +1250,115 @@
).
%-----------------------------------------------------------------------------%
-
-:- pred prepend_initialisation_call(prog_var::in, mer_type::in, mer_inst::in,
- hlds_goal::in, hlds_goal::out, mode_info::in, mode_info::out) is det.
-
-prepend_initialisation_call(Var, VarType, InitialInst, Goal0, Goal,
- !ModeInfo) :-
- Goal0 = hlds_goal(_GoalExpr0, GoalInfo0),
- Context = goal_info_get_context(GoalInfo0),
- CallUnifyContext = no,
- construct_initialisation_call(Var, VarType, InitialInst, Context,
- CallUnifyContext, InitVarGoal, !ModeInfo),
- goal_to_conj_list(Goal0, ConjList0),
- conj_list_to_goal([InitVarGoal | ConjList0], GoalInfo0, Goal).
-
-%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-modecheck_goal(Goal0, Goal, !ModeInfo) :-
- Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
- % Note: any changes here may need to be duplicated in unique_modes.m.
-
- % Store the current context in the mode_info.
- Context = goal_info_get_context(GoalInfo0),
- term.context_init(EmptyContext),
- ( Context = EmptyContext ->
- true
- ;
- mode_info_set_context(Context, !ModeInfo)
- ),
- ( goal_info_has_feature(GoalInfo0, feature_duplicated_for_switch) ->
- mode_info_get_in_dupl_for_switch(!.ModeInfo, InDuplForSwitch),
- mode_info_set_in_dupl_for_switch(in_dupl_for_switch, !ModeInfo),
- modecheck_goal_2(GoalExpr0, GoalInfo0, Goal, !ModeInfo),
- mode_info_set_in_dupl_for_switch(InDuplForSwitch, !ModeInfo)
- ;
- modecheck_goal_2(GoalExpr0, GoalInfo0, Goal, !ModeInfo)
- ).
-
-:- pred modecheck_goal_2(hlds_goal_expr::in, hlds_goal_info::in,
- hlds_goal::out, mode_info::in, mode_info::out) is det.
-
-:- pragma inline(modecheck_goal_2/5).
+ % Check that the evaluation method is OK for the given mode(s).
+ % We also check the mode of main/2 here.
+ %
+:- pred check_eval_methods(module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-modecheck_goal_2(GoalExpr0, GoalInfo0, Goal, !ModeInfo) :-
- % Modecheck the goal, and then store the changes in instantiation
- % of the vars in the delta_instmap in the goal's goal_info.
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- modecheck_goal_expr(GoalExpr0, GoalInfo0, GoalExpr, !ModeInfo),
- compute_goal_instmap_delta(InstMap0, GoalExpr, GoalInfo0, GoalInfo,
- !ModeInfo),
- Goal = hlds_goal(GoalExpr, GoalInfo).
+check_eval_methods(!ModuleInfo, !Specs) :-
+ module_info_predids(PredIds, !ModuleInfo),
+ pred_check_eval_methods(!.ModuleInfo, PredIds, !Specs).
-modecheck_goal_expr(GoalExpr0, GoalInfo0, GoalExpr, !ModeInfo) :-
- % XXX The predicates we call here should have their definitions
- % in the same order as this switch.
- (
- GoalExpr0 = unify(LHS0, RHS0, _UniMode, Unification0, UnifyContext),
- modecheck_goal_unify(LHS0, RHS0, Unification0, UnifyContext, GoalInfo0,
- GoalExpr, !ModeInfo)
- ;
- GoalExpr0 = plain_call(PredId, ProcId0, Args0, _Builtin,
- MaybeCallUnifyContext, PredName),
- modecheck_goal_plain_call(PredId, ProcId0, Args0,
- MaybeCallUnifyContext, PredName, GoalInfo0, GoalExpr,
- !ModeInfo)
- ;
- GoalExpr0 = generic_call(GenericCall, Args0, Modes0, _Detism),
- modecheck_goal_generic_call(GenericCall, Args0, Modes0, GoalInfo0,
- GoalExpr, !ModeInfo)
- ;
- GoalExpr0 = call_foreign_proc(Attributes, PredId, ProcId0,
- Args0, ExtraArgs, MaybeTraceRuntimeCond, PragmaCode),
- modecheck_goal_call_foreign_proc(Attributes, PredId, ProcId0,
- Args0, ExtraArgs, MaybeTraceRuntimeCond, PragmaCode,
- GoalInfo0, GoalExpr, !ModeInfo)
- ;
- GoalExpr0 = conj(ConjType, Goals),
- modecheck_goal_conj(ConjType, Goals, GoalInfo0, GoalExpr,
- !ModeInfo)
- ;
- GoalExpr0 = disj(Goals),
- modecheck_goal_disj(Goals, GoalInfo0, GoalExpr, !ModeInfo)
- ;
- GoalExpr0 = switch(Var, CanFail, Cases0),
- modecheck_goal_switch(Var, CanFail, Cases0, GoalInfo0, GoalExpr,
- !ModeInfo)
- ;
- GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
- modecheck_goal_if_then_else(Vars, Cond0, Then0, Else0, GoalInfo0,
- GoalExpr, !ModeInfo)
- ;
- GoalExpr0 = negation(SubGoal0),
- modecheck_goal_negation(SubGoal0, GoalInfo0, GoalExpr, !ModeInfo)
- ;
- GoalExpr0 = scope(Reason, SubGoal0),
- modecheck_goal_scope(Reason, SubGoal0, GoalInfo0, GoalExpr, !ModeInfo)
- ;
- GoalExpr0 = shorthand(ShortHand0),
- modecheck_goal_shorthand(ShortHand0, GoalInfo0, GoalExpr, !ModeInfo)
- ).
+:- pred pred_check_eval_methods(module_info::in, list(pred_id)::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-%-----------------------------------------------------------------------------%
+pred_check_eval_methods(_, [], !Specs).
+pred_check_eval_methods(ModuleInfo, [PredId | PredIds], !Specs) :-
+ module_info_preds(ModuleInfo, Preds),
+ map.lookup(Preds, PredId, PredInfo),
+ ProcIds = pred_info_procids(PredInfo),
+ proc_check_eval_methods(ModuleInfo, PredId, ProcIds, !Specs),
+ pred_check_eval_methods(ModuleInfo, PredIds, !Specs).
-:- pred modecheck_goal_conj(conj_type::in, list(hlds_goal)::in,
- hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
+:- pred proc_check_eval_methods(module_info::in, pred_id::in,
+ list(proc_id)::in, list(error_spec)::in, list(error_spec)::out) is det.
-modecheck_goal_conj(ConjType, Goals0, GoalInfo0, GoalExpr, !ModeInfo) :-
- (
- ConjType = plain_conj,
- mode_checkpoint(enter, "conj", !ModeInfo),
+proc_check_eval_methods(_, _, [], !Specs).
+proc_check_eval_methods(ModuleInfo, PredId, [ProcId | ProcIds], !Specs) :-
+ module_info_pred_proc_info(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo),
+ proc_info_get_eval_method(ProcInfo, EvalMethod),
+ proc_info_get_argmodes(ProcInfo, Modes),
(
- Goals0 = [],
- % Optimize the common case for efficiency.
- GoalExpr = conj(plain_conj, [])
- ;
- Goals0 = [_ | _],
- modecheck_conj_list(ConjType, Goals0, Goals, !ModeInfo),
- conj_list_to_goal(Goals, GoalInfo0, hlds_goal(GoalExpr, _GoalInfo))
- ),
- mode_checkpoint(exit, "conj", !ModeInfo)
+ eval_method_requires_ground_args(EvalMethod) = yes,
+ \+ only_fully_in_out_modes(Modes, ModuleInfo)
+ ->
+ GroundArgsSpec = report_eval_method_requires_ground_args(ProcInfo),
+ !:Specs = [GroundArgsSpec | !.Specs]
;
- ConjType = parallel_conj,
- mode_checkpoint(enter, "par_conj", !ModeInfo),
- % Empty parallel conjunction should not be a common case.
- modecheck_conj_list(ConjType, Goals0, Goals, !ModeInfo),
- par_conj_list_to_goal(Goals, GoalInfo0,
- hlds_goal(GoalExpr, _GoalInfo)),
- mode_checkpoint(exit, "par_conj", !ModeInfo)
- ).
-
-:- pred modecheck_goal_disj(list(hlds_goal)::in, hlds_goal_info::in,
- hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
-
-modecheck_goal_disj(Disjuncts0, GoalInfo0, GoalExpr, !ModeInfo) :-
- mode_checkpoint(enter, "disj", !ModeInfo),
+ true
+ ),
(
- Disjuncts0 = [], % for efficiency, optimize common case
- GoalExpr = disj(Disjuncts0),
- instmap.init_unreachable(InstMap),
- mode_info_set_instmap(InstMap, !ModeInfo)
- ;
- % If you modify this code, you may also need to modify
- % modecheck_clause_disj or the code that calls it.
- Disjuncts0 = [_ | _],
- NonLocals = goal_info_get_nonlocals(GoalInfo0),
- modecheck_disj_list(Disjuncts0, Disjuncts1, InstMaps0,
- NonLocals, LargeFlatConstructs, !ModeInfo),
- ( mode_info_solver_init_is_supported(!.ModeInfo) ->
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- handle_solver_vars_in_disjs(set.to_sorted_list(NonLocals),
- VarTypes, Disjuncts1, Disjuncts2, InstMaps0, InstMaps,
- !ModeInfo)
+ eval_method_destroys_uniqueness(EvalMethod) = yes,
+ \+ only_nonunique_modes(Modes, ModuleInfo)
+ ->
+ UniquenessSpec = report_eval_method_destroys_uniqueness(ProcInfo),
+ !:Specs = [UniquenessSpec | !.Specs]
;
- InstMaps = InstMaps0,
- Disjuncts2 = Disjuncts1
- ),
- Disjuncts3 = flatten_disjs(Disjuncts2),
- merge_disj_branches(NonLocals, LargeFlatConstructs,
- Disjuncts3, Disjuncts, InstMaps, !ModeInfo),
- disj_list_to_goal(Disjuncts, GoalInfo0, hlds_goal(GoalExpr, _GoalInfo))
+ true
),
- mode_checkpoint(exit, "disj", !ModeInfo).
-
-:- pred modecheck_goal_switch(prog_var::in, can_fail::in, list(case)::in,
- hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_goal_switch(Var, CanFail, Cases0, GoalInfo0, GoalExpr, !ModeInfo) :-
- mode_checkpoint(enter, "switch", !ModeInfo),
(
- Cases0 = [],
- Cases = [],
- instmap.init_unreachable(InstMap),
- mode_info_set_instmap(InstMap, !ModeInfo)
+ pred_info_name(PredInfo) = "main",
+ pred_info_orig_arity(PredInfo) = 2,
+ pred_info_is_exported(PredInfo),
+ \+ check_mode_of_main(Modes, ModuleInfo)
+ ->
+ MainSpec = report_wrong_mode_for_main(ProcInfo),
+ !:Specs = [MainSpec | !.Specs]
;
- % If you modify this code, you may also need to modify
- % modecheck_clause_switch or the code that calls it.
- Cases0 = [_ | _],
- NonLocals = goal_info_get_nonlocals(GoalInfo0),
- modecheck_case_list(Cases0, Var, Cases1, InstMaps,
- NonLocals, LargeFlatConstructs, !ModeInfo),
- merge_switch_branches(NonLocals, LargeFlatConstructs,
- Cases1, Cases, InstMaps, !ModeInfo)
- ),
- GoalExpr = switch(Var, CanFail, Cases),
- mode_checkpoint(exit, "switch", !ModeInfo).
-
-:- pred merge_disj_branches(set(prog_var)::in, set(prog_var)::in,
- list(hlds_goal)::in, list(hlds_goal)::out, list(instmap)::in,
- mode_info::in, mode_info::out) is det.
-
-merge_disj_branches(NonLocals, LargeFlatConstructs, Disjuncts0, Disjuncts,
- InstMaps0, !ModeInfo) :-
- ( set.empty(LargeFlatConstructs) ->
- Disjuncts = Disjuncts0,
- InstMaps = InstMaps0
- ;
- % The instmaps will each map every var in LargeFlatConstructs
- % to a very big inst. This means that instmap_merge will take a long
- % time on those variables and add lots of big insts to the merge_inst
- % table. That in turn will cause the later equiv_type_hlds pass
- % to take a long time processing the merge_inst table. All this
- % expense is for nothing, since the chances that the following code
- % wants to know the precise set of possible bindings of variables
- % constructed in what are effectively fact tables is astronomically
- % small.
- %
- % For the variables in LargeFlatConstructs, we know that their
- % final insts do not cause unreachability, do not have uniqueness,
- % do not have higher order inst info, and any information they contain
- % about specific bindings is something we are better off without.
- % We therefore just map all these variables to ground in the instmaps
- % of all the arms before merging them.
-
- list.map(
- set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs),
- Disjuncts0, Disjuncts),
- LargeFlatConstructList = set.to_sorted_list(LargeFlatConstructs),
- list.map(
- instmap_set_vars_same(ground(shared, none),
- LargeFlatConstructList),
- InstMaps0, InstMaps)
- ),
- instmap_merge(NonLocals, InstMaps, merge_disj, !ModeInfo).
-
-:- pred merge_switch_branches(set(prog_var)::in, set(prog_var)::in,
- list(case)::in, list(case)::out, list(instmap)::in,
- mode_info::in, mode_info::out) is det.
-
-merge_switch_branches(NonLocals, LargeFlatConstructs, Cases0, Cases,
- InstMaps0, !ModeInfo) :-
- ( set.empty(LargeFlatConstructs) ->
- Cases = Cases0,
- InstMaps = InstMaps0
- ;
- % The same considerations apply here as in merge_disj_branches.
- list.map(
- set_large_flat_constructs_to_ground_in_case(LargeFlatConstructs),
- Cases0, Cases),
- LargeFlatConstructList = set.to_sorted_list(LargeFlatConstructs),
- list.map(
- instmap_set_vars_same(ground(shared, none),
- LargeFlatConstructList),
- InstMaps0, InstMaps)
+ true
),
- instmap_merge(NonLocals, InstMaps, merge_disj, !ModeInfo).
+ proc_check_eval_methods(ModuleInfo, PredId, ProcIds, !Specs).
-:- pred modecheck_goal_if_then_else(list(prog_var)::in,
- hlds_goal::in, hlds_goal::in, hlds_goal::in,
- hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
+:- pred only_fully_in_out_modes(list(mer_mode)::in, module_info::in)
+ is semidet.
-modecheck_goal_if_then_else(Vars, Cond0, Then0, Else0, GoalInfo0, GoalExpr,
- !ModeInfo) :-
- mode_checkpoint(enter, "if-then-else", !ModeInfo),
- NonLocals = goal_info_get_nonlocals(GoalInfo0),
- ThenVars = goal_get_nonlocals(Then0),
- mode_info_get_instmap(!.ModeInfo, InstMap0),
-
- % We need to lock the non-local variables, to ensure that the condition
- % of the if-then-else does not bind them.
-
- mode_info_lock_vars(var_lock_if_then_else, NonLocals, !ModeInfo),
- mode_info_add_live_vars(ThenVars, !ModeInfo),
- modecheck_goal(Cond0, Cond, !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMapCond),
- mode_info_remove_live_vars(ThenVars, !ModeInfo),
- mode_info_unlock_vars(var_lock_if_then_else, NonLocals, !ModeInfo),
- ( instmap_is_reachable(InstMapCond) ->
- modecheck_goal(Then0, Then1, !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMapThen1)
- ;
- % We should not mode-analyse the goal, since it is unreachable.
- % Instead we optimize the goal away, so that later passes
- % won't complain about it not having mode information.
- Then1 = true_goal,
- InstMapThen1 = InstMapCond
- ),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- modecheck_goal(Else0, Else1, !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMapElse1),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- handle_solver_vars_in_ite(set.to_sorted_list(NonLocals), VarTypes,
- Then1, Then, Else1, Else,
- InstMapThen1, InstMapThen, InstMapElse1, InstMapElse, !ModeInfo),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- instmap_merge(NonLocals, [InstMapThen, InstMapElse], merge_if_then_else,
- !ModeInfo),
- GoalExpr = if_then_else(Vars, Cond, Then, Else),
- mode_info_get_instmap(!.ModeInfo, InstMap),
- mode_info_get_in_promise_purity_scope(!.ModeInfo, InPromisePurityScope),
+only_fully_in_out_modes([], _).
+only_fully_in_out_modes([Mode | Rest], ModuleInfo) :-
+ mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
(
- InPromisePurityScope = not_in_promise_purity_scope,
- CondNonLocals0 = goal_get_nonlocals(Cond),
- CondNonLocals =
- set.to_sorted_list(CondNonLocals0 `intersect` NonLocals),
- check_no_inst_any_vars(if_then_else, CondNonLocals,
- InstMap0, InstMap, !ModeInfo)
+ inst_is_ground(ModuleInfo, InitialInst)
;
- InPromisePurityScope = in_promise_purity_scope
- ),
- mode_checkpoint(exit, "if-then-else", !ModeInfo).
-
-:- pred modecheck_goal_negation(hlds_goal::in, hlds_goal_info::in,
- hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
-
-modecheck_goal_negation(SubGoal0, GoalInfo0, GoalExpr, !ModeInfo) :-
- mode_checkpoint(enter, "not", !ModeInfo),
- NonLocals = goal_info_get_nonlocals(GoalInfo0),
- mode_info_get_instmap(!.ModeInfo, InstMap0),
-
- % When analyzing a negated goal, nothing is forward-live (live on forward
- % execution after that goal), because if the goal succeeds then execution
- % will immediately backtrack. So we need to set the live variables set
- % to empty here. This allows those variables to be backtrackably
- % destructively updated. (If you try to do non-backtrackable destructive
- % update on such a variable, it will be caught later on by unique_modes.m.)
- mode_info_get_live_vars(!.ModeInfo, LiveVars0),
- mode_info_set_live_vars(bag.init, !ModeInfo),
-
- % We need to lock the non-local variables, to ensure that
- % the negation does not bind them.
- mode_info_lock_vars(var_lock_negation, NonLocals, !ModeInfo),
- modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
- mode_info_set_live_vars(LiveVars0, !ModeInfo),
- mode_info_unlock_vars(var_lock_negation, NonLocals, !ModeInfo),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- mode_info_get_in_promise_purity_scope(!.ModeInfo, InPromisePurityScope),
+ inst_is_free(ModuleInfo, InitialInst),
(
- InPromisePurityScope = not_in_promise_purity_scope,
- NegNonLocals = goal_info_get_nonlocals(GoalInfo0),
- instmap.init_unreachable(Unreachable),
- check_no_inst_any_vars(negation, set.to_sorted_list(NegNonLocals),
- InstMap0, Unreachable, !ModeInfo)
+ inst_is_free(ModuleInfo, FinalInst)
;
- InPromisePurityScope = in_promise_purity_scope
+ inst_is_ground(ModuleInfo, FinalInst)
+ )
),
- GoalExpr = negation(SubGoal),
- mode_checkpoint(exit, "not", !ModeInfo).
+ only_fully_in_out_modes(Rest, ModuleInfo).
-:- pred modecheck_goal_scope(scope_reason::in, hlds_goal::in,
- hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
+:- pred only_nonunique_modes(list(mer_mode)::in, module_info::in) is semidet.
-modecheck_goal_scope(Reason, SubGoal0, GoalInfo0, GoalExpr, !ModeInfo) :-
- (
- Reason = trace_goal(_, _, _, _, _),
- mode_checkpoint(enter, "scope", !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- NonLocals = goal_info_get_nonlocals(GoalInfo0),
- % We need to lock the non-local variables, to ensure that
- % the trace goal does not bind them. If it did, then the code
- % would not be valid with the trace goal disabled.
- mode_info_lock_vars(var_lock_trace_goal, NonLocals, !ModeInfo),
- modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
- mode_info_unlock_vars(var_lock_trace_goal, NonLocals, !ModeInfo),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- GoalExpr = scope(Reason, SubGoal),
- mode_checkpoint(exit, "scope", !ModeInfo)
- ;
- ( Reason = exist_quant(_)
- ; Reason = promise_solutions(_, _)
- ; Reason = commit(_)
- ; Reason = barrier(_)
- ),
- mode_checkpoint(enter, "scope", !ModeInfo),
- modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
- GoalExpr = scope(Reason, SubGoal),
- mode_checkpoint(exit, "scope", !ModeInfo)
- ;
- Reason = from_ground_term(TermVar, _),
- mode_checkpoint(enter, "scope", !ModeInfo),
- modecheck_goal_from_ground_term_scope(TermVar, SubGoal0, GoalInfo0,
- Kind1, SubGoal1, !ModeInfo),
- mode_checkpoint(exit, "scope", !ModeInfo),
- mode_info_set_had_from_ground_term(had_from_ground_term_scope,
- !ModeInfo),
+only_nonunique_modes([], _).
+only_nonunique_modes([Mode | Rest], ModuleInfo) :-
+ mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
+ inst_is_not_partly_unique(ModuleInfo, InitialInst),
+ inst_is_not_partly_unique(ModuleInfo, FinalInst),
+ only_nonunique_modes(Rest, ModuleInfo).
- mode_info_get_make_ground_terms_unique(!.ModeInfo,
- MakeGroundTermsUnique),
- (
- MakeGroundTermsUnique = do_not_make_ground_terms_unique,
- UpdatedReason1 = from_ground_term(TermVar, Kind1),
- GoalExpr = scope(UpdatedReason1, SubGoal1)
- ;
- MakeGroundTermsUnique = make_ground_terms_unique,
- (
- Kind1 = from_ground_term_construct,
- modecheck_goal_make_ground_term_unique(TermVar,
- SubGoal1, GoalInfo0, GoalExpr, !ModeInfo)
- ;
- ( Kind1 = from_ground_term_deconstruct
- ; Kind1 = from_ground_term_other
- ),
- % Do not wrap the subgoal up in a scope, since these scopes
- % do not get useful any special treatment.
- SubGoal1 = hlds_goal(GoalExpr, _)
- )
- )
- ;
- Reason = promise_purity(_Purity),
- mode_info_get_in_promise_purity_scope(!.ModeInfo, InPPScope),
- mode_info_set_in_promise_purity_scope(in_promise_purity_scope,
- !ModeInfo),
- mode_checkpoint(enter, "scope", !ModeInfo),
- modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
- GoalExpr = scope(Reason, SubGoal),
- mode_checkpoint(exit, "scope", !ModeInfo),
- mode_info_set_in_promise_purity_scope(InPPScope, !ModeInfo)
- ).
+:- pred check_mode_of_main(list(mer_mode)::in, module_info::in) is semidet.
- % This predicate transforms
- %
- % scope(TermVar,
- % conj(plain_conj,
- % X1 = ...
- % X2 = ...
- % ...
- % TermVar = ...
- % )
- % )
- %
- % into
- %
- % conj(plain_conj,
- % scope(TermVar,
- % conj(plain_conj,
- % X1 = ...
- % X2 = ...
- % ...
- % CloneVar = ...
- % )
- % ),
- % builtin.copy(CloneVar, TermVar)
- % )
- %
- % We could transform it instead into a plain conjunction that directly
- % builds a unique term, but that could have a significant detrimental
- % effect on compile time.
+check_mode_of_main([Di, Uo], ModuleInfo) :-
+ mode_get_insts(ModuleInfo, Di, DiInitialInst, DiFinalInst),
+ mode_get_insts(ModuleInfo, Uo, UoInitialInst, UoFinalInst),
%
- % The performance of the generated code is unlikely to be of too much
- % importance, since we expect programs will rarely need a unique copy
- % of a ground term.
+ % Note that we hard-code these tests,
+ % rather than using `inst_is_free', `inst_is_unique', etc.,
+ % since for main/2 we're looking for an exact match
+ % (modulo inst synonyms) with what the language reference
+ % manual specifies, rather than looking for a particular
+ % abstract property.
%
-:- pred modecheck_goal_make_ground_term_unique(prog_var::in,
- hlds_goal::in, hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_goal_make_ground_term_unique(TermVar, SubGoal0, GoalInfo0, GoalExpr,
- !ModeInfo) :-
- mode_info_get_var_types(!.ModeInfo, VarTypes0),
- mode_info_get_varset(!.ModeInfo, VarSet0),
- varset.new_var(VarSet0, CloneVar, VarSet),
- map.lookup(VarTypes0, TermVar, TermVarType),
- map.det_insert(VarTypes0, CloneVar, TermVarType, VarTypes),
- mode_info_set_varset(VarSet, !ModeInfo),
- mode_info_set_var_types(VarTypes, !ModeInfo),
- map.det_insert(map.init, TermVar, CloneVar, Rename),
- % By construction, TermVar can appear only in (a) SubGoal0's goal_info,
- % and (b) in the last conjunct in SubGoal0's goal_expr; it cannot appear
- % in any of the other conjuncts. We could make this code more efficient
- % by exploiting this fact, but there is not yet any evidence of any need
- % for this.
- rename_some_vars_in_goal(Rename, SubGoal0, SubGoal),
- rename_vars_in_goal_info(need_not_rename, Rename, GoalInfo0,
- ScopeGoalInfo1),
-
- % We must put the instmaps into the goal_infos of all the subgoals of the
- % final GoalExpr we return, since modecheck_goal will not get a chance to
- % do so.
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- instmap_lookup_var(InstMap0, TermVar, TermVarOldInst),
- ScopeInstMapDelta =
- instmap_delta_from_assoc_list([CloneVar - TermVarOldInst]),
- goal_info_set_instmap_delta(ScopeInstMapDelta,
- ScopeGoalInfo1, ScopeGoalInfo),
-
- Reason = from_ground_term(CloneVar, from_ground_term_construct),
- ScopeGoalExpr = scope(Reason, SubGoal),
- ScopeGoal = hlds_goal(ScopeGoalExpr, ScopeGoalInfo),
-
- % We could get a more accurate new inst for TermVar by replacing
- % all the "shared" functors in TermVarOldInst with "unique".
- % However, this should be good enough. XXX wangp, is this right?
- TermVarUniqueInst = ground(unique, none),
-
- instmap_set_var(CloneVar, TermVarOldInst, InstMap0, InstMap1),
- mode_info_set_instmap(InstMap1, !ModeInfo),
-
- Context = goal_info_get_context(GoalInfo0),
- modecheck_make_type_info_var_for_type(TermVarType, Context, TypeInfoVar,
- TypeInfoGoals, !ModeInfo),
-
- InstMapDelta =
- instmap_delta_from_assoc_list([TermVar - TermVarUniqueInst]),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- generate_simple_call(mercury_public_builtin_module, "copy", pf_predicate,
- mode_no(1), detism_det, purity_pure, [TypeInfoVar, CloneVar, TermVar],
- [], InstMapDelta, ModuleInfo, Context, CopyGoal),
- mode_info_get_instmap(!.ModeInfo, InstMap2),
- instmap_set_var(TermVar, TermVarUniqueInst, InstMap2, InstMap),
- mode_info_set_instmap(InstMap, !ModeInfo),
-
- GoalExpr = conj(plain_conj, [ScopeGoal | TypeInfoGoals] ++ [CopyGoal]).
-
-:- pred modecheck_make_type_info_var_for_type(mer_type::in, prog_context::in,
- prog_var::out, list(hlds_goal)::out, mode_info::in, mode_info::out) is det.
-
-modecheck_make_type_info_var_for_type(Type, Context, TypeInfoVar,
- TypeInfoGoals, !ModeInfo) :-
- mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ inst_expand(ModuleInfo, DiInitialInst, ground(unique, none)),
+ inst_expand(ModuleInfo, DiFinalInst, ground(clobbered, none)),
+ inst_expand(ModuleInfo, UoInitialInst, Free),
+ ( Free = free ; Free = free(_Type) ),
+ inst_expand(ModuleInfo, UoFinalInst, ground(unique, none)).
- % Get the relevant information for the current procedure.
- mode_info_get_pred_id(!.ModeInfo, PredId),
- mode_info_get_proc_id(!.ModeInfo, ProcId),
- module_info_pred_proc_info(ModuleInfo0, PredId, ProcId, PredInfo0,
- ProcInfo0),
-
- % Create a poly_info for the current procedure. We have to set the varset
- % and vartypes from the mode_info, not the proc_info, because new vars may
- % have been introduced during mode analysis, e.g. when adding
- % unifications to handle implied modes.
- mode_info_get_var_types(!.ModeInfo, VarTypes0),
- mode_info_get_varset(!.ModeInfo, VarSet0),
- proc_info_set_varset(VarSet0, ProcInfo0, ProcInfo1),
- proc_info_set_vartypes(VarTypes0, ProcInfo1, ProcInfo2),
- polymorphism.create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2,
- PolyInfo0),
-
- polymorphism_make_type_info_var(Type, Context, TypeInfoVar, TypeInfoGoals,
- PolyInfo0, PolyInfo),
-
- % Update the information in the predicate table.
- polymorphism.poly_info_extract(PolyInfo, PredInfo0, PredInfo,
- ProcInfo2, ProcInfo, ModuleInfo1),
- module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
- ModuleInfo1, ModuleInfo),
-
- % Update the information in the mode_info.
- proc_info_get_varset(ProcInfo, VarSet),
- proc_info_get_vartypes(ProcInfo, VarTypes),
- mode_info_set_varset(VarSet, !ModeInfo),
- mode_info_set_var_types(VarTypes, !ModeInfo),
- mode_info_set_module_info(ModuleInfo, !ModeInfo).
-
-:- pred modecheck_goal_from_ground_term_scope(prog_var::in,
- hlds_goal::in, hlds_goal_info::in, from_ground_term_kind::out,
- hlds_goal::out, mode_info::in, mode_info::out) is det.
-
-modecheck_goal_from_ground_term_scope(TermVar, SubGoal0, GoalInfo0,
- Kind, SubGoal, !ModeInfo) :-
- % The original goal does no quantification, so deleting the `scope'
- % would be OK. However, deleting it during mode analysis would mean
- % we don't have it during unique mode analysis and other later compiler
- % passes.
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- instmap_lookup_var(InstMap0, TermVar, TermVarInst),
- mode_info_get_varset(!.ModeInfo, VarSet),
- modecheck_specializable_ground_term(SubGoal0, TermVar, TermVarInst,
- MaybeGroundTermMode),
- (
- MaybeGroundTermMode = yes(construct_ground_term(RevConj0)),
- SubGoal0 = hlds_goal(_, SubGoalInfo0),
- modecheck_ground_term_construct(TermVar, RevConj0,
- SubGoalInfo0, VarSet, SubGoal, !ModeInfo),
- Kind = from_ground_term_construct
- ;
- (
- MaybeGroundTermMode = yes(deconstruct_ground_term(_)),
- % We should specialize the handling of these scopes as well as
- % scopes that construct ground terms, but we don't yet have
- % a compelling motivating example.
- SubGoal1 = SubGoal0,
- Kind = from_ground_term_deconstruct
- ;
- MaybeGroundTermMode = no,
- (
- TermVarInst = free,
- SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo0),
- SubGoalExpr0 = conj(plain_conj, SubGoalConjuncts0)
- ->
- % We reverse the list here for the same reason
- % modecheck_specializable_ground_term does in the
- % corresponding case.
- list.reverse(SubGoalConjuncts0, SubGoalConjuncts1),
- SubGoalExpr1 = conj(plain_conj, SubGoalConjuncts1),
- SubGoal1 = hlds_goal(SubGoalExpr1, SubGoalInfo0)
- ;
- SubGoal1 = SubGoal0
- ),
- Kind = from_ground_term_other
- ),
- ( goal_info_has_feature(GoalInfo0, feature_from_head) ->
- attach_features_to_all_goals([feature_from_head],
- attach_in_from_ground_term, SubGoal1, SubGoal2)
- ;
- SubGoal2 = SubGoal1
- ),
- mode_checkpoint(enter, "scope", !ModeInfo),
- modecheck_goal(SubGoal2, SubGoal, !ModeInfo),
- mode_checkpoint(exit, "scope", !ModeInfo)
- ).
-
-:- type ground_term_mode
- ---> construct_ground_term(list(hlds_goal))
- ; deconstruct_ground_term(list(hlds_goal)).
-
-:- pred modecheck_specializable_ground_term(hlds_goal::in, prog_var::in,
- mer_inst::in, maybe(ground_term_mode)::out) is det.
-
-modecheck_specializable_ground_term(SubGoal, TermVar, TermVarInst,
- MaybeGroundTermMode) :-
- SubGoal = hlds_goal(SubGoalExpr, SubGoalInfo),
- (
- NonLocals = goal_info_get_nonlocals(SubGoalInfo),
- set.singleton_set(NonLocals, TermVar),
- goal_info_get_purity(SubGoalInfo) = purity_pure,
- SubGoalExpr = conj(plain_conj, [UnifyTermGoal | UnifyArgGoals]),
- % If TermVar is created by an impure unification, which is
- % possible for solver types, it is possible for UnifyTermGoal
- % to contain a unification other than one involving TermVar.
- UnifyTermGoal ^ hlds_goal_expr = unify(TermVar, _, _, _, _),
- all_plain_construct_unifies([UnifyTermGoal | UnifyArgGoals])
- ->
- ( TermVarInst = free ->
- % UnifyTerm unifies TermVar with the arguments created
- % by UnifyArgs. Since TermVar is now free and the
- % argument variables haven't been encountered yet,
- % UnifyTerm cannot succeed until *after* the argument
- % variables become ground.
- %
- % Putting UnifyTerm after UnifyArgs here is much more efficient
- % than letting the usual more ordering algorithm delay it
- % repeatedly: it is linear instead of quadratic.
-
- list.reverse([UnifyTermGoal | UnifyArgGoals], RevConj),
- MaybeGroundTermMode = yes(construct_ground_term(RevConj))
- ; TermVarInst = ground(shared, none) ->
- Conj = [UnifyTermGoal | UnifyArgGoals],
- MaybeGroundTermMode = yes(deconstruct_ground_term(Conj))
- ;
- MaybeGroundTermMode = no
- )
- ;
- MaybeGroundTermMode = no
- ).
-
-:- pred all_plain_construct_unifies(list(hlds_goal)::in) is semidet.
-
-all_plain_construct_unifies([]).
-all_plain_construct_unifies([Goal | Goals]) :-
- Goal = hlds_goal(GoalExpr, _),
- GoalExpr = unify(_LHSVar, RHS, _, _, _),
- RHS = rhs_functor(_ConsId, no, _RHSVars),
- all_plain_construct_unifies(Goals).
-
-:- pred modecheck_ground_term_construct(prog_var::in, list(hlds_goal)::in,
- hlds_goal_info::in, prog_varset::in, hlds_goal::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_ground_term_construct(TermVar, ConjGoals0, !.SubGoalInfo, VarSet,
- SubGoal, !ModeInfo) :-
- map.init(LocalVarMap0),
- modecheck_ground_term_construct_goal_loop(VarSet, ConjGoals0, ConjGoals,
- LocalVarMap0, LocalVarMap),
- map.lookup(LocalVarMap, TermVar, TermVarInfo),
- TermVarInfo = construct_var_info(TermVarInst),
- InstMapDelta = instmap_delta_from_assoc_list([TermVar - TermVarInst]),
- goal_info_set_instmap_delta(InstMapDelta, !SubGoalInfo),
- % We present the determinism, so that the determinism analysis pass
- % does not have to traverse the goals inside the scope.
- goal_info_set_determinism(detism_det, !SubGoalInfo),
- SubGoalExpr = conj(plain_conj, ConjGoals),
- SubGoal = hlds_goal(SubGoalExpr, !.SubGoalInfo),
-
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- instmap_set_var(TermVar, TermVarInst, InstMap0, InstMap),
- mode_info_set_instmap(InstMap, !ModeInfo).
-
-:- type construct_var_info
- ---> construct_var_info(mer_inst).
-
-:- type construct_var_info_map == map(prog_var, construct_var_info).
-
-:- pred modecheck_ground_term_construct_goal_loop(prog_varset::in,
- list(hlds_goal)::in, list(hlds_goal)::out,
- construct_var_info_map::in, construct_var_info_map::out) is det.
-
-modecheck_ground_term_construct_goal_loop(_, [], [], !LocalVarMap).
-modecheck_ground_term_construct_goal_loop(VarSet,
- [Goal0 | Goals0], [Goal | Goals], !LocalVarMap) :-
- Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
- (
- GoalExpr0 = unify(LHSVar, RHS, _, _, UnifyContext),
- RHS = rhs_functor(ConsId, no, RHSVars)
- ->
- % We could set TermInst to simply to ground, as opposed to the inst
- % we now use which gives information about LHSVar's shape. This would
- % remove the need for the inst information in !LocalVarMap, and
- % would make HLDS dumps linear in the size of the term instead of
- % quadratic. However, due to structure sharing, the actual memory
- % requirements of these bound insts are only linear in the size of the
- % term.
- modecheck_ground_term_construct_arg_loop(RHSVars, ArgInsts, UniModes,
- !LocalVarMap),
- BoundInst = bound_functor(ConsId, ArgInsts),
- TermInst = bound(shared, [BoundInst]),
- LHSMode = (free -> TermInst),
- RHSMode = (TermInst -> TermInst),
- UnifyMode = LHSMode - RHSMode,
- ConstructHow = construct_statically,
- Uniqueness = cell_is_shared,
- Unification = construct(LHSVar, ConsId, RHSVars, UniModes,
- ConstructHow, Uniqueness, no_construct_sub_info),
- GoalExpr = unify(LHSVar, RHS, UnifyMode, Unification, UnifyContext),
- InstMapDelta = instmap_delta_from_assoc_list([LHSVar - TermInst]),
- goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo1),
- % We preset the determinism, so that the determinism analysis pass
- % does not have to traverse the goals inside the scope.
- goal_info_set_determinism(detism_det, GoalInfo1, GoalInfo),
- Goal = hlds_goal(GoalExpr, GoalInfo),
-
- LHSVarInfo = construct_var_info(TermInst),
- svmap.det_insert(LHSVar, LHSVarInfo, !LocalVarMap)
- ;
- unexpected(this_file,
- "modecheck_ground_term_construct_goal_loop: not rhs_functor unify")
- ),
- modecheck_ground_term_construct_goal_loop(VarSet, Goals0, Goals,
- !LocalVarMap).
-
-:- pred modecheck_ground_term_construct_arg_loop(list(prog_var)::in,
- list(mer_inst)::out, list(uni_mode)::out,
- construct_var_info_map::in, construct_var_info_map::out) is det.
-
-modecheck_ground_term_construct_arg_loop([], [], [], !LocalVarMap).
-modecheck_ground_term_construct_arg_loop([Var | Vars], [VarInst | VarInsts],
- [UniMode | UniModes], !LocalVarMap) :-
- % Each variable introduced by the superhomogeneous transformation
- % for a ground term appears in the from_ground_term scope exactly twice.
- % Once when it is produced (which is handled in the goal loop predicate),
- % and once when it is consumed, which is handled here.
- %
- % Since there will be no more appearances of this variable, we remove it
- % from LocalVarMap. This greatly reduces the size of LocalVarMap.
- svmap.det_remove(Var, VarInfo, !LocalVarMap),
- VarInfo = construct_var_info(VarInst),
- LHSOldInst = free,
- RHSOldInst = VarInst,
- LHSNewInst = VarInst,
- RHSNewInst = VarInst,
- UniMode = ((LHSOldInst - RHSOldInst) -> (LHSNewInst - RHSNewInst)),
- modecheck_ground_term_construct_arg_loop(Vars, VarInsts, UniModes,
- !LocalVarMap).
-
-:- pred modecheck_goal_plain_call(pred_id::in, proc_id::in,
- list(prog_var)::in, maybe(call_unify_context)::in, sym_name::in,
- hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_goal_plain_call(PredId, ProcId0, Args0, MaybeCallUnifyContext,
- PredName, GoalInfo0, GoalExpr, !ModeInfo) :-
- PredNameString = sym_name_to_string(PredName),
- CallString = "call " ++ PredNameString,
- mode_checkpoint(enter, CallString, !ModeInfo),
-
- mode_info_get_call_id(!.ModeInfo, PredId, CallId),
- mode_info_set_call_context(call_context_call(plain_call_id(CallId)),
- !ModeInfo),
-
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- DeterminismKnown = no,
- modecheck_call_pred(PredId, DeterminismKnown, ProcId0, ProcId,
- Args0, Args, GoalInfo0, ExtraGoals, !ModeInfo),
-
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- mode_info_get_pred_id(!.ModeInfo, CallerPredId),
- Builtin = builtin_state(ModuleInfo, CallerPredId, PredId, ProcId),
- Call = plain_call(PredId, ProcId, Args, Builtin, MaybeCallUnifyContext,
- PredName),
- handle_extra_goals(Call, ExtraGoals, GoalInfo0, Args0, Args,
- InstMap0, GoalExpr, !ModeInfo),
-
- mode_info_unset_call_context(!ModeInfo),
- mode_checkpoint(exit, CallString, !ModeInfo).
-
-:- pred modecheck_goal_generic_call(generic_call::in, list(prog_var)::in,
- list(mer_mode)::in, hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_goal_generic_call(GenericCall, Args0, Modes0, GoalInfo0, GoalExpr,
- !ModeInfo) :-
- mode_checkpoint(enter, "generic_call", !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMap0),
-
- hlds_goal.generic_call_id(GenericCall, CallId),
- mode_info_set_call_context(call_context_call(CallId), !ModeInfo),
- (
- GenericCall = higher_order(PredVar, _, PredOrFunc, _),
- modecheck_higher_order_call(PredOrFunc, PredVar,
- Args0, Args, Modes, Det, ExtraGoals, !ModeInfo),
- GoalExpr1 = generic_call(GenericCall, Args, Modes, Det),
- AllArgs0 = [PredVar | Args0],
- AllArgs = [PredVar | Args],
- handle_extra_goals(GoalExpr1, ExtraGoals, GoalInfo0, AllArgs0, AllArgs,
- InstMap0, GoalExpr, !ModeInfo)
- ;
- % Class method calls are added by polymorphism.m.
- % XXX We should probably fill this in so that
- % rerunning mode analysis works on code with typeclasses.
- GenericCall = class_method(_, _, _, _),
- unexpected(this_file, "modecheck_goal_expr: class_method_call")
- ;
- GenericCall = event_call(EventName),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- module_info_get_event_set(ModuleInfo, EventSet),
- EventSpecMap = EventSet ^ event_set_spec_map,
- ( event_arg_modes(EventSpecMap, EventName, ModesPrime) ->
- Modes = ModesPrime
- ;
- % The typechecker should have caught the unknown event,
- % and not let compilation of this predicate proceed any further.
- unexpected(this_file, "modecheck_goal_expr: unknown event")
- ),
- modecheck_event_call(Modes, Args0, Args, !ModeInfo),
- GoalExpr = generic_call(GenericCall, Args, Modes, detism_det)
- ;
- GenericCall = cast(_CastType),
- (
- goal_info_has_feature(GoalInfo0, feature_keep_constant_binding),
- mode_info_get_instmap(!.ModeInfo, InstMap),
- (
- Args0 = [Arg1Prime, _Arg2Prime],
- Modes0 = [Mode1Prime, Mode2Prime]
- ->
- Arg1 = Arg1Prime,
- Mode1 = Mode1Prime,
- Mode2 = Mode2Prime
- ;
- unexpected(this_file, "modecheck_goal_expr: bad cast")
- ),
- Mode1 = in_mode,
- Mode2 = out_mode,
- instmap_lookup_var(InstMap, Arg1, Inst1),
- Inst1 = bound(Unique, [bound_functor(ConsId, [])]),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- module_info_get_type_table(ModuleInfo, TypeTable),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- map.lookup(VarTypes, Arg1, ArgType1),
- type_to_ctor_and_args(ArgType1, ArgTypeCtor1, _),
- lookup_type_ctor_defn(TypeTable, ArgTypeCtor1, CtorDefn),
- get_type_defn_body(CtorDefn, Body),
- ConsTagValues = Body ^ du_type_cons_tag_values,
- map.lookup(ConsTagValues, ConsId, ConsTag),
- ConsTag = shared_local_tag(_, LocalTag)
- ->
- BoundInst = bound_functor(int_const(LocalTag), []),
- NewMode2 = (free -> bound(Unique, [BoundInst])),
- Modes = [Mode1, NewMode2]
- ;
- Modes = Modes0
- ),
- modecheck_builtin_cast(Modes, Args0, Args, Det, ExtraGoals, !ModeInfo),
- GoalExpr1 = generic_call(GenericCall, Args, Modes, Det),
- handle_extra_goals(GoalExpr1, ExtraGoals, GoalInfo0, Args0, Args,
- InstMap0, GoalExpr, !ModeInfo)
- ),
-
- mode_info_unset_call_context(!ModeInfo),
- mode_checkpoint(exit, "generic_call", !ModeInfo).
-
-:- pred modecheck_goal_unify(prog_var::in, unify_rhs::in,
- unification::in, unify_context::in, hlds_goal_info::in,
- hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
-
-modecheck_goal_unify(LHS0, RHS0, Unification0, UnifyContext, GoalInfo0,
- GoalExpr, !ModeInfo) :-
- mode_checkpoint(enter, "unify", !ModeInfo),
- mode_info_set_call_context(call_context_unify(UnifyContext), !ModeInfo),
- modecheck_unification(LHS0, RHS0, Unification0, UnifyContext, GoalInfo0,
- GoalExpr, !ModeInfo),
- mode_info_unset_call_context(!ModeInfo),
- mode_checkpoint(exit, "unify", !ModeInfo).
-
-:- pred modecheck_goal_call_foreign_proc(pragma_foreign_proc_attributes::in,
- pred_id::in, proc_id::in, list(foreign_arg)::in, list(foreign_arg)::in,
- maybe(trace_expr(trace_runtime))::in, pragma_foreign_code_impl::in,
- hlds_goal_info::in, hlds_goal_expr::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_goal_call_foreign_proc(Attributes, PredId, ProcId0, Args0, ExtraArgs,
- MaybeTraceRuntimeCond, PragmaCode, GoalInfo0, GoalExpr, !ModeInfo) :-
- % To modecheck a foreign_proc, we just modecheck the proc for
- % which it is the goal.
-
- mode_checkpoint(enter, "pragma_foreign_code", !ModeInfo),
- mode_info_get_call_id(!.ModeInfo, PredId, CallId),
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- DeterminismKnown = no,
- mode_info_set_call_context(call_context_call(plain_call_id(CallId)),
- !ModeInfo),
- ArgVars0 = list.map(foreign_arg_var, Args0),
- modecheck_call_pred(PredId, DeterminismKnown, ProcId0, ProcId,
- ArgVars0, ArgVars, GoalInfo0, ExtraGoals, !ModeInfo),
-
- % zs: The assignment to Pragma looks wrong: instead of Args0,
- % I think we should use Args after the following call:
- % replace_foreign_arg_vars(Args0, ArgVars, Args)
- % or is there some reason why Args0 and Args would be the same?
- Pragma = call_foreign_proc(Attributes, PredId, ProcId, Args0, ExtraArgs,
- MaybeTraceRuntimeCond, PragmaCode),
- handle_extra_goals(Pragma, ExtraGoals, GoalInfo0, ArgVars0, ArgVars,
- InstMap0, GoalExpr, !ModeInfo),
-
- mode_info_unset_call_context(!ModeInfo),
- mode_checkpoint(exit, "pragma_foreign_code", !ModeInfo).
-
-:- pred modecheck_goal_shorthand(shorthand_goal_expr::in, hlds_goal_info::in,
- hlds_goal_expr::out, mode_info::in, mode_info::out) is det.
-
-modecheck_goal_shorthand(ShortHand0, GoalInfo0, GoalExpr, !ModeInfo) :-
- (
- ShortHand0 = atomic_goal(_, Outer, Inner, MaybeOutputVars,
- MainGoal0, OrElseGoals0, OrElseInners),
-
- % The uniqueness of the Outer and Inner variables are handled by the
- % addition of calls to the fake predicates "stm_inner_to_outer_io" and
- % "stm_outer_to_inner_io" during the construction of the HLDS.
- % These calls are removed when atomic goals are expanded.
-
- mode_checkpoint(enter, "atomic", !ModeInfo),
- AtomicGoalList0 = [MainGoal0 | OrElseGoals0],
- NonLocals = goal_info_get_nonlocals(GoalInfo0),
-
- % XXX STM: Locking the outer variables would generate an error message
- % during mode analysis of the sub goal because of the calls to
- % "stm_outer_to_inner_io" and "stm_inner_to_outer_io". I (lmika) don't
- % think this is a problem as the uniqueness states of the outer and
- % inner variables are enforced by these calls anyway.
-
- % mode_info_lock_vars(var_lock_atomic_goal, OuterVars, !ModeInfo),
- modecheck_orelse_list(AtomicGoalList0, AtomicGoalList1, InstMapList0,
- !ModeInfo),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- % mode_info_unlock_vars(var_lock_atomic_goal, OuterVars, !ModeInfo),
-
- % XXX STM: Handling of solver vars
- handle_solver_vars_in_disjs(set.to_sorted_list(NonLocals),
- VarTypes, AtomicGoalList1, AtomicGoalList, InstMapList0,
- InstMapList, !ModeInfo),
- MainGoal = list.det_head(AtomicGoalList),
- OrElseGoals = list.det_tail(AtomicGoalList),
-
- instmap_merge(NonLocals, InstMapList, merge_stm_atomic, !ModeInfo),
-
- % Here we determine the type of atomic goal this is. It could be argued
- % that this should have been done in the typechecker, but the type of
- % the outer variables could be unknown when the typechecker looks
- % at the atomic goal.
- %
- % To prevent the need to traverse the code again, we will put this
- % check here (also: types of variables must be known at this point).
-
- Outer = atomic_interface_vars(OuterDI, OuterUO),
- map.lookup(VarTypes, OuterDI, OuterDIType),
- map.lookup(VarTypes, OuterUO, OuterUOType),
- (
- ( OuterDIType = io_state_type
- ; OuterDIType = io_io_type
- )
- ->
- GoalType = top_level_atomic_goal
- ;
- OuterDIType = stm_atomic_type
- ->
- GoalType = nested_atomic_goal
- ;
- unexpected(this_file,
- "modecheck_goal_shorthand atomic_goal: Invalid outer var type")
- ),
-
- % The following are sanity checks.
- expect(unify(OuterDIType, OuterUOType), this_file,
- "modecheck_goal_shorthand atomic_goal: mismatched outer var type"),
- Inner = atomic_interface_vars(InnerDI, InnerUO),
- map.lookup(VarTypes, InnerDI, InnerDIType),
- map.lookup(VarTypes, InnerUO, InnerUOType),
- expect(unify(InnerDIType, stm_atomic_type), this_file,
- "modecheck_goal_shorthand atomic_goal: Invalid inner var type"),
- expect(unify(InnerUOType, stm_atomic_type), this_file,
- "modecheck_goal_shorthand atomic_goal: Invalid inner var type"),
-
- ShortHand = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars,
- MainGoal, OrElseGoals, OrElseInners),
- GoalExpr = shorthand(ShortHand),
- mode_checkpoint(exit, "atomic", !ModeInfo)
- ;
- ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0),
- mode_checkpoint(enter, "try", !ModeInfo),
- modecheck_goal(SubGoal0, SubGoal, !ModeInfo),
- ShortHand = try_goal(MaybeIO, ResultVar, SubGoal),
- GoalExpr = shorthand(ShortHand),
- mode_checkpoint(exit, "try", !ModeInfo)
- ;
- ShortHand0 = bi_implication(_, _),
- % These should have been expanded out by now.
- unexpected(this_file, "modecheck_goal_shorthand: bi_implication")
- ).
-
-:- pred modecheck_orelse_list(list(hlds_goal)::in, list(hlds_goal)::out,
- list(instmap)::out, mode_info::in, mode_info::out) is det.
-
-modecheck_orelse_list([], [], [], !ModeInfo).
-modecheck_orelse_list([Goal0 | Goals0], [Goal | Goals], [InstMap | InstMaps],
- !ModeInfo) :-
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- modecheck_goal(Goal0, Goal, !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMap),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- modecheck_orelse_list(Goals0, Goals, InstMaps, !ModeInfo).
-
- % If the condition of a negation or if-then-else contains any inst any
- % non-locals (a potential referential transparency violation), then
- % we need to check that the programmer has recognised the possibility
- % and placed the if-then-else in a promise_<purity> scope.
- %
-:- pred check_no_inst_any_vars(negated_context_desc::in, prog_vars::in,
- instmap::in, instmap::in, mode_info::in, mode_info::out) is det.
-
-check_no_inst_any_vars(_, [], _, _, !ModeInfo).
-check_no_inst_any_vars(NegCtxtDesc, [NonLocal | NonLocals], InstMap0, InstMap,
- !ModeInfo) :-
- (
- ( instmap_lookup_var(InstMap0, NonLocal, Inst)
- ; instmap_lookup_var(InstMap, NonLocal, Inst)
- ),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- inst_contains_any(ModuleInfo, Inst)
- ->
- ModeError = purity_error_should_be_in_promise_purity_scope(NegCtxtDesc,
- NonLocal),
- mode_info_error(make_singleton_set(NonLocal), ModeError, !ModeInfo)
- ;
- check_no_inst_any_vars(NegCtxtDesc, NonLocals, InstMap0, InstMap,
- !ModeInfo)
- ).
-
-append_extra_goals(no_extra_goals, ExtraGoals, ExtraGoals).
-append_extra_goals(extra_goals(BeforeGoals, AfterGoals),
- no_extra_goals, extra_goals(BeforeGoals, AfterGoals)).
-append_extra_goals(extra_goals(BeforeGoals0, AfterGoals0),
- extra_goals(BeforeGoals1, AfterGoals1),
- extra_goals(BeforeGoals, AfterGoals)) :-
- BeforeGoals = BeforeGoals0 ++ BeforeGoals1,
- AfterGoals = AfterGoals0 ++ AfterGoals1.
-
-handle_extra_goals(MainGoal, no_extra_goals, _GoalInfo0, _Args0, _Args,
- _InstMap0, MainGoal, !ModeInfo).
-handle_extra_goals(MainGoal, extra_goals(BeforeGoals0, AfterGoals0),
- GoalInfo0, Args0, Args, InstMap0, Goal, !ModeInfo) :-
- mode_info_get_errors(!.ModeInfo, Errors),
- (
- % There's no point adding extra goals if the code is
- % unreachable anyway.
- instmap_is_reachable(InstMap0),
-
- % If we recorded errors processing the goal, it will have to be
- % reprocessed anyway, so don't add the extra goals now.
- Errors = []
- ->
- % We need to be careful to update the delta-instmaps
- % correctly, using the appropriate instmaps:
- %
- % % InstMapAtStart is here
- % BeforeGoals,
- % % we don't know the instmap here,
- % % but as it happens we don't need it
- % main goal,
- % % InstMapAfterMain is here
- % AfterGoals
- % % InstMapAtEnd (from the ModeInfo) is here
-
- % Recompute the new set of non-local variables for the main goal.
- NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
- set.list_to_set(Args0, OldArgVars),
- set.list_to_set(Args, NewArgVars),
- set.difference(NewArgVars, OldArgVars, IntroducedVars),
- set.union(NonLocals0, IntroducedVars, OutsideVars),
- set.intersect(OutsideVars, NewArgVars, NonLocals),
- goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
-
- % Combine the main goal and the extra goals into a conjunction.
- Goal0 = hlds_goal(MainGoal, GoalInfo),
- Context = goal_info_get_context(GoalInfo0),
- handle_extra_goals_contexts(BeforeGoals0, Context, BeforeGoals),
- handle_extra_goals_contexts(AfterGoals0, Context, AfterGoals),
- GoalList0 = BeforeGoals ++ [Goal0 | AfterGoals],
-
- mode_info_get_may_change_called_proc(!.ModeInfo, MayChangeCalledProc0),
-
- % Make sure we don't go into an infinite loop if
- % there is a bug in the code to add extra goals.
- mode_info_set_checking_extra_goals(yes, !ModeInfo),
-
- % We've already worked out which procedure should be called,
- % we don't need to do it again.
- mode_info_set_may_change_called_proc(may_not_change_called_proc,
- !ModeInfo),
-
- mode_info_set_instmap(InstMap0, !ModeInfo),
-
- % Recheck the goals to compute the instmap_deltas.
- %
- % This can fail even if the original check on the goal
- % succeeded in the case of a unification procedure which
- % binds a partially instantiated variable, because adding
- % the extra goals can make the partially instantiated
- % variables `live' after the main goal.
- % The other thing to beware of in this case is that delaying
- % must be disabled while processing the extra goals. If it
- % is not, the main unification will be delayed until after the
- % argument unifications, which turns them into assignments,
- % and we end up repeating the process forever.
- mode_info_add_goals_live_vars(plain_conj, GoalList0, !ModeInfo),
- modecheck_conj_list_no_delay(GoalList0, GoalList, !ModeInfo),
- Goal = conj(plain_conj, GoalList),
- mode_info_set_checking_extra_goals(no, !ModeInfo),
- mode_info_set_may_change_called_proc(MayChangeCalledProc0, !ModeInfo)
- ;
- Goal = MainGoal
- ).
-
-:- pred handle_extra_goals_contexts(list(hlds_goal)::in, prog_context::in,
- list(hlds_goal)::out) is det.
-
-handle_extra_goals_contexts([], _Context, []).
-handle_extra_goals_contexts([Goal0 | Goals0], Context, [Goal | Goals]) :-
- Goal0 = hlds_goal(GoalExpr, GoalInfo0),
- goal_info_set_context(Context, GoalInfo0, GoalInfo),
- Goal = hlds_goal(GoalExpr, GoalInfo),
- handle_extra_goals_contexts(Goals0, Context, Goals).
-
-%-----------------------------------------------------------------------------%
-
- % Ensure that any non-local solver var that is initialised in
- % one disjunct is initialised in all disjuncts.
- %
-:- pred handle_solver_vars_in_disjs(list(prog_var)::in,
- vartypes::in, list(hlds_goal)::in, list(hlds_goal)::out,
- list(instmap)::in, list(instmap)::out, mode_info::in, mode_info::out)
- is det.
-
-handle_solver_vars_in_disjs(NonLocals, VarTypes, Disjs0, Disjs,
- InstMaps0, InstMaps, !ModeInfo) :-
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- EnsureInitialised = solver_vars_that_must_be_initialised(NonLocals,
- VarTypes, ModuleInfo, InstMaps0),
- add_necessary_disj_init_calls(Disjs0, Disjs, InstMaps0, InstMaps,
- EnsureInitialised, !ModeInfo).
-
-:- pred handle_solver_vars_in_ite(list(prog_var)::in, vartypes::in,
- hlds_goal::in, hlds_goal::out, hlds_goal::in, hlds_goal::out,
- instmap::in, instmap::out, instmap::in, instmap::out, mode_info::in,
- mode_info::out) is det.
-
-handle_solver_vars_in_ite(NonLocals, VarTypes, Then0, Then, Else0, Else,
- ThenInstMap0, ThenInstMap, ElseInstMap0, ElseInstMap, !ModeInfo) :-
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- EnsureInitialised = solver_vars_that_must_be_initialised(NonLocals,
- VarTypes, ModuleInfo, [ThenInstMap0, ElseInstMap0]),
-
- ThenVarsToInit = solver_vars_to_init(EnsureInitialised, ModuleInfo,
- ThenInstMap0),
- construct_initialisation_calls(ThenVarsToInit, ThenInitCalls, !ModeInfo),
- InitedThenVars = list_to_set(ThenVarsToInit),
- Then = append_init_calls_to_goal(InitedThenVars, ThenInitCalls, Then0),
- instmap_set_vars_same(any_inst, ThenVarsToInit, ThenInstMap0, ThenInstMap),
-
- ElseVarsToInit = solver_vars_to_init(EnsureInitialised, ModuleInfo,
- ElseInstMap0),
- construct_initialisation_calls(ElseVarsToInit, ElseInitCalls, !ModeInfo),
- InitedElseVars = list_to_set(ElseVarsToInit),
- Else = append_init_calls_to_goal(InitedElseVars, ElseInitCalls, Else0),
- instmap_set_vars_same(any_inst, ElseVarsToInit, ElseInstMap0, ElseInstMap).
-
-:- func solver_vars_that_must_be_initialised(list(prog_var),
- vartypes, module_info, list(instmap)) = list(prog_var).
-
-solver_vars_that_must_be_initialised(Vars, VarTypes, ModuleInfo, InstMaps) =
- list.filter(
- solver_var_must_be_initialised(VarTypes, ModuleInfo, InstMaps),
- Vars).
-
-:- pred solver_var_must_be_initialised(vartypes::in, module_info::in,
- list(instmap)::in, prog_var::in) is semidet.
-
-solver_var_must_be_initialised(VarTypes, ModuleInfo, InstMaps, Var) :-
- map.lookup(VarTypes, Var, VarType),
- type_is_solver_type_with_auto_init(ModuleInfo, VarType),
- list.member(InstMap, InstMaps),
- instmap_lookup_var(InstMap, Var, Inst),
- not inst_match.inst_is_free(ModuleInfo, Inst).
-
-:- pred is_solver_var(vartypes::in, module_info::in, prog_var::in) is semidet.
-
-is_solver_var(VarTypes, ModuleInfo, Var) :-
- map.lookup(VarTypes, Var, VarType),
- type_is_solver_type(ModuleInfo, VarType).
-
-:- pred add_necessary_disj_init_calls(list(hlds_goal)::in,
- list(hlds_goal)::out, list(instmap)::in, list(instmap)::out,
- list(prog_var)::in, mode_info::in, mode_info::out) is det.
-
-add_necessary_disj_init_calls([], [], [], [], _EnsureInitialised, !ModeInfo).
-add_necessary_disj_init_calls([], _, [_ | _], _, _, _, _) :-
- unexpected(this_file, "add_necessary_init_calls: mismatched lists").
-add_necessary_disj_init_calls([_ | _], _, [], _, _, _, _) :-
- unexpected(this_file, "add_necessary_init_calls: mismatched lists").
-add_necessary_disj_init_calls([Goal0 | Goals0], [Goal | Goals],
- [InstMap0 | InstMaps0], [InstMap | InstMaps],
- EnsureInitialised, !ModeInfo) :-
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- VarsToInit = solver_vars_to_init(EnsureInitialised, ModuleInfo, InstMap0),
- construct_initialisation_calls(VarsToInit, InitCalls, !ModeInfo),
- InitedVars = list_to_set(VarsToInit),
- Goal = append_init_calls_to_goal(InitedVars, InitCalls, Goal0),
- instmap_set_vars_same(any_inst, VarsToInit, InstMap0, InstMap),
- add_necessary_disj_init_calls(Goals0, Goals, InstMaps0, InstMaps,
- EnsureInitialised, !ModeInfo).
-
-:- func append_init_calls_to_goal(set(prog_var), list(hlds_goal), hlds_goal) =
- hlds_goal.
-
-append_init_calls_to_goal(InitedVars, InitCalls, Goal0) = Goal :-
- Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
- NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
- NonLocals = set.union(InitedVars, NonLocals0),
- goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
- ( GoalExpr0 = disj(Disjs0) ->
- Disjs = list.map(append_init_calls_to_goal(InitedVars, InitCalls),
- Disjs0),
- Goal = hlds_goal(disj(Disjs), GoalInfo)
- ;
- goal_to_conj_list(Goal0, Conjs),
- conj_list_to_goal(Conjs ++ InitCalls, GoalInfo, Goal)
- ).
-
-:- func flatten_disjs(list(hlds_goal)) = list(hlds_goal).
-
-flatten_disjs(Disjs) = list.foldr(flatten_disj, Disjs, []).
-
-:- func flatten_disj(hlds_goal, list(hlds_goal)) = list(hlds_goal).
-
-flatten_disj(Disj, Disjs0) = Disjs :-
- ( Disj = hlds_goal(disj(Disjs1), _GoalInfo) ->
- Disjs = list.foldr(flatten_disj, Disjs1, Disjs0)
- ;
- Disjs = [Disj | Disjs0]
- ).
-
-:- func solver_vars_to_init(list(prog_var), module_info, instmap) =
- list(prog_var).
-
-solver_vars_to_init(Vars, ModuleInfo, InstMap) =
- list.filter(solver_var_to_init(ModuleInfo, InstMap), Vars).
-
-:- pred solver_var_to_init(module_info::in, instmap::in, prog_var::in)
- is semidet.
-
-solver_var_to_init(ModuleInfo, InstMap, Var) :-
- instmap_lookup_var(InstMap, Var, Inst),
- inst_match.inst_is_free(ModuleInfo, Inst).
-
-%-----------------------------------------------------------------------------%
-
- % Modecheck a conjunction without doing any reordering.
- % This is used by handle_extra_goals above.
- %
-:- pred modecheck_conj_list_no_delay(list(hlds_goal)::in, list(hlds_goal)::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_conj_list_no_delay([], [], !ModeInfo).
-modecheck_conj_list_no_delay([Goal0 | Goals0], [Goal | Goals], !ModeInfo) :-
- NonLocals = goal_get_nonlocals(Goal0),
- mode_info_remove_live_vars(NonLocals, !ModeInfo),
- modecheck_goal(Goal0, Goal, !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMap),
- ( instmap_is_unreachable(InstMap) ->
- % We should not mode-analyse the remaining goals, since they
- % are unreachable. Instead we optimize them away, so that
- % later passes won't complain about them not having mode information.
- mode_info_remove_goals_live_vars(Goals0, !ModeInfo),
- Goals = []
- ;
- modecheck_conj_list_no_delay(Goals0, Goals, !ModeInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred modecheck_conj_list(conj_type::in,
- list(hlds_goal)::in, list(hlds_goal)::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_conj_list(ConjType, Goals0, Goals, !ModeInfo) :-
- mode_info_get_errors(!.ModeInfo, OldErrors),
- mode_info_set_errors([], !ModeInfo),
-
- mode_info_get_may_init_solver_vars(!.ModeInfo, OldMayInit),
-
- mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
- delay_info_enter_conj(DelayInfo0, DelayInfo1),
- mode_info_set_delay_info(DelayInfo1, !ModeInfo),
-
- mode_info_get_live_vars(!.ModeInfo, LiveVars1),
- mode_info_add_goals_live_vars(ConjType, Goals0, !ModeInfo),
-
- % Try to schedule goals without inserting any solver initialisation calls
- % by setting the mode_info flag may_initialise_solver_vars to no.
- mode_info_set_may_init_solver_vars(may_not_init_solver_vars, !ModeInfo),
-
- modecheck_conj_list_2(ConjType, Goals0, Goals1,
- [], RevImpurityErrors0, !ModeInfo),
-
- mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
- delay_info_leave_conj(DelayInfo2, DelayedGoals0, DelayInfo3),
- mode_info_set_delay_info(DelayInfo3, !ModeInfo),
-
- % Otherwise try scheduling by inserting solver initialisation calls
- % where necessary (although only if `--solver-type-auto-init' is enabled).
- %
- modecheck_delayed_solver_goals(ConjType, Goals2,
- DelayedGoals0, DelayedGoals, RevImpurityErrors0, RevImpurityErrors,
- !ModeInfo),
- Goals = Goals1 ++ Goals2,
-
- mode_info_get_errors(!.ModeInfo, NewErrors),
- Errors = OldErrors ++ NewErrors,
- mode_info_set_errors(Errors, !ModeInfo),
-
- % We only report impurity errors if there were no other errors.
- (
- DelayedGoals = [],
-
- % Report all the impurity errors
- % (making sure we report the errors in the correct order).
- list.reverse(RevImpurityErrors, ImpurityErrors),
- mode_info_get_errors(!.ModeInfo, Errors5),
- Errors6 = Errors5 ++ ImpurityErrors,
- mode_info_set_errors(Errors6, !ModeInfo)
- ;
- DelayedGoals = [FirstDelayedGoal | MoreDelayedGoals],
- % The variables in the delayed goals should no longer be considered
- % live (the conjunction itself will delay, and its nonlocals will be
- % made live).
- mode_info_set_live_vars(LiveVars1, !ModeInfo),
- (
- MoreDelayedGoals = [],
- FirstDelayedGoal = delayed_goal(_DVars, Error, _DGoal),
- mode_info_add_error(Error, !ModeInfo)
- ;
- MoreDelayedGoals = [_ | _],
- get_all_waiting_vars(DelayedGoals, Vars),
- ModeError = mode_error_conj(DelayedGoals, conj_floundered),
- mode_info_error(Vars, ModeError, !ModeInfo)
- )
- ),
- % Restore the value of the may_initialise_solver_vars flag.
- mode_info_set_may_init_solver_vars(OldMayInit, !ModeInfo).
-
-mode_info_add_goals_live_vars(_ConjType, [], !ModeInfo).
-mode_info_add_goals_live_vars(ConjType, [Goal | Goals], !ModeInfo) :-
- % We add the live vars for the goals in the goal list in reverse order,
- % because this ensures that in the common case (where there is no
- % delaying), when we come to remove the live vars for the first goal
- % they will have been added last and will thus be at the start of the list
- % of live vars sets, which makes them cheaper to remove.
- mode_info_add_goals_live_vars(ConjType, Goals, !ModeInfo),
- (
- % Recurse into conjunctions, in case there are any conjunctions
- % that have not been flattened.
- Goal = hlds_goal(conj(ConjType, ConjGoals), _)
- ->
- mode_info_add_goals_live_vars(ConjType, ConjGoals, !ModeInfo)
- ;
- NonLocals = goal_get_nonlocals(Goal),
- mode_info_add_live_vars(NonLocals, !ModeInfo)
- ).
-
-mode_info_remove_goals_live_vars([], !ModeInfo).
-mode_info_remove_goals_live_vars([Goal | Goals], !ModeInfo) :-
- (
- % Recurse into conjunctions, in case there are any conjunctions
- % that have not been flattened.
- Goal = hlds_goal(conj(plain_conj, ConjGoals), _)
- ->
- mode_info_remove_goals_live_vars(ConjGoals, !ModeInfo)
- ;
- NonLocals = goal_get_nonlocals(Goal),
- mode_info_remove_live_vars(NonLocals, !ModeInfo)
- ),
- mode_info_remove_goals_live_vars(Goals, !ModeInfo).
-
-:- type impurity_errors == list(mode_error_info).
-
- % Flatten conjunctions as we go, as long as they are of the same type.
- % Call modecheck_conj_list_3 to do the actual scheduling.
- %
-:- pred modecheck_conj_list_2(conj_type::in,
- list(hlds_goal)::in, list(hlds_goal)::out,
- impurity_errors::in, impurity_errors::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_conj_list_2(_ConjType, [], [], !ImpurityErrors, !ModeInfo).
-modecheck_conj_list_2(ConjType, [Goal0 | Goals0], Goals, !ImpurityErrors,
- !ModeInfo) :-
- (
- Goal0 = hlds_goal(conj(plain_conj, ConjGoals), _),
- ConjType = plain_conj
- ->
- Goals1 = ConjGoals ++ Goals0,
- modecheck_conj_list_2(ConjType, Goals1, Goals, !ImpurityErrors,
- !ModeInfo)
- ;
- modecheck_conj_list_3(ConjType, Goal0, Goals0, Goals, !ImpurityErrors,
- !ModeInfo)
- ).
-
-:- pred modecheck_conj_list_3(conj_type::in, hlds_goal::in,
- list(hlds_goal)::in, list(hlds_goal)::out,
- impurity_errors::in, impurity_errors::out,
- mode_info::in, mode_info::out) is det.
-
- % Schedule a conjunction. If it is empty, then there is nothing to do.
- % For non-empty conjunctions, we attempt to schedule the first goal
- % in the conjunction. If successful, we wakeup a newly pending goal
- % (if any), and if not, we delay the goal. Then we continue attempting
- % to schedule all the rest of the goals.
- %
-modecheck_conj_list_3(ConjType, Goal0, Goals0, Goals, !ImpurityErrors,
- !ModeInfo) :-
- Purity = goal_get_purity(Goal0),
- (
- Purity = purity_impure,
- Impure = yes,
- check_for_impurity_error(Goal0, ScheduledSolverGoals,
- !ImpurityErrors, !ModeInfo)
- ;
- ( Purity = purity_pure
- ; Purity = purity_semipure
- ),
- Impure = no,
- ScheduledSolverGoals = []
- ),
-
- % Hang onto the original instmap, delay_info, and live_vars.
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
-
- % Modecheck the goal, noting first that the non-locals
- % which occur in the goal might not be live anymore.
- NonLocalVars = goal_get_nonlocals(Goal0),
- mode_info_remove_live_vars(NonLocalVars, !ModeInfo),
- modecheck_goal(Goal0, Goal, !ModeInfo),
-
- % Now see whether the goal was successfully scheduled. If we didn't manage
- % to schedule the goal, then we restore the original instmap, delay_info
- % and livevars here, and delay the goal.
- mode_info_get_errors(!.ModeInfo, Errors),
- (
- Errors = [FirstErrorInfo | _],
- mode_info_set_errors([], !ModeInfo),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- mode_info_add_live_vars(NonLocalVars, !ModeInfo),
- delay_info_delay_goal(FirstErrorInfo, Goal0, DelayInfo0, DelayInfo1),
- % Delaying an impure goal is an impurity error.
- (
- Impure = yes,
- FirstErrorInfo = mode_error_info(Vars, _, _, _),
- ImpureError = mode_error_conj(
- [delayed_goal(Vars, FirstErrorInfo, Goal0)],
- goal_itself_was_impure),
- mode_info_get_context(!.ModeInfo, Context),
- mode_info_get_mode_context(!.ModeInfo, ModeContext),
- ImpureErrorInfo = mode_error_info(Vars, ImpureError,
- Context, ModeContext),
- !:ImpurityErrors = [ImpureErrorInfo | !.ImpurityErrors]
- ;
- Impure = no
- )
- ;
- Errors = [],
- mode_info_get_delay_info(!.ModeInfo, DelayInfo1)
- ),
-
- % Next, we attempt to wake up any pending goals, and then continue
- % scheduling the rest of the goal.
- delay_info_wakeup_goals(WokenGoals, DelayInfo1, DelayInfo),
- Goals1 = WokenGoals ++ Goals0,
- (
- WokenGoals = []
- ;
- WokenGoals = [_],
- mode_checkpoint(wakeup, "goal", !ModeInfo)
- ;
- WokenGoals = [_, _ | _],
- mode_checkpoint(wakeup, "goals", !ModeInfo)
- ),
- mode_info_set_delay_info(DelayInfo, !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMap),
- ( instmap_is_unreachable(InstMap) ->
- % We should not mode-analyse the remaining goals, since they are
- % unreachable. Instead we optimize them away, so that later passes
- % won't complain about them not having mode information.
- mode_info_remove_goals_live_vars(Goals1, !ModeInfo),
- Goals2 = []
- ;
- % The remaining goals may still need to be flattened.
- modecheck_conj_list_2(ConjType, Goals1, Goals2, !ImpurityErrors,
- !ModeInfo)
- ),
- (
- Errors = [_ | _],
- % We delayed this goal -- it will be stored in the delay_info.
- Goals = ScheduledSolverGoals ++ Goals2
- ;
- Errors = [],
- % We successfully scheduled this goal, so insert it
- % in the list of successfully scheduled goals.
- % We flatten out conjunctions if we can. They can arise
- % when Goal0 was a scope(from_ground_term, _) goal.
- ( Goal = hlds_goal(conj(ConjType, SubGoals), _) ->
- Goals = ScheduledSolverGoals ++ SubGoals ++ Goals2
- ;
- Goals = ScheduledSolverGoals ++ [Goal | Goals2]
- )
- ).
-
- % We may still have some unscheduled goals. This may be because some
- % initialisation calls are needed to turn some solver type vars
- % from inst free to inst any. This predicate attempts to schedule
- % such goals.
- %
- % XXX Despite its name this predicate will in fact try to reschedule all
- % delayed goals, not just delayed solver goals.
- %
-:- pred modecheck_delayed_solver_goals(conj_type::in, list(hlds_goal)::out,
- list(delayed_goal)::in, list(delayed_goal)::out,
- impurity_errors::in, impurity_errors::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_delayed_solver_goals(ConjType, Goals, !DelayedGoals,
- !ImpurityErrors, !ModeInfo) :-
- % Try to handle any unscheduled goals by inserting solver
- % initialisation calls, aiming for a deterministic schedule.
- modecheck_delayed_goals_try_det(ConjType, !DelayedGoals,
- Goals0, !ImpurityErrors, !ModeInfo),
-
- % Try to handle any unscheduled goals by inserting solver
- % initialisation calls, aiming for *any* workable schedule.
- modecheck_delayed_goals_eager(ConjType, !DelayedGoals,
- Goals1, !ImpurityErrors, !ModeInfo),
- Goals = Goals0 ++ Goals1.
-
- % We may still have some unscheduled goals. This may be because some
- % initialisation calls are needed to turn some solver type vars
- % from inst free to inst any. This pass attempts to identify a
- % minimal subset of such vars to initialise that will allow the
- % remaining goals to be scheduled in a deterministic fashion.
- %
- % This works as follows. If a deterministic schedule exists for
- % the remaining goals, then each subgoal must also be deterministic.
- % Moreover, no call may employ an implied mode since these mean
- % introducing a semidet unification. Therefore we only need to
- % consider det procs for calls, constructions for var/functor
- % unifications, and assignments for var/var unifications.
- %
- % If a consistent deterministic schedule exists then every
- % variable involved in the goals either
- % - has already been instantiated;
- % - will be instantiated by a single remaining subgoal;
- % - will not be instantiated by any remaining subgoal.
- % Variables in this last category that are solver type variables
- % should be initialised. If all the variables that will remain
- % uninstantiated are in this last category then, after inserting
- % initialisation call, we should expect another attempt at
- % scheduling the remaining goals to succeed and produce a
- % deterministic result.
- %
- % XXX At some point we should extend this analysis to handle
- % disjunction, if-then-else goals, and negation.
- %
-:- pred modecheck_delayed_goals_try_det(conj_type::in, list(delayed_goal)::in,
- list(delayed_goal)::out, list(hlds_goal)::out,
- impurity_errors::in, impurity_errors::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_delayed_goals_try_det(ConjType, DelayedGoals0, DelayedGoals, Goals,
- !ImpurityErrors, !ModeInfo) :-
- (
- % There are no unscheduled goals, so we don't need to do anything.
-
- DelayedGoals0 = [],
- DelayedGoals = [],
- Goals = []
- ;
- % There are some unscheduled goals. See if allowing extra
- % initialisation calls (for a single goal) makes a difference.
-
- DelayedGoals0 = [_ | _],
- (
- % Extract the HLDS goals from the delayed goals.
- Goals0 = list.map(hlds_goal_from_delayed_goal, DelayedGoals0),
-
- % Work out which vars are already instantiated
- % (i.e. have non-free insts).
- mode_info_get_instmap(!.ModeInfo, InstMap),
- instmap_to_assoc_list(InstMap, VarInsts),
- NonFreeVars0 = set.list_to_set(
- non_free_vars_in_assoc_list(VarInsts)),
-
- % Find the set of vars whose instantiation should lead to
- % a deterministic schedule.
- promise_equivalent_solutions [CandidateInitVars] (
- candidate_init_vars(!.ModeInfo, Goals0, NonFreeVars0,
- CandidateInitVars)
- ),
-
- % And verify that all of these vars are solver type vars
- % (and can therefore be initialised.)
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- all [Var] (
- set.member(Var, CandidateInitVars)
- =>
- (
- map.lookup(VarTypes, Var, VarType),
- type_is_solver_type_with_auto_init(ModuleInfo, VarType)
- )
- ),
- mode_info_solver_init_is_supported(!.ModeInfo)
- ->
- % Construct the inferred initialisation goals
- % and try scheduling again.
- CandidateInitVarList = set.to_sorted_list(CandidateInitVars),
- construct_initialisation_calls(CandidateInitVarList,
- InitGoals, !ModeInfo),
- Goals1 = InitGoals ++ Goals0,
-
- mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
- delay_info_enter_conj(DelayInfo0, DelayInfo1),
- mode_info_set_delay_info(DelayInfo1, !ModeInfo),
-
- mode_info_add_goals_live_vars(ConjType, InitGoals, !ModeInfo),
-
- modecheck_conj_list_2(ConjType, Goals1, Goals, !ImpurityErrors,
- !ModeInfo),
-
- mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
- delay_info_leave_conj(DelayInfo2, DelayedGoals, DelayInfo3),
- mode_info_set_delay_info(DelayInfo3, !ModeInfo)
- ;
- % We couldn't identify a deterministic solution.
- DelayedGoals = DelayedGoals0,
- Goals = []
- )
- ).
-
-construct_initialisation_calls([], [], !ModeInfo).
-construct_initialisation_calls([Var | Vars], [Goal | Goals], !ModeInfo) :-
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- map.lookup(VarTypes, Var, VarType),
- InitialInst = free,
- Context = term.context_init,
- MaybeCallUnifyContext = no,
- construct_initialisation_call(Var, VarType, InitialInst, Context,
- MaybeCallUnifyContext, Goal, !ModeInfo),
- construct_initialisation_calls(Vars, Goals, !ModeInfo).
-
- % XXX will this catch synonyms for `free'?
- % N.B. This is perhaps the only time when `for' and `free'
- % can be juxtaposed grammatically :-)
- %
-:- func non_free_vars_in_assoc_list(assoc_list(prog_var, mer_inst)) =
- list(prog_var).
-
-non_free_vars_in_assoc_list([]) = [].
-non_free_vars_in_assoc_list([Var - Inst | AssocList]) =
- (
- ( Inst = free
- ; Inst = free(_)
- )
- ->
- non_free_vars_in_assoc_list(AssocList)
- ;
- [Var | non_free_vars_in_assoc_list(AssocList)]
- ).
-
- % Find a set of vars that, if they were instantiated, might
- % lead to a deterministic scheduling of the given goals.
- %
- % This approximation is fairly crude: it only considers variables as
- % being free or non-free, rather than having detailed insts.
- %
- % XXX Does not completely handle negation, disjunction, if_then_else
- % goals, foreign_code, or var/lambda unifications.
- %
-:- pred candidate_init_vars(mode_info::in, list(hlds_goal)::in,
- set(prog_var)::in, set(prog_var)::out) is cc_nondet.
-
-candidate_init_vars(ModeInfo, Goals, NonFreeVars0, CandidateVars) :-
- CandidateVars0 = set.init,
- candidate_init_vars_2(ModeInfo, Goals, NonFreeVars0, NonFreeVars1,
- CandidateVars0, CandidateVars1),
- CandidateVars = set.difference(CandidateVars1, NonFreeVars1).
-
-:- pred candidate_init_vars_2(mode_info::in, list(hlds_goal)::in,
- set(prog_var)::in, set(prog_var)::out,
- set(prog_var)::in, set(prog_var)::out) is nondet.
-
-candidate_init_vars_2(ModeInfo, Goals, !NonFree, !CandidateVars) :-
- list.foldl2(candidate_init_vars_3(ModeInfo), Goals,
- !NonFree, !CandidateVars).
-
-:- pred candidate_init_vars_3(mode_info::in, hlds_goal::in,
- set(prog_var)::in, set(prog_var)::out,
- set(prog_var)::in, set(prog_var)::out) is nondet.
-
-candidate_init_vars_3(_ModeInfo, Goal, !NonFree, !CandidateVars) :-
- % A var/var unification.
- Goal = hlds_goal(unify(X, RHS, _, _, _), _),
- RHS = rhs_var(Y),
- ( set.member(X, !.NonFree) ->
- not set.member(Y, !.NonFree),
- % It is an assignment from X to Y.
- !:NonFree = set.insert(!.NonFree, Y)
- ; set.member(Y, !.NonFree) ->
- % It is an assignment from Y to X.
- !:NonFree = set.insert(!.NonFree, X)
- ;
- % It is an assignment one way or the other.
- (
- !:NonFree = set.insert(!.NonFree, X),
- !:CandidateVars = set.insert(!.CandidateVars, Y)
- ;
- !:NonFree = set.insert(!.NonFree, Y),
- !:CandidateVars = set.insert(!.CandidateVars, X)
- )
- ).
-
-candidate_init_vars_3(_ModeInfo, Goal, !NonFree, !CandidateVars) :-
- % A var/functor unification, which can only be deterministic
- % if it is a construction.
- Goal = hlds_goal(unify(X, RHS, _, _, _), _),
- RHS = rhs_functor(_, _, Args),
-
- % If this is a construction then X must be free.
- not set.member(X, !.NonFree),
-
- % But X becomes instantiated.
- !:NonFree = set.insert(!.NonFree, X),
-
- % And the Args are potential candidates for initialisation.
- !:CandidateVars = set.insert_list(!.CandidateVars, Args).
-
-candidate_init_vars_3(_ModeInfo, Goal, !NonFree, !CandidateVars) :-
- % A var/lambda unification, which can only be deterministic if it is
- % a construction.
- %
- Goal = hlds_goal(unify(X, RHS, _, _, _), _),
- RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
-
- % If this is a construction then X must be free.
- not set.member(X, !.NonFree),
-
- % But X becomes instantiated.
- !:NonFree = set.insert(!.NonFree, X).
-
-candidate_init_vars_3(_ModeInfo, Goal, !NonFree, !CandidateVars) :-
- % Disjunctions are tricky, because we don't perform switch analysis
- % until after mode analysis. So here we assume that the disjunction
- % is a det switch and that we can ignore it for the purposes of identifying
- % candidate vars for initialisation.
- Goal = hlds_goal(disj(_Goals), _).
-
-candidate_init_vars_3(ModeInfo, Goal, !NonFree, !CandidateVars) :-
- % We ignore the condition of an if-then-else goal, other than to assume
- % that it binds its non-solver-type non-locals, but proceed on the
- % assumption that the then and else arms are det. This isn't very accurate
- % and may need refinement.
- %
- Goal = hlds_goal(GoalExpr, _),
- GoalExpr = if_then_else(_LocalVars, CondGoal, ThenGoal, ElseGoal),
-
- CondGoal = hlds_goal(_CondGoalExpr, CondGoalInfo),
- NonLocals = goal_info_get_nonlocals(CondGoalInfo),
- mode_info_get_module_info(ModeInfo, ModuleInfo),
- mode_info_get_var_types(ModeInfo, VarTypes),
- NonSolverNonLocals =
- set.filter(non_solver_var(ModuleInfo, VarTypes), NonLocals),
- !:NonFree = set.union(NonSolverNonLocals, !.NonFree),
-
- candidate_init_vars_3(ModeInfo, ThenGoal, !.NonFree, NonFreeThen,
- !CandidateVars),
- candidate_init_vars_3(ModeInfo, ElseGoal, !.NonFree, NonFreeElse,
- !CandidateVars),
- !:NonFree = set.union(NonFreeThen, NonFreeElse).
-
-candidate_init_vars_3(ModeInfo, Goal0, !NonFree, !CandidateVars) :-
- % XXX We should special-case the handling of from_ground_term_construct
- % scopes.
- Goal0 = hlds_goal(scope(_, Goal), _),
- candidate_init_vars_3(ModeInfo, Goal, !NonFree, !CandidateVars).
-
-candidate_init_vars_3(ModeInfo, Goal, !NonFree, !CandidateVars) :-
- Goal = hlds_goal(conj(_ConjType, Goals), _),
- candidate_init_vars_2(ModeInfo, Goals, !NonFree, !CandidateVars).
-
-candidate_init_vars_3(ModeInfo, Goal, !NonFree, !CandidateVars) :-
- % XXX Is the determinism field of a generic_call valid at this point?
- % Determinism analysis is run after mode analysis.
- %
- % We assume that generic calls are deterministic. The modes field of
- % higher_order calls is junk until *after* mode analysis, hence we can't
- % handle them here.
- Goal = hlds_goal(GoalExpr, _),
- GoalExpr = generic_call(Details, Args, ArgModes, _JunkDetism),
- Details \= higher_order(_, _, _, _),
- candidate_init_vars_call(ModeInfo, Args, ArgModes,
- !NonFree, !CandidateVars).
-
-candidate_init_vars_3(ModeInfo, Goal, !NonFree, !CandidateVars) :-
- % A call (at this point the ProcId is just a dummy value since it isn't
- % meaningful until the call is scheduled.)
-
- Goal = hlds_goal(plain_call(PredId, _, Args, _, _, _), _),
-
- % Find a deterministic proc for this call.
- mode_info_get_preds(ModeInfo, Preds),
- map.lookup(Preds, PredId, PredInfo),
- pred_info_get_procedures(PredInfo, ProcTable),
- map.values(ProcTable, ProcInfos),
- list.member(ProcInfo, ProcInfos),
- proc_info_get_declared_determinism(ProcInfo, yes(DeclaredDetism)),
- ( DeclaredDetism = detism_det ; DeclaredDetism = detism_cc_multi ),
-
- % Find the argument modes.
- proc_info_get_argmodes(ProcInfo, ArgModes),
-
- % Process the call args.
- candidate_init_vars_call(ModeInfo, Args, ArgModes,
- !NonFree, !CandidateVars).
-
- % This filter pred succeeds if the given variable does not have
- % a solver type.
- %
-:- pred non_solver_var(module_info::in, vartypes::in, prog_var::in) is semidet.
-
-non_solver_var(ModuleInfo, VarTypes, Var) :-
- VarType = VarTypes ^ det_elem(Var),
- not type_is_solver_type(ModuleInfo, VarType).
-
- % Update !NonFree and !CandidateVars given the args and modes for a call.
- %
-:- pred candidate_init_vars_call(mode_info::in,
- list(prog_var)::in, list(mer_mode)::in,
- set(prog_var)::in, set(prog_var)::out,
- set(prog_var)::in, set(prog_var)::out) is semidet.
-
-candidate_init_vars_call(_ModeInfo, [], [], !NonFree, !CandidateVars).
-candidate_init_vars_call(ModeInfo, [Arg | Args], [Mode | Modes],
- !NonFree, !CandidateVars) :-
- mode_info_get_module_info(ModeInfo, ModuleInfo),
- mode_get_insts_semidet(ModuleInfo, Mode, InitialInst, FinalInst),
- (
- InitialInst \= free,
- InitialInst \= free(_)
- ->
- % This arg is an input that needs instantiation.
- !:CandidateVars = set.insert(!.CandidateVars, Arg)
- ;
- % Otherwise this arg could be an output...
- FinalInst \= free,
- FinalInst \= free(_)
- ->
- % And it is.
- ( set.contains(!.NonFree, Arg) ->
- % This arg appears in an implied mode.
- fail
- ;
- % This arg is instantiated on output.
- !:NonFree = set.insert(!.NonFree, Arg)
- )
- ;
- % This arg is unused.
- true
- ),
- candidate_init_vars_call(ModeInfo, Args, Modes, !NonFree, !CandidateVars).
-
- % We may still have some unscheduled goals. This may be because some
- % initialisation calls are needed to turn some solver type vars
- % from inst free to inst any. This pass tries to unblock the
- % remaining goals by conservatively inserting initialisation calls.
- % It is "eager" in the sense that as soon as it encounters a sub-goal
- % that may be unblocked this way it tries to do so.
- %
-:- pred modecheck_delayed_goals_eager(conj_type::in, list(delayed_goal)::in,
- list(delayed_goal)::out, list(hlds_goal)::out,
- impurity_errors::in, impurity_errors::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_delayed_goals_eager(ConjType, DelayedGoals0, DelayedGoals, Goals,
- !ImpurityErrors, !ModeInfo) :-
- (
- % There are no unscheduled goals, so we don't need to do anything.
- DelayedGoals0 = [],
- DelayedGoals = [],
- Goals = []
- ;
- % There are some unscheduled goals. See if allowing extra
- % initialisation calls (for a single goal) makes a difference.
- DelayedGoals0 = [_ | _],
-
- Goals0 = list.map(hlds_goal_from_delayed_goal, DelayedGoals0),
-
- mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
- delay_info_enter_conj(DelayInfo0, DelayInfo1),
- mode_info_set_delay_info(DelayInfo1, !ModeInfo),
-
- mode_info_get_may_init_solver_vars(!.ModeInfo, OldMayInit),
- expect(unify(OldMayInit, may_not_init_solver_vars), this_file,
- "modecheck_delayed_goals_eager: may init solver vars"),
- mode_info_set_may_init_solver_vars(may_init_solver_vars, !ModeInfo),
- modecheck_conj_list_2(ConjType, Goals0, Goals1, !ImpurityErrors,
- !ModeInfo),
- mode_info_set_may_init_solver_vars(may_not_init_solver_vars,
- !ModeInfo),
-
- mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
- delay_info_leave_conj(DelayInfo2, DelayedGoals1, DelayInfo3),
- mode_info_set_delay_info(DelayInfo3, !ModeInfo),
-
- % See if we scheduled any goals.
- ( length(DelayedGoals1) < length(DelayedGoals0) ->
- % We scheduled some goals. Keep going until we either
- % flounder or succeed.
- modecheck_delayed_goals_eager(ConjType,
- DelayedGoals1, DelayedGoals, Goals2,
- !ImpurityErrors, !ModeInfo),
- Goals = Goals1 ++ Goals2
- ;
- DelayedGoals = DelayedGoals1,
- Goals = Goals1
- )
- ).
-
-:- func hlds_goal_from_delayed_goal(delayed_goal) = hlds_goal.
-
-hlds_goal_from_delayed_goal(delayed_goal(_WaitingVars, _ModeError, Goal)) =
- Goal.
-
- % Check whether there are any delayed goals (other than unifications)
- % at the point where we are about to schedule an impure goal. If so,
- % that is an error. Headvar unifications are allowed to be delayed
- % because in the case of output arguments, they cannot be scheduled until
- % the variable value is known. If headvar unifications couldn't be delayed
- % past impure goals, impure predicates wouldn't be able to have outputs!
- % (Note that we first try to schedule any delayed solver goals waiting
- % for initialisation.)
- %
-:- pred check_for_impurity_error(hlds_goal::in, list(hlds_goal)::out,
- impurity_errors::in, impurity_errors::out,
- mode_info::in, mode_info::out) is det.
-
-check_for_impurity_error(Goal, Goals, !ImpurityErrors, !ModeInfo) :-
- mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
- delay_info_leave_conj(DelayInfo0, DelayedGoals0, DelayInfo1),
- mode_info_set_delay_info(DelayInfo1, !ModeInfo),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- mode_info_get_pred_id(!.ModeInfo, PredId),
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- pred_info_get_clauses_info(PredInfo, ClausesInfo),
- clauses_info_get_headvar_list(ClausesInfo, HeadVars),
- filter_headvar_unification_goals(HeadVars, DelayedGoals0,
- HeadVarUnificationGoals, NonHeadVarUnificationGoals0),
- modecheck_delayed_solver_goals(plain_conj, Goals,
- NonHeadVarUnificationGoals0, NonHeadVarUnificationGoals,
- !ImpurityErrors, !ModeInfo),
- mode_info_get_delay_info(!.ModeInfo, DelayInfo2),
- delay_info_enter_conj(DelayInfo2, DelayInfo3),
- redelay_goals(HeadVarUnificationGoals, DelayInfo3, DelayInfo),
- mode_info_set_delay_info(DelayInfo, !ModeInfo),
- (
- NonHeadVarUnificationGoals = []
- ;
- NonHeadVarUnificationGoals = [_ | _],
- get_all_waiting_vars(NonHeadVarUnificationGoals, Vars),
- ModeError = mode_error_conj(NonHeadVarUnificationGoals,
- goals_followed_by_impure_goal(Goal)),
- mode_info_get_context(!.ModeInfo, Context),
- mode_info_get_mode_context(!.ModeInfo, ModeContext),
- ImpurityError = mode_error_info(Vars, ModeError, Context, ModeContext),
- !:ImpurityErrors = [ImpurityError | !.ImpurityErrors]
- ).
-
-:- pred filter_headvar_unification_goals(list(prog_var)::in,
- list(delayed_goal)::in, list(delayed_goal)::out, list(delayed_goal)::out)
- is det.
-
-filter_headvar_unification_goals(HeadVars, DelayedGoals,
- HeadVarUnificationGoals, NonHeadVarUnificationGoals) :-
- list.filter(is_headvar_unification_goal(HeadVars), DelayedGoals,
- HeadVarUnificationGoals, NonHeadVarUnificationGoals).
-
-:- pred is_headvar_unification_goal(list(prog_var)::in, delayed_goal::in)
- is semidet.
-
-is_headvar_unification_goal(HeadVars, delayed_goal(_, _, Goal)) :-
- Goal ^ hlds_goal_expr = unify(Var, RHS, _, _, _),
- (
- list.member(Var, HeadVars)
- ;
- RHS = rhs_var(OtherVar),
- list.member(OtherVar, HeadVars)
- ).
-
- % Given an association list of Vars - Goals,
- % combine all the Vars together into a single set.
- %
-:- pred get_all_waiting_vars(list(delayed_goal)::in, set(prog_var)::out)
- is det.
-
-get_all_waiting_vars(DelayedGoals, Vars) :-
- get_all_waiting_vars_2(DelayedGoals, set.init, Vars).
-
-:- pred get_all_waiting_vars_2(list(delayed_goal)::in,
- set(prog_var)::in, set(prog_var)::out) is det.
-
-get_all_waiting_vars_2([], Vars, Vars).
-get_all_waiting_vars_2([delayed_goal(Vars1, _, _) | Rest], Vars0, Vars) :-
- set.union(Vars0, Vars1, Vars2),
- get_all_waiting_vars_2(Rest, Vars2, Vars).
-
-:- pred redelay_goals(list(delayed_goal)::in, delay_info::in, delay_info::out)
- is det.
-
-redelay_goals([], !DelayInfo).
-redelay_goals([DelayedGoal | DelayedGoals], !DelayInfo) :-
- DelayedGoal = delayed_goal(_WaitingVars, ModeErrorInfo, Goal),
- delay_info_delay_goal(ModeErrorInfo, Goal, !DelayInfo),
- redelay_goals(DelayedGoals, !DelayInfo).
-
-%-----------------------------------------------------------------------------%
-
-:- pred modecheck_disj_list(list(hlds_goal)::in, list(hlds_goal)::out,
- list(instmap)::out, set(prog_var)::in, set(prog_var)::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_disj_list([], [], [], !LargeFlatConstructs, !ModeInfo).
-modecheck_disj_list([Goal0 | Goals0], [Goal | Goals], [InstMap | InstMaps],
- !LargeFlatConstructs, !ModeInfo) :-
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- modecheck_goal(Goal0, Goal, !ModeInfo),
- accumulate_large_flat_constructs(Goal, !LargeFlatConstructs),
- mode_info_get_instmap(!.ModeInfo, InstMap),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- modecheck_disj_list(Goals0, Goals, InstMaps, !LargeFlatConstructs,
- !ModeInfo).
-
-:- pred modecheck_case_list(list(case)::in, prog_var::in, list(case)::out,
- list(instmap)::out, set(prog_var)::in, set(prog_var)::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_case_list([], _Var, [], [], !LargeFlatConstructs, !ModeInfo).
-modecheck_case_list([Case0 | Cases0], Var, [Case | Cases],
- [InstMap | InstMaps], !LargeFlatConstructs, !ModeInfo) :-
- Case0 = case(MainConsId, OtherConsIds, Goal0),
- mode_info_get_instmap(!.ModeInfo, InstMap0),
-
- % Record the fact that Var was bound to ConsId in the instmap
- % before processing this case.
- modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo),
-
- % Modecheck this case (if it is reachable).
- mode_info_get_instmap(!.ModeInfo, InstMap1),
- ( instmap_is_reachable(InstMap1) ->
- modecheck_goal(Goal0, Goal1, !ModeInfo),
- mode_info_get_instmap(!.ModeInfo, InstMap)
- ;
- % We should not mode-analyse the goal, since it is unreachable.
- % Instead we optimize the goal away, so that later passes
- % won't complain about it not having mode information.
- Goal1 = true_goal,
- InstMap = InstMap1
- ),
-
- % Don't lose the information added by the functor test above.
- fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal),
-
- Case = case(MainConsId, OtherConsIds, Goal),
- accumulate_large_flat_constructs(Goal, !LargeFlatConstructs),
- mode_info_set_instmap(InstMap0, !ModeInfo),
- modecheck_case_list(Cases0, Var, Cases, InstMaps, !LargeFlatConstructs,
- !ModeInfo).
-
-:- pred accumulate_large_flat_constructs(hlds_goal::in,
- set(prog_var)::in, set(prog_var)::out) is det.
-
-accumulate_large_flat_constructs(Goal, !LargeFlatConstructs) :-
- ( set.empty(!.LargeFlatConstructs) ->
- % Calling goal_large_flat_constructs and then set.intersect
- % would be waste of time; !:LargeFlatConstructs will still be empty.
- true
- ;
- GoalLargeFlatConstructs = goal_large_flat_constructs(Goal),
- set.intersect(GoalLargeFlatConstructs, !LargeFlatConstructs)
- ).
-
-modecheck_functor_test(Var, ConsId, !ModeInfo) :-
- % Figure out the arity of this constructor, _including_ any type-infos
- % or typeclass-infos inserted for existential data types.
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- map.lookup(VarTypes, Var, Type),
- BoundInst = cons_id_to_bound_inst(ModuleInfo, Type, ConsId),
-
- % Record the fact that Var was bound to ConsId.
- modecheck_set_var_inst(Var, bound(unique, [BoundInst]), no, !ModeInfo).
-
-modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo) :-
- % Figure out the arity of this constructor, _including_ any type-infos
- % or typeclass-infos inserted for existential data types.
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- map.lookup(VarTypes, Var, Type),
- BoundInsts = list.map(cons_id_to_bound_inst(ModuleInfo, Type),
- [MainConsId | OtherConsIds]),
-
- % Record the fact that Var was bound to MainConsId or one of the
- % OtherConsIds.
- modecheck_set_var_inst(Var, bound(unique, BoundInsts), no, !ModeInfo).
-
-:- func cons_id_to_bound_inst(module_info, mer_type, cons_id) = bound_inst.
-
-cons_id_to_bound_inst(ModuleInfo, Type, ConsId) = BoundInst :-
- ConsIdAdjustedArity = cons_id_adjusted_arity(ModuleInfo, Type, ConsId),
- list.duplicate(ConsIdAdjustedArity, free, ArgInsts),
- BoundInst = bound_functor(ConsId, ArgInsts).
-
-compute_goal_instmap_delta(InstMap0, GoalExpr, !GoalInfo, !ModeInfo) :-
- ( GoalExpr = conj(_, []) ->
- % When modecheck_unify.m replaces a unification with a dead variable
- % with `true', make sure the instmap_delta of the goal is empty.
- % The code generator and mode_util.recompute_instmap_delta can be
- % confused by references to the dead variable in the instmap_delta,
- % resulting in calls to error/1.
-
- instmap_delta_init_reachable(DeltaInstMap),
- mode_info_set_instmap(InstMap0, !ModeInfo)
- ;
- NonLocals = goal_info_get_nonlocals(!.GoalInfo),
- mode_info_get_instmap(!.ModeInfo, InstMap),
- compute_instmap_delta(InstMap0, InstMap, NonLocals, DeltaInstMap)
- ),
- goal_info_set_instmap_delta(DeltaInstMap, !GoalInfo).
-
-%-----------------------------------------------------------------------------%
-
-:- func goal_large_flat_constructs(hlds_goal) = set(prog_var).
-
-goal_large_flat_constructs(Goal) = LargeFlatConstructs :-
- Goal = hlds_goal(GoalExpr, _),
- (
- GoalExpr = unify(_, _, _, _, _),
- % Unifications not wrapped in from_ground_term_construct scopes
- % are never marked by the modechecker as being constructed statically.
- LargeFlatConstructs = set.init
- ;
- ( GoalExpr = plain_call(_, _, _, _, _, _)
- ; GoalExpr = generic_call(_, _, _, _)
- ; GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
- ),
- LargeFlatConstructs = set.init
- ;
- ( GoalExpr = disj(_)
- ; GoalExpr = switch(_, _, _)
- ; GoalExpr = if_then_else(_, _, _, _)
- ; GoalExpr = negation(_)
- ; GoalExpr = shorthand(_)
- ; GoalExpr = conj(parallel_conj, _)
- ),
- LargeFlatConstructs = set.init
- ;
- GoalExpr = scope(Reason, _),
- (
- Reason = from_ground_term(TermVar, from_ground_term_construct),
- LargeFlatConstructs = set.make_singleton_set(TermVar)
- ;
- ( Reason = from_ground_term(_, from_ground_term_deconstruct)
- ; Reason = from_ground_term(_, from_ground_term_other)
- ; Reason = exist_quant(_)
- ; Reason = promise_solutions(_, _)
- ; Reason = promise_purity(_)
- ; Reason = commit(_)
- ; Reason = barrier(_)
- ; Reason = trace_goal(_, _, _, _, _)
- ),
- LargeFlatConstructs = set.init
- )
- ;
- GoalExpr = conj(plain_conj, Conjuncts),
- goals_large_flat_constructs(Conjuncts, set.init, LargeFlatConstructs)
- ).
-
-:- pred goals_large_flat_constructs(list(hlds_goal)::in,
- set(prog_var)::in, set(prog_var)::out) is det.
-
-goals_large_flat_constructs([], !LargeFlatConstructs).
-goals_large_flat_constructs([Goal | Goals], !LargeFlatConstructs) :-
- GoalLargeFlatConstructs = goal_large_flat_constructs(Goal),
- set.union(GoalLargeFlatConstructs, !LargeFlatConstructs),
- goals_large_flat_constructs(Goals, !LargeFlatConstructs).
-
-:- pred set_large_flat_constructs_to_ground_in_goal(set(prog_var)::in,
- hlds_goal::in, hlds_goal::out) is det.
-
-set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs,
- Goal0, Goal) :-
- Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
- (
- GoalExpr0 = unify(_, _, _, _, _),
- Goal = Goal0
- ;
- ( GoalExpr0 = plain_call(_, _, _, _, _, _)
- ; GoalExpr0 = generic_call(_, _, _, _)
- ; GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _)
- ),
- Goal = Goal0
- ;
- ( GoalExpr0 = disj(_)
- ; GoalExpr0 = switch(_, _, _)
- ; GoalExpr0 = if_then_else(_, _, _, _)
- ; GoalExpr0 = negation(_)
- ; GoalExpr0 = shorthand(_)
- ; GoalExpr0 = conj(parallel_conj, _)
- ),
- Goal = Goal0
- ;
- GoalExpr0 = scope(Reason, SubGoal0),
- (
- Reason = from_ground_term(TermVar, from_ground_term_construct),
- ( set.member(TermVar, LargeFlatConstructs) ->
- InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
- instmap_delta_set_var(TermVar, ground(shared, none),
- InstMapDelta0, InstMapDelta),
- goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo),
-
- SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo0),
- goal_info_set_instmap_delta(InstMapDelta,
- SubGoalInfo0, SubGoalInfo),
- % We could also replace the instmap deltas of the conjuncts
- % inside SubGoalExpr0. Doing so would take time but reduce
- % the compiler's memory requirements.
- SubGoal = hlds_goal(SubGoalExpr0, SubGoalInfo),
- GoalExpr = scope(Reason, SubGoal),
- Goal = hlds_goal(GoalExpr, GoalInfo)
- ;
- Goal = Goal0
- )
- ;
- ( Reason = from_ground_term(_, from_ground_term_deconstruct)
- ; Reason = from_ground_term(_, from_ground_term_other)
- ; Reason = exist_quant(_)
- ; Reason = promise_solutions(_, _)
- ; Reason = promise_purity(_)
- ; Reason = commit(_)
- ; Reason = barrier(_)
- ; Reason = trace_goal(_, _, _, _, _)
- ),
- Goal = Goal0
- )
- ;
- GoalExpr0 = conj(plain_conj, Conjuncts0),
- set_large_flat_constructs_to_ground_in_goals(LargeFlatConstructs,
- Conjuncts0, Conjuncts),
- GoalExpr = conj(plain_conj, Conjuncts),
-
- InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
- instmap_delta_changed_vars(InstMapDelta0, ChangedVars),
- set.intersect(ChangedVars, LargeFlatConstructs, GroundVars),
- instmap_delta_set_vars_same(ground(shared, none),
- set.to_sorted_list(GroundVars), InstMapDelta0, InstMapDelta),
- goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo),
- Goal = hlds_goal(GoalExpr, GoalInfo)
- ).
-
-:- pred set_large_flat_constructs_to_ground_in_goals(set(prog_var)::in,
- list(hlds_goal)::in, list(hlds_goal)::out) is det.
-
-set_large_flat_constructs_to_ground_in_goals(_, [], []).
-set_large_flat_constructs_to_ground_in_goals(LargeFlatConstructs,
- [Goal0 | Goals0], [Goal | Goals]) :-
- set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs,
- Goal0, Goal),
- set_large_flat_constructs_to_ground_in_goals(LargeFlatConstructs,
- Goals0, Goals).
-
-:- pred set_large_flat_constructs_to_ground_in_case(set(prog_var)::in,
- case::in, case::out) is det.
-
-set_large_flat_constructs_to_ground_in_case(LargeFlatConstructs,
- Case0, Case) :-
- Case0 = case(MainConsId, OtherConsIds, Goal0),
- set_large_flat_constructs_to_ground_in_goal(LargeFlatConstructs,
- Goal0, Goal),
- Case = case(MainConsId, OtherConsIds, Goal).
-
-%-----------------------------------------------------------------------------%
-
- % Calculate the argument number offset that needs to be passed to
- % modecheck_var_list_is_live, modecheck_var_has_inst_list, and
- % modecheck_set_var_inst_list. This offset number is calculated
- % so that real arguments get positive argument numbers and
- % type_info arguments get argument numbers less than or equal to 0.
- %
-compute_arg_offset(PredInfo, ArgOffset) :-
- OrigArity = pred_info_orig_arity(PredInfo),
- pred_info_get_arg_types(PredInfo, ArgTypes),
- list.length(ArgTypes, CurrentArity),
- ArgOffset = OrigArity - CurrentArity.
-
-%-----------------------------------------------------------------------------%
-
-modecheck_var_list_is_live_exact_match([_ | _], [], _, !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_list_is_live_exact_match: length mismatch").
-modecheck_var_list_is_live_exact_match([], [_ | _], _, !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_list_is_live_exact_match: length mismatch").
-modecheck_var_list_is_live_exact_match([], [], _ArgNum, !ModeInfo).
-modecheck_var_list_is_live_exact_match([Var | Vars], [IsLive | IsLives],
- ArgNum0, !ModeInfo) :-
- ArgNum = ArgNum0 + 1,
- mode_info_set_call_arg_context(ArgNum, !ModeInfo),
- modecheck_var_is_live_exact_match(Var, IsLive, !ModeInfo),
- modecheck_var_list_is_live_exact_match(Vars, IsLives, ArgNum, !ModeInfo).
-
-modecheck_var_list_is_live_no_exact_match([_ | _], [], _, !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_list_is_live_no_exact_match: length mismatch").
-modecheck_var_list_is_live_no_exact_match([], [_ | _], _, !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_list_is_live_no_exact_match: length mismatch").
-modecheck_var_list_is_live_no_exact_match([], [], _ArgNum, !ModeInfo).
-modecheck_var_list_is_live_no_exact_match([Var | Vars], [IsLive | IsLives],
- ArgNum0, !ModeInfo) :-
- ArgNum = ArgNum0 + 1,
- mode_info_set_call_arg_context(ArgNum, !ModeInfo),
- modecheck_var_is_live_no_exact_match(Var, IsLive, !ModeInfo),
- modecheck_var_list_is_live_no_exact_match(Vars, IsLives, ArgNum,
- !ModeInfo).
-
- % `live' means possibly used later on, and `dead' means definitely not used
- % later on. If you don't need an exact match, then the only time you get
- % an error is if you pass a variable which is live to a predicate
- % that expects the variable to be dead; the predicate may use destructive
- % update to clobber the variable, so we must be sure that it is dead
- % after the call.
- %
-
- % A version of modecheck_var_is_live specialized for NeedExactMatch = no.
- %
-:- pred modecheck_var_is_live_no_exact_match(prog_var::in, is_live::in,
- mode_info::in, mode_info::out) is det.
-
-modecheck_var_is_live_no_exact_match(VarId, ExpectedIsLive, !ModeInfo) :-
- mode_info_var_is_live(!.ModeInfo, VarId, VarIsLive),
- (
- ExpectedIsLive = is_dead,
- VarIsLive = is_live
- ->
- set.singleton_set(WaitingVars, VarId),
- ModeError = mode_error_var_is_live(VarId),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- ;
- true
- ).
-
- % A version of modecheck_var_is_live specialized for NeedExactMatch = yes.
- %
-:- pred modecheck_var_is_live_exact_match(prog_var::in, is_live::in,
- mode_info::in, mode_info::out) is det.
-
-modecheck_var_is_live_exact_match(VarId, ExpectedIsLive, !ModeInfo) :-
- mode_info_var_is_live(!.ModeInfo, VarId, VarIsLive),
- ( VarIsLive = ExpectedIsLive ->
- true
- ;
- set.singleton_set(WaitingVars, VarId),
- ModeError = mode_error_var_is_live(VarId),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Given a list of variables and a list of initial insts, ensure that
- % the inst of each variable matches the corresponding initial inst.
- %
-modecheck_var_has_inst_list_exact_match(Vars, Insts, ArgNum, Subst,
- !ModeInfo) :-
- modecheck_var_has_inst_list_exact_match_2(Vars, Insts, ArgNum,
- map.init, Subst, !ModeInfo).
-
-modecheck_var_has_inst_list_no_exact_match(Vars, Insts, ArgNum, Subst,
- !ModeInfo) :-
- modecheck_var_has_inst_list_no_exact_match_2(Vars, Insts, ArgNum,
- map.init, Subst, !ModeInfo).
-
-:- pred modecheck_var_has_inst_list_exact_match_2(list(prog_var)::in,
- list(mer_inst)::in, int::in, inst_var_sub::in, inst_var_sub::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_var_has_inst_list_exact_match_2([_ | _], [], _, !Subst, !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_has_inst_list_exact_match_2: length mismatch").
-modecheck_var_has_inst_list_exact_match_2([], [_ | _], _, !Subst, !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_has_inst_list_exact_match_2: length mismatch").
-modecheck_var_has_inst_list_exact_match_2([], [], _ArgNum, !Subst, !ModeInfo).
-modecheck_var_has_inst_list_exact_match_2([Var | Vars], [Inst | Insts],
- ArgNum0, !Subst, !ModeInfo) :-
- ArgNum = ArgNum0 + 1,
- mode_info_set_call_arg_context(ArgNum, !ModeInfo),
- modecheck_var_has_inst_exact_match(Var, Inst, !Subst, !ModeInfo),
- modecheck_var_has_inst_list_exact_match_2(Vars, Insts, ArgNum,
- !Subst, !ModeInfo).
-
-:- pred modecheck_var_has_inst_list_no_exact_match_2(list(prog_var)::in,
- list(mer_inst)::in, int::in, inst_var_sub::in, inst_var_sub::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_var_has_inst_list_no_exact_match_2([_ | _], [], _, !Subst,
- !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_has_inst_list_no_exact_match_2: length mismatch").
-modecheck_var_has_inst_list_no_exact_match_2([], [_ | _], _,
- !Subst, !ModeInfo) :-
- unexpected(this_file,
- "modecheck_var_has_inst_list_no_exact_match_2: length mismatch").
-modecheck_var_has_inst_list_no_exact_match_2([], [], _ArgNum,
- !Subst, !ModeInfo).
-modecheck_var_has_inst_list_no_exact_match_2([Var | Vars], [Inst | Insts],
- ArgNum0, !Subst, !ModeInfo) :-
- ArgNum = ArgNum0 + 1,
- mode_info_set_call_arg_context(ArgNum, !ModeInfo),
- modecheck_var_has_inst_no_exact_match(Var, Inst, !Subst, !ModeInfo),
- modecheck_var_has_inst_list_no_exact_match_2(Vars, Insts, ArgNum,
- !Subst, !ModeInfo).
-
-:- pred modecheck_var_has_inst_exact_match(prog_var::in, mer_inst::in,
- inst_var_sub::in, inst_var_sub::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_var_has_inst_exact_match(Var, Inst, !Subst, !ModeInfo) :-
- mode_info_get_instmap(!.ModeInfo, InstMap),
- instmap_lookup_var(InstMap, Var, VarInst),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- map.lookup(VarTypes, Var, Type),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
- (
- inst_matches_initial_no_implied_modes_sub(VarInst, Inst, Type,
- ModuleInfo0, ModuleInfo, !Subst)
- ->
- mode_info_set_module_info(ModuleInfo, !ModeInfo)
- ;
- set.singleton_set(WaitingVars, Var),
- ModeError = mode_error_var_has_inst(Var, VarInst, Inst),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- ).
-
-:- pred modecheck_var_has_inst_no_exact_match(prog_var::in, mer_inst::in,
- inst_var_sub::in, inst_var_sub::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_var_has_inst_no_exact_match(Var, Inst, !Subst, !ModeInfo) :-
- mode_info_get_instmap(!.ModeInfo, InstMap),
- instmap_lookup_var(InstMap, Var, VarInst),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- map.lookup(VarTypes, Var, Type),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
- (
- inst_matches_initial_sub(VarInst, Inst, Type, ModuleInfo0, ModuleInfo,
- !Subst)
- ->
- mode_info_set_module_info(ModuleInfo, !ModeInfo)
- ;
- set.singleton_set(WaitingVars, Var),
- ModeError = mode_error_var_has_inst(Var, VarInst, Inst),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- ).
-
-modecheck_introduced_type_info_var_has_inst_no_exact_match(Var, Type, Inst,
- !ModeInfo) :-
- mode_info_get_instmap(!.ModeInfo, InstMap),
- instmap_lookup_var(InstMap, Var, VarInst),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
- (
- inst_matches_initial_sub(VarInst, Inst, Type, ModuleInfo0, ModuleInfo,
- map.init, _Subst)
- ->
- mode_info_set_module_info(ModuleInfo, !ModeInfo)
- ;
- set.singleton_set(WaitingVars, Var),
- ModeError = mode_error_var_has_inst(Var, VarInst, Inst),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
-modecheck_set_var_inst_list(Vars0, InitialInsts, FinalInsts, ArgOffset,
- Vars, Goals, !ModeInfo) :-
- (
- modecheck_set_var_inst_list_2(Vars0, InitialInsts, FinalInsts,
- ArgOffset, Vars1, no_extra_goals, Goals1, !ModeInfo)
- ->
- Vars = Vars1,
- Goals = Goals1
- ;
- unexpected(this_file, "modecheck_set_var_inst_list: length mismatch")
- ).
-
-:- pred modecheck_set_var_inst_list_2(list(prog_var)::in, list(mer_inst)::in,
- list(mer_inst)::in, int::in, list(prog_var)::out,
- extra_goals::in, extra_goals::out, mode_info::in, mode_info::out)
- is semidet.
-
-modecheck_set_var_inst_list_2([], [], [], _, [], !ExtraGoals, !ModeInfo).
-modecheck_set_var_inst_list_2([Var0 | Vars0], [InitialInst | InitialInsts],
- [FinalInst | FinalInsts], ArgNum0, [Var | Vars],
- !ExtraGoals, !ModeInfo) :-
- ArgNum = ArgNum0 + 1,
- mode_info_set_call_arg_context(ArgNum, !ModeInfo),
- modecheck_set_var_inst_call(Var0, InitialInst, FinalInst,
- Var, !ExtraGoals, !ModeInfo),
- modecheck_set_var_inst_list_2(Vars0, InitialInsts, FinalInsts, ArgNum,
- Vars, !ExtraGoals, !ModeInfo).
-
-:- pred modecheck_set_var_inst_call(prog_var::in, mer_inst::in, mer_inst::in,
- prog_var::out, extra_goals::in, extra_goals::out,
- mode_info::in, mode_info::out) is det.
-
-modecheck_set_var_inst_call(Var0, InitialInst, FinalInst, Var, !ExtraGoals,
- !ModeInfo) :-
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- ( instmap_is_reachable(InstMap0) ->
- % The new inst must be computed by unifying the
- % old inst and the proc's final inst.
- instmap_lookup_var(InstMap0, Var0, VarInst0),
- handle_implied_mode(Var0, VarInst0, InitialInst, Var, !ExtraGoals,
- !ModeInfo),
- modecheck_set_var_inst(Var0, FinalInst, no, !ModeInfo),
- ( Var = Var0 ->
- true
- ;
- modecheck_set_var_inst(Var, FinalInst, no, !ModeInfo)
- )
- ;
- Var = Var0
- ).
-
- % Note that there are two versions of modecheck_set_var_inst,
- % one with arity 8 (suffixed with _call) and one with arity 5.
- % The former is used for predicate calls, where we may need
- % to introduce unifications to handle calls to implied modes.
- %
-modecheck_set_var_inst(Var0, FinalInst, MaybeUInst, !ModeInfo) :-
- mode_info_get_parallel_vars(!.ModeInfo, PVars0),
- mode_info_get_instmap(!.ModeInfo, InstMap0),
- ( instmap_is_reachable(InstMap0) ->
- % The new inst must be computed by unifying the
- % old inst and the proc's final inst.
- instmap_lookup_var(InstMap0, Var0, Inst0),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
- (
- abstractly_unify_inst(is_dead, Inst0, FinalInst,
- fake_unify, UnifyInst, _Det, ModuleInfo0, ModuleInfo1)
- ->
- ModuleInfo = ModuleInfo1,
- Inst = UnifyInst
- ;
- unexpected(this_file, "modecheck_set_var_inst: unify_inst failed")
- ),
- mode_info_set_module_info(ModuleInfo, !ModeInfo),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
- map.lookup(VarTypes, Var0, Type),
- (
- % If the top-level inst of the variable is not_reached,
- % then the instmap as a whole must be unreachable.
- inst_expand(ModuleInfo, Inst, not_reached)
- ->
- instmap.init_unreachable(InstMap),
- mode_info_set_instmap(InstMap, !ModeInfo)
- ;
- % If we haven't added any information and
- % we haven't bound any part of the var, then
- % the only thing we can have done is lose uniqueness.
- inst_matches_initial(Inst0, Inst, Type, ModuleInfo)
- ->
- instmap_set_var(Var0, Inst, InstMap0, InstMap),
- mode_info_set_instmap(InstMap, !ModeInfo)
- ;
- % We must have either added some information,
- % lost some uniqueness, or bound part of the var.
- % The call to inst_matches_binding will succeed
- % only if we haven't bound any part of the var.
- \+ inst_matches_binding(Inst, Inst0, Type, ModuleInfo),
-
- % We've bound part of the var. If the var was locked,
- % then we need to report an error...
- mode_info_var_is_locked(!.ModeInfo, Var0, Reason0),
- \+ (
- % ...unless the goal is a unification and the var was unified
- % with something no more instantiated than itself. This allows
- % for the case of `any = free', for example. The call to
- % inst_matches_binding, above will fail for the var with
- % mode `any >> any' however, it should be allowed because
- % it has only been unified with a free variable.
- MaybeUInst = yes(UInst),
- inst_is_at_least_as_instantiated(Inst, UInst, Type,
- ModuleInfo),
- inst_matches_binding_allow_any_any(Inst, Inst0, Type,
- ModuleInfo)
- )
- ->
- set.singleton_set(WaitingVars, Var0),
- ModeError = mode_error_bind_var(Reason0, Var0, Inst0, Inst),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- ;
- instmap_set_var(Var0, Inst, InstMap0, InstMap),
- mode_info_set_instmap(InstMap, !ModeInfo),
- mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
- delay_info_bind_var(Var0, DelayInfo0, DelayInfo),
- mode_info_set_delay_info(DelayInfo, !ModeInfo)
- )
- ;
- true
- ),
- (
- PVars0 = []
- ;
- PVars0 = [par_conj_mode_check(NonLocals, Bound0) | PVars1],
- ( set.member(Var0, NonLocals) ->
- set.insert(Bound0, Var0, Bound),
- PVars = [par_conj_mode_check(NonLocals, Bound) | PVars1]
- ;
- PVars = PVars0
- ),
- mode_info_set_parallel_vars(PVars, !ModeInfo)
- ).
-
- % If this was a call to an implied mode for that variable, then we need to
- % introduce a fresh variable.
- %
-:- pred handle_implied_mode(prog_var::in, mer_inst::in, mer_inst::in,
- prog_var::out, extra_goals::in, extra_goals::out,
- mode_info::in, mode_info::out) is det.
-
-handle_implied_mode(Var0, VarInst0, InitialInst0, Var, !ExtraGoals,
- !ModeInfo) :-
- mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
- inst_expand(ModuleInfo0, InitialInst0, InitialInst),
- inst_expand(ModuleInfo0, VarInst0, VarInst1),
-
- mode_info_get_var_types(!.ModeInfo, VarTypes0),
- map.lookup(VarTypes0, Var0, VarType),
- (
- % If the initial inst of the variable matches_final the initial inst
- % specified in the pred's mode declaration, then it's not a call
- % to an implied mode, it's an exact match with a genuine mode.
- inst_matches_initial_no_implied_modes(VarInst1, InitialInst,
- VarType, ModuleInfo0)
- ->
- Var = Var0
- ;
- % This is the implied mode case. We do not yet handle implied modes
- % for partially instantiated vars, since that would require doing
- % a partially instantiated deep copy, and we don't know how to do
- % that yet.
-
- InitialInst = any(_, _),
- inst_is_free(ModuleInfo0, VarInst1)
- ->
- % This is the simple case of implied `any' modes, where the declared
- % mode was `any -> ...' and the argument passed was `free'.
-
- Var = Var0,
-
- % If the variable's type is not a solver type (in which case inst `any'
- % means the same as inst `ground') then this is an implied mode that we
- % don't yet know how to handle.
- %
- % If the variable's type is a solver type then we need to insert a call
- % to the solver type's initialisation predicate. (To avoid unnecessary
- % complications, we avoid doing this if there are any mode errors
- % recorded at this point.)
-
- mode_info_get_context(!.ModeInfo, Context),
- mode_info_get_mode_context(!.ModeInfo, ModeContext),
- mode_context_to_unify_context(!.ModeInfo, ModeContext, UnifyContext),
- CallUnifyContext = yes(call_unify_context(Var, rhs_var(Var),
- UnifyContext)),
- (
- mode_info_get_errors(!.ModeInfo, ModeErrors),
- ModeErrors = [],
- mode_info_may_init_solver_vars(!.ModeInfo),
- mode_info_solver_init_is_supported(!.ModeInfo),
- type_is_solver_type_with_auto_init(ModuleInfo0, VarType)
- ->
- % Create code to initialize the variable to inst `any',
- % by calling the solver type's initialisation predicate.
- insert_extra_initialisation_call(Var, VarType, InitialInst,
- Context, CallUnifyContext, !ExtraGoals, !ModeInfo)
- ;
- % If the type is a type variable, or isn't a solver type,
- % then give up.
- set.singleton_set(WaitingVars, Var0),
- ModeError = mode_error_implied_mode(Var0, VarInst0, InitialInst),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- )
- ;
- inst_is_bound(ModuleInfo0, InitialInst)
- ->
- % This is the case we can't handle.
- Var = Var0,
- set.singleton_set(WaitingVars, Var0),
- ModeError = mode_error_implied_mode(Var0, VarInst0, InitialInst),
- mode_info_error(WaitingVars, ModeError, !ModeInfo)
- ;
- % This is the simple case of implied modes,
- % where the declared mode was free -> ...
-
- % Introduce a new variable.
- mode_info_get_varset(!.ModeInfo, VarSet0),
- varset.new_var(VarSet0, Var, VarSet),
- map.set(VarTypes0, Var, VarType, VarTypes),
- mode_info_set_varset(VarSet, !ModeInfo),
- mode_info_set_var_types(VarTypes, !ModeInfo),
-
- % Construct the code to do the unification.
- create_var_var_unification(Var0, Var, VarType, !.ModeInfo, ExtraGoal),
-
- % Append the goals together in the appropriate order:
- % ExtraGoals0, then NewUnify.
- NewUnifyExtraGoal = extra_goals([], [ExtraGoal]),
- append_extra_goals(!.ExtraGoals, NewUnifyExtraGoal, !:ExtraGoals)
- ).
-
-:- pred insert_extra_initialisation_call(prog_var::in, mer_type::in,
- mer_inst::in, prog_context::in, maybe(call_unify_context)::in,
- extra_goals::in, extra_goals::out, mode_info::in, mode_info::out) is det.
-
-insert_extra_initialisation_call(Var, VarType, Inst, Context, CallUnifyContext,
- !ExtraGoals, !ModeInfo) :-
- construct_initialisation_call(Var, VarType, Inst, Context,
- CallUnifyContext, InitVarGoal, !ModeInfo),
- NewExtraGoal = extra_goals([InitVarGoal], []),
- append_extra_goals(!.ExtraGoals, NewExtraGoal, !:ExtraGoals).
-
-construct_initialisation_call(Var, VarType, Inst, Context,
- MaybeCallUnifyContext, InitVarGoal, !ModeInfo) :-
- (
- type_to_ctor_and_args(VarType, TypeCtor, _TypeArgs),
- PredName = special_pred_name(spec_pred_init, TypeCtor),
- (
- TypeCtor = type_ctor(qualified(ModuleName, _TypeName), _Arity)
- ;
- TypeCtor = type_ctor(unqualified(_TypeName), _Arity),
- mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- module_info_get_name(ModuleInfo, ModuleName)
- ),
- NonLocals = set.make_singleton_set(Var),
- InstMapDeltaAL = [Var - Inst],
- InstMapDelta = instmap_delta_from_assoc_list(InstMapDeltaAL),
- build_call(ModuleName, PredName, [Var], [VarType], NonLocals,
- InstMapDelta, Context, MaybeCallUnifyContext,
- hlds_goal(GoalExpr, GoalInfo), !ModeInfo)
- ->
- InitVarGoal = hlds_goal(GoalExpr, GoalInfo),
- % If Var was ignored, i.e. it occurred in only one atomic goal
- % and was not in that atomic goal's nonlocals set, then creating
- % the call to the initialisation predicate and adding it to the
- % procedure body requires the addition of Var to the original goal's
- % nonlocals set. This *should* be done by looking at all the places
- % in the compiler that decide to call construct_initialisation_call
- % directly or indirectly, and modifying that code to add Var to
- % the relevant nonlocals set, or possibly by avoiding the call
- % to construct_initialisation_call altogether (after all, if
- % a variable is ignored, it should not need initialization).
- %
- % However, getting a requantify pass to do it for us is less work.
- %
- % An example of code that needs this fix for the correctness of the
- % HLDS is tests/hard_coded/solver_construction_init_test.m.
- mode_info_set_need_to_requantify(need_to_requantify, !ModeInfo)
- ;
- unexpected(this_file, "construct_initialisation_call")
- ).
-
-:- pred build_call(module_name::in, string::in, list(prog_var)::in,
- list(mer_type)::in, set(prog_var)::in, instmap_delta::in,
- prog_context::in, maybe(call_unify_context)::in, hlds_goal::out,
- mode_info::in, mode_info::out) is semidet.
-
-build_call(CalleeModuleName, CalleePredName, ArgVars, ArgTypes, NonLocals,
- InstMapDelta, Context, MaybeCallUnifyContext, Goal, !ModeInfo) :-
- mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
-
- % Get the relevant information for the procedure we are transforming
- % (i.e., the caller).
- mode_info_get_pred_id(!.ModeInfo, PredId),
- mode_info_get_proc_id(!.ModeInfo, ProcId),
- module_info_pred_proc_info(ModuleInfo0, PredId, ProcId, PredInfo0,
- ProcInfo0),
- pred_info_get_typevarset(PredInfo0, TVarSet),
- pred_info_get_exist_quant_tvars(PredInfo0, ExistQTVars),
- pred_info_get_head_type_params(PredInfo0, HeadTypeParams),
-
- % Get the pred_info and proc_info for the procedure we are calling.
- SymName = qualified(CalleeModuleName, CalleePredName),
- get_pred_id_and_proc_id_by_types(is_fully_qualified, SymName, pf_predicate,
- TVarSet, ExistQTVars, ArgTypes, HeadTypeParams, ModuleInfo0,
- Context, CalleePredId, CalleeProcId),
- module_info_pred_proc_info(ModuleInfo0, CalleePredId, CalleeProcId,
- CalleePredInfo, CalleeProcInfo),
-
- % Create a poly_info for the caller. We have to set the varset and
- % vartypes from the mode_info, not the proc_info, because new vars may
- % have been introduced during mode analysis (e.g., when adding
- % unifications to handle implied modes).
- mode_info_get_varset(!.ModeInfo, VarSet0),
- mode_info_get_var_types(!.ModeInfo, VarTypes0),
- proc_info_set_varset(VarSet0, ProcInfo0, ProcInfo1),
- proc_info_set_vartypes(VarTypes0, ProcInfo1, ProcInfo2),
- polymorphism.create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2,
- PolyInfo0),
-
- % Create a goal_info for the call.
- goal_info_init(GoalInfo0),
- goal_info_set_context(Context, GoalInfo0, GoalInfo1),
- goal_info_set_nonlocals(NonLocals, GoalInfo1, GoalInfo2),
- goal_info_set_instmap_delta(InstMapDelta, GoalInfo2, GoalInfo),
-
- % Do the transformation for this call goal.
- SymName = qualified(CalleeModuleName, CalleePredName),
- polymorphism_process_new_call(CalleePredInfo, CalleeProcInfo,
- CalleePredId, CalleeProcId, ArgVars, not_builtin,
- MaybeCallUnifyContext, SymName, GoalInfo, Goal, PolyInfo0, PolyInfo),
-
- % Update the information in the predicate table.
- polymorphism.poly_info_extract(PolyInfo, PredInfo0, PredInfo,
- ProcInfo2, ProcInfo, ModuleInfo1),
- module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
- ModuleInfo1, ModuleInfo),
-
- % Update the information in the mode_info.
- proc_info_get_varset(ProcInfo, VarSet),
- proc_info_get_vartypes(ProcInfo, VarTypes),
- mode_info_set_varset(VarSet, !ModeInfo),
- mode_info_set_var_types(VarTypes, !ModeInfo),
- mode_info_set_module_info(ModuleInfo, !ModeInfo).
-
-%-----------------------------------------------------------------------------%
-
-mode_context_to_unify_context(_ModeInfo, ModeContext, UnifyContext) :-
- (
- ModeContext = mode_context_unify(UnifyContext, _)
- ;
- ModeContext = mode_context_call(CallId, Arg),
- UnifyContext = unify_context(umc_call(CallId, Arg), [])
- ;
- ModeContext = mode_context_uninitialized,
- unexpected(this_file,
- "mode_context_to_unify_context: uninitialized context")
- ).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
- % Check that the evaluation method is OK for the given mode(s).
- % We also check the mode of main/2 here.
- %
-:- pred check_eval_methods(module_info::in, module_info::out,
- list(error_spec)::in, list(error_spec)::out) is det.
-
-check_eval_methods(!ModuleInfo, !Specs) :-
- module_info_predids(PredIds, !ModuleInfo),
- pred_check_eval_methods(!.ModuleInfo, PredIds, !Specs).
-
-:- pred pred_check_eval_methods(module_info::in, list(pred_id)::in,
- list(error_spec)::in, list(error_spec)::out) is det.
-
-pred_check_eval_methods(_, [], !Specs).
-pred_check_eval_methods(ModuleInfo, [PredId | PredIds], !Specs) :-
- module_info_preds(ModuleInfo, Preds),
- map.lookup(Preds, PredId, PredInfo),
- ProcIds = pred_info_procids(PredInfo),
- proc_check_eval_methods(ModuleInfo, PredId, ProcIds, !Specs),
- pred_check_eval_methods(ModuleInfo, PredIds, !Specs).
-
-:- pred proc_check_eval_methods(module_info::in, pred_id::in,
- list(proc_id)::in, list(error_spec)::in, list(error_spec)::out) is det.
-
-proc_check_eval_methods(_, _, [], !Specs).
-proc_check_eval_methods(ModuleInfo, PredId, [ProcId | ProcIds], !Specs) :-
- module_info_pred_proc_info(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo),
- proc_info_get_eval_method(ProcInfo, EvalMethod),
- proc_info_get_argmodes(ProcInfo, Modes),
- (
- eval_method_requires_ground_args(EvalMethod) = yes,
- \+ only_fully_in_out_modes(Modes, ModuleInfo)
- ->
- GroundArgsSpec = report_eval_method_requires_ground_args(ProcInfo),
- !:Specs = [GroundArgsSpec | !.Specs]
- ;
- true
- ),
- (
- eval_method_destroys_uniqueness(EvalMethod) = yes,
- \+ only_nonunique_modes(Modes, ModuleInfo)
- ->
- UniquenessSpec = report_eval_method_destroys_uniqueness(ProcInfo),
- !:Specs = [UniquenessSpec | !.Specs]
- ;
- true
- ),
- (
- pred_info_name(PredInfo) = "main",
- pred_info_orig_arity(PredInfo) = 2,
- pred_info_is_exported(PredInfo),
- \+ check_mode_of_main(Modes, ModuleInfo)
- ->
- MainSpec = report_wrong_mode_for_main(ProcInfo),
- !:Specs = [MainSpec | !.Specs]
- ;
- true
- ),
- proc_check_eval_methods(ModuleInfo, PredId, ProcIds, !Specs).
-
-:- pred only_fully_in_out_modes(list(mer_mode)::in, module_info::in)
- is semidet.
-
-only_fully_in_out_modes([], _).
-only_fully_in_out_modes([Mode | Rest], ModuleInfo) :-
- mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
- (
- inst_is_ground(ModuleInfo, InitialInst)
- ;
- inst_is_free(ModuleInfo, InitialInst),
- (
- inst_is_free(ModuleInfo, FinalInst)
- ;
- inst_is_ground(ModuleInfo, FinalInst)
- )
- ),
- only_fully_in_out_modes(Rest, ModuleInfo).
-
-:- pred only_nonunique_modes(list(mer_mode)::in, module_info::in) is semidet.
-
-only_nonunique_modes([], _).
-only_nonunique_modes([Mode | Rest], ModuleInfo) :-
- mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
- inst_is_not_partly_unique(ModuleInfo, InitialInst),
- inst_is_not_partly_unique(ModuleInfo, FinalInst),
- only_nonunique_modes(Rest, ModuleInfo).
-
-:- pred check_mode_of_main(list(mer_mode)::in, module_info::in) is semidet.
-
-check_mode_of_main([Di, Uo], ModuleInfo) :-
- mode_get_insts(ModuleInfo, Di, DiInitialInst, DiFinalInst),
- mode_get_insts(ModuleInfo, Uo, UoInitialInst, UoFinalInst),
- %
- % Note that we hard-code these tests,
- % rather than using `inst_is_free', `inst_is_unique', etc.,
- % since for main/2 we're looking for an exact match
- % (modulo inst synonyms) with what the language reference
- % manual specifies, rather than looking for a particular
- % abstract property.
- %
- inst_expand(ModuleInfo, DiInitialInst, ground(unique, none)),
- inst_expand(ModuleInfo, DiFinalInst, ground(clobbered, none)),
- inst_expand(ModuleInfo, UoInitialInst, Free),
- ( Free = free ; Free = free(_Type) ),
- inst_expand(ModuleInfo, UoFinalInst, ground(unique, none)).
-
-:- func report_eval_method_requires_ground_args(proc_info) = error_spec.
+:- func report_eval_method_requires_ground_args(proc_info) = error_spec.
report_eval_method_requires_ground_args(ProcInfo) = Spec :-
proc_info_get_eval_method(ProcInfo, EvalMethod),
@@ -4551,24 +1408,6 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-get_live_vars([], [], []).
-get_live_vars([_ | _], [], _) :-
- unexpected(this_file, "get_live_vars: length mismatch").
-get_live_vars([], [_ | _], _) :-
- unexpected(this_file, "get_live_vars: length mismatch").
-get_live_vars([Var | Vars], [IsLive | IsLives], LiveVars) :-
- (
- IsLive = is_live,
- LiveVars = [Var | LiveVars0]
- ;
- IsLive = is_dead,
- LiveVars = LiveVars0
- ),
- get_live_vars(Vars, IsLives, LiveVars0).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
:- func this_file = string.
this_file = "modes.m".
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.219
diff -u -b -r1.219 prog_data.m
--- compiler/prog_data.m 3 Sep 2009 23:07:29 -0000 1.219
+++ compiler/prog_data.m 24 Sep 2009 04:01:40 -0000
@@ -1704,8 +1704,8 @@
%
:- type unify_compare
---> unify_compare(
- unify :: maybe(equality_pred),
- compare :: maybe(comparison_pred)
+ uc_unify :: maybe(equality_pred),
+ uc_compare :: maybe(comparison_pred)
)
; abstract_noncanonical_type(is_solver_type).
@@ -1719,17 +1719,17 @@
%
:- type solver_type_details
---> solver_type_details(
- representation_type :: mer_type,
- init_pred :: solver_type_init,
- ground_inst :: mer_inst,
- any_inst :: mer_inst,
- mutable_items :: list(item)
+ std_representation_type :: mer_type,
+ std_init_pred :: solver_type_init,
+ std_ground_inst :: mer_inst,
+ std_any_inst :: mer_inst,
+ std_mutable_items :: list(item)
).
% An init_pred specifies the name of an impure user-defined predicate
- % used to initialise solver type values (the compiler will insert
- % calls to this predicate to convert free solver type variables to
- % inst any variables where necessary.)
+ % used to initialise solver type values (the compiler will insert calls
+ % to this predicate to convert free solver type variables to inst any
+ % variables where necessary.)
%
:- type init_pred == sym_name.
Index: compiler/prog_io_type_defn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_type_defn.m,v
retrieving revision 1.2
diff -u -b -r1.2 prog_io_type_defn.m
--- compiler/prog_io_type_defn.m 8 Sep 2009 02:43:37 -0000 1.2
+++ compiler/prog_io_type_defn.m 24 Sep 2009 04:23:33 -0000
@@ -567,7 +567,7 @@
;
MaybeNameParams = ok2(Name, Params),
(
- RepnType = SolverTypeDetails ^ representation_type,
+ RepnType = SolverTypeDetails ^ std_representation_type,
type_contains_var(RepnType, Var),
not list.member(Var, Params)
->
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.91
diff -u -b -r1.91 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 21 Sep 2009 04:08:58 -0000 1.91
+++ compiler/rtti_to_mlds.m 23 Sep 2009 16:38:52 -0000
@@ -59,6 +59,7 @@
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ml_closure_gen.
:- import_module ml_backend.ml_code_util.
+:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.ml_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.100
diff -u -b -r1.100 type_ctor_info.m
--- compiler/type_ctor_info.m 4 Sep 2009 02:27:55 -0000 1.100
+++ compiler/type_ctor_info.m 24 Sep 2009 04:03:50 -0000
@@ -347,7 +347,7 @@
% types for RTTI purposes. Which may cause problems with construct,
% similar to those for abstract types.
TypeBody = hlds_solver_type(SolverTypeDetails, _MaybeUserEqComp),
- RepnType = SolverTypeDetails ^ representation_type,
+ RepnType = SolverTypeDetails ^ std_representation_type,
% There can be no existentially typed args to an equivalence.
UnivTvars = TypeArity,
ExistTvars = [],
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.202
diff -u -b -r1.202 type_util.m
--- compiler/type_util.m 14 Sep 2009 02:57:57 -0000 1.202
+++ compiler/type_util.m 24 Sep 2009 04:07:41 -0000
@@ -83,6 +83,8 @@
:- pred type_definitely_has_no_user_defined_equality_pred(module_info::in,
mer_type::in) is semidet.
+:- pred is_solver_var(vartypes::in, module_info::in, prog_var::in) is semidet.
+
% Succeed iff the principal type constructor for the given type is
% declared a solver type, or if the type is a pred or func type. Pred
% and func types are considered solver types because higher-order terms
@@ -528,6 +530,10 @@
list.foldl(type_definitely_has_no_user_defined_eq_pred_2(ModuleInfo),
ArgTypes, !SeenTypes).
+is_solver_var(VarTypes, ModuleInfo, Var) :-
+ map.lookup(VarTypes, Var, VarType),
+ type_is_solver_type(ModuleInfo, VarType).
+
type_is_solver_type_with_auto_init(ModuleInfo, Type) :-
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
(
@@ -548,7 +554,7 @@
TypeBody = hlds_eqv_type(ActualType)
),
type_has_solver_type_details(ModuleInfo, ActualType, SolverTypeDetails),
- SolverTypeDetails ^ init_pred = solver_init_automatic(_).
+ SolverTypeDetails ^ std_init_pred = solver_init_automatic(_).
type_is_solver_type(ModuleInfo, Type) :-
(
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.210
diff -u -b -r1.210 unify_proc.m
--- compiler/unify_proc.m 24 Sep 2009 07:53:09 -0000 1.210
+++ compiler/unify_proc.m 25 Sep 2009 03:45:39 -0000
@@ -603,7 +603,7 @@
% (The pred_id and proc_id will be figured out by type checking
% and mode analysis.)
- HowToInit = SolverTypeDetails ^ init_pred,
+ HowToInit = SolverTypeDetails ^ std_init_pred,
(
HowToInit = solver_init_automatic(InitPred)
;
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.132
diff -u -b -r1.132 unique_modes.m
--- compiler/unique_modes.m 21 Jul 2009 02:08:50 -0000 1.132
+++ compiler/unique_modes.m 24 Sep 2009 04:09:45 -0000
@@ -83,12 +83,13 @@
:- import_module check_hlds.inst_match.
:- import_module check_hlds.inst_util.
-:- import_module check_hlds.modecheck_call.
-:- import_module check_hlds.modecheck_unify.
:- import_module check_hlds.mode_debug.
:- import_module check_hlds.mode_errors.
-:- import_module check_hlds.modes.
:- import_module check_hlds.mode_util.
+:- import_module check_hlds.modecheck_call.
+:- import_module check_hlds.modecheck_unify.
+:- import_module check_hlds.modecheck_util.
+:- import_module check_hlds.modes.
:- import_module hlds.instmap.
:- import_module libs.
:- import_module libs.compiler_util.
@@ -1003,7 +1004,7 @@
),
mode_info_get_instmap(!.ModeInfo, InstMap),
- fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal),
+ fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal1, Goal),
Case = case(MainConsId, OtherConsIds, Goal),
mode_info_set_instmap(InstMap0, !ModeInfo),
cvs diff: Diffing compiler/notes
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.146
diff -u -b -r1.146 compiler_design.html
--- compiler/notes/compiler_design.html 21 Sep 2009 04:09:05 -0000 1.146
+++ compiler/notes/compiler_design.html 24 Sep 2009 04:35:25 -0000
@@ -766,11 +766,17 @@
<dd>
<ul>
- <li> modes.m is the main mode analysis module.
- It checks that the code is mode-correct, reordering it
- if necessary, and annotates each goal with a delta-instmap
+ <li> modes.m is the top analysis module.
+ It checks that procedures are mode-correct.
+ <li> modecheck_goal.m does most of the work.
+ It handles the tasks that are common to all kinds of goals,
+ including annotating each goal with a delta-instmap
that specifies the changes in instantiatedness of each
- variable over that goal.
+ variable over that goal, and does the analysis of several
+ kinds of goals.
+ <li> modecheck_conj.m is the sub-module which analyses conjunctions
+ It reorders code as necessary.
+ unification goals.
<li> modecheck_unify.m is the sub-module which analyses
unification goals.
It also module qualifies data constructors.
@@ -782,13 +788,15 @@
<dl>
<dt> mode_info.m
<dd>
- (the main data structure for mode analysis)
+ The main data structure for mode analysis.
<dt> delay_info.m
<dd>
- (a sub-component of the mode_info data
+ A sub-component of the mode_info data
structure used for storing the information
for scheduling: which goals are currently
- delayed, what variables they are delayed on, etc.)
+ delayed, what variables they are delayed on, etc.
+ <dt> modecheck_util.m
+ <dd> Utility predicates useful during mode analysis.
<dt> instmap.m (XXX in the hlds.m package)
<dd>
Defines the instmap and instmap_delta ADTs
@@ -805,7 +813,7 @@
<dt> mode_errors.m
<dd>
This module contains all the code to
- print error messages for mode errors
+ generate error messages for mode errors
</dl>
<li> mode_util.m contains miscellaneous useful predicates dealing
with modes (many of these are used by lots of later stages
@@ -1549,12 +1557,17 @@
<h4> 4b. MLDS code generation </h4>
<ul>
-<li> ml_code_gen.m converts HLDS code to MLDS.
- The following sub-modules are used to handle different constructs:
+<li> ml_proc_gen.m is the top module of the package that converts HLDS code
+ to MLDS. Its main submodule is ml_code_gen.m, which handles the tasks
+ common to all kinds of goals, as well as the tasks specific to some
+ goals (conjunctions, disjunctions, if-then-elses, negations). For other
+ kinds of goals, ml_code_gen.m invokes some other submodules:
<ul>
<li> ml_unify_gen.m
<li> ml_closure_gen.m
<li> ml_call_gen.m
+ <li> ml_foreign_proc_gen.m
+ <li> ml_commit_gen.m
<li> ml_switch_gen.m, which calls upon:
<ul>
<li> ml_lookup_switch.m
@@ -1566,9 +1579,11 @@
</ul>
</ul>
The main data structure used by the MLDS code generator is defined
- in ml_code_util.m, while global data structures (those created at
+ in ml_gen_info.m, while global data structures (those created at
module scope) are handled in ml_global_data.m.
- The module ml_util.m provides some general utility routines.
+ The module ml_accurate_gc.m handles provisions for accurate garbage
+ collection, while the modules ml_code_util.m and ml_util.m provide
+ some general utility routines.
<li> ml_type_gen.m converts HLDS types to MLDS.
<li> type_ctor_info.m and base_typeclass_info.m generate
the RTTI data structures defined in rtti.m and pseudo_type_info.m
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/fixed
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/log4m
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/mopenssl
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/net
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/posix/samples
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/standalone_c
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing ssdb
cvs diff: Diffing tests
cvs diff: Diffing tests/analysis
cvs diff: Diffing tests/analysis/ctgc
cvs diff: Diffing tests/analysis/excp
cvs diff: Diffing tests/analysis/ext
cvs diff: Diffing tests/analysis/sharing
cvs diff: Diffing tests/analysis/table
cvs diff: Diffing tests/analysis/trail
cvs diff: Diffing tests/analysis/unused_args
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/stm
cvs diff: Diffing tests/stm/orig
cvs diff: Diffing tests/stm/orig/stm-compiler
cvs diff: Diffing tests/stm/orig/stm-compiler/test1
cvs diff: Diffing tests/stm/orig/stm-compiler/test10
cvs diff: Diffing tests/stm/orig/stm-compiler/test2
cvs diff: Diffing tests/stm/orig/stm-compiler/test3
cvs diff: Diffing tests/stm/orig/stm-compiler/test4
cvs diff: Diffing tests/stm/orig/stm-compiler/test5
cvs diff: Diffing tests/stm/orig/stm-compiler/test6
cvs diff: Diffing tests/stm/orig/stm-compiler/test7
cvs diff: Diffing tests/stm/orig/stm-compiler/test8
cvs diff: Diffing tests/stm/orig/stm-compiler/test9
cvs diff: Diffing tests/stm/orig/stm-compiler-par
cvs diff: Diffing tests/stm/orig/stm-compiler-par/bm1
cvs diff: Diffing tests/stm/orig/stm-compiler-par/bm2
cvs diff: Diffing tests/stm/orig/stm-compiler-par/stmqueue
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test1
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test10
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test11
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test2
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test3
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test4
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test5
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test6
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test7
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test8
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test9
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test1
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test2
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test3
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test4
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test5
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test6
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test7
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test8
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test9
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list