for review: type specialisation [2]

Simon Taylor stayl at cs.mu.OZ.AU
Sun Aug 30 15:46:08 AEST 1998


Index: NEWS
===================================================================
RCS file: /home/staff/zs/imp/mercury/NEWS,v
retrieving revision 1.114
diff -u -t -u -r1.114 NEWS
--- NEWS	1998/08/10 07:16:44	1.114
+++ NEWS	1998/08/26 06:17:54
@@ -356,6 +356,13 @@
   over data structures. Deforestation is enabled at optimization level
   `-O3' or higher, or by using the `--deforestation' option.
 
+* The compiler can now perform type specialization.
+
+  Type specialization removes the overhead of polymorphic code, including
+  code which uses typeclasses. The disadvantage is increased code size.
+  Currently we do not perform inter-module type specialization.
+  Type specialization is enabled by using the `--type-specialization' option.
+
 * We've added support for "transitive" inter-module analysis.
 
   With the previous support for inter-module optimization, when
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.37
diff -u -t -u -r1.37 bytecode_gen.m
--- bytecode_gen.m	1998/06/09 02:12:02	1.37
+++ bytecode_gen.m	1998/08/12 04:16:54
@@ -628,7 +628,7 @@
                         TypeArity)
         ;
                 ConsId = base_typeclass_info_const(ModuleName, ClassId,
-                        Instance),
+                        _, Instance),
                 ByteConsId = base_typeclass_info_const(ModuleName, ClassId,
                         Instance)
         ).
Index: compiler/code_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/code_util.m,v
retrieving revision 1.100
diff -u -t -u -r1.100 code_util.m
--- code_util.m	1998/07/20 10:00:31	1.100
+++ code_util.m	1998/08/12 04:15:24
@@ -673,7 +673,7 @@
 code_util__cons_id_to_tag(pred_const(P,M), _, _, pred_closure_tag(P,M)).
 code_util__cons_id_to_tag(base_type_info_const(M,T,A), _, _,
                 base_type_info_constant(M,T,A)).
-code_util__cons_id_to_tag(base_typeclass_info_const(M,C,N), _, _,
+code_util__cons_id_to_tag(base_typeclass_info_const(M,C,_,N), _, _,
                 base_typeclass_info_constant(M,C,N)).
 code_util__cons_id_to_tag(cons(Name, Arity), Type, ModuleInfo, Tag) :-
         (
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dependency_graph.m,v
retrieving revision 1.35
diff -u -t -u -r1.35 dependency_graph.m
--- dependency_graph.m	1998/06/09 02:12:22	1.35
+++ dependency_graph.m	1998/08/12 04:17:16
@@ -323,8 +323,8 @@
         ).
 dependency_graph__add_arcs_in_cons(base_type_info_const(_, _, _), _Caller,
                                 DepGraph, DepGraph).
-dependency_graph__add_arcs_in_cons(base_typeclass_info_const(_, _, _), _Caller,
-                                DepGraph, DepGraph).
+dependency_graph__add_arcs_in_cons(base_typeclass_info_const(_, _, _, _),
+                                _Caller, DepGraph, DepGraph).
 
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
Index: compiler/dnf.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dnf.m,v
retrieving revision 1.32
diff -u -t -u -r1.32 dnf.m
--- dnf.m	1998/07/08 20:55:55	1.32
+++ dnf.m	1998/07/27 03:17:46
@@ -384,7 +384,7 @@
                 % This ClassContext is a conservative approximation.
                 % We could get rid of some constraints on variables
                 % that are not part of the goal.
-        hlds_pred__define_new_pred(Goal0, Goal, ArgVars, InstMap0, PredName,
+        hlds_pred__define_new_pred(Goal0, Goal, ArgVars, _, InstMap0, PredName,
                 TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap,
                 VarSet, Markers, ModuleInfo0, ModuleInfo, PredProcId),
         PredProcId = proc(PredId, _).
Index: compiler/goal_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/goal_util.m,v
retrieving revision 1.47
diff -u -t -u -r1.47 goal_util.m
--- goal_util.m	1998/07/08 20:56:04	1.47
+++ goal_util.m	1998/07/27 00:47:54
@@ -69,7 +69,7 @@
 
         %
         % goal_util__extra_nonlocal_typeinfos(TypeInfoMap, TypeClassInfoMap,
-        %               VarTypes, ExistQVars, Goal, NonLocalTypeInfos):
+        %               VarTypes, ExistQVars, NonLocals, NonLocalTypeInfos):
         % compute which type-info and type-class-info variables
         % may need to be non-local to a goal.
         %
@@ -89,7 +89,7 @@
         %
 :- pred goal_util__extra_nonlocal_typeinfos(map(tvar, type_info_locn),
                 map(class_constraint, var), map(var, type), existq_tvars,
-                hlds_goal, set(var)).
+                set(var), set(var)).
 :- mode goal_util__extra_nonlocal_typeinfos(in, in, in, in, in, out) is det.
 
         % See whether the goal is a branched structure.
@@ -539,9 +539,7 @@
 %-----------------------------------------------------------------------------%
 
 goal_util__extra_nonlocal_typeinfos(TypeVarMap, TypeClassVarMap, VarTypes,
-                ExistQVars, Goal0, NonLocalTypeInfos) :-
-        Goal0 = _ - GoalInfo0,
-        goal_info_get_nonlocals(GoalInfo0, NonLocals),
+                ExistQVars, NonLocals, NonLocalTypeInfos) :-
         set__to_sorted_list(NonLocals, NonLocalsList),
         map__apply_to_list(NonLocalsList, VarTypes, NonLocalsTypes),
         term__vars_list(NonLocalsTypes, NonLocalTypeVars),
Index: compiler/handle_options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/handle_options.m,v
retrieving revision 1.60
diff -u -t -u -r1.60 handle_options.m
--- handle_options.m	1998/07/27 01:04:38	1.60
+++ handle_options.m	1998/08/26 07:13:45
@@ -364,12 +364,6 @@
         option_implies(procid_stack_layout, basic_stack_layout, bool(yes)),
         option_implies(agc_stack_layout, basic_stack_layout, bool(yes)),
 
-        % XXX higher_order.m does not update the typeinfo_varmap
-        % for specialised versions.
-        % This causes the compiler to abort in unused_args.m when compiling
-        % tests/valid/agc_ho_pred.m with `-O3 --intermodule-optimization'.
-        option_implies(typeinfo_liveness, optimize_higher_order, bool(no)),
-
         % XXX deforestation does not perform folding on polymorphic
         % predicates correctly with --typeinfo-liveness.
         option_implies(typeinfo_liveness, deforestation, bool(no)),

Index: compiler/hlds_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_data.m,v
retrieving revision 1.25
diff -u -t -u -r1.25 hlds_data.m
--- hlds_data.m	1998/07/08 20:56:10	1.25
+++ hlds_data.m	1998/08/12 04:19:21
@@ -36,12 +36,14 @@
                                 % whereas a code_addr_const is just an address.
                         ;       base_type_info_const(module_name, string, int)
                                 % module name, type name, type arity
-                        ;       base_typeclass_info_const(module_name, class_id,
-                                        string)
+                        ;       base_typeclass_info_const(module_name,
+                                        class_id, int, string)
                                 % name of module containing instance
-                                % declaration, class name and arity, a string
-                                % encoding the type names and arities of
-                                % arguments to the instance declaration
+                                % declaration (not filled in by
+                                % polymorphism.m - why?), class name and arity,
+                                % class instance, a string encoding the type
+                                % names and arities of the arguments to the
+                                % instance declaration 
                         .
 
         % A cons_defn is the definition of a constructor (i.e. a constant
@@ -122,7 +124,7 @@
         error("cons_id_arity: can't get arity of code_addr_const").
 cons_id_arity(base_type_info_const(_, _, _), _) :-
         error("cons_id_arity: can't get arity of base_type_info_const").
-cons_id_arity(base_typeclass_info_const(_, _, _), _) :-
+cons_id_arity(base_typeclass_info_const(_, _, _, _), _) :-
         error("cons_id_arity: can't get arity of base_typeclass_info_const").
 
 make_functor_cons_id(term__atom(Name), Arity, cons(unqualified(Name), Arity)).
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.199
diff -u -t -u -r1.199 hlds_out.m
--- hlds_out.m	1998/08/05 08:45:54	1.199
+++ hlds_out.m	1998/08/25 01:14:57
@@ -217,7 +217,7 @@
 hlds_out__cons_id_to_string(pred_const(_, _), "<pred>").
 hlds_out__cons_id_to_string(code_addr_const(_, _), "<code_addr>").
 hlds_out__cons_id_to_string(base_type_info_const(_, _, _), "<base_type_info>").
-hlds_out__cons_id_to_string(base_typeclass_info_const(_, _, _), 
+hlds_out__cons_id_to_string(base_typeclass_info_const(_, _, _, _), 
         "<base_typeclass_info>").
 
 hlds_out__write_cons_id(cons(SymName, Arity)) -->
@@ -238,7 +238,7 @@
         io__write_string("<code_addr>").
 hlds_out__write_cons_id(base_type_info_const(_, _, _)) -->
         io__write_string("<base_type_info>").
-hlds_out__write_cons_id(base_typeclass_info_const(_, _, _)) -->
+hlds_out__write_cons_id(base_typeclass_info_const(_, _, _, _)) -->
         io__write_string("<base_typeclass_info>").
 
         % The code of this predicate duplicates the functionality of
@@ -530,7 +530,7 @@
                 ( { map__is_empty(Proofs) } ->
                         []
                 ;
-                        hlds_out__write_constraint_proofs(Indent, VarSet,
+                        hlds_out__write_constraint_proofs(Indent, TVarSet,
                                 Proofs),
                         io__write_string("\n")
                 )
@@ -1532,7 +1532,7 @@
                 io__write_string(")")
         ;
                 { ConsId = base_typeclass_info_const(Module,
-                        class_id(Name, Arity), Instance) },
+                        class_id(Name, Arity), _, Instance) },
                 io__write_string("base_typeclass_info("""),
                 prog_out__write_sym_name(Module),
                 io__write_string(""", """),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.51
diff -u -t -u -r1.51 hlds_pred.m
--- hlds_pred.m	1998/08/13 02:20:07	1.51
+++ hlds_pred.m	1998/08/25 04:29:23
@@ -15,8 +15,8 @@
 
 :- import_module hlds_data, hlds_goal, hlds_module, llds, prog_data, instmap.
 :- import_module purity, globals.
-:- import_module bool, list, set, map, std_util, term, varset.
 :- import_module term_util.
+:- import_module bool, list, set, map, std_util, term, varset.
 
 :- implementation.
 
@@ -265,18 +265,20 @@
 :- pred type_info_locn_set_var(type_info_locn::in, var::in, 
                 type_info_locn::out) is det.
 
-        % hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap, PredName,
-        %       TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap, 
+        % hlds_pred__define_new_pred(Goal, CallGoal, Args, ExtraArgs, InstMap,
+        %       PredName, TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap, 
         %       VarSet, Markers, ModuleInfo0, ModuleInfo, PredProcId)
         %
         % Create a new predicate for the given goal, returning a goal to 
-        % call the created predicate.
-:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(var),
+        % call the created predicate. ExtraArgs is the list of extra
+        % type_infos and typeclass_infos required by --typeinfo-liveness
+        % which were added to the front of the argument list.
+:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(var), list(var),
                 instmap, string, tvarset, map(var, type),
                 class_constraints, map(tvar, type_info_locn),
                 map(class_constraint, var), varset, pred_markers, 
                 module_info, module_info, pred_proc_id).
