[m-rev.] diff: fix problems with double-word float constructor args

[Peter Wang]

Branches: main

Fix two problems with double-word floats on 32-bit platforms.

compiler/make_hlds_passes.m:
	It doesn't make sense to have a no-tag type functor with a double-word
	argument.  If the argument is a float then it should still be
	single-width, i.e. boxed.

compiler/unify_gen.m:
	The argument width was not taken into account when generating float
	arguments in constant structures.  Double-word float arguments were
	still generated as single-word boxed floats.

diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m
index 0978a85..67667fd 100644
--- a/compiler/make_hlds_passes.m
+++ b/compiler/make_hlds_passes.m
@@ -235,7 +235,7 @@ decide_du_type_layout(ModuleInfo, TypeCtor, TypeDefn, !TypeTable) :-
         Body0 = hlds_du_type(Ctors0, ConsTagValues, MaybeCheaperTagTest,
             DuKind, MaybeUserEqComp, DirectArgFunctors, ReservedTag,
             ReservedAddr, MaybeForeign),
-        list.map(layout_du_ctor_args(ModuleInfo), Ctors0, Ctors),
+        list.map(layout_du_ctor_args(ModuleInfo, DuKind), Ctors0, Ctors),
         Body = hlds_du_type(Ctors, ConsTagValues, MaybeCheaperTagTest,
             DuKind, MaybeUserEqComp, DirectArgFunctors, ReservedTag,
             ReservedAddr, MaybeForeign),
@@ -250,19 +250,28 @@ decide_du_type_layout(ModuleInfo, TypeCtor, TypeDefn, !TypeTable) :-
         % Leave these types alone.
     ).
     
