[m-dev.] for review: --high-level-data
Fergus Henderson
fjh at cs.mu.OZ.AU
Wed May 31 02:58:42 AEST 2000
Tyson, would you like to review this one?
----------
Estimated hours taken: 20
Make a start towards implementing the `--high-level-data' option.
XXX There are still quite a few places in the MLDS code generator,
specifically in ml_unify_gen.m, ml_call_gen.m, and ml_code_gen.m,
that assume `--no-high-level-data'. For example, we still use
the MR_field() macro rather than using named fields.
XXX Equivalence types are not yet supported.
compiler/ml_type_gen.m:
New module. If --high-level-data is enabled, this module
generates MLDS type definitions for HLDS types.
compiler/ml_code_gen.m:
Import ml_type_gen.m, and delete the stub code for
`ml_gen_types', since that is now defined in ml_type_gen.m.
compiler/mlds_to_c.m:
- If --high-level-data is enabled, declare variables whose Mercury
types is user-defined using the MLDS types generated by
ml_type_gen.m, and declare closures with type `MR_ClosurePtr'
rather than `MR_Word'.
- Output type definitions in the header file rather than
then `.c' file.
- Add code to output `mlds__enum' classes as C enums,
and to handle static members and nested types in classes;
these changes are needed because ml_type_gen generates those
constructs.
- Cast the argument of MR_tag() to `MR_Word'.
- Cast the result of MR_new_object() to the appropriate type.
runtime/mercury.h:
- Delete the cast to `MR_Word' in MR_new_object(), because it was
not right for the --high-level-data case; the necessary casts
are now generated by mlds_to_c.m.
- Define the `MR_ClosurePtr' type.
compiler/mlds_to_c.m:
compiler/ml_elim_nested.m:
Fully qualify struct member names. This is needed to avoid
name clashes for the enumeration constants and nested types
that ml_type_gen generates, in particular for the case where
the same constructor name and arity occurs in two or more
different types in a single module. It's also more consistent
with our general approach of fully qualifying all references.
compiler/mlds.m:
- Add a new field of type builtin_type to the mercury_type/2
MLDS type; this holds the type category (enumeration, etc.).
This required adding a module_info parameter to the
mercury_type_to_mlds function.
- Similarly, add a new field of type mlds__class_kind to the
class_type/2 MLDS type.
- Add a function `mlds__append_class_qualifier', for use by mlds_to_c.m
and ml_elim_nested.m.
- Add field names to the `mlds__class_defn' struct.
compiler/ml_code_util.m:
Add a new routine ml_gen_type for converting Mercury types to MLDS.
This just extracts the module_info from the ml_gen_info and then
calls mercury_type_to_mlds.
compiler/*ml*.m:
Change lots of places to use ml_gen_type and/or to pass the
module_info down to mercury_type_to_mlds, and to handle the
new field of mercury_type/3. Similarly, change quite a few
places to handle the new field of class_type/3.
In ml_code_util.m, passing the module_info down had the
pleasant side-effect of enabling the elimination of an
existing XXX: in ml_gen_proc_params_from_rtti,
UseNestedFunctions was not being calculated correctly,
because previously the globals where not easily available at
that point.
Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.48
diff -u -d -r1.48 ml_code_gen.m
--- compiler/ml_code_gen.m 2000/05/26 07:09:11 1.48
+++ compiler/ml_code_gen.m 2000/05/30 11:54:38
@@ -660,7 +660,7 @@
:- implementation.
-:- import_module ml_call_gen, ml_unify_gen, ml_code_util.
+:- import_module ml_type_gen, ml_call_gen, ml_unify_gen, ml_code_util.
:- import_module llds. % XXX needed for `code_model'.
:- import_module export, llds_out. % XXX needed for pragma C code
:- import_module hlds_pred, hlds_goal, hlds_data, prog_data.
@@ -715,19 +715,6 @@
{ MLDS_Defns = list__append(MLDS_TypeDefns, MLDS_PredDefns) }.
%-----------------------------------------------------------------------------%
-
- % Generate MLDS definitions for all the types,
- % typeclasses, and instances in the HLDS.
- %
-:- pred ml_gen_types(module_info, mlds__defns, io__state, io__state).
-:- mode ml_gen_types(in, out, di, uo) is det.
-
-ml_gen_types(_ModuleInfo, MLDS_TypeDefns) -->
- % XXX currently we use a low-level data representation,
- % so we don't map Mercury types to MLDS types.
- { MLDS_TypeDefns = [] }.
-
-%-----------------------------------------------------------------------------%
%
% Stuff to generate MLDS code for HLDS predicates & functions.
%
@@ -909,7 +896,7 @@
% proc_info_varset(ProcInfo, VarSet),
% proc_info_vartypes(ProcInfo, VarTypes),
% MLDS_LocalVars = ml_gen_all_local_var_decls(Goal, VarSet,
- % VarTypes, HeadVars),
+ % VarTypes, HeadVars, ModuleInfo),
% But instead we now generate them locally for each goal.
% We just declare the `succeeded' var here.
MLDS_Context = mlds__make_context(Context),
@@ -932,8 +919,9 @@
% each sub-goal.
%
:- func ml_gen_all_local_var_decls(hlds_goal, prog_varset,
- map(prog_var, prog_type), list(prog_var)) = mlds__defns.
-ml_gen_all_local_var_decls(Goal, VarSet, VarTypes, HeadVars) =
+ map(prog_var, prog_type), list(prog_var), module_info) =
+ mlds__defns.
+ml_gen_all_local_var_decls(Goal, VarSet, VarTypes, HeadVars, ModuleInfo) =
MLDS_LocalVars :-
Goal = _ - GoalInfo,
goal_info_get_context(GoalInfo, Context),
@@ -942,28 +930,29 @@
set__to_sorted_list(LocalVarsSet, LocalVars),
MLDS_Context = mlds__make_context(Context),
MLDS_LocalVars0 = ml_gen_local_var_decls(VarSet, VarTypes,
- MLDS_Context, LocalVars),
+ MLDS_Context, ModuleInfo, LocalVars),
MLDS_SucceededVar = ml_gen_succeeded_var_decl(MLDS_Context),
MLDS_LocalVars = [MLDS_SucceededVar | MLDS_LocalVars0].
% Generate declarations for a list of local variables.
%
:- func ml_gen_local_var_decls(prog_varset, map(prog_var, prog_type),
- mlds__context, prog_vars) = mlds__defns.
-ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars) = LocalDecls :-
- list__filter_map(ml_gen_local_var_decl(VarSet, VarTypes, Context),
- Vars, LocalDecls).
+ mlds__context, module_info, prog_vars) = mlds__defns.
+ml_gen_local_var_decls(VarSet, VarTypes, Context, ModuleInfo, Vars) =
+ LocalDecls :-
+ list__filter_map(ml_gen_local_var_decl(VarSet, VarTypes, Context,
+ ModuleInfo), Vars, LocalDecls).
% Generate a declaration for a local variable.
%
:- pred ml_gen_local_var_decl(prog_varset, map(prog_var, prog_type),
- mlds__context, prog_var, mlds__defn).
-:- mode ml_gen_local_var_decl(in, in, in, in, out) is semidet.
-ml_gen_local_var_decl(VarSet, VarTypes, Context, Var, MLDS_Defn) :-
+ mlds__context, module_info, prog_var, mlds__defn).
+:- mode ml_gen_local_var_decl(in, in, in, in, in, out) is semidet.
+ml_gen_local_var_decl(VarSet, VarTypes, Context, ModuleInfo, Var, MLDS_Defn) :-
map__lookup(VarTypes, Var, Type),
not type_util__is_dummy_argument_type(Type),
VarName = ml_gen_var_name(VarSet, Var),
- MLDS_Defn = ml_gen_var_decl(VarName, Type, Context).
+ MLDS_Defn = ml_gen_var_decl(VarName, Type, Context, ModuleInfo).
% Generate the code for a procedure body.
%
@@ -1107,19 +1096,21 @@
;
% generate a declaration for the variable (which
% will now become a local rather than a parameter)
+ { ml_gen_info_get_module_info(MLDSGenInfo,
+ ModuleInfo) },
{ VarDecl = ml_gen_var_decl(VarName, VarType,
- mlds__make_context(Context)) },
+ mlds__make_context(Context), ModuleInfo) },
{ LocalVarDecls = [VarDecl] },
% generate the assignment of the boxed variable
% to the dereferenced headvar
ml_qualify_var(VarName, VarLval),
ml_qualify_var(HeadVarName, HeadVarLval),
- { BoxedVarRval = unop(box(mercury_type(VarType)),
+ ml_gen_type(VarType, MLDS_VarType),
+ { BoxedVarRval = unop(box(MLDS_VarType),
lval(VarLval)) },
{ AssignStatement = ml_gen_assign(
- mem_ref(lval(HeadVarLval),
- mercury_type(ArgType)),
+ mem_ref(lval(HeadVarLval), MLDS_VarType),
BoxedVarRval, Context) },
{ ConvStatements = [AssignStatement] }
),
@@ -1200,8 +1191,9 @@
=(MLDSGenInfo),
{ ml_gen_info_get_varset(MLDSGenInfo, VarSet) },
{ ml_gen_info_get_var_types(MLDSGenInfo, VarTypes) },
+ { ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
{ VarDecls = ml_gen_local_var_decls(VarSet, VarTypes,
- mlds__make_context(Context), VarsList) },
+ mlds__make_context(Context), ModuleInfo, VarsList) },
%
% Generate code for the goal in its own code model.
@@ -1998,18 +1990,18 @@
->
ml_variable_type(Var, VarType),
ml_gen_var(Var, VarLval),
- { type_util__is_dummy_argument_type(VarType) ->
+ ( { type_util__is_dummy_argument_type(VarType) } ->
% The variable may not have been declared,
% so we need to generate a dummy value for it.
% Using `0' here is more efficient than
% using private_builtin__dummy_var, which is
% what ml_gen_var will have generated for this
% variable.
- ArgRval = const(int_const(0))
+ { ArgRval = const(int_const(0)) }
;
- ml_gen_box_or_unbox_rval(VarType, OrigType, lval(VarLval),
- ArgRval)
- },
+ ml_gen_box_or_unbox_rval(VarType, OrigType,
+ lval(VarLval), ArgRval)
+ ),
{ type_util__var(VarType, _) ->
Cast = "(MR_Word) "
;
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.14
diff -u -d -r1.14 ml_code_util.m
--- compiler/ml_code_util.m 2000/05/22 18:00:04 1.14
+++ compiler/ml_code_util.m 2000/05/30 11:45:41
@@ -28,10 +28,6 @@
% Various utility routines used for MLDS code generation.
%
- % A convenient abbreviation.
- %
-:- type prog_type == prog_data__type.
-
% Generate an MLDS assignment statement.
:- func ml_gen_assign(mlds__lval, mlds__rval, prog_context) = mlds__statement.
@@ -94,6 +90,20 @@
%-----------------------------------------------------------------------------%
%
+% Routines for generating types.
+%
+
+ % A convenient abbreviation.
+ %
+:- type prog_type == prog_data__type.
+
+ % Convert a Mercury type to an MLDS type.
+ %
+:- pred ml_gen_type(prog_type, mlds__type, ml_gen_info, ml_gen_info).
+:- mode ml_gen_type(in, out, in, out) is det.
+
+%-----------------------------------------------------------------------------%
+%
% Routines for generating function declarations (i.e. mlds__func_params).
%
@@ -101,7 +111,8 @@
%
:- func ml_gen_proc_params(module_info, pred_id, proc_id) = mlds__func_params.
-:- func ml_gen_proc_params_from_rtti(rtti_proc_label) = mlds__func_params.
+:- func ml_gen_proc_params_from_rtti(module_info, rtti_proc_label) =
+ mlds__func_params.
% Generate the function prototype for a procedure with the
% given argument types, modes, and code model.
@@ -190,7 +201,8 @@
% Generate a declaration for an MLDS variable, given its HLDS type.
%
-:- func ml_gen_var_decl(var_name, prog_type, mlds__context) = mlds__defn.
+:- func ml_gen_var_decl(var_name, prog_type, mlds__context, module_info) =
+ mlds__defn.
% Generate a declaration for an MLDS variable, given its MLDS type.
%
@@ -686,6 +698,16 @@
%-----------------------------------------------------------------------------%
%
+% Code for generating types.
+%
+
+ml_gen_type(Type, MLDS_Type) -->
+ =(Info),
+ { ml_gen_info_get_module_info(Info, ModuleInfo) },
+ { MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type) }.
+
+%-----------------------------------------------------------------------------%
+%
% Code for generating function declarations (i.e. mlds__func_params).
%
@@ -706,24 +728,14 @@
% As above, but from the rtti_proc_id rather than
% from the module_info, pred_id, and proc_id.
%
-ml_gen_proc_params_from_rtti(RttiProcId) = FuncParams :-
+ml_gen_proc_params_from_rtti(ModuleInfo, RttiProcId) = FuncParams :-
VarSet = RttiProcId^proc_varset,
HeadVars = RttiProcId^proc_headvars,
ArgTypes = RttiProcId^arg_types,
ArgModes = RttiProcId^proc_arg_modes,
CodeModel = RttiProcId^proc_interface_code_model,
-
HeadVarNames = ml_gen_var_names(VarSet, HeadVars),
-
- % XXX The setting of `UseNestedFunctions' to `no' is wrong!
- % We ought to thread the globals through here.
- % However, the UseNestedFunctions setting here
- % is only used to compute the source type for a cast,
- % and our current back-ends don't make use of that,
- % so currently it's not a big deal.
- UseNestedFunctions = no,
-
- FuncParams = ml_gen_params_base(UseNestedFunctions, HeadVarNames,
+ FuncParams = ml_gen_params_base(ModuleInfo, HeadVarNames,
ArgTypes, ArgModes, CodeModel).
% Generate the function prototype for a procedure with the
@@ -732,23 +744,20 @@
ml_gen_params(ModuleInfo, HeadVarNames, HeadTypes, HeadModes, CodeModel) =
FuncParams :-
modes_to_arg_modes(ModuleInfo, HeadModes, HeadTypes, ArgModes),
- module_info_globals(ModuleInfo, Globals),
- globals__lookup_bool_option(Globals, gcc_nested_functions,
- NestedFunctions),
- FuncParams = ml_gen_params_base(NestedFunctions, HeadVarNames,
+ FuncParams = ml_gen_params_base(ModuleInfo, HeadVarNames,
HeadTypes, ArgModes, CodeModel).
-:- func ml_gen_params_base(bool, list(string), list(prog_type),
+:- func ml_gen_params_base(module_info, list(string), list(prog_type),
list(arg_mode), code_model) = mlds__func_params.
-ml_gen_params_base(NestedFunctions, HeadVarNames, HeadTypes, HeadModes,
+ml_gen_params_base(ModuleInfo, HeadVarNames, HeadTypes, HeadModes,
CodeModel) = FuncParams :-
( CodeModel = model_semi ->
RetTypes = [mlds__native_bool_type]
;
RetTypes = []
),
- ml_gen_arg_decls(HeadVarNames, HeadTypes, HeadModes,
+ ml_gen_arg_decls(ModuleInfo, HeadVarNames, HeadTypes, HeadModes,
FuncArgs0),
( CodeModel = model_non ->
ContType = mlds__cont_type,
@@ -757,6 +766,9 @@
ContEnvType = mlds__generic_env_ptr_type,
ContEnvName = data(var("cont_env_ptr")),
ContEnvArg = ContEnvName - ContEnvType,
+ module_info_globals(ModuleInfo, Globals),
+ globals__lookup_bool_option(Globals, gcc_nested_functions,
+ NestedFunctions),
(
NestedFunctions = yes
->
@@ -773,11 +785,11 @@
% Given the argument variable names, and corresponding lists of their
% types and modes, generate the MLDS argument list declaration.
%
-:- pred ml_gen_arg_decls(list(mlds__var_name), list(prog_type), list(arg_mode),
- mlds__arguments).
-:- mode ml_gen_arg_decls(in, in, in, out) is det.
+:- pred ml_gen_arg_decls(module_info, list(mlds__var_name), list(prog_type),
+ list(arg_mode), mlds__arguments).
+:- mode ml_gen_arg_decls(in, in, in, in, out) is det.
-ml_gen_arg_decls(HeadVars, HeadTypes, HeadModes, FuncArgs) :-
+ml_gen_arg_decls(ModuleInfo, HeadVars, HeadTypes, HeadModes, FuncArgs) :-
(
HeadVars = [], HeadTypes = [], HeadModes = []
->
@@ -787,12 +799,12 @@
HeadTypes = [Type | Types],
HeadModes = [Mode | Modes]
->
- ml_gen_arg_decls(Vars, Types, Modes, FuncArgs0),
+ ml_gen_arg_decls(ModuleInfo, Vars, Types, Modes, FuncArgs0),
% exclude types such as io__state, etc.
( type_util__is_dummy_argument_type(Type) ->
FuncArgs = FuncArgs0
;
- ml_gen_arg_decl(Var, Type, Mode, FuncArg),
+ ml_gen_arg_decl(ModuleInfo, Var, Type, Mode, FuncArg),
FuncArgs = [FuncArg | FuncArgs0]
)
;
@@ -802,12 +814,12 @@
% Given an argument variable, and its type and mode,
% generate an MLDS argument declaration for it.
%
-:- pred ml_gen_arg_decl(var_name, prog_type, arg_mode,
+:- pred ml_gen_arg_decl(module_info, var_name, prog_type, arg_mode,
pair(mlds__entity_name, mlds__type)).
-:- mode ml_gen_arg_decl(in, in, in, out) is det.
+:- mode ml_gen_arg_decl(in, in, in, in, out) is det.
-ml_gen_arg_decl(Var, Type, ArgMode, FuncArg) :-
- MLDS_Type = mercury_type_to_mlds_type(Type),
+ml_gen_arg_decl(ModuleInfo, Var, Type, ArgMode, FuncArg) :-
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
( ArgMode \= top_in ->
MLDS_ArgType = mlds__ptr_type(MLDS_Type)
;
@@ -969,12 +981,12 @@
% output variables are passed by reference...
%
{ ml_gen_info_get_output_vars(MLDSGenInfo, OutputVars) },
- { list__member(Var, OutputVars) ->
- MLDS_Type = mercury_type_to_mlds_type(Type),
- Lval = mem_ref(lval(VarLval), MLDS_Type)
+ ( { list__member(Var, OutputVars) } ->
+ ml_gen_type(Type, MLDS_Type),
+ { Lval = mem_ref(lval(VarLval), MLDS_Type) }
;
- Lval = VarLval
- }
+ { Lval = VarLval }
+ )
).
% Lookup the types of a list of variables.
@@ -1010,9 +1022,9 @@
% Generate a declaration for an MLDS variable, given its HLDS type.
%
-ml_gen_var_decl(VarName, Type, Context) =
- ml_gen_mlds_var_decl(var(VarName), mercury_type_to_mlds_type(Type),
- Context).
+ml_gen_var_decl(VarName, Type, Context, ModuleInfo) =
+ ml_gen_mlds_var_decl(var(VarName),
+ mercury_type_to_mlds_type(ModuleInfo, Type), Context).
% Generate a declaration for an MLDS variable, given its MLDS type.
%
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.25
diff -u -d -r1.25 mlds.m
--- compiler/mlds.m 2000/05/26 07:09:12 1.25
+++ compiler/mlds.m 2000/05/30 11:30:12
@@ -261,9 +261,12 @@
:- interface.
-:- import_module hlds_pred, hlds_data, prog_data, builtin_ops, rtti.
+:- import_module hlds_module, hlds_pred, hlds_data.
+:- import_module prog_data, builtin_ops, rtti.
+:- import_module type_util.
-% To avoid duplication, we use a few things from the LLDS.
+% To avoid duplication, we use a few things from the LLDS
+% (specifically stuff for the C interface).
% It would be nice to avoid this dependency...
:- import_module llds.
@@ -314,6 +317,11 @@
% MLDS package.
:- func mlds_module_name_to_sym_name(mlds__package_name) = sym_name.
+% Given an MLDS module name (e.g. `foo.bar'), append another class qualifier
+% (e.g. for a class `baz'), and return the result (e.g. `foo.bar.baz').
+% The `arity' argument specifies the arity of the class.
+:- func mlds__append_class_qualifier(mlds_module_name, mlds__class_name, arity) =
+ mlds_module_name.
:- type mlds__defns == list(mlds__defn).
:- type mlds__defn
@@ -447,12 +455,14 @@
:- type mlds__class_defn
---> mlds__class_defn(
- mlds__class_kind,
- mlds__imports, % imports these classes (or
+ kind :: mlds__class_kind,
+ imports :: mlds__imports, % imports these classes (or
% modules, packages, ...)
- list(mlds__class_id), % inherits these base classes
- list(mlds__interface_id), % implements these interfaces
- mlds__defns % contains these members
+ inherits :: list(mlds__class_id),
+ % inherits these base classes
+ implements :: list(mlds__interface_id),
+ % implements these interfaces
+ members :: mlds__defns % contains these members
).
% Note: the definition of the `mlds__type' type is subject to change.
@@ -460,7 +470,11 @@
% switching on this type.
:- type mlds__type
---> % Mercury data types
- mercury_type(prog_data__type)
+ mercury_type(
+ prog_data__type, % the exact Mercury type
+ builtin_type % what kind of type it is:
+ % enum, float, etc.
+ )
% The type for the continuation functions used
% to handle nondeterminism
@@ -480,7 +494,11 @@
; mlds__native_char_type
% MLDS types defined using mlds__class_defn
- ; mlds__class_type(mlds__class, arity) % name, arity
+ ; mlds__class_type(
+ mlds__class, % name
+ arity,
+ mlds__class_kind
+ )
% MLDS array types.
% These are single-dimensional, and can be indexed
@@ -520,7 +538,7 @@
:- type mercury_type == prog_data__type.
-:- func mercury_type_to_mlds_type(mercury_type) = mlds__type.
+:- func mercury_type_to_mlds_type(module_info, mercury_type) = mlds__type.
% Hmm... this is tentative.
:- type mlds__class_id == mlds__type.
@@ -1149,7 +1167,7 @@
:- implementation.
:- import_module modules.
-:- import_module int, term, require.
+:- import_module int, term, string, require.
%-----------------------------------------------------------------------------%
@@ -1167,10 +1185,15 @@
%-----------------------------------------------------------------------------%
-% Currently mlds__types are just the same as Mercury types.
-% XXX something more complicated may be needed here...
+% Currently we return mlds__types that are just the same as Mercury types,
+% except that we also store the type category, so that we
+% can tell if the type is an enumeration or not, without
+% needing to refer to the HLDS type_table.
+% XXX It might be a better idea to get rid of the mercury_type/2
+% MLDS type and instead fully convert all Mercury types to MLDS types.
-mercury_type_to_mlds_type(Type) = mercury_type(Type).
+mercury_type_to_mlds_type(ModuleInfo, Type) = mercury_type(Type, Category) :-
+ classify_type(Type, ModuleInfo, Category).
%-----------------------------------------------------------------------------%
@@ -1198,6 +1221,11 @@
).
mlds_module_name_to_sym_name(MLDS_Package) = MLDS_Package.
+
+mlds__append_class_qualifier(Package, ClassName, ClassArity) =
+ qualified(Package, ClassQualifier) :-
+ string__format("%s_%d", [s(ClassName), i(ClassArity)],
+ ClassQualifier).
%-----------------------------------------------------------------------------%
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.34
diff -u -d -r1.34 mlds_to_c.m
--- compiler/mlds_to_c.m 2000/05/26 07:09:13 1.34
+++ compiler/mlds_to_c.m 2000/05/30 16:47:58
@@ -39,11 +39,12 @@
:- import_module hlds_pred. % for pred_proc_id.
:- import_module ml_code_util. % for ml_gen_mlds_var_decl, which is used by
% the code that handles tail recursion.
+:- import_module ml_type_gen. % for ml_gen_type_name
:- import_module globals, options, passes_aux.
:- import_module builtin_ops, c_util, modules.
-:- import_module prog_data, prog_out.
+:- import_module prog_data, prog_out, type_util.
-:- import_module bool, int, string, list, term, std_util, require.
+:- import_module bool, int, string, list, assoc_list, term, std_util, require.
%-----------------------------------------------------------------------------%
@@ -118,12 +119,25 @@
mlds_output_hdr_file(Indent, MLDS) -->
{ MLDS = mlds(ModuleName, ForeignCode, Imports, Defns) },
- { list__filter(defn_is_public, Defns, PublicDefns) },
mlds_output_hdr_start(Indent, ModuleName), io__nl,
mlds_output_hdr_imports(Indent, Imports), io__nl,
mlds_output_c_hdr_decls(Indent, ForeignCode), io__nl,
+ %
+ % The header file must contain _definitions_ of all public types,
+ % but only _declarations_ of all public variables, constants,
+ % and functions.
+ %
+ % Note that we don't forward-declare the types here; the
+ % forward declarations that we need for types used in function
+ % prototypes are generated by mlds_output_type_forward_decls.
+ % See the comment in mlds_output_decl.
+ %
+ { list__filter(defn_is_public, Defns, PublicDefns) },
+ { list__filter(defn_is_type, PublicDefns, PublicTypeDefns,
+ PublicNonTypeDefns) },
{ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName) },
- mlds_output_decls(Indent, MLDS_ModuleName, PublicDefns), io__nl,
+ mlds_output_defns(Indent, MLDS_ModuleName, PublicTypeDefns), io__nl,
+ mlds_output_decls(Indent, MLDS_ModuleName, PublicNonTypeDefns), io__nl,
mlds_output_hdr_end(Indent, ModuleName).
:- pred defn_is_public(mlds__defn).
@@ -133,6 +147,13 @@
Defn = mlds__defn(_Name, _Context, Flags, _Body),
access(Flags) \= private.
+:- 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(_, _).
+
:- pred defn_is_commit_type_var(mlds__defn).
:- mode defn_is_commit_type_var(in) is semidet.
@@ -177,14 +198,36 @@
mlds_output_src_file(Indent, MLDS) -->
{ MLDS = mlds(ModuleName, ForeignCode, Imports, Defns) },
- { list__filter(defn_is_public, Defns, _PublicDefns, PrivateDefns) },
mlds_output_src_start(Indent, ModuleName), io__nl,
mlds_output_src_imports(Indent, Imports), io__nl,
mlds_output_c_decls(Indent, ForeignCode), io__nl,
mlds_output_c_defns(Indent, ForeignCode), io__nl,
+ %
+ % The public types have already been defined in the
+ % header file, and the public vars, consts, and functions
+ % have already been declared in the header file.
+ % In the source file, we need to have
+ % #1. definitions of the private types,
+ % #2. forward-declarations of the private non-types
+ % #3. definitions of all the non-types
+ % in that order.
+ % #2 is needed to allow #3 to contain forward references,
+ % which can arise for e.g. mutually recursive procedures.
+ % #1 is needed since #2 may refer to the types.
+ %
+ % Note that we don't forward-declare the types here; the
+ % forward declarations that we need for types used in function
+ % prototypes are generated by mlds_output_type_forward_decls.
+ % See the comment in mlds_output_decl.
+ %
+ { list__filter(defn_is_public, Defns, _PublicDefns, PrivateDefns) },
+ { list__filter(defn_is_type, PrivateDefns, PrivateTypeDefns,
+ PrivateNonTypeDefns) },
+ { list__filter(defn_is_type, Defns, _TypeDefns, NonTypeDefns) },
{ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName) },
- mlds_output_decls(Indent, MLDS_ModuleName, PrivateDefns), io__nl,
- mlds_output_defns(Indent, MLDS_ModuleName, Defns), io__nl,
+ mlds_output_defns(Indent, MLDS_ModuleName, PrivateTypeDefns), io__nl,
+ mlds_output_decls(Indent, MLDS_ModuleName, PrivateNonTypeDefns), io__nl,
+ mlds_output_defns(Indent, MLDS_ModuleName, NonTypeDefns), io__nl,
mlds_output_src_end(Indent, ModuleName).
:- pred mlds_output_hdr_start(indent, mercury_module_name,
@@ -341,16 +384,116 @@
mlds_output_decl(Indent, ModuleName, Defn) -->
{ Defn = mlds__defn(Name, Context, Flags, DefnBody) },
- mlds_indent(Context, Indent),
- ( { Name = data(_) } ->
- % XXX for private data and private functions,
- % we should use "static"
- io__write_string("extern ")
+ (
+ %
+ % ANSI C does not permit forward declarations
+ % of enumeration types. So we just skip those.
+ % Currently they're not needed since we don't
+ % actually use the enum types.
+ %
+ { DefnBody = mlds__class(ClassDefn) },
+ { ClassDefn^kind = mlds__enum }
+ ->
+ []
;
+ %
+ % If we're using --high-level-data, then
+ % for function declarations, we need to ensure
+ % that we forward-declare any types used in
+ % the function parameters. This is because
+ % otherwise, for any struct names whose first
+ % occurence is in the function parameters,
+ % the scope of such struct names is just that
+ % function declaration, which is never right.
+ %
+ % We generate such forward declarations here,
+ % rather than generating type declarations in a
+ % header file and #including that header file,
+ % because doing the latter would significantly
+ % complicate the dependencies (to avoid cyclic
+ % #includes, you'd need to generate the type
+ % declarations in a different header file than
+ % the function declarations).
+ %
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ (
+ { HighLevelData = yes },
+ { DefnBody = mlds__function(_, Signature, _) }
+ ->
+ { Signature = mlds__func_params(Parameters,
+ _RetTypes) },
+ { assoc_list__values(Parameters, ParamTypes) },
+ list__foldl(mlds_output_type_forward_decls(Indent),
+ ParamTypes)
+ ;
+ []
+ ),
+ %
+ % Now output the declaration for this mlds__defn.
+ %
+ mlds_indent(Context, Indent),
+ ( { Name = data(_) } ->
+ % XXX for private data and private functions,
+ % we should use "static"
+ io__write_string("extern ")
+ ;
+ []
+ ),
+ mlds_output_decl_flags(Flags),
+ mlds_output_decl_body(Indent, qual(ModuleName, Name), DefnBody)
+ ).
+
+:- pred mlds_output_type_forward_decls(indent, mlds__type,
+ io__state, io__state).
+:- mode mlds_output_type_forward_decls(in, in, di, uo) is det.
+
+mlds_output_type_forward_decls(Indent, Type) -->
+ %
+ % Output forward declarations for all struct types
+ % that are contained in the specified type.
+ %
+ aggregate(mlds_type_contains_type(Type),
+ mlds_output_type_forward_decl(Indent)).
+
+ % mlds_type_contains_type(Type, SubType):
+ % True iff the type Type contains the type SubType.
+ %
+:- pred mlds_type_contains_type(mlds__type, mlds__type).
+:- mode mlds_type_contains_type(in, out) is multi.
+
+mlds_type_contains_type(Type, Type).
+mlds_type_contains_type(mlds__array_type(Type), Type).
+mlds_type_contains_type(mlds__ptr_type(Type), Type).
+mlds_type_contains_type(mlds__func_type(Parameters), Type) :-
+ Parameters = mlds__func_params(Arguments, RetTypes),
+ ( list__member(_Name - Type, Arguments)
+ ; list__member(Type, RetTypes)
+ ).
+
+:- pred mlds_output_type_forward_decl(indent, mlds__type,
+ io__state, io__state).
+:- mode mlds_output_type_forward_decl(in, in, di, uo) is det.
+
+mlds_output_type_forward_decl(Indent, Type) -->
+ (
+ {
+ Type = mlds__class_type(_Name, _Arity, Kind),
+ Kind \= mlds__enum,
+ ClassType = Type
+ ;
+ Type = mercury_type(MercuryType, user_type),
+ type_to_type_id(MercuryType, TypeId, _ArgsTypes),
+ ml_gen_type_name(TypeId, ClassName, ClassArity),
+ ClassType = mlds__class_type(ClassName, ClassArity,
+ mlds__class)
+ }
+ ->
+ mlds_indent(Indent),
+ mlds_output_type(ClassType),
+ io__write_string(";\n")
+ ;
[]
- ),
- mlds_output_decl_flags(Flags),
- mlds_output_decl_body(Indent, qual(ModuleName, Name), DefnBody).
+ ).
:- pred mlds_output_defn(indent, mlds_module_name, mlds__defn,
io__state, io__state).
@@ -402,8 +545,7 @@
mlds_output_func(Indent, Name, Context, Signature, MaybeBody)
;
{ DefnBody = mlds__class(ClassDefn) },
- mlds_output_class(Indent, Name, Context, ClassDefn),
- io__write_string(";\n")
+ mlds_output_class(Indent, Name, Context, ClassDefn)
).
@@ -416,8 +558,12 @@
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) -->
- io__write_string("struct "),
+mlds_output_class_decl(_Indent, Name, ClassDefn) -->
+ ( { ClassDefn^kind = mlds__enum } ->
+ io__write_string("enum ")
+ ;
+ io__write_string("struct ")
+ ),
mlds_output_fully_qualified_name(Name).
:- pred mlds_output_class(indent, mlds__qualified_entity_name, mlds__context,
@@ -425,15 +571,134 @@
:- mode mlds_output_class(in, in, in, in, di, uo) is det.
mlds_output_class(Indent, Name, Context, ClassDefn) -->
+ %
+ % 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.
+ %
+ % XXX this should be conditional: only when compiling to C,
+ % not when compiling to C++
+ %
+ { 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.
+ %
mlds_output_class_decl(Indent, Name, ClassDefn),
io__write_string(" {\n"),
- { ClassDefn = class_defn(_Kind, _Imports, _BaseClasses, _Implements,
- Defns) },
- { Name = qual(ModuleName, _) },
- mlds_output_defns(Indent + 1, ModuleName, Defns),
+ ( { Kind = mlds__enum } ->
+ mlds_output_enum_constants(Indent + 1, ClassModuleName,
+ BasesAndMembers)
+ ;
+ mlds_output_defns(Indent + 1, ClassModuleName,
+ BasesAndMembers)
+ ),
mlds_indent(Context, Indent),
- io__write_string("}").
+ io__write_string("};\n"),
+ mlds_output_defns(Indent, ClassModuleName, StaticMembers).
+
+:- 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.
+
+ % 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 data declarations/definitions
@@ -855,30 +1120,37 @@
:- pred mlds_output_type_prefix(mlds__type, io__state, io__state).
:- mode mlds_output_type_prefix(in, di, uo) is det.
-mlds_output_type_prefix(mercury_type(Type)) -->
- ( { Type = term__functor(term__atom("character"), [], _) } ->
- io__write_string("Char")
- ; { Type = term__functor(term__atom("int"), [], _) } ->
- io__write_string("Integer")
- ; { Type = term__functor(term__atom("string"), [], _) } ->
- io__write_string("String")
- ; { Type = term__functor(term__atom("float"), [], _) } ->
- io__write_string("Float")
- ; { Type = term__variable(_) } ->
- io__write_string("MR_Box")
- ;
- % XXX we ought to use pointers to struct types here,
- % so that distinct Mercury types map to distinct C types
- io__write_string("MR_Word")
- ).
+mlds_output_type_prefix(mercury_type(Type, TypeCategory)) -->
+ mlds_output_mercury_type_prefix(Type, TypeCategory).
mlds_output_type_prefix(mlds__native_int_type) --> io__write_string("int").
mlds_output_type_prefix(mlds__native_float_type) --> io__write_string("float").
mlds_output_type_prefix(mlds__native_bool_type) --> io__write_string("bool").
mlds_output_type_prefix(mlds__native_char_type) --> io__write_string("char").
-mlds_output_type_prefix(mlds__class_type(Name, Arity)) -->
- io__write_string("struct "),
- mlds_output_fully_qualified(Name, io__write_string),
- io__format("_%d", [i(Arity)]).
+mlds_output_type_prefix(mlds__class_type(Name, Arity, ClassKind)) -->
+ ( { ClassKind = mlds__enum } ->
+ %
+ % We can't just use the enumeration type,
+ % since the enumeration type's definition
+ % is not guaranteed to be in scope at this point.
+ % (Fixing that would be somewhat complicated; it would
+ % require writing enum definitions to a separate header file.)
+ % Also the enumeration might not be word-sized,
+ % which would cause problems for e.g. `std_util:arg/2'.
+ % So we just use `MR_Integer', and output the
+ % actual enumeration type as a comment.
+ %
+ io__write_string("MR_Integer /* actually `enum "),
+ mlds_output_fully_qualified(Name, io__write_string),
+ io__format("_%d", [i(Arity)]),
+ io__write_string("' */")
+ ;
+ % For struct types it's OK to output an incomplete type,
+ % since don't use these types directly, we only
+ % use pointers to them.
+ io__write_string("struct "),
+ mlds_output_fully_qualified(Name, io__write_string),
+ io__format("_%d", [i(Arity)])
+ ).
mlds_output_type_prefix(mlds__ptr_type(Type)) -->
mlds_output_type(Type),
io__write_string(" *").
@@ -912,15 +1184,77 @@
io__write_string("MR_"),
io__write_string(mlds_rtti_type_name(RttiName)).
+:- pred mlds_output_mercury_type_prefix(mercury_type, builtin_type,
+ io__state, io__state).
+:- mode mlds_output_mercury_type_prefix(in, in, di, uo) is det.
+
+mlds_output_mercury_type_prefix(Type, TypeCategory) -->
+ (
+ { TypeCategory = char_type },
+ io__write_string("MR_Char")
+ ;
+ { TypeCategory = int_type },
+ io__write_string("MR_Integer")
+ ;
+ { TypeCategory = str_type },
+ io__write_string("MR_String")
+ ;
+ { TypeCategory = float_type },
+ io__write_string("MR_Float")
+ ;
+ { TypeCategory = polymorphic_type },
+ io__write_string("MR_Box")
+ ;
+ { TypeCategory = pred_type },
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ io__write_string("MR_ClosurePtr")
+ ;
+ io__write_string("MR_Word")
+ )
+ ;
+ { TypeCategory = enum_type },
+ mlds_output_mercury_user_type_prefix(Type, TypeCategory)
+ ;
+ { TypeCategory = user_type },
+ mlds_output_mercury_user_type_prefix(Type, TypeCategory)
+ ).
+
+:- pred mlds_output_mercury_user_type_prefix(mercury_type, builtin_type,
+ io__state, io__state).
+:- mode mlds_output_mercury_user_type_prefix(in, in, di, uo) is det.
+
+mlds_output_mercury_user_type_prefix(Type, TypeCategory) -->
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ ( { type_to_type_id(Type, TypeId, _ArgsTypes) } ->
+ { ml_gen_type_name(TypeId, ClassName, ClassArity) },
+ { TypeCategory = enum_type ->
+ MLDS_Type = mlds__class_type(ClassName,
+ ClassArity, mlds__enum)
+ ;
+ MLDS_Type = mlds__ptr_type(mlds__class_type(
+ ClassName, ClassArity, mlds__class))
+ },
+ mlds_output_type_prefix(MLDS_Type)
+ ;
+ { error("mlds_output_mercury_user_type_prefix") }
+ )
+ ;
+ % for the --no-high-level-data case,
+ % we just treat everything as `MR_Word'
+ io__write_string("MR_Word")
+ ).
+
:- pred mlds_output_type_suffix(mlds__type, io__state, io__state).
:- mode mlds_output_type_suffix(in, di, uo) is det.
-mlds_output_type_suffix(mercury_type(_)) --> [].
+mlds_output_type_suffix(mercury_type(_, _)) --> [].
mlds_output_type_suffix(mlds__native_int_type) --> [].
mlds_output_type_suffix(mlds__native_float_type) --> [].
mlds_output_type_suffix(mlds__native_bool_type) --> [].
mlds_output_type_suffix(mlds__native_char_type) --> [].
-mlds_output_type_suffix(mlds__class_type(_, _)) --> [].
+mlds_output_type_suffix(mlds__class_type(_, _, _)) --> [].
mlds_output_type_suffix(mlds__ptr_type(_)) --> [].
mlds_output_type_suffix(mlds__array_type(_)) -->
io__write_string("[]").
@@ -983,7 +1317,7 @@
:- pred mlds_output_finality(finality, io__state, io__state).
:- mode mlds_output_finality(in, di, uo) is det.
-mlds_output_finality(final) --> io__write_string("final ").
+mlds_output_finality(final) --> io__write_string("/* final */ ").
mlds_output_finality(overridable) --> [].
:- pred mlds_output_constness(constness, io__state, io__state).
@@ -1521,12 +1855,24 @@
io__write_string(" = "),
( { MaybeTag = yes(Tag0) } ->
{ Tag = Tag0 },
- io__write_string("(MR_Word) MR_mkword("),
+ io__write_string("("),
+ mlds_output_type(Type),
+ io__write_string(") "),
+ io__write_string("MR_mkword("),
mlds_output_tag(Tag),
io__write_string(", "),
{ EndMkword = ")" }
;
{ Tag = 0 },
+ %
+ % XXX we shouldn't need the cast here,
+ % but currently the type that we include
+ % in the call to MR_new_object() is not
+ % always correct.
+ %
+ io__write_string("("),
+ mlds_output_type(Type),
+ io__write_string(") "),
{ EndMkword = "" }
),
io__write_string("MR_new_object("),
@@ -1649,13 +1995,13 @@
FieldType, _ClassType)) -->
(
{ FieldType = mlds__generic_type
- ; FieldType = mlds__mercury_type(term__variable(_))
+ ; FieldType = mlds__mercury_type(term__variable(_), _)
}
->
% XXX this generated code is ugly;
% it would be nicer to use a different macro
% than MR_field(), one which had type `MR_Box'
- % rather than `Word'.
+ % rather than `MR_Word'.
io__write_string("(* (MR_Box *) &")
;
% The field type for field(_, _, offset(_), _, _) lvals
@@ -1823,7 +2169,7 @@
mlds_output_boxed_rval(Type, Exprn) -->
(
{ Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _))
+ [], _), _)
; Type = mlds__native_float_type
}
->
@@ -1847,7 +2193,7 @@
mlds_output_unboxed_rval(Type, Exprn) -->
(
{ Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _))
+ [], _), _)
; Type = mlds__native_float_type
}
->
@@ -1875,6 +2221,13 @@
{ c_util__unary_prefix_op(UnaryOp, UnaryOpString) },
io__write_string(UnaryOpString),
io__write_string("("),
+ ( { UnaryOp = tag } ->
+ % The MR_tag macro requires its argument to be of type `Word'.
+ % XXX should we put this cast inside the definition of MR_tag?
+ io__write_string("(MR_Word) ")
+ ;
+ []
+ ),
mlds_output_rval(Exprn),
io__write_string(")").
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.7
diff -u -d -r1.7 ml_elim_nested.m
--- compiler/ml_elim_nested.m 2000/05/26 07:09:13 1.7
+++ compiler/ml_elim_nested.m 2000/05/30 11:54:03
@@ -157,7 +157,7 @@
% XXX this should be optimized to generate
% EnvTypeName from just EnvName
ml_create_env(EnvName, [], Context, ModuleName,
- _EnvType, EnvTypeName, _EnvDecls, _InitEnv),
+ _EnvTypeDefn, EnvTypeName, _EnvDecls, _InitEnv),
%
% traverse the function body, finding (and removing)
@@ -186,8 +186,8 @@
% functions
%
ml_create_env(EnvName, LocalVars, Context, ModuleName,
- EnvType, _EnvTypeName, EnvDecls, InitEnv),
- list__map(ml_insert_init_env(EnvName, ModuleName),
+ EnvTypeDefn, _EnvTypeName, EnvDecls, InitEnv),
+ list__map(ml_insert_init_env(EnvTypeName, ModuleName),
NestedFuncs0, NestedFuncs),
%
@@ -215,7 +215,7 @@
% at the start of the list of definitions,
% followed by the new version of the top-level function
%
- HoistedDefns = [EnvType | NestedFuncs]
+ HoistedDefns = [EnvTypeDefn | NestedFuncs]
),
DefnBody = mlds__function(PredProcId, Params, yes(FuncBody)),
Defn = mlds__defn(Name, Context, Flags, DefnBody),
@@ -272,7 +272,8 @@
% env_ptr->foo = foo;
%
QualVarName = qual(ModuleName, VarName),
- FieldName = named_field(QualVarName),
+ EnvModuleName = ml_env_module_name(ClassType),
+ FieldName = named_field(qual(EnvModuleName, VarName)),
Tag = yes(0),
EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
EnvArgLval = field(Tag, EnvPtr, FieldName, FieldType,
@@ -306,7 +307,7 @@
:- mode ml_create_env(in, in, in, in, out, out, out, out) is det.
ml_create_env(EnvClassName, LocalVars, Context, ModuleName,
- EnvType, EnvTypeName, EnvDecls, InitEnv) :-
+ EnvTypeDefn, EnvTypeName, EnvDecls, InitEnv) :-
%
% generate the following type:
%
@@ -314,12 +315,14 @@
% <LocalVars>
% };
%
+ EnvTypeKind = mlds__struct,
+ EnvTypeName = class_type(qual(ModuleName, EnvClassName), 0,
+ EnvTypeKind),
EnvTypeEntityName = type(EnvClassName, 0),
- EnvTypeName = class_type(qual(ModuleName, EnvClassName), 0),
EnvTypeFlags = env_decl_flags,
- EnvTypeDefnBody = mlds__class(mlds__class_defn(mlds__struct, [],
+ EnvTypeDefnBody = mlds__class(mlds__class_defn(EnvTypeKind, [],
[mlds__generic_env_ptr_type], [], LocalVars)),
- EnvType = mlds__defn(EnvTypeEntityName, Context, EnvTypeFlags,
+ EnvTypeDefn = mlds__defn(EnvTypeEntityName, Context, EnvTypeFlags,
EnvTypeDefnBody),
%
@@ -329,9 +332,9 @@
%
EnvVarName = data(var("env")),
EnvVarFlags = env_decl_flags,
- EnvVarType = mlds__class_type(qual(ModuleName, EnvClassName), 0),
- EnvVarDefnBody = mlds__data(EnvVarType, no_initializer),
- EnvVarDecl = mlds__defn(EnvVarName, Context, EnvVarFlags, EnvVarDefnBody),
+ EnvVarDefnBody = mlds__data(EnvTypeName, no_initializer),
+ EnvVarDecl = mlds__defn(EnvVarName, Context, EnvVarFlags,
+ EnvVarDefnBody),
%
% declare the `env_ptr' var, and
@@ -339,7 +342,7 @@
%
EnvVar = qual(ModuleName, "env"),
EnvVarAddr = mem_addr(var(EnvVar)),
- ml_init_env(EnvClassName, EnvVarAddr, Context, ModuleName,
+ ml_init_env(EnvTypeName, EnvVarAddr, Context, ModuleName,
EnvPtrVarDecl, InitEnv),
% group those two declarations together
@@ -361,17 +364,17 @@
% <Body>
% }
%
-:- pred ml_insert_init_env(mlds__class_name, mlds_module_name,
+:- pred ml_insert_init_env(mlds__type, mlds_module_name,
mlds__defn, mlds__defn).
:- mode ml_insert_init_env(in, in, in, out) is det.
-ml_insert_init_env(ClassName, ModuleName, Defn0, Defn) :-
+ml_insert_init_env(TypeName, ModuleName, Defn0, Defn) :-
Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
(
DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0)),
statement_contains_var(FuncBody0, qual(ModuleName, "env_ptr"))
->
EnvPtrVal = lval(var(qual(ModuleName, "env_ptr_arg"))),
- ml_init_env(ClassName, EnvPtrVal, Context, ModuleName,
+ ml_init_env(TypeName, EnvPtrVal, Context, ModuleName,
EnvPtrDecl, InitEnvPtr),
FuncBody = mlds__statement(block([EnvPtrDecl],
[InitEnvPtr, FuncBody0]), Context),
@@ -386,24 +389,20 @@
% struct <EnvClassName> *env_ptr;
% env_ptr = <EnvPtrVal>;
%
-:- pred ml_init_env(mlds__class_name, mlds__rval,
+:- pred ml_init_env(mlds__type, mlds__rval,
mlds__context, mlds_module_name, mlds__defn, mlds__statement).
:- mode ml_init_env(in, in, in, in, out, out) is det.
-ml_init_env(EnvClassName, EnvPtrVal, Context, ModuleName,
+ml_init_env(EnvTypeName, EnvPtrVal, Context, ModuleName,
EnvPtrVarDecl, InitEnvPtr) :-
-
- % compute the `struct <EnvClassName>' type
- EnvVarType = mlds__class_type(qual(ModuleName, EnvClassName), 0),
-
%
% generate the following variable declaration:
%
- % struct <EnvClassName> *env_ptr;
+ % <EnvTypeName> *env_ptr;
%
EnvPtrVarName = data(var("env_ptr")),
EnvPtrVarFlags = env_decl_flags,
- EnvPtrVarType = mlds__ptr_type(EnvVarType),
+ EnvPtrVarType = mlds__ptr_type(EnvTypeName),
EnvPtrVarDefnBody = mlds__data(EnvPtrVarType, no_initializer),
EnvPtrVarDecl = mlds__defn(EnvPtrVarName, Context, EnvPtrVarFlags,
EnvPtrVarDefnBody),
@@ -874,7 +873,8 @@
solutions(IsLocal, [FieldType])
->
EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
- FieldName = named_field(ThisVar),
+ EnvModuleName = ml_env_module_name(ClassType),
+ FieldName = named_field(qual(EnvModuleName, ThisVarName)),
Tag = yes(0),
Lval = field(Tag, EnvPtr, FieldName, FieldType, ClassType)
;
@@ -953,6 +953,15 @@
Lval = make_envptr_ref(Depth - 1, NewEnvPtr, EnvPtrVar, Var)
).
*********/
+
+:- func ml_env_module_name(mlds__type) = mlds_module_name.
+ml_env_module_name(ClassType) = EnvModuleName :-
+ ( ClassType = class_type(qual(ClassModule, ClassName), Arity, _Kind) ->
+ EnvModuleName = mlds__append_class_qualifier(ClassModule,
+ ClassName, Arity)
+ ;
+ error("ml_env_module_name: ClassType is not a class")
+ ).
%-----------------------------------------------------------------------------%
%
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.11
diff -u -d -r1.11 ml_call_gen.m
--- compiler/ml_call_gen.m 2000/05/26 07:09:11 1.11
+++ compiler/ml_call_gen.m 2000/05/30 11:50:55
@@ -58,8 +58,9 @@
% and given an source rval holding a value of the source type,
% produce an rval that converts the source rval to the destination type.
%
-:- pred ml_gen_box_or_unbox_rval(prog_type, prog_type, mlds__rval, mlds__rval).
-:- mode ml_gen_box_or_unbox_rval(in, in, in, out) is det.
+:- pred ml_gen_box_or_unbox_rval(prog_type, prog_type, mlds__rval, mlds__rval,
+ ml_gen_info, ml_gen_info).
+:- mode ml_gen_box_or_unbox_rval(in, in, in, out, in, out) is det.
% This is like `ml_gen_box_or_unbox_rval', except that it
% works on lvals rather than rvals.
@@ -462,8 +463,8 @@
;
VarRval = lval(VarLval)
},
- { ml_gen_box_or_unbox_rval(CallerType, CalleeType,
- VarRval, ArgRval) },
+ ml_gen_box_or_unbox_rval(CallerType, CalleeType,
+ VarRval, ArgRval),
{ InputRvals = [ArgRval | InputRvals1] },
{ OutputLvals = OutputLvals1 },
{ ConvDecls = ConvDecls1 },
@@ -513,25 +514,27 @@
% Convert VarRval, of type SourceType,
% to ArgRval, of type DestType.
-ml_gen_box_or_unbox_rval(SourceType, DestType, VarRval, ArgRval) :-
+ml_gen_box_or_unbox_rval(SourceType, DestType, VarRval, ArgRval) -->
(
%
% if converting from polymorphic type to concrete type,
% then unbox
%
- SourceType = term__variable(_),
- DestType = term__functor(_, _, _)
+ { SourceType = term__variable(_) },
+ { DestType = term__functor(_, _, _) }
->
- ArgRval = unop(unbox(mercury_type(DestType)), VarRval)
+ ml_gen_type(DestType, MLDS_DestType),
+ { ArgRval = unop(unbox(MLDS_DestType), VarRval) }
;
%
% if converting from concrete type to polymorphic type,
% then box
%
- SourceType = term__functor(_, _, _),
- DestType = term__variable(_)
+ { SourceType = term__functor(_, _, _) },
+ { DestType = term__variable(_) }
->
- ArgRval = unop(box(mercury_type(SourceType)), VarRval)
+ ml_gen_type(SourceType, MLDS_SourceType),
+ { ArgRval = unop(box(MLDS_SourceType), VarRval) }
;
%
% if converting from one concrete type to a different
@@ -540,15 +543,16 @@
% This is needed to handle construction/deconstruction
% unifications for no_tag types.
%
- \+ type_util__type_unify(SourceType, DestType,
- [], map__init, _)
+ { \+ type_util__type_unify(SourceType, DestType,
+ [], map__init, _) }
->
- ArgRval = unop(cast(mercury_type(DestType)), VarRval)
+ ml_gen_type(DestType, MLDS_DestType),
+ { ArgRval = unop(cast(MLDS_DestType), VarRval) }
;
%
% otherwise leave unchanged
%
- ArgRval = VarRval
+ { ArgRval = VarRval }
).
ml_gen_box_or_unbox_lval(CallerType, CalleeType, VarLval, VarName, Context,
@@ -558,9 +562,10 @@
% if no boxing/unboxing is required, then ml_box_or_unbox_rval
% will return its argument unchanged, and so we're done.
%
+ ml_gen_box_or_unbox_rval(CalleeType, CallerType, lval(VarLval),
+ BoxedRval),
(
- { ml_gen_box_or_unbox_rval(CalleeType, CallerType,
- lval(VarLval), lval(VarLval)) }
+ { BoxedRval = lval(VarLval) }
->
{ ArgLval = VarLval },
{ ConvDecls = [] },
@@ -577,8 +582,10 @@
ml_gen_info_new_conv_var(ConvVarNum),
{ string__format("conv%d_%s", [i(ConvVarNum), s(VarName)],
ArgVarName) },
+ =(Info),
+ { ml_gen_info_get_module_info(Info, ModuleInfo) },
{ ArgVarDecl = ml_gen_var_decl(ArgVarName, CalleeType,
- mlds__make_context(Context)) },
+ mlds__make_context(Context), ModuleInfo) },
{ ConvDecls = [ArgVarDecl] },
% create the lval for the variable and use it for the
@@ -596,8 +603,8 @@
% and the callee type, since this is an output not
% an input, so the callee type is the source type
% and the caller type is the destination type.
- { ml_gen_box_or_unbox_rval(CalleeType, CallerType,
- lval(ArgLval), ConvertedArgRval) },
+ ml_gen_box_or_unbox_rval(CalleeType, CallerType,
+ lval(ArgLval), ConvertedArgRval),
{ AssignStatement = ml_gen_assign(VarLval,
ConvertedArgRval, Context) },
{ ConvStatements = [AssignStatement] }
Index: compiler/ml_type_gen.m
===================================================================
RCS file: ml_type_gen.m
diff -N ml_type_gen.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ ml_type_gen.m Wed May 31 02:40:02 2000
@@ -0,0 +1,425 @@
+%-----------------------------------------------------------------------------%
+% 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.
+%-----------------------------------------------------------------------------%
+
+% File: ml_type_gen.m
+% Main author: fjh
+
+% MLDS type generation -- convert HLDS types to MLDS.
+
+% For enumerations, we use a Java-style emulation: we conver them
+% to classes with a single int member, plus a bunch of static const
+% members for the different enumerations consts.
+%
+% For discriminated unions, we create an MLDS base class type
+% corresponding to the HLDS type, and we also create MLDS
+% derived class types corresponding to each of the constructors
+% which are defined from the base class type.
+
+%-----------------------------------------------------------------------------%
+
+:- module ml_type_gen.
+:- interface.
+:- import_module prog_data, hlds_module, hlds_data, mlds.
+:- import_module io.
+
+ % Generate MLDS definitions for all the types in the HLDS.
+ %
+:- pred ml_gen_types(module_info, mlds__defns, io__state, io__state).
+:- mode ml_gen_types(in, out, di, uo) is det.
+
+ % Given an HLDS type_id, generate the MLDS class name and arity
+ % for the corresponding MLDS type.
+ %
+:- pred ml_gen_type_name(type_id, mlds__class, arity).
+:- mode ml_gen_type_name(in, out, out) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+:- import_module hlds_pred, prog_data, prog_util.
+:- import_module ml_code_util.
+:- import_module globals, options.
+
+:- import_module bool, int, string, list, map, std_util, require.
+
+ml_gen_types(ModuleInfo, MLDS_TypeDefns) -->
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ { module_info_types(ModuleInfo, TypeTable) },
+ { map__keys(TypeTable, TypeIds) },
+ { list__foldl(ml_gen_type_defn(ModuleInfo, TypeTable),
+ TypeIds, [], MLDS_TypeDefns) }
+ ;
+ { MLDS_TypeDefns = [] }
+ ).
+
+:- pred ml_gen_type_defn(module_info, type_table, type_id,
+ mlds__defns, mlds__defns).
+:- mode ml_gen_type_defn(in, in, in, in, out) is det.
+
+ml_gen_type_defn(ModuleInfo, TypeTable, TypeId, MLDS_Defns0, MLDS_Defns) :-
+ map__lookup(TypeTable, TypeId, TypeDefn),
+ hlds_data__get_type_defn_status(TypeDefn, Status),
+ ( status_defined_in_this_module(Status, yes) ->
+ hlds_data__get_type_defn_body(TypeDefn, TypeBody),
+ ml_gen_type_2(TypeBody, ModuleInfo, TypeId, TypeDefn,
+ MLDS_Defns0, MLDS_Defns)
+ ;
+ MLDS_Defns = MLDS_Defns0
+ ).
+
+:- pred ml_gen_type_2(hlds_type_body, module_info, type_id, hlds_type_defn,
+ mlds__defns, mlds__defns).
+:- mode ml_gen_type_2(in, in, in, in, in, out) is det.
+
+ml_gen_type_2(abstract_type, _, _, _) --> [].
+ml_gen_type_2(eqv_type(_EqvType), _, _, _) --> []. % XXX Fixme!
+ml_gen_type_2(uu_type(_), _, _, _) -->
+ { error("sorry, undiscriminated union types not implemented") }.
+ml_gen_type_2(du_type(Ctors, TagValues, IsEnum, MaybeEqualityPred),
+ ModuleInfo, TypeId, TypeDefn) -->
+ { ml_gen_equality_members(MaybeEqualityPred, MaybeEqualityMembers) },
+ ( { IsEnum = yes } ->
+ ml_gen_enum_type(TypeId, TypeDefn, Ctors, TagValues,
+ MaybeEqualityMembers)
+ ;
+ ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn,
+ Ctors, TagValues, MaybeEqualityMembers)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Enumeration types.
+%
+
+ %
+ % For each enumeration, we generate an MLDS type of the following form:
+ %
+ % struct <ClassName> {
+ % static const int <ctor1> = 0;
+ % static const int <ctor2> = 1;
+ % ...
+ % int value;
+ % };
+ %
+ % It is marked as an mlds__enum so that the MLDS -> target code
+ % generator can treat it specially if need be (e.g. generating
+ % a C enum rather than a class).
+ %
+:- pred ml_gen_enum_type(type_id, hlds_type_defn, list(constructor),
+ cons_tag_values, mlds__defns, mlds__defns, mlds__defns).
+:- mode ml_gen_enum_type(in, in, in, in, in, in, out) is det.
+
+ml_gen_enum_type(TypeId, TypeDefn, Ctors, TagValues,
+ MaybeEqualityMembers, MLDS_Defns0, MLDS_Defns) :-
+ hlds_data__get_type_defn_context(TypeDefn, Context),
+ MLDS_Context = mlds__make_context(Context),
+
+ % generate the class name
+ ml_gen_type_name(TypeId, qual(_, MLDS_ClassName), MLDS_ClassArity),
+
+ % generate the class members
+ ValueMember = ml_gen_enum_value_member(Context),
+ EnumConstMembers = list__map(ml_gen_enum_constant(Context, TagValues),
+ Ctors),
+ Members = list__append(MaybeEqualityMembers,
+ [ValueMember|EnumConstMembers]),
+
+ % enums don't import or inherit anything
+ Imports = [],
+ Inherits = [],
+ Implements = [],
+
+ % put it all together
+ MLDS_TypeName = type(MLDS_ClassName, MLDS_ClassArity),
+ MLDS_TypeFlags = ml_gen_type_decl_flags,
+ MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__enum,
+ Imports, Inherits, Implements, Members)),
+ MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
+ MLDS_TypeDefnBody),
+
+ MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
+
+:- func ml_gen_enum_value_member(prog_context) = mlds__defn.
+ml_gen_enum_value_member(Context) =
+ mlds__defn(data(var("value")),
+ mlds__make_context(Context),
+ ml_gen_member_decl_flags,
+ mlds__data(mlds__native_int_type, no_initializer)).
+
+:- func ml_gen_enum_constant(prog_context, cons_tag_values, constructor) =
+ mlds__defn.
+
+ml_gen_enum_constant(Context, ConsTagValues, Ctor) = MLDS_Defn :-
+ %
+ % figure out the value of this enumeration constant
+ %
+ Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
+ list__length(Args, Arity),
+ map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
+ ( TagVal = int_constant(Int) ->
+ ConstValue = const(int_const(Int))
+ ;
+ error("ml_gen_enum_constant: enum constant needs int tag")
+ ),
+ % sanity check
+ require(unify(Arity, 0), "ml_gen_enum_constant: arity != []"),
+
+ %
+ % generate an MLDS definition for this enumeration constant.
+ %
+ unqualify_name(Name, UnqualifiedName),
+ MLDS_Defn = mlds__defn(data(var(UnqualifiedName)),
+ mlds__make_context(Context),
+ ml_gen_enum_constant_decl_flags,
+ mlds__data(mlds__native_int_type, init_obj(ConstValue))).
+
+%-----------------------------------------------------------------------------%
+%
+% Discriminated union types.
+%
+
+ %
+ % For each discriminated union type, we generate an MLDS type of the
+ % following form:
+ %
+ % class <ClassName> {
+ % public:
+ % int data_tag;
+ % /* constants used for data_tag */
+ % static const int <ctor1> = 0;
+ % static const int <ctor2> = 1;
+ % ...
+ % /*
+ % ** Derived classes, one for each constructor;
+ % ** these are generated as nested classes to
+ % ** avoid name clashes.
+ % */
+ % class <ctor1> : public <ClassName> {
+ % public:
+ % /*
+ % ** fields, one for each argument of this
+ % ** constructor
+ % */
+ % MR_Word F1;
+ % MR_Word F2;
+ % ...
+ % };
+ % class <ctor2> : public <ClassName> {
+ % public:
+ % ...
+ % };
+ % ...
+ % };
+ %
+:- pred ml_gen_du_parent_type(module_info, type_id, hlds_type_defn,
+ list(constructor), cons_tag_values, mlds__defns,
+ mlds__defns, mlds__defns).
+:- mode ml_gen_du_parent_type(in, in, in, in, in, in, in, out) is det.
+
+ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn, Ctors, _TagValues,
+ MaybeEqualityMembers, MLDS_Defns0, MLDS_Defns) :-
+ hlds_data__get_type_defn_context(TypeDefn, Context),
+ MLDS_Context = mlds__make_context(Context),
+
+ % generate the class name
+ ml_gen_type_name(TypeId, qual(_, MLDS_ClassName), MLDS_ClassArity),
+
+ % generate the class members
+ TagMember = ml_gen_tag_member("data_tag", Context),
+ TagConstMembers = [],
+ % XXX we don't yet bother with these;
+ % mlds_to_c.m doesn't support static members.
+ % TagConstMembers = list__condense(list__map(
+ % ml_gen_tag_constant(Context, TagValues), Ctors)),
+ Members0 = list__append(MaybeEqualityMembers,
+ [TagMember|TagConstMembers]),
+
+ % generate the nested derived classes
+ list__foldl(ml_gen_du_ctor_type(ModuleInfo, TypeId, TypeDefn), Ctors,
+ Members0, Members),
+
+ % the base class doesn't import or inherit anything
+ Imports = [],
+ Inherits = [],
+ Implements = [],
+
+ % put it all together
+ MLDS_TypeName = type(MLDS_ClassName, MLDS_ClassArity),
+ MLDS_TypeFlags = ml_gen_type_decl_flags,
+ MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
+ Imports, Inherits, Implements, Members)),
+ MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
+ MLDS_TypeDefnBody),
+
+ MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
+
+:- func ml_gen_tag_member(mlds__var_name, prog_context) = mlds__defn.
+ml_gen_tag_member(Name, Context) =
+ mlds__defn(data(var(Name)),
+ mlds__make_context(Context),
+ ml_gen_member_decl_flags,
+ mlds__data(mlds__native_int_type, no_initializer)).
+
+:- func ml_gen_tag_constant(prog_context, cons_tag_values, constructor) =
+ mlds__defns.
+
+ml_gen_tag_constant(Context, ConsTagValues, Ctor) = MLDS_Defns :-
+ %
+ % Check if this constructor uses a secondary tag.
+ %
+ Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
+ list__length(Args, Arity),
+ map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
+ ( TagVal = shared_remote_tag(_PrimaryTag, SecondaryTag) ->
+ %
+ % Generate an MLDS definition for this secondary
+ % tag constant. We do this mainly for readability
+ % and interoperability. Note that we don't do the
+ % same thing for primary tags, so this is most
+ % useful in the `--tags none' case, where there
+ % will be no primary tags.
+ %
+ unqualify_name(Name, UnqualifiedName),
+ ConstValue = const(int_const(SecondaryTag)),
+ MLDS_Defn = mlds__defn(data(var(UnqualifiedName)),
+ mlds__make_context(Context),
+ ml_gen_enum_constant_decl_flags,
+ mlds__data(mlds__native_int_type,
+ init_obj(ConstValue))),
+ MLDS_Defns = [MLDS_Defn]
+ ;
+ MLDS_Defns = []
+ ).
+
+:- pred ml_gen_du_ctor_type(module_info, type_id, hlds_type_defn, constructor,
+ mlds__defns, mlds__defns).
+:- mode ml_gen_du_ctor_type(in, in, in, in, in, out) is det.
+
+ml_gen_du_ctor_type(ModuleInfo, TypeId, TypeDefn, Ctor,
+ MLDS_Defns0, MLDS_Defns) :-
+ Ctor = ctor(_ExistQTVars, _Constraints, CtorName, Args),
+
+ % XXX we should keep a context for the constructor,
+ % but we don't, so we just use the context from the type.
+ hlds_data__get_type_defn_context(TypeDefn, Context),
+ MLDS_Context = mlds__make_context(Context),
+
+ % generate the base class name
+ ClassKind = mlds__class,
+ ml_gen_type_name(TypeId, BaseClassName, BaseClassArity),
+ BaseClassId = mlds__class_type(BaseClassName, BaseClassArity,
+ ClassKind),
+
+ % generate the class name for this constructor
+ unqualify_name(CtorName, CtorClassName),
+ list__length(Args, CtorArity),
+
+ % generate the class members,
+ % numbering any unnamed fields starting from 1
+ list__map_foldl(ml_gen_du_ctor_member(ModuleInfo, Context),
+ Args, Members, 1, _),
+
+ % we inherit the base class for this type
+ Imports = [],
+ Inherits = [BaseClassId],
+ Implements = [],
+
+ % put it all together
+ MLDS_TypeName = type(CtorClassName, CtorArity),
+ MLDS_TypeFlags = ml_gen_type_decl_flags,
+ MLDS_TypeDefnBody = mlds__class(mlds__class_defn(ClassKind,
+ Imports, Inherits, Implements, Members)),
+ MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
+ MLDS_TypeDefnBody),
+
+ MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
+
+:- pred ml_gen_du_ctor_member(module_info, prog_context,
+ constructor_arg, mlds__defn, int, int).
+:- mode ml_gen_du_ctor_member(in, in, in, out, in, out) is det.
+
+ml_gen_du_ctor_member(ModuleInfo, Context, MaybeFieldName - Type, MLDS_Defn,
+ ArgNum0, ArgNum) :-
+ (
+ MaybeFieldName = yes(QualifiedFieldName),
+ unqualify_name(QualifiedFieldName, FieldName)
+ ;
+ MaybeFieldName = no,
+ FieldName = string__format("F%d", [i(ArgNum0)])
+ ),
+ MLDS_Defn = ml_gen_var_decl(FieldName, Type,
+ mlds__make_context(Context), ModuleInfo),
+ ArgNum = ArgNum0 + 1.
+
+%-----------------------------------------------------------------------------%
+%
+% Miscellaneous helper routines.
+%
+
+ml_gen_type_name(Name - Arity, qual(MLDS_Module, TypeName), Arity) :-
+ (
+ Name = qualified(ModuleName, TypeName)
+ ;
+ % builtin types like `int' may be still unqualified
+ % at this point
+ Name = unqualified(TypeName),
+ mercury_public_builtin_module(ModuleName)
+ ),
+ MLDS_Module = mercury_module_name_to_mlds(ModuleName).
+
+ % For interoperability, we ought to generate an `==' member
+ % for types which have a user-defined equality, if the target
+ % language supports it (as do e.g. C++, Java).
+:- pred ml_gen_equality_members(maybe(sym_name), list(mlds__defn)).
+:- mode ml_gen_equality_members(in, out) is det.
+ml_gen_equality_members(_, []). % XXX generation of `==' members
+ % is not yet implemented.
+
+%-----------------------------------------------------------------------------%
+%
+% Routines for generating declaration flags.
+%
+
+ % Return the declaration flags appropriate for a type.
+:- func ml_gen_type_decl_flags = mlds__decl_flags.
+ml_gen_type_decl_flags = MLDS_DeclFlags :-
+ % XXX are these right?
+ Access = public,
+ PerInstance = per_instance,
+ Virtuality = non_virtual,
+ Finality = overridable,
+ Constness = modifiable,
+ Abstractness = concrete,
+ MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
+ Virtuality, Finality, Constness, Abstractness).
+
+ % Return the declaration flags appropriate for a member variable.
+:- func ml_gen_member_decl_flags = mlds__decl_flags.
+ml_gen_member_decl_flags = MLDS_DeclFlags :-
+ Access = public,
+ PerInstance = per_instance,
+ Virtuality = non_virtual,
+ Finality = overridable,
+ Constness = modifiable,
+ Abstractness = concrete,
+ MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
+ Virtuality, Finality, Constness, Abstractness).
+
+ % Return the declaration flags appropriate for an enumeration constant.
+:- func ml_gen_enum_constant_decl_flags = mlds__decl_flags.
+ml_gen_enum_constant_decl_flags = MLDS_DeclFlags :-
+ Access = public,
+ PerInstance = one_copy,
+ Virtuality = non_virtual,
+ Finality = overridable, % XXX should we use `final' instead?
+ % does it make any difference?
+ Constness = const,
+ Abstractness = concrete,
+ MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
+ Virtuality, Finality, Constness, Abstractness).
+
+%-----------------------------------------------------------------------------%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.11
diff -u -d -r1.11 ml_unify_gen.m
--- compiler/ml_unify_gen.m 2000/05/26 14:48:37 1.11
+++ compiler/ml_unify_gen.m 2000/05/30 12:16:48
@@ -262,8 +262,8 @@
% and then convert it to the appropriate type
ml_gen_static_const_arg(Arg, StaticArg, ArgRval),
ml_variable_type(Arg, ArgType),
- { ml_gen_box_or_unbox_rval(ArgType, VarType,
- ArgRval, Rval) }
+ ml_gen_box_or_unbox_rval(ArgType, VarType,
+ ArgRval, Rval)
;
{ error("ml_code_gen: no_tag: arity != 1") }
)
@@ -287,7 +287,8 @@
;
TaggedRval = mkword(TagVal, ConstAddrRval)
},
- { Rval = unop(cast(mercury_type(VarType)), TaggedRval) }
+ ml_gen_type(VarType, MLDS_VarType),
+ { Rval = unop(cast(MLDS_VarType), TaggedRval) }
;
%
% If this argument is just a constant,
@@ -320,6 +321,7 @@
ml_gen_constant(type_ctor_info_constant(ModuleName0, TypeName, TypeArity),
VarType, Rval) -->
+ ml_gen_type(VarType, MLDS_VarType),
%
% Although the builtin types `int', `float', etc. are treated as part
% of the `builtin' module, for historical reasons they don't have
@@ -335,25 +337,27 @@
{ RttiTypeId = rtti_type_id(ModuleName, TypeName, TypeArity) },
{ DataAddr = data_addr(MLDS_Module,
rtti(RttiTypeId, type_ctor_info)) },
- { Rval = unop(cast(mercury_type(VarType)),
+ { Rval = unop(cast(MLDS_VarType),
const(data_addr_const(DataAddr))) }.
ml_gen_constant(base_typeclass_info_constant(ModuleName, ClassId,
Instance), VarType, Rval) -->
+ ml_gen_type(VarType, MLDS_VarType),
{ MLDS_Module = mercury_module_name_to_mlds(ModuleName) },
{ DataAddr = data_addr(MLDS_Module,
base_typeclass_info(ClassId, Instance)) },
- { Rval = unop(cast(mercury_type(VarType)),
+ { Rval = unop(cast(MLDS_VarType),
const(data_addr_const(DataAddr))) }.
ml_gen_constant(tabling_pointer_constant(PredId, ProcId), VarType, Rval) -->
+ ml_gen_type(VarType, MLDS_VarType),
=(Info),
{ ml_gen_info_get_module_info(Info, ModuleInfo) },
{ ml_gen_pred_label(ModuleInfo, PredId, ProcId,
PredLabel, PredModule) },
{ DataAddr = data_addr(PredModule,
tabling_pointer(PredLabel - ProcId)) },
- { Rval = unop(cast(mercury_type(VarType)),
+ { Rval = unop(cast(MLDS_VarType),
const(data_addr_const(DataAddr))) }.
ml_gen_constant(code_addr_constant(PredId, ProcId), _, ProcAddrRval) -->
@@ -409,7 +413,7 @@
{ MLDS_PrivateBuiltinModule = mercury_module_name_to_mlds(
PrivateBuiltinModule) },
{ ClosureLayoutType = mlds__class_type(qual(MLDS_PrivateBuiltinModule,
- "closure_layout"), 0) },
+ "closure_layout"), 0, mlds__struct) },
%
% Generate a wrapper function which just unboxes the
@@ -709,14 +713,14 @@
ml_qualify_var(Name, VarLval),
=(Info),
{ ml_gen_info_get_module_info(Info, ModuleInfo) },
- { mode_to_arg_mode(ModuleInfo, Mode, Type, top_in) ->
- Lval = VarLval
+ ( { mode_to_arg_mode(ModuleInfo, Mode, Type, top_in) } ->
+ { Lval = VarLval }
;
% output arguments are passed by reference,
% so we need to dereference them
- MLDS_Type = mercury_type_to_mlds_type(Type),
- Lval = mem_ref(lval(VarLval), MLDS_Type)
- },
+ ml_gen_type(Type, MLDS_Type),
+ { Lval = mem_ref(lval(VarLval), MLDS_Type) }
+ ),
ml_gen_wrapper_arg_lvals(Names1, Types1, Modes1, Lvals1),
{ Lvals = [Lval|Lvals1] }
;
@@ -805,7 +809,7 @@
% the tag to use, and the types of the argument vars.
%
ml_variable_type(Var, Type),
- { MLDS_Type = mercury_type_to_mlds_type(Type) },
+ ml_gen_type(Type, MLDS_Type),
ml_gen_var(Var, VarLval),
{ Tag = 0 ->
MaybeTag = no
@@ -813,7 +817,7 @@
MaybeTag = yes(Tag)
},
ml_variable_types(ArgVars, ArgTypes),
- { MLDS_ArgTypes0 = list__map(mercury_type_to_mlds_type, ArgTypes) },
+ list__map_foldl(ml_gen_type, ArgTypes, MLDS_ArgTypes0),
(
{ HowToConstruct = construct_dynamically },
@@ -896,7 +900,7 @@
;
TaggedRval = mkword(Tag, ConstAddrRval)
},
- { Rval = unop(cast(mercury_type(Type)), TaggedRval) },
+ { Rval = unop(cast(MLDS_Type), TaggedRval) },
{ AssignStatement = ml_gen_assign(VarLval, Rval, Context) },
{ MLDS_Decls = list__append(BoxConstDefns, [ConstDefn]) },
{ MLDS_Statements = [AssignStatement] }
@@ -928,7 +932,7 @@
ml_gen_box_const_rval(Type, Rval, Context, ConstDefns, BoxedRval) -->
(
- { Type = mercury_type(term__variable(_))
+ { Type = mercury_type(term__variable(_), _)
; Type = mlds__generic_type
}
->
@@ -943,7 +947,7 @@
% but calls to malloc() are not).
%
{ Type = mercury_type(term__functor(term__atom("float"),
- [], _))
+ [], _), _)
; Type = mlds__native_float_type
}
->
@@ -1258,8 +1262,8 @@
% Generate lvals for the LHS and the RHS
%
{ FieldId = offset(const(int_const(ArgNum))) },
- { MLDS_FieldType = mercury_type_to_mlds_type(BoxedFieldType) },
- { MLDS_VarType = mercury_type_to_mlds_type(VarType) },
+ ml_gen_type(BoxedFieldType, MLDS_FieldType),
+ ml_gen_type(VarType, MLDS_VarType),
{ FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId,
MLDS_FieldType, MLDS_VarType) },
ml_gen_var(Arg, ArgLval),
@@ -1306,8 +1310,8 @@
{ LeftMode = top_in },
{ RightMode = top_out }
->
- { ml_gen_box_or_unbox_rval(FieldType, ArgType,
- lval(FieldLval), FieldRval) },
+ ml_gen_box_or_unbox_rval(FieldType, ArgType,
+ lval(FieldLval), FieldRval),
{ MLDS_Statement = ml_gen_assign(ArgLval, FieldRval,
Context) },
{ MLDS_Statements = [MLDS_Statement | MLDS_Statements0] }
@@ -1316,8 +1320,8 @@
{ LeftMode = top_out },
{ RightMode = top_in }
->
- { ml_gen_box_or_unbox_rval(ArgType, FieldType,
- lval(ArgLval), ArgRval) },
+ ml_gen_box_or_unbox_rval(ArgType, FieldType,
+ lval(ArgLval), ArgRval),
{ MLDS_Statement = ml_gen_assign(FieldLval, ArgRval,
Context) },
{ MLDS_Statements = [MLDS_Statement | MLDS_Statements0] }
@@ -1444,7 +1448,7 @@
lval(field(yes(PrimaryTag), Rval,
offset(const(int_const(0))),
mlds__generic_type,
- mercury_type_to_mlds_type(VarType)))),
+ mercury_type_to_mlds_type(ModuleInfo, VarType)))),
const(int_const(SecondaryTag))),
module_info_globals(ModuleInfo, Globals),
globals__lookup_int_option(Globals, num_tag_bits, NumTagBits),
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.4
diff -u -d -r1.4 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 2000/05/10 18:07:09 1.4
+++ compiler/rtti_to_mlds.m 2000/05/30 10:52:27
@@ -182,17 +182,17 @@
gen_init_rtti_data_defn(type_ctor_info(RttiTypeId, UnifyProc, CompareProc,
CtorRep, SolverProc, InitProc, Version, NumPtags, NumFunctors,
FunctorsInfo, LayoutInfo, _MaybeHashCons,
- _PrettyprinterProc), ModuleName, _, Init, []) :-
+ _PrettyprinterProc), ModuleName, ModuleInfo, Init, []) :-
RttiTypeId = rtti_type_id(TypeModule, Type, TypeArity),
prog_out__sym_name_to_string(TypeModule, TypeModuleName),
Init = init_struct([
gen_init_int(TypeArity),
- gen_init_maybe_proc_id(UnifyProc),
- gen_init_maybe_proc_id(UnifyProc),
- gen_init_maybe_proc_id(CompareProc),
+ gen_init_maybe_proc_id(ModuleInfo, UnifyProc),
+ gen_init_maybe_proc_id(ModuleInfo, UnifyProc),
+ gen_init_maybe_proc_id(ModuleInfo, CompareProc),
gen_init_type_ctor_rep(CtorRep),
- gen_init_maybe_proc_id(SolverProc),
- gen_init_maybe_proc_id(InitProc),
+ gen_init_maybe_proc_id(ModuleInfo, SolverProc),
+ gen_init_maybe_proc_id(ModuleInfo, InitProc),
gen_init_string(TypeModuleName),
gen_init_string(Type),
gen_init_int(Version),
@@ -213,7 +213,7 @@
% commented out.
% gen_init_maybe(gen_init_rtti_name(RttiTypeId),
% MaybeHashCons),
- % gen_init_maybe_proc_id(PrettyprinterProc)
+ % gen_init_maybe_proc_id(ModuleInfo, PrettyprinterProc)
]).
gen_init_rtti_data_defn(base_typeclass_info(_ClassId, _InstanceStr,
BaseTypeClassInfo), _ModuleName, ModuleInfo,
@@ -269,10 +269,11 @@
gen_init_layout_info(no_layout, _, _) =
gen_init_null_pointer.
-:- func gen_init_maybe_proc_id(maybe(rtti_proc_label)) = mlds__initializer.
+:- func gen_init_maybe_proc_id(module_info, maybe(rtti_proc_label)) =
+ mlds__initializer.
-gen_init_maybe_proc_id(MaybeProcLabel) =
- gen_init_maybe(gen_init_proc_id, MaybeProcLabel).
+gen_init_maybe_proc_id(ModuleInfo, MaybeProcLabel) =
+ gen_init_maybe(gen_init_proc_id(ModuleInfo), MaybeProcLabel).
:- func gen_init_pseudo_type_info_defn(pseudo_type_info, module_name) =
mlds__initializer.
@@ -493,8 +494,8 @@
%
Init = init_obj(unop(box(WrapperFuncType), WrapperFuncRval)).
-:- func gen_init_proc_id(rtti_proc_label) = mlds__initializer.
-gen_init_proc_id(RttiProcId) = Init :-
+:- func gen_init_proc_id(module_info, rtti_proc_label) = mlds__initializer.
+gen_init_proc_id(ModuleInfo, RttiProcId) = Init :-
%
% construct an rval for the address of this procedure
% (this is similar to ml_gen_proc_addr_rval)
@@ -502,7 +503,7 @@
ml_gen_pred_label_from_rtti(RttiProcId, PredLabel, PredModule),
ProcId = RttiProcId^proc_id,
QualifiedProcLabel = qual(PredModule, PredLabel - ProcId),
- Params = ml_gen_proc_params_from_rtti(RttiProcId),
+ Params = ml_gen_proc_params_from_rtti(ModuleInfo, RttiProcId),
Signature = mlds__get_func_signature(Params),
ProcAddrRval = const(code_addr_const(proc(QualifiedProcLabel,
Signature))),
Index: runtime/mercury.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.10
diff -u -d -r1.10 mercury.h
--- runtime/mercury.h 2000/05/13 14:05:24 1.10
+++ runtime/mercury.h 2000/05/30 15:57:12
@@ -26,6 +26,7 @@
#include "mercury_thread.h" /* for the MR_*_GLOBAL_LOCK() macros */
#include "mercury_std.h"
#include "mercury_type_info.h"
+#include "mercury_ho_call.h" /* for the `MR_Closure' type */
#ifdef CONSERVATIVE_GC
#include "gc.h"
@@ -72,6 +73,11 @@
typedef void *MR_Box;
/*
+** The MR_ClosurePtr type is used for representing higher-order types.
+*/
+typedef const MR_Closure *MR_ClosurePtr;
+
+/*
** With the low-level data representation, the MR_Word type
** is used for representing user-defined types.
*/
@@ -243,13 +249,11 @@
}) \
: GC_MALLOC(bytes) \
)
- /* XXX why do we need to cast to MR_Word here? */
#define MR_new_object(type, size, name) \
- ((MR_Word) (type *) MR_GC_MALLOC_INLINE(size))
+ ((type *) MR_GC_MALLOC_INLINE(size))
#else
- /* XXX why do we need to cast to MR_Word here? */
#define MR_new_object(type, size, name) \
- ((MR_Word) (type *) GC_MALLOC(size))
+ ((type *) GC_MALLOC(size))
#endif
/*
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- 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