-:- mode hlds_pred__define_new_pred(in, out, in, in, in, in, in,
+:- mode hlds_pred__define_new_pred(in, out, in, out, in, in, in, in,
                 in, in, in, in, in, in, out, out) is det.
 
         % Various predicates for accessing the information stored in the
@@ -839,9 +841,9 @@
 
 %-----------------------------------------------------------------------------%
 
-hlds_pred__define_new_pred(Goal0, Goal, ArgVars0, InstMap0, PredName, TVarSet, 
-                VarTypes0, ClassContext, TVarMap, TCVarMap, VarSet0, 
-                Markers, ModuleInfo0, ModuleInfo, PredProcId) :-
+hlds_pred__define_new_pred(Goal0, Goal, ArgVars0, ExtraTypeInfos, InstMap0,
+                PredName, TVarSet, VarTypes0, ClassContext, TVarMap, TCVarMap,
+                VarSet0, Markers, ModuleInfo0, ModuleInfo, PredProcId) :-
         Goal0 = _GoalExpr - GoalInfo,
         goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
         instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap),
@@ -856,13 +858,15 @@
         globals__lookup_bool_option(Globals, typeinfo_liveness,
                 TypeInfoLiveness),
         ( TypeInfoLiveness = yes ->
+                goal_info_get_nonlocals(GoalInfo, NonLocals),
                 goal_util__extra_nonlocal_typeinfos(TVarMap, TCVarMap,
-                        VarTypes0, ExistQVars, Goal0, ExtraTypeInfos0),
-                set__delete_list(ExtraTypeInfos0, ArgVars0, ExtraTypeInfos),
-                set__to_sorted_list(ExtraTypeInfos, ExtraArgs),
-                list__append(ExtraArgs, ArgVars0, ArgVars)
+                        VarTypes0, ExistQVars, NonLocals, ExtraTypeInfos0),
+                set__delete_list(ExtraTypeInfos0, ArgVars0, ExtraTypeInfos1),
+                set__to_sorted_list(ExtraTypeInfos1, ExtraTypeInfos),
+                list__append(ExtraTypeInfos, ArgVars0, ArgVars)
         ;
-                ArgVars = ArgVars0
+                ArgVars = ArgVars0,
+                ExtraTypeInfos = []
         ),
 
         goal_info_get_context(GoalInfo, Context),
@@ -1151,6 +1155,10 @@
                         map(class_constraint, var),
                                         % typeclass_info vars for class
                                         % constraints
+                                        % Note that this field is not looked
+                                        % at after polymorphism is run, and
+                                        % is created by polymorphism, so it
+                                        % is probably redundant.
                         eval_method,    % how should the proc be evaluated      
                         maybe(arg_size_info),
                                         % Information about the relative sizes
Index: compiler/inlining.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/inlining.m,v
retrieving revision 1.78
diff -u -t -u -r1.78 inlining.m
--- inlining.m	1998/07/08 20:56:25	1.78
+++ inlining.m	1998/08/16 23:37:31
@@ -107,6 +107,15 @@
 :- mode inlining__do_inline_call(in, in, in, in, in, out, in, out,
         in, out, in, out, out) is det.
 
+        % inlining__get_type_substitution(CalleeArgTypes, CallerArgTypes,
+        %       HeadTypeParams, CalleeExistQTVars, TypeSubn).
+        %
+        % Work out a type substitution to map the callee's argument
+        % types into the caller's.
+:- pred inlining__get_type_substitution(list(type), list(type),
+                head_type_params, list(tvar), map(tvar, type)).
+:- mode inlining__get_type_substitution(in, in, in, in, out) is det.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%

