mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-16 14:25:56 +00:00
c6cbc43448
This patch allows the pragma to be parsed, and records the information from
the pragma in the proc_info structure for the relevant procedures.
The patch uses the pragma for the MLDS backend. However because mutual
recursion is not yet supported on the MLDS backend, mutually recursive calls
are ignored by the pragma.
The patch also documents the pragma in the reference manual, this
documentation is commented out until it is implemented for both LLDS and
MLDS backends.
The patch does not implement the SCC feature discussed on the mailing list.
That can be added later.
compiler/prog_data.m:
compiler/prog_item.m:
Add new require_tail_recursion pragma.
compiler/prog_io_pragma.m:
Parse the new pragma.
Remove the arity_and_modes type and use pred_name_arity_mpf_mmode
type from prog_item.m
compiler/parse_tree_out_pragma.m:
Support pretty printing the new pragma.
compiler/hlds_pred.m:
Add require_tailrec_info to the proc_info structure.
compiler/add_pragma.m:
Add information from the pragma to the proc_info structure after
parsing.
compiler/compiler_util.m:
Add a general warning_or_error type.
compiler/mlds.m:
Add require_tailrec_info to MLDS functions.
compiler/ml_proc_gen.m:
Copy the require_tailrec_info information from the HLDS to the MLDS.
compiler/ml_tailcall.m:
Generate errors and warnings with respect to the require_tail_recursion
pragma.
compiler/mercury_compile.m:
compiler/mercury_compile_mlds_back_end.m:
Return errors from the MLDS tailcall optimisation pass.
compiler/add_pragma.m:
compiler/comp_unit_interface.m:
compiler/equiv_type.m:
compiler/get_dependencies.m:
compiler/item_util.m:
compiler/make_hlds_separate_items.m:
compiler/module_qual.qual_errors.m:
compiler/module_qual.qualify_items.m:
compiler/prog_item_stats.m:
compiler/recompilation.version.m:
compiler/write_module_interface_files.m:
Conform to changes in prog_item.m.
compiler/ml_code_util.m:
compiler/ml_elim_nested.m:
compiler/ml_optimize.m:
compiler/ml_type_gen.m:
compiler/ml_util.m:
compiler/mlds_to_c.m:
compiler/mlds_to_cs.m:
compiler/mlds_to_java.m:
Conform to changes in mlds.m.
doc/reference_manual.texi
Document the require_tail_recursion pragma
tests/invalid/Mercury.options:
tests/invalid/Mmakefile:
tests/invalid/require_tail_recursion.err_exp:
tests/invalid/require_tail_recursion.m:
Add require_tail_recursion test case
2690 lines
105 KiB
Mathematica
2690 lines
105 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1999-2011 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_elim_nested.m.
|
|
% Main author: fjh.
|
|
%
|
|
% 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
|
|
% nested functions and also to the frame structs used for accurate GC.
|
|
%
|
|
% XXX Would it be possible to do both in a single pass?
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
% (1) eliminating nested functions
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% 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 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
|
|
% the effect of fixing up the dangling `env_ptr' references that ml_code_gen.m
|
|
% leaves in the code.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
% TRANSFORMATION SUMMARY
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% We transform code of the form e.g.
|
|
%
|
|
% <OuterRet> outer(<OuterArgs>) {
|
|
% <OuterLocals>
|
|
%
|
|
% <Inner1Ret> inner(<Inner1Args>, void *env_ptr_arg) {
|
|
% <Inner1Locals>
|
|
%
|
|
% <NestedInnerRet> nested_inner(<NestedInnerArgs>,
|
|
% void *env_ptr_arg)
|
|
% {
|
|
% <NestedInnerLocals>
|
|
%
|
|
% <NestedInnerCode>
|
|
% }
|
|
%
|
|
% <Inner1Code>
|
|
% }
|
|
%
|
|
% <Inner2Ret> inner(<Inner2Args>, void *env_ptr_arg) {
|
|
% <Inner2Locals>
|
|
%
|
|
% <Inner2Code>
|
|
% }
|
|
%
|
|
% <OuterCode>
|
|
% }
|
|
%
|
|
% into
|
|
%
|
|
% struct OuterLocals_struct {
|
|
% <OuterArgs>
|
|
% <OuterLocals>
|
|
% <Inner1Locals>
|
|
% };
|
|
%
|
|
% <NestedInnerRet> nested_inner(<NestedInnerArgs>, void *env_ptr_arg) {
|
|
% OuterLocals *env_ptr = env_ptr_arg;
|
|
% <NestedInnerLocals>
|
|
%
|
|
% <NestedInnerCode'>
|
|
% }
|
|
%
|
|
% <Inner1Ret> inner(<Inner1Args>, void *env_ptr_arg) {
|
|
% OuterLocals *env_ptr = env_ptr_arg;
|
|
%
|
|
% <Inner1Code'>
|
|
% }
|
|
%
|
|
% <Inner2Ret> inner(<Inner2Args>, void *env_ptr_arg) {
|
|
% OuterLocals *env_ptr = env_ptr_arg;
|
|
% <Inner2Locals>
|
|
%
|
|
% <Inner2Code'>
|
|
% }
|
|
%
|
|
% <OuterRet> outer(<OuterArgs>) {
|
|
% OuterLocals env;
|
|
% OuterLocals *env_ptr = &env;
|
|
%
|
|
% env_ptr-><OuterArgs> = <OuterArgs>;
|
|
% <OuterCode'>
|
|
% }
|
|
%
|
|
% where <Inner1Code'>, <Inner2Code'> and <NestedInnerCode'> are the
|
|
% same as <Inner1Code>, <Inner2Code> and <NestedInnerCode> (respectively)
|
|
% except that any references to a local variable <Var> declared in
|
|
% outer() are replaced with `env_ptr -> <Var>',
|
|
% and likewise <OuterCode'> is the same as <OuterCode> with references to
|
|
% local variables replaced with `env_ptr->foo'. In the latter
|
|
% case it could (depending on how smart the C compiler is) potentially
|
|
% be more efficient to generate `env.foo', but currently we don't do that.
|
|
%
|
|
% Actually the description above is slightly over-simplified: not all local
|
|
% variables need to be put in the environment struct. Only those local
|
|
% variables which are referenced by nested functions need to be
|
|
% put in the environment struct. Also, if none of the nested functions
|
|
% refer to the locals in the outer function, we don't need to create
|
|
% an environment struct at all, we just need to hoist the definitions
|
|
% of the nested functions out to the top level.
|
|
%
|
|
% The `env_ptr' variables generated here serve as definitions for
|
|
% the (previously dangling) references to such variables that
|
|
% ml_code_gen puts in calls to the nested functions.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
% (2) accurate GC
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% SUMMARY
|
|
%
|
|
% This is an MLDS-to-MLDS transformation that transforms the MLDS code
|
|
% to add the information needed to do accurate GC when compiling to C
|
|
% (or to assembler).
|
|
%
|
|
% Basically what we do is to put all local variables that might contain
|
|
% pointers in structs, with one struct for each stack frame, and chain
|
|
% these structs together. At GC time, we traverse the chain of structs.
|
|
% This allows us to accurately scan the C stack.
|
|
%
|
|
% This is described in more detail in the following paper:
|
|
%
|
|
% Fergus Henderson <fjh@cs.mu.oz.au>,
|
|
% "Accurate garbage collection in an uncooperative environment".
|
|
% International Symposium on Memory Management, Berlin, Germany, 2002.
|
|
%
|
|
% In theory accurate GC is now fully implemented, i.e. it should support
|
|
% the whole Mercury language, modulo the caveats below.
|
|
%
|
|
% TODO:
|
|
% - XXX Need to test the GC tracing code for type class methods.
|
|
% This code in theory ought to work, I think, but it has not really been
|
|
% tested.
|
|
%
|
|
% - XXX The garbage collector should resize the heap if/when it fills up.
|
|
% We should allocate a large amount of virtual memory for each heap,
|
|
% but we should collect when we've allocated a small part of it.
|
|
%
|
|
% - Heap reclamation on failure is not yet supported.
|
|
% One difficulty is that when resetting the heap, we need to also reset
|
|
% all the local variables which might point to reclaimed garbage, otherwise
|
|
% the collector might try to trace through them, which can result in an error
|
|
% since the data pointed to isn't of the right type because it has been
|
|
% overwritten.
|
|
%
|
|
% - The garbage collector should collect the solutions heap and the global heap
|
|
% as well as the ordinary heap.
|
|
%
|
|
% Note that this is currently not an issue, since currently we don't use
|
|
% these heaps, because we don't support heap reclamation on failure or
|
|
% tabling (respectively).
|
|
%
|
|
% Actually I think GC of these heaps should almost work already, or would
|
|
% once we start using these heaps, because we never allocate on the
|
|
% solutions heap or the global heap directly, instead we swap heaps to make
|
|
% the heap that we want to allocate on the main heap. Then if that heap
|
|
% runs out of space, we will invoke a garbage collection, and everything
|
|
% should work fine. However, there are a couple of problems.
|
|
%
|
|
% First, GC will swap the to-space heap and the from-space heap. So if the
|
|
% different heaps are different sizes, we may end up with the to-space heap
|
|
% being too small (e.g. because it was originally the solutions heap).
|
|
% To fix that, we can just allocate large total sizes for all the heaps;
|
|
% see the point above about heap resizing.
|
|
%
|
|
% Second, for GC of the global heap to work, the runtime routines which
|
|
% allocate stuff on that heap need to be modified to support GC.
|
|
% In particular, MR_deep_copy() and MR_make_long_lived() and its callers
|
|
% need be modified so that they are safe for GC (i.e. they must record
|
|
% all parameters and locals that point to the heap on the GC's shadow stack),
|
|
% and MR_deep_copy() needs to call MR_GC_check() before each heap allocation.
|
|
%
|
|
% - XXX We need to handle `pragma foreign_export'.
|
|
%
|
|
% The C interface in general is a bit problematic for GC. But for code which
|
|
% does not call back to Mercury, the way we currently handle it is fairly
|
|
% safe even if the C code uses pointers to the Mercury heap or allocates
|
|
% on the Mercury heap, because such code will not invoke the GC. So the worst
|
|
% that can go wrong is a heap overflow. Provided that the C code does not
|
|
% allocate too much (more than MR_heap_margin_size), it won't overflow the
|
|
% heap, and the heap will get GC'd next time you call some Mercury code
|
|
% which does a heap allocation. Of course you may run into problems if
|
|
% there is a loop that calls C code which allocates on the Mercury heap,
|
|
% and the loop contains no intervening calls to Mercury code that allocates
|
|
% heap space (and hence calls MR_GC_check()).
|
|
%
|
|
% But if Mercury code calls C code which calls back to Mercury code, and
|
|
% the C code uses pointers to the Mercury heap, then there could be
|
|
% serious problems (i.e. dangling pointers). Even if you just use `pragma
|
|
% foreign_export' to export a procedure and `pragma foreign_proc' to import
|
|
% it back again, there may be trouble. The code generated for the exported
|
|
% functions can include calls to MR_MAYBE_BOX_FOREIGN_TYPE, which may
|
|
% allocate heap; we ought to register the frame and call MR_GC_check()
|
|
% before each call to MR_MAYBE_BOX_FOREIGN_TYPE, but currently we don't.
|
|
%
|
|
% Even if that was solved, there is still the issue of what to do about
|
|
% any heap pointers held by user-written C code; we need to provide an API
|
|
% for registering pointers on the stack. (MR_agc_add_root() only works
|
|
% for globals, really, since there's no MR_agc_remove_root()).
|
|
%
|
|
% Various optional features of Mercury are not yet supported, e.g.
|
|
%
|
|
% - `--high-level-data' (fixup_newobj_in_atomic_statement
|
|
% gets the types wrong; see comment in ml_code_util.m)
|
|
%
|
|
% - trailing
|
|
%
|
|
% - tabling
|
|
%
|
|
% - multithreading
|
|
%
|
|
% There are also some things that could be done to improve efficiency, e.g.
|
|
%
|
|
% - optimize away temporary variables
|
|
%
|
|
% - put stack_chain and/or heap pointer in global register variables
|
|
%
|
|
% - move termination conditions (check for base case) outside of stack frame
|
|
% setup & GC check where possible
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% DETAILED DESCRIPTION
|
|
%
|
|
% For each function, we generate a struct for that function.
|
|
% Each such struct starts with a sub-struct containing a couple of
|
|
% fixed fields, which allow the GC to traverse the chain:
|
|
%
|
|
% struct <function_name>_frame {
|
|
% struct MR_StackChain fixed_fields;
|
|
% ...
|
|
% };
|
|
%
|
|
% The fixed fields are as follows:
|
|
%
|
|
% struct MR_StackChain {
|
|
% struct MR_StackChain *prev;
|
|
% void (*trace)(void *this_frame);
|
|
% };
|
|
%
|
|
% Actually, rather than using a nested structure, we just put these fields
|
|
% directly in the <function_name>_frame struct. (This turned out to be
|
|
% a little easier.)
|
|
%
|
|
% The prev field holds a link to the entry for this function's caller.
|
|
% The trace field is the address of a function to trace everything pointed
|
|
% to by this stack frame.
|
|
%
|
|
% To ensure that we don't try to traverse uninitialized fields,
|
|
% we zero-initialize each struct before inserting it into the chain.
|
|
%
|
|
% We need to keep a link to the topmost frame on the stack. There are two
|
|
% possible ways that we could handle this. One way is to pass it down
|
|
% as an parameter. Each function would get an extra parameter `stack_chain'
|
|
% which points to the caller's struct. An alternative approach is to just
|
|
% have a global variable `stack_chain' that points to the top of the stack.
|
|
% We need extra code to set this pointer when entering and returning from
|
|
% functions. To make this approach thread-safe, the variable would actually
|
|
% need to be thread-local rather than global. This approach would probably
|
|
% work best if the variable is a GNU C global register variable, which would
|
|
% make it both efficient and thread-safe.
|
|
% XXX Currently, for simplicity, we're using a global variable.
|
|
%
|
|
% At each allocation, we do a call to MR_GC_check(), which checks for heap
|
|
% exhaustion, and if necessary calls MR_garbage_collect() in
|
|
% runtime/mercury_accurate_gc.c to do the collection. The calls to
|
|
% MR_GC_check() are inserted by compiler/mlds_to_c.m.
|
|
%
|
|
% As an optimization, we ought to not bother allocating a struct for functions
|
|
% that don't have any variables that might contain pointers. We also ought
|
|
% to not bother allocating a struct for leaf functions that don't contain
|
|
% any functions calls or memory allocations.
|
|
% XXX These optimizations are not yet implemented!
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% EXAMPLE
|
|
%
|
|
% If we have a function
|
|
%
|
|
% RetType
|
|
% foo(Arg1Type arg1, Arg2Type arg2, ...)
|
|
% {
|
|
% Local1Type local1;
|
|
% Local2Type local2;
|
|
% ...
|
|
% local1 = MR_new_object(...);
|
|
% ...
|
|
% bar(arg1, arg2, local1, &local2);
|
|
% ...
|
|
% }
|
|
%
|
|
% where say Arg1Type and Local1Type might contain pointers,
|
|
% but Arg2Type and Local2Type don't, then we would transform it as follows:
|
|
%
|
|
% struct foo_frame {
|
|
% MR_StackChain fixed_fields;
|
|
% Arg1Type arg1;
|
|
% Local1Type local1;
|
|
% ...
|
|
% };
|
|
%
|
|
% static void
|
|
% foo_trace(void *this_frame) {
|
|
% struct foo_frame *frame = (struct foo_frame *)this_frame;
|
|
%
|
|
% ... code to construct TypeInfo for type of arg1 ...
|
|
% mercury__private_builtin__gc_trace_1_p_0(
|
|
% <TypeInfo for type of arg1>, &frame->arg1);
|
|
%
|
|
% ... code to construct TypeInfo for type of local1 ...
|
|
% mercury__private_builtin__gc_trace_1_p_0(
|
|
% <TypeInfo for type of local1>, &frame->local1);
|
|
%
|
|
% ...
|
|
% }
|
|
%
|
|
% RetType
|
|
% foo(Arg1Type arg1, Arg2Type arg2, ...)
|
|
% {
|
|
% struct foo_frame this_frame;
|
|
% Local2Type local2;
|
|
%
|
|
% this_frame.fixed_fields.prev = stack_chain;
|
|
% this_frame.fixed_fields.trace = foo_trace;
|
|
% this_frame.arg1 = arg1;
|
|
% this_frame.local1 = NULL;
|
|
% stack_chain = &this_frame;
|
|
%
|
|
% ...
|
|
% this_frame.local1 = MR_new_object(...);
|
|
% ...
|
|
% bar(this_frame.arg1, arg2, this_frame.local1, &local2);
|
|
% ...
|
|
% stack_chain = stack_chain->prev;
|
|
% }
|
|
%
|
|
% Alternatively, if we were passing stack_chain as an argument,
|
|
% rather than treating it as a global variable, then the generated
|
|
% code for foo() would look like this:
|
|
%
|
|
% RetType
|
|
% foo(struct MR_StackChain *stack_chain,
|
|
% Arg1Type arg1, Arg2Type arg2, ...)
|
|
% {
|
|
% struct foo_frame this_frame;
|
|
% Local2Type local2;
|
|
%
|
|
% this_frame.fixed_fields.prev = stack_chain;
|
|
% this_frame.fixed_fields.trace = foo_trace;
|
|
% this_frame.arg1 = arg1;
|
|
% this_frame.local1 = NULL;
|
|
%
|
|
% ...
|
|
% this_frame.local1 = MR_new_object(&this_frame, ...);
|
|
% ...
|
|
% bar(&this_frame, this_frame.arg1, arg2,
|
|
% this_frame.local1, &local2);
|
|
% ...
|
|
% /* no need to explicitly unchain the stack frame here */
|
|
% }
|
|
%
|
|
% Currently, rather than initializing the fields of `this_frame'
|
|
% using a sequence of assignment statements, we actually just use
|
|
% an initializer:
|
|
% struct foo_frame this_frame = { stack_chain };
|
|
% This implicitly zeros out the remaining fields.
|
|
% Only the non-null fields, i.e. the arguments and the trace
|
|
% field, need to be explicitly assigned using assignment statements.
|
|
%
|
|
% The code in the Mercury runtime to traverse the stack frames would
|
|
% look something like this:
|
|
%
|
|
% void
|
|
% MR_traverse_stack(struct MR_StackChain *stack_chain)
|
|
% {
|
|
% while (stack_chain != NULL) {
|
|
% (*stack_chain->trace)(stack_chain);
|
|
% stack_chain = stack_chain->prev;
|
|
% }
|
|
% }
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module ml_backend.ml_elim_nested.
|
|
:- interface.
|
|
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
:- import_module ml_backend.mlds.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type action
|
|
---> hoist_nested_funcs % Eliminate nested functions
|
|
; chain_gc_stack_frames. % Add shadow stack for supporting
|
|
% accurate GC.
|
|
|
|
:- inst hoist
|
|
---> hoist_nested_funcs.
|
|
:- inst chain
|
|
---> chain_gc_stack_frames.
|
|
|
|
% Process the whole MLDS, performing the indicated action.
|
|
%
|
|
:- 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.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module libs.options.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.builtin_modules.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module ml_backend.ml_code_util.
|
|
:- import_module ml_backend.ml_util.
|
|
|
|
:- import_module bool.
|
|
:- import_module counter.
|
|
:- import_module int.
|
|
:- import_module list.
|
|
:- import_module maybe.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module solutions.
|
|
:- import_module string.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- import_module ml_backend.ml_global_data.
|
|
|
|
% Perform the specified action on the whole MLDS.
|
|
%
|
|
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, 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,
|
|
_ScalarCellGroupMap, _VectorCellGroupMap,
|
|
_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)).
|
|
:- mode ml_elim_nested_defns_list(in(hoist), in, in, in, in, out) is det.
|
|
:- mode ml_elim_nested_defns_list(in(chain), in, in, in, in, out) is det.
|
|
|
|
ml_elim_nested_defns_list(_, _, _, _, [], []).
|
|
ml_elim_nested_defns_list(Action, ModuleName, Globals, OuterVars,
|
|
[Defn0 | Defns0], Defns) :-
|
|
ml_elim_nested_defns(Action, ModuleName, Globals, OuterVars, Defn0,
|
|
HeadDefns),
|
|
ml_elim_nested_defns_list(Action, ModuleName, Globals, OuterVars, Defns0,
|
|
TailDefns),
|
|
Defns = HeadDefns ++ TailDefns.
|
|
|
|
% Either eliminated nested functions:
|
|
% Hoist out any nested function occurring in a single mlds_defn.
|
|
% Return a list of mlds_defns that contains no nested functions.
|
|
%
|
|
% Or handle accurate GC: put all variables that might contain pointers
|
|
% in structs and chain these structs together into a "shadow stack".
|
|
% Extract out the code to trace these variables, putting it in a function
|
|
% whose address is stored in the shadow stack frame.
|
|
%
|
|
:- pred ml_elim_nested_defns(action, mlds_module_name, globals, outervars,
|
|
mlds_defn, list(mlds_defn)).
|
|
:- mode ml_elim_nested_defns(in(hoist), in, in, in, in, out) is det.
|
|
:- mode ml_elim_nested_defns(in(chain), in, in, in, in, out) is det.
|
|
|
|
ml_elim_nested_defns(Action, ModuleName, Globals, OuterVars, Defn0, Defns) :-
|
|
Defn0 = mlds_defn(Name, Context, Flags, DefnBody0),
|
|
( if
|
|
DefnBody0 = mlds_function(PredProcId, Params0,
|
|
body_defined_here(FuncBody0), Attributes, EnvVarNames,
|
|
MaybeRequiretailrecInfo),
|
|
% Don't add GC tracing code to the gc_trace/1 primitive!
|
|
% (Doing so would just slow things down unnecessarily.)
|
|
not (
|
|
Name = entity_function(PredLabel, _, _, _),
|
|
PredLabel = mlds_user_pred_label(_, _, "gc_trace", 1, _, _),
|
|
PrivateBuiltin = mercury_private_builtin_module,
|
|
ModuleName = mercury_module_name_to_mlds(PrivateBuiltin)
|
|
)
|
|
then
|
|
EnvName = ml_env_name(Name, Action),
|
|
EnvTypeName = ml_create_env_type_name(EnvName, ModuleName, Globals),
|
|
EnvPtrTypeName = ml_make_env_ptr_type(Globals, EnvTypeName),
|
|
|
|
% Traverse the function body, finding (and removing) any nested
|
|
% functions, and fixing up any references to the arguments or to local
|
|
% variables or local static constants that need to be put in the
|
|
% environment structure (e.g. because they occur in nested functions,
|
|
% or to make them visible to the garbage collector)
|
|
%
|
|
% Also, for accurate GC, add code to save and restore the stack chain
|
|
% pointer at any `try_commit' statements.
|
|
|
|
ElimInfo0 = elim_info_init(ModuleName, OuterVars,
|
|
EnvTypeName, EnvPtrTypeName, Globals),
|
|
Params0 = mlds_func_params(Arguments0, RetValues),
|
|
ml_maybe_add_args(Action, Arguments0, FuncBody0, ModuleName,
|
|
Context, ElimInfo0, ElimInfo1),
|
|
flatten_statement(Action, FuncBody0, FuncBody1, ElimInfo1, ElimInfo2),
|
|
fixup_gc_statements(Action, ElimInfo2, ElimInfo),
|
|
elim_info_finish(ElimInfo, NestedFuncs0, Locals),
|
|
|
|
(
|
|
NestedFuncs0 = [],
|
|
% When hoisting nested functions, if there were no nested
|
|
% functions, we have nothing to do.
|
|
% Likewise, when doing accurate GC, if there were no local
|
|
% variables (or arguments) that contained pointers, then we don't
|
|
% need to chain a stack frame for this function.
|
|
FuncBody = FuncBody1,
|
|
HoistedDefns = []
|
|
;
|
|
NestedFuncs0 = [_ | _],
|
|
% Create a struct to hold the local variables, and initialize
|
|
% the environment pointers for both the containing function
|
|
% and the nested functions. Also generate the GC tracing function,
|
|
% if Action = chain_gc_stack_frames.
|
|
%
|
|
ml_create_env(Action, EnvName, EnvTypeName, Locals, Context,
|
|
ModuleName, Name, Globals, EnvTypeDefn, EnvDecls, InitEnv,
|
|
GCTraceFuncDefns),
|
|
list.map_foldl(
|
|
ml_insert_init_env(Action, EnvTypeName, ModuleName, Globals),
|
|
NestedFuncs0, NestedFuncs, no, InsertedEnv),
|
|
|
|
% Hoist out the nested functions.
|
|
HoistedDefns0 = GCTraceFuncDefns ++ NestedFuncs,
|
|
|
|
% When hoisting nested functions, it is possible that none of the
|
|
% nested functions reference the arguments or locals of the parent
|
|
% function. In that case, there's no need to create an environment,
|
|
% we just need to flatten the functions.
|
|
%
|
|
% Note that we don't generate the env_ptr_args in this module
|
|
% (instead they are generated when the nested functions are
|
|
% generated). This means that we don't avoid generating these
|
|
% arguments. This is not really a big problem, since the code
|
|
% that generates these arguments needs them.
|
|
( if
|
|
Action = hoist_nested_funcs,
|
|
InsertedEnv = no
|
|
then
|
|
FuncBody = FuncBody1,
|
|
HoistedDefns = HoistedDefns0
|
|
else
|
|
% If the function's arguments are referenced by nested
|
|
% functions, or (for accurate GC) may contain pointers,
|
|
% then we need to copy them to local variables in the
|
|
% environment structure.
|
|
ml_maybe_copy_args(Action, ElimInfo, Arguments0, FuncBody0,
|
|
EnvTypeName, EnvPtrTypeName, Context,
|
|
_ArgsToCopy, CodeToCopyArgs),
|
|
|
|
% Insert code to unlink this stack frame before doing any tail
|
|
% calls or returning from the function, either explicitly
|
|
% or implicitly.
|
|
%
|
|
% Add unlink statements before any explicit returns or tail
|
|
% calls.
|
|
(
|
|
Action = hoist_nested_funcs,
|
|
FuncBody2 = FuncBody1
|
|
;
|
|
Action = chain_gc_stack_frames,
|
|
add_unchain_stack_to_statement(Action,
|
|
FuncBody1, FuncBody2, ElimInfo, _ElimInfo)
|
|
),
|
|
% Add a final unlink statement at the end of the function,
|
|
% if needed. This is only needed if the function has no
|
|
% return values -- if there is a return value, then the
|
|
% function must exit with an explicit return statement.
|
|
( if
|
|
Action = chain_gc_stack_frames,
|
|
RetValues = []
|
|
then
|
|
UnchainFrame = [ml_gen_unchain_frame(Context, ElimInfo)]
|
|
else
|
|
UnchainFrame = []
|
|
),
|
|
|
|
% Insert the definition and initialization of the environment
|
|
% struct variable at the start of the top-level function's
|
|
% body, and append the final unlink statement (if any)
|
|
% at the end.
|
|
FuncBody = make_block_stmt(EnvDecls,
|
|
InitEnv ++ CodeToCopyArgs ++ [FuncBody2] ++ UnchainFrame,
|
|
Context),
|
|
% Insert the environment struct type at the start of the list
|
|
% of hoisted definitions (preceding the previously nested
|
|
% functions in HoistedDefns0).
|
|
HoistedDefns = [EnvTypeDefn | HoistedDefns0]
|
|
)
|
|
),
|
|
(
|
|
Action = chain_gc_stack_frames,
|
|
% This pass will have put the GC tracing code for the arguments
|
|
% in the GC tracing function. So we don't need the GC tracing code
|
|
% annotation on the arguments anymore. We delete them here, because
|
|
% otherwise the `#if 0 ... #endif' blocks output for the
|
|
% annotations clutter up the generated C files.
|
|
Arguments = list.map(strip_gc_statement, Arguments0)
|
|
;
|
|
Action = hoist_nested_funcs,
|
|
Arguments = Arguments0
|
|
),
|
|
Params = mlds_func_params(Arguments, RetValues),
|
|
DefnBody = mlds_function(PredProcId, Params,
|
|
body_defined_here(FuncBody), Attributes, EnvVarNames,
|
|
MaybeRequiretailrecInfo),
|
|
Defn = mlds_defn(Name, Context, Flags, DefnBody),
|
|
Defns = list.append(HoistedDefns, [Defn])
|
|
else
|
|
% Leave definitions of things other than functions unchanged.
|
|
Defns = [Defn0]
|
|
).
|
|
|
|
:- func strip_gc_statement(mlds_argument) = mlds_argument.
|
|
|
|
strip_gc_statement(Argument0) = Argument :-
|
|
Argument0 = mlds_argument(Name, Type, _GCStatement),
|
|
Argument = mlds_argument(Name, Type, gc_no_stmt).
|
|
|
|
% Add any arguments which are used in nested functions
|
|
% to the local_data field in the elim_info.
|
|
%
|
|
:- pred ml_maybe_add_args(action, mlds_arguments, statement,
|
|
mlds_module_name, mlds_context, elim_info, elim_info).
|
|
:- mode ml_maybe_add_args(in(hoist), in, in, in, in, in, out) is det.
|
|
:- mode ml_maybe_add_args(in(chain), in, in, in, in, in, out) is det.
|
|
|
|
ml_maybe_add_args(_, [], _, _, _, !Info).
|
|
ml_maybe_add_args(Action, [Arg | Args], FuncBody, ModuleName, Context,
|
|
!Info) :-
|
|
( if
|
|
Arg = mlds_argument(entity_data(mlds_data_var(VarName)), _Type,
|
|
GCStatement),
|
|
ml_should_add_local_data(Action, !.Info, mlds_data_var(VarName),
|
|
GCStatement, [], [FuncBody])
|
|
then
|
|
ml_conv_arg_to_var(Context, Arg, ArgToCopy),
|
|
elim_info_add_local_data(ArgToCopy, !Info)
|
|
else
|
|
true
|
|
),
|
|
ml_maybe_add_args(Action, Args, FuncBody, ModuleName, Context, !Info).
|
|
|
|
% Generate code to copy any arguments which are used in nested functions
|
|
% to the environment struct.
|
|
%
|
|
:- pred ml_maybe_copy_args(action, elim_info, mlds_arguments, statement,
|
|
mlds_type, mlds_type, mlds_context, list(mlds_defn), list(statement)).
|
|
:- mode ml_maybe_copy_args(in(hoist), in, in, in, in, in, in, out, out) is det.
|
|
:- mode ml_maybe_copy_args(in(chain), in, in, in, in, in, in, out, out) is det.
|
|
|
|
ml_maybe_copy_args(_, _, [], _, _, _, _, [], []).
|
|
ml_maybe_copy_args(Action, Info, [Arg | Args], FuncBody, ClassType,
|
|
EnvPtrTypeName, Context, ArgsToCopy, CodeToCopyArgs) :-
|
|
ml_maybe_copy_args(Action, Info, Args, FuncBody, ClassType,
|
|
EnvPtrTypeName, Context, ArgsToCopyTail, CodeToCopyArgsTail),
|
|
ModuleName = elim_info_get_module_name(Info),
|
|
( if
|
|
Arg = mlds_argument(entity_data(mlds_data_var(VarName)), FieldType,
|
|
GCStatement),
|
|
ml_should_add_local_data(Action, Info, mlds_data_var(VarName),
|
|
GCStatement, [], [FuncBody])
|
|
then
|
|
ml_conv_arg_to_var(Context, Arg, ArgToCopy),
|
|
|
|
% Generate code to copy this arg to the environment struct:
|
|
% env_ptr->foo = foo;
|
|
%
|
|
QualVarName = qual(ModuleName, module_qual, VarName),
|
|
Globals = elim_info_get_globals(Info),
|
|
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),
|
|
Tag = yes(0),
|
|
EnvPtrName = env_name_base(Action) ++ "_ptr",
|
|
EnvPtr = ml_lval(ml_var(qual(ModuleName, module_qual,
|
|
mlds_var_name(EnvPtrName, no)), EnvPtrTypeName)),
|
|
EnvArgLval = ml_field(Tag, EnvPtr, FieldName, FieldType,
|
|
EnvPtrTypeName),
|
|
ArgRval = ml_lval(ml_var(QualVarName, FieldType)),
|
|
AssignToEnv = assign(EnvArgLval, ArgRval),
|
|
CodeToCopyArg = statement(ml_stmt_atomic(AssignToEnv), Context),
|
|
|
|
ArgsToCopy = [ArgToCopy | ArgsToCopyTail],
|
|
CodeToCopyArgs = [CodeToCopyArg | CodeToCopyArgsTail]
|
|
else
|
|
ArgsToCopy = ArgsToCopyTail,
|
|
CodeToCopyArgs = CodeToCopyArgsTail
|
|
).
|
|
|
|
% Create the environment struct type.
|
|
%
|
|
:- func ml_create_env_type_name(mlds_class_name, mlds_module_name, globals) =
|
|
mlds_type.
|
|
|
|
ml_create_env_type_name(EnvClassName, ModuleName, Globals) = EnvTypeName :-
|
|
% If we're allocating it on the heap, then we need to use a class type
|
|
% rather than a struct (value type). This is needed for verifiable code
|
|
% on the IL back-end.
|
|
globals.lookup_bool_option(Globals, put_nondet_env_on_heap, OnHeap),
|
|
(
|
|
OnHeap = yes,
|
|
EnvTypeKind = mlds_class
|
|
;
|
|
OnHeap = no,
|
|
EnvTypeKind = mlds_struct
|
|
),
|
|
EnvTypeName = mlds_class_type(qual(ModuleName, module_qual, EnvClassName),
|
|
0, EnvTypeKind).
|
|
|
|
% Create the environment struct type, the declaration of the environment
|
|
% variable, and the declaration and initializer for the environment
|
|
% pointer variable:
|
|
%
|
|
% struct <EnvClassName> {
|
|
% <LocalVars>
|
|
% };
|
|
% struct <EnvClassName> env;
|
|
% struct <EnvClassName> *env_ptr;
|
|
% env_ptr = &env;
|
|
%
|
|
% For accurate GC, we do something similar, but with a few differences:
|
|
%
|
|
% struct <EnvClassName> {
|
|
% /* these fixed fields match `struct MR_StackChain' */
|
|
% void *prev;
|
|
% void (*trace)(...);
|
|
% <LocalVars>
|
|
% };
|
|
% struct <EnvClassName> env = { stack_chain, foo_trace };
|
|
% struct <EnvClassName> *env_ptr;
|
|
% env_ptr = &env;
|
|
% stack_chain = env_ptr;
|
|
%
|
|
:- pred ml_create_env(action::in, mlds_class_name::in, mlds_type::in,
|
|
list(mlds_defn)::in, mlds_context::in, mlds_module_name::in,
|
|
mlds_entity_name::in, globals::in, mlds_defn::out,
|
|
list(mlds_defn)::out, list(statement)::out,
|
|
list(mlds_defn)::out) is det.
|
|
|
|
ml_create_env(Action, EnvClassName, EnvTypeName, LocalVars, Context,
|
|
ModuleName, FuncName, Globals, EnvTypeDefn, EnvDecls, InitEnv,
|
|
GCTraceFuncDefns) :-
|
|
% Generate the following type:
|
|
%
|
|
% struct <EnvClassName> {
|
|
% #ifdef ACCURATE_GC
|
|
% /* these fixed fields match `struct MR_StackChain' */
|
|
% void *prev;
|
|
% void (*trace)(...);
|
|
% #endif
|
|
% <LocalVars>
|
|
% };
|
|
%
|
|
% If we're allocating it on the heap, then we need to use a class type
|
|
% rather than a struct (value type). This is needed for verifiable code
|
|
% on the IL back-end.
|
|
globals.lookup_bool_option(Globals, put_nondet_env_on_heap, OnHeap),
|
|
(
|
|
OnHeap = yes,
|
|
EnvTypeKind = mlds_class,
|
|
BaseClasses = [mlds_generic_env_ptr_type]
|
|
;
|
|
OnHeap = no,
|
|
EnvTypeKind = mlds_struct,
|
|
BaseClasses = []
|
|
),
|
|
EnvTypeEntityName = entity_type(EnvClassName, 0),
|
|
EnvTypeFlags = env_type_decl_flags,
|
|
Fields0 = list.map(convert_local_to_field, LocalVars),
|
|
|
|
% Extract the GC tracing code from the fields.
|
|
list.map3(extract_gc_statements, Fields0, Fields1,
|
|
GC_InitStatements, GC_TraceStatements),
|
|
list.append(GC_InitStatements, GC_TraceStatements, GC_Statements0),
|
|
GC_Statements = list.condense(GC_Statements0),
|
|
|
|
(
|
|
Action = chain_gc_stack_frames,
|
|
ml_chain_stack_frames(Fields1, GC_Statements, EnvTypeName,
|
|
Context, FuncName, ModuleName, Globals, Fields, EnvInitializer,
|
|
LinkStackChain, GCTraceFuncDefns),
|
|
GCStatementEnv = gc_no_stmt
|
|
;
|
|
Action = hoist_nested_funcs,
|
|
(
|
|
GC_Statements = [],
|
|
GCStatementEnv = gc_no_stmt
|
|
;
|
|
GC_Statements = [_ | _],
|
|
GC_Block = make_block_stmt([], GC_Statements, Context),
|
|
GCStatementEnv = gc_trace_code(GC_Block)
|
|
),
|
|
Fields = Fields1,
|
|
EnvInitializer = no_initializer,
|
|
LinkStackChain = [],
|
|
GCTraceFuncDefns = []
|
|
),
|
|
|
|
Imports = [],
|
|
Interfaces = [],
|
|
TypeParams = [],
|
|
Ctors = [], % mlds_to_il.m will add an empty constructor if needed.
|
|
EnvTypeDefnBody = mlds_class(mlds_class_defn(EnvTypeKind, Imports,
|
|
BaseClasses, Interfaces, TypeParams, Ctors, Fields)),
|
|
EnvTypeDefn = mlds_defn(EnvTypeEntityName, Context, EnvTypeFlags,
|
|
EnvTypeDefnBody),
|
|
|
|
% Generate the following variable declaration:
|
|
%
|
|
% struct <EnvClassName> env; // = { ... }
|
|
%
|
|
EnvVarName = mlds_var_name(env_name_base(Action), no),
|
|
EnvVarEntityName = entity_data(mlds_data_var(EnvVarName)),
|
|
EnvVarFlags = ml_gen_local_var_decl_flags,
|
|
EnvVarDefnBody = mlds_data(EnvTypeName, EnvInitializer, GCStatementEnv),
|
|
EnvVarDecl = mlds_defn(EnvVarEntityName, Context, EnvVarFlags,
|
|
EnvVarDefnBody),
|
|
|
|
% Declare the `env_ptr' var, and initialize the `env_ptr' with the
|
|
% address of `env'.
|
|
EnvVar = qual(ModuleName, module_qual, EnvVarName),
|
|
|
|
% Generate code to initialize the environment pointer, either by
|
|
% allocating an object on the heap, or by taking the address of
|
|
% the struct we put on the stack.
|
|
(
|
|
OnHeap = yes,
|
|
EnvVarAddr = ml_lval(ml_var(EnvVar, EnvTypeName)),
|
|
% OnHeap should be "yes" only on for the IL backend, for which
|
|
% the value of MayUseAtomic is immaterial.
|
|
MayUseAtomic = may_not_use_atomic_alloc,
|
|
MaybeAllocId = no,
|
|
NewObj = [statement(
|
|
ml_stmt_atomic(new_object(ml_var(EnvVar, EnvTypeName),
|
|
no, no, EnvTypeName, no, no, [], [], MayUseAtomic,
|
|
MaybeAllocId)),
|
|
Context)]
|
|
;
|
|
OnHeap = no,
|
|
EnvVarAddr = ml_mem_addr(ml_var(EnvVar, EnvTypeName)),
|
|
NewObj = []
|
|
),
|
|
ml_init_env(Action, EnvTypeName, EnvVarAddr, Context, ModuleName,
|
|
Globals, EnvPtrVarDecl, InitEnv0),
|
|
EnvDecls = [EnvVarDecl, EnvPtrVarDecl],
|
|
InitEnv = NewObj ++ [InitEnv0] ++ LinkStackChain.
|
|
|
|
:- pred ml_chain_stack_frames(list(mlds_defn)::in, list(statement)::in,
|
|
mlds_type::in, mlds_context::in, mlds_entity_name::in,
|
|
mlds_module_name::in, globals::in,
|
|
list(mlds_defn)::out, mlds_initializer::out,
|
|
list(statement)::out, list(mlds_defn)::out) is det.
|
|
|
|
ml_chain_stack_frames(Fields0, GCTraceStatements, EnvTypeName, Context,
|
|
FuncName, ModuleName, Globals, Fields,
|
|
EnvInitializer, LinkStackChain, GCTraceFuncDefns) :-
|
|
% Generate code to declare and initialize the environment pointer
|
|
% for the GC trace function from that function's `this_frame' parameter:
|
|
%
|
|
% struct foo_frame *frame;
|
|
% frame = (struct foo_frame *) this_frame;
|
|
%
|
|
ThisFrameName = qual(ModuleName, module_qual,
|
|
mlds_var_name("this_frame", no)),
|
|
ThisFrameRval = ml_lval(ml_var(ThisFrameName, mlds_generic_type)),
|
|
CastThisFrameRval = ml_unop(cast(mlds_ptr_type(EnvTypeName)),
|
|
ThisFrameRval),
|
|
ml_init_env(chain_gc_stack_frames, EnvTypeName, CastThisFrameRval,
|
|
Context, ModuleName, Globals, FramePtrDecl, InitFramePtr),
|
|
|
|
% Put the environment pointer declaration and initialization
|
|
% and the GC tracing code in a function:
|
|
%
|
|
% void foo_trace(void *this_frame) {
|
|
% struct foo_frame *frame;
|
|
% frame = (struct foo_frame *) this_frame;
|
|
% <GCTraceStatements>
|
|
% }
|
|
%
|
|
gen_gc_trace_func(FuncName, ModuleName, FramePtrDecl,
|
|
[InitFramePtr | GCTraceStatements], Context, GCTraceFuncAddr,
|
|
GCTraceFuncParams, GCTraceFuncDefn),
|
|
GCTraceFuncDefns = [GCTraceFuncDefn],
|
|
|
|
% Insert the fixed fields in the struct <EnvClassName>:
|
|
%
|
|
% void *prev;
|
|
% void (*trace)(...);
|
|
%
|
|
PrevFieldName = entity_data(mlds_data_var(mlds_var_name("prev", no))),
|
|
PrevFieldFlags = ml_gen_public_field_decl_flags,
|
|
PrevFieldType = ml_stack_chain_type,
|
|
PrevFieldDefnBody = mlds_data(PrevFieldType, no_initializer, gc_no_stmt),
|
|
PrevFieldDecl = mlds_defn(PrevFieldName, Context, PrevFieldFlags,
|
|
PrevFieldDefnBody),
|
|
|
|
TraceFieldName = entity_data(mlds_data_var(mlds_var_name("trace", no))),
|
|
TraceFieldFlags = ml_gen_public_field_decl_flags,
|
|
TraceFieldType = mlds_func_type(GCTraceFuncParams),
|
|
TraceFieldDefnBody = mlds_data(TraceFieldType, no_initializer, gc_no_stmt),
|
|
TraceFieldDecl = mlds_defn(TraceFieldName, Context, TraceFieldFlags,
|
|
TraceFieldDefnBody),
|
|
|
|
Fields = [PrevFieldDecl, TraceFieldDecl | Fields0],
|
|
|
|
% Set the initializer so that the `prev' field is initialized to the global
|
|
% stack chain, and the `trace' field is initialized to the address of
|
|
% the GC tracing function:
|
|
%
|
|
% ... = { stack_chain, foo_trace };
|
|
%
|
|
% Since there no values for the remaining fields in the initializer,
|
|
% this means the remaining fields will get initialized to zero
|
|
% (C99 6.7.8 #21).
|
|
%
|
|
% XXX This uses a non-const initializer, which is a feature that is only
|
|
% supported in C99 and GNU C; it won't work in C89. We should just generate
|
|
% a bunch of assignments to all the fields, rather than relying on
|
|
% initializers like this.
|
|
%
|
|
StackChain = ml_stack_chain_var,
|
|
EnvInitializer = init_struct(EnvTypeName, [
|
|
init_obj(ml_lval(StackChain)),
|
|
init_obj(ml_const(mlconst_code_addr(GCTraceFuncAddr)))
|
|
]),
|
|
|
|
% Generate code to set the global stack chain
|
|
% to point to the current environment:
|
|
%
|
|
% stack_chain = frame_ptr;
|
|
%
|
|
EnvPtrTypeName = ml_make_env_ptr_type(Globals, EnvTypeName),
|
|
EnvPtr = ml_lval(ml_var(qual(ModuleName, module_qual,
|
|
mlds_var_name("frame_ptr", no)), EnvPtrTypeName)),
|
|
AssignToStackChain = assign(StackChain, EnvPtr),
|
|
LinkStackChain = [statement(ml_stmt_atomic(AssignToStackChain), Context)].
|
|
|
|
:- pred gen_gc_trace_func(mlds_entity_name::in, mlds_module_name::in,
|
|
mlds_defn::in, list(statement)::in, mlds_context::in,
|
|
mlds_code_addr::out, mlds_func_params::out, mlds_defn::out) is det.
|
|
|
|
gen_gc_trace_func(FuncName, PredModule, FramePointerDecl, GCTraceStatements,
|
|
Context, GCTraceFuncAddr, FuncParams, GCTraceFuncDefn) :-
|
|
% Compute the signature of the GC tracing function
|
|
ArgName = entity_data(mlds_data_var(mlds_var_name("this_frame", no))),
|
|
ArgType = mlds_generic_type,
|
|
Argument = mlds_argument(ArgName, ArgType, gc_no_stmt),
|
|
FuncParams = mlds_func_params([Argument], []),
|
|
Signature = mlds_get_func_signature(FuncParams),
|
|
|
|
% Compute the name of the GC tracing function
|
|
%
|
|
% To compute the name, we just take the name of the original function
|
|
% and add 100000 to the original function's sequence number.
|
|
% XXX This is a bit of a hack; maybe we should add
|
|
% another field to the `function' ctor for mlds_entity_name.
|
|
(
|
|
FuncName = entity_function(PredLabel, ProcId, MaybeSeqNum, PredId),
|
|
(
|
|
MaybeSeqNum = yes(SeqNum)
|
|
;
|
|
MaybeSeqNum = no,
|
|
SeqNum = 0
|
|
),
|
|
NewSeqNum = SeqNum + 100000,
|
|
GCTraceFuncName = entity_function(PredLabel, ProcId, yes(NewSeqNum),
|
|
PredId),
|
|
ProcLabel = mlds_proc_label(PredLabel, ProcId),
|
|
QualProcLabel = qual(PredModule, module_qual, ProcLabel),
|
|
GCTraceFuncAddr =
|
|
code_addr_internal(QualProcLabel, NewSeqNum, Signature)
|
|
;
|
|
( FuncName = entity_type(_, _)
|
|
; FuncName = entity_data(_)
|
|
; FuncName = entity_export(_)
|
|
),
|
|
unexpected($module, $pred, "not a function")
|
|
),
|
|
|
|
% Construct the function definition.
|
|
Statement = statement(ml_stmt_block([FramePointerDecl], GCTraceStatements),
|
|
Context),
|
|
DeclFlags = ml_gen_gc_trace_func_decl_flags,
|
|
MaybePredProcId = no,
|
|
Attributes = [],
|
|
EnvVarNames = set.init,
|
|
FuncDefn = mlds_function(MaybePredProcId, FuncParams,
|
|
body_defined_here(Statement), Attributes, EnvVarNames, no),
|
|
GCTraceFuncDefn = mlds_defn(GCTraceFuncName, Context, DeclFlags,
|
|
FuncDefn).
|
|
|
|
% Return the declaration flags appropriate for a procedure definition.
|
|
%
|
|
:- func ml_gen_gc_trace_func_decl_flags = mlds_decl_flags.
|
|
|
|
ml_gen_gc_trace_func_decl_flags = MLDS_DeclFlags :-
|
|
Access = acc_private,
|
|
PerInstance = one_copy,
|
|
Virtuality = non_virtual,
|
|
Overridability = overridable,
|
|
Constness = modifiable,
|
|
Abstractness = concrete,
|
|
MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
|
|
Virtuality, Overridability, Constness, Abstractness).
|
|
|
|
:- pred extract_gc_statements(mlds_defn::in, mlds_defn::out,
|
|
list(statement)::out, list(statement)::out) is det.
|
|
|
|
extract_gc_statements(Defn0, Defn, GCInitStmts, GCTraceStmts) :-
|
|
Defn0 = mlds_defn(Name, Context, Flags, Body0),
|
|
( if Body0 = mlds_data(Type, Init, gc_trace_code(GCTraceStmt)) then
|
|
Body = mlds_data(Type, Init, gc_no_stmt),
|
|
GCInitStmts = [],
|
|
GCTraceStmts = [GCTraceStmt],
|
|
Defn = mlds_defn(Name, Context, Flags, Body)
|
|
else if Body0 = mlds_data(Type, Init, gc_initialiser(GCInitStmt)) then
|
|
Body = mlds_data(Type, Init, gc_no_stmt),
|
|
GCInitStmts = [GCInitStmt],
|
|
GCTraceStmts = [],
|
|
Defn = mlds_defn(Name, Context, Flags, Body)
|
|
else
|
|
Defn = Defn0,
|
|
GCInitStmts = [],
|
|
GCTraceStmts = []
|
|
).
|
|
|
|
% When converting local variables into fields of the environment struct,
|
|
% we need to change `local' access into something else, since `local'
|
|
% is only supposed to be used for entities that are local to a function
|
|
% or block, not for fields. Currently we change it to `public'.
|
|
% (Perhaps changing it to `default' might be better?)
|
|
%
|
|
:- func convert_local_to_field(mlds_defn) = mlds_defn.
|
|
|
|
convert_local_to_field(Defn0) = Defn :-
|
|
Defn0 = mlds_defn(Name, Context, Flags0, Body),
|
|
( if access(Flags0) = acc_local then
|
|
Flags = set_access(Flags0, acc_public),
|
|
Defn = mlds_defn(Name, Context, Flags, Body)
|
|
else
|
|
Defn = Defn0
|
|
).
|
|
|
|
% ml_insert_init_env:
|
|
%
|
|
% If the definition is a nested function definition, and its body makes
|
|
% use of the environment pointer (`env_ptr'), then insert code to declare
|
|
% and initialize the environment pointer.
|
|
%
|
|
% We transform code of the form
|
|
% <Ret> <Func>(<Args>) {
|
|
% <Body>
|
|
% }
|
|
% to
|
|
% <Ret> <Func>(<Args>) {
|
|
% struct <EnvClassName> *env_ptr;
|
|
% env_ptr = (<EnvClassName> *) env_ptr_arg;
|
|
% <Body>
|
|
% }
|
|
%
|
|
% If we perform this transformation, set Init to "yes",
|
|
% otherwise leave it unchanged.
|
|
%
|
|
:- pred ml_insert_init_env(action::in, mlds_type::in, mlds_module_name::in,
|
|
globals::in, mlds_defn::in, mlds_defn::out, bool::in, bool::out)
|
|
is det.
|
|
|
|
ml_insert_init_env(Action, TypeName, ModuleName, Globals, Defn0, Defn,
|
|
Init0, Init) :-
|
|
Defn0 = mlds_defn(Name, Context, Flags, DefnBody0),
|
|
( if
|
|
DefnBody0 = mlds_function(PredProcId, Params,
|
|
body_defined_here(FuncBody0), Attributes, EnvVarNames,
|
|
MaybeRequiretailrecInfo),
|
|
statement_contains_var(FuncBody0, qual(ModuleName, module_qual,
|
|
mlds_data_var(mlds_var_name("env_ptr", no)))) = yes
|
|
then
|
|
EnvPtrVal = ml_lval(ml_var(qual(ModuleName, module_qual,
|
|
mlds_var_name("env_ptr_arg", no)),
|
|
mlds_generic_env_ptr_type)),
|
|
EnvPtrVarType = ml_make_env_ptr_type(Globals, TypeName),
|
|
|
|
% Insert a cast, to downcast from mlds_generic_env_ptr_type to the
|
|
% specific environment type for this procedure.
|
|
CastEnvPtrVal = ml_unop(cast(EnvPtrVarType), EnvPtrVal),
|
|
|
|
ml_init_env(Action, TypeName, CastEnvPtrVal, Context,
|
|
ModuleName, Globals, EnvPtrDecl, InitEnvPtr),
|
|
FuncBody = statement(ml_stmt_block([EnvPtrDecl],
|
|
[InitEnvPtr, FuncBody0]), Context),
|
|
DefnBody = mlds_function(PredProcId, Params,
|
|
body_defined_here(FuncBody), Attributes, EnvVarNames,
|
|
MaybeRequiretailrecInfo),
|
|
Defn = mlds_defn(Name, Context, Flags, DefnBody),
|
|
Init = yes
|
|
else
|
|
Defn = Defn0,
|
|
Init = Init0
|
|
).
|
|
|
|
:- func ml_make_env_ptr_type(globals, mlds_type) = mlds_type.
|
|
|
|
ml_make_env_ptr_type(_Globals, EnvType) = EnvPtrType :-
|
|
EnvPtrType = mlds_ptr_type(EnvType).
|
|
|
|
% Create the environment pointer and initialize it:
|
|
%
|
|
% struct <EnvClassName> *env_ptr;
|
|
% env_ptr = <EnvPtrVal>;
|
|
%
|
|
:- pred ml_init_env(action::in, mlds_type::in, mlds_rval::in,
|
|
mlds_context::in, mlds_module_name::in, globals::in,
|
|
mlds_defn::out, statement::out) is det.
|
|
|
|
ml_init_env(Action, EnvTypeName, EnvPtrVal, Context, ModuleName, Globals,
|
|
EnvPtrVarDecl, InitEnvPtr) :-
|
|
% Generate the following variable declaration:
|
|
%
|
|
% <EnvTypeName> *env_ptr;
|
|
%
|
|
EnvPtrVarName = mlds_var_name(env_name_base(Action) ++ "_ptr", no),
|
|
EnvPtrVarEntityName = entity_data(mlds_data_var(EnvPtrVarName)),
|
|
EnvPtrVarFlags = ml_gen_local_var_decl_flags,
|
|
EnvPtrVarType = ml_make_env_ptr_type(Globals, EnvTypeName),
|
|
% The env_ptr never needs to be traced by the GC, since the environment
|
|
% that it points to will always be on the stack, not into the heap.
|
|
GCStatement = gc_no_stmt,
|
|
EnvPtrVarDefnBody = mlds_data(EnvPtrVarType, no_initializer,
|
|
GCStatement),
|
|
EnvPtrVarDecl = mlds_defn(EnvPtrVarEntityName, Context,
|
|
EnvPtrVarFlags, EnvPtrVarDefnBody),
|
|
|
|
% Generate the following statement:
|
|
%
|
|
% env_ptr = <EnvPtrVal>;
|
|
%
|
|
% (note that the caller of this routine is responsible
|
|
% for inserting a cast in <EnvPtrVal> if needed).
|
|
%
|
|
EnvPtrVar = qual(ModuleName, module_qual, EnvPtrVarName),
|
|
AssignEnvPtr = assign(ml_var(EnvPtrVar, EnvPtrVarType), EnvPtrVal),
|
|
InitEnvPtr = statement(ml_stmt_atomic(AssignEnvPtr), Context).
|
|
|
|
% Given the declaration for a function parameter, produce a declaration
|
|
% for a corresponding local variable or environment struct field.
|
|
% We need to do this so as to include function parameter in the
|
|
% environment struct.
|
|
%
|
|
:- pred ml_conv_arg_to_var(mlds_context::in, mlds_argument::in,
|
|
mlds_defn::out) is det.
|
|
|
|
ml_conv_arg_to_var(Context, Arg, LocalVar) :-
|
|
Arg = mlds_argument(Name, Type, GCStatement),
|
|
Flags = ml_gen_local_var_decl_flags,
|
|
DefnBody = mlds_data(Type, no_initializer, GCStatement),
|
|
LocalVar = mlds_defn(Name, Context, Flags, DefnBody).
|
|
|
|
% Return the declaration flags appropriate for an environment struct
|
|
% type declaration.
|
|
%
|
|
:- func env_type_decl_flags = mlds_decl_flags.
|
|
|
|
env_type_decl_flags = MLDS_DeclFlags :-
|
|
Access = acc_private,
|
|
PerInstance = one_copy,
|
|
Virtuality = non_virtual,
|
|
Overridability = overridable,
|
|
Constness = modifiable,
|
|
Abstractness = concrete,
|
|
MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
|
|
Virtuality, Overridability, Constness, Abstractness).
|
|
|
|
% Generate a block statement, i.e. `{ <Decls>; <Statements>; }'.
|
|
% But if the block consists only of a single statement with no
|
|
% declarations, then just return that statement.
|
|
%
|
|
:- func make_block_stmt(list(mlds_defn), list(statement), mlds_context)
|
|
= statement.
|
|
|
|
make_block_stmt(VarDecls, Statements, Context) =
|
|
( if
|
|
VarDecls = [],
|
|
Statements = [SingleStatement]
|
|
then
|
|
SingleStatement
|
|
else
|
|
statement(ml_stmt_block(VarDecls, Statements), Context)
|
|
).
|
|
|
|
:- func ml_stack_chain_var = mlds_lval.
|
|
|
|
ml_stack_chain_var = StackChain :-
|
|
PrivateBuiltin = mercury_private_builtin_module,
|
|
MLDS_Module = mercury_module_name_to_mlds(PrivateBuiltin),
|
|
StackChain = ml_var(qual(MLDS_Module, module_qual,
|
|
mlds_var_name("stack_chain", no)), ml_stack_chain_type).
|
|
|
|
% The type of the `stack_chain' pointer, i.e. `void *'.
|
|
%
|
|
:- func ml_stack_chain_type = mlds_type.
|
|
|
|
ml_stack_chain_type = mlds_generic_env_ptr_type.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% This code does some name mangling.
|
|
% It essentially duplicates the functionality in mlds_output_name.
|
|
%
|
|
% Doing name mangling here is probably a bad idea; it might be better
|
|
% to change the MLDS data structure to allow structured type names, so that
|
|
% we don't have to do any name mangling at this point.
|
|
|
|
% Compute the name to use for the environment struct
|
|
% for the specified function.
|
|
%
|
|
:- func ml_env_name(mlds_entity_name, action) = mlds_class_name.
|
|
|
|
ml_env_name(entity_type(_, _), _) = _ :-
|
|
unexpected($module, $pred, "expected function, got type").
|
|
ml_env_name(entity_data(_), _) = _ :-
|
|
unexpected($module, $pred, "expected function, got data").
|
|
ml_env_name(entity_function(PredLabel, ProcId, MaybeSeqNum, _PredId), Action)
|
|
= ClassName :-
|
|
Base = env_name_base(Action),
|
|
PredLabelString = ml_pred_label_name(PredLabel),
|
|
proc_id_to_int(ProcId, ModeNum),
|
|
(
|
|
MaybeSeqNum = yes(SeqNum),
|
|
string.format("%s_%d_%d_%s",
|
|
[s(PredLabelString), i(ModeNum), i(SeqNum), s(Base)], ClassName)
|
|
;
|
|
MaybeSeqNum = no,
|
|
string.format("%s_%d_%s",
|
|
[s(PredLabelString), i(ModeNum), s(Base)], ClassName)
|
|
).
|
|
ml_env_name(entity_export(_), _) = _ :-
|
|
unexpected($module, $pred, "expected function, got export").
|
|
|
|
:- func env_name_base(action) = string.
|
|
|
|
env_name_base(chain_gc_stack_frames) = "frame".
|
|
env_name_base(hoist_nested_funcs) = "env".
|
|
|
|
:- func ml_pred_label_name(mlds_pred_label) = string.
|
|
|
|
ml_pred_label_name(mlds_user_pred_label(PredOrFunc, MaybeDefiningModule,
|
|
Name, Arity, _CodeModel, _NonOutputFunc)) = LabelName :-
|
|
( PredOrFunc = pf_predicate, Suffix = "p"
|
|
; PredOrFunc = pf_function, Suffix = "f"
|
|
),
|
|
(
|
|
MaybeDefiningModule = yes(DefiningModule),
|
|
ModuleNameString = ml_module_name_string(DefiningModule),
|
|
string.format("%s_%d_%s_in__%s",
|
|
[s(Name), i(Arity), s(Suffix), s(ModuleNameString)], LabelName)
|
|
;
|
|
MaybeDefiningModule = no,
|
|
string.format("%s_%d_%s",
|
|
[s(Name), i(Arity), s(Suffix)], LabelName)
|
|
).
|
|
ml_pred_label_name(mlds_special_pred_label(PredName, MaybeTypeModule,
|
|
TypeName, TypeArity)) = LabelName :-
|
|
(
|
|
MaybeTypeModule = yes(TypeModule),
|
|
TypeModuleString = ml_module_name_string(TypeModule),
|
|
string.format("%s__%s__%s_%d",
|
|
[s(PredName), s(TypeModuleString), s(TypeName), i(TypeArity)],
|
|
LabelName)
|
|
;
|
|
MaybeTypeModule = no,
|
|
string.format("%s__%s_%d",
|
|
[s(PredName), s(TypeName), i(TypeArity)], LabelName)
|
|
).
|
|
|
|
:- func ml_module_name_string(mercury_module_name) = string.
|
|
|
|
ml_module_name_string(ModuleName) = sym_name_to_string_sep(ModuleName, "__").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% flatten_function_body:
|
|
% flatten_maybe_statement:
|
|
% flatten_gc_statement:
|
|
% flatten_statements:
|
|
% flatten_statement:
|
|
%
|
|
% Recursively process the statement(s), calling fixup_var on every use
|
|
% of a variable inside them, and calling flatten_nested_defns for every
|
|
% definition they contain (e.g. definitions of local variables and nested
|
|
% functions).
|
|
%
|
|
% Also, for Action = chain_gc_stack_frames, add code to save and restore
|
|
% the stack chain pointer at any `try_commit' statements.
|
|
|
|
:- pred flatten_function_body(action, mlds_function_body, mlds_function_body,
|
|
elim_info, elim_info).
|
|
:- mode flatten_function_body(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_function_body(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_function_body(_, body_external, body_external, !Info).
|
|
flatten_function_body(Action, body_defined_here(Statement0),
|
|
body_defined_here(Statement), !Info) :-
|
|
flatten_statement(Action, Statement0, Statement, !Info).
|
|
|
|
:- pred flatten_maybe_statement(action, maybe(statement), maybe(statement),
|
|
elim_info, elim_info).
|
|
:- mode flatten_maybe_statement(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_maybe_statement(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_maybe_statement(_, no, no, !Info).
|
|
flatten_maybe_statement(Action, yes(Statement0), yes(Statement), !Info) :-
|
|
flatten_statement(Action, Statement0, Statement, !Info).
|
|
|
|
:- pred flatten_gc_statement(action, mlds_gc_statement, mlds_gc_statement,
|
|
elim_info, elim_info).
|
|
:- mode flatten_gc_statement(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_gc_statement(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_gc_statement(Action, GCStmt0, GCStmt, !Info) :-
|
|
(
|
|
GCStmt0 = gc_no_stmt,
|
|
GCStmt = gc_no_stmt
|
|
;
|
|
GCStmt0 = gc_trace_code(Statement0),
|
|
flatten_statement(Action, Statement0, Statement, !Info),
|
|
GCStmt = gc_trace_code(Statement)
|
|
;
|
|
GCStmt0 = gc_initialiser(Statement0),
|
|
flatten_statement(Action, Statement0, Statement, !Info),
|
|
GCStmt = gc_initialiser(Statement)
|
|
).
|
|
|
|
:- pred flatten_statements(action, list(statement), list(statement),
|
|
elim_info, elim_info).
|
|
:- mode flatten_statements(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_statements(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_statements(_, [], [], !Info).
|
|
flatten_statements(Action, [Statement0 | Statements0],
|
|
[Statement | Statements], !Info) :-
|
|
flatten_statement(Action, Statement0, Statement, !Info),
|
|
flatten_statements(Action, Statements0, Statements, !Info).
|
|
|
|
:- pred flatten_statement(action, statement, statement, elim_info, elim_info).
|
|
:- mode flatten_statement(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_statement(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_statement(Action, Statement0, Statement, !Info) :-
|
|
Statement0 = statement(Stmt0, Context),
|
|
flatten_stmt(Action, Stmt0, Stmt, !Info),
|
|
Statement = statement(Stmt, Context).
|
|
|
|
:- pred flatten_stmt(action, mlds_stmt, mlds_stmt, elim_info, elim_info).
|
|
:- mode flatten_stmt(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_stmt(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_stmt(Action, Stmt0, Stmt, !Info) :-
|
|
(
|
|
Stmt0 = ml_stmt_block(Defns0, Statements0),
|
|
flatten_nested_defns(Action, Defns0, Statements0, Defns,
|
|
InitStatements, !Info),
|
|
flatten_statements(Action, InitStatements ++ Statements0, Statements,
|
|
!Info),
|
|
Stmt = ml_stmt_block(Defns, Statements)
|
|
;
|
|
Stmt0 = ml_stmt_while(Kind, Rval0, Statement0),
|
|
fixup_rval(Action, !.Info, Rval0, Rval),
|
|
flatten_statement(Action, Statement0, Statement, !Info),
|
|
Stmt = ml_stmt_while(Kind, Rval, Statement)
|
|
;
|
|
Stmt0 = ml_stmt_if_then_else(Cond0, Then0, MaybeElse0),
|
|
fixup_rval(Action, !.Info, Cond0, Cond),
|
|
flatten_statement(Action, Then0, Then, !Info),
|
|
flatten_maybe_statement(Action, MaybeElse0, MaybeElse, !Info),
|
|
Stmt = ml_stmt_if_then_else(Cond, Then, MaybeElse)
|
|
;
|
|
Stmt0 = ml_stmt_switch(Type, Val0, Range, Cases0, Default0),
|
|
fixup_rval(Action, !.Info, Val0, Val),
|
|
flatten_cases(Action, Cases0, Cases, !Info),
|
|
flatten_default(Action, Default0, Default, !Info),
|
|
Stmt = ml_stmt_switch(Type, Val, Range, Cases, Default)
|
|
;
|
|
Stmt0 = ml_stmt_label(_),
|
|
Stmt = Stmt0
|
|
;
|
|
Stmt0 = ml_stmt_goto(_),
|
|
Stmt = Stmt0
|
|
;
|
|
Stmt0 = ml_stmt_computed_goto(Rval0, Labels),
|
|
fixup_rval(Action, !.Info, Rval0, Rval),
|
|
Stmt = ml_stmt_computed_goto(Rval, Labels)
|
|
;
|
|
Stmt0 = ml_stmt_call(Sig, Func0, Obj0, Args0, RetLvals0, TailCall),
|
|
fixup_rval(Action, !.Info, Func0, Func),
|
|
fixup_maybe_rval(Action, !.Info, Obj0, Obj),
|
|
fixup_rvals(Action, !.Info, Args0, Args),
|
|
fixup_lvals(Action, !.Info, RetLvals0, RetLvals),
|
|
Stmt = ml_stmt_call(Sig, Func, Obj, Args, RetLvals, TailCall)
|
|
;
|
|
Stmt0 = ml_stmt_return(Rvals0),
|
|
fixup_rvals(Action, !.Info, Rvals0, Rvals),
|
|
Stmt = ml_stmt_return(Rvals)
|
|
;
|
|
Stmt0 = ml_stmt_do_commit(Ref0),
|
|
fixup_rval(Action, !.Info, Ref0, Ref),
|
|
Stmt = ml_stmt_do_commit(Ref)
|
|
;
|
|
Stmt0 = ml_stmt_try_commit(Ref0, Statement0, Handler0),
|
|
fixup_lval(Action, !.Info, Ref0, Ref),
|
|
flatten_statement(Action, Statement0, Statement1, !Info),
|
|
flatten_statement(Action, Handler0, Handler1, !Info),
|
|
Stmt1 = ml_stmt_try_commit(Ref, Statement1, Handler1),
|
|
(
|
|
Action = chain_gc_stack_frames,
|
|
save_and_restore_stack_chain(Stmt1, Stmt, !Info)
|
|
;
|
|
Action = hoist_nested_funcs,
|
|
Stmt = Stmt1
|
|
)
|
|
;
|
|
Stmt0 = ml_stmt_atomic(AtomicStmt0),
|
|
fixup_atomic_stmt(Action, !.Info, AtomicStmt0, AtomicStmt),
|
|
Stmt = ml_stmt_atomic(AtomicStmt)
|
|
).
|
|
|
|
:- pred flatten_cases(action, list(mlds_switch_case), list(mlds_switch_case),
|
|
elim_info, elim_info).
|
|
:- mode flatten_cases(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_cases(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_cases(_, [], [], !Info).
|
|
flatten_cases(Action, [Case0 | Cases0], [Case | Cases], !Info) :-
|
|
flatten_case(Action, Case0, Case, !Info),
|
|
flatten_cases(Action, Cases0, Cases, !Info).
|
|
|
|
:- pred flatten_case(action, mlds_switch_case, mlds_switch_case,
|
|
elim_info, elim_info).
|
|
:- mode flatten_case(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_case(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_case(Action, Case0, Case, !Info) :-
|
|
Case0 = mlds_switch_case(FirstCond0, LaterConds0, Statement0),
|
|
fixup_case_cond(Action, !.Info, FirstCond0, FirstCond),
|
|
fixup_case_conds(Action, !.Info, LaterConds0, LaterConds),
|
|
flatten_statement(Action, Statement0, Statement, !Info),
|
|
Case = mlds_switch_case(FirstCond, LaterConds, Statement).
|
|
|
|
:- pred flatten_default(action, mlds_switch_default, mlds_switch_default,
|
|
elim_info, elim_info).
|
|
:- mode flatten_default(in(hoist), in, out, in, out) is det.
|
|
:- mode flatten_default(in(chain), in, out, in, out) is det.
|
|
|
|
flatten_default(Action, Default0, Default, !Info) :-
|
|
(
|
|
Default0 = default_is_unreachable,
|
|
Default = default_is_unreachable
|
|
;
|
|
Default0 = default_do_nothing,
|
|
Default = default_do_nothing
|
|
;
|
|
Default0 = default_case(Statement0),
|
|
flatten_statement(Action, Statement0, Statement, !Info),
|
|
Default = default_case(Statement)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% add code to save/restore the stack chain pointer:
|
|
% convert
|
|
% try {
|
|
% Statement
|
|
% } commit {
|
|
% Handler
|
|
% }
|
|
% into
|
|
% {
|
|
% void *saved_stack_chain;
|
|
% try {
|
|
% saved_stack_chain = stack_chain;
|
|
% Statement
|
|
% } commit {
|
|
% stack_chain = saved_stack_chain;
|
|
% Handler
|
|
% }
|
|
% }
|
|
%
|
|
:- inst try_commit
|
|
---> ml_stmt_try_commit(ground, ground, ground).
|
|
|
|
:- pred save_and_restore_stack_chain(mlds_stmt::in(try_commit),
|
|
mlds_stmt::out, elim_info::in, elim_info::out) is det.
|
|
|
|
save_and_restore_stack_chain(Stmt0, Stmt, !ElimInfo) :-
|
|
ModuleName = elim_info_get_module_name(!.ElimInfo),
|
|
elim_info_allocate_saved_stack_chain_id(Id, !ElimInfo),
|
|
|
|
Stmt0 = ml_stmt_try_commit(Ref, Statement0, Handler0),
|
|
Statement0 = statement(_, StatementContext),
|
|
Handler0 = statement(_, HandlerContext),
|
|
SavedVarDecl = gen_saved_stack_chain_var(Id, StatementContext),
|
|
SaveStatement = gen_save_stack_chain_var(ModuleName, Id, StatementContext),
|
|
RestoreStatement = gen_restore_stack_chain_var(ModuleName, Id,
|
|
HandlerContext),
|
|
Statement = statement(ml_stmt_block([], [SaveStatement, Statement0]),
|
|
HandlerContext),
|
|
Handler = statement(ml_stmt_block([], [RestoreStatement, Handler0]),
|
|
HandlerContext),
|
|
TryCommit = ml_stmt_try_commit(Ref, Statement, Handler),
|
|
Stmt = ml_stmt_block(
|
|
[SavedVarDecl],
|
|
[statement(TryCommit, StatementContext)]
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% flatten_nested_defns:
|
|
% flatten_nested_defn:
|
|
%
|
|
% Hoist out nested function definitions, and any local variables that need
|
|
% to go in the environment struct (e.g. because they are referenced by
|
|
% nested functions), storing them both in the elim_info. Convert initializers
|
|
% for local variables that need to go in the environment struct into assignment
|
|
% statements. Return the remaining (non-hoisted) definitions, the list of
|
|
% assignment statements, and the updated elim_info.
|
|
|
|
:- pred flatten_nested_defns(action, list(mlds_defn), list(statement),
|
|
list(mlds_defn), list(statement), elim_info, elim_info).
|
|
:- mode flatten_nested_defns(in(hoist), in, in, out, out, in, out) is det.
|
|
:- mode flatten_nested_defns(in(chain), in, in, out, out, in, out) is det.
|
|
|
|
flatten_nested_defns(_, [], _, [], [], !Info).
|
|
flatten_nested_defns(Action, [Defn0 | Defns0], FollowingStatements, Defns,
|
|
InitStatements, !Info) :-
|
|
flatten_nested_defn(Action, Defn0, Defns0, FollowingStatements,
|
|
Defns1, InitStatements1, !Info),
|
|
flatten_nested_defns(Action, Defns0, FollowingStatements,
|
|
Defns2, InitStatements2, !Info),
|
|
Defns = Defns1 ++ Defns2,
|
|
InitStatements = InitStatements1 ++ InitStatements2.
|
|
|
|
:- pred flatten_nested_defn(action, mlds_defn, list(mlds_defn),
|
|
list(statement), list(mlds_defn), list(statement),
|
|
elim_info, elim_info).
|
|
:- mode flatten_nested_defn(in(hoist), in, in, in, out, out, in, out) is det.
|
|
:- mode flatten_nested_defn(in(chain), in, in, in, out, out, in, out) is det.
|
|
|
|
flatten_nested_defn(Action, Defn0, FollowingDefns, FollowingStatements,
|
|
Defns, InitStatements, !Info) :-
|
|
Defn0 = mlds_defn(Name, Context, Flags0, DefnBody0),
|
|
(
|
|
DefnBody0 = mlds_function(PredProcId, Params, FuncBody0, Attributes,
|
|
EnvVarNames, MaybeRequiretailrecInfo),
|
|
% Recursively flatten the nested function.
|
|
flatten_function_body(Action, FuncBody0, FuncBody, !Info),
|
|
|
|
% Mark the function as private / one_copy,
|
|
% rather than as local / per_instance,
|
|
% if we're about to hoist it out to the top level.
|
|
(
|
|
Action = hoist_nested_funcs,
|
|
Flags1 = set_access(Flags0, acc_private),
|
|
Flags = set_per_instance(Flags1, one_copy)
|
|
;
|
|
Action = chain_gc_stack_frames,
|
|
Flags = Flags0
|
|
),
|
|
DefnBody = mlds_function(PredProcId, Params, FuncBody, Attributes,
|
|
EnvVarNames, MaybeRequiretailrecInfo),
|
|
Defn = mlds_defn(Name, Context, Flags, DefnBody),
|
|
(
|
|
Action = hoist_nested_funcs,
|
|
% Note that we assume that we can safely hoist stuff inside nested
|
|
% functions into the containing function. If that wasn't the case,
|
|
% we'd need code something like this:
|
|
% LocalVars = elim_info_get_local_data(ElimInfo),
|
|
% OuterVars0 = elim_info_get_outer_vars(ElimInfo),
|
|
% OuterVars = [LocalVars | OuterVars0],
|
|
% FlattenedDefns = ml_elim_nested_defns(ModuleName,
|
|
% OuterVars, Defn0),
|
|
% list.foldl(elim_info_add_nested_func, FlattenedDefns),
|
|
|
|
% Strip out the now flattened nested function, and store it
|
|
% in the elim_info.
|
|
elim_info_add_nested_func(Defn, !Info),
|
|
Defns = []
|
|
;
|
|
Action = chain_gc_stack_frames,
|
|
Defns = [Defn]
|
|
),
|
|
InitStatements = []
|
|
;
|
|
DefnBody0 = mlds_data(Type, Init0, GCStatement0),
|
|
% For local variable definitions, if they are referenced by any nested
|
|
% functions, then strip them out and store them in the elim_info.
|
|
( if
|
|
% Hoist ordinary local variables.
|
|
Name = entity_data(DataName),
|
|
DataName = mlds_data_var(VarName),
|
|
ml_should_add_local_data(Action, !.Info,
|
|
DataName, GCStatement0,
|
|
FollowingDefns, FollowingStatements)
|
|
then
|
|
% We need to strip out the initializer (if any) and convert it
|
|
% into an assignment statement, since this local variable
|
|
% is going to become a field, and fields can't have initializers.
|
|
( if Init0 = init_obj(Rval) then
|
|
% XXX Bug! Converting the initializer to an assignment doesn't
|
|
% work, because it doesn't handle the case when initializers in
|
|
% FollowingDefns reference this variable.
|
|
Init1 = no_initializer,
|
|
DefnBody1 = mlds_data(Type, Init1, GCStatement0),
|
|
Defn1 = mlds_defn(Name, Context, Flags0, DefnBody1),
|
|
ModuleName = elim_info_get_module_name(!.Info),
|
|
VarLval = ml_var(qual(ModuleName, module_qual, VarName), Type),
|
|
InitStmt = ml_stmt_atomic(assign(VarLval, Rval)),
|
|
InitStatements = [statement(InitStmt, Context)]
|
|
else
|
|
Defn1 = Defn0,
|
|
InitStatements = []
|
|
),
|
|
elim_info_add_local_data(Defn1, !Info),
|
|
Defns = []
|
|
else
|
|
fixup_initializer(Action, !.Info, Init0, Init),
|
|
DefnBody = mlds_data(Type, Init, GCStatement0),
|
|
Defn = mlds_defn(Name, Context, Flags0, DefnBody),
|
|
Defns = [Defn],
|
|
InitStatements = []
|
|
)
|
|
;
|
|
DefnBody0 = mlds_class(_),
|
|
% Leave nested class declarations alone.
|
|
%
|
|
% XXX That might not be the right thing to do, but currently
|
|
% ml_code_gen.m doesn't generate any of these, so it doesn't matter
|
|
% what we do.
|
|
Defns = [Defn0],
|
|
InitStatements = []
|
|
).
|
|
|
|
% Succeed iff we should add the definition of this variable to the
|
|
% local_data field of the elim_info, meaning that it should be added
|
|
% to the environment struct (if it's a variable) or hoisted out to the
|
|
% top level (if it's a static const).
|
|
%
|
|
:- pred ml_should_add_local_data(action, elim_info, mlds_data_name,
|
|
mlds_gc_statement, list(mlds_defn), list(statement)).
|
|
:- mode ml_should_add_local_data(in(hoist), in, in, in, in, in) is semidet.
|
|
:- mode ml_should_add_local_data(in(chain), in, in, in, in, in) is semidet.
|
|
|
|
ml_should_add_local_data(Action, Info, DataName, GCStatement,
|
|
FollowingDefns, FollowingStatements) :-
|
|
(
|
|
Action = chain_gc_stack_frames,
|
|
(
|
|
GCStatement = gc_trace_code(_)
|
|
;
|
|
GCStatement = gc_initialiser(_)
|
|
)
|
|
;
|
|
Action = hoist_nested_funcs,
|
|
ModuleName = elim_info_get_module_name(Info),
|
|
ml_need_to_hoist(ModuleName, DataName,
|
|
FollowingDefns, FollowingStatements)
|
|
).
|
|
|
|
% This checks for a nested function definition.
|
|
%
|
|
% XXX Do we need to check for references from the GCStatement
|
|
% fields here?
|
|
%
|
|
% XXX This algorithm is quadratic. For a block with N defs, each of which
|
|
% is referenced in a later definition, we do N^2 tests.
|
|
%
|
|
:- pred ml_need_to_hoist(mlds_module_name::in, mlds_data_name::in,
|
|
list(mlds_defn)::in, list(statement)::in) is semidet.
|
|
|
|
ml_need_to_hoist(ModuleName, DataName, FollowingDefns, FollowingStatements) :-
|
|
QualDataName = qual(ModuleName, module_qual, DataName),
|
|
Filter = ml_need_to_hoist_defn(QualDataName),
|
|
(
|
|
list.find_first_match(Filter, FollowingDefns, _)
|
|
;
|
|
statements_contains_matching_defn(Filter, FollowingStatements)
|
|
).
|
|
|
|
:- pred ml_need_to_hoist_defn(mlds_fully_qualified_name(mlds_data_name)::in,
|
|
mlds_defn::in) is semidet.
|
|
|
|
ml_need_to_hoist_defn(QualDataName, FollowingDefn) :-
|
|
FollowingDefn = mlds_defn(_, _, _, mlds_function(_, _, _, _, _, _)),
|
|
defn_contains_var(FollowingDefn, QualDataName) = yes.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% fixup_initializers:
|
|
% fixup_initializer:
|
|
% fixup_atomic_stmt:
|
|
% fixup_case_conds:
|
|
% fixup_case_cond:
|
|
% fixup_target_code_components:
|
|
% fixup_target_code_component:
|
|
% fixup_trail_op:
|
|
% fixup_rvals:
|
|
% fixup_maybe_rval:
|
|
% fixup_rval:
|
|
% fixup_lvals:
|
|
% fixup_lval:
|
|
%
|
|
% Recursively process the specified construct, calling fixup_var on
|
|
% every variable inside it.
|
|
|
|
:- pred fixup_initializers(action, elim_info,
|
|
list(mlds_initializer), list(mlds_initializer)).
|
|
:- mode fixup_initializers(in(hoist), in, in, out) is det.
|
|
:- mode fixup_initializers(in(chain), in, in, out) is det.
|
|
|
|
fixup_initializers(_, _, [], []).
|
|
fixup_initializers(Action, Info,
|
|
[Initializer0 | Initializers0], [Initializer | Initializers]) :-
|
|
fixup_initializer(Action, Info, Initializer0, Initializer),
|
|
fixup_initializers(Action, Info, Initializers0, Initializers).
|
|
|
|
:- pred fixup_initializer(action, elim_info,
|
|
mlds_initializer, mlds_initializer).
|
|
:- mode fixup_initializer(in(hoist), in, in, out) is det.
|
|
:- mode fixup_initializer(in(chain), in, in, out) is det.
|
|
|
|
fixup_initializer(Action, Info, Initializer0, Initializer) :-
|
|
(
|
|
Initializer0 = no_initializer,
|
|
Initializer = Initializer0
|
|
;
|
|
Initializer0 = init_obj(Rval0),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Initializer = init_obj(Rval)
|
|
;
|
|
Initializer0 = init_struct(Type, Members0),
|
|
fixup_initializers(Action, Info, Members0, Members),
|
|
Initializer = init_struct(Type, Members)
|
|
;
|
|
Initializer0 = init_array(Elements0),
|
|
fixup_initializers(Action, Info, Elements0, Elements),
|
|
Initializer = init_array(Elements)
|
|
).
|
|
|
|
:- pred fixup_atomic_stmt(action, elim_info,
|
|
mlds_atomic_statement, mlds_atomic_statement).
|
|
:- mode fixup_atomic_stmt(in(hoist), in, in, out) is det.
|
|
:- mode fixup_atomic_stmt(in(chain), in, in, out) is det.
|
|
|
|
fixup_atomic_stmt(Action, Info, Atomic0, Atomic) :-
|
|
(
|
|
( Atomic0 = comment(_)
|
|
; Atomic0 = gc_check
|
|
),
|
|
Atomic = Atomic0
|
|
;
|
|
Atomic0 = assign(Lval0, Rval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Atomic = assign(Lval, Rval)
|
|
;
|
|
Atomic0 = assign_if_in_heap(Lval0, Rval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Atomic = assign_if_in_heap(Lval, Rval)
|
|
;
|
|
Atomic0 = delete_object(Rval0),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Atomic = delete_object(Rval)
|
|
;
|
|
Atomic0 = new_object(Target0, MaybeTag, ExplicitSecTag, Type,
|
|
MaybeSize, MaybeCtorName, Args0, ArgTypes, MayUseAtomic,
|
|
MaybeAllocId),
|
|
fixup_lval(Action, Info, Target0, Target),
|
|
fixup_rvals(Action, Info, Args0, Args),
|
|
Atomic = new_object(Target, MaybeTag, ExplicitSecTag, Type,
|
|
MaybeSize, MaybeCtorName, Args, ArgTypes, MayUseAtomic,
|
|
MaybeAllocId)
|
|
;
|
|
Atomic0 = mark_hp(Lval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
Atomic = mark_hp(Lval)
|
|
;
|
|
Atomic0 = restore_hp(Rval0),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Atomic = restore_hp(Rval)
|
|
;
|
|
Atomic0 = trail_op(TrailOp0),
|
|
fixup_trail_op(Action, Info, TrailOp0, TrailOp),
|
|
Atomic = trail_op(TrailOp)
|
|
;
|
|
Atomic0 = inline_target_code(Lang, Components0),
|
|
fixup_target_code_components(Action, Info, Components0, Components),
|
|
Atomic = inline_target_code(Lang, Components)
|
|
;
|
|
Atomic0 = outline_foreign_proc(Lang, Vs, Lvals0, Code),
|
|
fixup_lvals(Action, Info, Lvals0, Lvals),
|
|
Atomic = outline_foreign_proc(Lang, Vs, Lvals, Code)
|
|
).
|
|
|
|
:- pred fixup_case_conds(action, elim_info,
|
|
list(mlds_case_match_cond), list(mlds_case_match_cond)).
|
|
:- mode fixup_case_conds(in(hoist), in, in, out) is det.
|
|
:- mode fixup_case_conds(in(chain), in, in, out) is det.
|
|
|
|
fixup_case_conds(_, _, [], []).
|
|
fixup_case_conds(Action, Info, [Cond0 | Conds0], [Cond | Conds]) :-
|
|
fixup_case_cond(Action, Info, Cond0, Cond),
|
|
fixup_case_conds(Action, Info, Conds0, Conds).
|
|
|
|
:- pred fixup_case_cond(action, elim_info,
|
|
mlds_case_match_cond, mlds_case_match_cond).
|
|
:- mode fixup_case_cond(in(hoist), in, in, out) is det.
|
|
:- mode fixup_case_cond(in(chain), in, in, out) is det.
|
|
|
|
fixup_case_cond(Action, Info, Cond0, Cond) :-
|
|
(
|
|
Cond0 = match_value(Rval0),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Cond = match_value(Rval)
|
|
;
|
|
Cond0 = match_range(Low0, High0),
|
|
fixup_rval(Action, Info, Low0, Low),
|
|
fixup_rval(Action, Info, High0, High),
|
|
Cond = match_range(Low, High)
|
|
).
|
|
|
|
:- pred fixup_target_code_components(action, elim_info,
|
|
list(target_code_component), list(target_code_component)).
|
|
:- mode fixup_target_code_components(in(hoist), in, in, out) is det.
|
|
:- mode fixup_target_code_components(in(chain), in, in, out) is det.
|
|
|
|
fixup_target_code_components(_, _, [], []).
|
|
fixup_target_code_components(Action, Info,
|
|
[Component0 | Components0], [Component | Components]) :-
|
|
fixup_target_code_component(Action, Info, Component0, Component),
|
|
fixup_target_code_components(Action, Info, Components0, Components).
|
|
|
|
:- pred fixup_target_code_component(action, elim_info,
|
|
target_code_component, target_code_component).
|
|
:- mode fixup_target_code_component(in(hoist), in, in, out) is det.
|
|
:- mode fixup_target_code_component(in(chain), in, in, out) is det.
|
|
|
|
fixup_target_code_component(Action, Info, Component0, Component) :-
|
|
(
|
|
( Component0 = raw_target_code(_Code)
|
|
; Component0 = user_target_code(_Code, _Context)
|
|
; Component0 = target_code_type(_Type)
|
|
; Component0 = target_code_name(_Name)
|
|
; Component0 = target_code_alloc_id(_AllocId)
|
|
),
|
|
Component = Component0
|
|
;
|
|
Component0 = target_code_input(Rval0),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Component = target_code_input(Rval)
|
|
;
|
|
Component0 = target_code_output(Lval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
Component = target_code_output(Lval)
|
|
).
|
|
|
|
:- pred fixup_trail_op(action, elim_info, trail_op, trail_op).
|
|
:- mode fixup_trail_op(in(hoist), in, in, out) is det.
|
|
:- mode fixup_trail_op(in(chain), in, in, out) is det.
|
|
|
|
fixup_trail_op(Action, Info, Op0, Op) :-
|
|
(
|
|
Op0 = store_ticket(Lval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
Op = store_ticket(Lval)
|
|
;
|
|
Op0 = reset_ticket(Rval0, Reason),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Op = reset_ticket(Rval, Reason)
|
|
;
|
|
( Op0 = discard_ticket
|
|
; Op0 = prune_ticket
|
|
),
|
|
Op = Op0
|
|
;
|
|
Op0 = mark_ticket_stack(Lval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
Op = mark_ticket_stack(Lval)
|
|
;
|
|
Op0 = prune_tickets_to(Rval0),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Op = prune_tickets_to(Rval)
|
|
).
|
|
|
|
:- pred fixup_rvals(action, elim_info, list(mlds_rval), list(mlds_rval)).
|
|
:- mode fixup_rvals(in(hoist), in, in, out) is det.
|
|
:- mode fixup_rvals(in(chain), in, in, out) is det.
|
|
|
|
fixup_rvals(_, _, [], []).
|
|
fixup_rvals(Action, Info, [Rval0 | Rvals0], [Rval | Rvals]) :-
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
fixup_rvals(Action, Info, Rvals0, Rvals).
|
|
|
|
:- pred fixup_maybe_rval(action, elim_info,
|
|
maybe(mlds_rval), maybe(mlds_rval)).
|
|
:- mode fixup_maybe_rval(in(hoist), in, in, out) is det.
|
|
:- mode fixup_maybe_rval(in(chain), in, in, out) is det.
|
|
|
|
fixup_maybe_rval(_, _, no, no).
|
|
fixup_maybe_rval(Action, Info, yes(Rval0), yes(Rval)) :-
|
|
fixup_rval(Action, Info, Rval0, Rval).
|
|
|
|
:- pred fixup_rval(action, elim_info, mlds_rval, mlds_rval).
|
|
:- mode fixup_rval(in(hoist), in, in, out) is det.
|
|
:- mode fixup_rval(in(chain), in, in, out) is det.
|
|
|
|
fixup_rval(Action, Info, Rval0, Rval) :-
|
|
(
|
|
Rval0 = ml_lval(Lval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
Rval = ml_lval(Lval)
|
|
;
|
|
Rval0 = ml_mem_addr(Lval0),
|
|
fixup_lval(Action, Info, Lval0, Lval),
|
|
Rval = ml_mem_addr(Lval)
|
|
;
|
|
Rval0 = ml_mkword(Tag, BaseRval0),
|
|
fixup_rval(Action, Info, BaseRval0, BaseRval),
|
|
Rval = ml_mkword(Tag, BaseRval)
|
|
;
|
|
Rval0 = ml_unop(UnOp, XRval0),
|
|
fixup_rval(Action, Info, XRval0, XRval),
|
|
Rval = ml_unop(UnOp, XRval)
|
|
;
|
|
Rval0 = ml_binop(BinOp, XRval0, YRval0),
|
|
fixup_rval(Action, Info, XRval0, XRval),
|
|
fixup_rval(Action, Info, YRval0, YRval),
|
|
Rval = ml_binop(BinOp, XRval, YRval)
|
|
;
|
|
Rval0 = ml_vector_common_row(VectorCommon, RowRval0),
|
|
fixup_rval(Action, Info, RowRval0, RowRval),
|
|
Rval = ml_vector_common_row(VectorCommon, RowRval)
|
|
;
|
|
( Rval0 = ml_const(_)
|
|
; Rval0 = ml_scalar_common(_)
|
|
; Rval0 = ml_self(_)
|
|
),
|
|
Rval = Rval0
|
|
).
|
|
|
|
:- pred fixup_lvals(action, elim_info, list(mlds_lval), list(mlds_lval)).
|
|
:- mode fixup_lvals(in(hoist), in, in, out) is det.
|
|
:- mode fixup_lvals(in(chain), in, in, out) is det.
|
|
|
|
fixup_lvals(_, _, [], []).
|
|
fixup_lvals(Action, Info, [X0 | Xs0], [X | Xs]) :-
|
|
fixup_lval(Action, Info, X0, X),
|
|
fixup_lvals(Action, Info, Xs0, Xs).
|
|
|
|
:- pred fixup_lval(action, elim_info, mlds_lval, mlds_lval).
|
|
:- mode fixup_lval(in(hoist), in, in, out) is det.
|
|
:- mode fixup_lval(in(chain), in, in, out) is det.
|
|
|
|
fixup_lval(Action, Info, Lval0, Lval) :-
|
|
(
|
|
Lval0 = ml_field(MaybeTag, Rval0, FieldId, FieldType, PtrType),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Lval = ml_field(MaybeTag, Rval, FieldId, FieldType, PtrType)
|
|
;
|
|
Lval0 = ml_mem_ref(Rval0, Type),
|
|
fixup_rval(Action, Info, Rval0, Rval),
|
|
Lval = ml_mem_ref(Rval, Type)
|
|
;
|
|
Lval0 = ml_global_var_ref(_Ref),
|
|
Lval = Lval0
|
|
;
|
|
Lval0 = ml_var(Var0, VarType),
|
|
fixup_var(Action, Info, Var0, VarType, Lval)
|
|
).
|
|
|
|
% fixup_gc_statements:
|
|
%
|
|
% Process the trace code in the locals that have been hoisted to the stack
|
|
% frame structure so that the code correctly refers to any variables that
|
|
% have been pulled out. It assumes the locals don't actually change during
|
|
% the process. I think this should be safe. (schmidt)
|
|
|
|
:- pred fixup_gc_statements(action, elim_info, elim_info).
|
|
:- mode fixup_gc_statements(in(hoist), in, out) is det.
|
|
:- mode fixup_gc_statements(in(chain), in, out) is det.
|
|
|
|
fixup_gc_statements(Action, !Info) :-
|
|
RevLocals = elim_info_get_local_data(!.Info),
|
|
% We must preserve the order for the Java backend, otherwise the generated
|
|
% code may contain closure_layout vectors that reference typevar vectors
|
|
% which are defined later.
|
|
Locals = list.reverse(RevLocals),
|
|
fixup_gc_statements_defns(Action, Locals, !Info).
|
|
|
|
:- pred fixup_gc_statements_defns(action, list(mlds_defn),
|
|
elim_info, elim_info).
|
|
:- mode fixup_gc_statements_defns(in(hoist), in, in, out) is det.
|
|
:- mode fixup_gc_statements_defns(in(chain), in, in, out) is det.
|
|
|
|
fixup_gc_statements_defns(_, [], !Info).
|
|
fixup_gc_statements_defns(Action, [Defn0 | Defns], !Info) :-
|
|
( if
|
|
Defn0 = mlds_defn(Name, Context, Flags, DefnBody0),
|
|
DefnBody0 = mlds_data(Type, Init, GCStatement0)
|
|
then
|
|
flatten_gc_statement(Action, GCStatement0, GCStatement, !Info),
|
|
DefnBody = mlds_data(Type, Init, GCStatement),
|
|
Defn = mlds_defn(Name, Context, Flags, DefnBody),
|
|
elim_info_remove_local_data(Defn0, !Info),
|
|
elim_info_add_local_data(Defn, !Info)
|
|
else
|
|
true
|
|
),
|
|
fixup_gc_statements_defns(Action, Defns, !Info).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Change up any references to local vars in the containing function
|
|
% to go via the environment pointer.
|
|
%
|
|
:- pred fixup_var(action, elim_info, mlds_var, mlds_type, mlds_lval).
|
|
:- mode fixup_var(in(hoist), in, in, in, out) is det.
|
|
:- mode fixup_var(in(chain), in, in, in, out) is det.
|
|
|
|
fixup_var(Action, Info, ThisVar, ThisVarType, Lval) :-
|
|
ThisVar = qual(ThisVarModuleName, QualKind, ThisVarName),
|
|
ModuleName = elim_info_get_module_name(Info),
|
|
Locals = elim_info_get_local_data(Info),
|
|
ClassType = elim_info_get_env_type_name(Info),
|
|
EnvPtrVarType = elim_info_get_env_ptr_type_name(Info),
|
|
Globals = elim_info_get_globals(Info),
|
|
( if
|
|
% Check for references to local variables that are used by
|
|
% nested functions, and replace them with `env_ptr->foo'.
|
|
ThisVarModuleName = ModuleName,
|
|
IsLocalVar = (pred(VarType::out) is nondet :-
|
|
list.member(Var, Locals),
|
|
Var = mlds_defn(entity_data(mlds_data_var(ThisVarName)), _, _,
|
|
mlds_data(VarType, _, _))
|
|
),
|
|
solutions.solutions(IsLocalVar, [FieldType])
|
|
then
|
|
EnvPtr = ml_lval(ml_var(qual(ModuleName, QualKind,
|
|
mlds_var_name(env_name_base(Action) ++ "_ptr", no)),
|
|
EnvPtrVarType)),
|
|
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),
|
|
EnvPtrVarType),
|
|
Tag = yes(0),
|
|
Lval = ml_field(Tag, EnvPtr, FieldName, FieldType, EnvPtrVarType)
|
|
else if
|
|
% Check for references to the env_ptr itself.
|
|
% For those, the code generator will have left the type as
|
|
% mlds_unknown_type, and we need to fill it in here.
|
|
Action = hoist_nested_funcs,
|
|
ThisVarName = mlds_var_name("env_ptr", no),
|
|
ThisVarType = mlds_unknown_type
|
|
then
|
|
Lval = ml_var(ThisVar, EnvPtrVarType)
|
|
else
|
|
% Leave everything else unchanged.
|
|
Lval = ml_var(ThisVar, ThisVarType)
|
|
).
|
|
|
|
% The following code is what we would have to use if we couldn't
|
|
% just hoist all local variables out to the outermost function.
|
|
% ( if
|
|
% %
|
|
% % Check for references to local variables
|
|
% % that are used by nested functions,
|
|
% % and replace them with `(&env)->foo'.
|
|
% % (The MLDS doesn't have any representation
|
|
% % for `env.foo'.)
|
|
% %
|
|
% ThisVarModuleName = ModuleName,
|
|
% list.member(Var, Locals),
|
|
% Var = mlds_defn(data(var(ThisVarName)), _, _, _)
|
|
% then
|
|
% Env = var(qual(ModuleName, module_qual, "env")),
|
|
% FieldName = named_field(ThisVar),
|
|
% Tag = yes(0),
|
|
% Lval = field(Tag, mem_addr(Env), FieldName)
|
|
% else if
|
|
% %
|
|
% % Check for references to variables in the
|
|
% % containing function(s), and replace them
|
|
% % with envptr->foo, envptr->envptr->foo, etc.
|
|
% % depending on the depth of nesting.
|
|
% %
|
|
% ThisVarModuleName = ModuleName,
|
|
% outervar_member(ThisVarName, OuterVars, 1, Depth)
|
|
% then
|
|
% EnvPtrName = qual(ModuleName, module_qual, "env_ptr"),
|
|
% EnvPtr = lval(var(EnvPtrName)),
|
|
% Lval = make_envptr_ref(Depth, EnvPtr, EnvPtrName, ThisVar)
|
|
% else
|
|
% %
|
|
% % leave everything else unchanged
|
|
% %
|
|
% Lval = var(ThisVar, ThisVarType)
|
|
% ).
|
|
%
|
|
% % check if the specified variable is contained in the
|
|
% % outervars, and if so, return the depth of nesting
|
|
% %
|
|
% :- pred outervar_member(mlds_var_name::in, outervars::in, int::in, int::out)
|
|
% is semidet.
|
|
%
|
|
% outervar_member(ThisVarName, [OuterVars | OtherOuterVars], Depth0, Depth) :-
|
|
% ( if
|
|
% list.member(Var, OuterVars),
|
|
% Var = mlds_defn(data(var(ThisVarName)), _, _, _)
|
|
% then
|
|
% Depth = Depth0
|
|
% else
|
|
% outervar_member(ThisVarName, OtherOuterVars, Depth0 + 1, Depth)
|
|
% ).
|
|
%
|
|
% % Produce a reference to a variable via `Depth' levels
|
|
% % of `envptr->' indirections.
|
|
% %
|
|
% :- func make_envptr_ref(int, mlds_rval, mlds_var, mlds_var) = lval.
|
|
%
|
|
% make_envptr_ref(Depth, CurEnvPtr, EnvPtrVar, Var) = Lval :-
|
|
% ( if Depth = 1 then
|
|
% Tag = yes(0),
|
|
% Lval = field(Tag, CurEnvPtr, named_field(Var))
|
|
% else
|
|
% Tag = yes(0),
|
|
% NewEnvPtr = lval(field(Tag, CurEnvPtr, named_field(EnvPtrVar))),
|
|
% Lval = make_envptr_ref(Depth - 1, NewEnvPtr, EnvPtrVar, Var)
|
|
% ).
|
|
|
|
:- func ml_env_module_name(compilation_target, mlds_type) = mlds_module_name.
|
|
|
|
ml_env_module_name(Target, ClassType) = EnvModuleName :-
|
|
( if ClassType = mlds_class_type(ClassModuleName, Arity, _Kind) then
|
|
ClassModuleName = qual(ClassModule, QualKind, ClassName),
|
|
EnvModuleName = mlds_append_class_qualifier(Target, ClassModule,
|
|
QualKind, ClassName, Arity)
|
|
else
|
|
unexpected($module, $pred, "ClassType is not a class")
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Succeed if the specified construct contains a definition for which the
|
|
% given filter predicate succeeds.
|
|
%
|
|
|
|
:- pred statements_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), list(statement)::in) is semidet.
|
|
|
|
statements_contains_matching_defn(Filter, [Statement | Statements]) :-
|
|
(
|
|
statement_contains_matching_defn(Filter, Statement)
|
|
;
|
|
statements_contains_matching_defn(Filter, Statements)
|
|
).
|
|
|
|
:- pred maybe_statement_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), maybe(statement)::in) is semidet.
|
|
|
|
maybe_statement_contains_matching_defn(Filter, yes(Statement)) :-
|
|
statement_contains_matching_defn(Filter, Statement).
|
|
|
|
:- pred statement_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), statement::in) is semidet.
|
|
|
|
statement_contains_matching_defn(Filter, Statement) :-
|
|
Statement = statement(Stmt, _Context),
|
|
stmt_contains_matching_defn(Filter, Stmt).
|
|
|
|
:- pred stmt_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), mlds_stmt::in) is semidet.
|
|
|
|
stmt_contains_matching_defn(Filter, Stmt) :-
|
|
(
|
|
Stmt = ml_stmt_block(Defns, Statements),
|
|
( defns_contains_matching_defn(Filter, Defns)
|
|
; statements_contains_matching_defn(Filter, Statements)
|
|
)
|
|
;
|
|
Stmt = ml_stmt_while(_Kind, _Rval, Statement),
|
|
statement_contains_matching_defn(Filter, Statement)
|
|
;
|
|
Stmt = ml_stmt_if_then_else(_Cond, Then, MaybeElse),
|
|
( statement_contains_matching_defn(Filter, Then)
|
|
; maybe_statement_contains_matching_defn(Filter, MaybeElse)
|
|
)
|
|
;
|
|
Stmt = ml_stmt_switch(_Type, _Val, _Range, Cases, Default),
|
|
( cases_contains_matching_defn(Filter, Cases)
|
|
; default_contains_matching_defn(Filter, Default)
|
|
)
|
|
;
|
|
Stmt = ml_stmt_try_commit(_Ref, Statement, Handler),
|
|
( statement_contains_matching_defn(Filter, Statement)
|
|
; statement_contains_matching_defn(Filter, Handler)
|
|
)
|
|
;
|
|
( Stmt = ml_stmt_label(_Label)
|
|
; Stmt = ml_stmt_goto(_)
|
|
; Stmt = ml_stmt_computed_goto(_Rval, _Labels)
|
|
; Stmt = ml_stmt_call(_Sig, _Func, _Obj, _Args, _RetLvals, _TailCall)
|
|
; Stmt = ml_stmt_return(_Rvals)
|
|
; Stmt = ml_stmt_do_commit(_Ref)
|
|
; Stmt = ml_stmt_atomic(_AtomicStmt)
|
|
),
|
|
fail
|
|
).
|
|
|
|
:- pred cases_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), list(mlds_switch_case)::in)
|
|
is semidet.
|
|
|
|
cases_contains_matching_defn(Filter, [Case | Cases]) :-
|
|
(
|
|
case_contains_matching_defn(Filter, Case)
|
|
;
|
|
cases_contains_matching_defn(Filter, Cases)
|
|
).
|
|
|
|
:- pred case_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), mlds_switch_case::in) is semidet.
|
|
|
|
case_contains_matching_defn(Filter, Case) :-
|
|
Case = mlds_switch_case(_FirstMatchCond, _LaterMatchConds, Statement),
|
|
statement_contains_matching_defn(Filter, Statement).
|
|
|
|
:- pred default_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), mlds_switch_default::in)
|
|
is semidet.
|
|
|
|
% default_contains_matching_defn(_, default_do_nothing) :- fail.
|
|
% default_contains_matching_defn(_, default_is_unreachable) :- fail.
|
|
default_contains_matching_defn(Filter, default_case(Statement)) :-
|
|
statement_contains_matching_defn(Filter, Statement).
|
|
|
|
:- pred defns_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), list(mlds_defn)::in) is semidet.
|
|
|
|
defns_contains_matching_defn(Filter, [Defn | Defns]) :-
|
|
(
|
|
defn_contains_matching_defn(Filter, Defn)
|
|
;
|
|
defns_contains_matching_defn(Filter, Defns)
|
|
).
|
|
|
|
:- pred defn_contains_matching_defn(
|
|
pred(mlds_defn)::in(pred(in) is semidet), mlds_defn::in) is semidet.
|
|
|
|
defn_contains_matching_defn(Filter, Defn) :-
|
|
(
|
|
Filter(Defn) % This is where we succeed!
|
|
;
|
|
Defn = mlds_defn(_Name, _Context, _Flags, DefnBody),
|
|
(
|
|
DefnBody = mlds_function(_PredProcId, _Params, FunctionBody,
|
|
_Attrs, _EnvVarNames, _MaybeRequiretailrecInfo),
|
|
FunctionBody = body_defined_here(Statement),
|
|
statement_contains_matching_defn(Filter, Statement)
|
|
;
|
|
DefnBody = mlds_class(ClassDefn),
|
|
ClassDefn = mlds_class_defn(_Kind, _Imports, _Inherits,
|
|
_Implements, _TypeParams, CtorDefns, FieldDefns),
|
|
(
|
|
defns_contains_matching_defn(Filter, FieldDefns)
|
|
;
|
|
defns_contains_matching_defn(Filter, CtorDefns)
|
|
)
|
|
)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Add code to unlink the stack chain before any explicit returns or
|
|
% tail calls.
|
|
%
|
|
:- pred add_unchain_stack_to_maybe_statement(action,
|
|
maybe(statement), maybe(statement), elim_info, elim_info).
|
|
% :- mode add_unchain_stack_to_maybe_statement(in(hoist), in, out, in, out)
|
|
% is det.
|
|
:- mode add_unchain_stack_to_maybe_statement(in(chain), in, out, in, out)
|
|
is det.
|
|
|
|
add_unchain_stack_to_maybe_statement(_, no, no, !Info).
|
|
add_unchain_stack_to_maybe_statement(Action, yes(Statement0), yes(Statement),
|
|
!Info) :-
|
|
add_unchain_stack_to_statement(Action, Statement0, Statement, !Info).
|
|
|
|
:- pred add_unchain_stack_to_statements(action,
|
|
list(statement), list(statement), elim_info, elim_info).
|
|
% :- mode add_unchain_stack_to_statements(in(hoist), in, out, in, out) is det.
|
|
:- mode add_unchain_stack_to_statements(in(chain), in, out, in, out) is det.
|
|
|
|
add_unchain_stack_to_statements(_, [], [], !Info).
|
|
add_unchain_stack_to_statements(Action, [Statement0 | Statements0],
|
|
[Statement | Statements], !Info) :-
|
|
add_unchain_stack_to_statement(Action, Statement0, Statement, !Info),
|
|
add_unchain_stack_to_statements(Action, Statements0, Statements, !Info).
|
|
|
|
:- pred add_unchain_stack_to_statement(action, statement, statement,
|
|
elim_info, elim_info).
|
|
% :- mode add_unchain_stack_to_statement(in(hoist), in, out, in, out) is det.
|
|
:- mode add_unchain_stack_to_statement(in(chain), in, out, in, out) is det.
|
|
|
|
add_unchain_stack_to_statement(Action, Statement0, Statement, !Info) :-
|
|
Statement0 = statement(Stmt0, Context),
|
|
add_unchain_stack_to_stmt(Action, Context, Stmt0, Stmt, !Info),
|
|
Statement = statement(Stmt, Context).
|
|
|
|
:- pred add_unchain_stack_to_stmt(action, mlds_context,
|
|
mlds_stmt, mlds_stmt, elim_info, elim_info).
|
|
% :- mode add_unchain_stack_to_stmt(in(hoist), in, in, out, in, out) is det.
|
|
:- mode add_unchain_stack_to_stmt(in(chain), in, in, out, in, out) is det.
|
|
|
|
add_unchain_stack_to_stmt(Action, Context, Stmt0, Stmt, !Info) :-
|
|
(
|
|
Stmt0 = ml_stmt_block(Defns, Statements0),
|
|
add_unchain_stack_to_statements(Action, Statements0, Statements,
|
|
!Info),
|
|
Stmt = ml_stmt_block(Defns, Statements)
|
|
;
|
|
Stmt0 = ml_stmt_while(Kind, Rval, Statement0),
|
|
add_unchain_stack_to_statement(Action, Statement0, Statement, !Info),
|
|
Stmt = ml_stmt_while(Kind, Rval, Statement)
|
|
;
|
|
Stmt0 = ml_stmt_if_then_else(Cond, Then0, MaybeElse0),
|
|
add_unchain_stack_to_statement(Action, Then0, Then, !Info),
|
|
add_unchain_stack_to_maybe_statement(Action, MaybeElse0, MaybeElse,
|
|
!Info),
|
|
Stmt = ml_stmt_if_then_else(Cond, Then, MaybeElse)
|
|
;
|
|
Stmt0 = ml_stmt_switch(Type, Val, Range, Cases0, Default0),
|
|
add_unchain_stack_to_cases(Action, Cases0, Cases, !Info),
|
|
add_unchain_stack_to_default(Action, Default0, Default, !Info),
|
|
Stmt = ml_stmt_switch(Type, Val, Range, Cases, Default)
|
|
;
|
|
Stmt0 = ml_stmt_call(_Sig, _Func, _Obj, _Args, RetLvals, CallKind),
|
|
add_unchain_stack_to_call(Stmt0, RetLvals, CallKind, Context,
|
|
Stmt, !Info)
|
|
;
|
|
Stmt0 = ml_stmt_return(_Rvals),
|
|
Stmt = prepend_unchain_frame(Stmt0, Context, !.Info)
|
|
;
|
|
Stmt0 = ml_stmt_try_commit(Ref, Statement0, Handler0),
|
|
add_unchain_stack_to_statement(Action, Statement0, Statement, !Info),
|
|
add_unchain_stack_to_statement(Action, Handler0, Handler, !Info),
|
|
Stmt = ml_stmt_try_commit(Ref, Statement, Handler)
|
|
;
|
|
( Stmt0 = ml_stmt_label(_)
|
|
; Stmt0 = ml_stmt_goto(_)
|
|
; Stmt0 = ml_stmt_computed_goto(_Rval, _Labels)
|
|
; Stmt0 = ml_stmt_do_commit(_Ref)
|
|
; Stmt0 = ml_stmt_atomic(_AtomicStmt0)
|
|
),
|
|
Stmt = Stmt0
|
|
).
|
|
|
|
:- pred add_unchain_stack_to_call(mlds_stmt::in, list(mlds_lval)::in,
|
|
ml_call_kind::in, mlds_context::in, mlds_stmt::out,
|
|
elim_info::in, elim_info::out) is det.
|
|
|
|
add_unchain_stack_to_call(Stmt0, RetLvals, CallKind, Context, Stmt, !Info) :-
|
|
(
|
|
CallKind = no_return_call,
|
|
% For no-return calls, we just unchain the stack
|
|
% frame before the call.
|
|
Stmt = prepend_unchain_frame(Stmt0, Context, !.Info)
|
|
;
|
|
CallKind = tail_call,
|
|
% For tail calls, we unchain the stack frame before the call,
|
|
% and then we insert a return statement after the call.
|
|
% The return statement is needed ensure that the code doesn't
|
|
% fall through (past the tail call) and then try to unchain
|
|
% the already-unchained stack frame.
|
|
UnchainFrame = ml_gen_unchain_frame(Context, !.Info),
|
|
Statement0 = statement(Stmt0, Context),
|
|
RetRvals = list.map(func(Rval) = ml_lval(Rval), RetLvals),
|
|
RetStmt = ml_stmt_return(RetRvals),
|
|
RetStatement = statement(RetStmt, Context),
|
|
Stmt = ml_stmt_block([], [UnchainFrame, Statement0, RetStatement])
|
|
;
|
|
CallKind = ordinary_call,
|
|
Stmt = Stmt0
|
|
).
|
|
|
|
:- pred add_unchain_stack_to_cases(action,
|
|
list(mlds_switch_case), list(mlds_switch_case), elim_info, elim_info).
|
|
% :- mode add_unchain_stack_to_cases(in(hoist), in, out, in, out) is det.
|
|
:- mode add_unchain_stack_to_cases(in(chain), in, out, in, out) is det.
|
|
|
|
add_unchain_stack_to_cases(_, [], [], !Info).
|
|
add_unchain_stack_to_cases(Action, [Case0 | Cases0], [Case | Cases], !Info) :-
|
|
add_unchain_stack_to_case(Action, Case0, Case, !Info),
|
|
add_unchain_stack_to_cases(Action, Cases0, Cases, !Info).
|
|
|
|
:- pred add_unchain_stack_to_case(action,
|
|
mlds_switch_case, mlds_switch_case, elim_info, elim_info).
|
|
% :- mode add_unchain_stack_to_case(in(hoist), in, out, in, out) is det.
|
|
:- mode add_unchain_stack_to_case(in(chain), in, out, in, out) is det.
|
|
|
|
add_unchain_stack_to_case(Action, Case0, Case, !Info) :-
|
|
Case0 = mlds_switch_case(FirstCond0, LaterConds0, Statement0),
|
|
fixup_case_cond(Action, !.Info, FirstCond0, FirstCond),
|
|
fixup_case_conds(Action, !.Info, LaterConds0, LaterConds),
|
|
add_unchain_stack_to_statement(Action, Statement0, Statement, !Info),
|
|
Case = mlds_switch_case(FirstCond, LaterConds, Statement).
|
|
|
|
:- pred add_unchain_stack_to_default(action,
|
|
mlds_switch_default, mlds_switch_default, elim_info, elim_info).
|
|
% :- mode add_unchain_stack_to_default(in(hoist), in, out, in, out) is det.
|
|
:- mode add_unchain_stack_to_default(in(chain), in, out, in, out) is det.
|
|
|
|
add_unchain_stack_to_default(Action, Default0, Default, !Info) :-
|
|
(
|
|
Default0 = default_is_unreachable,
|
|
Default = default_is_unreachable
|
|
;
|
|
Default0 = default_do_nothing,
|
|
Default = default_do_nothing
|
|
;
|
|
Default0 = default_case(Statement0),
|
|
add_unchain_stack_to_statement(Action, Statement0, Statement, !Info),
|
|
Default = default_case(Statement)
|
|
).
|
|
|
|
:- func prepend_unchain_frame(mlds_stmt, mlds_context, elim_info) =
|
|
mlds_stmt.
|
|
|
|
prepend_unchain_frame(Stmt0, Context, ElimInfo) = Stmt :-
|
|
UnchainFrame = ml_gen_unchain_frame(Context, ElimInfo),
|
|
Statement0 = statement(Stmt0, Context),
|
|
Stmt = ml_stmt_block([], [UnchainFrame, Statement0]).
|
|
|
|
:- func ml_gen_unchain_frame(mlds_context, elim_info) = statement.
|
|
|
|
ml_gen_unchain_frame(Context, ElimInfo) = UnchainFrame :-
|
|
EnvPtrTypeName = elim_info_get_env_ptr_type_name(ElimInfo),
|
|
|
|
% Generate code to remove this frame from the stack chain:
|
|
%
|
|
% stack_chain = stack_chain->prev;
|
|
%
|
|
% Actually, it is not quite as simple as that. The global
|
|
% `stack_chain' has type `void *', rather than `MR_StackChain *', and
|
|
% the MLDS has no way of representing the `struct MR_StackChain' type
|
|
% (which we'd need to cast it to) or of accessing an unqualified
|
|
% field name like `prev' (rather than `modulename__prev').
|
|
%
|
|
% So we do this in a slightly lower-level fashion, using
|
|
% a field offset rather than a field name:
|
|
%
|
|
% stack_chain = MR_hl_field(stack_chain, 0);
|
|
|
|
StackChain = ml_stack_chain_var,
|
|
Tag = yes(0),
|
|
PrevFieldId = ml_field_offset(ml_const(mlconst_int(0))),
|
|
PrevFieldType = mlds_generic_type,
|
|
PrevFieldRval = ml_lval(ml_field(Tag, ml_lval(StackChain), PrevFieldId,
|
|
PrevFieldType, EnvPtrTypeName)),
|
|
Assignment = assign(StackChain, PrevFieldRval),
|
|
UnchainFrame = statement(ml_stmt_atomic(Assignment), Context).
|
|
|
|
% Generate a local variable declaration to hold the saved stack chain
|
|
% pointer:
|
|
%
|
|
% void *saved_stack_chain;
|
|
%
|
|
:- func gen_saved_stack_chain_var(int, mlds_context) = mlds_defn.
|
|
|
|
gen_saved_stack_chain_var(Id, Context) = Defn :-
|
|
Name = entity_data(mlds_data_var(ml_saved_stack_chain_name(Id))),
|
|
Flags = ml_gen_local_var_decl_flags,
|
|
Type = ml_stack_chain_type,
|
|
Initializer = no_initializer,
|
|
% The saved stack chain never needs to be traced by the GC,
|
|
% since it will always point to the stack, not into the heap.
|
|
GCStatement = gc_no_stmt,
|
|
DefnBody = mlds_data(Type, Initializer, GCStatement),
|
|
Defn = mlds_defn(Name, Context, Flags, DefnBody).
|
|
|
|
% Generate a statement to save the stack chain pointer:
|
|
%
|
|
% saved_stack_chain = stack_chain;
|
|
%
|
|
:- func gen_save_stack_chain_var(mlds_module_name, int, mlds_context) =
|
|
statement.
|
|
|
|
gen_save_stack_chain_var(MLDS_Module, Id, Context) = SaveStatement :-
|
|
SavedStackChain = ml_var(qual(MLDS_Module, module_qual,
|
|
ml_saved_stack_chain_name(Id)), ml_stack_chain_type),
|
|
Assignment = assign(SavedStackChain, ml_lval(ml_stack_chain_var)),
|
|
SaveStatement = statement(ml_stmt_atomic(Assignment), Context).
|
|
|
|
% Generate a statement to restore the stack chain pointer:
|
|
%
|
|
% stack_chain = saved_stack_chain;
|
|
%
|
|
:- func gen_restore_stack_chain_var(mlds_module_name, int, mlds_context) =
|
|
statement.
|
|
|
|
gen_restore_stack_chain_var(MLDS_Module, Id, Context) = RestoreStatement :-
|
|
SavedStackChain = ml_var(qual(MLDS_Module, module_qual,
|
|
ml_saved_stack_chain_name(Id)), ml_stack_chain_type),
|
|
Assignment = assign(ml_stack_chain_var, ml_lval(SavedStackChain)),
|
|
RestoreStatement = statement(ml_stmt_atomic(Assignment), Context).
|
|
|
|
:- func ml_saved_stack_chain_name(int) = mlds_var_name.
|
|
|
|
ml_saved_stack_chain_name(Id) = mlds_var_name("saved_stack_chain", yes(Id)).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
%
|
|
% The elim_info type holds information that we use or accumulate
|
|
% as we traverse through the function body.
|
|
%
|
|
|
|
% The lists of local variables for each of the containing functions,
|
|
% innermost first.
|
|
:- type outervars == list(list(mlds_defn)).
|
|
|
|
:- type elim_info
|
|
---> elim_info(
|
|
% The name of the current module.
|
|
ei_module_name :: mlds_module_name,
|
|
|
|
% The lists of local variables for each of the containing
|
|
% functions, innermost first.
|
|
% XXX this is not used.
|
|
% It would be needed if we want to handle arbitrary nesting.
|
|
% Currently we assume that any variables can safely be hoisted
|
|
% to the outermost function, so this field is not needed.
|
|
% outer_vars :: outervars,
|
|
|
|
% The list of nested function definitions that we must hoist
|
|
% out. This list is stored in reverse order.
|
|
ei_nested_funcs :: list(mlds_defn),
|
|
|
|
% The list of local variables that we must put in the
|
|
% environment structure. This list is stored in reverse order.
|
|
ei_local_data :: list(mlds_defn),
|
|
|
|
% Type of the introduced environment struct.
|
|
ei_env_type_name :: mlds_type,
|
|
|
|
% Type of the introduced environment struct pointer.
|
|
% This might not just be just a pointer to the env_type_name
|
|
% (in the IL backend we don't necessarily use a pointer).
|
|
ei_env_ptr_type_name :: mlds_type,
|
|
|
|
% A counter used to number the local variables
|
|
% used to save the stack chain
|
|
ei_saved_stack_chain_counter :: counter,
|
|
|
|
ei_globals :: globals
|
|
).
|
|
|
|
:- func elim_info_init(mlds_module_name, outervars, mlds_type, mlds_type,
|
|
globals) = elim_info.
|
|
|
|
elim_info_init(ModuleName, _OuterVars, EnvTypeName, EnvPtrTypeName, Globals) =
|
|
elim_info(ModuleName, [], [], EnvTypeName, EnvPtrTypeName,
|
|
counter.init(0), Globals).
|
|
|
|
:- func elim_info_get_module_name(elim_info) = mlds_module_name.
|
|
% :- func elim_info_get_outer_vars(elim_info) = outervars.
|
|
:- func elim_info_get_local_data(elim_info) = list(mlds_defn).
|
|
:- func elim_info_get_env_type_name(elim_info) = mlds_type.
|
|
:- func elim_info_get_env_ptr_type_name(elim_info) = mlds_type.
|
|
:- func elim_info_get_globals(elim_info) = globals.
|
|
|
|
elim_info_get_module_name(ElimInfo) = ElimInfo ^ ei_module_name.
|
|
% elim_info_get_outer_vars(ElimInfo) = ElimInfo ^ ei_outer_vars.
|
|
elim_info_get_local_data(ElimInfo) = ElimInfo ^ ei_local_data.
|
|
elim_info_get_env_type_name(ElimInfo) = ElimInfo ^ ei_env_type_name.
|
|
elim_info_get_env_ptr_type_name(ElimInfo) = ElimInfo ^ ei_env_ptr_type_name.
|
|
elim_info_get_globals(ElimInfo) = ElimInfo ^ ei_globals.
|
|
|
|
:- pred elim_info_add_nested_func(mlds_defn::in,
|
|
elim_info::in, elim_info::out) is det.
|
|
|
|
elim_info_add_nested_func(NestedFunc, !ElimInfo) :-
|
|
!ElimInfo ^ ei_nested_funcs := [NestedFunc | !.ElimInfo ^ ei_nested_funcs].
|
|
|
|
:- pred elim_info_add_local_data(mlds_defn::in,
|
|
elim_info::in, elim_info::out) is det.
|
|
|
|
elim_info_add_local_data(LocalVar, !ElimInfo) :-
|
|
!ElimInfo ^ ei_local_data := [LocalVar | !.ElimInfo ^ ei_local_data].
|
|
|
|
:- pred elim_info_remove_local_data(mlds_defn::in,
|
|
elim_info::in, elim_info::out) is det.
|
|
|
|
elim_info_remove_local_data(LocalVar, !ElimInfo) :-
|
|
( if
|
|
list.delete_first(!.ElimInfo ^ ei_local_data, LocalVar, LocalData)
|
|
then
|
|
!ElimInfo ^ ei_local_data := LocalData
|
|
else
|
|
unexpected($module, $pred, "not found")
|
|
).
|
|
|
|
:- pred elim_info_allocate_saved_stack_chain_id(int::out,
|
|
elim_info::in, elim_info::out) is det.
|
|
|
|
elim_info_allocate_saved_stack_chain_id(Id, !ElimInfo) :-
|
|
Counter0 = !.ElimInfo ^ ei_saved_stack_chain_counter,
|
|
counter.allocate(Id, Counter0, Counter),
|
|
!ElimInfo ^ ei_saved_stack_chain_counter := Counter.
|
|
|
|
:- pred elim_info_finish(elim_info::in,
|
|
list(mlds_defn)::out, list(mlds_defn)::out) is det.
|
|
|
|
elim_info_finish(ElimInfo, Funcs, Locals) :-
|
|
Funcs = list.reverse(ElimInfo ^ ei_nested_funcs),
|
|
Locals = list.reverse(ElimInfo ^ ei_local_data).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module ml_backend.ml_elim_nested.
|
|
%-----------------------------------------------------------------------------%
|