-:- pred layout_du_ctor_args(module_info::in,
+:- pred layout_du_ctor_args(module_info::in, du_type_kind::in,
     constructor::in, constructor::out) is det.
 
-layout_du_ctor_args(ModuleInfo, Ctor0, Ctor) :-
+layout_du_ctor_args(ModuleInfo, DuKind, Ctor0, Ctor) :-
     Ctor0 = ctor(ExistTVars, Constraints, Name, Args0, Context),
     module_info_get_globals(ModuleInfo, Globals),
-    use_double_word_floats(Globals, DoubleWordFloats),
     (
-        DoubleWordFloats = yes,
-        set_double_word_floats(ModuleInfo, Args0, Args1)
-    ;
-        DoubleWordFloats = no,
+        ( DuKind = du_type_kind_mercury_enum
+        ; DuKind = du_type_kind_foreign_enum(_)
+        ; DuKind = du_type_kind_direct_dummy
+        ; DuKind = du_type_kind_notag(_, _, _)
+        ),
         Args1 = Args0
+    ;
+        DuKind = du_type_kind_general,
+        % A functor with a single float argument can have a double-width word
+        % if it is not a no-tag functor. An example is `poly_type.f(float)'.
+        ( use_double_word_floats(Globals, yes) ->
+            set_double_word_floats(ModuleInfo, Args0, Args1)
+        ;
+            Args1 = Args0
+        )
     ),
     globals.lookup_bool_option(Globals, allow_argument_packing, ArgPacking),
     (
diff --git a/compiler/unify_gen.m b/compiler/unify_gen.m
index 2a2381b..aebc73e 100644
--- a/compiler/unify_gen.m
+++ b/compiler/unify_gen.m
@@ -1706,8 +1706,9 @@ generate_const_struct_rval(ModuleInfo, UnboxedFloats, ConstStructMap,
         ConsTag = no_tag,
         (
             ConstArgs = [ConstArg],
+            det_single_arg_width(ConsArgWidths, ConsArgWidth),
             generate_const_struct_arg(ModuleInfo, UnboxedFloats,
-                ConstStructMap, ConstArg, ArgTypedRval),
+                ConstStructMap, ConstArg, ConsArgWidth, ArgTypedRval),
             TypedRval = ArgTypedRval
         ;
             ( ConstArgs = []
@@ -1719,8 +1720,9 @@ generate_const_struct_rval(ModuleInfo, UnboxedFloats, ConstStructMap,
         ConsTag = direct_arg_tag(Ptag),
         (
             ConstArgs = [ConstArg],
+            det_single_arg_width(ConsArgWidths, ConsArgWidth),
             generate_const_struct_arg(ModuleInfo, UnboxedFloats,
-                ConstStructMap, ConstArg, ArgTypedRval),
+                ConstStructMap, ConstArg, ConsArgWidth, ArgTypedRval),
             ArgTypedRval = typed_rval(ArgRval, _RvalType),
             Rval = mkword(Ptag, ArgRval),
             TypedRval = typed_rval(Rval, lt_data_ptr)
@@ -1738,7 +1740,7 @@ generate_const_struct_rval(ModuleInfo, UnboxedFloats, ConstStructMap,
             ConsTag = unshared_tag(Ptag)
         ),
         generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
-            ConstArgs, ArgTypedRvals),
+            ConstArgs, ConsArgWidths, ArgTypedRvals),
         pack_ground_term_args(ConsArgWidths, ArgTypedRvals, PackArgTypedRvals),
         add_scalar_static_cell(PackArgTypedRvals, DataAddr, !StaticCellInfo),
         MaybeOffset = no,
@@ -1748,7 +1750,7 @@ generate_const_struct_rval(ModuleInfo, UnboxedFloats, ConstStructMap,
     ;
         ConsTag = shared_remote_tag(Ptag, Stag),
         generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
-            ConstArgs, ArgTypedRvals),
+            ConstArgs, ConsArgWidths, ArgTypedRvals),
         pack_ground_term_args(ConsArgWidths, ArgTypedRvals, PackArgTypedRvals),
         StagTypedRval = typed_rval(const(llconst_int(Stag)), lt_integer),
         AllTypedRvals = [StagTypedRval | PackArgTypedRvals],
@@ -1778,22 +1780,21 @@ generate_const_struct_rval(ModuleInfo, UnboxedFloats, ConstStructMap,
     ).
 
 :- pred generate_const_struct_args(module_info::in, have_unboxed_floats::in,
-    const_struct_map::in, list(const_struct_arg)::in, list(typed_rval)::out)
-    is det.
+    const_struct_map::in, list(const_struct_arg)::in, list(arg_width)::in,
+    list(typed_rval)::out) is det.
 
-generate_const_struct_args(_, _, _, [], []).
 generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
-        [ConstArg | ConstArgs], [TypedRval | TypedRvals]) :-
-    generate_const_struct_arg(ModuleInfo, UnboxedFloats, ConstStructMap,
-        ConstArg, TypedRval),
-    generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
-        ConstArgs, TypedRvals).
+        ConstArgs, ArgWidths, TypedRvals) :-
+    list.map_corresponding(
+        generate_const_struct_arg(ModuleInfo, UnboxedFloats, ConstStructMap),
+        ConstArgs, ArgWidths, TypedRvals).
 
 :- pred generate_const_struct_arg(module_info::in, have_unboxed_floats::in,
-    const_struct_map::in, const_struct_arg::in, typed_rval::out) is det.
+    const_struct_map::in, const_struct_arg::in, arg_width::in, typed_rval::out)
+    is det.
 
 generate_const_struct_arg(ModuleInfo, UnboxedFloats, ConstStructMap,
-        ConstArg, TypedRval) :-
+        ConstArg, ArgWidth, TypedRval) :-
     (
         ConstArg = csa_const_struct(ConstNum),
         map.lookup(ConstStructMap, ConstNum, TypedRval)
@@ -1801,14 +1802,14 @@ generate_const_struct_arg(ModuleInfo, UnboxedFloats, ConstStructMap,
         ConstArg = csa_constant(ConsId, _),
         ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
         generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats,
-            ConstStructMap, ConsTag, TypedRval)
+            ConstStructMap, ConsTag, ArgWidth, TypedRval)
     ).
 
 :- pred generate_const_struct_arg_tag(module_info::in, have_unboxed_floats::in,
-    const_struct_map::in, cons_tag::in, typed_rval::out) is det.
+    const_struct_map::in, cons_tag::in, arg_width::in, typed_rval::out) is det.
 
 generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats, ConstStructMap,
-        ConsTag, TypedRval) :-
+        ConsTag, ArgWidth, TypedRval) :-
     (
         (
             ConsTag = string_tag(String),
@@ -1832,7 +1833,13 @@ generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats, ConstStructMap,
                 Type = lt_float
             ;
                 UnboxedFloats = do_not_have_unboxed_floats,
-                Type = lt_data_ptr
+                % Though a standalone float might have needed to boxed, it may
+                % be stored in unboxed form as a constructor argument.
+                ( ArgWidth = double_word ->
+                    Type = lt_float
+                ;
+                    Type = lt_data_ptr
+                )
             )
         ),
         TypedRval = typed_rval(const(Const), Type)
@@ -1848,7 +1855,7 @@ generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats, ConstStructMap,
     ;
         ConsTag = shared_with_reserved_addresses_tag(_, ActualConsTag),
         generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats,
-            ConstStructMap, ActualConsTag, TypedRval)
+            ConstStructMap, ActualConsTag, ArgWidth, TypedRval)
     ;
         ConsTag = type_ctor_info_tag(ModuleName, TypeName, TypeArity),
         RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, TypeArity),
@@ -1882,6 +1889,18 @@ generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats, ConstStructMap,
         unexpected($module, $pred, "unexpected tag")
     ).
 
+:- pred det_single_arg_width(list(arg_width)::in, arg_width::out) is det.
+
+det_single_arg_width(ArgWidths, ArgWidth) :-
+    (
+        ArgWidths = [ArgWidth]
+    ;
+        ( ArgWidths = []
+        ; ArgWidths = [_, _ | _]
+        ),
+        unexpected($module, $pred, "unexpected arg_width list")
+    ).
+
 %---------------------------------------------------------------------------%
 
 :- type active_ground_term_map == map(prog_var, typed_rval).

--------------------------------------------------------------------------
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
--------------------------------------------------------------------------