@@ -523,7 +535,8 @@
         % we may need to bind type variables in the caller.
         % For example, if we call `:- pred some [T] foo(T)',
         % and the definition of `foo' binds `T' to `int',
-        % then we need 
+        % then we need to replace all occurrences of type `T'
+        % with type `int' in the caller.
 
         % first, rename apart the type variables in the callee.
         % (we can almost throw away the new typevarset, since we
@@ -539,7 +552,7 @@
         % next, compute the type substitution and then apply it
 
         % Note: there's no need to update the type_info locations maps,
-        % either for the caller or calle, since for any type vars in the
+        % either for the caller or callee, since for any type vars in the
         % callee which get bound to type vars in the caller, the type_info
         % location will be given by the entry in the caller's
         % type_info locations map (and vice versa).  It doesn't matter if the
@@ -550,49 +563,24 @@
         map__apply_to_list(HeadVars, CalleeVarTypes1, HeadTypes),
         map__apply_to_list(ArgVars, VarTypes0, ArgTypes),
 
-        % handle the common case of non-existentially specially,
-        % since we can do things more efficiently in that case
         pred_info_get_exist_quant_tvars(PredInfo, CalleeExistQVars),
+        inlining__get_type_substitution(HeadTypes, ArgTypes, HeadTypeParams,
+                CalleeExistQVars, TypeSubn),
+
+        % handle the common case of non-existentially typed preds specially,
+        % since we can do things more efficiently in that case
         ( CalleeExistQVars = [] ->
-            (
-                type_list_subsumes(HeadTypes, ArgTypes, TypeSubn)
-            ->
                 % update types in callee only
                 apply_rec_substitution_to_type_map(CalleeVarTypes1,
                         TypeSubn, CalleeVarTypes),
                 VarTypes1 = VarTypes0
-            ;
-                % The head types should always be unifiable with the
-                % actual argument types, otherwise it is a type error
-                % that should have been detected by typechecking.
-                % But polymorphism.m introduces type-incorrect code --
-                % e.g. compare(Res, EnumA, EnumB) gets converted
-                % into builtin_compare_int(Res, EnumA, EnumB), which
-                % is a type error since it assumes that an enumeration
-                % is an int.  In those cases, we don't need to
-                % worry about the type substitution.
-                % (Perhaps it would be better if polymorphism introduced
-                % calls to unsafe_type_cast/2 for such cases.)
-                CalleeVarTypes = CalleeVarTypes1,
-                VarTypes1 = VarTypes0
-            )
         ;
-            % for calls to existentially type preds, we may need to
-            % bind type variables in the caller, not just those in the callee
-            (
-                map__init(TypeSubn0),
-                type_unify_list(HeadTypes, ArgTypes, HeadTypeParams,
-                        TypeSubn0, TypeSubn)
-            ->
                 % update types in callee
                 apply_rec_substitution_to_type_map(CalleeVarTypes1,
                         TypeSubn, CalleeVarTypes),
                 % update types in caller
                 apply_rec_substitution_to_type_map(VarTypes0,
                         TypeSubn, VarTypes1)
-            ;
-                error("inlining.m: type unification failed")
-            )
         ),
 
         % Now rename apart the variables in the called goal.
@@ -604,9 +592,43 @@
         goal_util__must_rename_vars_in_goal(CalledGoal, Subn, Goal),
 
         apply_substitutions_to_var_map(CalleeTypeInfoVarMap0, 
-                TypeRenaming, Subn, CalleeTypeInfoVarMap1),
+                TypeRenaming, TypeSubn, Subn, CalleeTypeInfoVarMap1),
         map__merge(TypeInfoVarMap0, CalleeTypeInfoVarMap1,
                 TypeInfoVarMap).
+
+inlining__get_type_substitution(HeadTypes, ArgTypes,
+                HeadTypeParams, CalleeExistQVars, TypeSubn) :-
+        ( CalleeExistQVars = [] ->
+                ( type_list_subsumes(HeadTypes, ArgTypes, TypeSubn0) ->
+                        TypeSubn = TypeSubn0 
+                ;
+                        % The head types should always be unifiable with the
+                        % actual argument types, otherwise it is a type error
+                        % that should have been detected by typechecking.
+                        % But polymorphism.m introduces type-incorrect code --
+                        % e.g. compare(Res, EnumA, EnumB) gets converted
+                        % into builtin_compare_int(Res, EnumA, EnumB), which
+                        % is a type error since it assumes that an enumeration
+                        % is an int.  In those cases, we don't need to
+                        % worry about the type substitution.
+                        % (Perhaps it would be better if polymorphism introduced
+                        % calls to unsafe_type_cast/2 for such cases.)
+                        map__init(TypeSubn)
+                )
+        ;
+                    % for calls to existentially type preds, we may need to
+                    % bind type variables in the caller, not just those in
+                    % the callee
+                (
+                        map__init(TypeSubn0),
+                        type_unify_list(HeadTypes, ArgTypes, HeadTypeParams,
+                                TypeSubn0, TypeSubn1)
+                ->
+                        TypeSubn = TypeSubn1
+                ;
+                        error("inlining.m: type unification failed")
+                )
+        ).
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/lambda.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/lambda.m,v
retrieving revision 1.44
diff -u -t -u -r1.44 lambda.m
--- lambda.m	1998/07/08 20:56:33	1.44
+++ lambda.m	1998/08/12 03:30:32
@@ -91,7 +91,7 @@
 :- import_module make_hlds, globals, options.
 :- import_module goal_util, prog_util, mode_util, inst_match, llds, arg_info.
 
-:- import_module bool, string, std_util, require.
+:- import_module assoc_list, bool, string, std_util, require.
 
 :- type lambda_info --->
                 lambda_info(
@@ -273,8 +273,10 @@
         % XXX existentially typed lambda expressions are not yet supported
         % (see the documentation at top of this file)
         ExistQVars = [],
+        LambdaGoal = _ - LambdaGoalInfo,
+        goal_info_get_nonlocals(LambdaGoalInfo, LambdaNonLocals),
         goal_util__extra_nonlocal_typeinfos(TVarMap, TCVarMap, VarTypes,
-                ExistQVars, LambdaGoal, ExtraTypeInfos),
+                ExistQVars, LambdaNonLocals, ExtraTypeInfos),
         lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
                 OrigNonLocals0, ExtraTypeInfos, LambdaGoal, Unification0,
                 VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap,
@@ -411,7 +413,7 @@
                 map__from_corresponding_lists(OrigVars, OrigArgModes,
                         OrigArgModesMap),
                 map__overlay(ArgModesMap, OrigArgModesMap, ArgModesMap1),
-                map__values(ArgModesMap1, ArgModes1),
+                map__apply_to_list(ArgVars, ArgModesMap1, ArgModes1),
 
                 % Recompute the uni_modes. 
                 mode_util__modes_to_uni_modes(ArgModes1, ArgModes1, 
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.105
diff -u -t -u -r1.105 mercury_compile.m
--- mercury_compile.m	1998/07/27 01:04:43	1.105
+++ mercury_compile.m	1998/08/12 06:45:19
@@ -1560,12 +1560,15 @@
         is det.
 
 mercury_compile__maybe_higher_order(HLDS0, Verbose, Stats, HLDS) -->
-        globals__io_lookup_bool_option(optimize_higher_order, Optimize),
-        ( { Optimize = yes } ->
+        globals__io_lookup_bool_option(optimize_higher_order, HigherOrder),
+        globals__io_lookup_bool_option(type_specialization, Types),
+
+        ( { HigherOrder = yes ; Types = yes } ->
                 maybe_write_string(Verbose,
-                                "% Specializing higher-order predicates...\n"),
+                "% Specializing higher-order and polymorphic predicates...\n"),
                 maybe_flush_output(Verbose),
-                specialize_higher_order(HLDS0, HLDS),
+                
+                specialize_higher_order(HigherOrder, Types, HLDS0, HLDS),
                 maybe_write_string(Verbose, "% done.\n"),
                 maybe_report_stats(Stats)
         ;
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.143
diff -u -t -u -r1.143 mercury_to_mercury.m
--- mercury_to_mercury.m	1998/08/19 06:51:12	1.143
+++ mercury_to_mercury.m	1998/08/25 04:29:24
@@ -1034,7 +1034,8 @@
         { string__int_to_string(Arity, ArityString) },
         io__write_strings(["<base_type_info for ",
                 ModuleString, ":", Type, "/", ArityString, ">"]).
-mercury_output_cons_id(base_typeclass_info_const(Module, Class, InstanceString),
+mercury_output_cons_id(
+                base_typeclass_info_const(Module, Class, _, InstanceString),
                 _) -->
         { prog_out__sym_name_to_string(Module, ModuleString) },
         io__write_string("<base_typeclass_info for "),
@@ -1461,7 +1462,7 @@
 :- mode output_type(in, in, di, uo) is det.
 
 output_type(VarSet, Type) -->
-        mercury_output_term(Type, VarSet, no).
+        mercury_output_term(Type, VarSet, yes).
 
 %-----------------------------------------------------------------------------%

Index: compiler/options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/options.m,v
retrieving revision 1.239
diff -u -t -u -r1.239 options.m
--- options.m	1998/08/10 06:56:41	1.239
+++ options.m	1998/08/26 07:24:45
@@ -217,6 +217,8 @@
                 ;       optimize_unused_args
                 ;       intermod_unused_args
                 ;       optimize_higher_order
+                ;       type_specialization
+                ;       higher_order_size_limit
                 ;       optimize_constructor_last_call
                 ;       optimize_duplicate_calls
                 ;       constant_propagation
@@ -533,6 +535,8 @@
         optimize_unused_args    -       bool(no),
         intermod_unused_args    -       bool(no),
         optimize_higher_order   -       bool(no),
+        type_specialization     -       bool(no),
+        higher_order_size_limit -       int(20),
         optimize_constructor_last_call -        bool(no),
         optimize_dead_procs     -       bool(no),
         deforestation           -       bool(no),
@@ -835,6 +839,9 @@
 long_option("intermod-unused-args",     intermod_unused_args).
 long_option("optimize-higher-order",    optimize_higher_order).
 long_option("optimise-higher-order",    optimize_higher_order).
+long_option("type-specialization",      type_specialization).
+long_option("type-specialisation",      type_specialization).
+long_option("higher-order-size-limit",  higher_order_size_limit).
 long_option("optimise-constructor-last-call",   optimize_constructor_last_call).
 long_option("optimize-constructor-last-call",   optimize_constructor_last_call).
 long_option("optimize-dead-procs",      optimize_dead_procs).
@@ -1144,7 +1151,7 @@
         optimize_saved_vars     -       bool(yes),
         optimize_unused_args    -       bool(yes),      
         optimize_higher_order   -       bool(yes),
-        %deforestation          -       bool(yes), % causes an abort
+        deforestation           -       bool(yes),
         constant_propagation    -       bool(yes),
         optimize_repeat         -       int(4)
 ]).
@@ -1798,7 +1805,12 @@
                 "\t`--intermodule-optimization'.",
 
                 "--optimize-higher-order",
-                "\tEnable specialization higher-order predicates.",
+                "\tEnable specialization of higher-order predicates.",
+                "--type-specialization",
+                "\tEnable specialization of polymorphic predicates.",
+                "--higher-order-size-limit",
+                "\tSet the maximum goal size of specialized versions created by",
+                "\t--optimize-higher-order and --type-specialization.",
                 "--optimize-constructor-last-call",
                 "\tEnable the optimization of ""last"" calls that are followed by",
                 "\tconstructor application.",
Index: compiler/pd_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/pd_info.m,v
retrieving revision 1.1
diff -u -t -u -r1.1 pd_info.m
--- pd_info.m	1998/04/27 04:02:03	1.1
+++ pd_info.m	1998/07/30 03:58:01
@@ -739,7 +739,9 @@
         { proc_info_vartypes(ProcInfo, VarTypes) },
         { proc_info_typeinfo_varmap(ProcInfo, TVarMap) },
         { proc_info_typeclass_info_varmap(ProcInfo, TCVarMap) },
