diff: typeclasses (final) [6/6]
David Glen JEFFERY
dgj at cs.mu.oz.au
Fri Dec 19 14:02:41 AEDT 1997
+ Changed1 = no
+ ),
+ apply_instance_rules(Cs, InstanceTable, Bindings, NewTVarSet1,
+ NewTVarSet, Proofs2, Proofs, TheRest, Changed2),
+ bool__or(Changed1, Changed2, Changed),
+ list__append(NewConstraints, TheRest, Constraints).
+
+ % We take the first matching instance rule that we can find; any
+ % overlapping instance declarations will have been caught earlier.
+
+ % This pred also catches tautological constraints since the
+ % NewConstraints will be [].
+
+ % XXX Surely we shouldn't need to re-name the variables and return
+ % XXX a new varset: this substitution should have been worked out
+ % XXX before, as these varsets would already have been merged.
+:- pred find_matching_instance_rule(list(hlds_instance_defn), sym_name,
+ list(type), tvarset, tvarset, map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof), list(class_constraint)).
+:- mode find_matching_instance_rule(in, in, in, in, out, in, out, out)
+ is semidet.
+
+find_matching_instance_rule(Instances, ClassName, Types, TVarSet,
+ NewTVarSet, Proofs0, Proofs, NewConstraints) :-
+
+ % Start a counter so we remember which instance decl we have
+ % used.
+ find_matching_instance_rule_2(Instances, 1, ClassName, Types,
+ TVarSet, NewTVarSet, Proofs0, Proofs, NewConstraints).
+
+:- pred find_matching_instance_rule_2(list(hlds_instance_defn), int,
+ sym_name, list(type), tvarset, tvarset,
+ map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof), list(class_constraint)).
+:- mode find_matching_instance_rule_2(in, in, in, in, in, out, in, out, out)
+ is semidet.
+
+find_matching_instance_rule_2([I|Is], N0, ClassName, Types, TVarSet,
+ NewTVarSet, Proofs0, Proofs, NewConstraints) :-
+ I = hlds_instance_defn(ModuleName, NewConstraints0, InstanceTypes0,
+ Interface, PredProcIds, InstanceNames, SuperClassProofs),
+ (
+ varset__merge_subst(TVarSet, InstanceNames, NewTVarSet0,
+ RenameSubst),
+ term__apply_rec_substitution_to_list(InstanceTypes0,
+ RenameSubst, InstanceTypes),
+ type_list_subsumes(InstanceTypes, Types, Subst)
+ ->
+ apply_rec_subst_to_constraints(RenameSubst, NewConstraints0,
+ NewConstraints1),
+ apply_rec_subst_to_constraints(Subst, NewConstraints1,
+ NewConstraints),
+ NewTVarSet = NewTVarSet0,
+ NewProof = apply_instance(hlds_instance_defn(ModuleName,
+ NewConstraints, InstanceTypes, Interface, PredProcIds,
+ InstanceNames, SuperClassProofs), N0),
+ Constraint = constraint(ClassName, Types),
+ map__set(Proofs0, Constraint, NewProof, Proofs)
+ ;
+ N is N0 + 1,
+ find_matching_instance_rule_2(Is, N, ClassName,
+ Types, TVarSet, NewTVarSet, Proofs0,
+ Proofs, NewConstraints)
+ ).
+
+ % To reduce the context using class declarations, we scan the
+ % context one constraint at a time. For each class in the constraint,
+ % we check to see if any of its superclasses is also a constraint, and
+ % if so, delete the superclass from the constraint list as it is
+ % redundant.
+:- pred apply_class_rules(list(class_constraint), class_table,
+ tsubst, tvarset, map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof), list(class_constraint), bool).
+:- mode apply_class_rules(in, in, in, in, in, out, out, out) is det.
+
+apply_class_rules(Constraints0, ClassTable, Bindings, TVarSet,
+ Proofs0, Proofs, Constraints, Changed) :-
+ apply_rec_subst_to_constraints(Bindings, Constraints0, Constraints1),
+ apply_class_rules_2(Constraints1, Constraints1, ClassTable,
+ TVarSet, Proofs0, Proofs, Constraints, Changed).
+
+:- pred apply_class_rules_2(list(class_constraint), list(class_constraint),
+ class_table, tvarset, map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof), list(class_constraint), bool).
+:- mode apply_class_rules_2(in, in, in, in, in, out, out, out) is det.
+
+ % The first argument is the list of constraints left to be checked.
+ % The second argument is the list of constraints that have not been
+ % rejected. If a redundant constraint is found, it is deleted from
+ % both (if it is still in the first list).
+apply_class_rules_2([], Constraints, _, _, Proofs, Proofs, Constraints, no).
+apply_class_rules_2([C|Cs], AllConstraints, ClassTable, TVarSet,
+ Proofs0, Proofs, Constraints, Changed) :-
+ C = constraint(ClassName, Types),
+ list__length(Types, Arity),
+ ClassId = class_id(ClassName, Arity),
+ map__lookup(ClassTable, ClassId, ClassDefn),
+ ClassDefn = hlds_class_defn(ParentClassConstraints0, ClassVars,
+ _ClassInterface, ClassVarset, _TermContext),
+ term__var_list_to_term_list(ClassVars, ClassTypes),
+ varset__merge_subst(TVarSet, ClassVarset, NewTVarSet, RenameSubst),
+ term__apply_rec_substitution_to_list(ClassTypes, RenameSubst,
+ NewClassTypes),
+ apply_rec_subst_to_constraints(RenameSubst, ParentClassConstraints0,
+ ParentClassConstraints),
+ IsRedundant = lambda(
+ [ThisConstraint::in, RenamedConstraint::out] is semidet,
+ (
+ type_list_subsumes(NewClassTypes, Types, Subst),
+ apply_rec_subst_to_constraint(Subst, ThisConstraint,
+ RenamedConstraint),
+ list__member(RenamedConstraint, AllConstraints)
+ )),
+ list__filter_map(IsRedundant, ParentClassConstraints,
+ RedundantConstraints),
+
+ % Delete the redundant constraints
+ list__delete_elems(AllConstraints, RedundantConstraints,
+ NewConstraints),
+ list__delete_elems(Cs, RedundantConstraints, NewCs),
+
+ % Remember why the constraints were redundant
+ RecordRedundancy = lambda([ConstraintName::in, TheProofs0::in,
+ TheProofs::out] is det,
+ (
+ map__set(TheProofs0, ConstraintName, superclass(C),
+ TheProofs)
+ )),
+ list__foldl(RecordRedundancy, RedundantConstraints, Proofs0, Proofs1),
+ (
+ RedundantConstraints = [],
+ Changed1 = no
+ ;
+ RedundantConstraints = [_|_],
+ Changed1 = yes
+ ),
+
+ apply_class_rules_2(NewCs, NewConstraints, ClassTable,
+ NewTVarSet, Proofs1, Proofs, Constraints, Changed2),
+ bool__or(Changed1, Changed2, Changed).
+
+%-----------------------------------------------------------------------------%
+
+:- pred record_class_constraint_proofs(pred_info, typecheck_info,
+ pred_info).
+:- mode record_class_constraint_proofs(in, typecheck_info_ui, out) is det.
+
+record_class_constraint_proofs(PredInfo0, TypeCheckInfo, PredInfo) :-
+ typecheck_info_get_type_assign_set(TypeCheckInfo, TypeAssignSet),
+ (
+ TypeAssignSet = [TypeAssign]
+ ->
+ type_assign_get_constraint_proofs(TypeAssign, Proofs),
+ pred_info_set_constraint_proofs(PredInfo0, Proofs,
+ PredInfo)
+ ;
+ % If there's not exactly one type_assign, don't
+ % bother recording the proofs since an error has
+ % occured, and will have been noted elsewhere
+ PredInfo = PredInfo0
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred convert_cons_defn_list(typecheck_info, list(hlds_cons_defn),
list(cons_type_info)).
:- mode convert_cons_defn_list(typecheck_info_ui, in, out) is det.
@@ -2805,7 +3341,7 @@
hlds_data__get_type_defn_tvarset(TypeDefn, ConsTypeVarSet),
hlds_data__get_type_defn_tparams(TypeDefn, ConsTypeParams),
construct_type(TypeId, ConsTypeParams, Context, ConsType),
- ConsTypeInfo = cons_type_info(ConsTypeVarSet, ConsType, ArgTypes).
+ ConsTypeInfo = cons_type_info(ConsTypeVarSet, ConsType, ArgTypes, []).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -2814,11 +3350,16 @@
:- type type_assign_set == list(type_assign).
-:- type type_assign ---> type_assign(
- map(var, type), % var types
- tvarset, % type names
- tsubst % type bindings
- ).
+:- type type_assign
+ ---> type_assign(
+ map(var, type), % var types
+ tvarset, % type names
+ tsubst, % type bindings
+ list(class_constraint), % typeclass constraints
+ map(class_constraint, % for each constraint
+ constraint_proof) % constraint found to be
+ % redundant, why is it so?
+ ).
%-----------------------------------------------------------------------------%
@@ -2828,45 +3369,79 @@
:- pred type_assign_get_var_types(type_assign, map(var, type)).
:- mode type_assign_get_var_types(in, out) is det.
-type_assign_get_var_types(type_assign(VarTypes, _, _), VarTypes).
+type_assign_get_var_types(type_assign(VarTypes, _, _, _, _), VarTypes).
%-----------------------------------------------------------------------------%
:- pred type_assign_get_typevarset(type_assign, tvarset).
:- mode type_assign_get_typevarset(in, out) is det.
-type_assign_get_typevarset(type_assign(_, TypeVarSet, _), TypeVarSet).
+type_assign_get_typevarset(type_assign(_, TypeVarSet, _, _, _), TypeVarSet).
%-----------------------------------------------------------------------------%
:- pred type_assign_get_type_bindings(type_assign, tsubst).
:- mode type_assign_get_type_bindings(in, out) is det.
-type_assign_get_type_bindings(type_assign(_, _, TypeBindings), TypeBindings).
+type_assign_get_type_bindings(type_assign(_, _, TypeBindings, _, _),
+ TypeBindings).
+%-----------------------------------------------------------------------------%
+
+:- pred type_assign_get_typeclass_constraints(type_assign,
+ list(class_constraint)).
+:- mode type_assign_get_typeclass_constraints(in, out) is det.
+
+type_assign_get_typeclass_constraints(type_assign(_, _, _, Constraints, _),
+ Constraints).
%-----------------------------------------------------------------------------%
+:- pred type_assign_get_constraint_proofs(type_assign,
+ map(class_constraint, constraint_proof)).
+:- mode type_assign_get_constraint_proofs(in, out) is det.
+
+type_assign_get_constraint_proofs(type_assign(_, _, _, _, Proofs), Proofs).
+%-----------------------------------------------------------------------------%
+
:- pred type_assign_set_var_types(type_assign, map(var, type), type_assign).
:- mode type_assign_set_var_types(in, in, out) is det.
-type_assign_set_var_types(type_assign(_, B, C), VarTypes,
- type_assign(VarTypes, B, C)).
+type_assign_set_var_types(type_assign(_, B, C, D, E), VarTypes,
+ type_assign(VarTypes, B, C, D, E)).
%-----------------------------------------------------------------------------%
:- pred type_assign_set_typevarset(type_assign, tvarset, type_assign).
:- mode type_assign_set_typevarset(in, in, out) is det.
-type_assign_set_typevarset(type_assign(A, _, C), TypeVarSet,
- type_assign(A, TypeVarSet, C)).
+type_assign_set_typevarset(type_assign(A, _, C, D, E), TypeVarSet,
+ type_assign(A, TypeVarSet, C, D, E)).
%-----------------------------------------------------------------------------%
:- pred type_assign_set_type_bindings(type_assign, tsubst, type_assign).
:- mode type_assign_set_type_bindings(in, in, out) is det.
-type_assign_set_type_bindings(type_assign(A, B, _), TypeBindings,
- type_assign(A, B, TypeBindings)).
+type_assign_set_type_bindings(type_assign(A, B, _, D, E), TypeBindings,
+ type_assign(A, B, TypeBindings, D, E)).
+
+%-----------------------------------------------------------------------------%
+
+:- pred type_assign_set_typeclass_constraints(type_assign,
+ list(class_constraint), type_assign).
+:- mode type_assign_set_typeclass_constraints(in, in, out) is det.
+
+type_assign_set_typeclass_constraints(type_assign(A, B, C, _, E), Constraints,
+ type_assign(A, B, C, Constraints, E)).
+
+%-----------------------------------------------------------------------------%
+
+:- pred type_assign_set_constraint_proofs(type_assign,
+ map(class_constraint, constraint_proof), type_assign).
+:- mode type_assign_set_constraint_proofs(in, in, out) is det.
+
+type_assign_set_constraint_proofs(type_assign(A, B, C, D, _),
+ Proofs, type_assign(A, B, C, D, Proofs)).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -2911,17 +3486,18 @@
{ pred_info_arg_types(PredInfo, VarSet, Types0) },
{ strip_builtin_qualifiers_from_type_list(Types0, Types) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
+ { pred_info_get_class_context(PredInfo, ClassContext) },
{ pred_info_get_purity(PredInfo, Purity) },
{ MaybeDet = no },
prog_out__write_context(Context),
io__write_string("Inferred "),
( { PredOrFunc = predicate },
mercury_output_pred_type(VarSet, Name, Types, MaybeDet,
- Purity, Context)
+ Purity, ClassContext, Context)
; { PredOrFunc = function },
{ pred_args_to_func_args(Types, ArgTypes, RetType) },
mercury_output_func_type(VarSet, Name, ArgTypes,
- RetType, MaybeDet, Purity, Context)
+ RetType, MaybeDet, Purity, ClassContext, Context)
).
%-----------------------------------------------------------------------------%
@@ -3156,7 +3732,7 @@
% arguments only for the arguments in which the two types differ.
(
{ ArgsTypeAssignSet = [SingleArgsTypeAssign] },
- { SingleArgsTypeAssign = TypeAssign - ConsArgTypes },
+ { SingleArgsTypeAssign = args(TypeAssign, ConsArgTypes, _) },
{ assoc_list__from_corresponding_lists(Args, ConsArgTypes,
ArgExpTypes) },
{ find_mismatched_args(ArgExpTypes, [TypeAssign], 1,
@@ -3166,7 +3742,7 @@
report_mismatched_args(Mismatches, yes, VarSet, Context)
;
- { conv_args_type_assign_set(ArgsTypeAssignSet,
+ { convert_args_type_assign_set(ArgsTypeAssignSet,
TypeAssignSet) },
%
@@ -3177,7 +3753,7 @@
(
% could the type of the functor be polymorphic?
{ list__member(ConsDefn, ConsDefnList) },
- { ConsDefn = cons_type_info(_, _, ConsArgTypes) },
+ { ConsDefn = cons_type_info(_, _, ConsArgTypes, _) },
{ ConsArgTypes \= [] }
->
% if so, print out the type of `Var'
@@ -3366,7 +3942,9 @@
io__state, io__state).
:- mode write_cons_type(in, in, in, di, uo) is det.
-write_cons_type(cons_type_info(TVarSet, ConsType0, ArgTypes0), Functor, _) -->
+ % XXX Should we mention the context here?
+write_cons_type(cons_type_info(TVarSet, ConsType0, ArgTypes0, _),
+ Functor, _) -->
{ strip_builtin_qualifier_from_cons_id(Functor, Functor1) },
{ strip_builtin_qualifiers_from_type_list(ArgTypes0, ArgTypes) },
( { ArgTypes \= [] } ->
@@ -3457,7 +4035,8 @@
:- mode write_args_type_assign_set(in, in, di, uo) is det.
write_args_type_assign_set([], _) --> [].
-write_args_type_assign_set([TypeAssign - _ArgTypes| TypeAssigns], VarSet) -->
+write_args_type_assign_set([args(TypeAssign, _ArgTypes, _Cnstrs)| TypeAssigns],
+ VarSet) -->
io__write_string("\t"),
write_type_assign(TypeAssign, VarSet),
io__write_string("\n"),
@@ -3929,7 +4508,7 @@
cons(Constructor, N),
_)),
ActualArities) },
- { ActualArities = [_|_] }
+ { ActualArities \= [] }
->
report_wrong_arity_constructor(Constructor, Arity,
ActualArities, Context)
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/unify_gen.m,v
retrieving revision 1.84
diff -u -r1.84 unify_gen.m
--- unify_gen.m 1997/12/05 15:47:56 1.84
+++ unify_gen.m 1997/12/09 06:37:37
@@ -202,6 +202,9 @@
unify_gen__generate_tag_rval_2(base_type_info_constant(_, _, _), _, _) :-
% This should never happen
error("Attempted base_type_info unification").
+unify_gen__generate_tag_rval_2(base_typeclass_info_constant(_, _, _), _, _) :-
+ % This should never happen
+ error("Attempted base_typeclass_info unification").
unify_gen__generate_tag_rval_2(no_tag, _Rval, TestRval) :-
TestRval = const(true).
unify_gen__generate_tag_rval_2(simple_tag(SimpleTag), Rval, TestRval) :-
@@ -296,11 +299,21 @@
( { Args = [] } ->
[]
;
- { error("unify_gen: address constant has args") }
+ { error("unify_gen: type-info constant has args") }
),
{ Code = empty },
code_info__cache_expression(Var, const(data_addr_const(data_addr(
ModuleName, base_type(info, TypeName, TypeArity))))).
+unify_gen__generate_construction_2(base_typeclass_info_constant(ModuleName,
+ ClassId, Instance), Var, Args, _Modes, Code) -->
+ ( { Args = [] } ->
+ []
+ ;
+ { error("unify_gen: typeclass-info constant has args") }
+ ),
+ { Code = empty },
+ code_info__cache_expression(Var, const(data_addr_const(data_addr(
+ ModuleName, base_typeclass_info(ClassId, Instance))))).
unify_gen__generate_construction_2(code_addr_constant(PredId, ProcId),
Var, Args, _Modes, Code) -->
( { Args = [] } ->
@@ -552,6 +565,9 @@
{ Code = empty }
;
{ Tag = base_type_info_constant(_, _, _) },
+ { Code = empty }
+ ;
+ { Tag = base_typeclass_info_constant(_, _, _) },
{ Code = empty }
;
{ Tag = no_tag },
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/unique_modes.m,v
retrieving revision 1.41
diff -u -r1.41 unique_modes.m
--- unique_modes.m 1997/11/24 23:10:27 1.41
+++ unique_modes.m 1997/12/17 02:10:29
@@ -367,6 +367,26 @@
mode_info_unset_call_context,
mode_checkpoint(exit, "higher-order call").
+unique_modes__check_goal_2(class_method_call(TCVar, Num, Args, Types, Modes,
+ Det), _GoalInfo0, Goal) -->
+ mode_checkpoint(enter, "class method call"),
+ % Setting the context to `higher_order_call(...)' is a little
+ % white lie. However, since there can't really be a unique
+ % mode error in a class_method_call, this lie will never be
+ % used. There can't be an error because the class_method_call
+ % is introduced by the compiler as the body of a class method.
+ mode_info_set_call_context(higher_order_call(predicate)),
+ { determinism_components(Det, _, at_most_zero) ->
+ NeverSucceeds = yes
+ ;
+ NeverSucceeds = no
+ },
+ { determinism_to_code_model(Det, CodeModel) },
+ unique_modes__check_call_modes(Args, Modes, CodeModel, NeverSucceeds),
+ { Goal = class_method_call(TCVar, Num, Args, Types, Modes, Det) },
+ mode_info_unset_call_context,
+ mode_checkpoint(exit, "class method call").
+
unique_modes__check_goal_2(call(PredId, ProcId, Args, Builtin, CallContext,
PredName), _GoalInfo0, Goal) -->
mode_checkpoint(enter, "call"),
Index: compiler/unused_args.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/unused_args.m,v
retrieving revision 1.37
diff -u -r1.37 unused_args.m
--- unused_args.m 1997/12/09 07:20:34 1.37
+++ unused_args.m 1997/12/19 01:15:59
@@ -291,7 +291,8 @@
% For example, if HeadVar1 has type list(T), then TypeInfo_for_T
% is used if HeadVar1 is used.
:- pred setup_typeinfo_deps(list(var)::in, map(var, type)::in, pred_proc_id::in,
- map(tvar, var)::in, var_dep::in, var_dep::out) is det.
+ map(tvar, type_info_locn)::in,
+ var_dep::in, var_dep::out) is det.
setup_typeinfo_deps([], _, _, _, VarDep, VarDep).
setup_typeinfo_deps([Var | Vars], VarTypeMap, PredProcId, TVarMap, VarDep0,
@@ -299,7 +300,11 @@
map__lookup(VarTypeMap, Var, Type),
type_util__vars(Type, TVars),
list__map(lambda([TVar::in, TypeInfoVar::out] is det,
- map__lookup(TVarMap, TVar, TypeInfoVar)), TVars, TypeInfoVars),
+ (
+ map__lookup(TVarMap, TVar, Locn),
+ type_info_locn_var(Locn, TypeInfoVar)
+ )),
+ TVars, TypeInfoVars),
AddArgDependency =
lambda([TVar::in, VarDepA::in, VarDepB::out] is det, (
add_arg_dep(VarDepA, TVar, PredProcId, Var, VarDepB)
@@ -434,6 +439,10 @@
traverse_goal(_, higher_order_call(PredVar,Args,_,_,_,_), UseInf0, UseInf) :-
set_list_vars_used(UseInf0, [PredVar|Args], UseInf).
+% we assume that class method calls use all variables involved
+traverse_goal(_, class_method_call(PredVar,_,Args,_,_,_), UseInf0, UseInf) :-
+ set_list_vars_used(UseInf0, [PredVar|Args], UseInf).
+
% handle pragma(c_code, ...) - pragma_c_code uses all its args
traverse_goal(_, pragma_c_code(_, _, _, _, Args, _, _, _), UseInf0, UseInf) :-
set_list_vars_used(UseInf0, Args, UseInf).
@@ -925,11 +934,13 @@
pred_info_clauses_info(PredInfo0, ClausesInfo),
pred_info_get_markers(PredInfo0, Markers),
pred_info_get_goal_type(PredInfo0, GoalType),
+ pred_info_get_class_context(PredInfo0, ClassContext),
+ map__init(EmptyProofs),
% *** This will need to be fixed when the condition
% field of the pred_info becomes used.
pred_info_init(PredModule, qualified(PredModule, Name), Arity, Tvars,
ArgTypes, true, Context, ClausesInfo, Status, Markers,
- GoalType, PredOrFunc, PredInfo1),
+ GoalType, PredOrFunc, ClassContext, EmptyProofs, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo).
@@ -1228,6 +1239,10 @@
fixup_goal_expr(_ModuleInfo, _UnusedVars, _ProcCallInfo, no,
GoalExpr - GoalInfo, GoalExpr - GoalInfo) :-
GoalExpr = higher_order_call(_, _, _, _, _, _).
+
+fixup_goal_expr(_ModuleInfo, _UnusedVars, _ProcCallInfo, no,
+ GoalExpr - GoalInfo, GoalExpr - GoalInfo) :-
+ GoalExpr = class_method_call(_, _, _, _, _, _).
fixup_goal_expr(_ModuleInfo, _UnusedVars, _ProcCallInfo, no,
GoalExpr - GoalInfo, GoalExpr - GoalInfo) :-
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.9
diff -u -r1.9 compiler_design.html
--- compiler_design.html 1997/12/09 04:02:08 1.9
+++ compiler_design.html 1997/12/09 06:38:07
@@ -97,9 +97,10 @@
definition is in prog_data.m, while the code to create it is in
prog_io.m and its submodules prog_io_dcg.m (which handles clauses
using Definite Clause Grammar notation), prog_io_goal.m (which handles
- goals), prog_io_pragma.m (which handles pragma declarations) and
- prog_io_util.m (which defines predicates and types needed by the other
- prog_io*.m modules. The data structure for insts is stored in
+ goals), prog_io_pragma.m (which handles pragma declarations),
+ prog_io_typeclass.m (which handles typeclass and instance declarations)
+ and prog_io_util.m (which defines predicates and types needed by the
+ other prog_io*.m modules. The data structure for insts is stored in
its own module, inst.m.
<p>
@@ -125,8 +126,9 @@
<br>
Notes on module qualification:
<ul>
- <li> all types, insts and modes occuring in pred, func, type and
- mode declarations are module qualified by module_qual.m.
+ <li> all types, typeclasses, insts and modes occuring in pred, func,
+ type, typeclass and mode declarations are module qualified by
+ module_qual.m.
<li> all types, insts and modes occuring in lambda expressions and
explicit type qualifications are module qualified in
make_hlds.m.
@@ -134,6 +136,8 @@
are module qualified during type checking.
<li> predicate and function calls and constructors within goals
are module qualified during mode analysis.
+ <li> predicate and function names in typeclass instance declarations
+ are qualified in check_typeclass.m (after mode analysis).
</ul>
@@ -203,10 +207,12 @@
pred_info. However, typecheck.m doesn't figure out the pred_id
for function calls or calls to overloaded predicates; that can't
be done in a single pass of typechecking, and so it is done
- later on in modes.m. When it has finished, typecheck.m calls
- clause_to_proc.m to make duplicate copies of the clauses for
- each different mode of a predicate; all later stages work on
- procedures, not predicates.
+ later on in modes.m. Typeclass constraints are checked here, and
+ any redundant constraints that are eliminated are recorded (as
+ constraint_proofs) in the pred_info for future reference. When it has
+ finished, typecheck.m calls clause_to_proc.m to make duplicate copies
+ of the clauses for each different mode of a predicate; all later
+ stages work on procedures, not predicates.
<li> type_util.m contains utility predicates dealing with types
that are used in a variety of different places within the compiler
</ul>
@@ -301,6 +307,18 @@
what modes.m does, and unique_modes calls lots of predicates
defined in modes.m to do it.
+<dt> checking typeclass instances (check_typeclass.m)
+ <dd>
+ check_typeclass.m checks that, each instance declaration, that the
+ types, modes and determinism of each predicate/function that is a
+ method of the class is correct (ie. that it matches the typeclass
+ declaration). In this pass, pred_ids and proc_ids are assigned to
+ the methods for each instance. In addition, while checking that the
+ superclasses of a class are satisfied by the instance declaration, a
+ set of constraint_proofs are built up for the superclass constraints.
+ These are used by polymorphism.m when generating the
+ base_typeclass_info for the instance.
+
<dt> simplification (simplify.m)
<dd>
@@ -326,8 +344,9 @@
The first two passes of this stage are code simplifications.
<ul>
-<li> introduction of type_info arguments for polymorphic predicates and
- transformation of complicated unifications into predicate calls
+<li> introduction of type_info arguments for polymorphic predicates,
+ introduction of typeclass_info arguments for typeclass-constrained predicates
+ and transformation of complicated unifications into predicate calls
(polymorphism.m)
<li> removal of lambda expressions (lambda.m) <br>
@@ -623,6 +642,10 @@
creates base_type_functors structures that give information on
the functors of a given type. The base_type_layout and base_type_functors
structures of each declared type constructor are added to the LLDS.
+<ul>
+<li> base_typeclass_info.m generates the base_typeclass_info structures that
+ list the methods of a class for each instance declaration. These are added to
+ the LLDS.
<li> stack_layout.m generates the stack_layout structures for
accurate garbage collection. Tables are created from the data
Index: compiler/notes/glossary.html
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/notes/glossary.html,v
retrieving revision 1.1
diff -u -r1.1 glossary.html
--- glossary.html 1997/04/03 05:17:38 1.1
+++ glossary.html 1997/11/26 04:55:57
@@ -15,6 +15,10 @@
<dl>
+<dt> class context
+ <dd>
+ The typeclass constraints on a predicate or function.
+
<dt> HLDS
<dd>
The "High Level Data Structure". See hlds.m.
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.87
diff -u -r1.87 mercury_builtin.m
--- mercury_builtin.m 1997/12/18 15:55:35 1.87
+++ mercury_builtin.m 1997/12/19 02:33:58
@@ -229,10 +229,36 @@
% they depend on the number of type parameters of the type represented
% by the type_info, and how many predicates we associate with each
% type.
+ %
+ % 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 type_info(T) ---> type_info(base_type_info(T) /*, ... */).
:- type base_type_info(T) ---> base_type_info(int /*, ... */).
+ % 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_info_from_typeclass_info(TypeClassInfo, Index, TypeInfo)
+ % extracts TypeInfo from TypeClassInfo, where TypeInfo is the Indexth
+ % type_info in the typeclass_info
+ %
+ % 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)).
+:- 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).
+:- mode superclass_from_typeclass_info(in, in, out) is det.
+
% the builtin < operator on ints, used in the code generated
% for compare/3 preds
:- pred builtin_int_lt(int, int).
@@ -252,6 +278,19 @@
% Many of the predicates defined in this module are builtin -
% the compiler generates code for them inline.
+
+:- pragma c_code(type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
+ TypeInfo::out), will_not_call_mercury,
+"
+ TypeInfo = MR_typeclass_info_type_info(TypeClassInfo, Index);
+").
+
+:- pragma c_code(superclass_from_typeclass_info(TypeClassInfo0::in, Index::in,
+ TypeClassInfo::out), will_not_call_mercury,
+"
+ TypeClassInfo =
+ MR_typeclass_info_superclass_info(TypeClassInfo0, Index);
+").
%-----------------------------------------------------------------------------%
Index: library/ops.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/ops.m,v
retrieving revision 1.19
diff -u -r1.19 ops.m
--- ops.m 1997/12/09 04:02:27 1.19
+++ ops.m 1997/12/09 06:38:35
@@ -188,6 +188,7 @@
ops__op_table("import_type", before, fx, 1199). % Mercury extension (NYI)
ops__op_table("impure", before, fy, 800). % Mercury extension
ops__op_table("inst", before, fx, 1199). % Mercury extension
+ops__op_table("instance", before, fx, 1199). % Mercury extension
ops__op_table("is", after, xfx, 701). % ISO Prolog says prec 700
ops__op_table("lambda", before, fxy, 950). % Mercury extension
ops__op_table("mod", after, xfx, 400). % Standard ISO Prolog
@@ -203,6 +204,7 @@
ops__op_table("some", before, fxy, 950). % Mercury/NU-Prolog extension
ops__op_table("then", after, xfx, 1150). % Mercury/NU-Prolog extension
ops__op_table("type", before, fx, 1180). % Mercury extension
+ops__op_table("typeclass", before, fx, 1199). % Mercury extension
ops__op_table("use_adt", before, fx, 1199). % Mercury extension (NYI)
ops__op_table("use_cons", before, fx, 1199). % Mercury extension (NYI)
ops__op_table("use_module", before, fx, 1199). % Mercury extension (NYI)
Index: library/string.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/string.m,v
retrieving revision 1.97
diff -u -r1.97 string.m
--- string.m 1997/12/03 07:05:13 1.97
+++ string.m 1997/12/09 06:38:38
@@ -20,7 +20,7 @@
:- import_module list, char.
:- pred string__length(string, int).
-:- mode string__length(in, out) is det.
+:- mode string__length(in, uo) is det.
% Determine the length of a string.
% An empty string has length zero.
@@ -1647,7 +1647,7 @@
:- pred string__length(string, int).
:- mode string__length(in, out) is det.
*/
-:- pragma(c_code, string__length(Str::in, Length::out), "
+:- pragma(c_code, string__length(Str::in, Length::uo), "
Length = strlen(Str);
").
Index: runtime/mercury_ho_call.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_ho_call.c,v
retrieving revision 1.3
diff -u -r1.3 mercury_ho_call.c
--- mercury_ho_call.c 1997/12/03 07:26:16 1.3
+++ mercury_ho_call.c 1997/12/17 03:09:14
@@ -116,6 +116,10 @@
call((Code *) field(0, closure, 1), LABEL(det_closure_return),
LABEL(do_call_det_closure));
}
+ /*
+ ** This is used as a return label both by do_call_det_closure and
+ ** do_call_det_class_method
+ */
Define_label(det_closure_return);
{
int i, num_in_args, num_out_args;
@@ -188,6 +192,10 @@
call((Code *) field(0, closure, 1), LABEL(semidet_closure_return),
LABEL(do_call_semidet_closure));
}
+ /*
+ ** This is used as a return label both by do_call_semidet_closure and
+ ** do_call_semidet_class_method
+ */
Define_label(semidet_closure_return);
{
int i, num_in_args, num_out_args;
@@ -245,6 +253,10 @@
call((Code *) field(0, closure, 1), LABEL(nondet_closure_return),
LABEL(do_call_nondet_closure));
}
+ /*
+ ** This is used as a return label both by do_call_nondet_closure and
+ ** do_call_nondet_class_method
+ */
Define_label(nondet_closure_return);
{
int i, num_in_args, num_out_args;
@@ -264,6 +276,138 @@
#endif
succeed();
+}
+
+
+
+
+
+ /*
+ ** r1: the typeclass_info
+ ** r2: index of class method
+ ** r3: number of immediate input arguments
+ ** r4: number of output arguments
+ ** r5+:input args
+ */
+Define_entry(do_call_det_class_method);
+{
+ Code *destination;
+ int i, num_in_args, num_arg_typeclass_infos;
+
+ destination = MR_typeclass_info_class_method(r1, r2);
+ num_arg_typeclass_infos = (int) MR_typeclass_info_instance_arity(r1);
+
+ num_in_args = r3; /* number of input args */
+
+ push(r4); /* The number of output args to unpack */
+ push(num_in_args); /* The number of input args */
+ push(succip);
+
+ save_registers();
+
+ if (num_arg_typeclass_infos < 4) {
+ /* copy to the left, from the left */
+ for (i = 1; i <= num_in_args; i++) {
+ virtual_reg(i+num_arg_typeclass_infos) =
+ virtual_reg(i+4);
+ }
+ } else if (num_arg_typeclass_infos > 4) {
+ /* copy to the right, from the right */
+ for (i = num_in_args; i > 0; i--) {
+ virtual_reg(i+num_arg_typeclass_infos) =
+ virtual_reg(i+4);
+ }
+ } /* else do nothing because num_arg_typeclass_infos == 4 */
+
+ for (i = num_arg_typeclass_infos; i > 0; i--) {
+ virtual_reg(i) =
+ MR_typeclass_info_arg_typeclass_info(virtual_reg(1),i);
+ }
+
+ restore_registers();
+
+ call(destination, LABEL(det_closure_return),
+ LABEL(do_call_det_class_method));
+}
+
+Define_entry(do_call_semidet_class_method);
+{
+ Code *destination;
+ int i, num_in_args, num_arg_typeclass_infos;
+
+ destination = MR_typeclass_info_class_method(r1, r2);
+ num_arg_typeclass_infos = (int) MR_typeclass_info_instance_arity(r1);
+
+ num_in_args = r3; /* number of input args */
+
+ push(r4); /* The number of output args to unpack */
+ push(num_in_args); /* The number of input args */
+ push(succip);
+
+ save_registers();
+
+ if (num_arg_typeclass_infos < 4) {
+ /* copy to the left, from the left */
+ for (i = 1; i <= num_in_args; i++) {
+ virtual_reg(i) = virtual_reg(i+4);
+ }
+ } else if (num_arg_typeclass_infos > 4) {
+ /* copy to the right, from the right */
+ for (i = num_in_args; i > 0; i--) {
+ virtual_reg(i+num_arg_typeclass_infos) =
+ virtual_reg(i+4);
+ }
+ } /* else do nothing because num_arg_typeclass_infos == 4 */
+
+ for (i = num_arg_typeclass_infos; i > 0; i--) {
+ virtual_reg(i) =
+ MR_typeclass_info_arg_typeclass_info(virtual_reg(1),i);
+ }
+
+ restore_registers();
+
+ call(destination, LABEL(semidet_closure_return),
+ LABEL(do_call_semidet_class_method));
+}
+
+Define_entry(do_call_nondet_class_method);
+{
+ Code *destination;
+ int i, num_in_args, num_arg_typeclass_infos;
+
+ destination = MR_typeclass_info_class_method(r1, r2);
+ num_arg_typeclass_infos = (int) MR_typeclass_info_instance_arity(r1);
+
+ num_in_args = r3; /* number of input args */
+
+ mkframe("do_call_nondet_class_method", 2, ENTRY(do_fail));
+ framevar(0) = r4; /* The number of output args to unpack */
+ framevar(1) = num_in_args; /* The number of input args */
+
+ save_registers();
+
+ if (num_arg_typeclass_infos < 4) {
+ /* copy to the left, from the left */
+ for (i = 1; i <= num_in_args; i++) {
+ virtual_reg(i) = virtual_reg(i+4);
+ }
+ } else if (num_arg_typeclass_infos > 4) {
+ /* copy to the right, from the right */
+ for (i = num_in_args; i > 0; i--) {
+ virtual_reg(i+num_arg_typeclass_infos) =
+ virtual_reg(i+4);
+ }
+ } /* else do nothing because num_arg_typeclass_infos == 4 */
+
+ for (i = num_arg_typeclass_infos; i > 0; i--) {
+ virtual_reg(i) =
+ MR_typeclass_info_arg_typeclass_info(virtual_reg(1),i);
+ }
+
+ restore_registers();
+
+ call(destination, LABEL(nondet_closure_return),
+ LABEL(do_call_nondet_class_method));
}
/*
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.2
diff -u -r1.2 mercury_type_info.h
--- mercury_type_info.h 1997/11/23 07:21:42 1.2
+++ mercury_type_info.h 1997/12/17 03:10:36
@@ -774,6 +774,30 @@
/*
** definitions for accessing the representation of the
+** Mercury typeclass_info
+*/
+
+#define MR_typeclass_info_instance_arity(tci) \
+ ((Integer)(*(Word **)(tci))[0])
+#define MR_typeclass_info_class_method(tci, n) \
+ ((Code *)(*(Word **)tci)[(n)])
+#define MR_typeclass_info_arg_typeclass_info(tci, n) \
+ (((Word *)(tci))[(n)])
+
+ /*
+ ** The following have the same definitions. This is because
+ ** the call to MR_typeclass_info_type_info must already have the
+ ** number of superclass_infos for the class added to it
+ */
+#define MR_typeclass_info_superclass_info(tci, n) \
+ (((Word *)(tci))[MR_typeclass_info_instance_arity(tci) + (n)])
+#define MR_typeclass_info_type_info(tci, n) \
+ (((Word *)(tci))[MR_typeclass_info_instance_arity(tci) + (n)])
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** definitions for accessing the representation of the
** Mercury `array' type
*/
love and cuddles,
dgj
--
David Jeffery (dgj at cs.mu.oz.au) | Marge: Did you just call everyone "chicken"?
MEngSc student, | Homer: Noooo. I swear on this Bible!
Department of Computer Science | Marge: That's not a Bible; that's a book of
University of Melbourne | carpet samples!
Australia | Homer: Ooooh... Fuzzy.
More information about the developers
mailing list