[m-rev.] for review: fix bug #129

[Peter Wang]

Still trying to make a small test case.  It bootchecks okay.

Branches: main

During higher-order specialisation, `interpret_typeclass_info_manipulator'
incorrectly simulated the execution of the macros
`MR_typeclass_info_superclass_info' and `MR_typeclass_info_param_type_info'.

The macros extract an argument of a typeclass_info vector, the offset of which
is given by `MR_typeclass_info_num_extra_instance_args(tci) + n'.
The computation used in `interpret_typeclass_info_manipulator' was actually
equivalent to `MR_typeclass_info_num_instance_constraints(tci) + n'.

Since "MR_typeclass_info_num_extra_instance_args gives the sum of
MR_typeclass_info_num_instance_type_vars and
MR_typeclass_info_num_instance_constraints", the offset would be off by the
number of (unconstrained) type variables. 

This fixes bug #129.

compiler/higher_order.m:
        As above.

        Add a sanity check.

library/private_builtin.m:
        Delete some unnecessary casts in Java foreign_procs.

runtime/mercury_type_info.h:
        Fix a typo.

diff --git a/compiler/higher_order.m b/compiler/higher_order.m
index 86ca91c..0258a3d 100644
--- a/compiler/higher_order.m
+++ b/compiler/higher_order.m
@@ -2020,16 +2020,21 @@ interpret_typeclass_info_manipulator(Manipulator, Args, Goal0, Goal, !Info) :-
         module_info_get_instance_table(ModuleInfo, Instances),
         map.lookup(Instances, ClassId, InstanceDefns),
         list.index1_det(InstanceDefns, InstanceNum, InstanceDefn),
-        InstanceDefn = hlds_instance_defn(_, _, _, Constraints, _, _, _, _, _),
+        InstanceDefn = hlds_instance_defn(_, _, _, Constraints, InstanceTypes,
+            _, _, _, _),
         (
-            Manipulator = type_info_from_typeclass_info,
-            list.length(Constraints, NumConstraints),
-            Index = Index0 + NumConstraints
-        ;
-            Manipulator = superclass_from_typeclass_info,
+            ( Manipulator = type_info_from_typeclass_info
+            ; Manipulator = superclass_from_typeclass_info
+            ),
+            % polymorphism.m adds MR_typeclass_info_num_extra_instance_args
+            % to the index. The calculation of NumExtra is from
+            % base_typeclass_info.gen_body.
+            type_vars_list(InstanceTypes, TypeVars),
+            get_unconstrained_tvars(TypeVars, Constraints, Unconstrained),
             list.length(Constraints, NumConstraints),
-            % Polymorphism.m adds the number of type_infos to the index.
-            Index = Index0 + NumConstraints
+            list.length(Unconstrained, NumUnconstrained),
+            NumExtra = NumConstraints + NumUnconstrained,
+            Index = Index0 + NumExtra
         ;
             Manipulator = instance_constraint_from_typeclass_info,
             Index = Index0
@@ -2045,6 +2050,18 @@ interpret_typeclass_info_manipulator(Manipulator, Args, Goal0, Goal, !Info) :-
         rtti_var_info_duplicate_replace(TypeInfoArg, TypeInfoVar,
             RttiVarMaps0, RttiVarMaps),
         proc_info_set_rtti_varmaps(RttiVarMaps, ProcInfo0, ProcInfo),
+
+        % Sanity check.
+        proc_info_get_vartypes(ProcInfo, VarTypes),
+        map.lookup(VarTypes, TypeInfoVar, TypeInfoVarType),
+        map.lookup(VarTypes, TypeInfoArg, TypeInfoArgType),
+        ( TypeInfoVarType = TypeInfoArgType ->
+            true
+        ;
+            unexpected(this_file,
+                "interpret_typeclass_info_manipulator: type mismatch")
+        ),
+
         !Info ^ hoi_proc_info := ProcInfo,
 
         !Info ^ hoi_changed := ho_changed
diff --git a/library/private_builtin.m b/library/private_builtin.m
index 58de473..f456a18 100644
--- a/library/private_builtin.m
+++ b/library/private_builtin.m
@@ -471,6 +471,7 @@ public static /* typeclass_info */ Object[] MR_typeclass_info_superclass_info(
     /* typeclass_info */ Object[] base_tcinfo;
     int t1;
 
+    /* The zeroth argument is num_extra_instance_args. */
     base_tcinfo = (Object[]) tcinfo[0];
     t1 = ((Integer) base_tcinfo[0]).intValue() + index;
     return (/* typeclass_info */ Object[]) tcinfo[t1];
@@ -719,8 +720,7 @@ special__Compare____base_typeclass_info_1_0(
         TypeInfo::out),
     [will_not_call_mercury, promise_pure, thread_safe],
 "
-    TypeInfo = MR_typeclass_info_param_type_info(
-        (Object[]) TypeClassInfo, Index);
+    TypeInfo = MR_typeclass_info_param_type_info(TypeClassInfo, Index);
 ").
 
 :- pragma foreign_proc("Java",
@@ -728,8 +728,7 @@ special__Compare____base_typeclass_info_1_0(
         Index::in, TypeInfo::out),
     [will_not_call_mercury, promise_pure, thread_safe],
 "
-    TypeInfo = MR_typeclass_info_instance_tvar_type_info(
-        (Object[]) TypeClassInfo, Index);
+    TypeInfo = MR_typeclass_info_instance_tvar_type_info(TypeClassInfo, Index);
 ").
 
 :- pragma foreign_proc("Java",
@@ -737,8 +736,7 @@ special__Compare____base_typeclass_info_1_0(
         TypeClassInfo::out),
     [will_not_call_mercury, promise_pure, thread_safe],
 "
-    TypeClassInfo = MR_typeclass_info_superclass_info(
-        (Object[]) TypeClassInfo0, Index);
+    TypeClassInfo = MR_typeclass_info_superclass_info(TypeClassInfo0, Index);
 ").
 
 :- pragma foreign_proc("Java",
@@ -746,8 +744,7 @@ special__Compare____base_typeclass_info_1_0(
         Index::in, TypeClassInfo::out),
     [will_not_call_mercury, promise_pure, thread_safe],
 "
-    TypeClassInfo = MR_typeclass_info_arg_typeclass_info(
-        (Object[]) TypeClassInfo0, Index);
+    TypeClassInfo = MR_typeclass_info_arg_typeclass_info(TypeClassInfo0, Index);
 ").
 
 :- pragma foreign_proc("Erlang",
diff --git a/runtime/mercury_type_info.h b/runtime/mercury_type_info.h
index 762e926..c889058 100644
--- a/runtime/mercury_type_info.h
+++ b/runtime/mercury_type_info.h
@@ -496,7 +496,7 @@ typedef MR_PseudoTypeInfo       *MR_PseudoTypeInfoParams;
 ** change, as above.)
 **
 ** MR_typeclass_info_arg_typeclass_info returns a typeclass_info for one of the
-** constrains on the instance declaration.
+** constraints on the instance declaration.
 **
 ** MR_typeclass_info_extra_instance_arg returns either what
 ** MR_typeclass_info_instance_tvar_type_info or

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