-        { hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap, 
+        % XXX handle the extra typeinfo arguments for
+        % --typeinfo-liveness properly.
+        { hlds_pred__define_new_pred(Goal, CallGoal, Args, _ExtraArgs, InstMap, 
                 Name, TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap,
                 VarSet, Markers, ModuleInfo0, ModuleInfo, PredProcId) },
         pd_info_set_module_info(ModuleInfo).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.147
diff -u -t -u -r1.147 polymorphism.m
--- polymorphism.m	1998/08/26 04:38:16	1.147
+++ polymorphism.m	1998/08/26 07:28:49
@@ -197,24 +197,24 @@
 %       :- instance  foo(list(T)) <= foo(T) where [...].
 %
 %       The typeclass_info for foo(int) is:
-%               The base_type_info:
+%               The base_typeclass_info:
 %                 * 0 (arity of the instance declaration) 
 %                 * pointer to method #1
 %                   ...
 %                 * pointer to method #n
 %
-%               The type_info:
+%               The typeclass_info:
 %                 * a pointer to the base typeclass info
 %                 * type info for int
 %
 %       The typeclass_info for foo(list(T)) is:
-%               The base_type_info:
+%               The base_typeclass_info:
 %                 * 1 (arity of the instance declaration)
 %                 * pointer to method #1
 %                   ...
 %                 * pointer to method #n
 %
-%               The type_info contains:
+%               The typeclass_info contains:
 %                 * a pointer to the base typeclass info
 %                 * typeclass info for foo(T)
 %                 * type info for list(T)
@@ -305,7 +305,7 @@
 :- module polymorphism.
 :- interface.
 
-:- import_module hlds_module, prog_data.
+:- import_module hlds_module, hlds_pred, prog_data, special_pred.
 :- import_module io.
 
 :- pred polymorphism__process_module(module_info, module_info,
@@ -318,17 +318,50 @@
         % is much simpler to avoid introducing type_info arguments for it.
         % Since both of these are really just assignment unifications, it
         % is desirable to generate them inline.
+        % There are also some predicates in private_builtin.m to
+        % manipulate typeclass_infos which don't need their type_infos.
 :- pred polymorphism__no_type_info_builtin(module_name, string, int).
 :- mode polymorphism__no_type_info_builtin(in, in, out) is semidet.
 
+        % From the type of a typeclass_info variable find the class_constraint
+        % about which the variable carries information, failing if the
+        % type is not a valid typeclass_info type.
+:- pred polymorphism__typeclass_info_class_constraint((type),
+                class_constraint).
+:- mode polymorphism__typeclass_info_class_constraint(in, out) is semidet.
+
+        % From the type of a type_info variable find the type about which
+        % the type_info carries information, failing if the type is not a
+        % valid type_info type.
+:- pred polymorphism__type_info_type((type), (type)).
+:- mode polymorphism__type_info_type(in, out) is semidet.
+
+        % Succeed if the predicate is one of the predicates defined in
+        % library/private_builtin.m to extract type_infos or typeclass_infos
+        % from typeclass_infos.
+:- pred polymorphism__is_typeclass_info_manipulator(module_info,
+                pred_id, typeclass_info_manipulator).
+:- mode polymorphism__is_typeclass_info_manipulator(in, in, out) is semidet.
+
+:- type typeclass_info_manipulator
+        --->    type_info_from_typeclass_info
+        ;       superclass_from_typeclass_info
+        .
+
+        % Look up the pred_id and proc_id for a type specific
+        % unification/comparison/index predicate.
+:- pred polymorphism__get_special_proc(type, special_pred_id,
+                module_info, sym_name, pred_id, proc_id).
+:- mode polymorphism__get_special_proc(in, in, in, out, out, out) is det.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
 :- implementation.
 
-:- import_module hlds_pred, hlds_goal, hlds_data, llds, (lambda).
-:- import_module type_util, mode_util, quantification, instmap.
-:- import_module code_util, unify_proc, special_pred, prog_util, make_hlds.
+:- import_module hlds_goal, hlds_data, llds, (lambda).
+:- import_module type_util, mode_util, quantification, instmap, prog_io.
+:- import_module code_util, unify_proc, prog_util, make_hlds.
 :- import_module (inst), hlds_out, base_typeclass_info, goal_util, passes_aux.
 
 :- import_module bool, int, string, list, set, map.
@@ -421,6 +454,12 @@
 polymorphism__no_type_info_builtin(MercuryBuiltin,
                 "unsafe_promise_unique", 2) :-
         mercury_public_builtin_module(MercuryBuiltin).
+polymorphism__no_type_info_builtin(MercuryBuiltin,
+                "superclass_from_typeclass_info", 3) :-
+        mercury_private_builtin_module(MercuryBuiltin).
+polymorphism__no_type_info_builtin(MercuryBuiltin,
+                "type_info_from_typeclass_info", 3) :-
+        mercury_private_builtin_module(MercuryBuiltin).
 
 %---------------------------------------------------------------------------%
 
@@ -830,8 +869,7 @@
 
         % We don't need to add type-infos for higher-order calls,
         % since the type-infos are added when the closures are
-        % constructed, not when they are called.  (Or at least I
-        % think we don't... -fjh.)
+        % constructed, not when they are called.
 polymorphism__process_goal_expr(higher_order_call(A, B, C, D, E, F),
                 GoalInfo, higher_order_call(A, B, C, D, E, F) - GoalInfo)
                 --> [].
@@ -865,9 +903,8 @@
                 { list__member(SpecialPredId, SpecialPredIds) }
         ->
                 { poly_info_get_module_info(Info0, ModuleInfo) },
-                { classify_type(Type, ModuleInfo, TypeCategory) },
-                { polymorphism__get_special_proc(TypeCategory, Type,
-                        SpecialPredId, ModuleInfo, Name, PredId1, ProcId1) }
+                { polymorphism__get_special_proc(Type, SpecialPredId,
+                        ModuleInfo, Name, PredId1, ProcId1) }
         ;
                 { PredId1 = PredId0 },
                 { ProcId1 = ProcId0 },
@@ -1042,9 +1079,9 @@
         polymorphism__process_goal(B0, B),
         polymorphism__process_goal(C0, C).
 
-polymorphism__process_goal_expr(pragma_c_code(IsRecursive, PredId0, ProcId0,
-                ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode),
-                GoalInfo, Goal) -->
+polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
+        { Goal0 = pragma_c_code(IsRecursive, PredId0, ProcId0,
+                ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode) },
         polymorphism__process_call(PredId0, ProcId0, ArgVars0, GoalInfo,
                 PredId, ProcId, ArgVars, ExtraVars, CallGoalInfo, ExtraGoals),
 
@@ -1056,71 +1093,94 @@
         =(Info0),
         { poly_info_get_module_info(Info0, ModuleInfo) },
         { module_info_pred_info(ModuleInfo, PredId, PredInfo) },
-        { pred_info_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
-                        PredArgTypes) },
+
+        { pred_info_module(PredInfo, PredModule) },
+        { pred_info_name(PredInfo, PredName) },
+        { pred_info_arity(PredInfo, PredArity) },
+
+
+        (
+                { polymorphism__no_type_info_builtin(PredModule,
+                        PredName, PredArity)  }
+        ->
+                { Goal = Goal0 - GoalInfo }
+        ;
+                { list__length(ExtraVars, NumExtraVars) },
+                { polymorphism__process_c_code(PredInfo, NumExtraVars,
+                        OrigArgTypes0, OrigArgTypes, ArgInfo0, ArgInfo) },
+
+                %
+                % plug it all back together
+                %
+                { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
+                        ArgInfo, OrigArgTypes, PragmaCode) - CallGoalInfo },
+                { list__append(ExtraGoals, [Call], GoalList) },
+                { conj_list_to_goal(GoalList, GoalInfo, Goal) }
+        ).
+
+
+:- pred polymorphism__process_c_code(pred_info, int, list(type), list(type),
+        list(maybe(pair(string, mode))), list(maybe(pair(string, mode)))).
+:- mode polymorphism__process_c_code(in, in, in, out, in, out) is det.
+
+polymorphism__process_c_code(PredInfo, NumExtraVars, OrigArgTypes0,
+                OrigArgTypes, ArgInfo0, ArgInfo) :-
+        pred_info_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
+                        PredArgTypes),
 
                 % Find out which variables are constrained (so that we don't
                 % add type-infos for them.
-        { pred_info_get_class_context(PredInfo, constraints(UnivCs, ExistCs)) },
-        { GetConstrainedVars = lambda([ClassConstraint::in, CVars::out] is det,
+        pred_info_get_class_context(PredInfo, constraints(UnivCs, ExistCs)),
+        GetConstrainedVars = lambda([ClassConstraint::in, CVars::out] is det,
                 (
                         ClassConstraint = constraint(_, CTypes),
                         term__vars_list(CTypes, CVars)
                 )
-        ) },
-        { list__map(GetConstrainedVars, UnivCs, UnivVars0) },
-        { list__condense(UnivVars0, UnivConstrainedVars) },
-        { list__map(GetConstrainedVars, ExistCs, ExistVars0) },
-        { list__condense(ExistVars0, ExistConstrainedVars) },
-
-        { term__vars_list(PredArgTypes, PredTypeVars0) },
-        { list__remove_dups(PredTypeVars0, PredTypeVars1) },
-        { list__delete_elems(PredTypeVars1, UnivConstrainedVars, 
-                PredTypeVars2) },
-        { list__delete_elems(PredTypeVars2, ExistConstrainedVars, 
-                PredTypeVars) },
+        ),
+        list__map(GetConstrainedVars, UnivCs, UnivVars0),
+        list__condense(UnivVars0, UnivConstrainedVars),
+        list__map(GetConstrainedVars, ExistCs, ExistVars0),
+        list__condense(ExistVars0, ExistConstrainedVars),
+
+        term__vars_list(PredArgTypes, PredTypeVars0),
+        list__remove_dups(PredTypeVars0, PredTypeVars1),
+        list__delete_elems(PredTypeVars1, UnivConstrainedVars, 
+                PredTypeVars2),
+        list__delete_elems(PredTypeVars2, ExistConstrainedVars, 
+                PredTypeVars),
 
                 % sanity check
-        { list__length(ExtraVars, NV) },
-        { list__length(UnivCs, NUCs) },
-        { list__length(ExistCs, NECs) },
-        { NCs is NUCs + NECs },
-        { list__length(PredTypeVars, NTs) },
-        { NEVs is NCs + NTs },
-        { require(unify(NEVs, NV), 
-                "list length mismatch in polymorphism processing pragma_c") },
+        list__length(UnivCs, NUCs),
+        list__length(ExistCs, NECs),
+        NCs is NUCs + NECs,
+        list__length(PredTypeVars, NTs),
+        NEVs is NCs + NTs,
+        require(unify(NEVs, NumExtraVars), 
+                "list length mismatch in polymorphism processing pragma_c"),
 
-        { polymorphism__c_code_add_typeinfos(
+        polymorphism__c_code_add_typeinfos(
                         PredTypeVars, PredTypeVarSet, ExistQVars, 
-                        ArgInfo0, ArgInfo1) },
-        { polymorphism__c_code_add_typeclass_infos(
-                        UnivCs, ExistCs, PredTypeVarSet, ArgInfo1, ArgInfo) },
+                        ArgInfo0, ArgInfo1),
+        polymorphism__c_code_add_typeclass_infos(
+                        UnivCs, ExistCs, PredTypeVarSet, ArgInfo1, ArgInfo),
 
         %
         % insert type_info/typeclass_info types for all the inserted 
         % type_info/typeclass_info vars into the arg-types list
         %
-        { mercury_private_builtin_module(PrivateBuiltin) },
-        { MakeType = lambda([TypeVar::in, TypeInfoType::out] is det,
+        mercury_private_builtin_module(PrivateBuiltin),
+        MakeType = lambda([TypeVar::in, TypeInfoType::out] is det,
                 construct_type(qualified(PrivateBuiltin, "type_info") - 1,
-                        [term__variable(TypeVar)], TypeInfoType)) },
-        { list__map(MakeType, PredTypeVars, TypeInfoTypes) },
-        { MakeTypeClass = lambda([_::in, TypeClassInfoType::out] is det,
+                        [term__variable(TypeVar)], TypeInfoType)),
+        list__map(MakeType, PredTypeVars, TypeInfoTypes),
+        MakeTypeClass = lambda([_::in, TypeClassInfoType::out] is det,
                 construct_type(qualified(PrivateBuiltin, "typeclass_info") - 0,
-                        [], TypeClassInfoType)) },
-        { list__map(MakeTypeClass, UnivCs, UnivTypes) },
-        { list__map(MakeTypeClass, ExistCs, ExistTypes) },
-        { list__append(TypeInfoTypes, OrigArgTypes0, OrigArgTypes1) },
-        { list__append(ExistTypes, OrigArgTypes1, OrigArgTypes2) },
-        { list__append(UnivTypes, OrigArgTypes2, OrigArgTypes) },
-
-        %
-        % plug it all back together
-        %
-        { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
-                        ArgInfo, OrigArgTypes, PragmaCode) - CallGoalInfo },
-        { list__append(ExtraGoals, [Call], GoalList) },
-        { conj_list_to_goal(GoalList, GoalInfo, Goal) }.
+                        [], TypeClassInfoType)),
+        list__map(MakeTypeClass, UnivCs, UnivTypes),
+        list__map(MakeTypeClass, ExistCs, ExistTypes),
+        list__append(TypeInfoTypes, OrigArgTypes0, OrigArgTypes1),
+        list__append(ExistTypes, OrigArgTypes1, OrigArgTypes2),
+        list__append(UnivTypes, OrigArgTypes2, OrigArgTypes).
 
 :- pred polymorphism__c_code_add_typeclass_infos(
                 list(class_constraint), list(class_constraint), 
@@ -1286,7 +1346,7 @@
                                 TypeSubst1) ->
                         TypeSubst = TypeSubst1
                 ;
