[m-rev.] Re: for review: static terms in the MLDS backend
Zoltan Somogyi
zs at csse.unimelb.edu.au
Mon Aug 31 12:00:57 AEST 2009
On 31-Aug-2009, Zoltan Somogyi <zs at cs.mu.oz.au> wrote:
> I intend to commit this diff tomorrow morning (sep 1). Reviews are welcome
> both before and after then.
I forgot the diff; here it is.
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/analysis.file.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/analysis.file.m,v
retrieving revision 1.10
diff -u -b -r1.10 analysis.file.m
--- compiler/analysis.file.m 2 Dec 2008 04:30:23 -0000 1.10
+++ compiler/analysis.file.m 28 Aug 2009 11:49:14 -0000
@@ -519,7 +519,7 @@
:- pred parse_module_name(term::in, module_name::out) is semidet.
parse_module_name(Term, ModuleName) :-
- sym_name_and_args(Term, ModuleName, []).
+ parse_sym_name_and_args(Term, ModuleName, []).
%-----------------------------------------------------------------------------%
Index: compiler/deep_profiling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deep_profiling.m,v
retrieving revision 1.99
diff -u -b -r1.99 deep_profiling.m
--- compiler/deep_profiling.m 30 Aug 2009 22:59:21 -0000 1.99
+++ compiler/deep_profiling.m 30 Aug 2009 23:15:37 -0000
@@ -1738,7 +1738,7 @@
goal_info_set_mdprof_inst(goal_is_mdprof_inst, GoalInfo1, GoalInfo),
GoalExpr = unify(Var, rhs_functor(ConsId, no, []),
(free -> Ground) - (Ground -> Ground),
- construct(Var, ConsId, [], [], construct_statically([]),
+ construct(Var, ConsId, [], [], construct_statically,
cell_is_shared, no_construct_sub_info),
unify_context(umc_explicit, [])),
Goal = hlds_goal(GoalExpr, GoalInfo).
@@ -1758,7 +1758,7 @@
GoalExpr = unify(Var, rhs_functor(ConsId, no, Args),
(free -> Ground) - (Ground -> Ground),
construct(Var, ConsId, Args, ArgModes,
- construct_statically([]), cell_is_shared, no_construct_sub_info),
+ construct_statically, cell_is_shared, no_construct_sub_info),
unify_context(umc_explicit, [])),
Goal = hlds_goal(GoalExpr, GoalInfo).
Index: compiler/field_access.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/field_access.m,v
retrieving revision 1.15
diff -u -b -r1.15 field_access.m
--- compiler/field_access.m 11 Jun 2009 07:00:08 -0000 1.15
+++ compiler/field_access.m 28 Aug 2009 11:49:14 -0000
@@ -303,7 +303,7 @@
[FieldNameTerm, OtherFieldNamesTerm], _)
->
(
- sym_name_and_args(FieldNameTerm, FieldName, Args)
+ parse_sym_name_and_args(FieldNameTerm, FieldName, Args)
->
parse_field_list(OtherFieldNamesTerm, VarSet, ContextPieces,
MaybeFieldNamesTail),
@@ -320,7 +320,7 @@
MaybeFieldNames = error1([Spec])
)
;
- ( sym_name_and_args(Term, FieldName, Args) ->
+ ( parse_sym_name_and_args(Term, FieldName, Args) ->
MaybeFieldNames = ok1([FieldName - Args])
;
Spec = make_field_list_error(VarSet, get_term_context(Term), Term,
Index: compiler/globals.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/globals.m,v
retrieving revision 1.91
diff -u -b -r1.91 globals.m
--- compiler/globals.m 3 Feb 2009 06:25:04 -0000 1.91
+++ compiler/globals.m 28 Aug 2009 11:49:14 -0000
@@ -157,14 +157,22 @@
%-----------------------------------------------------------------------------%
%
-% Access predicates for the `globals' structure
+% Access predicates for the `globals' structure.
%
+:- type il_version_number
+ ---> il_version_number(
+ ivn_major :: int,
+ ivn_minor :: int,
+ ivn_build :: int,
+ ivn_revision :: int
+ ).
+
:- pred globals_init(option_table::in, compilation_target::in, gc_method::in,
tags_method::in, termination_norm::in, termination_norm::in,
trace_level::in, trace_suppress_items::in,
- may_be_thread_safe::in, c_compiler_type::in, feedback_info::in,
- globals::out) is det.
+ may_be_thread_safe::in, c_compiler_type::in, maybe(il_version_number)::in,
+ feedback_info::in, globals::out) is det.
:- pred get_options(globals::in, option_table::out) is det.
:- pred get_target(globals::in, compilation_target::out) is det.
@@ -179,6 +187,8 @@
:- pred get_source_file_map(globals::in, maybe(source_file_map)::out) is det.
:- pred get_maybe_thread_safe(globals::in, may_be_thread_safe::out) is det.
:- pred get_c_compiler_type(globals::in, c_compiler_type::out) is det.
+:- pred get_maybe_il_version_number(globals::in, maybe(il_version_number)::out)
+ is det.
:- pred get_feedback_info(globals::in, feedback_info::out) is det.
:- pred set_option(option::in, option_data::in, globals::in, globals::out)
@@ -239,8 +249,8 @@
:- pred globals_io_init(option_table::in, compilation_target::in,
gc_method::in, tags_method::in, termination_norm::in,
termination_norm::in, trace_level::in, trace_suppress_items::in,
- may_be_thread_safe::in, c_compiler_type::in, feedback_info::in,
- io::di, io::uo) is det.
+ may_be_thread_safe::in, c_compiler_type::in, maybe(il_version_number)::in,
+ feedback_info::in, io::di, io::uo) is det.
:- pred io_get_target(compilation_target::out, io::di, io::uo) is det.
:- pred io_get_backend_foreign_languages(list(foreign_language)::out,
@@ -490,6 +500,7 @@
have_printed_usage :: bool,
may_be_thread_safe :: bool,
c_compiler_type :: c_compiler_type,
+ maybe_il_version_number :: maybe(il_version_number),
feedback :: feedback_info
).
@@ -517,10 +528,10 @@
globals_init(Options, Target, GC_Method, TagsMethod,
TerminationNorm, Termination2Norm, TraceLevel, TraceSuppress,
- MaybeThreadSafe, C_CompilerType, Feedback, Globals) :-
+ MaybeThreadSafe, C_CompilerType, MaybeILVersion, Feedback, Globals) :-
Globals = globals(Options, Target, GC_Method, TagsMethod,
TerminationNorm, Termination2Norm, TraceLevel, TraceSuppress,
- no, no, MaybeThreadSafe, C_CompilerType, Feedback).
+ no, no, MaybeThreadSafe, C_CompilerType, MaybeILVersion, Feedback).
get_options(Globals, Globals ^ options).
get_target(Globals, Globals ^ target).
@@ -533,6 +544,7 @@
get_source_file_map(Globals, Globals ^ source_file_map).
get_maybe_thread_safe(Globals, Globals ^ may_be_thread_safe).
get_c_compiler_type(Globals, Globals ^ c_compiler_type).
+get_maybe_il_version_number(Globals, Globals ^ maybe_il_version_number).
get_feedback_info(Globals, Globals ^ feedback).
get_backend_foreign_languages(Globals, ForeignLangs) :-
@@ -702,10 +714,11 @@
globals_io_init(Options, Target, GC_Method, TagsMethod, TerminationNorm,
Termination2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, Feedback, !IO) :-
+ C_CompilerType, MaybeILVersion, Feedback, !IO) :-
globals_init(Options, Target, GC_Method, TagsMethod,
TerminationNorm, Termination2Norm, TraceLevel,
- TraceSuppress, MaybeThreadSafe, C_CompilerType, Feedback, Globals),
+ TraceSuppress, MaybeThreadSafe, C_CompilerType, MaybeILVersion,
+ Feedback, Globals),
io_set_globals(Globals, !IO),
getopt_io.lookup_bool_option(Options, solver_type_auto_init,
AutoInitSupported),
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.168
diff -u -b -r1.168 goal_util.m
--- compiler/goal_util.m 11 Jun 2009 08:28:25 -0000 1.168
+++ compiler/goal_util.m 31 Aug 2009 00:33:53 -0000
@@ -89,15 +89,19 @@
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
prog_var_renaming::in, prog_var_renaming::out) is det.
- % Return all the variables in the goal.
+ % Return all the variables in the goal or goal expression.
% Unlike quantification.goal_vars, this predicate returns
% even the explicitly quantified variables.
%
+ % Warning: the complexity of this predicate is proportionial to the
+ % size of the goal. Goals can be pretty big. Whatever you want to do,
+ % if you have a way to do it *without* calling the predicate, you will
+ % probably want to it that way.
+ %
:- pred goal_vars(hlds_goal::in, set(prog_var)::out) is det.
- % Return all the variables in the list of goals.
- % Unlike quantification.goal_vars, this predicate returns
- % even the explicitly quantified variables.
+ % Do the same job as goal_vars, but for a list of goals, and adding
+ % the goal's variables to the accumulator.
%
:- pred goals_goal_vars(list(hlds_goal)::in,
set(prog_var)::in, set(prog_var)::out) is det.
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.339
diff -u -b -r1.339 handle_options.m
--- compiler/handle_options.m 26 Aug 2009 04:16:16 -0000 1.339
+++ compiler/handle_options.m 30 Aug 2009 23:15:37 -0000
@@ -115,7 +115,8 @@
postprocess_options(Result, Errors, !IO),
(
Errors = [_ | _],
- Link = no
+ Link = no,
+ io.set_exit_status(1, !IO)
;
Errors = [],
globals.io_lookup_bool_option(generate_dependencies,
@@ -194,13 +195,14 @@
postprocess_options(ok(OptionTable0), Errors, !IO) :-
check_option_values(OptionTable0, OptionTable, Target, GC_Method,
TagsMethod, TermNorm, Term2Norm, TraceLevel, TraceSuppress,
- MaybeThreadSafe, C_CompilerType, FeedbackInfo, [], CheckErrors, !IO),
+ MaybeThreadSafe, C_CompilerType, MaybeILVersion, FeedbackInfo,
+ [], CheckErrors, !IO),
(
CheckErrors = [],
postprocess_options_2(OptionTable, Target, GC_Method,
TagsMethod, TermNorm, Term2Norm, TraceLevel,
- TraceSuppress, MaybeThreadSafe, C_CompilerType, FeedbackInfo,
- [], Errors, !IO)
+ TraceSuppress, MaybeThreadSafe, C_CompilerType, MaybeILVersion,
+ FeedbackInfo, [], Errors, !IO)
;
CheckErrors = [_ | _],
Errors = CheckErrors
@@ -210,12 +212,12 @@
compilation_target::out, gc_method::out, tags_method::out,
termination_norm::out, termination_norm::out, trace_level::out,
trace_suppress_items::out, may_be_thread_safe::out,
- c_compiler_type::out, feedback_info::out,
+ c_compiler_type::out, maybe(il_version_number)::out, feedback_info::out,
list(string)::in, list(string)::out, io::di, io::uo) is det.
check_option_values(!OptionTable, Target, GC_Method, TagsMethod,
TermNorm, Term2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, FeedbackInfo, !Errors, !IO) :-
+ C_CompilerType, MaybeILVersion, FeedbackInfo, !Errors, !IO) :-
map.lookup(!.OptionTable, target, Target0),
(
Target0 = string(TargetStr),
@@ -358,10 +360,35 @@
C_CompilerType = C_CompilerTypePrime
;
C_CompilerType = cc_unknown, % dummy
- add_error("Invalid argument to option " ++
- "`--c-compiler-type'\n\t(must be" ++
- "`gcc', `lcc', `cl, or `unknown').", !Errors)
+ add_error("Invalid argument to " ++
+ "option `--c-compiler-type'\n" ++
+ "\t(must be `gcc', `lcc', `cl', or `unknown').",
+ !Errors)
),
+
+ map.lookup(!.OptionTable, dotnet_library_version, DotNetLibVersionOpt),
+ (
+ DotNetLibVersionOpt = string(DotNetLibVersionStr),
+ IsSep = (pred(('.')::in) is semidet),
+ string.words_separator(IsSep, DotNetLibVersionStr) = [Mj, Mn, Bu, Rv],
+ string.to_int(Mj, Major),
+ string.to_int(Mn, Minor),
+ string.to_int(Bu, Build),
+ string.to_int(Rv, Revision)
+ ->
+ ILVersion = il_version_number(Major, Minor, Build, Revision),
+ MaybeILVersion = yes(ILVersion)
+ ;
+ MaybeILVersion = no,
+ add_error("Invalid argument to " ++
+ "option `--dotnet-library-version'\n" ++
+ "\t(must be of the form " ++
+ "`MajorNum.MinorNum.BuildNum.RevisionNum').",
+ !Errors),
+ % The IL code generator cannot handle the IL version being unknown.
+ svmap.det_update(errorcheck_only, bool(yes), !OptionTable)
+ ),
+
map.lookup(!.OptionTable, feedback_file, FeedbackFile0),
(
FeedbackFile0 = string(FeedbackFile),
@@ -393,15 +420,16 @@
:- pred postprocess_options_2(option_table::in, compilation_target::in,
gc_method::in, tags_method::in, termination_norm::in,
termination_norm::in, trace_level::in, trace_suppress_items::in,
- may_be_thread_safe::in, c_compiler_type::in, feedback_info::in,
- list(string)::in, list(string)::out, io::di, io::uo) is det.
+ may_be_thread_safe::in, c_compiler_type::in, maybe(il_version_number)::in,
+ feedback_info::in, list(string)::in, list(string)::out,
+ io::di, io::uo) is det.
postprocess_options_2(OptionTable0, Target, GC_Method, TagsMethod0,
TermNorm, Term2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, FeedbackInfo, !Errors, !IO) :-
+ C_CompilerType, MaybeILVersion, FeedbackInfo, !Errors, !IO) :-
globals_io_init(OptionTable0, Target, GC_Method, TagsMethod0,
TermNorm, Term2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, FeedbackInfo, !IO),
+ C_CompilerType, MaybeILVersion, FeedbackInfo, !IO),
some [!Globals] (
globals.io_get_globals(!:Globals, !IO),
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.209
diff -u -b -r1.209 hlds_goal.m
--- compiler/hlds_goal.m 25 Aug 2009 23:46:47 -0000 1.209
+++ compiler/hlds_goal.m 28 Aug 2009 11:49:14 -0000
@@ -470,8 +470,8 @@
% superhomogeneous form. The variable specifies what the
% compiler calls that ground term.
%
- % This kind of scope is not intended to be meaningful after
- % mode analysis, and should be removed after mode analysis.
+ % This kind of scope is intended to be meaningful after
+ % mode analysis only if Kind = from_ground_term_construct.
; trace_goal(
trace_compiletime :: maybe(trace_expr(trace_compiletime)),
@@ -650,29 +650,33 @@
---> rhs_var(prog_var)
; rhs_functor(
rhs_functor :: cons_id,
+ % The `is_existential_construction' field is only used
+ % after polymorphism.m strips off the `new ' prefix from
+ % existentially typed constructions.
rhs_is_exist_constr :: is_existential_construction,
- % The `is_existential_construction' field
- % is only used after polymorphism.m strips
- % off the `new ' prefix from existentially
- % typed constructions.
rhs_args :: list(prog_var)
)
; rhs_lambda_goal(
rhs_purity :: purity,
+
+ % Whether this closure is `ground' or `any'.
rhs_groundness :: ho_groundness,
- % Whether this closure is `ground' or
- % `any'.
+
rhs_p_or_f :: pred_or_func,
+
+ % Currently, we don't support any other value than `normal'.
rhs_eval_method :: lambda_eval_method,
- % Currently, we don't support any other
- % value than `normal'.
+
+ % Non-locals of the goal excluding the lambda quantified
+ % variables.
rhs_nonlocals :: list(prog_var),
- % Non-locals of the goal excluding
- % the lambda quantified variables.
- rhs_lambda_quant_vars :: list(prog_var),
+
% Lambda quantified variables.
- rhs_lambda_modes :: list(mer_mode),
+ rhs_lambda_quant_vars :: list(prog_var),
+
% Modes of the lambda quantified variables.
+ rhs_lambda_modes :: list(mer_mode),
+
rhs_detism :: determinism,
rhs_lambda_goal :: hlds_goal
).
@@ -716,42 +720,31 @@
% e.g. Y = f(X) where the top node of Y is output,
% Constructions are written using `:=', e.g. Y := f(X).
+ % The variable being constructed, e.g. Y in above example.
construct_cell_var :: prog_var,
- % The variable being constructed,
- % e.g. Y in above example.
+ % The cons_id of the functor f/1 in the above example.
construct_cons_id :: cons_id,
- % The cons_id of the functor
- % f/1 in the above example.
+ % The list of argument variables; [X] in the above example.
+ % For a unification with a lambda expression, this is the list
+ % of the non-local variables of the lambda expression.
construct_args :: list(prog_var),
- % The list of argument variables
- % [X] in the above example
- % For a unification with a lambda
- % expression, this is the list of
- % the non-local variables of the
- % lambda expression.
+ % The list of modes of the arguments sub-unifications.
+ % For a unification with a lambda expression, this is the list
+ % of modes of the non-local variables of the lambda expression.
construct_arg_modes :: list(uni_mode),
- % The list of modes of the arguments
- % sub-unifications.
- % For a unification with a lambda
- % expression, this is the list of
- % modes of the non-local variables
- % of the lambda expression.
+ % Specify whether to allocate statically, to allocate
+ % dynamically (and if so, on the heap or in a region),
+ % or to reuse an existing cell (and if so, which cell).
+ % Constructions for which this field is `reuse_cell(_)'
+ % are described as "reconstructions".
construct_how :: how_to_construct,
- % Specify whether to allocate
- % statically, to allocate dynamically,
- % or to reuse an existing cell
- % (and if so, which cell).
- % Constructions for which this
- % field is `reuse_cell(_)' are
- % described as "reconstructions".
+ % Can the cell be allocated in shared data.
construct_is_unique :: cell_is_unique,
- % Can the cell be allocated
- % in shared data.
construct_sub_info :: construct_sub_info
)
@@ -764,30 +757,24 @@
% Note that deconstruction of lambda expressions is
% a mode error.
+ % The variable being deconstructed, e.g. Y in the example.
deconstruct_cell_var :: prog_var,
- % The variable being deconstructed
- % e.g. Y in the above example.
+ % The cons_id of the functor, e.g. f/1 in the example.
deconstruct_cons_id :: cons_id,
- % The cons_id of the functor,
- % e.g. f/1 in the above example
+ % The list of argument variables, e.g. [X] in the example.
deconstruct_args :: list(prog_var),
- % The list of argument variables,
- % e.g. [X] in the above example.
+ % The lists of modes of the argument sub-unifications.
deconstruct_arg_modes :: list(uni_mode),
- % The lists of modes of the argument
- % sub-unifications.
+ % Whether or not the unification could possibly fail.
deconstruct_can_fail :: can_fail,
- % Whether or not the unification
- % could possibly fail.
- deconstruct_can_cgc :: can_cgc
- % Can compile time GC this cell,
- % i.e. explicitly deallocate it
+ % Can compile time GC this cell, i.e. explicitly deallocate it
% after the deconstruction.
+ deconstruct_can_cgc :: can_cgc
)
; assign(
@@ -800,7 +787,7 @@
; simple_test(
% Y = X where the type of X and Y is an atomic type and
% they are both input, written Y == X.
- %
+
test_var1 :: prog_var,
test_var2 :: prog_var
)
@@ -812,12 +799,11 @@
% out-of-line call to a compiler generated unification
% predicate for that type & mode.
- compl_unify_mode :: uni_mode,
% The mode of the unification.
+ compl_unify_mode :: uni_mode,
+ % Whether or not it could possibly fail.
compl_unify_can_fail :: can_fail,
- % Whether or not it could possibly
- % fail.
% When unifying polymorphic types such as map/2, we need to
% pass type_info variables to the unification procedure for
@@ -831,10 +817,9 @@
% It is also checked by simplify.m when it converts
% complicated unifications into procedure calls.
+ % The type_info variables needed by this unification,
+ % if it ends up being a complicated unify.
compl_unify_typeinfos :: list(prog_var)
- % The type_info variables needed
- % by this unification, if it ends up
- % being a complicated unify.
).
:- type term_size_value
@@ -924,10 +909,8 @@
% back-end, the same optimization is handled by var_locn.m).
%
:- type how_to_construct
- ---> construct_statically(
- % Use a statically initialized constant.
- args :: list(static_cons)
- )
+ ---> construct_statically
+ % Create a static constant in the target language.
; construct_dynamically
% Allocate a new term on the heap.
@@ -938,18 +921,6 @@
; reuse_cell(cell_to_reuse).
% Reuse an existing heap cell.
- % Information on how to construct an argument for a static construction
- % unification. Each such argument must itself have been constructed
- % statically; we store here a subset of the fields of the original
- % `construct' unification for the arg. This is used by the MLDS back-end.
- %
-:- type static_cons
- ---> static_cons(
- cons_id, % The cons_id of the functor.
- list(prog_var), % The list of arg variables.
- list(static_cons) % How to construct the args.
- ).
-
% Information used to perform structure reuse on a cell.
%
:- type cell_to_reuse
@@ -2537,17 +2508,8 @@
How0 = construct_dynamically,
How = How0
;
- How0 = construct_statically(StaticConss0),
- % XXX This is a potential performance bug. The code that constructs
- % a ground term with N function symbols will have N construct
- % unifications with their How0 set to construct_statically, and
- % they will have an average of N/2 static_cons terms. The cost of
- % renaming all the variables in them is thus proportional to N^2.
- % We should look into removing the variables from static_cons
- % terms, to avoid the need for this renaming.
- list.map(rename_var_in_static_cons(Must, Subn),
- StaticConss0, StaticConss),
- How = construct_statically(StaticConss)
+ How0 = construct_statically,
+ How = How0
;
How0 = construct_in_region(RegVar0),
rename_var(Must, Subn, RegVar0, RegVar),
@@ -2597,15 +2559,6 @@
Unify = complicated_unify(Modes, Cat, TypeInfoVars)
).
-:- pred rename_var_in_static_cons(must_rename::in, prog_var_renaming::in,
- static_cons::in, static_cons::out) is det.
-
-rename_var_in_static_cons(Must, Subn, StaticCons0, StaticCons) :-
- StaticCons0 = static_cons(ConsId, ArgVars0, ArgConss0),
- list.map(rename_var(Must, Subn), ArgVars0, ArgVars),
- list.map(rename_var_in_static_cons(Must, Subn), ArgConss0, ArgConss),
- StaticCons = static_cons(ConsId, ArgVars, ArgConss).
-
:- pred rename_generic_call(must_rename::in, prog_var_renaming::in,
generic_call::in, generic_call::out) is det.
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.468
diff -u -b -r1.468 hlds_out.m
--- compiler/hlds_out.m 30 Aug 2009 22:59:21 -0000 1.468
+++ compiler/hlds_out.m 30 Aug 2009 23:15:37 -0000
@@ -149,6 +149,12 @@
prog_varset::in, bool::in, list(prog_var)::in, pred_or_func::in,
clause::in, maybe_vartypes::in, io::di, io::uo) is det.
+ % write_proc(Indent, AppendVarNums, ModuleInfo, PredId, ProcId,
+ % ImportStatus, Proc, !IO).
+ %
+:- pred write_proc(int::in, bool::in, module_info::in, pred_id::in,
+ proc_id::in, import_status::in, proc_info::in, io::di, io::uo) is det.
+
% Print out an HLDS goal. The module_info and prog_varset give
% the context of the goal. The boolean says whether variables should
% have their numbers appended to them. The integer gives the level
@@ -1014,9 +1020,13 @@
io.write_string("% special pred\n", !IO)
;
Origin = origin_transformed(Transformation, _, OrigPredId),
- io.write_string("% transformed from ", !IO),
+ OrigPredIdNum = pred_id_to_int(OrigPredId),
+ io.format("%% transformed from pred id %d\n",
+ [i(OrigPredIdNum)], !IO),
+ io.write_string("% ", !IO),
write_pred_id(ModuleInfo, OrigPredId, !IO),
- io.write_string(": ", !IO),
+ io.nl(!IO),
+ io.write_string("% transformation: ", !IO),
io.write(Transformation, !IO),
io.nl(!IO)
;
@@ -2637,11 +2647,9 @@
(
ConstructHow = construct_dynamically
;
- ConstructHow = construct_statically(StaticConsList),
+ ConstructHow = construct_statically,
write_indent(Indent, !IO),
- io.write_string("% construct statically\n", !IO),
- list.foldl(write_static_cons(Indent, 1, ProgVarSet, AppendVarNums),
- StaticConsList, !IO)
+ io.write_string("% construct statically\n", !IO)
;
ConstructHow = reuse_cell(CellToReuse),
CellToReuse = cell_to_reuse(ReuseVar, _ReuseConsIds, _FieldAssigns),
@@ -2703,29 +2711,6 @@
mercury_output_vars(ProgVarSet, AppendVarNums, TypeInfoVars, !IO),
io.write_string("\n", !IO).
-:- pred write_static_cons(int::in, int::in, prog_varset::in, bool::in,
- static_cons::in, io::di, io::uo) is det.
-
-write_static_cons(Indent, Depth, VarSet, AppendVarNums, StaticCons, !IO) :-
- StaticCons = static_cons(ConsId, ArgVars, ArgStaticConstList),
- write_indent(Indent, !IO),
- io.write_string("% ", !IO),
- write_indent(Depth, !IO),
- write_cons_id_and_arity(ConsId, !IO),
- io.write_string("\n", !IO),
- (
- ArgVars = []
- ;
- ArgVars = [_ | _],
- write_indent(Indent, !IO),
- io.write_string("% ", !IO),
- write_indent(Depth, !IO),
- mercury_output_vars(VarSet, AppendVarNums, ArgVars, !IO),
- io.write_string("\n", !IO)
- ),
- list.foldl(write_static_cons(Indent, Depth + 1, VarSet, AppendVarNums),
- ArgStaticConstList, !IO).
-
:- pred write_functor_and_submodes(cons_id::in, list(prog_var)::in,
list(uni_mode)::in, module_info::in, prog_varset::in, inst_varset::in,
bool::in, int::in, io::di, io::uo) is det.
@@ -4053,9 +4038,6 @@
write_procs_2(ProcIds, AppendVarNums, ModuleInfo, Indent,
PredId, ImportStatus, ProcTable, !IO).
-:- pred write_proc(int::in, bool::in, module_info::in, pred_id::in,
- proc_id::in, import_status::in, proc_info::in, io::di, io::uo) is det.
-
write_proc(Indent, AppendVarNums, ModuleInfo, PredId, ProcId,
ImportStatus, Proc, !IO) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
Index: compiler/interval.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/interval.m,v
retrieving revision 1.41
diff -u -b -r1.41 interval.m
--- compiler/interval.m 11 Jun 2009 07:00:11 -0000 1.41
+++ compiler/interval.m 28 Aug 2009 11:49:14 -0000
@@ -375,7 +375,7 @@
unexpected(this_file,
"build_interval_info_in_goal: construct in region")
;
- ( HowToConstruct = construct_statically(_)
+ ( HowToConstruct = construct_statically
; HowToConstruct = construct_dynamically
)
),
Index: compiler/liveness.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/liveness.m,v
retrieving revision 1.166
diff -u -b -r1.166 liveness.m
--- compiler/liveness.m 23 Dec 2008 01:37:35 -0000 1.166
+++ compiler/liveness.m 28 Aug 2009 11:49:14 -0000
@@ -588,7 +588,7 @@
(
GoalExpr = unify(_, _, _, Unification, _),
Unification = construct(LHSVar, _ConsId, RHSVars, _ArgModes,
- construct_statically(_), cell_is_shared, no_construct_sub_info)
+ construct_statically, cell_is_shared, no_construct_sub_info)
->
( set.remove_list(!.LocalLiveVars, RHSVars, !:LocalLiveVars) ->
set.insert(!.LocalLiveVars, LHSVar, !:LocalLiveVars),
Index: compiler/loop_inv.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/loop_inv.m,v
retrieving revision 1.47
diff -u -b -r1.47 loop_inv.m
--- compiler/loop_inv.m 23 Dec 2008 01:37:35 -0000 1.47
+++ compiler/loop_inv.m 28 Aug 2009 11:49:14 -0000
@@ -606,7 +606,7 @@
const_construction(hlds_goal(GoalExpr, _GoalInfo)) :-
Construction = GoalExpr ^ unify_kind,
( Construction ^ construct_args = []
- ; Construction ^ construct_how = construct_statically(_)
+ ; Construction ^ construct_how = construct_statically
).
%-----------------------------------------------------------------------------%
Index: compiler/make.module_dep_file.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.module_dep_file.m,v
retrieving revision 1.41
diff -u -b -r1.41 make.module_dep_file.m
--- compiler/make.module_dep_file.m 14 Aug 2009 20:37:46 -0000 1.41
+++ compiler/make.module_dep_file.m 28 Aug 2009 11:49:14 -0000
@@ -418,8 +418,8 @@
term.integer(module_dependencies_version_number), [], _),
SourceFileTerm = term.functor(
term.string(SourceFileName), [], _),
- sym_name_and_args(SourceFileModuleNameTerm, SourceFileModuleName,
- []),
+ parse_sym_name_and_args(SourceFileModuleNameTerm,
+ SourceFileModuleName, []),
parse_sym_name_list(ParentsTerm, Parents),
parse_sym_name_list(IntDepsTerm, IntDeps),
parse_sym_name_list(ImplDepsTerm, ImplDeps),
@@ -449,8 +449,8 @@
term.string(LanguageString), [], _),
globals.convert_foreign_language(LanguageString,
Language),
- sym_name_and_args(ImportedModuleTerm, ImportedModuleName,
- []),
+ parse_sym_name_and_args(ImportedModuleTerm,
+ ImportedModuleName, []),
ForeignImportModule = foreign_import_module_info(Language,
ImportedModuleName, term.context_init)
), ForeignImportTerms, ForeignImports),
@@ -558,7 +558,7 @@
parse_sym_name_list(term.functor(term.atom("{}"), Args, _), SymNames) :-
list.map(
(pred(Arg::in, SymName::out) is semidet :-
- sym_name_and_args(Arg, SymName, [])
+ parse_sym_name_and_args(Arg, SymName, [])
), Args, SymNames).
% The module_name given must be the top level module in the source file.
Index: compiler/make_hlds_warn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_warn.m,v
retrieving revision 1.31
diff -u -b -r1.31 make_hlds_warn.m
--- compiler/make_hlds_warn.m 10 Mar 2009 05:00:29 -0000 1.31
+++ compiler/make_hlds_warn.m 28 Aug 2009 11:49:14 -0000
@@ -149,19 +149,38 @@
( Reason = exist_quant(Vars)
; Reason = promise_solutions(Vars, _)
),
- Vars = [_ | _]
- ->
+ (
+ Vars = [_ | _],
SubGoalVars = free_goal_vars(SubGoal),
set.init(EmptySet),
warn_singletons_goal_vars(Vars, GoalInfo, EmptySet, SubGoalVars,
VarSet, PredCallId, !Specs),
set.insert_list(QuantVars, Vars, SubQuantVars)
;
+ Vars = [],
SubQuantVars = QuantVars
),
warn_singletons_in_goal(SubGoal, SubQuantVars, VarSet, PredCallId,
ModuleInfo, !Specs)
;
+ ( Reason = promise_purity(_)
+ ; Reason = commit(_)
+ ; Reason = barrier(_)
+ ; Reason = trace_goal(_, _, _, _, _)
+ ),
+ warn_singletons_in_goal(SubGoal, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs)
+ ;
+ Reason = from_ground_term(TermVar, _Kind),
+ % There can be no singleton variables inside the scopes by
+ % construction. The only variable involved in the scope
+ % that can possibly be singleton is the one representing the entire
+ % ground term.
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ warn_singletons_goal_vars([TermVar], GoalInfo, NonLocals,
+ QuantVars, VarSet, PredCallId, !Specs)
+ )
+ ;
GoalExpr = if_then_else(Vars, Cond, Then, Else),
% Warn if any quantified variables do not occur in the condition
Index: compiler/mark_static_terms.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mark_static_terms.m,v
retrieving revision 1.30
diff -u -b -r1.30 mark_static_terms.m
--- compiler/mark_static_terms.m 23 Dec 2008 01:37:36 -0000 1.30
+++ compiler/mark_static_terms.m 31 Aug 2009 00:39:35 -0000
@@ -42,20 +42,20 @@
:- import_module list.
:- import_module map.
:- import_module pair.
+:- import_module set_tree234.
:- import_module svmap.
%-----------------------------------------------------------------------------%
% As we traverse the goal, we keep track of which variables are static at
- % the current program point, and for each such variable, we keep
- % information on how to construct it.
+ % the current program point.
%
-:- type static_info == map(prog_var, static_cons).
+:- type static_info == set_tree234(prog_var).
mark_static_terms(_ModuleInfo, !Proc) :-
% The ModuleInfo argument is there just for passes_aux.
proc_info_get_goal(!.Proc, Goal0),
- map.init(StaticInfo0),
+ StaticInfo0 = set_tree234.init,
goal_mark_static_terms(Goal0, Goal, StaticInfo0, _StaticInfo),
proc_info_set_goal(Goal, !Proc).
@@ -154,14 +154,11 @@
(
Unification0 = construct(Var, ConsId, ArgVars, D, HowToConstruct0,
F, G),
- (
- % If all the arguments are static, then the newly constructed
- % variable is static too.
- list.map(map.search(!.StaticVars), ArgVars, StaticArgs)
- ->
- HowToConstruct = construct_statically(StaticArgs),
- svmap.det_insert(Var, static_cons(ConsId, ArgVars, StaticArgs),
- !StaticVars)
+ % If all the arguments are static, then the newly constructed variable
+ % is static too.
+ ( list.all_true(set_tree234.contains(!.StaticVars), ArgVars) ->
+ HowToConstruct = construct_statically,
+ set_tree234.insert(Var, !StaticVars)
;
HowToConstruct = HowToConstruct0
),
@@ -193,12 +190,10 @@
;
Unification0 = assign(TargetVar, SourceVar),
Unification = Unification0,
- (
- % If the variable being assign from is static,
- % then the variable being assigned to is static too.
- map.search(!.StaticVars, SourceVar, Data)
- ->
- svmap.det_insert(TargetVar, Data, !StaticVars)
+ % If the variable being assigned from is static, then the variable
+ % being assigned to is static too.
+ ( set_tree234.contains(!.StaticVars, SourceVar) ->
+ set_tree234.insert(TargetVar, !StaticVars)
;
true
)
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.501
diff -u -b -r1.501 mercury_compile.m
--- compiler/mercury_compile.m 30 Aug 2009 22:59:22 -0000 1.501
+++ compiler/mercury_compile.m 31 Aug 2009 01:16:25 -0000
@@ -1871,7 +1871,7 @@
mlds_has_main(MLDS) =
(
- MLDS = mlds(_, _, _, Defns, _, _, _),
+ Defns = MLDS ^ mlds_defns,
defns_contain_main(Defns)
->
has_main
@@ -5196,12 +5196,11 @@
map_args_to_regs(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 425, "args_to_regs", !DumpInfo, !IO),
- maybe_dump_hlds(!.HLDS, 499, "final", !DumpInfo, !IO),
-
maybe_write_string(Verbose, "% Converting HLDS to MLDS...\n", !IO),
- ml_code_gen(!.HLDS, !:MLDS, !IO),
+ ml_code_gen(!HLDS, !:MLDS),
maybe_write_string(Verbose, "% done.\n", !IO),
maybe_report_stats(Stats, !IO),
+ maybe_dump_hlds(!.HLDS, 499, "final", !DumpInfo, !IO),
maybe_dump_mlds(Globals, !.MLDS, 0, "initial", !IO),
maybe_write_string(Verbose, "% Generating RTTI data...\n", !IO),
@@ -5279,7 +5278,7 @@
GC = gc_accurate,
maybe_write_string(Verbose,
"% Threading GC stack frames...\n", !IO),
- ml_elim_nested(chain_gc_stack_frames, !MLDS, !IO),
+ ml_elim_nested(chain_gc_stack_frames, Globals, !MLDS),
maybe_write_string(Verbose, "% done.\n", !IO)
;
( GC = gc_automatic
@@ -5296,7 +5295,7 @@
(
NestedFuncs = no,
maybe_write_string(Verbose, "% Flattening nested functions...\n", !IO),
- ml_elim_nested(hoist_nested_funcs, !MLDS, !IO),
+ ml_elim_nested(hoist_nested_funcs, Globals, !MLDS),
maybe_write_string(Verbose, "% done.\n", !IO)
;
NestedFuncs = yes
@@ -5328,18 +5327,15 @@
generate_base_typeclass_info_rtti(HLDS, TypeClassInfoRtti),
module_info_get_globals(HLDS, Globals),
- globals.lookup_bool_option(Globals, new_type_class_rtti,
- NewTypeClassRtti),
+ globals.lookup_bool_option(Globals, new_type_class_rtti, NewTypeClassRtti),
generate_type_class_info_rtti(HLDS, NewTypeClassRtti,
NewTypeClassInfoRttiData),
- list.condense([TypeCtorRtti, TypeClassInfoRtti,
- NewTypeClassInfoRttiData], RttiData),
- RttiDefns = rtti_data_list_to_mlds(HLDS, RttiData),
- !.MLDS = mlds(ModuleName, ForeignCode, Imports, Defns0, InitPreds,
- FinalPreds, ExportedEnums),
- Defns = RttiDefns ++ Defns0,
- !:MLDS = mlds(ModuleName, ForeignCode, Imports, Defns, InitPreds,
- FinalPreds, ExportedEnums).
+ RttiDatas = TypeCtorRtti ++ TypeClassInfoRtti ++ NewTypeClassInfoRttiData,
+ !.MLDS = mlds(ModuleName, ForeignCode, Imports, GlobalData0, Defns,
+ InitPreds, FinalPreds, ExportedEnums),
+ add_rtti_datas_to_mlds(HLDS, RttiDatas, GlobalData0, GlobalData),
+ !:MLDS = mlds(ModuleName, ForeignCode, Imports, GlobalData, Defns,
+ InitPreds, FinalPreds, ExportedEnums).
%-----------------------------------------------------------------------------%
%
@@ -5353,7 +5349,7 @@
globals.lookup_bool_option(Globals, statistics, Stats),
maybe_write_string(Verbose, "% Converting MLDS to C...\n", !IO),
- mlds_to_c.output_mlds(MLDS, "", !IO),
+ output_c_mlds(MLDS, Globals, "", !IO),
maybe_write_string(Verbose, "% Finished converting MLDS to C.\n", !IO),
maybe_report_stats(Stats, !IO).
@@ -5365,7 +5361,7 @@
globals.lookup_bool_option(Globals, statistics, Stats),
maybe_write_string(Verbose, "% Converting MLDS to Java...\n", !IO),
- mlds_to_java.output_mlds(HLDS, MLDS, !IO),
+ output_java_mlds(HLDS, MLDS, !IO),
maybe_write_string(Verbose, "% Finished converting MLDS to Java.\n", !IO),
maybe_report_stats(Stats, !IO).
@@ -5389,7 +5385,7 @@
globals.lookup_bool_option(Globals, statistics, Stats),
maybe_write_string(Verbose, "% Converting MLDS to IL...\n", !IO),
- mlds_to_ilasm.output_mlds(MLDS, !IO),
+ output_mlds_via_ilasm(Globals, MLDS, !IO),
maybe_write_string(Verbose, "% Finished converting MLDS to IL.\n", !IO),
maybe_report_stats(Stats, !IO).
@@ -5559,7 +5555,7 @@
maybe_write_string(Verbose, "% Dumping out MLDS as C...\n", !IO),
maybe_flush_output(Verbose, !IO),
DumpSuffix = "_dump." ++ StageNumStr ++ "-" ++ StageName,
- mlds_to_c.output_mlds(MLDS, DumpSuffix, !IO),
+ output_c_mlds(MLDS, Globals, DumpSuffix, !IO),
maybe_write_string(Verbose, "% done.\n", !IO)
;
true
Index: compiler/ml_backend.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_backend.m,v
retrieving revision 1.12
diff -u -b -r1.12 ml_backend.m
--- compiler/ml_backend.m 23 Feb 2006 09:36:57 -0000 1.12
+++ compiler/ml_backend.m 28 Aug 2009 11:49:14 -0000
@@ -48,6 +48,7 @@
:- include_module ml_type_gen.
:- include_module ml_unify_gen.
:- include_module ml_code_util.
+:- include_module ml_global_data.
:- include_module rtti_to_mlds.
% Phase 6-ml: MLDS -> MLDS transformations
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.84
diff -u -b -r1.84 ml_call_gen.m
--- compiler/ml_call_gen.m 10 Jun 2009 06:26:19 -0000 1.84
+++ compiler/ml_call_gen.m 28 Aug 2009 11:49:14 -0000
@@ -19,6 +19,7 @@
:- 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.mlds.
@@ -77,8 +78,8 @@
% 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(mer_type::in, mer_type::in, box_policy::in,
- mlds_rval::in, mlds_rval::out, ml_gen_info::in, ml_gen_info::out) is det.
+:- 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,
@@ -123,7 +124,6 @@
:- 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.
@@ -140,7 +140,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for procedure calls
+% Code for procedure calls.
%
ml_gen_generic_call(GenericCall, ArgVars, ArgModes, Determinism, Context,
@@ -247,7 +247,8 @@
% since GNU C (2.95.2) ignores the function attributes on function
% pointer types in casts.
%
- ml_gen_info_new_conv_var(ConvVarNum, !Info),
+ ml_gen_info_new_conv_var(ConvVarSeq, !Info),
+ ConvVarSeq = conv_seq(ConvVarNum),
FuncVarName = mlds_var_name(string.format("func_%d", [i(ConvVarNum)]), no),
% The function address is always a pointer to code,
% not to the heap, so the GC doesn't need to trace it.
@@ -268,23 +269,27 @@
InputRvals, OutputLvals, OutputTypes,
ConvArgDecls, ConvOutputStatements, !Info),
ClosureRval = ml_unop(unbox(ClosureArgType), ml_lval(ClosureLval)),
-
- % Prepare to generate the call, passing the closure as the first argument.
- % (We can't actually generate the call yet, since it might be nondet,
- % and we don't yet know what its success continuation will be; instead
- % for now we just construct a higher-order term `DoGenCall', which when
- % called will generate it.)
ObjectRval = no,
- DoGenCall = ml_gen_mlds_call(Signature, ObjectRval, FuncVarRval,
- [ClosureRval | InputRvals], OutputLvals, OutputTypes,
- Determinism, Context),
(
ConvArgDecls = [],
ConvOutputStatements = []
->
- DoGenCall(Decls0, Statements0, !Info)
+ % Generate the call directly (as opposed to via DoGenCall)
+ % in the common case.
+ ml_gen_mlds_call(Signature, ObjectRval, FuncVarRval,
+ [ClosureRval | InputRvals], OutputLvals, OutputTypes,
+ Determinism, Context, Decls0, Statements0, !Info)
;
+ % Prepare to generate the call, passing the closure as the first
+ % argument. We can't actually generate the call yet, since it might be
+ % nondet, and we don't yet know what its success continuation will be.
+ % Instead we construct a higher-order term `DoGenCall', which, when
+ % called by ml_combine_conj, will generate it.
+ DoGenCall = ml_gen_mlds_call(Signature, ObjectRval, FuncVarRval,
+ [ClosureRval | InputRvals], OutputLvals, OutputTypes,
+ Determinism, Context),
+
% Construct a closure to generate code to convert the output arguments
% and then succeed.
DoGenConvOutputAndSucceed = (
@@ -322,8 +327,8 @@
Statements = []
;
IsDummy = is_not_dummy_type,
- ml_gen_box_or_unbox_rval(SrcType, DestType, native_if_possible,
- ml_lval(SrcLval), CastRval, !Info),
+ ml_gen_box_or_unbox_rval(ModuleInfo, SrcType, DestType,
+ native_if_possible, ml_lval(SrcLval), CastRval),
Assign = ml_gen_assign(DestLval, CastRval, Context),
Statements = [Assign]
),
@@ -389,21 +394,27 @@
InputRvals, OutputLvals, OutputTypes,
ConvArgDecls, ConvOutputStatements, !Info),
- % Construct a closure to generate the call (We can't actually generate
- % the call yet, since it might be nondet, and we don't yet know what its
- % success continuation will be; that's why for now we just construct
- % a closure `DoGenCall' to generate it.)
ObjectRval = no,
proc_info_interface_determinism(ProcInfo, Detism),
- DoGenCall = ml_gen_mlds_call(Signature, ObjectRval, FuncRval,
- InputRvals, OutputLvals, OutputTypes, Detism, Context),
(
ConvArgDecls = [],
ConvOutputStatements = []
->
- DoGenCall(Decls, Statements, !Info)
- ;
+ % Generate the call directly (as opposed to via DoGenCall)
+ % in the common case.
+ ml_gen_mlds_call(Signature, ObjectRval, FuncRval,
+ InputRvals, OutputLvals, OutputTypes, Detism, Context,
+ Decls, Statements, !Info)
+ ;
+ % Construct a closure to generate the call. We can't actually generate
+ % the call yet, since it might be nondet, and we don't yet know
+ % what its success continuation will be. That is why we construct
+ % a closure `DoGenCall', which, when called by ml_combine_conj, will
+ % generate it.
+ DoGenCall = ml_gen_mlds_call(Signature, ObjectRval, FuncRval,
+ InputRvals, OutputLvals, OutputTypes, Detism, Context),
+
% Construct a closure to generate code to convert the output arguments
% and then succeed.
DoGenConvOutputAndSucceed = (
@@ -675,8 +686,8 @@
CallerIsDummy = is_not_dummy_type,
VarRval = ml_lval(VarLval)
),
- ml_gen_box_or_unbox_rval(CallerType, CalleeType,
- native_if_possible, VarRval, ArgRval, !Info),
+ ml_gen_box_or_unbox_rval(ModuleInfo, CallerType, CalleeType,
+ native_if_possible, VarRval, ArgRval),
!:InputRvals = [ArgRval | !.InputRvals]
;
ArgMode = top_out,
@@ -729,8 +740,8 @@
ml_gen_mem_addr(Lval) =
(if Lval = ml_mem_ref(Rval, _) then Rval else ml_mem_addr(Lval)).
-ml_gen_box_or_unbox_rval(SourceType, DestType, BoxPolicy, VarRval, ArgRval,
- !Info) :-
+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,
@@ -742,21 +753,22 @@
SourceType = type_variable(_, _),
DestType \= type_variable(_, _)
->
- ml_gen_type(!.Info, DestType, MLDS_DestType),
+ 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(_, _)
->
- ml_gen_type(!.Info, SourceType, MLDS_SourceType),
+ 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)
->
- ml_gen_type(!.Info, DestType, MLDS_DestType),
+ MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
ArgRval = ml_unop(unbox(MLDS_DestType),
ml_unop(cast(mlds_generic_type), VarRval))
;
@@ -764,8 +776,9 @@
SourceType = builtin_type(builtin_type_float),
DestType \= builtin_type(builtin_type_float)
->
- ml_gen_type(!.Info, SourceType, MLDS_SourceType),
- ml_gen_type(!.Info, DestType, MLDS_DestType),
+ 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))
;
@@ -787,7 +800,7 @@
% optimisation.
SourceType \= DestType
->
- ml_gen_type(!.Info, DestType, MLDS_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
@@ -796,7 +809,7 @@
%
\+ type_unify(SourceType, DestType, [], map.init, _)
->
- ml_gen_type(!.Info, DestType, MLDS_DestType),
+ MLDS_DestType = mercury_type_to_mlds_type(ModuleInfo, DestType),
ArgRval = ml_unop(cast(MLDS_DestType), VarRval)
;
% Otherwise leave unchanged.
@@ -810,8 +823,9 @@
% 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_box_or_unbox_rval(CalleeType, CallerType, BoxPolicy,
- ml_lval(VarLval), BoxedRval, !Info),
+ 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 = [],
@@ -835,11 +849,12 @@
% temporary variable declaration, but the CallerType is
% used to construct the type_info.
- ml_gen_info_new_conv_var(ConvVarNum, !Info),
+ ml_gen_info_new_conv_var(ConvVarSeq, !Info),
VarName = mlds_var_name(VarNameStr, MaybeNum),
- ArgVarName = mlds_var_name(
- string.format("conv%d_%s", [i(ConvVarNum), s(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,
@@ -854,7 +869,7 @@
)
;
ForClosureWrapper = no,
- ml_gen_gc_statement(ArgVarName, CalleeType, CallerType,
+ 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))
@@ -864,7 +879,6 @@
% Create the lval for the variable and use it for the argument lval.
ml_gen_var_lval(!.Info, ArgVarName, MLDS_CalleeType, ArgLval),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
CallerIsDummy = check_dummy_type(ModuleInfo, CallerType),
(
CallerIsDummy = is_dummy_type,
@@ -878,15 +892,15 @@
% to/from the output argument whose address we were passed.
% Assign to the freshly generated arg variable.
- ml_gen_box_or_unbox_rval(CallerType, CalleeType, BoxPolicy,
- ml_lval(VarLval), ConvertedVarRval, !Info),
+ 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(CalleeType, CallerType, BoxPolicy,
- ml_lval(ArgLval), ConvertedArgRval, !Info),
+ ml_gen_box_or_unbox_rval(ModuleInfo, CalleeType, CallerType,
+ BoxPolicy, ml_lval(ArgLval), ConvertedArgRval),
AssignOutputStatement = ml_gen_assign(VarLval, ConvertedArgRval,
Context),
ConvOutputStatements = [AssignOutputStatement]
@@ -895,7 +909,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for builtins
+% 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.61
diff -u -b -r1.61 ml_closure_gen.m
--- compiler/ml_closure_gen.m 11 Jun 2009 07:00:13 -0000 1.61
+++ compiler/ml_closure_gen.m 28 Aug 2009 11:49:14 -0000
@@ -37,8 +37,7 @@
%
:- pred ml_gen_closure(pred_id::in, proc_id::in, prog_var::in, prog_vars::in,
list(uni_mode)::in, how_to_construct::in, prog_context::in,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
% ml_gen_closure_wrapper(PredId, ProcId, Offset, NumClosureArgs,
% Context, WrapperFuncRval, WrapperFuncType):
@@ -101,6 +100,7 @@
:- import_module ll_backend.stack_layout. % for `represent_locn_as_int'
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ml_call_gen.
+:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_unify_gen.
:- import_module ml_backend.rtti_to_mlds.
:- import_module parse_tree.builtin_lib_types.
@@ -113,13 +113,15 @@
:- import_module maybe.
:- import_module pair.
:- import_module set.
+:- import_module set_tree234.
:- import_module string.
+:- import_module svmap.
:- import_module term.
%-----------------------------------------------------------------------------%
ml_gen_closure(PredId, ProcId, Var, ArgVars, ArgModes, HowToConstruct, Context,
- Decls, Statements, !Info) :-
+ Statements, !Info) :-
% This constructs a closure.
% The representation of closures for the LLDS backend is defined in
% runtime/mercury_ho_call.h.
@@ -127,9 +129,9 @@
% in the MLDS backend?
% Generate a value for the closure layout; this is a static constant
- % that holds information about how the structure of this closure.
- ml_gen_closure_layout(PredId, ProcId, Context, ClosureLayoutRval0,
- ClosureLayoutType0, ClosureLayoutDecls, !Info),
+ % that holds information about the structure of this closure.
+ ml_gen_closure_layout(PredId, ProcId, Context,
+ ClosureLayoutRval0, ClosureLayoutType0, !Info),
% Generate a wrapper function which just unboxes the arguments and then
% calls the specified procedure, and put the address of the wrapper
@@ -161,19 +163,13 @@
% The pointer will not be tagged (i.e. the tag will be zero).
MaybeConsId = no,
MaybeConsName = no,
- PrimaryTag = 0,
- MaybeSecondaryTag = no,
+ PTag = 0,
+ MaybeSTag = no,
% Generate a `new_object' statement (or static constant) for the closure.
- ml_gen_new_object(MaybeConsId, PrimaryTag, MaybeSecondaryTag,
- MaybeConsName, Var, ExtraArgRvals, ExtraArgTypes, ArgVars,
- ArgModes, [], HowToConstruct, Context, Decls0, Statements, !Info),
- Decls1 = ClosureLayoutDecls ++ Decls0,
- % We sometimes generates two definitions of the same RTTI constant
- % in ml_gen_closure_layout (e.g. two definitions of the same
- % pseudo_type_info). To avoid generating invalid MLDS code,
- % we need to check for and eliminate any duplicate definitions here.
- Decls = list.remove_dups(Decls1).
+ ml_gen_new_object(MaybeConsId, MaybeConsName, PTag, MaybeSTag,
+ Var, ExtraArgRvals, ExtraArgTypes, ArgVars, ArgModes, [],
+ HowToConstruct, Context, Statements, !Info).
% Generate a value for the closure layout struct.
% See MR_Closure_Layout in ../runtime/mercury_ho_call.h.
@@ -182,56 +178,59 @@
% any changes here may need to be reflected there, and vice versa.
%
:- pred ml_gen_closure_layout(pred_id::in, proc_id::in, prog_context::in,
- mlds_rval::out, mlds_type::out, list(mlds_defn)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ mlds_rval::out, mlds_type::out, ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_closure_layout(PredId, ProcId, Context,
- ClosureLayoutRval, ClosureLayoutType, ClosureLayoutDefns, !Info) :-
+ ClosureLayoutRval, ClosureLayoutType, !Info) :-
ml_gen_info_get_module_info(!.Info, ModuleInfo),
continuation_info.generate_closure_layout(ModuleInfo, PredId, ProcId,
ClosureLayoutInfo),
- ml_gen_closure_proc_id(ModuleInfo, Context, InitProcId, ProcIdType,
- ClosureProcIdDefns),
+ some [!GlobalData] (
+ ml_gen_info_get_global_data(!.Info, !:GlobalData),
+
+ ml_gen_closure_proc_id(ModuleInfo, Context, InitProcId, _ProcIdType,
+ !GlobalData),
ClosureLayoutInfo = closure_layout_info(ClosureArgs, TVarLocnMap),
ml_stack_layout_construct_closure_args(ModuleInfo, ClosureArgs,
- InitClosureArgs, ClosureArgTypes, ClosureArgDefns),
- ml_gen_info_new_const(TvarVectorSeqNum, !Info),
- ml_format_static_const_name(!.Info, "typevar_vector", TvarVectorSeqNum,
- TvarVectorName),
- ml_stack_layout_construct_tvar_vector(ModuleInfo, TvarVectorName,
- Context, TVarLocnMap, TVarVectorRval, TVarVectorType, TVarDefns),
- InitTVarVector = init_obj(ml_unop(box(TVarVectorType), TVarVectorRval)),
- Inits = [InitProcId, InitTVarVector | InitClosureArgs],
- _ArgTypes = [ProcIdType, TVarVectorType | ClosureArgTypes],
-
- ml_gen_info_new_const(LayoutSeqNum, !Info),
- ml_format_static_const_name(!.Info, "closure_layout", LayoutSeqNum, Name),
- Access = acc_local,
- Initializer = init_array(Inits),
+ ClosureArgInitsAndTypes, !GlobalData),
+ assoc_list.keys(ClosureArgInitsAndTypes, ClosureArgInits),
+
+ ml_stack_layout_construct_tvar_vector(ModuleInfo, "typevar_vector",
+ Context, TVarLocnMap, TVarVectorRval, TVarVectorType, !GlobalData),
+ InitTVarVector =
+ init_obj(ml_unop(box(TVarVectorType), TVarVectorRval)),
+ Inits = [InitProcId, InitTVarVector | ClosureArgInits],
+ % _ArgTypes = [ProcIdType, TVarVectorType | ClosureArgTypes],
+
% XXX There's no way in C to properly represent this type,
% since it is a struct that ends with a variable-length array.
% For now we just treat the whole struct as an array.
ClosureLayoutType = mlds_array_type(mlds_generic_type),
- ClosureLayoutDefn = ml_gen_static_const_defn(Name, ClosureLayoutType,
- Access, Initializer, Context),
- ClosureLayoutDefns = ClosureProcIdDefns ++ TVarDefns ++
- ClosureArgDefns ++ [ClosureLayoutDefn],
+ ml_gen_static_const_defn("closure_layout", ClosureLayoutType,
+ acc_private, init_array(Inits), Context, ClosureLayoutVarName,
+ !GlobalData),
+
+ ml_gen_info_set_global_data(!.GlobalData, !Info)
+ ),
+
module_info_get_name(ModuleInfo, ModuleName),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- ClosureLayoutRval = ml_lval(
- ml_var(qual(MLDS_ModuleName, module_qual, Name), ClosureLayoutType)).
+ ClosureLayoutVar =
+ qual(MLDS_ModuleName, module_qual, ClosureLayoutVarName),
+ ClosureLayoutRval = ml_lval(ml_var(ClosureLayoutVar, ClosureLayoutType)).
:- pred ml_gen_closure_proc_id(module_info::in, prog_context::in,
- mlds_initializer::out, mlds_type::out, list(mlds_defn)::out) is det.
+ mlds_initializer::out, mlds_type::out,
+ ml_global_data::in, ml_global_data::out) is det.
ml_gen_closure_proc_id(_ModuleInfo, _Context, InitProcId, ProcIdType,
- ClosureProcIdDefns) :-
+ !GlobalData) :-
% XXX currently we don't fill in the ProcId field!
InitProcId = init_obj(ml_const(mlconst_null(ProcIdType))),
- ProcIdType = mlds_generic_type,
- ClosureProcIdDefns = [].
+ ProcIdType = mlds_generic_type.
+
% module_info_get_name(ModuleInfo, ModuleName),
% term.context_file(Context, FileName),
% term.context_line(Context, LineNumber),
@@ -248,28 +247,26 @@
% % ProcIdType = ...
:- pred ml_stack_layout_construct_closure_args(module_info::in,
- list(closure_arg_info)::in, list(mlds_initializer)::out,
- list(mlds_type)::out, list(mlds_defn)::out) is det.
+ list(closure_arg_info)::in, assoc_list(mlds_initializer, mlds_type)::out,
+ ml_global_data::in, ml_global_data::out) is det.
ml_stack_layout_construct_closure_args(ModuleInfo, ClosureArgs,
- ClosureArgInits, ClosureArgTypes, Defns) :-
+ ClosureArgInits, !GlobalData) :-
list.map_foldl(ml_stack_layout_construct_closure_arg_rval(ModuleInfo),
- ClosureArgs, ArgInitsAndTypes, [], Defns),
- assoc_list.keys(ArgInitsAndTypes, ArgInits),
- assoc_list.values(ArgInitsAndTypes, ArgTypes),
- Length = list.length(ArgInits),
+ ClosureArgs, ArgInitsAndTypes, !GlobalData),
+ Length = list.length(ArgInitsAndTypes),
LengthRval = ml_const(mlconst_int(Length)),
- LengthType = mlds_native_int_type,
CastLengthRval = ml_unop(box(LengthType), LengthRval),
- ClosureArgInits = [init_obj(CastLengthRval) | ArgInits],
- ClosureArgTypes = [LengthType | ArgTypes].
+ LengthType = mlds_native_int_type,
+ LengthInitAndType = init_obj(CastLengthRval) - LengthType,
+ ClosureArgInits = [LengthInitAndType | ArgInitsAndTypes].
:- pred ml_stack_layout_construct_closure_arg_rval(module_info::in,
closure_arg_info::in, pair(mlds_initializer, mlds_type)::out,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
ml_stack_layout_construct_closure_arg_rval(ModuleInfo, ClosureArg,
- ArgInit - ArgType, !Defns) :-
+ ArgInit - ArgType, !GlobalData) :-
ClosureArg = closure_arg_info(Type, _Inst),
% For a stack layout, we can treat all type variables as universally
@@ -278,53 +275,55 @@
% we can take the variable number directly from the procedure's tvar set.
ExistQTvars = [],
NumUnivQTvars = -1,
-
pseudo_type_info.construct_pseudo_type_info(Type, NumUnivQTvars,
ExistQTvars, PseudoTypeInfo),
ml_gen_pseudo_type_info(ModuleInfo, PseudoTypeInfo, ArgRval, ArgType,
- !Defns),
+ !GlobalData),
CastArgRval = ml_unop(box(ArgType), ArgRval),
ArgInit = init_obj(CastArgRval).
:- pred ml_gen_maybe_pseudo_type_info_defn(module_info::in,
- rtti_maybe_pseudo_type_info::in, list(mlds_defn)::in, list(mlds_defn)::out)
- is det.
+ rtti_maybe_pseudo_type_info::in,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_maybe_pseudo_type_info_defn(ModuleInfo, MaybePTI, !Defns) :-
- ml_gen_maybe_pseudo_type_info(ModuleInfo, MaybePTI, _Rval, _Type, !Defns).
+ml_gen_maybe_pseudo_type_info_defn(ModuleInfo, MaybePTI,
+ !GlobalData) :-
+ ml_gen_maybe_pseudo_type_info(ModuleInfo, MaybePTI, _Rval, _Type,
+ !GlobalData).
:- pred ml_gen_pseudo_type_info_defn(module_info::in,
- rtti_pseudo_type_info::in, list(mlds_defn)::in, list(mlds_defn)::out)
- is det.
+ rtti_pseudo_type_info::in,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_pseudo_type_info_defn(ModuleInfo, PTI, !Defns) :-
- ml_gen_pseudo_type_info(ModuleInfo, PTI, _Rval, _Type, !Defns).
+ml_gen_pseudo_type_info_defn(ModuleInfo, PTI, !GlobalData) :-
+ ml_gen_pseudo_type_info(ModuleInfo, PTI, _Rval, _Type, !GlobalData).
:- pred ml_gen_type_info_defn(module_info::in, rtti_type_info::in,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_type_info_defn(ModuleInfo, TI, !Defns) :-
- ml_gen_type_info(ModuleInfo, TI, _Rval, _Type, !Defns).
+ml_gen_type_info_defn(ModuleInfo, TI, !GlobalData) :-
+ ml_gen_type_info(ModuleInfo, TI, _Rval, _Type, !GlobalData).
:- pred ml_gen_maybe_pseudo_type_info(module_info::in,
rtti_maybe_pseudo_type_info::in, mlds_rval::out, mlds_type::out,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
ml_gen_maybe_pseudo_type_info(ModuleInfo, MaybePseudoTypeInfo, Rval, Type,
- !Defns) :-
+ !GlobalData) :-
(
MaybePseudoTypeInfo = pseudo(PseudoTypeInfo),
- ml_gen_pseudo_type_info(ModuleInfo, PseudoTypeInfo, Rval, Type, !Defns)
+ ml_gen_pseudo_type_info(ModuleInfo, PseudoTypeInfo, Rval, Type,
+ !GlobalData)
;
MaybePseudoTypeInfo = plain(TypeInfo),
- ml_gen_type_info(ModuleInfo, TypeInfo, Rval, Type, !Defns)
+ ml_gen_type_info(ModuleInfo, TypeInfo, Rval, Type, !GlobalData)
).
:- pred ml_gen_pseudo_type_info(module_info::in, rtti_pseudo_type_info::in,
- mlds_rval::out, mlds_type::out, list(mlds_defn)::in, list(mlds_defn)::out)
- is det.
+ mlds_rval::out, mlds_type::out,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_pseudo_type_info(ModuleInfo, PseudoTypeInfo, Rval, Type, !Defns) :-
+ml_gen_pseudo_type_info(ModuleInfo, PseudoTypeInfo, Rval, Type, !GlobalData) :-
(
PseudoTypeInfo = type_var(N),
% Type variables are represented just as integers.
@@ -338,43 +337,55 @@
(
PseudoTypeInfo = plain_arity_zero_pseudo_type_info(RttiTypeCtor0),
% For zero-arity types, we just generate a reference to the
- % already-existing type_ctor_info.
+ % type_ctor_info, which will always be generated by other code.
+ % (mercury_compile.m has code to generate type_ctor_infos for
+ % all type definitions in the module.)
RttiName = type_ctor_type_ctor_info,
RttiTypeCtor0 = rtti_type_ctor(ModuleName0, _, _),
ModuleName = fixup_builtin_module(ModuleName0),
RttiTypeCtor = RttiTypeCtor0,
- RttiId = ctor_rtti_id(RttiTypeCtor, RttiName)
+ RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
+
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId))
;
( PseudoTypeInfo = plain_pseudo_type_info(_, _)
; PseudoTypeInfo = var_arity_pseudo_type_info(_, _)
),
% For other types, we need to generate a definition of the
- % pseudo_type_info for that type, in the the current module.
- module_info_get_name(ModuleInfo, ModuleName),
+ % pseudo_type_info for that type, in the current module.
RttiData = rtti_data_pseudo_type_info(PseudoTypeInfo),
rtti_data_to_id(RttiData, RttiId),
- RttiDefns0 = rtti_data_list_to_mlds(ModuleInfo, [RttiData]),
- % rtti_data_list_to_mlds assumes that the result will be
- % at file scope, but here we're generating it as a local,
- % so we need to convert the access to `local'.
- RttiDefns = list.map(convert_to_local, RttiDefns0),
- !:Defns = RttiDefns ++ !.Defns,
+
+ ml_global_data_get_pdup_rval_type_map(!.GlobalData,
+ PDupRvalTypeMap),
+ ( map.search(PDupRvalTypeMap, RttiId, OldRvalType) ->
+ OldRvalType = ml_rval_and_type(Rval, Type)
+ ;
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId)),
+
+ add_rtti_data_to_mlds(ModuleInfo, RttiData, !GlobalData),
+
% Generate definitions of any type_infos and pseudo_type_infos
% referenced by this pseudo_type_info.
+ % ZZZ is this guaranteed to add nothing?
list.foldl(ml_gen_maybe_pseudo_type_info_defn(ModuleInfo),
- arg_maybe_pseudo_type_infos(PseudoTypeInfo), !Defns)
- ),
- MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- Rval = ml_const(mlconst_data_addr(data_addr(MLDS_ModuleName,
- mlds_rtti(RttiId)))),
- Type = mlds_rtti_type(item_type(RttiId))
+ arg_maybe_pseudo_type_infos(PseudoTypeInfo), !GlobalData)
+ )
+ )
).
:- pred ml_gen_type_info(module_info::in, rtti_type_info::in,
- mlds_rval::out, mlds_type::out, list(mlds_defn)::in, list(mlds_defn)::out)
- is det.
+ mlds_rval::out, mlds_type::out,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_type_info(ModuleInfo, TypeInfo, Rval, Type, !Defns) :-
+ml_gen_type_info(ModuleInfo, TypeInfo, Rval, Type, !GlobalData) :-
(
TypeInfo = plain_arity_zero_type_info(RttiTypeCtor0),
% For zero-arity types, we just generate a reference to the
@@ -382,30 +393,40 @@
RttiName = type_ctor_type_ctor_info,
RttiTypeCtor0 = rtti_type_ctor(ModuleName0, _, _),
ModuleName = fixup_builtin_module(ModuleName0),
- RttiId = ctor_rtti_id(RttiTypeCtor0, RttiName)
+ RttiId = ctor_rtti_id(RttiTypeCtor0, RttiName),
+
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId))
;
( TypeInfo = plain_type_info(_, _)
; TypeInfo = var_arity_type_info(_, _)
),
% For other types, we need to generate a definition of the type_info
% for that type, in the the current module.
- module_info_get_name(ModuleInfo, ModuleName),
RttiData = rtti_data_type_info(TypeInfo),
rtti_data_to_id(RttiData, RttiId),
- RttiDefns0 = rtti_data_list_to_mlds(ModuleInfo, [RttiData]),
- % rtti_data_list_to_mlds assumes that the result will be at file scope,
- % but here we're generating it as a local, so we need to convert
- % the access to `local'.
- RttiDefns = list.map(convert_to_local, RttiDefns0),
- !:Defns = RttiDefns ++ !.Defns,
- % Generate definitions of any type_infos referenced by this type_info.
- list.foldl(ml_gen_type_info_defn(ModuleInfo),
- arg_type_infos(TypeInfo), !Defns)
- ),
+
+ ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
+ ( map.search(PDupRvalTypeMap, RttiId, OldRvalType) ->
+ OldRvalType = ml_rval_and_type(Rval, Type)
+ ;
+ module_info_get_name(ModuleInfo, ModuleName),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- Rval = ml_const(mlconst_data_addr(data_addr(MLDS_ModuleName,
- mlds_rtti(RttiId)))),
- Type = mlds_rtti_type(item_type(RttiId)).
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId)),
+
+ add_rtti_data_to_mlds(ModuleInfo, RttiData, !GlobalData),
+
+ % Generate definitions of any type_infos referenced
+ % by this type_info.
+ % ZZZ is this guaranteed to add nothing?
+ list.foldl(ml_gen_type_info_defn(ModuleInfo),
+ arg_type_infos(TypeInfo), !GlobalData)
+ )
+ ).
:- func arg_maybe_pseudo_type_infos(rtti_pseudo_type_info)
= list(rtti_maybe_pseudo_type_info).
@@ -423,35 +444,27 @@
arg_type_infos(plain_type_info(_TypeCtor, ArgTIs)) = ArgTIs.
arg_type_infos(var_arity_type_info(_VarArityId, ArgTIs)) = ArgTIs.
-:- func convert_to_local(mlds_defn) = mlds_defn.
-
-convert_to_local(mlds_defn(Name, Context, Flags0, Body)) =
- mlds_defn(Name, Context, Flags, Body) :-
- Flags = set_access(Flags0, acc_local).
-
:- pred ml_stack_layout_construct_tvar_vector(module_info::in,
- mlds_var_name::in, prog_context::in, map(tvar, set(layout_locn))::in,
- mlds_rval::out, mlds_type::out, list(mlds_defn)::out) is det.
+ string::in, prog_context::in, map(tvar, set(layout_locn))::in,
+ mlds_rval::out, mlds_type::out,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_stack_layout_construct_tvar_vector(ModuleInfo, TvarVectorName, Context,
- TVarLocnMap, MLDS_Rval, ArrayType, Defns) :-
+ml_stack_layout_construct_tvar_vector(ModuleInfo, TvarVectorNameStr, Context,
+ TVarLocnMap, MLDS_Rval, ArrayType, !GlobalData) :-
ArrayType = mlds_array_type(mlds_native_int_type),
( map.is_empty(TVarLocnMap) ->
- MLDS_Rval = ml_const(mlconst_null(ArrayType)),
- Defns = []
+ MLDS_Rval = ml_const(mlconst_null(ArrayType))
;
- Access = acc_local,
ml_stack_layout_construct_tvar_rvals(TVarLocnMap, Vector,
_VectorTypes),
Initializer = init_array(Vector),
- Defn = ml_gen_static_const_defn(TvarVectorName, ArrayType,
- Access, Initializer, Context),
- Defns = [Defn],
+ ml_gen_static_const_defn(TvarVectorNameStr, ArrayType, acc_private,
+ Initializer, Context, TvarVectorName, !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- MLDS_Rval = ml_lval(ml_var(
+ QualTvarVectorName =
qual(MLDS_ModuleName, module_qual, TvarVectorName),
- ArrayType))
+ MLDS_Rval = ml_lval(ml_var(QualTvarVectorName, ArrayType))
).
:- pred ml_stack_layout_construct_tvar_rvals(map(tvar, set(layout_locn))::in,
@@ -931,7 +944,7 @@
ml_gen_wrapper_func(WrapperFuncName, WrapperParams, Context,
WrapperFuncBody, WrapperFunc, !Info),
WrapperFuncType = mlds_func_type(WrapperParams),
- ml_gen_info_add_extra_defn(WrapperFunc, !Info).
+ ml_gen_info_add_closure_wrapper_defn(WrapperFunc, !Info).
:- func arg_delete_gc_statement(mlds_argument) = mlds_argument.
@@ -968,8 +981,8 @@
ClosureKind = special_pred_closure,
unexpected(this_file, "gen_closure_gc_statement: special_pred_closure")
),
- ml_gen_gc_statement(ClosureName, ClosureDeclType,
- ClosureActualType, Context, ClosureGCStatement, !Info).
+ ml_gen_gc_statement_poly(ClosureName, ClosureDeclType, ClosureActualType,
+ Context, ClosureGCStatement, !Info).
:- pred ml_gen_wrapper_func(ml_label_func::in, mlds_func_params::in,
prog_context::in, statement::in, mlds_defn::out,
@@ -1151,16 +1164,12 @@
;
ClosureKind = typeclass_info_closure,
ml_gen_closure_layout(PredId, ProcId, Context,
- ClosureLayoutRval, ClosureLayoutType,
- ClosureLayoutDefns, !Info),
+ ClosureLayoutRval, ClosureLayoutType, !Info),
ClosureLayoutPtrGCInit = statement(
- ml_stmt_block(
- ClosureLayoutDefns,
- [statement(ml_stmt_atomic(
+ ml_stmt_atomic(
assign(ClosureLayoutPtrLval,
- ml_unop(box(ClosureLayoutType), ClosureLayoutRval)
- )), MLDS_Context)]
- ), MLDS_Context),
+ ml_unop(box(ClosureLayoutType), ClosureLayoutRval))),
+ MLDS_Context),
TypeParamsGCInitFragments = [
target_code_output(TypeParamsLval),
raw_target_code(" = (MR_Box) " ++
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.218
diff -u -b -r1.218 ml_code_gen.m
--- compiler/ml_code_gen.m 15 Jun 2009 06:52:43 -0000 1.218
+++ compiler/ml_code_gen.m 31 Aug 2009 01:51:02 -0000
@@ -96,7 +96,7 @@
%
% means that in the situation described by [situation],
% for the the specified [construct] we will generate the specified [code].
-
+%
% There is one other important thing which can be considered part of the
% calling convention for the code that we generate for each goal.
% If static ground term optimization is enabled, then for the terms
@@ -714,7 +714,6 @@
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
@@ -722,7 +721,7 @@
% Generate MLDS code for an entire module.
%
-:- pred ml_code_gen(module_info::in, mlds::out, io::di, io::uo) is det.
+:- 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
@@ -739,8 +738,21 @@
list(mlds_defn)::out, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is det.
- % ml_gen_wrap_goal(OuterCodeModel, InnerCodeModel, Context,
- % Statements0, Statements):
+ % Generate code for a goal that is one branch of a branched control
+ % structure. At the end of the branch, we need to forget what we learned
+ % during the branch about which variables are bound to constants,
+ % since those variables may not be bound to constants (at least not the
+ % same constants) in parallel branches, or in code after the branched
+ % control if control did not go through this branch.
+ %
+:- pred ml_gen_goal_as_branch(code_model::in, hlds_goal::in,
+ list(mlds_defn)::out, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_goal_as_branch_block(code_model::in, hlds_goal::in,
+ statement::out, ml_gen_info::in, ml_gen_info::out) is det.
+
+ % ml_gen_maybe_convert_goal_code_model(OuterCodeModel, InnerCodeModel,
+ % Context, Statements0, Statements, !Info):
%
% OuterCodeModel is the code model expected by the context in which a goal
% is called. InnerCodeModel is the code model which the goal actually has.
@@ -748,8 +760,8 @@
% InnerCodeModel into code that uses the calling convention appropriate
% for OuterCodeModel.
%
-:- pred ml_gen_wrap_goal(code_model::in, code_model::in, prog_context::in,
- list(statement)::in, list(statement)::out,
+:- pred ml_gen_maybe_convert_goal_code_model(code_model::in, code_model::in,
+ prog_context::in, list(statement)::in, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is det.
% Generate declarations for a list of local variables.
@@ -774,12 +786,14 @@
:- 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_global_data.
:- import_module ml_backend.ml_switch_gen.
:- import_module ml_backend.ml_type_gen.
:- import_module ml_backend.ml_unify_gen.
@@ -793,6 +807,7 @@
:- import_module maybe.
:- import_module pair.
:- import_module set.
+:- import_module set_tree234.
:- import_module solutions.
:- import_module string.
:- import_module std_util.
@@ -801,27 +816,27 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-ml_code_gen(ModuleInfo, MLDS, !IO) :-
- module_info_get_name(ModuleInfo, ModuleName),
- ml_gen_foreign_code(ModuleInfo, ForeignCode, !IO),
- ml_gen_imports(ModuleInfo, Imports),
- ml_gen_defns(ModuleInfo, Defns, !IO),
- ml_gen_exported_enums(ModuleInfo, ExportedEnums, !IO),
- module_info_user_init_pred_c_names(ModuleInfo, InitPreds),
- module_info_user_final_pred_c_names(ModuleInfo, FinalPreds),
- MLDS = mlds(ModuleName, ForeignCode, Imports, Defns,
+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,
- io::di, io::uo) is det.
+ map(foreign_language, mlds_foreign_code)::out) is det.
-ml_gen_foreign_code(ModuleInfo, AllForeignCode, !IO) :-
+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),
- globals.io_get_backend_foreign_languages(BackendForeignLanguages, !IO),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_backend_foreign_languages(Globals, BackendForeignLanguages),
WantedForeignImports = list.condense(
list.map((func(L) = Imports :-
@@ -922,13 +937,13 @@
unexpected(this_file, "foreign_type_required_imports: target erlang")
).
-:- pred ml_gen_defns(module_info::in, list(mlds_defn)::out, io::di, io::uo)
- is det.
+:- 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, !IO) :-
- ml_gen_types(ModuleInfo, TypeDefns, !IO),
- ml_gen_table_structs(ModuleInfo, TableStructDefns),
- ml_gen_preds(ModuleInfo, PredDefns, !IO),
+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.
%-----------------------------------------------------------------------------%
@@ -956,20 +971,23 @@
% Generate MLDS definitions for all the non-imported predicates
% (and functions) in the HLDS.
%
-:- pred ml_gen_preds(module_info::in, list(mlds_defn)::out, io::di, io::uo)
- is det.
+:- 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, !IO) :-
- module_info_preds(ModuleInfo, PredTable),
+ml_gen_preds(!ModuleInfo, PredDefns, GlobalData) :-
+ module_info_preds(!.ModuleInfo, PredTable),
map.keys(PredTable, PredIds),
- ml_gen_preds_2(ModuleInfo, PredIds, PredTable, [], PredDefns, !IO).
+ ml_gen_preds_2(!ModuleInfo, PredIds, [], PredDefns,
+ ml_global_data_init, GlobalData).
-:- pred ml_gen_preds_2(module_info::in, list(pred_id)::in, pred_table::in,
- list(mlds_defn)::in, list(mlds_defn)::out, io::di, io::uo) is det.
+:- 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, PredTable, !Defns, !IO) :-
+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),
(
@@ -984,10 +1002,10 @@
->
true
;
- ml_gen_pred(ModuleInfo, PredId, PredInfo, ImportStatus,
- !Defns, !IO)
+ ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
+ !GlobalDefns)
),
- ml_gen_preds_2(ModuleInfo, PredIds, PredTable, !Defns, !IO)
+ ml_gen_preds_2(!ModuleInfo, PredIds, !Defns, !GlobalDefns)
;
PredIds0 = []
).
@@ -995,11 +1013,13 @@
% Generate MLDS definitions for all the non-imported procedures
% of a given predicate (or function).
%
-:- pred ml_gen_pred(module_info::in, pred_id::in, pred_info::in,
- import_status::in, list(mlds_defn)::in, list(mlds_defn)::out,
- io::di, io::uo) is det.
+:- 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, !IO) :-
+ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
+ !GlobalData) :-
( ImportStatus = status_external(_) ->
ProcIds = pred_info_procids(PredInfo)
;
@@ -1009,45 +1029,26 @@
ProcIds = []
;
ProcIds = [_ | _],
+ trace [io(!IO)] (
write_pred_progress_message("% Generating MLDS code for ",
- PredId, ModuleInfo, !IO),
- pred_info_get_procedures(PredInfo, ProcTable),
- ml_gen_procs(ProcIds, ModuleInfo, PredId, PredInfo, ProcTable, !Defns)
+ PredId, !.ModuleInfo, !IO)
+ ),
+ ml_gen_procs(!ModuleInfo, PredId, ProcIds, !Defns, !GlobalData)
).
-:- pred ml_gen_procs(list(proc_id)::in, module_info::in, pred_id::in,
- pred_info::in, proc_table::in, list(mlds_defn)::in,
- list(mlds_defn)::out) is det.
-
-ml_gen_procs([], _, _, _, _, !Defns).
-ml_gen_procs([ProcId | ProcIds], ModuleInfo, PredId, PredInfo, ProcTable,
- !Defns) :-
- map.lookup(ProcTable, ProcId, ProcInfo),
- ml_gen_proc(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo, !Defns),
- ml_gen_procs(ProcIds, ModuleInfo, PredId, PredInfo, ProcTable, !Defns).
-
-%-----------------------------------------------------------------------------%
-%
-% Code for handling individual procedures
-%
-
- % Generate MLDS code for the specified procedure.
- %
-:- pred ml_gen_proc(module_info::in, pred_id::in, proc_id::in, pred_info::in,
- proc_info::in, list(mlds_defn)::in, list(mlds_defn)::out) is det.
+:- 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_proc(ModuleInfo, PredId, ProcId, _PredInfo, ProcInfo, !Defns) :-
- proc_info_get_context(ProcInfo, Context),
- ml_gen_proc_label(ModuleInfo, PredId, ProcId, Name, _ModuleName),
- MLDS_Context = mlds_make_context(Context),
- DeclFlags = ml_gen_proc_decl_flags(ModuleInfo, PredId, ProcId),
- ml_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcDefnBody, ExtraDefns),
- ProcDefn = mlds_defn(Name, MLDS_Context, DeclFlags, ProcDefnBody),
- !:Defns = ExtraDefns ++ [ProcDefn | !.Defns].
+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
+% Code for handling tabling structures.
%
:- pred ml_gen_table_structs(module_info::in, list(mlds_defn)::out) is det.
@@ -1300,60 +1301,47 @@
%-----------------------------------------------------------------------------%
%
-% Code for handling individual procedures (continued)
+% Code for handling individual procedures.
+% ZZZ reorder
%
- % 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).
-
- % Generate an MLDS definition for the specified procedure.
- %
-:- pred ml_gen_proc_defn(module_info::in, pred_id::in, proc_id::in,
- mlds_entity_defn::out, list(mlds_defn)::out) is det.
+:- 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(ProcInfo0, ProcInfo),
+ module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
+ !ModuleInfo),
-ml_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcDefnBody, ExtraDefns) :-
- module_info_pred_proc_info(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo),
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, Goal0),
-
- % The HLDS front-end sometimes over-estimates the set of non-locals.
- % We need to restrict the set of non-locals for the top-level goal
- % to just the headvars, because otherwise variables which occur in the
- % top-level non-locals but which are not really non-local will not be
- % declared.
-
- Goal0 = hlds_goal(GoalExpr, GoalInfo0),
- NonLocals0 = goal_info_get_code_gen_nonlocals(GoalInfo0),
- set.list_to_set(HeadVars, HeadVarsSet),
- set.intersect(HeadVarsSet, NonLocals0, NonLocals),
- goal_info_set_code_gen_nonlocals(NonLocals, GoalInfo0, GoalInfo),
- Goal = hlds_goal(GoalExpr, GoalInfo),
+ 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),
+ !:Info = ml_gen_info_init(!.ModuleInfo, PredId, ProcId, ProcInfo,
+ !.GlobalData),
( ImportStatus = status_external(_) ->
% For Mercury procedures declared `:- external', we generate an
@@ -1375,10 +1363,10 @@
( CodeModel = model_det
; CodeModel = model_semi
),
- ml_det_copy_out_vars(ModuleInfo, CopiedOutputVars, !Info)
+ ml_det_copy_out_vars(!.ModuleInfo, CopiedOutputVars, !Info)
;
CodeModel = model_non,
- ml_set_up_initial_succ_cont(ModuleInfo, CopiedOutputVars,
+ ml_set_up_initial_succ_cont(!.ModuleInfo, CopiedOutputVars,
!Info)
),
@@ -1399,8 +1387,8 @@
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
+ % 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,
@@ -1410,25 +1398,56 @@
MLDS_Context = mlds_make_context(Context),
MLDS_LocalVars = [ml_gen_succeeded_var_decl(MLDS_Context) |
OutputVarLocals],
- modes_to_arg_modes(ModuleInfo, Modes, ArgTypes, ArgModes),
+ modes_to_arg_modes(!.ModuleInfo, Modes, ArgTypes, ArgModes),
ml_gen_proc_body(CodeModel, HeadVars, ArgTypes, ArgModes,
- CopiedOutputVars, Goal, Decls0, Statements, !Info),
+ CopiedOutputVars, Goal, Defns0, Statements, !Info),
ml_gen_proc_params(PredId, ProcId, MLDS_Params, !Info),
- ml_gen_info_get_extra_defns(!.Info, ExtraDefns),
- Decls = MLDS_LocalVars ++ Decls0,
- Statement = ml_gen_block(Decls, Statements, Context),
+ 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)
+
),
- ml_gen_info_get_env_vars(!.Info, EnvVarNames)
+ % 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].
- MLDS_Attributes = attributes_to_mlds_attributes(ModuleInfo, AttributeList),
+ % Return the declaration flags appropriate for a procedure definition.
+ %
+:- func ml_gen_proc_decl_flags(module_info, pred_id, proc_id)
+ = mlds_decl_flags.
- ProcDefnBody = mlds_function(yes(proc(PredId, ProcId)), MLDS_Params,
- FunctionBody, MLDS_Attributes, EnvVarNames).
+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)
@@ -1554,7 +1573,6 @@
Context = goal_info_get_context(GoalInfo),
% First just generate the code for the procedure's goal.
- DoGenGoal = ml_gen_goal(CodeModel, Goal),
% In certain cases -- for example existentially typed procedures,
% or unification/compare procedures for equivalence types --
@@ -1573,8 +1591,10 @@
ConvOutputStatements = []
->
% No boxing/unboxing/casting required.
- DoGenGoal(Decls, Statements1, !Info)
+ 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.
@@ -1683,6 +1703,11 @@
% Stuff to generate code for goals.
%
+ml_gen_goal_as_branch(CodeModel, Goal, Decls, Statements, !Info) :-
+ ml_gen_info_get_const_var_map(!.Info, InitConstVarMap),
+ ml_gen_goal(CodeModel, Goal, Decls, Statements, !Info),
+ ml_gen_info_set_const_var_map(InitConstVarMap, !Info).
+
% 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).
@@ -1693,6 +1718,11 @@
Context = goal_info_get_context(GoalInfo),
Statement = ml_gen_block(Decls, Statements, Context).
+ml_gen_goal_as_branch_block(CodeModel, Goal, Statement, !Info) :-
+ ml_gen_info_get_const_var_map(!.Info, InitConstVarMap),
+ ml_gen_goal_as_block(CodeModel, Goal, Statement, !Info),
+ ml_gen_info_set_const_var_map(InitConstVarMap, !Info).
+
% Generate MLDS code for the specified goal in the specified code model.
% Return the result as two lists, one containing the necessary declarations
% and the other containing the generated statements.
@@ -1700,6 +1730,7 @@
ml_gen_goal(CodeModel, Goal, Decls, Statements, !Info) :-
Goal = hlds_goal(GoalExpr, GoalInfo),
Context = goal_info_get_context(GoalInfo),
+
% Generate the local variables for this 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,
@@ -1709,15 +1740,29 @@
% 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.
+
+ goal_expr_find_subgoal_nonlocals(GoalExpr, SubGoalNonLocals),
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ set.difference(SubGoalNonLocals, NonLocals, VarsToDeclareSet),
+ set.to_sorted_list(VarsToDeclareSet, VarsToDeclare0),
- Locals = goal_local_vars(Goal),
- SubGoalLocals = union_of_direct_subgoal_locals(Goal),
- set.difference(Locals, SubGoalLocals, VarsToDeclareHere),
- set.to_sorted_list(VarsToDeclareHere, VarsList0),
- ml_gen_info_get_varset(!.Info, VarSet),
ml_gen_info_get_var_types(!.Info, VarTypes),
- VarsList = put_typeinfo_vars_first(VarsList0, VarTypes),
- ml_gen_local_var_decls(VarSet, VarTypes, Context, VarsList, VarDecls,
+ (
+ ( VarsToDeclare0 = []
+ ; VarsToDeclare0 = [_]
+ ),
+ VarsToDeclare = VarsToDeclare0
+ ;
+ VarsToDeclare0 = [_, _ | _],
+ VarsToDeclare = put_typeinfo_vars_first(VarsToDeclare0, VarTypes)
+ ),
+
+ ml_gen_info_get_varset(!.Info, VarSet),
+ ml_gen_local_var_decls(VarSet, VarTypes, Context, VarsToDeclare, VarDecls,
!Info),
% Generate code for the goal in its own code model.
@@ -1727,78 +1772,195 @@
% Add whatever wrapper is needed to convert the goal's code model
% to the desired code model.
- ml_gen_wrap_goal(CodeModel, GoalCodeModel, Context,
+ ml_gen_maybe_convert_goal_code_model(CodeModel, GoalCodeModel, Context,
GoalStatements0, GoalStatements, !Info),
- ml_join_decls(VarDecls, [], GoalDecls, GoalStatements, Context,
- Decls, Statements).
+ Decls = VarDecls ++ GoalDecls,
+ Statements = GoalStatements.
- % Return the set of variables which occur in the specified goal
- % (including in its subgoals) and which are local to that goal.
+ % 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.
%
-:- func goal_local_vars(hlds_goal) = set(prog_var).
-
-goal_local_vars(Goal) = LocalVars :-
- % Find all the variables in the goal.
- goal_util.goal_vars(Goal, GoalVars),
- % Delete the non-locals.
- Goal = hlds_goal(_, GoalInfo),
- NonLocalVars = goal_info_get_code_gen_nonlocals(GoalInfo),
- set.difference(GoalVars, NonLocalVars, LocalVars).
-
-:- func union_of_direct_subgoal_locals(hlds_goal) = set(prog_var).
+:- pred goal_expr_find_subgoal_nonlocals(hlds_goal_expr::in,
+ set(prog_var)::out) is det.
-union_of_direct_subgoal_locals(hlds_goal(GoalExpr, _))
- = UnionOfSubGoalLocals :-
- promise_equivalent_solutions [UnionOfSubGoalLocals] (
- set.init(EmptySet),
- solutions.unsorted_aggregate(direct_subgoal(GoalExpr),
- union_subgoal_locals, EmptySet, UnionOfSubGoalLocals)
+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 union_subgoal_locals(hlds_goal::in, set(prog_var)::in,
- set(prog_var)::out) is det.
+:- pred goals_find_subgoal_nonlocals(list(hlds_goal)::in,
+ set(prog_var)::in, set(prog_var)::out) is det.
-union_subgoal_locals(SubGoal, UnionOfSubGoalLocals0, UnionOfSubGoalLocals) :-
- SubGoalLocals = goal_local_vars(SubGoal),
- set.union(UnionOfSubGoalLocals0, SubGoalLocals, UnionOfSubGoalLocals).
+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 special.
-
-ml_gen_wrap_goal(model_det, model_det, _, !Statements, !Info).
-ml_gen_wrap_goal(model_semi, model_semi, _, !Statements, !Info).
-ml_gen_wrap_goal(model_non, model_non, _, !Statements, !Info).
-
+ % 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_wrap_goal(model_semi, model_det, Context, !Statements, !Info) :-
- %
+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_wrap_goal(model_non, model_det, Context, !Statements, !Info) :-
- %
+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_wrap_goal(model_non, model_semi, Context, !Statements, !Info) :-
- %
+ml_gen_maybe_convert_goal_code_model(model_non, model_semi, Context,
+ !Statements, !Info) :-
% semi goal in nondet context:
% <Goal && SUCCEED()>
% ===>
@@ -1806,27 +1968,13 @@
%
% <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].
- % If the inner code model is less precise than the outer code model,
- % then simplify.m is supposed to wrap the goal inside a `some'
- % to indicate that a commit is needed.
-
-ml_gen_wrap_goal(model_det, model_semi, _, _, _, !Info) :-
- unexpected(this_file,
- "ml_gen_wrap_goal: code model mismatch -- semi in det").
-ml_gen_wrap_goal(model_det, model_non, _, _, _, !Info) :-
- unexpected(this_file,
- "ml_gen_wrap_goal: code model mismatch -- nondet in det").
-ml_gen_wrap_goal(model_semi, model_non, _, _, _, !Info) :-
- unexpected(this_file,
- "ml_gen_wrap_goal: code model mismatch -- nondet in semi").
-
% Generate code for a commit.
%
:- pred ml_gen_commit(hlds_goal::in, code_model::in, prog_context::in,
@@ -1887,9 +2035,7 @@
!Info),
% push nesting level
MLDS_Context = mlds_make_context(Context),
- ml_gen_info_new_commit_label(CommitLabelNum, !Info),
- CommitRef = mlds_var_name(string.format("commit_%d",
- [i(CommitLabelNum)]), no),
+ 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)),
@@ -1967,9 +2113,7 @@
!Info),
% push nesting level
MLDS_Context = mlds_make_context(Context),
- ml_gen_info_new_commit_label(CommitLabelNum, !Info),
- CommitRef = mlds_var_name(
- string.format("commit_%d", [i(CommitLabelNum)]), no),
+ 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)),
@@ -2277,10 +2421,14 @@
GoalExpr = negation(SubGoal),
ml_gen_negation(SubGoal, CodeModel, Context, Decls, Statements, !Info)
;
- GoalExpr = scope(_, SubGoal),
- % XXX We could special-case the handling of from_ground_term_construct
- % scopes.
- ml_gen_commit(SubGoal, CodeModel, Context, Decls, Statements, !Info)
+ GoalExpr = scope(Reason, SubGoal),
+ ( Reason = from_ground_term(TermVar, from_ground_term_construct) ->
+ ml_gen_ground_term(TermVar, SubGoal, Statements, !Info),
+ Decls = []
+ ;
+ ml_gen_commit(SubGoal, CodeModel, Context, Decls, Statements,
+ !Info)
+ )
;
GoalExpr = shorthand(_),
% these should have been expanded out by now
@@ -2353,7 +2501,6 @@
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#")
@@ -2364,10 +2511,9 @@
% 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
- %
+ % and LOCALS macros.
+
string.append_list([
" #define FAIL (MR_done = MR_TRUE)\n",
" #define SUCCEED (MR_succeeded = MR_TRUE)\n",
@@ -2603,7 +2749,6 @@
ml_gen_ordinary_pragma_java_proc(_CodeModel, Attributes, _PredId, _ProcId,
Args, ExtraArgs, JavaCode, Context, Decls, Statements, !Info) :-
-
Lang = get_foreign_language(Attributes),
% Generate <declaration of one local variable for each arg>
@@ -2785,9 +2930,9 @@
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),
+ 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, [
@@ -2963,7 +3108,6 @@
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>
@@ -3251,8 +3395,8 @@
ArgRval = ml_const(mlconst_int(0))
;
IsDummy = is_not_dummy_type,
- ml_gen_box_or_unbox_rval(VarType, OrigType, BoxPolicy,
- ml_lval(VarLval), ArgRval, !Info)
+ 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
@@ -3276,15 +3420,14 @@
)
->
% In the usual case, we can just use an assignment and perhaps a cast.
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ 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.)
- string.format("(%s)", [s(TypeString)], Cast)
+ Cast = "(" ++ TypeString ++ ")"
;
HighLevelData = no,
% For --no-high-level-data, we only need to use a cast is for
@@ -3471,9 +3614,7 @@
->
% In the usual case, we can just use an assignment,
% perhaps with a cast.
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data,
- HighLevelData),
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
(
HighLevelData = yes,
% In general, the types used for the C interface are not the same
@@ -3482,7 +3623,7 @@
% 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.
- string.format("*(%s *)&", [s(TypeString)], LHS_Cast),
+ LHS_Cast = "* (" ++ TypeString ++ " *) &",
RHS_Cast = ""
;
HighLevelData = no,
@@ -3520,7 +3661,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for if-then-else
+% Code for if-then-else.
%
:- pred ml_gen_ite(code_model::in, hlds_goal::in, hlds_goal::in, hlds_goal::in,
@@ -3556,10 +3697,13 @@
% }
CondCodeModel = model_semi,
+ ml_gen_info_get_const_var_map(!.Info, InitConstVarMap),
ml_gen_goal(model_semi, Cond, CondDecls, CondStatements, !Info),
ml_gen_test_success(!.Info, Succeeded),
ml_gen_goal_as_block(CodeModel, Then, ThenStatement, !Info),
+ ml_gen_info_set_const_var_map(InitConstVarMap, !Info),
ml_gen_goal_as_block(CodeModel, Else, ElseStatement, !Info),
+ ml_gen_info_set_const_var_map(InitConstVarMap, !Info),
IfStmt = ml_stmt_if_then_else(Succeeded, ThenStatement,
yes(ElseStatement)),
IfStatement = statement(IfStmt, mlds_make_context(Context)),
@@ -3592,6 +3736,7 @@
% is needed for declarations of static consts)
CondCodeModel = model_non,
+ ml_gen_info_get_const_var_map(!.Info, InitConstVarMap),
% Generate the `cond_<N>' var and the code to initialize it to false.
ml_gen_info_new_cond_var(CondVar, !Info),
@@ -3625,7 +3770,9 @@
% Generate `if (!cond_<N>) { <Else> }'.
ml_gen_test_cond_var(!.Info, CondVar, CondSucceeded),
+ ml_gen_info_set_const_var_map(InitConstVarMap, !Info),
ml_gen_goal_as_block(CodeModel, Else, ElseStatement, !Info),
+ ml_gen_info_set_const_var_map(InitConstVarMap, !Info),
IfStmt = ml_stmt_if_then_else(
ml_unop(std_unop(logical_not), CondSucceeded),
ElseStatement, no),
@@ -3638,7 +3785,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for negation
+% Code for negation.
%
:- pred ml_gen_negation(hlds_goal::in, code_model::in, prog_context::in,
@@ -3660,7 +3807,7 @@
% }
CodeModel = model_det,
- ml_gen_goal(model_semi, Cond, Decls, Statements, !Info)
+ ml_gen_goal_as_branch(model_semi, Cond, Decls, Statements, !Info)
;
% model_semi negation, model_det goal:
% <succeeded = not(Goal)>
@@ -3669,7 +3816,8 @@
% succeeded = MR_FALSE;
CodeModel = model_semi, CondCodeModel = model_det,
- ml_gen_goal(model_det, Cond, CondDecls, CondStatements, !Info),
+ ml_gen_goal_as_branch(model_det, Cond, CondDecls, CondStatements,
+ !Info),
ml_gen_set_success(!.Info, ml_const(mlconst_false), Context,
SetSuccessFalse),
Decls = CondDecls,
@@ -3682,7 +3830,8 @@
% succeeded = !succeeded;
CodeModel = model_semi, CondCodeModel = model_semi,
- ml_gen_goal(model_semi, Cond, CondDecls, CondStatements, !Info),
+ ml_gen_goal_as_branch(model_semi, Cond, CondDecls, CondStatements,
+ !Info),
ml_gen_test_success(!.Info, Succeeded),
ml_gen_set_success(!.Info, ml_unop(std_unop(logical_not), Succeeded),
Context, InvertSuccess),
@@ -3698,7 +3847,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for conjunctions
+% Code for conjunctions.
%
:- pred ml_gen_conj(hlds_goals::in, code_model::in, prog_context::in,
@@ -3732,7 +3881,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for disjunctions
+% Code for disjunctions.
%
:- pred ml_gen_disj(hlds_goals::in, code_model::in, prog_context::in,
@@ -3751,16 +3900,18 @@
% (The HLDS should not contain singleton disjunctions, but this code
% is needed to handle recursive calls to ml_gen_disj).
% Note that each arm of the model_non disjunction is placed into
- % a block. This avoids a problem where ml_join_decls can create block
- % nesting proportional to the size of the disjunction. The nesting
- % can hit fixed limit problems in some C compilers.
- ml_gen_goal(CodeModel, SingleGoal, Goal_Decls, Goal_Statements, !Info),
+ % a block. This used to avoid a problem where ml_join_decls could
+ % create block nesting proportional to the size of the disjunction,
+ % which could exceed nesting limits in some C compilers.
+ % ZZZ Now, we generate it just so the code looks neater.
+ ml_gen_goal_as_branch(CodeModel, SingleGoal,
+ Goal_Decls, Goal_Statements, !Info),
Statement = ml_gen_block(Goal_Decls, Goal_Statements, Context),
Statements = [Statement],
Decls = []
;
- Goals = [First | Rest],
- Rest = [_ | _],
+ Goals = [FirstGoal | LaterGoals],
+ LaterGoals = [_ | _],
(
CodeModel = model_non,
% model_non disj:
@@ -3770,18 +3921,19 @@
% <Goal && SUCCEED()>
% <Goals && SUCCEED()>
- ml_gen_goal(model_non, First, FirstDecls, FirstStatements, !Info),
- ml_gen_disj(Rest, model_non, Context, RestDecls, RestStatements,
- !Info),
+ ml_gen_goal_as_branch(model_non, FirstGoal,
+ FirstDecls, FirstStatements, !Info),
+ ml_gen_disj(LaterGoals, model_non, Context,
+ LaterDecls, LaterStatements, !Info),
(
- RestDecls = [],
+ LaterDecls = [],
FirstBlock = ml_gen_block(FirstDecls, FirstStatements,
Context),
Decls = [],
- Statements = [FirstBlock | RestStatements]
+ Statements = [FirstBlock | LaterStatements]
;
- RestDecls = [_ | _],
- unexpected(this_file, "ml_gen_disj: RestDecls not empty.")
+ LaterDecls = [_ | _],
+ unexpected(this_file, "ml_gen_disj: LaterDecls not empty.")
)
;
( CodeModel = model_det
@@ -3807,23 +3959,23 @@
% }
% }
- First = hlds_goal(_, FirstGoalInfo),
+ FirstGoal = hlds_goal(_, FirstGoalInfo),
FirstCodeModel = goal_info_get_code_model(FirstGoalInfo),
(
FirstCodeModel = model_det,
- ml_gen_goal(model_det, First, Decls, Statements, !Info)
+ ml_gen_goal(model_det, FirstGoal, Decls, Statements, !Info)
;
FirstCodeModel = model_semi,
- ml_gen_goal(model_semi, First, FirstDecls, FirstStatements,
- !Info),
+ ml_gen_goal_as_branch(model_semi, FirstGoal,
+ FirstDecls, FirstStatements, !Info),
ml_gen_test_success(!.Info, Succeeded),
- ml_gen_disj(Rest, CodeModel, Context,
- RestDecls, RestStatements, !Info),
- RestStatement = ml_gen_block(RestDecls, RestStatements,
+ ml_gen_disj(LaterGoals, CodeModel, Context,
+ LaterDecls, LaterStatements, !Info),
+ LaterStatement = ml_gen_block(LaterDecls, LaterStatements,
Context),
IfStmt = ml_stmt_if_then_else(
ml_unop(std_unop(logical_not), Succeeded),
- RestStatement, no),
+ LaterStatement, no),
IfStatement = statement(IfStmt, mlds_make_context(Context)),
Decls = FirstDecls,
Statements = FirstStatements ++ [IfStatement]
@@ -3838,7 +3990,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for handling attributes
+% Code for handling attributes.
%
:- func attributes_to_mlds_attributes(module_info, list(hlds_pred.attribute))
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.139
diff -u -b -r1.139 ml_code_util.m
--- compiler/ml_code_util.m 25 Aug 2009 23:46:48 -0000 1.139
+++ compiler/ml_code_util.m 31 Aug 2009 01:13:34 -0000
@@ -25,6 +25,7 @@
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.mlds.
+:- import_module ml_backend.ml_global_data.
:- import_module parse_tree.prog_data.
:- import_module bool.
@@ -35,7 +36,7 @@
%-----------------------------------------------------------------------------%
%
-% Various utility routines used for MLDS code generation
+% Various utility routines used for MLDS code generation.
%
% Generate an MLDS assignment statement.
@@ -58,19 +59,6 @@
:- func ml_gen_block_mlds(list(mlds_defn), list(statement), mlds_context)
= statement.
- % Join two statement lists and their corresponding declaration lists
- % in sequence.
- %
- % If the statements have no declarations in common, then their
- % corresponding declaration lists will be concatenated together into
- % a single list of declarations. But if they have any declarations
- % in common, then we put each statement list and its declarations into
- % a block, so that the declarations remain local to each statement list.
- %
-:- pred ml_join_decls(list(mlds_defn)::in, list(statement)::in,
- list(mlds_defn)::in, list(statement)::in, prog_context::in,
- list(mlds_defn)::out, list(statement)::out) is det.
-
:- type gen_pred == pred(list(mlds_defn), list(statement),
ml_gen_info, ml_gen_info).
:- inst gen_pred == (pred(out, out, in, out) is det).
@@ -109,7 +97,7 @@
%-----------------------------------------------------------------------------%
%
-% Routines for generating expressions
+% Routines for generating expressions.
%
% conjunction: ml_gen_and(X,Y) = binop((and), X, Y),
@@ -122,7 +110,7 @@
%-----------------------------------------------------------------------------%
%
-% Routines for generating types
+% Routines for generating types.
%
% Convert a Mercury type to an MLDS type.
@@ -184,7 +172,7 @@
%-----------------------------------------------------------------------------%
%
-% Routines for generating labels and entity names
+% Routines for generating labels and entity names.
%
% Generate the mlds_entity_name and module name for the entry point
@@ -223,7 +211,7 @@
%-----------------------------------------------------------------------------%
%
-% Routines for dealing with variables
+% Routines for dealing with variables.
%
% Generate a list of the mlds_lvals corresponding to a given list
@@ -297,7 +285,7 @@
%-----------------------------------------------------------------------------%
%
-% Routines for dealing with static constants
+% Routines for dealing with static constants.
%
% ml_format_reserved_object_name(CtorName, CtorArity, ReservedObjName):
@@ -308,16 +296,12 @@
%
:- func ml_format_reserved_object_name(string, arity) = mlds_var_name.
- % Generate a name for a local static constant.
- %
-:- pred ml_format_static_const_name(ml_gen_info::in, string::in, const_seq::in,
- mlds_var_name::out) is det.
-
% Generate a definition of a static constant, given the constant's name,
% type, accessibility, and initializer.
%
-:- func ml_gen_static_const_defn(mlds_var_name, mlds_type, access,
- mlds_initializer, prog_context) = mlds_defn.
+:- pred ml_gen_static_const_defn(string::in, mlds_type::in, access::in,
+ mlds_initializer::in, prog_context::in, mlds_var_name::out,
+ ml_global_data::in, ml_global_data::out) is det.
% Return the declaration flags appropriate for an initialized
% local static constant.
@@ -330,7 +314,7 @@
%-----------------------------------------------------------------------------%
%
-% Routines for dealing with fields
+% Routines for dealing with fields.
%
% Given the user-specified field name, if any, and the argument number
@@ -343,11 +327,11 @@
% are not word-sized, because the code for `arg' etc. in std_util.m
% relies on all arguments being word-sized.
%
-:- pred ml_must_box_field_type(mer_type::in, module_info::in) is semidet.
+:- pred ml_must_box_field_type(module_info::in, mer_type::in) is semidet.
%-----------------------------------------------------------------------------%
%
-% Routines for handling success and failure
+% Routines for handling success and failure.
%
% Generate code to succeed in the given code_model.
@@ -437,7 +421,7 @@
%-----------------------------------------------------------------------------%
%
-% Routines for dealing with the environment pointer used for nested functions
+% Routines for dealing with the environment pointer used for nested functions.
%
% Return an rval for a pointer to the current environment (the set of local
@@ -455,7 +439,7 @@
%-----------------------------------------------------------------------------%
%
-% Code to handle accurate GC
+% Code to handle accurate GC.
%
% ml_gen_gc_statement(Var, Type, Context, Code):
@@ -468,9 +452,9 @@
prog_context::in, mlds_gc_statement::out,
ml_gen_info::in, ml_gen_info::out) is det.
- % ml_gen_gc_statement(Var, DeclType, ActualType, Context, Code):
+ % ml_gen_gc_statement_poly(Var, DeclType, ActualType, Context, Code):
%
- % This is the same as the //4 version (above), except that it takes two
+ % 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
@@ -486,15 +470,15 @@
% doesn't (e.g. because DeclType may be a boxed float). So we need to pass
% both.
%
-:- pred ml_gen_gc_statement(mlds_var_name::in,
+:- 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//5, except that rather
- % than passing ActualType, the caller constructs the type-info itself,
+ % 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
@@ -527,7 +511,7 @@
%-----------------------------------------------------------------------------%
%
-% Miscellaneous routines
+% Miscellaneous routines.
%
% Get the value of the appropriate --det-copy-out or --nondet-copy-out
@@ -555,12 +539,16 @@
:- type ml_gen_info.
% Initialize the ml_gen_info, so that it is ready for generating code
- % for the given procedure.
+ % 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) = ml_gen_info.
+:- 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_module_name(ml_gen_info::in, mercury_module_name::out)
+:- 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.
@@ -570,12 +558,19 @@
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_globals(ml_gen_info::in, globals::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.
%
@@ -613,18 +608,19 @@
%
:- pred ml_gen_info_bump_counters(ml_gen_info::in, ml_gen_info::out) is det.
- % Generate a new commit label number. This is used to give unique names
- % to the labels used when generating code for commits.
+ % 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.
%
-:- type commit_sequence_num == int.
-:- pred ml_gen_info_new_commit_label(commit_sequence_num::out,
+ % 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. This is used to give unique names
- % to the local variables used to hold the results of nondet conditions
- % of if-then-elses.
+ % Generate a new `cond' variable number.
%
-:- type cond_seq == int.
+:- 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.
@@ -632,30 +628,34 @@
% to the local variables generated by ml_gen_box_or_unbox_lval, which are
% used to handle boxing/unboxing argument conversions.
%
-:- type conv_seq == int.
+:- 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.
- % Generate a new `const' sequence number. This is used to give unique names
- % to the local constants generated for --static-ground-terms, closure
- % layouts, string switch hash tables, etc.
- %
-:- type const_seq == int.
-:- pred ml_gen_info_new_const(const_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
+ ).
+
+:- 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_name(prog_var::in, mlds_var_name::in,
+:- 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_name(ml_gen_info::in, prog_var::in,
- mlds_var_name::out) is det.
-:- pred ml_gen_info_search_const_var_name(ml_gen_info::in, prog_var::in,
- mlds_var_name::out) is semidet.
+:- 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
@@ -709,6 +709,21 @@
:- 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
@@ -719,13 +734,13 @@
% Insert an extra definition at the start of the list of extra
% definitions.
%
-:- pred ml_gen_info_add_extra_defn(mlds_defn::in,
+:- 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_extra_defns(ml_gen_info::in, list(mlds_defn)::out)
- is det.
+:- 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.
@@ -735,7 +750,8 @@
% Get the names of the used environment variables.
%
-:- pred ml_gen_info_get_env_vars(ml_gen_info::in, set(string)::out) is det.
+:- pred ml_gen_info_get_env_var_names(ml_gen_info::in, set(string)::out)
+ is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -743,7 +759,6 @@
:- implementation.
:- import_module backend_libs.foreign.
-:- import_module backend_libs.rtti.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.polymorphism.
:- import_module check_hlds.type_util.
@@ -770,7 +785,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for various utility routines
+% Code for various utility routines.
%
ml_gen_assign(Lval, Rval, Context) = Statement :-
@@ -828,23 +843,6 @@
Context)
).
-ml_join_decls(FirstDecls, FirstStatements, RestDecls, RestStatements, Context,
- Decls, Statements) :-
- (
- some [Name] (
- list.member(mlds_defn(Name, _, _, _), FirstDecls),
- list.member(mlds_defn(Name, _, _, _), RestDecls)
- )
- ->
- First = ml_gen_block(FirstDecls, FirstStatements, Context),
- Rest = ml_gen_block(RestDecls, RestStatements, Context),
- Decls = [],
- Statements = [First, Rest]
- ;
- Decls = FirstDecls ++ RestDecls,
- Statements = FirstStatements ++ RestStatements
- ).
-
ml_combine_conj(FirstCodeModel, Context, DoGenFirst, DoGenRest,
Decls, Statements, !Info) :-
(
@@ -857,8 +855,8 @@
FirstCodeModel = model_det,
DoGenFirst(FirstDecls, FirstStatements, !Info),
DoGenRest(RestDecls, RestStatements, !Info),
- ml_join_decls(FirstDecls, FirstStatements, RestDecls, RestStatements,
- Context, Decls, Statements)
+ Decls = FirstDecls ++ RestDecls,
+ Statements = FirstStatements ++ RestStatements
;
% model_semi goal:
% <Goal, Goals>
@@ -1037,7 +1035,7 @@
HeadModes, PredOrFunc, CodeModel).
ml_gen_proc_params(PredId, ProcId, FuncParams, !Info) :-
- ModuleInfo = !.Info ^ mgi_module_info,
+ 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_headvars(ProcInfo, HeadVars),
@@ -1083,7 +1081,7 @@
ml_gen_params(HeadVarNames, HeadTypes, HeadModes, PredOrFunc,
CodeModel, FuncParams, !Info) :-
- ModuleInfo = !.Info ^ mgi_module_info,
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
modes_to_arg_modes(ModuleInfo, HeadModes, HeadTypes, ArgModes),
ml_gen_params_base(ModuleInfo, HeadVarNames,
HeadTypes, ArgModes, PredOrFunc, CodeModel, FuncParams,
@@ -1252,8 +1250,7 @@
!.MaybeInfo = yes(Info0),
% XXX We should fill in this Context properly.
term.context_init(Context),
- ml_gen_gc_statement(Var, Type, Context, GCStatement,
- Info0, Info),
+ ml_gen_gc_statement(Var, Type, Context, GCStatement, Info0, Info),
!:MaybeInfo = yes(Info)
;
!.MaybeInfo = no,
@@ -1421,11 +1418,11 @@
ml_gen_new_label(Label, !Info) :-
ml_gen_info_new_label(LabelNum, !Info),
- string.format("label_%d", [i(LabelNum)], Label).
+ Label = "label_" ++ string.int_to_string(LabelNum).
%-----------------------------------------------------------------------------%
%
-% Code for dealing with variables
+% Code for dealing with variables.
%
ml_gen_var_list(_Info, [], []).
@@ -1495,28 +1492,14 @@
ml_format_reserved_object_name(CtorName, CtorArity) = ReservedObjName :-
% We add the "obj_" prefix to avoid any potential name clashes.
-
- Name = string.format("obj_%s_%d", [s(CtorName), i(CtorArity)]),
+ Name = "obj_" ++ CtorName ++ "_" ++ string.int_to_string(CtorArity),
ReservedObjName = mlds_var_name(Name, no).
-ml_format_static_const_name(Info, BaseName, SequenceNum, ConstName) :-
- % To ensure that the names are unique, we qualify them with the pred_id
- % and proc_id numbers, as well as a sequence number. This is needed to
- % allow ml_elim_nested.m to hoist such constants out to top level.
-
- ml_gen_info_get_pred_id(Info, PredId),
- ml_gen_info_get_proc_id(Info, ProcId),
- pred_id_to_int(PredId, PredIdNum),
- proc_id_to_int(ProcId, ProcIdNum),
- ConstName = mlds_var_name(
- string.format("const_%d_%d_%d_%s", [i(PredIdNum),
- i(ProcIdNum), i(SequenceNum), s(BaseName)]), no).
-
ml_gen_var_lval(Info, VarName, VarType, QualifiedVarLval) :-
ml_gen_info_get_module_name(Info, ModuleName),
MLDS_Module = mercury_module_name_to_mlds(ModuleName),
- QualifiedVarLval = ml_var(qual(MLDS_Module, module_qual, VarName),
- VarType).
+ MLDS_Var = qual(MLDS_Module, module_qual, VarName),
+ QualifiedVarLval = ml_var(MLDS_Var, VarType).
ml_gen_var_decl(VarName, Type, Context, Defn, !Info) :-
ml_gen_info_get_module_info(!.Info, ModuleInfo),
@@ -1530,23 +1513,25 @@
Context).
ml_gen_mlds_var_decl_init(DataName, MLDS_Type, Initializer, GCStatement,
- Context) = MLDS_Defn :-
+ Context) = Defn :-
Name = entity_data(DataName),
- Defn = mlds_data(MLDS_Type, Initializer, GCStatement),
+ EntityDefn = mlds_data(MLDS_Type, Initializer, GCStatement),
DeclFlags = ml_gen_local_var_decl_flags,
- MLDS_Defn = mlds_defn(Name, Context, DeclFlags, Defn).
+ Defn = mlds_defn(Name, Context, DeclFlags, EntityDefn).
-ml_gen_static_const_defn(ConstName, ConstType, Access, Initializer, Context) =
- MLDS_Defn :-
- Name = entity_data(mlds_data_var(ConstName)),
- % The GC never needs to trace static constants,
- % because they can never point into the heap
- % (only to other static constants).
+ml_gen_static_const_defn(ConstName, ConstType, Access, Initializer, Context,
+ VarName, !GlobalData) :-
+ ml_global_data_get_unique_const_num(ConstNum, !GlobalData),
+ VarName = mlds_var_name(ConstName, yes(ConstNum)),
+ EntityName = entity_data(mlds_data_var(VarName)),
+ % The GC never needs to trace static constants, because they can never
+ % point into the heap; they can point only to other static constants.
GCStatement = gc_no_stmt,
- Defn = mlds_data(ConstType, Initializer, GCStatement),
+ EntityDefn = mlds_data(ConstType, Initializer, GCStatement),
DeclFlags = mlds.set_access(ml_static_const_decl_flags, Access),
MLDS_Context = mlds_make_context(Context),
- MLDS_Defn = mlds_defn(Name, MLDS_Context, DeclFlags, Defn).
+ Defn = mlds_defn(EntityName, MLDS_Context, DeclFlags, EntityDefn),
+ ml_global_data_add_flat_cell_defn(Defn, !GlobalData).
ml_gen_public_field_decl_flags = DeclFlags :-
Access = acc_public,
@@ -1581,12 +1566,12 @@
Virtuality, Finality, Constness, Abstractness).
ml_var_name_to_string(mlds_var_name(Var, yes(Num))) =
- string.format("%s_%d", [s(Var), i(Num)]).
+ Var ++ "_" ++ string.int_to_string(Num).
ml_var_name_to_string(mlds_var_name(Var, no)) = Var.
%-----------------------------------------------------------------------------%
%
-% Code for dealing with fields
+% Code for dealing with fields.
%
% Given the user-specified field name, if any, and the argument number
@@ -1600,7 +1585,7 @@
FieldName = unqualify_name(QualifiedFieldName)
;
MaybeFieldName = no,
- FieldName = string.format("F%d", [i(ArgNum)])
+ FieldName = "F" ++ string.int_to_string(ArgNum)
).
% Succeed iff the specified type must be boxed when used as a field.
@@ -1611,7 +1596,7 @@
% that don't need it, e.g. the .NET and Java back-ends. This routine should
% be modified to check the target.
%
-ml_must_box_field_type(Type, ModuleInfo) :-
+ml_must_box_field_type(ModuleInfo, Type) :-
classify_type(ModuleInfo, Type) = Category,
ml_must_box_field_type_category(Category) = yes.
@@ -1640,7 +1625,7 @@
%-----------------------------------------------------------------------------%
%
-% Code for handling success and failure
+% Code for handling success and failure.
%
ml_gen_success(model_det, _, Statements, !Info) :-
@@ -1713,8 +1698,10 @@
%
:- func ml_gen_cond_var_name(cond_seq) = mlds_var_name.
-ml_gen_cond_var_name(CondVar) =
- mlds_var_name(string.append("cond_", string.int_to_string(CondVar)), no).
+ml_gen_cond_var_name(CondVar) = VarName :-
+ CondVar = cond_seq(CondNum),
+ CondName = string.append("cond_", string.int_to_string(CondNum)),
+ VarName = mlds_var_name(CondName, no).
ml_gen_cond_var_decl(CondVar, Context) =
ml_gen_mlds_var_decl(mlds_data_var(ml_gen_cond_var_name(CondVar)),
@@ -1893,13 +1880,12 @@
%-----------------------------------------------------------------------------%
%
-% Routines for dealing with the environment pointer
-% used for nested functions.
+% Routines for dealing with the environment pointer used for nested functions.
%
ml_get_env_ptr(Info, ml_lval(EnvPtrLval)) :-
- ml_gen_var_lval(Info, mlds_var_name("env_ptr", no),
- mlds_unknown_type, EnvPtrLval).
+ ml_gen_var_lval(Info, mlds_var_name("env_ptr", no), mlds_unknown_type,
+ EnvPtrLval).
ml_declare_env_ptr_arg(mlds_argument(Name, Type, GCStatement)) :-
Name = entity_data(mlds_data_var(mlds_var_name("env_ptr_arg", no))),
@@ -1913,13 +1899,13 @@
%-----------------------------------------------------------------------------%
%
-% Code to handle accurate GC
+% Code to handle accurate GC.
%
ml_gen_gc_statement(VarName, Type, Context, GCStatement, !Info) :-
- ml_gen_gc_statement(VarName, Type, Type, Context, GCStatement, !Info).
+ ml_gen_gc_statement_poly(VarName, Type, Type, Context, GCStatement, !Info).
-ml_gen_gc_statement(VarName, DeclType, ActualType, Context,
+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,
@@ -2140,10 +2126,10 @@
ml_gen_info_get_var_types(!.Info, VarTypes),
MLDS_Context = mlds_make_context(Context),
GenLocalVarDecl =
- (func(Var) = MLDS_Defn :-
+ (func(Var) = VarDefn :-
LocalVarName = ml_gen_var_name(VarSet, Var),
map.lookup(VarTypes, Var, LocalVarType),
- MLDS_Defn = ml_gen_mlds_var_decl(mlds_data_var(LocalVarName),
+ VarDefn = ml_gen_mlds_var_decl(mlds_data_var(LocalVarName),
mercury_type_to_mlds_type(ModuleInfo, LocalVarType),
gc_no_stmt, MLDS_Context)
),
@@ -2155,9 +2141,9 @@
[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.
+ % 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.
@@ -2188,10 +2174,9 @@
% Generate the call
% `private_builtin.gc_trace(TypeInfo, (MR_C_Pointer) &Var);'.
CastVarAddr = ml_unop(cast(CPointerType), ml_mem_addr(VarLval)),
- TraceStatement = statement(
- ml_stmt_call(Signature, FuncAddr, no,
- [TypeInfoRval, CastVarAddr], [], ordinary_call
- ), mlds_make_context(Context)).
+ 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.
%
@@ -2200,9 +2185,9 @@
ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_make_type_info_var(Type, Context, TypeInfoVar, TypeInfoGoals, !Info) :-
- ModuleInfo0 = !.Info ^ mgi_module_info,
- PredId = !.Info ^ mgi_pred_id,
- ProcId = !.Info ^ mgi_proc_id,
+ 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),
@@ -2218,9 +2203,9 @@
ModuleInfo1, ModuleInfo),
proc_info_get_varset(ProcInfo, VarSet),
proc_info_get_vartypes(ProcInfo, VarTypes),
- !:Info = !.Info ^ mgi_module_info := ModuleInfo,
- !:Info = !.Info ^ mgi_varset := VarSet,
- !:Info = !.Info ^ mgi_var_types := VarTypes.
+ ml_gen_info_set_module_info(ModuleInfo, !Info),
+ ml_gen_info_set_varset(VarSet, !Info),
+ ml_gen_info_set_var_types(VarTypes, !Info).
%-----------------------------------------------------------------------------%
@@ -2424,61 +2409,73 @@
% The definition of the `ml_gen_info' ADT.
%
-% The `ml_gen_info' type holds information used during MLDS code generation
-% for a given procedure.
-%
-% Only the `func_label', `commit_label', `cond_var', `conv_var', `const_num',
-% `var_lvals', `success_cont_stack', and `extra_defns' fields are mutable;
-% the others are set when the `ml_gen_info' is created and then never
-% modified.
-
+ % The `ml_gen_info' type holds information used during MLDS code generation
+ % for a given procedure.
+ %
:- type ml_gen_info
---> ml_gen_info(
- % These fields remain constant for each procedure
- % (unless accurate GC is enabled, in which case the
- % varset and var_types may get updated if we create
- % fresh variables for type_info variables needed
- % for calls to private_builtin.gc_trace).
-
- mgi_module_info :: module_info,
- mgi_pred_id :: pred_id,
- mgi_proc_id :: proc_id,
- mgi_varset :: prog_varset,
- mgi_var_types :: vartypes,
+/* 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.
- mgi_byref_output_vars :: list(prog_var),
+/* 4 */ mgi_byref_output_vars :: list(prog_var),
% Output arguments that are returned as values.
- mgi_value_output_vars :: list(prog_var),
+/* 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,
- % These fields get updated as we traverse each procedure.
+ % The identity of the procedure we are generating code for.
+/* 3 */ mgsi_pred_id :: pred_id,
+/* 4 */ mgsi_proc_id :: proc_id,
- mgi_func_label :: counter,
- mgi_commit_label :: counter,
- mgi_label :: counter,
- mgi_cond_var :: counter,
- mgi_conv_var :: counter,
- mgi_const_num :: counter,
+/* 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,
- mgi_const_var_name_map :: map(prog_var, mlds_var_name),
+/* 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.
- mgi_success_cont_stack :: stack(success_cont),
-
- % Definitions of functions or global constants which should be
- % inserted before the definition of the function for the
- % current procedure.
- mgi_var_lvals :: map(prog_var, mlds_lval),
+/* 12 */ mgsi_success_cont_stack :: stack(success_cont),
- mgi_extra_defns :: list(mlds_defn),
- mgi_env_var_names :: set(string)
+/* 13 */ mgsi_env_var_names :: set(string)
).
-ml_gen_info_init(ModuleInfo, PredId, ProcId) = Info :-
- module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
- _PredInfo, ProcInfo),
+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),
@@ -2493,54 +2490,157 @@
% name (see ml_elim_nested.gen_gc_trace_func/8 for details).
%
counter.init(1, FuncLabelCounter),
- counter.init(0, CommitLabelCounter),
counter.init(0, LabelCounter),
+ counter.init(0, AuxVarCounter),
counter.init(0, CondVarCounter),
counter.init(0, ConvVarCounter),
- counter.init(0, ConstCounter),
- map.init(ConstNumMap),
+ map.init(ConstVarMap),
stack.init(SuccContStack),
map.init(VarLvals),
- ExtraDefns = [],
+ ClosureWrapperDefns = [],
EnvVarNames = set.init,
- Info = ml_gen_info(
- ModuleInfo,
+ SubInfo = ml_gen_sub_info(
+ HighLevelData,
+ CompilationTarget,
PredId,
ProcId,
- VarSet,
- VarTypes,
- ByRefOutputVars,
- ValueOutputVars,
FuncLabelCounter,
- CommitLabelCounter,
LabelCounter,
+ AuxVarCounter,
CondVarCounter,
ConvVarCounter,
- ConstCounter,
- ConstNumMap,
+ ConstVarMap,
+ ClosureWrapperDefns,
SuccContStack,
- VarLvals,
- ExtraDefns,
EnvVarNames
+ ),
+ Info = ml_gen_info(
+ ModuleInfo,
+ VarSet,
+ VarTypes,
+ ByRefOutputVars,
+ ValueOutputVars,
+ VarLvals,
+ GlobalData,
+ SubInfo
).
-ml_gen_info_get_module_info(Info, Info ^ mgi_module_info).
-
-ml_gen_info_get_module_name(Info, ModuleName) :-
- ml_gen_info_get_module_info(Info, ModuleInfo),
- module_info_get_name(ModuleInfo, ModuleName).
+:- 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_pred_id(Info, Info ^ mgi_pred_id).
-ml_gen_info_get_proc_id(Info, Info ^ mgi_proc_id).
+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_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_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),
@@ -2556,86 +2656,86 @@
ml_gen_info_get_module_info(Info, ModuleInfo),
module_info_get_globals(ModuleInfo, Globals).
-ml_gen_info_new_label(Label, !Info) :-
- Counter0 = !.Info ^ mgi_label,
+ml_gen_info_new_func_label(Label, !Info) :-
+ ml_gen_info_get_func_counter(!.Info, Counter0),
counter.allocate(Label, Counter0, Counter),
- !Info ^ mgi_label := Counter.
+ ml_gen_info_set_func_counter(Counter, !Info).
-ml_gen_info_new_func_label(Label, !Info) :-
- Counter0 = !.Info ^ mgi_func_label,
+ml_gen_info_new_label(Label, !Info) :-
+ ml_gen_info_get_label_counter(!.Info, Counter0),
counter.allocate(Label, Counter0, Counter),
- !Info ^ mgi_func_label := Counter.
+ ml_gen_info_set_label_counter(Counter, !Info).
ml_gen_info_bump_counters(!Info) :-
- FuncLabelCounter0 = !.Info ^ mgi_func_label,
- ConstNumCounter0 = !.Info ^ mgi_const_num,
+ ml_gen_info_get_func_counter(!.Info, FuncLabelCounter0),
counter.allocate(FuncLabel, FuncLabelCounter0, _),
- counter.allocate(ConstNum, ConstNumCounter0, _),
FuncLabelCounter = counter.init(FuncLabel + 10000),
- ConstNumCounter = counter.init(ConstNum + 10000),
- !Info ^ mgi_func_label := FuncLabelCounter,
- !Info ^ mgi_const_num := ConstNumCounter.
-
-ml_gen_info_new_commit_label(CommitLabel, !Info) :-
- Counter0 = !.Info ^ mgi_commit_label,
- counter.allocate(CommitLabel, Counter0, Counter),
- !Info ^ mgi_commit_label := Counter.
-
-ml_gen_info_new_cond_var(CondVar, !Info) :-
- Counter0 = !.Info ^ mgi_cond_var,
- counter.allocate(CondVar, Counter0, Counter),
- !Info ^ mgi_cond_var := Counter.
-
-ml_gen_info_new_conv_var(ConvVar, !Info) :-
- Counter0 = !.Info ^ mgi_conv_var,
- counter.allocate(ConvVar, Counter0, Counter),
- !Info ^ mgi_conv_var := Counter.
-
-ml_gen_info_new_const(ConstVar, !Info) :-
- Counter0 = !.Info ^ mgi_const_num,
- counter.allocate(ConstVar, Counter0, Counter),
- !Info ^ mgi_const_num := Counter.
-
-ml_gen_info_set_const_var_name(Var, Name, !Info) :-
- !Info ^ mgi_const_var_name_map :=
- map.set(!.Info ^ mgi_const_var_name_map, Var, Name).
-
-ml_gen_info_lookup_const_var_name(Info, Var, Name) :-
- Name = map.lookup(Info ^ mgi_const_var_name_map, Var).
+ ml_gen_info_set_func_counter(FuncLabelCounter, !Info).
-ml_gen_info_search_const_var_name(Info, Var, Name) :-
- Name = map.search(Info ^ mgi_const_var_name_map, Var).
+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) :-
- !Info ^ mgi_success_cont_stack :=
- stack.push(!.Info ^ mgi_success_cont_stack, SuccCont).
+ 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) :-
- Stack0 = !.Info ^ mgi_success_cont_stack,
+ ml_gen_info_get_success_cont_stack(!.Info, Stack0),
stack.pop_det(Stack0, _SuccCont, Stack),
- !Info ^ mgi_success_cont_stack := Stack.
+ ml_gen_info_set_success_cont_stack(Stack, !Info).
ml_gen_info_current_success_cont(Info, SuccCont) :-
- stack.top_det(Info ^ mgi_success_cont_stack, SuccCont).
+ ml_gen_info_get_success_cont_stack(Info, Stack),
+ stack.top_det(Stack, SuccCont).
ml_gen_info_set_var_lval(Var, Lval, !Info) :-
- !Info ^ mgi_var_lvals := map.set(!.Info ^ mgi_var_lvals, Var, Lval).
-
-ml_gen_info_get_var_lvals(Info, Info ^ mgi_var_lvals).
-ml_gen_info_set_var_lvals(VarLvals, !Info) :-
- !Info ^ mgi_var_lvals := VarLvals.
-
-ml_gen_info_add_extra_defn(ExtraDefn, !Info) :-
- !Info ^ mgi_extra_defns := [ExtraDefn | !.Info ^ mgi_extra_defns].
-
-ml_gen_info_get_extra_defns(Info, Info ^ mgi_extra_defns).
+ 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) :-
- EnvVarNames0 = !.Info ^ mgi_env_var_names,
+ ml_gen_info_get_env_var_names(!.Info, EnvVarNames0),
set.insert(EnvVarNames0, Name, EnvVarNames),
- !Info ^ mgi_env_var_names := EnvVarNames.
-
-ml_gen_info_get_env_vars(Info, Info ^ mgi_env_var_names).
+ ml_gen_info_set_env_var_names(EnvVarNames, !Info).
%-----------------------------------------------------------------------------%
@@ -2709,7 +2809,7 @@
%-----------------------------------------------------------------------------%
%
-% Miscellaneous routines
+% Miscellaneous routines.
%
get_copy_out_option(Globals, CodeModel) = CopyOut :-
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.105
diff -u -b -r1.105 ml_elim_nested.m
--- compiler/ml_elim_nested.m 25 Aug 2009 23:46:48 -0000 1.105
+++ compiler/ml_elim_nested.m 31 Aug 2009 01:53:06 -0000
@@ -9,17 +9,14 @@
% File: ml_elim_nested.m.
% Main author: fjh.
%
-% This module is an MLDS-to-MLDS transformation
-% that has two functions:
-% (1) eliminating nested functions
-% (2) putting local variables that might contain pointers into
-% structs, and chaining these structs together,
-% for use with accurate garbage collection.
-%
-% The two transformations are quite similar,
-% so they're both handled by the same code;
-% a flag is passed to say which transformation
-% should be done.
+% This module is an MLDS-to-MLDS transformation that has two functions:
+%
+% - eliminating nested functions
+% - putting local variables that might contain pointers into structs, and
+% chaining these structs together, for use with accurate garbage collection.
+%
+% The two transformations are quite similar, so they're both handled by
+% the same code; a flag is passed to say which transformation should be done.
%
% The word "environment" (as in "environment struct" or "environment pointer")
% is used to refer to both the environment structs used when eliminating
@@ -36,8 +33,8 @@
% Note that this module does not attempt to handle arbitrary MLDS as input;
% it will only work with the output of the current MLDS code generator.
% In particular, it assumes that local variables in nested functions can be
-% hoisted into the outermost function's environment. That's not true
-% in general (e.g. if the nested functions are recursive), but it's true
+% hoisted into the outermost function's environment. That is not true
+% in general (e.g. if the nested functions are recursive), but it is true
% for the code that ml_code_gen generates.
%
% As well as eliminating nested functions, this transformation also has
@@ -417,10 +414,9 @@
:- module ml_backend.ml_elim_nested.
:- interface.
+:- import_module libs.globals.
:- import_module ml_backend.mlds.
-:- import_module io.
-
%-----------------------------------------------------------------------------%
:- type action
@@ -435,9 +431,9 @@
% Process the whole MLDS, performing the indicated action.
%
-:- pred ml_elim_nested(action, mlds, mlds, io, io).
-:- mode ml_elim_nested(in(hoist), in, out, di, uo) is det.
-:- mode ml_elim_nested(in(chain), in, out, di, uo) is det.
+:- pred ml_elim_nested(action, globals, mlds, mlds).
+:- mode ml_elim_nested(in(hoist), in, in, out) is det.
+:- mode ml_elim_nested(in(chain), in, in, out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -447,7 +443,6 @@
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module libs.compiler_util.
-:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ml_code_util.
@@ -464,24 +459,29 @@
%-----------------------------------------------------------------------------%
+:- import_module ml_backend.ml_global_data.
+
% Perform the specified action on the whole MLDS.
%
-ml_elim_nested(Action, MLDS0, MLDS, !IO) :-
- globals.io_get_globals(Globals, !IO),
- MLDS0 = mlds(ModuleName, ForeignCode, Imports, Defns0, InitPreds,
- FinalPreds, ExportedEnums),
+ml_elim_nested(Action, Globals, MLDS0, MLDS) :-
+ MLDS0 = mlds(ModuleName, ForeignCode, Imports, GlobalData0, Defns0,
+ InitPreds, FinalPreds, ExportedEnums),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
OuterVars = [],
ml_elim_nested_defns_list(Action, MLDS_ModuleName, Globals, OuterVars,
- Defns0, Defns1),
- % The MLDS code generator sometimes generates two definitions of the
- % same RTTI constant as local constants in two different functions.
- % When we hoist them out, that leads to duplicate definitions here.
- % So we need to check for and eliminate any duplicate definitions
- % of constants.
- Defns = list.remove_dups(Defns1),
- MLDS = mlds(ModuleName, ForeignCode, Imports, Defns, InitPreds,
- FinalPreds, ExportedEnums).
+ Defns0, Defns),
+ % Flat global data structures do not need to be processed here; that is
+ % what makes them "flat".
+ ml_global_data_get_global_defns(GlobalData0,
+ _RevFlatCellDefns, _RevFlatRttiDefns, RevNonFlatDefns0),
+ list.reverse(RevNonFlatDefns0, NonFlatDefns0),
+ ml_elim_nested_defns_list(Action, MLDS_ModuleName, Globals, OuterVars,
+ NonFlatDefns0, NonFlatDefns),
+ list.reverse(NonFlatDefns, RevNonFlatDefns),
+ ml_global_data_set_rev_maybe_nonflat_defns(RevNonFlatDefns,
+ GlobalData0, GlobalData),
+ MLDS = mlds(ModuleName, ForeignCode, Imports, GlobalData, Defns,
+ InitPreds, FinalPreds, ExportedEnums).
:- pred ml_elim_nested_defns_list(action, mlds_module_name, globals, outervars,
list(mlds_defn), list(mlds_defn)).
@@ -548,7 +548,7 @@
elim_info_finish(ElimInfo, NestedFuncs0, Locals),
% Split the locals that we need to process into local variables
- % and local static constants.
+ % and local static constants. ZZZ
list.filter(ml_decl_is_static_const, Locals, LocalStatics, LocalVars),
% Fix up access flags on the statics that we're going to hoist:
@@ -733,7 +733,8 @@
%
QualVarName = qual(ModuleName, module_qual, VarName),
Globals = elim_info_get_globals(Info),
- EnvModuleName = ml_env_module_name(ClassType, Globals),
+ globals.get_target(Globals, Target),
+ EnvModuleName = ml_env_module_name(Target, ClassType),
FieldNameString = ml_var_name_to_string(VarName),
FieldName = ml_field_named(qual(EnvModuleName, type_qual,
FieldNameString), EnvPtrTypeName),
@@ -2140,7 +2141,8 @@
EnvPtr = ml_lval(ml_var(qual(ModuleName, QualKind,
mlds_var_name(env_name_base(Action) ++ "_ptr", no)),
EnvPtrVarType)),
- EnvModuleName = ml_env_module_name(ClassType, Globals),
+ globals.get_target(Globals, Target),
+ EnvModuleName = ml_env_module_name(Target, ClassType),
ThisVarFieldName = ml_var_name_to_string(ThisVarName),
FieldName = ml_field_named(
qual(EnvModuleName, type_qual, ThisVarFieldName),
@@ -2230,13 +2232,13 @@
% Lval = make_envptr_ref(Depth - 1, NewEnvPtr, EnvPtrVar, Var)
% ).
-:- func ml_env_module_name(mlds_type, globals) = mlds_module_name.
+:- func ml_env_module_name(compilation_target, mlds_type) = mlds_module_name.
-ml_env_module_name(ClassType, Globals) = EnvModuleName :-
+ml_env_module_name(Target, ClassType) = EnvModuleName :-
( ClassType = mlds_class_type(ClassModuleName, Arity, _Kind) ->
ClassModuleName = qual(ClassModule, QualKind, ClassName),
- EnvModuleName = mlds_append_class_qualifier(ClassModule,
- QualKind, Globals, ClassName, Arity)
+ EnvModuleName = mlds_append_class_qualifier(Target, ClassModule,
+ QualKind, ClassName, Arity)
;
unexpected(this_file, "ml_env_module_name: ClassType is not a class")
).
Index: compiler/ml_global_data.m
===================================================================
RCS file: compiler/ml_global_data.m
diff -N compiler/ml_global_data.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/ml_global_data.m 28 Aug 2009 11:49:14 -0000
@@ -0,0 +1,234 @@
+%-----------------------------------------------------------------------------%
+% 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_global_data.m.
+% Main author: zs.
+%
+% This module is part of the MLDS code generator. It handles the generation
+% of data structures that are "born global", i.e. they belong to the generated
+% module as a whole, not to any particular function in it.
+%
+%-----------------------------------------------------------------------------%
+
+:- module ml_backend.ml_global_data.
+:- interface.
+
+:- import_module backend_libs.rtti.
+:- import_module ml_backend.mlds.
+
+:- import_module list.
+:- import_module map.
+
+ % This abstract type represents the MLDS code generator's repository of
+ % data structures that are "born global", i.e. the ones for which we
+ % known from the start that they will be defined at file scope.
+ %
+:- type ml_global_data.
+
+ % Initialize the ml_global_data structure to a value that represents
+ % no global data structures known yet.
+ %
+:- func ml_global_data_init = ml_global_data.
+
+ % ml_global_data_get_global_defns(GlobalData, RevFlatCellDefns,
+ % RevFlatRttiDefns, RevMaybeNonFlatDefns):
+ %
+ % Get all the global definitions implicit in the argument. Each group
+ % of global definitions with shared characteristics are returned in a
+ % separate argument.
+ %
+:- pred ml_global_data_get_global_defns(ml_global_data::in,
+ list(mlds_defn)::out, list(mlds_defn)::out, list(mlds_defn)::out) is det.
+
+ % ml_global_data_get_all_global_defns(GlobalData, Defns):
+ %
+ % Get all the global definitions implicit in the argument, in an order
+ % which is likely to be reasonably good. Note that this order may still
+ % require forward declarations.
+ %
+:- pred ml_global_data_get_all_global_defns(ml_global_data::in,
+ list(mlds_defn)::out) is det.
+
+ % This type maps the names of rtti data structures that have already been
+ % generated to the rval that refers to that data structure, and its type.
+ %
+ % The code generator looks up this map whenever it is needs a reference to
+ % an RTTI data structure that may or may not have been generated before.
+ % If it finds the id of that data structure in this map, it uses the
+ % corresponding value *without* generating the duplicate definition.
+ % Of course, this requires the code generator to add the original
+ % definition of the data structure to the ml_globals_data whenever it adds
+ % new entries to this map.
+ %
+ % At the moment, the only data structures that are potentially duplicated
+ % are the representations of type_infos and pseudo_type_infos, so only
+ % these rtti_ids will be in this map.
+ %
+:- type ml_rtti_rval_type_map == map(rtti_id, ml_rval_and_type).
+:- type ml_rval_and_type
+ ---> ml_rval_and_type(
+ mlds_rval,
+ mlds_type
+ ).
+
+ % Return the component of the given ml_global_data that contains
+ % information about potentially duplicated RTTI global definitions.
+ %
+:- pred ml_global_data_get_pdup_rval_type_map(ml_global_data::in,
+ ml_rtti_rval_type_map::out) is det.
+
+:- pred ml_global_data_get_unique_const_num(int::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ % Set the list of unique maybe-nonflat definitions to the given list.
+ % Intended for use by code that transforms the previously current list
+ % of unique maybe-nonflat definitions.
+ %
+:- pred ml_global_data_set_rev_maybe_nonflat_defns(list(mlds_defn)::in,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ % Map the given rtti_id to the given ml_rval_and_type, and record the
+ % generation of the given global data definitions.
+ %
+:- pred ml_global_data_add_pdup_rtti_id(rtti_id::in, ml_rval_and_type::in,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ % Add to the global data structure one or more definitions that are
+ % "unique by construction". Some of these are guaranteed to be flat
+ % definitions (definitions for which ml_elim_nested is an identity
+ % operation), while some have no such guarantee.
+ %
+:- pred ml_global_data_add_flat_cell_defn(mlds_defn::in,
+ ml_global_data::in, ml_global_data::out) is det.
+:- pred ml_global_data_add_flat_rtti_defn(mlds_defn::in,
+ ml_global_data::in, ml_global_data::out) is det.
+:- pred ml_global_data_add_flat_rtti_defns(list(mlds_defn)::in,
+ ml_global_data::in, ml_global_data::out) is det.
+:- pred ml_global_data_add_maybe_nonflat_defns(list(mlds_defn)::in,
+ ml_global_data::in, ml_global_data::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module counter.
+:- import_module svmap.
+
+:- type ml_global_data
+ ---> ml_global_data(
+ mdg_pdup_rval_type_map :: ml_rtti_rval_type_map,
+ mdg_const_counter :: counter,
+ mdg_rev_flat_cell_defns :: list(mlds_defn),
+ mdg_rev_flat_rtti_defns :: list(mlds_defn),
+ mdg_rev_maybe_nonflat_defns :: list(mlds_defn)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ml_global_data_init = GlobalData :-
+ GlobalData = ml_global_data(map.init, counter.init(1), [], [], []).
+
+ml_global_data_get_global_defns(GlobalData, RevFlatCellDefns, RevFlatRttiDefns,
+ RevMaybeNonFlatDefns) :-
+ GlobalData = ml_global_data(_PDupRvalTypeMap, _ConstCounter,
+ RevFlatCellDefns, RevFlatRttiDefns, RevMaybeNonFlatDefns).
+
+ml_global_data_get_all_global_defns(GlobalData, Defns) :-
+ GlobalData = ml_global_data(_PDupRvalTypeMap, _ConstCounter,
+ RevFlatCellDefns, RevFlatRttiDefns, RevMaybeNonFlatDefns),
+ % RevFlatRttiDefns are type_ctor_infos and the like, while
+ % RevNonFlatDefns are type_infos and pseudo_type_infos.
+ % They refer to each other, so neither order is obviously better.
+ %
+ % RevFlatCellDefns can refer to either of the previous two groups,
+ % which cannot refer back, so RevFlatCellDefns should definitely be listed
+ % last.
+ Defns = list.reverse(RevFlatRttiDefns) ++
+ list.reverse(RevMaybeNonFlatDefns) ++
+ list.reverse(RevFlatCellDefns).
+
+%-----------------------------------------------------------------------------%
+%
+% Access predicates for the ml_global_data type.
+%
+
+:- pred ml_global_data_get_const_counter(ml_global_data::in,
+ counter::out) is det.
+:- pred ml_global_data_get_rev_flat_cell_defns(ml_global_data::in,
+ list(mlds_defn)::out) is det.
+:- pred ml_global_data_get_rev_flat_rtti_defns(ml_global_data::in,
+ list(mlds_defn)::out) is det.
+:- pred ml_global_data_get_rev_maybe_nonflat_defns(ml_global_data::in,
+ list(mlds_defn)::out) is det.
+
+:- pred ml_global_data_set_pdup_rval_type_map(ml_rtti_rval_type_map::in,
+ ml_global_data::in, ml_global_data::out) is det.
+:- pred ml_global_data_set_const_counter(counter::in,
+ ml_global_data::in, ml_global_data::out) is det.
+:- pred ml_global_data_set_rev_flat_cell_defns(list(mlds_defn)::in,
+ ml_global_data::in, ml_global_data::out) is det.
+:- pred ml_global_data_set_rev_flat_rtti_defns(list(mlds_defn)::in,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_global_data_get_pdup_rval_type_map(GlobalData,
+ GlobalData ^ mdg_pdup_rval_type_map).
+ml_global_data_get_const_counter(GlobalData,
+ GlobalData ^ mdg_const_counter).
+ml_global_data_get_rev_flat_cell_defns(GlobalData,
+ GlobalData ^ mdg_rev_flat_cell_defns).
+ml_global_data_get_rev_flat_rtti_defns(GlobalData,
+ GlobalData ^ mdg_rev_flat_rtti_defns).
+ml_global_data_get_rev_maybe_nonflat_defns(GlobalData,
+ GlobalData ^ mdg_rev_maybe_nonflat_defns).
+
+ml_global_data_set_pdup_rval_type_map(PDupRvalTypeMap, !GlobalData) :-
+ !GlobalData ^ mdg_pdup_rval_type_map := PDupRvalTypeMap.
+ml_global_data_set_const_counter(ConstCounter, !GlobalData) :-
+ !GlobalData ^ mdg_const_counter := ConstCounter.
+ml_global_data_set_rev_flat_cell_defns(Defns, !GlobalData) :-
+ !GlobalData ^ mdg_rev_flat_cell_defns := Defns.
+ml_global_data_set_rev_flat_rtti_defns(Defns, !GlobalData) :-
+ !GlobalData ^ mdg_rev_flat_rtti_defns := Defns.
+ml_global_data_set_rev_maybe_nonflat_defns(Defns, !GlobalData) :-
+ !GlobalData ^ mdg_rev_maybe_nonflat_defns := Defns.
+
+%-----------------------------------------------------------------------------%
+
+ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData) :-
+ ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap0),
+ svmap.det_insert(RttiId, RvalType, PDupRvalTypeMap0, PDupRvalTypeMap),
+ ml_global_data_set_pdup_rval_type_map(PDupRvalTypeMap, !GlobalData).
+
+ml_global_data_get_unique_const_num(ConstNum, !GlobalData) :-
+ ml_global_data_get_const_counter(!.GlobalData, ConstCounter0),
+ counter.allocate(ConstNum, ConstCounter0, ConstCounter),
+ ml_global_data_set_const_counter(ConstCounter, !GlobalData).
+
+ml_global_data_add_flat_cell_defn(Defn, !GlobalData) :-
+ ml_global_data_get_rev_flat_cell_defns(!.GlobalData, RevDefns0),
+ RevDefns = [Defn | RevDefns0],
+ ml_global_data_set_rev_flat_cell_defns(RevDefns, !GlobalData).
+
+ml_global_data_add_flat_rtti_defn(Defn, !GlobalData) :-
+ ml_global_data_get_rev_flat_rtti_defns(!.GlobalData, RevDefns0),
+ RevDefns = [Defn | RevDefns0],
+ ml_global_data_set_rev_flat_rtti_defns(RevDefns, !GlobalData).
+
+ml_global_data_add_flat_rtti_defns(Defns, !GlobalData) :-
+ ml_global_data_get_rev_flat_rtti_defns(!.GlobalData, RevDefns0),
+ RevDefns = list.reverse(Defns) ++ RevDefns0,
+ ml_global_data_set_rev_flat_rtti_defns(RevDefns, !GlobalData).
+
+ml_global_data_add_maybe_nonflat_defns(Defns, !GlobalData) :-
+ ml_global_data_get_rev_maybe_nonflat_defns(!.GlobalData, RevDefns0),
+ RevDefns = list.reverse(Defns) ++ RevDefns0,
+ ml_global_data_set_rev_maybe_nonflat_defns(RevDefns, !GlobalData).
+
+%-----------------------------------------------------------------------------%
+:- end_module ml_backend.ml_global_data.
+%-----------------------------------------------------------------------------%
Index: compiler/ml_string_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_string_switch.m,v
retrieving revision 1.40
diff -u -b -r1.40 ml_string_switch.m
--- compiler/ml_string_switch.m 25 Aug 2009 23:46:48 -0000 1.40
+++ compiler/ml_string_switch.m 28 Aug 2009 11:49:14 -0000
@@ -66,21 +66,18 @@
VarRval = ml_lval(VarLval),
% Generate the following local variable declarations:
- % int slot;
- % MR_String str;
+ % int slot_N;
+ % MR_String str_M;
- ml_gen_info_new_cond_var(SlotVarSeq, !Info),
- SlotVarName = mlds_var_name(
- string.format("slot_%d", [i(SlotVarSeq)]), no),
+ ml_gen_info_new_aux_var_name("slot", SlotVarName, !Info),
SlotVarType = mlds_native_int_type,
- SlotVarGCStatement = gc_no_stmt, % never need to trace ints
+ % We never need to trace ints.
+ SlotVarGCStatement = gc_no_stmt,
SlotVarDefn = ml_gen_mlds_var_decl(mlds_data_var(SlotVarName), SlotVarType,
SlotVarGCStatement, MLDS_Context),
ml_gen_var_lval(!.Info, SlotVarName, SlotVarType, SlotVarLval),
- ml_gen_info_new_cond_var(StringVarSeq, !Info),
- StringVarName = mlds_var_name(
- string.format("str_%d", [i(StringVarSeq)]), no),
+ ml_gen_info_new_aux_var_name("str", StringVarName, !Info),
StringVarType = ml_string_type,
% This variable always points to an element of the string_table array,
% which are all static constants; it can never point into the heap.
@@ -138,26 +135,28 @@
list.sort(SlotsCases0, SlotsCases),
% Generate the following local constant declarations:
- % static const int next_slots_table = { <NextSlots> };
- % static const MR_String string_table[] = { <Strings> };
+ % static const int next_slots_table_N = { <NextSlots> };
+ % static const MR_String string_table_M[] = { <Strings> };
+
+ some [!GlobalData] (
+ ml_gen_info_get_global_data(!.Info, !:GlobalData),
- ml_gen_info_new_const(NextSlotsSeq, !Info),
- ml_format_static_const_name(!.Info, "next_slots_table", NextSlotsSeq,
- NextSlotsName),
NextSlotsType = mlds_array_type(SlotVarType),
- NextSlotsDefn = ml_gen_static_const_defn(NextSlotsName,
- NextSlotsType, acc_local, init_array(NextSlots), Context),
+ ml_gen_static_const_defn("next_slots_table", NextSlotsType,
+ acc_private, init_array(NextSlots), Context, NextSlotsName,
+ !GlobalData),
ml_gen_var_lval(!.Info, NextSlotsName, NextSlotsType, NextSlotsLval),
- ml_gen_info_new_const(StringTableSeq, !Info),
- ml_format_static_const_name(!.Info, "string_table", StringTableSeq,
- StringTableName),
StringTableType = mlds_array_type(StringVarType),
- StringTableDefn = ml_gen_static_const_defn(StringTableName,
- StringTableType, acc_local, init_array(Strings), Context),
+ ml_gen_static_const_defn("string_table", StringTableType,
+ acc_private, init_array(Strings), Context, StringTableName,
+ !GlobalData),
ml_gen_var_lval(!.Info, StringTableName, StringTableType,
StringTableLval),
+ ml_gen_info_set_global_data(!.GlobalData, !Info)
+ ),
+
% Generate code which does the hash table lookup.
SwitchStmt0 = ml_stmt_switch(SlotVarType, ml_lval(SlotVarLval),
mlds_switch_range(0, TableSize - 1), SlotsCases,
@@ -235,7 +234,7 @@
% Collect all the generated variable/constant declarations
% and code fragments together.
- Decls = [NextSlotsDefn, StringTableDefn, SlotVarDefn, StringVarDefn],
+ Decls = [SlotVarDefn, StringVarDefn],
Statements =
HashLookupStatements ++
[FailComment | FailStatements] ++
@@ -252,7 +251,7 @@
!CodeMap, !Unit, !Info) :-
TaggedCase = tagged_case(MainTaggedConsId, OtherTaggedConsIds,
CaseNum, Goal),
- ml_gen_goal_as_block(CodeModel, Goal, GoalStatement, !Info),
+ ml_gen_goal_as_branch_block(CodeModel, Goal, GoalStatement, !Info),
MainString = gen_string_switch_case_comment(MainTaggedConsId),
OtherStrings = list.map(gen_string_switch_case_comment,
OtherTaggedConsIds),
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.41
diff -u -b -r1.41 ml_switch_gen.m
--- compiler/ml_switch_gen.m 25 Aug 2009 23:46:48 -0000 1.41
+++ compiler/ml_switch_gen.m 28 Aug 2009 11:49:14 -0000
@@ -384,7 +384,7 @@
% We do not need to test whether we are in the first tagged case;
% previous tests have implied that we must be, by eliminating all
% other cons_ids that Var could be bound to.
- ml_gen_goal_as_block(CodeModel, Goal, Statement, !Info)
+ ml_gen_goal_as_branch_block(CodeModel, Goal, Statement, !Info)
;
CanFail = can_fail,
% We handle this case as if we still had later cases, cases
@@ -395,7 +395,7 @@
ml_switch_generate_if_then_else_cond(TaggedCase, Var, Cond, !Info),
% Generate code for the first tagged case.
- ml_gen_goal_as_block(CodeModel, Goal, GoalBlock, !Info),
+ ml_gen_goal_as_branch_block(CodeModel, Goal, GoalBlock, !Info),
% Generate code for the non-covered tagged cases.
ml_gen_failure(CodeModel, Context, FailStatements, !Info),
@@ -414,7 +414,7 @@
ml_switch_generate_if_then_else_cond(TaggedCase, Var, Cond, !Info),
% Generate code for the first tagged case.
- ml_gen_goal_as_block(CodeModel, Goal, GoalBlock, !Info),
+ ml_gen_goal_as_branch_block(CodeModel, Goal, GoalBlock, !Info),
% Generate code for the later tagged cases.
ml_switch_generate_if_then_else_chain_ites(LaterTaggedCase,
@@ -514,7 +514,7 @@
TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, _, Goal),
ml_tagged_cons_id_to_match_cond(TaggedMainConsId, MainCond),
list.map(ml_tagged_cons_id_to_match_cond, TaggedOtherConsIds, OtherConds),
- ml_gen_goal_as_block(CodeModel, Goal, Statement, !Info),
+ ml_gen_goal_as_branch_block(CodeModel, Goal, Statement, !Info),
MLDS_Case = mlds_switch_case(MainCond, OtherConds, Statement).
:- pred ml_tagged_cons_id_to_match_cond(tagged_cons_id::in,
Index: compiler/ml_tag_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_tag_switch.m,v
retrieving revision 1.30
diff -u -b -r1.30 ml_tag_switch.m
--- compiler/ml_tag_switch.m 25 Aug 2009 23:46:48 -0000 1.30
+++ compiler/ml_tag_switch.m 28 Aug 2009 11:49:14 -0000
@@ -116,7 +116,7 @@
gen_tagged_case_code(CodeModel, TaggedCase, CaseNum, !CodeMap, !Unit, !Info) :-
TaggedCase = tagged_case(_MainTaggedConsId, _OtherTaggedConsIds,
CaseNum, Goal),
- ml_gen_goal_as_block(CodeModel, Goal, Statement, !Info),
+ ml_gen_goal_as_branch_block(CodeModel, Goal, Statement, !Info),
svmap.det_insert(CaseNum, Statement, !CodeMap).
:- type is_a_case_split_between_ptags
@@ -281,7 +281,7 @@
STagRval = ml_unop(std_unop(unmkbody), VarRval)
;
StagLocn = sectag_remote,
- STagRval = ml_gen_secondary_tag_rval(PrimaryTag, VarType, ModuleInfo,
+ STagRval = ml_gen_secondary_tag_rval(ModuleInfo, PrimaryTag, VarType,
VarRval)
;
StagLocn = sectag_none,
Index: compiler/ml_tailcall.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_tailcall.m,v
retrieving revision 1.51
diff -u -b -r1.51 ml_tailcall.m
--- compiler/ml_tailcall.m 25 Aug 2009 23:46:48 -0000 1.51
+++ compiler/ml_tailcall.m 28 Aug 2009 11:49:14 -0000
@@ -590,8 +590,8 @@
:- pred nontailcall_in_mlds(mlds::in, tailcall_warning::out) is nondet.
nontailcall_in_mlds(MLDS, Warning) :-
- MLDS = mlds(ModuleName, _ForeignCode, _Imports, Defns, _InitPreds,
- _FinalPreds, _ExportedEnums),
+ MLDS = mlds(ModuleName, _ForeignCode, _Imports, _GlobalData, Defns,
+ _InitPreds, _FinalPreds, _ExportedEnums),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
nontailcall_in_defns(MLDS_ModuleName, Defns, Warning).
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.85
diff -u -b -r1.85 ml_type_gen.m
--- compiler/ml_type_gen.m 9 Jul 2009 05:18:07 -0000 1.85
+++ compiler/ml_type_gen.m 28 Aug 2009 11:49:14 -0000
@@ -33,15 +33,13 @@
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
% Generate MLDS definitions for all the types in the HLDS.
%
-:- pred ml_gen_types(module_info::in, list(mlds_defn)::out, io::di, io::uo)
- is det.
+:- pred ml_gen_types(module_info::in, list(mlds_defn)::out) is det.
% Given an HLDS type_ctor, generate the MLDS class name and arity
% for the corresponding MLDS type.
@@ -83,18 +81,22 @@
:- pred ml_uses_secondary_tag(type_ctor::in, cons_tag_values::in,
constructor::in, int::out) is semidet.
+:- type tag_uses_base_class
+ ---> tag_does_not_use_base_class
+ ; tag_uses_base_class.
+
% A constructor is represented using the base class rather than a derived
% class if there is only a single functor, or if there is a single
% functor and some constants represented using reserved addresses.
%
-:- pred ml_tag_uses_base_class(cons_tag::in) is semidet.
+:- func ml_tag_uses_base_class(cons_tag) = tag_uses_base_class.
% Exported enumeration info in the HLDS is converted into an MLDS
% specific representation. The target specific code generators may
% further transform it.
%
-:- pred ml_gen_exported_enums(module_info::in, mlds_exported_enums::out,
- io::di, io::uo) is det.
+:- pred ml_gen_exported_enums(module_info::in, mlds_exported_enums::out)
+ is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -125,9 +127,10 @@
%-----------------------------------------------------------------------------%
-ml_gen_types(ModuleInfo, MLDS_TypeDefns, !IO) :-
- globals.io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
- globals.io_get_target(Target, !IO),
+ml_gen_types(ModuleInfo, MLDS_TypeDefns) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ globals.get_target(Globals, Target),
(
HighLevelData = yes,
module_info_get_type_table(ModuleInfo, TypeTable),
@@ -145,24 +148,22 @@
:- pred ml_gen_type_defn(module_info::in, type_table::in, type_ctor::in,
list(mlds_defn)::in, list(mlds_defn)::out) is det.
-ml_gen_type_defn(ModuleInfo, TypeTable, TypeCtor, MLDS_Defns0, MLDS_Defns) :-
+ml_gen_type_defn(ModuleInfo, TypeTable, TypeCtor, !Defns) :-
map.lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_status(TypeDefn, Status),
DefinedThisModule = status_defined_in_this_module(Status),
(
DefinedThisModule = yes,
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- ml_gen_type_2(TypeBody, ModuleInfo, TypeCtor, TypeDefn,
- MLDS_Defns0, MLDS_Defns)
+ ml_gen_type_2(ModuleInfo, TypeCtor, TypeDefn, TypeBody, !Defns)
;
- DefinedThisModule = no,
- MLDS_Defns = MLDS_Defns0
+ DefinedThisModule = no
).
-:- pred ml_gen_type_2(hlds_type_body::in, module_info::in, type_ctor::in,
- hlds_type_defn::in, list(mlds_defn)::in, list(mlds_defn)::out) is det.
+:- pred ml_gen_type_2(module_info::in, type_ctor::in, hlds_type_defn::in,
+ hlds_type_body::in, list(mlds_defn)::in, list(mlds_defn)::out) is det.
-ml_gen_type_2(TypeBody, ModuleInfo, TypeCtor, TypeDefn, !Defns) :-
+ml_gen_type_2(ModuleInfo, TypeCtor, TypeDefn, TypeBody, !Defns) :-
(
TypeBody = hlds_abstract_type(_)
;
@@ -180,13 +181,17 @@
( DuTypeKind = du_type_kind_mercury_enum
; DuTypeKind = du_type_kind_foreign_enum(_)
),
- ml_gen_enum_type(ModuleInfo, TypeCtor, TypeDefn, Ctors, TagValues,
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ ml_gen_enum_type(Target, TypeCtor, TypeDefn, Ctors, TagValues,
MaybeEqualityMembers, !Defns)
;
DuTypeKind = du_type_kind_direct_dummy,
% XXX We shouldn't have to generate an MLDS type for these types,
% but it is not easy to ensure that we never refer to that type.
- ml_gen_enum_type(ModuleInfo, TypeCtor, TypeDefn, Ctors, TagValues,
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ ml_gen_enum_type(Target, TypeCtor, TypeDefn, Ctors, TagValues,
MaybeEqualityMembers, !Defns)
;
( DuTypeKind = du_type_kind_notag(_, _, _)
@@ -219,12 +224,12 @@
% generator can treat it specially if need be (e.g. generating
% a C enum rather than a class).
%
-:- pred ml_gen_enum_type(module_info::in, type_ctor::in, hlds_type_defn::in,
- list(constructor)::in, cons_tag_values::in, list(mlds_defn)::in,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
+:- pred ml_gen_enum_type(compilation_target::in, type_ctor::in,
+ hlds_type_defn::in, list(constructor)::in, cons_tag_values::in,
+ list(mlds_defn)::in, list(mlds_defn)::in, list(mlds_defn)::out) is det.
-ml_gen_enum_type(ModuleInfo, TypeCtor, TypeDefn, Ctors, TagValues,
- MaybeEqualityMembers, MLDS_Defns0, MLDS_Defns) :-
+ml_gen_enum_type(Target, TypeCtor, TypeDefn, Ctors, TagValues,
+ MaybeEqualityMembers, !Defns) :-
hlds_data.get_type_defn_context(TypeDefn, Context),
MLDS_Context = mlds_make_context(Context),
@@ -246,8 +251,6 @@
% Make all Java classes corresponding to types implement the MercuryType
% and MercuryEnum interfaces.
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_target(Globals, Target),
(
Target = target_java,
InterfaceModuleName = mercury_module_name_to_mlds(
@@ -272,10 +275,10 @@
MLDS_TypeFlags = ml_gen_type_decl_flags,
MLDS_TypeDefnBody = mlds_class(mlds_class_defn(mlds_enum,
Imports, Inherits, Implements, [], Members)),
- MLDS_TypeDefn = mlds_defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
+ Defn = mlds_defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
MLDS_TypeDefnBody),
- MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
+ !:Defns = [Defn | !.Defns].
:- func ml_gen_enum_value_member(prog_context) = mlds_defn.
@@ -288,7 +291,7 @@
:- func ml_gen_enum_constant(prog_context, type_ctor, cons_tag_values,
constructor) = mlds_defn.
-ml_gen_enum_constant(Context, TypeCtor, ConsTagValues, Ctor) = MLDS_Defn :-
+ml_gen_enum_constant(Context, TypeCtor, ConsTagValues, Ctor) = Defn :-
% Figure out the value of this enumeration constant.
Ctor = ctor(_ExistQTVars, _Constraints, Name, Args, _Ctxt),
list.length(Args, Arity),
@@ -326,7 +329,7 @@
% Generate an MLDS definition for this enumeration constant.
UnqualifiedName = unqualify_name(Name),
- MLDS_Defn = mlds_defn(
+ Defn = mlds_defn(
entity_data(mlds_data_var(mlds_var_name(UnqualifiedName, no))),
mlds_make_context(Context),
ml_gen_enum_constant_decl_flags,
@@ -425,7 +428,7 @@
list(mlds_defn)::in, list(mlds_defn)::in, list(mlds_defn)::out) is det.
ml_gen_du_parent_type(ModuleInfo, TypeCtor, TypeDefn, Ctors, TagValues,
- MaybeEqualityMembers, MLDS_Defns0, MLDS_Defns) :-
+ MaybeEqualityMembers, !Defns) :-
hlds_data.get_type_defn_context(TypeDefn, Context),
MLDS_Context = mlds_make_context(Context),
@@ -435,11 +438,10 @@
mlds_class),
QualBaseClassName = qual(BaseClassModuleName, QualKind, BaseClassName),
module_info_get_globals(ModuleInfo, Globals),
- BaseClassQualifier = mlds_append_class_qualifier(
- BaseClassModuleName, QualKind, Globals,
- BaseClassName, BaseClassArity),
-
globals.get_target(Globals, Target),
+ BaseClassQualifier = mlds_append_class_qualifier(Target,
+ BaseClassModuleName, QualKind, BaseClassName, BaseClassArity),
+
(
% If none of the constructors for this type need a secondary tag,
% then we don't need the members for the secondary tag.
@@ -518,10 +520,10 @@
MLDS_TypeFlags = ml_gen_type_decl_flags,
MLDS_TypeDefnBody = mlds_class(mlds_class_defn(mlds_class,
Imports, Inherits, Implements, BaseClassCtorMethods, Members)),
- MLDS_TypeDefn = mlds_defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
+ Defn = mlds_defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
MLDS_TypeDefnBody),
- MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
+ !:Defns = [Defn | !.Defns].
% Generate the declaration for the field that holds the secondary tag.
%
@@ -536,7 +538,7 @@
:- func ml_gen_tag_constant(prog_context, type_ctor, cons_tag_values,
constructor) = list(mlds_defn).
-ml_gen_tag_constant(Context, TypeCtor, ConsTagValues, Ctor) = MLDS_Defns :-
+ml_gen_tag_constant(Context, TypeCtor, ConsTagValues, Ctor) = Defns :-
% Check if this constructor uses a secondary tag.
( ml_uses_secondary_tag(TypeCtor, ConsTagValues, Ctor, SecondaryTag) ->
% Generate an MLDS definition for this secondary tag constant.
@@ -547,14 +549,14 @@
Ctor = ctor(_ExistQTVars, _Constraints, Name, _Args, _Ctxt),
UnqualifiedName = unqualify_name(Name),
ConstValue = ml_const(mlconst_int(SecondaryTag)),
- MLDS_Defn = mlds_defn(
+ Defn = mlds_defn(
entity_data(mlds_data_var(mlds_var_name(UnqualifiedName, no))),
mlds_make_context(Context),
ml_gen_enum_constant_decl_flags,
mlds_data(mlds_native_int_type, init_obj(ConstValue), gc_no_stmt)),
- MLDS_Defns = [MLDS_Defn]
+ Defns = [Defn]
;
- MLDS_Defns = []
+ Defns = []
).
% Check if this constructor's representation uses a secondary tag,
@@ -660,9 +662,9 @@
MLDS_Context = mlds_make_context(Context),
% Generate the class name for this constructor.
+ list.length(Args, CtorArity),
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
- list.length(Args, CtorArity),
UnqualCtorName = ml_gen_du_ctor_name(Target, TypeCtor,
CtorName, CtorArity),
@@ -678,9 +680,17 @@
MLDS_ReservedObjName = ml_format_reserved_object_name(
UnqualCtorName, CtorArity),
- MLDS_ReservedObjDefn = ml_gen_static_const_defn(
- MLDS_ReservedObjName, SecondaryTagClassId,
- acc_public, no_initializer, Context),
+ MLDS_ReservedObjEntityName =
+ entity_data(mlds_data_var(MLDS_ReservedObjName)),
+ % The GC never needs to trace static constants, because they can
+ % never point into the heap; they can point only to other static
+ % constants.
+ GCStatement = gc_no_stmt,
+ EntityDefn = mlds_data(SecondaryTagClassId, no_initializer,
+ GCStatement),
+ DeclFlags = mlds.set_access(ml_static_const_decl_flags, acc_public),
+ MLDS_ReservedObjDefn = mlds_defn(MLDS_ReservedObjEntityName,
+ MLDS_Context, DeclFlags, EntityDefn),
MLDS_Members = [MLDS_ReservedObjDefn | MLDS_Members0]
;
% For reserved numeric addresses, we don't need to generate
@@ -729,20 +739,22 @@
% (not all back-ends use constructor functions).
MaybeSecTagVal = get_secondary_tag(TagVal),
UsesConstructors = target_uses_constructors(Target),
+ UsesBaseClass = ml_tag_uses_base_class(TagVal),
(
UsesConstructors = yes,
- ( ml_tag_uses_base_class(TagVal) ->
+ (
+ UsesBaseClass = tag_uses_base_class,
CtorClassType = BaseClassId,
CtorClassQualifier = BaseClassQualifier
;
+ UsesBaseClass = tag_does_not_use_base_class,
CtorClassType = mlds_class_type(
qual(BaseClassQualifier, type_qual, UnqualCtorName),
CtorArity, mlds_class),
- CtorClassQualifier = mlds_append_class_qualifier(
- BaseClassQualifier, type_qual,
- Globals, UnqualCtorName, CtorArity)
+ CtorClassQualifier = mlds_append_class_qualifier(Target,
+ BaseClassQualifier, type_qual, UnqualCtorName, CtorArity)
),
- CtorFunction = gen_constructor_function(Globals,
+ CtorFunction = gen_constructor_function(Target,
BaseClassId, CtorClassType, CtorClassQualifier,
SecondaryTagClassId, MaybeSecTagVal, Members, MLDS_Context),
% If this constructor is going to go in the base class, then we may
@@ -765,7 +777,7 @@
),
Members = [_ | _]
->
- ZeroArgCtor = gen_constructor_function(Globals, BaseClassId,
+ ZeroArgCtor = gen_constructor_function(Target, BaseClassId,
CtorClassType, CtorClassQualifier, SecondaryTagClassId,
no, [], MLDS_Context),
Ctors = [ZeroArgCtor, CtorFunction]
@@ -777,11 +789,13 @@
Ctors = []
),
- ( ml_tag_uses_base_class(TagVal) ->
+ (
+ UsesBaseClass = tag_uses_base_class,
% Put the members for this constructor directly in the base class.
MLDS_Members = Members ++ MLDS_Members0,
MLDS_CtorMethods = Ctors ++ MLDS_CtorMethods0
;
+ UsesBaseClass = tag_does_not_use_base_class,
% Generate a nested derived class for this constructor,
% and put the members for this constructor in that class.
@@ -822,9 +836,32 @@
% A constructor is represented using the base class rather than a derived
% class if there is only a single functor, or if there is a single
% functor and some constants represented using reserved addresses.
-ml_tag_uses_base_class(single_functor_tag).
-ml_tag_uses_base_class(shared_with_reserved_addresses_tag(_RAs, Tag)) :-
- ml_tag_uses_base_class(Tag).
+ml_tag_uses_base_class(Tag) = UsesBaseClass :-
+ (
+ Tag = single_functor_tag,
+ UsesBaseClass = tag_uses_base_class
+ ;
+ Tag = shared_with_reserved_addresses_tag(_RAs, SubTag),
+ UsesBaseClass = ml_tag_uses_base_class(SubTag)
+ ;
+ ( Tag = string_tag(_)
+ ; Tag = float_tag(_)
+ ; Tag = int_tag(_)
+ ; Tag = foreign_tag(_, _)
+ ; Tag = closure_tag(_, _, _)
+ ; Tag = type_ctor_info_tag(_, _, _)
+ ; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = tabling_info_tag(_, _)
+ ; Tag = deep_profiling_proc_layout_tag(_, _)
+ ; Tag = table_io_decl_tag(_, _)
+ ; Tag = unshared_tag(_)
+ ; Tag = shared_remote_tag(_, _)
+ ; Tag = shared_local_tag(_, _)
+ ; Tag = no_tag
+ ; Tag = reserved_address_tag(_)
+ ),
+ UsesBaseClass = tag_does_not_use_base_class
+ ).
:- func target_uses_constructors(compilation_target) = bool.
@@ -867,22 +904,21 @@
target_requires_module_qualified_params(target_erlang) =
unexpected(this_file, "target erlang").
-:- func gen_constructor_function(globals, mlds_class_id,
+:- func gen_constructor_function(compilation_target, mlds_class_id,
mlds_type, mlds_module_name, mlds_class_id, maybe(int), list(mlds_defn),
mlds_context) = mlds_defn.
-gen_constructor_function(Globals, BaseClassId, ClassType, ClassQualifier,
+gen_constructor_function(Target, BaseClassId, ClassType, ClassQualifier,
SecondaryTagClassId, MaybeTag, Members, Context) = CtorDefn :-
Args = list.map(make_arg, Members),
ReturnValues = [],
- globals.get_target(Globals, Target),
InitMembers0 = list.map(gen_init_field(Target, BaseClassId,
ClassType, ClassQualifier), Members),
(
MaybeTag = yes(TagVal),
- InitTag = gen_init_tag(ClassType, SecondaryTagClassId, TagVal,
- Context, Globals),
+ InitTag = gen_init_tag(Target, ClassType, SecondaryTagClassId, TagVal,
+ Context),
InitMembers = [InitTag | InitMembers0]
;
MaybeTag = no,
@@ -965,15 +1001,15 @@
% Generate "this->data_tag = <TagVal>;".
%
-:- func gen_init_tag(mlds_type, mlds_class_id, int, mlds_context, globals)
- = statement.
+:- func gen_init_tag(compilation_target, mlds_type, mlds_class_id, int,
+ mlds_context) = statement.
-gen_init_tag(ClassType, SecondaryTagClassId, TagVal, Context, Globals)
+gen_init_tag(Target, ClassType, SecondaryTagClassId, TagVal, Context)
= Statement :-
( SecondaryTagClassId = mlds_class_type(TagClass, TagArity, _) ->
TagClass = qual(BaseClassQualifier, QualKind, TagClassName),
- TagClassQualifier = mlds_append_class_qualifier(BaseClassQualifier,
- QualKind, Globals, TagClassName, TagArity)
+ TagClassQualifier = mlds_append_class_qualifier(Target,
+ BaseClassQualifier, QualKind, TagClassName, TagArity)
;
unexpected(this_file, "gen_init_tag: class_id should be a class")
),
@@ -989,57 +1025,54 @@
:- pred ml_gen_typeclass_info_member(module_info::in, prog_context::in,
prog_constraint::in, mlds_defn::out, int::in, int::out) is det.
-ml_gen_typeclass_info_member(ModuleInfo, Context, Constraint, MLDS_Defn,
- ArgNum0, ArgNum) :-
+ml_gen_typeclass_info_member(ModuleInfo, Context, Constraint, Defn, !ArgNum) :-
polymorphism.build_typeclass_info_type(Constraint, Type),
- ml_gen_field(ModuleInfo, Context, no, Type, MLDS_Defn, ArgNum0, ArgNum).
+ ml_gen_field(ModuleInfo, Context, no, Type, Defn, !ArgNum).
:- pred ml_gen_type_info_member(module_info::in, prog_context::in, tvar::in,
mlds_defn::out, int::in, int::out) is det.
-ml_gen_type_info_member(ModuleInfo, Context, TypeVar, MLDS_Defn,
- ArgNum0, ArgNum) :-
+ml_gen_type_info_member(ModuleInfo, Context, TypeVar, Defn, !ArgNum) :-
% We don't have access to the correct kind here. This won't matter though,
% since the type will only be checked to see that it is a variable,
% and won't be used in any other way.
Kind = kind_star,
polymorphism.build_type_info_type(type_variable(TypeVar, Kind), Type),
- ml_gen_field(ModuleInfo, Context, no, Type, MLDS_Defn, ArgNum0, ArgNum).
+ ml_gen_field(ModuleInfo, Context, no, Type, Defn, !ArgNum).
:- pred ml_gen_du_ctor_field(module_info::in, prog_context::in,
constructor_arg::in, mlds_defn::out, int::in, int::out) is det.
-ml_gen_du_ctor_field(ModuleInfo, Context, Arg, MLDS_Defn, ArgNum0, ArgNum) :-
+ml_gen_du_ctor_field(ModuleInfo, Context, Arg, Defn, !ArgNum) :-
ml_gen_field(ModuleInfo, Context, Arg ^ arg_field_name, Arg ^ arg_type,
- MLDS_Defn, ArgNum0, ArgNum).
+ Defn, !ArgNum).
:- pred ml_gen_field(module_info::in, prog_context::in,
maybe(ctor_field_name)::in, mer_type::in, mlds_defn::out,
int::in, int::out) is det.
-ml_gen_field(ModuleInfo, Context, MaybeFieldName, Type, MLDS_Defn,
- ArgNum0, ArgNum) :-
- ( ml_must_box_field_type(Type, ModuleInfo) ->
+ml_gen_field(ModuleInfo, Context, MaybeFieldName, Type, Defn, !ArgNum) :-
+ ( ml_must_box_field_type(ModuleInfo, Type) ->
MLDS_Type = mlds_generic_type
;
MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type)
),
- FieldName = ml_gen_field_name(MaybeFieldName, ArgNum0),
- MLDS_Defn = ml_gen_mlds_field_decl(
+ FieldName = ml_gen_field_name(MaybeFieldName, !.ArgNum),
+ Defn = ml_gen_mlds_field_decl(
mlds_data_var(mlds_var_name(FieldName, no)),
MLDS_Type, mlds_make_context(Context)),
- ArgNum = ArgNum0 + 1.
+ !:ArgNum = !.ArgNum + 1.
:- func ml_gen_mlds_field_decl(mlds_data_name, mlds_type, mlds_context)
= mlds_defn.
-ml_gen_mlds_field_decl(DataName, MLDS_Type, Context) = MLDS_Defn :-
+ml_gen_mlds_field_decl(DataName, MLDS_Type, Context) = Defn :-
Name = entity_data(DataName),
% We only need GC tracing code for top-level variables, not for fields
GCStatement = gc_no_stmt,
- Defn = mlds_data(MLDS_Type, no_initializer, GCStatement),
+ EntityDefn = mlds_data(MLDS_Type, no_initializer, GCStatement),
DeclFlags = ml_gen_public_field_decl_flags,
- MLDS_Defn = mlds_defn(Name, Context, DeclFlags, Defn).
+ Defn = mlds_defn(Name, Context, DeclFlags, EntityDefn).
%-----------------------------------------------------------------------------%
%
@@ -1138,17 +1171,17 @@
%----------------------------------------------------------------------------%
-ml_gen_exported_enums(ModuleInfo, MLDS_ExportedEnums, !IO) :-
+ml_gen_exported_enums(ModuleInfo, MLDS_ExportedEnums) :-
module_info_get_exported_enums(ModuleInfo, ExportedEnumInfo),
module_info_get_type_table(ModuleInfo, TypeTable),
- list.map_foldl(ml_gen_exported_enum(ModuleInfo, TypeTable),
- ExportedEnumInfo, MLDS_ExportedEnums, !IO).
+ list.map(ml_gen_exported_enum(ModuleInfo, TypeTable),
+ ExportedEnumInfo, MLDS_ExportedEnums).
:- pred ml_gen_exported_enum(module_info::in, type_table::in,
- exported_enum_info::in, mlds_exported_enum::out, io::di, io::uo) is det.
+ exported_enum_info::in, mlds_exported_enum::out) is det.
ml_gen_exported_enum(_ModuleInfo, TypeTable, ExportedEnumInfo,
- MLDS_ExportedEnum, !IO) :-
+ MLDS_ExportedEnum) :-
ExportedEnumInfo = exported_enum_info(Lang, Context, TypeCtor, Mapping),
map.lookup(TypeTable, TypeCtor, TypeDefn),
get_type_defn_body(TypeDefn, TypeBody),
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.133
diff -u -b -r1.133 ml_unify_gen.m
--- compiler/ml_unify_gen.m 25 Aug 2009 23:46:48 -0000 1.133
+++ compiler/ml_unify_gen.m 28 Aug 2009 11:49:14 -0000
@@ -60,12 +60,12 @@
:- pred ml_gen_known_tag_test(prog_var::in, tagged_cons_id::in, mlds_rval::out,
ml_gen_info::in, ml_gen_info::out) is det.
- % ml_gen_secondary_tag_rval(PrimaryTag, VarType, ModuleInfo, VarRval):
+ % ml_gen_secondary_tag_rval(ModuleInfo, PrimaryTag, VarType, VarRval):
%
% Return the rval for the secondary tag field of VarRval, assuming that
% VarRval has the specified VarType and PrimaryTag.
%
-:- func ml_gen_secondary_tag_rval(tag_bits, mer_type, module_info, mlds_rval)
+:- func ml_gen_secondary_tag_rval(module_info, tag_bits, mer_type, mlds_rval)
= mlds_rval.
% Generate an MLDS rval for a given reserved address,
@@ -74,19 +74,25 @@
:- func ml_gen_reserved_address(module_info, reserved_address, mlds_type) =
mlds_rval.
- % ml_gen_new_object(MaybeConsId, Tag, HasSecTag, MaybeCtorName, Var,
+ % ml_gen_new_object(MaybeConsId, MaybeCtorName, Tag, HasSecTag, Var,
% ExtraRvals, ExtraTypes, ArgVars, ArgModes, TakeAddr, HowToConstruct,
- % Context, Decls, Statements, !Info):
+ % Context, Statements, !Info):
%
% Generate a `new_object' statement, or a static constant, depending on the
% value of the how_to_construct argument. The `ExtraRvals' and `ExtraTypes'
% arguments specify additional constants to insert at the start of the
% argument list.
%
-:- pred ml_gen_new_object(maybe(cons_id)::in, mlds_tag::in, bool::in,
- maybe(ctor_name)::in, prog_var::in, list(mlds_rval)::in,
- list(mlds_type)::in, prog_vars::in, list(uni_mode)::in, list(int)::in,
- how_to_construct::in, prog_context::in, list(mlds_defn)::out,
+:- pred ml_gen_new_object(maybe(cons_id)::in, maybe(ctor_name)::in,
+ mlds_tag::in, bool::in, prog_var::in,
+ list(mlds_rval)::in, list(mlds_type)::in,
+ prog_vars::in, list(uni_mode)::in, list(int)::in,
+ how_to_construct::in, prog_context::in, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ % Generate MLDS code for a scope that constructs a ground term.
+ %
+:- pred ml_gen_ground_term(prog_var::in, hlds_goal::in,
list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
%-----------------------------------------------------------------------------%
@@ -109,16 +115,21 @@
:- 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_global_data.
:- import_module ml_backend.ml_type_gen.
:- import_module ml_backend.ml_util.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
+:- import_module assoc_list.
+:- import_module counter.
:- import_module int.
:- import_module map.
:- import_module pair.
+:- import_module set.
:- import_module string.
+:- import_module svmap.
:- import_module term.
:- import_module varset.
@@ -146,7 +157,7 @@
Context),
Statements = [Statement]
),
- ( ml_gen_info_search_const_var_name(!.Info, SourceVar, Name) ->
+ ( ml_gen_info_search_const_var(!.Info, SourceVar, GroundTerm) ->
% If the source variable is a constant, so is the target after
% this assignment.
%
@@ -156,7 +167,7 @@
% TargetVar among their arguments. If we didn't copy the constant
% info here, the construction of the later constant could cause
% a code generator abort.
- ml_gen_info_set_const_var_name(TargetVar, Name, !Info)
+ ml_gen_info_set_const_var(TargetVar, GroundTerm, !Info)
;
true
),
@@ -199,7 +210,8 @@
"ml_gen_unification: term size profiling not yet supported")
),
ml_gen_construct(Var, ConsId, Args, ArgModes, TakeAddr, HowToConstruct,
- Context, Decls, Statements, !Info)
+ Context, Statements, !Info),
+ Decls = []
;
Unification = deconstruct(Var, ConsId, Args, ArgModes, CanFail,
CanCGC),
@@ -235,8 +247,8 @@
% determinism field in the goal_info is allowed to be a conservative
% approximation, so we need to handle the case were CodeModel is less
% precise than ExpectedCodeModel.
- ml_gen_wrap_goal(CodeModel, ExpectedCodeModel, Context,
- Statements0, Statements, !Info)
+ ml_gen_maybe_convert_goal_code_model(CodeModel, ExpectedCodeModel,
+ Context, Statements0, Statements, !Info)
;
Unification = complicated_unify(_, _, _),
% Simplify.m should have converted these into procedure calls.
@@ -245,29 +257,25 @@
% ml_gen_construct generates code for a construction unification.
%
- % Note that the code for ml_gen_static_const_arg is very similar to
- % the code here, and any changes may need to be done in both places.
- %
:- pred ml_gen_construct(prog_var::in, cons_id::in, prog_vars::in,
list(uni_mode)::in, list(int)::in, how_to_construct::in, prog_context::in,
- list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_construct(Var, ConsId, Args, ArgModes, TakeAddr, HowToConstruct,
- Context, Decls, Statements, !Info) :-
+ Context, Statements, !Info) :-
% Figure out how this cons_id is represented.
ml_variable_type(!.Info, Var, Type),
ml_cons_id_to_tag(!.Info, ConsId, Tag),
- ml_gen_construct_2(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
- HowToConstruct, Context, Decls, Statements, !Info).
+ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
+ HowToConstruct, Context, Statements, !Info).
-:- pred ml_gen_construct_2(cons_tag::in, mer_type::in, prog_var::in,
+:- pred ml_gen_construct_tag(cons_tag::in, mer_type::in, prog_var::in,
cons_id::in, prog_vars::in, list(uni_mode)::in, list(int)::in,
- how_to_construct::in, prog_context::in, list(mlds_defn)::out,
- list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
+ how_to_construct::in, prog_context::in, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_construct_2(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
- HowToConstruct, Context, Decls, Statements, !Info) :-
+ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
+ HowToConstruct, Context, Statements, !Info) :-
(
% Types for which some other constructor has a reserved_address
% -- that only makes a difference when deconstructing, so here we
@@ -275,37 +283,56 @@
% constructor.
Tag = shared_with_reserved_addresses_tag(_, ThisTag),
- ml_gen_construct_2(ThisTag, Type, Var, ConsId, Args, ArgModes,
- TakeAddr, HowToConstruct, Context, Decls, Statements, !Info)
+ ml_gen_construct_tag(ThisTag, Type, Var, ConsId, Args, ArgModes,
+ TakeAddr, HowToConstruct, Context, Statements, !Info)
;
Tag = no_tag,
(
- Args = [Arg],
- ArgModes = [ArgMode]
+ Args = [ArgVar],
+ ArgModes = [_ArgMode]
->
- ml_variable_type(!.Info, Arg, ArgType),
- ml_variable_type(!.Info, Var, VarType),
- ml_gen_var(!.Info, Arg, ArgLval),
ml_gen_var(!.Info, Var, VarLval),
- ml_gen_sub_unify(ArgMode, ArgLval, ArgType, VarLval,
- VarType, Context, [], Statements, !Info),
- Decls = []
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ( ml_gen_info_search_const_var(!.Info, ArgVar, ArgGroundTerm) ->
+ ArgGroundTerm = ml_ground_term(ArgRval, ArgType),
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, Type,
+ native_if_possible, ArgRval, Rval),
+ GroundTerm = ml_ground_term(Rval, Type),
+ ml_gen_info_set_const_var(Var, GroundTerm, !Info)
+ ;
+ ml_gen_var(!.Info, ArgVar, ArgVarLval),
+ ml_variable_type(!.Info, ArgVar, ArgType),
+ ArgRval = ml_lval(ArgVarLval),
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, Type,
+ native_if_possible, ArgRval, Rval)
+ ),
+ Statement = ml_gen_assign(VarLval, Rval, Context),
+ Statements = [Statement]
;
- unexpected(this_file, "ml_gen_construct_2: no_tag: arity != 1")
+ unexpected(this_file, "ml_gen_construct_tag: no_tag: arity != 1")
)
;
% Lambda expressions.
Tag = closure_tag(PredId, ProcId, _EvalMethod),
ml_gen_closure(PredId, ProcId, Var, Args, ArgModes, HowToConstruct,
- Context, Decls, Statements, !Info)
+ Context, Statements, !Info)
;
% Ordinary compound terms.
- ( Tag = single_functor_tag
- ; Tag = unshared_tag(_TagVal)
- ; Tag = shared_remote_tag(_PrimaryTag, _SecondaryTag)
+ (
+ Tag = single_functor_tag,
+ Ptag = 0,
+ MaybeStag = no
+ ;
+ Tag = unshared_tag(Ptag),
+ MaybeStag = no
+ ;
+ Tag = shared_remote_tag(Ptag, Stag),
+ MaybeStag = yes(Stag)
),
- ml_gen_compound(Tag, ConsId, Var, Args, ArgModes, TakeAddr,
- HowToConstruct, Context, Decls, Statements, !Info)
+ UsesBaseClass = ml_tag_uses_base_class(Tag),
+ ml_gen_compound(ConsId, Ptag, MaybeStag, UsesBaseClass, Var,
+ Args, ArgModes, TakeAddr, HowToConstruct, Context,
+ Statements, !Info)
;
% Constants.
( Tag = int_tag(_)
@@ -324,120 +351,30 @@
Args = [],
ml_gen_var(!.Info, Var, VarLval),
ml_gen_constant(Tag, Type, Rval, !Info),
+ GroundTerm = ml_ground_term(Rval, Type),
+ ml_gen_info_set_const_var(Var, GroundTerm, !Info),
Statement = ml_gen_assign(VarLval, Rval, Context),
- Decls = [],
Statements = [Statement]
;
Args = [_ | _],
- unexpected(this_file, "ml_gen_construct_2: bad constant term")
+ unexpected(this_file, "ml_gen_construct_tag: bad constant term")
)
).
- % ml_gen_static_const_arg is similar to ml_gen_construct with
- % HowToConstruct = construct_statically(_), except that for compound terms,
- % rather than generating a new static constant, it just generates a
- % reference to one that has already been defined.
- %
- % Note that any changes here may require similar changes to
- % ml_gen_construct.
- %
-:- pred ml_gen_static_const_arg(prog_var::in, static_cons::in,
- prog_context::in, list(mlds_defn)::out, mlds_rval::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_static_const_arg_list(ml_gen_info::in, list(prog_var)::in,
+ list(mlds_rval)::out) is det.
-ml_gen_static_const_arg(Var, StaticCons, Context, Defns, Rval, !Info) :-
- % Figure out how this argument is represented.
- StaticCons = static_cons(ConsId, _ArgVars, _StaticArgs),
- ml_variable_type(!.Info, Var, VarType),
- ml_cons_id_to_tag(!.Info, ConsId, Tag),
- ml_gen_static_const_arg_2(Tag, VarType, Var, StaticCons, Context, Defns,
- Rval, !Info).
-
-:- pred ml_gen_static_const_arg_2(cons_tag::in, mer_type::in, prog_var::in,
- static_cons::in, prog_context::in, list(mlds_defn)::out, mlds_rval::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ml_gen_static_const_arg_list(_, [], []).
+ml_gen_static_const_arg_list(Info, [Var | Vars], [Rval | Rvals]) :-
+ ml_gen_static_const_arg(Info, Var, Rval),
+ ml_gen_static_const_arg_list(Info, Vars, Rvals).
-ml_gen_static_const_arg_2(Tag, VarType, Var, StaticCons, Context, Defns, Rval,
- !Info) :-
- StaticCons = static_cons(ConsId, ArgVars, StaticArgs),
- (
- % Types for which some other constructor has a reserved_address
- % -- that only makes a difference when constructing, so here
- % we ignore that, and just recurse on the representation for
- % this constructor.
- Tag = shared_with_reserved_addresses_tag(_, ThisTag),
- ml_gen_static_const_arg_2(ThisTag, VarType, Var, StaticCons,
- Context, Defns, Rval, !Info)
- ;
- Tag = no_tag,
- (
- ArgVars = [Arg],
- StaticArgs = [StaticArg]
- ->
- % Construct (statically) the argument, and then convert it
- % to the appropriate type.
- ml_gen_static_const_arg(Arg, StaticArg, Context, ArgDefns, ArgRval,
- !Info),
- ml_variable_type(!.Info, Arg, ArgType),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- MLDS_ArgType = mercury_type_to_mlds_type(ModuleInfo, ArgType),
- ml_gen_box_const_rval(MLDS_ArgType, ArgRval, Context, BoxDefns,
- Rval, !Info),
- Defns = ArgDefns ++ BoxDefns
- ;
- unexpected(this_file,
- "ml_gen_static_const_arg_2: no_tag: arity != 1")
- )
- ;
- % Compound terms, including lambda expressions.
- ( Tag = closure_tag(_, _, _), TagVal = 0
- ; Tag = single_functor_tag, TagVal = 0
- ; Tag = unshared_tag(TagVal)
- ; Tag = shared_remote_tag(TagVal, _SecondaryTag)
- ),
- % If this argument is something that would normally be allocated
- % on the heap, just generate a reference to the static constant
- % that we must have already generated for it.
+:- pred ml_gen_static_const_arg(ml_gen_info::in, prog_var::in, mlds_rval::out)
+ is det.
- ml_gen_type(!.Info, VarType, MLDS_VarType),
- ml_gen_info_get_globals(!.Info, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
- UsesBaseClass = (ml_tag_uses_base_class(Tag) -> yes ; no),
- ConstType = get_type_for_cons_id(MLDS_VarType, UsesBaseClass,
- yes(ConsId), HighLevelData, Globals),
- ml_gen_static_const_addr(!.Info, Var, ConstType, ConstAddrRval),
- ( TagVal = 0 ->
- TaggedRval = ConstAddrRval
- ;
- TaggedRval = ml_mkword(TagVal, ConstAddrRval)
- ),
- Rval = ml_unop(cast(MLDS_VarType), TaggedRval),
- Defns = []
- ;
- ( Tag = string_tag(_)
- ; Tag = int_tag(_)
- ; Tag = float_tag(_)
- ; Tag = shared_local_tag(_, _)
- ; Tag = reserved_address_tag(_)
- ; Tag = foreign_tag(_, _)
- ; Tag = type_ctor_info_tag(_, _, _)
- ; Tag = base_typeclass_info_tag(_, _, _)
- ; Tag = tabling_info_tag(_, _)
- ; Tag = deep_profiling_proc_layout_tag(_, _)
- ; Tag = table_io_decl_tag(_, _)
- ),
- (
- % If this argument is just a constant, then generate the rval
- % for the constant.
- StaticArgs = [],
- ml_gen_constant(Tag, VarType, Rval, !Info),
- Defns = []
- ;
- StaticArgs = [_ | _],
- unexpected(this_file,
- "ml_gen_static_const_arg_2: unknown compound term")
- )
- ).
+ml_gen_static_const_arg(Info, Var, Rval) :-
+ ml_gen_info_lookup_const_var(Info, Var, GroundTerm),
+ GroundTerm = ml_ground_term(Rval, _).
% Generate the rval for a given constant.
%
@@ -516,9 +453,9 @@
Rval = ml_gen_reserved_address(ModuleInfo, ReservedAddr, MLDS_VarType)
;
Tag = shared_with_reserved_addresses_tag(_, ThisTag),
- % For shared_with_reserved_address, the sharing is only important for
- % tag tests, not for constructions, so here we just recurse on the
- % real representation.
+ % Whether or not some other constructors in the type are represented
+ % by reserved addresses makes a difference only when deconstructing
+ % the term, not when constructing it.
ml_gen_constant(ThisTag, VarType, Rval, !Info)
;
% These tags, which are not (necessarily) constants, are handled
@@ -559,8 +496,9 @@
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
TypeCtor = type_ctor(TypeName, TypeArity),
UnqualTypeName = unqualify_name(TypeName),
- MLDS_TypeName = mlds_append_class_qualifier(MLDS_ModuleName,
- module_qual, Globals, UnqualTypeName, TypeArity),
+ globals.get_target(Globals, Target),
+ MLDS_TypeName = mlds_append_class_qualifier(Target,
+ MLDS_ModuleName, module_qual, UnqualTypeName, TypeArity),
Name = ml_format_reserved_object_name(CtorName, CtorArity),
Rval0 = ml_const(mlconst_data_addr(
data_addr(MLDS_TypeName, mlds_data_var(Name)))),
@@ -575,7 +513,6 @@
% optimize downcasts). So we only do it if the back-end
% requires it.
- globals.get_target(Globals, Target),
SupportsInheritance = target_supports_inheritence(Target),
(
SupportsInheritance = yes,
@@ -617,78 +554,64 @@
% Generate code to construct a new object.
%
-:- pred ml_gen_compound(cons_tag::in, cons_id::in, prog_var::in,
- prog_vars::in, list(uni_mode)::in, list(int)::in, how_to_construct::in,
- prog_context::in, list(mlds_defn)::out, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_compound(Tag, ConsId, Var, ArgVars, ArgModes, TakeAddr,
- HowToConstruct, Context, Decls, Statements, !Info) :-
- % Get the primary and secondary tags.
- ( get_primary_tag(Tag) = yes(PrimaryTag0) ->
- PrimaryTag = PrimaryTag0
- ;
- unexpected(this_file, "ml_gen_compound: primary tag unknown")
- ),
- MaybeSecondaryTag = get_secondary_tag(Tag),
-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
+:- pred ml_gen_compound(cons_id::in, int::in, maybe(int)::in,
+ tag_uses_base_class::in, prog_var::in, prog_vars::in, list(uni_mode)::in,
+ list(int)::in, how_to_construct::in, prog_context::in,
+ list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
+ml_gen_compound(ConsId, Ptag, MaybeStag, UsesBaseClass, Var,
+ ArgVars, ArgModes, TakeAddr, HowToConstruct, Context,
+ Statements, !Info) :-
% Figure out which class name to construct.
- ( ml_tag_uses_base_class(Tag) ->
+ (
+ UsesBaseClass = tag_uses_base_class,
MaybeCtorName = no
;
- globals.get_target(Globals, CompilationTarget),
+ UsesBaseClass = tag_does_not_use_base_class,
+ ml_gen_info_get_target(!.Info, CompilationTarget),
ml_cons_name(CompilationTarget, ConsId, CtorName),
MaybeCtorName = yes(CtorName)
),
% If there is a secondary tag, it goes in the first field.
(
- MaybeSecondaryTag = yes(SecondaryTag),
+ MaybeStag = yes(Stag),
HasSecTag = yes,
- SecondaryTagRval0 = ml_const(mlconst_int(SecondaryTag)),
- SecondaryTagType0 = mlds_native_int_type,
+ StagRval0 = ml_const(mlconst_int(Stag)),
+ StagType0 = mlds_native_int_type,
% With the low-level data representation, all fields -- even the
% secondary tag -- are boxed, and so we need box it here.
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
(
HighLevelData = no,
- SecondaryTagRval = ml_unop(box(SecondaryTagType0),
- SecondaryTagRval0),
- SecondaryTagType = mlds_generic_type
+ StagRval = ml_unop(box(StagType0), StagRval0),
+ StagType = mlds_generic_type
;
HighLevelData = yes,
- SecondaryTagRval = SecondaryTagRval0,
- SecondaryTagType = SecondaryTagType0
+ StagRval = StagRval0,
+ StagType = StagType0
),
- ExtraRvals = [SecondaryTagRval],
- ExtraArgTypes = [SecondaryTagType]
+ ExtraRvals = [StagRval],
+ ExtraArgTypes = [StagType]
;
- MaybeSecondaryTag = no,
+ MaybeStag = no,
HasSecTag = no,
ExtraRvals = [],
ExtraArgTypes = []
),
- ml_gen_new_object(yes(ConsId), PrimaryTag, HasSecTag, MaybeCtorName,
+ ml_gen_new_object(yes(ConsId), MaybeCtorName, Ptag, HasSecTag,
Var, ExtraRvals, ExtraArgTypes, ArgVars, ArgModes, TakeAddr,
- HowToConstruct, Context, Decls, Statements, !Info).
+ HowToConstruct, Context, Statements, !Info).
- % ml_gen_new_object: Generate a `new_object' statement, or a static
- % constant, depending on the value of the how_to_construct argument.
- % The `ExtraRvals' and `ExtraTypes' arguments specify additional constants
- % to insert at the start of the argument list.
- %
-ml_gen_new_object(MaybeConsId, Tag, HasSecTag, MaybeCtorName, Var,
+ml_gen_new_object(MaybeConsId, MaybeCtorName, Tag, HasSecTag, Var,
ExtraRvals, ExtraTypes, ArgVars, ArgModes, TakeAddr, HowToConstruct,
- Context, Decls, Statements, !Info) :-
+ Context, Statements, !Info) :-
% Determine the variable's type and lval, the tag to use, and the types
% of the argument vars.
- ml_variable_type(!.Info, Var, Type),
- ml_gen_type(!.Info, Type, MLDS_Type),
+ ml_variable_type(!.Info, Var, VarType),
+ ml_gen_type(!.Info, VarType, MLDS_Type),
ml_gen_var(!.Info, Var, VarLval),
( Tag = 0 ->
MaybeTag = no
@@ -699,12 +622,44 @@
(
HowToConstruct = construct_dynamically,
+ ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName,
+ MaybeTag, HasSecTag, Var, VarLval, VarType, MLDS_Type,
+ ExtraRvals, ExtraTypes, ArgVars, ArgTypes, ArgModes, TakeAddr,
+ Context, Statements, !Info)
+ ;
+ HowToConstruct = construct_statically,
+ expect(unify(TakeAddr, []), this_file,
+ "ml_gen_new_object: cannot take address of static object's field"),
+ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
+ Var, VarLval, VarType, MLDS_Type, ExtraRvals, ExtraTypes,
+ ArgVars, ArgTypes, Context, Statements, !Info)
+ ;
+ HowToConstruct = reuse_cell(CellToReuse),
+ ml_gen_new_object_reuse_cell(MaybeConsId, MaybeCtorName, Tag, MaybeTag,
+ HasSecTag, Var, VarLval, VarType, MLDS_Type,
+ ExtraRvals, ExtraTypes, ArgVars, ArgTypes, ArgModes, TakeAddr,
+ CellToReuse, Context, Statements, !Info)
+ ;
+ HowToConstruct = construct_in_region(_RegVar),
+ sorry(this_file, "ml_gen_new_object: construct_in_region NYI")
+ ).
+
+:- pred ml_gen_new_object_dynamically(maybe(cons_id)::in, maybe(ctor_name)::in,
+ maybe(mlds_tag)::in, bool::in, prog_var::in, mlds_lval::in, mer_type::in,
+ mlds_type::in, list(mlds_rval)::in, list(mlds_type)::in,
+ list(prog_var)::in, list(mer_type)::in, list(uni_mode)::in,
+ list(int)::in, prog_context::in, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName, MaybeTag, HasSecTag,
+ _Var, VarLval, VarType, MLDS_Type, ExtraRvals, ExtraTypes,
+ ArgVars, ArgTypes, ArgModes, TakeAddr, Context, Statements, !Info) :-
% Find out the types of the constructor arguments and generate rvals
% for them (boxing/unboxing if needed).
ml_gen_var_list(!.Info, ArgVars, ArgLvals),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type,
- ModuleInfo, ConsArgTypes),
+ get_maybe_cons_id_arg_types(ModuleInfo, MaybeConsId, ArgTypes, VarType,
+ ConsArgTypes),
FirstOffset = length(ExtraRvals),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, use_atomic_cells, UseAtomicCells),
@@ -715,9 +670,10 @@
UseAtomicCells = no,
MayUseAtomic0 = may_not_use_atomic_alloc
),
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
ml_gen_cons_args(ArgVars, ArgLvals, ArgTypes, ConsArgTypes, ArgModes,
- FirstOffset, 1, TakeAddr, ModuleInfo, ArgRvals0, MLDS_ArgTypes0,
- TakeAddrInfos, MayUseAtomic0, MayUseAtomic, !Info),
+ FirstOffset, 1, TakeAddr, ModuleInfo, HighLevelData,
+ ArgRvals0, MLDS_ArgTypes0, TakeAddrInfos, MayUseAtomic0, MayUseAtomic),
% Insert the extra rvals at the start.
ArgRvals = ExtraRvals ++ ArgRvals0,
@@ -738,56 +694,64 @@
ml_gen_field_take_address_assigns(TakeAddrInfos, VarLval, MLDS_Type,
MaybeTag, Context, !.Info, TakeAddrStatements),
- Statements = [Statement | TakeAddrStatements],
- Decls = []
- ;
- HowToConstruct = construct_statically(StaticArgs),
- expect(unify(TakeAddr, []), this_file,
- "ml_gen_new_object: cannot take address of static object's field"),
+ Statements = [Statement | TakeAddrStatements].
+
+:- pred ml_gen_new_object_statically(maybe(cons_id)::in, maybe(ctor_name)::in,
+ maybe(mlds_tag)::in,
+ prog_var::in, mlds_lval::in, mer_type::in, mlds_type::in,
+ list(mlds_rval)::in, list(mlds_type)::in,
+ list(prog_var)::in, list(mer_type)::in,
+ prog_context::in, list(statement)::out,
+ ml_gen_info::in, ml_gen_info::out) is det.
+ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
+ Var, VarLval, VarType, MLDS_Type, ExtraRvals, ExtraTypes,
+ ArgVars, ArgTypes, Context, Statements, !Info) :-
% Find out the types of the constructor arguments.
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type,
- ModuleInfo, ConsArgTypes),
- list.map(ml_gen_field_type(!.Info), ConsArgTypes, FieldTypes),
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
+ get_maybe_cons_id_arg_types(ModuleInfo, MaybeConsId, ArgTypes, VarType,
+ ConsArgTypes),
+ some [!GlobalData] (
% Generate rvals for the arguments.
list.map(ml_gen_type(!.Info), ArgTypes, MLDS_ArgTypes0),
- ml_gen_static_const_arg_list(ArgVars, StaticArgs, Context,
- StaticArgDefns, ArgRvals0, !Info),
+ ml_gen_static_const_arg_list(!.Info, ArgVars, ArgRvals0),
+
+ ml_gen_info_get_global_data(!.Info, !:GlobalData),
% Box or unbox the arguments, if needed, and insert the extra rvals
% at the start.
- ml_gen_info_get_globals(!.Info, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
(
HighLevelData = no,
% Box *all* the arguments, including the ExtraRvals.
ArgRvals1 = ExtraRvals ++ ArgRvals0,
MLDS_ArgTypes = ExtraTypes ++ MLDS_ArgTypes0,
- ml_gen_box_const_rval_list(MLDS_ArgTypes, ArgRvals1,
- Context, BoxConstDefns, ArgRvals, !Info)
+ ml_gen_box_const_rval_list(ModuleInfo, MLDS_ArgTypes, ArgRvals1,
+ Context, ArgRvals, !GlobalData)
;
HighLevelData = yes,
- ml_gen_box_or_unbox_const_rval_list(ArgTypes, FieldTypes,
- ArgRvals0, Context, BoxConstDefns, ArgRvals1, !Info),
+ list.map(ml_type_as_field(ModuleInfo, HighLevelData),
+ ConsArgTypes, FieldTypes),
+ ml_gen_box_or_unbox_const_rval_list(ModuleInfo, ArgTypes,
+ FieldTypes, ArgRvals0, Context, ArgRvals1, !GlobalData),
% For --high-level-data, the ExtraRvals should already have
% the right type, so we don't need to worry about boxing
% or unboxing them.
ArgRvals = ExtraRvals ++ ArgRvals1
),
- % Generate a local static constant for this term.
- ml_gen_static_const_name(Var, ConstName, !Info),
+ % Generate a static constant for this term.
(
MaybeCtorName = yes(_),
- UsesBaseClass = no
+ UsesBaseClass = tag_does_not_use_base_class
;
MaybeCtorName = no,
- UsesBaseClass = yes
+ UsesBaseClass = tag_uses_base_class
),
- ConstType = get_type_for_cons_id(MLDS_Type, UsesBaseClass,
- MaybeConsId, HighLevelData, Globals),
+ ml_gen_info_get_target(!.Info, Target),
+ ConstType = get_type_for_cons_id(Target, HighLevelData, MLDS_Type,
+ UsesBaseClass, MaybeConsId),
% XXX If the secondary tag is in a base class, then ideally its
% initializer should be wrapped in `init_struct([init_obj(X)])'
% rather than just `init_obj(X)' -- the fact that we don't leads to
@@ -798,24 +762,50 @@
;
Initializer = init_struct(ConstType, ArgInits)
),
- ConstDefn = ml_gen_static_const_defn(ConstName, ConstType,
- acc_local, Initializer, Context),
+ ml_gen_static_const_defn("const_var", ConstType, acc_private,
+ Initializer, Context, ConstVarName, !GlobalData),
+ ml_gen_info_set_global_data(!.GlobalData, !Info)
+ ),
% Assign the address of the local static constant to the variable.
- ml_gen_static_const_addr(!.Info, Var, ConstType, ConstAddrRval),
+ %
+ % Any later references to Var in later code on the right hand side of
+ % another construct_statically construction unification will refer to
+ % ConstDefn, not to VarLval. If the only later references to Var
+ % are in such places, then the definition of VarLval and AssignStatement
+ % are both useless, and can be deleted without harm. Unfortunately,
+ % at this point in the code generation process, we do not know if
+ % there are any other kinds of references to Var later on.
+ % ZZZ above comment needs updating
+
+ ml_gen_var_lval(!.Info, ConstVarName, ConstType, ConstLval),
+ ConstAddrRval = ml_mem_addr(ConstLval),
(
MaybeTag = no,
TaggedRval = ConstAddrRval
;
- MaybeTag = yes(_),
+ MaybeTag = yes(Tag),
TaggedRval = ml_mkword(Tag, ConstAddrRval)
),
Rval = ml_unop(cast(MLDS_Type), TaggedRval),
+ GroundTerm = ml_ground_term(Rval, VarType),
+ ml_gen_info_set_const_var(Var, GroundTerm, !Info),
+
AssignStatement = ml_gen_assign(VarLval, Rval, Context),
- Decls = StaticArgDefns ++ BoxConstDefns ++ [ConstDefn],
- Statements = [AssignStatement]
- ;
- HowToConstruct = reuse_cell(CellToReuse),
+ Statements = [AssignStatement].
+
+:- pred ml_gen_new_object_reuse_cell(maybe(cons_id)::in, maybe(ctor_name)::in,
+ mlds_tag::in, maybe(mlds_tag)::in, bool::in,
+ prog_var::in, mlds_lval::in, mer_type::in, mlds_type::in,
+ list(mlds_rval)::in, list(mlds_type)::in,
+ list(prog_var)::in, list(mer_type)::in, list(uni_mode)::in,
+ list(int)::in, cell_to_reuse::in, prog_context::in,
+ list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_new_object_reuse_cell(MaybeConsId, MaybeCtorName, Tag, MaybeTag,
+ HasSecTag, Var, VarLval, VarType, MLDS_Type, ExtraRvals, ExtraTypes,
+ ArgVars, ArgTypes, ArgModes, TakeAddr, CellToReuse, Context,
+ Statements, !Info) :-
CellToReuse = cell_to_reuse(ReuseVar, ReuseConsIds, _),
(
MaybeConsId = yes(ConsId0),
@@ -833,7 +823,7 @@
list.remove_dups(ReusePrimaryTags0, ReusePrimaryTags),
ml_cons_id_to_tag(!.Info, ConsId, ConsIdTag),
- ml_field_names_and_types(!.Info, Type, ConsId, ArgTypes, Fields),
+ ml_field_names_and_types(!.Info, VarType, ConsId, ArgTypes, Fields),
ml_tag_offset_and_argnum(ConsIdTag, PrimaryTag, OffSet, ArgNum),
ml_gen_var(!.Info, Var, Var1Lval),
@@ -860,48 +850,40 @@
ml_unop(std_unop(strip_tag), ml_lval(Var2Lval)))
),
- ml_gen_type(!.Info, Type, MLDS_DestType),
- CastVar2Rval = ml_unop(cast(MLDS_DestType), Var2Rval),
+ CastVar2Rval = ml_unop(cast(MLDS_Type), Var2Rval),
MLDS_Context = mlds_make_context(Context),
- AssignStatement = statement(
- ml_stmt_atomic(assign_if_in_heap(Var1Lval, CastVar2Rval)),
- MLDS_Context),
+ HeapTestStmt = ml_stmt_atomic(assign_if_in_heap(Var1Lval, CastVar2Rval)),
+ HeapTestStatement = statement(HeapTestStmt, MLDS_Context),
% For each field in the construction unification we need to generate
% an rval. ExtraRvals need to be inserted at the start of the object.
- ml_gen_extra_arg_assign(ExtraRvals, ExtraTypes, Type, VarLval,
+ ml_gen_extra_arg_assign(ExtraRvals, ExtraTypes, VarType, VarLval,
0, ConsIdTag, Context, ExtraRvalStatements, !Info),
% XXX we do more work than we need to here, as some of the cells
% may already contain the correct values.
ml_gen_unify_args_for_reuse(ConsId, ArgVars, ArgModes, ArgTypes,
- Fields, TakeAddr, Type, VarLval, OffSet, ArgNum, ConsIdTag,
+ Fields, TakeAddr, VarType, VarLval, OffSet, ArgNum, ConsIdTag,
Context, FieldStatements, TakeAddrInfos, !Info),
ml_gen_field_take_address_assigns(TakeAddrInfos, VarLval, MLDS_Type,
MaybeTag, Context, !.Info, TakeAddrStatements),
- IfBody = statement(ml_stmt_block([],
- ExtraRvalStatements ++ FieldStatements ++ TakeAddrStatements),
- MLDS_Context),
+ ThenStatements =
+ ExtraRvalStatements ++ FieldStatements ++ TakeAddrStatements,
+ ThenStmt = ml_stmt_block([], ThenStatements),
+ ThenStatement = statement(ThenStmt, MLDS_Context),
% If the reassignment isn't possible because the target is statically
% allocated then fall back to dynamic allocation.
- ml_gen_new_object(MaybeConsId, Tag, HasSecTag, MaybeCtorName, Var,
+ ml_gen_new_object(MaybeConsId, MaybeCtorName, Tag, HasSecTag, Var,
ExtraRvals, ExtraTypes, ArgVars, ArgModes, TakeAddr,
- construct_dynamically, Context, DynamicDecls, DynamicStmts, !Info),
- IfElse = statement(
- ml_stmt_block(DynamicDecls, DynamicStmts),
- MLDS_Context),
-
- IfStatement = statement(
- ml_stmt_if_then_else(ml_lval(Var1Lval), IfBody, yes(IfElse)),
- mlds_make_context(Context)),
+ construct_dynamically, Context, DynamicStmts, !Info),
+ ElseStmt = ml_stmt_block([], DynamicStmts),
+ ElseStatement = statement(ElseStmt, MLDS_Context),
- Statements = [AssignStatement, IfStatement],
- Decls = []
- ;
- HowToConstruct = construct_in_region(_RegVar),
- sorry(this_file, "ml_gen_new_object: " ++
- "implementation for construct_in_region is not available")
- ).
+ IfStmt = ml_stmt_if_then_else(ml_lval(Var1Lval), ThenStatement,
+ yes(ElseStatement)),
+ IfStatement = statement(IfStmt, mlds_make_context(Context)),
+
+ Statements = [HeapTestStatement, IfStatement].
:- pred ml_gen_field_take_address_assigns(list(take_addr_info)::in,
mlds_lval::in, mlds_type::in, maybe(mlds_tag)::in, prog_context::in,
@@ -929,11 +911,11 @@
% Return the MLDS type suitable for constructing a constant static
% ground term with the specified cons_id.
%
-:- func get_type_for_cons_id(mlds_type, bool, maybe(cons_id), bool,
- globals) = mlds_type.
+:- func get_type_for_cons_id(compilation_target, bool, mlds_type,
+ tag_uses_base_class, maybe(cons_id)) = mlds_type.
-get_type_for_cons_id(MLDS_Type, UsesBaseClass, MaybeConsId, HighLevelData,
- Globals) = ConstType :-
+get_type_for_cons_id(Target, HighLevelData, MLDS_Type, UsesBaseClass,
+ MaybeConsId) = ConstType :-
(
HighLevelData = no,
ConstType = mlds_array_type(mlds_generic_type)
@@ -952,7 +934,7 @@
% where the specified cons_id which is represented as a derived
% class that is derived from the base class for this discriminated
% union type.
- UsesBaseClass = no,
+ UsesBaseClass = tag_does_not_use_base_class,
MaybeConsId = yes(ConsId),
ConsId = cons(CtorSymName, CtorArity, _TypeCtor),
(
@@ -966,13 +948,12 @@
% If so, append the name of the derived class to the name of the
% base class for this type (since the derived class will also be
% nested inside the base class).
- globals.get_target(Globals, CompilationTarget),
QualTypeName = qual(_, _, UnqualTypeName),
- CtorName = ml_gen_du_ctor_name_unqual_type(CompilationTarget,
- UnqualTypeName, TypeArity, CtorSymName, CtorArity),
+ CtorName = ml_gen_du_ctor_name_unqual_type(Target, UnqualTypeName,
+ TypeArity, CtorSymName, CtorArity),
QualTypeName = qual(MLDS_Module, _QualKind, TypeName),
- ClassQualifier = mlds_append_class_qualifier(MLDS_Module,
- module_qual, Globals, TypeName, TypeArity),
+ ClassQualifier = mlds_append_class_qualifier(Target, MLDS_Module,
+ module_qual, TypeName, TypeArity),
ConstType = mlds_class_type(
qual(ClassQualifier, type_qual, CtorName),
CtorArity, mlds_class)
@@ -1006,19 +987,10 @@
)
).
-:- pred ml_gen_field_type(ml_gen_info::in, mer_type::in, mer_type::out)
- is det.
-
-ml_gen_field_type(Info, Type, FieldType) :-
- ml_gen_info_get_module_info(Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
- ml_type_as_field(Type, ModuleInfo, HighLevelData, FieldType).
-
-:- pred ml_type_as_field(mer_type::in, module_info::in, bool::in,
- mer_type::out) is det.
+:- pred ml_type_as_field(module_info::in, bool::in,
+ mer_type::in, mer_type::out) is det.
-ml_type_as_field(FieldType, ModuleInfo, HighLevelData, BoxedFieldType) :-
+ml_type_as_field(ModuleInfo, HighLevelData, FieldType, BoxedFieldType) :-
(
% With the low-level data representation, we store all fields as boxed,
% so we ignore the original field type and instead generate a
@@ -1035,9 +1007,12 @@
HighLevelData = no
;
HighLevelData = yes,
- ml_must_box_field_type(FieldType, ModuleInfo)
+ ml_must_box_field_type(ModuleInfo, FieldType)
)
->
+ % XXX zs: I do not see any reason why TypeVar cannot be confused with
+ % other type variables (whether constructed the same way or not),
+ % nor do I see any reason why such confusion would not lead to errors.
varset.init(TypeVarSet0),
varset.new_var(TypeVarSet0, TypeVar, _TypeVarSet),
% The kind is `star' since there are values with this type.
@@ -1046,40 +1021,32 @@
BoxedFieldType = FieldType
).
-:- pred get_maybe_cons_id_arg_types(maybe(cons_id)::in,
- list(mer_type)::in, mer_type::in, module_info::in, list(mer_type)::out)
+:- pred get_maybe_cons_id_arg_types(module_info::in, maybe(cons_id)::in,
+ list(mer_type)::in, mer_type::in, list(mer_type)::out)
is det.
-get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type, ModuleInfo,
+get_maybe_cons_id_arg_types(ModuleInfo, MaybeConsId, ArgTypes, Type,
ConsArgTypes) :-
(
MaybeConsId = yes(ConsId),
- ConsArgTypes = constructor_arg_types(ConsId, ArgTypes, Type,
- ModuleInfo)
+ ConsArgTypes =
+ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type)
;
MaybeConsId = no,
% It's a closure. In this case, the arguments are all boxed.
ConsArgTypes = ml_make_boxed_types(list.length(ArgTypes))
).
-:- func constructor_arg_types(cons_id, list(mer_type), mer_type,
- module_info) = list(mer_type).
+:- func constructor_arg_types(module_info, cons_id, list(mer_type), mer_type)
+ = list(mer_type).
-constructor_arg_types(ConsId, ArgTypes, Type, ModuleInfo) = ConsArgTypes :-
+constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :-
(
ConsId = cons(_, _, _),
\+ is_introduced_type_info_type(Type)
->
- % Use the type to determine the type_ctor
- ( type_to_ctor_and_args(Type, TypeCtor0, _) ->
- TypeCtor = TypeCtor0
- ;
- % The type-checker should ensure that this never happens:
- % the type for a ctor_id should never be a free type variable.
- unexpected(this_file, "constructor_arg_types: invalid type")
- ),
-
- % Given the type_ctor, lookup up the constructor.
+ % Determine the type_ctor, and then look up the data constructor.
+ type_to_ctor_det(Type, TypeCtor),
(
type_util.get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
->
@@ -1113,39 +1080,55 @@
% as can happen e.g. for closures and type_infos, we assume that
% the arguments all have the right type already.
% XXX is this the right thing to do?
- ArgTypes = ConsArgTypes
+ ConsArgTypes = ArgTypes
).
:- func ml_gen_mktag(int) = mlds_rval.
ml_gen_mktag(Tag) = ml_unop(std_unop(mktag), ml_const(mlconst_int(Tag))).
-:- pred ml_gen_box_or_unbox_const_rval_list(list(mer_type)::in,
- list(mer_type)::in, list(mlds_rval)::in, prog_context::in,
- list(mlds_defn)::out, list(mlds_rval)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_box_or_unbox_const_rval_list(module_info::in,
+ list(mer_type)::in, list(mer_type)::in, list(mlds_rval)::in,
+ prog_context::in, list(mlds_rval)::out,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_box_or_unbox_const_rval_list(ArgTypes, FieldTypes, ArgRvals,
- Context, BoxConstDefns, FieldRvals, !Info) :-
+ml_gen_box_or_unbox_const_rval_list(ModuleInfo, ArgTypes, FieldTypes, ArgRvals,
+ Context, FieldRvals, !GlobalData) :-
(
ArgTypes = [],
FieldTypes = [],
ArgRvals = []
->
- BoxConstDefns = [],
FieldRvals = []
;
ArgTypes = [ArgType | ArgTypesTail],
FieldTypes = [FieldType | FieldTypesTail],
ArgRvals = [ArgRval | ArgRvalsTail]
->
+ ml_gen_box_or_unbox_const_rval(ModuleInfo,
+ ArgType, FieldType, ArgRval, Context, FieldRval, !GlobalData),
+ ml_gen_box_or_unbox_const_rval_list(ModuleInfo,
+ ArgTypesTail, FieldTypesTail, ArgRvalsTail, Context,
+ FieldRvalsTail, !GlobalData),
+ FieldRvals = [FieldRval | FieldRvalsTail]
+ ;
+ unexpected(this_file,
+ "ml_gen_box_or_unbox_const_rval_list: list length mismatch")
+ ).
+
+:- pred ml_gen_box_or_unbox_const_rval(module_info::in,
+ mer_type::in, mer_type::in, mlds_rval::in, prog_context::in,
+ mlds_rval::out, ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_box_or_unbox_const_rval(ModuleInfo, ArgType, FieldType, ArgRval,
+ Context, FieldRval, !GlobalData) :-
(
% Handle the case where the field type is a boxed type
% -- in that case, we can just box the argument type.
FieldType = type_variable(_, _),
- ml_gen_type(!.Info, ArgType, MLDS_ArgType),
- ml_gen_box_const_rval(MLDS_ArgType, ArgRval, Context,
- BoxConstDefns0, FieldRval, !Info)
+ MLDS_ArgType = mercury_type_to_mlds_type(ModuleInfo, ArgType),
+ ml_gen_box_const_rval(ModuleInfo, MLDS_ArgType, ArgRval, Context,
+ FieldRval, !GlobalData)
;
( FieldType = defined_type(_, _, _)
; FieldType = builtin_type(_)
@@ -1154,50 +1137,41 @@
; FieldType = apply_n_type(_, _, _)
; FieldType = kinded_type(_, _)
),
- % Otherwise, fall back on ml_gen_box_or_unbox_rval.
- % XXX This might still generate stuff which is not legal
- % in a static initializer!
- ml_gen_box_or_unbox_rval(ArgType, FieldType, native_if_possible,
- ArgRval, FieldRval, !Info),
- BoxConstDefns0 = []
- ),
- ml_gen_box_or_unbox_const_rval_list(ArgTypesTail, FieldTypesTail,
- ArgRvalsTail, Context, BoxConstDefnsTail, FieldRvalsTail, !Info),
- BoxConstDefns = BoxConstDefns0 ++ BoxConstDefnsTail,
- FieldRvals = [FieldRval | FieldRvalsTail]
- ;
- unexpected(this_file,
- "ml_gen_box_or_unbox_const_rval_list: list length mismatch")
- ).
-
-:- pred ml_gen_box_const_rval_list(list(mlds_type)::in, list(mlds_rval)::in,
- prog_context::in, list(mlds_defn)::out, list(mlds_rval)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_box_const_rval_list([], [], _, [], [], !Info).
-ml_gen_box_const_rval_list([Type | Types], [Rval | Rvals], Context,
- ConstDefns, [BoxedRval | BoxedRvals], !Info) :-
- ml_gen_box_const_rval(Type, Rval, Context, ConstDefns1, BoxedRval, !Info),
- ml_gen_box_const_rval_list(Types, Rvals, Context, ConstDefns2,
- BoxedRvals, !Info),
- ConstDefns = ConstDefns1 ++ ConstDefns2.
-ml_gen_box_const_rval_list([], [_|_], _, _, _, !Info) :-
+ % Otherwise, fall back on ml_gen_box_or_unbox_rval in ml_call_gen.m.
+ % XXX This might generate an rval which is not legal in a static
+ % initializer!
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, FieldType,
+ native_if_possible, ArgRval, FieldRval)
+ ).
+
+:- pred ml_gen_box_const_rval_list(module_info::in, list(mlds_type)::in,
+ list(mlds_rval)::in, prog_context::in, list(mlds_rval)::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_box_const_rval_list(_, [], [], _, [], !GlobalData).
+ml_gen_box_const_rval_list(ModuleInfo, [Type | Types], [Rval | Rvals], Context,
+ [BoxedRval | BoxedRvals], !GlobalData) :-
+ ml_gen_box_const_rval(ModuleInfo, Type, Rval, Context, BoxedRval,
+ !GlobalData),
+ ml_gen_box_const_rval_list(ModuleInfo, Types, Rvals, Context, BoxedRvals,
+ !GlobalData).
+ml_gen_box_const_rval_list(_, [], [_ | _], _, _, !GlobalData) :-
unexpected(this_file, "ml_gen_box_const_rval_list: length mismatch").
-ml_gen_box_const_rval_list([_|_], [], _, _, _, !Info) :-
+ml_gen_box_const_rval_list(_, [_ | _], [], _, _, !GlobalData) :-
unexpected(this_file, "ml_gen_box_const_rval_list: length mismatch").
-:- pred ml_gen_box_const_rval(mlds_type::in, mlds_rval::in, prog_context::in,
- list(mlds_defn)::out, mlds_rval::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_box_const_rval(module_info::in, mlds_type::in, mlds_rval::in,
+ prog_context::in, mlds_rval::out,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_box_const_rval(Type, Rval, Context, ConstDefns, BoxedRval, !Info) :-
+ml_gen_box_const_rval(ModuleInfo, Type, Rval, Context, BoxedRval,
+ !GlobalData) :-
(
( Type = mercury_type(type_variable(_, _), _, _)
; Type = mlds_generic_type
)
->
- BoxedRval = Rval,
- ConstDefns = []
+ 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
@@ -1213,75 +1187,25 @@
)
->
% Generate a local static constant for this float.
- ml_gen_info_new_const(SequenceNum, !Info),
- ml_gen_info_get_pred_id(!.Info, PredId),
- ml_gen_info_get_proc_id(!.Info, ProcId),
- pred_id_to_int(PredId, PredIdNum),
- proc_id_to_int(ProcId, ProcIdNum),
- ConstName = mlds_var_name(string.format("float_%d_%d_%d",
- [i(PredIdNum), i(ProcIdNum), i(SequenceNum)]), no),
Initializer = init_obj(Rval),
- ConstDefn = ml_gen_static_const_defn(ConstName, Type,
- acc_local, Initializer, Context),
- ConstDefns = [ConstDefn],
+ ml_gen_static_const_defn("float", Type, acc_private, Initializer,
+ Context, ConstName, !GlobalData),
% Return as the boxed rval the address of that constant,
% cast to mlds_generic_type.
- ml_gen_var_lval(!.Info, ConstName, Type, ConstLval),
+ % ml_gen_var_lval(!.Info, ConstName, Type, ConstLval),
+
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDS_Module = mercury_module_name_to_mlds(ModuleName),
+ MLDS_ConstVar = qual(MLDS_Module, module_qual, ConstName),
+ ConstLval = ml_var(MLDS_ConstVar, Type),
+
ConstAddrRval = ml_mem_addr(ConstLval),
BoxedRval = ml_unop(cast(mlds_generic_type), ConstAddrRval)
;
- BoxedRval = ml_unop(box(Type), Rval),
- ConstDefns = []
+ BoxedRval = ml_unop(box(Type), Rval)
).
-:- pred ml_gen_static_const_arg_list(list(prog_var)::in, list(static_cons)::in,
- prog_context::in, list(mlds_defn)::out, list(mlds_rval)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_static_const_arg_list([], [], _, [], [], !Info).
-ml_gen_static_const_arg_list([Var | Vars], [StaticCons | StaticConses],
- Context, Defns, [Rval | Rvals], !Info) :-
- ml_gen_static_const_arg(Var, StaticCons, Context, VarDefns,
- Rval, !Info),
- ml_gen_static_const_arg_list(Vars, StaticConses, Context, VarsDefns,
- Rvals, !Info),
- Defns = VarDefns ++ VarsDefns.
-ml_gen_static_const_arg_list([_ | _], [], _, _, _, !Info) :-
- unexpected(this_file, "ml_gen_static_const_arg_list: length mismatch").
-ml_gen_static_const_arg_list([], [_ | _], _, _, _, !Info) :-
- unexpected(this_file, "ml_gen_static_const_arg_list: length mismatch").
-
- % Generate the name of the local static constant for a given variable.
- %
-:- pred ml_gen_static_const_name(prog_var::in, mlds_var_name::out,
- ml_gen_info::in, ml_gen_info::out) is det.
-
-ml_gen_static_const_name(Var, ConstName, !Info) :-
- ml_gen_info_new_const(SequenceNum, !Info),
- ml_gen_info_get_varset(!.Info, VarSet),
- VarName = ml_gen_var_name(VarSet, Var),
- ml_format_static_const_name(!.Info, ml_var_name_to_string(VarName),
- SequenceNum, ConstName),
- ml_gen_info_set_const_var_name(Var, ConstName, !Info).
-
-:- pred ml_lookup_static_const_name(ml_gen_info::in, prog_var::in,
- mlds_var_name::out) is det.
-
-ml_lookup_static_const_name(Info, Var, ConstName) :-
- ml_gen_info_lookup_const_var_name(Info, Var, ConstName).
-
- % Generate an rval containing the address of the local static constant
- % for a given variable.
- %
-:- pred ml_gen_static_const_addr(ml_gen_info::in, prog_var::in,
- mlds_type::in, mlds_rval::out) is det.
-
-ml_gen_static_const_addr(Info, Var, Type, ConstAddrRval) :-
- ml_lookup_static_const_name(Info, Var, ConstName),
- ml_gen_var_lval(Info, ConstName, Type, ConstLval),
- ConstAddrRval = ml_mem_addr(ConstLval).
-
:- pred ml_cons_name(compilation_target::in, cons_id::in, ctor_name::out)
is det.
@@ -1317,18 +1241,17 @@
%
:- pred ml_gen_cons_args(list(prog_var)::in, list(mlds_lval)::in,
list(mer_type)::in, list(mer_type)::in, list(uni_mode)::in,
- int::in, int::in, list(int)::in, module_info::in, list(mlds_rval)::out,
- list(mlds_type)::out, list(take_addr_info)::out,
- may_use_atomic_alloc::in, may_use_atomic_alloc::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+ int::in, int::in, list(int)::in, module_info::in, bool::in,
+ list(mlds_rval)::out, list(mlds_type)::out, list(take_addr_info)::out,
+ may_use_atomic_alloc::in, may_use_atomic_alloc::out) is det.
ml_gen_cons_args(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes, FirstOffset,
- FirstArgNum, TakeAddr, ModuleInfo, !:Rvals, !:MLDS_Types,
- !:TakeAddrInfos, !MayUseAtomic, !Info) :-
+ FirstArgNum, TakeAddr, ModuleInfo, HighLevelData,
+ !:Rvals, !:MLDS_Types, !:TakeAddrInfos, !MayUseAtomic) :-
(
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
- FirstOffset, FirstArgNum, TakeAddr, ModuleInfo, !:Rvals,
- !:MLDS_Types, !:TakeAddrInfos, !MayUseAtomic, !Info)
+ FirstOffset, FirstArgNum, TakeAddr, ModuleInfo, HighLevelData,
+ !:Rvals, !:MLDS_Types, !:TakeAddrInfos, !MayUseAtomic)
->
true
;
@@ -1337,17 +1260,16 @@
:- pred ml_gen_cons_args_2(list(prog_var)::in, list(mlds_lval)::in,
list(mer_type)::in, list(mer_type)::in, list(uni_mode)::in,
- int::in, int::in, list(int)::in, module_info::in, list(mlds_rval)::out,
- list(mlds_type)::out, list(take_addr_info)::out,
- may_use_atomic_alloc::in, may_use_atomic_alloc::out,
- ml_gen_info::in, ml_gen_info::out) is semidet.
+ int::in, int::in, list(int)::in, module_info::in, bool::in,
+ list(mlds_rval)::out, list(mlds_type)::out, list(take_addr_info)::out,
+ may_use_atomic_alloc::in, may_use_atomic_alloc::out) is semidet.
ml_gen_cons_args_2([], [], [], [], [], _FirstOffset, _FirstArgNum, _TakeAddr,
- _ModuleInfo, [], [], [], !MayUseAtomic, !Info).
+ _ModuleInfo, _HighLevelData, [], [], [], !MayUseAtomic).
ml_gen_cons_args_2([Var | Vars], [Lval | Lvals], [ArgType | ArgTypes],
[ConsArgType | ConsArgTypes], [UniMode | UniModes], FirstOffset,
- CurArgNum, !.TakeAddr, ModuleInfo, [Rval | Rvals],
- [MLDS_Type | MLDS_Types], TakeAddrInfos, !MayUseAtomic, !Info) :-
+ CurArgNum, !.TakeAddr, ModuleInfo, HighLevelData, [Rval | Rvals],
+ [MLDS_Type | MLDS_Types], TakeAddrInfos, !MayUseAtomic) :-
% It is important to use ArgType instead of ConsArgType here. ConsArgType
% is the declared type of the argument of the cons_id, while ArgType is
% the actual type of the variable being assigned to the given slot.
@@ -1360,9 +1282,7 @@
% Figure out the type of the field. Note that for the MLDS->C and
% MLDS->asm back-ends, we need to box floating point fields.
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
- ml_type_as_field(ConsArgType, ModuleInfo, HighLevelData, BoxedArgType),
+ ml_type_as_field(ModuleInfo, HighLevelData, ConsArgType, BoxedArgType),
MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, BoxedArgType),
% Compute the value of the field.
@@ -1370,8 +1290,8 @@
( !.TakeAddr = [CurArgNum | !:TakeAddr] ->
Rval = ml_const(mlconst_null(MLDS_Type)),
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
- FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, Rvals,
- MLDS_Types, TakeAddrInfosTail, !MayUseAtomic, !Info),
+ FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, HighLevelData,
+ Rvals, MLDS_Types, TakeAddrInfosTail, !MayUseAtomic),
% Whereas CurArgNum starts numbering the arguments from 1, offsets
% into fields start from zero. However, if FirstOffset > 0, then the
% cell contains FirstOffset other things (e.g. a secondary tag) before
@@ -1386,14 +1306,14 @@
check_dummy_type(ModuleInfo, ArgType) = is_not_dummy_type,
check_dummy_type(ModuleInfo, ConsArgType) = is_not_dummy_type
->
- ml_gen_box_or_unbox_rval(ArgType, BoxedArgType, native_if_possible,
- ml_lval(Lval), Rval, !Info)
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, BoxedArgType,
+ native_if_possible, ml_lval(Lval), Rval)
;
Rval = ml_const(mlconst_null(MLDS_Type))
),
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
- FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, Rvals,
- MLDS_Types, TakeAddrInfos, !MayUseAtomic, !Info)
+ FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, HighLevelData,
+ Rvals, MLDS_Types, TakeAddrInfos, !MayUseAtomic)
).
% Generate assignment statements for each of ExtraRvals into the object at
@@ -1412,15 +1332,9 @@
ml_gen_extra_arg_assign([ExtraRval | ExtraRvals], [ExtraType | ExtraTypes],
VarType, VarLval, Offset, ConsIdTag, Context,
[Statement | Statements], !Info) :-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
- (
- HighLevelData = no
- ;
- HighLevelData = yes,
- sorry(this_file, "ml_gen_extra_arg_assign: high-level data")
- ),
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
+ expect(unify(HighLevelData, no), this_file,
+ "ml_gen_extra_arg_assign: high-level data"),
ml_gen_type(!.Info, VarType, MLDS_VarType),
FieldId = ml_field_offset(ml_const(mlconst_int(Offset))),
@@ -1490,8 +1404,9 @@
ml_variable_type(!.Info, Arg, ArgType),
ml_gen_var(!.Info, Arg, ArgLval),
ml_gen_var(!.Info, Var, VarLval),
- ml_gen_sub_unify(Mode, ArgLval, ArgType, VarLval, Type,
- Context, [], Statements, !Info)
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, VarLval, Type,
+ Context, [], Statements)
;
unexpected(this_file, "ml_code_gen: no_tag: arity != 1")
)
@@ -1665,9 +1580,8 @@
FieldType = Field ^ arg_type,
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
- ml_type_as_field(FieldType, ModuleInfo, HighLevelData,
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
+ ml_type_as_field(ModuleInfo, HighLevelData, FieldType,
BoxedFieldType),
ml_gen_type(!.Info, FieldType, MLDS_FieldType),
ml_gen_type(!.Info, BoxedFieldType, MLDS_BoxedFieldType),
@@ -1696,9 +1610,7 @@
Offset, ArgNum, Tag, Context, !Statements, !Info) :-
MaybeFieldName = Field ^ arg_field_name,
FieldType = Field ^ arg_type,
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
(
% With the low-level data representation, we access all fields
% using offsets.
@@ -1708,7 +1620,7 @@
% With the high-level data representation, we always use named fields,
% except for tuple types.
HighLevelData = yes,
- globals.get_target(Globals, Target),
+ ml_gen_info_get_target(!.Info, Target),
(
( type_is_tuple(VarType, _)
; type_needs_lowlevel_rep(Target, VarType)
@@ -1718,19 +1630,18 @@
;
FieldName = ml_gen_field_name(MaybeFieldName, ArgNum),
( ConsId = cons(ConsName, ConsArity, TypeCtor) ->
- globals.get_target(Globals, CompilationTarget),
- UnqualConsName = ml_gen_du_ctor_name(CompilationTarget,
- TypeCtor, ConsName, ConsArity),
- FieldId = ml_gen_field_id(VarType, Tag, UnqualConsName,
- ConsArity, FieldName, Globals)
+ UnqualConsName = ml_gen_du_ctor_name(Target, TypeCtor,
+ ConsName, ConsArity),
+ FieldId = ml_gen_field_id(Target, VarType, Tag, UnqualConsName,
+ ConsArity, FieldName)
;
unexpected(this_file, "ml_gen_unify_arg: invalid cons_id")
)
)
),
% Box the field type, if needed.
- ml_type_as_field(FieldType, ModuleInfo, HighLevelData,
- BoxedFieldType),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ml_type_as_field(ModuleInfo, HighLevelData, FieldType, BoxedFieldType),
% Generate lvals for the LHS and the RHS.
ml_gen_type(!.Info, VarType, MLDS_VarType),
@@ -1741,20 +1652,18 @@
ml_gen_var(!.Info, Arg, ArgLval),
% Now generate code to unify them.
- ml_gen_sub_unify(Mode, ArgLval, ArgType, FieldLval, BoxedFieldType,
- Context, !Statements, !Info).
+ ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval,
+ BoxedFieldType, Context, !Statements).
-:- pred ml_gen_sub_unify(uni_mode::in, mlds_lval::in, mer_type::in,
- mlds_lval::in, mer_type::in, prog_context::in,
- list(statement)::in, list(statement)::out,
- ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_sub_unify(module_info::in, uni_mode::in, mlds_lval::in,
+ mer_type::in, mlds_lval::in, mer_type::in, prog_context::in,
+ list(statement)::in, list(statement)::out) is det.
-ml_gen_sub_unify(Mode, ArgLval, ArgType, FieldLval, FieldType, Context,
- !Statements, !Info) :-
+ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval, FieldType,
+ Context, !Statements) :-
% Figure out the direction of data-flow from the mode,
% and generate code accordingly.
Mode = ((LI - RI) -> (LF - RF)),
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
mode_to_arg_mode(ModuleInfo, (LI -> LF), ArgType, LeftMode),
mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode),
(
@@ -1778,8 +1687,8 @@
LeftMode = top_in,
RightMode = top_out
->
- ml_gen_box_or_unbox_rval(FieldType, ArgType, native_if_possible,
- ml_lval(FieldLval), FieldRval, !Info),
+ ml_gen_box_or_unbox_rval(ModuleInfo, FieldType, ArgType,
+ native_if_possible, ml_lval(FieldLval), FieldRval),
Statement = ml_gen_assign(ArgLval, FieldRval, Context),
!:Statements = [Statement | !.Statements]
;
@@ -1787,8 +1696,8 @@
LeftMode = top_out,
RightMode = top_in
->
- ml_gen_box_or_unbox_rval(ArgType, FieldType, native_if_possible,
- ml_lval(ArgLval), ArgRval, !Info),
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, FieldType,
+ native_if_possible, ml_lval(ArgLval), ArgRval),
Statement = ml_gen_assign(FieldLval, ArgRval, Context),
!:Statements = [Statement | !.Statements]
;
@@ -1915,8 +1824,8 @@
TagTestRval = ml_binop(eq, RvalTag, UnsharedTag)
;
Tag = shared_remote_tag(PrimaryTagNum, SecondaryTagNum),
- SecondaryTagField = ml_gen_secondary_tag_rval(PrimaryTagNum, Type,
- ModuleInfo, Rval),
+ SecondaryTagField = ml_gen_secondary_tag_rval(ModuleInfo,
+ PrimaryTagNum, Type, Rval),
SecondaryTagTestRval = ml_binop(eq, SecondaryTagField,
ml_const(mlconst_int(SecondaryTagNum))),
module_info_get_globals(ModuleInfo, Globals),
@@ -1959,12 +1868,7 @@
MatchesThisTag)
).
- % ml_gen_secondary_tag_rval(PrimaryTag, VarType, ModuleInfo, VarRval):
- %
- % Return the rval for the secondary tag field of VarRval, assuming that
- % VarRval has the specified VarType and PrimaryTag.
- %
-ml_gen_secondary_tag_rval(PrimaryTagVal, VarType, ModuleInfo, Rval) =
+ml_gen_secondary_tag_rval(ModuleInfo, PrimaryTagVal, VarType, Rval) =
SecondaryTagField :-
MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
module_info_get_globals(ModuleInfo, Globals),
@@ -1984,7 +1888,7 @@
ml_field_offset(ml_const(mlconst_int(0))),
mlds_generic_type, MLDS_VarType)))
;
- FieldId = ml_gen_hl_tag_field_id(VarType, ModuleInfo),
+ FieldId = ml_gen_hl_tag_field_id(ModuleInfo, VarType),
SecondaryTagField = ml_lval(ml_field(yes(PrimaryTagVal), Rval,
FieldId, mlds_native_int_type, MLDS_VarType))
).
@@ -1992,20 +1896,22 @@
% Return the field_id for the "data_tag" field of the specified
% Mercury type, which holds the secondary tag.
%
-:- func ml_gen_hl_tag_field_id(mer_type, module_info) = mlds_field_id.
+:- func ml_gen_hl_tag_field_id(module_info, mer_type) = mlds_field_id.
-ml_gen_hl_tag_field_id(Type, ModuleInfo) = FieldId :-
+ml_gen_hl_tag_field_id(ModuleInfo, Type) = FieldId :-
FieldName = "data_tag",
% Figure out the type name and arity.
type_to_ctor_and_args_det(Type, TypeCtor, _),
ml_gen_type_name(TypeCtor, QualifiedTypeName, TypeArity),
QualifiedTypeName = qual(MLDS_Module, TypeQualKind, TypeName),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+
% Figure out whether this type has constructors both with and without
% secondary tags. If so, then the secondary tag field is in a class
% "tag_type" that is derived from the base class for this type,
% rather than in the base class itself.
- module_info_get_globals(ModuleInfo, Globals),
module_info_get_type_table(ModuleInfo, TypeTable),
TypeDefn = map.lookup(TypeTable, TypeCtor),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
@@ -2023,8 +1929,8 @@
\+ ml_uses_secondary_tag(TypeCtor, TagValues, Ctor, _)
)
->
- ClassQualifier = mlds_append_class_qualifier(MLDS_Module,
- module_qual, Globals, TypeName, TypeArity),
+ ClassQualifier = mlds_append_class_qualifier(Target, MLDS_Module,
+ module_qual, TypeName, TypeArity),
ClassQualKind = TypeQualKind,
ClassName = "tag_type",
ClassArity = 0
@@ -2047,23 +1953,24 @@
QualClassName = qual(ClassQualifier, ClassQualKind, ClassName),
ClassPtrType = mlds_ptr_type(mlds_class_type(QualClassName, ClassArity,
mlds_class)),
- FieldQualifier = mlds_append_class_qualifier(ClassQualifier,
- ClassQualKind, Globals, ClassName, ClassArity),
+ FieldQualifier = mlds_append_class_qualifier(Target, ClassQualifier,
+ ClassQualKind, ClassName, ClassArity),
QualifiedFieldName = qual(FieldQualifier, type_qual, FieldName),
FieldId = ml_field_named(QualifiedFieldName, ClassPtrType).
-:- func ml_gen_field_id(mer_type, cons_tag, mlds_class_name, arity,
- mlds_field_name, globals) = mlds_field_id.
+:- func ml_gen_field_id(compilation_target, mer_type, cons_tag,
+ mlds_class_name, arity, mlds_field_name) = mlds_field_id.
-ml_gen_field_id(Type, Tag, ConsName, ConsArity, FieldName, Globals)
- = FieldId :-
+ml_gen_field_id(Target, Type, Tag, ConsName, ConsArity, FieldName) = FieldId :-
type_to_ctor_and_args_det(Type, TypeCtor, _),
ml_gen_type_name(TypeCtor, QualTypeName, TypeArity),
QualTypeName = qual(MLDS_Module, QualKind, TypeName),
- TypeQualifier = mlds_append_class_qualifier(
- MLDS_Module, QualKind, Globals, TypeName, TypeArity),
+ TypeQualifier = mlds_append_class_qualifier(Target, MLDS_Module, QualKind,
+ TypeName, TypeArity),
- ( ml_tag_uses_base_class(Tag) ->
+ UsesBaseClass = ml_tag_uses_base_class(Tag),
+ (
+ UsesBaseClass = tag_uses_base_class,
% In this case, there's only one functor for the type (other than
% reserved_address constants), and so the class name is determined
% by the type name.
@@ -2071,18 +1978,340 @@
TypeArity, mlds_class)),
QualifiedFieldName = qual(TypeQualifier, type_qual, FieldName)
;
+ UsesBaseClass = tag_does_not_use_base_class,
% In this case, the class name is determined by the constructor.
QualConsName = qual(TypeQualifier, type_qual, ConsName),
ClassPtrType = mlds_ptr_type(mlds_class_type(QualConsName,
ConsArity, mlds_class)),
- FieldQualifier = mlds_append_class_qualifier(TypeQualifier,
- type_qual, Globals, ConsName, ConsArity),
+ FieldQualifier = mlds_append_class_qualifier(Target, TypeQualifier,
+ type_qual, ConsName, ConsArity),
QualifiedFieldName = qual(FieldQualifier, type_qual, FieldName)
),
FieldId = ml_field_named(QualifiedFieldName, ClassPtrType).
%-----------------------------------------------------------------------------%
+ml_gen_ground_term(TermVar, Goal, Statements, !Info) :-
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ set.to_sorted_list(NonLocals, NonLocalList),
+ (
+ NonLocalList = [],
+ % The term being constructed by the scope is not needed, so there is
+ % nothing to do.
+ Statements = []
+ ;
+ NonLocalList = [NonLocal],
+ ( NonLocal = TermVar ->
+ ( GoalExpr = conj(plain_conj, Conjuncts) ->
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ml_gen_info_get_target(!.Info, Target),
+ ml_gen_info_get_high_level_data(!.Info, HighLevelData),
+ ml_gen_info_get_var_types(!.Info, VarTypes),
+
+ ml_gen_info_get_global_data(!.Info, GlobalData0),
+ ml_gen_ground_term_conjuncts(ModuleInfo, Target, HighLevelData,
+ VarTypes, Conjuncts, GlobalData0, GlobalData,
+ map.init, GroundTermMap),
+ ml_gen_info_set_global_data(GlobalData, !Info),
+
+ map.lookup(GroundTermMap, TermVar, TermVarGroundTerm),
+ ml_gen_info_set_const_var(TermVar, TermVarGroundTerm, !Info),
+
+ ml_gen_var(!.Info, TermVar, TermVarLval),
+ TermVarGroundTerm = ml_ground_term(TermVarRval, _),
+ Context = goal_info_get_context(GoalInfo),
+ Statement = ml_gen_assign(TermVarLval, TermVarRval, Context),
+ Statements = [Statement]
+ ;
+ unexpected(this_file, "ml_gen_ground_term: malformed goal")
+ )
+ ;
+ unexpected(this_file, "ml_gen_ground_term: unexpected nonlocal")
+ )
+ ;
+ NonLocalList = [_, _ | _],
+ unexpected(this_file, "ml_gen_ground_term: unexpected nonlocals")
+ ).
+
+:- pred ml_gen_ground_term_conjuncts(module_info::in, compilation_target::in,
+ bool::in, vartypes::in, list(hlds_goal)::in,
+ ml_global_data::in, ml_global_data::out,
+ ml_ground_term_map::in, ml_ground_term_map::out) is det.
+
+ml_gen_ground_term_conjuncts(_, _, _, _, [], !GlobalData, !GroundTermMap).
+ml_gen_ground_term_conjuncts(ModuleInfo, Target, HighLevelData, VarTypes,
+ [Goal | Goals], !GlobalData, !GroundTermMap) :-
+ ml_gen_ground_term_conjunct(ModuleInfo, Target, HighLevelData, VarTypes,
+ Goal, !GlobalData, !GroundTermMap),
+ ml_gen_ground_term_conjuncts(ModuleInfo, Target, HighLevelData, VarTypes,
+ Goals, !GlobalData, !GroundTermMap).
+
+:- pred ml_gen_ground_term_conjunct(module_info::in, compilation_target::in,
+ bool::in, vartypes::in, hlds_goal::in,
+ ml_global_data::in, ml_global_data::out,
+ ml_ground_term_map::in, ml_ground_term_map::out) is det.
+
+ml_gen_ground_term_conjunct(ModuleInfo, Target, HighLevelData, VarTypes,
+ Goal, !GlobalData, !GroundTermMap) :-
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ (
+ GoalExpr = unify(_, _, _, Unify, _),
+ Unify = construct(Var, ConsId, Args, _, _HowToConstruct, _, SubInfo),
+ SubInfo = no_construct_sub_info
+ ->
+ map.lookup(VarTypes, Var, VarType),
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, VarType),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
+ Context = goal_info_get_context(GoalInfo),
+ ml_gen_ground_term_conjunct_tag(ModuleInfo, Target, HighLevelData,
+ VarTypes, Var, VarType, MLDS_Type, ConsId, ConsTag, Args, Context,
+ !GlobalData, !GroundTermMap)
+ ;
+ unexpected(this_file, "ml_gen_ground_term_conjunct: malformed goal")
+ ).
+
+:- pred ml_gen_ground_term_conjunct_tag(module_info::in,
+ compilation_target::in, bool::in, vartypes::in,
+ prog_var::in, mer_type::in, mlds_type::in, cons_id::in, cons_tag::in,
+ list(prog_var)::in, prog_context::in,
+ ml_global_data::in, ml_global_data::out,
+ ml_ground_term_map::in, ml_ground_term_map::out) is det.
+
+ml_gen_ground_term_conjunct_tag(ModuleInfo, Target, HighLevelData, VarTypes,
+ Var, VarType, MLDS_Type, ConsId, ConsTag, Args, Context,
+ !GlobalData, !GroundTermMap) :-
+ (
+ % Constants.
+ (
+ ConsTag = int_tag(Int),
+ % See the comment in ml_gen_constant.
+ IntRval = ml_const(mlconst_int(Int)),
+ ( VarType = char_type ->
+ ConstRval = ml_unop(cast(mlds_native_char_type), IntRval)
+ ;
+ ConstRval = IntRval
+ )
+ ;
+ ConsTag = float_tag(Float),
+ ConstRval = ml_const(mlconst_float(Float))
+ ;
+ ConsTag = string_tag(String),
+ ConstRval = ml_const(mlconst_string(String))
+ ;
+ ConsTag = reserved_address_tag(ResAddr),
+ ConstRval = ml_gen_reserved_address(ModuleInfo, ResAddr, MLDS_Type)
+ ;
+ ConsTag = shared_local_tag(Ptag, Stag),
+ ConstRval = ml_unop(cast(MLDS_Type), ml_mkword(Ptag,
+ ml_unop(std_unop(mkbody), ml_const(mlconst_int(Stag)))))
+ ;
+ ConsTag = foreign_tag(ForeignLang, ForeignTag),
+ ConstRval = ml_const(mlconst_foreign(ForeignLang, ForeignTag,
+ mlds_native_int_type))
+ ),
+ expect(unify(Args, []), this_file,
+ "ml_gen_ground_term_conjunct_tag: constant tag with args"),
+ ConstGroundTerm = ml_ground_term(ConstRval, VarType),
+ svmap.det_insert(Var, ConstGroundTerm, !GroundTermMap)
+ ;
+ ( ConsTag = type_ctor_info_tag(_, _, _)
+ ; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ; ConsTag = tabling_info_tag(_, _)
+ ; ConsTag = table_io_decl_tag(_, _)
+ ),
+ unexpected(this_file, "ml_gen_ground_term_conjunct_tag: bad constant")
+ ;
+ ConsTag = shared_with_reserved_addresses_tag(_, ThisTag),
+ % Whether or not some other constructors in the type are represented
+ % by reserved addresses makes a difference only when deconstructing
+ % the term, not when constructing it.
+ ml_gen_ground_term_conjunct_tag(ModuleInfo, Target, HighLevelData,
+ VarTypes, Var, VarType, MLDS_Type, ConsId, ThisTag, Args, Context,
+ !GlobalData, !GroundTermMap)
+ ;
+ ConsTag = no_tag,
+ (
+ Args = [Arg],
+ svmap.det_remove(Arg, ArgGroundTerm, !GroundTermMap),
+ svmap.det_insert(Var, ArgGroundTerm, !GroundTermMap)
+ ;
+ ( Args = []
+ ; Args = [_, _ | _]
+ ),
+ unexpected(this_file,
+ "ml_gen_ground_term_conjunct_tag: no_tag arity != 1")
+ )
+ ;
+ % Lambda expressions cannot occur in from_ground_term_construct scopes
+ % during code generation, because if they do occur there originally,
+ % semantic analysis will change the scope reason to something else.
+ ConsTag = closure_tag(_PredId, _ProcId, _EvalMethod),
+ unexpected(this_file,
+ "ml_gen_ground_term_conjunct_tag: pred_closure_tag")
+ ;
+ % Ordinary compound terms.
+ % This code (loosely) follows the code of ml_gen_compound.
+ (
+ ConsTag = single_functor_tag,
+ Ptag = 0,
+ ExtraInitializers = []
+ ;
+ ConsTag = unshared_tag(Ptag),
+ ExtraInitializers = []
+ ;
+ ConsTag = shared_remote_tag(Ptag, Stag),
+ StagRval0 = ml_const(mlconst_int(Stag)),
+ (
+ HighLevelData = no,
+ StagRval = ml_unop(box(mlds_native_char_type), StagRval0)
+ ;
+ HighLevelData = yes,
+ StagRval = StagRval0
+ ),
+ ExtraInitializers = [init_obj(StagRval)]
+ ),
+ ml_gen_ground_term_conjunct_compound(ModuleInfo, Target, HighLevelData,
+ VarTypes, Var, VarType, MLDS_Type,
+ ConsId, ConsTag, Ptag, ExtraInitializers, Args, Context,
+ !GlobalData, !GroundTermMap)
+ ).
+
+:- pred ml_gen_ground_term_conjunct_compound(module_info::in,
+ compilation_target::in, bool::in, vartypes::in,
+ prog_var::in, mer_type::in, mlds_type::in, cons_id::in, cons_tag::in,
+ int::in, list(mlds_initializer)::in, list(prog_var)::in,
+ prog_context::in, ml_global_data::in, ml_global_data::out,
+ ml_ground_term_map::in, ml_ground_term_map::out) is det.
+
+ml_gen_ground_term_conjunct_compound(ModuleInfo, Target, HighLevelData,
+ VarTypes, Var, VarType, MLDS_Type, ConsId, ConsTag,
+ Ptag, ExtraInitializers, Args, Context,
+ !GlobalData, !GroundTermMap) :-
+ % This code (loosely) follows the code of ml_gen_new_object.
+
+ % This part does a simplied version of the job of
+ % get_maybe_cons_id_arg_types.
+ list.map(map.lookup(VarTypes), Args, ArgTypes),
+ (
+ ConsId = cons(_, _, _),
+ \+ is_introduced_type_info_type(VarType)
+ ->
+ % Determine the type_ctor, and then look up the data constructor.
+ type_to_ctor_det(VarType, TypeCtor),
+ (
+ type_util.get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
+ ->
+ ConsArgDefns = ConsDefn ^ cons_args,
+ ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgDefns),
+ NumExtraArgs = list.length(Args) - list.length(ConsArgTypes),
+ % If the scope contains existentially typed constructions,
+ % then polymorphism should have changed its scope_reason
+ % away from from_ground_term_construct.
+ expect(unify(NumExtraArgs, 0), this_file,
+ "xxx: extra args in from_ground_term_construct scope")
+ ;
+ % If we didn't find a constructor definition, maybe that is because
+ % this type was a built-in tuple type.
+ type_is_tuple(VarType, _)
+ ->
+ % In this case, the argument types are all fresh variables.
+ % Note that we don't need to worry about using the right varset
+ % here, since all we really care about at this point is whether
+ % something is a type variable or not, not which type variable it
+ % is.
+ ConsArgTypes = ml_make_boxed_types(list.length(Args))
+ ;
+ % Type_util.get_cons_defn shouldn't have failed.
+ unexpected(this_file,
+ "ml_gen_ground_term_conjunct_compound: get_cons_defn failed")
+ )
+ ;
+ ConsArgTypes = ArgTypes
+ ),
+ assoc_list.from_corresponding_lists(Args, ConsArgTypes, ArgConsArgTypes),
+
+ (
+ HighLevelData = yes,
+ list.map_foldl2(
+ construct_ground_term_initializer_hld(ModuleInfo, Context),
+ ArgConsArgTypes, ArgInitializers, !GlobalData, !GroundTermMap)
+ ;
+ HighLevelData = no,
+ list.map_foldl2(
+ construct_ground_term_initializer_lld(ModuleInfo, Context),
+ ArgConsArgTypes, ArgInitializers, !GlobalData, !GroundTermMap)
+ ),
+
+ % By construction, boxing the rvals in ExtraInitializers would be a no-op.
+ SubInitializers = ExtraInitializers ++ ArgInitializers,
+
+ % EntityDefn = mlds_data(MLDS_Type, Initializer, gc_no_stmt),
+ % Defn = mlds_defn(EntityName, MLDS_Context, Flags, EntityDefn),
+
+ % Generate a local static constant for this term.
+ ConstType = get_type_for_cons_id(Target, HighLevelData, MLDS_Type,
+ ml_tag_uses_base_class(ConsTag), yes(ConsId)),
+ % XXX If the secondary tag is in a base class, then ideally its
+ % initializer should be wrapped in `init_struct([init_obj(X)])'
+ % rather than just `init_obj(X)' -- the fact that we don't leads to
+ % some warnings from GNU C about missing braces in initializers.
+ ( ConstType = mlds_array_type(_) ->
+ Initializer = init_array(SubInitializers)
+ ;
+ Initializer = init_struct(ConstType, SubInitializers)
+ ),
+ ml_gen_static_const_defn("const_var", ConstType, acc_private, Initializer,
+ Context, ConstVarName, !GlobalData),
+
+ % Assign the (possibly tagged) address of the local static constant
+ % to the variable.
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDS_Module = mercury_module_name_to_mlds(ModuleName),
+ MLDS_ConstVar = qual(MLDS_Module, module_qual, ConstVarName),
+ ConstVarLval = ml_var(MLDS_ConstVar, MLDS_Type),
+
+ ConstAddrRval = ml_mem_addr(ConstVarLval),
+ ( Ptag = 0 ->
+ TaggedRval = ConstAddrRval
+ ;
+ TaggedRval = ml_mkword(Ptag, ConstAddrRval)
+ ),
+ Rval = ml_unop(cast(MLDS_Type), TaggedRval),
+ GroundTerm = ml_ground_term(Rval, VarType),
+ svmap.det_insert(Var, GroundTerm, !GroundTermMap).
+
+:- pred construct_ground_term_initializer_hld(module_info::in,
+ prog_context::in, pair(prog_var, mer_type) ::in, mlds_initializer::out,
+ ml_global_data::in, ml_global_data::out,
+ ml_ground_term_map::in, ml_ground_term_map::out) is det.
+
+construct_ground_term_initializer_hld(ModuleInfo, Context,
+ Arg - ConsArgType, ArgInitializer, !GlobalData, !GroundTermMap) :-
+ svmap.det_remove(Arg, ArgGroundTerm, !GroundTermMap),
+ ArgGroundTerm = ml_ground_term(ArgRval0, ArgType),
+ ml_type_as_field(ModuleInfo, yes, ConsArgType, BoxedArgType),
+ ml_gen_box_or_unbox_const_rval(ModuleInfo, ArgType, BoxedArgType,
+ ArgRval0, Context, ArgRval, !GlobalData),
+ ArgInitializer = init_obj(ArgRval).
+
+:- pred construct_ground_term_initializer_lld(module_info::in,
+ prog_context::in, pair(prog_var, mer_type) ::in, mlds_initializer::out,
+ ml_global_data::in, ml_global_data::out,
+ ml_ground_term_map::in, ml_ground_term_map::out) is det.
+
+construct_ground_term_initializer_lld(ModuleInfo, Context,
+ Arg - _ConsArgType, ArgInitializer, !GlobalData, !GroundTermMap) :-
+ svmap.det_remove(Arg, ArgGroundTerm, !GroundTermMap),
+ ArgGroundTerm = ml_ground_term(ArgRval0, ArgType),
+ MLDS_ArgType = mercury_type_to_mlds_type(ModuleInfo, ArgType),
+ ml_gen_box_const_rval(ModuleInfo, MLDS_ArgType,
+ ArgRval0, Context, ArgRval, !GlobalData),
+ ArgInitializer = init_obj(ArgRval).
+
+%-----------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "ml_unify_gen.m".
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.172
diff -u -b -r1.172 mlds.m
--- compiler/mlds.m 25 Aug 2009 23:46:49 -0000 1.172
+++ compiler/mlds.m 28 Aug 2009 11:49:14 -0000
@@ -339,9 +339,10 @@
:- import_module hlds.hlds_pred.
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
+:- import_module ml_backend.ml_global_data.
:- import_module parse_tree.prog_data.
-:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_foreign.
+:- import_module parse_tree.prog_type.
:- import_module bool.
:- import_module list.
@@ -372,7 +373,10 @@
% Packages/classes to import
mlds_toplevel_imports :: mlds_imports,
- % Definitions of code and data
+ mlds_global_defns :: ml_global_data,
+
+ % Definitions of code and non-global data.
+ % XXX Is there any non-global data?
mlds_defns :: list(mlds_defn),
% The names of init and final preds.
@@ -464,8 +468,8 @@
% The qual_kind argument specifies the qualifier kind of the module_name
% argument.
%
-:- func mlds_append_class_qualifier(mlds_module_name, mlds_qual_kind,
- globals, mlds_class_name, arity) = mlds_module_name.
+:- func mlds_append_class_qualifier(compilation_target, mlds_module_name,
+ mlds_qual_kind, mlds_class_name, arity) = mlds_module_name.
% Append a wrapper class qualifier to the module name and leave the
% package name unchanged.
@@ -487,10 +491,10 @@
:- type mlds_defn
---> mlds_defn(
% The name of the entity being declared.
- mlds_entity_name :: mlds_entity_name,
+ md_entity_name :: mlds_entity_name,
% The source location.
- mlds_context :: mlds_context,
+ md_context :: mlds_context,
% these contain the following:
% access, % public/private/protected
@@ -500,9 +504,9 @@
% constness, % const/modifiable (data only)
% is_abstract, % abstract/concrete
% etc.
- mlds_decl_flags :: mlds_decl_flags,
+ md_decl_flags :: mlds_decl_flags,
- mlds_entity_defn :: mlds_entity_defn
+ md_entity_defn :: mlds_entity_defn
).
% An mlds name may contain arbitrary characters.
@@ -1931,53 +1935,51 @@
% :- type mlds_module_name == prim_data.module_name.
:- type mlds_module_name
- ---> name(
- package_name :: prim_data.module_name,
- module_name :: prim_data.module_name
+ ---> mlds_module_name(
+ mmn_package_name :: prim_data.module_name,
+ mmn_module_name :: prim_data.module_name
).
mercury_module_and_package_name_to_mlds(MLDS_Package, MercuryModule)
- = name(MLDS_Package, MercuryModule).
+ = mlds_module_name(MLDS_Package, MercuryModule).
-mercury_module_name_to_mlds(MercuryModule)
- = name(MLDS_Package, MLDS_Package) :-
- (
- mercury_std_library_module_name(MercuryModule)
- ->
+mercury_module_name_to_mlds(MercuryModule) = Name :-
+ ( mercury_std_library_module_name(MercuryModule) ->
MLDS_Package = add_outermost_qualifier("mercury", MercuryModule)
;
MLDS_Package = MercuryModule
- ).
+ ),
+ Name = mlds_module_name(MLDS_Package, MLDS_Package).
is_std_lib_module(Module, Name) :-
- Name0 = Module ^ module_name,
+ Name0 = Module ^ mmn_module_name,
strip_outermost_qualifier(Name0, "mercury", Name),
mercury_std_library_module_name(Name).
-mlds_module_name_to_sym_name(Module) = Module ^ module_name.
+mlds_module_name_to_sym_name(Module) = Module ^ mmn_module_name.
-mlds_module_name_to_package_name(Module) = Module ^ package_name.
+mlds_module_name_to_package_name(Module) = Module ^ mmn_package_name.
-mlds_append_class_qualifier(name(Package, Module), QualKind, Globals,
- ClassName, ClassArity) =
- name(Package, qualified(AdjustedModule, ClassQualifier)) :-
+mlds_append_class_qualifier(Target, mlds_module_name(Package, Module),
+ QualKind, ClassName, ClassArity) = Name :-
% For the Java back-end, we flip the initial case of an type qualifiers,
% in order to match the usual Java conventions.
(
- globals.get_target(Globals, CompilationTarget),
- CompilationTarget = target_java,
+ Target = target_java,
QualKind = type_qual
->
AdjustedModule = flip_initial_case_of_final_part(Module)
;
AdjustedModule = Module
),
- string.format("%s_%d", [s(ClassName), i(ClassArity)], ClassQualifier).
+ string.format("%s_%d", [s(ClassName), i(ClassArity)], ClassQualifier),
+ Name = mlds_module_name(Package,
+ qualified(AdjustedModule, ClassQualifier)).
mlds_append_wrapper_class(Name) = mlds_append_name(Name, wrapper_class_name).
-mlds_append_name(name(Package, Module), Name)
- = name(Package, qualified(Module, Name)).
+mlds_append_name(mlds_module_name(Package, Module), Name)
+ = mlds_module_name(Package, qualified(Module, Name)).
wrapper_class_name = "mercury_code".
@@ -2086,31 +2088,46 @@
% Here we define the functions to lookup a member of the set.
%
-access(Flags) = promise_det(pred(Access::out) is semidet :-
- Flags /\ access_mask = access_bits(Access)).
-
-per_instance(Flags) = promise_det(pred(PerInstance::out) is semidet :-
- Flags /\ per_instance_mask = per_instance_bits(PerInstance)).
-
-virtuality(Flags) = promise_det(pred(Virtuality::out) is semidet :-
- Flags /\ virtuality_mask = virtuality_bits(Virtuality)).
+access(Flags) = Access :-
+ ( Flags /\ access_mask = access_bits(AccessPrime) ->
+ Access = AccessPrime
+ ;
+ unexpected(this_file, "access: unknown bits")
+ ).
-finality(Flags) = promise_det(pred(Finality::out) is semidet :-
- Flags /\ finality_mask = finality_bits(Finality)).
+per_instance(Flags) = PerInstance :-
+ ( Flags /\ per_instance_mask = per_instance_bits(PerInstancePrime) ->
+ PerInstance = PerInstancePrime
+ ;
+ unexpected(this_file, "per_instance: unknown bits")
+ ).
-constness(Flags) = promise_det(pred(Constness::out) is semidet :-
- Flags /\ constness_mask = constness_bits(Constness)).
+virtuality(Flags) = Virtuality :-
+ ( Flags /\ virtuality_mask = virtuality_bits(VirtualityPrime) ->
+ Virtuality = VirtualityPrime
+ ;
+ unexpected(this_file, "virtuality: unknown bits")
+ ).
-abstractness(Flags) = promise_det(pred(Abstractness::out) is semidet :-
- Flags /\ abstractness_mask = abstractness_bits(Abstractness)).
+finality(Flags) = Finality :-
+ ( Flags /\ finality_mask = finality_bits(FinalityPrime) ->
+ Finality = FinalityPrime
+ ;
+ unexpected(this_file, "per_instance: unknown bits")
+ ).
-:- func promise_det(pred(T)) = T.
-:- mode promise_det(pred(out) is semidet) = out is det.
+constness(Flags) = Constness :-
+ ( Flags /\ constness_mask = constness_bits(ConstnessPrime) ->
+ Constness = ConstnessPrime
+ ;
+ unexpected(this_file, "per_instance: unknown bits")
+ ).
-promise_det(Pred) = X :-
- ( if Pred(X0)
- then X = X0
- else unexpected(this_file, "promise_det failed")
+abstractness(Flags) = Abstractness :-
+ ( Flags /\ abstractness_mask = abstractness_bits(AbstractnessPrime) ->
+ Abstractness = AbstractnessPrime
+ ;
+ unexpected(this_file, "per_instance: unknown bits")
).
%
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.238
diff -u -b -r1.238 mlds_to_c.m
--- compiler/mlds_to_c.m 25 Aug 2009 23:46:49 -0000 1.238
+++ compiler/mlds_to_c.m 28 Aug 2009 12:56:48 -0000
@@ -27,14 +27,15 @@
:- module ml_backend.mlds_to_c.
:- interface.
-:- import_module ml_backend.mlds.
:- import_module backend_libs.rtti.
+:- import_module libs.globals.
+:- import_module ml_backend.mlds.
:- import_module io.
%-----------------------------------------------------------------------------%
- % output_mlds(MLDS, Suffix):
+ % output_c_mlds(MLDS, Globals, Suffix):
%
% Output C code the the appropriate C file and C declarations to the
% appropriate header file. The file names are determined by the module
@@ -42,26 +43,28 @@
% for debugging dumps. For normal output, the suffix should be the empty
% string.)
%
-:- pred output_mlds(mlds::in, string::in, io::di, io::uo) is det.
+:- pred output_c_mlds(mlds::in, globals::in, string::in, io::di, io::uo)
+ is det.
- % output_header_file(MLDS, Suffix):
+ % output_c_header_file(MLDS, Globals, Suffix):
%
% Output C declarations for the procedures (etc.) in the specified MLDS
% module to the appropriate .mih header file. See output_mlds for the
% meaning of Suffix.
%
-:- pred output_header_file(mlds::in, string::in,
+:- pred output_c_header_file(mlds::in, globals::in, string::in,
io::di, io::uo) is det.
:- func mlds_tabling_data_name(mlds_proc_label, proc_tabling_struct_id)
= string.
- % output_c_file(MLDS, Suffix):
+ % output_c_file(MLDS, Globals, Suffix):
%
% Output C code for the specified MLDS module to the appropriate C file.
% See output_mlds for the meaning of Suffix.
%
-:- pred output_c_file(mlds::in, string::in, io::di, io::uo) is det.
+:- pred output_c_file(mlds::in, globals::in, string::in, io::di, io::uo)
+ is det.
% Output an MLDS context in C #line format.
% This is useful for other foreign language interfaces such as
@@ -83,13 +86,13 @@
:- import_module hlds.hlds_pred. % for pred_proc_id.
:- import_module libs.compiler_util.
:- import_module libs.file_util.
-:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ml_code_util.
% for ml_gen_public_field_decl_flags,
% which is used by the code that
% handles derived classes
+:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_type_gen. % for ml_gen_type_name
:- import_module ml_backend.ml_util.
:- import_module parse_tree.file_names.
@@ -115,12 +118,61 @@
%-----------------------------------------------------------------------------%
-:- type output_type == pred(mlds_type, io, io).
-:- inst output_type == (pred(in, di, uo) is det).
+:- type output_type == pred(mlds_to_c_opts, mlds_type, io, io).
+:- inst output_type == (pred(in, in, di, uo) is det).
%-----------------------------------------------------------------------------%
-output_mlds(MLDS, Suffix, !IO) :-
+ % This type concentrates the values of all the options that this module
+ % needs, in a form that can be looked up much more quickly than by calling
+ % lookup_bool_option. Each field is named after the option whose value
+ % it holds, with the exception of m2co_need_to_init, which is set to `yes'
+ % if any of the profile_calls, profile_memory and profile_time fields
+ % is `yes'.
+ %
+ % This last is because we need to output calls to MR_init_entry if any form
+ % of profiling is enabled. (It would be OK to output the calls regardless,
+ % since they will macro-expand to nothing if profiling is not enabled,
+ % but for readability of the generated code we prefer not to.)
+ %
+:- type mlds_to_c_opts
+ ---> mlds_to_c_opts(
+ m2co_auto_comments :: bool,
+ m2co_gcc_local_labels :: bool,
+ m2co_gcc_nested_functions :: bool,
+ m2co_highlevel_data :: bool,
+ m2co_profile_calls :: bool,
+ m2co_profile_memory :: bool,
+ m2co_profile_time :: bool,
+ m2co_need_to_init :: bool,
+ m2co_target :: compilation_target
+ ).
+
+:- func init_mlds_to_c_opts(globals) = mlds_to_c_opts.
+
+init_mlds_to_c_opts(Globals) = Opts :-
+ globals.lookup_bool_option(Globals, auto_comments, Comments),
+ globals.lookup_bool_option(Globals, gcc_local_labels, GccLabels),
+ globals.lookup_bool_option(Globals, gcc_nested_functions, GccNested),
+ globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ globals.lookup_bool_option(Globals, profile_calls, ProfileCalls),
+ globals.lookup_bool_option(Globals, profile_memory, ProfileMemory),
+ globals.lookup_bool_option(Globals, profile_time, ProfileTime),
+ (
+ ( ProfileCalls = yes
+ ; ProfileMemory = yes
+ ; ProfileTime = yes
+ )
+ ->
+ ProfileAny = yes
+ ;
+ ProfileAny = no
+ ),
+ globals.get_target(Globals, Target),
+ Opts = mlds_to_c_opts(Comments, GccLabels, GccNested, HighLevelData,
+ ProfileCalls, ProfileMemory, ProfileTime, ProfileAny, Target).
+
+output_c_mlds(MLDS, Globals, Suffix, !IO) :-
% We output the source file before outputting the header, since the Mmake
% dependencies say the header file depends on the source file, and so if
% we wrote them out in the other order, this might lead to unnecessary
@@ -129,19 +181,32 @@
% XXX At some point we should also handle output of any non-C
% foreign code (Ada, Fortran, etc.) to appropriate files.
%
- output_c_file(MLDS, Suffix, !IO),
- output_header_file(MLDS, Suffix, !IO).
+ Opts = init_mlds_to_c_opts(Globals),
+ output_c_file_opts(MLDS, Opts, Suffix, !IO),
+ output_c_header_file_opts(MLDS, Opts, Suffix, !IO).
+
+output_c_file(MLDS, Globals, Suffix, !IO) :-
+ Opts = init_mlds_to_c_opts(Globals),
+ output_c_file_opts(MLDS, Opts, Suffix, !IO).
-output_c_file(MLDS, Suffix, !IO) :-
+:- pred output_c_file_opts(mlds::in, mlds_to_c_opts::in, string::in,
+ io::di, io::uo) is det.
+
+output_c_file_opts(MLDS, Opts, Suffix, !IO) :-
ModuleName = mlds_get_module_name(MLDS),
module_name_to_file_name(ModuleName, ".c" ++ Suffix, do_create_dirs,
SourceFile, !IO),
Indent = 0,
- output_to_file(SourceFile, mlds_output_src_file(Indent, MLDS), !IO).
+ output_to_file(SourceFile, mlds_output_src_file(Opts, Indent, MLDS), !IO).
- % Generate the header file.
- %
-output_header_file(MLDS, Suffix, !IO) :-
+output_c_header_file(MLDS, Globals, Suffix, !IO) :-
+ Opts = init_mlds_to_c_opts(Globals),
+ output_c_header_file_opts(MLDS, Opts, Suffix, !IO).
+
+:- pred output_c_header_file_opts(mlds::in, mlds_to_c_opts::in, string::in,
+ io::di, io::uo) is det.
+
+output_c_header_file_opts(MLDS, Opts, Suffix, !IO) :-
% We write the header file out to <module>.mih.tmp and then call
% `update_interface' to move the <module>.mih.tmp file to <module>.mih;
% this avoids updating the timestamp on the `.mih' file if it hasn't
@@ -153,14 +218,19 @@
module_name_to_file_name(ModuleName, ".mih" ++ Suffix,
do_create_dirs, HeaderFile, !IO),
Indent = 0,
- output_to_file(TmpHeaderFile, mlds_output_hdr_file(Indent, MLDS), !IO),
+ output_to_file(TmpHeaderFile, mlds_output_hdr_file(Opts, Indent, MLDS),
+ !IO),
update_interface(HeaderFile, !IO).
-:- pred mlds_output_hdr_file(indent::in, mlds::in, io::di, io::uo) is det.
+:- pred mlds_output_hdr_file(mlds_to_c_opts::in, indent::in, mlds::in,
+ io::di, io::uo) is det.
+
+mlds_output_hdr_file(Opts, Indent, MLDS, !IO) :-
+ MLDS = mlds(ModuleName, AllForeignCode, Imports, GlobalData, Defns0,
+ InitPreds, FinalPreds, ExportEnums),
+ ml_global_data_get_all_global_defns(GlobalData, GlobalDefns),
+ Defns = GlobalDefns ++ Defns0,
-mlds_output_hdr_file(Indent, MLDS, !IO) :-
- MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns, InitPreds,
- FinalPreds, ExportEnums),
mlds_output_hdr_start(Indent, ModuleName, !IO),
io.nl(!IO),
mlds_output_hdr_imports(Indent, Imports, !IO),
@@ -185,9 +255,9 @@
list.filter(defn_is_type, PublicDefns, PublicTypeDefns,
PublicNonTypeDefns),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- mlds_output_defns(Indent, yes, MLDS_ModuleName, PublicTypeDefns, !IO),
+ mlds_output_defns(Opts, Indent, yes, MLDS_ModuleName, PublicTypeDefns, !IO),
io.nl(!IO),
- mlds_output_decls(Indent, MLDS_ModuleName, PublicNonTypeDefns, !IO),
+ mlds_output_decls(Opts, Indent, MLDS_ModuleName, PublicNonTypeDefns, !IO),
io.nl(!IO),
mlds_output_init_fn_decls(MLDS_ModuleName, InitPreds, FinalPreds, !IO),
io.nl(!IO),
@@ -264,11 +334,14 @@
% it is actually the target file, but there's no obvious alternative term
% to use which also has a clear and concise abbreviation, so never mind...)
%
-:- pred mlds_output_src_file(indent::in, mlds::in, io::di, io::uo) is det.
+:- pred mlds_output_src_file(mlds_to_c_opts::in, indent::in, mlds::in,
+ io::di, io::uo) is det.
-mlds_output_src_file(Indent, MLDS, !IO) :-
- MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns,
+mlds_output_src_file(Opts, Indent, MLDS, !IO) :-
+ MLDS = mlds(ModuleName, AllForeignCode, Imports, GlobalData, Defns0,
InitPreds, FinalPreds, _ExportEnums),
+ ml_global_data_get_all_global_defns(GlobalData, GlobalDefns),
+ Defns = GlobalDefns ++ Defns0,
ForeignCode = mlds_get_c_foreign_code(AllForeignCode),
EnvVarNameSet = mlds_get_env_var_names(Defns),
@@ -301,6 +374,7 @@
% are generated by mlds_output_type_forward_decls. See the comment in
% mlds_output_decl.
+ % ZZZ could do the following better
list.filter(defn_is_public, Defns, _PublicDefns, PrivateDefns),
list.filter(defn_is_type, PrivateDefns, PrivateTypeDefns,
PrivateNonTypeDefns),
@@ -309,17 +383,18 @@
list.filter(defn_is_type_ctor_info, NonTypeDefns, TypeCtorInfoDefns),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
- mlds_output_defns(Indent, yes, MLDS_ModuleName, PrivateTypeDefns, !IO),
+ mlds_output_defns(Opts, Indent, yes, MLDS_ModuleName, PrivateTypeDefns,
+ !IO),
io.nl(!IO),
- mlds_output_decls(Indent, MLDS_ModuleName, PrivateNonTypeDefns, !IO),
+ mlds_output_decls(Opts, Indent, MLDS_ModuleName, PrivateNonTypeDefns, !IO),
io.nl(!IO),
- mlds_output_c_defns(MLDS_ModuleName, Indent, ForeignCode, !IO),
+ mlds_output_c_defns(Opts, MLDS_ModuleName, Indent, ForeignCode, !IO),
io.nl(!IO),
- mlds_output_defns(Indent, yes, MLDS_ModuleName, NonTypeDefns, !IO),
+ mlds_output_defns(Opts, Indent, yes, MLDS_ModuleName, NonTypeDefns, !IO),
io.nl(!IO),
- mlds_output_init_fn_defns(MLDS_ModuleName, FuncDefns, TypeCtorInfoDefns,
- InitPreds, FinalPreds, !IO),
+ mlds_output_init_fn_defns(Opts, MLDS_ModuleName, FuncDefns,
+ TypeCtorInfoDefns, InitPreds, FinalPreds, !IO),
io.nl(!IO),
mlds_output_grade_var(!IO),
io.nl(!IO),
@@ -595,17 +670,17 @@
io.write_string(";\n", !IO)
).
-:- pred mlds_output_init_fn_defns(mlds_module_name::in,
+:- pred mlds_output_init_fn_defns(mlds_to_c_opts::in, mlds_module_name::in,
list(mlds_defn)::in, list(mlds_defn)::in,
list(string)::in, list(string)::in, io::di, io::uo) is det.
-mlds_output_init_fn_defns(ModuleName, FuncDefns, TypeCtorInfoDefns, InitPreds,
- FinalPreds, !IO) :-
+mlds_output_init_fn_defns(Opts, ModuleName, FuncDefns, TypeCtorInfoDefns,
+ InitPreds, FinalPreds, !IO) :-
output_init_fn_name(ModuleName, "", !IO),
io.write_string("\n{\n", !IO),
- globals.io_get_globals(Globals, !IO),
+ NeedToInit = Opts ^ m2co_need_to_init,
(
- need_to_init_entries(Globals),
+ NeedToInit = yes,
FuncDefns = [_ | _]
->
io.write_strings(["\tstatic MR_bool initialised = MR_FALSE;\n",
@@ -709,19 +784,6 @@
io.write_string(Suffix, !IO),
io.write_string("(void)", !IO).
-:- pred need_to_init_entries(globals::in) is semidet.
-
-need_to_init_entries(Globals) :-
- % We only need to output calls to MR_init_entry() if profiling is enabled.
- % (It would be OK to output the calls regardless, since they will
- % macro-expand to nothing if profiling is not enabled, but for readability
- % of the generated code we prefer not to.)
- ( Option = profile_calls
- ; Option = profile_time
- ; Option = profile_memory
- ),
- globals.lookup_bool_option(Globals, Option, yes).
-
% Generate calls to MR_init_entry() for the specified functions.
%
:- pred mlds_output_calls_to_init_entry(mlds_module_name::in,
@@ -828,10 +890,10 @@
io.write_list(HeaderCode, "\n",
mlds_output_c_hdr_decl(Indent, yes(foreign_decl_is_local)), !IO).
-:- pred mlds_output_c_defns(mlds_module_name::in, indent::in,
- mlds_foreign_code::in, io::di, io::uo) is det.
+:- pred mlds_output_c_defns(mlds_to_c_opts::in, mlds_module_name::in,
+ indent::in, mlds_foreign_code::in, io::di, io::uo) is det.
-mlds_output_c_defns(ModuleName, Indent, ForeignCode, !IO) :-
+mlds_output_c_defns(Opts, ModuleName, Indent, ForeignCode, !IO) :-
ForeignCode = mlds_foreign_code(_RevHeaderCode, RevImports,
RevBodyCode, ExportDefns),
Imports = list.reverse(RevImports),
@@ -840,7 +902,7 @@
io.write_list(BodyCode, "\n", mlds_output_c_defn(Indent), !IO),
io.write_string("\n", !IO),
io.write_list(ExportDefns, "\n",
- mlds_output_pragma_export_defn(ModuleName, Indent), !IO).
+ mlds_output_pragma_export_defn(Opts, ModuleName, Indent), !IO).
:- pred mlds_output_c_foreign_import_module(int::in,
foreign_import_module_info::in, io::di, io::uo) is det.
@@ -876,27 +938,30 @@
mlds_output_c_defn(_Indent, user_foreign_code(lang_erlang, _, _), !IO) :-
sorry(this_file, "foreign code other than C").
-:- pred mlds_output_pragma_export_defn(mlds_module_name::in, indent::in,
- mlds_pragma_export::in, io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_defn(mlds_to_c_opts::in,
+ mlds_module_name::in, indent::in, mlds_pragma_export::in, io::di, io::uo)
+ is det.
-mlds_output_pragma_export_defn(ModuleName, Indent, PragmaExport, !IO) :-
+mlds_output_pragma_export_defn(Opts, ModuleName, Indent, PragmaExport, !IO) :-
PragmaExport = ml_pragma_export(Lang, _ExportName, MLDS_Name,
MLDS_Signature, Context),
expect(unify(Lang, lang_c), this_file,
"foreign_export to language other than C."),
- mlds_output_pragma_export_func_name(ModuleName, Indent, PragmaExport, !IO),
+ mlds_output_pragma_export_func_name(Opts, ModuleName, Indent,
+ PragmaExport, !IO),
io.write_string("\n", !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("{\n", !IO),
mlds_indent(Context, Indent, !IO),
- mlds_output_pragma_export_defn_body(ModuleName, MLDS_Name, MLDS_Signature,
- !IO),
+ mlds_output_pragma_export_defn_body(Opts, ModuleName,
+ MLDS_Name, MLDS_Signature, !IO),
io.write_string("}\n", !IO).
-:- pred mlds_output_pragma_export_func_name(mlds_module_name::in, indent::in,
- mlds_pragma_export::in, io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_func_name(mlds_to_c_opts::in,
+ mlds_module_name::in, indent::in, mlds_pragma_export::in,
+ io::di, io::uo) is det.
-mlds_output_pragma_export_func_name(ModuleName, Indent, Export, !IO) :-
+mlds_output_pragma_export_func_name(Opts, ModuleName, Indent, Export, !IO) :-
Export = ml_pragma_export(Lang, ExportName, _MLDSName, Signature, Context),
expect(unify(Lang, lang_c), this_file, "export to language other than C."),
Name = qual(ModuleName, module_qual, entity_export(ExportName)),
@@ -904,14 +969,15 @@
% For functions exported using `pragma foreign_export',
% we use the default C calling convention.
CallingConvention = "",
- mlds_output_func_decl_ho(Indent, Name, Context,
+ mlds_output_func_decl_ho(Opts, Indent, Name, Context,
CallingConvention, Signature,
- mlds_output_pragma_export_type(prefix),
- mlds_output_pragma_export_type(suffix), !IO).
+ mlds_output_pragma_export_type_ignore_opts(prefix),
+ mlds_output_pragma_export_type_ignore_opts(suffix), !IO).
-:- pred mlds_output_pragma_export_type(mlds_type::in, io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_type_prefix_suffix(mlds_type::in,
+ io::di, io::uo) is det.
-mlds_output_pragma_export_type(Type, !IO) :-
+mlds_output_pragma_export_type_prefix_suffix(Type, !IO) :-
mlds_output_pragma_export_type(prefix, Type, !IO),
mlds_output_pragma_export_type(suffix, Type, !IO).
@@ -919,75 +985,95 @@
---> prefix
; suffix.
-:- pred mlds_output_pragma_export_type(locn::in, mlds_type::in,
- io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_type_ignore_opts(locn::in,
+ mlds_to_c_opts::in, mlds_type::in, io::di, io::uo) is det.
-mlds_output_pragma_export_type(suffix, _Type, !IO).
-mlds_output_pragma_export_type(prefix, mlds_mercury_array_type(_ElemType),
- !IO) :-
- io.write_string("MR_ArrayPtr", !IO).
-mlds_output_pragma_export_type(prefix, mercury_type(_, _, ExportedType),
+mlds_output_pragma_export_type_ignore_opts(PrefixSuffix, _Opts, MLDS_Type,
!IO) :-
- io.write_string(exported_type_to_string(lang_c, ExportedType), !IO).
-mlds_output_pragma_export_type(prefix, mlds_cont_type(_), !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_commit_type, !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_native_bool_type, !IO) :-
- io.write_string("MR_bool", !IO).
-mlds_output_pragma_export_type(prefix, mlds_native_int_type, !IO) :-
- io.write_string("MR_Integer", !IO).
-mlds_output_pragma_export_type(prefix, mlds_native_float_type, !IO) :-
- io.write_string("MR_Float", !IO).
-mlds_output_pragma_export_type(prefix, mlds_native_char_type, !IO) :-
- io.write_string("MR_Char", !IO).
-mlds_output_pragma_export_type(prefix, mlds_foreign_type(ForeignType), !IO) :-
+ mlds_output_pragma_export_type(PrefixSuffix, MLDS_Type, !IO).
+
+:- pred mlds_output_pragma_export_type(locn::in,
+ mlds_type::in, io::di, io::uo) is det.
+
+mlds_output_pragma_export_type(PrefixSuffix, MLDS_Type, !IO) :-
+ (
+ PrefixSuffix = suffix
+ ;
+ PrefixSuffix = prefix,
+ (
+ MLDS_Type = mlds_mercury_array_type(_ElemType),
+ io.write_string("MR_ArrayPtr", !IO)
+ ;
+ MLDS_Type = mercury_type(_, _, ExportedType),
+ io.write_string(exported_type_to_string(lang_c, ExportedType), !IO)
+ ;
+ ( MLDS_Type = mlds_cont_type(_)
+ ; MLDS_Type = mlds_commit_type
+ ; MLDS_Type = mlds_class_type(_, _, _)
+ ; MLDS_Type = mlds_array_type(_)
+ ; MLDS_Type = mlds_func_type(_)
+ ; MLDS_Type = mlds_generic_type
+ ; MLDS_Type = mlds_generic_env_ptr_type
+ ; MLDS_Type = mlds_type_info_type
+ ; MLDS_Type = mlds_pseudo_type_info_type
+ ; MLDS_Type = mlds_rtti_type(_)
+ ),
+ io.write_string("MR_Word", !IO)
+ ;
+ MLDS_Type = mlds_native_bool_type,
+ io.write_string("MR_bool", !IO)
+ ;
+ MLDS_Type = mlds_native_int_type,
+ io.write_string("MR_Integer", !IO)
+ ;
+ MLDS_Type = mlds_native_float_type,
+ io.write_string("MR_Float", !IO)
+ ;
+ MLDS_Type = mlds_native_char_type,
+ io.write_string("MR_Char", !IO)
+ ;
+ MLDS_Type = mlds_foreign_type(ForeignType),
(
ForeignType = c(c_type(Name)),
io.write_string(Name, !IO)
;
ForeignType = il(_),
- unexpected(this_file, "mlds_output_type_prefix: il foreign_type")
+ unexpected(this_file,
+ "mlds_output_type_prefix: il foreign_type")
;
ForeignType = java(_),
- unexpected(this_file, "mlds_output_type_prefix: java foreign_type")
+ unexpected(this_file,
+ "mlds_output_type_prefix: java foreign_type")
;
ForeignType = erlang(_),
- unexpected(this_file, "mlds_output_type_prefix: erlang foreign_type")
- ).
-mlds_output_pragma_export_type(prefix, mlds_class_type(_, _, _), !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_array_type(_), !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_ptr_type(Type), !IO) :-
+ unexpected(this_file,
+ "mlds_output_type_prefix: erlang foreign_type")
+ )
+ ;
+ MLDS_Type = mlds_ptr_type(Type),
mlds_output_pragma_export_type(prefix, Type, !IO),
- io.write_string(" *", !IO).
-mlds_output_pragma_export_type(prefix, mlds_func_type(_), !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_generic_type, !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_generic_env_ptr_type, !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_type_info_type, !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_pseudo_type_info_type, !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_rtti_type(_), !IO) :-
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_tabling_type(_), !IO) :-
- % These types should never occur in procedures exported to C, so the fact
- % that we could generate a more accurate type shouldn't matter.
- io.write_string("MR_Word", !IO).
-mlds_output_pragma_export_type(prefix, mlds_unknown_type, !IO) :-
- unexpected(this_file, "mlds_output_pragma_export_type: unknown_type").
+ io.write_string(" *", !IO)
+ ;
+ MLDS_Type = mlds_tabling_type(_),
+ % These types should never occur in procedures exported to C,
+ % so the fact that we could generate a more accurate type
+ % shouldn't matter.
+ io.write_string("MR_Word", !IO)
+ ;
+ MLDS_Type = mlds_unknown_type,
+ unexpected(this_file,
+ "mlds_output_pragma_export_type: unknown_type")
+ )
+ ).
% Output the definition body for a pragma foreign_export.
%
-:- pred mlds_output_pragma_export_defn_body(mlds_module_name::in,
- mlds_qualified_entity_name::in, mlds_func_params::in, io::di, io::uo)
- is det.
+:- pred mlds_output_pragma_export_defn_body(mlds_to_c_opts::in,
+ mlds_module_name::in, mlds_qualified_entity_name::in, mlds_func_params::in,
+ io::di, io::uo) is det.
-mlds_output_pragma_export_defn_body(ModuleName, FuncName, Signature, !IO) :-
+mlds_output_pragma_export_defn_body(Opts, ModuleName, FuncName, Signature,
+ !IO) :-
Signature = mlds_func_params(Parameters, RetTypes),
% Declare local variables corresponding to any foreign_type parameters.
@@ -1002,23 +1088,23 @@
CForeignTypeInputs = list.filter(IsCForeignType, Parameters),
CForeignTypeOutputs = list.filter(IsCForeignTypePtr, Parameters),
io.write_list(CForeignTypeInputs, "",
- mlds_output_pragma_export_input_defns(ModuleName), !IO),
+ mlds_output_pragma_export_input_defns(Opts, ModuleName), !IO),
io.write_list(CForeignTypeOutputs, "",
- mlds_output_pragma_export_output_defns(ModuleName), !IO),
+ mlds_output_pragma_export_output_defns(Opts, ModuleName), !IO),
% Declare a local variable or two for the return value, if needed.
(
RetTypes = [RetType1],
( RetType1 = mlds_foreign_type(c(_)) ->
io.write_string("\t", !IO),
- mlds_output_pragma_export_type(RetType1, !IO),
+ mlds_output_pragma_export_type_prefix_suffix(RetType1, !IO),
io.write_string(" ret_value;\n", !IO),
io.write_string("\t", !IO),
- mlds_output_type(RetType1, !IO),
+ mlds_output_type(Opts, RetType1, !IO),
io.write_string(" boxed_ret_value;\n", !IO)
;
io.write_string("\t", !IO),
- mlds_output_pragma_export_type(RetType1, !IO),
+ mlds_output_pragma_export_type_prefix_suffix(RetType1, !IO),
io.write_string(" ret_value;\n", !IO)
)
;
@@ -1038,23 +1124,26 @@
(
RetTypes = [],
io.write_string("\t", !IO),
- mlds_output_pragma_export_call(ModuleName, FuncName, Parameters, !IO)
+ mlds_output_pragma_export_call(Opts, ModuleName, FuncName, Parameters,
+ !IO)
;
RetTypes = [RetType2],
( RetType2 = mlds_foreign_type(c(_)) ->
io.write_string("\tboxed_ret_value = ", !IO)
;
io.write_string("\tret_value = (", !IO),
- mlds_output_pragma_export_type(RetType2, !IO),
+ mlds_output_pragma_export_type_prefix_suffix(RetType2, !IO),
io.write_string(")", !IO)
),
- mlds_output_pragma_export_call(ModuleName, FuncName, Parameters, !IO)
+ mlds_output_pragma_export_call(Opts, ModuleName, FuncName, Parameters,
+ !IO)
;
RetTypes = [_, _ | _],
% This is just for MLDS dumps when compiling to non-C targets.
% So we don't need to worry about boxing/unboxing foreign types here.
io.write_string("\treturn (", !IO),
- mlds_output_return_list(RetTypes, mlds_output_pragma_export_type, !IO),
+ mlds_output_return_list(RetTypes,
+ mlds_output_pragma_export_type_prefix_suffix, !IO),
io.write_string(") ", !IO)
),
@@ -1069,7 +1158,7 @@
RetTypes = [RetType3],
( RetType3 = mlds_foreign_type(c(_)) ->
io.write_string("\tMR_MAYBE_UNBOX_FOREIGN_TYPE(", !IO),
- mlds_output_pragma_export_type(RetType3, !IO),
+ mlds_output_pragma_export_type_prefix_suffix(RetType3, !IO),
io.write_string(", boxed_ret_value, ret_value);\n", !IO)
;
true
@@ -1089,7 +1178,7 @@
QualName = qual(ModuleName, module_qual, Name),
BoxedQualName = qual(ModuleName, module_qual, boxed_name(Name)),
io.write_string("\tMR_MAYBE_BOX_FOREIGN_TYPE(", !IO),
- mlds_output_pragma_export_type(Type, !IO),
+ mlds_output_pragma_export_type_prefix_suffix(Type, !IO),
io.write_string(", ", !IO),
mlds_output_fully_qualified_name(QualName, !IO),
io.write_string(", ", !IO),
@@ -1104,30 +1193,32 @@
QualName = qual(ModuleName, module_qual, Name),
BoxedQualName = qual(ModuleName, module_qual, boxed_name(Name)),
io.write_string("\tMR_MAYBE_UNBOX_FOREIGN_TYPE(", !IO),
- mlds_output_pragma_export_type(pointed_to_type(Type), !IO),
+ mlds_output_pragma_export_type_prefix_suffix(pointed_to_type(Type), !IO),
io.write_string(", ", !IO),
mlds_output_fully_qualified_name(BoxedQualName, !IO),
io.write_string(", *", !IO),
mlds_output_fully_qualified_name(QualName, !IO),
io.write_string(");\n", !IO).
-:- pred mlds_output_pragma_export_input_defns(mlds_module_name::in,
- mlds_argument::in, io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_input_defns(mlds_to_c_opts::in,
+ mlds_module_name::in, mlds_argument::in, io::di, io::uo) is det.
-mlds_output_pragma_export_input_defns(ModuleName, Arg, !IO) :-
+mlds_output_pragma_export_input_defns(Opts, ModuleName, Arg, !IO) :-
Arg = mlds_argument(Name, Type, _GCStatement),
io.write_string("\t", !IO),
- mlds_output_data_decl_ho(mlds_output_type_prefix, mlds_output_type_suffix,
+ mlds_output_data_decl_ho(Opts,
+ mlds_output_type_prefix, mlds_output_type_suffix,
qual(ModuleName, module_qual, boxed_name(Name)), Type, !IO),
io.write_string(";\n", !IO).
-:- pred mlds_output_pragma_export_output_defns(mlds_module_name::in,
- mlds_argument::in, io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_output_defns(mlds_to_c_opts::in,
+ mlds_module_name::in, mlds_argument::in, io::di, io::uo) is det.
-mlds_output_pragma_export_output_defns(ModuleName, Arg, !IO) :-
+mlds_output_pragma_export_output_defns(Opts, ModuleName, Arg, !IO) :-
Arg = mlds_argument(Name, Type, _GCStatement),
io.write_string("\t", !IO),
- mlds_output_data_decl_ho(mlds_output_type_prefix, mlds_output_type_suffix,
+ mlds_output_data_decl_ho(Opts,
+ mlds_output_type_prefix, mlds_output_type_suffix,
qual(ModuleName, module_qual, boxed_name(Name)), pointed_to_type(Type),
!IO),
io.write_string(";\n", !IO).
@@ -1151,22 +1242,23 @@
unexpected(this_file, "boxed_name called for non-var argument")
).
-:- pred mlds_output_pragma_export_call(mlds_module_name::in,
- mlds_qualified_entity_name::in, mlds_arguments::in, io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_call(mlds_to_c_opts::in,
+ mlds_module_name::in, mlds_qualified_entity_name::in, mlds_arguments::in,
+ io::di, io::uo) is det.
-mlds_output_pragma_export_call(ModuleName, FuncName, Parameters, !IO) :-
+mlds_output_pragma_export_call(Opts, ModuleName, FuncName, Parameters, !IO) :-
mlds_output_fully_qualified_name(FuncName, !IO),
io.write_string("(", !IO),
- io.write_list(Parameters, ", ", mlds_output_pragma_export_arg(ModuleName),
- !IO),
+ io.write_list(Parameters, ", ",
+ mlds_output_pragma_export_arg(Opts, ModuleName), !IO),
io.write_string(");\n", !IO).
% Output a fully qualified name preceded by a cast.
%
-:- pred mlds_output_pragma_export_arg(mlds_module_name::in, mlds_argument::in,
- io::di, io::uo) is det.
+:- pred mlds_output_pragma_export_arg(mlds_to_c_opts::in, mlds_module_name::in,
+ mlds_argument::in, io::di, io::uo) is det.
-mlds_output_pragma_export_arg(ModuleName, Arg, !IO) :-
+mlds_output_pragma_export_arg(Opts, ModuleName, Arg, !IO) :-
Arg = mlds_argument(Name, Type, _GCStatement),
( Type = mlds_foreign_type(c(_)) ->
% This is a foreign_type input. Pass in the already-boxed value.
@@ -1183,7 +1275,7 @@
;
% Otherwise, no boxing or unboxing is needed.
% Just cast the argument to the right type.
- mlds_output_cast(Type, !IO),
+ mlds_output_cast(Opts, Type, !IO),
mlds_output_fully_qualified_name(qual(ModuleName, module_qual, Name),
!IO)
).
@@ -1268,42 +1360,55 @@
% Code to output declarations and definitions
%
-:- pred mlds_output_decls(indent::in, mlds_module_name::in,
- list(mlds_defn)::in, io::di, io::uo) is det.
-
-mlds_output_decls(Indent, ModuleName, Defns, !IO) :-
- list.foldl(mlds_output_decl_blank_line(Indent, ModuleName), Defns, !IO).
+:- pred mlds_output_defns(mlds_to_c_opts::in, indent::in, bool::in,
+ mlds_module_name::in, list(mlds_defn)::in, io::di, io::uo) is det.
-:- pred mlds_output_defns(indent::in, bool::in, mlds_module_name::in,
- list(mlds_defn)::in, io::di, io::uo) is det.
-
-mlds_output_defns(Indent, Separate, ModuleName, Defns, !IO) :-
- OutputDefn = mlds_output_defn(Indent, Separate, ModuleName),
- globals.io_lookup_bool_option(gcc_local_labels, GCC_LocalLabels, !IO),
+mlds_output_defns(Opts, Indent, Separate, ModuleName, Defns, !IO) :-
+ GCC_LocalLabels = Opts ^ m2co_gcc_local_labels,
(
GCC_LocalLabels = yes,
% GNU C __label__ declarations must precede ordinary variable
% declarations.
list.filter(defn_is_commit_type_var, Defns, LabelDecls, OtherDefns),
- list.foldl(OutputDefn, LabelDecls, !IO),
- list.foldl(OutputDefn, OtherDefns, !IO)
+ mlds_output_defn_list(Opts, Indent, Separate, ModuleName,
+ LabelDecls, !IO),
+ mlds_output_defn_list(Opts, Indent, Separate, ModuleName,
+ OtherDefns, !IO)
;
GCC_LocalLabels = no,
- list.foldl(OutputDefn, Defns, !IO)
+ mlds_output_defn_list(Opts, Indent, Separate, ModuleName,
+ Defns, !IO)
).
-:- pred mlds_output_decl_blank_line(indent::in, mlds_module_name::in,
- mlds_defn::in, io::di, io::uo) is det.
+:- pred mlds_output_defn_list(mlds_to_c_opts::in, indent::in, bool::in,
+ mlds_module_name::in, list(mlds_defn)::in, io::di, io::uo) is det.
+
+mlds_output_defn_list(_Opts, _Indent, _Separate, _ModuleName, [], !IO).
+mlds_output_defn_list(Opts, Indent, Separate, ModuleName,
+ [Defn | Defns], !IO) :-
+ mlds_output_defn(Opts, Indent, Separate, ModuleName, Defn, !IO),
+ mlds_output_defn_list(Opts, Indent, Separate, ModuleName, Defns, !IO).
+
+:- pred mlds_output_decls(mlds_to_c_opts::in, indent::in, mlds_module_name::in,
+ list(mlds_defn)::in, io::di, io::uo) is det.
+
+mlds_output_decls(_Opts, _Indent, _ModuleName, [], !IO).
+mlds_output_decls(Opts, Indent, ModuleName, [Defn | Defns], !IO) :-
+ mlds_output_decl_blank_line(Opts, Indent, ModuleName, Defn, !IO),
+ mlds_output_decls(Opts, Indent, ModuleName, Defns, !IO).
+
+:- pred mlds_output_decl_blank_line(mlds_to_c_opts::in, indent::in,
+ mlds_module_name::in, mlds_defn::in, io::di, io::uo) is det.
-mlds_output_decl_blank_line(Indent, ModuleName, Defn, !IO) :-
+mlds_output_decl_blank_line(Opts, Indent, ModuleName, Defn, !IO) :-
io.nl(!IO),
- mlds_output_decl(Indent, ModuleName, Defn, !IO).
+ mlds_output_decl(Opts, Indent, ModuleName, Defn, !IO).
-:- pred mlds_output_decl(indent::in, mlds_module_name::in, mlds_defn::in,
- io::di, io::uo) is det.
+:- pred mlds_output_decl(mlds_to_c_opts::in, indent::in,
+ mlds_module_name::in, mlds_defn::in, io::di, io::uo) is det.
-mlds_output_decl(Indent, ModuleName, Defn, !IO) :-
+mlds_output_decl(Opts, Indent, ModuleName, Defn, !IO) :-
Defn = mlds_defn(Name, Context, Flags, DefnBody),
(
% ANSI C does not permit forward declarations of enumeration types.
@@ -1329,34 +1434,34 @@
% the type declarations in a different header file than the function
% declarations).
- globals.io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
+ HighLevelData = Opts ^ m2co_highlevel_data,
(
HighLevelData = yes,
DefnBody = mlds_function(_, Params, _, _, _)
->
Params = mlds_func_params(Arguments, _RetTypes),
ParamTypes = mlds_get_arg_types(Arguments),
- mlds_output_type_forward_decls(Indent, ParamTypes, !IO)
+ mlds_output_type_forward_decls(Opts, Indent, ParamTypes, !IO)
;
true
),
% Now output the declaration for this mlds_defn.
mlds_indent(Context, Indent, !IO),
- mlds_output_decl_flags(Flags, forward_decl, Name, DefnBody, !IO),
- mlds_output_decl_body(Indent, qual(ModuleName, module_qual, Name),
- Context, DefnBody, !IO)
+ mlds_output_decl_flags(Opts, Flags, forward_decl, Name, DefnBody, !IO),
+ mlds_output_decl_body(Opts, Indent,
+ qual(ModuleName, module_qual, Name), Context, DefnBody, !IO)
).
-:- pred mlds_output_type_forward_decls(indent::in, list(mlds_type)::in,
- io::di, io::uo) is det.
+:- pred mlds_output_type_forward_decls(mlds_to_c_opts::in, indent::in,
+ list(mlds_type)::in, io::di, io::uo) is det.
-mlds_output_type_forward_decls(Indent, ParamTypes, !IO) :-
+mlds_output_type_forward_decls(Opts, Indent, ParamTypes, !IO) :-
% Output forward declarations for all struct types
% that are contained in the parameter types.
solutions.aggregate(mlds_type_list_contains_type(ParamTypes),
- mlds_output_type_forward_decl(Indent), !IO).
+ mlds_output_type_forward_decl(Opts, Indent), !IO).
% mlds_type_list_contains_type(Types, SubType):
%
@@ -1386,10 +1491,10 @@
; list.member(Type, RetTypes)
).
-:- pred mlds_output_type_forward_decl(indent::in, mlds_type::in,
- io::di, io::uo) is det.
+:- pred mlds_output_type_forward_decl(mlds_to_c_opts::in, indent::in,
+ mlds_type::in, io::di, io::uo) is det.
-mlds_output_type_forward_decl(Indent, Type, !IO) :-
+mlds_output_type_forward_decl(Opts, Indent, Type, !IO) :-
(
(
Type = mlds_class_type(_Name, _Arity, Kind),
@@ -1403,16 +1508,16 @@
)
->
mlds_indent(Indent, !IO),
- mlds_output_type(ClassType, !IO),
+ mlds_output_type(Opts, ClassType, !IO),
io.write_string(";\n", !IO)
;
true
).
-:- pred mlds_output_defn(indent::in, bool::in, mlds_module_name::in,
- mlds_defn::in, io::di, io::uo) is det.
+:- pred mlds_output_defn(mlds_to_c_opts::in, indent::in, bool::in,
+ mlds_module_name::in, mlds_defn::in, io::di, io::uo) is det.
-mlds_output_defn(Indent, Separate, ModuleName, Defn, !IO) :-
+mlds_output_defn(Opts, Indent, Separate, ModuleName, Defn, !IO) :-
Defn = mlds_defn(Name, Context, Flags, DefnBody),
(
( DefnBody = mlds_function(_, _, _, _, _)
@@ -1429,54 +1534,56 @@
)
),
mlds_indent(Context, Indent, !IO),
- mlds_output_decl_flags(Flags, definition, Name, DefnBody, !IO),
- mlds_output_defn_body(Indent, qual(ModuleName, module_qual, Name),
+ mlds_output_decl_flags(Opts, Flags, definition, Name, DefnBody, !IO),
+ mlds_output_defn_body(Opts, Indent, qual(ModuleName, module_qual, Name),
Context, DefnBody, !IO).
-:- pred mlds_output_decl_body(indent::in, mlds_qualified_entity_name::in,
- mlds_context::in, mlds_entity_defn::in, io::di, io::uo) is det.
+:- pred mlds_output_decl_body(mlds_to_c_opts::in, indent::in,
+ mlds_qualified_entity_name::in, mlds_context::in, mlds_entity_defn::in,
+ io::di, io::uo) is det.
-mlds_output_decl_body(Indent, Name, Context, DefnBody, !IO) :-
+mlds_output_decl_body(Opts, Indent, Name, Context, DefnBody, !IO) :-
(
DefnBody = mlds_data(Type, Initializer, _GCStatement),
- mlds_output_data_decl(Name, Type, initializer_array_size(Initializer),
- !IO)
+ mlds_output_data_decl(Opts, Name, Type,
+ initializer_array_size(Initializer), !IO)
;
DefnBody = mlds_function(MaybePredProcId, Signature,
_MaybeBody, _Attrs, _EnvVarNames),
- mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id, !IO),
- mlds_output_func_decl(Indent, Name, Context, Signature, !IO)
+ mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id(Opts),
+ !IO),
+ mlds_output_func_decl(Opts, Indent, Name, Context, Signature, !IO)
;
DefnBody = mlds_class(ClassDefn),
mlds_output_class_decl(Indent, Name, ClassDefn, !IO)
),
io.write_string(";\n", !IO).
-:- pred mlds_output_defn_body(indent::in, mlds_qualified_entity_name::in,
- mlds_context::in, mlds_entity_defn::in, io::di, io::uo) is det.
+:- pred mlds_output_defn_body(mlds_to_c_opts::in, indent::in,
+ mlds_qualified_entity_name::in, mlds_context::in, mlds_entity_defn::in,
+ io::di, io::uo) is det.
-mlds_output_defn_body(Indent, Name, Context, DefnBody, !IO) :-
+mlds_output_defn_body(Opts, Indent, Name, Context, DefnBody, !IO) :-
(
DefnBody = mlds_data(Type, Initializer, GCStatement),
- mlds_output_data_defn(Name, Type, Initializer, !IO),
- mlds_output_gc_statement(Indent, Name, GCStatement, "",
- !IO)
+ mlds_output_data_defn(Opts, Name, Type, Initializer, !IO),
+ mlds_output_gc_statement(Opts, Indent, Name, GCStatement, "", !IO)
;
DefnBody = mlds_function(MaybePredProcId, Signature,
MaybeBody, _Attributes, _EnvVarNames),
- mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id, !IO),
- mlds_output_func(Indent, Name, Context, Signature, MaybeBody, !IO)
+ mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id(Opts),
+ !IO),
+ mlds_output_func(Opts, Indent, Name, Context, Signature, MaybeBody, !IO)
;
DefnBody = mlds_class(ClassDefn),
- mlds_output_class(Indent, Name, Context, ClassDefn, !IO)
+ mlds_output_class(Opts, Indent, Name, Context, ClassDefn, !IO)
).
-:- pred mlds_output_gc_statement(indent::in,
+:- pred mlds_output_gc_statement(mlds_to_c_opts::in, indent::in,
mlds_qualified_entity_name::in, mlds_gc_statement::in,
string::in, io::di, io::uo) is det.
-mlds_output_gc_statement(Indent, Name, GCStatement, MaybeNewLine,
- !IO) :-
+mlds_output_gc_statement(Opts, Indent, Name, GCStatement, MaybeNewLine, !IO) :-
(
GCStatement = gc_no_stmt
;
@@ -1492,7 +1599,7 @@
% XXX This value for FuncInfo is bogus. However, this output is only
% for debugging anyway, so it doesn't really matter.
FuncInfo = func_info(Name, mlds_func_signature([], [])),
- mlds_output_statement(Indent, FuncInfo, Statement, !IO),
+ mlds_output_statement(Opts, Indent, FuncInfo, Statement, !IO),
io.write_string("#endif\n", !IO)
).
@@ -1522,10 +1629,11 @@
io.write_string("_s", !IO)
).
-:- pred mlds_output_class(indent::in, mlds_qualified_entity_name::in,
- mlds_context::in, mlds_class_defn::in, io::di, io::uo) is det.
+:- pred mlds_output_class(mlds_to_c_opts::in, indent::in,
+ mlds_qualified_entity_name::in, mlds_context::in, mlds_class_defn::in,
+ io::di, io::uo) is det.
-mlds_output_class(Indent, Name, Context, ClassDefn, !IO) :-
+mlds_output_class(Opts, Indent, Name, Context, ClassDefn, !IO) :-
% To avoid name clashes, we need to qualify the names of the member
% constants with the class name. (In particular, this is needed for
% enumeration constants and for the nested classes that we generate for
@@ -1534,9 +1642,9 @@
Name = qual(ModuleName, QualKind, UnqualName),
(
UnqualName = entity_type(ClassName, ClassArity),
- globals.io_get_globals(Globals, !IO),
- ClassModuleName = mlds_append_class_qualifier(ModuleName,
- QualKind, Globals, ClassName, ClassArity)
+ Target = Opts ^ m2co_target,
+ ClassModuleName = mlds_append_class_qualifier(Target, ModuleName,
+ QualKind, ClassName, ClassArity)
;
( UnqualName = entity_data(_)
; UnqualName = entity_function(_, _, _, _)
@@ -1597,7 +1705,7 @@
io.write_string(" {\n", !IO),
(
Kind = mlds_enum,
- mlds_output_enum_constants(Indent + 1, ClassModuleName,
+ mlds_output_enum_constants(Opts, Indent + 1, ClassModuleName,
BasesAndMembers, !IO)
;
( Kind = mlds_class
@@ -1605,12 +1713,12 @@
; Kind = mlds_interface
; Kind = mlds_struct
),
- mlds_output_defns(Indent + 1, no, ClassModuleName,
+ mlds_output_defns(Opts, Indent + 1, no, ClassModuleName,
BasesAndMembers, !IO)
),
mlds_indent(Context, Indent, !IO),
io.write_string("};\n", !IO),
- mlds_output_defns(Indent, yes, ClassModuleName, StaticMembers, !IO).
+ mlds_output_defns(Opts, Indent, yes, ClassModuleName, StaticMembers, !IO).
:- pred is_static_member(mlds_defn::in) is semidet.
@@ -1627,12 +1735,13 @@
mlds_defn::out, int::in, int::out) is det.
mlds_make_base_class(Context, ClassId, MLDS_Defn, BaseNum0, BaseNum) :-
- BaseName = mlds_var_name(string.format("base_%d", [i(BaseNum0)]), no),
+ BaseName = "base_" ++ string.int_to_string(BaseNum0),
+ BaseVarName = mlds_var_name(BaseName, no),
Type = ClassId,
% We only need GC tracing code for top-level variables,
% not for base classes.
GCStatement = gc_no_stmt,
- MLDS_Defn = mlds_defn(entity_data(mlds_data_var(BaseName)), Context,
+ MLDS_Defn = mlds_defn(entity_data(mlds_data_var(BaseVarName)), Context,
ml_gen_public_field_decl_flags,
mlds_data(Type, no_initializer, GCStatement)),
BaseNum = BaseNum0 + 1.
@@ -1640,15 +1749,15 @@
% Output the definitions of the enumeration constants
% for an enumeration type.
%
-:- pred mlds_output_enum_constants(indent::in, mlds_module_name::in,
- list(mlds_defn)::in, io::di, io::uo) is det.
+:- pred mlds_output_enum_constants(mlds_to_c_opts::in, indent::in,
+ mlds_module_name::in, list(mlds_defn)::in, io::di, io::uo) is det.
-mlds_output_enum_constants(Indent, EnumModuleName, Members, !IO) :-
+mlds_output_enum_constants(Opts, Indent, EnumModuleName, Members, !IO) :-
% Select the enumeration constants from the list of members
% for this enumeration type, and output them.
EnumConsts = list.filter(is_enum_const, Members),
io.write_list(EnumConsts, ",\n",
- mlds_output_enum_constant(Indent, EnumModuleName), !IO),
+ mlds_output_enum_constant(Opts, Indent, EnumModuleName), !IO),
io.nl(!IO).
% Test whether one of the members of an mlds_enum class
@@ -1662,17 +1771,17 @@
% Output the definition of a single enumeration constant.
%
-:- pred mlds_output_enum_constant(indent::in, mlds_module_name::in,
- mlds_defn::in, io::di, io::uo) is det.
+:- pred mlds_output_enum_constant(mlds_to_c_opts::in, indent::in,
+ mlds_module_name::in, mlds_defn::in, io::di, io::uo) is det.
-mlds_output_enum_constant(Indent, EnumModuleName, Defn, !IO) :-
+mlds_output_enum_constant(Opts, Indent, EnumModuleName, Defn, !IO) :-
Defn = mlds_defn(Name, Context, _Flags, DefnBody),
(
DefnBody = mlds_data(Type, Initializer, _GCStatement),
mlds_indent(Context, Indent, !IO),
mlds_output_fully_qualified_name(
qual(EnumModuleName, type_qual, Name), !IO),
- mlds_output_initializer(Type, Initializer, !IO)
+ mlds_output_initializer(Opts, Type, Initializer, !IO)
;
( DefnBody = mlds_function(_, _, _, _, _)
; DefnBody = mlds_class(_)
@@ -1683,39 +1792,41 @@
%-----------------------------------------------------------------------------%
%
-% Code to output data declarations/definitions
+% Code to output data declarations/definitions.
%
-:- pred mlds_output_data_decl(mlds_qualified_entity_name::in, mlds_type::in,
- initializer_array_size::in, io::di, io::uo) is det.
+:- pred mlds_output_data_decl(mlds_to_c_opts::in,
+ mlds_qualified_entity_name::in, mlds_type::in, initializer_array_size::in,
+ io::di, io::uo) is det.
-mlds_output_data_decl(Name, Type, InitializerSize, !IO) :-
- mlds_output_data_decl_ho(mlds_output_type_prefix,
+mlds_output_data_decl(Opts, Name, Type, InitializerSize, !IO) :-
+ mlds_output_data_decl_ho(Opts, mlds_output_type_prefix,
mlds_output_data_decl_2(InitializerSize), Name, Type, !IO).
-:- pred mlds_output_data_decl_2(initializer_array_size::in, mlds_type::in,
- io::di, io::uo) is det.
+:- pred mlds_output_data_decl_2(initializer_array_size::in, mlds_to_c_opts::in,
+ mlds_type::in, io::di, io::uo) is det.
-mlds_output_data_decl_2(InitializerSize, Type, !IO) :-
- mlds_output_type_suffix(Type, InitializerSize, !IO).
+mlds_output_data_decl_2(InitializerSize, Opts, Type, !IO) :-
+ mlds_output_type_suffix(Opts, Type, InitializerSize, !IO).
-:- pred mlds_output_data_decl_ho(output_type::in(output_type),
- output_type::in(output_type), mlds_qualified_entity_name::in,
- mlds_type::in, io::di, io::uo) is det.
+:- pred mlds_output_data_decl_ho(mlds_to_c_opts::in,
+ output_type::in(output_type), output_type::in(output_type),
+ mlds_qualified_entity_name::in, mlds_type::in, io::di, io::uo) is det.
-mlds_output_data_decl_ho(OutputPrefix, OutputSuffix, Name, Type, !IO) :-
- OutputPrefix(Type, !IO),
+mlds_output_data_decl_ho(Opts, OutputPrefix, OutputSuffix, Name, Type, !IO) :-
+ OutputPrefix(Opts, Type, !IO),
io.write_char(' ', !IO),
mlds_output_fully_qualified_name(Name, !IO),
- OutputSuffix(Type, !IO).
+ OutputSuffix(Opts, Type, !IO).
-:- pred mlds_output_data_defn(mlds_qualified_entity_name::in, mlds_type::in,
- mlds_initializer::in, io::di, io::uo) is det.
+:- pred mlds_output_data_defn(mlds_to_c_opts::in,
+ mlds_qualified_entity_name::in, mlds_type::in, mlds_initializer::in,
+ io::di, io::uo) is det.
-mlds_output_data_defn(Name, Type, Initializer, !IO) :-
- mlds_output_data_decl(Name, Type, initializer_array_size(Initializer),
- !IO),
- mlds_output_initializer(Type, Initializer, !IO),
+mlds_output_data_defn(Opts, Name, Type, Initializer, !IO) :-
+ mlds_output_data_decl(Opts, Name, Type,
+ initializer_array_size(Initializer), !IO),
+ mlds_output_initializer(Opts, Type, Initializer, !IO),
io.write_string(";\n", !IO).
:- pred mlds_output_maybe(maybe(T)::in,
@@ -1729,15 +1840,17 @@
MaybeValue = no
).
-:- pred mlds_output_initializer(mlds_type::in, mlds_initializer::in,
- io::di, io::uo) is det.
+:- pred mlds_output_initializer(mlds_to_c_opts::in, mlds_type::in,
+ mlds_initializer::in, io::di, io::uo) is det.
-mlds_output_initializer(_Type, Initializer, !IO) :-
- ( mlds_needs_initialization(Initializer) = yes ->
+mlds_output_initializer(Opts, _Type, Initializer, !IO) :-
+ NeedsInit = mlds_needs_initialization(Initializer),
+ (
+ NeedsInit = yes,
io.write_string(" = ", !IO),
- mlds_output_initializer_body(0, Initializer, !IO)
+ mlds_output_initializer_body(Opts, 0, Initializer, !IO)
;
- true
+ NeedsInit = no
).
:- func mlds_needs_initialization(mlds_initializer) = bool.
@@ -1748,57 +1861,65 @@
mlds_needs_initialization(init_struct(_Type, [_|_])) = yes.
mlds_needs_initialization(init_array(_)) = yes.
-:- pred mlds_output_initializer_body(int::in, mlds_initializer::in,
- io::di, io::uo) is det.
+:- pred mlds_output_initializer_body(mlds_to_c_opts::in, int::in,
+ mlds_initializer::in, io::di, io::uo) is det.
-mlds_output_initializer_body(_, no_initializer, !IO).
-mlds_output_initializer_body(Indent, init_obj(Rval), !IO) :-
+mlds_output_initializer_body(Opts, Indent, Init, !IO) :-
+ (
+ Init = no_initializer
+ ;
+ Init = init_obj(Rval),
mlds_indent(Indent, !IO),
- mlds_output_rval(Rval, !IO).
-mlds_output_initializer_body(Indent, init_struct(_Type, FieldInits), !IO) :-
+ mlds_output_rval(Opts, Rval, !IO)
+ ;
+ Init = init_struct(_Type, FieldInits),
% Note that standard ANSI/ISO C does not allow empty structs. But it is
% the responsibility of the MLDS code generator to not generate any.
% So we don't need to handle empty initializers specially here.
mlds_indent(Indent, !IO),
io.write_string("{\n", !IO),
- io.write_list(FieldInits, ",\n", mlds_output_initializer_body(Indent + 1),
- !IO),
+ io.write_list(FieldInits, ",\n",
+ mlds_output_initializer_body(Opts, Indent + 1), !IO),
io.write_string("\n", !IO),
mlds_indent(Indent, !IO),
- io.write_string("}", !IO).
-mlds_output_initializer_body(Indent, init_array(ElementInits), !IO) :-
+ io.write_string("}", !IO)
+ ;
+ Init = init_array(ElementInits),
% Standard ANSI/ISO C does not allow empty arrays. But the MLDS does.
% To keep the C compiler happy, we therefore convert zero-element MLDS
% arrays into one-element C arrays. (The extra element is a minor waste
- % of space, but it will otherwise be ignored.) So if the initializer list
- % here is empty, we need to output a single initializer. We can initialize
- % the extra element with any value; we use "0", since that is a valid
- % initializer for any type.
- io.write_string("{\n", !IO),
+ % of space, but it will otherwise be ignored.) So if the initializer
+ % list here is empty, we need to output a single initializer.
+ % We can initialize the extra element with any value. We use "0",
+ % since that is a valid initializer for any type.
(
ElementInits = [],
- mlds_indent(Indent + 1, !IO),
- io.write_string("0", !IO)
+ mlds_indent(Indent, !IO),
+ io.write_string("{ 0 }\n", !IO)
;
ElementInits = [_ | _],
+ mlds_indent(Indent, !IO),
+ io.write_string("{\n", !IO),
io.write_list(ElementInits, ",\n",
- mlds_output_initializer_body(Indent + 1), !IO)
- ),
+ mlds_output_initializer_body(Opts, Indent + 1), !IO),
io.write_string("\n", !IO),
mlds_indent(Indent, !IO),
- io.write_string("}", !IO).
+ io.write_string("}", !IO)
+ )
+ ).
%-----------------------------------------------------------------------------%
%
% Code to output function declarations/definitions
%
-:- pred mlds_output_pred_proc_id(pred_proc_id::in, io::di, io::uo) is det.
+:- pred mlds_output_pred_proc_id(mlds_to_c_opts::in, pred_proc_id::in,
+ io::di, io::uo) is det.
-mlds_output_pred_proc_id(proc(PredId, ProcId), !IO) :-
- globals.io_lookup_bool_option(auto_comments, AddComments, !IO),
+mlds_output_pred_proc_id(Opts, proc(PredId, ProcId), !IO) :-
+ Comments = Opts ^ m2co_auto_comments,
(
- AddComments = yes,
+ Comments = yes,
io.write_string("/* pred_id: ", !IO),
pred_id_to_int(PredId, PredIdNum),
io.write_int(PredIdNum, !IO),
@@ -1807,15 +1928,15 @@
io.write_int(ProcIdNum, !IO),
io.write_string(" */\n", !IO)
;
- AddComments = no
+ Comments = no
).
-:- pred mlds_output_func(indent::in, mlds_qualified_entity_name::in,
- mlds_context::in, mlds_func_params::in, mlds_function_body::in,
- io::di, io::uo) is det.
+:- pred mlds_output_func(mlds_to_c_opts::in, indent::in,
+ mlds_qualified_entity_name::in, mlds_context::in,
+ mlds_func_params::in, mlds_function_body::in, io::di, io::uo) is det.
-mlds_output_func(Indent, Name, Context, Params, FunctionBody, !IO) :-
- mlds_output_func_decl(Indent, Name, Context, Params, !IO),
+mlds_output_func(Opts, Indent, Name, Context, Params, FunctionBody, !IO) :-
+ mlds_output_func_decl(Opts, Indent, Name, Context, Params, !IO),
(
FunctionBody = body_external,
io.write_string(";\n", !IO)
@@ -1826,72 +1947,76 @@
mlds_indent(Context, Indent, !IO),
io.write_string("{\n", !IO),
- mlds_maybe_output_time_profile_instr(Context, Indent + 1, Name, !IO),
+ mlds_maybe_output_time_profile_instr(Opts, Context, Indent + 1, Name,
+ !IO),
Signature = mlds_get_func_signature(Params),
FuncInfo = func_info(Name, Signature),
- mlds_output_statement(Indent + 1, FuncInfo, Body, !IO),
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, Body, !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("}\n", !IO) % end the function
).
-:- pred mlds_output_func_decl(indent::in, mlds_qualified_entity_name::in,
- mlds_context::in, mlds_func_params::in, io::di, io::uo) is det.
+:- pred mlds_output_func_decl(mlds_to_c_opts::in, indent::in,
+ mlds_qualified_entity_name::in, mlds_context::in, mlds_func_params::in,
+ io::di, io::uo) is det.
-mlds_output_func_decl(Indent, QualifiedName, Context, Signature, !IO) :-
+mlds_output_func_decl(Opts, Indent, QualifiedName, Context, Signature, !IO) :-
CallingConvention = "MR_CALL ",
- mlds_output_func_decl_ho(Indent, QualifiedName, Context,
+ mlds_output_func_decl_ho(Opts, Indent, QualifiedName, Context,
CallingConvention, Signature,
mlds_output_type_prefix, mlds_output_type_suffix, !IO).
-:- pred mlds_output_func_decl_ho(indent::in, mlds_qualified_entity_name::in,
- mlds_context::in, string::in, mlds_func_params::in,
+:- pred mlds_output_func_decl_ho(mlds_to_c_opts::in, indent::in,
+ mlds_qualified_entity_name::in, mlds_context::in, string::in,
+ mlds_func_params::in,
output_type::in(output_type), output_type::in(output_type),
io::di, io::uo) is det.
-mlds_output_func_decl_ho(Indent, QualifiedName, Context, CallingConvention,
- Signature, OutputPrefix, OutputSuffix, !IO) :-
+mlds_output_func_decl_ho(Opts, Indent, QualifiedName, Context,
+ CallingConvention, Signature, OutputPrefix, OutputSuffix, !IO) :-
Signature = mlds_func_params(Parameters, RetTypes),
(
RetTypes = [],
io.write_string("void", !IO)
;
RetTypes = [RetType],
- OutputPrefix(RetType, !IO)
+ OutputPrefix(Opts, RetType, !IO)
;
RetTypes = [_, _ | _],
mlds_output_return_list(RetTypes,
- mlds_output_prefix_suffix(OutputPrefix, OutputSuffix), !IO)
+ mlds_output_prefix_suffix(Opts, OutputPrefix, OutputSuffix), !IO)
),
io.write_char(' ', !IO),
io.write_string(CallingConvention, !IO),
io.nl(!IO),
mlds_output_fully_qualified_name(QualifiedName, !IO),
QualifiedName = qual(ModuleName, _, _),
- mlds_output_params(OutputPrefix, OutputSuffix,
- Indent, ModuleName, Context, Parameters, !IO),
+ mlds_output_params(Opts, OutputPrefix, OutputSuffix, Indent,
+ ModuleName, Context, Parameters, !IO),
(
RetTypes = [RetType2],
- OutputSuffix(RetType2, !IO)
+ OutputSuffix(Opts, RetType2, !IO)
;
RetTypes = []
;
RetTypes = [_, _ | _]
).
-:- pred mlds_output_prefix_suffix(output_type::in(output_type),
- output_type::in(output_type), mlds_type::in, io::di, io::uo) is det.
+:- pred mlds_output_prefix_suffix(mlds_to_c_opts::in,
+ output_type::in(output_type), output_type::in(output_type), mlds_type::in,
+ io::di, io::uo) is det.
-mlds_output_prefix_suffix(OutputPrefix, OutputSuffix, Value, !IO) :-
- OutputPrefix(Value, !IO),
- OutputSuffix(Value, !IO).
+mlds_output_prefix_suffix(Opts, OutputPrefix, OutputSuffix, Value, !IO) :-
+ OutputPrefix(Opts, Value, !IO),
+ OutputSuffix(Opts, Value, !IO).
-:- pred mlds_output_params(output_type::in(output_type),
+:- pred mlds_output_params(mlds_to_c_opts::in, output_type::in(output_type),
output_type::in(output_type), indent::in, mlds_module_name::in,
mlds_context::in, mlds_arguments::in, io::di, io::uo) is det.
-mlds_output_params(OutputPrefix, OutputSuffix, Indent, ModuleName,
+mlds_output_params(Opts, OutputPrefix, OutputSuffix, Indent, ModuleName,
Context, Parameters, !IO) :-
io.write_char('(', !IO),
(
@@ -1901,73 +2026,77 @@
Parameters = [_ | _],
io.nl(!IO),
io.write_list(Parameters, ",\n",
- mlds_output_param(OutputPrefix, OutputSuffix,
- Indent + 1, ModuleName, Context), !IO)
+ mlds_output_param(Opts, OutputPrefix, OutputSuffix,
+ Indent + 1, ModuleName, Context),
+ !IO)
),
io.write_char(')', !IO).
-:- pred mlds_output_param(output_type::in(output_type),
+:- pred mlds_output_param(mlds_to_c_opts::in, output_type::in(output_type),
output_type::in(output_type), indent::in, mlds_module_name::in,
mlds_context::in, mlds_argument::in, io::di, io::uo) is det.
-mlds_output_param(OutputPrefix, OutputSuffix, Indent, ModuleName, Context,
- Arg, !IO) :-
+mlds_output_param(Opts, OutputPrefix, OutputSuffix, Indent, ModuleName,
+ Context, Arg, !IO) :-
Arg = mlds_argument(Name, Type, GCStatement),
QualName = qual(ModuleName, module_qual, Name),
mlds_indent(Context, Indent, !IO),
- mlds_output_data_decl_ho(OutputPrefix, OutputSuffix, QualName, Type, !IO),
- mlds_output_gc_statement(Indent, QualName, GCStatement,
- "\n", !IO).
+ mlds_output_data_decl_ho(Opts, OutputPrefix, OutputSuffix, QualName, Type,
+ !IO),
+ mlds_output_gc_statement(Opts, Indent, QualName, GCStatement, "\n", !IO).
-:- pred mlds_output_func_type_prefix(mlds_func_params::in, io::di, io::uo)
- is det.
+:- pred mlds_output_func_type_prefix(mlds_to_c_opts::in, mlds_func_params::in,
+ io::di, io::uo) is det.
-mlds_output_func_type_prefix(Params, !IO) :-
+mlds_output_func_type_prefix(Opts, Params, !IO) :-
Params = mlds_func_params(_Parameters, RetTypes),
(
RetTypes = [],
io.write_string("void", !IO)
;
RetTypes = [RetType],
- mlds_output_type(RetType, !IO)
+ mlds_output_type(Opts, RetType, !IO)
;
RetTypes = [_, _ | _],
- mlds_output_return_list(RetTypes, mlds_output_type, !IO)
+ mlds_output_return_list(RetTypes, mlds_output_type(Opts), !IO)
),
% Note that mlds_func_type actually corresponds to a function _pointer_
% type in C. This is necessary because function types in C are not first
% class.
io.write_string(" MR_CALL (*", !IO).
-:- pred mlds_output_func_type_suffix(mlds_func_params::in, io::di, io::uo)
- is det.
+:- pred mlds_output_func_type_suffix(mlds_to_c_opts::in, mlds_func_params::in,
+ io::di, io::uo) is det.
-mlds_output_func_type_suffix(Params, !IO) :-
+mlds_output_func_type_suffix(Opts, Params, !IO) :-
Params = mlds_func_params(Parameters, _RetTypes),
io.write_string(")", !IO),
- mlds_output_param_types(Parameters, !IO).
+ mlds_output_param_types(Opts, Parameters, !IO).
-:- pred mlds_output_param_types(mlds_arguments::in, io::di, io::uo) is det.
+:- pred mlds_output_param_types(mlds_to_c_opts::in, mlds_arguments::in,
+ io::di, io::uo) is det.
-mlds_output_param_types(Parameters, !IO) :-
+mlds_output_param_types(Opts, Parameters, !IO) :-
io.write_char('(', !IO),
(
Parameters = [],
io.write_string("void", !IO)
;
Parameters = [_ | _],
- io.write_list(Parameters, ", ", mlds_output_param_type, !IO)
+ io.write_list(Parameters, ", ", mlds_output_param_type(Opts), !IO)
),
io.write_char(')', !IO).
-:- pred mlds_output_param_type(mlds_argument::in, io::di, io::uo) is det.
+:- pred mlds_output_param_type(mlds_to_c_opts::in, mlds_argument::in,
+ io::di, io::uo) is det.
-mlds_output_param_type(mlds_argument(_Name, Type, _GCStatement), !IO) :-
- mlds_output_type(Type, !IO).
+mlds_output_param_type(Opts, Arg, !IO) :-
+ Arg = mlds_argument(_Name, Type, _GCStatement),
+ mlds_output_type(Opts, Type, !IO).
%-----------------------------------------------------------------------------%
%
-% Code to output names of various entities
+% Code to output names of various entities.
%
:- pred mlds_output_fully_qualified_name(mlds_qualified_entity_name::in,
@@ -2013,8 +2142,8 @@
:- pred mlds_output_fully_qualified(mlds_fully_qualified_name(T)::in,
pred(T, io, io)::in(pred(in, di, uo) is det), io::di, io::uo) is det.
-mlds_output_fully_qualified(qual(ModuleName, _QualKind, Name), OutputFunc,
- !IO) :-
+mlds_output_fully_qualified(QualName, OutputFunc, !IO) :-
+ QualName = qual(ModuleName, _QualKind, Name),
SymName = mlds_module_name_to_sym_name(ModuleName),
MangledModuleName = sym_name_mangle(SymName),
io.write_string(MangledModuleName, !IO),
@@ -2032,32 +2161,43 @@
% XXX We should avoid appending the arity, modenum, and seqnum
% if they are not needed.
-mlds_output_name(entity_type(Name, Arity), !IO) :-
+mlds_output_name(EntityName, !IO) :-
+ (
+ EntityName = entity_type(Name, Arity),
MangledName = name_mangle(Name),
- io.format("%s_%d", [s(MangledName), i(Arity)], !IO).
-mlds_output_name(entity_data(DataName), !IO) :-
- mlds_output_data_name(DataName, !IO).
-mlds_output_name(entity_function(PredLabel, ProcId, MaybeSeqNum, _PredId),
- !IO) :-
+ io.write_string(MangledName, !IO),
+ io.write_char('_', !IO),
+ io.write_int(Arity, !IO)
+ ;
+ EntityName = entity_data(DataName),
+ mlds_output_data_name(DataName, !IO)
+ ;
+ EntityName = entity_function(PredLabel, ProcId, MaybeSeqNum, _PredId),
mlds_output_pred_label(PredLabel, !IO),
proc_id_to_int(ProcId, ModeNum),
- io.format("_%d", [i(ModeNum)], !IO),
+ io.write_char('_', !IO),
+ io.write_int(ModeNum, !IO),
(
MaybeSeqNum = yes(SeqNum),
- io.format("_%d", [i(SeqNum)], !IO)
+ io.write_char('_', !IO),
+ io.write_int(SeqNum, !IO)
;
MaybeSeqNum = no
+ )
+ ;
+ EntityName = entity_export(Name),
+ io.write_string(Name, !IO)
).
-mlds_output_name(entity_export(Name), !IO) :-
- io.write_string(Name, !IO).
% mlds_output_pred_label should be kept in sync with
% mlds_pred_label_to_string.
%
:- pred mlds_output_pred_label(mlds_pred_label::in, io::di, io::uo) is det.
-mlds_output_pred_label(mlds_user_pred_label(PredOrFunc, MaybeDefiningModule,
- Name, PredArity, _CodeModel, _NonOutputFunc), !IO) :-
+mlds_output_pred_label(PredLabel, !IO) :-
+ (
+ PredLabel = mlds_user_pred_label(PredOrFunc, MaybeDefiningModule,
+ Name, PredArity, _CodeModel, _NonOutputFunc),
(
PredOrFunc = pf_predicate,
Suffix = "p",
@@ -2068,16 +2208,21 @@
OrigArity = PredArity - 1
),
MangledName = name_mangle(Name),
- io.format("%s_%d_%s", [s(MangledName), i(OrigArity), s(Suffix)], !IO),
+ io.write_string(MangledName, !IO),
+ io.write_char('_', !IO),
+ io.write_int(OrigArity, !IO),
+ io.write_char('_', !IO),
+ io.write_string(Suffix, !IO),
(
MaybeDefiningModule = yes(DefiningModule),
io.write_string("_in__", !IO),
mlds_output_module_name(DefiningModule, !IO)
;
MaybeDefiningModule = no
- ).
-mlds_output_pred_label(mlds_special_pred_label(PredName, MaybeTypeModule,
- TypeName, TypeArity), !IO) :-
+ )
+ ;
+ PredLabel = mlds_special_pred_label(PredName, MaybeTypeModule,
+ TypeName, TypeArity),
MangledPredName = name_mangle(PredName),
MangledTypeName = name_mangle(TypeName),
io.write_string(MangledPredName, !IO),
@@ -2091,15 +2236,18 @@
),
io.write_string(MangledTypeName, !IO),
io.write_string("_", !IO),
- io.write_int(TypeArity, !IO).
+ io.write_int(TypeArity, !IO)
+ ).
% mlds_pred_label_to_string should be kept in sync with
% mlds_output_pred_label.
%
:- func mlds_pred_label_to_string(mlds_pred_label) = string.
-mlds_pred_label_to_string(mlds_user_pred_label(PredOrFunc, MaybeDefiningModule,
- Name, PredArity, _CodeModel, _NonOutputFunc)) = Str :-
+mlds_pred_label_to_string(PredLabel) = Str :-
+ (
+ PredLabel = mlds_user_pred_label(PredOrFunc, MaybeDefiningModule,
+ Name, PredArity, _CodeModel, _NonOutputFunc),
(
PredOrFunc = pf_predicate,
Suffix = "p",
@@ -2110,17 +2258,18 @@
OrigArity = PredArity - 1
),
MangledName = name_mangle(Name),
- MainStr = string.format("%s_%d_%s",
- [s(MangledName), i(OrigArity), s(Suffix)]),
+ MainStr = MangledName ++ "_" ++ string.int_to_string(OrigArity)
+ ++ "_" ++ Suffix,
(
MaybeDefiningModule = yes(DefiningModule),
Str = MainStr ++ "_in__" ++ sym_name_mangle(DefiningModule)
;
MaybeDefiningModule = no,
Str = MainStr
- ).
-mlds_pred_label_to_string(mlds_special_pred_label(PredName, MaybeTypeModule,
- TypeName, TypeArity)) = Str :-
+ )
+ ;
+ PredLabel = mlds_special_pred_label(PredName, MaybeTypeModule,
+ TypeName, TypeArity),
MangledPredName = name_mangle(PredName),
MangledTypeName = name_mangle(TypeName),
PrefixStr = MangledPredName ++ "__",
@@ -2132,7 +2281,8 @@
MidStr = ""
),
Str = PrefixStr ++ MidStr ++ MangledTypeName ++ "_" ++
- int_to_string(TypeArity).
+ int_to_string(TypeArity)
+ ).
:- pred mlds_output_data_name(mlds_data_name::in, io::di, io::uo) is det.
@@ -2159,96 +2309,122 @@
%-----------------------------------------------------------------------------%
%
-% Code to output types
+% Code to output types.
%
-:- pred mlds_output_type(mlds_type::in, io::di, io::uo) is det.
+:- pred mlds_output_type(mlds_to_c_opts::in, mlds_type::in, io::di, io::uo)
+ is det.
-mlds_output_type(Type, !IO) :-
+mlds_output_type(Opts, Type, !IO) :-
% Because of the joys of C syntax, the code for outputting types
% needs to be split into two parts; first the prefix, i.e. the part
% of the type name that goes before the variable name in a variable
% declaration, and then the suffix, i.e. the part which goes after
% the variable name, e.g. the "[]" for array types.
+ %
+ % In the declaration of a type, as opposed to the declaration of a
+ % variable, the variable name is not there, so we have just the prefix and
+ % the suffix.
- mlds_output_type_prefix(Type, !IO),
- mlds_output_type_suffix(Type, !IO).
+ mlds_output_type_prefix(Opts, Type, !IO),
+ mlds_output_type_suffix(Opts, Type, !IO).
-:- pred mlds_output_type_prefix(mlds_type::in, io::di, io::uo) is det.
+:- pred mlds_output_type_prefix(mlds_to_c_opts::in, mlds_type::in,
+ io::di, io::uo) is det.
-mlds_output_type_prefix(mercury_type(Type, TypeCategory, _), !IO) :-
- mlds_output_mercury_type_prefix(Type, TypeCategory, !IO).
-mlds_output_type_prefix(mlds_mercury_array_type(_ElemType), !IO) :-
- globals.io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
+mlds_output_type_prefix(Opts, MLDS_Type, !IO) :-
+ (
+ MLDS_Type = mercury_type(Type, TypeCategory, _),
+ mlds_output_mercury_type_prefix(Opts, Type, TypeCategory, !IO)
+ ;
+ MLDS_Type = mlds_mercury_array_type(_ElemType),
+ HighLevelData = Opts ^ m2co_highlevel_data,
(
HighLevelData = yes,
- mlds_output_mercury_user_type_name(
+ mlds_output_mercury_user_type_name(Opts,
type_ctor(qualified(unqualified("array"), "array"), 1),
ctor_cat_user(cat_user_general), !IO)
;
HighLevelData = no,
io.write_string("MR_ArrayPtr", !IO)
- ).
-mlds_output_type_prefix(mlds_native_int_type, !IO) :-
- io.write_string("MR_Integer", !IO).
-mlds_output_type_prefix(mlds_native_float_type, !IO) :-
- io.write_string("MR_Float", !IO).
-mlds_output_type_prefix(mlds_native_bool_type, !IO) :-
- io.write_string("MR_bool", !IO).
-mlds_output_type_prefix(mlds_native_char_type, !IO) :-
- io.write_string("MR_Char", !IO).
-mlds_output_type_prefix(mlds_foreign_type(_ForeignType), !IO) :-
+ )
+ ;
+ MLDS_Type = mlds_native_int_type,
+ io.write_string("MR_Integer", !IO)
+ ;
+ MLDS_Type = mlds_native_float_type,
+ io.write_string("MR_Float", !IO)
+ ;
+ MLDS_Type = mlds_native_bool_type,
+ io.write_string("MR_bool", !IO)
+ ;
+ MLDS_Type = mlds_native_char_type,
+ io.write_string("MR_Char", !IO)
+ ;
+ MLDS_Type = mlds_foreign_type(_ForeignType),
% For binary compatibility with the --target asm back-end,
% we need to output these as a generic type, rather than making
% use of the C type name
- io.write_string("MR_Box", !IO).
-mlds_output_type_prefix(mlds_class_type(Name, Arity, ClassKind), !IO) :-
+ io.write_string("MR_Box", !IO)
+ ;
+ MLDS_Type = mlds_class_type(Name, Arity, ClassKind),
(
ClassKind = mlds_enum,
- % We can't just use the enumeration type, since the enumeration type's
- % definition is not guaranteed to be in scope at this point. (Fixing
- % that would be somewhat complicated; it would require writing enum
- % definitions to a separate header file.) Also the enumeration might
- % not be word-sized, which would cause problems for e.g.
- % `std_util.arg/2'. So we just use `MR_Integer', and output the
- % actual enumeration type as a comment.
+ % We can't just use the enumeration type, since the enumeration
+ % type's definition is not guaranteed to be in scope at this point.
+ % (Fixing that would be somewhat complicated; it would require
+ % writing enum definitions to a separate header file.) Also
+ % the enumeration might not be word-sized, which would cause
+ % problems for e.g. `std_util.arg/2'. So we just use `MR_Integer',
+ % and output the actual enumeration type as a comment.
io.write_string("MR_Integer /* actually `enum ", !IO),
mlds_output_fully_qualified(Name, mlds_output_mangled_name, !IO),
- io.format("_%d_e", [i(Arity)], !IO),
- io.write_string("' */", !IO)
+ io.write_char('_', !IO),
+ io.write_int(Arity, !IO),
+ io.write_string("_e' */", !IO)
;
( ClassKind = mlds_class
; ClassKind = mlds_package
; ClassKind = mlds_interface
; ClassKind = mlds_struct
),
- % For struct types it's OK to output an incomplete type,
- % since don't use these types directly, we only use pointers to them.
+ % For struct types it's OK to output an incomplete type, since
+ % don't use these types directly, we only use pointers to them.
io.write_string("struct ", !IO),
mlds_output_fully_qualified(Name, mlds_output_mangled_name, !IO),
- io.format("_%d_s", [i(Arity)], !IO)
- ).
-mlds_output_type_prefix(mlds_ptr_type(Type), !IO) :-
- mlds_output_type(Type, !IO),
- io.write_string(" *", !IO).
-mlds_output_type_prefix(mlds_array_type(Type), !IO) :-
- % Here we just output the element type. The "[]" goes in the type suffix.
- mlds_output_type(Type, !IO).
-mlds_output_type_prefix(mlds_func_type(FuncParams), !IO) :-
- mlds_output_func_type_prefix(FuncParams, !IO).
-mlds_output_type_prefix(mlds_generic_type, !IO) :-
- io.write_string("MR_Box", !IO).
-mlds_output_type_prefix(mlds_generic_env_ptr_type, !IO) :-
- io.write_string("void *", !IO).
-mlds_output_type_prefix(mlds_type_info_type, !IO) :-
- io.write_string("MR_TypeInfo", !IO).
-mlds_output_type_prefix(mlds_pseudo_type_info_type, !IO) :-
- io.write_string("MR_PseudoTypeInfo", !IO).
-mlds_output_type_prefix(mlds_cont_type(ArgTypes), !IO) :-
+ io.write_char('_', !IO),
+ io.write_int(Arity, !IO),
+ io.write_string("_s", !IO)
+ )
+ ;
+ MLDS_Type = mlds_ptr_type(Type),
+ mlds_output_type(Opts, Type, !IO),
+ io.write_string(" *", !IO)
+ ;
+ MLDS_Type = mlds_array_type(Type),
+ % Here we just output the element type. The "[]" goes in the type
+ % suffix.
+ mlds_output_type(Opts, Type, !IO)
+ ;
+ MLDS_Type = mlds_func_type(FuncParams),
+ mlds_output_func_type_prefix(Opts, FuncParams, !IO)
+ ;
+ MLDS_Type = mlds_generic_type,
+ io.write_string("MR_Box", !IO)
+ ;
+ MLDS_Type = mlds_generic_env_ptr_type,
+ io.write_string("void *", !IO)
+ ;
+ MLDS_Type = mlds_type_info_type,
+ io.write_string("MR_TypeInfo", !IO)
+ ;
+ MLDS_Type = mlds_pseudo_type_info_type,
+ io.write_string("MR_PseudoTypeInfo", !IO)
+ ;
+ MLDS_Type = mlds_cont_type(ArgTypes),
(
ArgTypes = [],
- globals.io_lookup_bool_option(gcc_nested_functions, GCC_NestedFuncs,
- !IO),
+ GCC_NestedFuncs = Opts ^ m2co_gcc_nested_functions,
(
GCC_NestedFuncs = yes,
io.write_string("MR_NestedCont", !IO)
@@ -2260,29 +2436,34 @@
ArgTypes = [_ | _],
% This case only happens for --nondet-copy-out
io.write_string("void MR_CALL (*", !IO)
- ).
-mlds_output_type_prefix(mlds_commit_type, !IO) :-
- globals.io_lookup_bool_option(gcc_local_labels, GCC_LocalLabels, !IO),
+ )
+ ;
+ MLDS_Type = mlds_commit_type,
+ GCC_LocalLabels = Opts ^ m2co_gcc_local_labels,
(
GCC_LocalLabels = yes,
io.write_string("__label__", !IO)
;
GCC_LocalLabels = no,
io.write_string("jmp_buf", !IO)
- ).
-mlds_output_type_prefix(mlds_rtti_type(RttiIdMaybeElement), !IO) :-
+ )
+ ;
+ MLDS_Type = mlds_rtti_type(RttiIdMaybeElement),
rtti_id_maybe_element_c_type(RttiIdMaybeElement, CType, _IsArray),
- io.write_string(CType, !IO).
-mlds_output_type_prefix(mlds_tabling_type(TablingId), !IO) :-
+ io.write_string(CType, !IO)
+ ;
+ MLDS_Type = mlds_tabling_type(TablingId),
tabling_id_c_type(TablingId, CType, _IsArray),
- io.write_string(CType, !IO).
-mlds_output_type_prefix(mlds_unknown_type, !IO) :-
- unexpected(this_file, "prefix has unknown type").
+ io.write_string(CType, !IO)
+ ;
+ MLDS_Type = mlds_unknown_type,
+ unexpected(this_file, "prefix has unknown type")
+ ).
-:- pred mlds_output_mercury_type_prefix(mer_type::in, type_ctor_category::in,
- io::di, io::uo) is det.
+:- pred mlds_output_mercury_type_prefix(mlds_to_c_opts::in, mer_type::in,
+ type_ctor_category::in, io::di, io::uo) is det.
-mlds_output_mercury_type_prefix(Type, CtorCat, !IO) :-
+mlds_output_mercury_type_prefix(Opts, Type, CtorCat, !IO) :-
(
CtorCat = ctor_cat_builtin(cat_builtin_char),
io.write_string("MR_Char", !IO)
@@ -2306,7 +2487,7 @@
io.write_string("MR_Tuple", !IO)
;
CtorCat = ctor_cat_higher_order,
- globals.io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
+ HighLevelData = Opts ^ m2co_highlevel_data,
(
HighLevelData = yes,
io.write_string("MR_ClosurePtr", !IO)
@@ -2322,31 +2503,28 @@
; CtorCat = ctor_cat_user(_)
; CtorCat = ctor_cat_system(_)
),
- mlds_output_mercury_user_type_prefix(Type, CtorCat, !IO)
+ mlds_output_mercury_user_type_prefix(Opts, Type, CtorCat, !IO)
).
-:- pred mlds_output_mercury_user_type_prefix(mer_type::in,
+:- pred mlds_output_mercury_user_type_prefix(mlds_to_c_opts::in, mer_type::in,
type_ctor_category::in, io::di, io::uo) is det.
-mlds_output_mercury_user_type_prefix(Type, CtorCat, !IO) :-
- globals.io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
+mlds_output_mercury_user_type_prefix(Opts, Type, CtorCat, !IO) :-
+ HighLevelData = Opts ^ m2co_highlevel_data,
(
HighLevelData = yes,
- ( type_to_ctor_and_args(Type, TypeCtor, _ArgsTypes) ->
- mlds_output_mercury_user_type_name(TypeCtor, CtorCat, !IO)
- ;
- unexpected(this_file, "mlds_output_mercury_user_type_prefix")
- )
+ type_to_ctor_det(Type, TypeCtor),
+ mlds_output_mercury_user_type_name(Opts, TypeCtor, CtorCat, !IO)
;
HighLevelData = no,
% In this case, we just treat everything as `MR_Word'.
io.write_string("MR_Word", !IO)
).
-:- pred mlds_output_mercury_user_type_name(type_ctor::in,
+:- pred mlds_output_mercury_user_type_name(mlds_to_c_opts::in, type_ctor::in,
type_ctor_category::in, io::di, io::uo) is det.
-mlds_output_mercury_user_type_name(TypeCtor, CtorCat, !IO) :-
+mlds_output_mercury_user_type_name(Opts, TypeCtor, CtorCat, !IO) :-
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
(
CtorCat = ctor_cat_enum(_),
@@ -2361,15 +2539,16 @@
; CtorCat = ctor_cat_system(_)
; CtorCat = ctor_cat_user(_)
),
- MLDS_Type = mlds_ptr_type(
- mlds_class_type(ClassName, ClassArity, mlds_class))
+ ClassType = mlds_class_type(ClassName, ClassArity, mlds_class),
+ MLDS_Type = mlds_ptr_type(ClassType)
),
- mlds_output_type_prefix(MLDS_Type, !IO).
+ mlds_output_type_prefix(Opts, MLDS_Type, !IO).
-:- pred mlds_output_type_suffix(mlds_type::in, io::di, io::uo) is det.
+:- pred mlds_output_type_suffix(mlds_to_c_opts::in, mlds_type::in,
+ io::di, io::uo) is det.
-mlds_output_type_suffix(Type, !IO) :-
- mlds_output_type_suffix(Type, no_size, !IO).
+mlds_output_type_suffix(Opts, Type, !IO) :-
+ mlds_output_type_suffix(Opts, Type, no_size, !IO).
:- type initializer_array_size
---> array_size(int)
@@ -2383,38 +2562,27 @@
initializer_array_size(init_struct(_, _)) = no_size.
initializer_array_size(init_array(Elems)) = array_size(list.length(Elems)).
-:- pred mlds_output_type_suffix(mlds_type::in, initializer_array_size::in,
- io::di, io::uo) is det.
+:- pred mlds_output_type_suffix(mlds_to_c_opts::in, mlds_type::in,
+ initializer_array_size::in, io::di, io::uo) is det.
-mlds_output_type_suffix(mercury_type(_, _, _), _, !IO).
-mlds_output_type_suffix(mlds_mercury_array_type(_), _, !IO).
-mlds_output_type_suffix(mlds_native_int_type, _, !IO).
-mlds_output_type_suffix(mlds_native_float_type, _, !IO).
-mlds_output_type_suffix(mlds_native_bool_type, _, !IO).
-mlds_output_type_suffix(mlds_native_char_type, _, !IO).
- % XXX Currently we can't output a type suffix.
-mlds_output_type_suffix(mlds_foreign_type(_), _, !IO).
-mlds_output_type_suffix(mlds_class_type(_, _, _), _, !IO).
-mlds_output_type_suffix(mlds_ptr_type(_), _, !IO).
-mlds_output_type_suffix(mlds_array_type(_), ArraySize, !IO) :-
- mlds_output_array_type_suffix(ArraySize, !IO).
-mlds_output_type_suffix(mlds_func_type(FuncParams), _, !IO) :-
- mlds_output_func_type_suffix(FuncParams, !IO).
-mlds_output_type_suffix(mlds_generic_type, _, !IO).
-mlds_output_type_suffix(mlds_generic_env_ptr_type, _, !IO).
-mlds_output_type_suffix(mlds_type_info_type, _, !IO).
-mlds_output_type_suffix(mlds_pseudo_type_info_type, _, !IO).
-mlds_output_type_suffix(mlds_cont_type(ArgTypes), _, !IO) :-
+mlds_output_type_suffix(Opts, MLDS_Type, ArraySize, !IO) :-
+ (
+ MLDS_Type = mlds_array_type(_),
+ mlds_output_array_type_suffix(ArraySize, !IO)
+ ;
+ MLDS_Type = mlds_func_type(FuncParams),
+ mlds_output_func_type_suffix(Opts, FuncParams, !IO)
+ ;
+ MLDS_Type = mlds_cont_type(ArgTypes),
(
ArgTypes = []
;
ArgTypes = [_ | _],
% This case only happens for --nondet-copy-out.
io.write_string(")(", !IO),
- io.write_list(ArgTypes, ", ", mlds_output_type, !IO),
+ io.write_list(ArgTypes, ", ", mlds_output_type(Opts), !IO),
% add the type for the environment parameter, if needed
- globals.io_lookup_bool_option(gcc_nested_functions, GCC_NestedFuncs,
- !IO),
+ GCC_NestedFuncs = Opts ^ m2co_gcc_nested_functions,
(
GCC_NestedFuncs = no,
io.write_string(", void *", !IO)
@@ -2422,26 +2590,46 @@
GCC_NestedFuncs = yes
),
io.write_string(")", !IO)
- ).
-mlds_output_type_suffix(mlds_commit_type, _, !IO).
-mlds_output_type_suffix(mlds_rtti_type(RttiIdMaybeElement), ArraySize, !IO) :-
+ )
+ ;
+ MLDS_Type = mlds_rtti_type(RttiIdMaybeElement),
IsArrayType = rtti_id_maybe_element_has_array_type(RttiIdMaybeElement),
(
IsArrayType = is_array,
mlds_output_array_type_suffix(ArraySize, !IO)
;
IsArrayType = not_array
- ).
-mlds_output_type_suffix(mlds_tabling_type(TablingId), ArraySize, !IO) :-
+ )
+ ;
+ MLDS_Type = mlds_tabling_type(TablingId),
IsArrayType = tabling_id_has_array_type(TablingId),
(
IsArrayType = is_array,
mlds_output_array_type_suffix(ArraySize, !IO)
;
IsArrayType = not_array
+ )
+ ;
+ MLDS_Type = mlds_unknown_type,
+ unexpected(this_file, "mlds_output_type_suffix: unknown_type")
+ ;
+ ( MLDS_Type = mercury_type(_, _, _)
+ ; MLDS_Type = mlds_mercury_array_type(_)
+ ; MLDS_Type = mlds_native_int_type
+ ; MLDS_Type = mlds_native_float_type
+ ; MLDS_Type = mlds_native_bool_type
+ ; MLDS_Type = mlds_native_char_type
+ % XXX Currently we can't output a type suffix.
+ ; MLDS_Type = mlds_foreign_type(_)
+ ; MLDS_Type = mlds_class_type(_, _, _)
+ ; MLDS_Type = mlds_ptr_type(_)
+ ; MLDS_Type = mlds_generic_type
+ ; MLDS_Type = mlds_generic_env_ptr_type
+ ; MLDS_Type = mlds_type_info_type
+ ; MLDS_Type = mlds_pseudo_type_info_type
+ ; MLDS_Type = mlds_commit_type
+ )
).
-mlds_output_type_suffix(mlds_unknown_type, _, !IO) :-
- unexpected(this_file, "mlds_output_type_suffix: unknown_type").
:- pred mlds_output_array_type_suffix(initializer_array_size::in,
io::di, io::uo) is det.
@@ -2453,21 +2641,24 @@
% To keep the C compiler happy, we therefore convert zero-element MLDS
% arrays into one-element C arrays.
int.max(Size0, 1, Size),
- io.format("[%d]", [i(Size)], !IO).
+ io.write_char('[', !IO),
+ io.write_int(Size, !IO),
+ io.write_char(']', !IO).
%-----------------------------------------------------------------------------%
%
-% Code to output declaration specifiers
+% Code to output declaration specifiers.
%
:- type decl_or_defn
---> forward_decl
; definition.
-:- pred mlds_output_decl_flags(mlds_decl_flags::in, decl_or_defn::in,
- mlds_entity_name::in, mlds_entity_defn::in, io::di, io::uo) is det.
+:- pred mlds_output_decl_flags(mlds_to_c_opts::in, mlds_decl_flags::in,
+ decl_or_defn::in, mlds_entity_name::in, mlds_entity_defn::in,
+ io::di, io::uo) is det.
-mlds_output_decl_flags(Flags, DeclOrDefn, Name, DefnBody, !IO) :-
+mlds_output_decl_flags(Opts, Flags, DeclOrDefn, Name, DefnBody, !IO) :-
% mlds_output_extern_or_static handles both the `access' and the
% `per_instance' fields of the mlds_decl_flags. We have to handle them
% together because C overloads `static' to mean both `private' and
@@ -2475,9 +2666,15 @@
% clear which MLDS construct each `static' keyword means, we precede the
% `static' without (optionally-enabled) comments saying whether it is
% `private', `one_copy', or both.
- %
+
+ Comments = Opts ^ m2co_auto_comments,
+ (
+ Comments = yes,
mlds_output_access_comment(access(Flags), !IO),
- mlds_output_per_instance_comment(per_instance(Flags), !IO),
+ mlds_output_per_instance_comment(per_instance(Flags), !IO)
+ ;
+ Comments = no
+ ),
mlds_output_extern_or_static(access(Flags), per_instance(Flags),
DeclOrDefn, Name, DefnBody, !IO),
mlds_output_virtuality(virtuality(Flags), !IO),
@@ -2487,45 +2684,22 @@
:- pred mlds_output_access_comment(access::in, io::di, io::uo) is det.
-mlds_output_access_comment(Access, !IO) :-
- globals.io_lookup_bool_option(auto_comments, Comments, !IO),
- (
- Comments = yes,
- mlds_output_access_comment_2(Access, !IO)
- ;
- Comments = no
- ).
-
-:- pred mlds_output_access_comment_2(access::in, io::di, io::uo) is det.
-
-mlds_output_access_comment_2(acc_public, !IO) :-
+mlds_output_access_comment(acc_public, !IO) :-
io.write_string("/* public: */ ", !IO).
-mlds_output_access_comment_2(acc_private, !IO) :-
+mlds_output_access_comment(acc_private, !IO) :-
io.write_string("/* private: */ ", !IO).
-mlds_output_access_comment_2(acc_protected, !IO) :-
+mlds_output_access_comment(acc_protected, !IO) :-
io.write_string("/* protected: */ ", !IO).
-mlds_output_access_comment_2(acc_default, !IO) :-
+mlds_output_access_comment(acc_default, !IO) :-
io.write_string("/* default access */ ", !IO).
-mlds_output_access_comment_2(acc_local, !IO) :-
+mlds_output_access_comment(acc_local, !IO) :-
io.write_string("/* local: */ ", !IO).
:- pred mlds_output_per_instance_comment(per_instance::in, io::di, io::uo)
is det.
-mlds_output_per_instance_comment(PerInstance, !IO) :-
- globals.io_lookup_bool_option(auto_comments, Comments, !IO),
- (
- Comments = yes,
- mlds_output_per_instance_comment_2(PerInstance, !IO)
- ;
- Comments = no
- ).
-
-:- pred mlds_output_per_instance_comment_2(per_instance::in, io::di, io::uo)
- is det.
-
-mlds_output_per_instance_comment_2(per_instance, !IO).
-mlds_output_per_instance_comment_2(one_copy, !IO) :-
+mlds_output_per_instance_comment(per_instance, !IO).
+mlds_output_per_instance_comment(one_copy, !IO) :-
io.write_string("/* one_copy */ ", !IO).
:- pred mlds_output_extern_or_static(access::in, per_instance::in,
@@ -2590,35 +2764,33 @@
%-----------------------------------------------------------------------------%
%
-% Code to output statements
+% Code to output statements.
%
:- type func_info
---> func_info(mlds_qualified_entity_name, mlds_func_signature).
-:- pred mlds_output_statements(indent::in, func_info::in,
+:- pred mlds_output_statements(mlds_to_c_opts::in, indent::in, func_info::in,
list(statement)::in, io::di, io::uo) is det.
-mlds_output_statements(Indent, FuncInfo, Statements, !IO) :-
- list.foldl(mlds_output_statement(Indent, FuncInfo), Statements, !IO).
+mlds_output_statements(_Opts, _Indent, _FuncInfo, [], !IO).
+mlds_output_statements(Opts, Indent, FuncInfo, [Statement | Statements],
+ !IO) :-
+ mlds_output_statement(Opts, Indent, FuncInfo, Statement, !IO),
+ mlds_output_statements(Opts, Indent, FuncInfo, Statements, !IO).
-:- pred mlds_output_statement(indent::in, func_info::in, statement::in,
- io::di, io::uo) is det.
+:- pred mlds_output_statement(mlds_to_c_opts::in, indent::in, func_info::in,
+ statement::in, io::di, io::uo) is det.
-mlds_output_statement(Indent, FuncInfo, statement(Statement, Context), !IO) :-
+mlds_output_statement(Opts, Indent, FuncInfo, Statement, !IO) :-
+ Statement = statement(Stmt, Context),
output_context(Context, !IO),
- mlds_output_stmt(Indent, FuncInfo, Statement, Context, !IO).
-
-:- pred mlds_output_stmt(indent::in, func_info::in, mlds_stmt::in,
- mlds_context::in, io::di, io::uo) is det.
-
-mlds_output_stmt(Indent, FuncInfo, Statement, Context, !IO) :-
(
- Statement = ml_stmt_atomic(AtomicStatement),
- mlds_output_atomic_stmt(Indent, FuncInfo, AtomicStatement, Context,
- !IO)
+ Stmt = ml_stmt_atomic(AtomicStatement),
+ mlds_output_atomic_stmt(Opts, Indent, FuncInfo, AtomicStatement,
+ Context, !IO)
;
- Statement = ml_stmt_block(Defns, Statements),
+ Stmt = ml_stmt_block(Defns, Statements),
mlds_indent(Indent, !IO),
io.write_string("{\n", !IO),
(
@@ -2631,42 +2803,44 @@
list.filter(defn_is_function, Defns, NestedFuncDefns),
(
NestedFuncDefns = [_ | _],
- mlds_output_decls(Indent + 1, ModuleName, NestedFuncDefns,
- !IO),
+ mlds_output_decls(Opts, Indent + 1, ModuleName,
+ NestedFuncDefns, !IO),
io.write_string("\n", !IO)
;
NestedFuncDefns = []
),
- mlds_output_defns(Indent + 1, no, ModuleName, Defns, !IO),
+ mlds_output_defns(Opts, Indent + 1, no, ModuleName, Defns, !IO),
io.write_string("\n", !IO)
;
Defns = []
),
- mlds_output_statements(Indent + 1, FuncInfo, Statements, !IO),
+ mlds_output_statements(Opts, Indent + 1, FuncInfo, Statements, !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("}\n", !IO)
;
- Statement = ml_stmt_while(Cond, LoopStatement, AtLeastOnce),
+ Stmt = ml_stmt_while(Cond, LoopStatement, AtLeastOnce),
(
AtLeastOnce = no,
mlds_indent(Indent, !IO),
io.write_string("while (", !IO),
- mlds_output_rval(Cond, !IO),
+ mlds_output_rval(Opts, Cond, !IO),
io.write_string(")\n", !IO),
- mlds_output_statement(Indent + 1, FuncInfo, LoopStatement, !IO)
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, LoopStatement,
+ !IO)
;
AtLeastOnce = yes,
mlds_indent(Indent, !IO),
io.write_string("do\n", !IO),
- mlds_output_statement(Indent + 1, FuncInfo, LoopStatement, !IO),
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, LoopStatement,
+ !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("while (", !IO),
- mlds_output_rval(Cond, !IO),
+ mlds_output_rval(Opts, Cond, !IO),
io.write_string(");\n", !IO)
)
;
- Statement = ml_stmt_if_then_else(Cond, Then0, MaybeElse),
+ Stmt = ml_stmt_if_then_else(Cond, Then0, MaybeElse),
% We need to take care to avoid problems caused by the dangling else
% ambiguity.
(
@@ -2709,33 +2883,34 @@
mlds_indent(Indent, !IO),
io.write_string("if (", !IO),
- mlds_output_rval(Cond, !IO),
+ mlds_output_rval(Opts, Cond, !IO),
io.write_string(")\n", !IO),
- mlds_output_statement(Indent + 1, FuncInfo, Then, !IO),
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, Then, !IO),
(
MaybeElse = yes(Else),
mlds_indent(Context, Indent, !IO),
io.write_string("else\n", !IO),
- mlds_output_statement(Indent + 1, FuncInfo, Else, !IO)
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, Else, !IO)
;
MaybeElse = no
)
;
- Statement = ml_stmt_switch(_Type, Val, _Range, Cases, Default),
+ Stmt = ml_stmt_switch(_Type, Val, _Range, Cases, Default),
mlds_indent(Context, Indent, !IO),
io.write_string("switch (", !IO),
- mlds_output_rval(Val, !IO),
+ mlds_output_rval(Opts, Val, !IO),
io.write_string(") {\n", !IO),
% We put the default case first, so that if it is unreachable,
% it will get merged in with the first case.
- mlds_output_switch_default(Indent + 1, FuncInfo, Context, Default,
- !IO),
- list.foldl(mlds_output_switch_case(Indent + 1, FuncInfo, Context),
+ mlds_output_switch_default(Opts, Indent + 1, FuncInfo, Context,
+ Default, !IO),
+ list.foldl(
+ mlds_output_switch_case(Opts, Indent + 1, FuncInfo, Context),
Cases, !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("}\n", !IO)
;
- Statement = ml_stmt_label(LabelName),
+ Stmt = ml_stmt_label(LabelName),
% Note: MLDS allows labels at the end of blocks. C doesn't.
% Hence we need to insert a semi-colon after the colon to ensure that
% there is a statement to attach the label to.
@@ -2744,7 +2919,7 @@
mlds_output_label_name(LabelName, !IO),
io.write_string(":;\n", !IO)
;
- Statement = ml_stmt_goto(Target),
+ Stmt = ml_stmt_goto(Target),
(
Target = goto_label(LabelName),
mlds_indent(Indent, !IO),
@@ -2761,13 +2936,13 @@
io.write_string("continue;\n", !IO)
)
;
- Statement = ml_stmt_computed_goto(Expr, Labels),
+ Stmt = ml_stmt_computed_goto(Expr, Labels),
% XXX For GNU C, we could output potentially more efficient code
% by using an array of labels; this would tell the compiler that
% it didn't need to do any range check.
mlds_indent(Indent, !IO),
io.write_string("switch (", !IO),
- mlds_output_rval(Expr, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string(") {\n", !IO),
list.foldl2(mlds_output_computed_goto_label(Context, Indent), Labels,
0, _FinalCount, !IO),
@@ -2776,7 +2951,7 @@
mlds_indent(Context, Indent, !IO),
io.write_string("}\n", !IO)
;
- Statement = ml_stmt_call(Signature, FuncRval, MaybeObject, CallArgs,
+ Stmt = ml_stmt_call(Signature, FuncRval, MaybeObject, CallArgs,
Results, IsTailCall),
FuncInfo = func_info(CallerName, CallerSignature),
@@ -2788,8 +2963,8 @@
mlds_indent(Indent, !IO),
io.write_string("{\n", !IO),
- mlds_maybe_output_call_profile_instr(Context, Indent + 1, FuncRval,
- CallerName, !IO),
+ mlds_maybe_output_call_profile_instr(Opts, Context, Indent + 1,
+ FuncRval, CallerName, !IO),
% Optimize general tail calls. We can't really do much here except to
% insert `return' as an extra hint to the C compiler.
@@ -2822,7 +2997,7 @@
),
(
MaybeObject = yes(Object),
- mlds_output_bracketed_rval(Object, !IO),
+ mlds_output_bracketed_rval(Opts, Object, !IO),
io.write_string(".", !IO) % XXX should this be "->"?
;
MaybeObject = no
@@ -2831,16 +3006,16 @@
Results = []
;
Results = [Lval],
- mlds_output_lval(Lval, !IO),
+ mlds_output_lval(Opts, Lval, !IO),
io.write_string(" = ", !IO)
;
Results = [_, _ | _],
- mlds_output_return_list(Results, mlds_output_lval, !IO),
+ mlds_output_return_list(Results, mlds_output_lval(Opts), !IO),
io.write_string(" = ", !IO)
),
- mlds_output_bracketed_rval(FuncRval, !IO),
+ mlds_output_bracketed_rval(Opts, FuncRval, !IO),
io.write_string("(", !IO),
- io.write_list(CallArgs, ", ", mlds_output_rval, !IO),
+ io.write_list(CallArgs, ", ", mlds_output_rval(Opts), !IO),
io.write_string(");\n", !IO),
(
@@ -2852,13 +3027,13 @@
mlds_indent(Context, Indent + 1, !IO),
io.write_string("return;\n", !IO)
;
- mlds_maybe_output_time_profile_instr(Context, Indent + 1,
+ mlds_maybe_output_time_profile_instr(Opts, Context, Indent + 1,
CallerName, !IO)
),
mlds_indent(Indent, !IO),
io.write_string("}\n", !IO)
;
- Statement = ml_stmt_return(Results),
+ Stmt = ml_stmt_return(Results),
mlds_indent(Indent, !IO),
io.write_string("return", !IO),
(
@@ -2866,21 +3041,21 @@
;
Results = [Rval],
io.write_char(' ', !IO),
- mlds_output_rval(Rval, !IO)
+ mlds_output_rval(Opts, Rval, !IO)
;
Results = [_, _ | _],
- mlds_output_return_list(Results, mlds_output_rval, !IO)
+ mlds_output_return_list(Results, mlds_output_rval(Opts), !IO)
),
io.write_string(";\n", !IO)
;
- Statement = ml_stmt_do_commit(Ref),
+ Stmt = ml_stmt_do_commit(Ref),
mlds_indent(Indent, !IO),
- globals.io_lookup_bool_option(gcc_local_labels, GCC_LocalLabels, !IO),
+ GCC_LocalLabels = Opts ^ m2co_gcc_local_labels,
(
GCC_LocalLabels = yes,
% Output "goto <Ref>".
io.write_string("goto ", !IO),
- mlds_output_rval(Ref, !IO)
+ mlds_output_rval(Opts, Ref, !IO)
;
GCC_LocalLabels = no,
% Output "MR_builtin_longjmp(<Ref>, 1)". This is a macro that
@@ -2888,13 +3063,13 @@
% __builtin_longjmp(). Note that the second argument to GNU
% C's __builtin_longjmp() *must* be `1'.
io.write_string("MR_builtin_longjmp(", !IO),
- mlds_output_rval(Ref, !IO),
+ mlds_output_rval(Opts, Ref, !IO),
io.write_string(", 1)", !IO)
),
io.write_string(";\n", !IO)
;
- Statement = ml_stmt_try_commit(Ref, Stmt0, Handler),
- globals.io_lookup_bool_option(gcc_local_labels, GCC_LocalLabels, !IO),
+ Stmt = ml_stmt_try_commit(Ref, SubStatement0, Handler),
+ GCC_LocalLabels = Opts ^ m2co_gcc_local_labels,
(
GCC_LocalLabels = yes,
@@ -2910,21 +3085,21 @@
% Note that <Ref> should be just variable name, not a complicated
% expression. If not, the C compiler will catch it.
- mlds_output_statement(Indent, FuncInfo, Stmt0, !IO),
+ mlds_output_statement(Opts, Indent, FuncInfo, SubStatement0, !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("goto ", !IO),
- mlds_output_lval(Ref, !IO),
+ mlds_output_lval(Opts, Ref, !IO),
io.write_string("_done;\n", !IO),
mlds_indent(Context, Indent - 1, !IO),
- mlds_output_lval(Ref, !IO),
+ mlds_output_lval(Opts, Ref, !IO),
io.write_string(":\n", !IO),
- mlds_output_statement(Indent, FuncInfo, Handler, !IO),
+ mlds_output_statement(Opts, Indent, FuncInfo, Handler, !IO),
mlds_indent(Context, Indent - 1, !IO),
- mlds_output_lval(Ref, !IO),
+ mlds_output_lval(Opts, Ref, !IO),
io.write_string("_done:\t;\n", !IO)
;
@@ -2954,23 +3129,28 @@
% We need to take care to avoid problems caused by the
% dangling else ambiguity.
- ( Stmt0 = statement(ml_stmt_if_then_else(_, _, no), Context) ->
- Stmt = statement(ml_stmt_block([], [Stmt0]), Context)
+ (
+ SubStatement0 = statement(SubStmt0, Context),
+ SubStmt0 = ml_stmt_if_then_else(_, _, no)
+ ->
+ SubStmt = ml_stmt_block([], [SubStatement0]),
+ SubStatement = statement(SubStmt, Context)
;
- Stmt = Stmt0
+ SubStatement = SubStatement0
),
mlds_indent(Indent, !IO),
io.write_string("if (MR_builtin_setjmp(", !IO),
- mlds_output_lval(Ref, !IO),
+ mlds_output_lval(Opts, Ref, !IO),
io.write_string(") == 0)\n", !IO),
- mlds_output_statement(Indent + 1, FuncInfo, Stmt, !IO),
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, SubStatement,
+ !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("else\n", !IO),
- mlds_output_statement(Indent + 1, FuncInfo, Handler, !IO)
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, Handler, !IO)
)
).
@@ -2987,47 +3167,47 @@
Count = Count0 + 1.
%-----------------------------------------------------------------------------%
-
%
% Extra code for outputting switch statements.
%
-:- pred mlds_output_switch_case(indent::in, func_info::in, mlds_context::in,
- mlds_switch_case::in, io::di, io::uo) is det.
+:- pred mlds_output_switch_case(mlds_to_c_opts::in, indent::in, func_info::in,
+ mlds_context::in, mlds_switch_case::in, io::di, io::uo) is det.
-mlds_output_switch_case(Indent, FuncInfo, Context, Case, !IO) :-
+mlds_output_switch_case(Opts, Indent, FuncInfo, Context, Case, !IO) :-
Case = mlds_switch_case(FirstCond, LaterConds, Statement),
- mlds_output_case_cond(Indent, Context, FirstCond, !IO),
- list.foldl(mlds_output_case_cond(Indent, Context), LaterConds, !IO),
- mlds_output_statement(Indent + 1, FuncInfo, Statement, !IO),
+ mlds_output_case_cond(Opts, Indent, Context, FirstCond, !IO),
+ list.foldl(mlds_output_case_cond(Opts, Indent, Context), LaterConds, !IO),
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, Statement, !IO),
mlds_indent(Context, Indent + 1, !IO),
io.write_string("break;\n", !IO).
-:- pred mlds_output_case_cond(indent::in, mlds_context::in,
+:- pred mlds_output_case_cond(mlds_to_c_opts::in, indent::in, mlds_context::in,
mlds_case_match_cond::in, io::di, io::uo) is det.
-mlds_output_case_cond(Indent, Context, Match, !IO) :-
+mlds_output_case_cond(Opts, Indent, Context, Match, !IO) :-
(
Match = match_value(Val),
mlds_indent(Context, Indent, !IO),
io.write_string("case ", !IO),
- mlds_output_rval(Val, !IO),
+ mlds_output_rval(Opts, Val, !IO),
io.write_string(":\n", !IO)
;
Match = match_range(Low, High),
% This uses the GNU C extension `case <Low> ... <High>:'.
mlds_indent(Context, Indent, !IO),
io.write_string("case ", !IO),
- mlds_output_rval(Low, !IO),
+ mlds_output_rval(Opts, Low, !IO),
io.write_string(" ... ", !IO),
- mlds_output_rval(High, !IO),
+ mlds_output_rval(Opts, High, !IO),
io.write_string(":\n", !IO)
).
-:- pred mlds_output_switch_default(indent::in, func_info::in,
- mlds_context::in, mlds_switch_default::in, io::di, io::uo) is det.
+:- pred mlds_output_switch_default(mlds_to_c_opts::in, indent::in,
+ func_info::in, mlds_context::in, mlds_switch_default::in, io::di, io::uo)
+ is det.
-mlds_output_switch_default(Indent, FuncInfo, Context, Default, !IO) :-
+mlds_output_switch_default(Opts, Indent, FuncInfo, Context, Default, !IO) :-
(
Default = default_is_unreachable,
mlds_indent(Context, Indent, !IO),
@@ -3038,7 +3218,7 @@
Default = default_case(Statement),
mlds_indent(Context, Indent, !IO),
io.write_string("default:\n", !IO),
- mlds_output_statement(Indent + 1, FuncInfo, Statement, !IO),
+ mlds_output_statement(Opts, Indent + 1, FuncInfo, Statement, !IO),
mlds_indent(Context, Indent + 1, !IO),
io.write_string("break;\n", !IO)
).
@@ -3048,15 +3228,16 @@
% If memory profiling is turned on, output an instruction to
% record the heap allocation.
%
-:- pred mlds_maybe_output_heap_profile_instr(mlds_context::in,
- indent::in, list(mlds_rval)::in, mlds_qualified_entity_name::in,
- maybe(ctor_name)::in, io::di, io::uo) is det.
+:- pred mlds_maybe_output_heap_profile_instr(mlds_to_c_opts::in,
+ mlds_context::in, indent::in, list(mlds_rval)::in,
+ mlds_qualified_entity_name::in, maybe(ctor_name)::in, io::di, io::uo)
+ is det.
-mlds_maybe_output_heap_profile_instr(Context, Indent, Args, FuncName,
+mlds_maybe_output_heap_profile_instr(Opts, Context, Indent, Args, FuncName,
MaybeCtorName, !IO) :-
- globals.io_lookup_bool_option(profile_memory, ProfileMem, !IO),
+ ProfileMemory = Opts ^ m2co_profile_calls,
(
- ProfileMem = yes,
+ ProfileMemory = yes,
mlds_indent(Context, Indent, !IO),
io.write_string("MR_record_allocation(", !IO),
io.write_int(list.length(Args), !IO),
@@ -3081,23 +3262,24 @@
),
io.write_string(");\n", !IO)
;
- ProfileMem = no
+ ProfileMemory = no
).
% If call profiling is turned on output an instruction to record
% an arc in the call profile between the callee and caller.
%
-:- pred mlds_maybe_output_call_profile_instr(mlds_context::in, indent::in,
- mlds_rval::in, mlds_qualified_entity_name::in, io::di, io::uo) is det.
+:- pred mlds_maybe_output_call_profile_instr(mlds_to_c_opts::in,
+ mlds_context::in, indent::in, mlds_rval::in,
+ mlds_qualified_entity_name::in, io::di, io::uo) is det.
-mlds_maybe_output_call_profile_instr(Context, Indent,
+mlds_maybe_output_call_profile_instr(Opts, Context, Indent,
CalleeFuncRval, CallerName, !IO) :-
- globals.io_lookup_bool_option(profile_calls, ProfileCalls, !IO),
+ ProfileCalls = Opts ^ m2co_profile_calls,
(
ProfileCalls = yes,
mlds_indent(Context, Indent, !IO),
io.write_string("MR_prof_call_profile(", !IO),
- mlds_output_bracketed_rval(CalleeFuncRval, !IO),
+ mlds_output_bracketed_rval(Opts, CalleeFuncRval, !IO),
io.write_string(", ", !IO),
mlds_output_fully_qualified_name(CallerName, !IO),
io.write_string(");\n", !IO)
@@ -3108,11 +3290,12 @@
% If time profiling is turned on output an instruction which informs
% the runtime which procedure we are currently located in.
%
-:- pred mlds_maybe_output_time_profile_instr(mlds_context::in,
- indent::in, mlds_qualified_entity_name::in, io::di, io::uo) is det.
+:- pred mlds_maybe_output_time_profile_instr(mlds_to_c_opts::in,
+ mlds_context::in, indent::in, mlds_qualified_entity_name::in,
+ io::di, io::uo) is det.
-mlds_maybe_output_time_profile_instr(Context, Indent, Name, !IO) :-
- globals.io_lookup_bool_option(profile_time, ProfileTime, !IO),
+mlds_maybe_output_time_profile_instr(Opts, Context, Indent, Name, !IO) :-
+ ProfileTime = Opts ^ m2co_profile_time,
(
ProfileTime = yes,
mlds_indent(Context, Indent, !IO),
@@ -3130,10 +3313,10 @@
mlds_output_label_name(LabelName, !IO) :-
mlds_output_mangled_name(LabelName, !IO).
-:- pred mlds_output_atomic_stmt(indent::in, func_info::in,
+:- pred mlds_output_atomic_stmt(mlds_to_c_opts::in, indent::in, func_info::in,
mlds_atomic_statement::in, mlds_context::in, io::di, io::uo) is det.
-mlds_output_atomic_stmt(Indent, FuncInfo, Statement, Context, !IO) :-
+mlds_output_atomic_stmt(Opts, Indent, FuncInfo, Statement, Context, !IO) :-
(
Statement = comment(Comment),
% XXX We should escape any "*/"'s in the Comment. We should also split
@@ -3145,23 +3328,23 @@
;
Statement = assign(Lval, Rval),
mlds_indent(Indent, !IO),
- mlds_output_lval(Lval, !IO),
+ mlds_output_lval(Opts, Lval, !IO),
io.write_string(" = ", !IO),
- mlds_output_rval(Rval, !IO),
+ mlds_output_rval(Opts, Rval, !IO),
io.write_string(";\n", !IO)
;
Statement = assign_if_in_heap(Lval, Rval),
mlds_indent(Indent, !IO),
io.write_string("MR_assign_if_in_heap(", !IO),
- mlds_output_lval(Lval, !IO),
+ mlds_output_lval(Opts, Lval, !IO),
io.write_string(", ", !IO),
- mlds_output_rval(Rval, !IO),
+ mlds_output_rval(Opts, Rval, !IO),
io.write_string(");\n", !IO)
;
Statement = delete_object(Rval),
mlds_indent(Indent, !IO),
io.write_string("MR_free_heap(", !IO),
- mlds_output_rval(Rval, !IO),
+ mlds_output_rval(Opts, Rval, !IO),
io.write_string(");\n", !IO)
;
Statement = new_object(Target, MaybeTag, _HasSecTag, Type, MaybeSize,
@@ -3184,10 +3367,10 @@
BaseVarName = "base",
Base = ls_string(BaseVarName),
mlds_indent(Context, Indent + 1, !IO),
- mlds_output_type_prefix(Type, !IO),
+ mlds_output_type_prefix(Opts, Type, !IO),
io.write_string(" ", !IO),
io.write_string(BaseVarName, !IO),
- mlds_output_type_suffix(Type, !IO),
+ mlds_output_type_suffix(Opts, Type, !IO),
io.write_string(";\n", !IO)
),
@@ -3225,16 +3408,16 @@
),
FuncInfo = func_info(FuncName, _FuncSignature),
- mlds_maybe_output_heap_profile_instr(Context, Indent + 1, Args,
+ mlds_maybe_output_heap_profile_instr(Opts, Context, Indent + 1, Args,
FuncName, MaybeCtorName, !IO),
mlds_indent(Context, Indent + 1, !IO),
- write_lval_or_string(Base, !IO),
+ write_lval_or_string(Opts, Base, !IO),
io.write_string(" = ", !IO),
(
MaybeTag = yes(Tag0),
Tag = Tag0,
- mlds_output_cast(Type, !IO),
+ mlds_output_cast(Opts, Type, !IO),
io.write_string("MR_mkword(", !IO),
mlds_output_tag(Tag, !IO),
io.write_string(", ", !IO),
@@ -3245,7 +3428,7 @@
% XXX We shouldn't need the cast here, but currently the type
% that we include in the call to MR_new_object() is not always
% correct.
- mlds_output_cast(Type, !IO),
+ mlds_output_cast(Opts, Type, !IO),
EndMkword = ""
),
(
@@ -3255,12 +3438,12 @@
MayUseAtomic = may_use_atomic_alloc,
io.write_string("MR_new_object_atomic(", !IO)
),
- mlds_output_type(Type, !IO),
+ mlds_output_type(Opts, Type, !IO),
io.write_string(", ", !IO),
(
MaybeSize = yes(Size),
io.write_string("(", !IO),
- mlds_output_rval(Size, !IO),
+ mlds_output_rval(Opts, Size, !IO),
io.write_string(" * sizeof(MR_Word))", !IO)
;
MaybeSize = no,
@@ -3287,13 +3470,13 @@
;
Base = ls_string(BaseVarName1),
mlds_indent(Context, Indent + 1, !IO),
- mlds_output_lval(Target, !IO),
+ mlds_output_lval(Opts, Target, !IO),
io.write_string(" = ", !IO),
io.write_string(BaseVarName1, !IO),
io.write_string(";\n", !IO)
),
mlds_output_init_args(Args, ArgTypes, Context, 0, Base, Tag,
- Indent + 1, !IO),
+ Opts, Indent + 1, !IO),
mlds_indent(Context, Indent, !IO),
io.write_string("}\n", !IO)
;
@@ -3304,13 +3487,13 @@
Statement = mark_hp(Lval),
mlds_indent(Indent, !IO),
io.write_string("MR_mark_hp(", !IO),
- mlds_output_lval(Lval, !IO),
+ mlds_output_lval(Opts, Lval, !IO),
io.write_string(");\n", !IO)
;
Statement = restore_hp(Rval),
mlds_indent(Indent, !IO),
io.write_string("MR_restore_hp(", !IO),
- mlds_output_rval(Rval, !IO),
+ mlds_output_rval(Opts, Rval, !IO),
io.write_string(");\n", !IO)
;
Statement = trail_op(_TrailOp),
@@ -3319,8 +3502,8 @@
Statement = inline_target_code(TargetLang, Components),
(
TargetLang = ml_target_c,
- list.foldl(mlds_output_target_code_component(Context), Components,
- !IO)
+ list.foldl(mlds_output_target_code_component(Opts, Context),
+ Components, !IO)
;
( TargetLang = ml_target_gnu_c
; TargetLang = ml_target_asm
@@ -3334,10 +3517,10 @@
unexpected(this_file, "outline_foreign_proc is not used in C backend")
).
-:- pred mlds_output_target_code_component(mlds_context::in,
+:- pred mlds_output_target_code_component(mlds_to_c_opts::in, mlds_context::in,
target_code_component::in, io::di, io::uo) is det.
-mlds_output_target_code_component(Context, TargetCode, !IO) :-
+mlds_output_target_code_component(Opts, Context, TargetCode, !IO) :-
(
TargetCode = user_target_code(CodeString, MaybeUserContext, _Attrs),
(
@@ -3355,11 +3538,11 @@
io.write_string(CodeString, !IO)
;
TargetCode = target_code_input(Rval),
- mlds_output_rval(Rval, !IO),
+ mlds_output_rval(Opts, Rval, !IO),
io.write_string(" ", !IO)
;
TargetCode = target_code_output(Lval),
- mlds_output_lval(Lval, !IO),
+ mlds_output_lval(Opts, Lval, !IO),
io.write_string(" ", !IO)
;
% Note: `target_code_name(Name)' target_code_components are used to
@@ -3417,16 +3600,16 @@
; ls_string(string).
:- pred mlds_output_init_args(list(mlds_rval)::in, list(mlds_type)::in,
- mlds_context::in, int::in, lval_or_string::in, mlds_tag::in, indent::in,
- io::di, io::uo) is det.
+ mlds_context::in, int::in, lval_or_string::in, mlds_tag::in,
+ mlds_to_c_opts::in, indent::in, io::di, io::uo) is det.
-mlds_output_init_args([_ | _], [], _, _, _, _, _, !IO) :-
+mlds_output_init_args([_ | _], [], _, _, _, _, _, _, !IO) :-
unexpected(this_file, "mlds_output_init_args: length mismatch").
-mlds_output_init_args([], [_ | _], _, _, _, _, _, !IO) :-
+mlds_output_init_args([], [_ | _], _, _, _, _, _, _, !IO) :-
unexpected(this_file, "mlds_output_init_args: length mismatch").
-mlds_output_init_args([], [], _, _, _, _, _, !IO).
+mlds_output_init_args([], [], _, _, _, _, _, _, !IO).
mlds_output_init_args([Arg | Args], [ArgType | ArgTypes], Context,
- ArgNum, Base, Tag, Indent, !IO) :-
+ ArgNum, Base, Tag, Opts, Indent, !IO) :-
% The MR_hl_field() macro expects its argument to have type MR_Box,
% so we need to box the arguments if they aren't already boxed.
% Hence the use of mlds_output_boxed_rval below.
@@ -3439,21 +3622,22 @@
io.write_string("MR_hl_field(", !IO),
mlds_output_tag(Tag, !IO),
io.write_string(", ", !IO),
- write_lval_or_string(Base, !IO),
+ write_lval_or_string(Opts, Base, !IO),
io.write_string(", ", !IO),
io.write_int(ArgNum, !IO),
io.write_string(") = ", !IO),
- mlds_output_boxed_rval(ArgType, Arg, !IO),
+ mlds_output_boxed_rval(Opts, ArgType, Arg, !IO),
io.write_string(";\n", !IO),
mlds_output_init_args(Args, ArgTypes, Context,
- ArgNum + 1, Base, Tag, Indent, !IO).
+ ArgNum + 1, Base, Tag, Opts, Indent, !IO).
-:- pred write_lval_or_string(lval_or_string::in, io::di, io::uo) is det.
+:- pred write_lval_or_string(mlds_to_c_opts::in, lval_or_string::in,
+ io::di, io::uo) is det.
-write_lval_or_string(Base, !IO) :-
+write_lval_or_string(Opts, Base, !IO) :-
(
Base = ls_lval(Target),
- mlds_output_lval(Target, !IO)
+ mlds_output_lval(Opts, Target, !IO)
;
Base = ls_string(BaseVarName),
io.write_string(BaseVarName, !IO)
@@ -3464,9 +3648,10 @@
% Code to output expressions.
%
-:- pred mlds_output_lval(mlds_lval::in, io::di, io::uo) is det.
+:- pred mlds_output_lval(mlds_to_c_opts::in, mlds_lval::in, io::di, io::uo)
+ is det.
-mlds_output_lval(Lval, !IO) :-
+mlds_output_lval(Opts, Lval, !IO) :-
(
Lval = ml_field(MaybeTag, PtrRval, FieldId, FieldType, PtrType),
(
@@ -3487,9 +3672,9 @@
io.write_string("MR_hl_mask_field(", !IO),
io.write_string("(MR_Word) ", !IO)
),
- mlds_output_rval(PtrRval, !IO),
+ mlds_output_rval(Opts, PtrRval, !IO),
io.write_string(", ", !IO),
- mlds_output_rval(OffsetRval, !IO),
+ mlds_output_rval(Opts, OffsetRval, !IO),
io.write_string("))", !IO)
;
% The field type for ml_lval_field(_, _, ml_field_offset(_),
@@ -3501,29 +3686,29 @@
io.write_string("(", !IO),
( MaybeTag = yes(0) ->
( PtrType \= CtorType ->
- mlds_output_cast(CtorType, !IO)
+ mlds_output_cast(Opts, CtorType, !IO)
;
true
),
( PtrRval = ml_mem_addr(Lval) ->
- mlds_output_lval(Lval, !IO),
+ mlds_output_lval(Opts, Lval, !IO),
io.write_string(").", !IO)
;
- mlds_output_bracketed_rval(PtrRval, !IO),
+ mlds_output_bracketed_rval(Opts, PtrRval, !IO),
io.write_string(")->", !IO)
)
;
- mlds_output_cast(CtorType, !IO),
+ mlds_output_cast(Opts, CtorType, !IO),
(
MaybeTag = yes(Tag),
io.write_string("MR_body(", !IO),
- mlds_output_rval(PtrRval, !IO),
+ mlds_output_rval(Opts, PtrRval, !IO),
io.write_string(", ", !IO),
mlds_output_tag(Tag, !IO)
;
MaybeTag = no,
io.write_string("MR_strip_tag(", !IO),
- mlds_output_rval(PtrRval, !IO)
+ mlds_output_rval(Opts, PtrRval, !IO)
),
io.write_string("))->", !IO)
),
@@ -3533,7 +3718,7 @@
;
Lval = ml_mem_ref(Rval, _Type),
io.write_string("*", !IO),
- mlds_output_bracketed_rval(Rval, !IO)
+ mlds_output_bracketed_rval(Opts, Rval, !IO)
;
Lval = ml_global_var_ref(GobalVar),
io.write_string(global_var_name(GobalVar), !IO)
@@ -3565,33 +3750,35 @@
mlds_output_mangled_name(Name, !IO) :-
io.write_string(name_mangle(Name), !IO).
-:- pred mlds_output_bracketed_lval(mlds_lval::in, io::di, io::uo) is det.
+:- pred mlds_output_bracketed_lval(mlds_to_c_opts::in, mlds_lval::in,
+ io::di, io::uo) is det.
-mlds_output_bracketed_lval(Lval, !IO) :-
+mlds_output_bracketed_lval(Opts, Lval, !IO) :-
(
% If it's just a variable name, then we don't need parentheses.
Lval = ml_var(_, _)
->
- mlds_output_lval(Lval, !IO)
+ mlds_output_lval(Opts, Lval, !IO)
;
io.write_char('(', !IO),
- mlds_output_lval(Lval, !IO),
+ mlds_output_lval(Opts, Lval, !IO),
io.write_char(')', !IO)
).
-:- pred mlds_output_bracketed_rval(mlds_rval::in, io::di, io::uo) is det.
+:- pred mlds_output_bracketed_rval(mlds_to_c_opts::in, mlds_rval::in,
+ io::di, io::uo) is det.
-mlds_output_bracketed_rval(Rval, !IO) :-
+mlds_output_bracketed_rval(Opts, Rval, !IO) :-
(
% If it's just a variable name, then we don't need parentheses.
( Rval = ml_lval(ml_var(_,_))
; Rval = ml_const(mlconst_code_addr(_))
)
->
- mlds_output_rval(Rval, !IO)
+ mlds_output_rval(Opts, Rval, !IO)
;
io.write_char('(', !IO),
- mlds_output_rval(Rval, !IO),
+ mlds_output_rval(Opts, Rval, !IO),
io.write_char(')', !IO)
).
@@ -3612,12 +3799,13 @@
io.write_list(List, ", ", OutputPred, !IO),
io.write_string("}", !IO).
-:- pred mlds_output_rval(mlds_rval::in, io::di, io::uo) is det.
+:- pred mlds_output_rval(mlds_to_c_opts::in, mlds_rval::in, io::di, io::uo)
+ is det.
-mlds_output_rval(Rval, !IO) :-
+mlds_output_rval(Opts, Rval, !IO) :-
(
Rval = ml_lval(Lval),
- mlds_output_lval(Lval, !IO)
+ mlds_output_lval(Opts, Lval, !IO)
% XXX Do we need the commented out code below?
% if a field is used as an rval, then we need to use
% the MR_hl_const_field() macro, not the MR_hl_field() macro,
@@ -3645,70 +3833,71 @@
io.write_string("MR_mkword(", !IO),
mlds_output_tag(Tag, !IO),
io.write_string(", ", !IO),
- mlds_output_rval(BaseRval, !IO),
+ mlds_output_rval(Opts, BaseRval, !IO),
io.write_string(")", !IO)
;
Rval = ml_const(Const),
- mlds_output_rval_const(Const, !IO)
+ mlds_output_rval_const(Opts, Const, !IO)
;
Rval = ml_unop(Op, RvalA),
- mlds_output_unop(Op, RvalA, !IO)
+ mlds_output_unop(Opts, Op, RvalA, !IO)
;
Rval = ml_binop(Op, RvalA, RvalB),
- mlds_output_binop(Op, RvalA, RvalB, !IO)
+ mlds_output_binop(Opts, Op, RvalA, RvalB, !IO)
;
Rval = ml_mem_addr(Lval),
% XXX Are parentheses needed?
io.write_string("&", !IO),
- mlds_output_lval(Lval, !IO)
+ mlds_output_lval(Opts, Lval, !IO)
;
Rval = ml_self(_),
io.write_string("this", !IO)
).
-:- pred mlds_output_unop(mlds_unary_op::in, mlds_rval::in, io::di, io::uo)
- is det.
+:- pred mlds_output_unop(mlds_to_c_opts::in, mlds_unary_op::in, mlds_rval::in,
+ io::di, io::uo) is det.
-mlds_output_unop(Unop, Expr, !IO) :-
+mlds_output_unop(Opts, Unop, Expr, !IO) :-
(
Unop = cast(Type),
- mlds_output_cast_rval(Type, Expr, !IO)
+ mlds_output_cast_rval(Opts, Type, Expr, !IO)
;
Unop = box(Type),
- mlds_output_boxed_rval(Type, Expr, !IO)
+ mlds_output_boxed_rval(Opts, Type, Expr, !IO)
;
Unop = unbox(Type),
- mlds_output_unboxed_rval(Type, Expr, !IO)
+ mlds_output_unboxed_rval(Opts, Type, Expr, !IO)
;
Unop = std_unop(StdUnop),
- mlds_output_std_unop(StdUnop, Expr, !IO)
+ mlds_output_std_unop(Opts, StdUnop, Expr, !IO)
).
-:- pred mlds_output_cast_rval(mlds_type::in, mlds_rval::in, io::di, io::uo)
- is det.
+:- pred mlds_output_cast_rval(mlds_to_c_opts::in, mlds_type::in, mlds_rval::in,
+ io::di, io::uo) is det.
-mlds_output_cast_rval(Type, Expr, !IO) :-
- mlds_output_cast(Type, !IO),
- mlds_output_rval(Expr, !IO).
+mlds_output_cast_rval(Opts, Type, Expr, !IO) :-
+ mlds_output_cast(Opts, Type, !IO),
+ mlds_output_rval(Opts, Expr, !IO).
-:- pred mlds_output_cast(mlds_type::in, io::di, io::uo) is det.
+:- pred mlds_output_cast(mlds_to_c_opts::in, mlds_type::in, io::di, io::uo)
+ is det.
-mlds_output_cast(Type, !IO) :-
+mlds_output_cast(Opts, Type, !IO) :-
io.write_string("(", !IO),
- mlds_output_type(Type, !IO),
+ mlds_output_type(Opts, Type, !IO),
io.write_string(") ", !IO).
-:- pred mlds_output_boxed_rval(mlds_type::in, mlds_rval::in, io::di, io::uo)
- is det.
+:- pred mlds_output_boxed_rval(mlds_to_c_opts::in,
+ mlds_type::in, mlds_rval::in, io::di, io::uo) is det.
-mlds_output_boxed_rval(Type, Expr, !IO) :-
+mlds_output_boxed_rval(Opts, Type, Expr, !IO) :-
(
( Type = mlds_generic_type
; Type = mercury_type(_, ctor_cat_variable, _)
)
->
% It already has type MR_Box, so no cast is needed.
- mlds_output_rval(Expr, !IO)
+ mlds_output_rval(Opts, Expr, !IO)
;
Expr = ml_unop(cast(OtherType), InnerExpr),
( Type = OtherType
@@ -3718,14 +3907,14 @@
% Avoid unnecessary double-casting -- strip away the inner cast.
% This is necessary for ANSI/ISO C conformance, to avoid casts
% from pointers to integers in static initializers.
- mlds_output_boxed_rval(Type, InnerExpr, !IO)
+ mlds_output_boxed_rval(Opts, Type, InnerExpr, !IO)
;
( Type = mercury_type(builtin_type(builtin_type_float), _, _)
; Type = mlds_native_float_type
)
->
io.write_string("MR_box_float(", !IO),
- mlds_output_rval(Expr, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string(")", !IO)
;
( Type = mercury_type(builtin_type(builtin_type_char), _, _)
@@ -3738,11 +3927,11 @@
% This is done to avoid spurious warnings about "cast from
% integer to pointer of different size" from gcc.
io.write_string("((MR_Box) (MR_Word) (", !IO),
- mlds_output_rval(Expr, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string("))", !IO)
;
io.write_string("((MR_Box) (", !IO),
- mlds_output_rval(Expr, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string("))", !IO)
).
@@ -3760,17 +3949,17 @@
is_an_address(ml_const(mlconst_code_addr(_))).
is_an_address(ml_const(mlconst_data_addr(_))).
-:- pred mlds_output_unboxed_rval(mlds_type::in, mlds_rval::in,
- io::di, io::uo) is det.
+:- pred mlds_output_unboxed_rval(mlds_to_c_opts::in,
+ mlds_type::in, mlds_rval::in, io::di, io::uo) is det.
-mlds_output_unboxed_rval(Type, Expr, !IO) :-
+mlds_output_unboxed_rval(Opts, Type, Expr, !IO) :-
(
( Type = mercury_type(builtin_type(builtin_type_float), _, _)
; Type = mlds_native_float_type
)
->
io.write_string("MR_unbox_float(", !IO),
- mlds_output_rval(Expr, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string(")", !IO)
;
( Type = mercury_type(builtin_type(builtin_type_char), _, _)
@@ -3783,21 +3972,21 @@
% This is done to avoid spurious warnings about "cast from
% pointer to integer of different size" from gcc.
io.write_string("(", !IO),
- mlds_output_cast(Type, !IO),
+ mlds_output_cast(Opts, Type, !IO),
io.write_string("(MR_Word) ", !IO),
- mlds_output_rval(Expr, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string(")", !IO)
;
io.write_string("(", !IO),
- mlds_output_cast(Type, !IO),
- mlds_output_rval(Expr, !IO),
+ mlds_output_cast(Opts, Type, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string(")", !IO)
).
-:- pred mlds_output_std_unop(builtin_ops.unary_op::in, mlds_rval::in,
- io::di, io::uo) is det.
+:- pred mlds_output_std_unop(mlds_to_c_opts::in, builtin_ops.unary_op::in,
+ mlds_rval::in, io::di, io::uo) is det.
-mlds_output_std_unop(UnaryOp, Expr, !IO) :-
+mlds_output_std_unop(Opts, UnaryOp, Expr, !IO) :-
c_util.unary_prefix_op(UnaryOp, UnaryOpString),
io.write_string(UnaryOpString, !IO),
io.write_string("(", !IO),
@@ -3808,19 +3997,19 @@
;
true
),
- mlds_output_rval(Expr, !IO),
+ mlds_output_rval(Opts, Expr, !IO),
io.write_string(")", !IO).
-:- pred mlds_output_binop(binary_op::in, mlds_rval::in, mlds_rval::in,
- io::di, io::uo) is det.
+:- pred mlds_output_binop(mlds_to_c_opts::in, binary_op::in,
+ mlds_rval::in, mlds_rval::in, io::di, io::uo) is det.
-mlds_output_binop(Op, X, Y, !IO) :-
+mlds_output_binop(Opts, Op, X, Y, !IO) :-
binop_category_string(Op, Category, OpStr),
(
Category = array_index_binop,
- mlds_output_bracketed_rval(X, !IO),
+ mlds_output_bracketed_rval(Opts, X, !IO),
io.write_string("[", !IO),
- mlds_output_rval(Y, !IO),
+ mlds_output_rval(Opts, Y, !IO),
io.write_string("]", !IO)
;
Category = compound_compare_binop,
@@ -3830,9 +4019,9 @@
;
Category = string_compare_binop,
io.write_string("(strcmp(", !IO),
- mlds_output_rval(X, !IO),
+ mlds_output_rval(Opts, X, !IO),
io.write_string(", ", !IO),
- mlds_output_rval(Y, !IO),
+ mlds_output_rval(Opts, Y, !IO),
io.write_string(")", !IO),
io.write_string(" ", !IO),
io.write_string(OpStr, !IO),
@@ -3843,45 +4032,46 @@
; Category = float_arith_binop
),
io.write_string("(", !IO),
- mlds_output_bracketed_rval(X, !IO),
+ mlds_output_bracketed_rval(Opts, X, !IO),
io.write_string(" ", !IO),
io.write_string(OpStr, !IO),
io.write_string(" ", !IO),
- mlds_output_bracketed_rval(Y, !IO),
+ mlds_output_bracketed_rval(Opts, Y, !IO),
io.write_string(")", !IO)
;
Category = unsigned_compare_binop,
io.write_string("( (MR_Unsigned) ", !IO),
- mlds_output_rval(X, !IO),
+ mlds_output_rval(Opts, X, !IO),
io.write_string(" ", !IO),
io.write_string(OpStr, !IO),
io.write_string(" (MR_Unsigned) ", !IO),
- mlds_output_rval(Y, !IO),
+ mlds_output_rval(Opts, Y, !IO),
io.write_string(")", !IO)
;
Category = int_or_bool_binary_infix_binop,
% We could treat X + (-const) specially, but we don't.
% The reason is documented in the equivalent code in llds_out.m.
io.write_string("(", !IO),
- mlds_output_rval(X, !IO),
+ mlds_output_rval(Opts, X, !IO),
io.write_string(" ", !IO),
io.write_string(OpStr, !IO),
io.write_string(" ", !IO),
- mlds_output_rval(Y, !IO),
+ mlds_output_rval(Opts, Y, !IO),
io.write_string(")", !IO)
;
Category = macro_binop,
io.write_string(OpStr, !IO),
io.write_string("(", !IO),
- mlds_output_rval(X, !IO),
+ mlds_output_rval(Opts, X, !IO),
io.write_string(", ", !IO),
- mlds_output_rval(Y, !IO),
+ mlds_output_rval(Opts, Y, !IO),
io.write_string(")", !IO)
).
-:- pred mlds_output_rval_const(mlds_rval_const::in, io::di, io::uo) is det.
+:- pred mlds_output_rval_const(mlds_to_c_opts::in, mlds_rval_const::in,
+ io::di, io::uo) is det.
-mlds_output_rval_const(Const, !IO) :-
+mlds_output_rval_const(Opts, Const, !IO) :-
(
Const = mlconst_true,
io.write_string("MR_TRUE", !IO)
@@ -3899,7 +4089,7 @@
expect(unify(Lang, lang_c), this_file,
"output_rval_const - mlconst_foreign for language other than C."),
io.write_string("((", !IO),
- mlds_output_type(Type, !IO),
+ mlds_output_type(Opts, Type, !IO),
io.write_string(") ", !IO),
io.write_string(Value, !IO),
io.write_string(")", !IO)
@@ -3961,13 +4151,14 @@
mlds_output_proc_label(mlds_proc_label(PredLabel, ProcId), !IO) :-
mlds_output_pred_label(PredLabel, !IO),
proc_id_to_int(ProcId, ModeNum),
- io.format("_%d", [i(ModeNum)], !IO).
+ io.write_char('_', !IO),
+ io.write_int(ModeNum, !IO).
:- func mlds_proc_label_to_string(mlds_proc_label) = string.
mlds_proc_label_to_string(mlds_proc_label(PredLabel, ProcId)) =
- mlds_pred_label_to_string(PredLabel) ++
- string.format("_%d", [i(proc_id_to_int(ProcId))]).
+ mlds_pred_label_to_string(PredLabel) ++ "_"
+ ++ string.int_to_string(proc_id_to_int(ProcId)).
:- pred mlds_output_data_addr(mlds_data_addr::in, io::di, io::uo) is det.
@@ -4043,10 +4234,12 @@
mlds_indent(N - 1, !IO)
).
+%-----------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "mlds_to_c.m".
+%-----------------------------------------------------------------------------%
:- end_module mlds_to_c.
-
%-----------------------------------------------------------------------------%
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.144
diff -u -b -r1.144 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 25 Aug 2009 23:46:49 -0000 1.144
+++ compiler/mlds_to_gcc.m 28 Aug 2009 12:56:48 -0000
@@ -167,6 +167,7 @@
:- import_module ml_backend.ml_code_util.
% For ml_gen_public_field_decl_flags, which is used by the code
% that handles derived classes.
+:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_util.
:- import_module ml_backend.mlds_to_c. % to handle C foreign_code
:- import_module parse_tree.file_names.
@@ -242,17 +243,18 @@
mlds_to_gcc__compile_to_asm(MLDS, ContainsCCode) -->
% XXX We need to handle initialise declarations properly here.
- { MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns0,
+ % XXX zs: I am not sure whether the handling of _GlobalData is right.
+ { MLDS = mlds(ModuleName, AllForeignCode, Imports, _GlobalData, Defns0,
InitPreds, FinalPreds, ExportedEnums) },
- %
% Handle output of any foreign code (C, Ada, Fortran, etc.)
% to appropriate files.
- %
+
{ list__filter(defn_contains_foreign_code(ml_target_asm), Defns0,
ForeignDefns, Defns) },
% We only handle C currently, so we just look up C
{ ForeignCode = map__lookup(AllForeignCode, lang_c) },
+ globals.io_get_globals(Globals),
(
% Check if there is any C code from pragma foreign_code,
% pragma export, or pragma foreign_proc declarations.
@@ -295,9 +297,9 @@
% them from the asm file!) and pass that to mlds_to_c.m
% to create the .mih file, and if necessary the .c file.
{ ForeignMLDS = mlds(ModuleName, AllForeignCode, Imports,
- list__map(make_public, ForeignDefns), InitPreds,
- FinalPreds, ExportedEnums) },
- mlds_to_c__output_c_file(ForeignMLDS, "")
+ ml_global_data_init, list__map(make_public, ForeignDefns),
+ InitPreds, FinalPreds, ExportedEnums) },
+ mlds_to_c__output_c_file(ForeignMLDS, Globals, "")
),
%
% Generate the .mih C header file for this module.
@@ -305,7 +307,7 @@
% because this is needed to allow interoperability between modules
% compiled with --target asm and --target c.
%
- mlds_to_c__output_header_file(MLDS, ""),
+ mlds_to_c__output_c_header_file(MLDS, Globals, ""),
%
% We generate things in this order:
@@ -1294,8 +1296,9 @@
{ Name = qual(ModuleName, QualKind, UnqualName) },
globals__io_get_globals(Globals),
{ UnqualName = entity_type(ClassName, ClassArity) ->
- ClassModuleName = mlds_append_class_qualifier(ModuleName,
- QualKind, Globals, ClassName, ClassArity)
+ globals.get_target(Globals, Target),
+ ClassModuleName = mlds_append_class_qualifier(Target, ModuleName,
+ QualKind, ClassName, ClassArity)
;
unexpected(this_file, "mlds_output_enum_constants")
},
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.205
diff -u -b -r1.205 mlds_to_il.m
--- compiler/mlds_to_il.m 25 Aug 2009 23:46:49 -0000 1.205
+++ compiler/mlds_to_il.m 28 Aug 2009 12:56:48 -0000
@@ -70,7 +70,6 @@
:- import_module ml_backend.mlds.
:- import_module bool.
-:- import_module io.
:- import_module list.
:- import_module maybe.
:- import_module set.
@@ -81,8 +80,8 @@
%
% This is where all the action is for the IL backend.
%
-:- pred generate_il(mlds::in, list(ilasm.decl)::out,
- set(foreign_language)::out, io::di, io::uo) is det.
+:- pred generate_il(globals::in, mlds::in, list(ilasm.decl)::out,
+ set(foreign_language)::out) is det.
%-----------------------------------------------------------------------------%
@@ -113,7 +112,7 @@
% mlds_generic_env_ptr_type?
).
-:- pred get_il_data_rep(il_data_rep::out, io::di, io::uo) is det.
+:- pred get_il_data_rep(globals::in, il_data_rep::out) is det.
% Get the corresponding ILDS type for an MLDS type
% (this depends on which representation you happen to be using).
@@ -154,6 +153,7 @@
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- 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.
:- import_module parse_tree.error_util.
@@ -236,73 +236,50 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-generate_il(MLDS, ILAsm, ForeignLangs, !IO) :-
- maybe_get_dotnet_library_version(MaybeVersion, !IO),
+generate_il(Globals, MLDS, ILAsm, ForeignLangs) :-
+ globals.get_maybe_il_version_number(Globals, MaybeVersionNumber),
(
- MaybeVersion = yes(Version),
- generate_il(MLDS, Version, ILAsm, ForeignLangs, !IO)
+ MaybeVersionNumber = yes(VersionNumber),
+ VersionNumber = il_version_number(Major, Minor, Build, Revision),
+ Version = version(Major, Minor, Build, Revision),
+ generate_il(Globals, MLDS, Version, ILAsm, ForeignLangs)
;
- MaybeVersion = no,
+ MaybeVersionNumber = no,
ILAsm = [],
ForeignLangs = set.init
).
-:- pred maybe_get_dotnet_library_version(maybe(assembly_decl)::out,
- io::di, io::uo) is det.
-
-maybe_get_dotnet_library_version(MaybeVersion, !IO) :-
- io_lookup_string_option(dotnet_library_version, VersionStr, !IO),
- IsSep = (pred(('.')::in) is semidet),
- (
- string.words_separator(IsSep, VersionStr) = [Mj, Mn, Bu, Rv],
- string.to_int(Mj, Major),
- string.to_int(Mn, Minor),
- string.to_int(Bu, Build),
- string.to_int(Rv, Revision)
- ->
- Version = version(Major, Minor, Build, Revision),
- MaybeVersion = yes(Version)
- ;
- MaybeVersion = no,
- write_error_pieces_maybe_with_context(no, 0, [
- words("Error: invalid version string"),
- words("`" ++ VersionStr ++ "'"),
- words("passed to `--dotnet-library-version'.")
- ], !IO),
- io.set_exit_status(1, !IO)
- ).
-
%-----------------------------------------------------------------------------%
-:- pred generate_il(mlds::in, assembly_decl::in,
- list(ilasm.decl)::out, set(foreign_language)::out,
- io::di, io::uo) is det.
+:- pred generate_il(globals::in, mlds::in, assembly_decl::in,
+ list(ilasm.decl)::out, set(foreign_language)::out) is det.
-generate_il(MLDS, Version, ILAsm, ForeignLangs, !IO) :-
+generate_il(Globals, MLDS0, Version, ILAsm, ForeignLangs) :-
% XXX initialise declarations NYI for IL backend
- mlds(MercuryModuleName, ForeignCode, Imports, Defns, _, _, _) =
- transform_mlds(MLDS),
+ il_transform_mlds(MLDS0, MLDS),
+ MLDS = mlds(MercuryModuleName, ForeignCode, Imports, GlobalData, Defns0,
+ _, _, _),
+ ml_global_data_get_all_global_defns(GlobalData, GlobalDefns),
+ Defns = GlobalDefns ++ Defns0,
ModuleName = mercury_module_name_to_mlds(MercuryModuleName),
AssemblyName =
sym_name_to_string(mlds_module_name_to_sym_name(ModuleName)),
- get_il_data_rep(ILDataRep, !IO),
- globals.io_lookup_bool_option(debug_il_asm, DebugIlAsm, !IO),
- globals.io_lookup_bool_option(verifiable_code,
- VerifiableCode, !IO),
- globals.io_lookup_bool_option(il_byref_tailcalls, ByRefTailCalls, !IO),
- globals.io_lookup_bool_option(sign_assembly, SignAssembly, !IO),
- globals.io_lookup_bool_option(separate_assemblies, SeparateAssemblies,
- !IO),
- globals.io_lookup_bool_option(support_ms_clr, MsCLR, !IO),
- globals.io_lookup_bool_option(support_rotor_clr, RotorCLR, !IO),
+ get_il_data_rep(Globals, ILDataRep),
+ globals.lookup_bool_option(Globals, debug_il_asm, DebugIlAsm),
+ globals.lookup_bool_option(Globals, verifiable_code, VerifiableCode),
+ globals.lookup_bool_option(Globals, il_byref_tailcalls, ByRefTailCalls),
+ globals.lookup_bool_option(Globals, sign_assembly, SignAssembly),
+ globals.lookup_bool_option(Globals, separate_assemblies,
+ SeparateAssemblies),
+ globals.lookup_bool_option(Globals, support_ms_clr, MsCLR),
+ globals.lookup_bool_option(Globals, support_rotor_clr, RotorCLR),
IlInfo0 = il_info_init(ModuleName, AssemblyName, Imports, ILDataRep,
DebugIlAsm, VerifiableCode, ByRefTailCalls, MsCLR, RotorCLR),
% Generate code for all the methods.
- list.map_foldl(mlds_defn_to_ilasm_decl, Defns, ILDecls,
- IlInfo0, IlInfo),
+ list.map_foldl(mlds_defn_to_ilasm_decl, Defns, ILDecls, IlInfo0, IlInfo),
list.filter(has_foreign_code_defined(ForeignCode),
[lang_csharp], ForeignCodeLangs),
@@ -317,9 +294,7 @@
% Standard library modules all go in the one assembly in a separate step
% during the build (using AL.EXE).
PackageName = mlds_module_name_to_package_name(ModuleName),
- (
- sym_name_prefix(PackageName) = "mercury"
- ->
+ ( sym_name_prefix(PackageName) = "mercury" ->
ThisAssembly = [],
AssemblerRefs = Imports
;
@@ -354,8 +329,7 @@
Namespace = [namespace(NamespaceName, ILDecls)],
ILAsm = list.condense([ThisAssembly, ExternAssemblies, Namespace]).
-get_il_data_rep(ILDataRep, !IO) :-
- globals.io_get_globals(Globals, !IO),
+get_il_data_rep(Globals, ILDataRep) :-
globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
ILEnvPtrType = choose_il_envptr_type(Globals),
ILDataRep = il_data_rep(HighLevelData, ILEnvPtrType).
@@ -379,30 +353,49 @@
% class, and then fix all the references so that they refer to their new
% names.
%
-:- func transform_mlds(mlds) = mlds.
+:- pred il_transform_mlds(mlds::in, mlds::out) is det.
-transform_mlds(MLDS0) = MLDS :-
- AllExports = list.condense(
- list.map(
- (func(mlds_foreign_code(_, _, _, Exports)) = Exports),
- map.values(MLDS0 ^ mlds_foreign_code_map))
- ),
+il_transform_mlds(MLDS0, MLDS) :-
+ MLDS0 = mlds(ModuleName, ForeignCodeMap, TopLevelImports,
+ GlobalData0, Defns0, InitPreds, FinalPreds, ExportedEnums),
+
+ map.values(ForeignCodeMap, ForeignCodes),
+ ForeignCodeExportLists =
+ list.map(project_foreign_code_export, ForeignCodes),
+ ForeignCodeExports = list.condense(ForeignCodeExportLists),
% Generate the exports for this file, they will be placed into
% class methods inside the wrapper class.
- list.map(mlds_export_to_mlds_defn, AllExports, ExportDefns),
+ list.map(mlds_export_to_mlds_defn, ForeignCodeExports, ExportDefns),
+
+ % We take all the definitions out of the global data field of the MLDS.
+ ml_global_data_get_all_global_defns(GlobalData0, GlobalDefns),
+ Defns1 = GlobalDefns ++ Defns0 ++ ExportDefns,
+ GlobalData = ml_global_data_init,
- list.filter(
+ IsFunctionOrData =
(pred(D::in) is semidet :-
( D = mlds_defn(_, _, _, mlds_function(_, _, _, _, _))
; D = mlds_defn(_, _, _, mlds_data(_, _, _))
)
- ), MLDS0 ^ mlds_defns ++ ExportDefns, MercuryCodeMembers, Others),
- WrapperClass = wrapper_class(list.map(rename_defn, MercuryCodeMembers)),
- % Note that ILASM requires that the type definitions in Others
+ ),
+ list.filter(IsFunctionOrData, Defns1, MercuryCodeDefns, OtherDefns),
+
+ WrapperClass = wrapper_class(list.map(rename_defn, MercuryCodeDefns)),
+ % XXX We are we renaming OtherDefns? Its definitions are not being wrapped
+ % in a class.
+ WrappedOtherDefns = list.map(rename_defn, OtherDefns),
+ % Note that ILASM requires that the type definitions in WrappedOtherDefns
% must precede the references to those types in WrapperClass.
- MLDS = MLDS0 ^ mlds_defns :=
- list.map(rename_defn, Others) ++ [WrapperClass].
+ Defns = WrappedOtherDefns ++ [WrapperClass],
+
+ MLDS = mlds(ModuleName, ForeignCodeMap, TopLevelImports,
+ GlobalData, Defns, InitPreds, FinalPreds, ExportedEnums).
+
+:- func project_foreign_code_export(mlds_foreign_code) =
+ list(mlds_pragma_export).
+
+project_foreign_code_export(mlds_foreign_code(_, _, _, Exports)) = Exports.
:- func wrapper_class(list(mlds_defn)) = mlds_defn.
@@ -414,13 +407,20 @@
mlds_class(mlds_class_defn(mlds_package, [], [], [], [], Members))
).
+%-----------------------------------------------------------------------------%
+%
+% Rename the relevant components of the definition (such as qualified var
+% names) to reflect the wrapper class we are adding around the definition.
+%
+
:- func rename_defn(mlds_defn) = mlds_defn.
-rename_defn(mlds_defn(Name, Context, Flags, Entity0))
- = mlds_defn(Name, Context, Flags, Entity) :-
+rename_defn(Defn0) = Defn :-
+ Defn0 = mlds_defn(Name, Context, Flags, Entity0),
(
Entity0 = mlds_data(Type, Initializer, GCStatement),
- Entity = mlds_data(Type, rename_initializer(Initializer),
+ Entity = mlds_data(Type,
+ rename_initializer(Initializer),
rename_gc_statement(GCStatement))
;
Entity0 = mlds_function(MaybePredProcId, Params, FunctionBody0,
@@ -441,7 +441,8 @@
ClassDefn = mlds_class_defn(Kind, Imports, Inherits, Implements,
list.map(rename_defn, Ctors), list.map(rename_defn, Members)),
Entity = mlds_class(ClassDefn)
- ).
+ ),
+ Defn = mlds_defn(Name, Context, Flags, Entity).
:- func rename_maybe_statement(maybe(statement)) = maybe(statement).
Index: compiler/mlds_to_ilasm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_ilasm.m,v
retrieving revision 1.40
diff -u -b -r1.40 mlds_to_ilasm.m
--- compiler/mlds_to_ilasm.m 21 Jul 2008 03:10:10 -0000 1.40
+++ compiler/mlds_to_ilasm.m 28 Aug 2009 12:56:48 -0000
@@ -18,6 +18,7 @@
:- module ml_backend.mlds_to_ilasm.
:- interface.
+:- import_module libs.globals.
:- import_module ml_backend.mlds.
:- import_module io.
@@ -26,7 +27,7 @@
% Convert the MLDS to IL and write it to a file.
%
-:- pred mlds_to_ilasm.output_mlds(mlds::in, io::di, io::uo) is det.
+:- pred output_mlds_via_ilasm(globals::in, mlds::in, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -36,7 +37,6 @@
% :- import_module hlds.passes_aux.
:- import_module libs.compiler_util.
:- import_module libs.file_util.
-:- import_module libs.globals.
:- import_module libs.options.
:- import_module ml_backend.ilasm.
:- import_module ml_backend.il_peephole.
@@ -53,18 +53,18 @@
%-----------------------------------------------------------------------------%
-output_mlds(MLDS, !IO) :-
+output_mlds_via_ilasm(Globals, MLDS, !IO) :-
ModuleName = mlds_get_module_name(MLDS),
- module_name_to_file_name(ModuleName, ".il", do_create_dirs,
- ILAsmFile, !IO),
- output_to_file_return_result(ILAsmFile, output_assembler(MLDS), Result,
+ module_name_to_file_name(ModuleName, ".il", do_create_dirs, ILAsmFile,
!IO),
+ output_to_file_return_result(ILAsmFile, output_assembler(Globals, MLDS),
+ Result, !IO),
(
Result = yes(ForeignLangs),
% Output any outline foreign_code to the appropriate foreign
% language file.
- list.foldl(output_foreign_file(MLDS),
+ list.foldl(output_foreign_file(Globals, MLDS),
set.to_sorted_list(ForeignLangs), !IO)
;
% An I/O error occurred; output_to_file has already reported
@@ -72,60 +72,58 @@
Result = no
).
-:- pred output_foreign_file(mlds::in, foreign_language::in,
+:- pred output_foreign_file(globals::in, mlds::in, foreign_language::in,
io::di, io::uo) is det.
-output_foreign_file(MLDS, ForeignLang, !IO) :-
+output_foreign_file(Globals, MLDS, ForeignLang, !IO) :-
ModuleName = mlds_get_module_name(MLDS),
(
ForeignModuleName = foreign_language_module_name(ModuleName,
ForeignLang),
Extension = foreign_language_file_extension(ForeignLang)
->
- handle_foreign_lang(ForeignLang, CodeGenerator),
+ (
+ ForeignLang = lang_csharp,
module_name_to_file_name(ForeignModuleName, Extension,
do_create_dirs, File, !IO),
- output_to_file(File,
- (pred(di, uo) is det --> CodeGenerator(MLDS)), !IO)
+ output_to_file(File, output_csharp_code(Globals, MLDS), !IO)
+ ;
+ ForeignLang = lang_c,
+ sorry(this_file, "language C foreign code not supported")
+ ;
+ ForeignLang = lang_il,
+ sorry(this_file, "language IL foreign code not supported")
;
- unexpected(this_file, "output_foreign_file: " ++
- "unexpected language")
+ ForeignLang = lang_java,
+ sorry(this_file, "language Java foreign code not supported")
+ ;
+ ForeignLang = lang_erlang,
+ sorry(this_file, "language Erlang foreign code not supported")
+ )
+ ;
+ unexpected(this_file, "output_foreign_file: unexpected language")
).
-:- pred handle_foreign_lang(foreign_language::in,
- pred(mlds, io, io)::out(pred(in, di, uo) is det)) is det.
-
-handle_foreign_lang(lang_csharp, output_csharp_code).
-handle_foreign_lang(lang_c, _) :-
- sorry(this_file, "language C foreign code not supported").
-handle_foreign_lang(lang_il, _) :-
- sorry(this_file, "language IL foreign code not supported").
-handle_foreign_lang(lang_java, _) :-
- sorry(this_file, "language Java foreign code not supported").
-handle_foreign_lang(lang_erlang, _) :-
- sorry(this_file, "language Erlang foreign code not supported").
-
% Generate the `.il' file.
% Returns the set of foreign language
%
-:- pred output_assembler(mlds::in, set(foreign_language)::out,
+:- pred output_assembler(globals::in, mlds::in, set(foreign_language)::out,
io::di, io::uo) is det.
-output_assembler(MLDS, ForeignLangs, !IO) :-
- MLDS = mlds(ModuleName, _ForeignCode, _Imports, _Defns,
+output_assembler(Globals, MLDS, ForeignLangs, !IO) :-
+ MLDS = mlds(ModuleName, _ForeignCode, _Imports, _GlobalData, _Defns,
_InitPreds, _FinalPreds, _ExportedEnums),
output_src_start(ModuleName, !IO),
io.nl(!IO),
- generate_il(MLDS, ILAsm0, ForeignLangs, !IO),
+ generate_il(Globals, MLDS, ILAsm0, ForeignLangs),
- % Perform peephole optimization if requested. If peephole
- % optimization was not requested, we may still need to invoke
- % the peephole optimization pass, because some of the peephole
- % optimizations are actually needed for verifiability of the
- % generated IL.
- globals.io_lookup_bool_option(optimize_peep, Peephole, !IO),
- globals.io_lookup_bool_option(verifiable_code, Verifiable, !IO),
+ % Perform peephole optimization if requested. If peephole optimization
+ % was not requested, we may still need to invoke the peephole optimization
+ % pass, because some of the peephole optimizations are actually needed
+ % for verifiability of the generated IL.
+ globals.lookup_bool_option(Globals, optimize_peep, Peephole),
+ globals.lookup_bool_option(Globals, verifiable_code, Verifiable),
( Peephole = yes ->
VerifyOnly = no,
il_peephole_optimize(VerifyOnly, ILAsm0, ILAsm)
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.135
diff -u -b -r1.135 mlds_to_java.m
--- compiler/mlds_to_java.m 25 Aug 2009 23:46:49 -0000 1.135
+++ compiler/mlds_to_java.m 28 Aug 2009 12:56:48 -0000
@@ -74,7 +74,7 @@
%-----------------------------------------------------------------------------%
-:- pred output_mlds(module_info::in, mlds::in, io::di, io::uo) is det.
+:- pred output_java_mlds(module_info::in, mlds::in, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -96,6 +96,7 @@
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.java_util.
:- import_module ml_backend.ml_code_util. % for ml_gen_local_var_decl_flags.
+:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_type_gen. % for ml_gen_type_name
:- import_module ml_backend.ml_util.
:- import_module ml_backend.rtti_to_mlds.
@@ -124,7 +125,7 @@
%-----------------------------------------------------------------------------%
-output_mlds(ModuleInfo, MLDS, !IO) :-
+output_java_mlds(ModuleInfo, MLDS, !IO) :-
% Note that the Java file name that we use for modules in the
% Mercury standard library do not include a "mercury." prefix;
% that's why we don't call mercury_module_name_to_mlds here.
@@ -318,8 +319,9 @@
output_java_src_file(ModuleInfo, Indent, MLDS, !IO) :-
% Run further transformations on the MLDS.
- MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns0,
+ MLDS = mlds(ModuleName, AllForeignCode, Imports, GlobalData, Defns0,
InitPreds, FinalPreds, ExportedEnums),
+ ml_global_data_get_all_global_defns(GlobalData, GlobalDefns),
% Do NOT enforce the outermost "mercury" qualifier here. This module
% name is compared with other module names in the MLDS, to avoid
@@ -333,7 +335,7 @@
% Create wrappers in MLDS for all pointer addressed methods.
generate_code_addr_wrappers(Indent + 1, CodeAddrs, [], WrapperDefns),
- Defns1 = WrapperDefns ++ Defns0,
+ Defns1 = GlobalDefns ++ WrapperDefns ++ Defns0,
% Rename classes with excessively long names.
shorten_long_class_names(MLDS_ModuleName, Defns1, Defns),
@@ -1057,17 +1059,17 @@
map(mlds_class_name, mlds_class_name)::out) is det.
maybe_shorten_long_class_name(!Defn, !Renaming) :-
- Access = access(!.Defn ^ mlds_decl_flags),
+ Access = access(!.Defn ^ md_decl_flags),
(
% We only rename private classes for now.
Access = acc_private,
- EntityName0 = !.Defn ^ mlds_entity_name,
+ EntityName0 = !.Defn ^ md_entity_name,
(
EntityName0 = entity_type(ClassName0, Arity),
ClassName = shorten_class_name(ClassName0),
( ClassName \= ClassName0 ->
EntityName = entity_type(ClassName, Arity),
- !Defn ^ mlds_entity_name := EntityName,
+ !Defn ^ md_entity_name := EntityName,
svmap.det_insert(ClassName0, ClassName, !Renaming)
;
true
@@ -1119,7 +1121,7 @@
mlds_defn::in, mlds_defn::out) is det.
rename_class_names_defn(Renaming, !Defn) :-
- EntityDefn0 = !.Defn ^ mlds_entity_defn,
+ EntityDefn0 = !.Defn ^ md_entity_defn,
(
EntityDefn0 = mlds_data(Type0, Initializer0, GCStatement),
rename_class_names_type(Renaming, Type0, Type),
@@ -1147,7 +1149,7 @@
EntityDefn = mlds_class(mlds_class_defn(ClassKind, Imports, Inherits,
Implements, Ctors, Members))
),
- !Defn ^ mlds_entity_defn := EntityDefn.
+ !Defn ^ md_entity_defn := EntityDefn.
:- pred rename_class_names_type(class_name_renaming::in,
mlds_type::in, mlds_type::out) is det.
Index: compiler/mlds_to_managed.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_managed.m,v
retrieving revision 1.50
diff -u -b -r1.50 mlds_to_managed.m
--- compiler/mlds_to_managed.m 10 Jun 2009 06:26:22 -0000 1.50
+++ compiler/mlds_to_managed.m 28 Aug 2009 12:56:48 -0000
@@ -16,6 +16,7 @@
:- module ml_backend.mlds_to_managed.
:- interface.
+:- import_module libs.globals.
:- import_module ml_backend.mlds.
:- import_module io.
@@ -24,7 +25,7 @@
% Convert the MLDS to C# and write it to a file.
%
-:- pred output_csharp_code(mlds::in, io::di, io::uo) is det.
+:- pred output_csharp_code(globals::in, mlds::in, io::di, io::uo) is det.
% Print the header comments of the output module.
%
@@ -41,12 +42,12 @@
:- import_module backend_libs.c_util.
:- import_module libs.compiler_util.
-:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ilds.
-:- import_module ml_backend.mlds_to_il.
+:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_util.
+:- import_module ml_backend.mlds_to_il.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_foreign.
@@ -64,45 +65,18 @@
%-----------------------------------------------------------------------------%
-output_csharp_code(MLDS, !IO) :-
- MLDS = mlds(ModuleName, _ForeignCode, _Imports, _Defns,
+output_csharp_code(Globals, MLDS, !IO) :-
+ MLDS = mlds(ModuleName, AllForeignCode, _Imports, GlobalData, Defns0,
_InitPreds, _FinalPreds, _ExportedEnums),
- output_src_start(ModuleName, !IO),
- io.nl(!IO),
- generate_code(MLDS, !IO),
- output_src_end(ModuleName, !IO).
-
-%-----------------------------------------------------------------------------%
-
-output_src_start(ModuleName, !IO) :-
- library.version(Version),
- io.write_strings(
- ["//\n// Automatically generated from `",
- sym_name_to_string(ModuleName),
- ".m' by the\n",
- "// Mercury compiler, version ",
- Version,
- ".\n",
- "// Do not edit.\n",
- "\n\n"], !IO).
-
-output_src_end(ModuleName, !IO) :-
- io.write_string("// End of module: ", !IO),
- prog_out.write_sym_name(ModuleName, !IO),
- io.write_string(". \n", !IO).
-
-%-----------------------------------------------------------------------------%
+ ml_global_data_get_all_global_defns(GlobalData, GlobalDefns),
+ Defns = GlobalDefns ++ Defns0,
-:- pred generate_code(mlds::in, io::di, io::uo) is det.
+ output_src_start(ModuleName, !IO),
-generate_code(MLDS, !IO) :-
- MLDS = mlds(ModuleName, AllForeignCode, _Imports, Defns,
- _InitPreds, _FinalPreds, _ExportedEnums),
ClassName = class_name(mercury_module_name_to_mlds(ModuleName),
wrapper_class_name),
- io.nl(!IO),
- output_csharp_header_code(!IO),
+ output_csharp_header_code(Globals, !IO),
% Get the foreign code for the required language.
ForeignCode = map.lookup(AllForeignCode, lang_csharp),
@@ -124,7 +98,8 @@
% Output the contents of foreign_proc declarations.
% Put each one inside a method.
- list.foldl(generate_method_code, Defns, !IO),
+ get_il_data_rep(Globals, DataRep),
+ list.foldl(generate_method_code(DataRep), Defns, !IO),
io.write_string("};\n", !IO),
@@ -133,12 +108,35 @@
(pred(_N::in, !.IO::di, !:IO::uo) is det :-
io.write_string("}", !IO)
), !IO),
- io.nl(!IO).
+ io.nl(!IO),
-:- pred output_csharp_header_code(io::di, io::uo) is det.
+ output_src_end(ModuleName, !IO).
+
+%-----------------------------------------------------------------------------%
-output_csharp_header_code(!IO) :-
- get_il_data_rep(DataRep, !IO),
+output_src_start(ModuleName, !IO) :-
+ library.version(Version),
+ io.write_strings(
+ ["//\n// Automatically generated from `",
+ sym_name_to_string(ModuleName),
+ ".m' by the\n",
+ "// Mercury compiler, version ",
+ Version,
+ ".\n",
+ "// Do not edit.\n",
+ "\n\n"], !IO).
+
+output_src_end(ModuleName, !IO) :-
+ io.write_string("// End of module: ", !IO),
+ prog_out.write_sym_name(ModuleName, !IO),
+ io.write_string(". \n", !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pred output_csharp_header_code(globals::in, io::di, io::uo) is det.
+
+output_csharp_header_code(Globals, !IO) :-
+ get_il_data_rep(Globals, DataRep),
( DataRep = il_data_rep(yes, _) ->
io.write_string("#define MR_HIGHLEVEL_DATA\n", !IO)
;
@@ -150,7 +148,7 @@
% in the C# code anymore.
io.write_string("using mercury;\n\n", !IO),
- globals.io_lookup_bool_option(sign_assembly, SignAssembly, !IO),
+ globals.lookup_bool_option(Globals, sign_assembly, SignAssembly),
(
SignAssembly = yes,
io.write_string("[assembly:System.Reflection." ++
@@ -187,6 +185,9 @@
generate_namespace_details(ClassName, NameSpaceFmtStr, Namespace) :-
% XXX We should consider what happens if we need to mangle
% the namespace name.
+ %
+ % XXX Generating the left brace here and the right brace somewhere else
+ % seems bad design. -zs
NameSpaceFmtStr = "namespace @%s {",
Namespace0 = get_class_namespace(ClassName),
@@ -215,14 +216,18 @@
output_reset_context(!IO)
), !IO).
-:- pred generate_method_code(mlds_defn::in, io::di, io::uo) is det.
+:- pred generate_method_code(il_data_rep::in, mlds_defn::in, io::di, io::uo)
+ is det.
-generate_method_code(mlds_defn(entity_export(_), _, _, _), !IO).
-generate_method_code(mlds_defn(entity_data(_), _, _, _), !IO).
-generate_method_code(mlds_defn(entity_type(_, _), _, _, _), !IO).
-generate_method_code(Defn, !IO) :-
- Defn = mlds_defn(entity_function(PredLabel, ProcId, MaybeSeqNum, _PredId),
- _Context, _DeclFlags, Entity),
+generate_method_code(DataRep, Defn, !IO) :-
+ Defn = mlds_defn(EntityName, _Context, _DeclFlags, Entity),
+ (
+ ( EntityName = entity_export(_)
+ ; EntityName = entity_data(_)
+ ; EntityName = entity_type(_, _)
+ )
+ ;
+ EntityName = entity_function(PredLabel, ProcId, MaybeSeqNum, _PredId),
(
% XXX we ignore the attributes
Entity = mlds_function(_, Params, body_defined_here(Statement),
@@ -232,7 +237,6 @@
->
expect(set.empty(EnvVarNames), this_file,
"generate_method_code: EnvVarNames"),
- get_il_data_rep(DataRep, !IO),
Params = mlds_func_params(Inputs, Outputs),
(
Outputs = [],
@@ -257,45 +261,46 @@
io.write_string(Id, !IO),
io.write_string("(", !IO),
io.write_list(Inputs, ", ",
- write_input_arg_as_foreign_type, !IO),
+ write_input_arg_as_foreign_type(DataRep), !IO),
io.write_string(")", !IO),
io.nl(!IO),
io.write_string("{\n", !IO),
- write_statement(Inputs, Statement, !IO),
+ write_statement(DataRep, Inputs, Statement, !IO),
io.write_string("}\n", !IO)
;
true
+ )
).
-:- pred write_statement(mlds_arguments::in, statement::in,
+:- pred write_statement(il_data_rep::in, mlds_arguments::in, statement::in,
io::di, io::uo) is det.
-write_statement(Args, statement(Statement, Context), !IO) :-
+write_statement(DataRep, Args, statement(Statement, Context), !IO) :-
(
% XXX petdr
Statement = ml_stmt_atomic(ForeignProc),
ForeignProc = outline_foreign_proc(lang_csharp, OutlineArgs, _, Code)
->
- list.foldl(write_outline_arg_init, OutlineArgs, !IO),
+ list.foldl(write_outline_arg_init(DataRep), OutlineArgs, !IO),
output_context(mlds_get_prog_context(Context), !IO),
io.write_string(Code, !IO),
io.nl(!IO),
output_reset_context(!IO),
- list.foldl(write_outline_arg_final, OutlineArgs, !IO)
+ list.foldl(write_outline_arg_final(DataRep), OutlineArgs, !IO)
;
Statement = ml_stmt_block(Defns, Statements)
->
- io.write_list(Defns, "", write_defn_decl, !IO),
+ io.write_list(Defns, "", write_defn_decl(DataRep), !IO),
io.write_string("{\n", !IO),
- io.write_list(Statements, "", write_statement(Args), !IO),
+ io.write_list(Statements, "", write_statement(DataRep, Args), !IO),
io.write_string("\n}\n", !IO)
;
Statement = ml_stmt_return(Rvals)
->
( Rvals = [Rval] ->
io.write_string("return ", !IO),
- write_rval(Rval, !IO),
+ write_rval(DataRep, Rval, !IO),
io.write_string(";\n", !IO)
;
sorry(this_file, "multiple return values")
@@ -303,75 +308,54 @@
;
Statement = ml_stmt_atomic(assign(LVal, RVal))
->
- write_lval(LVal, !IO),
+ write_lval(DataRep, LVal, !IO),
io.write_string(" = ", !IO),
- write_rval(RVal, !IO),
+ write_rval(DataRep, RVal, !IO),
io.write_string(";\n", !IO)
;
functor(Statement, canonicalize, SFunctor, _Arity),
sorry(this_file, "foreign code output for " ++ SFunctor)
).
-:- pred write_outline_arg_init(outline_arg::in, io::di, io::uo) is det.
+:- pred write_outline_arg_init(il_data_rep::in, outline_arg::in,
+ io::di, io::uo) is det.
-write_outline_arg_init(in(Type, VarName, Rval), !IO) :-
- write_parameter_type(Type, !IO),
+write_outline_arg_init(DataRep, OutlineArg, !IO) :-
+ (
+ OutlineArg = in(Type, VarName, Rval),
+ write_parameter_type(DataRep, Type, !IO),
io.write_string(" ", !IO),
io.write_string(VarName, !IO),
io.write_string(" = ", !IO),
- write_rval(Rval, !IO),
- io.write_string(";\n", !IO).
-write_outline_arg_init(out(Type, VarName, _Lval), !IO) :-
- write_parameter_type(Type, !IO),
+ write_rval(DataRep, Rval, !IO),
+ io.write_string(";\n", !IO)
+ ;
+ OutlineArg = out(Type, VarName, _Lval),
+ write_parameter_type(DataRep, Type, !IO),
io.write_string(" ", !IO),
io.write_string(VarName, !IO),
% In C# give output variables a default value to avoid warnings.
io.write_string(" = ", !IO),
- write_parameter_initializer(Type, !IO),
- io.write_string(";\n", !IO).
-write_outline_arg_init(unused, !IO).
-
-:- pred write_outline_arg_final(outline_arg::in, io::di, io::uo) is det.
-
-write_outline_arg_final(in(_, _, _), !IO).
-write_outline_arg_final(out(_Type, VarName, Lval), !IO) :-
- write_lval(Lval, !IO),
- io.write_string(" = ", !IO),
- io.write_string(VarName, !IO),
- io.write_string(";\n", !IO).
-write_outline_arg_final(unused, !IO).
+ write_parameter_initializer(DataRep, Type, !IO),
+ io.write_string(";\n", !IO)
+ ;
+ OutlineArg = unused
+ ).
-:- pred write_declare_and_assign_local(mlds_argument::in,
+:- pred write_outline_arg_final(il_data_rep::in, outline_arg::in,
io::di, io::uo) is det.
-write_declare_and_assign_local(mlds_argument(Name, Type, _GcCode), !IO) :-
- ( Name = entity_data(mlds_data_var(VarName0)) ->
- VarName = VarName0
- ;
- unexpected(this_file, "not a variable name")
- ),
-
- % A pointer type is an output type.
- ( Type = mlds_ptr_type(OutputType) ->
- ( is_anonymous_variable(VarName) ->
- true
+write_outline_arg_final(DataRep, OutlineArg, !IO) :-
+ (
+ OutlineArg = in(_, _, _)
;
- write_parameter_type(OutputType, !IO),
- io.write_string(" ", !IO),
- write_mlds_var_name_for_local(VarName, !IO),
-
- % In C# give output types a default value to avoid warnings.
+ OutlineArg = out(_Type, VarName, Lval),
+ write_lval(DataRep, Lval, !IO),
io.write_string(" = ", !IO),
- write_parameter_initializer(OutputType, !IO),
+ io.write_string(VarName, !IO),
io.write_string(";\n", !IO)
- )
;
- write_parameter_type(Type, !IO),
- io.write_string(" ", !IO),
- write_mlds_var_name_for_local(VarName, !IO),
- io.write_string(" = ", !IO),
- write_mlds_var_name_for_parameter(VarName, !IO),
- io.write_string(";\n", !IO)
+ OutlineArg = unused
).
:- pred write_assign_local_to_output(mlds_argument::in, io::di, io::uo) is det.
@@ -415,50 +399,59 @@
output_reset_context(!IO) :-
c_util.reset_line_num(!IO).
-:- pred write_rval(mlds_rval::in, io::di, io::uo) is det.
+:- pred write_rval(il_data_rep::in, mlds_rval::in, io::di, io::uo) is det.
-write_rval(ml_lval(Lval), !IO) :-
- write_lval(Lval, !IO).
-write_rval(ml_mkword(_Tag, _Rval), !IO) :-
- sorry(this_file, "mkword rval").
-write_rval(ml_const(RvalConst), !IO) :-
- write_rval_const(RvalConst, !IO).
-write_rval(ml_unop(Unop, Rval), !IO) :-
+write_rval(DataRep, Rval, !IO) :-
+ (
+ Rval = ml_lval(Lval),
+ write_lval(DataRep, Lval, !IO)
+ ;
+ Rval = ml_mkword(_Tag, _Rval),
+ sorry(this_file, "mkword rval")
+ ;
+ Rval = ml_const(RvalConst),
+ write_rval_const(RvalConst, !IO)
+ ;
+ Rval = ml_unop(Unop, RvalA),
(
Unop = std_unop(StdUnop),
c_util.unary_prefix_op(StdUnop, UnopStr)
->
io.write_string(UnopStr, !IO),
io.write_string("(", !IO),
- write_rval(Rval, !IO),
+ write_rval(DataRep, RvalA, !IO),
io.write_string(")", !IO)
;
Unop = cast(Type)
->
io.write_string("(", !IO),
- write_parameter_type(Type, !IO),
+ write_parameter_type(DataRep, Type, !IO),
io.write_string(") ", !IO),
- write_rval(Rval, !IO)
+ write_rval(DataRep, RvalA, !IO)
;
sorry(this_file, "box or unbox unop")
- ).
-write_rval(ml_binop(Binop, Rval1, Rval2), !IO) :-
+ )
+ ;
+ Rval = ml_binop(Binop, RvalA, RvalB),
c_util.binop_category_string(Binop, Category, BinopStr),
( Category = int_or_bool_binary_infix_binop ->
io.write_string("(", !IO),
- write_rval(Rval1, !IO),
+ write_rval(DataRep, RvalA, !IO),
io.write_string(") ", !IO),
io.write_string(BinopStr, !IO),
io.write_string(" (", !IO),
- write_rval(Rval2, !IO),
+ write_rval(DataRep, RvalB, !IO),
io.write_string(")", !IO)
;
sorry(this_file, "binop rval")
+ )
+ ;
+ Rval = ml_mem_addr(_),
+ sorry(this_file, "mem_addr rval")
+ ;
+ Rval = ml_self(_),
+ sorry(this_file, "self rval")
).
-write_rval(ml_mem_addr(_), !IO) :-
- sorry(this_file, "mem_addr rval").
-write_rval(ml_self(_), !IO) :-
- sorry(this_file, "self rval").
:- pred write_rval_const(mlds_rval_const::in, io::di, io::uo) is det.
@@ -502,23 +495,23 @@
write_rval_const(mlconst_null(_), !IO) :-
io.write_string("null", !IO).
-:- pred write_lval(mlds_lval::in, io::di, io::uo) is det.
+:- pred write_lval(il_data_rep::in, mlds_lval::in, io::di, io::uo) is det.
-write_lval(Lval, !IO) :-
+write_lval(DataRep, Lval, !IO) :-
(
Lval = ml_field(_, Rval, FieldId, _, _),
(
FieldId = ml_field_offset(OffSet),
io.write_string("(", !IO),
- write_rval(Rval, !IO),
+ write_rval(DataRep, Rval, !IO),
io.write_string(")", !IO),
io.write_string("[", !IO),
- write_rval(OffSet, !IO),
+ write_rval(DataRep, OffSet, !IO),
io.write_string("]", !IO)
;
FieldId = ml_field_named(FQFieldName, _Type),
io.write_string("(", !IO),
- write_rval(Rval, !IO),
+ write_rval(DataRep, Rval, !IO),
io.write_string(")", !IO),
io.write_string(".", !IO),
FQFieldName = qual(_, _, FieldName),
@@ -526,7 +519,7 @@
)
;
Lval = ml_mem_ref(Rval, _),
- write_rval(Rval, !IO)
+ write_rval(DataRep, Rval, !IO)
;
Lval = ml_global_var_ref(_),
sorry(this_file, "write_lval: global_var_ref NYI")
@@ -536,15 +529,15 @@
write_mlds_var_name_for_parameter(VarName, !IO)
).
-:- pred write_defn_decl(mlds_defn::in, io::di, io::uo) is det.
+:- pred write_defn_decl(il_data_rep::in, mlds_defn::in, io::di, io::uo) is det.
-write_defn_decl(Defn, !IO) :-
+write_defn_decl(DataRep, Defn, !IO) :-
Defn = mlds_defn(Name, _Context, _Flags, DefnBody),
(
DefnBody = mlds_data(Type, _Initializer, _GCStatement),
Name = entity_data(mlds_data_var(VarName))
->
- write_parameter_type(Type, !IO),
+ write_parameter_type(DataRep, Type, !IO),
io.write_string(" ", !IO),
write_mlds_var_name_for_parameter(VarName, !IO),
io.write_string(";\n", !IO)
@@ -553,21 +546,19 @@
sorry(this_file, "data_addr_const rval")
).
-:- pred write_parameter_type(mlds_type::in, io::di, io::uo) is det.
+:- pred write_parameter_type(il_data_rep::in, mlds_type::in, io::di, io::uo)
+ is det.
-write_parameter_type(Type, !IO) :-
- get_il_data_rep(DataRep, !IO),
+write_parameter_type(DataRep, Type, !IO) :-
ILType = mlds_type_to_ilds_type(DataRep, Type),
write_il_type_as_foreign_type(ILType, !IO).
-:- pred write_input_arg_as_foreign_type(mlds_argument::in,
+:- pred write_input_arg_as_foreign_type(il_data_rep::in, mlds_argument::in,
io::di, io::uo) is det.
-write_input_arg_as_foreign_type(Arg, !IO) :-
+write_input_arg_as_foreign_type(DataRep, Arg, !IO) :-
Arg = mlds_argument(EntityName, Type, _GCStatement),
- get_il_data_rep(DataRep, !IO),
- write_il_type_as_foreign_type(mlds_type_to_ilds_type(DataRep, Type),
- !IO),
+ write_il_type_as_foreign_type(mlds_type_to_ilds_type(DataRep, Type), !IO),
io.write_string(" ", !IO),
( EntityName = entity_data(mlds_data_var(VarName)) ->
write_mlds_var_name_for_parameter(VarName, !IO)
@@ -575,10 +566,10 @@
unexpected(this_file, "found a variable in a list")
).
-:- pred write_parameter_initializer(mlds_type::in, io::di, io::uo) is det.
+:- pred write_parameter_initializer(il_data_rep::in, mlds_type::in,
+ io::di, io::uo) is det.
-write_parameter_initializer(Type, !IO) :-
- get_il_data_rep(DataRep, !IO),
+write_parameter_initializer(DataRep, Type, !IO) :-
ILType = mlds_type_to_ilds_type(DataRep, Type),
ILType = il_type(_, ILSimpleType),
write_csharp_initializer(ILSimpleType, !IO).
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.381
diff -u -b -r1.381 modes.m
--- compiler/modes.m 19 Aug 2009 07:44:55 -0000 1.381
+++ compiler/modes.m 28 Aug 2009 11:49:15 -0000
@@ -1945,7 +1945,7 @@
modecheck_ground_term_construct_goal_loop(VarSet, ConjGoals0, ConjGoals,
LocalVarMap0, LocalVarMap),
map.lookup(LocalVarMap, TermVar, TermVarInfo),
- TermVarInfo = construct_var_info(TermVarInst, _),
+ TermVarInfo = construct_var_info(TermVarInst),
instmap_delta_from_assoc_list([TermVar - TermVarInst], InstMapDelta),
goal_info_set_instmap_delta(InstMapDelta, !SubGoalInfo),
% We present the determinism, so that the determinism analysis pass
@@ -1959,7 +1959,7 @@
mode_info_set_instmap(InstMap, !ModeInfo).
:- type construct_var_info
- ---> construct_var_info(mer_inst, static_cons).
+ ---> construct_var_info(mer_inst).
:- type construct_var_info_map == map(prog_var, construct_var_info).
@@ -1983,13 +1983,13 @@
% requirements of these bound insts are only linear in the size of the
% term.
modecheck_ground_term_construct_arg_loop(RHSVars, ArgInsts, UniModes,
- StaticConss, !LocalVarMap),
+ !LocalVarMap),
BoundInst = bound_functor(ConsId, ArgInsts),
TermInst = bound(shared, [BoundInst]),
LHSMode = (free -> TermInst),
RHSMode = (TermInst -> TermInst),
UnifyMode = LHSMode - RHSMode,
- ConstructHow = construct_statically(StaticConss),
+ ConstructHow = construct_statically,
Uniqueness = cell_is_shared,
Unification = construct(LHSVar, ConsId, RHSVars, UniModes,
ConstructHow, Uniqueness, no_construct_sub_info),
@@ -2001,8 +2001,7 @@
goal_info_set_determinism(detism_det, GoalInfo1, GoalInfo),
Goal = hlds_goal(GoalExpr, GoalInfo),
- LHSVarStaticCons = static_cons(ConsId, RHSVars, StaticConss),
- LHSVarInfo = construct_var_info(TermInst, LHSVarStaticCons),
+ LHSVarInfo = construct_var_info(TermInst),
svmap.det_insert(LHSVar, LHSVarInfo, !LocalVarMap)
;
unexpected(this_file,
@@ -2012,12 +2011,12 @@
!LocalVarMap).
:- pred modecheck_ground_term_construct_arg_loop(list(prog_var)::in,
- list(mer_inst)::out, list(uni_mode)::out, list(static_cons)::out,
+ 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([], [], [], !LocalVarMap).
modecheck_ground_term_construct_arg_loop([Var | Vars], [VarInst | VarInsts],
- [UniMode | UniModes], [StaticCons | StaticConss], !LocalVarMap) :-
+ [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),
@@ -2026,14 +2025,14 @@
% 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, StaticCons),
+ 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,
- StaticConss, !LocalVarMap).
+ !LocalVarMap).
:- pred modecheck_goal_plain_call(pred_id::in, proc_id::in,
list(prog_var)::in, maybe(call_unify_context)::in, sym_name::in,
@@ -4049,7 +4048,23 @@
InstmapDelta, Context, MaybeCallUnifyContext,
hlds_goal(GoalExpr, GoalInfo), !ModeInfo)
->
- InitVarGoal = hlds_goal(GoalExpr, GoalInfo)
+ 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")
).
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.173
diff -u -b -r1.173 module_qual.m
--- compiler/module_qual.m 11 Jun 2009 07:00:16 -0000 1.173
+++ compiler/module_qual.m 28 Aug 2009 11:49:15 -0000
@@ -675,7 +675,7 @@
:- pred term_qualified_symbols(term::in, list(sym_name)::out) is semidet.
term_qualified_symbols(Term, Symbols) :-
- ( sym_name_and_args(Term, SymName, Args) ->
+ ( parse_sym_name_and_args(Term, SymName, Args) ->
SymName = qualified(_, _),
term_qualified_symbols_list(Args, Symbols0),
Symbols = [SymName | Symbols0]
Index: compiler/prog_ctgc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_ctgc.m,v
retrieving revision 1.23
diff -u -b -r1.23 prog_ctgc.m
--- compiler/prog_ctgc.m 11 Jun 2009 07:00:17 -0000 1.23
+++ compiler/prog_ctgc.m 28 Aug 2009 11:49:15 -0000
@@ -203,7 +203,7 @@
Args = [ConsTerm, ArityTerm, PosTerm]
->
(
- sym_name_and_args(ConsTerm, ConsIdName, []),
+ parse_sym_name_and_args(ConsTerm, ConsIdName, []),
ArityTerm = term.functor(term.integer(Arity), _, _),
PosTerm = term.functor(term.integer(Pos), _, _)
->
Index: compiler/prog_io_dcg.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_dcg.m,v
retrieving revision 1.47
diff -u -b -r1.47 prog_io_dcg.m
--- compiler/prog_io_dcg.m 19 Feb 2009 03:49:18 -0000 1.47
+++ compiler/prog_io_dcg.m 28 Aug 2009 11:49:15 -0000
@@ -122,7 +122,7 @@
% Next, parse it.
(
term.coerce(Term, ProgTerm),
- sym_name_and_args(ProgTerm, SymName, Args0)
+ parse_sym_name_and_args(ProgTerm, SymName, Args0)
->
% First check for the special cases:
(
Index: compiler/prog_io_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.59
diff -u -b -r1.59 prog_io_goal.m
--- compiler/prog_io_goal.m 10 Mar 2009 05:00:28 -0000 1.59
+++ compiler/prog_io_goal.m 28 Aug 2009 11:49:15 -0000
@@ -132,7 +132,7 @@
% It's not a builtin.
term.coerce(Term, ArgsTerm),
% Check for predicate calls.
- ( sym_name_and_args(ArgsTerm, SymName, Args) ->
+ ( parse_sym_name_and_args(ArgsTerm, SymName, Args) ->
GoalExpr = call_expr(SymName, Args, purity_pure)
;
% A call to a free variable, or to a number or string.
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.138
diff -u -b -r1.138 prog_io_pragma.m
--- compiler/prog_io_pragma.m 3 Dec 2008 05:01:41 -0000 1.138
+++ compiler/prog_io_pragma.m 28 Aug 2009 11:49:15 -0000
@@ -806,7 +806,7 @@
MaybeItem) :-
(
PragmaTerms = [ImportTerm],
- sym_name_and_args(ImportTerm, Import, [])
+ parse_sym_name_and_args(ImportTerm, Import, [])
->
Pragma = pragma_foreign_import_module(lang_c, Import),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
@@ -828,7 +828,7 @@
MaybeItem) :-
(
PragmaTerms = [LangTerm, ImportTerm],
- sym_name_and_args(ImportTerm, Import, [])
+ parse_sym_name_and_args(ImportTerm, Import, [])
->
( parse_foreign_language(LangTerm, Language) ->
Pragma = pragma_foreign_import_module(Language, Import),
Index: compiler/prog_io_sym_name.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_sym_name.m,v
retrieving revision 1.1
diff -u -b -r1.1 prog_io_sym_name.m
--- compiler/prog_io_sym_name.m 2 Dec 2008 04:30:25 -0000 1.1
+++ compiler/prog_io_sym_name.m 28 Aug 2009 11:49:15 -0000
@@ -31,7 +31,7 @@
% top function symbol, and a list of its argument terms. It fails
% if the input is not valid syntax for a QualifiedTerm.
%
-:- pred sym_name_and_args(term(T)::in, sym_name::out, list(term(T))::out)
+:- pred parse_sym_name_and_args(term(T)::in, sym_name::out, list(term(T))::out)
is semidet.
% parse_qualified_term(Term, _ContainingTerm, VarSet, ContextPieces,
@@ -116,7 +116,7 @@
:- import_module int.
-sym_name_and_args(Term, SymName, Args) :-
+parse_sym_name_and_args(Term, SymName, Args) :-
% The values of VarSet and ContextPieces do not matter here, since
% we succeed only if they aren't used.
VarSet = varset.init,
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.64
diff -u -b -r1.64 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 2 Dec 2008 04:30:25 -0000 1.64
+++ compiler/prog_io_typeclass.m 28 Aug 2009 11:49:15 -0000
@@ -559,7 +559,7 @@
->
Result = Result0
;
- sym_name_and_args(ConstraintTerm, ClassName, Args0)
+ parse_sym_name_and_args(ConstraintTerm, ClassName, Args0)
->
% XXX ArgsResultContextPieces = [words("In typeclass constraint:")]
ArgsResultContextPieces = [],
@@ -827,9 +827,10 @@
[PredNameTerm, ArityTerm], _)
->
(
- sym_name_and_args(PredNameTerm, PredName, []),
+ parse_sym_name_and_args(PredNameTerm, PredName, []),
ArityTerm = term.functor(term.integer(ArityInt), [], _),
- sym_name_and_args(InstanceMethodTerm, InstanceMethodName, [])
+ parse_sym_name_and_args(InstanceMethodTerm, InstanceMethodName,
+ [])
->
InstanceMethod = instance_method(pf_predicate, PredName,
instance_proc_def_name(InstanceMethodName), ArityInt,
@@ -852,9 +853,10 @@
[FuncNameTerm, ArityTerm], _)
->
(
- sym_name_and_args(FuncNameTerm, FuncName, []),
+ parse_sym_name_and_args(FuncNameTerm, FuncName, []),
ArityTerm = term.functor(term.integer(ArityInt), [], _),
- sym_name_and_args(InstanceMethodTerm, InstanceMethodName, [])
+ parse_sym_name_and_args(InstanceMethodTerm, InstanceMethodName,
+ [])
->
InstanceMethod = instance_method(pf_function, FuncName,
instance_proc_def_name(InstanceMethodName), ArityInt,
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.66
diff -u -b -r1.66 prog_io_util.m
--- compiler/prog_io_util.m 11 Jun 2009 07:00:17 -0000 1.66
+++ compiler/prog_io_util.m 28 Aug 2009 11:49:15 -0000
@@ -285,11 +285,11 @@
PredAndArgsTerm = term.functor(term.atom("="),
[FuncAndArgsTerm, FuncResultTerm], _)
->
- sym_name_and_args(FuncAndArgsTerm, SymName, ArgTerms0),
+ parse_sym_name_and_args(FuncAndArgsTerm, SymName, ArgTerms0),
PredOrFunc = pf_function,
ArgTerms = ArgTerms0 ++ [FuncResultTerm]
;
- sym_name_and_args(PredAndArgsTerm, SymName, ArgTerms),
+ parse_sym_name_and_args(PredAndArgsTerm, SymName, ArgTerms),
PredOrFunc = pf_predicate
).
@@ -612,7 +612,7 @@
;
% If the sym_name_and_args fails, we should report the error
% (we would need to call parse_qualified_term instead).
- sym_name_and_args(Term, Name, Args),
+ parse_sym_name_and_args(Term, Name, Args),
convert_inst_list(AllowConstrainedInstVar, Args, ConvertedArgs),
Mode = user_defined_mode(Name, ConvertedArgs)
).
@@ -721,7 +721,7 @@
term.coerce_var(Var)), Inst)
;
% Anything else must be a user-defined inst.
- sym_name_and_args(Term, QualifiedName, Args1),
+ parse_sym_name_and_args(Term, QualifiedName, Args1),
(
BuiltinModule = mercury_public_builtin_module,
sym_name_get_module_name_default(QualifiedName, unqualified(""),
@@ -818,7 +818,7 @@
InstTerm = term.functor(Functor, Args0, _),
(
Functor = term.atom(_),
- sym_name_and_args(InstTerm, SymName, Args1),
+ parse_sym_name_and_args(InstTerm, SymName, Args1),
list.length(Args1, Arity),
ConsId = cons(SymName, Arity, cons_id_dummy_type_ctor)
;
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.131
diff -u -b -r1.131 purity.m
--- compiler/purity.m 19 Aug 2009 07:44:57 -0000 1.131
+++ compiler/purity.m 28 Aug 2009 11:49:15 -0000
@@ -690,6 +690,10 @@
% from_ground_term_construct and other kinds, which is a pity,
% since from_ground_term_construct scopes do not need purity
% checking.
+ % XXX However, from_ground_term scopes *are* guaranteed to be
+ % conjunctions of unifications, and we could take advantage of
+ % that, e.g. by avoiding repeatedly taking the varset and vartypes
+ % out of !Info and just as repeatedly putting it back again.
( Reason = promise_solutions(_, _)
; Reason = commit(_)
; Reason = barrier(_)
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.133
diff -u -b -r1.133 quantification.m
--- compiler/quantification.m 10 Mar 2009 05:00:30 -0000 1.133
+++ compiler/quantification.m 28 Aug 2009 11:49:15 -0000
@@ -487,7 +487,7 @@
MaybeReuseVar = no,
MaybeRegionVar = yes(RegionVar0)
;
- ( How = construct_statically(_)
+ ( How = construct_statically
; How = construct_dynamically
),
MaybeSetArgs = no,
@@ -1341,7 +1341,7 @@
MaybeSetArgs = no,
insert(!.Set, RegionVar, !:Set)
;
- ( How = construct_statically(_)
+ ( How = construct_statically
; How = construct_dynamically
),
MaybeSetArgs = no
Index: compiler/rbmm.add_rbmm_goal_infos.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.add_rbmm_goal_infos.m,v
retrieving revision 1.7
diff -u -b -r1.7 rbmm.add_rbmm_goal_infos.m
--- compiler/rbmm.add_rbmm_goal_infos.m 11 Jun 2009 07:00:18 -0000 1.7
+++ compiler/rbmm.add_rbmm_goal_infos.m 28 Aug 2009 11:49:15 -0000
@@ -426,7 +426,7 @@
set.make_singleton_set(AllocatedIntoRegion), set.init),
goal_info_set_maybe_rbmm(yes(RbmmInfo), !Info)
;
- ( HowToConstruct = construct_statically(_)
+ ( HowToConstruct = construct_statically
; HowToConstruct = construct_dynamically
; HowToConstruct = reuse_cell(_)
),
Index: compiler/recompilation.check.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.check.m,v
retrieving revision 1.47
diff -u -b -r1.47 recompilation.check.m
--- compiler/recompilation.check.m 14 Aug 2009 20:37:48 -0000 1.47
+++ compiler/recompilation.check.m 28 Aug 2009 11:49:15 -0000
@@ -296,7 +296,7 @@
SubModuleTerms, _),
list.map(
(pred(Term::in, SubModule::out) is semidet :-
- sym_name_and_args(Term, SubModule, [])
+ parse_sym_name_and_args(Term, SubModule, [])
),
SubModuleTerms, SubModules)
->
@@ -366,7 +366,7 @@
conjunction_to_list(Term, Args),
(
Args = [ModuleNameTerm, SuffixTerm, TimestampTerm | MaybeOtherTerms],
- sym_name_and_args(ModuleNameTerm, ModuleName0, []),
+ parse_sym_name_and_args(ModuleNameTerm, ModuleName0, []),
SuffixTerm = term.functor(term.string(Suffix), [], _),
Timestamp = term_to_timestamp(TimestampTerm),
(
@@ -462,10 +462,10 @@
Term = term.functor(term.atom("=>"),
[QualifierTerm, ModuleNameTerm], _)
->
- sym_name_and_args(QualifierTerm, Qualifier, []),
- sym_name_and_args(ModuleNameTerm, ModuleName, [])
+ parse_sym_name_and_args(QualifierTerm, Qualifier, []),
+ parse_sym_name_and_args(ModuleNameTerm, ModuleName, [])
;
- sym_name_and_args(Term, ModuleName, []),
+ parse_sym_name_and_args(Term, ModuleName, []),
Qualifier = ModuleName
)
->
@@ -492,16 +492,16 @@
Term = term.functor(term.atom("=>"),
[QualifierTerm, MatchesTerm], _)
->
- sym_name_and_args(QualifierTerm, Qualifier, []),
+ parse_sym_name_and_args(QualifierTerm, Qualifier, []),
conjunction_to_list(MatchesTerm, MatchesList),
list.map(
(pred(MatchTerm::in, Match::out) is semidet :-
- sym_name_and_args(MatchTerm, MatchName, []),
+ parse_sym_name_and_args(MatchTerm, MatchName, []),
Match = PredId - MatchName
),
MatchesList, Matches)
;
- sym_name_and_args(Term, Qualifier, []),
+ parse_sym_name_and_args(Term, Qualifier, []),
Matches = [PredId - Qualifier]
)
->
@@ -525,7 +525,7 @@
(
Term = term.functor(term.atom("=>"),
[QualifierTerm, MatchesTerm], _),
- sym_name_and_args(QualifierTerm, Qualifier, [])
+ parse_sym_name_and_args(QualifierTerm, Qualifier, [])
->
conjunction_to_list(MatchesTerm, MatchesList),
list.map(parse_resolved_functor(Info), MatchesList, Matches),
@@ -546,7 +546,7 @@
( PredOrFuncStr = "predicate", PredOrFunc = pf_predicate
; PredOrFuncStr = "function", PredOrFunc = pf_function
),
- sym_name_and_args(ModuleTerm, ModuleName, []),
+ parse_sym_name_and_args(ModuleTerm, ModuleName, []),
ArityTerm = term.functor(term.integer(Arity), [], _)
->
PredId = invalid_pred_id,
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.66
diff -u -b -r1.66 recompilation.version.m
--- compiler/recompilation.version.m 2 Dec 2008 04:30:25 -0000 1.66
+++ compiler/recompilation.version.m 28 Aug 2009 11:49:15 -0000
@@ -1275,7 +1275,7 @@
->
ParseName =
(pred(NameTerm::in, Name::out) is semidet :-
- sym_name_and_args(NameTerm, Name, [])
+ parse_sym_name_and_args(NameTerm, Name, [])
),
map_parser(parse_item_version_number(ParseName), InstanceVNsTerms,
Result1),
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.89
diff -u -b -r1.89 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 26 Jun 2009 01:12:00 -0000 1.89
+++ compiler/rtti_to_mlds.m 28 Aug 2009 11:49:15 -0000
@@ -21,15 +21,20 @@
:- import_module backend_libs.rtti.
:- import_module hlds.hlds_module.
+:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.mlds.
:- import_module list.
%-----------------------------------------------------------------------------%
- % Return a list of MLDS definitions for the given rtti_data list.
+ % Add the MLDS definitions for the given rtti_data(s) to the
+ % ml_global_data structure.
%
-:- func rtti_data_list_to_mlds(module_info, list(rtti_data)) = list(mlds_defn).
+:- pred add_rtti_datas_to_mlds(module_info::in, list(rtti_data)::in,
+ ml_global_data::in, ml_global_data::out) is det.
+:- pred add_rtti_data_to_mlds(module_info::in, rtti_data::in,
+ ml_global_data::in, ml_global_data::out) is det.
% Given a list of MLDS RTTI data definitions (only), return the definitions
% such that if X appears in the initialiser for Y then X appears earlier in
@@ -74,62 +79,37 @@
%-----------------------------------------------------------------------------%
-rtti_data_list_to_mlds(ModuleInfo, RttiDatas) = MLDS_Defns :-
- RealRttiDatas = list.filter(real_rtti_data, RttiDatas),
- MLDS_DefnLists0 = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- MLDS_Defns0 = list.condense(MLDS_DefnLists0),
- list.filter(mlds_defn_is_potentially_duplicated, MLDS_Defns0,
- MaybeDupDefns0, NoDupDefns),
- list.sort_and_remove_dups(MaybeDupDefns0, MaybeDupDefns),
- MLDS_Defns = MaybeDupDefns ++ NoDupDefns.
-
-:- pred mlds_defn_is_potentially_duplicated(mlds_defn::in) is semidet.
-
-mlds_defn_is_potentially_duplicated(MLDS_Defn) :-
- MLDS_Defn = mlds_defn(EntityName, _, _, _),
- EntityName = entity_data(DataName),
- DataName = mlds_rtti(ctor_rtti_id(_, RttiName)),
- ( RttiName = type_ctor_type_info(_)
- ; RttiName = type_ctor_pseudo_type_info(_)
- ).
-
- % return a list of MLDS definitions for the given rtti_data.
-:- func rtti_data_to_mlds(module_info, rtti_data) = list(mlds_defn).
+add_rtti_datas_to_mlds(ModuleInfo, RttiDatas, !GlobalData) :-
+ list.foldl(add_rtti_data_to_mlds(ModuleInfo), RttiDatas, !GlobalData).
-rtti_data_to_mlds(ModuleInfo, RttiData) = MLDS_Defns :-
+add_rtti_data_to_mlds(ModuleInfo, RttiData, !GlobalData) :-
( RttiData = rtti_data_pseudo_type_info(type_var(_)) ->
% These just get represented as integers, so we don't need to define
% a structure for them; which is why rtti_data_to_id/3 does not
% handle this case.
- MLDS_Defns = []
+ true
;
- rtti_data_to_id(RttiData, RttiId),
- Name = entity_data(mlds_rtti(RttiId)),
- gen_init_rtti_data_defn(RttiData, RttiId, ModuleInfo,
- Initializer, ExtraDefns),
- rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
- MLDS_Defn),
- MLDS_Defns = [MLDS_Defn | ExtraDefns]
+ gen_init_rtti_data_defn(ModuleInfo, RttiData, !GlobalData)
).
:- pred rtti_name_and_init_to_defn(rtti_type_ctor::in, ctor_rtti_name::in,
- mlds_initializer::in, mlds_defn::out) is det.
+ mlds_initializer::in, ml_global_data::in, ml_global_data::out) is det.
-rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer, MLDS_Defn) :-
+rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer, !GlobalData) :-
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- rtti_id_and_init_to_defn(RttiId, Initializer, MLDS_Defn).
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred rtti_id_and_init_to_defn(rtti_id::in, mlds_initializer::in,
- mlds_defn::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
-rtti_id_and_init_to_defn(RttiId, Initializer, MLDS_Defn) :-
+rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData) :-
Name = entity_data(mlds_rtti(RttiId)),
- rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, MLDS_Defn).
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData).
:- pred rtti_entity_name_and_init_to_defn(mlds_entity_name::in, rtti_id::in,
- mlds_initializer::in, mlds_defn::out) is det.
+ mlds_initializer::in, ml_global_data::in, ml_global_data::out) is det.
-rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, MLDS_Defn) :-
+rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData) :-
% Generate the context.
%
% XXX The rtti_data ought to include a prog_context (the context of the
@@ -148,7 +128,9 @@
% Generate the declaration body, i.e. the type and the initializer
MLDS_Type = mlds_rtti_type(item_type(RttiId)),
DefnBody = mlds_data(MLDS_Type, Initializer, GCStatement),
- MLDS_Defn = mlds_defn(Name, MLDS_Context, Flags, DefnBody).
+ Defn = mlds_defn(Name, MLDS_Context, Flags, DefnBody),
+
+ ml_global_data_add_flat_rtti_defn(Defn, !GlobalData).
% Return the declaration flags appropriate for an rtti_data.
% Note that this must be the same as ml_static_const_decl_flags,
@@ -177,38 +159,44 @@
% Return an MLDS initializer for the given RTTI definition
% occurring in the given module.
%
-:- pred gen_init_rtti_data_defn(rtti_data::in, rtti_id::in, module_info::in,
- mlds_initializer::out, list(mlds_defn)::out) is det.
+:- pred gen_init_rtti_data_defn(module_info::in, rtti_data::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_init_rtti_data_defn(RttiData, RttiId, ModuleInfo, Init, Defns) :-
+gen_init_rtti_data_defn(ModuleInfo, RttiData, !GlobalData) :-
+ rtti_data_to_id(RttiData, RttiId),
+ Name = entity_data(mlds_rtti(RttiId)),
(
RttiData = rtti_data_base_typeclass_info(_InstanceModule, _ClassId,
_InstanceStr, BaseTypeClassInfo),
BaseTypeClassInfo = base_typeclass_info(N1, N2, N3, N4, N5, Methods),
NumExtra = BaseTypeClassInfo ^ num_extra,
list.map_foldl(gen_init_method(ModuleInfo, NumExtra),
- Methods, MethodInitializers, [], Defns),
- Init = init_array([
+ Methods, MethodInitializers, !GlobalData),
+ Initializer = init_array([
gen_init_boxed_int(N1),
gen_init_boxed_int(N2),
gen_init_boxed_int(N3),
gen_init_boxed_int(N4),
gen_init_boxed_int(N5)
| MethodInitializers
- ])
+ ]),
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
+ !GlobalData)
;
RttiData = rtti_data_type_info(TypeInfo),
- gen_type_info_defn(ModuleInfo, TypeInfo, RttiId, Init, Defns)
+ gen_type_info_defn(ModuleInfo, TypeInfo, Name, RttiId, !GlobalData)
;
RttiData = rtti_data_pseudo_type_info(PseudoTypeInfo),
- gen_pseudo_type_info_defn(ModuleInfo, PseudoTypeInfo, RttiId,
- Init, Defns)
+ gen_pseudo_type_info_defn(ModuleInfo, PseudoTypeInfo, Name, RttiId,
+ !GlobalData)
;
RttiData = rtti_data_type_class_decl(TCDecl),
- gen_type_class_decl_defn(TCDecl, RttiId, ModuleInfo, Init, Defns)
+ gen_type_class_decl_defn(ModuleInfo, TCDecl, Name, RttiId,
+ !GlobalData)
;
RttiData = rtti_data_type_class_instance(Instance),
- gen_type_class_instance_defn(Instance, RttiId, ModuleInfo, Init, Defns)
+ gen_type_class_instance_defn(ModuleInfo, Instance, Name, RttiId,
+ !GlobalData)
;
RttiData = rtti_data_type_ctor_info(TypeCtorData),
TypeCtorData = type_ctor_data(Version, TypeModule, TypeName,
@@ -220,29 +208,25 @@
FunctorsRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_type_functors),
LayoutRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_type_layout),
- some [!Defns] (
- gen_functors_layout_info(ModuleInfo, RttiTypeCtor,
- TypeCtorDetails, FunctorsInfo, LayoutInfo, NumberMapInfo,
- !:Defns),
+ gen_functors_layout_info(ModuleInfo, RttiTypeCtor, TypeCtorDetails,
+ FunctorsInfo, LayoutInfo, NumberMapInfo, !GlobalData),
% Note that gen_init_special_pred will by necessity add an extra
% level of indirection to calling the special preds. However the
% backend compiler should be smart enough to ensure that this is
% inlined away.
- gen_init_special_pred(ModuleInfo, UnifyUniv, UnifyInit, !Defns),
- gen_init_special_pred(ModuleInfo, CompareUniv, CompareInit,
- !Defns),
-
- Defns = !.Defns
- ),
+ gen_init_special_pred(ModuleInfo, UnifyUniv, UnifyInitializer,
+ !GlobalData),
+ gen_init_special_pred(ModuleInfo, CompareUniv, CompareInitializer,
+ !GlobalData),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_int(TypeArity),
gen_init_int(Version),
gen_init_int(NumPtags),
gen_init_type_ctor_rep(TypeCtorData),
- UnifyInit,
- CompareInit,
+ UnifyInitializer,
+ CompareInitializer,
gen_init_string(TypeModuleName),
gen_init_string(TypeName),
% In the C back-end, these two "structs" are actually unions.
@@ -264,15 +248,18 @@
% XXX this may need to change to call
% gen_init_special_pred, if this is re-enabled.
% gen_init_proc_id_from_univ(ModuleInfo, PrettyprinterProc)
- ])
+ ]),
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
+ !GlobalData)
).
%-----------------------------------------------------------------------------%
-:- pred gen_type_class_decl_defn(tc_decl::in, rtti_id::in, module_info::in,
- mlds_initializer::out, list(mlds_defn)::out) is det.
+:- pred gen_type_class_decl_defn(module_info::in, tc_decl::in,
+ mlds_entity_name::in, rtti_id::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_type_class_decl_defn(TCDecl, RttiId, ModuleInfo, Init, SubDefns) :-
+gen_type_class_decl_defn(ModuleInfo, TCDecl, Name, RttiId, !GlobalData) :-
TCDecl = tc_decl(TCId, Version, Supers),
TCId = tc_id(TCName, TVarNames, MethodIds),
TCName = tc_name(ModuleSymName, ClassName, Arity),
@@ -280,97 +267,90 @@
TVarNamesRttiId = tc_rtti_id(TCName, type_class_id_var_names),
(
TVarNames = [],
- TVarNameDefns = [],
- TVarNamesInit = gen_init_null_pointer(
- mlds_rtti_type(item_type(TVarNamesRttiId)))
+ TVarNamesInitType = mlds_rtti_type(item_type(TVarNamesRttiId)),
+ TVarNamesInitializer = gen_init_null_pointer(TVarNamesInitType)
;
TVarNames = [_ | _],
- gen_tc_id_var_names(TVarNamesRttiId, TVarNames, TVarNameDefn),
- TVarNameDefns = [TVarNameDefn],
- TVarNamesInit = gen_init_rtti_id(ModuleName, TVarNamesRttiId)
+ gen_tc_id_var_names(TVarNamesRttiId, TVarNames, !GlobalData),
+ TVarNamesInitializer = gen_init_rtti_id(ModuleName, TVarNamesRttiId)
),
MethodIdsRttiId = tc_rtti_id(TCName, type_class_id_method_ids),
(
MethodIds = [],
- MethodIdDefns = [],
- MethodIdsInit = gen_init_null_pointer(
- mlds_rtti_type(item_type(MethodIdsRttiId)))
+ MethodIdsInitType = mlds_rtti_type(item_type(MethodIdsRttiId)),
+ MethodIdsInitializer = gen_init_null_pointer(MethodIdsInitType)
;
MethodIds = [_ | _],
- gen_tc_id_method_ids(MethodIdsRttiId, TCName, MethodIds, MethodIdDefn),
- MethodIdDefns = [MethodIdDefn],
- MethodIdsInit = gen_init_rtti_id(ModuleName, MethodIdsRttiId)
+ gen_tc_id_method_ids(MethodIdsRttiId, TCName, MethodIds, !GlobalData),
+ MethodIdsInitializer = gen_init_rtti_id(ModuleName, MethodIdsRttiId)
),
TCIdRttiId = tc_rtti_id(TCName, type_class_id),
ModuleSymNameStr = sym_name_to_string(ModuleSymName),
list.length(TVarNames, NumTVars),
list.length(MethodIds, NumMethods),
- TCIdInit = init_struct(mlds_rtti_type(item_type(TCIdRttiId)), [
+ TCIdInitializer = init_struct(mlds_rtti_type(item_type(TCIdRttiId)), [
gen_init_string(ModuleSymNameStr),
gen_init_string(ClassName),
gen_init_int(Arity),
gen_init_int(NumTVars),
gen_init_int(NumMethods),
- TVarNamesInit,
- MethodIdsInit
+ TVarNamesInitializer,
+ MethodIdsInitializer
]),
- rtti_id_and_init_to_defn(TCIdRttiId, TCIdInit, TCIdDefn),
+ rtti_id_and_init_to_defn(TCIdRttiId, TCIdInitializer, !GlobalData),
(
- Supers = [],
- SuperDefns = [],
- SupersInit = gen_init_null_pointer(
- mlds_rtti_type(item_type(MethodIdsRttiId)))
+ Supers = []
;
Supers = [_ | _],
- list.map_foldl2(gen_tc_constraint(ModuleInfo,
- make_decl_super_id(TCName)), Supers, SuperRttiIds,
- counter.init(1), _, [], SuperConstrDefns),
+ list.map_foldl2(
+ gen_tc_constraint(ModuleInfo, make_decl_super_id(TCName)),
+ Supers, SuperRttiIds, counter.init(1), _, !GlobalData),
SuperArrayRttiName = type_class_decl_supers,
SuperArrayRttiId = tc_rtti_id(TCName, SuperArrayRttiName),
ElementType = mlds_rtti_type(element_type(SuperArrayRttiId)),
- SuperArrayInit = gen_init_array(
+ SuperArrayInitializer = gen_init_array(
gen_init_cast_rtti_id(ElementType, ModuleName), SuperRttiIds),
- rtti_id_and_init_to_defn(SuperArrayRttiId, SuperArrayInit, SuperDefn),
- SuperDefns = [SuperDefn | SuperConstrDefns],
- SupersInit = gen_init_null_pointer(
- mlds_rtti_type(item_type(MethodIdsRttiId)))
+ rtti_id_and_init_to_defn(SuperArrayRttiId, SuperArrayInitializer,
+ !GlobalData)
),
+ % XXX Is MethodIdsRttiId the right thing to take the type from?
+ SupersInitType = mlds_rtti_type(item_type(MethodIdsRttiId)),
+ SupersInitializer = gen_init_null_pointer(SupersInitType),
list.length(Supers, NumSupers),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_id(ModuleName, TCIdRttiId),
gen_init_int(Version),
gen_init_int(NumSupers),
- SupersInit
+ SupersInitializer
]),
- SubDefns = TVarNameDefns ++ MethodIdDefns ++ [TCIdDefn | SuperDefns].
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData).
-:- pred make_decl_super_id(tc_name::in, int::in, int::in, rtti_id::out)
- is det.
+:- pred make_decl_super_id(tc_name::in, int::in, int::in, rtti_id::out) is det.
make_decl_super_id(TCName, TCNum, Arity, RttiId) :-
TCRttiName = type_class_decl_super(TCNum, Arity),
RttiId = tc_rtti_id(TCName, TCRttiName).
-:- pred gen_tc_id_var_names(rtti_id::in, list(string)::in, mlds_defn::out)
- is det.
+:- pred gen_tc_id_var_names(rtti_id::in, list(string)::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_tc_id_var_names(RttiId, Names, MLDS_Defn) :-
- Init = gen_init_array(gen_init_string, Names),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
+gen_tc_id_var_names(RttiId, Names, !GlobalData) :-
+ Initializer = gen_init_array(gen_init_string, Names),
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred gen_tc_id_method_ids(rtti_id::in, tc_name::in, list(tc_method_id)::in,
- mlds_defn::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
-gen_tc_id_method_ids(RttiId, TCName, MethodIds, Defn) :-
- Init = gen_init_array(gen_tc_id_method_id(TCName), MethodIds),
- rtti_id_and_init_to_defn(RttiId, Init, Defn).
+gen_tc_id_method_ids(RttiId, TCName, MethodIds, !GlobalData) :-
+ Initializer = gen_init_array(gen_tc_id_method_id(TCName), MethodIds),
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- func gen_tc_id_method_id(tc_name, tc_method_id) = mlds_initializer.
-gen_tc_id_method_id(TCName, MethodId) = Init :-
+gen_tc_id_method_id(TCName, MethodId) = Initializer :-
MethodId = tc_method_id(MethodName, MethodArity, PredOrFunc),
RttiId = tc_rtti_id(TCName, type_class_id_method_ids),
- Init = init_struct(mlds_rtti_type(element_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(element_type(RttiId)), [
gen_init_string(MethodName),
gen_init_int(MethodArity),
gen_init_pred_or_func(PredOrFunc)
@@ -378,10 +358,12 @@
%-----------------------------------------------------------------------------%
-:- pred gen_type_class_instance_defn(tc_instance::in, rtti_id::in,
- module_info::in, mlds_initializer::out, list(mlds_defn)::out) is det.
+:- pred gen_type_class_instance_defn(module_info::in, tc_instance::in,
+ mlds_entity_name::in, rtti_id::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_type_class_instance_defn(Instance, RttiId, ModuleInfo, Init, SubDefns) :-
+gen_type_class_instance_defn(ModuleInfo, Instance, Name, RttiId,
+ !GlobalData) :-
Instance = tc_instance(TCName, Types, NumTypeVars,
InstanceConstraints, _Methods),
TCDeclRttiId = tc_rtti_id(TCName, type_class_decl),
@@ -393,29 +375,28 @@
module_info_get_name(ModuleInfo, ModuleName),
TypeRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data, Types),
- gen_pseudo_type_info_array(ModuleInfo, TypeRttiDatas, TypesInit,
- TypesDefns),
- rtti_id_and_init_to_defn(InstanceTypesRttiId, TypesInit, TypesDefn),
-
- list.map_foldl2(gen_tc_constraint(ModuleInfo,
- make_instance_constr_id(TCName, Types)),
- InstanceConstraints, TCConstrIds, counter.init(1), _,
- [], TCConstrDefns),
+ gen_pseudo_type_info_array(ModuleInfo, TypeRttiDatas, TypesInitializer,
+ !GlobalData),
+ rtti_id_and_init_to_defn(InstanceTypesRttiId, TypesInitializer,
+ !GlobalData),
+
+ list.map_foldl2(
+ gen_tc_constraint(ModuleInfo, make_instance_constr_id(TCName, Types)),
+ InstanceConstraints, TCConstrIds, counter.init(1), _, !GlobalData),
ElementType = mlds_rtti_type(element_type(InstanceConstrsRttiId)),
- InstanceConstrsInit = gen_init_array(
+ InstanceConstrsInitializer = gen_init_array(
gen_init_cast_rtti_id(ElementType, ModuleName), TCConstrIds),
- rtti_id_and_init_to_defn(InstanceConstrsRttiId, InstanceConstrsInit,
- InstanceConstrsDefn),
+ rtti_id_and_init_to_defn(InstanceConstrsRttiId, InstanceConstrsInitializer,
+ !GlobalData),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_id(ModuleName, TCDeclRttiId),
gen_init_int(NumTypeVars),
gen_init_int(NumInstanceConstraints),
gen_init_rtti_id(ModuleName, InstanceTypesRttiId),
gen_init_rtti_id(ModuleName, InstanceConstrsRttiId)
]),
- SubDefns = TypesDefns ++ [TypesDefn | TCConstrDefns] ++
- [InstanceConstrsDefn].
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData).
:- pred make_instance_constr_id(tc_name::in, list(tc_type)::in,
int::in, int::in, rtti_id::out) is det.
@@ -426,80 +407,148 @@
%-----------------------------------------------------------------------------%
-:- pred gen_type_info_defn(module_info::in, rtti_type_info::in, rtti_id::in,
- mlds_initializer::out, list(mlds_defn)::out) is det.
+:- pred gen_type_info_defn(module_info::in, rtti_type_info::in,
+ mlds_entity_name::in, rtti_id::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_type_info_defn(ModuleInfo, RttiTypeInfo, RttiId, Init, Defns) :-
+gen_type_info_defn(ModuleInfo, RttiTypeInfo, Name, RttiId, !GlobalData) :-
(
RttiTypeInfo = plain_arity_zero_type_info(_),
unexpected(this_file, "gen_type_info_defn: plain_arity_zero_type_info")
;
RttiTypeInfo = plain_type_info(RttiTypeCtor, ArgTypes),
+ ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
+ ( map.search(PDupRvalTypeMap, RttiId, _) ->
+ % We have already generated the required global data structures.
+ true
+ ;
ArgRttiDatas = list.map(type_info_to_rtti_data, ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
- DefnsList = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- Defns = list.condense(DefnsList),
+ list.foldl(add_rtti_data_to_mlds(ModuleInfo), RealRttiDatas,
+ !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
gen_init_cast_rtti_datas_array(mlds_type_info_type,
ModuleName, ArgRttiDatas)
- ])
+ ]),
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
+ !GlobalData),
+
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId)),
+ RvalType = ml_rval_and_type(Rval, Type),
+
+ ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
+ )
;
RttiTypeInfo = var_arity_type_info(VarArityId, ArgTypes),
+ ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
+ ( map.search(PDupRvalTypeMap, RttiId, _) ->
+ % We have already generated the required global data structures.
+ true
+ ;
ArgRttiDatas = list.map(type_info_to_rtti_data, ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
- DefnsList = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- Defns = list.condense(DefnsList),
+ list.foldl(add_rtti_data_to_mlds(ModuleInfo), RealRttiDatas,
+ !GlobalData),
RttiTypeCtor = var_arity_id_to_rtti_type_ctor(VarArityId),
module_info_get_name(ModuleInfo, ModuleName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
gen_init_int(list.length(ArgTypes)),
gen_init_cast_rtti_datas_array(mlds_type_info_type,
ModuleName, ArgRttiDatas)
- ])
+ ]),
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
+ !GlobalData),
+
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId)),
+ RvalType = ml_rval_and_type(Rval, Type),
+
+ ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
+ )
).
:- pred gen_pseudo_type_info_defn(module_info::in, rtti_pseudo_type_info::in,
- rtti_id::in, mlds_initializer::out, list(mlds_defn)::out) is det.
+ mlds_entity_name::in, rtti_id::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_pseudo_type_info_defn(ModuleInfo, RttiPseudoTypeInfo, RttiId,
- Init, Defns) :-
+gen_pseudo_type_info_defn(ModuleInfo, RttiPseudoTypeInfo, Name, RttiId,
+ !GlobalData) :-
(
RttiPseudoTypeInfo = plain_arity_zero_pseudo_type_info(_),
unexpected(this_file,
"gen_pseudo_type_info_defn: plain_arity_zero_pseudo_type_info")
;
RttiPseudoTypeInfo = plain_pseudo_type_info(RttiTypeCtor, ArgTypes),
- ArgRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data, ArgTypes),
+ ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
+ ( map.search(PDupRvalTypeMap, RttiId, _) ->
+ % We have already generated the required global data structures.
+ true
+ ;
+ ArgRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data,
+ ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
- DefnsList = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- Defns = list.condense(DefnsList),
+ list.foldl(add_rtti_data_to_mlds(ModuleInfo), RealRttiDatas,
+ !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
gen_init_cast_rtti_datas_array(mlds_pseudo_type_info_type,
ModuleName, ArgRttiDatas)
- ])
+ ]),
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
+ !GlobalData),
+
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId)),
+ RvalType = ml_rval_and_type(Rval, Type),
+
+ ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
+ )
;
RttiPseudoTypeInfo = var_arity_pseudo_type_info(VarArityId, ArgTypes),
- ArgRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data, ArgTypes),
+ ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
+ ( map.search(PDupRvalTypeMap, RttiId, _) ->
+ % We have already generated the required global data structures.
+ true
+ ;
+ ArgRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data,
+ ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
- DefnsList = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- Defns = list.condense(DefnsList),
+ list.foldl(add_rtti_data_to_mlds(ModuleInfo), RealRttiDatas,
+ !GlobalData),
RttiTypeCtor = var_arity_id_to_rtti_type_ctor(VarArityId),
module_info_get_name(ModuleInfo, ModuleName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
gen_init_int(list.length(ArgTypes)),
gen_init_cast_rtti_datas_array(mlds_pseudo_type_info_type,
ModuleName, ArgRttiDatas)
- ])
+ ]),
+ rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
+ !GlobalData),
+
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ DataAddr = data_addr(MLDS_ModuleName, mlds_rtti(RttiId)),
+ Rval = ml_const(mlconst_data_addr(DataAddr)),
+ Type = mlds_rtti_type(item_type(RttiId)),
+ RvalType = ml_rval_and_type(Rval, Type),
+
+ ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
+ )
;
RttiPseudoTypeInfo = type_var(_),
unexpected(this_file, "gen_pseudo_type_info_defn: type_var")
@@ -509,168 +558,161 @@
:- pred gen_functors_layout_info(module_info::in, rtti_type_ctor::in,
type_ctor_details::in, mlds_initializer::out, mlds_initializer::out,
- mlds_initializer::out, list(mlds_defn)::out) is det.
+ mlds_initializer::out, ml_global_data::in, ml_global_data::out) is det.
gen_functors_layout_info(ModuleInfo, RttiTypeCtor, TypeCtorDetails,
- FunctorInit, LayoutInit, NumberMapInit, Defns) :-
+ FunctorInitializer, LayoutInitializer, NumberMapInitializer,
+ !GlobalData) :-
module_info_get_name(ModuleInfo, ModuleName),
(
TypeCtorDetails = tcd_enum(_, EnumFunctors, EnumByValue, EnumByName,
_IsDummy, FunctorNumberMap),
- EnumFunctorDescs = list.map(
- gen_enum_functor_desc(ModuleInfo, RttiTypeCtor), EnumFunctors),
- ByValueDefn = gen_enum_value_ordered_table(ModuleInfo,
- RttiTypeCtor, EnumByValue),
- ByNameDefn = gen_enum_name_ordered_table(ModuleInfo,
- RttiTypeCtor, EnumByName),
- NumberMapDefn = gen_functor_number_map(RttiTypeCtor, FunctorNumberMap),
- LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ list.foldl(gen_enum_functor_desc(ModuleInfo, RttiTypeCtor),
+ EnumFunctors, !GlobalData),
+ gen_enum_value_ordered_table(ModuleInfo, RttiTypeCtor,
+ EnumByValue, !GlobalData),
+ gen_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
+ EnumByName, !GlobalData),
+ gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
+ LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_value_ordered_table),
- FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_name_ordered_table),
- NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_functor_number_map),
- Defns = [ByValueDefn, ByNameDefn, NumberMapDefn | EnumFunctorDescs]
+ NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map)
;
TypeCtorDetails = tcd_foreign_enum(ForeignEnumLang, _,
ForeignEnumFunctors, ForeignEnumByOrdinal, ForeignEnumByName,
FunctorNumberMap),
- ForeignEnumFunctorDescs = list.map(
+ list.foldl(
gen_foreign_enum_functor_desc(ModuleInfo, ForeignEnumLang,
RttiTypeCtor),
- ForeignEnumFunctors),
- ByOrdinalDefn = gen_foreign_enum_ordinal_ordered_table(ModuleInfo,
- RttiTypeCtor, ForeignEnumByOrdinal),
- ByNameDefn = gen_foreign_enum_name_ordered_table(ModuleInfo,
- RttiTypeCtor, ForeignEnumByName),
- NumberMapDefn = gen_functor_number_map(RttiTypeCtor, FunctorNumberMap),
- LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ ForeignEnumFunctors, !GlobalData),
+ gen_foreign_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
+ ForeignEnumByOrdinal, !GlobalData),
+ gen_foreign_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
+ ForeignEnumByName, !GlobalData),
+ gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
+ LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_foreign_enum_ordinal_ordered_table),
- FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_foreign_enum_name_ordered_table),
- NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_functor_number_map),
- Defns = [ByOrdinalDefn, ByNameDefn, NumberMapDefn |
- ForeignEnumFunctorDescs]
+ NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map)
;
TypeCtorDetails = tcd_du(_, DuFunctors, DuByPtag, DuByName,
FunctorNumberMap),
- DuFunctorDefns = list.map(
- gen_du_functor_desc(ModuleInfo, RttiTypeCtor), DuFunctors),
- ByPtagDefns = gen_du_ptag_ordered_table(ModuleInfo,
- RttiTypeCtor, DuByPtag),
- ByNameDefn = gen_du_name_ordered_table(ModuleInfo,
- RttiTypeCtor, DuByName),
- NumberMapDefn = gen_functor_number_map(RttiTypeCtor, FunctorNumberMap),
- LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ list.foldl(gen_du_functor_desc(ModuleInfo, RttiTypeCtor), DuFunctors,
+ !GlobalData),
+ gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor,
+ DuByPtag, !GlobalData),
+ gen_du_name_ordered_table(ModuleInfo, RttiTypeCtor,
+ DuByName, !GlobalData),
+ gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
+ LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_ptag_ordered_table),
- FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_name_ordered_table),
- NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_functor_number_map),
- Defns = list.condense(DuFunctorDefns) ++
- [ByNameDefn, NumberMapDefn | ByPtagDefns]
+ NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map)
;
TypeCtorDetails = tcd_reserved(_, MaybeResFunctors, ResFunctors,
DuByPtag, MaybeResByName, FunctorNumberMap),
- MaybeResFunctorDefns = list.map(
- gen_maybe_res_functor_desc(ModuleInfo, RttiTypeCtor),
- MaybeResFunctors),
- ByValueDefns = gen_maybe_res_value_ordered_table(ModuleInfo,
- RttiTypeCtor, ResFunctors, DuByPtag),
- ByNameDefn = gen_maybe_res_name_ordered_table(ModuleInfo,
- RttiTypeCtor, MaybeResByName),
- NumberMapDefn = gen_functor_number_map(RttiTypeCtor, FunctorNumberMap),
- LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ list.foldl(gen_maybe_res_functor_desc(ModuleInfo, RttiTypeCtor),
+ MaybeResFunctors, !GlobalData),
+ gen_maybe_res_value_ordered_table(ModuleInfo, RttiTypeCtor,
+ ResFunctors, DuByPtag, !GlobalData),
+ gen_maybe_res_name_ordered_table(ModuleInfo, RttiTypeCtor,
+ MaybeResByName, !GlobalData),
+ gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
+ LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_res_value_ordered_table),
- FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_res_name_ordered_table),
- NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_functor_number_map),
- Defns = [ByNameDefn, NumberMapDefn | ByValueDefns] ++
- list.condense(MaybeResFunctorDefns)
+ NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_functor_number_map)
;
TypeCtorDetails = tcd_notag(_, NotagFunctor),
- NumberMapDefn = gen_functor_number_map(RttiTypeCtor, [0]),
- LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ gen_functor_number_map(RttiTypeCtor, [0], !GlobalData),
+ LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_notag_functor_desc),
- FunctorInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_notag_functor_desc),
- NumberMapInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_functor_number_map),
- FunctorDefn = gen_notag_functor_desc(ModuleInfo, RttiTypeCtor,
- NotagFunctor),
- Defns = [NumberMapDefn | FunctorDefn]
+ gen_notag_functor_desc(ModuleInfo, RttiTypeCtor, NotagFunctor,
+ !GlobalData)
;
TypeCtorDetails = tcd_eqv(EqvType),
TypeRttiData = maybe_pseudo_type_info_to_rtti_data(EqvType),
- gen_pseudo_type_info(ModuleInfo, TypeRttiData, LayoutInit, Defns),
+ gen_pseudo_type_info(ModuleInfo, TypeRttiData, LayoutInitializer,
+ !GlobalData),
% The type is a lie, but a safe one.
- FunctorInit = gen_init_null_pointer(mlds_generic_type),
- NumberMapInit = gen_init_null_pointer(mlds_generic_type)
+ FunctorInitializer = gen_init_null_pointer(mlds_generic_type),
+ NumberMapInitializer = gen_init_null_pointer(mlds_generic_type)
;
( TypeCtorDetails = tcd_builtin(_)
; TypeCtorDetails = tcd_impl_artifact(_)
; TypeCtorDetails = tcd_foreign(_)
),
- Defns = [],
- LayoutInit = gen_init_null_pointer(mlds_generic_type),
- FunctorInit = gen_init_null_pointer(mlds_generic_type),
- NumberMapInit = gen_init_null_pointer(mlds_generic_type)
+ LayoutInitializer = gen_init_null_pointer(mlds_generic_type),
+ FunctorInitializer = gen_init_null_pointer(mlds_generic_type),
+ NumberMapInitializer = gen_init_null_pointer(mlds_generic_type)
).
%-----------------------------------------------------------------------------%
-:- func gen_enum_functor_desc(module_info, rtti_type_ctor, enum_functor)
- = mlds_defn.
+:- pred gen_enum_functor_desc(module_info::in, rtti_type_ctor::in,
+ enum_functor::in, ml_global_data::in, ml_global_data::out) is det.
-gen_enum_functor_desc(_ModuleInfo, RttiTypeCtor, EnumFunctor) = MLDS_Defn :-
+gen_enum_functor_desc(_ModuleInfo, RttiTypeCtor, EnumFunctor, !GlobalData) :-
EnumFunctor = enum_functor(FunctorName, Ordinal),
RttiName = type_ctor_enum_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_string(FunctorName),
gen_init_int(Ordinal)
]),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
-:- func gen_foreign_enum_functor_desc(module_info, foreign_language,
- rtti_type_ctor, foreign_enum_functor) = mlds_defn.
+:- pred gen_foreign_enum_functor_desc(module_info::in, foreign_language::in,
+ rtti_type_ctor::in, foreign_enum_functor::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_foreign_enum_functor_desc(_ModuleInfo, Lang,
- RttiTypeCtor, ForeignEnumFunctor) = MLDS_Defn :-
+gen_foreign_enum_functor_desc(_ModuleInfo, Lang, RttiTypeCtor,
+ ForeignEnumFunctor, !GlobalData) :-
ForeignEnumFunctor = foreign_enum_functor(FunctorName, Ordinal, Value),
RttiName = type_ctor_foreign_enum_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_string(FunctorName),
gen_init_int(Ordinal),
gen_init_foreign(Lang, Value)
]),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
-:- func gen_notag_functor_desc(module_info, rtti_type_ctor, notag_functor)
- = list(mlds_defn).
+:- pred gen_notag_functor_desc(module_info::in, rtti_type_ctor::in,
+ notag_functor::in, ml_global_data::in, ml_global_data::out) is det.
-gen_notag_functor_desc(ModuleInfo, RttiTypeCtor, NotagFunctorDesc)
- = MLDS_Defns :-
+gen_notag_functor_desc(ModuleInfo, RttiTypeCtor, NotagFunctorDesc,
+ !GlobalData) :-
NotagFunctorDesc = notag_functor(FunctorName, ArgType, MaybeArgName),
ArgTypeRttiData = maybe_pseudo_type_info_to_rtti_data(ArgType),
- gen_pseudo_type_info(ModuleInfo, ArgTypeRttiData, PTIInit, SubDefns),
+ gen_pseudo_type_info(ModuleInfo, ArgTypeRttiData, PTIInitializer,
+ !GlobalData),
RttiName = type_ctor_notag_functor_desc,
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_string(FunctorName),
- PTIInit,
+ PTIInitializer,
gen_init_maybe(ml_string_type, gen_init_string, MaybeArgName)
]),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn),
- MLDS_Defns = [MLDS_Defn | SubDefns].
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
-:- func gen_du_functor_desc(module_info, rtti_type_ctor, du_functor)
- = list(mlds_defn).
+:- pred gen_du_functor_desc(module_info::in, rtti_type_ctor::in,
+ du_functor::in, ml_global_data::in, ml_global_data::out) is det.
-gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor) = MLDS_Defns :-
+gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData) :-
DuFunctor = du_functor(FunctorName, Arity, Ordinal, Rep, ArgInfos,
MaybeExistInfo),
ArgTypes = list.map(du_arg_info_type, ArgInfos),
@@ -680,44 +722,40 @@
module_info_get_name(ModuleInfo, ModuleName),
(
ArgInfos = [_ | _],
- ArgTypeDefns = gen_field_types(ModuleInfo, RttiTypeCtor,
- Ordinal, ArgTypes),
- ArgTypeInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ gen_field_types(ModuleInfo, RttiTypeCtor, Ordinal, ArgTypes,
+ !GlobalData),
+ ArgTypeInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_field_types(Ordinal))
;
ArgInfos = [],
- ArgTypeDefns = [],
- ArgTypeInit = gen_init_null_pointer(
+ ArgTypeInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_field_types(0)))))
),
(
ArgNames = [_ | _],
- ArgNameDefns = [gen_field_names(ModuleInfo, RttiTypeCtor,
- Ordinal, MaybeArgNames)],
- ArgNameInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ gen_field_names(ModuleInfo, RttiTypeCtor, Ordinal,
+ MaybeArgNames, !GlobalData),
+ ArgNameInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_field_names(Ordinal))
;
ArgNames = [],
- ArgNameDefns = [],
- ArgNameInit = gen_init_null_pointer(
+ ArgNameInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_field_names(0)))))
),
(
MaybeExistInfo = yes(ExistInfo),
- ExistInfoDefns = gen_exist_info(ModuleInfo, RttiTypeCtor,
- Ordinal, ExistInfo),
- ExistInfoInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ gen_exist_info(ModuleInfo, RttiTypeCtor, Ordinal, ExistInfo,
+ !GlobalData),
+ ExistInfoInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_exist_info(Ordinal))
;
MaybeExistInfo = no,
- ExistInfoDefns = [],
- ExistInfoInit = gen_init_null_pointer(
+ ExistInfoInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_exist_info(0)))))
),
- SubDefns = ArgTypeDefns ++ ArgNameDefns ++ ExistInfoDefns,
(
Rep = du_ll_rep(Ptag, SectagAndLocn)
;
@@ -737,7 +775,7 @@
),
RttiName = type_ctor_du_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_string(FunctorName),
gen_init_int(Arity),
gen_init_int(ContainsVarBitVector),
@@ -745,40 +783,39 @@
gen_init_int(Ptag),
gen_init_int(Stag),
gen_init_int(Ordinal),
- ArgTypeInit,
- ArgNameInit,
- ExistInfoInit
+ ArgTypeInitializer,
+ ArgNameInitializer,
+ ExistInfoInitializer
]),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn),
- MLDS_Defns = [MLDS_Defn | SubDefns].
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
-:- func gen_res_addr_functor_desc(module_info, rtti_type_ctor,
- reserved_functor) = mlds_defn.
+:- pred gen_res_addr_functor_desc(module_info::in, rtti_type_ctor::in,
+ reserved_functor::in, ml_global_data::in, ml_global_data::out) is det.
-gen_res_addr_functor_desc(ModuleInfo, RttiTypeCtor, ResFunctor) = MLDS_Defn :-
+gen_res_addr_functor_desc(ModuleInfo, RttiTypeCtor, ResFunctor, !GlobalData) :-
ResFunctor = reserved_functor(FunctorName, Ordinal, ReservedAddress),
RttiName = type_ctor_res_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_string(FunctorName),
gen_init_int(Ordinal),
gen_init_reserved_address(ModuleInfo, ReservedAddress)
]),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
-:- func gen_maybe_res_functor_desc(module_info, rtti_type_ctor,
- maybe_reserved_functor) = list(mlds_defn).
+:- pred gen_maybe_res_functor_desc(module_info::in, rtti_type_ctor::in,
+ maybe_reserved_functor::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_maybe_res_functor_desc(ModuleInfo, RttiTypeCtor, MaybeResFunctor)
- = MLDS_Defns :-
+gen_maybe_res_functor_desc(ModuleInfo, RttiTypeCtor, MaybeResFunctor,
+ !GlobalData) :-
(
MaybeResFunctor = res_func(ResFunctor),
- MLDS_Defn = gen_res_addr_functor_desc(ModuleInfo, RttiTypeCtor,
- ResFunctor),
- MLDS_Defns = [MLDS_Defn]
+ gen_res_addr_functor_desc(ModuleInfo, RttiTypeCtor, ResFunctor,
+ !GlobalData)
;
MaybeResFunctor = du_func(DuFunctor),
- MLDS_Defns = gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor)
+ gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData)
).
%-----------------------------------------------------------------------------%
@@ -786,7 +823,7 @@
:- func gen_init_exist_locn(rtti_type_ctor, exist_typeinfo_locn) =
mlds_initializer.
-gen_init_exist_locn(RttiTypeCtor, ExistTypeInfoLocn) = Init :-
+gen_init_exist_locn(RttiTypeCtor, ExistTypeInfoLocn) = Initializer :-
(
ExistTypeInfoLocn = typeinfo_in_tci(SlotInCell, SlotInTci)
;
@@ -794,26 +831,29 @@
SlotInTci = -1
),
RttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_exist_locn),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_int(SlotInCell),
gen_init_int(SlotInTci)
]).
-:- func gen_exist_locns_array(module_info, rtti_type_ctor, int,
- list(exist_typeinfo_locn)) = mlds_defn.
+:- pred gen_exist_locns_array(module_info::in, rtti_type_ctor::in, int::in,
+ list(exist_typeinfo_locn)::in, ml_global_data::in, ml_global_data::out)
+ is det.
-gen_exist_locns_array(_ModuleInfo, RttiTypeCtor, Ordinal, Locns) = MLDS_Defn :-
- Init = gen_init_array(gen_init_exist_locn(RttiTypeCtor), Locns),
+gen_exist_locns_array(_ModuleInfo, RttiTypeCtor, Ordinal, Locns,
+ !GlobalData) :-
+ Initializer = gen_init_array(gen_init_exist_locn(RttiTypeCtor), Locns),
RttiName = type_ctor_exist_locns(Ordinal),
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
:- pred gen_tc_constraint(module_info::in,
pred(int, int, rtti_id)::in(pred(in, in, out) is det),
tc_constraint::in, rtti_id::out, counter::in, counter::out,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
gen_tc_constraint(ModuleInfo, MakeRttiId, Constraint, RttiId, !Counter,
- !Defns) :-
+ !GlobalData) :-
Constraint = tc_constraint(TCName, Types),
list.length(Types, Arity),
counter.allocate(TCNum, !Counter),
@@ -821,13 +861,13 @@
TCDeclRttiName = type_class_decl,
module_info_get_name(ModuleInfo, ModuleName),
TypeRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data, Types),
- gen_pseudo_type_info_array(ModuleInfo, TypeRttiDatas, PTIInits, PTIDefns),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ gen_pseudo_type_info_array(ModuleInfo, TypeRttiDatas, PTIInitializers,
+ !GlobalData),
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_tc_rtti_name(ModuleName, TCName, TCDeclRttiName),
- PTIInits
+ PTIInitializers
]),
- rtti_id_and_init_to_defn(RttiId, Init, ConstrDefn),
- !:Defns = !.Defns ++ [ConstrDefn | PTIDefns].
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred make_exist_tc_constr_id(rtti_type_ctor::in, int::in, int::in, int::in,
rtti_id::out) is det.
@@ -836,10 +876,10 @@
RttiName = type_ctor_exist_tc_constr(Ordinal, TCNum, Arity),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName).
-:- func gen_exist_info(module_info, rtti_type_ctor, int, exist_info)
- = list(mlds_defn).
+:- pred gen_exist_info(module_info::in, rtti_type_ctor::in, int::in,
+ exist_info::in, ml_global_data::in, ml_global_data::out) is det.
-gen_exist_info(ModuleInfo, RttiTypeCtor, Ordinal, ExistInfo) = MLDS_Defns :-
+gen_exist_info(ModuleInfo, RttiTypeCtor, Ordinal, ExistInfo, !GlobalData) :-
ExistInfo = exist_info(Plain, InTci, Constraints, Locns),
module_info_get_name(ModuleInfo, ModuleName),
RttiName = type_ctor_exist_info(Ordinal),
@@ -847,128 +887,137 @@
list.length(Constraints, Tci),
(
Constraints = [],
- ConstrInit = gen_init_null_pointer(
+ ConstrInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(ctor_rtti_id(RttiTypeCtor,
- type_ctor_exist_tc_constrs(Ordinal))))),
- ConstrDefns = []
+ type_ctor_exist_tc_constrs(Ordinal)))))
;
Constraints = [_ | _],
- ConstrInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ ConstrInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_exist_tc_constrs(Ordinal)),
- list.map_foldl2(gen_tc_constraint(ModuleInfo,
+ list.map_foldl2(
+ gen_tc_constraint(ModuleInfo,
make_exist_tc_constr_id(RttiTypeCtor, Ordinal)),
- Constraints, TCConstrIds, counter.init(1), _,
- [], TCConstrDefns),
+ Constraints, TCConstrIds, counter.init(1), _, !GlobalData),
TCConstrArrayRttiName = type_ctor_exist_tc_constrs(Ordinal),
TCConstrArrayRttiId = ctor_rtti_id(RttiTypeCtor,
TCConstrArrayRttiName),
ElementType = mlds_rtti_type(element_type(TCConstrArrayRttiId)),
- TCConstrArrayInit = gen_init_array(
+ TCConstrArrayInitializer = gen_init_array(
gen_init_cast_rtti_id(ElementType, ModuleName), TCConstrIds),
rtti_name_and_init_to_defn(RttiTypeCtor, TCConstrArrayRttiName,
- TCConstrArrayInit, TCConstrArrayDefn),
- ConstrDefns = [TCConstrArrayDefn | TCConstrDefns]
+ TCConstrArrayInitializer, !GlobalData)
),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ gen_exist_locns_array(ModuleInfo, RttiTypeCtor, Ordinal, Locns,
+ !GlobalData),
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_int(Plain),
gen_init_int(InTci),
gen_init_int(Tci),
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_exist_locns(Ordinal)),
- ConstrInit
+ ConstrInitializer
]),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn),
- LocnsDefn = gen_exist_locns_array(ModuleInfo, RttiTypeCtor, Ordinal,
- Locns),
- MLDS_Defns = [MLDS_Defn, LocnsDefn | ConstrDefns].
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
+
+:- pred gen_field_types(module_info::in, rtti_type_ctor::in, int::in,
+ list(rtti_maybe_pseudo_type_info_or_self)::in,
+ ml_global_data::in, ml_global_data::out) is det.
+
+gen_field_types(ModuleInfo, RttiTypeCtor, Ordinal, Types, !GlobalData) :-
+ TypeRttiDatas = list.map(maybe_pseudo_type_info_or_self_to_rtti_data,
+ Types),
+ gen_pseudo_type_info_array(ModuleInfo, TypeRttiDatas, Initializer,
+ !GlobalData),
+ RttiName = type_ctor_field_types(Ordinal),
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_field_names(module_info, rtti_type_ctor, int, list(maybe(string)))
- = mlds_defn.
+:- pred gen_field_names(module_info::in, rtti_type_ctor::in, int::in,
+ list(maybe(string))::in, ml_global_data::in, ml_global_data::out) is det.
-gen_field_names(_ModuleInfo, RttiTypeCtor, Ordinal, MaybeNames) = MLDS_Defn :-
+gen_field_names(_ModuleInfo, RttiTypeCtor, Ordinal, MaybeNames, !GlobalData) :-
StrType = builtin_type(builtin_type_string),
- Init = gen_init_array(
+ Initializer = gen_init_array(
gen_init_maybe(
mercury_type(StrType, ctor_cat_builtin(cat_builtin_string),
non_foreign_type(StrType)),
gen_init_string),
MaybeNames),
RttiName = type_ctor_field_names(Ordinal),
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
-
-:- func gen_field_types(module_info, rtti_type_ctor, int,
- list(rtti_maybe_pseudo_type_info_or_self)) = list(mlds_defn).
-
-gen_field_types(ModuleInfo, RttiTypeCtor, Ordinal, Types) = MLDS_Defns :-
- TypeRttiDatas = list.map(maybe_pseudo_type_info_or_self_to_rtti_data,
- Types),
- gen_pseudo_type_info_array(ModuleInfo, TypeRttiDatas, Init, SubDefns),
- RttiName = type_ctor_field_types(Ordinal),
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn),
- MLDS_Defns = [MLDS_Defn | SubDefns].
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
%-----------------------------------------------------------------------------%
-:- func gen_enum_value_ordered_table(module_info, rtti_type_ctor,
- map(int, enum_functor)) = mlds_defn.
+:- pred gen_enum_value_ordered_table(module_info::in, rtti_type_ctor::in,
+ map(int, enum_functor)::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_enum_value_ordered_table(ModuleInfo, RttiTypeCtor, EnumByValue)
- = MLDS_Defn :-
+gen_enum_value_ordered_table(ModuleInfo, RttiTypeCtor, EnumByValue,
+ !GlobalData) :-
map.values(EnumByValue, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(enum_functor_rtti_name, Functors),
- Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_enum_value_ordered_table,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_enum_name_ordered_table(module_info, rtti_type_ctor,
- map(string, enum_functor)) = mlds_defn.
+:- pred gen_enum_name_ordered_table(module_info::in, rtti_type_ctor::in,
+ map(string, enum_functor)::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_enum_name_ordered_table(ModuleInfo, RttiTypeCtor, EnumByName)
- = MLDS_Defn :-
+gen_enum_name_ordered_table(ModuleInfo, RttiTypeCtor, EnumByName,
+ !GlobalData) :-
map.values(EnumByName, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(enum_functor_rtti_name, Functors),
- Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_enum_name_ordered_table,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_foreign_enum_ordinal_ordered_table(module_info, rtti_type_ctor,
- map(int, foreign_enum_functor)) = mlds_defn.
+:- pred gen_foreign_enum_ordinal_ordered_table(module_info::in,
+ rtti_type_ctor::in, map(int, foreign_enum_functor)::in,
+ ml_global_data::in, ml_global_data::out) is det.
gen_foreign_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
- ForeignEnumByOrdinal) = MLDS_Defn :-
+ ForeignEnumByOrdinal, !GlobalData) :-
map.values(ForeignEnumByOrdinal, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
- Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_foreign_enum_ordinal_ordered_table,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_foreign_enum_name_ordered_table(module_info, rtti_type_ctor,
- map(string, foreign_enum_functor)) = mlds_defn.
+:- pred gen_foreign_enum_name_ordered_table(module_info::in,
+ rtti_type_ctor::in, map(string, foreign_enum_functor)::in,
+ ml_global_data::in, ml_global_data::out) is det.
gen_foreign_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
- ForeignEnumByName) = MLDS_Defn :-
+ ForeignEnumByName, !GlobalData) :-
map.values(ForeignEnumByName, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
- Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_foreign_enum_name_ordered_table,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_du_ptag_ordered_table(module_info, rtti_type_ctor,
- map(int, sectag_table)) = list(mlds_defn).
+:- pred gen_du_ptag_ordered_table(module_info::in, rtti_type_ctor::in,
+ map(int, sectag_table)::in, ml_global_data::in, ml_global_data::out)
+ is det.
-gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor, PtagMap) = MLDS_Defns :-
+gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor, PtagMap, !GlobalData) :-
module_info_get_name(ModuleInfo, ModuleName),
map.to_assoc_list(PtagMap, PtagList),
- SubDefns = list.map(gen_du_stag_ordered_table(ModuleName, RttiTypeCtor),
- PtagList),
+ list.foldl(gen_du_stag_ordered_table(ModuleName, RttiTypeCtor), PtagList,
+ !GlobalData),
(
PtagList = [],
PtagInitPrefix = [],
@@ -996,145 +1045,155 @@
unexpected(this_file, "gen_du_ptag_ordered_table: bad ptag list")
)
),
- PtagInits = gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor,
+ PtagInitializers = gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor,
PtagList, FirstPtag),
RttiName = type_ctor_du_ptag_ordered_table,
- Init = init_array(PtagInitPrefix ++ PtagInits),
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn),
- MLDS_Defns = [MLDS_Defn | SubDefns].
+ Initializer = init_array(PtagInitPrefix ++ PtagInitializers),
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
:- func gen_du_ptag_ordered_table_body(module_name, rtti_type_ctor,
assoc_list(int, sectag_table), int) = list(mlds_initializer).
gen_du_ptag_ordered_table_body(_, _, [], _) = [].
gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor,
- [Ptag - SectagTable | PtagTail], CurPtag) = [Init | Inits] :-
+ [Ptag - SectagTable | PtagTail], CurPtag)
+ = [Initializer | Initializers] :-
expect(unify(Ptag, CurPtag), this_file,
"gen_du_ptag_ordered_table_body: ptag mismatch"),
SectagTable = sectag_table(SectagLocn, NumSharers, _SectagMap),
RttiName = type_ctor_du_ptag_layout(Ptag),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_int(NumSharers),
gen_init_sectag_locn(SectagLocn),
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_stag_ordered_table(Ptag))
]),
- Inits = gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor,
+ Initializers = gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor,
PtagTail, CurPtag + 1).
-:- func gen_du_stag_ordered_table(module_name, rtti_type_ctor,
- pair(int, sectag_table)) = mlds_defn.
+:- pred gen_du_stag_ordered_table(module_name::in, rtti_type_ctor::in,
+ pair(int, sectag_table)::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_du_stag_ordered_table(ModuleName, RttiTypeCtor, Ptag - SectagTable)
- = MLDS_Defn :-
+gen_du_stag_ordered_table(ModuleName, RttiTypeCtor, Ptag - SectagTable,
+ !GlobalData) :-
SectagTable = sectag_table(_SectagLocn, _NumSharers, SectagMap),
map.values(SectagMap, SectagFunctors),
FunctorRttiNames = list.map(du_functor_rtti_name, SectagFunctors),
- Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_du_stag_ordered_table(Ptag),
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_du_name_ordered_table(module_info, rtti_type_ctor,
- map(string, map(int, du_functor))) = mlds_defn.
+:- pred gen_du_name_ordered_table(module_info::in, rtti_type_ctor::in,
+ map(string, map(int, du_functor))::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_du_name_ordered_table(ModuleInfo, RttiTypeCtor, NameArityMap)
- = MLDS_Defn :-
+gen_du_name_ordered_table(ModuleInfo, RttiTypeCtor, NameArityMap,
+ !GlobalData) :-
map.values(NameArityMap, ArityMaps),
list.map(map.values, ArityMaps, FunctorLists),
list.condense(FunctorLists, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(du_functor_rtti_name, Functors),
- Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_du_name_ordered_table,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_maybe_res_value_ordered_table(module_info, rtti_type_ctor,
- list(reserved_functor), map(int, sectag_table)) = list(mlds_defn).
+:- pred gen_maybe_res_value_ordered_table(module_info::in, rtti_type_ctor::in,
+ list(reserved_functor)::in, map(int, sectag_table)::in,
+ ml_global_data::in, ml_global_data::out) is det.
gen_maybe_res_value_ordered_table(ModuleInfo, RttiTypeCtor, ResFunctors,
- DuByPtag) = MLDS_Defns :-
+ DuByPtag, !GlobalData) :-
ResFunctorReps = list.map(res_addr_rep, ResFunctors),
list.filter(res_addr_is_numeric, ResFunctorReps,
NumericResFunctorReps, SymbolicResFunctorReps),
list.length(NumericResFunctorReps, NumNumericResFunctorReps),
list.length(SymbolicResFunctorReps, NumSymbolicResFunctorReps),
module_info_get_name(ModuleInfo, ModuleName),
- ResDefns = [gen_res_addr_functor_table(ModuleName, RttiTypeCtor,
- ResFunctors)],
+ gen_res_addr_functor_table(ModuleName, RttiTypeCtor, ResFunctors,
+ !GlobalData),
( NumSymbolicResFunctorReps = 0 ->
- ResAddrDefns = [],
- ResAddrInit = gen_init_null_pointer(mlds_generic_type)
+ ResAddrInitializer = gen_init_null_pointer(mlds_generic_type)
;
- ResAddrDefns = [gen_res_addrs_list(ModuleInfo, RttiTypeCtor,
- SymbolicResFunctorReps)],
- ResAddrInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ gen_res_addrs_list(ModuleInfo, RttiTypeCtor,
+ SymbolicResFunctorReps, !GlobalData),
+ ResAddrInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_res_addrs)
),
- DuDefns = gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor, DuByPtag),
- SubDefns = ResDefns ++ ResAddrDefns ++ DuDefns,
+ gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor, DuByPtag, !GlobalData),
RttiName = type_ctor_res_value_ordered_table,
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
- Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_int(NumNumericResFunctorReps),
gen_init_int(NumSymbolicResFunctorReps),
- ResAddrInit,
+ ResAddrInitializer,
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_res_addr_functors),
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_ptag_ordered_table)
]),
- rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn),
- MLDS_Defns = [MLDS_Defn | SubDefns].
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
-:- func gen_res_addr_functor_table(module_name, rtti_type_ctor,
- list(reserved_functor)) = mlds_defn.
+:- pred gen_res_addr_functor_table(module_name::in, rtti_type_ctor::in,
+ list(reserved_functor)::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_res_addr_functor_table(ModuleName, RttiTypeCtor, ResFunctors)
- = MLDS_Defn :-
+gen_res_addr_functor_table(ModuleName, RttiTypeCtor, ResFunctors,
+ !GlobalData) :-
FunctorRttiNames = list.map(res_functor_rtti_name, ResFunctors),
- Init = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
+ Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_res_addr_functors,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_res_addrs_list(module_info, rtti_type_ctor, list(reserved_address))
- = mlds_defn.
+:- pred gen_res_addrs_list(module_info::in, rtti_type_ctor::in,
+ list(reserved_address)::in, ml_global_data::in, ml_global_data::out)
+ is det.
-gen_res_addrs_list(ModuleInfo, RttiTypeCtor, ResAddrs) = MLDS_Defn :-
- Init = gen_init_array(gen_init_reserved_address(ModuleInfo), ResAddrs),
+gen_res_addrs_list(ModuleInfo, RttiTypeCtor, ResAddrs, !GlobalData) :-
+ Initializer =
+ gen_init_array(gen_init_reserved_address(ModuleInfo), ResAddrs),
RttiName = type_ctor_res_addrs,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
-:- func gen_maybe_res_name_ordered_table(module_info, rtti_type_ctor,
- map(string, map(int, maybe_reserved_functor))) = mlds_defn.
+:- pred gen_maybe_res_name_ordered_table(module_info::in, rtti_type_ctor::in,
+ map(string, map(int, maybe_reserved_functor))::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_maybe_res_name_ordered_table(ModuleInfo, RttiTypeCtor, NameArityMap)
- = MLDS_Defn :-
+gen_maybe_res_name_ordered_table(ModuleInfo, RttiTypeCtor, NameArityMap,
+ !GlobalData) :-
map.values(NameArityMap, ArityMaps),
list.map(map.values, ArityMaps, FunctorLists),
list.condense(FunctorLists, Functors),
module_info_get_name(ModuleInfo, ModuleName),
- Init = gen_init_array(
+ Initializer = gen_init_array(
gen_maybe_res_name_ordered_table_element(ModuleName, RttiTypeCtor),
Functors),
RttiName = type_ctor_res_name_ordered_table,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
:- func gen_maybe_res_name_ordered_table_element(module_name, rtti_type_ctor,
maybe_reserved_functor) = mlds_initializer.
gen_maybe_res_name_ordered_table_element(ModuleName, RttiTypeCtor,
- MaybeResFunctor) = Init :-
+ MaybeResFunctor) = Initializer :-
RttiName = type_ctor_maybe_res_addr_functor_desc,
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
Type = mlds_rtti_type(item_type(RttiId)),
(
MaybeResFunctor = res_func(ResFunctor),
Name = ResFunctor ^ res_name,
- Init = init_struct(Type, [
+ Initializer = init_struct(Type, [
gen_init_string(Name),
gen_init_int(0), % arity=0
gen_init_bool(yes), % is_reserved = true
@@ -1144,7 +1203,7 @@
;
MaybeResFunctor = du_func(DuFunctor),
Name = DuFunctor ^ du_name,
- Init = init_struct(Type, [
+ Initializer = init_struct(Type, [
gen_init_string(Name),
gen_init_int(DuFunctor ^ du_orig_arity),
gen_init_bool(no), % is_reserved = false
@@ -1153,13 +1212,14 @@
])
).
-:- func gen_functor_number_map(rtti_type_ctor, list(int)) = mlds_defn.
+:- pred gen_functor_number_map(rtti_type_ctor::in, list(int)::in,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_functor_number_map(RttiTypeCtor, FunctorNumberMap) =
- MLDS_Defn :-
- Init = gen_init_array(gen_init_int, FunctorNumberMap),
+gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData) :-
+ Initializer = gen_init_array(gen_init_int, FunctorNumberMap),
RttiName = type_ctor_functor_number_map,
- rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
+ rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
+ !GlobalData).
%-----------------------------------------------------------------------------%
@@ -1375,45 +1435,51 @@
%-----------------------------------------------------------------------------%
:- pred gen_pseudo_type_info(module_info::in, rtti_data::in,
- mlds_initializer::out, list(mlds_defn)::out) is det.
+ mlds_initializer::out, ml_global_data::in, ml_global_data::out) is det.
-gen_pseudo_type_info(ModuleInfo, PTIRttiData, Init, Defns) :-
- RealRttiDatas = list.filter(real_rtti_data, [PTIRttiData]),
- DefnLists = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- Defns = list.condense(DefnLists),
+gen_pseudo_type_info(ModuleInfo, PTIRttiData, Initializer, !GlobalData) :-
+ ( real_rtti_data(PTIRttiData) ->
+ add_rtti_data_to_mlds(ModuleInfo, PTIRttiData, !GlobalData)
+ ;
+ % Since PTIRttiData does not correspond to a global data definition,
+ % we have nothing to do.
+ true
+ ),
module_info_get_name(ModuleInfo, ModuleName),
- Init = gen_init_cast_rtti_data(mlds_pseudo_type_info_type,
+ Initializer = gen_init_cast_rtti_data(mlds_pseudo_type_info_type,
ModuleName, PTIRttiData).
:- pred gen_pseudo_type_info_array(module_info::in, list(rtti_data)::in,
- mlds_initializer::out, list(mlds_defn)::out) is det.
+ mlds_initializer::out, ml_global_data::in, ml_global_data::out) is det.
-gen_pseudo_type_info_array(ModuleInfo, PTIRttiDatas, Init, Defns) :-
+gen_pseudo_type_info_array(ModuleInfo, PTIRttiDatas, Initializer,
+ !GlobalData) :-
RealRttiDatas = list.filter(real_rtti_data, PTIRttiDatas),
- DefnLists = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- Defns = list.condense(DefnLists),
+ list.foldl(add_rtti_data_to_mlds(ModuleInfo), RealRttiDatas, !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
- Init = gen_init_cast_rtti_datas_array(mlds_pseudo_type_info_type,
+ Initializer = gen_init_cast_rtti_datas_array(mlds_pseudo_type_info_type,
ModuleName, PTIRttiDatas).
:- pred gen_pseudo_type_info_list(module_info::in, list(rtti_data)::in,
- list(mlds_initializer)::out, list(mlds_defn)::out) is det.
+ list(mlds_initializer)::out,
+ ml_global_data::in, ml_global_data::out) is det.
-gen_pseudo_type_info_list(ModuleInfo, PTIRttiDatas, Inits, Defns) :-
+gen_pseudo_type_info_list(ModuleInfo, PTIRttiDatas, Initializers,
+ !GlobalData) :-
RealRttiDatas = list.filter(real_rtti_data, PTIRttiDatas),
- DefnLists = list.map(rtti_data_to_mlds(ModuleInfo), RealRttiDatas),
- Defns = list.condense(DefnLists),
+ list.foldl(add_rtti_data_to_mlds(ModuleInfo), RealRttiDatas, !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
- Inits = list.map(
+ Initializers = list.map(
gen_init_cast_rtti_data(mlds_pseudo_type_info_type, ModuleName),
PTIRttiDatas).
%-----------------------------------------------------------------------------%
:- pred gen_init_method(module_info::in, int::in, rtti_proc_label::in,
- mlds_initializer::out, list(mlds_defn)::in, list(mlds_defn)::out) is det.
+ mlds_initializer::out, ml_global_data::in, ml_global_data::out) is det.
-gen_init_method(ModuleInfo, NumExtra, RttiProcLabel, Init, !ExtraDefns) :-
+gen_init_method(ModuleInfo, NumExtra, RttiProcLabel, Initializer,
+ !GlobalData) :-
% We can't store the address of the typeclass method directly in the
% base_typeclass_info; instead, we need to generate a wrapper function
% that extracts the NumExtra parameters it needs from the typeclass_info,
@@ -1427,15 +1493,15 @@
% to optimize this...
%
gen_wrapper_func_and_initializer(ModuleInfo, NumExtra, RttiProcLabel,
- typeclass_info_closure, Init, !ExtraDefns).
+ typeclass_info_closure, Initializer, !GlobalData).
:- pred gen_init_special_pred(module_info::in, univ::in, mlds_initializer::out,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
-gen_init_special_pred(ModuleInfo, RttiProcIdUniv, Init, !ExtraDefns) :-
+gen_init_special_pred(ModuleInfo, RttiProcIdUniv, Initializer, !GlobalData) :-
% We can't store the address of the special pred procedure directly in the
% type_ctor_info because when the special pred is called by looking up
- % its address in the type_ctor_info its always called with its arguments
+ % its address in the type_ctor_info it is always called with its arguments
% boxed, but the generated special pred may operate on unboxed values,
% hence we need to generate a wrapper function which unboxes the arguments
% if necessary.
@@ -1445,11 +1511,11 @@
% so we don't need a wrapper. (This case can occur with
% --no-special-preds, where the procedure will be
% private_builtin.unused/0.)
- Init = gen_init_proc_id(ModuleInfo, RttiProcId)
+ Initializer = gen_init_proc_id(ModuleInfo, RttiProcId)
;
NumExtra = 0,
- gen_wrapper_func_and_initializer(ModuleInfo, NumExtra,
- RttiProcId, special_pred_closure, Init, !ExtraDefns)
+ gen_wrapper_func_and_initializer(ModuleInfo, NumExtra, RttiProcId,
+ special_pred_closure, Initializer, !GlobalData)
)
;
unexpected(this_file,
@@ -1458,35 +1524,41 @@
:- pred gen_wrapper_func_and_initializer(module_info::in, int::in,
rtti_proc_label::in, closure_kind::in, mlds_initializer::out,
- list(mlds_defn)::in, list(mlds_defn)::out) is det.
+ ml_global_data::in, ml_global_data::out) is det.
gen_wrapper_func_and_initializer(ModuleInfo, NumExtra, RttiProcId,
- ClosureKind, Init, !ExtraDefns) :-
- % We start off by creating a fresh MLGenInfo here, using the pred_id and
- % proc_id of the wrapped procedure. This requires considerable care.
- % We need to call ml_gen_info_bump_counters to ensure that the function
- % label allocated for the wrapper func does not overlap with any function
- % labels used when generating code for the wrapped procedure.
- %
+ ClosureKind, Initializer, !GlobalData) :-
+ some [!Info] (
+ % We start off by creating a fresh MLGenInfo here, using the pred_id
+ % and proc_id of the wrapped procedure. This requires considerable
+ % care. We need to call ml_gen_info_bump_counters to ensure that
+ % the function label allocated for the wrapper func does not overlap
+ % with any function labels used when generating code for the wrapped
+ % procedure.
+
PredId = RttiProcId ^ pred_id,
ProcId = RttiProcId ^ proc_id,
- MLGenInfo0 = ml_gen_info_init(ModuleInfo, PredId, ProcId),
- ml_gen_info_bump_counters(MLGenInfo0, MLGenInfo1),
+ module_info_proc_info(ModuleInfo, PredId, ProcId, ProcInfo),
+ !:Info = ml_gen_info_init(ModuleInfo, PredId, ProcId, ProcInfo,
+ !.GlobalData),
+ ml_gen_info_bump_counters(!Info),
% Now we can safely go ahead and generate the wrapper function.
term.context_init(Context),
ml_gen_closure_wrapper(PredId, ProcId, ClosureKind, NumExtra, Context,
- WrapperFuncRval, WrapperFuncType, MLGenInfo1, MLGenInfo),
- ml_gen_info_get_extra_defns(MLGenInfo, ExtraDefns),
- !:ExtraDefns = ExtraDefns ++ !.ExtraDefns,
-
- % The initializer for the wrapper is just the wrapper function's address,
- % converted to mlds_generic_type (by boxing).
- Init = init_obj(ml_unop(box(WrapperFuncType), WrapperFuncRval)).
+ WrapperFuncRval, WrapperFuncType, !Info),
+ ml_gen_info_get_closure_wrapper_defns(!.Info, ExtraDefns),
+ ml_gen_info_get_global_data(!.Info, !:GlobalData),
+ ml_global_data_add_maybe_nonflat_defns(ExtraDefns, !GlobalData),
+
+ % The initializer for the wrapper is just the wrapper function's
+ % address, converted to mlds_generic_type (by boxing).
+ Initializer = init_obj(ml_unop(box(WrapperFuncType), WrapperFuncRval))
+ ).
:- func gen_init_proc_id(module_info, rtti_proc_label) = mlds_initializer.
-gen_init_proc_id(ModuleInfo, RttiProcId) = Init :-
+gen_init_proc_id(ModuleInfo, RttiProcId) = Initializer :-
% Construct an rval for the address of this procedure
% (this is similar to ml_gen_proc_addr_rval).
ml_gen_pred_label_from_rtti(ModuleInfo, RttiProcId, PredLabel, PredModule),
@@ -1503,14 +1575,14 @@
% depend on how many type_info parameters it takes, which will depend
% on the type's arity.
ProcAddrArg = ml_unop(box(mlds_func_type(Params)), ProcAddrRval),
- Init = init_obj(ProcAddrArg).
+ Initializer = init_obj(ProcAddrArg).
:- func gen_init_proc_id_from_univ(module_info, univ) =
mlds_initializer.
-gen_init_proc_id_from_univ(ModuleInfo, ProcLabelUniv) = Init :-
+gen_init_proc_id_from_univ(ModuleInfo, ProcLabelUniv) = Initializer :-
( univ_to_type(ProcLabelUniv, ProcLabel) ->
- Init = gen_init_proc_id(ModuleInfo, ProcLabel)
+ Initializer = gen_init_proc_id(ModuleInfo, ProcLabel)
;
unexpected(this_file,
"gen_init_proc_id_from_univ: cannot extract univ value")
@@ -1559,7 +1631,7 @@
%-----------------------------------------------------------------------------%
%
-% Ordering RTTI definitions
+% Ordering RTTI definitions.
%
order_mlds_rtti_defns(Defns) = OrdDefns :-
@@ -1579,7 +1651,7 @@
is det.
add_rtti_defn_nodes(Defn, !Graph, !NameMap) :-
- Name = Defn ^ mlds_entity_name,
+ Name = Defn ^ md_entity_name,
(
Name = entity_data(DataName),
digraph.add_vertex(DataName, _, !Graph),
@@ -1607,7 +1679,8 @@
unexpected(this_file, "add_rtti_defn_arcs: expected rtti entity_data")
).
-:- pred add_rtti_defn_arcs_initializer(mlds_data_name::in, mlds_initializer::in,
+:- pred add_rtti_defn_arcs_initializer(mlds_data_name::in,
+ mlds_initializer::in,
digraph(mlds_data_name)::in, digraph(mlds_data_name)::out) is det.
add_rtti_defn_arcs_initializer(DefnDataName, Initializer, !Graph) :-
Index: compiler/structure_reuse.indirect.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.indirect.m,v
retrieving revision 1.34
diff -u -b -r1.34 structure_reuse.indirect.m
--- compiler/structure_reuse.indirect.m 23 Dec 2008 01:37:41 -0000 1.34
+++ compiler/structure_reuse.indirect.m 28 Aug 2009 11:49:15 -0000
@@ -476,7 +476,7 @@
(
Unification = construct(Var, _, _, _, HowToConstruct, _, _),
(
- HowToConstruct = construct_statically(_),
+ HowToConstruct = construct_statically,
!IrInfo ^ static_vars :=
set.insert(!.IrInfo ^ static_vars, Var)
;
Index: compiler/superhomogeneous.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/superhomogeneous.m,v
retrieving revision 1.33
diff -u -b -r1.33 superhomogeneous.m
--- compiler/superhomogeneous.m 11 Jun 2009 07:00:20 -0000 1.33
+++ compiler/superhomogeneous.m 28 Aug 2009 11:49:15 -0000
@@ -753,9 +753,9 @@
NumAdded = CallAdded + ArgAdded
;
% Handle the usual case.
- % XXX Why do we use Arg1 instead of Args here?
+ % XXX Why do we use Args1 instead of Args here?
RHS = term.functor(F, Args1, FunctorContext),
- ( sym_name_and_args(RHS, FunctorName, FunctorArgsPrime) ->
+ ( parse_sym_name_and_args(RHS, FunctorName, FunctorArgsPrime) ->
FunctorArgs = FunctorArgsPrime,
list.length(FunctorArgs, Arity),
ConsId = cons(FunctorName, Arity, cons_id_dummy_type_ctor)
Index: compiler/typecheck_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_info.m,v
retrieving revision 1.26
diff -u -b -r1.26 typecheck_info.m
--- compiler/typecheck_info.m 23 Dec 2008 01:37:42 -0000 1.26
+++ compiler/typecheck_info.m 28 Aug 2009 11:49:15 -0000
@@ -378,6 +378,7 @@
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
+:- import_module assoc_list.
:- import_module int.
:- import_module pair.
:- import_module string.
@@ -434,7 +435,10 @@
ConstraintProofs = ConstraintProofs0,
ConstraintMap1 = ConstraintMap0
;
- expand_types(Vars, TypeBindings, VarTypes0, VarTypes),
+ map.to_sorted_assoc_list(VarTypes0, VarTypesList0),
+ expand_types(VarTypesList0, TypeBindings, [], RevVarTypesList),
+ list.reverse(RevVarTypesList, VarTypesList),
+ map.from_sorted_assoc_list(VarTypesList, VarTypes),
apply_rec_subst_to_constraint_proofs(TypeBindings,
ConstraintProofs0, ConstraintProofs),
apply_rec_subst_to_constraint_map(TypeBindings,
@@ -501,7 +505,10 @@
% Finally, rename the types and type class constraints to use
% the new typevarset type variables.
apply_variable_renaming_to_type_list(TSubst, Types, NewTypes),
- map.from_corresponding_lists(Vars, NewTypes, NewVarTypes),
+ assoc_list.from_corresponding_lists(Vars, NewTypes, VarsNewTypes),
+ % Creating the NewVarTypes map from a list that map.m knows is sorted
+ % gives a speedup.
+ map.from_sorted_assoc_list(VarsNewTypes, NewVarTypes),
map.apply_to_list(HeadTypeParams, TSubst, NewHeadTypeParams),
retrieve_prog_constraints(HLDSTypeConstraints, TypeConstraints),
apply_variable_renaming_to_prog_constraints(TSubst,
@@ -521,30 +528,36 @@
% Doug Auclair's training_cars program). The code below prevents stack
% overflows in grades that do not permit tail recursion.
%
-:- pred expand_types(list(prog_var)::in, tsubst::in,
- vartypes::in, vartypes::out) is det.
+:- pred expand_types(assoc_list(prog_var, mer_type)::in, tsubst::in,
+ assoc_list(prog_var, mer_type)::in, assoc_list(prog_var, mer_type)::out)
+ is det.
-expand_types(Vars, TypeSubst, !VarTypes) :-
- expand_types_2(Vars, TypeSubst, 1000, LeftOverVars, !VarTypes),
+expand_types(VarTypes, TypeSubst, !RevVarTypes) :-
+ expand_types_2(VarTypes, TypeSubst, 1000, LeftOverVarTypes, !RevVarTypes),
(
- LeftOverVars = []
+ LeftOverVarTypes = []
;
- LeftOverVars = [_ | _],
- expand_types(LeftOverVars, TypeSubst, !VarTypes)
+ LeftOverVarTypes = [_ | _],
+ expand_types(LeftOverVarTypes, TypeSubst, !RevVarTypes)
).
-:- pred expand_types_2(list(prog_var)::in, tsubst::in, int::in,
- list(prog_var)::out, vartypes::in, vartypes::out) is det.
+:- pred expand_types_2(assoc_list(prog_var, mer_type)::in, tsubst::in, int::in,
+ assoc_list(prog_var, mer_type)::out,
+ assoc_list(prog_var, mer_type)::in, assoc_list(prog_var, mer_type)::out)
+ is det.
expand_types_2([], _, _, [], !VarTypes).
-expand_types_2([Var | Vars], TypeSubst, VarsToDo, LeftOverVars, !VarTypes) :-
+expand_types_2([VarType0 | VarTypes0], TypeSubst, VarsToDo, LeftOverVarTypes,
+ !RevVarTypes) :-
( VarsToDo < 0 ->
- LeftOverVars = [Var | Vars]
+ LeftOverVarTypes = [VarType0 | VarTypes0]
;
- map.lookup(!.VarTypes, Var, Type0),
+ VarType0 = Var - Type0,
apply_rec_subst_to_type(TypeSubst, Type0, Type),
- map.det_update(!.VarTypes, Var, Type, !:VarTypes),
- expand_types_2(Vars, TypeSubst, VarsToDo - 1, LeftOverVars, !VarTypes)
+ VarType = Var - Type,
+ !:RevVarTypes = [VarType | !.RevVarTypes],
+ expand_types_2(VarTypes0, TypeSubst, VarsToDo - 1, LeftOverVarTypes,
+ !RevVarTypes)
).
% We rename any existentially quantified type variables which get mapped
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.158
diff -u -b -r1.158 unused_args.m
--- compiler/unused_args.m 16 Jul 2009 07:27:13 -0000 1.158
+++ compiler/unused_args.m 28 Aug 2009 11:49:15 -0000
@@ -302,7 +302,7 @@
globals.lookup_bool_option(Globals, optimize_unused_args, DoFixup),
(
DoFixup = yes,
- list.foldl2(create_new_pred(UnusedArgInfo), PredProcsToFix,
+ list.foldl2(unused_args_create_new_pred(UnusedArgInfo), PredProcsToFix,
ProcCallInfo0, ProcCallInfo, !ModuleInfo),
% maybe_write_string(VeryVerbose, "% Finished new preds.\n",
% !IO),
@@ -984,11 +984,11 @@
% calling interface. The other is that the next proc_id for a predicate is
% chosen based on the length of the list of proc_ids.
%
-:- pred create_new_pred(unused_arg_info::in, pred_proc_id::in,
+:- pred unused_args_create_new_pred(unused_arg_info::in, pred_proc_id::in,
proc_call_info::in, proc_call_info::out,
module_info::in, module_info::out) is det.
-create_new_pred(UnusedArgInfo, proc(PredId, ProcId), !ProcCallInfo,
+unused_args_create_new_pred(UnusedArgInfo, proc(PredId, ProcId), !ProcCallInfo,
!ModuleInfo) :-
map.lookup(UnusedArgInfo, proc(PredId, ProcId), UnusedArgs),
module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
Index: compiler/var_locn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/var_locn.m,v
retrieving revision 1.67
diff -u -b -r1.67 var_locn.m
--- compiler/var_locn.m 6 Jan 2009 03:56:27 -0000 1.67
+++ compiler/var_locn.m 28 Aug 2009 11:49:15 -0000
@@ -920,7 +920,7 @@
;
% XXX We should probably throw an exception if we find
% construct_statically here.
- HowToConstruct = construct_statically(_),
+ HowToConstruct = construct_statically,
RegionVarCode = empty,
MaybeRegionRval = no,
LldsComment = "Allocating heap for ",
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.144
diff -u -b -r1.144 compiler_design.html
--- compiler/notes/compiler_design.html 11 Jun 2009 07:00:35 -0000 1.144
+++ compiler/notes/compiler_design.html 28 Aug 2009 12:57:10 -0000
@@ -1564,9 +1564,10 @@
since it is also used by LLDS back-end)
</ul>
</ul>
- The module ml_code_util.m provides utility routines for
- MLDS code generation. The module ml_util.m provides some
- general utility routines for the MLDS.
+ The main data structure used by the MLDS code generator is defined
+ in ml_code_util.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.
<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
Index: tests/hard_coded/float_field.exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/float_field.exp,v
retrieving revision 1.2
diff -u -b -r1.2 float_field.exp
--- tests/hard_coded/float_field.exp 15 Feb 2007 00:41:52 -0000 1.2
+++ tests/hard_coded/float_field.exp 28 Aug 2009 12:57:42 -0000
@@ -6,7 +6,13 @@
5.0
foo2(1.0)
1.0
+foo3(foo2(1.0))
+1.0
bar2(2, 3.0, 4)
3.0
5.0
5.0
+bar_foo2(6, foo2(7.0), 8)
+7.0
+bar_foo3(6, foo3(foo2(7.0)), 8)
+7.0
Index: tests/hard_coded/float_field.m
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/float_field.m,v
retrieving revision 1.1
diff -u -b -r1.1 float_field.m
--- tests/hard_coded/float_field.m 5 Jun 2000 02:47:36 -0000 1.1
+++ tests/hard_coded/float_field.m 28 Aug 2009 12:57:42 -0000
@@ -12,7 +12,12 @@
:- type baz.
:- type foo2 ---> foo2(float). % no_tag type
+:- type foo3 ---> foo3(foo2). % no_tag type containing another notag type
:- type bar2 ---> bar2(int, float, int). % ordinary d.u. type
+:- type bar_foo2 ---> bar_foo2(int, foo2, int).
+ % notag type inside ordinary d.u. type
+:- type bar_foo3 ---> bar_foo3(int, foo3, int).
+ % notag type inside notag type inside ordinary d.u. type
:- type baz2 == float. % equivalence type
:- func foo_val(foo) = float.
@@ -20,9 +25,13 @@
:- func baz_val(baz) = float.
:- func foo2_val(foo2) = float.
+:- func foo3_val(foo3) = float.
:- func bar2_val(bar2) = float.
:- func baz2_val(baz2) = float.
+:- func bar_foo2_val(bar_foo2) = float.
+:- func bar_foo3_val(bar_foo3) = float.
+
:- implementation.
:- import_module float, math, string, list.
@@ -35,9 +44,13 @@
baz_val(X) = X.
foo2_val(foo2(X)) = X.
+foo3_val(foo3(X)) = foo2_val(X).
bar2_val(bar2(_, X, _)) = X.
baz2_val(X) = X.
+bar_foo2_val(bar_foo2(_, foo2(X), _)) = X.
+bar_foo3_val(bar_foo3(_, foo3(foo2(X)), _)) = X.
+
main -->
{ Foo = foo(1.0) },
print(Foo), nl,
@@ -52,10 +65,20 @@
{ Foo2 = foo2(1.0) },
print(Foo2), nl,
print(foo2_val(Foo2)), nl,
+ { Foo3 = foo3(Foo2) },
+ print(Foo3), nl,
+ print(foo3_val(Foo3)), nl,
{ Bar2 = bar2(2, 3.0, 4) },
print(Bar2), nl,
print(bar2_val(Bar2)), nl,
{ Baz2 = 5.0 },
print(Baz2), nl,
- print(baz2_val(Baz2)), nl.
+ print(baz2_val(Baz2)), nl,
+ { BarFoo2 = bar_foo2(6, foo2(7.0), 8) },
+ print(BarFoo2), nl,
+ print(bar_foo2_val(BarFoo2)), nl,
+
+ { BarFoo3 = bar_foo3(6, foo3(foo2(7.0)), 8) },
+ print(BarFoo3), nl,
+ print(bar_foo3_val(BarFoo3)), nl.
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