[m-dev.] for review: add types to MLDS statements
Tyson Dowd
trd at cs.mu.OZ.AU
Mon Mar 27 20:39:48 AEST 2000
On 26-Feb-2000, Fergus Henderson <fjh at cs.mu.OZ.AU> wrote:
> Apart from that, this change looks fine.
> But I'd like to see a diff or relative diff
> for the change to make `cast' an mlds__unary_op
> rather than an mlds__stmt.
I've finally got around to cleaning this diff up again.
A relative diff is below (generated somewhat manually).
Below that I've attached the entire change for later reference.
diff -u ml_elim_nested.m
-@@ -413,7 +427,7 @@
EnvPtrVar = qual(ModuleName, "env_ptr"),
- AssignEnvPtr = cast(var(EnvPtrVar), EnvPtrVal, EnvPtrVarType),
+ AssignEnvPtr = assign(var(EnvPtrVar), unop(cast(EnvPtrVarType),
+ EnvPtrVal)),
InitEnvPtr = mlds__statement(atomic(AssignEnvPtr), Context).
% Given the declaration for a function parameter, produce a
@@ -745,6 +759,9 @@
fixup_atomic_stmt(assign(Lval0, Rval0), assign(Lval, Rval)) -->
fixup_lval(Lval0, Lval),
fixup_rval(Rval0, Rval).
-fixup_atomic_stmt(cast(Lval0, Rval0, Type), cast(Lval, Rval, Type)) -->
- fixup_lval(Lval0, Lval),
- fixup_rval(Rval0, Rval).
fixup_atomic_stmt(new_object(Target0, MaybeTag, Type, MaybeSize, MaybeCtorName,
Args0, ArgTypes),
new_object(Target, MaybeTag, Type, MaybeSize, MaybeCtorName,
-@@ -1160,6 +1183,10 @@
( lval_contains_var(Lval, Name)
; rval_contains_var(Rval, Name)
).
-atomic_stmt_contains_var(cast(Lval, Rval, _Type), Name) :-
- ( lval_contains_var(Lval, Name)
- ; rval_contains_var(Rval, Name)
- ).
atomic_stmt_contains_var(new_object(Target, _MaybeTag, _Type, _MaybeSize,
_MaybeCtorName, Args, _ArgTypes), Name) :-
( lval_contains_var(Target, Name)
diff -u -r1.15 mlds.m
-@@ -767,6 +767,13 @@
% Assign the value specified by rval to the location
% specified by lval.
- % XXX trd: fjh -- does this look ok?
-
- ; cast(mlds__lval, mlds__rval, mlds__type)
- % cast(Location, Value, Type):
- % Assign the value specified by rval to the location
- % specified by lval and cast it to type.
-
%
% heap management
%
@@ -1007,8 +1022,9 @@
:- type mlds__unary_op
---> box(mlds__type)
; unbox(mlds__type)
+ ; cast(mlds__type)
; std_unop(builtin_ops__unary_op).
:- type mlds__rval_const
+@@ -1007,8 +1016,9 @@
; data_addr_const(mlds__data_addr).
:- type mlds__code_addr
diff -u -r1.21 mlds_to_c.m
@@ -1366,6 +1366,15 @@
mlds_output_rval(Rval),
io__write_string(";\n").
-mlds_output_atomic_stmt(Indent, cast(Lval, Rval, Type), _) -->
- mlds_indent(Indent),
- mlds_output_lval(Lval),
- io__write_string(" = ( "),
- mlds_output_type(Type),
- io__write_string(" )"),
- mlds_output_rval(Rval),
- io__write_string(";\n").
-
%
% heap management
%
@@ -1603,6 +1603,8 @@
:- pred mlds_output_unop(mlds__unary_op, mlds__rval, io__state, io__state).
:- mode mlds_output_unop(in, in, di, uo) is det.
+mlds_output_unop(cast(Type), Exprn) -->
+ mlds_output_cast_rval(Type, Exprn).
mlds_output_unop(box(Type), Exprn) -->
mlds_output_boxed_rval(Type, Exprn).
mlds_output_unop(unbox(Type), Exprn) -->
@@ -1610,6 +1612,15 @@
mlds_output_unop(std_unop(Unop), Exprn) -->
mlds_output_std_unop(Unop, Exprn).
+:- pred mlds_output_cast_rval(mlds__type, mlds__rval, io__state, io__state).
+:- mode mlds_output_cast_rval(in, in, di, uo) is det.
+
+mlds_output_cast_rval(Type, Exprn) -->
+ io__write_string("("),
+ mlds_output_type(Type),
+ io__write_string(") "),
+ mlds_output_rval(Exprn).
+
:- pred mlds_output_boxed_rval(mlds__type, mlds__rval, io__state, io__state).
:- mode mlds_output_boxed_rval(in, in, di, uo) is det.
===================================================================
Estimated hours taken: 16 (some work done in tandem with fjh)
Extend MLDS to cope with alternate backends, and hopefully to allow
easier implementation of high level data structures in the C backend.
Add type information that is required for more heavily typed backends
(with C you can just cast to void * to escape the type system when it is
inconvenient, with other systems this is impossible, e.g. a Java backend).
Introduce new "cast" statement, that does an assignment that may
also modify the type (through a cast).
compiler/mercury_compile.m:
Split the generation of MLDS from outputting high-level C code.
MLDS can be connected up to other backends.
compiler/ml_base_type_info.m:
compiler/ml_call_gen.m:
compiler/ml_code_gen.m:
compiler/ml_code_util.m:
compiler/ml_tailcall.m:
compiler/ml_unify_gen.m:
Add a type to code address constants (the type signature of the
function).
Add the type of the field and the type of the object to field
instructions.
Add a type to mem_ref (the type of the reference).
Don't create local definitions if the locals are dummy types.
compiler/ml_elim_nested.m:
Add types to code addresses, fields and mem_refs.
Use cast where appropriate.
compiler/mlds.m:
Add cast statement.
Add types to code addresses, fields and mem_refs.
compiler/mlds_to_c.m:
Output casts, generally ignore the types in code addresses,
fields and mem_refs (high level C code doesn't really need them,
although it might be nice to use them in future).
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.151
diff -u -r1.151 mercury_compile.m
--- compiler/mercury_compile.m 2000/03/26 09:06:54 1.151
+++ compiler/mercury_compile.m 2000/03/27 09:20:44
@@ -430,7 +430,8 @@
( { AditiOnly = yes } ->
[]
; { HighLevelCode = yes } ->
- mercury_compile__mlds_backend(HLDS50),
+ mercury_compile__mlds_backend(HLDS50, MLDS),
+ mercury_compile__mlds_to_high_level_c(MLDS),
globals__io_lookup_bool_option(compile_to_c,
CompileToC),
( { CompileToC = no } ->
@@ -2189,12 +2190,12 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-% The `--high-level-C' MLDS-based alternative backend
+% The MLDS-based alternative backend
-:- pred mercury_compile__mlds_backend(module_info, io__state, io__state).
-:- mode mercury_compile__mlds_backend(in, di, uo) is det.
+:- pred mercury_compile__mlds_backend(module_info, mlds, io__state, io__state).
+:- mode mercury_compile__mlds_backend(in, out, di, uo) is det.
-mercury_compile__mlds_backend(HLDS50) -->
+mercury_compile__mlds_backend(HLDS50, MLDS) -->
globals__io_lookup_bool_option(verbose, Verbose),
globals__io_lookup_bool_option(statistics, Stats),
@@ -2221,7 +2222,16 @@
ml_elim_nested(MLDS1, MLDS)
;
{ MLDS = MLDS1 }
- ),
+ ).
+
+% The `--high-level-C' MLDS output pass
+
+:- pred mercury_compile__mlds_to_high_level_c(mlds, io__state, io__state).
+:- mode mercury_compile__mlds_to_high_level_c(in, di, uo) is det.
+
+mercury_compile__mlds_to_high_level_c(MLDS) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ globals__io_lookup_bool_option(statistics, Stats),
maybe_write_string(Verbose, "% Converting MLDS to C...\n"),
mlds_to_c__output_mlds(MLDS),
Index: compiler/ml_base_type_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_base_type_info.m,v
retrieving revision 1.5
diff -u -r1.5 ml_base_type_info.m
--- compiler/ml_base_type_info.m 2000/03/10 13:37:48 1.5
+++ compiler/ml_base_type_info.m 2000/03/24 02:36:55
@@ -211,7 +211,10 @@
%
ml_gen_pred_label(ModuleInfo, PredId, ProcId, PredLabel, PredModule),
QualifiedProcLabel = qual(PredModule, PredLabel - ProcId),
- ProcAddrRval = const(code_addr_const(proc(QualifiedProcLabel))),
+ Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+ Signature = mlds__get_func_signature(Params),
+ ProcAddrRval = const(code_addr_const(proc(QualifiedProcLabel,
+ Signature))),
%
% Convert the procedure address to a generic type.
% We need to use a generic type because since the actual type
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.3
diff -u -r1.3 ml_call_gen.m
--- compiler/ml_call_gen.m 2000/03/15 08:30:54 1.3
+++ compiler/ml_call_gen.m 2000/03/24 02:37:18
@@ -119,7 +119,9 @@
_Arity) },
ml_gen_var(ClosureVar, ClosureLval),
{ FieldId = offset(const(int_const(1))) },
- { FuncLval = field(yes(0), lval(ClosureLval), FieldId) },
+ % XXX are these types right?
+ { FuncLval = field(yes(0), lval(ClosureLval), FieldId,
+ mlds__generic_type, ClosureArgType) },
{ FuncType = mlds__func_type(Params) },
{ FuncRval = unop(unbox(FuncType), lval(FuncLval)) }
;
@@ -351,8 +353,11 @@
{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
{ ml_gen_pred_label(ModuleInfo, PredId, ProcId,
PredLabel, PredModule) },
+ { Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId) },
+ { Signature = mlds__get_func_signature(Params) },
{ QualifiedProcLabel = qual(PredModule, PredLabel - ProcId) },
- { CodeAddrRval = const(code_addr_const(proc(QualifiedProcLabel))) }.
+ { CodeAddrRval = const(code_addr_const(proc(QualifiedProcLabel,
+ Signature))) }.
%
% Generate rvals and lvals for the arguments of a procedure call
@@ -460,7 +465,7 @@
% we optimize &*Rval to just Rval.
:- func ml_gen_mem_addr(mlds__lval) = mlds__rval.
ml_gen_mem_addr(Lval) =
- (if Lval = mem_ref(Rval) then Rval else mem_addr(Lval)).
+ (if Lval = mem_ref(Rval, _) then Rval else mem_addr(Lval)).
% Convert VarRval, of type SourceType,
% to ArgRval, of type DestType.
@@ -600,6 +605,216 @@
),
{ MLDS_Statements = [MLDS_Statement] },
{ MLDS_Decls = [] }.
+
+ % Given a module name, a predicate name, a proc_id and a list of
+ % the lvals for the arguments, find out if that procedure of that
+ % predicate is an inline builtin. If yes, the last two arguments
+ % return two things:
+ %
+ % - an rval to execute as a test if the builtin is semidet; or
+ %
+ % - an rval to assign to an lval if the builtin is det.
+ %
+ % Exactly one of these will be present.
+ %
+ % XXX this is not great interface design -
+ % better to return a discriminated union than
+ % returning two maybes. But I kept it this way so that
+ % the code stays similar to code_util__translate_builtin.
+
+:- pred ml_translate_builtin(module_name, string, proc_id, list(mlds__lval),
+ maybe(mlds__rval), maybe(pair(mlds__lval, mlds__rval))).
+:- mode ml_translate_builtin(in, in, in, in, out, out) is semidet.
+
+ml_translate_builtin(FullyQualifiedModule, PredName, ProcId, Args,
+ TestOp, AssignmentOp) :-
+ proc_id_to_int(ProcId, ProcInt),
+ % -- not yet:
+ % FullyQualifiedModule = qualified(unqualified("std"), ModuleName),
+ FullyQualifiedModule = unqualified(ModuleName),
+ ml_translate_builtin_2(ModuleName, PredName, ProcInt, Args,
+ TestOp, AssignmentOp).
+
+:- pred ml_translate_builtin_2(string, string, int, list(mlds__lval),
+ maybe(mlds__rval), maybe(pair(mlds__lval, mlds__rval))).
+:- mode ml_translate_builtin_2(in, in, in, in, out, out) is semidet.
+
+% WARNING: any changes here may need to be duplicated in
+% code_util__translate_builtin_2 and vice versa.
+
+ml_translate_builtin_2("private_builtin", "unsafe_type_cast", 0,
+ [X, Y], no, yes(Y - lval(X))).
+ml_translate_builtin_2("builtin", "unsafe_promise_unique", 0,
+ [X, Y], no, yes(Y - lval(X))).
+
+ml_translate_builtin_2("private_builtin", "builtin_int_gt", 0, [X, Y],
+ yes(binop((>), lval(X), lval(Y))), no).
+ml_translate_builtin_2("private_builtin", "builtin_int_lt", 0, [X, Y],
+ yes(binop((<), lval(X), lval(Y))), no).
+
+ml_translate_builtin_2("int", "builtin_plus", 0, [X, Y, Z],
+ no, yes(Z - binop((+), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_plus", 1, [X, Y, Z],
+ no, yes(X - binop((-), lval(Z), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_plus", 2, [X, Y, Z],
+ no, yes(Y - binop((-), lval(Z), lval(X)))).
+ml_translate_builtin_2("int", "+", 0, [X, Y, Z],
+ no, yes(Z - binop((+), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "+", 1, [X, Y, Z],
+ no, yes(X - binop((-), lval(Z), lval(Y)))).
+ml_translate_builtin_2("int", "+", 2, [X, Y, Z],
+ no, yes(Y - binop((-), lval(Z), lval(X)))).
+ml_translate_builtin_2("int", "builtin_minus", 0, [X, Y, Z],
+ no, yes(Z - binop((-), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_minus", 1, [X, Y, Z],
+ no, yes(X - binop((+), lval(Y), lval(Z)))).
+ml_translate_builtin_2("int", "builtin_minus", 2, [X, Y, Z],
+ no, yes(Y - binop((-), lval(X), lval(Z)))).
+ml_translate_builtin_2("int", "-", 0, [X, Y, Z],
+ no, yes(Z - binop((-), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "-", 1, [X, Y, Z],
+ no, yes(X - binop((+), lval(Y), lval(Z)))).
+ml_translate_builtin_2("int", "-", 2, [X, Y, Z],
+ no, yes(Y - binop((-), lval(X), lval(Z)))).
+ml_translate_builtin_2("int", "builtin_times", 0, [X, Y, Z],
+ no, yes(Z - binop((*), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_times", 1, [X, Y, Z],
+ no, yes(X - binop((/), lval(Z), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_times", 2, [X, Y, Z],
+ no, yes(Y - binop((/), lval(Z), lval(X)))).
+ml_translate_builtin_2("int", "*", 0, [X, Y, Z],
+ no, yes(Z - binop((*), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "*", 1, [X, Y, Z],
+ no, yes(X - binop((/), lval(Z), lval(Y)))).
+ml_translate_builtin_2("int", "*", 2, [X, Y, Z],
+ no, yes(Y - binop((/), lval(Z), lval(X)))).
+ml_translate_builtin_2("int", "builtin_div", 0, [X, Y, Z],
+ no, yes(Z - binop((/), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_div", 1, [X, Y, Z],
+ no, yes(X - binop((*), lval(Y), lval(Z)))).
+ml_translate_builtin_2("int", "builtin_div", 2, [X, Y, Z],
+ no, yes(Y - binop((/), lval(X), lval(Z)))).
+ml_translate_builtin_2("int", "//", 0, [X, Y, Z],
+ no, yes(Z - binop((/), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "//", 1, [X, Y, Z],
+ no, yes(X - binop((*), lval(Y), lval(Z)))).
+ml_translate_builtin_2("int", "//", 2, [X, Y, Z],
+ no, yes(Y - binop((/), lval(X), lval(Z)))).
+ml_translate_builtin_2("int", "builtin_mod", 0, [X, Y, Z],
+ no, yes(Z - binop((mod), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "rem", 0, [X, Y, Z],
+ no, yes(Z - binop((mod), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_left_shift", 0, [X, Y, Z],
+ no, yes(Z - binop((<<), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "unchecked_left_shift", 0, [X, Y, Z],
+ no, yes(Z - binop((<<), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_right_shift", 0, [X, Y, Z],
+ no, yes(Z - binop((>>), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "unchecked_right_shift", 0, [X, Y, Z],
+ no, yes(Z - binop((>>), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_bit_and", 0, [X, Y, Z],
+ no, yes(Z - binop((&), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "/\\", 0, [X, Y, Z],
+ no, yes(Z - binop((&), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_bit_or", 0, [X, Y, Z],
+ no, yes(Z - binop(('|'), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "\\/", 0, [X, Y, Z],
+ no, yes(Z - binop(('|'), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_bit_xor", 0, [X, Y, Z],
+ no, yes(Z - binop((^), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "^", 0, [X, Y, Z],
+ no, yes(Z - binop((^), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "xor", 0, [X, Y, Z],
+ no, yes(Z - binop((^), lval(X), lval(Y)))).
+ml_translate_builtin_2("int", "builtin_unary_plus", 0, [X, Y],
+ no, yes(Y - lval(X))).
+ml_translate_builtin_2("int", "+", 0, [X, Y],
+ no, yes(Y - lval(X))).
+ml_translate_builtin_2("int", "builtin_unary_minus", 0, [X, Y],
+ no, yes(Y - binop((-), const(int_const(0)), lval(X)))).
+ml_translate_builtin_2("int", "-", 0, [X, Y],
+ no, yes(Y - binop((-), const(int_const(0)), lval(X)))).
+ml_translate_builtin_2("int", "builtin_bit_neg", 0, [X, Y],
+ no, yes(Y - unop(std_unop(bitwise_complement), lval(X)))).
+ml_translate_builtin_2("int", "\\", 0, [X, Y],
+ no, yes(Y - unop(std_unop(bitwise_complement), lval(X)))).
+ml_translate_builtin_2("int", ">", 0, [X, Y],
+ yes(binop((>), lval(X), lval(Y))), no).
+ml_translate_builtin_2("int", "<", 0, [X, Y],
+ yes(binop((<), lval(X), lval(Y))), no).
+ml_translate_builtin_2("int", ">=", 0, [X, Y],
+ yes(binop((>=), lval(X), lval(Y))), no).
+ml_translate_builtin_2("int", "=<", 0, [X, Y],
+ yes(binop((<=), lval(X), lval(Y))), no).
+
+ml_translate_builtin_2("float", "builtin_float_plus", 0, [X, Y, Z],
+ no, yes(Z - binop(float_plus, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "builtin_float_plus", 1, [X, Y, Z],
+ no, yes(X - binop(float_minus, lval(Z), lval(Y)))).
+ml_translate_builtin_2("float", "builtin_float_plus", 2, [X, Y, Z],
+ no, yes(Y - binop(float_minus, lval(Z), lval(X)))).
+ml_translate_builtin_2("float", "+", 0, [X, Y, Z],
+ no, yes(Z - binop(float_plus, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "+", 1, [X, Y, Z],
+ no, yes(X - binop(float_minus, lval(Z), lval(Y)))).
+ml_translate_builtin_2("float", "+", 2, [X, Y, Z],
+ no, yes(Y - binop(float_minus, lval(Z), lval(X)))).
+ml_translate_builtin_2("float", "builtin_float_minus", 0, [X, Y, Z],
+ no, yes(Z - binop(float_minus, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "builtin_float_minus", 1, [X, Y, Z],
+ no, yes(X - binop(float_plus, lval(Y), lval(Z)))).
+ml_translate_builtin_2("float", "builtin_float_minus", 2, [X, Y, Z],
+ no, yes(Y - binop(float_minus, lval(X), lval(Z)))).
+ml_translate_builtin_2("float", "-", 0, [X, Y, Z],
+ no, yes(Z - binop(float_minus, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "-", 1, [X, Y, Z],
+ no, yes(X - binop(float_plus, lval(Y), lval(Z)))).
+ml_translate_builtin_2("float", "-", 2, [X, Y, Z],
+ no, yes(Y - binop(float_minus, lval(X), lval(Z)))).
+ml_translate_builtin_2("float", "builtin_float_times", 0, [X, Y, Z],
+ no, yes(Z - binop(float_times, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "builtin_float_times", 1, [X, Y, Z],
+ no, yes(X - binop(float_divide, lval(Z), lval(Y)))).
+ml_translate_builtin_2("float", "builtin_float_times", 2, [X, Y, Z],
+ no, yes(Y - binop(float_divide, lval(Z), lval(X)))).
+ml_translate_builtin_2("float", "*", 0, [X, Y, Z],
+ no, yes(Z - binop(float_times, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "*", 1, [X, Y, Z],
+ no, yes(X - binop(float_divide, lval(Z), lval(Y)))).
+ml_translate_builtin_2("float", "*", 2, [X, Y, Z],
+ no, yes(Y - binop(float_divide, lval(Z), lval(X)))).
+ml_translate_builtin_2("float", "builtin_float_divide", 0, [X, Y, Z],
+ no, yes(Z - binop(float_divide, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "builtin_float_divide", 1, [X, Y, Z],
+ no, yes(X - binop(float_times, lval(Y), lval(Z)))).
+ml_translate_builtin_2("float", "builtin_float_divide", 2, [X, Y, Z],
+ no, yes(Y - binop(float_divide, lval(X), lval(Z)))).
+ml_translate_builtin_2("float", "/", 0, [X, Y, Z],
+ no, yes(Z - binop(float_divide, lval(X), lval(Y)))).
+ml_translate_builtin_2("float", "/", 1, [X, Y, Z],
+ no, yes(X - binop(float_times, lval(Y), lval(Z)))).
+ml_translate_builtin_2("float", "/", 2, [X, Y, Z],
+ no, yes(Y - binop(float_divide, lval(X), lval(Z)))).
+ml_translate_builtin_2("float", "+", 0, [X, Y],
+ no, yes(Y - lval(X))).
+ml_translate_builtin_2("float", "-", 0, [X, Y],
+ no, yes(Y - binop(float_minus, const(float_const(0.0)), lval(X)))).
+ml_translate_builtin_2("float", "builtin_float_gt", 0, [X, Y],
+ yes(binop(float_gt, lval(X), lval(Y))), no).
+ml_translate_builtin_2("float", ">", 0, [X, Y],
+ yes(binop(float_gt, lval(X), lval(Y))), no).
+ml_translate_builtin_2("float", "builtin_float_lt", 0, [X, Y],
+ yes(binop(float_lt, lval(X), lval(Y))), no).
+ml_translate_builtin_2("float", "<", 0, [X, Y],
+ yes(binop(float_lt, lval(X), lval(Y))), no).
+ml_translate_builtin_2("float", "builtin_float_ge", 0, [X, Y],
+ yes(binop(float_ge, lval(X), lval(Y))), no).
+ml_translate_builtin_2("float", ">=", 0, [X, Y],
+ yes(binop(float_ge, lval(X), lval(Y))), no).
+ml_translate_builtin_2("float", "builtin_float_le", 0, [X, Y],
+ yes(binop(float_le, lval(X), lval(Y))), no).
+ml_translate_builtin_2("float", "=<", 0, [X, Y],
+ yes(binop(float_le, lval(X), lval(Y))), no).
:- func ml_gen_simple_expr(simple_expr(mlds__lval)) = mlds__rval.
ml_gen_simple_expr(leaf(Lval)) = lval(Lval).
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.31
diff -u -r1.31 ml_code_gen.m
--- compiler/ml_code_gen.m 2000/03/13 02:23:04 1.31
+++ compiler/ml_code_gen.m 2000/03/27 08:10:19
@@ -883,16 +883,19 @@
%
:- 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) =
- list__map(ml_gen_local_var_decl(VarSet, VarTypes, Context), Vars).
+ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars) = LocalDecls :-
+ list__filter_map(ml_gen_local_var_decl(VarSet, VarTypes, Context),
+ Vars, LocalDecls).
% Generate a declaration for a local variable.
%
-:- func ml_gen_local_var_decl(prog_varset, map(prog_var, prog_type),
- mlds__context, prog_var) = mlds__defn.
-ml_gen_local_var_decl(VarSet, VarTypes, Context, Var) = MLDS_Defn :-
- VarName = ml_gen_var_name(VarSet, Var),
+:- 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) :-
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).
% Generate the code for a procedure body.
@@ -1803,7 +1806,7 @@
llds_out__name_mangle(VarName, MangledVarName),
string__append_list([MangledModuleName, "__",
MangledVarName], Var_ArgName)
- ; ArgRval = lval(mem_ref(lval(var(qual(ModuleName, VarName))))) ->
+ ; ArgRval = lval(mem_ref(lval(var(qual(ModuleName, VarName))), _)) ->
SymName = mlds_module_name_to_sym_name(ModuleName),
llds_out__sym_name_mangle(SymName, MangledModuleName),
llds_out__name_mangle(VarName, MangledVarName),
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.3
diff -u -r1.3 ml_code_util.m
--- compiler/ml_code_util.m 2000/02/23 04:30:52 1.3
+++ compiler/ml_code_util.m 2000/02/23 06:44:06
@@ -727,9 +727,17 @@
{ ml_gen_info_get_proc_id(Info, ProcId) },
{ ml_gen_pred_label(ModuleInfo, PredId, ProcId,
PredLabel, PredModule) },
+ { ml_gen_info_use_gcc_nested_functions(UseNestedFuncs, Info, _) },
+ { UseNestedFuncs = yes ->
+ ArgTypes = []
+ ;
+ ArgTypes = [mlds__generic_env_ptr_type]
+ },
+ { Signature = mlds__func_signature(ArgTypes, []) },
+
{ ProcLabel = qual(PredModule, PredLabel - ProcId) },
{ FuncLabelRval = const(code_addr_const(internal(ProcLabel,
- FuncLabel))) }.
+ FuncLabel, Signature))) }.
% Generate the mlds__pred_label and module name
% for a given procedure.
@@ -826,9 +834,10 @@
{ MLDS_Module = mercury_module_name_to_mlds(ModuleName) },
{ VarName = ml_gen_var_name(VarSet, Var) },
{ VarLval = var(qual(MLDS_Module, VarName)) },
+ { MLDS_Type = mercury_type_to_mlds_type(Type) },
% output variables are passed by reference...
{ list__member(Var, OutputVars) ->
- Lval = mem_ref(lval(VarLval))
+ Lval = mem_ref(lval(VarLval), MLDS_Type)
;
Lval = VarLval
}
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.4
diff -u -r1.4 ml_elim_nested.m
--- compiler/ml_elim_nested.m 2000/03/20 05:25:01 1.4
+++ compiler/ml_elim_nested.m 2000/03/23 06:02:48
@@ -153,13 +153,19 @@
ml_elim_nested_defns(ModuleName, OuterVars, Defn0) = FlatDefns :-
Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
( DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0)) ->
+ EnvName = ml_env_name(Name),
+ % XXX this should be optimized to generate
+ % EnvTypeName from just EnvName
+ ml_create_env(EnvName, [], Context, ModuleName,
+ _EnvType, EnvTypeName, _EnvDecls, _InitEnv),
+
%
% traverse the function body, finding (and removing)
% any nested functions, and fixing up any references
% to the arguments or to local variables which
% occur in nested functions
%
- ElimInfo0 = elim_info_init(ModuleName, OuterVars),
+ ElimInfo0 = elim_info_init(ModuleName, OuterVars, EnvTypeName),
Params = mlds__func_params(Arguments, _RetValues),
ml_maybe_add_args(Arguments, FuncBody0, ModuleName,
Context, ElimInfo0, ElimInfo1),
@@ -173,33 +179,33 @@
FuncBody = FuncBody1,
HoistedDefns = []
;
- %
- % If the function's arguments are referenced by
- % nested functions, then we need to copy them to
- % local variables in the environment structure.
- %
- ml_maybe_copy_args(Arguments, FuncBody0, ModuleName,
- Context, _ArgsToCopy, CodeToCopyArgs),
-
%
- % create a struct to hold the local variables,
+ % Create a struct to hold the local variables,
% and initialize the environment pointers for
% both the containing function and the nested
% functions
%
- EnvName = ml_env_name(Name),
ml_create_env(EnvName, LocalVars, Context, ModuleName,
- EnvType, EnvDecls, InitEnv),
+ EnvType, _EnvTypeName, EnvDecls, InitEnv),
list__map(ml_insert_init_env(EnvName, ModuleName),
NestedFuncs0, NestedFuncs),
%
+ % If the function's arguments are referenced by
+ % nested functions, then we need to copy them to
+ % local variables in the environment structure.
+ %
+ ml_maybe_copy_args(Arguments, FuncBody0, ModuleName,
+ EnvTypeName, Context, _ArgsToCopy,
+ CodeToCopyArgs),
+
+ %
% insert the definition and initialization of the
% environment struct variable at the start of the
% top-level function's body
%
FuncBody = ml_block(EnvDecls,
- list__append([InitEnv | CodeToCopyArgs],
+ list__append([InitEnv | CodeToCopyArgs],
[FuncBody1]),
Context),
%
@@ -245,16 +251,17 @@
% to the environment struct.
%
:- pred ml_maybe_copy_args(mlds__arguments, mlds__statement,
- mlds_module_name, mlds__context, mlds__defns, mlds__statements).
-:- mode ml_maybe_copy_args(in, in, in, in, out, out) is det.
+ mlds_module_name, mlds__type, mlds__context,
+ mlds__defns, mlds__statements).
+:- mode ml_maybe_copy_args(in, in, in, in, in, out, out) is det.
-ml_maybe_copy_args([], _, _, _, [], []).
-ml_maybe_copy_args([Arg|Args], FuncBody, ModuleName, Context,
+ml_maybe_copy_args([], _, _, _, _, [], []).
+ml_maybe_copy_args([Arg|Args], FuncBody, ModuleName, ClassType, Context,
ArgsToCopy, CodeToCopyArgs) :-
- ml_maybe_copy_args(Args, FuncBody, ModuleName, Context,
+ ml_maybe_copy_args(Args, FuncBody, ModuleName, ClassType, Context,
ArgsToCopy0, CodeToCopyArgs0),
(
- Arg = data(var(VarName)) - _Type,
+ Arg = data(var(VarName)) - FieldType,
ml_should_add_local_var(ModuleName, VarName, [], [FuncBody])
->
ml_conv_arg_to_var(Context, Arg, ArgToCopy),
@@ -268,7 +275,8 @@
FieldName = named_field(QualVarName),
Tag = yes(0),
EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
- EnvArgLval = field(Tag, EnvPtr, FieldName),
+ EnvArgLval = field(Tag, EnvPtr, FieldName, FieldType,
+ ClassType),
ArgRval = lval(var(QualVarName)),
AssignToEnv = assign(EnvArgLval, ArgRval),
CodeToCopyArg = mlds__statement(atomic(AssignToEnv), Context),
@@ -293,12 +301,12 @@
% env_ptr = &env;
%
:- pred ml_create_env(mlds__class_name, list(mlds__defn), mlds__context,
- mlds_module_name, mlds__defn,
+ mlds_module_name, mlds__defn, mlds__type,
list(mlds__defn), mlds__statement).
-:- mode ml_create_env(in, in, in, in, out, out, out) is det.
+:- mode ml_create_env(in, in, in, in, out, out, out, out) is det.
ml_create_env(EnvClassName, LocalVars, Context, ModuleName,
- EnvType, EnvDecls, InitEnv) :-
+ EnvType, EnvTypeName, EnvDecls, InitEnv) :-
%
% generate the following type:
%
@@ -306,11 +314,12 @@
% <LocalVars>
% };
%
- EnvTypeName = type(EnvClassName, 0),
+ EnvTypeEntityName = type(EnvClassName, 0),
+ EnvTypeName = class_type(qual(ModuleName, EnvClassName), 0),
EnvTypeFlags = env_decl_flags,
- EnvTypeDefnBody = mlds__class(mlds__class_defn(mlds__struct, [], [], [],
- LocalVars)),
- EnvType = mlds__defn(EnvTypeName, Context, EnvTypeFlags,
+ EnvTypeDefnBody = mlds__class(mlds__class_defn(mlds__struct, [],
+ [mlds__generic_env_ptr_type], [], LocalVars)),
+ EnvType = mlds__defn(EnvTypeEntityName, Context, EnvTypeFlags,
EnvTypeDefnBody),
%
@@ -362,12 +371,6 @@
DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0)),
statement_contains_var(FuncBody0, qual(ModuleName, "env_ptr"))
->
- %
- % XXX we should really insert a type cast here,
- % to convert from mlds__generic_ptr_type (i.e. `void *') to
- % the mlds__class_type (i.e. `struct <EnvClassName> *').
- % But the MLDS doesn't have any representation for casts.
- %
EnvPtrVal = lval(var(qual(ModuleName, "env_ptr_arg"))),
ml_init_env(ClassName, EnvPtrVal, Context, ModuleName,
EnvPtrDecl, InitEnvPtr),
@@ -410,10 +413,11 @@
%
% generate the following statement:
%
- % env_ptr = <EnvPtrVal>;
+ % env_ptr = (EnvPtrVarType) <EnvPtrVal>;
%
EnvPtrVar = qual(ModuleName, "env_ptr"),
- AssignEnvPtr = assign(var(EnvPtrVar), EnvPtrVal),
+ AssignEnvPtr = assign(var(EnvPtrVar), unop(cast(EnvPtrVarType),
+ EnvPtrVal)),
InitEnvPtr = mlds__statement(atomic(AssignEnvPtr), Context).
% Given the declaration for a function parameter, produce a
@@ -816,9 +820,10 @@
:- pred fixup_lval(mlds__lval, mlds__lval, elim_info, elim_info).
:- mode fixup_lval(in, out, in, out) is det.
-fixup_lval(field(MaybeTag, Rval0, FieldId), field(MaybeTag, Rval, FieldId)) -->
+fixup_lval(field(MaybeTag, Rval0, FieldId, FieldType, ClassType),
+ field(MaybeTag, Rval, FieldId, FieldType, ClassType)) -->
fixup_rval(Rval0, Rval).
-fixup_lval(mem_ref(Rval0), mem_ref(Rval)) -->
+fixup_lval(mem_ref(Rval0, Type), mem_ref(Rval, Type)) -->
fixup_rval(Rval0, Rval).
fixup_lval(var(Var0), VarLval) -->
fixup_var(Var0, VarLval).
@@ -838,6 +843,7 @@
ThisVar = qual(ThisVarModuleName, ThisVarName),
ModuleName = elim_info_get_module_name(ElimInfo),
LocalVars = elim_info_get_local_vars(ElimInfo),
+ ClassType = elim_info_get_env_type_name(ElimInfo),
(
%
% Check for references to local variables
@@ -845,13 +851,17 @@
% and replace them with `env_ptr->foo'.
%
ThisVarModuleName = ModuleName,
- list__member(Var, LocalVars),
- Var = mlds__defn(data(var(ThisVarName)), _, _, _)
+ IsLocal = (pred(VarType::out) is nondet :-
+ list__member(Var, LocalVars),
+ Var = mlds__defn(data(var(ThisVarName)), _, _,
+ data(VarType, _))
+ ),
+ solutions(IsLocal, [FieldType])
->
EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
FieldName = named_field(ThisVar),
Tag = yes(0),
- Lval = field(Tag, EnvPtr, FieldName)
+ Lval = field(Tag, EnvPtr, FieldName, FieldType, ClassType)
;
%
% leave everything else unchanged
@@ -1229,9 +1239,9 @@
:- pred lval_contains_var(mlds__lval, mlds__var).
:- mode lval_contains_var(in, in) is semidet.
-lval_contains_var(field(_MaybeTag, Rval, _FieldId), Name) :-
+lval_contains_var(field(_MaybeTag, Rval, _FieldId, _, _), Name) :-
rval_contains_var(Rval, Name).
-lval_contains_var(mem_ref(Rval), Name) :-
+lval_contains_var(mem_ref(Rval, _Type), Name) :-
rval_contains_var(Rval, Name).
lval_contains_var(var(Name), Name). /* this is where we can succeed! */
@@ -1266,7 +1276,10 @@
% The list of local variables that we must
% put in the environment structure
% This list is stored in reverse order.
- list(mlds__defn)
+ list(mlds__defn),
+
+ % Type of the introduced environment struct
+ mlds__type
).
% The lists of local variables for
@@ -1274,34 +1287,37 @@
% innermost first
:- type outervars == list(list(mlds__defn)).
-:- func elim_info_init(mlds_module_name, outervars) = elim_info.
-elim_info_init(ModuleName, OuterVars) =
- elim_info(ModuleName, OuterVars, [], []).
+:- func elim_info_init(mlds_module_name, outervars, mlds__type) = elim_info.
+elim_info_init(ModuleName, OuterVars, EnvTypeName) =
+ elim_info(ModuleName, OuterVars, [], [], EnvTypeName).
:- func elim_info_get_module_name(elim_info) = mlds_module_name.
-elim_info_get_module_name(elim_info(ModuleName, _, _, _)) = ModuleName.
+elim_info_get_module_name(elim_info(ModuleName, _, _, _, _)) = ModuleName.
:- func elim_info_get_outer_vars(elim_info) = outervars.
-elim_info_get_outer_vars(elim_info(_, OuterVars, _, _)) = OuterVars.
+elim_info_get_outer_vars(elim_info(_, OuterVars, _, _, _)) = OuterVars.
:- func elim_info_get_local_vars(elim_info) = list(mlds__defn).
-elim_info_get_local_vars(elim_info(_, _, _, LocalVars)) = LocalVars.
+elim_info_get_local_vars(elim_info(_, _, _, LocalVars, _)) = LocalVars.
+
+:- func elim_info_get_env_type_name(elim_info) = mlds__type.
+elim_info_get_env_type_name(elim_info(_, _, _, _, EnvTypeName)) = EnvTypeName.
:- pred elim_info_add_nested_func(mlds__defn, elim_info, elim_info).
:- mode elim_info_add_nested_func(in, in, out) is det.
-elim_info_add_nested_func(NestedFunc, elim_info(A, B, NestedFuncs0, D),
- elim_info(A, B, NestedFuncs, D)) :-
+elim_info_add_nested_func(NestedFunc, elim_info(A, B, NestedFuncs0, D, E),
+ elim_info(A, B, NestedFuncs, D, E)) :-
NestedFuncs = [NestedFunc | NestedFuncs0].
:- pred elim_info_add_local_var(mlds__defn, elim_info, elim_info).
:- mode elim_info_add_local_var(in, in, out) is det.
-elim_info_add_local_var(LocalVar, elim_info(A, B, C, LocalVars0),
- elim_info(A, B, C, LocalVars)) :-
+elim_info_add_local_var(LocalVar, elim_info(A, B, C, LocalVars0, E),
+ elim_info(A, B, C, LocalVars, E)) :-
LocalVars = [LocalVar | LocalVars0].
:- pred elim_info_finish(elim_info, list(mlds__defn), list(mlds__defn)).
:- mode elim_info_finish(in, out, out) is det.
-elim_info_finish(elim_info(_ModuleName, _OuterVars, RevFuncs, RevLocalVars),
+elim_info_finish(elim_info(_ModuleName, _OuterVars, RevFuncs, RevLocalVars, _),
Funcs, LocalVars) :-
Funcs = list__reverse(RevFuncs),
LocalVars = list__reverse(RevLocalVars).
Index: compiler/ml_tailcall.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_tailcall.m,v
retrieving revision 1.1
diff -u -r1.1 ml_tailcall.m
--- compiler/ml_tailcall.m 1999/11/10 16:21:13 1.1
+++ compiler/ml_tailcall.m 2000/02/17 06:48:39
@@ -317,14 +317,14 @@
% We just assume it is local. (This assumption is
% true for the code generated by ml_code_gen.m.)
true.
-lval_is_local(field(_Tag, Rval, _Field)) :-
+lval_is_local(field(_Tag, Rval, _Field, _, _)) :-
% a field of a local variable is local
( Rval = mem_addr(Lval) ->
lval_is_local(Lval)
;
fail
).
-lval_is_local(mem_ref(_Rval)) :-
+lval_is_local(mem_ref(_Rval, _Type)) :-
fail.
%-----------------------------------------------------------------------------%
@@ -381,9 +381,9 @@
:- pred check_lval(mlds__lval, locals).
:- mode check_lval(in, in) is semidet.
-check_lval(field(_MaybeTag, Rval, _FieldId), Locals) :-
+check_lval(field(_MaybeTag, Rval, _FieldId, _, _), Locals) :-
check_rval(Rval, Locals).
-check_lval(mem_ref(_), _) :-
+check_lval(mem_ref(_, _), _) :-
% We assume that the addresses of local variables are only
% ever passed down to other functions, or assigned to,
% so a mem_ref lval can never refer to a local variable.
@@ -453,10 +453,10 @@
function_is_local(CodeAddr, Locals) :-
(
- CodeAddr = proc(QualifiedProcLabel),
+ CodeAddr = proc(QualifiedProcLabel, _Sig),
MaybeSeqNum = no
;
- CodeAddr = internal(QualifiedProcLabel, SeqNum),
+ CodeAddr = internal(QualifiedProcLabel, SeqNum, _Sig),
MaybeSeqNum = yes(SeqNum)
),
% XXX we ignore the ModuleName --
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.3
diff -u -r1.3 ml_unify_gen.m
--- compiler/ml_unify_gen.m 2000/02/23 04:30:53 1.3
+++ compiler/ml_unify_gen.m 2000/03/27 08:23:45
@@ -668,7 +668,8 @@
;
% output arguments are passed by reference,
% so we need to dereference them
- Lval = mem_ref(lval(VarLval))
+ MLDS_Type = mercury_type_to_mlds_type(Type),
+ Lval = mem_ref(lval(VarLval), MLDS_Type)
},
ml_gen_wrapper_arg_lvals(Names1, Types1, Modes1, Lvals1),
{ Lvals = [Lval|Lvals1] }
@@ -690,7 +691,9 @@
% generate `MR_field(MR_mktag(0), closure, <N>)'
%
{ FieldId = offset(const(int_const(ArgNum + Offset))) },
- { FieldLval = field(yes(0), lval(ClosureLval), FieldId) },
+ % XXX these types might not be right
+ { FieldLval = field(yes(0), lval(ClosureLval), FieldId,
+ mlds__generic_env_ptr_type, mlds__generic_type) },
%
% recursively handle the remaining fields
%
@@ -888,13 +891,13 @@
{ Tag = unshared_tag(UnsharedTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
- ml_gen_unify_args(Args, Modes, ArgTypes,
+ ml_gen_unify_args(Args, Modes, ArgTypes, Type,
VarLval, 0, UnsharedTag, Context, MLDS_Statements)
;
{ Tag = shared_remote_tag(PrimaryTag, _SecondaryTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
- ml_gen_unify_args(Args, Modes, ArgTypes,
+ ml_gen_unify_args(Args, Modes, ArgTypes, Type,
VarLval, 1, PrimaryTag, Context, MLDS_Statements)
;
{ Tag = shared_local_tag(_Bits1, _Num1) },
@@ -902,14 +905,14 @@
).
:- pred ml_gen_unify_args(prog_vars, list(uni_mode), list(prog_type),
- mlds__lval, int, mlds__tag, prog_context,
+ prog_type, mlds__lval, int, mlds__tag, prog_context,
mlds__statements, ml_gen_info, ml_gen_info).
-:- mode ml_gen_unify_args(in, in, in, in, in, in, in, out, in, out) is det.
+:- mode ml_gen_unify_args(in, in, in, in, in, in, in, in, out, in, out) is det.
-ml_gen_unify_args(Args, Modes, ArgTypes, VarLval, ArgNum, PrimaryTag, Context,
- MLDS_Statements) -->
+ml_gen_unify_args(Args, Modes, ArgTypes, VarType, VarLval, ArgNum,
+ PrimaryTag, Context, MLDS_Statements) -->
(
- ml_gen_unify_args_2(Args, Modes, ArgTypes,
+ ml_gen_unify_args_2(Args, Modes, ArgTypes, VarType,
VarLval, ArgNum, PrimaryTag, Context,
[], MLDS_Statements0)
->
@@ -919,34 +922,37 @@
).
:- pred ml_gen_unify_args_2(prog_vars, list(uni_mode), list(prog_type),
- mlds__lval, int, mlds__tag, prog_context,
+ prog_type, mlds__lval, int, mlds__tag, prog_context,
mlds__statements, mlds__statements, ml_gen_info, ml_gen_info).
-:- mode ml_gen_unify_args_2(in, in, in, in, in, in, in, in, out, in, out)
+:- mode ml_gen_unify_args_2(in, in, in, in, in, in, in, in, in, out, in, out)
is semidet.
-ml_gen_unify_args_2([], [], [], _, _, _, _, Statements, Statements) --> [].
+ml_gen_unify_args_2([], [], [], _, _, _, _, _, Statements, Statements) --> [].
ml_gen_unify_args_2([Arg|Args], [Mode|Modes], [ArgType|ArgTypes],
- VarLval, ArgNum, PrimaryTag, Context,
+ VarType, VarLval, ArgNum, PrimaryTag, Context,
MLDS_Statements0, MLDS_Statements) -->
{ ArgNum1 = ArgNum + 1 },
- ml_gen_unify_args_2(Args, Modes, ArgTypes, VarLval, ArgNum1,
+ ml_gen_unify_args_2(Args, Modes, ArgTypes, VarType, VarLval, ArgNum1,
PrimaryTag, Context, MLDS_Statements0, MLDS_Statements1),
- ml_gen_unify_arg(Arg, Mode, ArgType, VarLval, ArgNum, PrimaryTag,
- Context, MLDS_Statements1, MLDS_Statements).
+ ml_gen_unify_arg(Arg, Mode, ArgType, VarType, VarLval, ArgNum,
+ PrimaryTag, Context, MLDS_Statements1, MLDS_Statements).
-:- pred ml_gen_unify_arg(prog_var, uni_mode, prog_type,
+:- pred ml_gen_unify_arg(prog_var, uni_mode, prog_type, prog_type,
mlds__lval, int, mlds__tag, prog_context,
mlds__statements, mlds__statements, ml_gen_info, ml_gen_info).
-:- mode ml_gen_unify_arg(in, in, in, in, in, in, in, in, out, in, out)
+:- mode ml_gen_unify_arg(in, in, in, in, in, in, in, in, in, out, in, out)
is det.
-ml_gen_unify_arg(Arg, Mode, ArgType, VarLval, ArgNum, PrimaryTag, Context,
- MLDS_Statements0, MLDS_Statements) -->
+ml_gen_unify_arg(Arg, Mode, ArgType, VarType, VarLval, ArgNum, PrimaryTag,
+ Context, MLDS_Statements0, MLDS_Statements) -->
%
% Generate lvals for the LHS and the RHS
%
{ FieldId = offset(const(int_const(ArgNum))) },
- { FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId) },
+ { MLDS_ArgType = mercury_type_to_mlds_type(ArgType) },
+ { MLDS_VarType = mercury_type_to_mlds_type(VarType) },
+ { FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId,
+ MLDS_ArgType, MLDS_VarType) },
ml_gen_var(Arg, ArgLval),
%
% Now generate code to unify them
@@ -1088,50 +1094,53 @@
ml_gen_var(Var, VarLval),
ml_variable_type(Var, Type),
ml_cons_id_to_tag(ConsId, Type, Tag),
- { TagTestExpression = ml_gen_tag_test_rval(Tag, lval(VarLval)) },
+ { TagTestExpression = ml_gen_tag_test_rval(Tag, Type, lval(VarLval)) },
{ TagTestDecls = [] },
{ TagTestStatements = [] }.
- % ml_gen_tag_test_rval(Tag, VarRval) = TestRval:
+ % ml_gen_tag_test_rval(Tag, VarType, VarRval) = TestRval:
% TestRval is a Rval of type bool which evaluates to
% true if VarRval has the specified Tag and false otherwise.
+ % VarType is the type of VarRval.
%
-:- func ml_gen_tag_test_rval(cons_tag, mlds__rval) = mlds__rval.
+:- func ml_gen_tag_test_rval(cons_tag, prog_type, mlds__rval) = mlds__rval.
-ml_gen_tag_test_rval(string_constant(String), Rval) =
+ml_gen_tag_test_rval(string_constant(String), _, Rval) =
binop(str_eq, Rval, const(string_const(String))).
-ml_gen_tag_test_rval(float_constant(Float), Rval) =
+ml_gen_tag_test_rval(float_constant(Float), _, Rval) =
binop(float_eq, Rval, const(float_const(Float))).
-ml_gen_tag_test_rval(int_constant(Int), Rval) =
+ml_gen_tag_test_rval(int_constant(Int), _, Rval) =
binop(eq, Rval, const(int_const(Int))).
-ml_gen_tag_test_rval(pred_closure_tag(_, _, _), _Rval) = _TestRval :-
+ml_gen_tag_test_rval(pred_closure_tag(_, _, _), _, _Rval) = _TestRval :-
% This should never happen, since the error will be detected
% during mode checking.
error("Attempted higher-order unification").
-ml_gen_tag_test_rval(code_addr_constant(_, _), _Rval) = _TestRval :-
+ml_gen_tag_test_rval(code_addr_constant(_, _), _, _Rval) = _TestRval :-
% This should never happen
error("Attempted code_addr unification").
-ml_gen_tag_test_rval(type_ctor_info_constant(_, _, _), _) = _ :-
+ml_gen_tag_test_rval(type_ctor_info_constant(_, _, _), _, _) = _ :-
% This should never happen
error("Attempted type_ctor_info unification").
-ml_gen_tag_test_rval(base_typeclass_info_constant(_, _, _), _) = _ :-
+ml_gen_tag_test_rval(base_typeclass_info_constant(_, _, _), _, _) = _ :-
% This should never happen
error("Attempted base_typeclass_info unification").
-ml_gen_tag_test_rval(tabling_pointer_constant(_, _), _) = _ :-
+ml_gen_tag_test_rval(tabling_pointer_constant(_, _), _, _) = _ :-
% This should never happen
error("Attempted tabling_pointer unification").
-ml_gen_tag_test_rval(no_tag, _Rval) = const(true).
-ml_gen_tag_test_rval(unshared_tag(UnsharedTag), Rval) =
+ml_gen_tag_test_rval(no_tag, _, _Rval) = const(true).
+ml_gen_tag_test_rval(unshared_tag(UnsharedTag), _, Rval) =
binop(eq, unop(std_unop(tag), Rval),
unop(std_unop(mktag), const(int_const(UnsharedTag)))).
-ml_gen_tag_test_rval(shared_remote_tag(Bits, Num), Rval) =
+ml_gen_tag_test_rval(shared_remote_tag(Bits, Num), VarType, Rval) =
binop(and,
binop(eq, unop(std_unop(tag), Rval),
unop(std_unop(mktag), const(int_const(Bits)))),
binop(eq, lval(field(yes(Bits), Rval,
- offset(const(int_const(0))))),
+ offset(const(int_const(0))),
+ mlds__native_int_type,
+ mercury_type_to_mlds_type(VarType))),
const(int_const(Num)))).
-ml_gen_tag_test_rval(shared_local_tag(Bits, Num), Rval) =
+ml_gen_tag_test_rval(shared_local_tag(Bits, Num), _, Rval) =
binop(eq, Rval,
mkword(Bits, unop(std_unop(mkbody), const(int_const(Num))))).
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.17
diff -u -r1.17 mlds.m
--- compiler/mlds.m 2000/03/20 05:25:01 1.17
+++ compiler/mlds.m 2000/03/23 06:02:48
@@ -492,7 +492,7 @@
% that can be used to point to the environment
% (set of local variables) of the containing function.
% This is used for handling nondeterminism,
- % if the target language doesn't supported
+ % if the target language doesn't support
% nested functions, and also for handling
% closures for higher-order code.
; mlds__generic_env_ptr_type
@@ -905,8 +905,10 @@
% values on the heap
% or fields of a structure
%
- ---> field(maybe(mlds__tag), mlds__rval, field_id)
- % field(Tag, Address, FieldName)
+ ---> field(maybe(mlds__tag), mlds__rval, field_id,
+ mlds__type, mlds__type)
+ % field(Tag, Address, FieldName, FieldType,
+ % ClassType)
% selects a field of a compound term.
% Address is a tagged pointer to a cell
% on the heap; the offset into the cell
@@ -916,13 +918,19 @@
% The value of the tag should be given if
% it is known, since this will lead to
% faster code.
+ % The FieldType is the type of the field.
+ % The ClassType is the type of the object from
+ % which we are fetching the field.
%
% values somewhere in memory
% this is the deference operator (e.g. unary `*' in C)
%
- ; mem_ref(mlds__rval) % The rval should have
- % originally come from a mem_addr rval.
+ ; mem_ref(mlds__rval, mlds__type)
+ % The rval should have originally come
+ % from a mem_addr rval.
+ % The type is the type of the value being
+ % dereferenced
%
% variables
@@ -962,6 +970,7 @@
:- type mlds__unary_op
---> box(mlds__type)
; unbox(mlds__type)
+ ; cast(mlds__type)
; std_unop(builtin_ops__unary_op).
:- type mlds__rval_const
@@ -979,8 +988,9 @@
; data_addr_const(mlds__data_addr).
:- type mlds__code_addr
- ---> proc(mlds__qualified_proc_label)
- ; internal(mlds__qualified_proc_label, mlds__func_sequence_num).
+ ---> proc(mlds__qualified_proc_label, mlds__func_signature)
+ ; internal(mlds__qualified_proc_label, mlds__func_sequence_num,
+ mlds__func_signature).
:- type mlds__data_addr
---> data_addr(mlds_module_name, mlds__data_name).
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.22
diff -u -r1.22 mlds_to_c.m
--- compiler/mlds_to_c.m 2000/02/23 04:30:55 1.22
+++ compiler/mlds_to_c.m 2000/02/24 04:04:42
@@ -1269,10 +1269,10 @@
%
FuncRval = const(code_addr_const(CodeAddr)),
(
- CodeAddr = proc(QualifiedProcLabel),
+ CodeAddr = proc(QualifiedProcLabel, _Sig),
MaybeSeqNum = no
;
- CodeAddr = internal(QualifiedProcLabel, SeqNum),
+ CodeAddr = internal(QualifiedProcLabel, SeqNum, _Sig),
MaybeSeqNum = yes(SeqNum)
),
QualifiedProcLabel = qual(ModuleName, PredLabel - ProcId),
@@ -1473,7 +1473,7 @@
:- pred mlds_output_lval(mlds__lval, io__state, io__state).
:- mode mlds_output_lval(in, di, uo) is det.
-mlds_output_lval(field(MaybeTag, Rval, offset(OffsetRval))) -->
+mlds_output_lval(field(MaybeTag, Rval, offset(OffsetRval), _, _)) -->
( { MaybeTag = yes(Tag) } ->
io__write_string("MR_field("),
mlds_output_tag(Tag),
@@ -1485,7 +1485,7 @@
io__write_string(", "),
mlds_output_rval(OffsetRval),
io__write_string(")").
-mlds_output_lval(field(MaybeTag, PtrRval, named_field(FieldId))) -->
+mlds_output_lval(field(MaybeTag, PtrRval, named_field(FieldId), _, _)) -->
( { MaybeTag = yes(0) } ->
( { PtrRval = mem_addr(Lval) } ->
mlds_output_bracketed_lval(Lval),
@@ -1507,7 +1507,7 @@
io__write_string("->")
),
mlds_output_fully_qualified(FieldId, io__write_string).
-mlds_output_lval(mem_ref(Rval)) -->
+mlds_output_lval(mem_ref(Rval, _Type)) -->
io__write_string("*"),
mlds_output_bracketed_rval(Rval).
mlds_output_lval(var(VarName)) -->
@@ -1562,7 +1562,7 @@
% the MR_const_field() macro, not the MR_field() macro,
% to avoid warnings about discarding const,
% and similarly for MR_mask_field.
- ( { Lval = field(MaybeTag, Rval, FieldNum) } ->
+ ( { Lval = field(MaybeTag, Rval, FieldNum, _, _) } ->
( { MaybeTag = yes(Tag) } ->
io__write_string("MR_const_field("),
mlds_output_tag(Tag),
@@ -1603,6 +1603,8 @@
:- pred mlds_output_unop(mlds__unary_op, mlds__rval, io__state, io__state).
:- mode mlds_output_unop(in, in, di, uo) is det.
+mlds_output_unop(cast(Type), Exprn) -->
+ mlds_output_cast_rval(Type, Exprn).
mlds_output_unop(box(Type), Exprn) -->
mlds_output_boxed_rval(Type, Exprn).
mlds_output_unop(unbox(Type), Exprn) -->
@@ -1610,6 +1612,15 @@
mlds_output_unop(std_unop(Unop), Exprn) -->
mlds_output_std_unop(Unop, Exprn).
+:- pred mlds_output_cast_rval(mlds__type, mlds__rval, io__state, io__state).
+:- mode mlds_output_cast_rval(in, in, di, uo) is det.
+
+mlds_output_cast_rval(Type, Exprn) -->
+ io__write_string("("),
+ mlds_output_type(Type),
+ io__write_string(") "),
+ mlds_output_rval(Exprn).
+
:- pred mlds_output_boxed_rval(mlds__type, mlds__rval, io__state, io__state).
:- mode mlds_output_boxed_rval(in, in, di, uo) is det.
@@ -1787,9 +1798,9 @@
:- pred mlds_output_code_addr(mlds__code_addr, io__state, io__state).
:- mode mlds_output_code_addr(in, di, uo) is det.
-mlds_output_code_addr(proc(Label)) -->
+mlds_output_code_addr(proc(Label, _Sig)) -->
mlds_output_fully_qualified(Label, mlds_output_proc_label).
-mlds_output_code_addr(internal(Label, SeqNum)) -->
+mlds_output_code_addr(internal(Label, SeqNum, _Sig)) -->
mlds_output_fully_qualified(Label, mlds_output_proc_label),
io__write_string("_"),
io__write_int(SeqNum).
--
Tyson Dowd #
# Surreal humour isn't eveyone's cup of fur.
trd at cs.mu.oz.au #
http://www.cs.mu.oz.au/~trd #
--------------------------------------------------------------------------
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