-                error("polymorphism__process_call: type unification failed")
+                error("polymorphism__process_goal_expr: type unification failed")
                 ),
 
                 apply_subst_to_constraints(Subst, PredClassContext0,
@@ -1474,12 +1534,12 @@
         ;
                 poly_info_get_varset(Info0, VarSet0),
                 poly_info_get_var_types(Info0, VarTypes0),
-                goal_util__extra_nonlocal_typeinfos(TypeVarMap,
-                        TypeClassVarMap, VarTypes0, ExistQVars, Goal0,
-                        NewOutsideVars),
                 Goal0 = _ - GoalInfo0,
                 goal_info_get_nonlocals(GoalInfo0, NonLocals),
-                set__union(NewOutsideVars, NonLocals, OutsideVars),
+                goal_util__extra_nonlocal_typeinfos(TypeVarMap,
+                        TypeClassVarMap, VarTypes0, ExistQVars,
+                        NonLocals, NewOutsideVars),
+                set__union(NonLocals, NewOutsideVars, OutsideVars),
                 implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
                         OutsideVars, Goal, VarSet, VarTypes, _Warnings),
                 poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info)
@@ -1775,7 +1835,7 @@
                                 polymorphism__construct_typeclass_info(
                                         InstanceExtraTypeInfoVars, 
                                         InstanceExtraTypeClassInfoVars, 
-                                        ClassId, InstanceNum,
+                                        ClassId, NewC, InstanceNum,
                                         ExistQVars,
                                         Var, NewGoals, 
                                         Info2, Info),
@@ -1800,8 +1860,9 @@
                                 % First create a variable to hold the new
                                 % typeclass_info 
                         unqualify_name(ClassName, ClassNameString),
-                        polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
-                                ClassNameString, Var, VarSet1, VarTypes1),
+                        polymorphism__new_typeclass_info_var(VarSet0,
+                                VarTypes0, NewC, ClassNameString,
+                                Var, VarSet1, VarTypes1),
 
                         MaybeVar = yes(Var),
                         MaybePredProcId = no,
@@ -1846,11 +1907,8 @@
 
                                 % Work out which superclass typeclass_info to
                                 % take
-                        ToTerm = lambda([TheVar::in, TheTerm::out] is det,
-                                (
-                                        TheTerm = term__variable(TheVar)
-                                )),
-                        list__map(ToTerm, SubClassVars, SubClassVarTerms),
+                        term__var_list_to_term_list(SubClassVars,
+                                SubClassVarTerms),
                         (
                                 type_list_subsumes(SubClassVarTerms,
                                         SubClassTypes, SubTypeSubst0)
@@ -1884,18 +1942,22 @@
                                 % inserting a call to
                                 % superclass_from_typeclass_info in
                                 % private_builtin.
+                                % Note that superclass_from_typeclass_info
+                                % does not need extra type_info arguments
+                                % even though its declaration is polymorphic.
 
                                 % Make the goal for the call
-                        varset__init(Empty),
+                        varset__init(DummyTVarSet0),
+                        varset__new_var(DummyTVarSet0, TCVar, DummyTVarSet),
                         mercury_private_builtin_module(PrivateBuiltin),
                         ExtractSuperClass = qualified(PrivateBuiltin, 
                                           "superclass_from_typeclass_info"),
                         construct_type(qualified(PrivateBuiltin,
-                                        "typeclass_info") - 0,
-                                        [], TypeClassInfoType),
+                                "typeclass_info") - 1, [term__variable(TCVar)],
+                                TypeClassInfoType),
                         construct_type(unqualified("int") - 0, [], IntType),
                         get_pred_id_and_proc_id(ExtractSuperClass, predicate, 
-                                Empty, 
+                                DummyTVarSet, 
                                 [TypeClassInfoType, IntType, TypeClassInfoType],
                                 ModuleInfo, PredId, ProcId),
                         Call = call(PredId, ProcId, 
@@ -1921,12 +1983,13 @@
         ).
 
 :- pred polymorphism__construct_typeclass_info(list(var), list(var), class_id, 
-        int, existq_tvars, var, list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__construct_typeclass_info(in, in, in, in, in, out, out, 
-        in, out) is det.
+        class_constraint, int, existq_tvars, var, list(hlds_goal),
+        poly_info, poly_info).
+:- mode polymorphism__construct_typeclass_info(in, in, in, in, in, in,
+        out, out, in, out) is det.
 
 polymorphism__construct_typeclass_info(ArgTypeInfoVars, ArgTypeClassInfoVars,
-                ClassId, InstanceNum, ExistQVars,
+                ClassId, Constraint, InstanceNum, ExistQVars,
                 NewVar, NewGoals, Info0, Info) :-
 
         poly_info_get_module_info(Info0, ModuleInfo),
@@ -1956,15 +2019,15 @@
 
         unqualify_name(ClassName, ClassNameString),
         polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
-                ClassNameString, BaseVar, VarSet1, VarTypes1),
-
-        base_typeclass_info__make_instance_string(InstanceTypes,
-                InstanceString),
+                Constraint, ClassNameString, BaseVar, VarSet1, VarTypes1),
 
                 % XXX I don't think we actually need to carry the module name
                 % around.
         ModuleName = unqualified("some bogus module name"),
-        ConsId = base_typeclass_info_const(ModuleName, ClassId, InstanceString),
+        base_typeclass_info__make_instance_string(InstanceTypes,
+                InstanceString),
+        ConsId = base_typeclass_info_const(ModuleName, ClassId,
+                InstanceNum, InstanceString),
         BaseTypeClassInfoTerm = functor(ConsId, []),
 
                 % create the construction unification to initialize the variable
@@ -1993,7 +2056,7 @@
 
                 % introduce a new variable
         polymorphism__new_typeclass_info_var(VarSet1, VarTypes1,
-                ClassNameString, NewVar, VarSet, VarTypes),
+                Constraint, ClassNameString, NewVar, VarSet, VarTypes),
 
                 % create the construction unification to initialize the
                 % variable
