[m-rev.] for review: unboxed floats in high-level C grades
Peter Wang
novalazy at gmail.com
Thu Aug 18 13:46:53 AEST 2011
Branches: main
Support unboxed float fields in high-level C grades.
When the representation of `float' is no wider than a machine word, d.u.
functor arguments of type `float' (or equivalent) will be stored directly
within cells constructed for that functor, instead of a pointer to the box
containing the value. This was already so for low-level C grades.
compiler/mlds.m:
Add an option to mlds_type, equivalent to
`mlds_array_type(mlds_generic_type)' except that some elements are
known to be floats.
Update some comments.
compiler/ml_global_data.m:
Remember the `--unboxed-float' option in `ml_global_data'.
Special case generic arrays in `ml_gen_static_scalar_const_addr' and
`ml_gen_static_scalar_const_value'. Float literals cannot be used to
initialize an element of a generic array in C. If any appear, replace
the generic array type by an instance of
`mlds_mostly_generic_array_type' with float fields in the positions
which have float initializers.
compiler/ml_code_util.m:
Make `ml_must_box_field_type' and `ml_gen_box_const_rval' depend on the
`--unboxed-float' option.
Delete some now-misleading comments.
Delete an unused predicate.
compiler/mlds_to_c.m:
Update code that writes out scalar static data to handle
`mlds_mostly_generic_array_type'.
In one case, for `--high-level-data' only, output float constants by
their integer representation, so that they may be cast to pointer
types.
compiler/ml_unify_gen.m:
Rename some predicates for clarity.
compiler/ml_accurate_gc.m:
compiler/ml_lookup_switch.m:
compiler/ml_proc_gen.m:
compiler/ml_simplify_switch.m:
compiler/mlds_to_cs.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
Conform to changes.
library/float.m:
Add hidden functions to return the integer representation of the bit
layout of floating point values.
library/exception.m:
Delete mention of MR_AVOID_MACROS.
runtime/mercury.c:
runtime/mercury.h:
Make MR_box_float/MR_unbox_float act like "casts" when MR_BOXED_FLOAT
is undefined, and only define them in high-level grades. I think they
should be replaced by MR_float_to_word/MR_word_to_float (which have
less confusing names when there is no boxing) but that would require
some header file reshuffling which I don't want to undertake yet.
Delete references to MR_AVOID_MACROS. Apparently it existed to support
the defunct gcc back-end but I cannot see it ever being defined.
runtime/mercury_conf_param.h:
MR_HIGHLEVEL_CODE no longer implies MR_BOXED_FLOAT.
Delete mention of MR_AVOID_MACROS.
runtime/mercury_float.h:
Fix a comment.
tests/hard_coded/Mmakefile:
tests/hard_coded/float_ground_term.exp:
tests/hard_coded/float_ground_term.m:
Add a test case.
diff --git a/compiler/ml_accurate_gc.m b/compiler/ml_accurate_gc.m
index 64a97e7..9202868 100644
--- a/compiler/ml_accurate_gc.m
+++ b/compiler/ml_accurate_gc.m
@@ -202,6 +202,7 @@ ml_type_might_contain_pointers_for_gc(Type) = MightContainPointers :-
( Type = mlds_mercury_array_type(_)
; Type = mlds_ptr_type(_)
; Type = mlds_array_type(_)
+ ; Type = mlds_mostly_generic_array_type(_)
; Type = mlds_generic_type
; Type = mlds_generic_env_ptr_type
; Type = mlds_type_info_type
diff --git a/compiler/ml_code_util.m b/compiler/ml_code_util.m
index fb90c40..b8c159d 100644
--- a/compiler/ml_code_util.m
+++ b/compiler/ml_code_util.m
@@ -320,9 +320,6 @@
:- func ml_gen_field_name(maybe(ctor_field_name), int) = mlds_field_name.
% Succeeds iff the specified type must be boxed when used as a field.
- % For the MLDS->C and MLDS->asm back-ends, we need to box types that
- % are not word-sized, because the code for `arg' etc. in std_util.m
- % relies on all arguments being word-sized.
%
:- pred ml_must_box_field_type(module_info::in, mer_type::in) is semidet.
@@ -542,10 +539,6 @@
%
:- func fixup_builtin_module(module_name) = module_name.
-:- pred ml_gen_box_const_rvals(module_info::in, prog_context::in,
- list(mlds_type)::in, list(mlds_rval)::in, list(mlds_rval)::out,
- ml_global_data::in, ml_global_data::out) is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1375,15 +1368,13 @@ ml_gen_field_name(MaybeFieldName, ArgNum) = FieldName :-
).
% Succeed iff the specified type must be boxed when used as a field.
- % For the MLDS->C and MLDS->asm back-ends, we need to box types that are
- % not word-sized, because the code for `arg' etc. in std_util.m rely
- % on all arguments being word-sized.
% XXX Currently we box such types even for the other MLDS based back-ends
% that don't need it, e.g. the .NET back-end.
%
ml_must_box_field_type(ModuleInfo, Type) :-
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
+ globals.lookup_bool_option(Globals, unboxed_float, UnboxedFloat),
(
( Target = target_c
; Target = target_csharp
@@ -1393,16 +1384,16 @@ ml_must_box_field_type(ModuleInfo, Type) :-
; Target = target_erlang
),
classify_type(ModuleInfo, Type) = Category,
- MustBox = ml_must_box_field_type_category(Category)
+ MustBox = ml_must_box_field_type_category(Category, UnboxedFloat)
;
Target = target_java,
MustBox = no
),
MustBox = yes.
-:- func ml_must_box_field_type_category(type_ctor_category) = bool.
+:- func ml_must_box_field_type_category(type_ctor_category, bool) = bool.
-ml_must_box_field_type_category(CtorCat) = MustBox :-
+ml_must_box_field_type_category(CtorCat, UnboxedFloat) = MustBox :-
(
( CtorCat = ctor_cat_builtin(cat_builtin_int)
; CtorCat = ctor_cat_builtin(cat_builtin_string)
@@ -1417,24 +1408,13 @@ ml_must_box_field_type_category(CtorCat) = MustBox :-
),
MustBox = no
;
- ( CtorCat = ctor_cat_builtin(cat_builtin_char)
- ; CtorCat = ctor_cat_builtin(cat_builtin_float)
- ),
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
MustBox = yes
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
+ MustBox = bool.not(UnboxedFloat)
).
-ml_gen_box_const_rvals(_, _, [], [], [], !GlobalData).
-ml_gen_box_const_rvals(_, _, [], [_ | _], _, !GlobalData) :-
- unexpected($module, $pred, "list length mismatch").
-ml_gen_box_const_rvals(_, _, [_ | _], [], _, !GlobalData) :-
- unexpected($module, $pred, "list length mismatch").
-ml_gen_box_const_rvals(ModuleInfo, Context, [Type | Types], [Rval | Rvals],
- [BoxedRval | BoxedRvals], !GlobalData) :-
- ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
- !GlobalData),
- ml_gen_box_const_rvals(ModuleInfo, Context, Types, Rvals, BoxedRvals,
- !GlobalData).
-
ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
!GlobalData) :-
(
@@ -1444,8 +1424,8 @@ ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
->
BoxedRval = Rval
;
- % For the MLDS->C and MLDS->asm back-ends, we need to handle floats
- % specially, since boxed floats normally get heap allocated, whereas
+ % For the MLDS->C and MLDS->asm back-ends, we need to handle constant
+ % floats specially. Boxed floats normally get heap allocated, whereas
% for other types boxing is just a cast (casts are OK in static
% initializers, but calls to malloc() are not).
( Type = mercury_type(builtin_type(builtin_type_float), _, _)
@@ -1458,6 +1438,9 @@ ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
; Target = target_x86_64
)
->
+ HaveUnboxedFloats = ml_global_data_have_unboxed_floats(!.GlobalData),
+ (
+ HaveUnboxedFloats = do_not_have_unboxed_floats,
% Generate a local static constant for this float.
module_info_get_name(ModuleInfo, ModuleName),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
@@ -1469,6 +1452,12 @@ ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval, BoxedRval,
% cast to mlds_generic_type.
BoxedRval = ml_unop(cast(mlds_generic_type), ConstAddrRval)
;
+ HaveUnboxedFloats = have_unboxed_floats,
+ % This is not a real box, but a cast. The "box" is required as it
+ % may be further cast to pointer types.
+ BoxedRval = ml_unop(box(Type), Rval)
+ )
+ ;
BoxedRval = ml_unop(box(Type), Rval)
).
diff --git a/compiler/ml_global_data.m b/compiler/ml_global_data.m
index 8fe08fb..db71071 100644
--- a/compiler/ml_global_data.m
+++ b/compiler/ml_global_data.m
@@ -41,6 +41,10 @@
---> do_not_use_common_cells
; use_common_cells.
+:- type have_unboxed_floats
+ ---> have_unboxed_floats
+ ; do_not_have_unboxed_floats.
+
:- type ml_scalar_cell_map ==
map(ml_scalar_common_type_num, ml_scalar_cell_group).
@@ -79,7 +83,11 @@
% Initialize the ml_global_data structure to a value that represents
% no global data structures known yet.
%
-:- func ml_global_data_init(use_common_cells) = ml_global_data.
+:- func ml_global_data_init(use_common_cells, have_unboxed_floats) =
+ ml_global_data.
+
+:- func ml_global_data_have_unboxed_floats(ml_global_data) =
+ have_unboxed_floats.
% ml_global_data_get_global_defns(GlobalData, ScalarCellTypeMap,
% RevFlatCellDefns, RevFlatRttiDefns, RevMaybeNonFlatDefns):
@@ -202,10 +210,13 @@
:- implementation.
+:- import_module backend_libs.builtin_ops.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_out.hlds_out_util.
:- import_module ml_backend.ml_type_gen.
+:- import_module parse_tree.prog_type.
+:- import_module bool.
:- import_module int.
:- import_module maybe.
:- import_module require.
@@ -228,6 +239,7 @@
---> ml_global_data(
mgd_pdup_rval_type_map :: ml_rtti_rval_type_map,
mgd_use_common_cells :: use_common_cells,
+ mgd_have_unboxed_floats :: have_unboxed_floats,
mgd_const_counter :: counter,
mgd_rev_flat_cell_defns :: list(mlds_defn),
mgd_rev_flat_rtti_defns :: list(mlds_defn),
@@ -247,17 +259,20 @@
%-----------------------------------------------------------------------------%
-ml_global_data_init(UseCommonCells) = GlobalData :-
- GlobalData = ml_global_data(map.init, UseCommonCells,
+ml_global_data_init(UseCommonCells, HaveUnboxedFloats) = GlobalData :-
+ GlobalData = ml_global_data(map.init, UseCommonCells, HaveUnboxedFloats,
counter.init(1), [], [], [],
counter.init(1), map.init, map.init, map.init, map.init,
counter.init(0), bimap.init).
+ml_global_data_have_unboxed_floats(GlobalData) =
+ GlobalData ^ mgd_have_unboxed_floats.
+
ml_global_data_get_global_defns(GlobalData,
ScalarCellGroupMap, VectorCellGroupMap,
RevFlatCellDefns, RevFlatRttiDefns, RevMaybeNonFlatDefns) :-
GlobalData = ml_global_data(_PDupRvalTypeMap, _UseCommonCells,
- _ConstCounter,
+ _HaveUnboxedFloats, _ConstCounter,
RevFlatCellDefns, RevFlatRttiDefns, RevMaybeNonFlatDefns,
_TypeNumCounter,
_ScalarTypeNumMap, ScalarCellGroupMap,
@@ -267,7 +282,7 @@ ml_global_data_get_global_defns(GlobalData,
ml_global_data_get_all_global_defns(GlobalData,
ScalarCellGroupMap, VectorCellGroupMap, AllocIds, Defns) :-
GlobalData = ml_global_data(_PDupRvalTypeMap, _UseCommonCells,
- _ConstCounter,
+ _HaveUnboxedFloats, _ConstCounter,
RevFlatCellDefns, RevFlatRttiDefns, RevMaybeNonFlatDefns,
_TypeNumCounter,
_ScalarTypeNumMap, ScalarCellGroupMap,
@@ -354,8 +369,11 @@ ml_global_data_add_maybe_nonflat_defns(Defns, !GlobalData) :-
%-----------------------------------------------------------------------------%
-ml_gen_static_scalar_const_value(MLDS_ModuleName, ConstBaseName, ConstType,
- Initializer, Context, DataRval, !GlobalData) :-
+ml_gen_static_scalar_const_value(MLDS_ModuleName, ConstBaseName, ConstType0,
+ Initializer0, Context, DataRval, !GlobalData) :-
+ HaveUnboxedFloats = !.GlobalData ^ mgd_have_unboxed_floats,
+ ml_maybe_specialize_generic_array_type(HaveUnboxedFloats,
+ ConstType0, ConstType, Initializer0, Initializer),
UseCommonCells = !.GlobalData ^ mgd_use_common_cells,
(
UseCommonCells = use_common_cells,
@@ -371,8 +389,11 @@ ml_gen_static_scalar_const_value(MLDS_ModuleName, ConstBaseName, ConstType,
DataRval = ml_lval(DataVar)
).
-ml_gen_static_scalar_const_addr(MLDS_ModuleName, ConstBaseName, ConstType,
- Initializer, Context, DataAddrRval, !GlobalData) :-
+ml_gen_static_scalar_const_addr(MLDS_ModuleName, ConstBaseName, ConstType0,
+ Initializer0, Context, DataAddrRval, !GlobalData) :-
+ HaveUnboxedFloats = !.GlobalData ^ mgd_have_unboxed_floats,
+ ml_maybe_specialize_generic_array_type(HaveUnboxedFloats,
+ ConstType0, ConstType, Initializer0, Initializer),
UseCommonCells = !.GlobalData ^ mgd_use_common_cells,
(
UseCommonCells = use_common_cells,
@@ -468,6 +489,125 @@ ml_gen_plain_static_defn(ConstBaseName, ConstType,
RevDefns = [Defn | RevDefns0],
ml_global_data_set_rev_flat_cell_defns(RevDefns, !GlobalData).
+:- pred ml_maybe_specialize_generic_array_type(have_unboxed_floats::in,
+ mlds_type::in, mlds_type::out, mlds_initializer::in, mlds_initializer::out)
+ is det.
+
+ml_maybe_specialize_generic_array_type(HaveUnboxedFloats,
+ ConstType0, ConstType, Initializer0, Initializer) :-
+ (
+ HaveUnboxedFloats = have_unboxed_floats,
+ ConstType0 = mlds_array_type(mlds_generic_type),
+ Initializer0 = init_array(Inits0),
+ list.map2(ml_specialize_generic_array_init, Inits0, Inits, Types),
+ list.member(mlds_native_float_type, Types)
+ ->
+ ConstType = mlds_mostly_generic_array_type(Types),
+ Initializer = init_array(Inits)
+ ;
+ ConstType = ConstType0,
+ Initializer = Initializer0
+ ).
+
+:- pred ml_specialize_generic_array_init(mlds_initializer::in,
+ mlds_initializer::out, mlds_type::out) is det.
+
+ml_specialize_generic_array_init(Init0, Init, Type) :-
+ (
+ Init0 = init_obj(Rval0),
+ ml_specialize_generic_array_rval(Rval0, Rval)
+ ->
+ Init = init_obj(Rval),
+ Type = mlds_native_float_type
+ ;
+ Init = Init0,
+ Type = mlds_generic_type
+ ).
+
+:- pred ml_specialize_generic_array_rval(mlds_rval::in, mlds_rval::out)
+ is semidet.
+
+ml_specialize_generic_array_rval(!Rval) :-
+ (
+ !.Rval = ml_const(mlconst_float(_))
+ ;
+ !.Rval = ml_unop(Op, SubRval),
+ (
+ Op = box(Type)
+ ;
+ Op = unbox(Type)
+ ;
+ Op = cast(Type)
+ ),
+ (
+ Type = mlds_native_float_type,
+ !:Rval = SubRval
+ ;
+ Type = mercury_type(_, CtorCat, _),
+ (
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
+ !:Rval = SubRval
+ ;
+ CtorCat = ctor_cat_user(cat_user_notag),
+ ml_specialize_generic_array_rval(SubRval, !:Rval)
+ )
+ )
+ ;
+ !.Rval = ml_binop(Op, _, _),
+ ml_specialize_generic_array_binop(Op, yes)
+ ).
+
+:- pred ml_specialize_generic_array_binop(binary_op::in, bool::out) is det.
+
+ml_specialize_generic_array_binop(Op, IsFloat) :-
+ (
+ ( Op = int_add
+ ; Op = int_sub
+ ; Op = int_mul
+ ; Op = int_div
+ ; Op = int_mod
+ ; Op = unchecked_left_shift
+ ; Op = unchecked_right_shift
+ ; Op = bitwise_and
+ ; Op = bitwise_or
+ ; Op = bitwise_xor
+ ; Op = logical_and
+ ; Op = logical_or
+ ; Op = eq
+ ; Op = ne
+ ; Op = str_eq
+ ; Op = str_ne
+ ; Op = str_lt
+ ; Op = str_gt
+ ; Op = str_le
+ ; Op = str_ge
+ ; Op = str_cmp
+ ; Op = int_lt
+ ; Op = int_gt
+ ; Op = int_le
+ ; Op = int_ge
+ ; Op = unsigned_le
+ ; Op = float_eq
+ ; Op = float_ne
+ ; Op = float_lt
+ ; Op = float_gt
+ ; Op = float_le
+ ; Op = float_ge
+ ; Op = body
+ ; Op = array_index(_) % should not be an initializer anyway
+ ; Op = compound_eq
+ ; Op = compound_lt
+ ),
+ IsFloat = no
+ ;
+ ( Op = float_plus
+ ; Op = float_minus
+ ; Op = float_times
+ ; Op = float_divide
+ ),
+ IsFloat = yes
+ ).
+
%-----------------------------------------------------------------------------%
ml_gen_static_vector_type(MLDS_ModuleName, MLDS_Context, Target, ArgTypes,
diff --git a/compiler/ml_lookup_switch.m b/compiler/ml_lookup_switch.m
index 6396ce4..907c577 100644
--- a/compiler/ml_lookup_switch.m
+++ b/compiler/ml_lookup_switch.m
@@ -743,6 +743,7 @@ ml_default_value_for_type(MLDS_Type) = DefaultRval :-
; MLDS_Type = mlds_foreign_type(_)
; MLDS_Type = mlds_class_type(_, _, _)
; MLDS_Type = mlds_array_type(_)
+ ; MLDS_Type = mlds_mostly_generic_array_type(_)
; MLDS_Type = mlds_func_type(_)
; MLDS_Type = mlds_generic_type
; MLDS_Type = mlds_type_info_type
diff --git a/compiler/ml_proc_gen.m b/compiler/ml_proc_gen.m
index 97de546..aa7631f 100644
--- a/compiler/ml_proc_gen.m
+++ b/compiler/ml_proc_gen.m
@@ -282,7 +282,15 @@ ml_gen_preds(!ModuleInfo, PredDefns, GlobalData) :-
),
UseCommonCells = do_not_use_common_cells
),
- GlobalData0 = ml_global_data_init(UseCommonCells),
+ globals.lookup_bool_option(Globals, unboxed_float, UnboxedFloats),
+ (
+ UnboxedFloats = yes,
+ HaveUnboxedFloats = have_unboxed_floats
+ ;
+ UnboxedFloats = no,
+ HaveUnboxedFloats = do_not_have_unboxed_floats
+ ),
+ GlobalData0 = ml_global_data_init(UseCommonCells, HaveUnboxedFloats),
ml_gen_preds_2(!ModuleInfo, PredIds, [], PredDefns,
GlobalData0, GlobalData).
diff --git a/compiler/ml_simplify_switch.m b/compiler/ml_simplify_switch.m
index 3de64d5..b353e63 100644
--- a/compiler/ml_simplify_switch.m
+++ b/compiler/ml_simplify_switch.m
@@ -138,6 +138,7 @@ is_integral_type(MLDSType) = IsIntegral :-
; MLDSType = mlds_generic_type
; MLDSType = mlds_generic_env_ptr_type
; MLDSType = mlds_array_type(_)
+ ; MLDSType = mlds_mostly_generic_array_type(_)
; MLDSType = mlds_pseudo_type_info_type
; MLDSType = mlds_rtti_type(_)
; MLDSType = mlds_tabling_type(_)
diff --git a/compiler/ml_unify_gen.m b/compiler/ml_unify_gen.m
index ea15835..380c94f 100644
--- a/compiler/ml_unify_gen.m
+++ b/compiler/ml_unify_gen.m
@@ -771,8 +771,8 @@ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
% Box *all* the arguments, including the ExtraRvals.
list.map(ml_gen_info_lookup_const_var(!.Info), ArgVars,
ArgGroundTerms),
- ml_gen_box_extra_const_rval_list(ModuleInfo, Context, ExtraTypes,
- ExtraRvals, ExtraArgRvals, !GlobalData),
+ ml_gen_box_extra_const_rval_list_lld(ModuleInfo, Context,
+ ExtraTypes, ExtraRvals, ExtraArgRvals, !GlobalData),
ml_gen_box_const_rval_list(ModuleInfo, Context, ArgGroundTerms,
ArgRvals1, !GlobalData)
;
@@ -781,7 +781,7 @@ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
ArgRvals0),
list.map(ml_type_as_field(ModuleInfo, HighLevelData),
ConsArgTypes, FieldTypes),
- ml_gen_box_or_unbox_const_rval_list(ModuleInfo, ArgTypes,
+ ml_gen_box_or_unbox_const_rval_list_hld(ModuleInfo, ArgTypes,
FieldTypes, ArgRvals0, Context, ArgRvals1, !GlobalData),
% For --high-level-data, the ExtraRvals should already have
% the right type, so we don't need to worry about boxing
@@ -798,8 +798,8 @@ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
UsesBaseClass = tag_uses_base_class
),
ml_gen_info_get_target(!.Info, Target),
- ConstType = get_type_for_cons_id(Target, HighLevelData, MLDS_Type,
- UsesBaseClass, MaybeConsId),
+ ConstType = get_const_type_for_cons_id(Target, HighLevelData,
+ MLDS_Type, UsesBaseClass, MaybeConsId),
% XXX If the secondary tag is in a base class, then ideally its
% initializer should be wrapped in `init_struct([init_obj(X)])'
% rather than just `init_obj(X)' -- the fact that we don't leads to
@@ -978,10 +978,14 @@ ml_gen_field_take_address_assigns([TakeAddrInfo | TakeAddrInfos],
% Return the MLDS type suitable for constructing a constant static
% ground term with the specified cons_id.
%
-:- func get_type_for_cons_id(compilation_target, bool, mlds_type,
+ % In all cases, mlds_array_type(mlds_generic_type) is provisional.
+ % ml_gen_static_scalar_const* will replace it by a more specialized type,
+ % mlds_mostly_generic_array_type(_), if required by the elements.
+ %
+:- func get_const_type_for_cons_id(compilation_target, bool, mlds_type,
tag_uses_base_class, maybe(cons_id)) = mlds_type.
-get_type_for_cons_id(Target, HighLevelData, MLDS_Type, UsesBaseClass,
+get_const_type_for_cons_id(Target, HighLevelData, MLDS_Type, UsesBaseClass,
MaybeConsId) = ConstType :-
(
HighLevelData = no,
@@ -1060,8 +1064,8 @@ get_type_for_cons_id(Target, HighLevelData, MLDS_Type, UsesBaseClass,
ml_type_as_field(ModuleInfo, HighLevelData, FieldType, BoxedFieldType) :-
(
- % With the low-level data representation, we store all fields as boxed,
- % so we ignore the original field type and instead generate a
+ % With the low-level data representation, we store all fields as
+ % "boxed" so we ignore the original field type and instead generate a
% polymorphic type BoxedFieldType which we use for the type of the
% field. This type is used in the calls to ml_gen_box_or_unbox_rval
% to ensure that we box values when storing them into fields and
@@ -1069,7 +1073,7 @@ ml_type_as_field(ModuleInfo, HighLevelData, FieldType, BoxedFieldType) :-
%
% With the high-level data representation, we don't box everything,
% but for the MLDS->C and MLDS->asm back-ends we still need to box
- % floating point fields.
+ % floating point fields if they are wider than a word.
(
HighLevelData = no
@@ -1181,13 +1185,13 @@ ml_cast_cons_tag(Type, Tag, Rval) = CastRval :-
),
CastRval = ml_unop(cast(Type), TagRval).
-:- pred ml_gen_box_or_unbox_const_rval_list(module_info::in,
+:- pred ml_gen_box_or_unbox_const_rval_list_hld(module_info::in,
list(mer_type)::in, list(mer_type)::in, list(mlds_rval)::in,
prog_context::in, list(mlds_rval)::out,
ml_global_data::in, ml_global_data::out) is det.
-ml_gen_box_or_unbox_const_rval_list(ModuleInfo, ArgTypes, FieldTypes, ArgRvals,
- Context, FieldRvals, !GlobalData) :-
+ml_gen_box_or_unbox_const_rval_list_hld(ModuleInfo, ArgTypes, FieldTypes,
+ ArgRvals, Context, FieldRvals, !GlobalData) :-
(
ArgTypes = [],
FieldTypes = [],
@@ -1199,9 +1203,9 @@ ml_gen_box_or_unbox_const_rval_list(ModuleInfo, ArgTypes, FieldTypes, ArgRvals,
FieldTypes = [FieldType | FieldTypesTail],
ArgRvals = [ArgRval | ArgRvalsTail]
->
- ml_gen_box_or_unbox_const_rval(ModuleInfo,
+ ml_gen_box_or_unbox_const_rval_hld(ModuleInfo,
ArgType, FieldType, ArgRval, Context, FieldRval, !GlobalData),
- ml_gen_box_or_unbox_const_rval_list(ModuleInfo,
+ ml_gen_box_or_unbox_const_rval_list_hld(ModuleInfo,
ArgTypesTail, FieldTypesTail, ArgRvalsTail, Context,
FieldRvalsTail, !GlobalData),
FieldRvals = [FieldRval | FieldRvalsTail]
@@ -1209,11 +1213,11 @@ ml_gen_box_or_unbox_const_rval_list(ModuleInfo, ArgTypes, FieldTypes, ArgRvals,
unexpected($module, $pred, "list length mismatch")
).
-:- pred ml_gen_box_or_unbox_const_rval(module_info::in,
+:- pred ml_gen_box_or_unbox_const_rval_hld(module_info::in,
mer_type::in, mer_type::in, mlds_rval::in, prog_context::in,
mlds_rval::out, ml_global_data::in, ml_global_data::out) is det.
-ml_gen_box_or_unbox_const_rval(ModuleInfo, ArgType, FieldType, ArgRval,
+ml_gen_box_or_unbox_const_rval_hld(ModuleInfo, ArgType, FieldType, ArgRval,
Context, FieldRval, !GlobalData) :-
(
% Handle the case where the field type is a boxed type
@@ -1250,20 +1254,20 @@ ml_gen_box_const_rval_list(ModuleInfo, Context, [GroundTerm | GroundTerms],
ml_gen_box_const_rval_list(ModuleInfo, Context, GroundTerms,
BoxedRvals, !GlobalData).
-:- pred ml_gen_box_extra_const_rval_list(module_info::in, prog_context::in,
+:- pred ml_gen_box_extra_const_rval_list_lld(module_info::in, prog_context::in,
list(mlds_type)::in, list(mlds_rval)::in, list(mlds_rval)::out,
ml_global_data::in, ml_global_data::out) is det.
-ml_gen_box_extra_const_rval_list(_, _, [], [], [], !GlobalData).
-ml_gen_box_extra_const_rval_list(ModuleInfo, Context, [Type | Types],
+ml_gen_box_extra_const_rval_list_lld(_, _, [], [], [], !GlobalData).
+ml_gen_box_extra_const_rval_list_lld(ModuleInfo, Context, [Type | Types],
[Rval | Rvals], [BoxedRval | BoxedRvals], !GlobalData) :-
ml_gen_box_const_rval(ModuleInfo, Context, Type, Rval,
BoxedRval, !GlobalData),
- ml_gen_box_extra_const_rval_list(ModuleInfo, Context, Types, Rvals,
+ ml_gen_box_extra_const_rval_list_lld(ModuleInfo, Context, Types, Rvals,
BoxedRvals, !GlobalData).
-ml_gen_box_extra_const_rval_list(_, _, [], [_ | _], _, !GlobalData) :-
+ml_gen_box_extra_const_rval_list_lld(_, _, [], [_ | _], _, !GlobalData) :-
unexpected($module, $pred, "length mismatch").
-ml_gen_box_extra_const_rval_list(_, _, [_ | _], [], _, !GlobalData) :-
+ml_gen_box_extra_const_rval_list_lld(_, _, [_ | _], [], _, !GlobalData) :-
unexpected($module, $pred, "length mismatch").
:- pred ml_cons_name(compilation_target::in, cons_id::in, ctor_name::out)
@@ -1348,8 +1352,7 @@ ml_gen_cons_args_2([Var | Vars], [Lval | Lvals], [ArgType | ArgTypes],
% is actually the same as integer.
update_type_may_use_atomic_alloc(ModuleInfo, ArgType, !MayUseAtomic),
- % Figure out the type of the field. Note that for the MLDS->C and
- % MLDS->asm back-ends, we need to box floating point fields.
+ % Figure out the type of the field.
ml_type_as_field(ModuleInfo, HighLevelData, ConsArgType, BoxedArgType),
MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, BoxedArgType),
@@ -2529,7 +2532,7 @@ ml_gen_ground_term_conjunct_compound(ModuleInfo, Target, HighLevelData,
SubInitializers = ExtraInitializers ++ ArgInitializers,
% Generate a local static constant for this term.
- ConstType = get_type_for_cons_id(Target, HighLevelData, MLDS_Type,
+ ConstType = get_const_type_for_cons_id(Target, HighLevelData, MLDS_Type,
ml_tag_uses_base_class(ConsTag), yes(ConsId)),
% XXX If the secondary tag is in a base class, then ideally its
% initializer should be wrapped in `init_struct([init_obj(X)])'
@@ -2602,7 +2605,7 @@ construct_ground_term_initializer_hld(ModuleInfo, Context,
map.det_remove(Arg, ArgGroundTerm, !GroundTermMap),
ArgGroundTerm = ml_ground_term(ArgRval0, ArgType, _MLDS_ArgType),
ml_type_as_field(ModuleInfo, yes, ConsArgType, BoxedArgType),
- ml_gen_box_or_unbox_const_rval(ModuleInfo, ArgType, BoxedArgType,
+ ml_gen_box_or_unbox_const_rval_hld(ModuleInfo, ArgType, BoxedArgType,
ArgRval0, Context, ArgRval, !GlobalData).
:- pred construct_ground_term_initializer_lld(module_info::in,
diff --git a/compiler/mlds.m b/compiler/mlds.m
index 5cea540..d66279f 100644
--- a/compiler/mlds.m
+++ b/compiler/mlds.m
@@ -815,6 +815,15 @@
% MLDS code generator, e.g. the arrays used for
% string switches.
+ ; mlds_mostly_generic_array_type(list(mlds_type))
+ % A generic array with some float elements.
+ %
+ % This is the same as mlds_array_type(mlds_generic_type) except
+ % that some element types are mlds_native_float_type instead of
+ % mlds_generic_type. In C, it is not possible to initialize an
+ % element of a generic array with a float literal, so we replace
+ % them with a structure type with some float fields.
+
; mlds_ptr_type(mlds_type)
% Pointer types.
% Currently these are used for handling output arguments.
@@ -1320,14 +1329,9 @@
% The types of the arguments to the constructor.
%
- % Note that for --low-level-data, we box all fields of objects
- % created with new_object, i.e. they are represented with type
- % mlds_generic_type. We also do that for some fields even
- % for --high-level-data (e.g. floating point fields for the
- % MLDS->C and MLDS->asm back-ends). In such cases, the type
- % here should be mlds_generic_type; it is the responsibility
- % of the HLDS->MLDS code generator to insert code to box/unbox
- % the arguments.
+ % For boxed fields, the type here should be mlds_generic_type;
+ % it is the responsibility of the HLDS->MLDS code generator to
+ % insert code to box/unbox the arguments.
list(mlds_type),
% Can we use a cell allocated with GC_malloc_atomic to hold
@@ -1539,15 +1543,11 @@
% The FieldType is the type of the field. The PtrType is the
% type of the pointer from which we are fetching the field.
%
- % Note that for --low-level-data, we box all fields of objects
- % created with new_object, i.e. they are reprsented with type
- % mlds_generic_type. We also do that for some fields even
- % for --high-level-data (e.g. floating point fields for the
- % MLDS->C and MLDS->asm back-ends). In such cases, the type
- % here should be mlds_generic_type, not the actual type of
- % the field. If the actual type is different, then it is the
- % HLDS->MLDS code generator's responsibility to insert the
- % necessary code to handle boxing/unboxing.
+ % For boxed fields, the type here should be mlds_generic_type,
+ % not the actual type of the field. If the actual type is
+ % different, then it is the HLDS->MLDS code generator's
+ % responsibility to insert the necessary code to handle
+ % boxing/unboxing.
field_tag :: maybe(mlds_tag),
field_addr :: mlds_rval,
diff --git a/compiler/mlds_to_c.m b/compiler/mlds_to_c.m
index aafe07e..bcd0d11 100644
--- a/compiler/mlds_to_c.m
+++ b/compiler/mlds_to_c.m
@@ -98,6 +98,7 @@
:- import_module assoc_list.
:- import_module bool.
:- import_module cord.
+:- import_module float.
:- import_module int.
:- import_module library.
:- import_module list.
@@ -1090,6 +1091,7 @@ mlds_output_pragma_export_type(PrefixSuffix, MLDS_Type, !IO) :-
; MLDS_Type = mlds_commit_type
; MLDS_Type = mlds_class_type(_, _, _)
; MLDS_Type = mlds_array_type(_)
+ ; MLDS_Type = mlds_mostly_generic_array_type(_)
; MLDS_Type = mlds_func_type(_)
; MLDS_Type = mlds_generic_type
; MLDS_Type = mlds_generic_env_ptr_type
@@ -1546,16 +1548,63 @@ mlds_output_scalar_cell_group_decl(Opts, Indent, MangledModuleName,
TypeNum - CellGroup, !IO) :-
TypeNum = ml_scalar_common_type_num(TypeRawNum),
CellGroup = ml_scalar_cell_group(Type, InitArraySize,
- _Counter, _Members, RevRows),
+ _Counter, _Members, Rows),
+
+ ( Type = mlds_mostly_generic_array_type(ElemTypes) ->
+ mlds_output_scalar_cell_group_struct_defn(Opts, Indent,
+ MangledModuleName, TypeRawNum, ElemTypes, !IO)
+ ;
+ true
+ ),
mlds_indent(Indent, !IO),
io.write_string("\nstatic /* final */ const ", !IO),
- mlds_output_type_prefix(Opts, Type, !IO),
- NumRows = cord.length(RevRows),
+ NumRows = cord.length(Rows),
+ mlds_output_scalar_cell_group_type_and_name(Opts, MangledModuleName,
+ TypeRawNum, Type, InitArraySize, NumRows, !IO),
+ io.write_string(";\n", !IO).
+
+:- pred mlds_output_scalar_cell_group_struct_defn(mlds_to_c_opts::in, int::in,
+ string::in, int::in, list(mlds_type)::in, io::di, io::uo) is det.
+
+mlds_output_scalar_cell_group_struct_defn(Opts, Indent, MangledModuleName,
+ TypeRawNum, ElemTypes, !IO) :-
+ mlds_indent(Indent, !IO),
+ io.format("\nstruct %s_scalar_cell_group_%d {\n",
+ [s(MangledModuleName), i(TypeRawNum)], !IO),
+ list.foldl2(mlds_output_scalar_cell_group_struct_field(Opts, Indent + 1),
+ ElemTypes, 1, _, !IO),
+ mlds_indent(Indent, !IO),
+ io.write_string("};\n", !IO).
+
+:- pred mlds_output_scalar_cell_group_struct_field(mlds_to_c_opts::in,
+ indent::in, mlds_type::in, int::in, int::out, io::di, io::uo) is det.
+
+mlds_output_scalar_cell_group_struct_field(Opts, Indent, FieldType,
+ Num, Num + 1, !IO) :-
+ mlds_indent(Indent, !IO),
+ mlds_output_type_prefix(Opts, FieldType, !IO),
+ io.format(" f%d;\n", [i(Num)], !IO).
+
+:- pred mlds_output_scalar_cell_group_type_and_name(mlds_to_c_opts::in,
+ string::in, int::in, mlds_type::in, initializer_array_size::in, int::in,
+ io::di, io::uo) is det.
+
+mlds_output_scalar_cell_group_type_and_name(Opts, MangledModuleName,
+ TypeRawNum, Type, InitArraySize, NumRows, !IO) :-
+ ( Type = mlds_mostly_generic_array_type(_) ->
+ io.format("struct %s_scalar_cell_group_%d",
+ [s(MangledModuleName), i(TypeRawNum)], !IO)
+ ;
+ mlds_output_type_prefix(Opts, Type, !IO)
+ ),
io.format(" %s_scalar_common_%d[%d]",
[s(MangledModuleName), i(TypeRawNum), i(NumRows)], !IO),
- mlds_output_type_suffix(Opts, Type, InitArraySize, !IO),
- io.write_string(";\n", !IO).
+ ( Type = mlds_mostly_generic_array_type(_) ->
+ true
+ ;
+ mlds_output_type_suffix(Opts, Type, InitArraySize, !IO)
+ ).
:- pred mlds_output_vector_cell_group_decls(mlds_to_c_opts::in, indent::in,
mlds_module_name::in, string::in,
@@ -1580,13 +1629,13 @@ mlds_output_vector_cell_group_decl(Opts, Indent, ModuleName, MangledModuleName,
TypeNum - CellGroup, !IO) :-
TypeNum = ml_vector_common_type_num(TypeRawNum),
CellGroup = ml_vector_cell_group(Type, ClassDefn, _FieldNames,
- _NextRow, RevRows),
+ _NextRow, Rows),
mlds_output_defn(Opts, Indent, yes, ModuleName, ClassDefn, !IO),
mlds_indent(Indent, !IO),
io.write_string("\nstatic /* final */ const ", !IO),
mlds_output_type_prefix(Opts, Type, !IO),
- NumRows = cord.length(RevRows),
+ NumRows = cord.length(Rows),
io.format(" %s_vector_common_%d[%d]",
[s(MangledModuleName), i(TypeRawNum), i(NumRows)], !IO),
mlds_output_type_suffix(Opts, Type, no_size, !IO),
@@ -1619,10 +1668,8 @@ mlds_output_scalar_cell_group_defn(Opts, Indent, MangledModuleName,
list.length(Rows, NumRows),
mlds_indent(Indent, !IO),
io.write_string("\nstatic /* final */ const ", !IO),
- mlds_output_type_prefix(Opts, Type, !IO),
- io.format(" %s_scalar_common_%d[%d]",
- [s(MangledModuleName), i(TypeRawNum), i(NumRows)], !IO),
- mlds_output_type_suffix(Opts, Type, InitArraySize, !IO),
+ mlds_output_scalar_cell_group_type_and_name(Opts, MangledModuleName,
+ TypeRawNum, Type, InitArraySize, NumRows, !IO),
io.write_string(" = {\n", !IO),
list.foldl2(mlds_output_cell(Opts, Indent + 1), Rows, 0, _, !IO),
io.write_string("};\n", !IO).
@@ -2745,6 +2792,10 @@ mlds_output_type_prefix(Opts, MLDS_Type, !IO) :-
% suffix.
mlds_output_type(Opts, Type, !IO)
;
+ MLDS_Type = mlds_mostly_generic_array_type(_),
+ Type = mlds_generic_type,
+ mlds_output_type(Opts, Type, !IO)
+ ;
MLDS_Type = mlds_func_type(FuncParams),
mlds_output_func_type_prefix(Opts, FuncParams, !IO)
;
@@ -2897,6 +2948,8 @@ mlds_output_type_suffix(Opts, MLDS_Type, ArraySize, !IO) :-
MLDS_Type = mlds_array_type(_),
mlds_output_array_type_suffix(ArraySize, !IO)
;
+ MLDS_Type = mlds_mostly_generic_array_type(_)
+ ;
MLDS_Type = mlds_func_type(FuncParams),
mlds_output_func_type_suffix(Opts, FuncParams, !IO)
;
@@ -3905,6 +3958,7 @@ type_needs_forwarding_pointer_space(mlds_native_char_type) = no.
type_needs_forwarding_pointer_space(mlds_foreign_type(_)) = no.
type_needs_forwarding_pointer_space(mlds_class_type(_, _, _)) = no.
type_needs_forwarding_pointer_space(mlds_array_type(_)) = no.
+type_needs_forwarding_pointer_space(mlds_mostly_generic_array_type(_)) = no.
type_needs_forwarding_pointer_space(mlds_ptr_type(_)) = no.
type_needs_forwarding_pointer_space(mlds_func_type(_)) = no.
type_needs_forwarding_pointer_space(mlds_generic_type) = no.
@@ -4252,7 +4306,14 @@ mlds_output_unop(Opts, Unop, Expr, !IO) :-
mlds_output_cast_rval(Opts, Type, Expr, !IO) :-
mlds_output_cast(Opts, Type, !IO),
- mlds_output_rval(Opts, Expr, !IO).
+ (
+ Opts ^ m2co_highlevel_data = yes,
+ Expr = ml_const(mlconst_float(Float))
+ ->
+ mlds_output_float_bits(Opts, Float, !IO)
+ ;
+ mlds_output_rval(Opts, Expr, !IO)
+ ).
:- pred mlds_output_cast(mlds_to_c_opts::in, mlds_type::in, io::di, io::uo)
is det.
@@ -4288,9 +4349,16 @@ mlds_output_boxed_rval(Opts, Type, Expr, !IO) :-
; Type = mlds_native_float_type
)
->
+ (
+ Opts ^ m2co_highlevel_data = yes,
+ Expr = ml_const(mlconst_float(Float))
+ ->
+ mlds_output_float_bits(Opts, Float, !IO)
+ ;
io.write_string("MR_box_float(", !IO),
mlds_output_rval(Opts, Expr, !IO),
io.write_string(")", !IO)
+ )
;
( Type = mercury_type(builtin_type(builtin_type_char), _, _)
; Type = mlds_native_char_type
@@ -4505,6 +4573,35 @@ mlds_output_rval_const(_Opts, Const, !IO) :-
io.write_string("NULL", !IO)
).
+ % Output the bit layout of a floating point literal as an integer, so that
+ % it can be cast to a pointer type. We manage to avoid this in all but one
+ % situation: in high-level data grades, when the program contains a ground
+ % term, of which a sub-term is a no-tag wrapper around float.
+ %
+ % XXX the problem is the field type in the C struct which is generated for
+ % the type which has the no-tag argument. The generated field type is a
+ % pointer to the struct for the no-tag type, yet the no-tag optimisation is
+ % used, so the field type should either be the struct for the no-tag type
+ % (not a pointer) or the type which the no-tag type wraps (which itself may
+ % be a no-tag type, etc.)
+ %
+:- pred mlds_output_float_bits(mlds_to_c_opts::in, float::in, io::di, io::uo)
+ is det.
+
+mlds_output_float_bits(Opts, Float, !IO) :-
+ expect(unify(Opts ^ m2co_highlevel_data, yes), $module, $pred,
+ "should only be required with --high-level-data"),
+ Globals = Opts ^ m2co_all_globals,
+ globals.lookup_bool_option(Globals, single_prec_float, SinglePrecFloat),
+ (
+ SinglePrecFloat = yes,
+ String = float32_bits_string(Float)
+ ;
+ SinglePrecFloat = no,
+ String = float64_bits_string(Float)
+ ),
+ io.format("%s /* float-bits: %g */", [s(String), f(Float)], !IO).
+
%-----------------------------------------------------------------------------%
:- pred mlds_output_tag(mlds_tag::in, io::di, io::uo) is det.
diff --git a/compiler/mlds_to_cs.m b/compiler/mlds_to_cs.m
index ebcf0e9..a85d4a3 100644
--- a/compiler/mlds_to_cs.m
+++ b/compiler/mlds_to_cs.m
@@ -1499,6 +1499,7 @@ get_type_initializer(Info, Type) = Initializer :-
; Type = mlds_commit_type
; Type = mlds_class_type(_, _, _)
; Type = mlds_array_type(_)
+ ; Type = mlds_mostly_generic_array_type(_)
; Type = mlds_ptr_type(_)
; Type = mlds_func_type(_)
; Type = mlds_generic_type
@@ -2262,6 +2263,11 @@ type_to_string(Info, MLDS_Type, String, ArrayDims) :-
type_to_string(Info, Type, String, ArrayDims0),
ArrayDims = [0 | ArrayDims0]
;
+ MLDS_Type = mlds_mostly_generic_array_type(_),
+ Type = mlds_generic_type,
+ type_to_string(Info, Type, String, ArrayDims0),
+ ArrayDims = [0 | ArrayDims0]
+ ;
MLDS_Type = mlds_func_type(mlds_func_params(Args, RetTypes)),
ArgTypes = list.map(func(mlds_argument(_, Type, _)) = Type, Args),
String = method_ptr_type_to_string(Info, ArgTypes, RetTypes),
@@ -2418,6 +2424,8 @@ generic_args_types_to_string(Info, ArgsTypes, String) :-
type_is_array(Type) = IsArray :-
( Type = mlds_array_type(_) ->
IsArray = is_array
+ ; Type = mlds_mostly_generic_array_type(_) ->
+ IsArray = is_array
; Type = mlds_mercury_array_type(_) ->
IsArray = is_array
; Type = mercury_type(_, CtorCat, _) ->
diff --git a/compiler/mlds_to_gcc.m b/compiler/mlds_to_gcc.m
index c48e8a7..97fbef0 100644
--- a/compiler/mlds_to_gcc.m
+++ b/compiler/mlds_to_gcc.m
@@ -299,7 +299,8 @@ compile_to_asm(Globals, MLDS, ContainsCCode, !IO) :-
% them from the asm file!) and pass that to mlds_to_c.m
% to create the .mih file, and if necessary the .c file.
ForeignMLDS = mlds(ModuleName, AllForeignCode, Imports,
- ml_global_data_init(do_not_use_common_cells),
+ ml_global_data_init(do_not_use_common_cells,
+ do_not_have_unboxed_floats),
list.map(make_public, ForeignDefns),
InitPreds, FinalPreds, ExportedEnums),
mlds_to_c.output_c_file(ForeignMLDS, Globals, "", !IO)
@@ -1761,6 +1762,11 @@ build_type(Type, ArraySize, GlobalInfo, GCC_Type, !IO) :-
build_type(BaseType, GlobalInfo, GCC_BaseType, !IO),
build_sized_array_type(GCC_BaseType, ArraySize, GCC_Type, !IO)
;
+ Type = mlds_mostly_generic_array_type(_),
+ BaseType = mlds_generic_type,
+ build_type(BaseType, GlobalInfo, GCC_BaseType, !IO),
+ build_sized_array_type(GCC_BaseType, ArraySize, GCC_Type, !IO)
+ ;
Type = mlds_func_type(Params),
Signature = mlds_get_func_signature(Params),
Signature = mlds_func_signature(ArgTypes, RetTypes),
diff --git a/compiler/mlds_to_il.m b/compiler/mlds_to_il.m
index e24f4e7..40d9e8f 100644
--- a/compiler/mlds_to_il.m
+++ b/compiler/mlds_to_il.m
@@ -379,7 +379,8 @@ il_transform_mlds(MLDS0, MLDS) :-
expect(map.is_empty(VectorCellGroupMap), $module, $pred,
"nonempty VectorCellGroupMap"),
Defns1 = GlobalDefns ++ Defns0 ++ ExportDefns,
- GlobalData = ml_global_data_init(do_not_use_common_cells),
+ GlobalData = ml_global_data_init(do_not_use_common_cells,
+ do_not_have_unboxed_floats),
IsFunctionOrData =
(pred(D::in) is semidet :-
@@ -3112,6 +3113,9 @@ mlds_type_to_ilds_type(DataRep, mlds_mercury_array_type(ElementType)) =
mlds_type_to_ilds_type(DataRep, mlds_array_type(ElementType)) =
il_type([], '[]'(mlds_type_to_ilds_type(DataRep, ElementType), [])).
+mlds_type_to_ilds_type(_, mlds_mostly_generic_array_type(_)) = _ :-
+ sorry($module, $pred, "mlds_mostly_generic_array_type").
+
% XXX Should be checked.
mlds_type_to_ilds_type(_, mlds_type_info_type) = il_generic_type.
diff --git a/compiler/mlds_to_java.m b/compiler/mlds_to_java.m
index 46d6166..8c1db58 100644
--- a/compiler/mlds_to_java.m
+++ b/compiler/mlds_to_java.m
@@ -1477,6 +1477,10 @@ rename_class_names_type(Renaming, !Type) :-
rename_class_names_type(Renaming, Type0, Type),
!:Type = mlds_array_type(Type)
;
+ !.Type = mlds_mostly_generic_array_type(Types0),
+ list.map(rename_class_names_type(Renaming), Types0, Types),
+ !:Type = mlds_mostly_generic_array_type(Types)
+ ;
!.Type = mlds_ptr_type(Type0),
rename_class_names_type(Renaming, Type0, Type),
!:Type = mlds_ptr_type(Type)
@@ -2781,6 +2785,7 @@ get_java_type_initializer(Type) = Initializer :-
; Type = mlds_foreign_type(_)
; Type = mlds_class_type(_, _, _)
; Type = mlds_array_type(_)
+ ; Type = mlds_mostly_generic_array_type(_)
; Type = mlds_ptr_type(_)
; Type = mlds_func_type(_)
; Type = mlds_generic_type
@@ -3476,6 +3481,11 @@ type_to_string(Info, MLDS_Type, String, ArrayDims) :-
type_to_string(Info, Type, String, ArrayDims0),
ArrayDims = [0 | ArrayDims0]
;
+ MLDS_Type = mlds_mostly_generic_array_type(_Type),
+ Type = mlds_generic_type,
+ type_to_string(Info, Type, String, ArrayDims0),
+ ArrayDims = [0 | ArrayDims0]
+ ;
MLDS_Type = mlds_func_type(_FuncParams),
String = "jmercury.runtime.MethodPtr",
ArrayDims = []
diff --git a/library/exception.m b/library/exception.m
index f04155b..f0d1699 100644
--- a/library/exception.m
+++ b/library/exception.m
@@ -946,8 +946,6 @@ catch_impl(Pred::(pred(out) is nondet), Handler::in(handler), T::out) :-
MR_Pred pred, MR_Pred handler_pred, MR_Box *output,
MR_CONT_PARAMS);
- #ifndef MR_AVOID_MACROS
-
/* det ==> model_det */
#define mercury__exception__builtin_catch_3_p_0 \
mercury__exception__builtin_catch_model_det
@@ -972,8 +970,6 @@ catch_impl(Pred::(pred(out) is nondet), Handler::in(handler), T::out) :-
#define mercury__exception__builtin_catch_3_p_5 \
mercury__exception__builtin_catch_model_non
- #endif /* !MR_AVOID_MACROS */
-
void MR_CALL mercury__exception__builtin_throw_1_p_0(MR_Univ exception);
void MR_CALL mercury__exception__builtin_catch_model_det(
diff --git a/library/float.m b/library/float.m
index 7a66dbc..92d59ed 100644
--- a/library/float.m
+++ b/library/float.m
@@ -226,6 +226,26 @@
:- func float.float_to_doc(float) = doc.
%---------------------------------------------------------------------------%
+
+:- interface.
+
+% These functions are hidden for now. `int' is not guaranteed to be able to
+% represent a double, so we return strings for now. Endianness and treatment
+% of special values also needs to be considered.
+
+ % Convert a float to an IEEE single-precision floating point value, then
+ % return the integer representation of the bit layout of that value as a
+ % string.
+ %
+:- func float32_bits_string(float::in) = (string::uo) is det.
+
+ % Convert a float to an IEEE double-precision floating point value, then
+ % return the integer representation of the bit layout of that value as a
+ % string.
+ %
+:- func float64_bits_string(float::in) = (string::uo) is det.
+
+%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
@@ -867,5 +887,89 @@ float.max_exponent = 1024.
%
float.float_to_doc(X) = str(string.float_to_string(X)).
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_proc("C",
+ float32_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ union {
+ float f;
+ MR_int_least32_t i;
+ } u;
+ char buf[64];
+
+ u.f = (float) Flt;
+ sprintf(buf, ""%d"", u.i);
+ MR_make_aligned_string_copy(Str, buf);
+").
+
+:- pragma foreign_proc("Java",
+ float32_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ float f = (float) Flt;
+ int i = Float.floatToIntBits(f);
+ Str = Integer.toString(i);
+").
+
+:- pragma foreign_proc("C#",
+ float32_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ float f = (float) Flt;
+ int i = System.BitConverter.ToInt32(System.BitConverter.GetBytes(f), 0);
+ Str = i.ToString();
+").
+
+:- pragma foreign_proc("Erlang",
+ float32_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ <<Int:32/signed-integer>> = <<Flt:32/float>>,
+ Str = integer_to_list(Int)
+").
+
+:- pragma foreign_proc("C",
+ float64_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ union {
+ double f;
+ MR_int_least64_t i;
+ } u;
+ char buf[64];
+
+ u.f = (double) Flt;
+ sprintf(buf, ""%ld"", u.i);
+ MR_make_aligned_string_copy(Str, buf);
+").
+
+:- pragma foreign_proc("Java",
+ float64_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ double d = (double) Flt;
+ long i = Double.doubleToLongBits(d);
+ Str = Long.toString(i);
+").
+
+:- pragma foreign_proc("C#",
+ float64_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ double d = (double) Flt;
+ long i = System.BitConverter.DoubleToInt64Bits(d);
+ Str = i.ToString();
+").
+
+:- pragma foreign_proc("Erlang",
+ float64_bits_string(Flt::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ <<Int:64/signed-integer>> = <<Flt:64/float>>,
+ Str = integer_to_list(Int)
+").
+
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
diff --git a/runtime/mercury.c b/runtime/mercury.c
index d073ebe..dc7e1d8 100644
--- a/runtime/mercury.c
+++ b/runtime/mercury.c
@@ -83,7 +83,7 @@ MR_OUTLINE_DEFN(
}
)
-#if defined(MR_AVOID_MACROS) || !defined(MR_GNUC)
+#if defined(MR_BOXED_FLOAT) && !defined(MR_GNUC)
MR_OUTLINE_DEFN(
MR_Box
@@ -93,45 +93,14 @@ MR_OUTLINE_DEFN(
MR_Float *ptr;
MR_make_hp_float_aligned();
- ptr = (MR_Float *) MR_new_object(MR_Float, sizeof(MR_Float),
+ ptr = (MR_Float *) MR_new_object_atomic(MR_Float, sizeof(MR_Float),
MR_ALLOC_SITE_FLOAT, NULL);
*ptr = f;
return (MR_Box) ptr;
}
)
-#endif /* MR_AVOID_MACROS || !MR_GNUC */
-
-#if defined(MR_AVOID_MACROS)
-
-MR_OUTLINE_DEFN(
- MR_Float
- MR_unbox_float(MR_Box b)
-,
- {
- return * (MR_Float *) b;
- }
-)
-
-#endif /* MR_AVOID_MACROS */
-
-/*
-** This is exactly the same as MR_box_float(), except that
-** it is unconditionally defined as an external function,
-** not as a macro, static function, or inline function.
-** It is used by the `--target asm' GCC back-end interface.
-*/
-MR_Box
-MR_asm_box_float(MR_Float f)
-{
- MR_Float *ptr;
-
- MR_make_hp_float_aligned();
- ptr = (MR_Float *) MR_new_object(MR_Float, sizeof(MR_Float),
- MR_ALLOC_SITE_FLOAT, NULL);
- *ptr = f;
- return (MR_Box) ptr;
-}
+#endif /* MR_BOXED_FLOAT && !MR_GNUC */
#endif /* ! MR_HIGHLEVEL_CODE */
diff --git a/runtime/mercury.h b/runtime/mercury.h
index c90edbb..14b8582 100644
--- a/runtime/mercury.h
+++ b/runtime/mercury.h
@@ -259,28 +259,40 @@ extern MR_Word mercury__private_builtin__dummy_var;
#endif
+/*---------------------------------------------------------------------------*/
/*
-** Code to box/unbox floats
+** Code to box/unbox floats in high-level C grades.
+** The low-level C grades only use MR_float_to_word and MR_word_to_float.
+**
+** This code is not in mercury_float.h because the function definition
+** requires the declaration of MR_new_object_atomic.
**
-** Note that this code is also duplicated in mercury.c.
-** XXX we should optimize the case where sizeof(MR_Float) == sizeof(MR_Box)
+** When sizeof(MR_Float) <= sizeof(MR_Box), the names "box" and "unbox" should
+** be interpreted as casts to and from MR_Box, as we do not truly box the
+** floats then.
*/
-#if defined(MR_GNUC) && !defined(MR_AVOID_MACROS)
- #define MR_box_float(f) ({ \
+#ifdef MR_HIGHLEVEL_CODE
+ #ifdef MR_BOXED_FLOAT
+
+ #if defined(MR_GNUC)
+ #define MR_box_float(f) \
+ ({ \
MR_Float *MR_box_float_ptr; \
\
MR_make_hp_float_aligned(); \
- MR_box_float_ptr = MR_new_object_atomic(MR_Float, \
+ MR_box_float_ptr = (MR_Float *) MR_new_object_atomic(MR_Float,\
sizeof(MR_Float), MR_ALLOC_SITE_FLOAT, NULL); \
*MR_box_float_ptr = (f); \
/* return */ (MR_Box) MR_box_float_ptr; \
})
-#else
+ #else
+ /* Note that this code is also duplicated in mercury.c. */
MR_EXTERN_INLINE MR_Box MR_box_float(MR_Float f);
MR_EXTERN_INLINE MR_Box
- MR_box_float(MR_Float f) {
+ MR_box_float(MR_Float f)
+ {
MR_Float *ptr;
MR_make_hp_float_aligned();
@@ -289,25 +301,19 @@ extern MR_Word mercury__private_builtin__dummy_var;
*ptr = f;
return (MR_Box) ptr;
}
-#endif
-
-#ifdef MR_AVOID_MACROS
- MR_EXTERN_INLINE MR_Float MR_unbox_float(MR_Box b);
+ #endif
- MR_EXTERN_INLINE
- MR_Float MR_unbox_float(MR_Box b) {
- return *(MR_Float *)b;
- }
-#else
#define MR_unbox_float(ptr) (*(MR_Float *)ptr)
-#endif
-/*
-** Like MR_box_float, but always an external function, never a macro
-** or an inline function. This is used by the `--target asm'
-** GCC back-end interface.
-*/
-MR_Box MR_asm_box_float(MR_Float f);
+ #else /* ! MR_BOXED_FLOAT */
+
+ #define MR_box_float(F) ((MR_Box) MR_float_to_word(F))
+ #define MR_unbox_float(B) MR_word_to_float((MR_Word)(B))
+
+ #endif /* ! MR_BOXED_FLOAT */
+#endif /* MR_HIGHLEVEL_CODE */
+
+/*---------------------------------------------------------------------------*/
/*
** MR_GC_check():
diff --git a/runtime/mercury_conf_param.h b/runtime/mercury_conf_param.h
index 8d57750..31409e0 100644
--- a/runtime/mercury_conf_param.h
+++ b/runtime/mercury_conf_param.h
@@ -107,10 +107,6 @@
** For details, see the definition of the MR_CALL macro in
** runtime/mercury_std.h.
**
-** MR_AVOID_MACROS:
-** For the MLDS back-end (i.e. MR_HIGHLEVEL_CODE),
-** use inline functions rather than macros for a few builtins.
-**
** MR_THREAD_SAFE
** Enable support for parallelism.
**
@@ -594,15 +590,6 @@
*/
/*
-** MR_HIGHLEVEL_CODE implies MR_BOXED_FLOAT,
-** since unboxed float is currently not yet implemented for the MLDS back-end.
-** XXX we really ought to fix that...
-*/
-#ifdef MR_HIGHLEVEL_CODE
- #define MR_BOXED_FLOAT 1
-#endif
-
-/*
** MR_PIC means that we are generating position independent code,
** i.e. that the file was compiled with the gcc option `-fpic' or equivalent.
*/
diff --git a/runtime/mercury_float.h b/runtime/mercury_float.h
index a9398f5..599fe14 100644
--- a/runtime/mercury_float.h
+++ b/runtime/mercury_float.h
@@ -73,7 +73,7 @@
#else /* not MR_BOXED_FLOAT */
- /* unboxed float means we can assume sizeof(MR_Float) == sizeof(MR_Word) */
+ /* unboxed float means we can assume sizeof(MR_Float) <= sizeof(MR_Word) */
#define MR_make_hp_float_aligned() ((void)0)
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index d3190a0..cdf6716 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -99,6 +99,7 @@ ORDINARY_PROGS= \
finalise_decl \
finalize_to_bitmap \
float_field \
+ float_ground_term \
float_map \
float_reg \
float_rounding_bug \
diff --git a/tests/hard_coded/float_ground_term.exp b/tests/hard_coded/float_ground_term.exp
new file mode 100644
index 0000000..c3c07cf
--- /dev/null
+++ b/tests/hard_coded/float_ground_term.exp
@@ -0,0 +1,3 @@
+[mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1)]
+[mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2)]
+[poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3)]
diff --git a/tests/hard_coded/float_ground_term.m b/tests/hard_coded/float_ground_term.m
new file mode 100644
index 0000000..e6b4792
--- /dev/null
+++ b/tests/hard_coded/float_ground_term.m
@@ -0,0 +1,51 @@
+%-----------------------------------------------------------------------------%
+
+:- module float_ground_term.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+
+:- type mono
+ ---> mono(float).
+
+:- type list_of_mono
+ ---> []
+ ; [mono | list_of_mono].
+
+:- type poly(T)
+ ---> poly(T).
+
+main(!IO) :-
+ T1 = [
+ mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1),
+ mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1),
+ mono(1.1), mono(1.1), mono(1.1), mono(1.1), mono(1.1)
+ ] : list(mono),
+ T2 = [
+ mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2),
+ mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2),
+ mono(2.2), mono(2.2), mono(2.2), mono(2.2), mono(2.2)
+ ] : list_of_mono,
+ T3 =[
+ poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3),
+ poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3),
+ poly(3.3), poly(3.3), poly(3.3), poly(3.3), poly(3.3)
+ ],
+ io.write(T1, !IO),
+ io.nl(!IO),
+ io.write(T2, !IO),
+ io.nl(!IO),
+ io.write(T3, !IO),
+ io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list