[m-dev.] for review: GCC back-end interface
Fergus Henderson
fjh at cs.mu.OZ.AU
Fri Jan 5 18:10:12 AEDT 2001
Estimated hours taken: 120
Connect the Mercury compiler to the GCC back-end.
These changes give us a version of the Mercury compiler which
compiles to assembler without going via any intermediate files.
This new back-end for the Mercury compiler generates GCC's `tree' data
type, and then calls functions in the GCC "middle-end" to convert that
to GCC's RTL (Register Transfer Language) and to invoke the rest of
the GCC middle-end and back-end to compile it to assembler.
I don't plan to commit the changes to mercury_compile.m yet, since the
new module that it imports have references to functions defined in the
GCC back-end, and so they require you to have a copy of the gcc
back-end built to link in to the Mercury compiler. I'm not sure what
the best solution to that is; probably a configure option and some
conditional compilation, like we do for the Aditi back-end, is the
best approach.
gcc/mercury:
New directory.
This contains the C side of the Mercury <-> GCC interface.
gcc/mercury/Make-lang.in:
gcc/mercury/config-lang.in:
gcc/mercury/lang-specs.h:
Makefile/configure/specs fragments (respectively)
that are required by GCC.
gcc/mercury/lang-options.h:
Documents the Mercury-specific gcc options,
in particular the `--mmc-flag=' option.
gcc/mercury/mercury-gcc.c:
gcc/mercury/mercury-gcc.h:
This is the "meat" on the C side of the Mercury <-> GCC interface.
These files provide the C code that GCC requires of each
language front-end. They also define some routines for
building parts of the GCC `tree' data structure that are
used by the Mercury compiler.
gcc/mercury/Makefile:
A Makefile which just runs `make mercury' in the parent directory.
Just for convenience.
gcc/mercury/README:
gcc/mercury/ChangeLog:
Some (very basic) documentation.
gcc/mercury/test.m:
A sample Mercury module, to serve as a simple test case.
gcc/mercury/testmercury.c:
C driver program for the test Mercury module.
mercury/compiler/gcc.m:
New file. This is an interface to the tree data structure defined
in gcc/tree.h, and to functions for manipulating that data structure
which are defined in gcc/mercury/mercury-gcc.c and in other parts
of the GCC back-end. It's almost entirely composed of simple
pragma c_code routines that each just call a single C function.
mercury/compiler/mlds_to_gcc.m:
New file. This converts the MLDS into the gcc tree representation
whose interface is in gcc.m, using the routines defined in gcc.m.
This is the "meat" on the Mercury side of the Mercury <=> GCC interface.
mercury/compiler/globals.m:
Define new target `asm', for compiling directly to assembler
(without any intermediate files), via the gcc back-end.
mercury/compiler/handle_options.m:
`--target asm' implies `--high-level-code'.
mercury/compiler/mercury_compile.m:
Handle `--target asm' by invoking mlds_to_gcc.m.
mercury/main.c:
New file, containing main() that calls mercury_main().
mercury/compiler/Mmakefile:
Add C2INITFLAGS=--library, so that we can link `libmercury_compile.a'
as a library without main(). For the mercury_compile executable,
get main by linking in ../main.o.
Add `libmmc' target, for building libmercury_compile.a and
mercury_compile_init.a.
Add the appropriate `-D' and `-I' options to CFLAGS-gcc so that we
can compile gcc.m.
mercury/runtime/mercury.c:
Define out-of-line copies of MR_box_float() and MR_unbox_float(),
so that the new `--target asm' back-end can generate calls to them.
mercury/runtime/mercury.h:
mercury/runtime/mercury_heap.h:
Add comments warning about code duplication between
the inline and out-of-line versions of various functions.
mercury/Makefile:
mercury/Mmakefile:
Add `libmmc' target, for use by gcc/mercury/Make-lang.in.
mercury/runtime/mercury_std.h:
When IN_GCC is defined, use safe_ctype.h rather than
ctype.h, since the latter conflicts with the GCC headers.
Comment out the definition of the `reg' macro, since
that too conflicts with the GCC headers.
mercury/runtime/mercury_dlist.c:
mercury/runtime/mercury_hash_table.c:
mercury/runtime/mercury_stacks.h:
Delete unnecessary uses of the `reg' macro.
Workspace: /home/pgrad/fjh/ws/gcc
Index: mercury/compiler/gcc.m
===================================================================
RCS file: gcc.m
diff -N gcc.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ gcc.m Fri Jan 5 17:16:46 2001
@@ -0,0 +1,1280 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2000 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: gcc.m
+% Main author: fjh
+
+% This module is the Mercury interface to the GCC compiler back-end.
+%
+% This module provides a thin wrapper around the C types,
+% constants, and functions defined in gcc/tree.{c,h,def}
+% and gcc/mercury/mercury-gcc.c in the GCC source.
+% (The functions in gcc/mercury/mercury-gcc.c are in turn a
+% thicker wrapper around the more complicated parts of GCC's
+% source-language-independent back-end.)
+%
+% Note that we want to keep this code as simple as possible.
+% Anything complicated, which might require changes for new versions
+% of gcc, should go in gcc/mercury/mercury-gcc.c rather than in
+% inline C code here.
+%
+% This module makes no attempt to be a *complete* interface to the
+% gcc back-end; we only define interfaces to those parts of the gcc
+% back-end that we need for compiling Mercury.
+%
+% REFERENCES
+%
+% For more information about the GCC compiler back-end,
+% see the documentation at <http://gcc.gnu.org> and
+% <http://gcc.gnu.org/readings.html>, in particular
+% "Writing a Compiler Front End to GCC" by Joachim Nadler
+% and Tim Josling <tej at melbpc.org.au>.
+%
+% QUOTES
+%
+% ``GCC is a software Vietnam.''
+% -- Simon Peyton-Jones.
+%
+% ``Never get involved in a land war in Asia.''
+% -- from the movie "The Princess Bride".
+%
+
+%-----------------------------------------------------------------------------%
+
+:- module gcc.
+:- interface.
+:- import_module io, bool.
+
+%-----------------------------------------------------------------------------%
+
+% The GCC `tree' type.
+:- type gcc__tree.
+:- type gcc__tree_code.
+
+%-----------------------------------------------------------------------------%
+%
+% Types
+%
+
+% A GCC `tree' representing a type.
+:- type gcc__type.
+
+ % Builtin types
+:- func void_type_node = gcc__type.
+:- func boolean_type_node = gcc__type.
+:- func char_type_node = gcc__type.
+:- func string_type_node = gcc__type. % `char *'
+:- func double_type_node = gcc__type.
+:- func ptr_type_node = gcc__type. % `void *'
+:- func integer_type_node = gcc__type. % C `int'.
+ % (Note that we use `intptr_t' for
+ % the Mercury `int' type.)
+:- func int8_type_node = gcc__type. % C99 `int8_t'
+:- func int16_type_node = gcc__type. % C99 `int16_t'
+:- func int32_type_node = gcc__type. % C99 `int32_t'
+:- func int64_type_node = gcc__type. % C99 `int64_t'
+:- func intptr_type_node = gcc__type. % C99 `intptr_t'
+:- func jmpbuf_type_node = gcc__type. % `__builtin_jmpbuf', i.e. `void *[5]'
+ % This is used for `__builtin_setjmp'
+ % and `__builtin_longjmp'.
+
+ % Given a type `T', produce a pointer type `T *'.
+:- pred build_pointer_type(gcc__type::in, gcc__type::out,
+ io__state::di, io__state::uo) is det.
+
+ % Given a type `T', and a size N, produce an array type `T[N]'.
+:- pred build_array_type(gcc__type::in, int::in, gcc__type::out,
+ io__state::di, io__state::uo) is det.
+
+ % build_range_type(Type, Min, Max, RangeType):
+ % Given a discrete (integer, enum, boolean, or char) type,
+ % produce a new type which is the sub-range of that type
+ % with low bound Min and high bound Max.
+:- pred build_range_type(gcc__type::in, int::in, int::in,
+ gcc__type::out, io__state::di, io__state::uo) is det.
+
+% A GCC `tree' representing a list of parameter types.
+:- type gcc__param_types.
+:- func empty_param_types = gcc__param_types.
+:- func cons_param_types(gcc__type, gcc__param_types) = gcc__param_types.
+
+ % Produce a function type, given the return type and
+ % the parameter types.
+:- pred build_function_type(gcc__type::in, gcc__param_types::in,
+ gcc__type::out, io__state::di, io__state::uo) is det.
+
+ % Return a type that was defined in a type declaration
+ % (see the section on type declarations, below).
+:- func declared_type(gcc__type_decl) = gcc__type.
+
+ % Given an array type, return the array element type.
+ % This procedure must only be called with an array type,
+ % otherwise it will abort.
+:- pred get_array_elem_type(gcc__type::in, gcc__type::out,
+ io__state::di, io__state::uo) is det.
+
+ % Given a struct type, return the field declarations for
+ % that struct.
+ % This procedure must only be called with a struct type,
+ % otherwise it will abort.
+:- pred get_struct_field_decls(gcc__type::in, gcc__field_decls::out,
+ io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%
+% Declarations
+%
+
+% A GCC `tree' representing a declaration.
+:- type gcc__decl.
+
+%
+% Stuff for variable declarations
+%
+
+% A GCC `tree' representing a local variable.
+:- type gcc__var_decl.
+
+:- type var_name == string.
+
+ % build an extern variable declaration
+:- pred build_extern_var_decl(var_name::in, gcc__type::in, gcc__var_decl::out,
+ io__state::di, io__state::uo) is det.
+
+ % build an initialized global variable definition
+:- pred build_global_var_decl(var_name::in, gcc__type::in, gcc__expr::in,
+ gcc__var_decl::out, io__state::di, io__state::uo) is det.
+
+ % build a local variable definition
+:- pred build_local_var_decl(var_name::in, gcc__type::in, gcc__var_decl::out,
+ io__state::di, io__state::uo) is det.
+
+%
+% Stuff for function declarations
+%
+
+% A GCC `tree' representing a function parameter.
+:- type gcc__param_decl == gcc__var_decl.
+
+ % build a function parameter declaration
+:- type param_name == string.
+:- pred build_param_decl(param_name::in, gcc__type::in, gcc__param_decl::out,
+ io__state::di, io__state::uo) is det.
+
+% A GCC `tree' representing a list of parameters.
+:- type gcc__param_decls.
+
+ % routines for building parameter lists
+:- func empty_param_decls = gcc__param_decls.
+:- func cons_param_decls(gcc__param_decl, gcc__param_decls) = gcc__param_decls.
+
+% A GCC `tree' representing a function declaration.
+:- type gcc__func_decl.
+
+ % build a function declaration
+:- type func_name == string.
+:- type func_asm_name == string.
+:- pred build_function_decl(func_name, func_asm_name, gcc__type,
+ gcc__param_types, gcc__param_decls, gcc__func_decl,
+ io__state, io__state).
+:- mode build_function_decl(in, in, in, in, in, out, di, uo) is det.
+
+ % Declarations for builtin functions
+:- func alloc_func_decl = gcc__func_decl. % GC_malloc()
+:- func strcmp_func_decl = gcc__func_decl. % strcmp()
+:- func hash_string_func_decl = gcc__func_decl. % MR_hash_string()
+:- func box_float_func_decl = gcc__func_decl. % MR_box_float()
+:- func setjmp_func_decl = gcc__func_decl. % __builtin_setjmp()
+:- func longjmp_func_decl = gcc__func_decl. % __builtin_longjmp()
+
+%
+% Stuff for type declarations
+%
+
+ % A GCC `tree' representing a field declaration
+:- type gcc__field_decl.
+
+ % build a field declaration
+:- type field_name == string.
+:- pred build_field_decl(field_name::in, gcc__type::in, gcc__field_decl::out,
+ io__state::di, io__state::uo) is det.
+
+ % get the type of a field
+:- pred field_type(gcc__field_decl::in, gcc__type::out,
+ io__state::di, io__state::uo) is det.
+
+ % A GCC `tree' representing a list of field declarations
+:- type gcc__field_decls.
+
+ % Construct an empty field list.
+:- pred empty_field_list(gcc__field_decls, io__state, io__state).
+:- mode empty_field_list(out, di, uo) is det.
+
+ % Give a new field decl, cons it into the start of a field list.
+ % Note that each field decl can only be on one field list.
+:- pred cons_field_list(gcc__field_decl, gcc__field_decls, gcc__field_decls,
+ io__state, io__state).
+:- mode cons_field_list(in, in, out, di, uo) is det.
+
+ % Given a non-empty field list, return the first field decl
+ % and the remaining field decls.
+ % This procedure must only be called with a non-empty input list,
+ % otherwise it will abort.
+:- pred next_field_decl(gcc__field_decls, gcc__field_decl, gcc__field_decls,
+ io__state, io__state).
+:- mode next_field_decl(in, out, out, di, uo) is det.
+
+:- type gcc__type_decl.
+
+:- type struct_name == string.
+:- pred build_struct_type_decl(gcc__struct_name, gcc__field_decls,
+ gcc__type_decl, io__state, io__state).
+:- mode build_struct_type_decl(in, in, out, di, uo) is det.
+
+%-----------------------------------------------------------------------------%
+%
+% Operators
+%
+
+% GCC tree_codes for operators
+:- type gcc__op.
+
+:- func plus_expr = gcc__op. % +
+:- func minus_expr = gcc__op. % *
+:- func mult_expr = gcc__op. % -
+:- func trunc_div_expr = gcc__op. % / (truncating integer division)
+:- func trunc_mod_expr = gcc__op. % % (remainder after truncating
+ % integer division)
+
+:- func eq_expr = gcc__op. % ==
+:- func ne_expr = gcc__op. % !=
+:- func lt_expr = gcc__op. % <
+:- func gt_expr = gcc__op. % >
+:- func le_expr = gcc__op. % <=
+:- func ge_expr = gcc__op. % >=
+
+:- func truth_andif_expr = gcc__op. % &&
+:- func truth_orif_expr = gcc__op. % ||
+:- func truth_not_expr = gcc__op. % !
+
+:- func bit_ior_expr = gcc__op. % | (bitwise inclusive or)
+:- func bit_xor_expr = gcc__op. % ^ (bitwise exclusive or)
+:- func bit_and_expr = gcc__op. % & (bitwise and)
+:- func bit_not_expr = gcc__op. % ~ (bitwise complement)
+
+:- func lshift_expr = gcc__op. % << (left shift)
+:- func rshift_expr = gcc__op. % >> (left shift)
+
+:- func array_ref = gcc__op. % [] (array indexing)
+ % first operand is the array,
+ % second operand is the index
+
+%-----------------------------------------------------------------------------%
+%
+% Expressions
+%
+
+% A GCC `tree' representing an expression.
+:- type gcc__expr.
+
+ % look up the type of an expression
+:- pred expr_type(gcc__expr, gcc__type, io__state, io__state).
+:- mode expr_type(in, out, di, uo) is det.
+
+%
+% constants
+%
+
+ % build an expression for an integer constant
+:- pred build_int(int, gcc__expr, io__state, io__state).
+:- mode build_int(in, out, di, uo) is det.
+
+ % build an expression for a floating-point constant
+:- pred build_float(float, gcc__expr, io__state, io__state).
+:- mode build_float(in, out, di, uo) is det.
+
+ % build an expression for a Mercury string constant
+:- pred build_string(string, gcc__expr, io__state, io__state).
+:- mode build_string(in, out, di, uo) is det.
+
+ % Build an expression for a string constant,
+ % with the specified length. This length must
+ % include the terminating null, if one is desired.
+:- pred build_string(int, string, gcc__expr, io__state, io__state).
+:- mode build_string(in, in, out, di, uo) is det.
+
+ % build an expression for a null pointer
+:- pred build_null_pointer(gcc__expr, io__state, io__state).
+:- mode build_null_pointer(out, di, uo) is det.
+
+%
+% operator expressions
+%
+
+ % build a unary expression
+:- pred build_unop(gcc__op, gcc__type, gcc__expr, gcc__expr,
+ io__state, io__state).
+:- mode build_unop(in, in, in, out, di, uo) is det.
+
+ % build a binary expression
+:- pred build_binop(gcc__op, gcc__type, gcc__expr, gcc__expr, gcc__expr,
+ io__state, io__state).
+:- mode build_binop(in, in, in, in, out, di, uo) is det.
+
+ % take the address of an expression
+:- pred build_addr_expr(gcc__expr, gcc__expr, io__state, io__state).
+:- mode build_addr_expr(in, out, di, uo) is det.
+
+ % build a pointer dereference expression
+:- pred build_pointer_deref(gcc__expr, gcc__expr, io__state, io__state).
+:- mode build_pointer_deref(in, out, di, uo) is det.
+
+ % build a field extraction expression
+:- pred build_component_ref(gcc__expr, gcc__field_decl, gcc__expr,
+ io__state, io__state).
+:- mode build_component_ref(in, in, out, di, uo) is det.
+
+ % build a type conversion expression
+:- pred convert_type(gcc__expr, gcc__type, gcc__expr, io__state, io__state).
+:- mode convert_type(in, in, out, di, uo) is det.
+
+%
+% variables
+%
+
+ % build an expression for a variable
+:- func var_expr(gcc__var_decl) = gcc__expr.
+
+%
+% stuff for function calls
+%
+
+ % build a function pointer expression
+ % i.e. take the address of a function
+:- pred build_func_addr_expr(gcc__func_decl, gcc__expr, io__state, io__state).
+:- mode build_func_addr_expr(in, out, di, uo) is det.
+
+ % A GCC `tree' representing a list of arguments.
+:- type gcc__arg_list.
+
+:- pred empty_arg_list(gcc__arg_list, io__state, io__state).
+:- mode empty_arg_list(out, di, uo) is det.
+
+:- pred cons_arg_list(gcc__expr, gcc__arg_list, gcc__arg_list, io__state, io__state).
+:- mode cons_arg_list(in, in, out, di, uo) is det.
+
+ % build an expression for a function call
+:- pred build_call_expr(gcc__expr, gcc__arg_list, bool, gcc__expr,
+ io__state, io__state).
+:- mode build_call_expr(in, in, in, out, di, uo) is det.
+
+%
+% Initializers
+%
+
+ % A GCC `tree' representing an array index or field to initialize.
+:- type gcc__init_elem.
+
+ % Create a gcc__init_elem that represents an initializer
+ % for an array element at the given array index.
+:- pred array_elem_initializer(int, gcc__init_elem, io__state, io__state).
+:- mode array_elem_initializer(in, out, di, uo) is det.
+
+ % Create a gcc__init_elem that represents an initializer
+ % for the given field of a structure.
+:- pred struct_field_initializer(gcc__field_decl, gcc__init_elem,
+ io__state, io__state).
+:- mode struct_field_initializer(in, out, di, uo) is det.
+
+ % A GCC `tree' representing a list of initializers
+ % for an array or structure.
+:- type gcc__init_list.
+
+:- pred empty_init_list(gcc__init_list, io__state, io__state).
+:- mode empty_init_list(out, di, uo) is det.
+
+:- pred cons_init_list(gcc__init_elem, gcc__expr, gcc__init_list, gcc__init_list,
+ io__state, io__state).
+:- mode cons_init_list(in, in, in, out, di, uo) is det.
+
+ % build an expression for an array or structure initializer
+:- pred build_initializer_expr(gcc__init_list, gcc__type, gcc__expr,
+ io__state, io__state).
+:- mode build_initializer_expr(in, in, out, di, uo) is det.
+
+%-----------------------------------------------------------------------------%
+%
+% Functions
+%
+
+ % start generating code for a function
+:- pred start_function(gcc__func_decl, io__state, io__state).
+:- mode start_function(in, di, uo) is det.
+
+ % finish generating code for a function
+:- pred end_function(io__state, io__state).
+:- mode end_function(di, uo) is det.
+
+ % set_context(Filename, LineNumber):
+ % Set the source location that GCC uses for subsequent
+ % declarations and diagnostics. This should be called
+ % before `start_function' and also before `end_function'.
+:- pred set_context(string, int, io__state, io__state).
+:- mode set_context(in, in, di, uo) is det.
+
+ % gen_line_note(FileName, LineNumber):
+ % Generate a marker indicating the source location.
+ % This should be called before generating each statement.
+:- pred gen_line_note(string, int, io__state, io__state).
+:- mode gen_line_note(in, in, di, uo) is det.
+
+%-----------------------------------------------------------------------------%
+%
+% Statements
+%
+
+%
+% routines to generate code for if-then-elses
+%
+
+ % start generating code for an if-then-else
+ % the argument is the gcc tree for the condition
+:- pred gen_start_cond(gcc__expr, io__state, io__state).
+:- mode gen_start_cond(in, di, uo) is det.
+
+ % start the else part (optional)
+:- pred gen_start_else(io__state, io__state).
+:- mode gen_start_else(di, uo) is det.
+
+ % finish the if-then-else
+:- pred gen_end_cond(io__state, io__state).
+:- mode gen_end_cond(di, uo) is det.
+
+%
+% routines to generate code for switches
+%
+
+:- pred gen_start_switch(gcc__expr, gcc__type, io__state, io__state).
+:- mode gen_start_switch(in, in, di, uo) is det.
+
+:- pred gen_case_label(gcc__expr, gcc__label, io__state, io__state).
+:- mode gen_case_label(in, in, di, uo) is det.
+
+:- pred gen_default_case_label(gcc__label, io__state, io__state).
+:- mode gen_default_case_label(in, di, uo) is det.
+
+:- pred gen_break(io__state, io__state).
+:- mode gen_break(di, uo) is det.
+
+:- pred gen_end_switch(gcc__expr, io__state, io__state).
+:- mode gen_end_switch(in, di, uo) is det.
+
+%
+% routines to generate code for loops
+%
+
+:- type gcc__loop.
+
+:- pred gen_start_loop(gcc__loop, io__state, io__state).
+:- mode gen_start_loop(out, di, uo) is det.
+
+:- pred gen_exit_loop_if_false(gcc__loop, gcc__expr, io__state, io__state).
+:- mode gen_exit_loop_if_false(in, in, di, uo) is det.
+
+:- pred gen_end_loop(io__state, io__state).
+:- mode gen_end_loop(di, uo) is det.
+
+%
+% routines to generate code for calls/returns
+%
+
+ % generate code for an expression with side effects
+ % (e.g. a call)
+:- pred gen_expr_stmt(gcc__expr, io__state, io__state).
+:- mode gen_expr_stmt(in, di, uo) is det.
+
+ % generate code for a return statement
+:- pred gen_return(gcc__expr, io__state, io__state).
+:- mode gen_return(in, di, uo) is det.
+
+%
+% assignment
+%
+
+ % gen_assign(LHS, RHS):
+ % generate code for an assignment statement
+:- pred gen_assign(gcc__expr, gcc__expr, io__state, io__state).
+:- mode gen_assign(in, in, di, uo) is det.
+
+%
+% labels and goto
+%
+
+:- type gcc__label.
+:- type gcc__label_name == string.
+
+ % Build a gcc tree node for a label.
+ % Note that you also need to use gen_label
+ % (or gen_case_label) to define the label.
+:- pred build_label(gcc__label_name, gcc__label, io__state, io__state).
+:- mode build_label(in, out, di, uo) is det.
+
+:- pred build_unnamed_label(gcc__label, io__state, io__state).
+:- mode build_unnamed_label(out, di, uo) is det.
+
+:- pred gen_label(gcc__label, io__state, io__state).
+:- mode gen_label(in, di, uo) is det.
+
+:- pred gen_goto(gcc__label, io__state, io__state).
+:- mode gen_goto(in, di, uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+:- import_module int, string.
+
+:- pragma c_header_code("
+
+#include ""config.h""
+#include ""system.h""
+#include ""gansidecl.h""
+#include ""tree.h""
+/* XXX we should eliminate the dependency on the C front-end */
+#include ""c-tree.h""
+
+#include ""mercury-gcc.h""
+
+").
+
+
+:- type gcc__tree ---> gcc__tree(c_pointer).
+:- type gcc__tree_code == int.
+
+%-----------------------------------------------------------------------------%
+%
+% Types
+%
+
+:- type gcc__type == gcc__tree.
+
+:- type gcc__func_decl == gcc__type.
+
+:- pragma c_code(void_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) void_type_node;
+").
+:- pragma c_code(boolean_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) boolean_type_node;
+").
+:- pragma c_code(char_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) char_type_node;
+").
+:- pragma c_code(string_type_node = (Type::out), [will_not_call_mercury], "
+ /*
+ ** XXX we should consider using const when appropriate,
+ ** i.e. when the string doesn't have a unique mode
+ */
+ Type = (MR_Word) string_type_node;
+").
+:- pragma c_code(double_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) double_type_node;
+").
+:- pragma c_code(ptr_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) ptr_type_node;
+").
+:- pragma c_code(integer_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) integer_type_node;
+").
+:- pragma c_code(int8_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) merc_int8_type_node;
+").
+:- pragma c_code(int16_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) merc_int16_type_node;
+").
+:- pragma c_code(int32_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) merc_int32_type_node;
+").
+:- pragma c_code(int64_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) merc_int64_type_node;
+").
+:- pragma c_code(intptr_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) merc_intptr_type_node;
+").
+:- pragma c_code(jmpbuf_type_node = (Type::out), [will_not_call_mercury], "
+ Type = (MR_Word) merc_jmpbuf_type_node;
+").
+
+:- pragma c_code(build_pointer_type(Type::in, PtrType::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ PtrType = (MR_Word) build_pointer_type((tree) Type);
+").
+
+:- pragma c_code(build_array_type(ElemType::in, NumElems::in, ArrayType::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ /* XXX Move this code to `mercury-gcc.c'. */
+ /* XXX Do we need to check that NumElems fits in a HOST_WIDE_INT? */
+ HOST_WIDE_INT max = (HOST_WIDE_INT) NumElems - (HOST_WIDE_INT) 1;
+ tree index_type = build_index_type (build_int_2 (max,
+ (max < 0 ? -1 : 0)));
+ ArrayType = (MR_Word) build_array_type((tree) ElemType, index_type);
+").
+
+:- pragma c_code(build_range_type(Type::in, Min::in, Max::in, RangeType::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ RangeType = (MR_Word) build_range_type((tree) Type,
+ build_int_2 (Min, (Min < 0 ? -1 : 0)),
+ build_int_2 (Max, (Max < 0 ? -1 : 0)));
+").
+
+:- type gcc__param_types == gcc__tree.
+
+:- pragma c_code(empty_param_types = (ParamTypes::out), [will_not_call_mercury],
+"
+ ParamTypes = (MR_Word) merc_empty_param_type_list();
+").
+
+:- pragma c_code(cons_param_types(Type::in, Types0::in) = (Types::out),
+ [will_not_call_mercury],
+"
+ Types = (MR_Word)
+ merc_cons_param_type_list((tree) Type, (tree) Types0);
+").
+
+:- pragma c_code(build_function_type(RetType::in, ParamTypes::in,
+ FunctionType::out, _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ FunctionType = (MR_Word) build_function_type((tree) RetType,
+ (tree) ParamTypes);
+").
+
+:- pragma c_code(declared_type(TypeDecl::in) = (Type::out),
+ [will_not_call_mercury],
+"
+ Type = (MR_Word) TREE_TYPE((tree) TypeDecl);
+").
+
+:- pragma c_code(get_array_elem_type(ArrayType::in, ElemType::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ ElemType = (MR_Word) TREE_TYPE((tree) ArrayType);
+").
+
+:- pragma c_code(get_struct_field_decls(StructType::in, FieldDecls::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ FieldDecls = (MR_Word) TYPE_FIELDS((tree) StructType);
+").
+
+%-----------------------------------------------------------------------------%
+%
+% Declarations
+%
+
+%
+% Stuff for variable declarations
+%
+
+:- type gcc__var_decl == gcc__tree.
+
+:- pragma c_code(build_extern_var_decl(Name::in, Type::in, Decl::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_build_extern_var_decl(Name, (tree) Type);
+").
+
+:- pragma c_code(build_global_var_decl(Name::in, Type::in, Init::in, Decl::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_build_global_var_decl(Name, (tree) Type,
+ (tree) Init);
+").
+
+:- pragma c_code(build_local_var_decl(Name::in, Type::in, Decl::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_build_local_var_decl(Name, (tree) Type);
+").
+
+%
+% Stuff for function declarations
+%
+
+:- type gcc__param_decls == gcc__tree.
+
+:- pragma c_code(build_param_decl(Name::in, Type::in, Decl::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_build_param_decl(Name, (tree) Type);
+").
+
+:- pragma c_code(empty_param_decls = (Decl::out), [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_empty_param_list();
+").
+
+:- pragma c_code(cons_param_decls(Decl::in, Decls0::in) = (Decls::out),
+ [will_not_call_mercury],
+"
+ Decls = (MR_Word) merc_cons_param_list((tree) Decl, (tree) Decls0);
+").
+
+:- pragma c_code(build_function_decl(Name::in, AsmName::in,
+ RetType::in, ParamTypes::in, Params::in, Decl::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_build_function_decl(Name, AsmName,
+ (tree) RetType, (tree) ParamTypes, (tree) Params);
+").
+
+:- pragma c_code(alloc_func_decl = (Decl::out),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_alloc_function_node;
+").
+
+:- pragma c_code(strcmp_func_decl = (Decl::out),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_strcmp_function_node;
+").
+
+:- pragma c_code(hash_string_func_decl = (Decl::out),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_hash_string_function_node;
+").
+
+:- pragma c_code(box_float_func_decl = (Decl::out),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_box_float_function_node;
+").
+
+:- pragma c_code(setjmp_func_decl = (Decl::out),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_setjmp_function_node;
+").
+
+:- pragma c_code(longjmp_func_decl = (Decl::out),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_longjmp_function_node;
+").
+
+%
+% Stuff for type declarations.
+%
+
+:- type gcc__field_decl == gcc__tree.
+
+:- pragma c_code(build_field_decl(Name::in, Type::in, Decl::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_build_field_decl(Name, (tree) Type);
+").
+
+:- pragma c_code(field_type(Decl::in, Type::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Type = (MR_Word) TREE_TYPE((tree) Decl);
+").
+
+:- type gcc__field_decls == gcc__tree.
+
+:- pragma c_code(empty_field_list(Decl::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_empty_field_list();
+").
+
+:- pragma c_code(cons_field_list(Decl::in, Decls0::in, Decls::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Decls = (MR_Word) merc_cons_field_list((tree) Decl, (tree) Decls0);
+").
+
+:- pragma c_code(next_field_decl(Decls::in, Decl::out, RemainingDecls::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ assert((tree) Decls != NULL_TREE);
+ Decl = (MR_Word) (tree) Decls;
+ RemainingDecls = (MR_Word) TREE_CHAIN((tree) Decls);
+").
+
+:- type gcc__type_decl == gcc__tree.
+
+:- pragma c_code(build_struct_type_decl(Name::in, FieldTypes::in, Decl::out,
+ _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Decl = (MR_Word) merc_build_struct_type_decl(Name, (tree) FieldTypes);
+").
+
+%-----------------------------------------------------------------------------%
+%
+% Operators
+%
+
+:- type gcc__op == gcc__tree_code.
+
+:- pragma c_code(plus_expr = (Code::out), [will_not_call_mercury], "
+ Code = PLUS_EXPR;
+").
+:- pragma c_code(minus_expr = (Code::out), [will_not_call_mercury], "
+ Code = MINUS_EXPR;
+").
+:- pragma c_code(mult_expr = (Code::out), [will_not_call_mercury], "
+ Code = MULT_EXPR;
+").
+:- pragma c_code(trunc_div_expr = (Code::out), [will_not_call_mercury], "
+ Code = TRUNC_DIV_EXPR;
+").
+:- pragma c_code(trunc_mod_expr = (Code::out), [will_not_call_mercury], "
+ Code = TRUNC_MOD_EXPR;
+").
+
+:- pragma c_code(eq_expr = (Code::out), [will_not_call_mercury], "
+ Code = EQ_EXPR;
+").
+:- pragma c_code(ne_expr = (Code::out), [will_not_call_mercury], "
+ Code = NE_EXPR;
+").
+:- pragma c_code(lt_expr = (Code::out), [will_not_call_mercury], "
+ Code = LT_EXPR;
+").
+:- pragma c_code(gt_expr = (Code::out), [will_not_call_mercury], "
+ Code = GT_EXPR;
+").
+:- pragma c_code(le_expr = (Code::out), [will_not_call_mercury], "
+ Code = LE_EXPR;
+").
+:- pragma c_code(ge_expr = (Code::out), [will_not_call_mercury], "
+ Code = GE_EXPR;
+").
+
+:- pragma c_code(truth_andif_expr = (Code::out), [will_not_call_mercury], "
+ Code = TRUTH_ANDIF_EXPR;
+").
+:- pragma c_code(truth_orif_expr = (Code::out), [will_not_call_mercury], "
+ Code = TRUTH_ORIF_EXPR;
+").
+:- pragma c_code(truth_not_expr = (Code::out), [will_not_call_mercury], "
+ Code = TRUTH_NOT_EXPR;
+").
+
+:- pragma c_code(bit_ior_expr = (Code::out), [will_not_call_mercury], "
+ Code = BIT_IOR_EXPR;
+").
+:- pragma c_code(bit_xor_expr = (Code::out), [will_not_call_mercury], "
+ Code = BIT_XOR_EXPR;
+").
+:- pragma c_code(bit_and_expr = (Code::out), [will_not_call_mercury], "
+ Code = BIT_AND_EXPR;
+").
+:- pragma c_code(bit_not_expr = (Code::out), [will_not_call_mercury], "
+ Code = BIT_NOT_EXPR;
+").
+
+:- pragma c_code(lshift_expr = (Code::out), [will_not_call_mercury], "
+ Code = LSHIFT_EXPR;
+").
+:- pragma c_code(rshift_expr = (Code::out), [will_not_call_mercury], "
+ Code = RSHIFT_EXPR;
+").
+
+:- pragma c_code(array_ref = (Code::out), [will_not_call_mercury], "
+ Code = ARRAY_REF;
+").
+
+%-----------------------------------------------------------------------------%
+%
+% Expressions
+%
+
+:- type gcc__expr == gcc__tree.
+
+:- pragma c_code(expr_type(Expr::in, Type::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Type = (MR_Word) TREE_TYPE((tree) Expr);
+").
+
+%
+% constants
+%
+
+build_int(Val, IntExpr) -->
+ { Lowpart = Val },
+ { Highpart = (if Val < 0 then -1 else 0) },
+ build_int_2(Lowpart, Highpart, IntExpr).
+
+ % build_int_2(Lowpart, Highpart):
+ % build an expression for an integer constant.
+ % Lowpart gives the low word, and Highpart gives the high word.
+:- pred build_int_2(int, int, gcc__expr, io__state, io__state).
+:- mode build_int_2(in, in, out, di, uo) is det.
+
+:- pragma c_code(build_int_2(Low::in, High::in, Expr::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Expr = (MR_Word) build_int_2(Low, High);
+").
+
+build_float(Val, Expr) -->
+ build_real(gcc__double_type_node, Val, Expr).
+
+ % build an expression for a floating-point constant
+ % of the specified type.
+:- pred build_real(gcc__type, float, gcc__expr, io__state, io__state).
+:- mode build_real(in, in, out, di, uo) is det.
+
+:- pragma c_code(build_real(Type::in, Value::in, Expr::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ /* XXX should move to mercury-gcc.c */
+ /* XXX this won't work if cross-compiling */
+ union { double dbl; HOST_WIDE_INT ints[20]; } u;
+ u.dbl = Value;
+ Expr = (MR_Word) build_real((tree) Type,
+ REAL_VALUE_FROM_TARGET_DOUBLE(u.ints));
+").
+
+build_string(String, Expr) -->
+ build_string(string__length(String) + 1, String, Expr).
+
+:- pragma c_code(build_string(Len::in, String::in, Expr::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Expr = (MR_Word) merc_build_string(Len, String);
+").
+
+:- pragma c_code(build_null_pointer(NullPointerExpr::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ NullPointerExpr = (MR_Word) null_pointer_node;
+").
+
+%
+% operator expressions
+%
+
+:- pragma c_code(build_unop(Op::in, Type::in, Arg::in, Expr::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Expr = (MR_Word) fold(build1(Op, (tree) Type, (tree) Arg));
+").
+
+:- pragma c_code(build_binop(Op::in, Type::in, Arg1::in, Arg2::in, Expr::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Expr = (MR_Word) fold(build(Op, (tree) Type, (tree) Arg1, (tree) Arg2));
+").
+
+:- pragma c_code(build_pointer_deref(Pointer::in, DerefExpr::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ /* XXX should move to mercury-gcc.c */
+ tree ptr = (tree) Pointer;
+ tree ptr_type = TREE_TYPE (ptr);
+ tree type = TREE_TYPE (ptr_type);
+ DerefExpr = (MR_Word) build1 (INDIRECT_REF, type, ptr);
+").
+
+:- pragma c_code(build_component_ref(ObjectExpr::in, FieldDecl::in, FieldExpr::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ /* XXX should move to mercury-gcc.c */
+ tree field_type = TREE_TYPE ((tree) FieldDecl);
+ FieldExpr = (MR_Word) build (COMPONENT_REF, field_type,
+ (tree) ObjectExpr, (tree) FieldDecl);
+").
+
+:- pragma c_code(convert_type(Expr::in, Type::in, ResultExpr::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ /*
+ ** XXX should we use convert() instead?
+ ** if not, should we expose the CONVERT_EXPR gcc__op
+ ** and just use gcc__build_binop?
+ */
+ ResultExpr = (MR_Word) build1 (CONVERT_EXPR, (tree) Type, (tree) Expr);
+").
+
+ % We building an address expression, we need to call
+ % mark_addressable to let the gcc back-end know that we've
+ % taken the address of this expression, so that (e.g.)
+ % if the expression is a variable, then gcc will know to
+ % put it in a stack slot rather than a register.
+ % To make the interface to this module safer,
+ % we don't export the `addr_expr' operator directly.
+ % Instead, we only export the procedure `build_addr_expr'
+ % which includes the necessary call to mark_addressable.
+
+build_addr_expr(Expr, AddrExpr) -->
+ mark_addressable(Expr),
+ expr_type(Expr, Type),
+ build_pointer_type(Type, PtrType),
+ build_unop(addr_expr, PtrType, Expr, AddrExpr).
+
+:- func addr_expr = gcc__op. % & (address-of)
+:- pragma c_code(addr_expr = (Code::out), [will_not_call_mercury], "
+ Code = ADDR_EXPR;
+").
+
+:- pred mark_addressable(gcc__expr::in, io__state::di, io__state::uo) is det.
+:- pragma c_code(mark_addressable(Expr::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ mark_addressable((tree) Expr);
+").
+
+%
+% variables
+%
+
+
+ % GCC represents variable expressions just by (the pointer to)
+ % their declaration tree node.
+var_expr(Decl) = Decl.
+
+%
+% stuff for function calls
+%
+
+ % GCC represents functions pointer expressions just as ordinary
+ % ADDR_EXPR nodes whose operand the function declaration tree node.
+build_func_addr_expr(FuncDecl, Expr) -->
+ build_addr_expr(FuncDecl, Expr).
+
+:- type gcc__arg_list == gcc__tree.
+
+:- pragma c_code(empty_arg_list(ArgList::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ ArgList = (MR_Word) merc_empty_arg_list();
+").
+
+:- pragma c_code(cons_arg_list(Arg::in, ArgList0::in, ArgList::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ ArgList = (MR_Word)
+ merc_cons_arg_list((tree) Arg, (tree) ArgList0);
+").
+
+:- pragma c_code(build_call_expr(Func::in, Args::in, IsTailCall::in,
+ CallExpr::out, _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ CallExpr = (MR_Word) merc_build_call_expr((tree) Func, (tree) Args,
+ (int) IsTailCall);
+").
+
+%
+% Initializers
+%
+
+:- type gcc__init_elem == gcc__tree.
+
+gcc__array_elem_initializer(Int, GCC_Int) -->
+ build_int(Int, GCC_Int).
+
+gcc__struct_field_initializer(FieldDecl, FieldDecl) --> [].
+
+:- type gcc__init_list == gcc__tree.
+
+:- pragma c_code(empty_init_list(InitList::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ InitList = (MR_Word) merc_empty_init_list();
+").
+
+:- pragma c_code(cons_init_list(Elem::in, Init::in, InitList0::in, InitList::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ InitList = (MR_Word)
+ merc_cons_init_list((tree) Elem, (tree) Init, (tree) InitList0);
+").
+
+:- pragma c_code(build_initializer_expr(InitList::in, Type::in,
+ Expr::out, _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ Expr = (MR_Word) build(CONSTRUCTOR, (tree) Type, NULL_TREE,
+ (tree) InitList);
+#if 0
+ /* XXX do we need this? */
+ TREE_STATIC ((tree) Expr) = 1;
+#endif
+").
+
+%-----------------------------------------------------------------------------%
+%
+% Functions
+%
+
+:- pragma c_code(start_function(FuncDecl::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ merc_start_function((tree) FuncDecl);
+").
+
+:- pragma import(end_function(di, uo), [will_not_call_mercury],
+ "merc_end_function").
+
+:- pragma c_code(set_context(FileName::in, LineNumber::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ merc_set_context(FileName, LineNumber);
+").
+
+:- pragma c_code(gen_line_note(FileName::in, LineNumber::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ emit_line_note(FileName, LineNumber);
+").
+
+%-----------------------------------------------------------------------------%
+%
+% Statements.
+%
+
+%
+% if-then-else
+%
+
+:- pragma c_code(gen_start_cond(Cond::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ expand_start_cond((tree) Cond, 0);
+").
+
+:- pragma import(gen_start_else(di, uo), [will_not_call_mercury],
+ "expand_start_else").
+
+:- pragma import(gen_end_cond(di, uo), [will_not_call_mercury],
+ "expand_end_cond").
+
+%
+% switch statements
+%
+
+:- pragma c_code(gen_start_switch(Expr::in, Type::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ expand_start_case(1, (tree) Expr, (tree) Type, ""switch"");
+").
+
+:- pragma c_code(gen_case_label(Value::in, Label::in,
+ _IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ merc_gen_switch_case_label((tree) Value, (tree) Label);
+").
+
+:- pragma c_code(gen_default_case_label(Label::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ merc_gen_switch_case_label(NULL_TREE, (tree) Label);
+").
+
+:- pragma c_code(gen_break(_IO0::di, _IO::uo), [will_not_call_mercury],
+"
+ int result = expand_exit_something();
+ assert(result != 0);
+").
+
+:- pragma c_code(gen_end_switch(Expr::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ expand_end_case((tree) Expr);
+").
+
+%
+% loops
+%
+
+ % the type `gcc__loop' corresponds to the
+ % C type `struct nesting *'
+:- type gcc__loop ---> gcc__loop(c_pointer).
+
+:- pragma c_code(gen_start_loop(Loop::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Loop = (MR_Word) expand_start_loop(0);
+").
+
+:- pragma c_code(gen_exit_loop_if_false(Loop::in, Expr::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ int res = expand_exit_loop_if_false((struct nesting *) Loop,
+ (tree) Expr);
+ assert(res != 0);
+").
+
+:- pragma c_code(gen_end_loop(_IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ expand_end_loop();
+").
+
+%
+% calls and return
+%
+
+:- pragma c_code(gen_expr_stmt(Expr::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ merc_gen_expr_stmt((tree) Expr);
+").
+
+:- pragma c_code(gen_return(Expr::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ merc_gen_return((tree) Expr);
+").
+
+%
+% assignment
+%
+
+:- pragma c_code(gen_assign(LHS::in, RHS::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ merc_gen_assign((tree) LHS, (tree) RHS);
+").
+
+%
+% labels and gotos
+%
+
+:- type gcc__label == gcc__tree.
+
+:- pragma c_code(build_label(Name::in, Label::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Label = (MR_Word) merc_build_label(Name);
+").
+
+:- pragma c_code(build_unnamed_label(Label::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ Label = (MR_Word) merc_build_label(NULL);
+").
+
+:- pragma c_code(gen_label(Label::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ expand_label((tree) Label);
+").
+
+:- pragma c_code(gen_goto(Label::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury],
+"
+ expand_goto((tree) Label);
+").
+
+%-----------------------------------------------------------------------------%
Index: mercury/compiler/globals.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/globals.m,v
retrieving revision 1.38
diff -u -d -r1.38 globals.m
--- mercury/compiler/globals.m 2000/11/17 17:47:10 1.38
+++ mercury/compiler/globals.m 2000/12/17 13:13:34
@@ -22,11 +22,15 @@
:- type globals.
:- type compilation_target
- ---> c % Generate C code
+ ---> c % Generate C code (including GNU C)
; il % Generate IL assembler code
% IL is the Microsoft .NET Intermediate Language
- ; java. % Generate Java
+ ; java % Generate Java
% (this target is not yet implemented)
+ ; asm. % Compile directly to assembler via the GCC back-end.
+ % Do not go via C, instead generate GCC's internal
+ % `tree' data structure.
+ % (Work in progress.)
:- type gc_method
---> none
@@ -186,6 +190,9 @@
% test against known strings.
convert_target("java", java).
convert_target("Java", java).
+convert_target("asm", asm).
+convert_target("Asm", asm).
+convert_target("ASM", asm).
convert_target("il", il).
convert_target("IL", il).
convert_target("c", c).
Index: mercury/compiler/handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.98
diff -u -d -r1.98 handle_options.m
--- mercury/compiler/handle_options.m 2000/12/10 07:39:37 1.98
+++ mercury/compiler/handle_options.m 2000/12/17 13:15:34
@@ -294,10 +294,18 @@
[]
),
- % Generating high-level C code requires putting each commit
+ % Generating assembler via the gcc back-end requires
+ % using high-level code.
+ ( { Target = asm } ->
+ globals__io_set_option(highlevel_code, bool(yes))
+ ;
+ []
+ ),
+
+ % Generating high-level C or asm code requires putting each commit
% in its own function, to avoid problems with setjmp() and
% non-volatile local variables.
- ( { Target = c } ->
+ ( { Target = c ; Target = asm } ->
option_implies(highlevel_code, put_commit_in_own_func, bool(yes))
;
[]
@@ -587,6 +595,10 @@
{ Target = il },
{ BackendForeignLanguage =
foreign_language_string(managed_cplusplus) }
+ ;
+ { Target = asm },
+ % XXX This is wrong! It should be asm.
+ { BackendForeignLanguage = foreign_language_string(c) }
;
% XXX We don't generate java or handle it as a foreign
% language just yet, but if we did, we should fix this
Index: mercury/compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.186
diff -u -d -r1.186 mercury_compile.m
--- mercury/compiler/mercury_compile.m 2000/12/13 12:12:53 1.186
+++ mercury/compiler/mercury_compile.m 2000/12/15 18:58:32
@@ -63,6 +63,7 @@
:- import_module ml_optimize. % MLDS -> MLDS
:- import_module mlds_to_c. % MLDS -> C
:- import_module mlds_to_ilasm. % MLDS -> IL assembler
+:- import_module mlds_to_gcc. % MLDS -> GCC back-end
% miscellaneous compiler modules
@@ -484,6 +485,10 @@
mercury_compile__il_assemble(ModuleName,
HasMain)
)
+ ; { Target = asm } ->
+ % compile directly assembler using the gcc back-end
+ mercury_compile__mlds_backend(HLDS50, MLDS),
+ mercury_compile__mlds_to_gcc(MLDS)
; { HighLevelCode = yes } ->
mercury_compile__mlds_backend(HLDS50, MLDS),
mercury_compile__mlds_to_high_level_c(MLDS),
@@ -2542,6 +2547,18 @@
maybe_write_string(Verbose, "% Converting MLDS to C...\n"),
mlds_to_c__output_mlds(MLDS),
maybe_write_string(Verbose, "% Finished converting MLDS to C.\n"),
+ maybe_report_stats(Stats).
+
+:- pred mercury_compile__mlds_to_gcc(mlds, io__state, io__state).
+:- mode mercury_compile__mlds_to_gcc(in, di, uo) is det.
+
+mercury_compile__mlds_to_gcc(MLDS) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ globals__io_lookup_bool_option(statistics, Stats),
+
+ maybe_write_string(Verbose, "% Passing MLDS to GCC and compiling to assembler...\n"),
+ mlds_to_gcc__compile_to_asm(MLDS),
+ maybe_write_string(Verbose, "% Finished compiling to assembler.\n"),
maybe_report_stats(Stats).
:- pred mercury_compile__mlds_to_il_assembler(mlds, io__state, io__state).
Index: mercury/compiler/mlds_to_gcc.m
===================================================================
RCS file: mlds_to_gcc.m
diff -N mlds_to_gcc.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ mlds_to_gcc.m Thu Jan 4 04:05:30 2001
@@ -0,0 +1,2924 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1999-2000 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.
+%-----------------------------------------------------------------------------%
+
+% mlds_to_gcc - Convert MLDS to the GCC back-end representation.
+% Main author: fjh.
+
+% Note that this does *not* compile to GNU C -- instead it
+% actually generates GCC's internal "Tree" representation,
+% without going via an external file.
+
+% Currently this supports grade hlc.gc only.
+%
+% Trailing will probably work too, but since trailing
+% is currently implemented using the C interface,
+% it will end up compiling everything via C.
+
+% TODO:
+% Fix configuration issues:
+% - mmake support
+% - document installation procedure
+% - test more
+% - support in tools/bootcheck and check that it bootchecks
+% - set up nightly tests
+%
+% Implement implementation-specific features that are supported
+% by other Mercury back-ends:
+% - support --high-level-data (enum types, pred types, user_type)
+% - support --profiling and --heap-profiling
+% - support --nondet-copy-out
+% - support --gcc-nested-functions (probably not worth it)
+% - pragma foreign_code(asm, ...)
+%
+% Implement implementation-specific features that are supported
+% by other gcc front-ends:
+% - support gdb
+% - improve accuracy of line numbers (e.g. for decls).
+% - fix variable scoping so that local vars show up
+% - generate gcc trees rather than expanding as we go
+%
+% Improve efficiency of generated code:
+% - --static-ground-terms
+% - improve code for switches with default_is_unreachable.
+% One way would be to implement computed_goto and cast_to_unsigned,
+% and change target_supports_computed_goto_2(asm) in ml_switch_gen.m
+% to `yes'.
+% - fix variable scoping
+% - fix declaration flags (const, etc.)
+% - implement annotation in gcc tree to force tailcalls
+%
+% Improve efficiency of compilation:
+% - improve symbol table handling
+%
+% See also the TODO list in ml_code_gen.m.
+
+%-----------------------------------------------------------------------------%
+
+:- module mlds_to_gcc.
+:- interface.
+
+:- import_module mlds.
+:- use_module io.
+
+:- pred mlds_to_gcc__compile_to_asm(mlds__mlds, io__state, io__state).
+:- mode mlds_to_gcc__compile_to_asm(in, di, uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- use_module gcc.
+
+% XXX some of these imports might be unused
+
+:- import_module ml_util.
+:- import_module mlds_to_c. % to handle C foreign_code
+:- import_module llds_out. % XXX needed for llds_out__name_mangle,
+ % llds_out__sym_name_mangle,
+ % llds_out__make_base_typeclass_info_name,
+:- import_module rtti. % for rtti__addr_to_string.
+:- import_module ml_code_util. % for ml_gen_mlds_var_decl, which is used by
+ % the code that handles derived classes
+:- import_module hlds_pred. % for proc_id_to_int and invalid_pred_id
+:- import_module globals, options, passes_aux.
+:- import_module builtin_ops, modules.
+:- import_module prog_data, prog_out, prog_util, type_util, error_util.
+:- import_module pseudo_type_info.
+
+:- import_module bool, int, string, library, list, map.
+:- import_module assoc_list, term, std_util, require.
+
+%-----------------------------------------------------------------------------%
+
+:- type output_type == pred(mlds__type, io__state, io__state).
+:- inst output_type = (pred(in, di, uo) is det).
+
+%-----------------------------------------------------------------------------%
+
+
+mlds_to_gcc__compile_to_asm(MLDS) -->
+ { MLDS = mlds(ModuleName, ForeignCode, Imports, Defns0) },
+
+ %
+ % Handle output of any foreign code (C, Ada, Fortran, etc.)
+ % to appropriate files.
+ %
+ { list__filter(defn_contains_foreign_code, Defns0,
+ ForeignDefns, Defns) },
+ (
+ { ForeignCode = mlds__foreign_code([], [], []) },
+ { ForeignDefns = [] }
+ ->
+ % there's no foreign code, so we don't need to
+ % do anything special
+ { NeedInitFn = yes }
+ ;
+ % create a new MLDS containing just the foreign code
+ % and pass that to mlds_to_c.m
+ { ForeignMLDS = mlds(ModuleName, ForeignCode, Imports,
+ ForeignDefns) },
+ mlds_to_c__output_mlds(ForeignMLDS),
+ { NeedInitFn = no }
+ ),
+
+ %
+ % We generate things in this order:
+ % #1. definitions of the types,
+ % #2. definitions of all the non-types
+ % #3. initialization functions
+ % #1 needs to come before #2 since we need the types to be
+ % complete before we generate local variables of that type.
+ % (This happens for the environment structs that we
+ % use for nested functions.)
+ %
+ % Declarations of functions and types referred to by this
+ % module are generated on-demand.
+ %
+ { list__filter(defn_is_type, Defns, TypeDefns, NonTypeDefns) },
+ { MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName) },
+ { GlobalInfo0 = global_info(map__init, map__init) },
+ gen_defns(MLDS_ModuleName, TypeDefns, GlobalInfo0, GlobalInfo1),
+ gen_defns(MLDS_ModuleName, NonTypeDefns, GlobalInfo1, GlobalInfo2),
+
+ % XXX currently we just generate an empty initialization function.
+ % Initialization functions are only needed for --profiling
+ % and --heap-profiling, which we don't support yet.
+ ( { NeedInitFn = yes } ->
+ gen_init_fn_defns(MLDS_ModuleName, GlobalInfo2, _GlobalInfo)
+ ;
+ []
+ ).
+/****
+not yet:
+ { list__filter(defn_is_function, NonTypeDefns, FuncDefns) },
+ { list__filter(defn_is_type_ctor_info, NonTypeDefns,
+ TypeCtorInfoDefns) },
+ mlds_output_init_fn_defns(MLDS_ModuleName, FuncDefns,
+ TypeCtorInfoDefns), io__nl,
+*****/
+
+ % XXX we ought to output a reference to the mangled grade name,
+ % to prevent linking with the wrong grade.
+ % But this would require duplicating the logic in
+ % runtime/mercury_grade.h. Some of it is already duplicated
+ % in
+ % of the code in
+/******
+not yet:
+ % mlds_output_grade_var, io__nl.
+******/
+
+
+/******
+not yet implemented for mlds_to_gcc:
+ %
+ % Output a reference to the mangled grade name for the grade
+ % that the C file gets compiled with. This ensures that
+ % we don't try to link objects files compiled in different
+ % grades.
+ %
+:- pred mlds_output_grade_var(io__state::di, io__state::uo) is det.
+mlds_output_grade_var -->
+ io__write_string(
+ "// ensure everything is compiled with the same grade\n"),
+ io__write_string(
+ "static const void *const MR_grade = &MR_GRADE_VAR;\n").
+******/
+
+%-----------------------------------------------------------------------------%
+
+:- pred gen_init_fn_defns(mlds_module_name::in,
+ global_info::in, global_info::out,
+ io__state::di, io__state::uo) is det.
+
+gen_init_fn_defns(MLDS_ModuleName, GlobalInfo0, GlobalInfo) -->
+ %
+ % Generate an empty function of the form
+ %
+ % void <foo>_init_type_tables() {}
+ %
+ { GlobalInfo = GlobalInfo0 },
+ { FuncName = init_fn_name(MLDS_ModuleName, "_type_tables") },
+ { GCC_ParamTypes = gcc__empty_param_types },
+ { GCC_ParamDecls = gcc__empty_param_decls },
+ { GCC_RetType = gcc__void_type_node },
+ gcc__build_function_decl(FuncName, FuncName,
+ GCC_RetType, GCC_ParamTypes, GCC_ParamDecls, GCC_FuncDecl),
+ { Name = export(FuncName) },
+ { map__init(SymbolTable) },
+ { map__init(LabelTable) },
+ { FuncInfo = func_info(GlobalInfo,
+ qual(MLDS_ModuleName, Name),
+ SymbolTable, LabelTable) },
+ { term__context_init(Context) },
+ { FuncBody = mlds__statement(block([], []), mlds__make_context(Context)) },
+ gcc__start_function(GCC_FuncDecl),
+ gen_statement(FuncInfo, FuncBody),
+ gcc__end_function.
+
+:- func init_fn_name(mlds_module_name, string) = string.
+
+init_fn_name(ModuleName, Suffix) = InitFnName :-
+ % Here we ensure that we only get one "mercury__" at the
+ % start of the function name.
+ prog_out__sym_name_to_string(
+ mlds_module_name_to_sym_name(ModuleName), "__",
+ ModuleNameString0),
+ (
+ string__prefix(ModuleNameString0, "mercury__")
+ ->
+ ModuleNameString = ModuleNameString0
+ ;
+ string__append("mercury__", ModuleNameString0,
+ ModuleNameString)
+ ),
+ string__append_list([ModuleNameString, "__init", Suffix], InitFnName).
+
+%-----------------------------------------------------------------------------%
+
+/***************
+XXX The following is all not yet implemented for mlds_to_gcc.m.
+The code below shows what mlds_to_c.m does
+(modified to avoid using C macros, which we'll need to do for mlds_to_gcc.m).
+
+ %
+ % Maybe output the function `mercury__<modulename>__init()'.
+ % The body of the function consists of calls
+ % MR_init_entry(<function>) for each function defined in the
+ % module.
+ %
+:- pred mlds_output_init_fn_decls(mlds_module_name::in,
+ io__state::di, io__state::uo) is det.
+
+mlds_output_init_fn_decls(ModuleName) -->
+ output_init_fn_name(ModuleName, ""),
+ io__write_string(";\n"),
+ output_init_fn_name(ModuleName, "_type_tables"),
+ io__write_string(";\n"),
+ output_init_fn_name(ModuleName, "_debugger"),
+ io__write_string(";\n").
+
+:- pred mlds_output_init_fn_defns(mlds_module_name::in, mlds__defns::in,
+ mlds__defns::in, io__state::di, io__state::uo) is det.
+
+mlds_output_init_fn_defns(ModuleName, FuncDefns, TypeCtorInfoDefns) -->
+ output_init_fn_name(ModuleName, ""),
+ io__write_string("\n{\n"),
+ io_get_globals(Globals),
+ (
+ { need_to_init_entries(Globals) },
+ { FuncDefns \= [] }
+ ->
+ io__write_strings(["\tstatic bool initialised = FALSE;\n",
+ "\tif (initialised) return;\n",
+ "\tinitialised = TRUE;\n\n"]),
+ mlds_output_calls_to_init_entry(ModuleName, FuncDefns)
+ ;
+ []
+ ),
+ io__write_string("}\n\n"),
+
+ output_init_fn_name(ModuleName, "_type_tables"),
+ io__write_string("\n{\n"),
+ (
+ { TypeCtorInfoDefns \= [] }
+ ->
+ io__write_strings(["\tstatic bool initialised = FALSE;\n",
+ "\tif (initialised) return;\n",
+ "\tinitialised = TRUE;\n\n"]),
+ mlds_output_calls_to_register_tci(ModuleName,
+ TypeCtorInfoDefns)
+ ;
+ []
+ ),
+ io__write_string("}\n\n"),
+
+ output_init_fn_name(ModuleName, "_debugger"),
+ io__write_string("\n{\n"),
+ io__write_string(
+ "\tMR_fatal_error(""debugger initialization in MLDS grade"");\n"),
+ io__write_string("}\n").
+
+:- pred output_init_fn_name(mlds_module_name::in, string::in,
+ io__state::di, io__state::uo) is det.
+
+output_init_fn_name(ModuleName, Suffix) -->
+ % Here we ensure that we only get one "mercury__" at the
+ % start of the function name.
+ { prog_out__sym_name_to_string(
+ mlds_module_name_to_sym_name(ModuleName), "__",
+ ModuleNameString0) },
+ {
+ string__prefix(ModuleNameString0, "mercury__")
+ ->
+ ModuleNameString = ModuleNameString0
+ ;
+ string__append("mercury__", ModuleNameString0,
+ ModuleNameString)
+ },
+ io__write_string("void "),
+ io__write_string(ModuleNameString),
+ io__write_string("__init"),
+ io__write_string(Suffix),
+ io__write_string("(void)").
+
+:- pred need_to_init_entries(globals::in) is semidet.
+need_to_init_entries(Globals) :-
+ % We only need to output calls to MR_init_entry() if profiling is
+ % enabled.
+ ( Option = profile_calls
+ ; Option = profile_time
+ ; Option = profile_memory
+ ),
+ globals__lookup_bool_option(Globals, Option, yes).
+
+ % Generate calls to MR_init_entry() for the specified functions.
+ %
+:- pred mlds_output_calls_to_init_entry(mlds_module_name::in, mlds__defns::in,
+ io__state::di, io__state::uo) is det.
+
+mlds_output_calls_to_init_entry(_ModuleName, []) --> [].
+mlds_output_calls_to_init_entry(ModuleName, [FuncDefn | FuncDefns]) -->
+ { FuncDefn = mlds__defn(EntityName, _, _, _) },
+ % Generate a call to MR_insert_entry_label(), which is declared as
+ % MR_insert_entry_label(const char *name, MR_Code *addr,
+ % const MR_Stack_Layout_Entry *entry_layout);
+ io__write_string("\tMR_insert_entry_label("""),
+ mlds_output_fully_qualified_name(qual(ModuleName, EntityName)),
+ io__write_string("\t"", "),
+ mlds_output_fully_qualified_name(qual(ModuleName, EntityName)),
+ io__write_string(", NULL);\n"),
+ mlds_output_calls_to_init_entry(ModuleName, FuncDefns).
+
+ % Generate calls to MR_register_type_ctor_info() for the specified
+ % type_ctor_infos.
+ %
+:- pred mlds_output_calls_to_register_tci(mlds_module_name::in, mlds__defns::in,
+ io__state::di, io__state::uo) is det.
+
+mlds_output_calls_to_register_tci(_ModuleName, []) --> [].
+mlds_output_calls_to_register_tci(ModuleName,
+ [TypeCtorInfoDefn | TypeCtorInfoDefns]) -->
+ { TypeCtorInfoDefn = mlds__defn(EntityName, _, _, _) },
+ io__write_string("\tMR_register_type_ctor_info(&"),
+ mlds_output_fully_qualified_name(qual(ModuleName, EntityName)),
+ io__write_string(");\n"),
+ mlds_output_calls_to_register_tci(ModuleName, TypeCtorInfoDefns).
+********************/
+
+%-----------------------------------------------------------------------------%
+%
+% Foreign language interface stuff
+%
+
+/****************
+XXX The following code for handling `pragma export'
+is all not yet implemented for mlds_to_gcc.m.
+The code below is copied from mlds_to_c.m.
+It shows what we need to do.
+
+:- pred mlds_output_pragma_export_decl(mlds_module_name, indent,
+ mlds__pragma_export, io__state, io__state).
+:- mode mlds_output_pragma_export_decl(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_decl(ModuleName, Indent, PragmaExport) -->
+ mlds_output_pragma_export_func_name(ModuleName, Indent, PragmaExport),
+ io__write_string(";").
+
+:- pred mlds_output_pragma_export_defn(mlds_module_name, indent,
+ mlds__pragma_export, io__state, io__state).
+:- mode mlds_output_pragma_export_defn(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_defn(ModuleName, Indent, PragmaExport) -->
+ { PragmaExport = ml_pragma_export(_C_name, MLDS_Name, MLDS_Signature,
+ Context) },
+ mlds_output_pragma_export_func_name(ModuleName, Indent, PragmaExport),
+ io__write_string("\n"),
+ mlds_indent(Context, Indent),
+ io__write_string("{\n"),
+ mlds_indent(Context, Indent),
+ mlds_output_pragma_export_defn_body(ModuleName, MLDS_Name,
+ MLDS_Signature),
+ io__write_string("}\n").
+
+:- pred mlds_output_pragma_export_func_name(mlds_module_name, indent,
+ mlds__pragma_export, io__state, io__state).
+:- mode mlds_output_pragma_export_func_name(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_func_name(ModuleName, Indent,
+ ml_pragma_export(C_name, _MLDS_Name, Signature, Context)) -->
+ { Name = qual(ModuleName, export(C_name)) },
+ mlds_indent(Context, Indent),
+ % For functions exported using `pragma export',
+ % we use the default C calling convention.
+ { CallingConvention = "" },
+ mlds_output_func_decl_ho(Indent, Name, Context,
+ CallingConvention, Signature,
+ mlds_output_pragma_export_type(prefix),
+ mlds_output_pragma_export_type(suffix)).
+
+:- type locn ---> prefix ; suffix.
+:- pred mlds_output_pragma_export_type(locn, mlds__type, io__state, io__state).
+:- mode mlds_output_pragma_export_type(in, in, di, uo) is det.
+
+mlds_output_pragma_export_type(suffix, _Type) --> [].
+mlds_output_pragma_export_type(prefix, mercury_type(Type, _)) -->
+ { export__type_to_type_string(Type, String) },
+ io__write_string(String).
+mlds_output_pragma_export_type(prefix, mlds__cont_type(_)) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__commit_type) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__native_bool_type) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__native_int_type) -->
+ io__write_string("MR_Integer").
+mlds_output_pragma_export_type(prefix, mlds__native_float_type) -->
+ io__write_string("MR_Float").
+mlds_output_pragma_export_type(prefix, mlds__native_char_type) -->
+ io__write_string("MR_Char").
+mlds_output_pragma_export_type(prefix, mlds__class_type(_, _, _)) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__array_type(_)) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__ptr_type(Type)) -->
+ mlds_output_pragma_export_type(prefix, Type),
+ io__write_string(" *").
+mlds_output_pragma_export_type(prefix, mlds__func_type(_)) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__generic_type) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__generic_env_ptr_type) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__pseudo_type_info_type) -->
+ io__write_string("MR_Word").
+mlds_output_pragma_export_type(prefix, mlds__rtti_type(_)) -->
+ io__write_string("MR_Word").
+
+
+ %
+ % Output the definition body for a pragma export
+ %
+:- pred mlds_output_pragma_export_defn_body(mlds_module_name,
+ mlds__qualified_entity_name, func_params, io__state, io__state).
+:- mode mlds_output_pragma_export_defn_body(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_defn_body(ModuleName, FuncName, Signature) -->
+ { Signature = mlds__func_params(Parameters, RetTypes) },
+
+ ( { RetTypes = [] } ->
+ io__write_string("\t")
+ ; { RetTypes = [RetType] } ->
+ io__write_string("\treturn ("),
+ mlds_output_pragma_export_type(prefix, RetType),
+ mlds_output_pragma_export_type(suffix, RetType),
+ io__write_string(") ")
+ ;
+ { error("mlds_output_pragma_export: multiple return types") }
+ ),
+
+ mlds_output_fully_qualified_name(FuncName),
+ io__write_string("("),
+ io__write_list(Parameters, ", ",
+ mlds_output_name_with_cast(ModuleName)),
+ io__write_string(");\n").
+
+
+ %
+ % Write out the arguments to the MLDS function. Note the last
+ % in the list of the arguments is the return value, so it must
+ % be "&arg"
+ %
+:- pred write_func_args(mlds_module_name::in, mlds__arguments::in,
+ io__state::di, io__state::uo) is det.
+
+write_func_args(_ModuleName, []) -->
+ { error("write_func_args: empty list") }.
+write_func_args(_ModuleName, [_Arg]) -->
+ io__write_string("&arg").
+write_func_args(ModuleName, [Arg | Args]) -->
+ { Args = [_|_] },
+ mlds_output_name_with_cast(ModuleName, Arg),
+ io__write_string(", "),
+ write_func_args(ModuleName, Args).
+
+ %
+ % Output a fully qualified name preceded by a cast.
+ %
+:- pred mlds_output_name_with_cast(mlds_module_name::in,
+ pair(mlds__entity_name, mlds__type)::in,
+ io__state::di, io__state::uo) is det.
+
+mlds_output_name_with_cast(ModuleName, Name - Type) -->
+ mlds_output_cast(Type),
+ mlds_output_fully_qualified_name(qual(ModuleName, Name)).
+
+************************/
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output declarations and definitions
+%
+
+
+ % Handle MLDS definitions that occur at global scope.
+:- pred gen_defns(mlds_module_name, mlds__defns, global_info, global_info,
+ io__state, io__state).
+:- mode gen_defns(in, in, in, out, di, uo) is det.
+
+gen_defns(_ModuleName, [], GlobalInfo, GlobalInfo) --> [].
+gen_defns(ModuleName, [Defn | Defns], GlobalInfo0, GlobalInfo) -->
+ gen_defn(ModuleName, Defn, GlobalInfo0, GlobalInfo1),
+ gen_defns(ModuleName, Defns, GlobalInfo1, GlobalInfo).
+
+ % Handle MLDS definitions that are nested inside a
+ % function definition (or inside a block within a function),
+ % and which are hence local to that function.
+:- pred build_local_defns(mlds__defns, func_info, mlds_module_name,
+ symbol_table, symbol_table, io__state, io__state).
+:- mode build_local_defns(in, in, in, in, out, di, uo) is det.
+
+build_local_defns([], _, _, SymbolTable, SymbolTable) --> [].
+build_local_defns([Defn|Defns], FuncInfo, ModuleName, SymbolTable0, SymbolTable) -->
+ build_local_defn(Defn, FuncInfo, ModuleName, GCC_Defn),
+ % Insert the variable definition into our symbol table.
+ % The MLDS code that the MLDS code generator generates should
+ % not have any shadowing of parameters or local variables by
+ % nested local variables, so we use map__det_insert rather
+ % than map__set here. (Actually nothing in this module depends
+ % on it, so this sanity here is perhaps a bit paranoid.)
+ { Defn = mlds__defn(Name, _, _, _) },
+ { SymbolTable1 = map__det_insert(SymbolTable0,
+ qual(ModuleName, Name), GCC_Defn) },
+ build_local_defns(Defns, FuncInfo, ModuleName, SymbolTable1, SymbolTable).
+
+ % Handle MLDS definitions that are nested inside a type,
+ % i.e. fields of that type.
+:- pred build_field_defns(mlds__defns, mlds_module_name, global_info,
+ gcc__field_decls, field_table, field_table,
+ io__state, io__state).
+:- mode build_field_defns(in, in, in, out, in, out, di, uo) is det.
+
+build_field_defns([], _, _, FieldList, FieldTable, FieldTable) -->
+ gcc__empty_field_list(FieldList).
+build_field_defns([Defn|Defns], ModuleName, GlobalInfo, FieldList,
+ FieldTable0, FieldTable) -->
+ build_field_defn(Defn, ModuleName, GlobalInfo, GCC_FieldDefn),
+ % Insert the field definition into our field symbol table.
+ { Defn = mlds__defn(Name, _, _, _) },
+ ( { Name = data(var(FieldName)) } ->
+ { FieldTable1 = map__det_insert(FieldTable0,
+ qual(ModuleName, FieldName), GCC_FieldDefn) }
+ ;
+ { unexpected(this_file, "non-var field") }
+ ),
+ build_field_defns(Defns, ModuleName, GlobalInfo, FieldList0,
+ FieldTable1, FieldTable),
+ gcc__cons_field_list(GCC_FieldDefn, FieldList0, FieldList).
+
+:- pred gen_defn(mlds_module_name, mlds__defn, global_info, global_info,
+ io__state, io__state).
+:- mode gen_defn(in, in, in, out, di, uo) is det.
+
+gen_defn(ModuleName, Defn, GlobalInfo0, GlobalInfo) -->
+ { Defn = mlds__defn(Name, Context, _Flags, DefnBody) },
+ % mlds_output_decl_flags(Flags, definition, Name, DefnBody),
+ gen_defn_body(qual(ModuleName, Name), Context,
+ DefnBody, GlobalInfo0, GlobalInfo).
+
+:- pred build_local_defn(mlds__defn, func_info, mlds_module_name, gcc__var_decl,
+ io__state, io__state).
+:- mode build_local_defn(in, in, in, out, di, uo) is det.
+
+build_local_defn(Defn, FuncInfo, ModuleName, GCC_Defn) -->
+ { Defn = mlds__defn(Name, Context, _Flags, DefnBody) },
+ % mlds_output_decl_flags(Flags, definition, Name, DefnBody),
+ build_local_defn_body(qual(ModuleName, Name), FuncInfo, Context, DefnBody,
+ GCC_Defn).
+
+:- pred build_field_defn(mlds__defn, mlds_module_name, global_info,
+ gcc__field_decl, io__state, io__state).
+:- mode build_field_defn(in, in, in, out, di, uo) is det.
+
+build_field_defn(Defn, ModuleName, GlobalInfo, GCC_Defn) -->
+ { Defn = mlds__defn(Name, Context, _Flags, DefnBody) },
+ % mlds_output_decl_flags(Flags, definition, Name, DefnBody),
+ build_field_defn_body(qual(ModuleName, Name), Context, DefnBody,
+ GlobalInfo, GCC_Defn).
+
+:- pred gen_defn_body(mlds__qualified_entity_name,
+ mlds__context, mlds__entity_defn,
+ global_info, global_info, io__state, io__state).
+:- mode gen_defn_body(in, in, in, in, out, di, uo) is det.
+
+gen_defn_body(Name, Context, DefnBody, GlobalInfo0, GlobalInfo) -->
+ (
+ { DefnBody = mlds__data(Type, Initializer) },
+ % build_initializer expects a func_info,
+ % so we construct one here. The name func_info is a
+ % bit misleading since here it is holding information
+ % about the global variable declaration.
+ { LocalVars = map__init },
+ { LabelTable = map__init },
+ { FuncInfo = func_info(GlobalInfo0, Name, LocalVars,
+ LabelTable) },
+ { GCC_Name = build_qualified_name(Name) },
+ build_type(Type, GlobalInfo0, GCC_Type),
+ build_initializer(Initializer, GCC_Type, FuncInfo, GCC_Initializer),
+ gcc__build_global_var_decl(GCC_Name, GCC_Type, GCC_Initializer,
+ GCC_Defn),
+ %
+ % insert the definition in our symbol table
+ %
+ { GlobalVars0 = GlobalInfo0 ^ global_vars },
+ { GlobalVars = map__det_insert(GlobalVars0, Name, GCC_Defn) },
+ { GlobalInfo = GlobalInfo0 ^ global_vars := GlobalVars }
+ ;
+ { DefnBody = mlds__function(_MaybePredProcId, Signature,
+ MaybeBody) },
+ gen_func(Name, Context, Signature, MaybeBody,
+ GlobalInfo0, GlobalInfo)
+ ;
+ { DefnBody = mlds__class(ClassDefn) },
+ gen_class(Name, Context, ClassDefn,
+ GlobalInfo0, GlobalInfo)
+ ).
+
+:- pred build_local_defn_body(mlds__qualified_entity_name, func_info,
+ mlds__context, mlds__entity_defn, gcc__var_decl,
+ io__state, io__state).
+:- mode build_local_defn_body(in, in, in, in, out, di, uo) is det.
+
+build_local_defn_body(Name, FuncInfo, _Context, DefnBody, GCC_Defn) -->
+ (
+ { DefnBody = mlds__data(Type, Initializer) },
+ build_local_data_defn(Name, Type, Initializer, FuncInfo, GCC_Defn)
+ ;
+ { DefnBody = mlds__function(_, _, _) },
+ % nested functions should get eliminated by ml_elim_nested,
+ % unless --gcc-nested-functions is enabled.
+ % XXX --gcc-nested-functions is not yet implemented
+ { sorry(this_file, "nested function (`--gcc-nested-functions' "
+ ++ "not yet supported with `--target asm')") }
+ ;
+ { DefnBody = mlds__class(_) },
+ % currently the MLDS code generator doesn't generate
+ % types nested inside functions, so we don't need to
+ % implement this
+ { unexpected(this_file, "nested type") }
+ ).
+
+:- pred build_field_defn_body(mlds__qualified_entity_name,
+ mlds__context, mlds__entity_defn,
+ global_info, gcc__field_decl,
+ io__state, io__state).
+:- mode build_field_defn_body(in, in, in, in, out, di, uo) is det.
+
+build_field_defn_body(Name, _Context, DefnBody, GlobalInfo, GCC_Defn) -->
+ (
+ { DefnBody = mlds__data(Type, Initializer) },
+ build_field_data_defn(Name, Type, Initializer, GlobalInfo,
+ GCC_Defn)
+ ;
+ { DefnBody = mlds__function(_, _, _) },
+ { unexpected(this_file, "function nested in type") }
+ ;
+ { DefnBody = mlds__class(_) },
+ { unexpected(this_file, "type nested in type") }
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output data declarations/definitions
+%
+
+ % Handle an MLDS data definition that is nested inside a
+ % function definition (or inside a block within a function),
+ % and which is hence local to that function.
+:- pred build_local_data_defn(mlds__qualified_entity_name, mlds__type,
+ mlds__initializer, func_info, gcc__var_decl,
+ io__state, io__state).
+:- mode build_local_data_defn(in, in, in, in, out, di, uo) is det.
+
+build_local_data_defn(Name, Type, Initializer, FuncInfo, GCC_Defn) -->
+ build_type(Type, initializer_array_size(Initializer),
+ FuncInfo ^ global_info, GCC_Type),
+ { Name = qual(_ModuleName, UnqualName) },
+ ( { UnqualName = data(var(VarName)) } ->
+ gcc__build_local_var_decl(VarName, GCC_Type, GCC_Defn)
+ ;
+ % var/1 should be the only kind of mlds__data_name for which
+ % the MLDS code generator generates local definitions
+ % (within functions)
+ { unexpected(this_file, "build_local_data_defn: non-var") }
+ ),
+ ( { Initializer = no_initializer } ->
+ []
+ ;
+ build_initializer(Initializer, GCC_Type, FuncInfo, GCC_Expr),
+ gcc__gen_assign(gcc__var_expr(GCC_Defn), GCC_Expr)
+ ).
+
+ % Handle an MLDS data definition that is nested inside a type,
+ % i.e. a field definition.
+:- pred build_field_data_defn(mlds__qualified_entity_name, mlds__type,
+ mlds__initializer, global_info, gcc__field_decl,
+ io__state, io__state).
+:- mode build_field_data_defn(in, in, in, in, out, di, uo) is det.
+
+build_field_data_defn(Name, Type, Initializer, GlobalInfo, GCC_Defn) -->
+ build_type(Type, initializer_array_size(Initializer),
+ GlobalInfo, GCC_Type),
+ { Name = qual(_ModuleName, UnqualName) },
+ ( { UnqualName = data(var(VarName)) } ->
+ gcc__build_field_decl(VarName, GCC_Type, GCC_Defn)
+ ;
+ { sorry(this_file, "build_field_data_defn: non-var") }
+ ),
+ ( { Initializer = no_initializer } ->
+ []
+ ;
+ % fields can't have initializers
+ { sorry(this_file, "build_field_data_defn: initializer") }
+ ).
+
+:- pred build_initializer(mlds__initializer, gcc__type, func_info,
+ gcc__expr, io__state, io__state) is det.
+:- mode build_initializer(in, in, in, out, di, uo) is det.
+
+build_initializer(Initializer, GCC_Type, FuncInfo, GCC_Expr) -->
+ (
+ { Initializer = no_initializer },
+ { unexpected(this_file, "no_initializer (build_initializer)") }
+ ;
+ { Initializer = init_obj(Rval) },
+ build_rval(Rval, FuncInfo, GCC_Expr)
+ ;
+ { Initializer = init_struct(InitList) },
+ gcc__get_struct_field_decls(GCC_Type, GCC_FieldDecls),
+ build_struct_initializer(InitList, GCC_FieldDecls, FuncInfo,
+ GCC_InitList),
+ gcc__build_initializer_expr(GCC_InitList, GCC_Type, GCC_Expr)
+ ;
+ { Initializer = init_array(InitList) },
+ gcc__get_array_elem_type(GCC_Type, GCC_ElemType),
+ build_array_initializer(InitList, GCC_ElemType, 0, FuncInfo,
+ GCC_InitList),
+ gcc__build_initializer_expr(GCC_InitList, GCC_Type, GCC_Expr)
+ ).
+
+:- pred build_array_initializer(list(mlds__initializer), gcc__type, int,
+ func_info, gcc__init_list, io__state, io__state) is det.
+:- mode build_array_initializer(in, in, in, in, out, di, uo) is det.
+
+build_array_initializer([], _, _, _, GCC_InitList) -->
+ gcc__empty_init_list(GCC_InitList).
+build_array_initializer([Init | Inits], GCC_ElemType, Index, FuncInfo,
+ GCC_InitList) -->
+ gcc__array_elem_initializer(Index, GCC_InitIndex),
+ build_initializer(Init, GCC_ElemType, FuncInfo, GCC_InitValue),
+ build_array_initializer(Inits, GCC_ElemType, Index + 1, FuncInfo,
+ GCC_InitList0),
+ gcc__cons_init_list(GCC_InitIndex, GCC_InitValue,
+ GCC_InitList0, GCC_InitList).
+
+:- pred build_struct_initializer(list(mlds__initializer), gcc__field_decls,
+ func_info, gcc__init_list, io__state, io__state) is det.
+:- mode build_struct_initializer(in, in, in, out, di, uo) is det.
+
+build_struct_initializer([], _, _, GCC_InitList) -->
+ gcc__empty_init_list(GCC_InitList).
+build_struct_initializer([Init | Inits], GCC_FieldDecls, FuncInfo,
+ GCC_InitList) -->
+ gcc__next_field_decl(GCC_FieldDecls, GCC_ThisFieldDecl,
+ GCC_RemainingFieldDecls),
+ gcc__struct_field_initializer(GCC_ThisFieldDecl, GCC_InitField),
+ gcc__field_type(GCC_ThisFieldDecl, GCC_ThisFieldType),
+ build_initializer(Init, GCC_ThisFieldType, FuncInfo, GCC_InitValue),
+ build_struct_initializer(Inits, GCC_RemainingFieldDecls, FuncInfo,
+ GCC_InitList0),
+ gcc__cons_init_list(GCC_InitField, GCC_InitValue, GCC_InitList0,
+ GCC_InitList).
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output type definitions
+%
+
+:- pred gen_class(mlds__qualified_entity_name, mlds__context,
+ mlds__class_defn, global_info, global_info,
+ io__state, io__state).
+:- mode gen_class(in, in, in, in, out, di, uo) is det.
+
+gen_class(Name, Context, ClassDefn, GlobalInfo0, GlobalInfo) -->
+ %
+ % To avoid name clashes, we need to qualify the names of
+ % the member constants with the class name.
+ % (In particular, this is needed for enumeration constants
+ % and for the nested classes that we generate for constructors
+ % of discriminated union types.)
+ % Here we compute the appropriate qualifier.
+ %
+ { Name = qual(ModuleName, UnqualName) },
+ { UnqualName = type(ClassName, ClassArity) ->
+ ClassModuleName = mlds__append_class_qualifier(ModuleName,
+ ClassName, ClassArity)
+ ;
+ error("mlds_output_enum_constants")
+ },
+
+ %
+ % Hoist out static members, since plain old C doesn't support
+ % static members in structs (except for enumeration constants).
+ %
+ % XXX this should be conditional: only when compiling to C,
+ % not when compiling to C++
+ %
+ { ClassDefn = class_defn(Kind, _Imports, BaseClasses, _Implements,
+ AllMembers) },
+ ( { Kind = mlds__enum } ->
+ { StaticMembers = [] },
+ { StructMembers = AllMembers }
+ ;
+ { list__filter(is_static_member, AllMembers, StaticMembers,
+ NonStaticMembers) },
+ { StructMembers = NonStaticMembers }
+ ),
+
+ %
+ % Convert the base classes into member variables,
+ % since plain old C doesn't support base classes.
+ %
+ % This is copied from the MLDS->C back-end.
+ % We could probably handle it more directly for the
+ % MLDS->GCC back-end, but doing it this way is simple
+ % enough, and works.
+ %
+ { list__map_foldl(mlds_make_base_class(Context),
+ BaseClasses, BaseDefns, 1, _) },
+ { list__append(BaseDefns, StructMembers, BasesAndMembers) },
+
+ %
+ % Output the class declaration and the class members.
+ % We treat enumerations specially.
+ %
+ ( { Kind = mlds__enum } ->
+ % XXX enumeration definitions are not yet implemented
+ { sorry(this_file, "enum type (`--high-level-data' not yet "
+ ++ "implemented for `--target asm')") }
+ /************
+ mlds_output_class_decl(Indent, Name, ClassDefn),
+ io__write_string(" {\n"),
+ mlds_output_enum_constants(Indent + 1, ClassModuleName,
+ BasesAndMembers)
+ *************/
+ ;
+ %
+ % Build a gcc declaration node for the struct and
+ % for the fields it contains. Create a field table
+ % mapping the field names to their respective nodes.
+ %
+ { map__init(FieldTable0) },
+ build_field_defns(BasesAndMembers, ClassModuleName,
+ GlobalInfo0, FieldDecls, FieldTable0, FieldTable),
+ { AsmStructName = build_qualified_name(Name) },
+ gcc__build_struct_type_decl(AsmStructName,
+ FieldDecls, StructTypeDecl),
+ %
+ % Insert the gcc declaration node and the field table
+ % for this type into the global type table
+ %
+ { TypeTable0 = GlobalInfo0 ^ type_table },
+ { map__det_insert(TypeTable0, Name,
+ gcc_type_info(StructTypeDecl, FieldTable),
+ TypeTable) },
+ { GlobalInfo1 = GlobalInfo0 ^ type_table := TypeTable }
+ ),
+ %
+ % Output the static members.
+ %
+ gen_defns(ClassModuleName, StaticMembers, GlobalInfo1, GlobalInfo).
+
+:- pred is_static_member(mlds__defn::in) is semidet.
+
+is_static_member(Defn) :-
+ Defn = mlds__defn(Name, _, Flags, _),
+ ( Name = type(_, _)
+ ; per_instance(Flags) = one_copy
+ ).
+
+ % Convert a base class class_id into a member variable
+ % that holds the value of the base class.
+ %
+:- pred mlds_make_base_class(mlds__context, mlds__class_id, mlds__defn,
+ int, int).
+:- mode mlds_make_base_class(in, in, out, in, out) is det.
+
+mlds_make_base_class(Context, ClassId, MLDS_Defn, BaseNum0, BaseNum) :-
+ BaseName = string__format("base_%d", [i(BaseNum0)]),
+ Type = ClassId,
+ MLDS_Defn = ml_gen_mlds_var_decl(var(BaseName), Type, Context),
+ BaseNum = BaseNum0 + 1.
+
+/***********
+XXX enumeration definitions are not yet implemented for mlds_to_gcc.m.
+The following code for handling enumeration definitions is copied from
+mlds_to_c.m. It shows what we should generate.
+
+:- pred mlds_output_class_decl(indent, mlds__qualified_entity_name,
+ mlds__class_defn, io__state, io__state).
+:- mode mlds_output_class_decl(in, in, in, di, uo) is det.
+
+mlds_output_class_decl(_Indent, Name, ClassDefn) -->
+ ( { ClassDefn^kind = mlds__enum } ->
+ io__write_string("enum "),
+ mlds_output_fully_qualified_name(Name),
+ io__write_string("_e")
+ ;
+ io__write_string("struct "),
+ mlds_output_fully_qualified_name(Name),
+ io__write_string("_s")
+ ).
+
+ % Output the definitions of the enumeration constants
+ % for an enumeration type.
+ %
+:- pred mlds_output_enum_constants(indent, mlds_module_name,
+ mlds__defns, io__state, io__state).
+:- mode mlds_output_enum_constants(in, in, in, di, uo) is det.
+
+mlds_output_enum_constants(Indent, EnumModuleName, Members) -->
+ %
+ % Select the enumeration constants from the list of members
+ % for this enumeration type, and output them.
+ %
+ { EnumConsts = list__filter(is_enum_const, Members) },
+ io__write_list(EnumConsts, ",\n",
+ mlds_output_enum_constant(Indent, EnumModuleName)),
+ io__nl.
+
+ % Test whether one of the members of an mlds__enum class
+ % is an enumeration constant.
+ %
+:- pred is_enum_const(mlds__defn).
+:- mode is_enum_const(in) is semidet.
+
+is_enum_const(Defn) :-
+ Defn = mlds__defn(_Name, _Context, Flags, _DefnBody),
+ constness(Flags) = const.
+
+ % Output the definition of a single enumeration constant.
+ %
+:- pred mlds_output_enum_constant(indent, mlds_module_name, mlds__defn,
+ io__state, io__state).
+:- mode mlds_output_enum_constant(in, in, in, di, uo) is det.
+
+mlds_output_enum_constant(Indent, EnumModuleName, Defn) -->
+ { Defn = mlds__defn(Name, Context, _Flags, DefnBody) },
+ (
+ { DefnBody = data(Type, Initializer) }
+ ->
+ mlds_indent(Context, Indent),
+ mlds_output_fully_qualified_name(qual(EnumModuleName, Name)),
+ mlds_output_initializer(Type, Initializer)
+ ;
+ { error("mlds_output_enum_constant: constant is not data") }
+ ).
+
+***********/
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output function declarations/definitions
+%
+
+:- pred gen_func(qualified_entity_name, mlds__context,
+ func_params, maybe(statement),
+ global_info, global_info, io__state, io__state).
+:- mode gen_func(in, in, in, in, in, out, di, uo) is det.
+
+gen_func(Name, Context, Signature, MaybeBody, GlobalInfo0, GlobalInfo) -->
+ { GlobalInfo = GlobalInfo0 },
+ (
+ { MaybeBody = no }
+ ;
+ { MaybeBody = yes(Body) },
+ make_func_decl_for_defn(Name, Signature, GlobalInfo0,
+ FuncDecl, SymbolTable),
+ build_label_table(Body, LabelTable),
+ { FuncInfo = func_info(GlobalInfo,
+ Name, SymbolTable, LabelTable) },
+ set_context(Context),
+ gcc__start_function(FuncDecl),
+ % mlds_maybe_output_time_profile_instr(Context, Name)
+ gen_statement(FuncInfo, Body),
+ set_context(Context),
+ gcc__end_function
+ ).
+
+ %
+ % Before generating code for a function,
+ % we build a table of all the label declarations
+ % in that function body.
+ %
+:- pred build_label_table(mlds__statement::in, label_table::out,
+ io__state::di, io__state::uo) is det.
+build_label_table(Statement, LabelTable) -->
+ { solutions(statement_contains_label(Statement), Labels) },
+ list__map_foldl(gcc__build_label, Labels, GCC_LabelDecls),
+ { map__from_corresponding_lists(Labels, GCC_LabelDecls,
+ LabelTable) }.
+
+:- pred statement_contains_label(mlds__statement::in, mlds__label::out)
+ is nondet.
+statement_contains_label(Statement, Label) :-
+ statement_contains_statement(Statement, SubStatement),
+ SubStatement = mlds__statement(label(Label), _).
+
+ % XXX we should lookup the existing definition, if there is one,
+ % rather than always making a new one
+:- pred make_func_decl(mlds__qualified_entity_name::in,
+ mlds__func_signature::in, global_info::in,
+ gcc__func_decl::out, io__state::di, io__state::uo) is det.
+make_func_decl(Name, Signature, GlobalInfo, GCC_FuncDecl) -->
+ { Signature = func_signature(Arguments, ReturnTypes) },
+ get_return_type(ReturnTypes, GlobalInfo, RetType),
+ { get_qualified_func_name(Name, _ModuleName, FuncName, AsmFuncName) },
+ build_param_types(Arguments, GlobalInfo, GCC_Types, GCC_ParamTypes),
+ build_dummy_param_decls(GCC_Types, GCC_ParamDecls),
+ gcc__build_function_decl(FuncName, AsmFuncName,
+ RetType, GCC_ParamTypes, GCC_ParamDecls, GCC_FuncDecl).
+
+:- pred build_dummy_param_decls(list(gcc__type), gcc__param_decls,
+ io__state, io__state).
+:- mode build_dummy_param_decls(in, out, di, uo) is det.
+
+build_dummy_param_decls([], gcc__empty_param_decls) --> [].
+build_dummy_param_decls([Type | Types],
+ gcc__cons_param_decls(ParamDecl, ParamDecls)) -->
+ gcc__build_param_decl("<unnamed param>", Type, ParamDecl),
+ build_dummy_param_decls(Types, ParamDecls).
+
+ % Like make_func_decl, except that it fills in the
+ % function parameters properly
+:- pred make_func_decl_for_defn(mlds__qualified_entity_name::in,
+ mlds__func_params::in, global_info::in, gcc__func_decl::out,
+ symbol_table::out, io__state::di, io__state::uo) is det.
+make_func_decl_for_defn(Name, Parameters, GlobalInfo, FuncDecl, SymbolTable) -->
+ { Parameters = func_params(Arguments, ReturnTypes) },
+ get_return_type(ReturnTypes, GlobalInfo, RetType),
+ { get_qualified_func_name(Name, ModuleName, FuncName, AsmFuncName) },
+ build_param_types_and_decls(Arguments, ModuleName, GlobalInfo,
+ ParamTypes, ParamDecls, SymbolTable),
+ gcc__build_function_decl(FuncName, AsmFuncName,
+ RetType, ParamTypes, ParamDecls, FuncDecl).
+
+:- pred get_return_type(list(mlds__type)::in, global_info::in, gcc__type::out,
+ io__state::di, io__state::uo) is det.
+get_return_type(List, GlobalInfo, GCC_Type) -->
+ ( { List = [] } ->
+ { GCC_Type = gcc__void_type_node }
+ ; { List = [Type] } ->
+ build_type(Type, GlobalInfo, GCC_Type)
+ ;
+ { error(this_file ++ ": multiple return types") }
+ ).
+
+ % get_func_name(Name, ModuleName, FuncName, AsmFuncName):
+ % Get the module name and the function name.
+ % `FuncName' is the name used for generating debug symbols,
+ % whereas `AsmFuncName' is what we actually spit out in the
+ % assembler file.
+:- pred get_qualified_func_name(mlds__qualified_entity_name::in,
+ mlds_module_name::out, string::out, string::out) is det.
+get_qualified_func_name(Name, ModuleName, FuncName, AsmFuncName) :-
+ Name = qual(ModuleName, EntityName),
+ get_func_name(EntityName, FuncName, AsmFuncName0),
+ maybe_add_module_qualifier(Name, AsmFuncName0, AsmFuncName).
+
+ % get_func_name(Name, FuncName, AsmFuncName):
+ % Get the function name (without any module qualifier).
+ % `FuncName' is the name used for generating debug symbols,
+ % whereas `AsmFuncName' is what we actually spit out in the
+ % assembler file.
+:- pred get_func_name(mlds__entity_name::in,
+ string::out, string::out) is det.
+get_func_name(FunctionName, FuncName, AsmFuncName) :-
+ ( FunctionName = function(PredLabel, ProcId, MaybeSeqNum, _PredId) ->
+ %
+ % Generate the AsmFuncName
+ % This needs to be fully name mangled to ensure that it
+ % is unique.
+ %
+ % XXX we should consider not appending the modenum and seqnum
+ % if they are not needed.
+ %
+ get_pred_label_name(PredLabel, AsmFuncName0),
+ proc_id_to_int(ProcId, ProcIdNum),
+ ( MaybeSeqNum = yes(SeqNum) ->
+ AsmFuncName = string__format("%s_%d_%d",
+ [s(AsmFuncName0), i(ProcIdNum), i(SeqNum)])
+ ;
+ AsmFuncName = string__format("%s_%d",
+ [s(AsmFuncName0), i(ProcIdNum)])
+ ),
+ %
+ % Generate the FuncName.
+ % This is for human consumption, and does not
+ % necessarily need to be unique.
+ %
+ (
+ PredLabel = pred(_PorF, _ModuleName, PredName, _Arity),
+ FuncName = PredName
+ ;
+ PredLabel = special_pred(SpecialPredName, _ModuleName,
+ TypeName, _Arity),
+ FuncName = SpecialPredName ++ TypeName
+ )
+ ;
+ error("get_func_name: non-function")
+ ).
+
+ % XXX same as mlds_output_pred_label in mlds_to_c,
+ % except that it returns a string.
+:- pred get_pred_label_name(mlds__pred_label, string).
+:- mode get_pred_label_name(in, out) is det.
+
+get_pred_label_name(pred(PredOrFunc, MaybeDefiningModule, Name, Arity),
+ LabelName) :-
+ ( PredOrFunc = predicate, Suffix = "p"
+ ; PredOrFunc = function, Suffix = "f"
+ ),
+ llds_out__name_mangle(Name, MangledName),
+ string__format("%s_%d_%s", [s(MangledName), i(Arity), s(Suffix)],
+ LabelName0),
+ ( MaybeDefiningModule = yes(DefiningModule) ->
+ LabelName = LabelName0 ++ "_in__" ++
+ get_module_name(DefiningModule)
+ ;
+ LabelName = LabelName0
+ ).
+get_pred_label_name(special_pred(PredName, MaybeTypeModule,
+ TypeName, TypeArity), LabelName) :-
+ llds_out__name_mangle(PredName, MangledPredName),
+ llds_out__name_mangle(TypeName, MangledTypeName),
+ TypeNameString = string__format("%s_%d",
+ [s(MangledTypeName), i(TypeArity)]),
+ ( MaybeTypeModule = yes(TypeModule) ->
+ TypeNameList = [get_module_name(TypeModule),
+ "__", TypeNameString]
+ ;
+ TypeNameList = [TypeNameString]
+ ),
+ LabelName = string__append_list([MangledPredName, "__" | TypeNameList]).
+
+:- func get_module_name(module_name) = string.
+get_module_name(ModuleName) = MangledModuleName :-
+ llds_out__sym_name_mangle(ModuleName, MangledModuleName).
+
+:- pred build_param_types(mlds__arg_types::in, global_info::in,
+ list(gcc__type)::out, gcc__param_types::out,
+ io__state::di, io__state::uo) is det.
+
+build_param_types([], _, [], gcc__empty_param_types) --> [].
+build_param_types([ArgType | ArgTypes], GlobalInfo, [GCC_Type | GCC_Types],
+ ParamTypes) -->
+ build_param_types(ArgTypes, GlobalInfo, GCC_Types, ParamTypes0),
+ build_type(ArgType, GlobalInfo, GCC_Type),
+ { ParamTypes = gcc__cons_param_types(GCC_Type, ParamTypes0) }.
+
+:- pred build_param_types_and_decls(mlds__arguments::in, mlds_module_name::in,
+ global_info::in, gcc__param_types::out, gcc__param_decls::out,
+ symbol_table::out, io__state::di, io__state::uo) is det.
+
+build_param_types_and_decls([], _, _, gcc__empty_param_types,
+ gcc__empty_param_decls, SymbolTable) -->
+ { map__init(SymbolTable) }.
+build_param_types_and_decls([Arg|Args], ModuleName, GlobalInfo,
+ ParamTypes, ParamDecls, SymbolTable) -->
+ build_param_types_and_decls(Args, ModuleName, GlobalInfo,
+ ParamTypes0, ParamDecls0, SymbolTable0),
+ { Arg = ArgName - Type },
+ build_type(Type, GlobalInfo, GCC_Type),
+ ( { ArgName = data(var(ArgVarName)) } ->
+ gcc__build_param_decl(ArgVarName, GCC_Type, ParamDecl),
+ { SymbolTable = map__det_insert(SymbolTable0,
+ qual(ModuleName, ArgName), ParamDecl) }
+ ;
+ { error("build_param_types_and_decls: invalid param name") }
+ ),
+ { ParamTypes = gcc__cons_param_types(GCC_Type, ParamTypes0) },
+ { ParamDecls = gcc__cons_param_decls(ParamDecl, ParamDecls0) }.
+
+%-----------------------------------------------------------------------------%
+%
+% Code to build types
+%
+
+:- pred build_type(mlds__type, global_info, gcc__type, io__state, io__state).
+:- mode build_type(in, in, out, di, uo) is det.
+
+build_type(Type, GlobalInfo, GCC_Type) -->
+ build_type(Type, no_size, GlobalInfo, GCC_Type).
+
+:- pred build_type(mlds__type, initializer_array_size, global_info,
+ gcc__type, io__state, io__state).
+:- mode build_type(in, in, in, out, di, uo) is det.
+
+build_type(mercury_type(Type, TypeCategory), _, _, GCC_Type) -->
+ build_mercury_type(Type, TypeCategory, GCC_Type).
+build_type(mlds__native_int_type, _, _, gcc__integer_type_node) --> [].
+build_type(mlds__native_float_type, _, _, gcc__double_type_node) --> [].
+build_type(mlds__native_bool_type, _, _, gcc__boolean_type_node) --> [].
+build_type(mlds__native_char_type, _, _, gcc__char_type_node) --> [].
+build_type(mlds__class_type(Name, Arity, ClassKind), _, GlobalInfo,
+ GCC_Type) -->
+ ( { ClassKind = mlds__enum } ->
+ %
+ % XXX following comment is copied from mlds_to_c;
+ % it is wrong for mlds_to_gcc back-end
+ %
+ % We can't just use the enumeration type,
+ % since the enumeration type's definition
+ % is not guaranteed to be in scope at this point.
+ % (Fixing that would be somewhat complicated; it would
+ % require writing enum definitions to a separate header file.)
+ % Also the enumeration might not be word-sized,
+ % which would cause problems for e.g. `std_util:arg/2'.
+ % So we just use `MR_Integer'.
+ %
+ { GCC_Type = 'MR_Integer' }
+ ;
+ %
+ % Check to see whether we already have a definition for
+ % this type.
+ %
+ { Name = qual(ModuleName, TypeName) },
+ { EntityName = qual(ModuleName, type(TypeName, Arity)) },
+ (
+ { map__search(GlobalInfo ^ type_table, EntityName,
+ gcc_type_info(GCC_TypeDecl, _)) }
+ ->
+ { GCC_Type = gcc__declared_type(GCC_TypeDecl) }
+ ;
+ %
+ % The type was not already defined.
+ % This case only arises with `--high-level-data'.
+ % For struct types which are not defined in this
+ % module, it's OK to use an incomplete type,
+ % since don't use such types directly, we only
+ % use pointers to them.
+ %
+ % XXX currently we use `void' as the canonical
+ % incomplete type. Probably it would be better
+ % to generate an incomplete struct type decl
+ % for each struct type.
+ %
+ { GCC_Type = gcc__void_type_node },
+ %
+ % XXX The I/O code below is just for debugging,
+ % and should eventually be removed
+ %
+ io__write_string("note: undeclared class_type "),
+ io__print(EntityName),
+ io__write_string(", i.e. "),
+ { AsmName = build_qualified_name(EntityName) },
+ io__write_string(AsmName),
+ io__nl
+ )
+ ).
+build_type(mlds__ptr_type(Type), _, GlobalInfo, GCC_PtrType) -->
+ build_type(Type, GlobalInfo, GCC_Type),
+ gcc__build_pointer_type(GCC_Type, GCC_PtrType).
+build_type(mlds__array_type(Type), ArraySize, GlobalInfo, GCC_ArrayType) -->
+ build_type(Type, GlobalInfo, GCC_Type),
+ build_sized_array_type(GCC_Type, ArraySize, GCC_ArrayType).
+build_type(mlds__func_type(Params), _, GlobalInfo, GCC_FuncPtrType) -->
+ { Signature = mlds__get_func_signature(Params) },
+ { Signature = mlds__func_signature(ArgTypes, RetTypes) },
+ ( { RetTypes = [RetType] } ->
+ build_type(RetType, no_size, GlobalInfo, GCC_RetType)
+ ;
+ { sorry(this_file, "multiple return types") }
+ ),
+ build_param_types(ArgTypes, GlobalInfo, _, GCC_ParamTypes),
+ gcc__build_function_type(GCC_RetType, GCC_ParamTypes, GCC_FuncType),
+ gcc__build_pointer_type(GCC_FuncType, GCC_FuncPtrType).
+build_type(mlds__generic_type, _, _, 'MR_Box') --> [].
+build_type(mlds__generic_env_ptr_type, _, _, gcc__ptr_type_node) --> [].
+build_type(mlds__pseudo_type_info_type, _, _, 'MR_PseudoTypeInfo') --> [].
+build_type(mlds__cont_type(ArgTypes), _, _, GCC_Type) -->
+ ( { ArgTypes = [] } ->
+ globals__io_lookup_bool_option(gcc_nested_functions,
+ GCC_NestedFuncs),
+ ( { GCC_NestedFuncs = yes } ->
+ % typedef void (*MR_NestedCont)(void)
+ gcc__build_function_type(gcc__void_type_node,
+ gcc__empty_param_types, FuncType),
+ gcc__build_pointer_type(FuncType, MR_NestedCont),
+ { GCC_Type = MR_NestedCont }
+ ;
+ % typedef void (*MR_Cont)(void *)
+ gcc__build_function_type(gcc__void_type_node,
+ gcc__cons_param_types(gcc__ptr_type_node,
+ gcc__empty_param_types),
+ FuncType),
+ gcc__build_pointer_type(FuncType, MR_Cont),
+ { GCC_Type = MR_Cont }
+ )
+ ;
+ % This case only happens for --nondet-copy-out
+ % (See mlds_to_c.m for what we ought to do.)
+ { sorry(this_file,
+ "cont_type (`--nondet-copy-out' & `--target asm')") }
+ ).
+build_type(mlds__commit_type, _, _, gcc__jmpbuf_type_node) --> [].
+build_type(mlds__rtti_type(RttiName), InitializerSize, _GlobalInfo, GCC_Type) -->
+ build_rtti_type(RttiName, InitializerSize, GCC_Type).
+
+:- pred build_mercury_type(mercury_type, builtin_type, gcc__type,
+ io__state, io__state).
+:- mode build_mercury_type(in, in, out, di, uo) is det.
+
+build_mercury_type(_Type, TypeCategory, GCC_Type) -->
+ (
+ { TypeCategory = char_type },
+ { GCC_Type = 'MR_Char' }
+ ;
+ { TypeCategory = int_type },
+ { GCC_Type = 'MR_Integer' }
+ ;
+ { TypeCategory = str_type },
+ { GCC_Type = 'MR_String' }
+ ;
+ { TypeCategory = float_type },
+ { GCC_Type = 'MR_Float' }
+ ;
+ { TypeCategory = polymorphic_type },
+ { GCC_Type = 'MR_Box' }
+ ;
+ { TypeCategory = tuple_type },
+ % tuples are always (pointers to)
+ % arrays of polymorphic terms
+ gcc__build_pointer_type('MR_Box', MR_Tuple),
+ { GCC_Type = MR_Tuple }
+ ;
+ { TypeCategory = pred_type },
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ { sorry(this_file, "--high-level-data (pred_type)") }
+ % { GCC_Type = 'MR_ClosurePtr' }
+ ;
+ { GCC_Type = 'MR_Word' }
+ )
+ ;
+ { TypeCategory = enum_type },
+ % Note that the MLDS -> C back-end uses 'MR_Word' here,
+ % unless --high-level-data is enabled. But 'MR_Integer'
+ % seems better, I think. It probably doesn't make any real
+ % difference either way.
+ % XXX for --high-level-data, we should use a real enum type
+ { GCC_Type = 'MR_Integer' }
+ ;
+ { TypeCategory = user_type },
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ { sorry(this_file, "--high-level-data (user_type)") }
+ ;
+ { GCC_Type = 'MR_Word' }
+ )
+ ).
+
+:- pred build_sized_array_type(gcc__type, initializer_array_size, gcc__type,
+ io__state, io__state).
+:- mode build_sized_array_type(in, in, out, di, uo) is det.
+
+build_sized_array_type(GCC_Type, ArraySize, GCC_ArrayType) -->
+ { ArraySize = no_size, Size = 0
+ ; ArraySize = array_size(Size)
+ },
+ gcc__build_array_type(GCC_Type, Size, GCC_ArrayType).
+
+%-----------------------------------------------------------------------------%
+
+:- type initializer_array_size
+ ---> array_size(int)
+ ; no_size. % either the size is unknown,
+ % or the data is not an array
+
+:- func initializer_array_size(mlds__initializer) = initializer_array_size.
+initializer_array_size(no_initializer) = no_size.
+initializer_array_size(init_obj(_)) = no_size.
+initializer_array_size(init_struct(_)) = no_size.
+initializer_array_size(init_array(Elems)) = array_size(list__length(Elems)).
+
+%-----------------------------------------------------------------------------%
+%
+% Code to build RTTI types
+%
+
+% The types constructed here should be the same as the types
+% defined in runtime/mercury_type_info.h for the C back-end.
+% See that file for documentation on these types.
+
+% XXX it would be more efficient to construct these types once,
+% at initialization time, rather than every time they are used.
+
+:- pred build_rtti_type(rtti_name, initializer_array_size, gcc__type,
+ io__state, io__state).
+:- mode build_rtti_type(in, in, out, di, uo) is det.
+
+build_rtti_type(exist_locns(_), Size, GCC_Type) -->
+ build_du_exist_locn_type(MR_DuExistLocn),
+ build_sized_array_type(MR_DuExistLocn, Size, GCC_Type).
+build_rtti_type(exist_info(_), _, MR_DuExistInfo) -->
+ build_du_exist_info_type(MR_DuExistInfo).
+build_rtti_type(field_names(_), Size, GCC_Type) -->
+ build_sized_array_type('MR_ConstString', Size, GCC_Type).
+build_rtti_type(field_types(_), Size, GCC_Type) -->
+ build_sized_array_type('MR_PseudoTypeInfo', Size, GCC_Type).
+build_rtti_type(enum_functor_desc(_), _, GCC_Type) -->
+ % typedef struct {
+ % MR_ConstString MR_enum_functor_name;
+ % MR_int_least32_t MR_enum_functor_ordinal;
+ % } MR_EnumFunctorDesc;
+ build_struct_type("MR_EnumFunctorDesc",
+ ['MR_ConstString' - "MR_enum_functor_name",
+ 'MR_int_least32_t' - "MR_enum_functor_ordinal"],
+ GCC_Type).
+build_rtti_type(notag_functor_desc, _, GCC_Type) -->
+ % typedef struct {
+ % MR_ConstString MR_notag_functor_name;
+ % MR_PseudoTypeInfo MR_notag_functor_arg_type;
+ % XXX need to add the following field when I do a cvs update:
+ % /***MR_ConstString MR_notag_functor_arg_name;***/
+ % } MR_NotagFunctorDesc;
+ build_struct_type("MR_NotagFunctorDesc",
+ ['MR_ConstString' - "MR_notag_functor_name",
+ 'MR_PseudoTypeInfo' - "MR_notag_functor_arg_type"],
+ %%% 'MR_ConstString' - "MR_notag_functor_arg_name"],
+ GCC_Type).
+build_rtti_type(du_functor_desc(_), _, GCC_Type) -->
+ % typedef struct {
+ % MR_ConstString MR_du_functor_name;
+ % MR_int_least16_t MR_du_functor_orig_arity;
+ % MR_int_least16_t MR_du_functor_arg_type_contains_var;
+ % MR_Sectag_Locn MR_du_functor_sectag_locn;
+ % MR_int_least8_t MR_du_functor_primary;
+ % MR_int_least32_t MR_du_functor_secondary;
+ % MR_int_least32_t MR_du_functor_ordinal;
+ % const MR_PseudoTypeInfo *MR_du_functor_arg_types;
+ % const MR_ConstString *MR_du_functor_arg_names;
+ % const MR_DuExistInfo *MR_du_functor_exist_info;
+ % } MR_DuFunctorDesc;
+ build_du_exist_info_type(MR_DuExistInfo),
+ gcc__build_pointer_type('MR_PseudoTypeInfo', MR_PseudoTypeInfoPtr),
+ gcc__build_pointer_type(MR_DuExistInfo, MR_DuExistInfoPtr),
+ gcc__build_pointer_type('MR_ConstString', MR_ConstStringPtr),
+ build_struct_type("MR_DuFunctorDesc",
+ ['MR_ConstString' - "MR_notag_functor_name",
+ 'MR_PseudoTypeInfo' - "MR_notag_functor_arg_type",
+ 'MR_ConstString' - "MR_du_functor_name",
+ 'MR_int_least16_t' - "MR_du_functor_orig_arity",
+ 'MR_int_least16_t' - "MR_du_functor_arg_type_contains_var",
+ 'MR_Sectag_Locn' - "MR_du_functor_sectag_locn",
+ 'MR_int_least8_t' - "MR_du_functor_primary",
+ 'MR_int_least32_t' - "MR_du_functor_secondary",
+ 'MR_int_least32_t' - "MR_du_functor_ordinal",
+ MR_PseudoTypeInfoPtr - "MR_du_functor_arg_types",
+ MR_ConstStringPtr - "MR_du_functor_arg_names",
+ MR_DuExistInfoPtr - "MR_du_functor_exist_info"],
+ GCC_Type).
+build_rtti_type(enum_name_ordered_table, Size, GCC_Type) -->
+ { MR_EnumFunctorDescPtr = gcc__ptr_type_node },
+ build_sized_array_type(MR_EnumFunctorDescPtr, Size, GCC_Type).
+build_rtti_type(enum_value_ordered_table, Size, GCC_Type) -->
+ { MR_EnumFunctorDescPtr = gcc__ptr_type_node },
+ build_sized_array_type(MR_EnumFunctorDescPtr, Size, GCC_Type).
+build_rtti_type(du_name_ordered_table, Size, GCC_Type) -->
+ { MR_DuFunctorDescPtr = gcc__ptr_type_node },
+ build_sized_array_type(MR_DuFunctorDescPtr, Size, GCC_Type).
+build_rtti_type(du_stag_ordered_table(_), Size, GCC_Type) -->
+ { MR_DuFunctorDescPtr = gcc__ptr_type_node },
+ build_sized_array_type(MR_DuFunctorDescPtr, Size, GCC_Type).
+build_rtti_type(du_ptag_ordered_table, Size, GCC_Type) -->
+ % typedef struct {
+ % MR_int_least32_t MR_sectag_sharers;
+ % MR_Sectag_Locn MR_sectag_locn;
+ % const MR_DuFunctorDesc * const * MR_sectag_alternatives;
+ % } MR_DuPtagLayout;
+ build_struct_type("MR_DuPtagLayout",
+ ['MR_int_least32_t' - "MR_sectag_sharers",
+ 'MR_Sectag_Locn' - "MR_sectag_locn",
+ gcc__ptr_type_node - "MR_sectag_alternatives"],
+ MR_DuPtagLayout),
+ build_sized_array_type(MR_DuPtagLayout, Size, GCC_Type).
+build_rtti_type(type_ctor_info, _, GCC_Type) -->
+ % struct MR_TypeCtorInfo_Struct {
+ % MR_Integer arity;
+ % MR_ProcAddr unify_pred;
+ % MR_ProcAddr new_unify_pred;
+ % MR_ProcAddr compare_pred;
+ % MR_TypeCtorRep type_ctor_rep;
+ % MR_ProcAddr solver_pred;
+ % MR_ProcAddr init_pred;
+ % MR_ConstString type_ctor_module_name;
+ % MR_ConstString type_ctor_name;
+ % MR_Integer type_ctor_version;
+ % MR_TypeFunctors type_functors;
+ % MR_TypeLayout type_layout;
+ % MR_int_least32_t type_ctor_num_functors;
+ % MR_int_least8_t type_ctor_num_ptags; /* if DU */
+ % /*
+ % ** The following fields will be added later, once we can exploit them:
+ % ** union MR_TableNode_Union **type_std_table;
+ % ** MR_ProcAddr prettyprinter;
+ % */
+ % };
+ { MR_ProcAddr = gcc__ptr_type_node },
+ build_struct_type("MR_TypeFunctors",
+ [gcc__ptr_type_node - "functors_init"],
+ MR_TypeFunctors),
+ build_struct_type("MR_TypeLayout",
+ [gcc__ptr_type_node - "layout_init"],
+ MR_TypeLayout),
+ build_struct_type("MR_TypeCtorInfo_Struct",
+ ['MR_Integer' - "arity",
+ MR_ProcAddr - "unify_pred",
+ MR_ProcAddr - "new_unify_pred",
+ MR_ProcAddr - "compare_pred",
+ 'MR_TypeCtorRep' - "type_ctor_rep",
+ MR_ProcAddr - "solver_pred",
+ MR_ProcAddr - "init_pred",
+ 'MR_ConstString' - "type_ctor_module_name",
+ 'MR_ConstString' - "type_ctor_name",
+ 'MR_Integer' - "type_ctor_version",
+ MR_TypeFunctors - "type_functors",
+ MR_TypeLayout - "type_layout",
+ 'MR_int_least32_t' - "type_ctor_num_functors",
+ 'MR_int_least8_t' - "type_ctor_num_ptags"],
+ GCC_Type).
+build_rtti_type(base_typeclass_info(_, _, _), Size, GCC_Type) -->
+ { MR_BaseTypeclassInfo = gcc__ptr_type_node },
+ build_sized_array_type(MR_BaseTypeclassInfo, Size, GCC_Type).
+build_rtti_type(pseudo_type_info(PseudoTypeInfo), _, GCC_Type) -->
+ build_pseudo_type_info_type(PseudoTypeInfo, GCC_Type).
+build_rtti_type(type_hashcons_pointer, _, MR_TableNodePtrPtr) -->
+ { MR_TableNodePtrPtr = gcc__ptr_type_node }.
+
+:- pred build_pseudo_type_info_type(pseudo_type_info::in,
+ gcc__type::out, io__state::di, io__state::uo) is det.
+
+build_pseudo_type_info_type(type_var(_), _) -->
+ % we use small integers to represent type_vars,
+ % rather than pointers, so there is no pointed-to type
+ { error("mlds_rtti_type: type_var") }.
+build_pseudo_type_info_type(type_ctor_info(_), GCC_Type) -->
+ build_rtti_type(type_ctor_info, no_size, GCC_Type).
+build_pseudo_type_info_type(type_info(_TypeId, ArgTypes), GCC_Type) -->
+ { Arity = list__length(ArgTypes) },
+ % typedef struct {
+ % MR_TypeCtorInfo MR_pti_type_ctor_info;
+ % MR_PseudoTypeInfo MR_pti_first_order_arg_pseudo_typeinfos[<ARITY>];
+ % } MR_FO_PseudoTypeInfo_Struct<ARITY>;
+ { MR_TypeCtorInfo = gcc__ptr_type_node },
+ gcc__build_array_type('MR_PseudoTypeInfo', Arity,
+ MR_PseudoTypeInfoArray),
+ { StructName = string__format("MR_FO_PseudoTypeInfo_Struct%d",
+ [i(Arity)]) },
+ build_struct_type(StructName,
+ [MR_TypeCtorInfo - "MR_pti_type_ctor_info",
+ MR_PseudoTypeInfoArray - "MR_pti_first_order_arg_pseudo_typeinfos"],
+ GCC_Type).
+build_pseudo_type_info_type(higher_order_type_info(_TypeId, _Arity,
+ ArgTypes), GCC_Type) -->
+ { Arity = list__length(ArgTypes) },
+ % struct NAME { \
+ % MR_TypeCtorInfo MR_pti_type_ctor_info; \
+ % MR_Integer MR_pti_higher_order_arity; \
+ % MR_PseudoTypeInfo MR_pti_higher_order_arg_pseudo_typeinfos[ARITY]; \
+ % }
+ { MR_TypeCtorInfo = gcc__ptr_type_node },
+ gcc__build_array_type('MR_PseudoTypeInfo', Arity,
+ MR_PseudoTypeInfoArray),
+ { StructName = string__format("MR_HO_PseudoTypeInfo_Struct%d",
+ [i(Arity)]) },
+ build_struct_type(StructName,
+ [MR_TypeCtorInfo - "MR_pti_type_ctor_info",
+ 'MR_Integer' - "MR_pti_higher_order_arity",
+ MR_PseudoTypeInfoArray - "MR_pti_higher_order_arg_pseudo_typeinfos"],
+ GCC_Type).
+
+:- pred build_du_exist_locn_type(gcc__type, io__state, io__state).
+:- mode build_du_exist_locn_type(out, di, uo) is det.
+
+build_du_exist_locn_type(MR_DuExistLocn) -->
+ % typedef struct {
+ % MR_int_least16_t MR_exist_arg_num;
+ % MR_int_least16_t MR_exist_offset_in_tci;
+ % } MR_DuExistLocn;
+ build_struct_type("MR_DuExistLocn",
+ ['MR_int_least16_t' - "MR_exist_arg_num",
+ 'MR_int_least16_t' - "MR_exist_offset_in_tci"],
+ MR_DuExistLocn).
+
+:- pred build_du_exist_info_type(gcc__type, io__state, io__state).
+:- mode build_du_exist_info_type(out, di, uo) is det.
+
+build_du_exist_info_type(MR_DuExistInfo) -->
+ % typedef struct {
+ % MR_int_least16_t MR_exist_typeinfos_plain;
+ % MR_int_least16_t MR_exist_typeinfos_in_tci;
+ % MR_int_least16_t MR_exist_tcis;
+ % const MR_DuExistLocn *MR_exist_typeinfo_locns;
+ % } MR_DuExistInfo;
+ build_du_exist_locn_type(MR_DuExistLocn),
+ gcc__build_pointer_type(MR_DuExistLocn, MR_DuExistLocnPtr),
+ build_struct_type("MR_DuExistInfo",
+ ['MR_int_least16_t' - "MR_exist_typeinfos_plain",
+ 'MR_int_least16_t' - "MR_exist_typeinfos_in_tci",
+ 'MR_int_least16_t' - "MR_exist_tcis",
+ MR_DuExistLocnPtr - "MR_exist_typeinfo_locns"],
+ MR_DuExistInfo).
+
+ % rtti_enum_const(Name, Value):
+ % Succeed iff Name is the name of an RTTI
+ % enumeration constant whose integer value is Value.
+ % The values here must match the definitions of the
+ % MR_TypeCtor and MR_Sectag_Locn enumerations in
+ % runtime/mercury_type_info.h.
+:- pred rtti_enum_const(string::in, int::out) is semidet.
+rtti_enum_const("MR_TYPECTOR_REP_ENUM", 0).
+rtti_enum_const("MR_TYPECTOR_REP_ENUM_USEREQ", 1).
+rtti_enum_const("MR_TYPECTOR_REP_DU", 2).
+rtti_enum_const("MR_TYPECTOR_REP_DU_USEREQ", 3).
+rtti_enum_const("MR_TYPECTOR_REP_NOTAG", 4).
+rtti_enum_const("MR_TYPECTOR_REP_NOTAG_USEREQ", 5).
+rtti_enum_const("MR_TYPECTOR_REP_EQUIV", 6).
+rtti_enum_const("MR_TYPECTOR_REP_EQUIV_VAR", 7).
+rtti_enum_const("MR_TYPECTOR_REP_INT", 8).
+rtti_enum_const("MR_TYPECTOR_REP_CHAR", 9).
+rtti_enum_const("MR_TYPECTOR_REP_FLOAT", 10).
+rtti_enum_const("MR_TYPECTOR_REP_STRING", 11).
+rtti_enum_const("MR_TYPECTOR_REP_PRED", 12).
+rtti_enum_const("MR_TYPECTOR_REP_UNIV", 13).
+rtti_enum_const("MR_TYPECTOR_REP_VOID", 14).
+rtti_enum_const("MR_TYPECTOR_REP_C_POINTER", 15).
+rtti_enum_const("MR_TYPECTOR_REP_TYPEINFO", 16).
+rtti_enum_const("MR_TYPECTOR_REP_TYPECLASSINFO", 17).
+rtti_enum_const("MR_TYPECTOR_REP_ARRAY", 18).
+rtti_enum_const("MR_TYPECTOR_REP_SUCCIP", 19).
+rtti_enum_const("MR_TYPECTOR_REP_HP", 20).
+rtti_enum_const("MR_TYPECTOR_REP_CURFR", 21).
+rtti_enum_const("MR_TYPECTOR_REP_MAXFR", 22).
+rtti_enum_const("MR_TYPECTOR_REP_REDOFR", 23).
+rtti_enum_const("MR_TYPECTOR_REP_REDOIP", 24).
+rtti_enum_const("MR_TYPECTOR_REP_TRAIL_PTR", 25).
+rtti_enum_const("MR_TYPECTOR_REP_TICKET", 26).
+rtti_enum_const("MR_TYPECTOR_REP_NOTAG_GROUND", 27).
+rtti_enum_const("MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ", 28).
+rtti_enum_const("MR_TYPECTOR_REP_EQUIV_GROUND", 29).
+rtti_enum_const("MR_TYPECTOR_REP_TUPLE", 30).
+rtti_enum_const("MR_TYPECTOR_REP_UNKNOWN", 31).
+rtti_enum_const("MR_SECTAG_NONE", 0).
+rtti_enum_const("MR_SECTAG_LOCAL", 1).
+rtti_enum_const("MR_SECTAG_REMOTE", 2).
+
+:- pred build_struct_type(gcc__struct_name::in,
+ list(pair(gcc__type, gcc__field_name))::in,
+ gcc__type::out, io__state::di, io__state::uo) is det.
+
+build_struct_type(StructName, Fields, GCC_Type) -->
+ build_fields(Fields, GCC_Fields),
+ gcc__build_struct_type_decl(StructName, GCC_Fields, GCC_TypeDecl),
+ { GCC_Type = gcc__declared_type(GCC_TypeDecl) }.
+
+:- pred build_fields(list(pair(gcc__type, gcc__field_name))::in,
+ gcc__field_decls::out, io__state::di, io__state::uo) is det.
+
+build_fields([], GCC_Fields) -->
+ gcc__empty_field_list(GCC_Fields).
+build_fields([Type - Name | Fields0], GCC_Fields) -->
+ build_fields(Fields0, GCC_Fields0),
+ gcc__build_field_decl(Name, Type, FieldDecl),
+ gcc__cons_field_list(FieldDecl, GCC_Fields0, GCC_Fields).
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output names of various entities
+%
+
+:- func build_qualified_name(mlds__qualified_entity_name) = string.
+
+build_qualified_name(QualifiedName) = AsmName :-
+ QualifiedName = qual(_ModuleName, Name),
+ AsmName0 = build_name(Name),
+ maybe_add_module_qualifier(QualifiedName, AsmName0, AsmName).
+
+:- pred maybe_add_module_qualifier(mlds__qualified_entity_name::in,
+ string::in, string::out) is det.
+maybe_add_module_qualifier(QualifiedName, AsmName0, AsmName) :-
+ QualifiedName = qual(ModuleName, Name),
+ (
+ (
+ %
+ % don't module-qualify main/2
+ %
+ Name = function(PredLabel, _, _, _),
+ PredLabel = pred(predicate, no, "main", 2)
+ ;
+ %
+ % don't module-qualify base_typeclass_infos
+ %
+ % We don't want to include the module name as part
+ % of the name if it is a base_typeclass_info, since
+ % we _want_ to cause a link error for overlapping
+ % instance decls, even if they are in a different
+ % module
+ %
+ Name = data(base_typeclass_info(_, _))
+ ;
+ % We don't module qualify pragma export names.
+ Name = export(_)
+ )
+ ->
+ AsmName = AsmName0
+ ;
+ ModuleSymName = mlds_module_name_to_sym_name(ModuleName),
+ AsmName = string__format("%s__%s",
+ [s(get_module_name(ModuleSymName)), s(AsmName0)])
+ ).
+
+% XXX we should consider not appending the arity, modenum, and seqnum
+% if they are not needed.
+
+:- func build_name(mlds__entity_name) = string.
+
+build_name(type(Name, Arity)) = TypeName :-
+ llds_out__name_mangle(Name, MangledName),
+ TypeName = string__format("%s_%d", [s(MangledName), i(Arity)]).
+build_name(data(DataName)) = build_data_name(DataName).
+build_name(EntityName) = AsmFuncName :-
+ EntityName = function(_, _, _, _),
+ get_func_name(EntityName, _FuncName, AsmFuncName).
+build_name(export(Name)) = Name.
+
+:- func build_data_name(mlds__data_name) = string.
+
+build_data_name(var(Name)) = MangledName :-
+ llds_out__name_mangle(Name, MangledName).
+build_data_name(common(Num)) =
+ string__format("common_%d", [i(Num)]).
+build_data_name(rtti(RttiTypeId0, RttiName0)) = RttiAddrName :-
+ RttiTypeId = fixup_rtti_type_id(RttiTypeId0),
+ RttiName = fixup_rtti_name(RttiName0),
+ rtti__addr_to_string(RttiTypeId, RttiName, RttiAddrName).
+build_data_name(base_typeclass_info(ClassId, InstanceStr)) = Name :-
+ llds_out__make_base_typeclass_info_name(ClassId, InstanceStr,
+ Name).
+build_data_name(module_layout) = _ :-
+ sorry(this_file, "module_layout").
+build_data_name(proc_layout(_ProcLabel)) = _ :-
+ sorry(this_file, "proc_layout").
+build_data_name(internal_layout(_ProcLabel, _FuncSeqNum)) = _ :-
+ sorry(this_file, "internal_layout").
+build_data_name(tabling_pointer(ProcLabel)) = TablingPointerName :-
+ % convert the proc_label into an entity_name,
+ % so we can use get_func_name below
+ ProcLabel = PredLabel - ProcId,
+ MaybeSeqNum = no,
+ invalid_pred_id(InvalidPredId),
+ Name = function(PredLabel, ProcId, MaybeSeqNum, InvalidPredId),
+ get_func_name(Name, _FuncName, AsmFuncName),
+ TablingPointerName = string__append("table_for_", AsmFuncName).
+
+ % XXX sometimes earlier stages of the compiler forget to add
+ % the appropriate qualifiers for stuff in the `builtin' module;
+ % we fix that here.
+:- func fixup_rtti_type_id(rtti_type_id) = rtti_type_id.
+fixup_rtti_type_id(RttiTypeId0) = RttiTypeId :-
+ (
+ RttiTypeId0 = rtti_type_id(ModuleName0, Name, Arity),
+ ModuleName0 = unqualified("")
+ ->
+ ModuleName = unqualified("builtin"),
+ RttiTypeId = rtti_type_id(ModuleName, Name, Arity)
+ ;
+ RttiTypeId = RttiTypeId0
+ ).
+
+:- func fixup_rtti_name(rtti_name) = rtti_name.
+fixup_rtti_name(RttiTypeId0) = RttiTypeId :-
+ (
+ RttiTypeId0 = pseudo_type_info(PseudoTypeInfo0)
+ ->
+ RttiTypeId = pseudo_type_info(
+ fixup_pseudo_type_info(PseudoTypeInfo0))
+ ;
+ RttiTypeId = RttiTypeId0
+ ).
+
+:- func fixup_pseudo_type_info(pseudo_type_info) = pseudo_type_info.
+fixup_pseudo_type_info(PseudoTypeInfo0) = PseudoTypeInfo :-
+ (
+ PseudoTypeInfo0 = type_ctor_info(RttiTypeId0)
+ ->
+ PseudoTypeInfo = type_ctor_info(
+ fixup_rtti_type_id(RttiTypeId0))
+ ;
+ PseudoTypeInfo = PseudoTypeInfo0
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Symbol tables and other (semi-)global data structures
+%
+
+:- type global_info
+ ---> global_info(
+ type_table :: gcc_type_table,
+ global_vars :: symbol_table
+ ).
+
+% The type field table records the mapping from MLDS type names
+% to the table of field declarations for that type.
+:- type gcc_type_table == map(mlds__qualified_entity_name, gcc_type_info).
+:- type gcc_type_info ---> gcc_type_info(gcc__type_decl, field_table).
+
+% The field table records the mapping from MLDS field names
+% to GCC field declarations.
+:- type field_table == map(mlds__fully_qualified_name(field_name), gcc__field_decl).
+
+% The func_info holds information used while generating code
+% inside a function.
+% The name is a bit of a misnomer, since we also use this while
+% generating initializers for global variable.
+% So it should perhaps be called something like
+% func_or_global_var_info (ugh).
+:- type func_info
+ ---> func_info(
+ global_info :: global_info,
+ func_name :: mlds__qualified_entity_name,
+ local_vars :: symbol_table,
+ label_table :: label_table
+ ).
+
+% The symbol table records the mapping from MLDS variable names
+% to GCC variable declarations.
+% We initialize the symbol table with the function parameters,
+% and update it whenever we enter a block with local variables.
+:- type symbol_table == map(mlds__qualified_entity_name, gcc__var_decl).
+
+% The label table records the mapping from MLDS label names
+% to GCC label declaration tree nodes.
+% We initialize it using a separate pass over the function body
+% before we generate code for the function.
+:- type label_table == map(mlds__label, gcc__label).
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output statements
+%
+
+:- pred gen_statements(func_info, list(mlds__statement),
+ io__state, io__state).
+:- mode gen_statements(in, in, di, uo) is det.
+
+gen_statements(FuncInfo, Statements) -->
+ list__foldl(gen_statement(FuncInfo), Statements).
+
+:- pred gen_statement(func_info, mlds__statement,
+ io__state, io__state).
+:- mode gen_statement(in, in, di, uo) is det.
+
+gen_statement(FuncInfo, mlds__statement(Statement, Context)) -->
+ gen_context(Context),
+ gen_stmt(FuncInfo, Statement, Context).
+
+:- pred gen_stmt(func_info, mlds__stmt, mlds__context,
+ io__state, io__state).
+:- mode gen_stmt(in, in, in, di, uo) is det.
+
+ %
+ % sequence
+ %
+gen_stmt(FuncInfo0, block(Defns, Statements), _Context) -->
+ { FuncName = FuncInfo0 ^ func_name },
+ { FuncName = qual(ModuleName, _) },
+ { SymbolTable0 = FuncInfo0 ^ local_vars },
+ build_local_defns(Defns, FuncInfo0, ModuleName, SymbolTable0, SymbolTable),
+ { FuncInfo = FuncInfo0 ^ local_vars := SymbolTable },
+ gen_statements(FuncInfo, Statements).
+
+ %
+ % iteration
+ %
+gen_stmt(FuncInfo, while(Cond, Statement, AtLeastOneIteration), _Context) -->
+ gcc__gen_start_loop(Loop),
+ build_rval(Cond, FuncInfo, GCC_Cond),
+ (
+ { AtLeastOneIteration = yes },
+ % generate the test at the end of the loop
+ gen_statement(FuncInfo, Statement),
+ gcc__gen_exit_loop_if_false(Loop, GCC_Cond)
+ ;
+ { AtLeastOneIteration = no },
+ % generate the test at the start of the loop
+ gcc__gen_exit_loop_if_false(Loop, GCC_Cond),
+ gen_statement(FuncInfo, Statement)
+ ),
+ gcc__gen_end_loop.
+
+ %
+ % selection (see also computed_goto)
+ %
+gen_stmt(FuncInfo, if_then_else(Cond, Then, MaybeElse), _Context) -->
+ build_rval(Cond, FuncInfo, GCC_Cond),
+ gcc__gen_start_cond(GCC_Cond),
+ gen_statement(FuncInfo, Then),
+ (
+ { MaybeElse = no }
+ ;
+ { MaybeElse = yes(Else) },
+ gcc__gen_start_else,
+ gen_statement(FuncInfo, Else)
+ ),
+ gcc__gen_end_cond.
+gen_stmt(FuncInfo, switch(Type, Val, Range, Cases, Default), _) -->
+ build_type(Type, FuncInfo ^ global_info, GCC_Type),
+ ( { Range = range(Min, Max) } ->
+ gcc__build_range_type(GCC_Type, Min, Max, GCC_RangeType)
+ ;
+ { GCC_RangeType = GCC_Type }
+ ),
+ build_rval(Val, FuncInfo, GCC_Expr),
+ gcc__gen_start_switch(GCC_Expr, GCC_RangeType),
+ % we put the default case first, so that if it is unreachable,
+ % it will get merged in with the first case.
+ gen_default(FuncInfo, Default),
+ gen_cases(FuncInfo, Cases),
+ gcc__gen_end_switch(GCC_Expr).
+
+ %
+ % transfer of control
+ %
+gen_stmt(FuncInfo, label(LabelName), _) -->
+ { LabelTable = FuncInfo ^ label_table },
+ { GCC_Label = map__lookup(LabelTable, LabelName) },
+ gcc__gen_label(GCC_Label).
+gen_stmt(FuncInfo, goto(LabelName), _) -->
+ { LabelTable = FuncInfo ^ label_table },
+ { GCC_Label = map__lookup(LabelTable, LabelName) },
+ gcc__gen_goto(GCC_Label).
+gen_stmt(_FuncInfo, computed_goto(_Expr, _Labels), _) -->
+ % XXX not yet implemented
+ % but we set target_supports_computed_goto to no
+ % for this target, so we shouldn't get any
+ { unexpected(this_file, "computed goto") }.
+
+ %
+ % function call/return
+ %
+gen_stmt(FuncInfo, Call, _) -->
+ { Call = call(_Signature, FuncRval, MaybeObject, CallArgs,
+ Results, IsTailCall) },
+ { require(unify(MaybeObject, no), this_file ++ ": method call") },
+ build_args(CallArgs, FuncInfo, GCC_ArgList),
+ build_rval(FuncRval, FuncInfo, GCC_FuncRval),
+ % XXX GCC currently ignores the tail call boolean
+ { IsTailCallBool = (IsTailCall = tail_call -> yes ; no) },
+ gcc__build_call_expr(GCC_FuncRval, GCC_ArgList, IsTailCallBool,
+ GCC_Call),
+ ( { Results = [ResultLval] } ->
+ build_lval(ResultLval, FuncInfo, GCC_ResultExpr),
+ gcc__gen_assign(GCC_ResultExpr, GCC_Call)
+ ; { Results = [] } ->
+ gcc__gen_expr_stmt(GCC_Call)
+ ;
+ { sorry(this_file, "call with multiple outputs") }
+ ).
+gen_stmt(FuncInfo, return(Results), _) -->
+ ( { Results = [] } ->
+ % XXX Not yet implemented
+ % These are not generated by the current MLDS code
+ % generator, so I didn't bother to implement them.
+ { sorry(this_file, "gen_stmt: return without return value") }
+ ; { Results = [Rval] } ->
+ build_rval(Rval, FuncInfo, Expr),
+ gcc__gen_return(Expr)
+ ;
+ { sorry(this_file, "gen_stmt: multiple return values") }
+ ).
+
+ %
+ % commits
+ %
+gen_stmt(FuncInfo, do_commit(Ref), _Context) -->
+ % generate `__builtin_longjmp(&<Ref>, 1);'
+ { Ref = lval(RefLval0) ->
+ RefLval = RefLval0
+ ;
+ unexpected(this_file, "non-lval argument to do_commit")
+ },
+ build_call(gcc__longjmp_func_decl, [mem_addr(RefLval), const(int_const(1))],
+ FuncInfo, GCC_CallLongjmp),
+ gcc__gen_expr_stmt(GCC_CallLongjmp).
+gen_stmt(FuncInfo, try_commit(Ref, Stmt, Handler), _) -->
+ %
+ % Generate the following:
+ %
+ % if (__builtin_setjmp(&<Ref>) == 0)
+ % <Stmt>
+ % else
+ % <Handler>
+ %
+ build_call(gcc__setjmp_func_decl, [mem_addr(Ref)], FuncInfo,
+ GCC_CallSetjmp),
+ gcc__build_int(0, GCC_Zero),
+ gcc__build_binop(gcc__eq_expr, gcc__boolean_type_node,
+ GCC_CallSetjmp, GCC_Zero, GCC_SetjmpEqZero),
+ gcc__gen_start_cond(GCC_SetjmpEqZero),
+ gen_statement(FuncInfo, Stmt),
+ gcc__gen_start_else,
+ gen_statement(FuncInfo, Handler),
+ gcc__gen_end_cond.
+
+ %
+ % exception handling
+ %
+/* XXX MLDS exception handling not yet implemented */
+
+ %
+ % atomic statements
+ %
+gen_stmt(FuncInfo, atomic(AtomicStatement), Context) -->
+ gen_atomic_stmt(FuncInfo, AtomicStatement, Context).
+
+%-----------------------------------------------------------------------------%
+
+%
+% Extra code for outputting switch statements
+%
+
+:- pred gen_cases(func_info::in, mlds__switch_cases::in,
+ io__state::di, io__state::uo) is det.
+gen_cases(FuncInfo, Cases) -->
+ list__foldl(gen_case(FuncInfo), Cases).
+
+:- pred gen_case(func_info::in, mlds__switch_case::in,
+ io__state::di, io__state::uo) is det.
+gen_case(FuncInfo, MatchConds - Code) -->
+ list__foldl(gen_case_label(FuncInfo), MatchConds),
+ gen_statement(FuncInfo, Code),
+ gcc__gen_break.
+
+:- pred gen_case_label(func_info::in, mlds__case_match_cond::in,
+ io__state::di, io__state::uo) is det.
+gen_case_label(FuncInfo, match_value(Val)) -->
+ build_rval(Val, FuncInfo, GCC_Val),
+ gcc__build_unnamed_label(Label),
+ gcc__gen_case_label(GCC_Val, Label).
+gen_case_label(FuncInfo, match_range(Min, Max)) -->
+ build_rval(Min, FuncInfo, _GCC_Min),
+ build_rval(Max, FuncInfo, _GCC_Max),
+ gcc__build_unnamed_label(_Label),
+ % the following is not yet implemented
+ % (would be easy to do, but not needed so far, since
+ % these are not generated by the current MLDS code generator)
+ %%% gcc__gen_case_range_label(GCC_Min, GCC_Max, Label).
+ { sorry(this_file, "match_range") }.
+
+:- pred gen_default(func_info::in, mlds__switch_default::in,
+ io__state::di, io__state::uo) is det.
+gen_default(_, default_do_nothing) --> [].
+gen_default(_, default_is_unreachable) -->
+ % If the default is unreachable, we just generate a label
+ % which will just drop through into the first case.
+ % This generally leads to more efficient code than
+ % default_do_nothing.
+ gcc__build_unnamed_label(Label),
+ gcc__gen_default_case_label(Label).
+gen_default(FuncInfo, default_case(Statement)) -->
+ gcc__build_unnamed_label(Label),
+ gcc__gen_default_case_label(Label),
+ gen_statement(FuncInfo, Statement).
+
+%-----------------------------------------------------------------------------%
+
+/**********
+XXX Profiling is not yet implemented for mlds_to_gcc.m.
+The following code for handling profiling is copied from
+mlds_to_c.m. It shows what we should generate.
+
+ %
+ % If memory profiling is turned on output an instruction to
+ % record the heap allocation.
+ %
+:- pred mlds_maybe_output_heap_profile_instr(mlds__context::in,
+ indent::in, list(mlds__rval)::in,
+ mlds__qualified_entity_name::in, maybe(ctor_name)::in,
+ io__state::di, io__state::uo) is det.
+
+mlds_maybe_output_heap_profile_instr(Context, Indent, Args, FuncName,
+ MaybeCtorName) -->
+ globals__io_lookup_bool_option(profile_memory, ProfileMem),
+ (
+ { ProfileMem = yes }
+ ->
+ mlds_indent(Context, Indent),
+ io__write_string("MR_record_allocation("),
+ io__write_int(list__length(Args)),
+ io__write_string(", "),
+ mlds_output_fully_qualified_name(FuncName),
+ io__write_string(", """),
+ mlds_output_fully_qualified_name(FuncName),
+ io__write_string(""", "),
+ ( { MaybeCtorName = yes(CtorName) } ->
+ io__write_char('"'),
+ c_util__output_quoted_string(CtorName),
+ io__write_char('"')
+ ;
+ io__write_string("NULL")
+ ),
+ io__write_string(");\n")
+ ;
+ []
+ ).
+
+ %
+ % If call profiling is turned on output an instruction to record
+ % an arc in the call profile between the callee and caller.
+ %
+:- pred mlds_maybe_output_call_profile_instr(mlds__context::in,
+ indent::in, mlds__rval::in, mlds__qualified_entity_name::in,
+ io__state::di, io__state::uo) is det.
+
+mlds_maybe_output_call_profile_instr(Context, Indent,
+ CalleeFuncRval, CallerName) -->
+ globals__io_lookup_bool_option(profile_calls, ProfileCalls),
+ ( { ProfileCalls = yes } ->
+ mlds_indent(Context, Indent),
+ io__write_string("MR_prof_call_profile("),
+ mlds_output_bracketed_rval(CalleeFuncRval),
+ io__write_string(", "),
+ mlds_output_fully_qualified_name(CallerName),
+ io__write_string(");\n")
+ ;
+ []
+ ).
+
+ %
+ % If time profiling is turned on output an instruction which
+ % informs the runtime which procedure we are currently located
+ % in.
+ %
+:- pred mlds_maybe_output_time_profile_instr(mlds__context::in,
+ indent::in, mlds__qualified_entity_name::in,
+ io__state::di, io__state::uo) is det.
+
+mlds_maybe_output_time_profile_instr(Context, Indent, Name) -->
+ globals__io_lookup_bool_option(profile_time, ProfileTime),
+ (
+ { ProfileTime = yes }
+ ->
+ mlds_indent(Context, Indent),
+ io__write_string("MR_set_prof_current_proc("),
+ mlds_output_fully_qualified_name(Name),
+ io__write_string(");\n")
+ ;
+ []
+ ).
+
+***************/
+
+%-----------------------------------------------------------------------------%
+
+%
+% atomic statements
+%
+
+:- pred gen_atomic_stmt(func_info,
+ mlds__atomic_statement, mlds__context, io__state, io__state).
+:- mode gen_atomic_stmt(in, in, in, di, uo) is det.
+
+ %
+ % comments
+ %
+gen_atomic_stmt(_FuncInfo, comment(_Comment), _) -->
+ % For now, we just ignore the comments.
+ % XXX Does gcc provide some way of inserting
+ % comments into the generated assembler?
+ [].
+
+ %
+ % assignment
+ %
+gen_atomic_stmt(FuncInfo, assign(Lval, Rval), _) -->
+ build_lval(Lval, FuncInfo, GCC_Lval),
+ build_rval(Rval, FuncInfo, GCC_Rval),
+ gcc__gen_assign(GCC_Lval, GCC_Rval).
+
+ %
+ % heap management
+ %
+gen_atomic_stmt(_FuncInfo, delete_object(_Lval), _) -->
+ % XXX not yet implemented
+ % we should generate a call to GC_free()
+ % (would be easy to do, but not needed so far, since
+ % these are not generated by the current MLDS code generator)
+ { sorry(this_file, "delete_object") }.
+
+gen_atomic_stmt(FuncInfo, NewObject, Context) -->
+ { NewObject = new_object(Target, MaybeTag, Type, MaybeSize,
+ _MaybeCtorName, Args, ArgTypes) },
+
+ %
+ % Calculate the size that we're going to allocate.
+ %
+ ( { MaybeSize = yes(SizeInBytes0) } ->
+ % Rather than generating a reference to a global variable
+ % mercury__private_builtin__SIZEOF_WORD, we ignore the
+ % word size multiplier, and instead get the word size
+ % from the bytes_per_word option.
+ % XXX This is kludgy. We should change new_object
+ % so that it has the size in words rather than in bytes.
+ (
+ { SizeInBytes0 = binop((*), SizeInWords,
+ _SizeOfWord) }
+ ->
+ globals__io_lookup_int_option(bytes_per_word,
+ BytesPerWord),
+ { SizeOfWord = const(int_const(BytesPerWord)) },
+ { SizeInBytes = binop((*), SizeInWords, SizeOfWord) }
+ ;
+ { sorry(this_file, "unexpected size in new_object") },
+ { SizeInBytes0 = SizeInBytes }
+ )
+ % For debugging:
+ % io__print("SizeInBytes0 = "), io__print(SizeInBytes0), io__nl,
+ % io__print("SizeInBytes = "), io__print(SizeInBytes), io__nl,
+ ;
+ { sorry(this_file, "new_object with unknown size") }
+ ),
+
+ %
+ % Generate code to allocate the memory and optionally tag the pointer,
+ % i.e. `Target = (Type) GC_malloc(SizeInBytes)'
+ % or `Target = MR_mkword(Tag, (Type) GC_malloc(SizeInBytes))'.
+ %
+
+ % generate `GC_malloc(SizeInBytes)'
+ build_call(gcc__alloc_func_decl, [SizeInBytes], FuncInfo, GCC_Call),
+
+ % cast the result to (Type)
+ build_type(Type, FuncInfo ^ global_info, GCC_Type),
+ gcc__convert_type(GCC_Call, GCC_Type, GCC_CastCall),
+
+ % add a tag to the pointer, if necessary
+ ( { MaybeTag = yes(Tag0) } ->
+ { Tag = Tag0 },
+ gcc__build_int(Tag, GCC_Tag),
+ gcc__build_binop(gcc__plus_expr, GCC_Type,
+ GCC_CastCall, GCC_Tag, GCC_TaggedCastCall)
+ ;
+ { Tag = 0 },
+ { GCC_TaggedCastCall = GCC_CastCall }
+ ),
+
+ % assign it to Target
+ build_lval(Target, FuncInfo, GCC_Target),
+ gcc__gen_assign(GCC_Target, GCC_TaggedCastCall),
+
+ %
+ % Initialize the fields.
+ %
+ gen_init_args(Args, ArgTypes, Context, 0, Target, Type, Tag,
+ FuncInfo).
+
+gen_atomic_stmt(_FuncInfo, mark_hp(_Lval), _) -->
+ { sorry(this_file, "mark_hp") }.
+
+gen_atomic_stmt(_FuncInfo, restore_hp(_Rval), _) -->
+ { sorry(this_file, "restore_hp") }.
+
+ %
+ % trail management
+ %
+gen_atomic_stmt(_FuncInfo, trail_op(_TrailOp), _) -->
+ % Currently trail ops are implemented via calls to
+ % impure predicates implemented in C, rather than as
+ % MLDS trail ops, so this should never be reached.
+ { unexpected(this_file, "trail_op") }.
+ % XXX That approach should work OK, but it is not
+ % maximally efficient for this back-end, since for
+ % this back-end the calls to C will end up as out-of-line
+ % calls. It would be more efficient to recognize
+ % the calls to the impure trail predicates and treat them
+ % as as builtins, expanding them to MLDS trail ops in
+ % ml_code_gen/ml_call_gen, and then generating inline
+ % code for them here.
+
+ %
+ % foreign language interfacing
+ %
+gen_atomic_stmt(_FuncInfo, target_code(_TargetLang, _Components),
+ _Context) -->
+ % XXX we should support inserting inline asm code fragments
+ { sorry(this_file, "target_code (for `--target asm')") }.
+
+ %
+ % gen_init_args generates code to initialize the fields
+ % of an object allocated with a new_object MLDS instruction.
+ %
+:- pred gen_init_args(list(mlds__rval), list(mlds__type), mlds__context, int,
+ mlds__lval, mlds__type, mlds__tag, func_info,
+ io__state, io__state).
+:- mode gen_init_args(in, in, in, in, in, in, in, in, di, uo) is det.
+
+gen_init_args([_|_], [], _, _, _, _, _, _) -->
+ { error("gen_init_args: length mismatch") }.
+gen_init_args([], [_|_], _, _, _, _, _, _) -->
+ { error("gen_init_args: length mismatch") }.
+gen_init_args([], [], _, _, _, _, _, _) --> [].
+gen_init_args([Arg | Args], [ArgType | ArgTypes], Context,
+ ArgNum, Target, Type, Tag, FuncInfo) -->
+ %
+ % Currently all fields of new_object instructions are
+ % represented as MR_Box, so we need to box them if necessary.
+ %
+ { Lval = field(yes(Tag), lval(Target),
+ offset(const(int_const(ArgNum))), mlds__generic_type, Type) },
+ { Rval = unop(box(ArgType), Arg) },
+ build_lval(Lval, FuncInfo, GCC_Lval),
+ build_rval(Rval, FuncInfo, GCC_Rval),
+ gcc__gen_assign(GCC_Lval, GCC_Rval),
+ gen_init_args(Args, ArgTypes, Context,
+ ArgNum + 1, Target, Type, Tag, FuncInfo).
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output expressions
+%
+
+:- pred build_lval(mlds__lval, func_info, gcc__expr, io__state, io__state).
+:- mode build_lval(in, in, out, di, uo) is det.
+
+build_lval(field(MaybeTag, Rval, offset(OffsetRval),
+ FieldType, _ClassType), FuncInfo, GCC_FieldRef) -->
+ % sanity check (copied from mlds_to_c.m)
+ (
+ { FieldType = mlds__generic_type
+ ; FieldType = mlds__mercury_type(term__variable(_), _)
+ }
+ ->
+ []
+ ;
+ % The field type for field(_, _, offset(_), _, _) lvals
+ % must be something that maps to MR_Box.
+ { error("unexpected field type") }
+ ),
+
+ % generate the tagged pointer whose field we want to extract
+ build_rval(Rval, FuncInfo, GCC_TaggedPointer),
+
+ % subtract or mask out the tag
+ ( { MaybeTag = yes(Tag) } ->
+ gcc__build_int(Tag, GCC_Tag),
+ gcc__build_binop(gcc__minus_expr, gcc__ptr_type_node,
+ GCC_TaggedPointer, GCC_Tag, GCC_Pointer)
+ ;
+ globals__io_lookup_int_option(num_tag_bits, TagBits),
+ gcc__build_int(\ ((1 << TagBits) - 1), GCC_Mask),
+ gcc__build_binop(gcc__bit_and_expr, gcc__ptr_type_node,
+ GCC_TaggedPointer, GCC_Mask, GCC_Pointer)
+ ),
+
+ % add the appropriate offset
+ build_rval(OffsetRval, FuncInfo, GCC_OffsetInWords),
+ globals__io_lookup_int_option(bytes_per_word, BytesPerWord),
+ gcc__build_int(BytesPerWord, GCC_BytesPerWord),
+ gcc__build_binop(gcc__mult_expr, 'MR_intptr_t',
+ GCC_OffsetInWords, GCC_BytesPerWord, GCC_OffsetInBytes),
+ gcc__build_binop(gcc__plus_expr, gcc__ptr_type_node,
+ GCC_Pointer, GCC_OffsetInBytes, GCC_FieldPointer0),
+
+ % cast the pointer to the right type (XXX is this necessary?)
+ build_type(FieldType, FuncInfo ^ global_info, GCC_FieldType),
+ gcc__build_pointer_type(GCC_FieldType, GCC_FieldPointerType),
+ gcc__convert_type(GCC_FieldPointer0, GCC_FieldPointerType,
+ GCC_FieldPointer),
+
+ % deference it
+ gcc__build_pointer_deref(GCC_FieldPointer, GCC_FieldRef).
+
+build_lval(field(MaybeTag, PtrRval, named_field(FieldName, CtorType),
+ _FieldType, _PtrType), FuncInfo, GCC_Expr) -->
+ % generate the tagged pointer whose field we want to extract
+ build_rval(PtrRval, FuncInfo, GCC_TaggedPointer),
+
+ % subtract or mask out the tag
+ ( { MaybeTag = yes(Tag) } ->
+ gcc__build_int(Tag, GCC_Tag),
+ gcc__build_binop(gcc__minus_expr, gcc__ptr_type_node,
+ GCC_TaggedPointer, GCC_Tag, GCC_Pointer)
+ ;
+ globals__io_lookup_int_option(num_tag_bits, TagBits),
+ gcc__build_int(\ ((1 << TagBits) - 1), GCC_Mask),
+ gcc__build_binop(gcc__bit_and_expr, gcc__ptr_type_node,
+ GCC_TaggedPointer, GCC_Mask, GCC_Pointer)
+ ),
+
+ % cast the pointer to the right type
+ build_type(CtorType, FuncInfo ^ global_info, GCC_CtorType),
+ gcc__build_pointer_type(GCC_CtorType, GCC_PointerType),
+ gcc__convert_type(GCC_Pointer, GCC_PointerType,
+ GCC_CastPointer),
+
+ % deference it
+ gcc__build_pointer_deref(GCC_CastPointer, GCC_ObjectRef),
+
+ % extract the right field
+ { TypeTable = FuncInfo ^ global_info ^ type_table },
+ { TypeName = get_class_type_name(CtorType) },
+ { gcc_type_info(_, FieldTable) = map__lookup(TypeTable, TypeName) },
+ { GCC_FieldDecl = map__lookup(FieldTable, FieldName) },
+ gcc__build_component_ref(GCC_ObjectRef, GCC_FieldDecl,
+ GCC_Expr).
+
+build_lval(mem_ref(PointerRval, _Type), FuncInfo, Expr) -->
+ build_rval(PointerRval, FuncInfo, PointerExpr),
+ gcc__build_pointer_deref(PointerExpr, Expr).
+
+build_lval(var(qual(ModuleName, VarName)), FuncInfo, Expr) -->
+ %
+ % Look up the variable in the symbol table.
+ % We try the symbol table for local vars first,
+ % and then if its not there, we look in the global vars
+ % symbol table. If it's not in either of those,
+ % we check if its an RTTI enumeration constant.
+ %
+ { Name = qual(ModuleName, data(var(VarName))) },
+ (
+ { map__search(FuncInfo ^ local_vars, Name, LocalVarDecl) }
+ ->
+ { Expr = gcc__var_expr(LocalVarDecl) }
+ ;
+ { map__search(FuncInfo ^ global_info ^ global_vars,
+ Name, GlobalVarDecl) }
+ ->
+ { Expr = gcc__var_expr(GlobalVarDecl) }
+ ;
+ % check if its in the private_builtin module
+ % and is an RTTI enumeration constant
+ { mercury_private_builtin_module(PrivateBuiltin) },
+ { mercury_module_name_to_mlds(PrivateBuiltin) = ModuleName },
+ { rtti_enum_const(VarName, IntVal) }
+ ->
+ gcc__build_int(IntVal, Expr)
+ ;
+ { unexpected(this_file, "undeclared variable: " ++
+ build_qualified_name(Name)) }
+ ).
+
+:- func get_class_type_name(mlds__type) = mlds__qualified_entity_name.
+get_class_type_name(Type) = Name :-
+ (
+ (
+ Type = mlds__class_type(ClassName, Arity, _Kind)
+ ;
+ Type = mlds__ptr_type(mlds__class_type(ClassName,
+ Arity, _Kind))
+ )
+ ->
+ ClassName = qual(ModuleName, UnqualClassName),
+ Name = qual(ModuleName, type(UnqualClassName, Arity))
+ ;
+ unexpected(this_file, "non-class_type in get_type_name")
+ ).
+
+:- pred build_rval(mlds__rval, func_info, gcc__expr, io__state, io__state).
+:- mode build_rval(in, in, out, di, uo) is det.
+
+build_rval(lval(Lval), FuncInfo, Expr) -->
+ build_lval(Lval, FuncInfo, Expr).
+
+build_rval(mkword(Tag, Arg), FuncInfo, Expr) -->
+ gcc__build_int(Tag, GCC_Tag),
+ build_rval(Arg, FuncInfo, GCC_Arg),
+ gcc__build_binop(gcc__plus_expr, gcc__ptr_type_node,
+ GCC_Arg, GCC_Tag, Expr).
+
+build_rval(const(Const), FuncInfo, Expr) -->
+ build_rval_const(Const, FuncInfo ^ global_info, Expr).
+
+build_rval(unop(Op, Rval), FuncInfo, Expr) -->
+ build_unop(Op, Rval, FuncInfo, Expr).
+
+build_rval(binop(Op, Rval1, Rval2), FuncInfo, Expr) -->
+ build_std_binop(Op, Rval1, Rval2, FuncInfo, Expr).
+
+build_rval(mem_addr(Lval), FuncInfo, AddrExpr) -->
+ build_lval(Lval, FuncInfo, Expr),
+ gcc__build_addr_expr(Expr, AddrExpr).
+
+:- pred build_unop(mlds__unary_op, mlds__rval, func_info, gcc__expr,
+ io__state, io__state).
+:- mode build_unop(in, in, in, out, di, uo) is det.
+
+build_unop(cast(Type), Rval, FuncInfo, GCC_Expr) -->
+ build_cast_rval(Type, Rval, FuncInfo, GCC_Expr).
+build_unop(box(Type), Rval, FuncInfo, GCC_Expr) -->
+ (
+ { type_is_float(Type) }
+ ->
+ build_call(gcc__box_float_func_decl, [Rval], FuncInfo,
+ GCC_Expr)
+ ;
+ build_cast_rval(mlds__generic_type, Rval, FuncInfo, GCC_Expr)
+ ).
+build_unop(unbox(Type), Rval, FuncInfo, GCC_Expr) -->
+ (
+ { type_is_float(Type) }
+ ->
+ % Generate `*(MR_Float *)<Rval>'
+ build_rval(Rval, FuncInfo, GCC_Pointer),
+ gcc__build_pointer_type('MR_Float', FloatPointerType),
+ gcc__convert_type(GCC_Pointer, FloatPointerType,
+ GCC_CastPointer),
+ gcc__build_pointer_deref(GCC_CastPointer, GCC_Expr)
+ ;
+ build_cast_rval(Type, Rval, FuncInfo, GCC_Expr)
+ ).
+build_unop(std_unop(Unop), Exprn, FuncInfo, GCC_Expr) -->
+ build_std_unop(Unop, Exprn, FuncInfo, GCC_Expr).
+
+:- pred type_is_float(mlds__type::in) is semidet.
+type_is_float(Type) :-
+ ( Type = mlds__mercury_type(term__functor(term__atom("float"),
+ [], _), _)
+ ; Type = mlds__native_float_type
+ ).
+
+:- pred build_cast_rval(mlds__type, mlds__rval, func_info, gcc__expr,
+ io__state, io__state).
+:- mode build_cast_rval(in, in, in, out, di, uo) is det.
+
+build_cast_rval(Type, Rval, FuncInfo, GCC_Expr) -->
+ build_rval(Rval, FuncInfo, GCC_Rval),
+ build_type(Type, FuncInfo ^ global_info, GCC_Type),
+ gcc__convert_type(GCC_Rval, GCC_Type, GCC_Expr).
+
+:- pred build_std_unop(builtin_ops__unary_op, mlds__rval, func_info,
+ gcc__expr, io__state, io__state).
+:- mode build_std_unop(in, in, in, out, di, uo) is det.
+
+build_std_unop(UnaryOp, Arg, FuncInfo, Expr) -->
+ build_rval(Arg, FuncInfo, GCC_Arg),
+ build_unop_expr(UnaryOp, GCC_Arg, Expr).
+
+:- pred build_unop_expr(builtin_ops__unary_op, gcc__expr, gcc__expr,
+ io__state, io__state).
+:- mode build_unop_expr(in, in, out, di, uo) is det.
+
+% We assume that the tag bits are kept on the low bits
+% (`--tags low'), not on the high bits (`--tags high').
+% XXX we should enforce this in handle_options.m.
+
+build_unop_expr(mktag, Tag, Tag) --> [].
+build_unop_expr(tag, Arg, Expr) -->
+ globals__io_lookup_int_option(num_tag_bits, TagBits),
+ gcc__build_int((1 << TagBits) - 1, Mask),
+ gcc__build_binop(gcc__bit_and_expr, 'MR_intptr_t',
+ Arg, Mask, Expr).
+build_unop_expr(unmktag, Tag, Tag) --> [].
+build_unop_expr(mkbody, Arg, Expr) -->
+ globals__io_lookup_int_option(num_tag_bits, TagBits),
+ gcc__build_int(TagBits, TagBitsExpr),
+ gcc__build_binop(gcc__lshift_expr, 'MR_intptr_t',
+ Arg, TagBitsExpr, Expr).
+build_unop_expr(unmkbody, Arg, Expr) -->
+ globals__io_lookup_int_option(num_tag_bits, TagBits),
+ gcc__build_int(TagBits, TagBitsExpr),
+ gcc__build_binop(gcc__rshift_expr, 'MR_intptr_t',
+ Arg, TagBitsExpr, Expr).
+build_unop_expr(cast_to_unsigned, _, _) -->
+ % cast_to_unsigned is only needed for dense (computed_goto) switches,
+ % and we set target_supports_computed_goto to no for this target,
+ % so we shouldn't get any of these
+ { unexpected(this_file, "cast_to_unsigned") }.
+build_unop_expr(hash_string, Arg, Expr) -->
+ gcc__build_func_addr_expr(gcc__hash_string_func_decl,
+ HashStringFuncExpr),
+ gcc__empty_arg_list(GCC_ArgList0),
+ gcc__cons_arg_list(Arg, GCC_ArgList0, GCC_ArgList),
+ { IsTailCall = no },
+ gcc__build_call_expr(HashStringFuncExpr, GCC_ArgList, IsTailCall,
+ Expr).
+build_unop_expr(bitwise_complement, Arg, Expr) -->
+ gcc__build_unop(gcc__bit_not_expr, 'MR_Integer', Arg, Expr).
+build_unop_expr((not), Arg, Expr) -->
+ gcc__build_unop(gcc__truth_not_expr, gcc__boolean_type_node, Arg, Expr).
+
+:- pred build_std_binop(builtin_ops__binary_op, mlds__rval, mlds__rval,
+ func_info, gcc__expr, io__state, io__state).
+:- mode build_std_binop(in, in, in, in, out, di, uo) is det.
+
+build_std_binop(BinaryOp, Arg1, Arg2, FuncInfo, Expr) -->
+ ( { string_compare_op(BinaryOp, CorrespondingIntOp) } ->
+ %
+ % treat string comparison operators specially:
+ % convert "X `str_OP` Y" into "strcmp(X, Y) `OP` 0"
+ %
+ build_call(gcc__strcmp_func_decl, [Arg1, Arg2], FuncInfo,
+ GCC_Call),
+ gcc__build_int(0, Zero),
+ gcc__build_binop(CorrespondingIntOp, gcc__boolean_type_node,
+ GCC_Call, Zero, Expr)
+ ;
+ %
+ % the usual case: just build a gcc tree node for the expr.
+ %
+ build_rval(Arg1, FuncInfo, GCC_Arg1),
+ build_rval(Arg2, FuncInfo, GCC_Arg2),
+ { convert_binary_op(BinaryOp, GCC_BinaryOp, GCC_ResultType) },
+ gcc__build_binop(GCC_BinaryOp, GCC_ResultType,
+ GCC_Arg1, GCC_Arg2, Expr)
+ ).
+
+:- pred string_compare_op(builtin_ops__binary_op, gcc__op).
+:- mode string_compare_op(in, out) is semidet.
+string_compare_op(str_eq, gcc__eq_expr).
+string_compare_op(str_ne, gcc__ne_expr).
+string_compare_op(str_lt, gcc__lt_expr).
+string_compare_op(str_gt, gcc__gt_expr).
+string_compare_op(str_le, gcc__le_expr).
+string_compare_op(str_ge, gcc__ge_expr).
+
+ % Convert one of our operators to the corresponding
+ % gcc operator. Also compute the gcc return type.
+:- pred convert_binary_op(builtin_ops__binary_op, gcc__op, gcc__type).
+:- mode convert_binary_op(in, out, out) is det.
+
+ % Operator GCC operator GCC result type
+convert_binary_op(+, gcc__plus_expr, 'MR_Integer').
+convert_binary_op(-, gcc__minus_expr, 'MR_Integer').
+convert_binary_op(*, gcc__mult_expr, 'MR_Integer').
+convert_binary_op(/, gcc__trunc_div_expr, 'MR_Integer').
+convert_binary_op((mod), gcc__trunc_mod_expr, 'MR_Integer').
+convert_binary_op((<<), gcc__lshift_expr, 'MR_Integer').
+convert_binary_op((>>), gcc__rshift_expr, 'MR_Integer').
+convert_binary_op((&), gcc__bit_and_expr, 'MR_Integer').
+convert_binary_op(('|'), gcc__bit_ior_expr, 'MR_Integer').
+convert_binary_op((^), gcc__bit_xor_expr, 'MR_Integer').
+convert_binary_op((and), gcc__truth_andif_expr, gcc__boolean_type_node).
+convert_binary_op((or), gcc__truth_orif_expr, gcc__boolean_type_node).
+convert_binary_op(eq, gcc__eq_expr, gcc__boolean_type_node).
+convert_binary_op(ne, gcc__ne_expr, gcc__boolean_type_node).
+convert_binary_op(body, gcc__minus_expr, 'MR_intptr_t').
+convert_binary_op(array_index, gcc__array_ref, Type) :-
+ % XXX temp hack -- this is wrong.
+ % We should change builtin_ops:array_index
+ % so that it takes the type as an argument.
+ Type = 'MR_Integer'.
+convert_binary_op(str_eq, _, _) :- unexpected(this_file, "str_eq").
+convert_binary_op(str_ne, _, _) :- unexpected(this_file, "str_ne").
+convert_binary_op(str_lt, _, _) :- unexpected(this_file, "str_lt").
+convert_binary_op(str_gt, _, _) :- unexpected(this_file, "str_gt").
+convert_binary_op(str_le, _, _) :- unexpected(this_file, "str_le").
+convert_binary_op(str_ge, _, _) :- unexpected(this_file, "str_ge").
+convert_binary_op((<), gcc__le_expr, gcc__boolean_type_node).
+convert_binary_op((>), gcc__gt_expr, gcc__boolean_type_node).
+convert_binary_op((<=), gcc__le_expr, gcc__boolean_type_node).
+convert_binary_op((>=), gcc__ge_expr, gcc__boolean_type_node).
+convert_binary_op(float_plus, gcc__plus_expr, 'MR_Float').
+convert_binary_op(float_minus, gcc__minus_expr, 'MR_Float').
+convert_binary_op(float_times, gcc__mult_expr, 'MR_Float').
+convert_binary_op(float_divide, gcc__trunc_div_expr, 'MR_Float').
+convert_binary_op(float_eq, gcc__eq_expr, gcc__boolean_type_node).
+convert_binary_op(float_ne, gcc__ne_expr, gcc__boolean_type_node).
+convert_binary_op(float_lt, gcc__lt_expr, gcc__boolean_type_node).
+convert_binary_op(float_gt, gcc__gt_expr, gcc__boolean_type_node).
+convert_binary_op(float_le, gcc__le_expr, gcc__boolean_type_node).
+convert_binary_op(float_ge, gcc__ge_expr, gcc__boolean_type_node).
+
+:- pred build_call(gcc__func_decl::in, list(mlds__rval)::in, func_info::in,
+ gcc__expr::out, io__state::di, io__state::uo) is det.
+build_call(FuncDecl, ArgList, FuncInfo, GCC_Call) -->
+ gcc__build_func_addr_expr(FuncDecl, FuncExpr),
+ build_args(ArgList, FuncInfo, GCC_ArgList),
+ { IsTailCall = no },
+ gcc__build_call_expr(FuncExpr, GCC_ArgList, IsTailCall, GCC_Call).
+
+:- pred build_args(list(mlds__rval), func_info, gcc__arg_list,
+ io__state, io__state).
+:- mode build_args(in, in, out, di, uo) is det.
+
+build_args([], _FuncInfo, EmptyArgList) -->
+ gcc__empty_arg_list(EmptyArgList).
+build_args([Arg|Args], FuncInfo, GCC_ArgList) -->
+ build_rval(Arg, FuncInfo, GCC_Expr),
+ build_args(Args, FuncInfo, GCC_ArgList0),
+ gcc__cons_arg_list(GCC_Expr, GCC_ArgList0, GCC_ArgList).
+
+%-----------------------------------------------------------------------------%
+%
+% Code to output constants
+%
+
+:- pred build_rval_const(mlds__rval_const, global_info, gcc__expr,
+ io__state, io__state).
+:- mode build_rval_const(in, in, out, di, uo) is det.
+
+build_rval_const(true, _, Expr) -->
+ % XXX currently we don't use a separate boolean type
+ gcc__build_int(1, Expr).
+build_rval_const(false, _, Expr) -->
+ % XXX currently we don't use a separate boolean type
+ gcc__build_int(0, Expr).
+build_rval_const(int_const(N), _, Expr) -->
+ gcc__build_int(N, Expr).
+build_rval_const(float_const(FloatVal), _, Expr) -->
+ gcc__build_float(FloatVal, Expr).
+build_rval_const(string_const(String), _, Expr) -->
+ gcc__build_string(String, Expr).
+build_rval_const(multi_string_const(Length, String), _, Expr) -->
+ gcc__build_string(Length, String, Expr).
+build_rval_const(code_addr_const(CodeAddr), GlobalInfo, Expr) -->
+ build_code_addr(CodeAddr, GlobalInfo, Expr).
+build_rval_const(data_addr_const(DataAddr), _, Expr) -->
+ build_data_addr(DataAddr, Expr).
+build_rval_const(null(_Type), _, Expr) -->
+ % XXX is it OK to ignore the type here?
+ gcc__build_null_pointer(Expr).
+
+:- pred build_code_addr(mlds__code_addr, global_info, gcc__expr,
+ io__state, io__state).
+:- mode build_code_addr(in, in, out, di, uo) is det.
+
+build_code_addr(CodeAddr, GlobalInfo, Expr) -->
+ (
+ { CodeAddr = proc(Label, Signature) },
+ { MaybeSeqNum = no }
+ ;
+ { CodeAddr = internal(Label, SeqNum, Signature) },
+ { MaybeSeqNum = yes(SeqNum) }
+ ),
+ % convert the label into a entity_name,
+ % so we can use make_func_decl below
+ { Label = qual(ModuleName, PredLabel - ProcId) },
+ { invalid_pred_id(InvalidPredId) },
+ { Name = qual(ModuleName, function(PredLabel, ProcId,
+ MaybeSeqNum, InvalidPredId)) },
+ % build a function declaration for the function,
+ % and take its address.
+ make_func_decl(Name, Signature, GlobalInfo, FuncDecl),
+ gcc__build_func_addr_expr(FuncDecl, Expr).
+
+:- pred build_data_addr(mlds__data_addr, gcc__expr, io__state, io__state).
+:- mode build_data_addr(in, out, di, uo) is det.
+
+build_data_addr(DataAddr, Expr) -->
+ build_data_decl(DataAddr, Decl),
+ gcc__build_addr_expr(gcc__var_expr(Decl), Expr).
+
+:- pred build_data_decl(mlds__data_addr, gcc__var_decl, io__state, io__state).
+:- mode build_data_decl(in, out, di, uo) is det.
+
+build_data_decl(data_addr(ModuleName, DataName), Decl) -->
+ % XXX Bug! Type won't always be 'MR_Word'
+ % XXX Bug! Shouldn't always be extern
+ { VarName = build_data_var_name(ModuleName, DataName) },
+ { Type = 'MR_Word' },
+ gcc__build_extern_var_decl(VarName, Type, Decl).
+
+:- func build_data_var_name(mlds_module_name, mlds__data_name) = string.
+
+build_data_var_name(ModuleName, DataName) =
+ ModuleQualifier ++ build_data_name(DataName) :-
+ (
+ %
+ % don't module-qualify base_typeclass_infos
+ %
+ % We don't want to include the module name as part
+ % of the name if it is a base_typeclass_info, since
+ % we _want_ to cause a link error for overlapping
+ % instance decls, even if they are in a different
+ % module
+ %
+ DataName = base_typeclass_info(_, _)
+ ->
+ ModuleQualifier = ""
+ ;
+ ModuleNameString = get_module_name(
+ mlds_module_name_to_sym_name(ModuleName)),
+ ModuleQualifier = string__append(ModuleNameString, "__")
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Generation of source context info (file name and line number annotations).
+%
+
+:- pred set_context(mlds__context::in, io__state::di, io__state::uo) is det.
+
+set_context(MLDS_Context) -->
+ { ProgContext = mlds__get_prog_context(MLDS_Context) },
+ { FileName = term__context_file(ProgContext) },
+ { LineNumber = term__context_line(ProgContext) },
+ gcc__set_context(FileName, LineNumber).
+
+:- pred gen_context(mlds__context, io__state, io__state).
+:- mode gen_context(in, di, uo) is det.
+
+gen_context(MLDS_Context) -->
+ { ProgContext = mlds__get_prog_context(MLDS_Context) },
+ { FileName = term__context_file(ProgContext) },
+ { LineNumber = term__context_line(ProgContext) },
+ gcc__gen_line_note(FileName, LineNumber).
+
+%-----------------------------------------------------------------------------%
+%
+% "Typedefs", i.e. constants of type `gcc__type'.
+%
+% We use the same names for types as in the MLDS -> C back-end.
+%
+
+:- func 'MR_Box' = gcc__type.
+:- func 'MR_Integer' = gcc__type.
+:- func 'MR_Float' = gcc__type.
+:- func 'MR_Char' = gcc__type.
+:- func 'MR_String' = gcc__type.
+:- func 'MR_ConstString' = gcc__type.
+:- func 'MR_Word' = gcc__type.
+:- func 'MR_PseudoTypeInfo' = gcc__type.
+:- func 'MR_Sectag_Locn' = gcc__type.
+:- func 'MR_TypeCtorRep' = gcc__type.
+
+:- func 'MR_int_least8_t' = gcc__type.
+:- func 'MR_int_least16_t' = gcc__type.
+:- func 'MR_int_least32_t' = gcc__type.
+:- func 'MR_int_least64_t' = gcc__type.
+:- func 'MR_intptr_t' = gcc__type.
+
+'MR_Box' = gcc__ptr_type_node.
+'MR_Integer' = gcc__intptr_type_node.
+'MR_Float' = gcc__double_type_node.
+'MR_Char' = gcc__char_type_node.
+'MR_String' = gcc__string_type_node.
+ % XXX 'MR_ConstString' should really be const
+'MR_ConstString' = gcc__string_type_node.
+ % XXX 'MR_Word' should perhaps be unsigned, to match the C back-end
+'MR_Word' = gcc__intptr_type_node.
+
+'MR_PseudoTypeInfo' = gcc__ptr_type_node.
+
+ % XXX MR_Sectag_Locn and MR_TypeCtorRep are actually enums
+ % in the C back-end. Binary compatibility between this
+ % back-end and the C back-end only works if the C compiler
+ % represents these enums the same as `int'.
+'MR_Sectag_Locn' = gcc__integer_type_node.
+'MR_TypeCtorRep' = gcc__integer_type_node.
+
+'MR_int_least8_t' = gcc__int8_type_node.
+'MR_int_least16_t' = gcc__int16_type_node.
+'MR_int_least32_t' = gcc__int32_type_node.
+'MR_int_least64_t' = gcc__int64_type_node.
+'MR_intptr_t' = gcc__intptr_type_node.
+
+%-----------------------------------------------------------------------------%
+%
+% Utility predicates.
+%
+
+:- pred defn_contains_foreign_code(mlds__defn).
+:- mode defn_contains_foreign_code(in) is semidet.
+
+defn_contains_foreign_code(Defn) :-
+ Defn = mlds__defn(_Name, _Context, _Flags, Body),
+ Body = function(_, _, yes(FunctionBody)),
+ statement_contains_statement(FunctionBody, Statement),
+ Statement = mlds__statement(Stmt, _),
+ Stmt = atomic(target_code(TargetLang, _)),
+ TargetLang \= lang_asm.
+
+ % XXX This should be moved to ml_util.m
+:- pred defn_is_type(mlds__defn).
+:- mode defn_is_type(in) is semidet.
+
+defn_is_type(Defn) :-
+ Defn = mlds__defn(Name, _Context, _Flags, _Body),
+ Name = type(_, _).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "mlds_to_gcc.m".
+
+:- end_module mlds_to_gcc.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: mercury/compiler/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Mmakefile,v
retrieving revision 1.35
diff -u -d -r1.35 Mmakefile
--- mercury/compiler/Mmakefile 2000/12/11 05:38:45 1.35
+++ mercury/compiler/Mmakefile 2000/12/20 11:44:07
@@ -41,9 +42,11 @@
C2INIT = MERCURY_MOD_LIB_MODS="$(LIBRARY_DIR)/$(STD_LIB_NAME).init $(RUNTIME_DIR)/$(RT_LIB_NAME).init" \
MERCURY_TRACE_LIB_MODS="$(BROWSER_DIR)/$(BROWSER_LIB_NAME).init" \
MERCURY_MKINIT=$(UTIL_DIR)/mkinit $(SCRIPTS_DIR)/c2init
+C2INITFLAGS = --library
ML = MERCURY_C_LIB_DIR=. $(SCRIPTS_DIR)/ml
MLFLAGS = --mercury-libs none
-MLLIBS = $(TRACE_DIR)/lib$(TRACE_LIB_NAME).$A \
+MLLIBS = ../main.o \
+ $(TRACE_DIR)/lib$(TRACE_LIB_NAME).$A \
$(BROWSER_DIR)/lib$(BROWSER_LIB_NAME).$A \
$(LIBRARY_DIR)/lib$(STD_LIB_NAME).$A \
$(RUNTIME_DIR)/lib$(RT_LIB_NAME).$A ` \
@@ -81,6 +84,18 @@
CFLAGS-rl_code=-O1
+# The c_code in the module gcc.m needs the header files from the GNU C
+# distribution.
+GCC_SRC_DIR= ../../../..
+CFLAGS-gcc = -DMERCURY_BOOTSTRAP_H \
+ -DIN_GCC -DHAVE_CONFIG_H \
+ -I. \
+ -I$(GCC_SRC_DIR)/gcc \
+ -I$(GCC_SRC_DIR)/gcc/mercury \
+ -I$(GCC_SRC_DIR)/gcc/config \
+ -I$(GCC_SRC_DIR)/include \
+
+
#-----------------------------------------------------------------------------#
# Rules for preprocessing `.pp' files.
@@ -147,11 +162,15 @@
.PHONY: mercury
mercury: mercury_compile
+.PHONY: libmmc
+libmmc: libmercury_compile.a mercury_compile_init.o
+
#-----------------------------------------------------------------------------#
# Add some additional dependencies, so that Mmake knows to remake the
# compiler if one of the libraries changes.
+mercury_compile: ../main.o
mercury_compile: $(RUNTIME_DIR)/lib$(RT_LIB_NAME).$A
mercury_compile: $(LIBRARY_DIR)/lib$(STD_LIB_NAME).$A
mercury_compile: $(BROWSER_DIR)/lib$(BROWSER_LIB_NAME).$A
Index: mercury/main.c
===================================================================
RCS file: main.c
diff -N main.c
--- /dev/null Thu Mar 30 14:06:13 2000
+++ main.c Fri Dec 15 05:56:26 2000
@@ -0,0 +1,35 @@
+/*
+** Copyright (C) 2000 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.
+*/
+
+/*
+** main.c
+**
+** This file defines the main() function for the `compiler/mercury_compile'
+** executable. We define main() separately here,
+** because compiler/mercury_compile is built as a library;
+** this is necessary for the GCC back-end port, where the
+** mercury_compile library is linked together with the
+** GCC back-end into the `cc1mercury' program,
+** whose main() function is defined in gcc/toplev.c.
+**
+** The main() function here just calls mercury_main().
+** mercury_main() is defined in compiler/mercury_compile_init.c,
+** which is automatically generated (by scripts/c2init,
+** which invokes mkinit, whose source is in util/mkinit.c).
+** It initializes the Mercury runtime and then calls the
+** main/2 predicate, which is defined compiler/mercury_compile.m.
+**
+** For general information about the design of the Mercury compiler,
+** see compiler/notes/compiler_design.html.
+*/
+
+extern int mercury_main(int argc, char *argv[]);
+
+int
+main(int argc, char *argv[])
+{
+ return mercury_main(argc, argv);
+}
Index: mercury/Makefile
===================================================================
RCS file: /home/mercury1/repository/mercury/Makefile,v
retrieving revision 1.9
diff -u -d -r1.9 Makefile
--- mercury/Makefile 1998/04/09 03:59:01 1.9
+++ mercury/Makefile 2001/01/01 13:02:11
@@ -28,6 +28,10 @@
all:
$(MMAKE) MMAKEFLAGS=$(PARALLEL) all 2>&1 | tee make_all.log
+.PHONY: libmmc
+libmmc:
+ $(MMAKE) MMAKEFLAGS=$(PARALLEL) libmmc
+
.PHONY: install
install:
$(MMAKE) MMAKEFLAGS=$(PARALLEL) install 2>&1 | tee make_install.log
Index: mercury/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/Mmakefile,v
retrieving revision 1.62
diff -u -d -r1.62 Mmakefile
--- mercury/Mmakefile 2000/12/18 07:14:01 1.62
+++ mercury/Mmakefile 2001/01/01 12:59:30
@@ -136,6 +136,10 @@
compiler: dep_compiler scripts util boehm_gc runtime library browser trace
cd compiler && $(SUBDIR_MMAKE)
+.PHONY: libmmc
+libmmc: dep_compiler scripts util boehm_gc runtime library browser trace
+ cd compiler && $(SUBDIR_MMAKE) libmmc
+
.PHONY: doc
doc: scripts util
cd doc && $(SUBDIR_MMAKE)
Index: mercury/runtime/mercury.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.c,v
retrieving revision 1.18
diff -u -d -r1.18 mercury.c
--- mercury/runtime/mercury.c 2000/12/03 02:22:51 1.18
+++ mercury/runtime/mercury.c 2000/12/31 16:58:26
@@ -942,7 +942,10 @@
#ifdef __GNUC__
-/* provide definitions for functions declared `extern inline' */
+/*
+** Provide definitions for functions declared `extern inline'.
+** Note that this code duplicates the code in mercury.h/mercury_heap.h.
+*/
MR_Word
MR_create1(MR_Word w1)
@@ -974,7 +977,26 @@
return (MR_Word) p;
}
-#endif
+#ifdef MR_AVOID_MACROS
+
+MR_Float *
+MR_box_float(MR_Float f)
+{
+ MR_Float *ptr = (MR_Float *)
+ MR_new_object(MR_Float, sizeof(MR_Float), "float");
+ *ptr = f;
+ return (MR_Box) ptr;
+}
+
+MR_Float
+MR_unbox_float(MR_Box b)
+{
+ return *(MR_Float *)b;
+}
+
+#endif /* MR_AVOID_MACROS */
+
+#endif /* __GNUC__ */
/*---------------------------------------------------------------------------*/
Index: mercury/runtime/mercury_dlist.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_dlist.c,v
retrieving revision 1.5
diff -u -d -r1.5 mercury_dlist.c
--- mercury/runtime/mercury_dlist.c 2000/10/11 03:00:16 1.5
+++ mercury/runtime/mercury_dlist.c 2000/12/15 14:30:44
@@ -20,7 +20,7 @@
MR_Dlist *
MR_dlist_makelist0(void)
{
- reg MR_Dlist *list;
+ MR_Dlist *list;
list = MR_GC_NEW(MR_Dlist);
MR_dlist_data(list) = NULL;
@@ -37,7 +37,7 @@
MR_Dlist *
MR_dlist_makelist(const void *data)
{
- reg MR_Dlist *list;
+ MR_Dlist *list;
MR_assert(data != NULL);
list = MR_dlist_makelist0();
@@ -52,7 +52,7 @@
MR_Dlist *
MR_dlist_addhead(MR_Dlist *list, const void *data)
{
- reg MR_Dlist *item;
+ MR_Dlist *item;
if (list == NULL) {
list = MR_dlist_makelist0();
@@ -79,7 +79,7 @@
MR_Dlist *
MR_dlist_addtail(MR_Dlist *list, const void *data)
{
- reg MR_Dlist *item;
+ MR_Dlist *item;
if (list == NULL) {
list = MR_dlist_makelist0();
@@ -151,7 +151,7 @@
MR_Dlist *
MR_dlist_addndlist(MR_Dlist *list1, MR_Dlist *list2)
{
- reg MR_Dlist *ptr;
+ MR_Dlist *ptr;
if (list1 == NULL) {
list1 = MR_dlist_makelist0();
@@ -175,7 +175,7 @@
void
MR_dlist_insert_before(MR_Dlist *list, MR_Dlist *where, const void *data)
{
- reg MR_Dlist *item;
+ MR_Dlist *item;
item = MR_GC_NEW(MR_Dlist);
MR_dlist_data(item) = data;
@@ -196,7 +196,7 @@
void
MR_dlist_insert_after(MR_Dlist *list, MR_Dlist *where, const void *data)
{
- reg MR_Dlist *item;
+ MR_Dlist *item;
item = MR_GC_NEW(MR_Dlist);
MR_dlist_data(item) = data;
@@ -264,8 +264,8 @@
void
MR_dlist_oldlist(MR_Dlist *list, void (* func)(const void *))
{
- reg MR_Dlist *ptr;
- reg MR_Dlist *item;
+ MR_Dlist *ptr;
+ MR_Dlist *item;
if (list == NULL) {
return;
Index: mercury/runtime/mercury.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.29
diff -u -d -r1.29 mercury.h
--- mercury/runtime/mercury.h 2000/12/14 16:43:24 1.29
+++ mercury/runtime/mercury.h 2000/12/31 16:59:09
@@ -318,6 +318,7 @@
/*
** Code to box/unbox floats
**
+** Note that this code is also duplicated in mercury.c.
** XXX we should optimize the case where sizeof(MR_Float) == sizeof(MR_Box)
*/
Index: mercury/runtime/mercury_hash_table.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_hash_table.c,v
retrieving revision 1.3
diff -u -d -r1.3 mercury_hash_table.c
--- mercury/runtime/mercury_hash_table.c 2000/10/11 03:00:17 1.3
+++ mercury/runtime/mercury_hash_table.c 2000/12/15 14:31:21
@@ -27,7 +27,7 @@
void
MR_ht_init_table(MR_Hash_Table *table)
{
- reg int i;
+ int i;
table->MR_ht_store = MR_GC_NEW_ARRAY(MR_Dlist *, table->MR_ht_size);
@@ -44,8 +44,8 @@
const void *
MR_ht_lookup_table(const MR_Hash_Table *table, const void *key)
{
- reg MR_Dlist *ptr;
- reg int h;
+ MR_Dlist *ptr;
+ int h;
h = MR_tablehash(table)(key);
@@ -76,9 +76,9 @@
bool
MR_ht_insert_table(const MR_Hash_Table *table, void *entry)
{
- reg MR_Dlist *ptr;
- reg const void *key;
- reg int h;
+ MR_Dlist *ptr;
+ const void *key;
+ int h;
key = MR_tablekey(table)(entry);
h = MR_tablehash(table)(key);
@@ -110,8 +110,8 @@
MR_Dlist *
MR_ht_get_all_entries(const MR_Hash_Table *table)
{
- reg MR_Dlist *list;
- reg int i;
+ MR_Dlist *list;
+ int i;
list = MR_dlist_makelist0();
for (i = 0; i < table->MR_ht_size; i++) {
@@ -128,8 +128,8 @@
void
MR_ht_process_all_entries(const MR_Hash_Table *table, void f(const void *))
{
- reg MR_Dlist *ptr;
- reg int i;
+ MR_Dlist *ptr;
+ int i;
for (i = 0; i < table->MR_ht_size; i++) {
MR_for_dlist (ptr, table->MR_ht_store[i]) {
@@ -146,8 +146,8 @@
int
MR_ht_str_to_int(const char *cs)
{
- reg int h;
- reg const char *s;
+ int h;
+ const char *s;
s = cs;
for (h = 0; *s != '\0'; s++) {
Index: mercury/runtime/mercury_heap.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_heap.h,v
retrieving revision 1.18
diff -u -d -r1.18 mercury_heap.h
--- mercury/runtime/mercury_heap.h 2000/11/24 06:03:36 1.18
+++ mercury/runtime/mercury_heap.h 2000/12/31 16:59:49
@@ -178,6 +178,10 @@
#ifdef MR_HIGHLEVEL_CODE
+/*
+** Note that this code is also duplicated in mercury.c.
+*/
+
MR_EXTERN_INLINE MR_Word MR_create1(MR_Word w1);
MR_EXTERN_INLINE MR_Word MR_create2(MR_Word w1, MR_Word w2);
MR_EXTERN_INLINE MR_Word MR_create3(MR_Word w1, MR_Word w2, MR_Word w3) ;
Index: mercury/runtime/mercury_stacks.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_stacks.h,v
retrieving revision 1.26
diff -u -d -r1.26 mercury_stacks.h
--- mercury/runtime/mercury_stacks.h 2000/12/13 06:06:16 1.26
+++ mercury/runtime/mercury_stacks.h 2000/12/15 14:30:09
@@ -109,8 +109,8 @@
#define MR_mkframe(predname, numslots, redoip) \
do { \
- reg MR_Word *prevfr; \
- reg MR_Word *succfr; \
+ MR_Word *prevfr; \
+ MR_Word *succfr; \
\
prevfr = MR_maxfr; \
succfr = MR_curfr; \
@@ -132,8 +132,8 @@
/* with the given tag at the bottom of the nondet stack frame */
#define MR_mkpragmaframe(predname, numslots, structname, redoip) \
do { \
- reg MR_Word *prevfr; \
- reg MR_Word *succfr; \
+ MR_Word *prevfr; \
+ MR_Word *succfr; \
\
prevfr = MR_maxfr; \
succfr = MR_curfr; \
@@ -151,7 +151,7 @@
#define MR_mktempframe(redoip) \
do { \
- reg MR_Word *prevfr; \
+ MR_Word *prevfr; \
\
prevfr = MR_maxfr; \
MR_maxfr += MR_NONDET_TEMP_SIZE; \
@@ -163,7 +163,7 @@
#define MR_mkdettempframe(redoip) \
do { \
- reg MR_Word *prevfr; \
+ MR_Word *prevfr; \
\
prevfr = MR_maxfr; \
MR_maxfr += MR_DET_TEMP_SIZE; \
@@ -175,7 +175,7 @@
} while (0)
#define MR_succeed() do { \
- reg MR_Word *childfr; \
+ MR_Word *childfr; \
\
MR_debugsucceed(); \
childfr = MR_curfr; \
@@ -185,7 +185,7 @@
#define MR_succeed_discard() \
do { \
- reg MR_Word *childfr; \
+ MR_Word *childfr; \
\
MR_debugsucceeddiscard(); \
childfr = MR_curfr; \
Index: mercury/runtime/mercury_std.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_std.h,v
retrieving revision 1.15
diff -u -d -r1.15 mercury_std.h
--- mercury/runtime/mercury_std.h 2000/12/03 02:22:53 1.15
+++ mercury/runtime/mercury_std.h 2001/01/03 13:41:43
@@ -14,10 +14,23 @@
#include <stdlib.h> /* for size_t */
#include <assert.h> /* for assert() */
-#include <ctype.h> /* for isalnum(), etc. */
+#ifndef IN_GCC
+ #include <ctype.h> /* for isalnum(), etc. */
+#else
+ /*
+ ** When building compiler/gcc.m, we #include GCC back-end
+ ** header files that include libiberty's "safe-ctype.h",
+ ** and we can't include both safe-ctype.h and ctype.h,
+ ** since they conflict, so include safe-ctype.h
+ ** rather than ctype.h.
+ */
+ #include "safe-ctype.h"
+#endif
+#if 0
#ifndef reg
#define reg register
+#endif
#endif
#ifndef bool
#define bool char
Index: gcc/mercury/ChangeLog
===================================================================
RCS file: ChangeLog
diff -N ChangeLog
--- /dev/null Thu Mar 30 14:06:13 2000
+++ /tmp/cvssRzvtF Fri Jan 5 17:48:18 2001
@@ -0,0 +1,4 @@
+2000-11-26 Fergus Henderson <fjh at cs.mu.oz.au>
+
+ Initial version.
+
Index: gcc/mercury/Make-lang.in
===================================================================
RCS file: Make-lang.in
diff -N Make-lang.in
--- /dev/null Thu Mar 30 14:06:13 2000
+++ Make-lang.in Fri Jan 5 16:58:37 2001
@@ -0,0 +1,276 @@
+# Top level makefile fragment for Mercury.
+# Copyright (C) 2000 Fergus Henderson
+# Copyright (C) 1999, 2000 Tim Josling
+# Copyright (C) 1994, 1995, 1997, 1998, 1999 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# This file provides the language dependent support in the main Makefile.
+# Each language makefile fragment must provide the following targets:
+#
+# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap,
+# foo.info, foo.dvi,
+# foo.install-normal, foo.install-common, foo.install-info, foo.install-man,
+# foo.uninstall, foo.distdir,
+# foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean,
+# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
+#
+# where `foo' is the name of the language.
+#
+# It should also provide rules for:
+#
+# - making any compiler driver (eg: gcc)
+# - the compiler proper (eg: mercury)
+# - define the names for selecting the language in LANGUAGES.
+#
+
+# The directory for the Mercury source distribution
+MERCURY_FRONT_END_SRC_DIR = mercury/mercury
+
+# Libraries from the Mercury compiler front-end,
+# standard library, and runtime system that we need.
+MERCURY_FRONT_END_LIBS = \
+ $(MERCURY_FRONT_END_SRC_DIR)/compiler/mercury_compile_init.o \
+ $(MERCURY_FRONT_END_SRC_DIR)/compiler/libmercury_compile.a \
+ $(MERCURY_FRONT_END_SRC_DIR)/browser/libmer_browser.a \
+ $(MERCURY_FRONT_END_SRC_DIR)/trace/libmer_trace.a \
+ $(MERCURY_FRONT_END_SRC_DIR)/library/libmer_std.a \
+ $(MERCURY_FRONT_END_SRC_DIR)/runtime/libmer_rt.a \
+ $(MERCURY_FRONT_END_SRC_DIR)/boehm_gc/libgc.a
+
+# Additional C libraries that we need to link in
+# because they are needed by the libraries listed above.
+MERCURY_C_LIBS = -lm
+# If Mercury debugging is enabled, you may need this instead:
+MERCURY_C_LIBS = -lnsl -ldl -lreadline -lncurses -lm
+
+ML = MERCURY_LIBS="$(MERCURY_FRONT_END_LIBS)" ml
+MLFLAGS =
+ALL_MLFLAGS = $(MLFLAGS) $(EXTRA_MLFLAGS)
+
+# Libraries from the GNU back-end that we need.
+MERCURY_BACK_END_LIBS = toplev.o libbackend.a \
+ $(LIBIBERTY) $(INTLLIBS) $(LIBS) $(LIBDEPS)
+
+# List any automatically generated files, e.g.
+# MERCURY_GENERATED = $(srcdir)/mercury/parse.c
+MERCURY_GENERATED =
+
+MERCURY_EXES = mercury/cc1mercury$(exeext)
+
+# specify additional GCC warning options here
+# The following are enabled by default (see LOOSE_WARN in ../Makefile.in):
+# -W -Wall -Wwrite-strings -Wstrict-prototypes -Wmissing-prototypes
+mercury-warn = -Wtraditional -pedantic # -Wno-long-long
+
+#
+# Define the names for selecting mercury in LANGUAGES.
+
+# the real thing
+
+.PHONY: mercury MERCURY
+
+mercury MERCURY: mercury/cc1mercury$(exeext) mercury/testmercury$(exeext)
+
+mercury/cc1mercury$(exeext): mercury/mercury-gcc.o $(OBJDEPS) $(LIBDEPS) \
+ c-convert.o $(MERCURY_FRONT_END_LIBS) $(MERCURY_BACK_END_LIBS)
+ @echo mercury objs = $(OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) mercury/mercury-gcc.o c-convert.o \
+ $(OBJS) $(MERCURY_BACK_END_LIBS) $(MERCURY_FRONT_END_LIBS) \
+ $(MERCURY_C_LIBS) \
+ -o $@
+ @# The code above uses the C compiler to do the linking.
+ @# Another alternative would be to use the Mercury linker instead:
+ @# $(ML) $(ALL_MLFLAGS) $(ALL_CFLAGS) $(LDFLAGS) \
+ @ mercury/mercury-gcc.o c-convert.o \
+ @ $(OBJS) $(MERCURY_BACK_END_LIBS) -o $@
+
+mercury/testmercury$(exeext): mercury/testmercury.o mercury/test.o
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) mercury/testmercury.o mercury/test.o \
+ -o $@
+
+# Ensure that we build the Mercury compiler front-end library
+# before linking cc1mercury.
+# XXX This is commented out, since currently it doesn't work
+# properly -- somehow we end up passing the wrong CFLAGS,
+# because the Mercury make inherits the CFLAGS from the gcc make,
+# which are wrong for building Mercury.
+#
+# $(MERCURY_FRONT_END_LIBS) : libmmc
+#
+# .PHONY: libmmc
+# libmmc:
+# cd $(MERCURY_FRONT_END_SRC_DIR) && make libmmc
+#
+# $(MERCURY_FRONT_END_SRC_DIR)/compiler/mercury_compile_init.o :
+# true
+
+#
+# Compiling object files from source files.
+
+# Note that dependencies on obstack.h are not written
+# because that file is not part of GCC.
+
+# object file makes
+mercury/mercury-gcc.o: \
+ $(srcdir)/mercury/mercury-gcc.c \
+ $(srcdir)/mercury/mercury-gcc.h \
+ $(CONFIG_H) gansidecl.h $(TREE_H) flags.h output.h \
+ c-lex.h c-tree.h $(RTL_H) tm_p.h $(GGC_H) toplev.h
+ $(CC) -o $@ -c $(ALL_CFLAGS) $(INCLUDES) $<
+
+#main to test generated program
+mercury/testmercury.o: $(srcdir)/mercury/testmercury.c $(CONFIG_H)
+ $(CC) -o $@ -c $(ALL_CFLAGS) $(INCLUDES) $<
+
+#generated program
+mercury/test.o: mercury/test.s
+ $(CC) -o $@ -c $(ALL_CFLAGS) $(INCLUDES) $<
+
+#generate the code
+mercury/test.s: mercury/cc1mercury$(exeext) $(srcdir)/mercury/test.m
+ ./mercury/cc1mercury$(exeext) -quiet -g -O2 \
+ --mmc-flag=-I$(MERCURY_FRONT_END_SRC_DIR)/library \
+ --mmc-flag=-O2 $(srcdir)/mercury/test.m -o $@
+
+$(INTL_TARGETS):
+
+#
+# Build hooks:
+
+mercury.all.build: mercury
+mercury.all.cross:
+ _error_not_here_yet - havent even thought about it - it may even work
+
+mercury.start.encap:
+mercury.rest.encap:
+
+mercury.info:
+mercury.dvi:
+
+#
+# Install hooks:
+
+# Nothing to do here.
+mercury.install-normal:
+
+mercury.install-common: mercury
+ echo `pwd`
+ for name in $(MERCURY_EXES); \
+ do \
+ echo $$name; \
+ if [ -f $$name$(exeext) ] ; then \
+ echo found $$name; \
+ name2="`echo \`basename $$name\` | sed -e '$(program_transform_name)' `"; \
+ echo becomes $$name2; \
+ rm -f $(bindir)/$$name2$(exeext); \
+ $(INSTALL_PROGRAM) $$name$(exeext) $(bindir)/$$name2$(exeext); \
+ chmod a+x $(bindir)/$$name2$(exeext); \
+ fi ; \
+ done
+
+
+mercury.install-info:
+
+mercury.install-man:
+
+mercury.uninstall:
+ for name in $(MERCURY_EXES); \
+ do \
+ echo $$name; \
+ name2="`echo $$name | sed -e '$(program_transform_name)' `"; \
+ echo becomes $$name2; \
+ echo -rm -rf $(bindir)/$$name2$(exeext); \
+ rm -rf $(bindir)/$$name2$(exeext); \
+ done
+
+#
+# Clean hooks:
+# A lot of the ancillary files are deleted by the main makefile.
+# We just have to delete files specific to us.
+
+mercury.mostlyclean:
+ for name in $(MERCURY_EXES); \
+ do \
+ echo deleting $$name; \
+ if [ -f mercury/$$name$(exeext) ] ; then \
+ rm -f mercury/$$name$(exeext); \
+ fi ; \
+ done
+ -rm -f mercury/*.o
+
+
+mercury.clean:
+
+mercury.distclean:
+ -rm -f mercury/config.status mercury/Makefile
+ -rm -f mercury/*.output
+
+mercury.extraclean:
+
+mercury.maintainer-clean:
+ for name in $(MERCURY_GENERATED); \
+ do \
+ if [ -f $(srcdir)/mercury/$$name ] ; then \
+ echo deleting $(srcdir)/mercury/$$name; \
+ rm -f $(srcdir)/mercury/$$name; \
+ fi ; \
+ done
+
+
+#
+# Stage hooks:
+# The main makefile has already created stage?/mercury.
+
+mercury.stage1: stage1-start
+ -mv mercury/*$(objext) stage1/mercury
+mercury.stage2: stage2-start
+ -mv mercury/*$(objext) stage2/mercury
+mercury.stage3: stage3-start
+ -mv mercury/*$(objext) stage3/mercury
+mercury.stage4: stage4-start
+ -mv mercury/*$(objext) stage4/mercury
+#
+# Maintenance hooks:
+
+# This target creates the files that can be rebuilt, but go in the
+# distribution anyway. It then copies the files to the distdir directory.
+mercury.distdir:
+
+#tests
+
+check: check-mercury
+
+check-mercury: testsuite/site.exp mercury/testmercury$(exeext)
+ -mkdir testsuite/mercury
+ -rootme=`pwd`; export rootme; \
+ srcdir=`cd ${srcdir}; pwd` ; export srcdir ; \
+ cd testsuite; \
+ EXPECT=${EXPECT} ; export EXPECT ; \
+ TRANSFORM=$(program_transform_name); export TRANSFORM; \
+ if [ -f $${rootme}/../expect/expect ] ; then \
+ TCL_LIBRARY=`cd .. ; cd ${srcdir}/../tcl/library ; pwd` ; \
+ export TCL_LIBRARY ; fi ; \
+ $(RUNTEST) --tool mercury $(RUNTESTFLAGS)
+
+# copy the output files from the current test to source
+# i.e. say the new results are OK
+check-mercury-fix: force
+ srcdir=`cd ${srcdir}; pwd` ; export srcdir ;
+ -cp testsuite/mercury/*.out* ${srcdir}/testsuite/mercury
+
Index: gcc/mercury/Makefile
===================================================================
RCS file: Makefile
diff -N Makefile
--- /dev/null Thu Mar 30 14:06:13 2000
+++ Makefile Sun Dec 31 00:02:43 2000
@@ -0,0 +1,24 @@
+all: mercury
+
+mercury: force
+ cd ..; make mercury
+
+cc1mercury: force
+ cd ..; make mercury/cc1mercury
+
+check: force
+ cd ..; make check-mercury
+
+.PHONY: force
+force:
+
+BACKUPDIR := $$HOME/src/mercury/back-$(shell date +%Y-%m-%d)
+
+backup:
+ echo $(BACKUPDIR)
+ [ -d $(BACKUPDIR) ] || mkdir $(BACKUPDIR)
+ cp Make-lang.in Makefile README config-lang.in \
+ test.m test.mer testmercury.c \
+ mercury-gcc.h mercury-gcc.c \
+ mercury/compiler/gcc.m mercury/compiler/mlds_to_gcc.m $(BACKUPDIR)
+ cp mercury/cvd.out $(BACKUPDIR)
Index: gcc/mercury/Mmakefile
===================================================================
RCS file: Mmakefile
diff -N Mmakefile
--- /dev/null Thu Mar 30 14:06:13 2000
+++ Mmakefile Fri Jan 5 17:08:30 2001
@@ -0,0 +1,41 @@
+# RM_C = echo
+# MCFLAGS = --target asm
+MCFLAGS = --no-line-numbers
+
+hello.cs =
+calculator.cs =
+tak.cs =
+query.cs =
+queens.cs =
+n.cs =
+c.cs =
+eliza.cs =
+interpreter.cs =
+
+GRADE = hlc.gc
+
+
+GCC = ../xgcc -B./ -B../
+CC = $(GCC)
+
+GMCFLAGS = --mmc-flag=-I../../mercury/library
+# GMCFLAGS += -O2 -fomit-frame-pointer
+GMCFLAGS += -save-temps -g
+GMCFLAGS += --mmc-flag=-O0
+MCFLAGS += -O0
+#GMCFLAGS += --mmc-flag=--no-static-ground-terms
+#MCFLAGS += --no-static-ground-terms
+MLFLAGS = -g
+MGNUCFLAGS = -v
+
+GMCFLAGS += --mmc-flag=--infer-all
+MCFLAGS += --infer-all
+
+%.o : %.m cc1mercury Mmakefile
+ $(GCC) -x mercury $(GMCFLAGS) -c $<
+
+%.s : %.m cc1mercury Mmakefile
+ $(GCC) -x mercury $(GMCFLAGS) -S $<
+
+%.s0 : %.c
+ MERCURY_C_COMPILER="$(CC)" $(MGNUC) $(ALL_GRADEFLAGS) $(ALL_MGNUCFLAGS) -S $< -o $@
Index: gcc/mercury/README
===================================================================
RCS file: README
diff -N README
--- /dev/null Thu Mar 30 14:06:13 2000
+++ README Fri Jan 5 17:28:37 2001
@@ -0,0 +1,13 @@
+GCC front end code for Mercury.
+See <http://www.cs.mu.oz.au/mercury/> for more info on Mercury.
+
+Put into the subdirectory gcc/mercury/
+
+To test the output
+
+ cd gcc
+ make mercury
+
+Unfortunately the Objective C people stole the `.m' extension,
+so to compile Mercury programs with gcc, you need to use the
+`-x mercury' option.
Index: gcc/mercury/config-lang.in
===================================================================
RCS file: config-lang.in
diff -N config-lang.in
--- /dev/null Thu Mar 30 14:06:13 2000
+++ /tmp/cvsZdXtQJ Fri Jan 5 17:49:15 2001
@@ -0,0 +1,21 @@
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language - name of language as it would appear in $(LANGUAGES)
+# compilers - value to add to $(COMPILERS)
+# stagestuff - files to add to $(STAGESTUFF)
+# diff_excludes - files to ignore when building diffs between two versions.
+
+language="mercury"
+
+compilers="cc1mercury\$(exeext)"
+
+stagestuff="cc1mercury"
+
+# diff_excludes="-x parse.tab.c"
+diff_excludes=
+
+headers=
+
+#outputs=mercury/Makefile
+
Index: gcc/mercury/lang-options.h
===================================================================
RCS file: lang-options.h
diff -N lang-options.h
--- /dev/null Thu Mar 30 14:06:13 2000
+++ /tmp/cvsmju4ca Fri Jan 5 17:49:15 2001
@@ -0,0 +1,26 @@
+/* Switch definitions for the GNU compiler for the Mercury language.
+ Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* This is the contribution to the `documented_lang_options' array
+ in toplev.c for Mercury. */
+
+DEFINE_LANG_NAME ("Mercury")
+
+ { "--mmc-flag= ", "Pass specified option to the Mercury compiler" },
Index: gcc/mercury/lang-specs.h
===================================================================
RCS file: lang-specs.h
diff -N lang-specs.h
--- /dev/null Thu Mar 30 14:06:13 2000
+++ lang-specs.h Thu Dec 28 10:32:37 2000
@@ -0,0 +1,28 @@
+/* Definitions for specs for the GNU compiler for the Mercury language.
+ Copyright (C) 1996, 1998, 1999, 2000 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* This is the contribution to the `default_compilers' array in gcc.c for
+ Mercuyy. */
+
+ {".mer", "@mercury" },
+ {".m", "@mercury" },
+ {"@mercury",
+ "%{!E:cc1mercury %i %(cc1mercury) %(cc1_options) %{I*}\
+ %{!fsyntax-only:%(invoke_as)}}"},
Index: gcc/mercury/mercury-gcc.c
===================================================================
RCS file: mercury-gcc.c
diff -N mercury-gcc.c
--- /dev/null Thu Mar 30 14:06:13 2000
+++ /tmp/cvssNXVTN Fri Jan 5 17:49:16 2001
@@ -0,0 +1,1639 @@
+/* mercury-gcc.c: Mercury language front-end.
+ Copyright (C) 2001 Fergus Henderson.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* This file contains part of the Mercury language front-end
+ of the GNU compiler collection, specifically the part
+ that is implemented in C. Most of the Mercury language
+ front-end is implemented in Mercury -- see the files
+ compiler/gcc.m and compiler/mlds_to_gcc.m in the Mercury
+ distribution.
+
+ For more information about Mercury, see the Mercury web site
+ <http://www.cs.mu.oz.au/mercury/>.
+
+ Naming convention: all variables and functions in this front-end
+ have names starting with `merc_', except for hooks required by GCC,
+ which have the name that GCC expects. */
+
+/* Implemented by Fergus Henderson <fjh at cs.mu.oz.au> December 2000. */
+
+#include "config.h"
+#include "system.h"
+#include "gansidecl.h"
+#include "tree.h"
+#include "flags.h"
+#include "output.h" /* For make_function_rtl(). */
+/* XXX we should avoid the dependency on `c-*.h'. */
+#include "c-lex.h"
+#include "c-tree.h"
+#include "rtl.h" /* For MD_INIT_BUILTINS. */
+#include "tm_p.h" /* For MD_INIT_BUILTINS. */
+#include "ggc.h"
+#include "toplev.h"
+#include "diagnostic.h"
+
+#include "mercury-gcc.h"
+
+#include <stdio.h>
+#include <assert.h>
+
+/*---------------------------------------------------------------------------*/
+
+static const char * snapshot_version ATTRIBUTE_UNUSED
+ = "for GCC weekly snapshot 20001030";
+
+/*---------------------------------------------------------------------------*/
+
+/* Declarations of functions defined elsewhere. */
+
+extern int mercury_main PARAMS((int argc, const char *argv[]));
+
+/* Declarations of functions defined in this file. */
+
+static tree merc_convert PARAMS((tree type, tree expr));
+static void merc_init_builtin_functions PARAMS((void));
+static void merc_handle_fatal_error PARAMS((const char *msg, va_list *args));
+
+/*---------------------------------------------------------------------------*/
+
+/* Global variables defined elsewhere. */
+
+extern char **save_argv; /* in toplev.c */
+
+/* Global Variables for the various types and nodes we create. */
+
+/* Declaration nodes for builtin functions: */
+tree merc_alloc_function_node; /* GC_malloc() */
+tree merc_strcmp_function_node; /* strcmp() */
+tree merc_hash_string_function_node; /* MR_hash_string() */
+tree merc_box_float_function_node; /* MR_box_float() */
+tree merc_setjmp_function_node; /* __builtin_setjmp() */
+tree merc_longjmp_function_node; /* __builtin_longjmp() */
+
+/* Declaration nodes for builtin types: */
+tree merc_int8_type_node; /* int8_t */
+tree merc_int16_type_node; /* int16_t */
+tree merc_int32_type_node; /* int32_t */
+tree merc_int64_type_node; /* int64_t */
+tree merc_intptr_type_node; /* intptr_t */
+tree merc_jmpbuf_type_node; /* __builtin_jmpbuf i.e. void *[5] */
+
+/* The filename of the source file that we're going to parse. */
+static const char *merc_filename;
+
+/* A linked list of options to pass to the Mercury compiler front-end. */
+struct merc_option_list {
+ const char *value;
+ struct merc_option_list *next;
+};
+static struct merc_option_list *merc_option_list_head = NULL;
+static struct merc_option_list *merc_option_list_last = NULL;
+
+/* Options controlling the sizes of certain C types. */
+static int merc_flag_short_double = 0;
+static int merc_flag_short_wchar = 0;
+
+/*---------------------------------------------------------------------------*/
+
+/* Global Variables Expected by gcc: */
+
+const char * const language_string = "Mercury";
+
+int flag_traditional; /* Used by dwarfout.c. */
+
+#define NULL_BINDING_LEVEL (struct binding_level *) NULL
+
+/* The elements of `ridpointers' are identifier nodes
+ for the reserved type names and storage classes.
+ It is indexed by a RID_... value. */
+tree *ridpointers = NULL;
+
+tree global_trees[TI_MAX];
+tree c_global_trees[CTI_MAX];
+tree current_function_decl;
+
+int ggc_p = 1; /* yes - garbage collection */
+
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+
+/*
+** Functions for processing declarations
+*/
+
+/* Make a PARAM_DECL for a parameter whose name is NAME,
+ and whose type is TYPE. */
+
+tree
+merc_build_param_decl (param_name, param_type)
+ const char *param_name;
+ tree param_type;
+{
+ tree parm_decl = build_decl (PARM_DECL, get_identifier (param_name),
+ param_type);
+ DECL_ARG_TYPE (parm_decl) = param_type;
+ return parm_decl;
+}
+
+/* Make a VAR_DECL for an extern variable whose name is VAR_NAME,
+ and whose type is VAR_TYPE. */
+
+tree
+merc_build_extern_var_decl (var_name, var_type)
+ const char *var_name;
+ tree var_type;
+{
+ tree var_decl = build_decl (VAR_DECL, get_identifier (var_name),
+ var_type);
+ DECL_EXTERNAL (var_decl) = 1;
+ layout_decl (var_decl, /*known_align=*/0);
+ rest_of_decl_compilation (var_decl, /*asm_spec=*/NULL_PTR,
+ /*toplevel=*/1, /*at_end=*/0);
+ return var_decl;
+}
+
+/* Make a VAR_DECL for an extern variable whose name is VAR_NAME,
+ and whose type is VAR_TYPE. */
+
+tree
+merc_build_global_var_decl (var_name, var_type, initializer)
+ const char *var_name;
+ tree var_type;
+ tree initializer;
+{
+ tree var_decl = build_decl (VAR_DECL, get_identifier (var_name),
+ var_type);
+ DECL_INITIAL (var_decl) = fold (initializer);
+ TREE_PUBLIC (var_decl) = 1;
+ TREE_STATIC (var_decl) = 1;
+ layout_decl (var_decl, /*known_align=*/0);
+ rest_of_decl_compilation (var_decl, /*asm_spec=*/NULL_PTR,
+ /*toplevel=*/1, /*at_end=*/0);
+ return var_decl;
+}
+
+/* Make a VAR_DECL for a local variable whose name is VAR_NAME,
+ and whose type is VAR_TYPE. */
+
+tree
+merc_build_local_var_decl (var_name, var_type)
+ const char *var_name;
+ tree var_type;
+{
+ tree var_decl = build_decl (VAR_DECL, get_identifier (var_name),
+ var_type);
+ expand_decl (var_decl);
+ return var_decl;
+}
+
+/* Make an empty parameter list. */
+
+tree
+merc_empty_param_list ()
+{
+ return NULL_TREE;
+}
+
+/* Cons a new parameter PARM_DECL onto a parameter list PARAM_LIST. */
+
+tree
+merc_cons_param_list (param_decl, param_list)
+ tree param_decl;
+ tree param_list;
+{
+ return chainon (param_decl, param_list);
+}
+
+/* Make an empty parameter type list. */
+
+tree
+merc_empty_param_type_list ()
+{
+ return tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+}
+
+/* Cons a new parameter type PARAM_TYPE onto
+ a parameter type list PARAM_TYPE_LIST. */
+
+tree
+merc_cons_param_type_list (param_type, param_type_list)
+ tree param_type;
+ tree param_type_list;
+{
+ return tree_cons (NULL_TREE, param_type, param_type_list);
+}
+
+/* Make a FUNCTION_DECL for a function whose name is NAME,
+ whose parameter types are given in the list PARAM_TYPE_LIST,
+ and whose parameters are given in PARAM_LIST. */
+
+tree
+merc_build_function_decl (name, asm_name,
+ return_type, param_type_list, param_list)
+ const char *name;
+ const char *asm_name;
+ tree return_type;
+ tree param_type_list;
+ tree param_list;
+{
+ tree fntype;
+ tree fndecl;
+
+ /* The function type depends on the return type and type of args. */
+ fntype = build_function_type (return_type, param_type_list);
+
+ /* Now make the function decl. */
+ fndecl = build_decl (FUNCTION_DECL, get_identifier (name), fntype);
+ DECL_ASSEMBLER_NAME (fndecl) = get_identifier (asm_name);
+ DECL_EXTERNAL (fndecl) = 0;
+ TREE_PUBLIC (fndecl) = 1;
+ TREE_STATIC (fndecl) = 1;
+ DECL_ARGUMENTS (fndecl) = param_list;
+ DECL_RESULT (fndecl)
+ = build_decl (RESULT_DECL, NULL_TREE, return_type);
+ DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
+
+ rest_of_decl_compilation (fndecl, NULL_PTR, 1, 0);
+ return fndecl;
+}
+
+/* Make a FIELD_DECL for a field whose name is NAME,
+ and whose type is TYPE. */
+
+tree
+merc_build_field_decl (field_name, field_type)
+ const char *field_name;
+ tree field_type;
+{
+ return build_decl (FIELD_DECL, get_identifier (field_name), field_type);
+}
+
+/* Make an empty field list. */
+
+tree
+merc_empty_field_list ()
+{
+ return NULL_TREE;
+}
+
+/* Cons a new field FIELD_DECL onto a field list FIELD_LIST. */
+
+tree
+merc_cons_field_list (field_decl, field_list)
+ tree field_decl;
+ tree field_list;
+{
+ return chainon (field_decl, field_list);
+}
+
+/* Make a TYPE_DECL node with a RECORD_TYPE type,
+ for a struct type whose name is NAME,
+ and whose fields are given in the list FIELD_DECLS. */
+
+tree
+merc_build_struct_type_decl (name, field_decls)
+ const char *name;
+ tree field_decls;
+{
+ tree decl;
+ tree type;
+ tree field;
+
+ type = make_node (RECORD_TYPE);
+ for (field = field_decls; field; field = TREE_CHAIN (field))
+ DECL_CONTEXT (field) = type;
+ TYPE_FIELDS (type) = field_decls;
+
+#if 0
+ /* Create a fake NULL-named TYPE_DECL node whose TREE_TYPE will be the
+ tagged type we just added to the current binding level. This fake
+ NULL-named TYPE_DECL node helps dwarfout.c to know when it needs
+ to output a representation of a tagged type, and it also gives
+ us a convenient place to record the "scope start" address for the
+ tagged type. */
+
+ TYPE_STUB_DECL (type) = pushdecl (build_decl (TYPE_DECL, NULL_TREE, type));
+#endif
+
+ decl = build_decl (TYPE_DECL, get_identifier (name), type);
+
+ TYPE_NAME (type) = decl;
+ TYPE_STUB_DECL (type) = decl;
+ layout_type (type);
+ rest_of_type_compilation (type, /*toplev=*/1);
+
+ return decl;
+}
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** Functions for processing expressions
+*/
+
+tree
+merc_build_string (len, chars)
+ int len;
+ const char *chars;
+{
+ tree string;
+ tree string_addr;
+
+ string = build_string (len, chars);
+ TREE_TYPE (string)
+ = build_array_type (char_type_node,
+ build_index_type (build_int_2 (len, 0)));
+ TREE_CONSTANT (string) = 1;
+ TREE_STATIC (string) = 1;
+
+ string_addr = build1 (ADDR_EXPR, string_type_node, string);
+ return string_addr;
+}
+
+/* Make an empty expression list. */
+
+tree
+merc_empty_arg_list ()
+{
+ return NULL_TREE;
+}
+
+/* Cons a new argument expression ARG onto an argument list ARG_LIST. */
+
+tree
+merc_cons_arg_list (arg, arg_list)
+ tree arg;
+ tree arg_list;
+{
+ return tree_cons (NULL_TREE, arg, arg_list);
+}
+
+/* Make an empty initializer list. */
+
+tree
+merc_empty_init_list ()
+{
+ return NULL_TREE;
+}
+
+/* Create a new initializer to initialize the field or
+ array element at index ELEM with the expression EXPR,
+ and cons this initializer onto the initializer list INIT_LIST. */
+
+tree
+merc_cons_init_list (elem, expr, init_list)
+ tree elem;
+ tree expr;
+ tree init_list;
+{
+ return tree_cons (elem, expr, init_list);
+}
+
+/* Build an expression tree node for a function call expression
+ `FNPTR (ARGS)'. FORCE_TAILCALL_P is 1 iff it is definitely safe
+ to treat this call as a tail or sibling call. */
+
+tree
+merc_build_call_expr (fnptr, args, force_tailcall_p)
+ tree fnptr;
+ tree args;
+ int force_tailcall_p ATTRIBUTE_UNUSED;
+{
+ tree fnptrtype;
+ tree fntype;
+ tree rettype;
+ tree call;
+
+ fnptrtype = TREE_TYPE (fnptr);
+ fntype = TREE_TYPE (fnptrtype);
+ rettype = TREE_TYPE (fntype);
+ call = build (CALL_EXPR, rettype, fnptr, args, NULL_TREE);
+ TREE_SIDE_EFFECTS (call) = 1;
+ return fold (call);
+}
+
+/* Generate code for the expression EXPR. */
+
+void
+merc_gen_expr_stmt (expr)
+ tree expr;
+{
+ expand_expr_stmt (expr);
+}
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** Functions for processing statements
+*/
+
+/* Generate code for a `return EXP;' statement. */
+
+void
+merc_gen_return (exp)
+ tree exp;
+{
+ expand_return (build (MODIFY_EXPR, void_type_node,
+ DECL_RESULT (current_function_decl), exp));
+}
+
+/* Generate code for an assignment statement. */
+
+void
+merc_gen_assign (lhs, rhs)
+ tree lhs;
+ tree rhs;
+{
+ tree assignment;
+
+ assignment = build (MODIFY_EXPR, void_type_node, lhs, rhs);
+ TREE_SIDE_EFFECTS (assignment) = 1;
+
+ expand_expr_stmt (assignment);
+}
+
+/* Build a tree node for a label with given NAME. */
+
+tree
+merc_build_label (name)
+ const char *name;
+{
+ tree id;
+ tree label;
+
+ id = (name ? get_identifier (name) : NULL_TREE);
+ label = build_decl (LABEL_DECL, id, NULL_TREE);
+ DECL_CONTEXT (label) = current_function_decl;
+ return label;
+}
+
+/* Convert the expression to the specified type.
+ For Mercury, there are no implicit conversions,
+ so this function should only ever do the identity conversions. */
+
+static tree
+merc_convert (type, expr)
+ tree type;
+ tree expr;
+{
+ /* We use the convert() function from c-convert.c. */
+ return convert (type, expr);
+}
+
+/* Generate a case label for the given VALUE. */
+
+void
+merc_gen_switch_case_label (expr, label)
+ tree expr;
+ tree label;
+{
+ int result;
+ tree duplicate_case;
+
+ result = pushcase (expr, merc_convert, label, &duplicate_case);
+ assert (result == 0);
+}
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** Functions for processing functions
+*/
+
+/* Set the source location that GCC uses for subsequent declarations
+ and diagnostics. */
+
+void
+merc_set_context (filename, line_number)
+ const char *filename;
+ int line_number;
+{
+ input_filename = filename;
+ line_number = lineno;
+}
+
+/* Prepare to generate code for the function given by FNDECL. */
+
+void
+merc_start_function (fndecl)
+ tree fndecl;
+{
+ tree param_decl, next_param;
+ tree first_param;
+
+ /* Set line number information. */
+ DECL_SOURCE_FILE (fndecl) = input_filename;
+ DECL_SOURCE_LINE (fndecl) = lineno;
+
+ /* Announce we are compiling this function. */
+ announce_function (fndecl);
+
+ /* put it in the list of decls for current scope */
+ pushdecl (fndecl);
+
+ /* Set up to compile the function and enter it. */
+ current_function_decl = fndecl;
+ DECL_INITIAL (fndecl) = error_mark_node;
+
+ /* GGC
+ temporary_allocation ();
+ */
+ make_function_rtl (fndecl);
+
+ init_function_start (fndecl, input_filename, lineno);
+ expand_function_start (fndecl, 0);
+
+ pushlevel (0);
+ expand_start_bindings (2);
+
+ /* Push all the PARM_DECL nodes onto the current scope (i.e. the scope of the
+ subprogram body) so that they can be recognized as local variables in the
+ subprogram. */
+
+ for (first_param = param_decl = nreverse (DECL_ARGUMENTS (fndecl));
+ param_decl;
+ param_decl = next_param)
+ {
+ next_param = TREE_CHAIN (param_decl);
+ TREE_CHAIN (param_decl) = NULL;
+ pushdecl (param_decl);
+ }
+
+ /* Store back the PARM_DECL nodes. They appear in the right order. */
+ DECL_ARGUMENTS (fndecl) = first_param; /*getdecls ();*/
+
+ pushlevel (0);
+ expand_start_bindings (0);
+
+ /* Now return to our caller, which will go ahead and generate the code in
+ the function. Note that this code will get allocated in
+ permanent_obstack. To do this properly, we need to enter the function
+ context before expanding the function body, but then error recovery is
+ more complex, so we don't do that here. XXX is that comment still valid
+ now we have the new gcc garbage collection scheme? */
+}
+
+/* Finish generating code for the current function. */
+
+void
+merc_end_function ()
+{
+ tree block;
+
+ block = poplevel (/*keep=*/1, /*reverse=*/1, /*functionbody=*/0);
+ expand_end_bindings (block, /*mark_ends=*/1, /*dont_jump_in=*/1);
+
+ /* Now get back out of the function and compile it. */
+ block = poplevel (/*keep=*/1, /*reverse=*/0, /*functionbody=*/1);
+ expand_end_bindings (block, /*mark_ends=*/0, /*dont_jump_in=*/1);
+ expand_function_end (input_filename, lineno, 0);
+ rest_of_compilation (current_function_decl);
+ current_function_decl = 0;
+ /* permanent_allocation (1); */
+}
+
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+
+/* Routines Expected by gcc: */
+
+const char *
+init_parse (filename)
+ const char *filename;
+{
+ if (!filename)
+ {
+ fprintf (stderr, "%s: error: too few arguments.\n", progname);
+ fprintf (stderr, "%s: you must specify a file name.\n", progname);
+ exit (1);
+ }
+
+ merc_filename = filename;
+ return filename;
+}
+
+/* This is the main entry point.
+ We invoke the Mercury compiler, which will
+ 1. parse the source code,
+ 2. perform semantic analysis (e.g. type checking),
+ 3. perform high-level optimizations
+ 4. convert from logic programs to imperative
+ style code (using continuation passing to
+ handle backtracking and nondeterminism)
+ 5. perform a few more optimizations,
+ and finally
+ 6. call the routines here to emit gcc trees and
+ expand these to RTL.
+
+ In step 6, the Mercury compiler will call merc_finish_function()
+ for each function, which in turn will call rest_of_compilation(),
+ which invokes the remaining stages of the GCC back-end. */
+
+int
+yyparse (void)
+{
+ const char *base_argv[] = {
+ "--target", "asm", "--target-code-only"
+ };
+ int base_argc = sizeof(base_argv) / sizeof(base_argv[0]);
+ int num_options;
+ struct merc_option_list *option;
+ const char **argv;
+ int argc;
+ int i;
+ int result;
+
+ /* Count the number of extra options to add. */
+ num_options = 0;
+ for (option = merc_option_list_head; option; option = option->next)
+ num_options++;
+
+ /* Build an argv array containing the program name (from save_argv),
+ the base options (above), the extra options added via `--mmc-flag=',
+ and then the filename. We add a terminating NULL at the end. */
+ argc = 1 + base_argc + num_options + 1;
+ argv = (const char **) xmalloc ((argc + 1) * sizeof (const char *));
+ argv[0] = save_argv[0];
+ for (i = 0; i < base_argc; i++)
+ argv[i + 1] = base_argv[i];
+ i++;
+ for (option = merc_option_list_head; option; option = option->next)
+ argv[i++] = option->value;
+ argv[i++] = merc_filename;
+ argv[i++] = NULL;
+ assert (i == argc + 1);
+
+ /* Announce how we will invoke the Mercury compiler.
+ XXX This diagnostic should probably be optional. */
+ if (1)
+ {
+ fnotice (stderr, "mercury_compile ");
+ for (i = 1; i < argc; i++)
+ fnotice (stderr, "%s ", argv[i]);
+ fnotice (stderr, "\n");
+ }
+
+ /* Invoke the Mercury compiler. */
+ result = mercury_main (argc, argv);
+ free (argv);
+
+ /* XXX We should set errorcount properly, but currently we don't. */
+ if (result != 0 && errorcount == 0) {
+ errorcount++;
+ }
+
+ return result;
+}
+
+void
+finish_parse (void)
+{
+ return;
+}
+
+void
+lang_init_options (void)
+{
+ return;
+}
+
+void
+lang_print_xnode (file, t, i)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree t ATTRIBUTE_UNUSED;
+ int i ATTRIBUTE_UNUSED;
+{
+ return;
+}
+
+
+/* Decode all the language specific options that cannot be decoded by GCC. The
+ option decoding phase of GCC calls this routine on the flags that it cannot
+ decode. Return 1 if successful, otherwise return 0. */
+
+int
+lang_decode_option (argc, argv)
+ int argc ATTRIBUTE_UNUSED;
+ char **argv;
+{
+ const char *option_value = NULL;
+ char *arg = argv[0];
+ if ((option_value = skip_leading_substring (arg, "--mmc-flag="))
+ || (option_value = skip_leading_substring (arg, "-fmmc-flag=")))
+ {
+ /* Insert this option into the list */
+ struct merc_option_list *option =
+ (struct merc_option_list *) xmalloc (sizeof(struct merc_option_list *));
+ option->value = xstrdup (option_value);
+ option->next = NULL;
+ if (merc_option_list_last != NULL)
+ {
+ merc_option_list_last->next = option;
+ merc_option_list_last = option;
+ }
+ else
+ {
+ merc_option_list_head = option;
+ merc_option_list_last = option;
+ }
+
+ return 1;
+ }
+ return 0;
+}
+
+/* Perform all the initialization steps that are language-specific. */
+
+void
+lang_init ()
+{
+ set_fatal_function (merc_handle_fatal_error);
+}
+
+/* Perform all the finalization steps that are language-specific. */
+
+void
+lang_finish ()
+{}
+
+/* Return a short string identifying this language to the debugger. */
+
+const char *
+lang_identify ()
+{ return "mercury"; }
+
+/*---------------------------------------------------------------------------*/
+
+/* Routines Expected by gcc: */
+
+/* These are used to build types for various sizes. The code below
+ is a simplified version of that of GNAT. */
+
+#ifndef MAX_BITS_PER_WORD
+#define MAX_BITS_PER_WORD BITS_PER_WORD
+#endif
+
+/* This variable keeps a table for types for each precision so that we only
+ allocate each of them once. Signed and unsigned types are kept separate. */
+static tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2];
+
+/* Return an integer type with the number of bits of precision given by
+ PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
+ it is a signed type. */
+
+tree
+type_for_size (precision, unsignedp)
+ unsigned precision;
+ int unsignedp;
+{
+ tree t;
+ /* GGC
+ int moment;
+ */
+
+ if (precision <= MAX_BITS_PER_WORD
+ && signed_and_unsigned_types[precision][unsignedp] != 0)
+ return signed_and_unsigned_types[precision][unsignedp];
+
+ /* Since we will keep these types around, they must be permanent. */
+ /* GGC
+ moment = suspend_momentary ();
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+ */
+
+ if (unsignedp)
+ t = signed_and_unsigned_types[precision][1]
+ = make_unsigned_type (precision);
+ else
+ t = signed_and_unsigned_types[precision][0]
+ = make_signed_type (precision);
+
+ /* GGC
+ pop_obstacks ();
+ resume_momentary (moment);
+ */
+
+ return t;
+}
+
+/* Return a data type that has machine mode MODE. UNSIGNEDP selects
+ an unsigned type; otherwise a signed type is returned. */
+
+tree
+type_for_mode (mode, unsignedp)
+ enum machine_mode mode;
+ int unsignedp;
+{
+ return type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
+}
+
+/* Return the unsigned version of a TYPE_NODE, a scalar type. */
+
+tree
+unsigned_type (type_node)
+ tree type_node;
+{
+ return type_for_size (TYPE_PRECISION (type_node), 1);
+}
+
+/* Return the signed version of a TYPE_NODE, a scalar type. */
+
+tree
+signed_type (type_node)
+ tree type_node;
+{
+ return type_for_size (TYPE_PRECISION (type_node), 0);
+}
+
+/* Return a type the same as TYPE except unsigned or signed according to
+ UNSIGNEDP. */
+
+tree
+signed_or_unsigned_type (unsignedp, type)
+ int unsignedp;
+ tree type;
+{
+ if (! INTEGRAL_TYPE_P (type) || TREE_UNSIGNED (type) == unsignedp)
+ return type;
+ else
+ return type_for_size (TYPE_PRECISION (type), unsignedp);
+}
+
+/* These functions and variables deal with binding contours. We only
+ need these functions for the list of PARM_DECLs, but we leave the
+ functions more general; these are a simplified version of the
+ functions from GNAT. */
+
+/* For each binding contour we allocate a binding_level structure which records
+ the entities defined or declared in that contour. Contours include:
+
+ the global one
+ one for each subprogram definition
+ one for each compound statement (declare block)
+
+ Binding contours are used to create GCC tree BLOCK nodes. */
+
+struct binding_level
+{
+ /* A chain of ..._DECL nodes for all variables, constants, functions,
+ parameters and type declarations. These ..._DECL nodes are chained
+ through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
+ in the reverse of the order supplied to be compatible with the
+ back-end. */
+ tree names;
+ /* For each level (except the global one), a chain of BLOCK nodes for all
+ the levels that were entered and exited one level down from this one. */
+ tree blocks;
+ /* The back end may need, for its own internal processing, to create a BLOCK
+ node. This field is set aside for this purpose. If this field is non-null
+ when the level is popped, i.e. when poplevel is invoked, we will use such
+ block instead of creating a new one from the 'names' field, that is the
+ ..._DECL nodes accumulated so far. Typically the routine 'pushlevel'
+ will be called before setting this field, so that if the front-end had
+ inserted ..._DECL nodes in the current block they will not be lost. */
+ tree block_created_by_back_end;
+ /* The binding level containing this one (the enclosing binding level). */
+ struct binding_level *level_chain;
+};
+
+/* The binding level currently in effect. */
+static struct binding_level *current_binding_level = NULL;
+
+/* The outermost binding level. This binding level is created when the
+ compiler is started and it will exist through the entire compilation. */
+static struct binding_level *global_binding_level;
+
+/* Binding level structures are initialized by copying this one. */
+static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL};
+
+/* Return non-zero if we are currently in the global binding level. */
+
+int
+global_bindings_p ()
+{
+ return current_binding_level == global_binding_level ? -1 : 0;
+}
+
+/* Return the list of declarations in the current level. Note that this list
+ is in reverse order (it has to be so for back-end compatibility). */
+
+tree
+getdecls ()
+{
+ return current_binding_level->names;
+}
+
+/* Nonzero if the current level needs to have a BLOCK made. */
+
+int
+kept_level_p ()
+{
+ return (current_binding_level->names != 0);
+}
+
+/* Enter a new binding level. The input parameter is ignored, but has to be
+ specified for back-end compatibility. */
+
+void
+pushlevel (ignore)
+ int ignore ATTRIBUTE_UNUSED;
+{
+ struct binding_level *newlevel
+ = (struct binding_level *) xmalloc (sizeof (struct binding_level));
+
+ *newlevel = clear_binding_level;
+
+ /* Add this level to the front of the chain (stack) of levels that are
+ active. */
+ newlevel->level_chain = current_binding_level;
+ current_binding_level = newlevel;
+}
+
+/* Exit a binding level.
+ Pop the level off, and restore the state of the identifier-decl mappings
+ that were in effect when this level was entered.
+
+ If KEEP is nonzero, this level had explicit declarations, so
+ and create a "block" (a BLOCK node) for the level
+ to record its declarations and subblocks for symbol table output.
+
+ If FUNCTIONBODY is nonzero, this level is the body of a function,
+ so create a block as if KEEP were set and also clear out all
+ label names.
+
+ If REVERSE is nonzero, reverse the order of decls before putting
+ them into the BLOCK. */
+
+tree
+poplevel (keep, reverse, functionbody)
+ int keep;
+ int reverse;
+ int functionbody;
+{
+ /* Points to a BLOCK tree node. This is the BLOCK node construted for the
+ binding level that we are about to exit and which is returned by this
+ routine. */
+ tree block_node = NULL_TREE;
+ tree decl_chain;
+ tree subblock_chain = current_binding_level->blocks;
+ tree subblock_node;
+ tree block_created_by_back_end;
+
+ /* Reverse the list of *_DECL nodes if desired. Note that the ..._DECL
+ nodes chained through the `names' field of current_binding_level are in
+ reverse order except for PARM_DECL node, which are explicitely stored in
+ the right order. */
+ decl_chain = (reverse) ? nreverse (current_binding_level->names)
+ : current_binding_level->names;
+
+ block_created_by_back_end = current_binding_level->block_created_by_back_end;
+ if (block_created_by_back_end != 0)
+ {
+ block_node = block_created_by_back_end;
+
+ /* Check if we are about to discard some information that was gathered
+ by the front-end. Nameley check if the back-end created a new block
+ without calling pushlevel first. To understand why things are lost
+ just look at the next case (i.e. no block created by back-end. */
+ if ((keep || functionbody) && (decl_chain || subblock_chain))
+ abort ();
+ }
+
+ /* If there were any declarations in the current binding level, or if this
+ binding level is a function body, or if there are any nested blocks then
+ create a BLOCK node to record them for the life of this function. */
+ else if (keep || functionbody)
+ block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0);
+
+ /* Record the BLOCK node just built as the subblock its enclosing scope. */
+ for (subblock_node = subblock_chain; subblock_node;
+ subblock_node = TREE_CHAIN (subblock_node))
+ BLOCK_SUPERCONTEXT (subblock_node) = block_node;
+
+ /* Clear out the meanings of the local variables of this level. */
+
+ for (subblock_node = decl_chain; subblock_node;
+ subblock_node = TREE_CHAIN (subblock_node))
+ if (DECL_NAME (subblock_node) != 0)
+ /* If the identifier was used or addressed via a local extern decl,
+ don't forget that fact. */
+ if (DECL_EXTERNAL (subblock_node))
+ {
+ if (TREE_USED (subblock_node))
+ TREE_USED (DECL_NAME (subblock_node)) = 1;
+ if (TREE_ADDRESSABLE (subblock_node))
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
+ }
+
+ /* Pop the current level. */
+ current_binding_level = current_binding_level->level_chain;
+
+ if (functionbody)
+ {
+ /* This is the top level block of a function. The ..._DECL chain stored
+ in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
+ leave them in the BLOCK because they are found in the FUNCTION_DECL
+ instead. */
+ DECL_INITIAL (current_function_decl) = block_node;
+ BLOCK_VARS (block_node) = 0;
+ }
+ else if (block_node)
+ {
+ if (block_created_by_back_end == NULL)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block_node);
+ }
+
+ /* If we did not make a block for the level just exited, any blocks made for
+ inner levels (since they cannot be recorded as subblocks in that level)
+ must be carried forward so they will later become subblocks of something
+ else. */
+ else if (subblock_chain)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, subblock_chain);
+ if (block_node)
+ TREE_USED (block_node) = 1;
+
+ return block_node;
+}
+
+/* Insert BLOCK at the end of the list of subblocks of the
+ current binding level. This is used when a BIND_EXPR is expanded,
+ to handle the BLOCK node inside the BIND_EXPR. */
+
+void
+insert_block (block)
+ tree block;
+{
+ TREE_USED (block) = 1;
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block);
+}
+
+/* Set the BLOCK node for the innermost scope
+ (the one we are currently in). */
+
+void
+set_block (block)
+ tree block;
+{
+ current_binding_level->block_created_by_back_end = block;
+}
+
+/* Records a ..._DECL node DECL as belonging to the current lexical scope.
+ Returns the ..._DECL node. */
+
+tree
+pushdecl (decl)
+ tree decl;
+{
+ /* External objects aren't nested, other objects may be. */
+
+ if ((DECL_EXTERNAL (decl)) || (decl==current_function_decl))
+ DECL_CONTEXT (decl) = 0;
+ else
+ DECL_CONTEXT (decl) = current_function_decl;
+
+ /* Put the declaration on the list. The list of declarations is in reverse
+ order. The list will be reversed later if necessary. This needs to be
+ this way for compatibility with the back-end. */
+
+ TREE_CHAIN (decl) = current_binding_level->names;
+ current_binding_level->names = decl;
+
+ /* For the declartion of a type, set its name if it is not already set. */
+
+ if (TREE_CODE (decl) == TYPE_DECL
+ && TYPE_NAME (TREE_TYPE (decl)) == 0)
+ TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
+
+ return decl;
+}
+
+#ifndef CHAR_TYPE_SIZE
+#define CHAR_TYPE_SIZE BITS_PER_UNIT
+#endif
+
+#ifndef INT_TYPE_SIZE
+#define INT_TYPE_SIZE BITS_PER_WORD
+#endif
+
+#undef SIZE_TYPE
+#define SIZE_TYPE "long unsigned int"
+
+/* Create the predefined scalar types of C,
+ and some nodes representing standard constants (0, 1, (void *) 0).
+ Initialize the global binding level.
+ Make definitions for built-in primitive functions. */
+
+void
+init_decl_processing ()
+{
+ tree array_domain_type;
+
+ set_identifier_size (sizeof (struct tree_identifier));
+
+ current_function_decl = NULL;
+ current_binding_level = NULL_BINDING_LEVEL;
+ pushlevel (0); /* make the binding_level structure for global names */
+ global_binding_level = current_binding_level;
+
+ build_common_tree_nodes (flag_signed_char);
+
+ /* set standard type names */
+ /* XXX should we modify this for Mercury? */
+
+ ridpointers = (tree *) xcalloc ((int) RID_MAX, sizeof (tree));
+ ridpointers[(int) RID_INT] = get_identifier ("int");
+ ridpointers[(int) RID_CHAR] = get_identifier ("char");
+ ridpointers[(int) RID_VOID] = get_identifier ("void");
+ ridpointers[(int) RID_FLOAT] = get_identifier ("float");
+ ridpointers[(int) RID_DOUBLE] = get_identifier ("double");
+ ridpointers[(int) RID_SHORT] = get_identifier ("short");
+ ridpointers[(int) RID_LONG] = get_identifier ("long");
+ ridpointers[(int) RID_UNSIGNED] = get_identifier ("unsigned");
+ ridpointers[(int) RID_SIGNED] = get_identifier ("signed");
+ ridpointers[(int) RID_INLINE] = get_identifier ("inline");
+ ridpointers[(int) RID_CONST] = get_identifier ("const");
+ ridpointers[(int) RID_RESTRICT] = get_identifier ("restrict");
+ ridpointers[(int) RID_VOLATILE] = get_identifier ("volatile");
+ ridpointers[(int) RID_BOUNDED] = get_identifier ("__bounded");
+ ridpointers[(int) RID_UNBOUNDED] = get_identifier ("__unbounded");
+ ridpointers[(int) RID_AUTO] = get_identifier ("auto");
+ ridpointers[(int) RID_STATIC] = get_identifier ("static");
+ ridpointers[(int) RID_EXTERN] = get_identifier ("extern");
+ ridpointers[(int) RID_TYPEDEF] = get_identifier ("typedef");
+ ridpointers[(int) RID_REGISTER] = get_identifier ("register");
+ /* ridpointers[(int) RID_ITERATOR] = get_identifier ("iterator"); */
+ ridpointers[(int) RID_COMPLEX] = get_identifier ("complex");
+ ridpointers[(int) RID_ID] = get_identifier ("id");
+ ridpointers[(int) RID_IN] = get_identifier ("in");
+ ridpointers[(int) RID_OUT] = get_identifier ("out");
+ ridpointers[(int) RID_INOUT] = get_identifier ("inout");
+ ridpointers[(int) RID_BYCOPY] = get_identifier ("bycopy");
+ ridpointers[(int) RID_BYREF] = get_identifier ("byref");
+ ridpointers[(int) RID_ONEWAY] = get_identifier ("oneway");
+
+ /* Define `int' and `char' first so that dbx will output them first. */
+
+ /* spec1() ensures that the type's type is itself. Needed for DBX.
+ For the C front-end this is done in pushdecl with a kludge. */
+
+#define spec1(type, id, node) \
+ { \
+ tree spec1_decl; \
+ TREE_TYPE (node) = node; \
+ spec1_decl = build_decl (type, id, node); \
+ TYPE_NAME (node) = spec1_decl; \
+ pushdecl (spec1_decl); \
+ }
+
+ spec1(TYPE_DECL, ridpointers[(int) RID_INT], integer_type_node);
+ spec1(TYPE_DECL, get_identifier ("char"), char_type_node);
+ spec1(TYPE_DECL, get_identifier ("long int"), long_integer_type_node);
+ spec1(TYPE_DECL, get_identifier ("unsigned int"), unsigned_type_node);
+ spec1(TYPE_DECL, get_identifier ("long unsigned int"), long_unsigned_type_node);
+ spec1(TYPE_DECL, get_identifier ("long long int"), long_long_integer_type_node);
+ spec1(TYPE_DECL, get_identifier ("long long unsigned int"), long_long_unsigned_type_node);
+ spec1(TYPE_DECL, get_identifier ("short int"), short_integer_type_node);
+ spec1(TYPE_DECL, get_identifier ("short unsigned int"), short_unsigned_type_node);
+ spec1(TYPE_DECL, get_identifier ("signed char"), signed_char_type_node);
+ spec1(TYPE_DECL, get_identifier ("unsigned char"), unsigned_char_type_node);
+ spec1(TYPE_DECL, NULL_TREE, intQI_type_node);
+ spec1(TYPE_DECL, NULL_TREE, intHI_type_node);
+ spec1(TYPE_DECL, NULL_TREE, intSI_type_node);
+ spec1(TYPE_DECL, NULL_TREE, intDI_type_node);
+#if HOST_BITS_PER_WIDE_INT >= 64
+ spec1(TYPE_DECL, NULL_TREE, intTI_type_node);
+#endif
+ spec1(TYPE_DECL, NULL_TREE, unsigned_intQI_type_node);
+ spec1(TYPE_DECL, NULL_TREE, unsigned_intHI_type_node);
+ spec1(TYPE_DECL, NULL_TREE, unsigned_intSI_type_node);
+ spec1(TYPE_DECL, NULL_TREE, unsigned_intDI_type_node);
+#if HOST_BITS_PER_WIDE_INT >= 64
+ spec1(TYPE_DECL, NULL_TREE, unsigned_intTI_type_node);
+#endif
+
+ /* Create the widest literal types. */
+ widest_integer_literal_type_node = make_signed_type (HOST_BITS_PER_WIDE_INT * 2);
+ widest_unsigned_literal_type_node = make_unsigned_type (HOST_BITS_PER_WIDE_INT * 2);
+ spec1(TYPE_DECL, NULL_TREE, widest_integer_literal_type_node);
+ spec1(TYPE_DECL, NULL_TREE, widest_unsigned_literal_type_node);
+
+ merc_int8_type_node = make_signed_type (8);
+ merc_int16_type_node = make_signed_type (16);
+ merc_int32_type_node = make_signed_type (32);
+ merc_int64_type_node = make_signed_type (64);
+ merc_intptr_type_node = make_signed_type (POINTER_SIZE);
+
+ set_sizetype (merc_intptr_type_node);
+
+ build_common_tree_nodes_2 (merc_flag_short_double);
+
+ spec1(TYPE_DECL, ridpointers[(int) RID_FLOAT], float_type_node);
+ spec1(TYPE_DECL, ridpointers[(int) RID_DOUBLE], double_type_node);
+ spec1(TYPE_DECL, get_identifier ("long double"), long_double_type_node);
+ spec1(TYPE_DECL, ridpointers[(int) RID_VOID], void_type_node);
+
+#ifdef MD_INIT_BUILTINS
+ MD_INIT_BUILTINS;
+#endif
+
+ wchar_type_node = get_identifier (merc_flag_short_wchar
+ ? "short unsigned int"
+ : WCHAR_TYPE);
+
+#if 0
+ /* XXX This is wrong, I think.
+ The boolean type should be marked as a BOOLEAN_TYPE. */
+ boolean_type_node = integer_type_node;
+ boolean_true_node = integer_one_node;
+ boolean_false_node = integer_zero_node;
+#else
+ boolean_type_node = make_node (BOOLEAN_TYPE);
+ TYPE_PRECISION (boolean_type_node) = 1;
+ fixup_unsigned_type (boolean_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("boolean"),
+ boolean_type_node));
+ boolean_false_node = TYPE_MIN_VALUE (boolean_type_node);
+ boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
+#endif
+
+ string_type_node = build_pointer_type (char_type_node);
+ const_string_type_node
+ = build_pointer_type (build_type_variant (char_type_node, 1, 0));
+
+ /* Make a type to be the domain of a few array types
+ whose domains don't really matter.
+ 2000 is small enough that it always fits in size_t
+ and large enough that it can hold most function names for the
+ initializations of __FUNCTION__ and __PRETTY_FUNCTION__. */
+ array_domain_type = build_index_type (build_int_2 (2000, 0));
+
+ /* make a type for arrays of characters.
+ With luck nothing will ever really depend on the length of this
+ array type. */
+ char_array_type_node
+ = build_array_type (char_type_node, array_domain_type);
+
+ /* The documentation in builtins.c says that __builtin_setjmp expects its
+ argument to be a pointer to an array of five words. */
+ merc_jmpbuf_type_node
+ = build_array_type (ptr_type_node, build_index_type (build_int_2 (4, 0)));
+
+ merc_init_builtin_functions ();
+
+ pedantic_lvalues = pedantic;
+
+ start_identifier_warnings ();
+
+}
+
+/* Handle a fatal error, for the Mercury front-end.
+ We override the default behaviour so that we can specify
+ a different email address for bugs reports. */
+
+static void
+merc_handle_fatal_error (msg, args)
+ const char *msg;
+ va_list *args;
+{
+ diagnostic_context dc;
+
+ set_diagnostic_context
+ (&dc, msg, args, input_filename, lineno, /* warn = */0);
+ report_diagnostic (&dc);
+
+ fprintf (stderr,
+ "Please submit a full bug report to <mercury-bugs at cs.mu.oz.au>.\n");
+#if 0
+ fprintf (stderr, "See %s for instructions.\n", GCCBUGURL);
+#endif
+ exit (FATAL_EXIT_CODE);
+}
+
+static void
+merc_init_builtin_functions ()
+{
+ tree no_more_params = merc_empty_param_type_list ();
+ tree alloc_function_param_types;
+ tree alloc_function_type;
+ tree strcmp_function_param_types;
+ tree strcmp_function_type;
+ tree hash_string_function_param_types;
+ tree hash_string_function_type;
+ tree box_float_function_param_types;
+ tree box_float_function_type;
+ tree setjmp_function_param_types;
+ tree setjmp_function_type;
+ tree longjmp_function_param_types;
+ tree longjmp_function_type;
+
+ /* Declare `void *GC_malloc(int);'. */
+ /* XXX The argument type for GC_malloc() should be `size_t', not `int'. */
+ alloc_function_param_types
+ = tree_cons (NULL_TREE, integer_type_node, no_more_params);
+ alloc_function_type
+ = build_function_type (ptr_type_node, alloc_function_param_types);
+ merc_alloc_function_node
+ = builtin_function ("GC_malloc", alloc_function_type,
+ 0, NOT_BUILT_IN, NULL_PTR);
+ DECL_IS_MALLOC (merc_alloc_function_node) = 1;
+
+ /* Declare `int strcmp(const char *, const char *);'. */
+ strcmp_function_param_types
+ = tree_cons (NULL_TREE, const_string_type_node,
+ tree_cons (NULL_TREE, const_string_type_node, no_more_params));
+ strcmp_function_type
+ = build_function_type (integer_type_node, strcmp_function_param_types);
+ merc_strcmp_function_node
+ = builtin_function ("__builtin_strcmp", strcmp_function_type,
+ BUILT_IN_STRCMP, BUILT_IN_NORMAL, "strcmp");
+
+ /* Declare `int MR_hash_string(const char *, const char *);'. */
+ hash_string_function_param_types
+ = tree_cons (NULL_TREE, const_string_type_node,
+ tree_cons (NULL_TREE, const_string_type_node,
+ no_more_params));
+ hash_string_function_type
+ = build_function_type (integer_type_node, hash_string_function_param_types);
+ merc_hash_string_function_node
+ = builtin_function ("MR_hash_string", hash_string_function_type,
+ 0, NOT_BUILT_IN, NULL_PTR);
+
+ /* Declare `MR_Float * MR_box_float(MR_Float);'. */
+ box_float_function_param_types
+ = tree_cons (NULL_TREE, double_type_node, no_more_params);
+ box_float_function_type
+ = build_function_type (build_pointer_type (double_type_node),
+ box_float_function_param_types);
+ merc_box_float_function_node
+ = builtin_function ("MR_box_float", box_float_function_type,
+ 0, NOT_BUILT_IN, NULL_PTR);
+
+ /* Declare `int __builtin_setjmp(void *);'. */
+ setjmp_function_param_types
+ = tree_cons (NULL_TREE, ptr_type_node, no_more_params);
+ setjmp_function_type
+ = build_function_type (integer_type_node, setjmp_function_param_types);
+ merc_setjmp_function_node
+ = builtin_function ("__builtin_setjmp", setjmp_function_type,
+ BUILT_IN_SETJMP, BUILT_IN_NORMAL, NULL_PTR);
+
+ /* Declare `void __builtin_longjmp(void *, int);'. */
+ longjmp_function_param_types
+ = tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ no_more_params));
+ longjmp_function_type
+ = build_function_type (void_type_node, longjmp_function_param_types);
+ merc_longjmp_function_node
+ = builtin_function ("__builtin_longjmp", longjmp_function_type,
+ BUILT_IN_LONGJMP, BUILT_IN_NORMAL, NULL_PTR);
+
+ /* Register our global tree nodes as roots for the garbage collector. */
+ ggc_add_tree_root (&merc_alloc_function_node, 1);
+ ggc_add_tree_root (&merc_strcmp_function_node, 1);
+ ggc_add_tree_root (&merc_hash_string_function_node, 1);
+ ggc_add_tree_root (&merc_box_float_function_node, 1);
+ ggc_add_tree_root (&merc_setjmp_function_node, 1);
+ ggc_add_tree_root (&merc_longjmp_function_node, 1);
+}
+
+/* If DECL has a cleanup, build and return that cleanup here.
+ This is a callback called by expand_expr. */
+
+tree
+maybe_build_cleanup (decl)
+ tree decl ATTRIBUTE_UNUSED;
+{ return NULL_TREE; }
+
+/* Print an error message for invalid use of an incomplete type. */
+
+void
+incomplete_type_error (dont_care_1, dont_care_2)
+ tree dont_care_1 ATTRIBUTE_UNUSED;
+ tree dont_care_2 ATTRIBUTE_UNUSED;
+{ abort (); }
+
+tree
+truthvalue_conversion (expr)
+ tree expr;
+{ return expr; }
+
+
+/* Mark EXP saying that we need to be able to take the
+ address of it; it should not be allocated in a register.
+ Value is 1 if successful.
+
+ This implementation was copied from c-decl.c. */
+
+int
+mark_addressable (exp)
+ tree exp;
+{
+ register tree x = exp;
+ while (1)
+ switch (TREE_CODE (x))
+ {
+ case COMPONENT_REF:
+#if 0 /* C specific */
+ if (DECL_C_BIT_FIELD (TREE_OPERAND (x, 1)))
+ {
+ error ("cannot take address of bitfield `%s'",
+ IDENTIFIER_POINTER (DECL_NAME (TREE_OPERAND (x, 1))));
+ return 0;
+ }
+#endif
+
+ /* ... fall through ... */
+
+ case ADDR_EXPR:
+ case ARRAY_REF:
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ x = TREE_OPERAND (x, 0);
+ break;
+
+ case CONSTRUCTOR:
+ TREE_ADDRESSABLE (x) = 1;
+ return 1;
+
+ case VAR_DECL:
+ case CONST_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
+ && DECL_NONLOCAL (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ error ("global register variable `%s' used in nested function",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ return 0;
+ }
+ pedwarn ("register variable `%s' used in nested function",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ }
+ else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ error ("address of global register variable `%s' requested",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ return 0;
+ }
+
+ /* If we are making this addressable due to its having
+ volatile components, give a different error message. Also
+ handle the case of an unnamed parameter by not trying
+ to give the name. */
+
+ else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
+ {
+ error ("cannot put object with volatile field into register");
+ return 0;
+ }
+
+ pedwarn ("address of register variable `%s' requested",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ }
+ put_var_into_stack (x);
+
+ /* drops in */
+ case FUNCTION_DECL:
+ TREE_ADDRESSABLE (x) = 1;
+#if 0 /* poplevel deals with this now. */
+ if (DECL_CONTEXT (x) == 0)
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
+#endif
+
+ default:
+ return 1;
+ }
+}
+
+/* Print any language-specific compilation statistics. */
+
+void
+print_lang_statistics ()
+{}
+
+/* Since we don't use the DECL_LANG_SPECIFIC field, this is a no-op. */
+
+void
+copy_lang_decl (node)
+ tree node ATTRIBUTE_UNUSED;
+{}
+
+/* Hooks for print-tree.c: */
+
+void
+print_lang_decl (file, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{}
+
+void
+print_lang_type (file, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{}
+
+void
+print_lang_identifier (file, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{}
+
+/* Sets some debug flags for the parser. It does nothing here. */
+
+void
+set_yydebug (value)
+ int value ATTRIBUTE_UNUSED;
+{}
+
+/* mark any data hanging of a tree node as used, for garbage collection */
+void
+lang_mark_tree (t)
+ union tree_node *t ATTRIBUTE_UNUSED;
+{
+/* we have no extras in the tree - nothing to do so return */
+ return;
+}
+
+/* Return the typed-based alias set for T, which may be an expression
+ or a type. Return -1 if we don't do anything special. */
+
+HOST_WIDE_INT
+lang_get_alias_set (t)
+ tree t ATTRIBUTE_UNUSED;
+{
+ return -1;
+}
+
+/* Return a definition for a builtin function named NAME and whose data type
+ is TYPE. TYPE should be a function type with argument types.
+ FUNCTION_CODE tells later passes how to compile calls to this function.
+ See tree.h for its possible values.
+
+ If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
+ the name to be called if we can't opencode the function.
+
+ copied from gcc/c-decl.c by tim josling
+
+*/
+
+tree
+builtin_function (name, type, function_code, class, library_name)
+ const char *name;
+ tree type;
+ int function_code;
+ enum built_in_class class;
+ const char *library_name;
+{
+ tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ /* If -traditional, permit redefining a builtin function any way you like.
+ (Though really, if the program redefines these functions,
+ it probably won't work right unless compiled with -fno-builtin.) */
+ if (flag_traditional && name[0] != '_')
+ DECL_BUILT_IN_NONANSI (decl) = 1;
+ if (library_name)
+ DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
+ make_decl_rtl (decl, NULL_PTR, 1);
+ pushdecl (decl);
+ DECL_BUILT_IN_CLASS (decl) = class;
+ DECL_FUNCTION_CODE (decl) = function_code;
+
+#if 0 /* c specific */
+ /* Warn if a function in the namespace for users
+ is used without an occasion to consider it declared. */
+ if (name[0] != '_' || name[1] != '_')
+ C_DECL_ANTICIPATED (decl) = 1;
+#endif
+
+ return decl;
+}
Index: gcc/mercury/mercury-gcc.h
===================================================================
RCS file: mercury-gcc.h
diff -N mercury-gcc.h
--- /dev/null Thu Mar 30 14:06:13 2000
+++ /tmp/cvsTESKoD Fri Jan 5 17:49:31 2001
@@ -0,0 +1,137 @@
+/* mercury-gcc.h: Mercury language front-end for GNU CC.
+ Copyright (C) 2001 Fergus Henderson.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* Declarations of variables and functions defined in mercury-gcc.c.
+ See mercury-gcc.c for documentation. */
+
+/* Implemented by Fergus Henderson <fjh at cs.mu.oz.au> December 2000. */
+
+#ifndef MERCURY_GCC_H
+#define MERCURY_GCC_H
+
+/* global variables */
+
+extern tree merc_alloc_function_node;
+extern tree merc_strcmp_function_node;
+extern tree merc_hash_string_function_node;
+extern tree merc_box_float_function_node;
+extern tree merc_setjmp_function_node;
+extern tree merc_longjmp_function_node;
+
+extern tree merc_int8_type_node;
+extern tree merc_int16_type_node;
+extern tree merc_int32_type_node;
+extern tree merc_int64_type_node;
+extern tree merc_intptr_type_node;
+extern tree merc_jmpbuf_type_node;
+
+/* functions for processing declarations */
+
+extern tree
+merc_build_extern_var_decl PARAMS((const char *name, tree type));
+
+extern tree
+merc_build_global_var_decl PARAMS((const char *name, tree type,
+ tree initializer));
+
+extern tree
+merc_build_local_var_decl PARAMS((const char *name, tree type));
+
+extern tree
+merc_build_param_decl PARAMS((const char *name, tree type));
+
+extern tree
+merc_empty_param_list PARAMS((void));
+
+extern tree
+merc_cons_param_list PARAMS((tree parm_decl, tree param_list));
+
+extern tree
+merc_empty_param_type_list PARAMS((void));
+
+extern tree
+merc_cons_param_type_list PARAMS((tree parm_decl, tree param_list));
+
+extern tree
+merc_build_function_decl PARAMS((const char *name, const char *asm_name,
+ tree return_type, tree param_type_list,
+ tree param_list));
+
+extern tree
+merc_build_field_decl PARAMS((const char *name, tree type));
+
+extern tree
+merc_empty_field_list PARAMS((void));
+
+extern tree
+merc_cons_field_list PARAMS((tree field_decl, tree field_list));
+
+extern tree
+merc_build_struct_type_decl PARAMS((const char *name, tree field_list));
+
+/* functions for processing expressions */
+
+extern tree
+merc_build_string PARAMS((int len, const char *chars));
+
+extern tree
+merc_empty_arg_list PARAMS((void));
+
+extern tree
+merc_cons_arg_list PARAMS((tree expr, tree arg_list));
+
+extern tree
+merc_build_call_expr PARAMS((tree func, tree args, int tailcall));
+
+extern void
+merc_gen_expr_stmt PARAMS((tree expr));
+
+extern tree
+merc_empty_init_list PARAMS((void));
+
+extern tree
+merc_cons_init_list PARAMS((tree elem, tree expr, tree init_list));
+
+/* functions for processing functions */
+
+extern void
+merc_set_context PARAMS((const char *filename, int line_number));
+
+extern void
+merc_start_function PARAMS((tree func_decl));
+
+extern void
+merc_end_function PARAMS((void));
+
+/* functions for processing statements */
+
+extern void
+merc_gen_return PARAMS((tree return_value));
+
+extern void
+merc_gen_assign PARAMS((tree lhs, tree rhs));
+
+extern tree
+merc_build_label PARAMS((const char *name));
+
+extern void
+merc_gen_switch_case_label PARAMS((tree expr, tree label));
+
+#endif /* MERCURY_GCC_H */
Index: gcc/mercury/test.m
===================================================================
RCS file: test.m
diff -N test.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ test.m Sat Dec 30 21:40:59 2000
@@ -0,0 +1,9 @@
+:- module test.
+:- interface.
+:- import_module int.
+
+:- func test(int, int) = int.
+
+:- implementation.
+
+test(X, Y) = X + Y.
Index: gcc/mercury/testmercury.c
===================================================================
RCS file: testmercury.c
diff -N testmercury.c
--- /dev/null Thu Mar 30 14:06:13 2000
+++ /tmp/cvsOrBCXr Fri Jan 5 17:49:31 2001
@@ -0,0 +1,13 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+extern int test__test_3_f_0(int, int);
+
+int main(int argc, char ** argv)
+{
+ if (argc == 3)
+ printf("%d\n", test__test_3_f_0((int) atol(argv[1]), (int) atol(argv[2])));
+ else
+ printf("usage: testmercury int1 int2; displays int1 + int2\n");
+ return 0;
+}
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
| of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh> | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list