@@ -2018,7 +2081,7 @@
                 % note that we could perhaps be more accurate than
                 % `ground(shared)', but it shouldn't make any
                 % difference.
-        InstConsId = cons( qualified(PrivateBuiltin, "typeclass_info"), 
+        InstConsId = cons(qualified(PrivateBuiltin, "typeclass_info"), 
                 NumArgVars),
         instmap_delta_from_assoc_list(
                 [NewVar - 
@@ -2373,12 +2436,9 @@
 
         CountUnifyGoal = CountUnify - CountGoalInfo.
 
-:- pred polymorphism__get_special_proc(builtin_type, type, special_pred_id,
-                                module_info, sym_name, pred_id, proc_id).
-:- mode polymorphism__get_special_proc(in, in, in, in, out, out, out) is det.
-
-polymorphism__get_special_proc(TypeCategory, Type, SpecialPredId, ModuleInfo,
+polymorphism__get_special_proc(Type, SpecialPredId, ModuleInfo,
                         PredName, PredId, ProcId) :-
+        classify_type(Type, ModuleInfo, TypeCategory),
         ( TypeCategory = user_type ->
                 module_info_get_special_pred_map(ModuleInfo, SpecialPredMap),
                 ( type_to_type_id(Type, TypeId, _TypeArgs) ->
@@ -2432,7 +2492,7 @@
         ->
                 PredId = PredId1
         ;
-                error("polymorphism__get_pred_id: pred_id lookup failed")
+                error("polymorphism__get_builtin_pred_id: pred_id lookup failed")
         ).
 
         % Create a unification for a type_info or base_type_info variable:
@@ -2588,7 +2648,7 @@
         varset__name_var(VarSet1, Var, Name, VarSet),
         mercury_private_builtin_module(PrivateBuiltin),
         construct_type(qualified(PrivateBuiltin, Symbol) - 1, [Type],
-                        UnifyPredType),
+                UnifyPredType),
         map__set(VarTypes0, Var, UnifyPredType, VarTypes).
 
 %---------------------------------------------------------------------------%
@@ -2615,59 +2675,57 @@
 :- mode extract_type_info_2(in, in, in, in, in, out, out, in, in, in, out, out,
         out) is det.
 
-extract_type_info_2(Type, _TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
+extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
                 TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
                 VarSet, VarTypes, TypeInfoLocns) :-
 
                 % We need a tvarset to pass to get_pred_id_and_proc_id
-        varset__init(TVarSet0),
-        varset__new_var(TVarSet0, TVar, TVarSet),
+        varset__init(DummyTVarSet0),
 
         mercury_private_builtin_module(PrivateBuiltin),
         ExtractTypeInfo = qualified(PrivateBuiltin,
                                 "type_info_from_typeclass_info"),
-        construct_type(qualified(PrivateBuiltin, "typeclass_info") - 0, [],
-                TypeClassInfoType),
+
+                % We pretend that the `constraint' field of the
+                % `typeclass_info' type is a type variable for the purposes of
+                % locating `private_builtin:type_info_from_typeclass_info'.
+        varset__new_var(DummyTVarSet0, DummyTypeClassTVar, DummyTVarSet1),
+        construct_type(qualified(PrivateBuiltin, "typeclass_info") - 1,
+                [term__variable(DummyTypeClassTVar)], TypeClassInfoType),
+
         construct_type(unqualified("int") - 0, [], IntType),
+
+        varset__new_var(DummyTVarSet1, DummyTVar, DummyTVarSet),
         construct_type(qualified(PrivateBuiltin, "type_info") - 1,
-                [term__variable(TVar)], TypeInfoType),
-        get_pred_id_and_proc_id(ExtractTypeInfo, predicate, TVarSet, 
+                [term__variable(DummyTVar)], TypeInfoType),
+        get_pred_id_and_proc_id(ExtractTypeInfo, predicate, DummyTVarSet, 
                 [TypeClassInfoType, IntType, TypeInfoType],
                 ModuleInfo, PredId, ProcId),
+        
         polymorphism__make_count_var(Index, VarSet0, VarTypes0, IndexVar,
                 IndexGoal, VarSet1, VarTypes1),
 
         polymorphism__new_type_info_var(Type, "type_info", VarSet1, VarTypes1,
-                TypeInfoVar, VarSet2, VarTypes2),
+                TypeInfoVar, VarSet, VarTypes),
 
-                % We have to put an extra type_info at the front of the call to
-                % type_info_from_typeclass_info, and pass it a bogus value
-                % because the pred has a type parameter... even though we are
-                % actually _extracting_ the type_info.  Existential typing of
-                % type_info_from_typeclass_info would fix this.
-        polymorphism__new_type_info_var(Type, "type_info", VarSet2, VarTypes2,
-                DummyTypeInfoVar, VarSet, VarTypes),
-
-                % Now we put a dummy value in the dummy type-info variable.
-        polymorphism__init_with_int_constant(DummyTypeInfoVar, 0,
-                DummyTypeInfoGoal),
-
-                % Make the goal info for the call
-        set__list_to_set([DummyTypeInfoVar, TypeClassInfoVar, IndexVar,
-                TypeInfoVar], NonLocals),
+                % Make the goal info for the call.
+                % `type_info_from_typeclass_info' does not require an extra
+                % type_info argument even though its declaration is
+                % polymorphic.
+        set__list_to_set([TypeClassInfoVar, IndexVar, TypeInfoVar], NonLocals),
         instmap_delta_from_assoc_list([TypeInfoVar - ground(shared, no)],
                 InstmapDelta),
         goal_info_init(NonLocals, InstmapDelta, det, GoalInfo),
 
         Call = call(PredId, ProcId, 
-                [DummyTypeInfoVar, TypeClassInfoVar, IndexVar, TypeInfoVar],
+                [TypeClassInfoVar, IndexVar, TypeInfoVar],
                 not_builtin, no, ExtractTypeInfo) - GoalInfo,
 
-        Goals = [IndexGoal, DummyTypeInfoGoal, Call],
+        Goals = [IndexGoal, Call],
 
                 % Update the location of the type_info so that we don't go to
                 % the bother of re-extracting it.
-        map__det_update(TypeInfoLocns0, TVar, type_info(TypeInfoVar),
+        map__det_update(TypeInfoLocns0, TypeVar, type_info(TypeInfoVar),
                 TypeInfoLocns).
 
 %-----------------------------------------------------------------------------%
@@ -2715,8 +2773,8 @@
 
                 % Make a new variable to contain the dictionary for this
                 % typeclass constraint
-        polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName,
-                Var, VarSet1, VarTypes1),
+        polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, C,
+                ClassName, Var, VarSet1, VarTypes1),
         ExtraHeadVars1 = [Var | ExtraHeadVars0],
 
                 % Find all the type variables in the constraint, and remember
@@ -2769,21 +2827,74 @@
 is_pair(_).
 
 :- pred polymorphism__new_typeclass_info_var(varset, map(var, type), 
-                string, var, 
+                class_constraint, string, var, 
                 varset, map(var, type)).
-:- mode polymorphism__new_typeclass_info_var(in, in, in, out, out, out) is det.
+:- mode polymorphism__new_typeclass_info_var(in, in,
+                in, in, out, out, out) is det.
 
-polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName, 
-                Var, VarSet, VarTypes) :-
+polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, Constraint,
+                ClassString, Var, VarSet, VarTypes) :-
         % introduce new variable
         varset__new_var(VarSet0, Var, VarSet1),
-        string__append("TypeClassInfo_for_", ClassName, Name),
+        string__append("TypeClassInfo_for_", ClassString, Name),
         varset__name_var(VarSet1, Var, Name, VarSet),
 
-        mercury_private_builtin_module(PrivateBuiltin),
-        construct_type(qualified(PrivateBuiltin, "typeclass_info") - 0,
-                                        [], DictionaryType),
+        polymorphism__build_typeclass_info_type(Constraint, DictionaryType),
         map__set(VarTypes0, Var, DictionaryType, VarTypes).
+
+:- pred polymorphism__build_typeclass_info_type(class_constraint, (type)).
+:- mode polymorphism__build_typeclass_info_type(in, out) is det.
+
+polymorphism__build_typeclass_info_type(Constraint, DictionaryType) :-
+        Constraint = constraint(SymName, ArgTypes),
+
+        % `constraint/n' is not really a type - it is a representation of a
+        % class constraint about which a typeclass_info holds information.
+        % `type_util:type_to_type_id' treats it as a type variable.
+        construct_qualified_term(SymName, [], ClassNameTerm),
+        construct_qualified_term(unqualified("constraint"),
+                [ClassNameTerm | ArgTypes], ConstraintTerm),
+
+        mercury_private_builtin_module(PrivateBuiltin),
+        construct_type(qualified(PrivateBuiltin, "typeclass_info") - 1,
+                [ConstraintTerm], DictionaryType).
+
+%---------------------------------------------------------------------------%
+
+polymorphism__typeclass_info_class_constraint(TypeClassInfoType, Constraint) :-
+        mercury_private_builtin_module(PrivateBuiltin),
+        type_to_type_id(TypeClassInfoType,
+                qualified(PrivateBuiltin, "typeclass_info") - 1,
+                [ConstraintTerm]),
+
+        % type_to_type_id fails on `constraint/n', so we use
+        % `sym_name_and_args' instead.
+        sym_name_and_args(ConstraintTerm, unqualified("constraint"),
+                [ClassNameTerm | ArgTypes]),
+        sym_name_and_args(ClassNameTerm, ClassName, []),
+        Constraint = constraint(ClassName, ArgTypes).
+
+polymorphism__type_info_type(TypeInfoType, Type) :-
+        mercury_private_builtin_module(PrivateBuiltin),
+        type_to_type_id(TypeInfoType,
+                qualified(PrivateBuiltin, "type_info") - 1,
+                [Type]).
+
+%---------------------------------------------------------------------------%
+
+polymorphism__is_typeclass_info_manipulator(ModuleInfo,
+                PredId, TypeClassManipulator) :-
+        module_info_pred_info(ModuleInfo, PredId, PredInfo),
+        mercury_private_builtin_module(PrivateBuiltin),
+        pred_info_module(PredInfo, PrivateBuiltin),
+        pred_info_name(PredInfo, PredName),
+        (
+                PredName = "type_info_from_typeclass_info",
+                TypeClassManipulator = type_info_from_typeclass_info
+        ;
+                PredName = "superclass_from_typeclass_info",
+                TypeClassManipulator = superclass_from_typeclass_info
+        ).
 
 %---------------------------------------------------------------------------%

Index: compiler/special_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/special_pred.m,v
retrieving revision 1.22
diff -u -t -u -r1.22 special_pred.m
--- special_pred.m	1998/05/25 21:48:55	1.22
+++ special_pred.m	1998/08/17 04:52:46
@@ -96,11 +96,16 @@
 
 special_pred_get_type("__Unify__", Types, T) :-
         list__reverse(Types, [T | _]).
+special_pred_get_type("unify", Types, T) :-
+        list__reverse(Types, [T | _]).
 special_pred_get_type("__Index__", Types, T) :-
         list__reverse(Types, [_, T | _]).
+special_pred_get_type("index", Types, T) :-
+        list__reverse(Types, [_, T | _]).
 special_pred_get_type("__Compare__", Types, T) :-
         list__reverse(Types, [T | _]).
-
+special_pred_get_type("compare", Types, T) :-
+        list__reverse(Types, [T | _]).
 
 special_pred_description(unify, "unification predicate").
 special_pred_description(compare, "comparison predicate").

Index: compiler/type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.57
diff -u -t -u -r1.57 type_util.m
--- type_util.m	1998/08/04 02:14:13	1.57
+++ type_util.m	1998/08/25 00:55:44
@@ -157,15 +157,16 @@
                                                  map(var, type)).
 :- mode apply_rec_substitution_to_type_map(in, in, out) is det.
 
-        % Update a map from tvar to type_info_locn, using the type substititon
-        % to rename tvars and a variable substition to rename vars.
+        % Update a map from tvar to type_info_locn, using the type renaming
+        % and substitution to rename tvars and a variable substition to
+        % rename vars.
         %
         % If tvar maps to a another type variable, we keep the new
         % variable, if it maps to a type, we remove it from the map.
 
 :- pred apply_substitutions_to_var_map(map(tvar, type_info_locn), tsubst,
-        map(var, var), map(tvar, type_info_locn)).
-:- mode apply_substitutions_to_var_map(in, in, in, out) is det.
+        map(tvar, type), map(var, var), map(tvar, type_info_locn)).
+:- mode apply_substitutions_to_var_map(in, in, in, in, out) is det.
 
 :- pred apply_rec_subst_to_constraints(substitution, class_constraints,
         class_constraints).
@@ -247,36 +248,24 @@
         % Given a type, determine what sort of type it is.
 
 classify_type(VarType, ModuleInfo, Type) :-
-        (
-                VarType = term__variable(_)
-        ->
-                Type = polymorphic_type
-        ;
-                VarType = term__functor(term__atom("character"), [], _)
-        ->
-                Type = char_type
-        ;
-                VarType = term__functor(term__atom("int"), [], _)
-        ->
-                Type = int_type
-        ;
-                VarType = term__functor(term__atom("float"), [], _)
-        ->
-                Type = float_type
-        ;
-                VarType = term__functor(term__atom("string"), [], _)
-        ->
-                Type = str_type
-        ;
-                type_is_higher_order(VarType, _, _)
-        ->
-                Type = pred_type
-        ;
-                type_is_enumeration(VarType, ModuleInfo)
-        ->
-                Type = enum_type
+        ( type_to_type_id(VarType, TypeId, _) ->
+                ( TypeId = unqualified("character") - 0 ->
+                        Type = char_type
+                ; TypeId = unqualified("int") - 0 ->
+                        Type = int_type
+                ; TypeId = unqualified("float") - 0 ->
+                        Type = float_type
+                ; TypeId = unqualified("string") - 0 ->
+                        Type = str_type
+                ; type_id_is_higher_order(TypeId, _) ->
+                        Type = pred_type
+                ; type_id_is_enumeration(TypeId, ModuleInfo) ->
+                        Type = enum_type
+                ;
+                        Type = user_type
+                )
         ;
-                Type = user_type
+                Type = polymorphic_type
         ).
 
 type_is_higher_order(Type, PredOrFunc, PredArgTypes) :-
@@ -304,11 +293,10 @@
                 PredOrFunc = function
         ).
 
-:- pred type_is_enumeration(type, module_info).
-:- mode type_is_enumeration(in, in) is semidet.
+:- pred type_id_is_enumeration(type_id, module_info).
+:- mode type_id_is_enumeration(in, in) is semidet.
 
-type_is_enumeration(Type, ModuleInfo) :-
-        type_to_type_id(Type, TypeId, _),
+type_id_is_enumeration(TypeId, ModuleInfo) :-
         module_info_types(ModuleInfo, TypeDefnTable),
         map__search(TypeDefnTable, TypeId, TypeDefn),
         hlds_data__get_type_defn_body(TypeDefn, TypeBody),
@@ -318,6 +306,14 @@
 type_to_type_id(Type, SymName - Arity, Args) :-
         sym_name_and_args(Type, SymName, Args1),
 
+        % `private_builtin:constraint' is introduced by polymorphism, and
+        % should only appear as the argument of a `typeclass:info/1' type.
+        % It behaves sort of like a type variable, so according to the
+        % specification of `type_to_type_id', it should cause failure.
+        % There isn't a definition in the type table.
+        mercury_private_builtin_module(PrivateBuiltin),
+        SymName \= qualified(PrivateBuiltin, "constraint"),
+
         % higher order types may have representations where
         % their arguments don't directly correspond to the
         % arguments of the term.
@@ -702,54 +698,77 @@
 
 %-----------------------------------------------------------------------------%
 
-apply_substitutions_to_var_map(VarMap0, TSubst, Subst, VarMap) :-
+apply_substitutions_to_var_map(VarMap0, TRenaming, TSubst, Subst, VarMap) :-
         % optimize the common case of empty substitutions
-        ( map__is_empty(Subst), map__is_empty(TSubst) ->
+        (
+                map__is_empty(Subst),
+                map__is_empty(TSubst),
+                map__is_empty(TRenaming)
+        ->
                 VarMap = VarMap0
         ;
                 map__keys(VarMap0, TVars),
                 map__init(NewVarMap),
-                apply_substitutions_to_var_map_2(TVars, VarMap0, TSubst,
-                        Subst, NewVarMap, VarMap)
+                apply_substitutions_to_var_map_2(TVars, VarMap0,
+                        TRenaming, TSubst, Subst, NewVarMap, VarMap)
         ).
 
 
 :- pred apply_substitutions_to_var_map_2(list(var)::in, map(tvar,
-                type_info_locn)::in, tsubst::in, map(var, var)::in, 
-                map(tvar, type_info_locn)::in, 
+                type_info_locn)::in, tsubst::in, map(tvar, type)::in,
+                map(var, var)::in, map(tvar, type_info_locn)::in, 
                 map(tvar, type_info_locn)::out) is det.
 
-apply_substitutions_to_var_map_2([], _VarMap0, _, _, NewVarMap, NewVarMap).
-apply_substitutions_to_var_map_2([TVar | TVars], VarMap0, TSubst, Subst, 
-                NewVarMap0, NewVarMap) :-
+apply_substitutions_to_var_map_2([], _VarMap0, _, _, _, NewVarMap, NewVarMap).
+apply_substitutions_to_var_map_2([TVar | TVars], VarMap0, TRenaming,
+                TSubst, VarSubst, NewVarMap0, NewVarMap) :-
         map__lookup(VarMap0, TVar, Locn),
         type_info_locn_var(Locn, Var),
+        
+                % find the new var, if there is one
+        ( map__search(VarSubst, Var, NewVar0) ->
+                NewVar = NewVar0
+        ;
+                NewVar = Var
+        ),
+        type_info_locn_set_var(Locn, NewVar, NewLocn),
 
                 % find the new tvar, if there is one, otherwise just
                 % create the old var as a type variable.
-        ( map__search(TSubst, TVar, NewTerm0) ->
-                NewTerm = NewTerm0 
+        (
+                map__search(TRenaming, TVar, NewTVar0)
+        ->
+                ( NewTVar0 = term__variable(NewTVar1) ->
+                        NewTVar2 = NewTVar1
+                ;
+                        % varset__merge_subst only returns var->var mappings,
+                        % never var->term.
+                        error(
+                        "apply_substitution_to_var_map_2: weird type renaming")
+                )
         ; 
-                type_util__var(NewTerm, TVar)
+                % The variable wasn't renamed.
+                NewTVar2 = TVar
         ),
 
-                % find the new var, if there is one
-        ( map__search(Subst, Var, NewVar0) ->
-                NewVar = NewVar0
+        ( map__search(TSubst, NewTVar2, NewType0) ->
+                NewType = NewType0
         ;
-                NewVar = Var
+                % The variable wasn't substituted.
+                type_util__var(NewType, NewTVar2)
         ),
-        type_info_locn_set_var(Locn, NewVar, NewLocn),
 
                 % if the tvar is still a variable, insert it into the
                 % map with the new var.
-        ( type_util__var(NewTerm, NewTVar) ->
-                map__det_insert(NewVarMap0, NewTVar, NewLocn, NewVarMap1)
+        ( type_util__var(NewType, NewTVar) ->
+                % Don't abort if two old type variables
+                % map to the same new type variable.
+                map__set(NewVarMap0, NewTVar, NewLocn, NewVarMap1)
         ;
                 NewVarMap1 = NewVarMap0
         ),
-        apply_substitutions_to_var_map_2(TVars, VarMap0, TSubst, Subst, 
-                NewVarMap1, NewVarMap).
+        apply_substitutions_to_var_map_2(TVars, VarMap0, TRenaming,
+                TSubst, VarSubst, NewVarMap1, NewVarMap).
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/unused_args.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/unused_args.m,v
retrieving revision 1.52
diff -u -t -u -r1.52 unused_args.m
--- unused_args.m	1998/07/08 20:57:41	1.52
+++ unused_args.m	1998/08/15 00:20:54
@@ -55,7 +55,7 @@
 :- import_module hlds_pred, hlds_goal, hlds_data, hlds_out, type_util, instmap.
 :- import_module code_util, globals, make_hlds, mercury_to_mercury, mode_util.
 :- import_module options, prog_data, prog_out, quantification, special_pred.
-:- import_module passes_aux, inst_match, modules.
+:- import_module passes_aux, inst_match, modules, polymorphism.
 
 :- import_module assoc_list, bool, char, int, list, map, require.
 :- import_module set, std_util, string, term, varset. 
@@ -258,7 +258,14 @@
                 module_info_globals(ModuleInfo, Globals),
                 globals__lookup_bool_option(Globals, typeinfo_liveness, 
                         TypeinfoLiveness),
-                ( TypeinfoLiveness = yes ->
+                ( 
+                        TypeinfoLiveness = yes,
+                        pred_info_module(PredInfo, PredModule),
+                        pred_info_name(PredInfo, PredName),
+                        pred_info_arity(PredInfo, PredArity),
+                        \+ polymorphism__no_type_info_builtin(PredModule,
+                                PredName, PredArity)
+                ->
                         proc_info_typeinfo_varmap(ProcInfo, TVarMap),
                         setup_typeinfo_deps(Vars, VarTypes, 
                                 proc(PredId, ProcId), TVarMap, VarDep2,
@@ -933,24 +940,24 @@
                 (
                                 % fix up special pred names
                         special_pred_get_type(Name0, ArgTypes0, Type),
-                        type_to_type_id(Type, TypeId0, _)
+                        type_to_type_id(Type, TypeId, _)
                 ->
-                        TypeId = TypeId0
+                        type_util__type_id_module(ModuleInfo,
+                                TypeId, TypeModule),
+                        type_util__type_id_name(ModuleInfo, TypeId, TypeName),
+                        type_util__type_id_arity(ModuleInfo,
+                                TypeId, TypeArity),
+                        string__int_to_string(TypeArity, TypeAr),
+                        prog_out__sym_name_to_string(TypeModule,
+                                TypeModuleString0),
+                        string__replace_all(TypeModuleString0, ":", "__",
+                                TypeModuleString),
+                        string__append_list([Name0, "_", TypeModuleString,
+                                "__", TypeName, "_", TypeAr], Name1)
                 ;
-                        string__append_list(["unused_args:make_new_pred_info\n",
-                                        "cannot make label for special pred `",
-                                        Name0, "'."], Message),
-                        error(Message)
-                ),
-                type_util__type_id_module(ModuleInfo, TypeId, TypeModule),
-                type_util__type_id_name(ModuleInfo, TypeId, TypeName),
-                type_util__type_id_arity(ModuleInfo, TypeId, TypeArity),
-                string__int_to_string(TypeArity, TypeAr),
-                prog_out__sym_name_to_string(TypeModule, TypeModuleString0),
-                string__replace_all(TypeModuleString0, ":", "__",
-                        TypeModuleString),
-                string__append_list( [Name0, "_", TypeModuleString, "__",
-                        TypeName, "_", TypeAr], Name1)
+                        % The special predicate has already been specialised.
+                        Name1 = Name0
+                )
         ;
                 Name1 = Name0
         ),
@@ -971,7 +978,6 @@
                 Markers, GoalType, PredOrFunc, ClassContext, EmptyProofs,
                 PredInfo1),
         pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo).
-
 
         % Replace the goal in the procedure with one to call the given
         % pred_id and proc_id.

Index: user_guide.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/user_guide.texi,v
retrieving revision 1.133
diff -u -t -u -r1.133 user_guide.texi
--- user_guide.texi	1998/08/10 07:17:09	1.133
+++ user_guide.texi	1998/08/30 05:33:23
@@ -2455,13 +2455,23 @@
 @sp 1
 @item --intermod-unused-args
 Perform unused argument removal across module boundaries.
-This option implies `--optimize-unused-args' and
-`--intermodule-optimization'.
+This option implies @samp{--optimize-unused-args} and
+ at samp{--intermodule-optimization}.
 
 @sp 1
 @item --optimize-higher-order
 Specialize calls to higher-order predicates where
 the higher-order arguments are known.
+
+ at sp 1
+ at item --type-specialization
+Specialize calls to polymorphic predicates where
+the polymorphic types are known.
+
+ at sp 1
+ at item --higher-order-size-limit
+Set the maximum goal size of specialized versions created by
+ at samp{--optimize-higher-order} and @samp{--type-specialization}.
 
 @sp 1
 @item --optimize-constant-propagation

Index: library/private_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/private_builtin.m,v
retrieving revision 1.7
diff -u -t -u -r1.7 private_builtin.m
--- private_builtin.m	1998/08/24 08:24:23	1.7
+++ private_builtin.m	1998/08/25 04:29:42
@@ -89,12 +89,17 @@
 :- type type_info(T) ---> type_info(base_type_info(T) /*, ... */).
 :- type base_type_info(T) ---> base_type_info(int /*, ... */).
 
+        % The type variable in these types isn't really a type variable,
+        % it's a place for polymorphism.m to put a representation of the
+        % class constraint about which the typeclass_info carries information.
+        %
         % Note that, since these types look to the compiler as though they
         % are candidates to become no_tag types, special code is required in
         % type_util:type_is_no_tag_type/3.
 
-:- type typeclass_info ---> typeclass_info(base_typeclass_info /*, ... */). 
-:- type base_typeclass_info ---> typeclass_info(int /*, ... */). 
+:- type typeclass_info(T) ---> typeclass_info(base_typeclass_info(T)
+                                                /*, ... */). 
+:- type base_typeclass_info(_) ---> typeclass_info(int /*, ... */). 
 
         % type_info_from_typeclass_info(TypeClassInfo, Index, TypeInfo)  
         % extracts TypeInfo from TypeClassInfo, where TypeInfo is the Indexth
@@ -102,13 +107,14 @@
         % 
         % Note: Index must be equal to the number of the desired type_info 
         % plus the number of superclasses for this class.
-:- pred type_info_from_typeclass_info(typeclass_info, int, type_info(T)).
+:- pred type_info_from_typeclass_info(typeclass_info(_), int, type_info(T)).
 :- mode type_info_from_typeclass_info(in, in, out) is det.
 
         % superclass_from_typeclass_info(TypeClassInfo, Index, SuperClass)  
         % extracts SuperClass from TypeClassInfo where TypeInfo is the Indexth
         % superclass of the class.
-:- pred superclass_from_typeclass_info(typeclass_info, int, typeclass_info).
+:- pred superclass_from_typeclass_info(typeclass_info(_),
+                int, typeclass_info(_)).
 :- mode superclass_from_typeclass_info(in, in, out) is det.
 
         % the builtin < operator on ints, used in the code generated
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/Mmakefile,v
retrieving revision 1.39
diff -u -t -u -r1.39 Mmakefile
--- Mmakefile	1998/08/26 07:51:56	1.39
+++ Mmakefile	1998/08/29 05:17:41
@@ -31,6 +31,7 @@
         erroneous_liveness \
         expand \
         export_test \
+        extra_typeinfo \
         float_map \
         float_reg \
         float_rounding_bug \
@@ -97,6 +98,9 @@
 # some tests need to be compiled with particular options
 
 MCFLAGS-boyer           =       --infer-all
+MCFLAGS-cut_test        =       -O5
+MCFLAGS-extra_typeinfo  =       --optimize-higher-order \
+                                --no-type-specialization --typeinfo-liveness
 MCFLAGS-func_test       =       --infer-all
 MCFLAGS-ho_order        =       --optimize-higher-order
 MCFLAGS-ho_order2       =       --optimize-higher-order


%-----------------------------------------------------------------------------%
% This tests the inclusion and ordering of extra typeinfos by
% higher_order.m with --typeinfo-liveness.
% Unfortunately you really need to look at the HLDS dump to check this one.
% Compile this with options:
%	--typeinfo-liveness --optimize-higher-order --no-type-specialization
% The --no-type-specialization is required to ensure that call_foldl
% remains polymorphic.
%-----------------------------------------------------------------------------%
:- module extra_typeinfo.
:- interface.

:- import_module io.

:- pred main(io__state::di, io__state::uo) is det.


:- implementation.

:- import_module list.

main -->
	( { call_foldl([[1,2,3], [4,5,6]], [[7,8,9], [10, 11, 12]], L) } ->
		io__write(L),
		io__nl
	;
		io__write_string("failed\n")
	).

:- pred call_foldl(list(list(T))::in, 
	list(list(U))::in, list(list(U))::out) is semidet.

	% This calls foldl so that the original type variables in foldl
	% get mapped to non-variable types, so higher_order.m needs to add
	% extra argument type_infos for the type variables in the types
	% of the specialised arguments.
call_foldl(In, Out0, Out) :-
	Pred = lambda([Int::in] is semidet, Int = 2),
	list_foldl(Pred, [2], In, _, Out0, Out).

:- pred list_foldl(pred(V)::(pred(in) is semidet), list(V)::in,
		T::in, T::out, U::in, U::out) is semidet.		

list_foldl(_P, [], T, T, U, U).
list_foldl(P, [V | Vs], T0, T, U0, U) :-
	call(P, V),
	list_foldl(P, Vs, T0, T, U0, U).

%-----------------------------------------------------------------------------%



More information about the developers mailing list